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 in [pm_arraySplit](@ref pm_arraySplit).
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 vector vs. scalar array + sep and operations.
28 : #if D0_D0_ENABLED
29 : #define GET_SIZE len
30 : #define ALL(item) item
31 : #define GET_INDEX(i) i : i + sepLen - 1_IK
32 : #elif D1_D0_ENABLED
33 : #define GET_SIZE size
34 : #define ALL(item) all(item)
35 : #define GET_INDEX(i) i : i + sepLen - 1_IK
36 : #elif D1_D1_ENABLED
37 : #define GET_SIZE size
38 : #define ALL(item) all(item)
39 : #define GET_INDEX(i) i : i + sepLen - 1_IK
40 : #else
41 : #error "Unrecognized interface."
42 : #endif
43 : ! Define logical vs. normal equivalence operators.
44 : #if LK_ENABLED
45 : #define IS_EQUAL .eqv.
46 : #elif SK_ENABLED || IK_ENABLED || CK_ENABLED || RK_ENABLED
47 : #define IS_EQUAL ==
48 : #else
49 : #error "Unrecognized interface."
50 : #endif
51 :
52 : ! Define custom-comparison macro.
53 : #if CusCom_ENABLED && D1_D1_ENABLED
54 : #define ISEQ(Segment,sep) iseq(Segment, sep, sepLen)
55 : #elif CusCom_ENABLED && (D0_D0_ENABLED || D1_D0_ENABLED)
56 : #define ISEQ(segment,sep) iseq(segment, sep)
57 : #elif DefCom_ENABLED
58 : #define ISEQ(segment,sep) ALL(segment IS_EQUAL sep)
59 : #else
60 : #error "Unrecognized interface."
61 : #endif
62 :
63 : ! Define the scalar vs. array interface for container component assignment.
64 : #if Jagged_ENABLED && D1_D0_ENABLED
65 : #define GET_ARRAY(object) [object]
66 : #elif Jagged_ENABLED && (D0_D0_ENABLED || D1_D1_ENABLED)
67 : #define GET_ARRAY(object) object
68 : #elif !(Index_ENABLED || Fixed_ENABLED)
69 : #error "Unrecognized interface."
70 : #endif
71 : !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
72 : #if setSplit_ENABLED && Fixed_ENABLED && DefIns_ENABLED
73 : !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
74 :
75 : ! Define the return value when no splitting occurs.
76 :
77 : logical(LK) :: keep_def
78 : integer(IK) :: lenArray, i, iLast, offset
79 : #if D1_D0_ENABLED
80 : integer(IK), parameter :: sepLen = 1_IK
81 : #elif D0_D0_ENABLED || D1_D1_ENABLED
82 : integer(IK) :: sepLen
83 : sepLen = GET_SIZE(sep, kind = IK)
84 : #else
85 : #error "Unrecognized interface."
86 : #endif
87 : offset = 1_IK
88 : if (present(keep)) then
89 : if (keep) offset = sepLen
90 : end if
91 : lenArray = GET_SIZE(array, kind = IK)
92 : CHECK_ASSERTION(__LINE__, 1_IK < size(field, 1, IK), SK_"@setSplit(): The condition `1 < size(field)` must hold. shape(field) = "//getStr(shape(field, IK)))
93 : #if D0_D0_ENABLED || D1_D1_ENABLED
94 : if (sepLen == 0_IK) then
95 : nsplit = 1_IK
96 : field(1) = 1_IK
97 : field(2) = lenArray + 1_IK
98 : return
99 : end if
100 : #endif
101 : if (sepLen < lenArray) then
102 : i = 1_IK
103 : iLast = lenArray - sepLen + 1_IK
104 : if (present(keep)) then
105 : if (keep) then
106 : loopFindSplitStart1: do
107 : if (ISEQ(array(GET_INDEX(i)), sep)) then
108 : CHECK_ASSERTION(__LINE__, nsplit < size(field, 1, IK), SK_"@setSplit(): The condition `nsplit < size(field, 1)` must hold. shape(field) = "//getStr(shape(field, IK)))
109 : nsplit = nsplit + 1_IK
110 : field(nsplit) = i
111 : i = i + sepLen
112 : !if (nsplit == nsplitMax) exit loopFindSplitStart1
113 : else
114 : i = i + 1_IK
115 : end if
116 : if (i > iLast) exit loopFindSplitStart1
117 : end do loopFindSplitStart1
118 :
119 : return
120 : end if
121 : end if
122 : loopFindSepPos: do
123 : if (ISEQ(array(GET_INDEX(i)), sep)) then
124 : CHECK_ASSERTION(__LINE__, nsplit < size(field, 1, IK), SK_"@setSplit(): The condition `nsplit < size(field, 1)` must hold. shape(field) = "//getStr(shape(field, IK)))
125 : nsplit = nsplit + 1_IK
126 : field(nsplit) = i
127 : i = i + sepLen
128 : !if (nsplit == nsplitMax) exit loopFindSepPos
129 : else
130 : i = i + 1_IK
131 : end if
132 : if (i > iLast) exit loopFindSepPos
133 : end do loopFindSepPos
134 :
135 : ! Split array at all requested instances of sep.
136 :
137 : blockInstanceExists: if (nsplit > 0_IK) then
138 : if (present(keep)) then
139 : keep_def = keep
140 : else
141 : keep_def = .false._LK
142 : end if
143 : if (keep_def) then
144 : !lenArraySplit = nsplit + 1_IK
145 : allocate(field(2, 2 * nsplit + 1))
146 : splitCounter = 1_IK
147 : field(1, splitCounter) = 1_IK
148 : do i = 1_IK, nsplit
149 : field(2, splitCounter) = sepLoc(i) - 1_IK
150 : field(1, splitCounter + 1) = sepLoc(i)
151 : field(2, splitCounter + 1) = sepLoc(i) + sepLen - 1_IK
152 : splitCounter = splitCounter + 2_IK
153 : field(1, splitCounter) = sepLoc(i) + sepLen
154 : end do
155 : field(2, splitCounter) = lenArray
156 : else
157 : allocate(field(2, nsplit + 1))
158 : field(1, 1) = 1_IK
159 : do i = 1_IK, nsplit
160 : field(2, i) = sepLoc(i) - 1_IK
161 : field(1, i + 1) = sepLoc(i) + sepLen
162 : end do
163 : field(2, i) = lenArray
164 : end if
165 : else blockInstanceExists
166 : nsplit = 1_IK
167 : field(1) = 1_IK
168 : field(2) = lenArray + sepLen + 1_IK
169 : end if blockInstanceExists
170 : deallocate(sepLoc)
171 : elseif (lenArray == sepLen) then
172 : if (ALL(array IS_EQUAL sep)) then
173 : if (present(keep)) then
174 : if (keep) then
175 : nsplit = 3_IK
176 : field(2) = 1_IK
177 : field(3) = lenArray + 1_IK
178 : field(4) = lenArray + 1_IK
179 : return
180 : end if
181 : end if
182 : nsplit = 2_IK
183 : field(1) = 1_IK
184 : field(2) = 0_IK
185 : field(1) = lenArray
186 : field(2) = lenArray - 1_IK
187 : else
188 : RETURN_WHOLE_ARRAY
189 : end if
190 : else ! `array` is smaller than `sep`. Return whole `array`.
191 : nsplit = 1_IK
192 : field(1) = 1_IK
193 : field(2) = lenArray + 1_IK
194 : end if
195 :
196 : !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
197 : #elif setSplit_ENABLED && Fixed_ENABLED && CusIns_ENABLED
198 : !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
199 :
200 : !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
201 : #elif setSplit_ENABLED && (Index_ENABLED || Jagged_ENABLED)
202 : !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
203 :
204 : ! Define the return value when no splitting occurs.
205 : #if Jagged_ENABLED
206 : integer(IK) :: tokenStart
207 : #define RETURN_WHOLE_ARRAY \
208 : allocate(field(1)); field(1)%val = array
209 : #elif Index_ENABLED
210 : #define RETURN_WHOLE_ARRAY \
211 : allocate(field(2, 1)); field(1, 1) = 1_IK; field(2, 1) = GET_SIZE(array, kind = IK)
212 : #else
213 : #error "Unrecognized interface."
214 : #endif
215 :
216 : #if D0_D0_ENABLED || D1_D1_ENABLED
217 : integer(IK) :: sepLen
218 : #elif D1_D0_ENABLED
219 : integer(IK) , parameter :: sepLen = 1_IK
220 : #else
221 : #error "Unrecognized interface."
222 : #endif
223 :
224 : integer(IK) , allocatable :: sepLoc(:) ! sep Occurrence Position in the array.
225 : integer(IK) :: lenArray, i, iLast
226 : integer(IK) :: sepLocLen, sepLocLenMax
227 : !integer(IK) :: lenArraySplit
228 : logical(LK) :: keep_def
229 : integer(IK) :: splitCounter
230 :
231 : #if CusIns_ENABLED
232 : integer(IK) :: lenInstance, lenInstanceNew, instanceMax
233 : integer(IK) , allocatable :: instanceNew(:)
234 : logical(LK) :: sorted_def
235 : logical(LK) :: unique_def
236 :
237 103562 : lenInstance = size(instance, kind = IK)
238 103562 : if (lenInstance == 0_IK) then
239 16416 : RETURN_WHOLE_ARRAY
240 12212 : return
241 : end if
242 : #elif !DefIns_ENABLED
243 : #error "Unrecognized interface."
244 : #endif
245 :
246 : #if D0_D0_ENABLED || D1_D1_ENABLED
247 55246 : sepLen = GET_SIZE(sep, kind = IK)
248 55246 : if (sepLen == 0_IK) then
249 7788 : RETURN_WHOLE_ARRAY
250 3624 : return
251 : end if
252 : #endif
253 96970 : lenArray = GET_SIZE(array, kind = IK)
254 96970 : if (lenArray > sepLen) then
255 :
256 68834 : sepLocLenMax = lenArray / sepLen + 1_IK
257 : #if CusIns_ENABLED
258 218964 : instanceMax = maxval(instance)
259 218964 : if (minval(instance) > 0_IK .and. instanceMax < sepLocLenMax) sepLocLenMax = instanceMax
260 : #endif
261 : ! Find all requested instances of sep.
262 :
263 74974 : allocate(sepLoc(sepLocLenMax))
264 : i = 1_IK
265 : sepLocLen = 0_IK
266 39466 : iLast = lenArray - sepLen + 1_IK
267 : loopFindSepPos: do
268 504321 : if (ISEQ(array(GET_INDEX(i)), sep)) then
269 134567 : sepLocLen = sepLocLen + 1_IK
270 43667 : sepLoc(sepLocLen) = i
271 90900 : i = i + sepLen
272 : !if (sepLocLen == sepLocLenMax) exit loopFindSepPos
273 : else
274 306246 : i = i + 1_IK
275 : end if
276 440813 : if (i > iLast) exit loopFindSepPos
277 : end do loopFindSepPos
278 :
279 : ! Split array at all requested instances of sep.
280 :
281 74974 : blockInstanceExists: if (sepLocLen > 0_IK) then
282 : #if CusIns_ENABLED
283 : ! Convert all negative and positive instances to counts from the beginning within the possible range [1, sepLocLen].
284 : !lenInstance = size(instance, kind = IK) ! this is now moved up to quit if zero-length instance is encountered.
285 58586 : allocate(instanceNew(lenInstance))
286 : lenInstanceNew = 0_IK
287 : i = 0_IK
288 : ! This loop requires lenInstance to be at least 1,
289 : ! which is guaranteed by the condition after `lenInstance` definition in the above.
290 : do
291 134758 : i = i + 1_IK
292 134758 : if (instance(i) > 0_IK .and. instance(i) <= sepLocLen) then
293 54922 : lenInstanceNew = lenInstanceNew + 1_IK
294 54922 : instanceNew(lenInstanceNew) = instance(i)
295 79836 : elseif (instance(i) < 0_IK .and. instance(i) + sepLocLen + 1_IK > 0_IK) then
296 47628 : lenInstanceNew = lenInstanceNew + 1_IK
297 47628 : instanceNew(lenInstanceNew) = instance(i) + sepLocLen + 1_IK
298 : end if
299 134758 : if (i == lenInstance) exit
300 : end do
301 :
302 : sorted_def = .false._LK
303 58586 : if (present(sorted)) sorted_def = sorted
304 58586 : if (.not. sorted_def) call setSorted(instanceNew(1:lenInstanceNew))
305 :
306 : unique_def = .false._LK
307 58586 : if (present(unique)) unique_def = unique
308 37332 : if (unique_def) then
309 : sepLocLen = lenInstanceNew
310 : else
311 227080 : instanceNew = getUnique(instanceNew(1:lenInstanceNew))
312 44678 : sepLocLen = size(instanceNew, kind = IK)
313 : end if
314 :
315 58586 : if (sepLocLen == 0_IK) then ! instance is empty, return the input array, untouched.
316 9492 : RETURN_WHOLE_ARRAY
317 : ! The following deallocations are essential since gfortran, as of version 10.3, cannot automatically deallocate array upon return.
318 5124 : deallocate(instanceNew)
319 5124 : deallocate(sepLoc)
320 5124 : return
321 : end if
322 : #define INSTANCENEW(i) instanceNew(i)
323 : #else
324 : #define INSTANCENEW(i) i
325 : #endif
326 58811 : if (present(keep)) then
327 39060 : keep_def = keep
328 : else
329 : keep_def = .false._LK
330 : end if
331 39060 : if (keep_def) then
332 : !lenArraySplit = sepLocLen + 1_IK
333 : #if Jagged_ENABLED
334 19800 : allocate(field(2_IK * sepLocLen + 1_IK))
335 : tokenStart = 1_IK
336 : splitCounter = 1_IK
337 9592 : do i = 1_IK, sepLocLen
338 13832 : field(splitCounter)%val = array(tokenStart : sepLoc(INSTANCENEW(i)) - 1_IK)
339 17432 : field(splitCounter + 1)%val = GET_ARRAY(sep)
340 6072 : tokenStart = sepLoc(INSTANCENEW(i)) + sepLen
341 9592 : splitCounter = splitCounter + 2_IK
342 : end do
343 7600 : field(splitCounter)%val = array(tokenStart : lenArray)
344 : #elif Index_ENABLED
345 18834 : allocate(field(2, 2 * sepLocLen + 1))
346 : splitCounter = 1_IK
347 16020 : field(1, splitCounter) = 1_IK
348 43672 : do i = 1_IK, sepLocLen
349 27652 : field(2, splitCounter) = sepLoc(INSTANCENEW(i)) - 1_IK
350 27652 : field(1, splitCounter + 1) = sepLoc(INSTANCENEW(i))
351 27652 : field(2, splitCounter + 1) = sepLoc(INSTANCENEW(i)) + sepLen - 1_IK
352 27652 : splitCounter = splitCounter + 2_IK
353 43672 : field(1, splitCounter) = sepLoc(INSTANCENEW(i)) + sepLen
354 : end do
355 16020 : field(2, splitCounter) = lenArray
356 : #else
357 : #error "Unrecognized interface."
358 : #endif
359 : else
360 : !lenArraySplit = sepLocLen + 1_IK
361 : #if Jagged_ENABLED
362 31172 : allocate(field(sepLocLen + 1_IK))
363 : tokenStart = 1_IK
364 22624 : do i = 1, sepLocLen
365 31012 : field(i)%val = array(tokenStart : sepLoc(INSTANCENEW(i)) - 1)
366 22624 : tokenStart = sepLoc(INSTANCENEW(i)) + sepLen
367 : end do
368 15292 : field(i)%val = array(tokenStart : lenArray)
369 : #elif Index_ENABLED
370 37991 : allocate(field(2, sepLocLen + 1))
371 32139 : field(1, 1) = 1_IK
372 91044 : do i = 1_IK, sepLocLen
373 58905 : field(2, i) = sepLoc(INSTANCENEW(i)) - 1_IK
374 91044 : field(1, i + 1) = sepLoc(INSTANCENEW(i)) + sepLen
375 : end do
376 32139 : field(2, i) = lenArray
377 : #else
378 : #error "Unrecognized interface."
379 : #endif
380 : end if
381 : #if CusIns_ENABLED
382 53462 : deallocate(instanceNew) ! This is essential since gfortran, as of version 10.3, cannot automatically deallocate array upon return.
383 : #endif
384 : else blockInstanceExists
385 : !lenArraySplit = 1_IK
386 20407 : RETURN_WHOLE_ARRAY
387 : end if blockInstanceExists
388 :
389 69850 : deallocate(sepLoc)
390 :
391 21996 : elseif (lenArray == sepLen) then
392 :
393 : if (ALL(array IS_EQUAL sep) & ! LCOV_EXCL_LINE ! \warning ALL is a preprocessor macro.
394 : #if CusIns_ENABLED
395 : .and. any(abs(instance) == 1_IK) & ! LCOV_EXCL_LINE
396 : #endif
397 : ) then
398 5856 : if (present(keep)) then
399 3904 : if (keep) then
400 : !lenArraySplit = 2_IK
401 : #if Jagged_ENABLED
402 1408 : allocate(field(3))
403 352 : field(1)%val = array(1:0)
404 1152 : field(2)%val = array ! == [sep]
405 352 : field(3)%val = array(1:0)
406 : #elif Index_ENABLED
407 1600 : allocate(field(2,3))
408 1600 : field(1,1) = 1_IK
409 1600 : field(2,1) = 0_IK
410 1600 : field(1,2) = 1_IK
411 1600 : field(2,2) = lenArray
412 1600 : field(1,3) = lenArray
413 1600 : field(2,3) = lenArray - 1_IK
414 : #else
415 : #error "Unrecognized interface."
416 : #endif
417 1952 : return
418 : end if
419 : end if
420 : !lenArraySplit = 2_IK
421 : #if Jagged_ENABLED
422 2112 : allocate(field(2))
423 704 : field(1)%val = array(1:0)
424 704 : field(2)%val = array(1:0)
425 : #elif Index_ENABLED
426 3200 : allocate(field(2,2))
427 3200 : field(1, 1) = 1_IK
428 3200 : field(2, 1) = 0_IK
429 3200 : field(1, 2) = lenArray
430 3200 : field(2, 2) = lenArray - 1_IK
431 : #else
432 : #error "Unrecognized interface."
433 : #endif
434 : else
435 : !lenArraySplit = 1_IK
436 9080 : RETURN_WHOLE_ARRAY
437 : end if
438 :
439 : else ! array is smaller than sep
440 :
441 : !lenArraySplit = 1_IK
442 18496 : RETURN_WHOLE_ARRAY
443 :
444 : end if
445 :
446 : #else
447 : !%%%%%%%%%%%%%%%%%%%%%%%%
448 : #error "Unrecognized interface."
449 : !%%%%%%%%%%%%%%%%%%%%%%%%
450 : #endif
451 : #undef RETURN_WHOLE_ARRAY
452 : #undef INSTANCENEW
453 : #undef GET_ARRAY
454 : #undef GET_INDEX
455 : #undef GET_SIZE
456 : #undef IS_EQUAL
457 : #undef ISEQ
458 : #undef ALL
|
