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 of [pm_arrayResize](@ref pm_arrayResize).
19 : !>
20 : !> \fintest
21 : !>
22 : !> \author
23 : !> \FatemehBagheri, Wednesday 12:20 AM, October 13, 2021, Dallas, TX
24 :
25 : !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
26 :
27 : ! Bypass gfortran bug 10-12.
28 : #if setResized_D1_SK_ENABLED || setResized_D2_SK_ENABLED || setResized_D3_SK_ENABLED
29 : #define TYPE_KIND character(2,SKC) ::
30 : #else
31 : #define TYPE_KIND
32 : #endif
33 :
34 : #if setResized_D1_LK_ENABLED || setResized_D2_LK_ENABLED || setResized_D3_LK_ENABLED
35 : #define IS_EQUAL .eqv.
36 : #else
37 : #define IS_EQUAL ==
38 : #endif
39 :
40 : #if setResized_D0_ENABLED || setResized_D1_ENABLED
41 : #define SET_BND(X,lb,ub) X(lb : ub)
42 : #define SET_DIM(X) X(:)
43 : #define SET_SIZE(X) X
44 : #elif setResized_D2_ENABLED
45 : #define SET_BND(X,lb,ub) X(lb(1) : ub(1), lb(2) : ub(2))
46 : #define SET_SIZE(X) X(rank(array))
47 : #define SET_DIM(X) X(:,:)
48 : #elif setResized_D3_ENABLED
49 : #define SET_BND(X,lb,ub) X(lb(1) : ub(1), lb(2) : ub(2), lb(3) : ub(3))
50 : #define SET_SIZE(X) X(rank(array))
51 : #define SET_DIM(X) X(:,:,:)
52 : #else
53 : #error "Unrecognized interface."
54 : #endif
55 :
56 : #if setResized_D0_ENABLED
57 : integer(IK) , parameter :: lbmin = +1_IK, ubmax = +15_IK
58 1 : character(:,SKC), allocatable :: array, arrayInit, array_ref, lower, upper
59 : character(1,SKC), parameter :: fill = SKC_"-"
60 : #define GET_UBOUND(X) len(X, kind = IK)
61 : #define GET_LBOUND(X) 1
62 : #define ALL
63 : #else
64 : #define GET_LBOUND(X) lbound(X, kind = IK)
65 : #define GET_UBOUND(X) ubound(X, kind = IK)
66 : integer(IK) , parameter :: lbmin = -5_IK, ubmax = +10_IK
67 : #if setResized_D1_SK_ENABLED || setResized_D2_SK_ENABLED || setResized_D3_SK_ENABLED
68 : character(2,SKC), allocatable :: SET_DIM(array), SET_DIM(arrayInit), SET_DIM(array_ref)
69 : character(2,SKC), parameter :: fill = SKC_"--", lower = SKC_"aa", upper = SKC_"zz"
70 : #elif setResized_D1_IK_ENABLED || setResized_D2_IK_ENABLED || setResized_D3_IK_ENABLED
71 : integer(IKC) , allocatable :: SET_DIM(array), SET_DIM(arrayInit), SET_DIM(array_ref)
72 : integer(IKC) , parameter :: fill = huge(0_IKC), lower = -huge(0_IKC), upper = huge(0_IKC)
73 : #elif setResized_D1_LK_ENABLED || setResized_D2_LK_ENABLED || setResized_D3_LK_ENABLED
74 : logical(LKC) , allocatable :: SET_DIM(array), SET_DIM(arrayInit), SET_DIM(array_ref)
75 : logical(LKC) , parameter :: fill = .false._LKC, lower = .false._LKC, upper = .true._LKC
76 : #elif setResized_D1_CK_ENABLED || setResized_D2_CK_ENABLED || setResized_D3_CK_ENABLED
77 : complex(CKC) , allocatable :: SET_DIM(array), SET_DIM(arrayInit), SET_DIM(array_ref)
78 : complex(CKC) , parameter :: fill = cmplx(huge(0._CKC), huge(0._CKC), kind = CKC)
79 : complex(CKC) , parameter :: lower = -fill, upper = fill
80 : #elif setResized_D1_RK_ENABLED || setResized_D2_RK_ENABLED || setResized_D3_RK_ENABLED
81 : real(RKC) , allocatable :: SET_DIM(array), SET_DIM(arrayInit), SET_DIM(array_ref)
82 : real(RKC) , parameter :: fill = huge(0._RKC)
83 : real(RKC) , parameter :: lower = -fill, upper = fill
84 : #else
85 : #error "Unrecognized interface."
86 : #endif
87 : #endif
88 : character(127, SK) :: errmsg
89 : integer(IK) :: SET_SIZE(lb)
90 : integer(IK) :: SET_SIZE(ub)
91 : integer(IK) :: SET_SIZE(lbc)
92 : integer(IK) :: SET_SIZE(lbold)
93 : integer(IK) :: SET_SIZE(ubold)
94 : integer(IK) :: SET_SIZE(lbcold)
95 : integer(IK) :: SET_SIZE(ubcold)
96 : logical(LK) :: assumedSize
97 : integer :: itest
98 : logical(LK) :: failed
99 58 : type(display_type) :: disp
100 58 : disp = display_type()
101 58 : assertion = .true._LK
102 :
103 5858 : do itest = 1, 100
104 5800 : call runTestsWith()
105 5800 : call runTestsWith(failed)
106 5800 : call runTestsWith(errmsg = errmsg)
107 11658 : call runTestsWith(failed, errmsg)
108 : end do
109 :
110 : ! Test with unallocated input `array`.
111 58 : call runTestsWithUnalloc()
112 58 : call runTestsWithUnalloc(failed)
113 58 : call runTestsWithUnalloc(errmsg = errmsg)
114 58 : call runTestsWithUnalloc(failed, errmsg)
115 :
116 : !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
117 :
118 : contains
119 :
120 : !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
121 :
122 41334 : subroutine checkFailure(line, failed, errmsg)
123 : integer, intent(in) :: line
124 : logical(LK), intent(in), optional :: failed
125 : character(*, SK), intent(in), optional :: errmsg
126 41334 : if (present(failed)) then
127 20708 : assertion = assertion .and. .not. failed
128 62124 : call test%assert(assertion, SK_"The `array` resizing must not fail with present(failed), present(errmsg) = "//getStr([present(failed), present(errmsg)]), int(line, IK))
129 : end if
130 41334 : end subroutine
131 :
132 : !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
133 :
134 232 : subroutine runTestsWithUnalloc(failed, errmsg)
135 : logical(LK), intent(out), optional :: failed
136 : character(*, SK), intent(out), optional :: errmsg
137 232 : if (allocated(array_ref)) deallocate(array_ref)
138 612 : lb = 1_IK
139 612 : call setUnifRand(ub, lb - 1_IK, ubmax)
140 : #if setResized_D0_ENABLED
141 4 : allocate(character(ub,SKC) :: array_ref)
142 : #else
143 578 : allocate(TYPE_KIND SET_BND(array_ref, lb, ub))
144 : #endif
145 232 : if (allocated(array)) deallocate(array)
146 844 : call setResized(array, ub - lb + 1_IK, failed, errmsg)
147 232 : call checkFailure(__LINE__, failed, errmsg)
148 1183 : assertion = assertion .and. ALL(GET_LBOUND(array) == GET_LBOUND(array_ref))
149 : call test%assert(assertion, SK_"The lower bounds of the output `array` must be correctly set when the input `array` is unallocated with present(failed), present(errmsg), LBOUND(array), LBOUND(array_ref) = "// & ! LCOV_EXCL_LINE
150 2748 : getStr([present(failed), present(errmsg)])//SK_", "//getStr([GET_LBOUND(array), GET_LBOUND(array_ref)]), int(__LINE__, IK))
151 1183 : assertion = assertion .and. ALL(GET_UBOUND(array) == GET_UBOUND(array_ref))
152 : call test%assert(assertion, SK_"The upper bounds of the output `array` must be correctly set when the input `array` is unallocated with present(failed), present(errmsg), UBOUND(array), UBOUND(array_ref) = "// & ! LCOV_EXCL_LINE
153 2756 : getStr([present(failed), present(errmsg)])//SK_", "//getStr([GET_UBOUND(array), GET_UBOUND(array_ref)]), int(__LINE__, IK))
154 232 : end subroutine
155 :
156 : !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
157 :
158 23200 : subroutine runTestsWith(failed, errmsg)
159 :
160 : logical(LK), intent(out), optional :: failed
161 : character(*, SK), intent(out), optional :: errmsg
162 :
163 23200 : if (allocated(arrayInit)) deallocate(arrayInit)
164 23200 : if (allocated(array_ref)) deallocate(array_ref)
165 :
166 : ! Test the missing `size` interface.
167 23200 : assumedSize = logical(getUnifRand(0., 1.) < 0.1, LK)
168 : #if setResized_D0_ENABLED
169 400 : lb = 1_IK
170 400 : lbold = 1_IK
171 400 : call setUnifRand(ubold, lbold, ubmax)
172 400 : if (assumedSize) then
173 38 : ub = ubold * 2_IK
174 : else
175 362 : call setUnifRand(ub, lb, 2 * ubmax)
176 : end if
177 400 : allocate(character(ub,SKC) :: array_ref)
178 400 : allocate(character(ubold,SKC) :: arrayInit)
179 3594 : lower = repeat(SKC_"a", len(arrayInit))
180 3594 : upper = repeat(SKC_"z", len(arrayInit))
181 : #else
182 60800 : call setUnifRand(lbold, lbmin, ubmax)
183 60800 : call setUnifRand(ubold, lbold, ubmax)
184 22800 : lb = lbold ! call setUnifRand(lb, -15_IK, +5_IK)
185 22800 : if (assumedSize) then
186 6087 : ub = lb + (ubold - lbold + 1_IK) * 2_IK - 1_IK
187 : else
188 54713 : call setUnifRand(ub, lb, 2 * ubmax)
189 : end if
190 59200 : allocate(TYPE_KIND SET_BND(array_ref, lb, ub))
191 59200 : allocate(TYPE_KIND SET_BND(arrayInit, lbold, ubold))
192 : #endif
193 1263319 : call setUnifRand(arrayInit, lower, upper)
194 309099 : if (all([lb] <= [lbold]) .and. all([ubold] <= [ub]) .and. getUnifRand()) then
195 8362 : if (assumedSize) then
196 : ! Test the expansion interface without `size`.
197 1178 : lbc = lbold
198 1178 : lbcold = lbold
199 1178 : ubcold = ubold
200 1178 : if (allocated(array)) deallocate(array)
201 64940 : allocate(array, source = arrayInit)
202 3109 : call setCoreHalo(array_ref, array, fill, lbc - lb)
203 : !write(*,*) "lb, ub", lb, ub
204 2332 : call setResized(array, failed, errmsg)
205 1178 : call report(__LINE__, failed, errmsg)
206 : end if
207 : ! Test the expansion interface.
208 8362 : lbc = lbold
209 8362 : lbcold = lbold
210 8362 : ubcold = ubold
211 8362 : if (allocated(array)) deallocate(array)
212 302935 : allocate(array, source = arrayInit)
213 20595 : call setCoreHalo(array_ref, array, fill, lbc - lb)
214 : !write(*,*) "lb, ub", lb, ub
215 29031 : call setResized(array, ub - lb + 1_IK, failed, errmsg)
216 8362 : call report(__LINE__, failed, errmsg)
217 : ! Test the expansion + shift interface.
218 20595 : call setUnifRand(lbc, lb, ub - (ubcold - lbcold))
219 : !write(*,*) "lb, ub, lbc, lbcold, ubcold", lb, ub, lbc, lbcold, ubcold
220 8362 : if (allocated(array)) deallocate(array)
221 302935 : allocate(array, source = arrayInit)
222 20595 : call setCoreHalo(array_ref, array, fill, lbc - lb)
223 20595 : call setResized(array, ub - lb + 1_IK, lbc, failed, errmsg)
224 8362 : call report(__LINE__, failed, errmsg)
225 : end if
226 : ! Test the expansion/contraction + shift + subset interface.
227 23200 : if (allocated(array)) deallocate(array)
228 1305319 : allocate(array, source = arrayInit)
229 61200 : call setUnifRand(lbcold, lbold, ubold)
230 61200 : call setUnifRand(ubcold, lbcold, min(ubold, lbcold + min(ubold - lbold, ub - lb)))
231 61200 : call setUnifRand(lbc, lb, ub - (ubcold - lbcold))
232 : !write(*,*) "GET_LBOUND(array), GET_UBOUND(array), lbcold, ubcold", GET_LBOUND(array), GET_UBOUND(array), lbcold, ubcold
233 : !write(*,*) "SET_BND(array, lbcold, ubcold)", SET_BND(array, lbcold, ubcold)
234 : !write(*,*) "array_ref", array_ref
235 192304 : call setCoreHalo(array_ref, SET_BND(array, lbcold, ubcold), fill, lbc - lb)
236 : !write(*,*) "array_ref, lb, ub, lbc, lbcold, ubcold", array_ref, lb, ub, lbc, lbcold, ubcold
237 84400 : call setResized(array, ub - lb + 1_IK, lbc, lbcold, ubcold, failed, errmsg)
238 23200 : call report(__LINE__, failed, errmsg)
239 :
240 23200 : end subroutine
241 :
242 : !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
243 :
244 41102 : subroutine report(line, failed, errmsg)
245 : integer, intent(in) :: line
246 : logical(LK), intent(in), optional :: failed
247 : character(*, SK), intent(in), optional :: errmsg
248 82328 : call checkFailure(line, failed, errmsg)
249 212387 : assertion = assertion .and. ALL(GET_LBOUND(array) == GET_LBOUND(array_ref))
250 41102 : call display()
251 123306 : call test%assert(assertion, SK_"The lower bounds of the output `array` must be correctly set with present(failed), present(errmsg) = "//getStr([present(failed), present(errmsg)]), int(line, IK))
252 212387 : assertion = assertion .and. ALL(GET_UBOUND(array) == GET_UBOUND(array_ref))
253 41102 : call display()
254 123306 : call test%assert(assertion, SK_"The upper bounds of the output `array` must be correctly set with present(failed), present(errmsg) = "//getStr([present(failed), present(errmsg)]), int(line, IK))
255 : #if setResized_D0_ENABLED || \
256 : setResized_D1_ENABLED
257 : assertion = assertion .and. all([array(lbc : lbc - lbcold + ubcold)] IS_EQUAL & ! LCOV_EXCL_LINE
258 : [array_ref(lbc : lbc - lbcold + ubcold)] & ! LCOV_EXCL_LINE
259 172135 : )
260 : #elif setResized_D2_ENABLED
261 : assertion = assertion .and. all(array(lbc(1) : lbc(1) - lbcold(1) + ubcold(1), lbc(2) : lbc(2) - lbcold(2) + ubcold(2)) IS_EQUAL & ! LCOV_EXCL_LINE
262 : array_ref(lbc(1) : lbc(1) - lbcold(1) + ubcold(1), lbc(2) : lbc(2) - lbcold(2) + ubcold(2)) & ! LCOV_EXCL_LINE
263 178454 : )
264 : #elif setResized_D3_ENABLED
265 : assertion = assertion .and. all(array(lbc(1) : lbc(1) - lbcold(1) + ubcold(1), lbc(2) : lbc(2) - lbcold(2) + ubcold(2), lbc(3) : lbc(3) - lbcold(3) + ubcold(3)) IS_EQUAL & ! LCOV_EXCL_LINE
266 : array_ref(lbc(1) : lbc(1) - lbcold(1) + ubcold(1), lbc(2) : lbc(2) - lbcold(2) + ubcold(2), lbc(3) : lbc(3) - lbcold(3) + ubcold(3)) & ! LCOV_EXCL_LINE
267 564461 : )
268 : #else
269 : #error "Unrecognized interface."
270 : #endif
271 41102 : call display()
272 123306 : call test%assert(assertion, SK_"Call to setResized() must correctly rebind and refill `array` with present(failed), present(errmsg) = "//getStr([present(failed), present(errmsg)]), int(line, IK))
273 41102 : end subroutine
274 :
275 : !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
276 :
277 123306 : subroutine display()
278 123306 : if (test%traceable .and. .not. assertion) then
279 : ! LCOV_EXCL_START
280 : call disp%skip()
281 : call disp%show("rank(array)")
282 : call disp%show( rank(array) )
283 : call disp%show("lbold")
284 : call disp%show( lbold )
285 : call disp%show("ubold")
286 : call disp%show( ubold )
287 : call disp%show("lb")
288 : call disp%show( lb )
289 : call disp%show("ub")
290 : call disp%show( ub )
291 : call disp%show("lbc")
292 : call disp%show( lbc )
293 : call disp%show("lbcold")
294 : call disp%show( lbcold )
295 : call disp%show("ubcold")
296 : call disp%show( ubcold )
297 : call disp%show("arrayInit")
298 : call disp%show( arrayInit )
299 : call disp%show("array_ref")
300 : call disp%show( array_ref )
301 : call disp%show("array")
302 : call disp%show( array )
303 : call disp%show("array == array_ref")
304 : call disp%show( array IS_EQUAL array_ref )
305 : call disp%skip()
306 : ! LCOV_EXCL_STOP
307 : end if
308 123306 : end subroutine
309 :
310 : !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
311 :
312 : #undef GET_LBOUND
313 : #undef GET_UBOUND
314 : #undef TYPE_KIND
315 : #undef IS_EQUAL
316 : #undef SET_SIZE
317 : #undef SET_BND
318 : #undef SET_DIM
319 : #undef ALL
|
