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 implementations of the procedures in [pm_arrayUnique](@ref pm_arrayUnique).
19 : !>
20 : !> \finmain
21 : !>
22 : !> \author
23 : !> \AmirShahmoradi, September 1, 2017, 11:35 PM, Institute for Computational Engineering and Sciences (ICES), The University of Texas at Austin
24 :
25 : !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
26 :
27 : ! Define the equivalence checks.
28 : #if LK_ENABLED
29 : #define IS_NEQ .neqv.
30 : #define IS_EQ .eqv.
31 : #else
32 : #define IS_NEQ /=
33 : #define IS_EQ ==
34 : #endif
35 : ! Define the comparison operation.
36 : #if DefCom_ENABLED
37 : #define NOT_COMPARABLE(i, j) i IS_NEQ j
38 : #define COMPARABLE(i, j) i IS_EQ j
39 : #elif CusCom_ENABLED
40 : #define NOT_COMPARABLE(i, j) .not. iseq(i, j)
41 : #define COMPARABLE(i, j) iseq(i, j)
42 : #else
43 : #error "Unrecognized interface."
44 : #endif
45 : ! Define the indexing and length rules.
46 : #if SK_ENABLED && D0_ENABLED
47 : #define GET_INDEX(i) i:i
48 : #define GET_SIZE(x) len(x, kind = IK)
49 : #elif D1_ENABLED
50 : #define GET_INDEX(i) i
51 : #define GET_SIZE(x) size(x, kind = IK)
52 : #else
53 : #error "Unrecognized interface."
54 : #endif
55 : !%%%%%%%%%%%%%%%
56 : #if isUnique_ENABLED
57 : !%%%%%%%%%%%%%%%
58 :
59 : integer(IK) :: iarray, jarray, lenArray
60 : lenArray = GET_SIZE(array)
61 66580 : unique = .true._LK
62 55693 : loopOuter: do iarray = 1, lenArray - 1
63 55693 : if (unique(iarray)) then
64 154576 : loopInner: do jarray = iarray + 1, lenArray
65 154576 : if (COMPARABLE(array(GET_INDEX(iarray)), array(GET_INDEX(jarray)))) then
66 12385 : unique(iarray) = .false._LK
67 12385 : unique(jarray) = .false._LK
68 : end if
69 : end do loopInner
70 : end if
71 : end do loopOuter
72 :
73 : !%%%%%%%%%%%%%%%%%%
74 : #elif isUniqueAll_ENABLED
75 : !%%%%%%%%%%%%%%%%%%
76 :
77 : integer(IK) :: iarray, jarray, lenArray
78 7558 : lenArray = GET_SIZE(array)
79 : uniqueAll = .true._LK
80 18356 : loopOuter: do iarray = 1, lenArray - 1
81 52461 : loopInner: do jarray = iarray + 1, lenArray
82 35536 : if (NOT_COMPARABLE(array(GET_INDEX(iarray)), array(GET_INDEX(jarray)))) cycle loopInner
83 : uniqueAll = .false._LK
84 44903 : return
85 : end do loopInner
86 : end do loopOuter
87 :
88 : !%%%%%%%%%%%%%%%%%%
89 : #elif isUniqueAny_ENABLED
90 : !%%%%%%%%%%%%%%%%%%
91 :
92 : integer(IK) :: iarray, jarray, lenArray
93 4041 : lenArray = GET_SIZE(array)
94 : uniqueAny = .false._LK
95 8808 : loopOuter: do iarray = 1, lenArray
96 11756 : loopInner1: do jarray = 1, iarray - 1
97 11756 : if (COMPARABLE(array(GET_INDEX(iarray)), array(GET_INDEX(jarray)))) cycle loopOuter
98 : end do loopInner1
99 17491 : loopInner2: do jarray = iarray + 1, lenArray
100 17491 : if (COMPARABLE(array(GET_INDEX(iarray)), array(GET_INDEX(jarray)))) cycle loopOuter
101 : end do loopInner2
102 : uniqueAny = .true._LK
103 5774 : return
104 : end do loopOuter
105 :
106 : !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
107 : #elif getUnique_ENABLED || setUnique_ENABLED
108 : !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
109 :
110 : #if setUnique_ENABLED
111 : integer(IK) , allocatable :: countIndexSorted(:)
112 : integer(IK) :: counter
113 : #endif
114 : logical(LK) :: equivalent
115 : integer(IK) :: iarray, iuniq, lenArray
116 : #if !(setUnique_ENABLED && UniFix_ENABLED)
117 : integer(IK) :: lenUnique
118 204313 : allocate(unique, mold = array)
119 : #endif
120 101133 : lenArray = GET_SIZE(array) ! fpp
121 : #if setUnique_ENABLED && UniArb_ENABLED
122 1624 : allocate(count(lenArray))
123 : #elif !((setUnique_ENABLED && UniFix_ENABLED) || getUnique_ENABLED)
124 : #error "Unrecognized interface."
125 : #endif
126 1427 : lenUnique = 0_IK
127 699266 : loopOverArray: do iarray = 1_IK, lenArray
128 : equivalent = .false._LK
129 3115865 : loopOverUnique: do iuniq = 1_IK, lenUnique
130 5033 : equivalent = COMPARABLE(array(GET_INDEX(iarray)), unique(GET_INDEX(iuniq))) ! fpp
131 3115865 : if (equivalent) then
132 : #if setUnique_ENABLED
133 287495 : count(iuniq) = count(iuniq) + 1_IK
134 : #endif
135 287495 : exit loopOverUnique
136 : end if
137 : end do loopOverUnique
138 699266 : if (.not. equivalent) then
139 242899 : lenUnique = lenUnique + 1_IK
140 : #if setUnique_ENABLED && UniFix_ENABLED
141 8271 : CHECK_ASSERTION(__LINE__, lenUnique <= size(count, 1, IK), SK_"@setUnique(): The condition `lenUnique <= size(count)` must hold. lenUnique, size(count) = "//getStr([lenUnique, size(count, 1, IK)]))
142 8271 : CHECK_ASSERTION(__LINE__, lenUnique <= GET_SIZE(unique), SK_"@setUnique(): The condition `lenUnique <= len/size(count)` must hold. lenUnique, len/size(unique) = "//getStr([lenUnique, GET_SIZE(unique)]))
143 : #elif !((setUnique_ENABLED && UniArb_ENABLED) || getUnique_ENABLED)
144 : #error "Unrecognized interface."
145 : #endif
146 237316 : unique(GET_INDEX(lenUnique)) = array(GET_INDEX(iarray))
147 : #if setUnique_ENABLED
148 5947 : count(lenUnique) = 1_IK
149 : #endif
150 : end if
151 : end do loopOverArray
152 : #if setUnique_ENABLED
153 : #endif
154 : #if !(setUnique_ENABLED && UniFix_ENABLED)
155 683444 : unique = unique(1:lenUnique)
156 : #endif
157 : ! This section is relevant only to the subroutine interfaces, to compute the count and index of unique elements.
158 : #if setUnique_ENABLED
159 : #if UniArb_ENABLED
160 9628 : count = count(1:lenUnique)
161 : #endif
162 3051 : if (present(order)) then
163 2425 : if (order /= 0_IK) then
164 1617 : allocate(countIndexSorted(lenUnique))
165 1617 : call setSorted(count(1:lenUnique), countIndexSorted)
166 1617 : if (order > 0_IK) then
167 : #if UniArb_ENABLED
168 404 : call setRemapped(count , countIndexSorted)
169 404 : call setRemapped(unique , countIndexSorted)
170 : #elif UniFix_ENABLED
171 2364 : count(1:lenUnique) = count(countIndexSorted(1:lenUnique))
172 : #if D0_ENABLED && SK_ENABLED
173 20 : unique(1:lenUnique) = getRemapped(unique(1:lenUnique) , countIndexSorted)
174 : #elif D1_ENABLED
175 : ! \bug Intel ifort bug: `getRemapped()` cannot assign `unique(1:lenUnique)` correctly.
176 2256 : unique(1:lenUnique) = unique(countIndexSorted(1:lenUnique))
177 : #else
178 : #error "Unrecognized interface."
179 : #endif
180 : #endif
181 : else
182 : #if UniArb_ENABLED
183 405 : call setRemapped(count , countIndexSorted, action = reverse)
184 405 : call setRemapped(unique , countIndexSorted, action = reverse)
185 : #elif UniFix_ENABLED
186 2364 : count(1:lenUnique) = count(countIndexSorted(lenUnique:1:-1))
187 : #if D0_ENABLED && SK_ENABLED
188 20 : unique(1:lenUnique) = getRemapped(unique(1:lenUnique), countIndexSorted, action = reverse)
189 : #elif D1_ENABLED
190 : ! \bug Intel ifort bug: `getRemapped()` cannot assign `unique(1:lenUnique)` correctly.
191 2256 : unique(1:lenUnique) = unique(countIndexSorted(lenUnique:1:-1))
192 : #else
193 : #error "Unrecognized interface."
194 : #endif
195 : #endif
196 : end if
197 1617 : deallocate(countIndexSorted)
198 : end if
199 : end if
200 :
201 3051 : if (present(index)) then
202 : #if UniArb_ENABLED
203 2411 : allocate(index(lenUnique))
204 : #elif UniFix_ENABLED
205 2424 : CHECK_ASSERTION(__LINE__, lenUnique <= size(index, 1, IK), SK_"@setUnique(): The condition `lenUnique <= size(index)` must hold. lenUnique, size(index) = "//getStr([lenUnique, size(index, 1, IK)]))
206 : #else
207 : #error "Unrecognized interface."
208 : #endif
209 4787 : loopOverUniqueForIndex: do iuniq = 1_IK, lenUnique
210 3166 : allocate(index(iuniq)%val(count(iuniq)))
211 : iarray = 0_IK
212 : counter = 1_IK
213 1621 : loopOverArrayForIndex: do
214 9000 : iarray = iarray + 1_IK
215 9000 : if (NOT_COMPARABLE(unique(GET_INDEX(iuniq)), array(GET_INDEX(iarray)))) cycle loopOverArrayForIndex ! fpp
216 3963 : index(iuniq)%val(counter) = iarray
217 3963 : counter = counter + 1_IK
218 3963 : if (counter > count(iuniq)) exit loopOverArrayForIndex
219 : end do loopOverArrayForIndex
220 : end do loopOverUniqueForIndex
221 : end if
222 : #endif
223 : #else
224 : !%%%%%%%%%%%%%%%%%%%%%%%%
225 : #error "Unrecognized interface."
226 : !%%%%%%%%%%%%%%%%%%%%%%%%
227 : #endif
228 : #undef NOT_COMPARABLE
229 : #undef COMPARABLE
230 : #undef GET_INDEX
231 : #undef GET_SIZE
232 : #undef IS_NEQ
233 : #undef IS_EQ
234 : #undef ALL
|
