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 include file contains the procedure implementation of Non-Recursive QuickSort selecting the smallest `rank`th value in the input array.
19 : !>
20 : !> \finmain
21 : !>
22 : !> \author
23 : !> \AmirShahmoradi
24 :
25 : !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
26 :
27 : ! Define the runtime debugging parameters.
28 : #if CHECK_ENABLED
29 : #if getSelected_ENABLED
30 : character(*,SK), parameter :: PROCEDURE_NAME = SK_"@getSelected"
31 : #elif setSelected_ENABLED
32 : character(*,SK), parameter :: PROCEDURE_NAME = SK_"@setSelected"
33 : #else
34 : #error "Unrecognized interface."
35 : #endif
36 : #endif
37 : ! Define the auxiliary variables.
38 : #if SK_ENABLED && D0_ENABLED
39 : character(1,SKC) :: pivot, temp
40 : #elif SK_ENABLED && D1_ENABLED
41 80 : character(len(array),SKC) :: pivot, temp
42 : #elif IK_ENABLED && D1_ENABLED
43 : integer(IKC) :: pivot, temp
44 : #elif LK_ENABLED && D1_ENABLED
45 : logical(LKC) :: pivot, temp
46 : #elif CK_ENABLED && D1_ENABLED
47 : complex(CKC) :: pivot, temp
48 : #elif RK_ENABLED && D1_ENABLED
49 : real(RKC) :: pivot, temp
50 : #elif PSSK_ENABLED && D1_ENABLED
51 : type(css_pdt(SKC)) :: pivot, temp
52 : #elif BSSK_ENABLED && D1_ENABLED
53 0 : type(css_type) :: pivot, temp
54 : #else
55 : #error "Unrecognized interface."
56 : #endif
57 : ! Define the auxiliary variables for the functional interface.
58 : #if getSelected_ENABLED
59 : #if SK_ENABLED && D0_ENABLED
60 42 : character(len(array),SKC) :: arrayCopy
61 : #elif SK_ENABLED && D1_ENABLED
62 40 : character(len(array),SKC) :: arrayCopy(size(array))
63 : #elif IK_ENABLED && D1_ENABLED
64 402 : integer(IKC) :: arrayCopy(size(array))
65 : #elif LK_ENABLED && D1_ENABLED
66 390 : logical(LKC) :: arrayCopy(size(array))
67 : #elif CK_ENABLED && D1_ENABLED
68 312 : complex(CKC) :: arrayCopy(size(array))
69 : #elif RK_ENABLED && D1_ENABLED
70 320 : real(RKC) :: arrayCopy(size(array))
71 : #elif PSSK_ENABLED && D1_ENABLED
72 : type(css_pdt(SKC)) :: arrayCopy(size(array))
73 : #elif BSSK_ENABLED && D1_ENABLED
74 154 : type(css_type) :: arrayCopy(size(array))
75 : #else
76 : #error "Unrecognized interface."
77 : #endif
78 : #elif !setSelected_ENABLED
79 : #error "Unrecognized interface."
80 : #endif
81 : ! Set the custom vs. default sorting criterion.
82 : #if CusCom_ENABLED
83 : #define IS_SORTED(i,j) isSorted(i,j)
84 : #elif DefCom_ENABLED && D1_ENABLED && (PSSK_ENABLED || BSSK_ENABLED)
85 : #define IS_SORTED(i,j) i%val < j%val
86 : #elif DefCom_ENABLED && D1_ENABLED && LK_ENABLED
87 : #define IS_SORTED(i,j) j .and. .not. i
88 : #elif DefCom_ENABLED && D1_ENABLED && CK_ENABLED
89 : #define IS_SORTED(i,j) i%re < j%re
90 : #elif DefCom_ENABLED
91 : #define IS_SORTED(i,j) i < j
92 : #else
93 : #error "Unrecognized interface."
94 : #endif
95 : ! Define the indexing rules.
96 : #if D0_ENABLED && SK_ENABLED
97 : #define GET_SIZE(array) len(array, kind = IK)
98 : #define GET_INDEX(i) i:i
99 : #elif D1_ENABLED && (SK_ENABLED || IK_ENABLED || LK_ENABLED || CK_ENABLED || RK_ENABLED || PSSK_ENABLED || BSSK_ENABLED)
100 : #define GET_SIZE(array) size(array, kind = IK)
101 : #define GET_INDEX(i) i
102 : #else
103 : #error "Unrecognized interface."
104 : #endif
105 : #if indexing_ENABLED
106 : integer(IK), allocatable :: arrayIndex(:)
107 : #define SELECTION index
108 : #endif
109 : integer(IK) :: mid, start, low, high, lenArray
110 896 : lenArray = GET_SIZE(array)
111 1691 : if (present(lb)) then
112 723 : low = lb
113 723 : CHECK_ASSERTION(__LINE__, 1_IK <= lb, PROCEDURE_NAME//SK_": The condition `1 <= lb` must hold. lb = "//getStr(lb))
114 : else
115 : low = 1_IK
116 : end if
117 1691 : if (present(ub)) then
118 722 : high = ub
119 2166 : CHECK_ASSERTION(__LINE__, ub <= lenArray, PROCEDURE_NAME//SK_": The condition `ub <= lenArray` must hold. ub, lenArray = "//getStr([ub, lenArray]))
120 : else
121 : high = lenArray
122 : end if
123 : ! This condition together with the previous ones also guarantees that the input array length is non-zero.
124 6764 : CHECK_ASSERTION(__LINE__, low <= rank .and. rank <= high, PROCEDURE_NAME//SK_": The condition `low <= rank .and. rank <= high` must hold. low, rank, high = "//getStr([low, rank, high]))
125 : #if indexing_ENABLED
126 : #define GET_VALUE(i) arrayIndex(i)
127 : #define PIVOT array(GET_INDEX(pivot))
128 : allocate(arrayIndex(low:high))
129 : do concurrent(mid = low:high)
130 : arrayIndex(mid) = mid
131 : end do
132 : #elif getSelected_ENABLED
133 : #define ARRAY arrayCopy
134 : #define GET_VALUE(i) ARRAY(GET_INDEX(i))
135 628076 : arrayCopy(low:high) = array(low:high)
136 : #elif setSelected_ENABLED
137 : #define GET_VALUE(i) ARRAY(GET_INDEX(i))
138 : #else
139 : #error "Unrecognized interface."
140 : #endif
141 : do
142 14599 : if (high - low <= 1_IK) then
143 1691 : if (high - low == 1_IK) then
144 571 : if (IS_SORTED(ARRAY(GET_INDEX(high)), ARRAY(GET_INDEX(low)))) then
145 7 : temp = GET_VALUE(low)
146 7 : GET_VALUE(low) = GET_VALUE(high)
147 119 : GET_VALUE(high) = temp
148 : end if
149 : end if
150 1367 : SELECTION = GET_VALUE(rank) ! \warning `SELECTION` is a preprocessor macro.
151 365 : return
152 : else
153 12908 : mid = (low + high) / 2_IK
154 618 : temp = GET_VALUE(mid)
155 618 : GET_VALUE(mid) = GET_VALUE(low+1_IK)
156 618 : GET_VALUE(low+1_IK) = temp
157 12908 : if (IS_SORTED(ARRAY(GET_INDEX(high)), ARRAY(GET_INDEX(low)))) then
158 159 : temp = GET_VALUE(low)
159 159 : GET_VALUE(low) = GET_VALUE(high)
160 2198 : GET_VALUE(high) = temp
161 : end if
162 12908 : if (IS_SORTED(ARRAY(GET_INDEX(high)), ARRAY(GET_INDEX(low+1_IK)))) then
163 67 : temp = GET_VALUE(low+1_IK)
164 67 : GET_VALUE(low+1_IK) = GET_VALUE(high)
165 1671 : GET_VALUE(high) = temp
166 : end if
167 12908 : if (IS_SORTED(ARRAY(GET_INDEX(low+1_IK)), ARRAY(GET_INDEX(low)))) then
168 76 : temp = GET_VALUE(low)
169 76 : GET_VALUE(low) = GET_VALUE(low+1_IK)
170 1456 : GET_VALUE(low+1_IK) = temp
171 : end if
172 : start = high
173 : mid = low + 1_IK
174 12908 : pivot = GET_VALUE(mid)
175 17 : do
176 : do
177 1333487 : mid = mid + 1_IK
178 1333487 : if (IS_SORTED(ARRAY(GET_INDEX(mid)), PIVOT)) cycle ! fpp
179 805244 : exit
180 : end do
181 : do
182 1400213 : start = start - 1_IK
183 1400213 : if (IS_SORTED( PIVOT, ARRAY(GET_INDEX(start)))) cycle
184 860599 : exit
185 : end do
186 496927 : if (start < mid) exit
187 12621 : temp = GET_VALUE(mid)
188 12621 : GET_VALUE(mid) = GET_VALUE(start)
189 485261 : GET_VALUE(start) = temp
190 : end do
191 618 : GET_VALUE(low + 1_IK) = GET_VALUE(start)
192 618 : GET_VALUE(start) = pivot
193 12908 : if (start >= rank) high = start - 1_IK
194 12908 : if (start <= rank) low = mid
195 : end if
196 : end do
197 : #undef indexing_ENABLED
198 : #undef SELECTION
199 : #undef GET_VALUE
200 : #undef GET_INDEX
201 : #undef IS_SORTED
202 : #undef GET_SIZE
203 : #undef PIVOT
204 : #undef ARRAY
|
