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 implementation details of the routines under the generic interfaces in [pm_arrayRemove](@ref pm_arrayRemove).
19 : !>
20 : !> \finmain
21 : !>
22 : !> \author
23 : !> \AmirShahmoradi, September 1, 2017, 12:00 AM, Institute for Computational Engineering and Sciences (ICES), The University of Texas at Austin
24 :
25 : !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
26 :
27 : ! Define the temporary new array for cases where the result is to be returned in the input array.
28 : #if setRemoved_ENABLED
29 : #if SK_ENABLED && D0_D0_ENABLED
30 : character(:,SKC) , allocatable :: ArrayRemoved
31 : #elif SK_ENABLED && (D1_D0_ENABLED || D1_D1_ENABLED)
32 665 : character(len(array,IK),SKC), allocatable :: ArrayRemoved(:)
33 : #elif IK_ENABLED && (D1_D0_ENABLED || D1_D1_ENABLED)
34 : integer(IKC) , allocatable :: ArrayRemoved(:)
35 : #elif LK_ENABLED && (D1_D0_ENABLED || D1_D1_ENABLED)
36 : logical(LKC) , allocatable :: ArrayRemoved(:)
37 : #elif CK_ENABLED && (D1_D0_ENABLED || D1_D1_ENABLED)
38 : complex(CKC) , allocatable :: ArrayRemoved(:)
39 : #elif RK_ENABLED && (D1_D0_ENABLED || D1_D1_ENABLED)
40 : real(RKC) , allocatable :: ArrayRemoved(:)
41 : #else
42 : #error "Unrecognized interface."
43 : #endif
44 : #elif !getRemoved_ENABLED
45 : #error "Unrecognized interface."
46 : #endif
47 : ! Define logical vs. normal equivalence operators. This becomes relevant only when user-specified comparison function iseq() is missing.
48 : #if LK_ENABLED
49 : #define IS_EQUAL .eqv.
50 : #elif SK_ENABLED || IK_ENABLED || CK_ENABLED || RK_ENABLED
51 : #define IS_EQUAL ==
52 : #else
53 : #error "Unrecognized interface."
54 : #endif
55 : ! Determine assumed-length scalar character vs. array input arguments.
56 : #if D0_D0_ENABLED
57 : integer(IK) :: lenPattern
58 : #define GET_INDEX(i) i : i + lenPattern - 1_IK
59 : #define GET_SIZE len
60 : #if CusCom_ENABLED
61 : #define ISEQ(segment,pattern) iseq(segment,pattern)
62 : #else
63 : #define ISEQ(segment,pattern) segment == pattern
64 : #endif
65 : #elif D1_D1_ENABLED
66 : integer(IK) :: lenPattern
67 : #define GET_INDEX(i) i : i + lenPattern - 1_IK
68 : #define GET_SIZE size
69 : #if CusCom_ENABLED
70 : #define ISEQ(Segment,pattern) iseq(Segment, pattern, lenPattern)
71 : #else
72 : #define ISEQ(Segment,pattern) all(Segment IS_EQUAL pattern)
73 : #endif
74 : #elif D1_D0_ENABLED
75 : integer(IK), parameter :: lenPattern = 1_IK
76 : #define GET_INDEX(i) i
77 : #define GET_SIZE size
78 : #if CusCom_ENABLED
79 : #define ISEQ(segment,pattern) iseq(segment, pattern)
80 : #elif DefCom_ENABLED
81 : #define ISEQ(segment,pattern) segment IS_EQUAL pattern
82 : #else
83 : #error "Unrecognized interface."
84 : #endif
85 : #else
86 : #error "Unrecognized interface."
87 : #endif
88 : ! Set the array offset.
89 : #if D0_D0_ENABLED || getRemoved_ENABLED
90 : integer(IK) , parameter :: offset = 0_IK
91 : #else
92 : integer(IK) :: offset
93 : #endif
94 : ! This `lenArrayOld` serves as the array index offset, to be also used later.
95 : integer(IK) , allocatable :: DOP(:) ! pattern Occurrence Position in the array.
96 : integer(IK) :: lenArray, i, iLast
97 : integer(IK) :: lenDOP, lenDOPMax, tokenStart
98 : integer(IK) :: lenArrayOld, lenArrayRemoved, lenArrayCurrent
99 : #if CusIns_ENABLED
100 : integer(IK) :: lenInstance, lenInstanceNew, maxInstance
101 : integer(IK) , allocatable :: InstanceNew(:)
102 : logical(LK) :: sorted_def
103 : logical(LK) :: unique_def
104 24378 : lenInstance = size(instance, kind = IK)
105 24378 : if (lenInstance == 0_IK) then
106 : #if getRemoved_ENABLED
107 2772 : ArrayRemoved = array
108 : #endif
109 2924 : return
110 : end if
111 : #endif
112 : ! Set the non-default array offset.
113 : #if !(D0_D0_ENABLED || getRemoved_ENABLED)
114 11570 : offset = lbound(array,1,IK) - 1_IK
115 : #endif
116 : ! Set the pattern length.
117 : #if D0_D0_ENABLED || D1_D1_ENABLED
118 13865 : lenPattern = GET_SIZE(pattern, kind = IK) ! \warning GET_SIZE is a preprocessor macro.
119 13865 : if (lenPattern == 0_IK) then
120 : #if getRemoved_ENABLED
121 1694 : ArrayRemoved = array
122 : #endif
123 174 : return
124 : end if
125 : #endif
126 30630 : lenArray = GET_SIZE(array, kind = IK) ! \warning GET_SIZE is a preprocessor macro.
127 30630 : if (lenArray > lenPattern) then
128 14690 : lenDOPMax = lenArray / lenPattern + 1_IK
129 : #if CusIns_ENABLED
130 46740 : maxInstance = maxval(instance)
131 46740 : if (minval(instance) > 0_IK .and. maxInstance < lenDOPMax) lenDOPMax = maxInstance
132 : #elif !DefIns_ENABLED
133 : #error "Unrecognized interface."
134 : #endif
135 : ! Find all requested instances of pattern.
136 23626 : allocate(DOP(lenDOPMax))
137 : lenDOP = 0_IK
138 7770 : i = offset + 1_IK
139 12144 : iLast = offset + lenArray - lenPattern + 1_IK
140 : loopFindDOP: do
141 136731 : if (ISEQ(array(GET_INDEX(i)), pattern)) then ! fpp
142 : ! if (& ! LCOV_EXCL_LINE
143 : !#if setRemovedDefComDefIns_D1_D0_ENABLED || getRemovedDefComDefIns_D1_D0_ENABLED
144 : !#if CusCom_ENABLED
145 : ! iseq(array(i), pattern) & ! \warning ALL is a preprocessor macro. ! LCOV_EXCL_LINE
146 : !#else
147 : ! array(i) IS_EQUAL pattern & ! \warning ALL is a preprocessor macro. ! LCOV_EXCL_LINE
148 : !#endif
149 : !#elif setRemovedDefComDefIns_D1_D1_ENABLED || getRemovedDefComDefIns_D1_D1_ENABLED
150 : !#if CusCom_ENABLED
151 : ! iseq(array(i : i + lenPattern - 1), pattern, lenPattern) & ! \warning ALL is a preprocessor macro. ! LCOV_EXCL_LINE
152 : !#else
153 : ! ALL (array(i : i + lenPattern - 1) IS_EQUAL pattern) & ! \warning ALL is a preprocessor macro. ! LCOV_EXCL_LINE
154 : !#endif
155 : !#endif
156 : ! ) then
157 35159 : lenDOP = lenDOP + 1_IK
158 7650 : DOP(lenDOP) = i
159 27509 : i = i + lenPattern
160 : !if (lenDOP == lenDOPMax) exit loopFindDOP
161 : else
162 94868 : i = i + 1_IK
163 : end if
164 130027 : if (i > iLast) exit loopFindDOP
165 : end do loopFindDOP
166 : ! Remove array at all requested instances of pattern.
167 23626 : blockInstanceExists: if (lenDOP > 0_IK) then
168 : #if CusIns_ENABLED
169 : ! Convert all negative and positive instances to counts from the beginning within the possible range [1, lenDOP].
170 : !lenInstance = size(instance, kind = IK) ! this is now moved up to quit if zero-length instance is encountered.
171 12506 : allocate(InstanceNew(lenInstance))
172 : lenInstanceNew = 0_IK
173 : i = 0_IK
174 : ! This loop requires lenInstance to be at least 1, which is guaranteed by the condition after `lenInstance` definition in the above.
175 : do
176 28774 : i = i + 1_IK
177 28774 : if (instance(i) > 0_IK .and. instance(i) <= lenDOP) then
178 11722 : lenInstanceNew = lenInstanceNew + 1_IK
179 11722 : InstanceNew(lenInstanceNew) = instance(i)
180 17052 : elseif (instance(i) < 0_IK .and. instance(i) + lenDOP + 1_IK > 0_IK) then
181 10188 : lenInstanceNew = lenInstanceNew + 1_IK
182 10188 : InstanceNew(lenInstanceNew) = instance(i) + lenDOP + 1_IK
183 : end if
184 28774 : if (i == lenInstance) exit
185 : end do
186 : sorted_def = .false._LK
187 12506 : if (present(sorted)) sorted_def = sorted
188 12506 : if (.not. sorted_def) call setSorted(InstanceNew(1:lenInstanceNew))
189 : unique_def = .false._LK
190 12506 : if (present(unique)) unique_def = unique
191 7956 : if (unique_def) then
192 : lenDOP = lenInstanceNew
193 : else
194 48520 : InstanceNew = getUnique(InstanceNew(1:lenInstanceNew))
195 9542 : lenDOP = size(InstanceNew, kind = IK)
196 : end if
197 12506 : if (lenDOP == 0_IK) then ! instance is empty, return the input array, untouched.
198 : #if getRemoved_ENABLED
199 2142 : ArrayRemoved = array
200 : #endif
201 : ! The following deallocations are essential since gfortran,
202 : ! as of version 10.3, cannot automatically deallocate array upon return.
203 : #if CusIns_ENABLED
204 1092 : deallocate(InstanceNew)
205 : #endif
206 1092 : deallocate(DOP)
207 1092 : return
208 : end if
209 : #define INSTANCENEW(i) InstanceNew(i)
210 : #else
211 : !CusIns_ENABLED
212 : #define INSTANCENEW(i) i
213 : #endif
214 : !CusIns_ENABLED
215 20130 : lenArrayRemoved = lenArray - lenDOP * lenPattern
216 : #if SK_ENABLED && D0_D0_ENABLED
217 335 : allocate(character(lenArrayRemoved,SKC) :: ArrayRemoved)
218 : #elif SK_ENABLED && (D1_D0_ENABLED || D1_D1_ENABLED) && getRemoved_ENABLED
219 : ! \bug
220 : ! An Intel ifort compiler bug as of version 2021.4 prevents
221 : ! the merging of the following allocation with the one after.
222 646 : allocate(character(len(array),SKC) :: ArrayRemoved(lenArrayRemoved))
223 : #else
224 20080 : allocate(ArrayRemoved(offset + 1_IK : offset + lenArrayRemoved))
225 : #endif
226 : tokenStart = offset + 1_IK
227 : lenArrayOld = offset
228 49585 : do i = 1, lenDOP
229 29455 : lenArrayCurrent = lenArrayOld + DOP(INSTANCENEW(i)) - tokenStart
230 77204 : ArrayRemoved(lenArrayOld+1:lenArrayCurrent) = array(tokenStart : DOP(INSTANCENEW(i)) - 1)
231 29455 : tokenStart = DOP(INSTANCENEW(i)) + lenPattern
232 20130 : lenArrayOld = lenArrayCurrent
233 : end do
234 63703 : ArrayRemoved(lenArrayOld + 1_IK : offset + lenArrayRemoved) = array(tokenStart : offset + lenArray)
235 : #if CusIns_ENABLED
236 : ! This is essential since gfortran, as of version 10.3,
237 : ! cannot automatically deallocate array upon return.
238 11414 : deallocate(InstanceNew)
239 : #endif
240 : else blockInstanceExists
241 : #if getRemoved_ENABLED
242 4654 : ArrayRemoved = array
243 : #endif
244 2404 : deallocate(DOP)
245 2404 : return
246 : end if blockInstanceExists
247 20130 : deallocate(DOP)
248 7004 : elseif (lenArray == lenPattern) then
249 : if (ISEQ(array(GET_INDEX(offset + 1_IK)), pattern) & ! LCOV_EXCL_LINE
250 : #if CusIns_ENABLED
251 : .and. any(abs(instance) == 1_IK) & ! LCOV_EXCL_LINE
252 : #endif
253 : ) then
254 : #if SK_ENABLED && D0_D0_ENABLED
255 64 : allocate(character(0,SKC) :: ArrayRemoved)
256 : #elif SK_ENABLED && (D1_D0_ENABLED || D1_D1_ENABLED)
257 96 : allocate(character(len(array),SKC) :: ArrayRemoved(0))
258 : #else
259 1728 : allocate(ArrayRemoved(0))
260 : #endif
261 : else
262 6174 : ArrayRemoved = array
263 : end if
264 : else ! array is smaller than pattern
265 : #if getRemoved_ENABLED
266 4470 : ArrayRemoved = array
267 : #endif
268 62 : return
269 : end if
270 : #if setRemoved_ENABLED
271 8031 : call move_alloc(from = ArrayRemoved, to = array)
272 : #endif
273 : #undef INSTANCENEW
274 : #undef GET_INDEX
275 : #undef GET_SIZE
276 : #undef IS_EQUAL
277 : #undef ISEQ
|
