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 module contains implementations of the tests of the procedures under the generic interfaces
19 : !> [getUnique](@ref pm_arrayUnique::getUnique),
20 : !> [setUnique](@ref pm_arrayUnique::setUnique).
21 : !>
22 : !> \fintest
23 : !>
24 : !> \author
25 : !> \AmirShahmoradi, September 1, 2017, 11:35 PM, Institute for Computational Engineering and Sciences (ICES), The University of Texas at Austin
26 :
27 : !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
28 :
29 : ! Define the comparison operator.
30 : #if LK_ENABLED
31 : #define IS_EQUAL .eqv.
32 : #elif SK_ENABLED || IK_ENABLED || LK_ENABLED || CK_ENABLED || RK_ENABLED
33 : #define IS_EQUAL ==
34 : #else
35 : #error "Unrecognized interface."
36 : #endif
37 : ! Define the slicing rule.
38 : #if SK_ENABLED && D0_ENABLED
39 : #define GET_INDEX(i) i:i
40 : #define GET_SIZE len
41 : #elif D1_ENABLED
42 : #define GET_INDEX(i) i
43 : #define GET_SIZE size
44 : #else
45 : #error "Unrecognized interface."
46 : #endif
47 :
48 : !%%%%%%%%%%%%%%%
49 : #if isUnique_ENABLED
50 : !%%%%%%%%%%%%%%%
51 :
52 : character(*, SK), parameter :: PROCEDURE_NAME = "@isUnique()"
53 : #if SK_ENABLED && D0_ENABLED
54 1 : character(:,SKC), allocatable :: array
55 : character(1,SKC), parameter :: lb = "a", ub = "i"
56 : #elif SK_ENABLED && D1_ENABLED
57 : character(2,SKC), dimension(:), allocatable :: array
58 : character(2,SKC), parameter :: lb = "aa", ub = "ii"
59 : #elif IK_ENABLED && D1_ENABLED
60 : integer(IKC) , dimension(:), allocatable :: array
61 : integer(IKC) , parameter :: lb = 0, ub = 9
62 : #elif LK_ENABLED && D1_ENABLED
63 : logical(LKC) , dimension(:), allocatable :: array
64 : logical(LKC) , parameter :: lb = .false., ub = .true.
65 : #elif CK_ENABLED && D1_ENABLED
66 : complex(CKC) , dimension(:), allocatable :: array
67 : complex(CKC) , parameter :: lb = (0., -9.), ub = (+9., 0.)
68 : #elif RK_ENABLED && D1_ENABLED
69 : real(RKC) , dimension(:), allocatable :: array
70 : real(RKC) , parameter :: lb = 0., ub = 9.
71 : #else
72 : #error "Unrecognized interface."
73 : #endif
74 20 : type(display_type) :: disp
75 : logical(LK), allocatable :: unique(:)
76 : integer(IK) :: lenArray, itry, iell, jell, repetition
77 20 : assertion = .true._LK
78 2040 : do itry = 1, 100
79 :
80 : #if SK_ENABLED && D0_ENABLED
81 100 : iell = getUnifRand(0_IK, 9_IK)
82 1018 : array = getUnifRand(repeat(lb, iell), repeat(ub, iell))
83 : #else
84 12295 : array = getUnifRand(lb, ub, getUnifRand(0_IK, 9_IK))
85 : #endif
86 2000 : call report(__LINE__, iseq)
87 2020 : call report(__LINE__)
88 :
89 : end do
90 :
91 : contains
92 :
93 4000 : subroutine report(line, iseq)
94 : integer , intent(in) :: line
95 : logical(LK) , external , optional :: iseq
96 4000 : if (present(iseq)) then
97 12954 : unique = isUnique(array, iseq)
98 : else
99 12954 : unique = isUnique(array)
100 : end if
101 4000 : lenArray = GET_SIZE(array, kind = IK)
102 4000 : assertion = assertion .and. size(unique, 1, IK) == lenArray
103 4000 : call test%assert(assertion, PROCEDURE_NAME//SK_": The length of the output `logical` array must match that of the input sequence.", line)
104 4000 : if (0_IK < lenArray) then
105 21518 : do iell = 1, lenArray
106 21518 : if (present(iseq)) then
107 8954 : repetition = 0
108 65238 : do jell = 1, lenArray
109 65238 : if (iseq(array(GET_INDEX(iell)), array(GET_INDEX(jell)))) repetition = repetition + 1
110 : end do
111 8954 : assertion = assertion .and. (unique(iell) .eqv. 1_IK == repetition)
112 : else
113 : #if SK_ENABLED && D0_ENABLED
114 3346 : assertion = assertion .and. (unique(iell) .eqv. 1_IK == count(array(iell:iell) == getCharVec(array)))
115 : #else
116 61892 : assertion = assertion .and. (unique(iell) .eqv. 1_IK == count(array(iell) IS_EQUAL array))
117 : #endif
118 : end if
119 : end do
120 3610 : if (test%traceable .and. .not. assertion) then
121 : ! LCOV_EXCL_START
122 : call disp%skip
123 : call disp%show("array")
124 : call disp%show( array )
125 : call disp%show("unique")
126 : call disp%show( unique )
127 : call disp%skip
128 : ! LCOV_EXCL_STOP
129 : end if
130 3610 : call test%assert(assertion, PROCEDURE_NAME//SK_": The output argument `unique` must be correctly set.", line)
131 : end if
132 4000 : end subroutine
133 :
134 : !%%%%%%%%%%%%%%%%%%
135 : #elif isUniqueAll_ENABLED
136 : !%%%%%%%%%%%%%%%%%%
137 :
138 : character(*, SK), parameter :: PROCEDURE_NAME = "@isUniqueAll()"
139 : #if SK_ENABLED && D0_ENABLED
140 1 : character(:,SKC), allocatable :: array
141 : character(1,SKC), parameter :: lb = "a", ub = "i"
142 : #elif SK_ENABLED && D1_ENABLED
143 : character(2,SKC), dimension(:), allocatable :: array
144 : character(2,SKC), parameter :: lb = "aa", ub = "ii"
145 : #elif IK_ENABLED && D1_ENABLED
146 : integer(IKC) , dimension(:), allocatable :: array
147 : integer(IKC) , parameter :: lb = 0, ub = 9
148 : #elif LK_ENABLED && D1_ENABLED
149 : logical(LKC) , dimension(:), allocatable :: array
150 : logical(LKC) , parameter :: lb = .false., ub = .true.
151 : #elif CK_ENABLED && D1_ENABLED
152 : complex(CKC) , dimension(:), allocatable :: array
153 : complex(CKC) , parameter :: lb = (0., -9.), ub = (+9., 0.)
154 : #elif RK_ENABLED && D1_ENABLED
155 : real(RKC) , dimension(:), allocatable :: array
156 : real(RKC) , parameter :: lb = 0., ub = 9.
157 : #else
158 : #error "Unrecognized interface."
159 : #endif
160 20 : type(display_type) :: disp
161 : logical(LK) :: uniqueAll, allUnique
162 : integer(IK) :: lenArray, itry
163 20 : assertion = .true._LK
164 2040 : do itry = 1, 100
165 :
166 : #if SK_ENABLED && D0_ENABLED
167 100 : lenArray = getUnifRand(0_IK, 9_IK)
168 1092 : array = getUnifRand(repeat(lb, lenArray), repeat(ub, lenArray))
169 : #else
170 12366 : array = getUnifRand(lb, ub, getUnifRand(0_IK, 9_IK))
171 : #endif
172 2000 : call report(__LINE__, iseq)
173 2020 : call report(__LINE__)
174 :
175 : end do
176 :
177 : contains
178 :
179 4000 : subroutine report(line, iseq)
180 : integer , intent(in) :: line
181 : logical(LK) , external , optional :: iseq
182 4000 : if (present(iseq)) then
183 2000 : uniqueAll = isUniqueAll(array, iseq)
184 6999 : allUnique = all(isUnique(array, iseq))
185 : else
186 2000 : uniqueAll = isUniqueAll(array)
187 6999 : allUnique = all(isUnique(array))
188 : end if
189 4000 : lenArray = GET_SIZE(array, kind = IK)
190 4000 : assertion = assertion .and. (0_IK < lenArray .or. uniqueAll)
191 4000 : call test%assert(assertion, PROCEDURE_NAME//SK_": An empty sequence is all-unique elements.", line)
192 4000 : if (0_IK < lenArray) then
193 3612 : assertion = assertion .and. (uniqueAll .eqv. allUnique)
194 3612 : if (test%traceable .and. .not. assertion) then
195 : ! LCOV_EXCL_START
196 : call disp%skip
197 : call disp%show("array")
198 : call disp%show( array )
199 : call disp%show("uniqueAll")
200 : call disp%show( uniqueAll )
201 : call disp%skip
202 : ! LCOV_EXCL_STOP
203 : end if
204 3612 : call test%assert(assertion, PROCEDURE_NAME//SK_": The output argument `unique` must be correctly set.", line)
205 : end if
206 4000 : end subroutine
207 :
208 : !%%%%%%%%%%%%%%%%%%
209 : #elif isUniqueAny_ENABLED
210 : !%%%%%%%%%%%%%%%%%%
211 :
212 : character(*, SK), parameter :: PROCEDURE_NAME = "@isUniqueAny()"
213 : #if SK_ENABLED && D0_ENABLED
214 1 : character(:,SKC), allocatable :: array
215 : character(1,SKC), parameter :: lb = "a", ub = "i"
216 : #elif SK_ENABLED && D1_ENABLED
217 : character(2,SKC), dimension(:), allocatable :: array
218 : character(2,SKC), parameter :: lb = "aa", ub = "ii"
219 : #elif IK_ENABLED && D1_ENABLED
220 : integer(IKC) , dimension(:), allocatable :: array
221 : integer(IKC) , parameter :: lb = 0, ub = 9
222 : #elif LK_ENABLED && D1_ENABLED
223 : logical(LKC) , dimension(:), allocatable :: array
224 : logical(LKC) , parameter :: lb = .false., ub = .true.
225 : #elif CK_ENABLED && D1_ENABLED
226 : complex(CKC) , dimension(:), allocatable :: array
227 : complex(CKC) , parameter :: lb = (0., -9.), ub = (+9., 0.)
228 : #elif RK_ENABLED && D1_ENABLED
229 : real(RKC) , dimension(:), allocatable :: array
230 : real(RKC) , parameter :: lb = 0., ub = 9.
231 : #else
232 : #error "Unrecognized interface."
233 : #endif
234 20 : type(display_type) :: disp
235 : logical(LK) :: uniqueAny, anyUnique
236 : integer(IK) :: lenArray, itry
237 20 : assertion = .true._LK
238 2040 : do itry = 1, 100
239 :
240 : #if SK_ENABLED && D0_ENABLED
241 100 : lenArray = getUnifRand(0_IK, 9_IK)
242 986 : array = getUnifRand(repeat(lb, lenArray), repeat(ub, lenArray))
243 : #else
244 12542 : array = getUnifRand(lb, ub, getUnifRand(0_IK, 9_IK))
245 : #endif
246 2000 : call report(__LINE__, iseq)
247 2020 : call report(__LINE__)
248 :
249 : end do
250 :
251 : contains
252 :
253 4000 : subroutine report(line, iseq)
254 : integer , intent(in) :: line
255 : logical(LK) , external , optional :: iseq
256 4000 : if (present(iseq)) then
257 2000 : uniqueAny = isUniqueAny(array, iseq)
258 4350 : anyUnique = any(isUnique(array, iseq))
259 : else
260 2000 : uniqueAny = isUniqueAny(array)
261 4350 : anyUnique = any(isUnique(array))
262 : end if
263 4000 : lenArray = GET_SIZE(array, kind = IK)
264 4000 : assertion = assertion .and. (0_IK < lenArray .or. .not. uniqueAny)
265 4000 : call test%assert(assertion, PROCEDURE_NAME//SK_": An empty sequence has non-unique elements.", line)
266 4000 : if (0_IK < lenArray) then
267 3630 : assertion = assertion .and. (uniqueAny .eqv. anyUnique)
268 3630 : if (test%traceable .and. .not. assertion) then
269 : ! LCOV_EXCL_START
270 : call disp%skip
271 : call disp%show("array")
272 : call disp%show( array )
273 : call disp%show("uniqueAny")
274 : call disp%show( uniqueAny )
275 : call disp%skip
276 : ! LCOV_EXCL_STOP
277 : end if
278 3630 : call test%assert(assertion, PROCEDURE_NAME//SK_": The output argument `unique` must be correctly set.", line)
279 : end if
280 4000 : end subroutine
281 :
282 : !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
283 : #elif getUnique_ENABLED || setUnique_ENABLED
284 : !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
285 :
286 : #if getUnique_ENABLED
287 : character(*, SK), parameter :: PROCEDURE_NAME = "@getUnique()"
288 : #elif setUnique_ENABLED
289 : integer(IK) , allocatable :: Count(:), Count_ref(:)
290 20 : type(cvi_type), allocatable :: index(:), Index_ref(:)
291 : character(*, SK), parameter :: PROCEDURE_NAME = "@setUnique()"
292 : #endif
293 : integer(IK) :: lenUnique
294 :
295 : #if SK_ENABLED && D0_ENABLED
296 : #define ALL
297 2 : character(:,SKC), allocatable :: array, unique, unique_ref
298 : #elif SK_ENABLED && D1_ENABLED && getUnique_ENABLED
299 1 : character(:,SKC), dimension(:), allocatable :: array, unique, unique_ref
300 : #elif SK_ENABLED && D1_ENABLED && setUnique_ENABLED
301 : character(2,SKC), dimension(:), allocatable :: array, unique, unique_ref
302 : #elif IK_ENABLED && D1_ENABLED
303 : integer(IKC) , dimension(:), allocatable :: array, unique, unique_ref
304 : #elif LK_ENABLED && D1_ENABLED
305 : logical(LKC) , dimension(:), allocatable :: array, unique, unique_ref
306 : #elif CK_ENABLED && D1_ENABLED
307 : complex(CKC) , dimension(:), allocatable :: array, unique, unique_ref
308 : #elif RK_ENABLED && D1_ENABLED
309 : real(RKC) , dimension(:), allocatable :: array, unique, unique_ref
310 : #else
311 : #error "Unrecognized interface."
312 : #endif
313 :
314 : !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
315 :
316 40 : assertion = .true._LK
317 40 : call runTestsWith()
318 40 : call runTestsWith(iseq = iseq)
319 : #if setUnique_ENABLED
320 20 : call runTestsWith(order = +0_IK)
321 20 : call runTestsWith(order = +1_IK)
322 20 : call runTestsWith(order = -1_IK)
323 20 : call runTestsWith(index = index)
324 20 : call runTestsWith(index = index, order = 0_IK)
325 20 : call runTestsWith(index = index, order = 1_IK)
326 20 : call runTestsWith(index = index, order = -1_IK)
327 20 : call runTestsWith(iseq = iseq, order = 0_IK)
328 20 : call runTestsWith(iseq = iseq, order = 1_IK)
329 20 : call runTestsWith(iseq = iseq, order = -1_IK)
330 20 : call runTestsWith(iseq = iseq, index = index)
331 20 : call runTestsWith(iseq = iseq, index = index, order = 0_IK)
332 20 : call runTestsWith(iseq = iseq, index = index, order = 1_IK)
333 20 : call runTestsWith(iseq = iseq, index = index, order = -1_IK)
334 20 : call runTestsWith(fixed = .true., order = +0_IK)
335 20 : call runTestsWith(fixed = .true., order = +1_IK)
336 20 : call runTestsWith(fixed = .true., order = -1_IK)
337 20 : call runTestsWith(fixed = .true., index = index)
338 20 : call runTestsWith(fixed = .true., index = index, order = 0_IK)
339 20 : call runTestsWith(fixed = .true., index = index, order = 1_IK)
340 20 : call runTestsWith(fixed = .true., index = index, order = -1_IK)
341 20 : call runTestsWith(fixed = .true., iseq = iseq, order = 0_IK)
342 20 : call runTestsWith(fixed = .true., iseq = iseq, order = 1_IK)
343 20 : call runTestsWith(fixed = .true., iseq = iseq, order = -1_IK)
344 20 : call runTestsWith(fixed = .true., iseq = iseq, index = index)
345 20 : call runTestsWith(fixed = .true., iseq = iseq, index = index, order = 0_IK)
346 20 : call runTestsWith(fixed = .true., iseq = iseq, index = index, order = 1_IK)
347 189 : call runTestsWith(fixed = .true., iseq = iseq, index = index, order = -1_IK)
348 : #endif
349 :
350 : !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
351 :
352 : contains
353 :
354 : !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
355 :
356 : subroutine runTestsWith ( iseq & ! LCOV_EXCL_LINE
357 : #if setUnique_ENABLED
358 : , fixed & ! LCOV_EXCL_LINE
359 : , index & ! LCOV_EXCL_LINE
360 : , order & ! LCOV_EXCL_LINE
361 : )
362 : logical , intent(in) , optional :: fixed
363 : type(cvi_type), allocatable , intent(inout), optional :: index(:)
364 : integer(IK) , intent(in) , optional :: order
365 : integer(IK) , allocatable :: RemapIndex(:)
366 : integer(IK) :: order_def
367 : #else
368 : )
369 : #endif
370 : logical(LK), external, optional :: iseq
371 : #if setUnique_ENABLED
372 : order_def = 0_IK
373 600 : if (present(order)) order_def = order
374 600 : if (allocated(Count_ref)) deallocate(Count_ref)
375 3065 : if (allocated(Index_ref)) deallocate(Index_ref)
376 : #endif
377 640 : if (allocated(array)) deallocate(array)
378 640 : if (allocated(unique)) deallocate(unique)
379 640 : if (allocated(unique_ref)) deallocate(unique_ref)
380 :
381 : !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
382 :
383 : #if SK_ENABLED && D0_ENABLED
384 32 : array = ""
385 32 : unique_ref = ""
386 : #elif SK_ENABLED && D1_ENABLED && getUnique_ENABLED
387 2 : allocate(character(2,SKC) :: array(0), unique_ref(0))
388 : #elif SK_ENABLED && D1_ENABLED && setUnique_ENABLED
389 30 : allocate(array(0), unique_ref(0))
390 : #elif IK_ENABLED && D1_ENABLED
391 160 : allocate(array(0), unique_ref(0))
392 : #elif LK_ENABLED && D1_ENABLED
393 160 : allocate(array(0), unique_ref(0))
394 : #elif CK_ENABLED && D1_ENABLED
395 128 : allocate(array(0), unique_ref(0))
396 : #elif RK_ENABLED && D1_ENABLED
397 128 : allocate(array(0), unique_ref(0))
398 : #endif
399 :
400 : #if getUnique_ENABLED
401 40 : call report(__LINE__, iseq)
402 : #elif setUnique_ENABLED
403 600 : allocate(Count_ref(0), Index_ref(0))
404 880 : call report(__LINE__, iseq, fixed, index, order)
405 : #endif
406 :
407 : !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
408 :
409 : #if SK_ENABLED && D0_ENABLED
410 32 : array = SKC_" "
411 32 : unique_ref = SKC_" "
412 : #elif SK_ENABLED && D1_ENABLED
413 96 : array = [character(2,SKC) :: " "]
414 96 : unique_ref = [character(2,SKC) :: " "]
415 : #elif IK_ENABLED && D1_ENABLED
416 480 : array = [1_IKC]
417 480 : unique_ref = [1_IKC]
418 : #elif LK_ENABLED && D1_ENABLED
419 480 : array = [logical(LKC) :: .false.]
420 480 : unique_ref = [logical(LKC) :: .false.]
421 : #elif CK_ENABLED && D1_ENABLED
422 384 : array = [(+1._CKC, -1._CKC)]
423 384 : unique_ref = [(+1._CKC, -1._CKC)]
424 : #elif RK_ENABLED && D1_ENABLED
425 384 : array = [1._RKC]
426 384 : unique_ref = [1._RKC]
427 : #endif
428 :
429 : #if getUnique_ENABLED
430 40 : call report(__LINE__, iseq)
431 : #elif setUnique_ENABLED
432 1800 : Count_ref = [1_IK]
433 600 : deallocate(Index_ref)
434 1260 : allocate(Index_ref(1))
435 1800 : Index_ref(1)%val = [1_IK]
436 600 : call report(__LINE__, iseq, fixed, index, order)
437 : #endif
438 :
439 : !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
440 :
441 : #if SK_ENABLED && D0_ENABLED
442 32 : array = SKC_" "
443 : #elif SK_ENABLED && D1_ENABLED
444 128 : array = [character(2,SKC) :: " ", " "]
445 : #elif IK_ENABLED && D1_ENABLED
446 640 : array = [1_IKC, 1_IKC]
447 : #elif LK_ENABLED && D1_ENABLED
448 640 : array = [logical(LKC) :: .false., .false.]
449 : #elif CK_ENABLED && D1_ENABLED
450 512 : array = [complex(CKC) :: (+1._CKC, -1._CKC), (+1._CKC, -1._CKC)]
451 : #elif RK_ENABLED && D1_ENABLED
452 512 : array = [real(RKC) :: 1._RKC, 1._RKC]
453 : #endif
454 :
455 1248 : unique_ref = array(GET_INDEX(1))
456 : #if getUnique_ENABLED
457 40 : call report(__LINE__, iseq)
458 : #elif setUnique_ENABLED
459 1800 : Count_ref = [2_IK]
460 1200 : deallocate(Index_ref)
461 1260 : allocate(Index_ref(1))
462 2400 : Index_ref(1)%val = [1_IK, 2_IK]
463 600 : call report(__LINE__, iseq, fixed, index, order)
464 : #endif
465 :
466 : !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
467 :
468 : #if SK_ENABLED && D0_ENABLED
469 32 : array = SKC_"ABaB "
470 32 : unique_ref = SKC_"ABa "
471 : #elif SK_ENABLED && D1_ENABLED
472 224 : array = [character(2,SKC) :: "A", "B", "a", "B", " "]
473 192 : unique_ref = [character(2,SKC) :: "A", "B", "a", " "]
474 : #elif IK_ENABLED && D1_ENABLED
475 1120 : array = [1_IKC, 2_IKC, 0_IKC, 2_IKC, -1_IKC]
476 960 : unique_ref = [1_IKC, 2_IKC, 0_IKC, -1_IKC]
477 : #elif LK_ENABLED && D1_ENABLED
478 960 : array = [logical(LKC) :: .false., .false., .true., .false.]
479 640 : unique_ref = [logical(LKC) :: .false., .true.]
480 : #elif CK_ENABLED && D1_ENABLED
481 896 : array = [(+1._CKC, -1._CKC), (+2._CKC, -2._CKC), (+0._CKC, 0._CKC), (+2._CKC, -2._CKC), (-1._CKC, +1._CKC)]
482 768 : unique_ref = [(+1._CKC, -1._CKC), (+2._CKC, -2._CKC), (+0._CKC, 0._CKC), (-1._CKC, +1._CKC)]
483 : #elif RK_ENABLED && D1_ENABLED
484 896 : array = [1._RKC, 2._RKC, 0._RKC, 2._RKC, -1._RKC]
485 768 : unique_ref = [1._RKC, 2._RKC, 0._RKC, -1._RKC]
486 : #endif
487 :
488 : #if getUnique_ENABLED
489 40 : call report(__LINE__, iseq)
490 : #elif setUnique_ENABLED
491 1200 : deallocate(Index_ref)
492 : #if LK_ENABLED
493 450 : allocate(Index_ref(2))
494 600 : Count_ref = [3_IK, 1_IK]
495 750 : Index_ref(1)%val = [integer(IK) :: 1, 2, 4]
496 450 : Index_ref(2)%val = [integer(IK) :: 3]
497 150 : if (order_def == 0_IK) then
498 280 : RemapIndex = [integer(IK) :: 1, 2]
499 80 : elseif (order_def > 0_IK) then
500 160 : RemapIndex = [integer(IK) :: 2, 1]
501 : elseif (order_def < 0_IK) then
502 160 : RemapIndex = [integer(IK) :: 1, 2]
503 : end if
504 : #else
505 2250 : allocate(Index_ref(4))
506 2700 : Count_ref = [1_IK, 2_IK, 1_IK, 1_IK]
507 1350 : Index_ref(1)%val = [1_IK]
508 1800 : Index_ref(2)%val = [2_IK, 4_IK]
509 1350 : Index_ref(3)%val = [3_IK]
510 1350 : Index_ref(4)%val = [5_IK]
511 450 : if (order_def == 0_IK) then
512 1260 : RemapIndex = [1_IK, 2_IK, 3_IK, 4_IK]
513 240 : elseif (order_def > 0_IK) then
514 720 : RemapIndex = [1_IK, 3_IK, 4_IK, 2_IK]
515 : elseif (order_def < 0_IK) then
516 720 : RemapIndex = [2_IK, 4_IK, 3_IK, 1_IK]
517 : end if
518 : #endif
519 5400 : Index_ref = Index_ref(RemapIndex)
520 600 : call setRemapped(Count_ref, RemapIndex)
521 600 : call setRemapped(unique_ref, RemapIndex)
522 600 : call report(__LINE__, iseq, fixed, index, order)
523 : #endif
524 :
525 : !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
526 :
527 : #if SK_ENABLED && D0_ENABLED
528 32 : array = "ABaX "
529 : #elif SK_ENABLED && D1_ENABLED
530 224 : array = ["A", "B", "a", "X", " "]
531 : #elif IK_ENABLED && D1_ENABLED
532 1120 : array = [1_IKC, 2_IKC, 0_IKC, -1_IKC, -2_IKC]
533 : #elif LK_ENABLED && D1_ENABLED
534 640 : array = [logical(LKC) :: .true., .false.]
535 : #elif CK_ENABLED && D1_ENABLED
536 896 : array = [(+1._CKC, -1._CKC), (+0._CKC, 0._CKC), (+2._CKC, -2._CKC), (-1._CKC, +1._CKC), (-2._CKC, +2._CKC)]
537 : #elif RK_ENABLED && D1_ENABLED
538 896 : array = [1._RKC, 0._RKC, 2._RKC, -1._RKC, -2._RKC]
539 : #endif
540 :
541 4256 : unique_ref = array
542 : #if getUnique_ENABLED
543 40 : call report(__LINE__, iseq)
544 : #elif setUnique_ENABLED && LK_ENABLED
545 450 : deallocate(Index_ref)
546 450 : allocate(Index_ref(2))
547 600 : Count_ref = [integer(IK) :: 1, 1]
548 450 : Index_ref(1)%val = [integer(IK) :: 1]
549 450 : Index_ref(2)%val = [integer(IK) :: 2]
550 150 : if (order_def == 0_IK) then
551 280 : RemapIndex = [integer(IK) :: 1, 2]
552 80 : elseif (order_def > 0_IK) then
553 160 : RemapIndex = [integer(IK) :: 1, 2]
554 : elseif (order_def < 0_IK) then
555 160 : RemapIndex = [integer(IK) :: 2, 1]
556 : end if
557 900 : Index_ref = Index_ref(RemapIndex)
558 150 : call setRemapped(Count_ref, RemapIndex)
559 150 : call setRemapped(unique_ref, RemapIndex)
560 150 : call report(__LINE__, iseq, fixed, index, order)
561 : #elif setUnique_ENABLED
562 2250 : deallocate(Index_ref)
563 2700 : allocate(Index_ref(5))
564 3150 : Count_ref = [1_IK, 1_IK, 1_IK, 1_IK, 1_IK]
565 1350 : Index_ref(1)%val = [1_IK]
566 1350 : Index_ref(2)%val = [2_IK]
567 1350 : Index_ref(3)%val = [3_IK]
568 1350 : Index_ref(4)%val = [4_IK]
569 1350 : Index_ref(5)%val = [5_IK]
570 450 : if (order_def == 0_IK) then
571 1470 : RemapIndex = [1_IK, 2_IK, 3_IK, 4_IK, 5_IK]
572 240 : elseif (order_def > 0_IK) then
573 840 : RemapIndex = [1_IK, 2_IK, 3_IK, 4_IK, 5_IK]
574 : elseif (order_def < 0_IK) then
575 840 : RemapIndex = [5_IK, 4_IK, 3_IK, 2_IK, 1_IK]
576 : end if
577 5400 : Index_ref = Index_ref(RemapIndex)
578 450 : call setRemapped(Count_ref, RemapIndex)
579 450 : call setRemapped(unique_ref, RemapIndex)
580 450 : call report(__LINE__, iseq, fixed, index, order)
581 : #endif
582 :
583 : !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
584 :
585 : #if SK_ENABLED && D1_ENABLED
586 192 : array = ["", "", "", ""]
587 96 : unique_ref = [""]
588 : #if getUnique_ENABLED
589 2 : call report(__LINE__)
590 : #elif setUnique_ENABLED
591 90 : Count_ref = [4_IK]
592 180 : deallocate(Index_ref)
593 180 : allocate(Index_ref(5))
594 180 : Index_ref(1)%val = [1_IK, 2_IK, 3_IK, 4_IK]
595 30 : call report(__LINE__, iseq, fixed, index, order)
596 : #endif
597 : #endif
598 :
599 640 : end subroutine
600 :
601 : !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
602 : !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
603 :
604 : #if getUnique_ENABLED
605 202 : subroutine report(line, iseq)
606 : integer , intent(in) :: line
607 : logical(LK) , external , optional :: iseq
608 202 : if (present(iseq)) then
609 379 : unique = getUnique(array, iseq)
610 : else
611 385 : unique = getUnique(array)
612 : end if
613 202 : lenUnique = GET_SIZE(unique, kind = IK)
614 572 : assertion = assertion .and. ALL(unique(1:lenUnique) IS_EQUAL unique_ref)
615 202 : if (test%traceable .and. .not. assertion) then
616 : ! LCOV_EXCL_START
617 : write(test%disp%unit,"(*(g0,:,', '))")
618 : write(test%disp%unit,"(*(g0,:,', '))") "array ", array
619 : write(test%disp%unit,"(*(g0,:,', '))") "unique ", unique(1:lenUnique)
620 : write(test%disp%unit,"(*(g0,:,', '))") "unique_ref ", unique_ref
621 : write(test%disp%unit,"(*(g0,:,', '))") "lenUnique ", lenUnique
622 : write(test%disp%unit,"(*(g0,:,', '))")
623 : ! LCOV_EXCL_STOP
624 : end if
625 202 : call test%assert(assertion, PROCEDURE_NAME//SK_": The output argument `unique` must be correctly set.", line)
626 202 : end subroutine
627 : #elif setUnique_ENABLED
628 : subroutine report ( line & ! LCOV_EXCL_LINE
629 : , iseq & ! LCOV_EXCL_LINE
630 : , fixed & ! LCOV_EXCL_LINE
631 : , index & ! LCOV_EXCL_LINE
632 : , order & ! LCOV_EXCL_LINE
633 : )
634 : use pm_option, only: getOption
635 : integer , intent(in) :: line
636 : logical(LK) , external , optional :: iseq
637 : logical(LK) , intent(in) , optional :: fixed
638 : type(cvi_type), intent(inout) , optional , allocatable :: index(:)
639 : integer(IK) , intent(in) , optional :: order
640 : integer(IK) :: i
641 3030 : if (getOption(.false._LK, fixed)) then ! Test the contiguous array interfaces.
642 1414 : if (allocated(Count)) deallocate(Count)
643 1414 : if (allocated(unique)) deallocate(unique)
644 1414 : lenUnique = GET_SIZE(array, kind = IK)
645 2506 : allocate(unique, mold = array)
646 1414 : allocate(Count(lenUnique))
647 1414 : if (present(index)) then
648 2757 : if (allocated(index)) deallocate(index)
649 2760 : allocate(index(lenUnique))
650 808 : if (present(iseq)) then
651 404 : call setUnique(array, unique, lenUnique, Count, iseq = iseq, index = index, order = order)
652 : else
653 404 : call setUnique(array, unique, lenUnique, Count, index = index, order = order)
654 : end if
655 : else
656 606 : if (present(iseq)) then
657 : call setUnique(array, unique, lenUnique, Count, iseq = iseq, order = order)
658 : else
659 : call setUnique(array, unique, lenUnique, Count, order = order)
660 : end if
661 : end if
662 : else
663 1616 : if (present(index)) then
664 808 : if (present(iseq)) then
665 1188 : call setUnique(array, unique, Count, iseq = iseq, index = index, order = order)
666 : else
667 1107 : call setUnique(array, unique, Count, index = index, order = order)
668 : end if
669 : else
670 1616 : if (present(iseq)) then
671 404 : call setUnique(array, unique, Count, iseq = iseq, order = order)
672 : else
673 404 : call setUnique(array, unique, Count, order = order)
674 : end if
675 : end if
676 1616 : lenUnique = GET_SIZE(unique, kind = IK)
677 : end if
678 :
679 3030 : assertion = assertion .and. lenUnique == GET_SIZE(unique_ref, kind = IK)
680 4444 : call outputSpec(lenUnique, iseq, fixed, index, order)
681 3030 : call test%assert(assertion, PROCEDURE_NAME//SK_": The size of the output argument `unique` must be correctly set.", line)
682 :
683 8910 : assertion = assertion .and. all(Count(1:lenUnique) == Count_ref)
684 3030 : call outputSpec(lenUnique, iseq, fixed, index, order)
685 3030 : call test%assert(assertion, PROCEDURE_NAME//SK_": The output argument `Count` must be correctly set.", line)
686 :
687 3030 : if (present(index)) then
688 4752 : do i = 1, lenUnique
689 7040 : assertion = assertion .and. all(index(i)%val == Index_ref(i)%val)
690 3136 : call outputSpec(lenUnique, iseq, fixed, index, order)
691 4752 : call test%assert(assertion, PROCEDURE_NAME//SK_": The output argument `index` must be correctly set.", line)
692 : end do
693 : end if
694 :
695 8580 : assertion = assertion .and. ALL(unique(1:lenUnique) IS_EQUAL unique_ref)
696 3030 : call outputSpec(lenUnique, iseq, fixed, index, order)
697 3030 : call test%assert(assertion, PROCEDURE_NAME//SK_": The output argument `unique` must be correctly set.", line)
698 :
699 3030 : end subroutine
700 :
701 12226 : subroutine outputSpec(lenUnique, iseq, fixed, index, order)
702 : integer(IK) , intent(in) :: lenUnique
703 : logical(LK) , external , optional :: iseq
704 : logical(LK) , intent(in), optional :: fixed
705 : type(cvi_type), intent(in), optional , allocatable :: index(:)
706 : integer(IK) , intent(in), optional :: order
707 : integer(IK) :: i
708 12226 : if (test%traceable .and. .not. assertion) then
709 : ! LCOV_EXCL_START
710 : write(test%disp%unit,"(*(g0,:,', '))")
711 : write(test%disp%unit,"(*(g0,:,', '))") "array ", array
712 : write(test%disp%unit,"(*(g0,:,', '))") "lenArray ", GET_SIZE(array, kind = IK)
713 : write(test%disp%unit,"(*(g0,:,', '))") "unique ", unique(1:lenUnique)
714 : write(test%disp%unit,"(*(g0,:,', '))") "unique_ref ", unique_ref
715 : write(test%disp%unit,"(*(g0,:,', '))") "lenUnique ", lenUnique
716 : write(test%disp%unit,"(*(g0,:,', '))") "Count ", Count(1:lenUnique)
717 : write(test%disp%unit,"(*(g0,:,', '))") "Count_ref ", Count_ref
718 : write(test%disp%unit,"(*(g0,:,', '))") "present(iseq) ", present(iseq)
719 : write(test%disp%unit,"(*(g0,:,', '))") "present(fixed) ", present(fixed)
720 : write(test%disp%unit,"(*(g0,:,', '))")
721 : if (present(fixed)) then
722 : write(test%disp%unit,"(*(g0,:,', '))") "fixed ", fixed
723 : end if
724 : write(test%disp%unit,"(*(g0,:,', '))") "present(order) ", present(order)
725 : if (present(order)) then
726 : write(test%disp%unit,"(*(g0,:,', '))") "order ", order
727 : end if
728 : write(test%disp%unit,"(*(g0,:,', '))") "present(index) ", present(index)
729 : if (present(index)) then
730 : do i = 1, lenUnique
731 : write(test%disp%unit,"(*(g0,:,', '))") "index ", index(i)%val
732 : write(test%disp%unit,"(*(g0,:,', '))") "Index_ref ", Index_ref(i)%val
733 : write(test%disp%unit,"(*(g0,:,', '))")
734 : end do
735 : end if
736 : ! LCOV_EXCL_STOP
737 : end if
738 12226 : end subroutine
739 : #endif
740 :
741 : #else
742 : !%%%%%%%%%%%%%%%%%%%%%%%%
743 : #error "Unrecognized interface."
744 : !%%%%%%%%%%%%%%%%%%%%%%%%
745 : #endif
746 :
747 150572 : pure function iseq(element1, element2) result(equivalent)
748 : #if SK_ENABLED && D0_ENABLED
749 : character(1,SKC), intent(in) :: element1, element2
750 : #elif SK_ENABLED && D1_ENABLED
751 : character(*,SKC), intent(in) :: element1, element2
752 : #elif IK_ENABLED && D1_ENABLED
753 : integer(IKC) , intent(in) :: element1, element2
754 : #elif LK_ENABLED && D1_ENABLED
755 : logical(LKC) , intent(in) :: element1, element2
756 : #elif CK_ENABLED && D1_ENABLED
757 : complex(CKC) , intent(in) :: element1, element2
758 : #elif RK_ENABLED && D1_ENABLED
759 : real(RKC) , intent(in) :: element1, element2
760 : #endif
761 : logical(LK) :: equivalent
762 150572 : equivalent = element1 IS_EQUAL element2
763 150572 : end function
764 :
765 : !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
766 :
767 : #undef GET_INDEX
768 : #undef GET_SIZE
769 : #undef IS_EQUAL
770 : #undef ALL
|
