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 procedure implementations of [pm_arraySort](@ref pm_arraySort).
19 : !>
20 : !> \finmain
21 : !>
22 : !> \author
23 : !> \AmirShahmoradi, April 21, 2017, 1:54 AM, Institute for Computational Engineering and Sciences (ICES), The University of Texas at Austin
24 :
25 : !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
26 :
27 : ! Define the custom comparison macro for recursive sorting.
28 : #if DefCom_ENABLED
29 : #define ISSORTED
30 : #elif CusCom_ENABLED
31 : #define ISSORTED , isSorted
32 : #else
33 : #error "Unrecognized interface."
34 : #endif
35 : ! Set the sorting rules.
36 : #if CusCom_ENABLED
37 : #define IS_SORTED(i,j) isSorted(i,j)
38 : #elif LK_ENABLED && DefCom_ENABLED
39 : #define IS_SORTED(i,j) j .and. .not. i
40 : #elif CK_ENABLED && DefCom_ENABLED
41 : #define IS_SORTED(i,j) i%re < j%re
42 : #elif (PSSK_ENABLED || BSSK_ENABLED) && DefCom_ENABLED
43 : #define IS_SORTED(i,j) i%val < j%val
44 : #elif (SK_ENABLED || IK_ENABLED || RK_ENABLED) && DefCom_ENABLED
45 : #define IS_SORTED(i,j) i < j
46 : #else
47 : #error "Unrecognized interface."
48 : #endif
49 : ! Set the indexing rules.
50 : #if D0_ENABLED && SK_ENABLED
51 : #define GET_INDEX(i) i:i
52 : #define GET_SIZE len
53 : #elif D1_ENABLED
54 : #define GET_INDEX(i) i
55 : #define GET_SIZE size
56 : #else
57 : #error "Unrecognized interface."
58 : #endif
59 : ! Set the types and kinds.
60 : #if SK_ENABLED && D0_ENABLED
61 : #define TYPE_KIND character(1,SKC)
62 : #elif SK_ENABLED && D1_ENABLED
63 : #define TYPE_KIND character(len(array,IK),SKC)
64 : #elif IK_ENABLED && D1_ENABLED
65 : #define TYPE_KIND integer(IKC)
66 : #elif LK_ENABLED && D1_ENABLED
67 : #define TYPE_KIND logical(LKC)
68 : #elif CK_ENABLED && D1_ENABLED
69 : #define TYPE_KIND complex(CKC)
70 : #elif RK_ENABLED && D1_ENABLED
71 : #define TYPE_KIND real(RKC)
72 : #elif PSSK_ENABLED && D1_ENABLED
73 : #define TYPE_KIND type(css_pdt(SKC))
74 : #elif BSSK_ENABLED && D1_ENABLED
75 : #define TYPE_KIND type(css_type)
76 : #else
77 : #error "Unrecognized interface."
78 : #endif
79 : ! Set the len type parameter for the string kind.
80 : #if SK_ENABLED
81 : #define TYPE_KIND_LEN(LEN) character(LEN,SKC)
82 : #else
83 : #define TYPE_KIND_LEN(LEN) TYPE_KIND
84 : #endif
85 :
86 : !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
87 : #if getSorted_ENABLED && Ind_ENABLED
88 : !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
89 :
90 : #if DefCom_ENABLED
91 6 : call setSorted(array, sorting)
92 : #elif CusCom_ENABLED
93 7 : call setSorted(array, sorting, isSorted)
94 : #else
95 : #error "Unrecognized interface."
96 : #endif
97 :
98 : !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
99 : #elif getSorted_ENABLED && Arr_ENABLED
100 : !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
101 :
102 : #if DefCom_ENABLED
103 : #define CALL_SETSORTED(METHOD) call setSorted(sorting, METHOD)
104 : #elif CusCom_ENABLED
105 : #define CALL_SETSORTED(METHOD) call setSorted(sorting, isSorted, METHOD)
106 : #else
107 : #error "Unrecognized interface."
108 : #endif
109 1305 : sorting = array
110 115 : blockMethod: if (present(method)) then
111 : select type (method)
112 : type is (qsorti_type)
113 : exit blockMethod
114 : type is (qsortr_type)
115 0 : CALL_SETSORTED(method)
116 : type is (qsortrdp_type)
117 0 : CALL_SETSORTED(method)
118 : type is (bubble_type)
119 0 : CALL_SETSORTED(method)
120 : type is (heapi_type)
121 0 : CALL_SETSORTED(method)
122 : type is (heapr_type)
123 0 : CALL_SETSORTED(method)
124 : type is (insertionl_type)
125 0 : CALL_SETSORTED(method)
126 : type is (insertionb_type)
127 0 : CALL_SETSORTED(method)
128 : type is (merger_type)
129 0 : CALL_SETSORTED(method)
130 : type is (selection_type)
131 0 : CALL_SETSORTED(method)
132 : type is (shell_type)
133 0 : CALL_SETSORTED(method)
134 : class default
135 0 : error stop MODULE_NAME//SK_"@getSorted(): Unrecognized `method`."
136 : end select
137 : return
138 : end if blockMethod
139 115 : CALL_SETSORTED(qsorti)
140 : #undef CALL_SETSORTED
141 :
142 : !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
143 : #elif setSorted_ENABLED && Ind_ENABLED && (Qsorti_ENABLED || Def_ENABLED)
144 : !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
145 :
146 11910 : TYPE_KIND :: temp
147 : integer(IK), parameter :: MIN_ARRAY_SIZE = 15_IK
148 : integer(IK) :: i, j, swapIndex, tempIndex, low, high, mid, stackCounter, stack(2_IK * bit_size(0_IK)) ! storage_size(0_IK)
149 135352 : high = GET_SIZE(array, kind = IK)
150 5188970 : do concurrent(j = 1 : high); index(j) = j; end do
151 406056 : CHECK_ASSERTION(__LINE__, high == size(index, 1, IK), SK_"@setSorted(): The condition `size(array) == size(index)` must hold. size(array), size(index) = "//getStr([high, size(index, 1, IK)])) ! fpp
152 : !if (high == 0_IK) return
153 : stackCounter = 0_IK
154 : low = 1_IK
155 : loopMain: do
156 1030264 : if (high - low < MIN_ARRAY_SIZE) then
157 4637402 : do j = low + 1_IK, high
158 4122270 : tempIndex = index(j)
159 324267 : temp = array(GET_INDEX(tempIndex))
160 12635345 : do i = j - 1_IK, low, -1_IK
161 12071831 : if (IS_SORTED(temp, array(GET_INDEX(index(i))))) then ! fpp
162 8513075 : index(i + 1_IK) = index(i)
163 : cycle
164 : end if
165 646210 : exit
166 : !if (array(GET_INDEX(index(i))) <= temp) exit ! fpp
167 : !index(i + 1_IK) = index(i)
168 : end do
169 4637402 : index(i + 1_IK) = tempIndex
170 : end do
171 515132 : if (stackCounter == 0_IK) exit loopMain
172 379780 : high = stack(stackCounter)
173 379780 : low = stack(stackCounter - 1_IK)
174 379780 : stackCounter = stackCounter - 2_IK
175 : else
176 379780 : mid = (low + high) / 2_IK
177 379780 : tempIndex = index(mid)
178 379780 : index(mid) = index(low + 1_IK)
179 379780 : index(low + 1_IK) = tempIndex
180 379780 : if (IS_SORTED(array(GET_INDEX(index(high))) , array(GET_INDEX(index(low))))) then ! fpp
181 62419 : swapIndex = index(low)
182 160206 : index(low) = index(high)
183 160206 : index(high) = swapIndex
184 : end if
185 379780 : if (IS_SORTED(array(GET_INDEX(index(high))) , array(GET_INDEX(index(low + 1_IK))))) then ! fpp
186 40255 : swapIndex = index(low + 1_IK)
187 103605 : index(low + 1_IK) = index(high)
188 103605 : index(high) = swapIndex
189 : end if
190 379780 : if (IS_SORTED(array(GET_INDEX(index(low + 1_IK))) , array(GET_INDEX(index(low))))) then ! fpp
191 40500 : swapIndex = index(low)
192 104055 : index(low) = index(low + 1_IK)
193 104055 : index(low + 1_IK) = swapIndex
194 : end if
195 : !call exchangeIndex(index(low),index(high))
196 : !call exchangeIndex(index(low + 1_IK),index(high))
197 : !call exchangeIndex(index(low),index(low + 1_IK))
198 : i = low + 1_IK
199 : j = high
200 379780 : tempIndex = index(low + 1_IK)
201 371468 : temp = array(GET_INDEX(tempIndex)) ! fpp
202 3522804 : do
203 : do
204 7664544 : i = i + 1_IK
205 : !if (temp <= array(GET_INDEX(index(i))) ) exit ! fpp
206 7664544 : if (IS_SORTED(array(GET_INDEX(index(i))) , temp ) ) cycle ! fpp
207 3653627 : exit
208 : end do
209 : do
210 7646673 : j = j - 1_IK
211 : !if (array(GET_INDEX(index(j))) <= temp) exit
212 7654985 : if (IS_SORTED(temp, array(GET_INDEX(index(j))))) cycle ! fpp
213 3641678 : exit
214 : end do
215 3902584 : if (j < i) exit
216 2223338 : swapIndex = index(i)
217 3522804 : index(i) = index(j)
218 3522804 : index(j) = swapIndex
219 : end do
220 379780 : index(low + 1_IK) = index(j)
221 379780 : index(j) = tempIndex
222 379780 : stackCounter = stackCounter + 2_IK
223 1139340 : CHECK_ASSERTION(__LINE__, size(stack, kind = IK) > stackCounter, SK_"@setSorted(): The stack size exceeded. This is highly unusual. size(stack), stackCounter = "//getStr([size(stack, kind = IK), stackCounter])) ! fpp
224 379780 : if (j - low <= high - i + 1_IK) then
225 211250 : stack(stackCounter) = high
226 211250 : stack(stackCounter - 1_IK) = i
227 211250 : high = j - 1_IK
228 : else
229 168530 : stack(stackCounter) = j - 1_IK
230 168530 : stack(stackCounter - 1_IK) = low
231 : low = i
232 : end if
233 : end if
234 : end do loopMain
235 : ! contains
236 : ! pure subroutine exchangeIndex(i,j)
237 : ! integer(IK), intent(inout) :: i,j
238 : ! integer(IK) :: swp
239 : ! if (array(GET_INDEX(j)) < array(GET_INDEX(i))) then
240 : ! swp = i
241 : ! i = j
242 : ! j = swp
243 : ! end if
244 : ! end subroutine
245 :
246 : !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
247 : #elif setSorted_ENABLED && Arr_ENABLED && (Qsorti_ENABLED || Def_ENABLED)
248 : !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
249 :
250 4872 : TYPE_KIND :: temp, pivot
251 : integer :: stackCounter
252 : integer(IK) :: i, j, left, right, low, high, mid
253 : integer(IK) :: stack(2_IK * bit_size(0_IK)) ! storage_size(i)
254 : #define UseSelection_ENABLED 1
255 : #if UseSelection_ENABLED
256 : integer(IK) :: k
257 : #endif
258 : low = 1_IK
259 186246 : high = GET_SIZE(array, kind = IK)
260 : stackCounter = 1_IK
261 : do
262 1720626 : if (high - low < 30_IK) then
263 : #if UseSelection_ENABLED
264 : ! use setSortedSelection on small Arrays. Works better than setSortedInsertion.
265 15567267 : loopSelectionSort: do i = low, high - 1_IK
266 : #if 1
267 658432 : temp = array(GET_INDEX(i))
268 : j = i
269 168053520 : do k = i + 1_IK, high ! minloc
270 168053520 : if (IS_SORTED(array(GET_INDEX(k)), temp)) then
271 13240342 : temp = array(GET_INDEX(k))
272 : j = k
273 : end if
274 : end do
275 : #else
276 : j = minloc(array(i:high), dim = 1, kind = IK) + i - 1_IK
277 : #endif
278 658432 : temp = array(GET_INDEX(i))
279 658432 : array(GET_INDEX(i)) = array(GET_INDEX(j))
280 15567267 : array(GET_INDEX(j)) = temp
281 : end do loopSelectionSort
282 : #else
283 : ! use setSortedInsertion on small Arrays.
284 : loopInsertionSort: do i = low + 1_IK, high
285 : temp = array(GET_INDEX(i))
286 : do j = i - 1_IK, low, -1_IK
287 : if (IS_SORTED(temp, array(GET_INDEX(j)))) then
288 : array(GET_INDEX(j + 1_IK)) = array(GET_INDEX(j))
289 : cycle
290 : end if
291 : exit
292 : end do
293 : array(GET_INDEX(j + 1_IK)) = temp
294 : end do loopInsertionSort
295 : #endif
296 : ! pop from stack.
297 953436 : if (stackCounter == 1) return
298 767190 : stackCounter = stackCounter - 2
299 767190 : high = stack(stackCounter+1)
300 767190 : low = stack(stackCounter)
301 767190 : cycle
302 : end if
303 : ! Find median of three pivot and place sentinels at first and last elements.
304 767190 : mid = (low + high) / 2_IK
305 767190 : left = low + 1_IK
306 35808 : temp = array(GET_INDEX(mid))
307 35808 : array(GET_INDEX(mid)) = array(GET_INDEX(left))
308 767190 : if (IS_SORTED(array(GET_INDEX(high)), temp)) then
309 18449 : array(GET_INDEX(left)) = array(GET_INDEX(high))
310 318920 : array(GET_INDEX(high)) = temp
311 : else
312 448270 : array(GET_INDEX(left)) = temp
313 : end if
314 767190 : if (IS_SORTED(array(GET_INDEX(high)) , array(GET_INDEX(low)))) then
315 11671 : temp = array(GET_INDEX(low))
316 11671 : array(GET_INDEX(low)) = array(GET_INDEX(high))
317 201982 : array(GET_INDEX(high)) = temp
318 : end if
319 767190 : if (IS_SORTED(array(GET_INDEX(left)) , array(GET_INDEX(low)))) then
320 22486 : temp = array(GET_INDEX(low))
321 22486 : array(GET_INDEX(low)) = array(GET_INDEX(left))
322 395830 : array(GET_INDEX(left)) = temp
323 : end if
324 35808 : pivot = array(GET_INDEX(left))
325 767190 : right = high - 1_IK
326 749545 : left = left + 1_IK
327 18123489 : do
328 18890679 : if (IS_SORTED(array(GET_INDEX(left)), pivot))then
329 : do
330 21889600 : left = left + 1_IK
331 21889600 : if (IS_SORTED(array(GET_INDEX(left)), pivot))cycle
332 14688533 : exit
333 : end do
334 : end if
335 18890679 : if (IS_SORTED(pivot , array(GET_INDEX(right)))) then
336 : do
337 22667125 : right = right - 1_IK
338 22684770 : if (IS_SORTED(pivot , array(GET_INDEX(right)))) cycle
339 15543365 : exit
340 : end do
341 : end if
342 18890679 : if (left >= right) exit
343 583810 : temp = array(GET_INDEX(left))
344 583810 : array(GET_INDEX(left)) = array(GET_INDEX(right))
345 583810 : array(GET_INDEX(right)) = temp
346 18123489 : right = right - 1_IK
347 18123489 : left = left + 1_IK
348 : end do
349 767190 : if (left == right) left = left + 1_IK
350 767190 : if (left < mid) then
351 301684 : stack(stackCounter) = left
352 301684 : stack(stackCounter + 1) = high
353 301684 : stackCounter = stackCounter + 2
354 301684 : high = left - 1_IK
355 : else
356 465506 : stack(stackCounter) = low
357 465506 : stack(stackCounter + 1) = left - 1_IK
358 0 : stackCounter = stackCounter + 2
359 : low = left
360 : end if
361 : end do
362 : #undef UseSelection_ENABLED
363 :
364 : !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
365 : #elif setSorted_ENABLED && Arr_ENABLED && Qsortr_ENABLED
366 : !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
367 :
368 16286 : TYPE_KIND :: temp, pivot
369 : integer(IK) :: i, j, left, lenArray
370 251797 : lenArray = GET_SIZE(array, kind = IK)
371 251797 : if(lenArray > 15_IK) then
372 : ! partition.
373 : i = 0_IK
374 8031 : pivot = array(GET_INDEX(1_IK))
375 110363 : j = GET_SIZE(array, kind = IK) + 1_IK
376 0 : do
377 1547867 : j = j - 1_IK
378 2205748 : do
379 3753615 : if (IS_SORTED(pivot, array(GET_INDEX(j)))) then
380 2205748 : j = j - 1_IK
381 : cycle
382 : end if
383 : exit
384 : end do
385 1547867 : i = i + 1_IK
386 1794340 : do
387 3355729 : if (IS_SORTED(array(GET_INDEX(i)), pivot)) then
388 1794340 : i = i + 1_IK
389 : cycle
390 : end if
391 : exit
392 : end do
393 1547867 : if (i < j) then ! exchange array(i) and array(j)
394 69792 : temp = array(GET_INDEX(i))
395 69792 : array(GET_INDEX(i)) = array(GET_INDEX(j))
396 1423982 : array(GET_INDEX(j)) = temp
397 123885 : elseif (i == j) then
398 22721 : left = i + 1_IK
399 22721 : exit
400 : else
401 : left = i
402 : exit
403 : endif
404 : end do
405 123885 : call setSorted(array(1 : left - 1_IK)ISSORTED, qsortr)
406 123885 : call setSorted(array(left : lenArray)ISSORTED, qsortr)
407 127912 : elseif (lenArray > 1_IK) then ! use insertion sort on small Arrays
408 989892 : do i = 2_IK, lenArray
409 50966 : temp = array(GET_INDEX(i))
410 2680645 : do j = i - 1_IK, 1_IK, -1_IK
411 2537920 : if (IS_SORTED(temp, array(GET_INDEX(j)))) then
412 1800620 : array(GET_INDEX(j + 1_IK)) = array(GET_INDEX(j))
413 : cycle
414 : end if
415 142725 : exit
416 : end do
417 989892 : array(GET_INDEX(j + 1_IK)) = temp
418 : end do
419 : endif
420 :
421 : !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
422 : #elif setSorted_ENABLED && Arr_ENABLED && Qsortrdp_ENABLED
423 : !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
424 :
425 11553 : TYPE_KIND :: temp, pivot1, pivot2
426 : integer(IK) :: i, j, last, l, k, g
427 269776 : last = GET_SIZE(array, kind = IK)
428 269776 : if (last < 15_IK) then ! use insertion sort on small Arrays
429 681979 : do i = 2_IK, last
430 39328 : temp = array(GET_INDEX(i))
431 1787703 : do j = i - 1_IK, 1_IK, -1_IK
432 1661212 : if (IS_SORTED(temp, array(GET_INDEX(j)))) then
433 1213839 : array(GET_INDEX(j + 1)) = array(GET_INDEX(j))
434 : cycle
435 : end if
436 126491 : exit
437 : end do
438 681979 : array(GET_INDEX(j + 1)) = temp
439 : end do
440 57116 : return
441 : end if
442 3954 : pivot1 = array(GET_INDEX(last / 3_IK))
443 3954 : pivot2 = array(GET_INDEX(2_IK * last / 3_IK))
444 161661 : if (IS_SORTED(pivot2, pivot1)) then
445 1982 : temp = pivot1
446 1982 : pivot1 = pivot2
447 14904 : pivot2 = temp
448 : end if
449 3954 : array(GET_INDEX(last / 3_IK)) = array(GET_INDEX(1_IK))
450 3954 : array(GET_INDEX(1_IK)) = pivot1
451 3954 : array(GET_INDEX(2_IK * last / 3_IK)) = array(GET_INDEX(last))
452 161661 : array(GET_INDEX(last)) = pivot2
453 : g = last
454 : l = 2_IK
455 213236 : do while (IS_SORTED(array(GET_INDEX(l)), pivot1))
456 169736 : l = l + 1_IK
457 : end do
458 : k = l
459 11833721 : do while(k < g)
460 147267 : temp = array(GET_INDEX(k))
461 11690784 : if (IS_SORTED(temp, pivot1)) then
462 54486 : array(GET_INDEX(k)) = array(GET_INDEX(l))
463 54486 : array(GET_INDEX(l)) = temp
464 782206 : l = l + 1_IK
465 10908578 : elseif (IS_SORTED(pivot2, temp)) then
466 1113234 : do while(IS_SORTED(pivot2, array(GET_INDEX(g - 1_IK))))
467 542665 : g = g - 1_IK
468 : end do
469 554716 : if (k >= g) exit
470 : g = g - 1_IK
471 535992 : if (IS_SORTED(array(GET_INDEX(g)), pivot1)) then
472 18340 : array(GET_INDEX(k)) = array(GET_INDEX(l))
473 18340 : array(GET_INDEX(l)) = array(GET_INDEX(g))
474 18340 : array(GET_INDEX(g)) = temp
475 249692 : l = l + 1_IK
476 : else
477 17354 : array(GET_INDEX(k)) = array(GET_INDEX(g))
478 286300 : array(GET_INDEX(g)) = temp
479 : end if
480 : end if
481 11690784 : k = k + 1_IK
482 : end do
483 161661 : if (l > 2_IK) then
484 3711 : array(GET_INDEX(1)) = array(GET_INDEX(l - 1_IK))
485 3711 : array(GET_INDEX(l - 1_IK)) = pivot1
486 52041 : call setSorted(array(1_IK : l - 2_IK)ISSORTED, qsortrdp) ! fpp
487 : end if
488 161661 : call setSorted(array(l : g - 1_IK)ISSORTED, qsortrdp) ! fpp
489 161661 : if (g < last) then
490 3670 : array(GET_INDEX(last)) = array(GET_INDEX(g))
491 3670 : array(GET_INDEX(g)) = pivot2
492 52030 : call setSorted(array(g + 1_IK : last)ISSORTED, qsortrdp) ! fpp
493 : end if
494 :
495 : !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
496 : #elif setSorted_ENABLED && Arr_ENABLED && Bubble_ENABLED
497 : !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
498 :
499 225 : TYPE_KIND :: temp
500 : integer(IK) :: i, j
501 1008480 : do i = GET_SIZE(array, kind = IK) - 1_IK, 1_IK, -1_IK
502 167730135 : do j = 1_IK, i
503 167726033 : if (IS_SORTED(array(GET_INDEX(j + 1_IK)), array(GET_INDEX(j)))) then
504 5060737 : temp = array(GET_INDEX(j + 1_IK))
505 5060737 : array(GET_INDEX(j + 1_IK)) = array(GET_INDEX(j))
506 72736728 : array(GET_INDEX(j)) = temp
507 : end if
508 : end do
509 : end do
510 :
511 : !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
512 : #elif setSorted_ENABLED && Arr_ENABLED && (Heapi_ENABLED || Heapr_ENABLED)
513 : !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
514 :
515 400 : TYPE_KIND :: temp
516 : integer(IK) :: i, last
517 8001 : last = GET_SIZE(array, kind = IK)
518 : ! Build heap
519 996411 : do i = last / 2_IK, 1_IK, -1_IK
520 996411 : call heapify(array, i)
521 : end do
522 : ! Unpick heap
523 1980876 : do i = last, 2_IK, -1_IK
524 95889 : temp = array(GET_INDEX(1))
525 95889 : array(GET_INDEX(1)) = array(GET_INDEX(i))
526 95889 : array(GET_INDEX(i)) = temp
527 1980876 : call heapify(array(1:i-1), 1_IK)
528 : end do
529 : contains
530 : #if DefCom_ENABLED
531 : pure &
532 : #endif
533 : #if Heapr_ENABLED
534 : recursive &
535 : #endif
536 8359274 : subroutine heapify(array, i)
537 : integer(IK), intent(in) :: i
538 : #if SK_ENABLED && D0_ENABLED
539 : character(*,SKC), intent(inout):: array
540 : #elif SK_ENABLED && D1_ENABLED
541 : character(*,SKC), intent(inout), contiguous :: array(:)
542 : #elif D1_ENABLED
543 : TYPE_KIND, intent(inout) :: array(:)
544 : #else
545 : #error "Unrecognized interface."
546 : #endif
547 446202 : TYPE_KIND :: temp
548 : integer(IK) :: left, right, root, last, largest
549 8359274 : last = GET_SIZE(array, kind = IK)
550 8359274 : root = i
551 6860164 : largest = root
552 8359274 : left = 2_IK * root
553 : #if Heapi_ENABLED
554 1499110 : temp = array(GET_INDEX(root))
555 6995793 : do while(left <= last)
556 6065011 : right = left + 1_IK
557 : if (left <= last) then
558 6065011 : if(IS_SORTED(array(GET_INDEX(largest)), array(GET_INDEX(left)))) largest = left
559 : end if
560 6065011 : if (right <= last) then
561 6040605 : if(IS_SORTED(array(GET_INDEX(largest)), array(GET_INDEX(right)))) largest = right
562 : end if
563 6065011 : if (largest == root) exit
564 5496683 : array(GET_INDEX(root)) = array(GET_INDEX(largest))
565 5496683 : array(GET_INDEX(largest)) = temp
566 : root = largest
567 6065011 : left = 2_IK * root
568 : end do
569 : #elif Heapr_ENABLED
570 6860164 : right = left + 1_IK
571 6860164 : if (left <= last) then
572 5942199 : if(IS_SORTED(array(GET_INDEX(largest)), array(GET_INDEX(left)))) largest = left
573 : end if
574 6860164 : if (right <= last) then
575 5918169 : if(IS_SORTED(array(GET_INDEX(largest)), array(GET_INDEX(right)))) largest = right
576 : end if
577 6860164 : if (largest /= root) then
578 5397989 : temp = array(GET_INDEX(root))
579 5397989 : array(GET_INDEX(root)) = array(GET_INDEX(largest))
580 5397989 : array(GET_INDEX(largest)) = temp
581 5397989 : call heapify(array, largest)
582 : end if
583 : #else
584 : #error "Unrecognized interface."
585 : #endif
586 8359274 : end subroutine
587 :
588 : !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
589 : #elif setSorted_ENABLED && Arr_ENABLED && Insertionl_ENABLED
590 : !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
591 :
592 54051 : TYPE_KIND :: temp
593 : integer(IK) :: i, pos
594 7339347 : do i = 2_IK, GET_SIZE(array, kind = IK)
595 315605 : temp = array(GET_INDEX(i))
596 : ! Do linear search
597 84984434 : do pos = i - 1_IK, 1_IK, -1_IK
598 84466608 : if (IS_SORTED(temp, array(GET_INDEX(pos)))) then
599 78710991 : array(GET_INDEX(pos + 1_IK)) = array(GET_INDEX(pos))
600 : cycle
601 : end if
602 517826 : exit
603 : end do
604 : ! Insert
605 7339347 : array(GET_INDEX(pos + 1_IK)) = temp
606 : end do
607 :
608 : !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
609 : #elif setSorted_ENABLED && Arr_ENABLED && Insertionb_ENABLED
610 : !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
611 :
612 192 : TYPE_KIND :: temp
613 : integer(IK) :: i, j, a, b, mid, pos
614 986968 : do i = 2_IK, GET_SIZE(array, kind = IK)
615 48547 : temp = array(GET_INDEX(i))
616 : ! Do binary search
617 : a = 1_IK
618 983012 : b = i - 1_IK
619 : loopBinarySearch: do
620 5536250 : if (a == b) then
621 584013 : if (IS_SORTED(temp, array(GET_INDEX(a)))) then
622 : pos = a
623 : else
624 299489 : pos = a + 1_IK
625 : end if
626 : exit loopBinarySearch
627 : end if
628 4952237 : if (a > b) then
629 : pos = a
630 : exit loopBinarySearch
631 : end if
632 4833893 : mid = (a + b) / 2_IK
633 4833893 : if (IS_SORTED(array(GET_INDEX(mid)), temp)) then
634 2402194 : a = mid + 1_IK
635 2431699 : elseif (IS_SORTED(temp, array(GET_INDEX(mid)))) then
636 2151044 : b = mid - 1_IK
637 : else
638 : pos = mid
639 : exit loopBinarySearch
640 : end if
641 : end do loopBinarySearch
642 83593913 : do j = i, pos + 1_IK, -1_IK
643 83593913 : array(GET_INDEX(j)) = array(GET_INDEX(j - 1_IK))
644 : end do
645 : ! Insert
646 986968 : array(GET_INDEX(pos)) = temp
647 : end do
648 :
649 : !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
650 : #elif setSorted_ENABLED && Arr_ENABLED && Merger_ENABLED
651 : !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
652 :
653 : #if SK_ENABLED && D0_ENABLED
654 10188 : character(len(array, kind = IK),SKC) :: temp
655 : #elif D1_ENABLED
656 179435 : TYPE_KIND :: temp(size(array, kind = IK))
657 : #else
658 : #error "Unrecognized interface."
659 : #endif
660 : integer(IK) :: last
661 : last = GET_SIZE(array, kind = IK)
662 194825 : if (last < 1_IK) return
663 189595 : if (last < 15_IK) then
664 96785 : call setSorted(array ISSORTED, insertionl)
665 96785 : return
666 : end if
667 92810 : call setSorted(array(1 : last / 2)ISSORTED, merger) ! fpp
668 92810 : call setSorted(array(last / 2 + 1 : last)ISSORTED, merger) ! fpp
669 92810 : call setMerged(temp, array(1 : last / 2), array(last / 2 + 1 : last)ISSORTED) ! fpp
670 4653552 : array = temp
671 :
672 : !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
673 : #elif setSorted_ENABLED && Arr_ENABLED && Selection_ENABLED
674 : !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
675 :
676 197 : TYPE_KIND :: temp
677 : integer(IK) :: i, j, k, lenArray
678 4095 : lenArray = GET_SIZE(array, kind = IK)
679 1010516 : do i = 1, lenArray - 1_IK
680 : ! minloc
681 51053 : temp = array(GET_INDEX(i))
682 : j = i
683 167861897 : do k = i + 1_IK, lenArray
684 167861897 : if (IS_SORTED(array(GET_INDEX(k)), temp)) then
685 2555907 : temp = array(GET_INDEX(k))
686 : j = k
687 : end if
688 : end do
689 : !j = minloc(array(i:), 1) + i - 1_IK
690 51053 : temp = array(GET_INDEX(i))
691 51053 : array(GET_INDEX(i)) = array(GET_INDEX(j))
692 1010516 : array(GET_INDEX(j)) = temp
693 : end do
694 :
695 : !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
696 : #elif setSorted_ENABLED && Arr_ENABLED && Shell_ENABLED
697 : !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
698 :
699 : #if SK_ENABLED && D0_ENABLED
700 212 : character(len(array, kind = IK),SKC) :: temp
701 : #elif D1_ENABLED
702 0 : TYPE_KIND :: temp(size(array, kind = IK))
703 : #else
704 : #error "Unrecognized interface."
705 : #endif
706 : integer(IK) :: i, j, counter, interval, lenArray, oneThirdLenArray
707 : interval = 1_IK
708 : lenArray = GET_SIZE(array, kind = IK)
709 4031 : oneThirdLenArray = lenArray / 3_IK
710 19651 : do while(interval < oneThirdLenArray)
711 19651 : interval = 3_IK * interval + 1_IK
712 : end do
713 23682 : do while(interval > 0_IK)
714 984794 : do i = 1_IK, interval
715 : ! copy array(i), array(i+interval), array(i+2*interval), ...
716 : counter = 0_IK
717 1241378 : do j = i, lenArray, interval
718 5359865 : counter = counter + 1_IK
719 5408811 : temp(GET_INDEX(counter)) = array(GET_INDEX(j))
720 : end do
721 965143 : call setSorted(temp(1:counter)ISSORTED, insertionl)
722 : counter = 0_IK
723 1261029 : do j = i, lenArray, interval
724 5359865 : counter = counter + 1_IK
725 5408811 : array(GET_INDEX(j)) = temp(GET_INDEX(counter))
726 : end do
727 : end do
728 19651 : interval = (interval - 1_IK) / 3_IK
729 : end do
730 :
731 : !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
732 : #elif isSorted_ENABLED || isAscending_ENABLED || isAscendingAll_ENABLED || isDescending_ENABLED || isDescendingAll_ENABLED
733 : !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
734 :
735 : ! Define the sorting component.
736 : #if PSSK_ENABLED || BSSK_ENABLED
737 : #define COMPONENT %val
738 : #elif CK_ENABLED
739 : #define COMPONENT %re
740 : #else
741 : #define COMPONENT
742 : #endif
743 : ! Define the comparison operator.
744 : #if DefCom_ENABLED && isAscending_ENABLED
745 : #define NOT_COMPARES_WITH >
746 : #define SORTED ascending
747 : #elif DefCom_ENABLED && isDescending_ENABLED
748 : #define NOT_COMPARES_WITH <
749 : #define SORTED descending
750 : #elif DefCom_ENABLED && isAscendingAll_ENABLED
751 : #define NOT_COMPARES_WITH >=
752 : #define SORTED ascendingAll
753 : #elif DefCom_ENABLED && isDescendingAll_ENABLED
754 : #define NOT_COMPARES_WITH <=
755 : #define SORTED descendingAll
756 : #elif !isSorted_ENABLED
757 : #error "Unrecognized interface."
758 : #endif
759 : ! Define the logical comparison operator.
760 : #if LK_ENABLED && isAscending_ENABLED
761 : use pm_logicalCompare, only: operator(>)
762 : #elif LK_ENABLED && isDescending_ENABLED
763 : use pm_logicalCompare, only: operator(<)
764 : #elif LK_ENABLED && isAscendingAll_ENABLED
765 : use pm_logicalCompare, only: operator(>=)
766 : #elif LK_ENABLED && isDescendingAll_ENABLED
767 : use pm_logicalCompare, only: operator(<=)
768 : #elif LK_ENABLED && DefCom_ENABLED && isSorted_ENABLED
769 : use pm_logicalCompare, only: operator(<=), operator(>=)
770 : #endif
771 : integer(IK) :: i
772 : #if DefCom_ENABLED && (isAscending_ENABLED || isAscendingAll_ENABLED || isDescending_ENABLED || isDescendingAll_ENABLED)
773 : SORTED = .false._LK
774 39735346 : do i = 1_IK, GET_SIZE(array, kind = IK) - 1_IK
775 39735346 : if (array(GET_INDEX(i))COMPONENT NOT_COMPARES_WITH array(GET_INDEX(i + 1))COMPONENT) return
776 : end do
777 : SORTED = .true._LK
778 : #elif DefCom_ENABLED && isSorted_ENABLED
779 : logical(LK) :: isAscending, isDescending
780 : sorted = .true._LK
781 : isAscending = .true._LK
782 : isDescending = .true._LK
783 60149 : do i = 1_IK, GET_SIZE(array, kind = IK) - 1_IK
784 60044 : isAscending = isAscending .and. array(GET_INDEX(i))COMPONENT <= array(GET_INDEX(i+1_IK))COMPONENT
785 60044 : isDescending = isDescending .and. array(GET_INDEX(i))COMPONENT >= array(GET_INDEX(i+1_IK))COMPONENT
786 60044 : sorted = isAscending .or. isDescending
787 60149 : if (.not. sorted) exit
788 : end do
789 : #elif CusCom_ENABLED && isSorted_ENABLED
790 : sorted = .true._LK
791 2470383 : do i = 1_IK, GET_SIZE(array, kind = IK) - 1_IK
792 2362465 : sorted = sorted .and. isSorted(array(GET_INDEX(i))COMPONENT, array(GET_INDEX(i+1_IK))COMPONENT)
793 107918 : if (.not. sorted) exit
794 : end do
795 : #else
796 : #error "Unrecognized interface."
797 : #endif
798 : #undef NOT_COMPARES_WITH
799 : #undef COMPONENT
800 : #undef SORTED
801 :
802 : #else
803 : !%%%%%%%%%%%%%%%%%%%%%%%%
804 : #error "Unrecognized interface."
805 : !%%%%%%%%%%%%%%%%%%%%%%%%
806 : #endif
807 : #undef TYPE_KIND_LEN
808 : #undef TYPE_KIND
809 : #undef IS_SORTED
810 : #undef GET_INDEX
811 : #undef GET_SIZE
812 : #undef ISSORTED
|
