Line data Source code
1 : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
2 : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
3 : !!!! !!!!
4 : !!!! ParaMonte: Parallel Monte Carlo and Machine Learning Library. !!!!
5 : !!!! !!!!
6 : !!!! Copyright (C) 2012-present, The Computational Data Science Lab !!!!
7 : !!!! !!!!
8 : !!!! This file is part of the ParaMonte library. !!!!
9 : !!!! !!!!
10 : !!!! LICENSE !!!!
11 : !!!! !!!!
12 : !!!! https://github.com/cdslaborg/paramonte/blob/main/LICENSE.md !!!!
13 : !!!! !!!!
14 : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
15 : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
16 :
17 : !> \brief
18 : !> This file contains the implementation details of the routines under the generic interfaces of [pm_arrayReplace](@ref pm_arrayReplace).
19 : !>
20 : !> \finmain
21 : !>
22 : !> \author
23 : !> \AmirShahmoradi, September 1, 2017, 12:00 AM, Institute for Computational Engineering and Sciences (ICES), The University of Texas at Austin
24 :
25 : !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
26 :
27 : ! Define logical vs. normal equivalence operators
28 : #if LK_ENABLED
29 : #define IS_EQUAL .eqv.
30 : #elif SK_ENABLED || IK_ENABLED || CK_ENABLED || RK_ENABLED
31 : #define IS_EQUAL ==
32 : #else
33 : #error "Unrecognized interface."
34 : #endif
35 : ! Define scalar vs. vector operations.
36 : !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
37 : #if D0_D0_D0_ENABLED && SK_ENABLED
38 : !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
39 : #define GET_SIZE len
40 : #define GET_INDEX(i) i : i + lenPattern - 1_IK
41 : #define D0_D0_D0_ENABLED 1
42 : #if CusCom_ENABLED
43 : #define ISEQ(segment, pattern) iseq(segment, pattern)
44 : #elif DefCom_ENABLED
45 : #define ISEQ(segment, pattern) segment == pattern
46 : #else
47 : #error "Unrecognized interface."
48 : #endif
49 : !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
50 : #elif D1_D0_D0_ENABLED || D1_D0_D1_ENABLED
51 : !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
52 : #define GET_SIZE size
53 : #define GET_INDEX(i) i
54 : #if CusCom_ENABLED
55 : #define ISEQ(segment, pattern) iseq(segment, pattern)
56 : #elif DefCom_ENABLED
57 : #define ISEQ(segment, pattern) segment IS_EQUAL pattern
58 : #else
59 : #error "Unrecognized interface."
60 : #endif
61 : !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
62 : #elif D1_D1_D0_ENABLED || D1_D1_D1_ENABLED
63 : !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
64 : #define GET_SIZE size
65 : #define GET_INDEX(i) i : i + lenPattern - 1_IK
66 : #if CusCom_ENABLED
67 : #define ISEQ(segment,pattern) iseq(segment, pattern, lenPattern)
68 : #elif DefCom_ENABLED
69 : #define ISEQ(segment,pattern) all(segment IS_EQUAL pattern)
70 : #else
71 : #error "Unrecognized interface."
72 : #endif
73 : #else
74 : !%%%%%%%%%%%%%%%%%%%%%%%%
75 : #error "Unrecognized interface."
76 : !%%%%%%%%%%%%%%%%%%%%%%%%
77 : #endif
78 : ! Define the temporary new array for cases where the result is to be returned in the input array.
79 : #if setReplaced_ENABLED && D0_D0_D0_ENABLED && SK_ENABLED
80 : character(:,SKC) , allocatable :: arrayNew
81 : #elif setReplaced_ENABLED && (D1_D0_D0_ENABLED || D1_D1_D0_ENABLED || D1_D0_D1_ENABLED || D1_D1_D1_ENABLED)
82 : #if SK_ENABLED
83 1486 : character(len(array,IK),SKC), allocatable :: arrayNew(:)
84 : #elif IK_ENABLED
85 : integer(IKC) , allocatable :: arrayNew(:)
86 : #elif LK_ENABLED
87 : logical(LKC) , allocatable :: arrayNew(:)
88 : #elif CK_ENABLED
89 : complex(CKC) , allocatable :: arrayNew(:)
90 : #elif RK_ENABLED
91 : real(RKC) , allocatable :: arrayNew(:)
92 : #else
93 : #error "Unrecognized interface."
94 : #endif
95 : #elif !getReplaced_ENABLED
96 : #error "Unrecognized interface."
97 : #endif
98 : ! Declare local variables.
99 : #if CusIns_ENABLED
100 : integer(IK) :: lenInstance, lenInstanceNew, maxInstance!, minInstance
101 : integer(IK) , allocatable :: instanceNew(:)
102 : logical(LK) :: sorted_def
103 : logical(LK) :: unique_def
104 : #endif
105 : integer(IK) , allocatable :: POP(:) ! pattern Occurrence Position in the array.
106 : integer(IK) :: lenArray, lenDiff, i, iLast
107 : integer(IK) :: lenArrayNew, newPOP, newPOPNext, lenPOP, lenPOPMax
108 : ! Declare the replacement length.
109 : #if D1_D0_D0_ENABLED || D1_D1_D0_ENABLED
110 : integer(IK) , parameter :: lenReplacement = 1_IK
111 : #elif D0_D0_D0_ENABLED || D1_D1_D1_ENABLED || D1_D0_D1_ENABLED
112 : #define lenReplacement_ENABLED 1
113 : integer(IK) :: lenReplacement
114 : #else
115 : #error "Unrecognized interface."
116 : #endif
117 : ! Declare the pattern length.
118 : #if D1_D0_D0_ENABLED || D1_D0_D1_ENABLED
119 : integer(IK) , parameter :: lenPattern = 1_IK
120 : #elif D0_D0_D0_ENABLED || D1_D1_D1_ENABLED || D1_D1_D0_ENABLED
121 : #define lenPattern_ENABLED 1
122 : integer(IK) :: lenPattern
123 : #else
124 : #error "Unrecognized interface."
125 : #endif
126 : ! Set the array offset.
127 : #if D0_D0_D0_ENABLED || getReplaced_ENABLED
128 : integer(IK) , parameter :: offset = 0_IK
129 : #elif setReplaced_ENABLED
130 : integer(IK) :: offset
131 28208 : offset = lbound(array,1,IK) - 1_IK
132 : #else
133 : #error "Unrecognized interface."
134 : #endif
135 : ! Set the replacement length.
136 : #if lenReplacement_ENABLED
137 73098 : lenReplacement = GET_SIZE(replacement, kind = IK) ! \warning GET_SIZE is a preprocessor macro.
138 : #endif
139 : ! Set the pattern length.
140 : #if lenPattern_ENABLED
141 73096 : lenPattern = GET_SIZE(pattern, kind = IK) ! \warning GET_SIZE is a preprocessor macro.
142 : #endif
143 103498 : lenArray = GET_SIZE(array, kind = IK) ! \warning GET_SIZE is a preprocessor macro.
144 : #if CusIns_ENABLED
145 92656 : lenInstance = size(instance, kind = IK)
146 92656 : if (lenInstance == 0_IK) then
147 : #if getReplaced_ENABLED
148 46098 : arrayNew = array
149 : #elif !setReplaced_ENABLED
150 : #error "Unrecognized Interface."
151 : #endif
152 10476 : return
153 : end if
154 : #endif
155 91402 : if (lenArray > lenPattern) then
156 53263 : blockFullEmptyPattern: if (lenPattern > 0_IK) then
157 57781 : lenPOPMax = lenArray / lenPattern + 1_IK
158 : #if CusIns_ENABLED
159 : !print *, "instance", instance
160 415212 : maxInstance = maxval(instance)
161 415212 : if (minval(instance) >= 0_IK .and. maxInstance < lenPOPMax) lenPOPMax = maxInstance
162 : #endif
163 : !print *, "array", array
164 : !print *, "pattern", pattern
165 : !print *, "lenArray, offset, lenPattern", lenArray, offset, lenPattern
166 : ! Find all requested instances of pattern.
167 65621 : allocate(POP(lenPOPMax))!, source = -huge(1_IK))
168 16812 : i = 1_IK + offset
169 : lenPOP = 0_IK
170 53097 : iLast = lenArray + offset - lenPattern + 1_IK
171 : loopFindPOP: do
172 : #if getReplaced_ENABLED && CusCom_ENABLED && CusIns_ENABLED && D1_D1_D1_ENABLED && RK_ENABLED
173 : !! \bug
174 : !! gfortran 11 cannot correctly pass the length of the input `array` argument to `iseq()`
175 : !! via an explicit interface (and so why `iseq()` interface remains implicit.
176 : !print *, array(GET_INDEX(i)), pattern
177 : !print *, size(array(GET_INDEX(i))), size(pattern)
178 : !print *, ISEQ(array(GET_INDEX(i)), pattern)
179 : #endif
180 503324 : if (ISEQ(array(GET_INDEX(i)), pattern)) then ! fpp
181 97965 : lenPOP = lenPOP + 1_IK
182 97965 : if (lenPOP > lenPOPMax) exit loopFindPOP ! This condition is crucial when `maxInstance < lenPOPMax`.
183 : !print *, "POP", POP
184 35828 : POP(lenPOP) = i
185 61754 : i = i + lenPattern
186 : else
187 371609 : i = i + 1_IK
188 : end if
189 469494 : if (i > iLast) exit loopFindPOP
190 : end do loopFindPOP
191 : else blockFullEmptyPattern
192 11366 : lenPOP = lenArray + 1_IK
193 : #if CusIns_ENABLED
194 62952 : maxInstance = maxval(instance)
195 62952 : if (minval(instance) >= 0_IK .and. maxInstance < lenPOP) lenPOP = maxInstance
196 : #endif
197 12754 : allocate(POP(lenPOP))
198 79916 : do i = 1, lenPOP
199 79916 : POP(i) = i + offset
200 : end do
201 : end if blockFullEmptyPattern
202 : ! Replace all requested instances of pattern.
203 78375 : blockInstanceExists: if (lenPOP > 0_IK) then
204 : #if CusIns_ENABLED
205 : ! Convert all negative and positive instances to counts from the beginning within the possible range [1, lenPOP].
206 : !lenInstance = size(instance, kind = IK) ! this is now moved up to quit if zero-length instance is encountered.
207 48035 : allocate(instanceNew(lenInstance))
208 : lenInstanceNew = 0_IK
209 : i = 0_IK
210 : ! This loop requires lenInstance to be at least 1, which is guaranteed by the condition after `lenInstance` definition in the above.
211 : do
212 279495 : i = i + 1_IK
213 279495 : if (instance(i) > 0_IK .and. instance(i) <= lenPOP) then
214 32558 : lenInstanceNew = lenInstanceNew + 1_IK
215 32558 : instanceNew(lenInstanceNew) = instance(i)
216 246937 : elseif (instance(i) < 0_IK .and. instance(i) + lenPOP + 1_IK > 0_IK) then
217 40026 : lenInstanceNew = lenInstanceNew + 1_IK
218 40026 : instanceNew(lenInstanceNew) = instance(i) + lenPOP + 1_IK
219 : end if
220 279495 : if (i == lenInstance) exit
221 : end do
222 : sorted_def = .false._LK
223 48035 : if (present(sorted)) sorted_def = sorted
224 48035 : if (.not. sorted_def) call setSorted(instanceNew(1:lenInstanceNew))
225 : unique_def = .false._LK
226 48035 : if (present(unique)) unique_def = unique
227 31882 : if (unique_def) then
228 : lenPOP = lenInstanceNew
229 : else
230 148996 : instanceNew = getUnique(instanceNew(1:lenInstanceNew))
231 32135 : lenPOP = size(instanceNew, kind = IK)
232 : end if
233 48035 : if (lenPOP == 0_IK) then ! instance is empty, return the input array, untouched.
234 : #if getReplaced_ENABLED
235 104765 : arrayNew = array
236 : #endif
237 : ! The following deallocations are essential since gfortran, as of version 10.3, cannot automatically deallocate array upon return.
238 : #if CusIns_ENABLED
239 17732 : deallocate(instanceNew)
240 : #endif
241 17732 : deallocate(POP)
242 17732 : return
243 : end if
244 : #define INSTANCENEW(i) instanceNew(i)
245 : #elif DefIns_ENABLED
246 : #define INSTANCENEW(i) i
247 : #else
248 : #error "Unrecognized Interface."
249 : #endif
250 31602 : lenDiff = lenReplacement - lenPattern
251 31602 : lenArrayNew = lenArray + lenPOP * lenDiff
252 : #if SK_ENABLED && D0_D0_D0_ENABLED
253 454 : allocate(character(lenArrayNew,SKC) :: arrayNew)
254 : !> \bug
255 : !> This string vector allocation must be separated from the following because of a bug in Intel ifort 2021.5.
256 : !> The bug is related to the separation of module interface from implementation.
257 : #elif SK_ENABLED && getReplaced_ENABLED && (D1_D0_D0_ENABLED || D1_D0_D1_ENABLED || D1_D1_D0_ENABLED || D1_D1_D1_ENABLED)
258 2192 : allocate(character(len(array,IK),SKC) :: arrayNew(1_IK + offset : lenArrayNew + offset))
259 : #else
260 38473 : allocate(arrayNew(1_IK + offset : lenArrayNew + offset))
261 : #endif
262 : !#if getReplacedDefComCusIns_D1_D0_D1_IK_ENABLED || getReplacedDefComCusIns_D1_D1_D1_IK_ENABLED
263 : !print *, "size(replacement)", size(replacement)
264 : !print *, "instanceNew", instanceNew
265 : !print *, "INSTANCENEW(1_IK)", INSTANCENEW(1_IK)
266 : !print *, "offset", offset
267 : !print *, "POP", POP
268 : !#endif
269 36317 : newPOP = POP(INSTANCENEW(1_IK))
270 93508 : arrayNew(1_IK + offset : POP(INSTANCENEW(1_IK)) - 1_IK) = array(1_IK + offset : POP(INSTANCENEW(1_IK)) - 1_IK)
271 86251 : do i = 1_IK, lenPOP - 1_IK
272 122846 : arrayNew(newPOP : newPOP + lenReplacement - 1_IK) = replacement
273 49934 : newPOPNext = POP(INSTANCENEW(i + 1_IK)) + i * lenDiff
274 106686 : arrayNew(newPOP + lenReplacement : newPOPNext - 1_IK) = array(POP(INSTANCENEW(i)) + lenPattern : POP(INSTANCENEW(i+1_IK)) - 1_IK)
275 36317 : newPOP = newPOPNext
276 : end do
277 104559 : arrayNew(newPOP : newPOP + lenReplacement - 1_IK) = replacement
278 93724 : arrayNew(newPOP + lenReplacement : lenArrayNew + offset) = array(POP(INSTANCENEW(i)) + lenPattern : lenArray + offset)
279 : #if CusIns_ENABLED
280 22279 : deallocate(instanceNew) ! This is essential since gfortran, as of version 10.3, cannot automatically deallocate array upon return.
281 : #endif
282 : #if setReplaced_ENABLED
283 10066 : call move_alloc(from = arrayNew, to = array)
284 : #elif getReplaced_ENABLED
285 : else blockInstanceExists
286 150185 : arrayNew = array
287 : #else
288 : #error "Unrecognized interface."
289 : #endif
290 : end if blockInstanceExists
291 60643 : deallocate(POP)
292 13027 : elseif (lenArray == lenPattern) then
293 11382 : if (ISEQ(array(GET_INDEX(1_IK + offset)), pattern)) then
294 : #if CusIns_ENABLED
295 : ! \bug
296 : ! Bizarrely, if this condition is merged with the above, then both ifort and gfortran occasionally
297 : ! (but in different situations yield .true., even when expression is `.true. and .false.`.
298 9860 : if (any(abs(instance) == 1_IK)) then
299 : #endif
300 : #if setReplaced_ENABLED && D0_D0_D0_ENABLED && SK_ENABLED
301 24 : array = replacement
302 : #elif setReplaced_ENABLED
303 766 : deallocate(array)
304 2109 : allocate(array(1_IK + offset : lenReplacement + offset), source = replacement)
305 : #elif getReplaced_ENABLED
306 : #if D0_D0_D0_ENABLED && SK_ENABLED
307 28 : arrayNew = replacement
308 : #else
309 4146 : allocate(arrayNew(1_IK + offset : lenReplacement + offset), source = replacement)
310 : #endif
311 : #else
312 : #error "Unrecognized Interface."
313 : #endif
314 42 : return
315 : #if CusIns_ENABLED
316 : end if
317 : #endif
318 : end if
319 : #if getReplaced_ENABLED
320 17207 : arrayNew = array
321 : else ! array is smaller than pattern.
322 17361 : arrayNew = array
323 : #endif
324 : end if
325 : #undef lenReplacement_ENABLED
326 : #undef lenPattern_ENABLED
327 : #undef INSTANCENEW
328 : #undef GET_INDEX
329 : #undef GET_SIZE
330 : #undef IS_EQUAL
331 : #undef ISEQ
332 : #undef ANY
333 : #undef ALL
|
