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 [pm_arrayRank](@ref pm_arrayRank).
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 : !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
28 : #if getRank_ENABLED && DefCom_ENABLED
29 : !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
30 :
31 : #if Dense_ENABLED
32 2079 : call setRankDense(rank, array)
33 : #elif Fractional_ENABLED
34 24252 : call setRankFractional(rank, array)
35 : #elif Modified_ENABLED
36 2067 : call setRankModified(rank, array)
37 : #elif Ordinal_ENABLED
38 2067 : call setRankOrdinal(rank, array)
39 : #elif Standard_ENABLED
40 2067 : call setRankStandard(rank, array)
41 : #else
42 : #error "Unrecognized interface."
43 : #endif
44 :
45 : !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
46 : #elif getRank_ENABLED && CusCom_ENABLED
47 : !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
48 :
49 : #if Dense_ENABLED
50 2064 : call setRankDense(rank, array, isSorted)
51 : #elif Fractional_ENABLED
52 2063 : call setRankFractional(rank, array, isSorted)
53 : #elif Modified_ENABLED
54 2064 : call setRankModified(rank, array, isSorted)
55 : #elif Ordinal_ENABLED
56 2064 : call setRankOrdinal(rank, array, isSorted)
57 : #elif Standard_ENABLED
58 2064 : call setRankStandard(rank, array, isSorted)
59 : #else
60 : #error "Unrecognized interface."
61 : #endif
62 :
63 : !%%%%%%%%%%%%%%
64 : #elif setRank_ENABLED
65 : !%%%%%%%%%%%%%%
66 :
67 : ! Define the sorting method.
68 : #if CusCom_ENABLED
69 : #define SET_SORTED_INDEX call setSorted(array, index, isSorted)
70 : #define IS_EQ(i,j) .not. (isSorted(i,j) .or. isSorted(j,i))
71 : #elif DefCom_ENABLED
72 : #define SET_SORTED_INDEX call setSorted(array, index)
73 : #if PSSK_ENABLED || BSSK_ENABLED
74 : #define IS_EQ(i,j) i%val == j%val
75 : #elif LK_ENABLED
76 : #define IS_EQ(i,j) j .eqv. i
77 : #elif CK_ENABLED
78 : #define IS_EQ(i,j) i%re == j%re
79 : #else
80 : #define IS_EQ(i,j) i == j
81 : #endif
82 : #else
83 : #error "Unrecognized interface."
84 : #endif
85 : ! Define the indexing method.
86 : #if SK_ENABLED && D0_ENABLED
87 : #define GET_INDEX(i) i:i
88 : #define GET_SIZE len
89 : #else
90 : #define GET_INDEX(i) i
91 : #define GET_SIZE size
92 : #endif
93 : ! Define the runtime check.
94 : #define CHECK_LEN_RANK \
95 : CHECK_ASSERTION(__LINE__, GET_SIZE(array, kind = IK) == size(rank, kind = IK), \
96 : SK_"@setRank(): The input `array` and `rank` must be of the same size: "// \
97 : getStr([GET_SIZE(array, kind = IK), size(rank, kind = IK)])) ! fpp
98 : ! perform ranking.
99 : #if Dense_ENABLED
100 : integer, parameter :: TKR = kind(rank)
101 : integer(TKR), parameter :: INCREMENT = +1_TKR, FIRST = +1_TKR
102 8274 : integer(TKR) :: index(size(rank, kind = IK))
103 : integer(TKR) :: i, last, current
104 24822 : CHECK_LEN_RANK
105 : last = size(rank, 1, IK)
106 8274 : if (size(rank, kind = IK) > 0_IK) then
107 8053 : SET_SORTED_INDEX ! fpp
108 : current = first
109 8053 : rank(index(current)) = current
110 105451 : loopTie: do
111 113504 : if (current == last) return
112 108868 : i = current + INCREMENT
113 : loopTieSegment: do
114 185433 : if (IS_EQ(array(GET_INDEX(index(current))), array(GET_INDEX(index(i))))) then
115 79982 : rank(index(i)) = rank(index(i - 1_TKR)) ! This is technically the same as `current`.
116 79982 : if (i < last) then
117 38474 : i = i + INCREMENT
118 : else ! happens only if there is a tied segment at the end.
119 38091 : return
120 : end if
121 : else
122 105451 : rank(index(i)) = rank(index(i - 1_TKR)) + 1_TKR
123 : current = i
124 : cycle loopTie
125 : end if
126 : end do loopTieSegment
127 : end do loopTie
128 : end if
129 : #elif Fractional_ENABLED
130 : integer , parameter :: TKR = kind(rank) ! Real Kind of rank.
131 : integer(IK) , parameter :: INCREMENT = +1_IK, FIRST = +1_IK
132 52692 : integer(IK) :: i, last, current, index(size(rank, kind = IK))
133 : real(TKR) :: sumRank
134 158076 : CHECK_LEN_RANK
135 : last = size(rank, 1, IK)
136 52692 : if (size(rank, kind = IK) > 0_IK) then
137 52464 : SET_SORTED_INDEX ! fpp
138 : current = first
139 52464 : rank(index(current)) = current
140 : sumRank = real(current, TKR)
141 906459 : loopTie: do
142 958923 : if (current == last) return
143 922297 : i = current + INCREMENT
144 : loopTieSegment: do
145 1250545 : if (IS_EQ(array(GET_INDEX(index(current))), array(GET_INDEX(index(i))))) then
146 344086 : sumRank = sumRank + real(i, TKR)
147 344086 : if (i < last) then
148 289416 : i = i + INCREMENT
149 : else ! happens only if there is a tied segment at the end.
150 77728 : rank(index(current : i)) = sumRank / real(i - current + 1_IK, TKR)
151 53264 : return
152 : end if
153 : else
154 2110952 : rank(index(current : i - 1_IK)) = sumRank / real(i - current, TKR)
155 906459 : rank(index(i)) = real(i, TKR)
156 : sumRank = real(i, TKR)
157 : current = i
158 : cycle loopTie
159 : end if
160 : end do loopTieSegment
161 : end do loopTie
162 : end if
163 : #elif Modified_ENABLED
164 : integer, parameter :: TKR = kind(rank)
165 : integer(TKR), parameter :: INCREMENT = -1_IK, LAST = +1_IK
166 8262 : integer(TKR) :: i, first, current, index(size(rank, kind = IK))
167 24786 : CHECK_LEN_RANK
168 : first = size(rank, 1, TKR)
169 8262 : if (size(rank, kind = IK) > 0_IK) then
170 8035 : SET_SORTED_INDEX ! fpp
171 : current = first
172 8035 : rank(index(current)) = current
173 104858 : loopTie: do
174 112893 : if (current == last) return
175 108282 : i = current + INCREMENT
176 : loopTieSegment: do
177 187017 : if (IS_EQ(array(GET_INDEX(index(current))), array(GET_INDEX(index(i))))) then
178 82159 : rank(index(i)) = current
179 82159 : if (i > last) then
180 38528 : i = i + INCREMENT
181 : else ! happens only if there is a tied segment at the end.
182 40207 : return
183 : end if
184 : else
185 104858 : rank(index(i)) = i
186 : current = i
187 : cycle loopTie
188 : end if
189 : end do loopTieSegment
190 : end do loopTie
191 : end if
192 : #elif Ordinal_ENABLED
193 : integer, parameter :: TKR = kind(rank)
194 16524 : integer(TKR) :: i, index(size(rank, kind = IK))
195 24786 : CHECK_LEN_RANK
196 8262 : SET_SORTED_INDEX ! fpp
197 : do concurrent(i = 1_TKR : size(rank, 1, TKR))
198 202003 : rank(index(i)) = i
199 : end do
200 : #elif Standard_ENABLED
201 : integer, parameter :: TKR = kind(rank)
202 : integer(TKR), parameter :: INCREMENT = +1_IK, FIRST = +1_IK
203 8262 : integer(TKR) :: current, i, last, index(size(rank, kind = IK))
204 24786 : CHECK_LEN_RANK
205 : last = size(rank, kind = TKR)
206 8262 : if (size(rank, kind = IK) > 0_IK) then
207 8053 : SET_SORTED_INDEX ! fpp
208 : current = first
209 8053 : rank(index(current)) = current
210 103371 : loopTie: do
211 111424 : if (current == last) return
212 106767 : i = current + INCREMENT
213 : loopTieSegment: do
214 184137 : if (IS_EQ(array(GET_INDEX(index(current))), array(GET_INDEX(index(i))))) then
215 80766 : rank(index(i)) = current
216 80766 : if (i < last) then
217 38570 : i = i + INCREMENT
218 : else ! happens only if there is a tied segment at the end.
219 38800 : return
220 : end if
221 : else
222 103371 : rank(index(i)) = i
223 : current = i
224 : cycle loopTie
225 : end if
226 : end do loopTieSegment
227 : end do loopTie
228 : end if
229 : #else
230 : #error "Unrecognized interface."
231 : #endif
232 :
233 : #else
234 : !%%%%%%%%%%%%%%%%%%%%%%%%
235 : #error "Unrecognized interface."
236 : !%%%%%%%%%%%%%%%%%%%%%%%%
237 : #endif
238 :
239 : #undef SET_SORTED_INDEX
240 : #undef GET_INDEX
241 : #undef GET_SIZE
242 : #undef IS_EQ
|
