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 procedures implementations of the module [pm_arrayComplement](@ref pm_arrayComplement).
19 : !>
20 : !> \finmain
21 : !>
22 : !> \author
23 : !> \FatemehBagheri, Wednesday 5:03 PM, August 11, 2021, Dallas, TX
24 :
25 : !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
26 :
27 : !%%%%%%%%%%%%%%%%%%%
28 : #if getCompRange_ENABLED
29 : !%%%%%%%%%%%%%%%%%%%
30 :
31 : use pm_arrayRange, only: getRange
32 : integer(IKC) :: i, j
33 : integer(IKC) :: lenSetA
34 : integer(IKC) :: lenComplement
35 6635 : integer(IKC) :: complementTemp(max(0_IKC, 1_IKC + floor(real(stop - start) / real(step), kind = IKC)))
36 : #if Sorted_ENABLED
37 : integer(IKC) :: jstart
38 : #elif !Random_ENABLED
39 : #error "Unrecognized interface."
40 : #endif
41 6635 : CHECK_ASSERTION(__LINE__, step /= 0_IKC, SK_"@getCompRange(): The input `step` must be non-zero. step = "//getStr(step)) ! fpp
42 1325 : lenComplement = 0_IKC
43 6635 : lenSetA = size(setA, kind = IKC)
44 6635 : if (lenSetA > 0_IK) then
45 : #if Sorted_ENABLED
46 5206 : if (sorted) then
47 522 : jstart = 1_IKC
48 2606 : if (unique) then
49 1303 : if (step == 1_IKC .and. start <= setA(1) .and. setA(lenSetA) <= stop) then
50 16 : allocate(complement(abs(stop - start) + 1_IKC - lenSetA))
51 95 : loopOverSuperSetOrderedUnique: do i = start, stop, step
52 185 : loopOverSubSetOrderedUnique: do j = jstart, lenSetA
53 185 : if (i == setA(j)) then
54 50 : jstart = j + 1_IKC
55 50 : cycle loopOverSuperSetOrderedUnique
56 : end if
57 : end do loopOverSubSetOrderedUnique
58 35 : lenComplement = lenComplement + 1_IKC
59 45 : complement(lenComplement) = i
60 : end do loopOverSuperSetOrderedUnique
61 : else
62 3646 : loopOverRangeOrderedUnique: do i = start, stop, step
63 47664 : loopOverSetOrderedUnique: do j = jstart, lenSetA
64 47664 : if (i == setA(j)) then
65 987 : jstart = j + 1_IKC
66 987 : cycle loopOverRangeOrderedUnique
67 : end if
68 : end do loopOverSetOrderedUnique
69 1366 : lenComplement = lenComplement + 1_IKC
70 2659 : complementTemp(lenComplement) = i
71 : end do loopOverRangeOrderedUnique
72 3952 : complement = complementTemp(1:lenComplement)
73 : end if
74 : else
75 3697 : loopOverRangeOrdered: do i = start, stop, step
76 65557 : loopOverSetOrdered: do j = jstart, lenSetA
77 65557 : if (i == setA(j)) then
78 158 : jstart = j
79 : do
80 1380 : jstart = jstart + 1_IKC
81 1380 : if (jstart > lenSetA) then
82 17 : do jstart = i + step, stop, step
83 : !print *, i, step, i + step, jstart, i == step
84 : !print *, start, stop, step, size(setA), size(complementTemp), lenComplement
85 : !print *, complementTemp
86 : !print *, "setA"
87 : !print *, setA
88 : !print *, "setA"
89 25 : lenComplement = lenComplement + 1_IKC
90 36 : complementTemp(lenComplement) = jstart
91 : end do
92 : exit loopOverRangeOrdered
93 : end if
94 1363 : if (i /= setA(jstart)) cycle loopOverRangeOrdered
95 : end do
96 : cycle loopOverRangeOrdered
97 : end if
98 : end do loopOverSetOrdered
99 1373 : lenComplement = lenComplement + 1_IKC
100 3680 : complementTemp(lenComplement) = i
101 : end do loopOverRangeOrdered
102 4004 : complement = complementTemp(1:lenComplement)
103 : end if
104 : else
105 : #endif
106 11196 : loopOverRange: do i = start, stop, step
107 297684 : loopOverSet: do j = 1_IKC, lenSetA
108 297684 : if (i == setA(j)) then
109 : cycle loopOverRange
110 : end if
111 : end do loopOverSet
112 4185 : lenComplement = lenComplement + 1_IKC
113 11196 : complementTemp(lenComplement) = i
114 : end do loopOverRange
115 11993 : complement = complementTemp(1:lenComplement)
116 : #if Sorted_ENABLED
117 : end if
118 : #endif
119 : else
120 250 : complement = getRange(start, stop, step)
121 : end if
122 :
123 : !%%%%%%%%%%%%%%%%%%%%
124 : #elif getComplement_ENABLED
125 : !%%%%%%%%%%%%%%%%%%%%
126 :
127 : ! Define the equivalence checking method.
128 : #if DefCom_ENABLED && LK_ENABLED
129 : #define ISEQ(elementA,elementB) elementA .eqv. elementB
130 : #elif DefCom_ENABLED
131 : #define ISEQ(elementA,elementB) elementA == elementB
132 : #elif CusCom_ENABLED
133 : #define ISEQ(elementA, elementB) iseq(elementA, elementB)
134 : #else
135 : #error "Unrecognized interface."
136 : #endif
137 : ! Define temporary complement storage.
138 : #if SK_ENABLED && D0_ENABLED
139 : #define GET_INDEX(i) i:i
140 : #define GET_SIZE len
141 112 : character(len(setB,IK),SKC) :: complementTemp
142 : #elif D1_ENABLED
143 : #define GET_SIZE size
144 : #define GET_INDEX(i) i
145 : #if SK_ENABLED
146 : character(len(setB,IK),SKC) &
147 : #elif IK_ENABLED
148 : integer(IKC) &
149 : #elif LK_ENABLED
150 : logical(LKC) &
151 : #elif CK_ENABLED
152 : complex(CKC) &
153 : #elif RK_ENABLED
154 : real(RKC) &
155 : #else
156 : #error "Unrecognized interface."
157 : #endif
158 6058 : & :: complementTemp(size(setB))
159 : #else
160 : #error "Unrecognized interface."
161 : #endif
162 : integer(IK) :: lenComplement
163 : integer(IK) :: lenSetA
164 : integer(IK) :: lenSetB
165 : integer(IK) :: i, j
166 :
167 : ! Define the handling method of sorted vs. unsorted sets.
168 : #if Random_ENABLED
169 : integer(IK) , parameter :: jstart = 1_IK
170 : #define INCREMENT(jstart)
171 : #elif Sorted_ENABLED
172 : #define INCREMENT(jstart) jstart = j + 1_IK
173 : integer(IK) :: jstart
174 : jstart = 1_IK
175 1058 : if (sorted) then
176 537 : if (unique) then
177 : #else
178 : #error "Unrecognized interface."
179 : #endif
180 2331 : lenSetA = GET_SIZE(setA, kind = IK) ! fpp
181 : lenSetB = GET_SIZE(setB, kind = IK) ! fpp
182 : lenComplement = 0_IK
183 8295 : loopOverUniqueSetB: do i = 1_IK, lenSetB
184 107472 : loopOverUniqueSetA: do j = jstart, lenSetA
185 107472 : if (ISEQ(setA(GET_INDEX(j)), setB(GET_INDEX(i)))) then ! fpp
186 523 : INCREMENT(jstart) ! fpp
187 523 : cycle loopOverUniqueSetB
188 : end if
189 : end do loopOverUniqueSetA
190 2776 : lenComplement = lenComplement + 1_IK
191 7672 : complementTemp(GET_INDEX(lenComplement)) = setB(GET_INDEX(i))
192 : end do loopOverUniqueSetB
193 7266 : complement = complementTemp(1:lenComplement)
194 : #if Sorted_ENABLED
195 : else ! sorted but not unique.
196 289 : lenSetA = GET_SIZE(setA, kind = IK) ! fpp
197 : lenSetB = GET_SIZE(setB, kind = IK) ! fpp
198 : lenComplement = 0_IK
199 289 : if (lenSetB > 0_IK) then
200 1269 : loopOverSetB: do i = 1_IK, lenSetB
201 1643 : loopOverSetA: do j = jstart, lenSetA
202 1643 : if (ISEQ(setA(GET_INDEX(j)), setB(GET_INDEX(i)))) then ! fpp
203 634 : if (i < lenSetB) then
204 : ! go to the next element in setA only if the next element in setB is not the same as the current element in setB.
205 544 : if (.not. ISEQ(setB(GET_INDEX(i)), setB(GET_INDEX(i+1)))) INCREMENT(jstart) ! fpp
206 : else
207 90 : INCREMENT(jstart) ! fpp
208 : end if
209 : cycle loopOverSetB
210 : end if
211 : end do loopOverSetA
212 426 : lenComplement = lenComplement + 1_IK
213 635 : complementTemp(GET_INDEX(lenComplement)) = setB(GET_INDEX(i))
214 : end do loopOverSetB
215 : end if
216 933 : complement = complementTemp(1:lenComplement)
217 : end if
218 : else ! not sorted
219 : #if DefCom_ENABLED
220 847 : complement = getComplement(setA, setB)
221 : #elif CusCom_ENABLED
222 846 : complement = getComplement(setA, setB, iseq)
223 : #else
224 : #error "Unrecognized interface."
225 : #endif
226 : end if
227 : #endif
228 :
229 : #undef INCREMENT
230 : #undef GET_INDEX
231 : #undef GET_SIZE
232 : #undef ISEQ
233 :
234 : #else
235 : !%%%%%%%%%%%%%%%%%%%%%%%%
236 : #error "Unrecognized interface."
237 : !%%%%%%%%%%%%%%%%%%%%%%%%
238 : #endif
|
