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 of [pm_arrayStrip](@ref pm_arrayStrip).
19 : !>
20 : !> \fintest
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 : #if D1_D0_ENABLED
28 : #define ISEQ iseqVec
29 : #endif
30 : #if LK_ENABLED
31 : #define IS_EQUAL .eqv.
32 : #else
33 : #define IS_EQUAL ==
34 : #endif
35 : #if D0_D0_ENABLED && SK_ENABLED
36 : #define GET_REPEAT(x, count) repeat(x, count)
37 : #define GET_SIZE len
38 : #define ALL
39 : #else
40 : #define GET_REPEAT(x, count) x
41 : #define GET_SIZE size
42 : #endif
43 : !%%%%%%%%%%%%%%%%%%
44 : #if getStripped_ENABLED
45 : !%%%%%%%%%%%%%%%%%%
46 :
47 : #if SK_ENABLED && D0_D0_ENABLED
48 3 : character(:,SKC), allocatable :: arrayStripped, arrayStripped_ref, array, pattern
49 : character(1,SKC), parameter :: lower = SKC_"a", upper = SKC_"d"
50 : #elif SK_ENABLED && D1_D0_ENABLED
51 3 : character(2,SKC), allocatable :: arrayStripped(:), arrayStripped_ref(:), array(:), pattern
52 : character(2,SKC), parameter :: lower = SKC_"aa", upper = SKC_"dd"
53 : #elif IK_ENABLED && D1_D0_ENABLED
54 15 : integer(IKC) , allocatable :: arrayStripped(:), arrayStripped_ref(:), array(:), pattern
55 : integer(IKC) , parameter :: lower = 0_IKC, upper = 10_IKC
56 : #elif LK_ENABLED && D1_D0_ENABLED
57 15 : logical(LKC) , allocatable :: arrayStripped(:), arrayStripped_ref(:), array(:), pattern
58 : logical(LKC) , parameter :: lower = .false._LKC, upper = .true._LKC
59 : #elif CK_ENABLED && D1_D0_ENABLED
60 12 : complex(CKC) , allocatable :: arrayStripped(:), arrayStripped_ref(:), array(:), pattern
61 : complex(CKC) , parameter :: lower = (-1._CKC, -1._CKC), upper = (1._CKC, 1._CKC)
62 : #elif RK_ENABLED && D1_D0_ENABLED
63 12 : real(RKC) , allocatable :: arrayStripped(:), arrayStripped_ref(:), array(:), pattern
64 : real(RKC) , parameter :: lower = -1._RKC, upper = 1._RKC
65 : #elif SK_ENABLED && D1_D1_ENABLED
66 : character(2,SKC), allocatable :: arrayStripped(:), arrayStripped_ref(:), array(:), pattern(:)
67 : character(2,SKC), parameter :: lower = SKC_"aa", upper = SKC_"dd"
68 : #elif IK_ENABLED && D1_D1_ENABLED
69 : integer(IKC) , allocatable :: arrayStripped(:), arrayStripped_ref(:), array(:), pattern(:)
70 : integer(IKC) , parameter :: lower = 0_IKC, upper = 10_IKC
71 : #elif LK_ENABLED && D1_D1_ENABLED
72 : logical(LKC) , allocatable :: arrayStripped(:), arrayStripped_ref(:), array(:), pattern(:)
73 : logical(LKC) , parameter :: lower = .false._LKC, upper = .true._LKC
74 : #elif CK_ENABLED && D1_D1_ENABLED
75 : complex(CKC) , allocatable :: arrayStripped(:), arrayStripped_ref(:), array(:), pattern(:)
76 : complex(CKC) , parameter :: lower = (-1._CKC, -1._CKC), upper = (1._CKC, 1._CKC)
77 : #elif RK_ENABLED && D1_D1_ENABLED
78 : real(RKC) , allocatable :: arrayStripped(:), arrayStripped_ref(:), array(:), pattern(:)
79 : real(RKC) , parameter :: lower = -1._RKC, upper = 1._RKC
80 : #else
81 : #error "Unrecognized interface."
82 : #endif
83 : #if SB_ENABLED
84 : #define SIDE_TYPE leftRight_type
85 : #elif SR_ENABLED
86 : #define SIDE_TYPE right_type
87 : #elif LR_ENABLED
88 : #define SIDE_TYPE left_type
89 : #else
90 : #error "Unrecognized interface."
91 : #endif
92 : type(SIDE_TYPE), parameter :: side = SIDE_TYPE()
93 117 : assertion = .true._LK
94 117 : call runTestsWith()
95 117 : call runTestsWith(iseq)
96 :
97 : contains
98 :
99 234 : subroutine runTestsWith(iseq)
100 :
101 : logical(LK), external, optional :: iseq
102 : integer(IK) :: i, lenArray
103 :
104 70434 : do i = 1_IK, 300_IK
105 :
106 70200 : call reset()
107 70200 : lenArray = getUnifRand(0_IK, 100_IK)
108 70200 : call setResized(array, size = lenArray)
109 3679081 : call setUnifRand(array, GET_REPEAT(lower, lenArray), GET_REPEAT(upper, lenArray))
110 : ! set pattern.
111 70200 : if (getUnifRand()) then
112 : #if D0_D0_ENABLED || D1_D1_ENABLED
113 : block
114 : integer(IK) :: lenpattern
115 17900 : lenpattern = getUnifRand(0, 2)
116 17900 : call setResized(pattern, lenpattern)
117 37036 : call setUnifRand(pattern, GET_REPEAT(lower, lenpattern), GET_REPEAT(upper, lenpattern))
118 : end block
119 : #elif D1_D0_ENABLED
120 17175 : pattern = getUnifRand(lower, upper)
121 :
122 : #else
123 : #error "Unrecognized interface."
124 : #endif
125 : else
126 : #if D0_D0_ENABLED || D1_D1_ENABLED
127 : block
128 : integer(IK) :: lindex, rindex
129 18100 : if (getUnifRand()) then
130 : lindex = 1_IK
131 8945 : rindex = getUnifRand(0_IK, min(2_IK, lenArray))
132 : else
133 9155 : lindex = lenArray - getUnifRand(0_IK, min(2_IK, lenArray)) + 1_IK
134 457 : rindex = lenArray
135 : end if
136 52161 : pattern = array(lindex : rindex)
137 : end block
138 : #elif D1_D0_ENABLED
139 17025 : if (lenArray > 0_IK) then
140 16853 : pattern = merge(array(1), array(lenArray), getUnifRand())
141 : else
142 172 : pattern = getUnifRand(lower, upper)
143 : end if
144 : #else
145 : #error "Unrecognized interface."
146 : #endif
147 : end if
148 :
149 : ! strip.
150 :
151 70200 : if (present(iseq)) then
152 : #if SB_ENABLED
153 582309 : arrayStripped_ref = array(getSIL(array, pattern, iseq) : getSIR(array, pattern, iseq))
154 : #elif LR_ENABLED
155 588041 : arrayStripped_ref = array(getSIL(array, pattern, iseq) : )
156 : #elif SR_ENABLED
157 587692 : arrayStripped_ref = array( : getSIR(array, pattern, iseq))
158 : #else
159 : #error "Unrecognized interface."
160 : #endif
161 3446784 : arrayStripped = getStripped(array, pattern, iseq, side)
162 : else
163 : #if SB_ENABLED
164 585489 : arrayStripped_ref = array(getSIL(array, pattern) : getSIR(array, pattern))
165 : #elif LR_ENABLED
166 590542 : arrayStripped_ref = array(getSIL(array, pattern) : )
167 : #elif SR_ENABLED
168 588653 : arrayStripped_ref = array( : getSIR(array, pattern))
169 : #endif
170 3460068 : arrayStripped = getStripped(array, pattern, side)
171 : end if
172 70356 : call report(__LINE__, iseq, side)
173 : #if SB_ENABLED
174 1167798 : arrayStripped = getStripped(array, pattern)
175 23478 : call report(__LINE__, iseq)
176 : #endif
177 :
178 : end do
179 :
180 234 : end subroutine
181 :
182 : !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
183 :
184 93600 : subroutine report(line, iseq, side)
185 : type(SIDE_TYPE), intent(in), optional :: side
186 : logical(LK) , external, optional :: iseq
187 : integer, intent(in) :: line
188 4599324 : assertion = assertion .and. logical(ALL(arrayStripped IS_EQUAL arrayStripped_ref), LK) ! fpp
189 93600 : if (test%traceable .and. .not. assertion) then
190 : ! LCOV_EXCL_START
191 : call test%disp%skip()
192 : call test%disp%show("arrayStripped_ref")
193 : call test%disp%show( arrayStripped_ref )
194 : call test%disp%show("arrayStripped")
195 : call test%disp%show( arrayStripped )
196 : call test%disp%show("array")
197 : call test%disp%show( array )
198 : call test%disp%show("pattern")
199 : call test%disp%show( pattern )
200 : call test%disp%show("present(iseq)")
201 : call test%disp%show( present(iseq) )
202 : call test%disp%show("present(side)")
203 : call test%disp%show( present(side) )
204 : call test%disp%skip()
205 : ! LCOV_EXCL_STOP
206 : end if
207 93600 : call test%assert(assertion, SK_"@getStripped(): The test array must be stripped correctly.", int(line, IK))
208 93600 : end subroutine
209 :
210 : !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
211 :
212 : #if D0_D0_ENABLED || D1_D0_ENABLED
213 71542 : function iseq(Segment, pattern) result(equivalent)
214 : #if SK_ENABLED && D0_D0_ENABLED
215 : character(*,SKC), intent(in) :: Segment, pattern
216 : #elif SK_ENABLED && D1_D0_ENABLED
217 : character(*,SKC), intent(in) :: Segment, pattern
218 : #elif IK_ENABLED && D1_D0_ENABLED
219 : integer(IKC) , intent(in) :: Segment, pattern
220 : #elif LK_ENABLED && D1_D0_ENABLED
221 : logical(LKC) , intent(in) :: Segment, pattern
222 : #elif CK_ENABLED && D1_D0_ENABLED
223 : complex(CKC) , intent(in) :: Segment, pattern
224 : #elif RK_ENABLED && D1_D0_ENABLED
225 : real(RKC) , intent(in) :: Segment, pattern
226 : #endif
227 : logical(LK) :: equivalent
228 71542 : equivalent = Segment IS_EQUAL pattern
229 71542 : end function
230 : #elif D1_D1_ENABLED
231 43182 : function iseq(Segment, pattern, lenpattern) result(equivalent)
232 : logical(LK) :: equivalent
233 : integer(IK), intent(in) :: lenpattern
234 : #if SK_ENABLED
235 : character(*,SKC), intent(in) :: Segment(lenpattern), pattern(lenpattern)
236 : #elif IK_ENABLED
237 : integer(IKC) , intent(in) :: Segment(lenpattern), pattern(lenpattern)
238 : #elif LK_ENABLED
239 : logical(LKC) , intent(in) :: Segment(lenpattern), pattern(lenpattern)
240 : #elif CK_ENABLED
241 : complex(CKC) , intent(in) :: Segment(lenpattern), pattern(lenpattern)
242 : #elif RK_ENABLED
243 : real(RKC) , intent(in) :: Segment(lenpattern), pattern(lenpattern)
244 : #endif
245 63506 : equivalent = all(Segment IS_EQUAL pattern)
246 43182 : end function
247 : #else
248 : #error "Unrecognized interface."
249 : #endif
250 :
251 : !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
252 :
253 70200 : subroutine reset()
254 70200 : if (allocated(array)) deallocate(array)
255 70200 : if (allocated(pattern)) deallocate(pattern)
256 70200 : if (allocated(arrayStripped)) deallocate(arrayStripped)
257 70200 : if (allocated(arrayStripped_ref)) deallocate(arrayStripped_ref)
258 70200 : end subroutine
259 :
260 : !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
261 : #elif getSIL_ENABLED || getSIR_ENABLED
262 : !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
263 :
264 : #if SK_ENABLED && D0_D0_ENABLED
265 2 : character(:,SKC), allocatable :: array, pattern
266 : character(1,SKC), parameter :: lower = SKC_"a", upper = SKC_"d"
267 : #elif SK_ENABLED && D1_D0_ENABLED
268 2 : character(2,SKC), allocatable :: array(:), pattern
269 : character(2,SKC), parameter :: lower = SKC_"aa", upper = SKC_"dd"
270 : #elif IK_ENABLED && D1_D0_ENABLED
271 10 : integer(IKC) , allocatable :: array(:), pattern
272 : integer(IKC) , parameter :: lower = 0_IKC, upper = 10_IKC
273 : #elif LK_ENABLED && D1_D0_ENABLED
274 10 : logical(LKC) , allocatable :: array(:), pattern
275 : logical(LKC) , parameter :: lower = .false._LKC, upper = .true._LKC
276 : #elif CK_ENABLED && D1_D0_ENABLED
277 8 : complex(CKC) , allocatable :: array(:), pattern
278 : complex(CKC) , parameter :: lower = (-1._CKC, -1._CKC), upper = (1._CKC, 1._CKC)
279 : #elif RK_ENABLED && D1_D0_ENABLED
280 8 : real(RKC) , allocatable :: array(:), pattern
281 : real(RKC) , parameter :: lower = -1._RKC, upper = 1._RKC
282 : #elif SK_ENABLED && D1_D1_ENABLED
283 : character(2,SKC), allocatable :: array(:), pattern(:)
284 : character(2,SKC), parameter :: lower = SKC_"aa", upper = SKC_"dd"
285 : #elif IK_ENABLED && D1_D1_ENABLED
286 : integer(IKC) , allocatable :: array(:), pattern(:)
287 : integer(IKC) , parameter :: lower = 0_IKC, upper = 10_IKC
288 : #elif LK_ENABLED && D1_D1_ENABLED
289 : logical(LKC) , allocatable :: array(:), pattern(:)
290 : logical(LKC) , parameter :: lower = .false._LKC, upper = .true._LKC
291 : #elif CK_ENABLED && D1_D1_ENABLED
292 : complex(CKC) , allocatable :: array(:), pattern(:)
293 : complex(CKC) , parameter :: lower = (-1._CKC, -1._CKC), upper = (1._CKC, 1._CKC)
294 : #elif RK_ENABLED && D1_D1_ENABLED
295 : real(RKC) , allocatable :: array(:), pattern(:)
296 : real(RKC) , parameter :: lower = -1._RKC, upper = 1._RKC
297 : #else
298 : #error "Unrecognized interface."
299 : #endif
300 :
301 : #if getSIL_ENABLED
302 : #define GETSIX getSIL
303 : #elif getSIR_ENABLED
304 : #define GETSIX getSIR
305 : #endif
306 : #if D1_D0_ENABLED
307 : #define ISEQ iseqVec
308 : #endif
309 : #if LK_ENABLED
310 : #define IS_EQUAL .eqv.
311 : #else
312 : #define IS_EQUAL ==
313 : #endif
314 : #if SK_ENABLED && D0_D0_ENABLED
315 : #define GET_SIZE len
316 : #else
317 : #define GET_SIZE size
318 : #endif
319 : #if getSIL_ENABLED
320 : character(*, SK), parameter :: PROCEDURE_NAME = "@getSIL()"
321 : #elif getSIR_ENABLED
322 : character(*, SK), parameter :: PROCEDURE_NAME = "@getSIR()"
323 : #endif
324 : integer(IK) :: index, index_ref
325 :
326 78 : assertion = .true._LK
327 78 : call runTestsWith()
328 78 : call runTestsWith(iseq)
329 :
330 : contains
331 :
332 156 : subroutine runTestsWith(iseq)
333 : logical(LK), external, optional :: iseq
334 :
335 : #if D1_D0_ENABLED
336 :
337 : integer(IK) :: i
338 15276 : do i = 1_IK, 200_IK
339 15200 : call reset()
340 796034 : array = getUnifRand(lower, upper, s1 = getUnifRand(0_IK, 100_IK))
341 15200 : pattern = getUnifRand(lower, upper)
342 15276 : call report(__LINE__, iseq)
343 : end do
344 :
345 : #elif D0_D0_ENABLED || D1_D1_ENABLED
346 :
347 : !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
348 :
349 80 : call reset()
350 : #if SK_ENABLED && D0_D0_ENABLED
351 4 : array = SKC_""
352 4 : pattern = SKC_""
353 : #elif SK_ENABLED && D1_D1_ENABLED
354 4 : allocate(character(2,SKC) :: array(0), pattern(0))
355 : #elif IK_ENABLED && D1_D1_ENABLED
356 20 : allocate(array(0), pattern(0))
357 : #elif LK_ENABLED && D1_D1_ENABLED
358 20 : allocate(array(0), pattern(0))
359 : #elif CK_ENABLED && D1_D1_ENABLED
360 16 : allocate(array(0), pattern(0))
361 : #elif RK_ENABLED && D1_D1_ENABLED
362 16 : allocate(array(0), pattern(0))
363 : #endif
364 :
365 : #if getSIL_ENABLED
366 40 : index_ref = 1_IK
367 : #elif getSIR_ENABLED
368 40 : index_ref = 0_IK
369 : #endif
370 80 : call report(__LINE__, iseq)
371 :
372 : !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
373 :
374 80 : call reset()
375 :
376 : #if SK_ENABLED && D0_D0_ENABLED
377 4 : array = SKC_"aaabb"
378 4 : pattern = SKC_""
379 : #elif SK_ENABLED && D1_D1_ENABLED
380 28 : array = [character(2,SKC) :: "aa", "aa", "aa", "bb", "bb"]
381 4 : pattern = [character(2,SKC) ::]
382 : #elif IK_ENABLED && D1_D1_ENABLED
383 140 : array = [integer(IKC) :: 1, 1, 1, 2, 2]
384 20 : pattern = [integer(IKC) ::]
385 : #elif LK_ENABLED && D1_D1_ENABLED
386 140 : array = [logical(LKC) :: .false., .false., .false., .true., .true.]
387 20 : pattern = [logical(LKC) ::]
388 : #elif CK_ENABLED && D1_D1_ENABLED
389 112 : array = [complex(CKC) :: 1, 1, 1, 2, 2]
390 16 : pattern = [complex(CKC) ::]
391 : #elif RK_ENABLED && D1_D1_ENABLED
392 112 : array = [real(RKC) :: 1, 1, 1, 2, 2]
393 16 : pattern = [real(RKC) ::]
394 : #endif
395 :
396 : #if getSIL_ENABLED
397 40 : index_ref = 1_IK
398 : #elif getSIR_ENABLED
399 40 : index_ref = 5_IK
400 40 : call setReversed(array)
401 : #endif
402 80 : call report(__LINE__, iseq)
403 :
404 : !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
405 :
406 80 : call reset()
407 :
408 : #if SK_ENABLED && D0_D0_ENABLED
409 4 : array = SKC_"aaabb"
410 4 : pattern = SKC_"a"
411 : #elif SK_ENABLED && D1_D1_ENABLED
412 28 : array = [character(2,SKC) :: "aa", "aa", "aa", "bb", "bb"]
413 12 : pattern = [character(2,SKC) :: "aa"]
414 : #elif IK_ENABLED && D1_D1_ENABLED
415 140 : array = [integer(IKC) :: 1, 1, 1, 2, 2]
416 60 : pattern = [integer(IKC) :: 1]
417 : #elif LK_ENABLED && D1_D1_ENABLED
418 140 : array = [logical(LKC) :: .false., .false., .false., .true., .true.]
419 60 : pattern = [logical(LKC) :: .false.]
420 : #elif CK_ENABLED && D1_D1_ENABLED
421 112 : array = [complex(CKC) :: 1, 1, 1, 2, 2]
422 48 : pattern = [complex(CKC) :: 1]
423 : #elif RK_ENABLED && D1_D1_ENABLED
424 112 : array = [real(RKC) :: 1, 1, 1, 2, 2]
425 48 : pattern = [real(RKC) :: 1]
426 : #endif
427 :
428 : #if getSIL_ENABLED
429 40 : index_ref = 4_IK
430 : #elif getSIR_ENABLED
431 40 : index_ref = 2_IK
432 40 : call setReversed(array)
433 : #endif
434 80 : call report(__LINE__, iseq)
435 :
436 : !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
437 :
438 80 : call reset()
439 :
440 : #if SK_ENABLED && D0_D0_ENABLED
441 4 : array = SKC_"aaabb"
442 4 : pattern = SKC_"aa"
443 : #elif SK_ENABLED && D1_D1_ENABLED
444 28 : array = [character(2,SKC) :: "aa", "aa", "aa", "bb", "bb"]
445 16 : pattern = [character(2,SKC) :: "aa", "aa"]
446 : #elif IK_ENABLED && D1_D1_ENABLED
447 140 : array = [integer(IKC) :: 1, 1, 1, 2, 2]
448 80 : pattern = [integer(IKC) :: 1, 1]
449 : #elif LK_ENABLED && D1_D1_ENABLED
450 140 : array = [logical(LKC) :: .false., .false., .false., .true., .true.]
451 80 : pattern = [logical(LKC) :: .false., .false.]
452 : #elif CK_ENABLED && D1_D1_ENABLED
453 112 : array = [complex(CKC) :: 1, 1, 1, 2, 2]
454 64 : pattern = [complex(CKC) :: 1, 1]
455 : #elif RK_ENABLED && D1_D1_ENABLED
456 112 : array = [real(RKC) :: 1, 1, 1, 2, 2]
457 64 : pattern = [real(RKC) :: 1, 1]
458 : #endif
459 :
460 : #if getSIL_ENABLED
461 40 : index_ref = 3_IK
462 : #elif getSIR_ENABLED
463 40 : index_ref = 3_IK
464 40 : call setReversed(array)
465 : #endif
466 80 : call report(__LINE__, iseq)
467 :
468 : !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
469 :
470 80 : call reset()
471 :
472 : #if SK_ENABLED && D0_D0_ENABLED
473 4 : array = SKC_"aaabb"
474 4 : pattern = SKC_"b"
475 : #elif SK_ENABLED && D1_D1_ENABLED
476 28 : array = [character(2,SKC) :: "aa", "aa", "aa", "bb", "bb"]
477 12 : pattern = [character(2,SKC) :: "bb"]
478 : #elif IK_ENABLED && D1_D1_ENABLED
479 140 : array = [integer(IKC) :: 1, 1, 1, 2, 2]
480 60 : pattern = [integer(IKC) :: 2]
481 : #elif LK_ENABLED && D1_D1_ENABLED
482 140 : array = [logical(LKC) :: .false., .false., .false., .true., .true.]
483 60 : pattern = [logical(LKC) :: .true.]
484 : #elif CK_ENABLED && D1_D1_ENABLED
485 112 : array = [complex(CKC) :: 1, 1, 1, 2, 2]
486 48 : pattern = [complex(CKC) :: 2]
487 : #elif RK_ENABLED && D1_D1_ENABLED
488 112 : array = [real(RKC) :: 1, 1, 1, 2, 2]
489 48 : pattern = [real(RKC) :: 2]
490 : #endif
491 :
492 : #if getSIL_ENABLED
493 40 : index_ref = 1_IK
494 : #elif getSIR_ENABLED
495 40 : index_ref = 5_IK
496 40 : call setReversed(array)
497 : #endif
498 80 : call report(__LINE__, iseq)
499 :
500 : !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
501 :
502 80 : call reset()
503 :
504 : #if SK_ENABLED && D0_D0_ENABLED
505 4 : array = SKC_"aaabb"
506 4 : pattern = SKC_"bb"
507 : #elif SK_ENABLED && D1_D1_ENABLED
508 28 : array = [character(2,SKC) :: "aa", "aa", "aa", "bb", "bb"]
509 16 : pattern = [character(2,SKC) :: "bb", "bb"]
510 : #elif IK_ENABLED && D1_D1_ENABLED
511 140 : array = [integer(IKC) :: 1, 1, 1, 2, 2]
512 80 : pattern = [integer(IKC) :: 2, 2]
513 : #elif LK_ENABLED && D1_D1_ENABLED
514 140 : array = [logical(LKC) :: .false., .false., .false., .true., .true.]
515 80 : pattern = [logical(LKC) :: .true., .true.]
516 : #elif CK_ENABLED && D1_D1_ENABLED
517 112 : array = [complex(CKC) :: 1, 1, 1, 2, 2]
518 64 : pattern = [complex(CKC) :: 2, 2]
519 : #elif RK_ENABLED && D1_D1_ENABLED
520 112 : array = [real(RKC) :: 1, 1, 1, 2, 2]
521 64 : pattern = [real(RKC) :: 2, 2]
522 : #endif
523 :
524 : #if getSIL_ENABLED
525 40 : index_ref = 1_IK
526 : #elif getSIR_ENABLED
527 40 : index_ref = 5_IK
528 40 : call setReversed(array)
529 : #endif
530 80 : call report(__LINE__, iseq)
531 :
532 : !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
533 :
534 80 : call reset()
535 :
536 : #if SK_ENABLED && D0_D0_ENABLED
537 4 : array = SKC_"aaabb"
538 : #elif SK_ENABLED && D1_D1_ENABLED
539 28 : array = [character(2,SKC) :: "aa", "aa", "aa", "bb", "bb"]
540 : #elif IK_ENABLED && D1_D1_ENABLED
541 140 : array = [integer(IKC) :: 1, 1, 1, 2, 2]
542 : #elif LK_ENABLED && D1_D1_ENABLED
543 140 : array = [logical(LKC) :: .false., .false., .false., .true., .true.]
544 : #elif CK_ENABLED && D1_D1_ENABLED
545 112 : array = [complex(CKC) :: 1, 1, 1, 2, 2]
546 : #elif RK_ENABLED && D1_D1_ENABLED
547 112 : array = [real(RKC) :: 1, 1, 1, 2, 2]
548 : #endif
549 :
550 : #if getSIL_ENABLED
551 40 : index_ref = 6_IK
552 : #elif getSIR_ENABLED
553 40 : index_ref = 0_IK
554 40 : call setReversed(array)
555 : #endif
556 612 : pattern = array
557 80 : call report(__LINE__, iseq)
558 :
559 : !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
560 :
561 80 : call reset()
562 :
563 : #if SK_ENABLED && D0_D0_ENABLED
564 4 : array = SKC_"aaabb"
565 4 : pattern = array//array
566 : #elif SK_ENABLED && D1_D1_ENABLED
567 28 : array = [character(2,SKC) :: "aa", "aa", "aa", "bb", "bb"]
568 96 : pattern = [array, array]
569 : #elif IK_ENABLED && D1_D1_ENABLED
570 140 : array = [integer(IKC) :: 1, 1, 1, 2, 2]
571 480 : pattern = [array, array]
572 : #elif LK_ENABLED && D1_D1_ENABLED
573 140 : array = [logical(LKC) :: .false., .false., .false., .true., .true.]
574 480 : pattern = [array, array]
575 : #elif CK_ENABLED && D1_D1_ENABLED
576 112 : array = [complex(CKC) :: 1, 1, 1, 2, 2]
577 384 : pattern = [array, array]
578 : #elif RK_ENABLED && D1_D1_ENABLED
579 112 : array = [real(RKC) :: 1, 1, 1, 2, 2]
580 384 : pattern = [array, array]
581 : #endif
582 :
583 : #if getSIL_ENABLED
584 40 : index_ref = 1_IK
585 : #elif getSIR_ENABLED
586 40 : index_ref = 5_IK
587 40 : call setReversed(array)
588 : #endif
589 80 : call report(__LINE__, iseq)
590 :
591 : !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
592 :
593 : #else
594 : #error "Unrecognized interface."
595 : #endif
596 :
597 156 : end subroutine
598 :
599 : !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
600 :
601 15840 : subroutine report(line, iseq)
602 : integer , intent(in) :: line
603 : logical(LK) , external, optional :: iseq
604 :
605 15840 : if (present(iseq)) then
606 :
607 : #if D1_D0_ENABLED
608 15200 : index_ref = GETSIX(array, [pattern], ISEQ) ! fpp
609 : #endif
610 7920 : index = GETSIX(array, pattern, iseq)
611 : else
612 : #if D1_D0_ENABLED
613 15200 : index_ref = GETSIX(array, [pattern])
614 : #endif
615 7920 : index = GETSIX(array, pattern)
616 : end if
617 15840 : assertion = assertion .and. logical(index == index_ref, LK)
618 15840 : if (test%traceable .and. .not. assertion) then
619 : ! LCOV_EXCL_START
620 : call test%disp%skip()
621 : call test%disp%show("index_ref")
622 : call test%disp%show( index_ref )
623 : call test%disp%show("index")
624 : call test%disp%show( index )
625 : call test%disp%show("array")
626 : call test%disp%show( array )
627 : call test%disp%show("pattern")
628 : call test%disp%show( pattern )
629 : call test%disp%show("present(iseq)")
630 : call test%disp%show( present(iseq) )
631 : call test%disp%skip()
632 : ! LCOV_EXCL_STOP
633 : end if
634 15840 : call test%assert(assertion, PROCEDURE_NAME//SK_": The `index` of the stripped array must be computed correctly.", int(line, IK))
635 15840 : end subroutine
636 :
637 : !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
638 :
639 : #if D0_D0_ENABLED
640 18 : function iseq(Segment, pattern) result(equivalent)
641 : character(*,SKC), intent(in) :: pattern, Segment
642 : logical(LK) :: equivalent
643 18 : equivalent = Segment == pattern
644 18 : end function
645 : #elif D1_D0_ENABLED || D1_D1_ENABLED
646 : #if D1_D0_ENABLED
647 9712 : function iseq(Segment, pattern) result(equivalent)
648 : #if SK_ENABLED
649 : character(*,SKC), intent(in) :: Segment, pattern
650 : #elif IK_ENABLED
651 : integer(IKC) , intent(in) :: Segment, pattern
652 : #elif LK_ENABLED
653 : logical(LKC) , intent(in) :: Segment, pattern
654 : #elif CK_ENABLED
655 : complex(CKC) , intent(in) :: Segment, pattern
656 : #elif RK_ENABLED
657 : real(RKC) , intent(in) :: Segment, pattern
658 : #endif
659 : logical(LK) :: equivalent
660 9712 : equivalent = Segment IS_EQUAL pattern
661 9712 : end function
662 : #endif
663 10054 : function ISEQ(Segment, pattern, lenPattern) result(equivalent) ! fpp
664 : logical(LK) :: equivalent
665 : integer(IK), intent(in) :: lenPattern
666 : #if SK_ENABLED
667 : character(*,SKC), intent(in) :: Segment(lenPattern), pattern(lenPattern)
668 : #elif IK_ENABLED
669 : integer(IKC) , intent(in) :: Segment(lenPattern), pattern(lenPattern)
670 : #elif LK_ENABLED
671 : logical(LKC) , intent(in) :: Segment(lenPattern), pattern(lenPattern)
672 : #elif CK_ENABLED
673 : complex(CKC) , intent(in) :: Segment(lenPattern), pattern(lenPattern)
674 : #elif RK_ENABLED
675 : real(RKC) , intent(in) :: Segment(lenPattern), pattern(lenPattern)
676 : #endif
677 12649 : equivalent = all(Segment IS_EQUAL pattern)
678 10054 : end function
679 : #else
680 : #error "Unrecognized interface."
681 : #endif
682 15840 : subroutine reset()
683 15840 : if (allocated(array)) deallocate(array)
684 15840 : if (allocated(pattern)) deallocate(pattern)
685 15840 : end subroutine
686 : #undef IS_EQUAL
687 : #undef GET_SIZE
688 : #undef ISEQ
689 : #undef ALL
690 :
691 : #else
692 : !%%%%%%%%%%%%%%%%%%%%%%%%
693 : #error "Unrecognized interface."
694 : !%%%%%%%%%%%%%%%%%%%%%%%%
695 : #endif
696 :
697 : #undef GET_REPEAT
698 : #undef SIDE_TYPE
699 : #undef IS_EQUAL
700 : #undef GET_SIZE
701 : #undef GETSIX
702 : #undef ISEQ
703 : #undef ALL
|
