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_arrayRefill](@ref pm_arrayRefill).
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 setRefilled_D1_SK_ENABLED || setRefilled_D2_SK_ENABLED || setRefilled_D3_SK_ENABLED
29 : #define TYPE_KIND character(2,SKC) ::
30 : #else
31 : #define TYPE_KIND
32 : #endif
33 :
34 : #if setRefilled_D1_LK_ENABLED || setRefilled_D2_LK_ENABLED || setRefilled_D3_LK_ENABLED
35 : #define IS_EQUAL .eqv.
36 : #else
37 : #define IS_EQUAL ==
38 : #endif
39 :
40 : #if setRefilled_D0_ENABLED || setRefilled_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 setRefilled_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 setRefilled_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 setRefilled_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 setRefilled_D1_SK_ENABLED || setRefilled_D2_SK_ENABLED || setRefilled_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 setRefilled_D1_IK_ENABLED || setRefilled_D2_IK_ENABLED || setRefilled_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 setRefilled_D1_LK_ENABLED || setRefilled_D2_LK_ENABLED || setRefilled_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 setRefilled_D1_CK_ENABLED || setRefilled_D2_CK_ENABLED || setRefilled_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 setRefilled_D1_RK_ENABLED || setRefilled_D2_RK_ENABLED || setRefilled_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 : logical(LK) :: failed
90 : integer(IK) :: SET_SIZE(lb)
91 : integer(IK) :: SET_SIZE(ub)
92 : integer(IK) :: SET_SIZE(lbc)
93 : integer(IK) :: SET_SIZE(lbold)
94 : integer(IK) :: SET_SIZE(ubold)
95 : integer(IK) :: SET_SIZE(lbcold)
96 : integer(IK) :: SET_SIZE(ubcold)
97 : logical(LK) :: assumedSize
98 : integer :: itest
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 41098 : 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 41098 : if (present(failed)) then
127 20588 : assertion = assertion .and. .not. failed
128 61764 : 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 41098 : 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 setRefilled_D0_ENABLED
141 30 : array_ref = repeat(fill, ub)
142 : #else
143 565 : allocate(TYPE_KIND SET_BND(array_ref, lb, ub))
144 16709 : array_ref = fill
145 : #endif
146 232 : if (allocated(array)) deallocate(array)
147 844 : call setRefilled(array, fill, ub - lb + 1_IK, failed, errmsg)
148 232 : call checkFailure(__LINE__, failed, errmsg)
149 1173 : assertion = assertion .and. ALL(GET_LBOUND(array) == GET_LBOUND(array_ref))
150 : 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
151 2736 : getStr([present(failed), present(errmsg)])//SK_", "//getStr([GET_LBOUND(array), GET_LBOUND(array_ref)]), int(__LINE__, IK))
152 1173 : assertion = assertion .and. ALL(GET_UBOUND(array) == GET_UBOUND(array_ref))
153 : 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
154 2744 : getStr([present(failed), present(errmsg)])//SK_", "//getStr([GET_UBOUND(array), GET_UBOUND(array_ref)]), int(__LINE__, IK))
155 16713 : assertion = assertion .and. ALL(array IS_EQUAL array_ref)
156 : #if setRefilled_D0_ENABLED
157 4 : assertion = assertion .and. len_trim(array) == len_trim(array_ref)
158 : #endif
159 696 : call test%assert(assertion, SK_"The contents of the output `array` must be correctly set when the input `array` is unallocated with present(failed), present(errmsg) = "//getStr([present(failed), present(errmsg)]), int(__LINE__, IK))
160 232 : end subroutine
161 :
162 : !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
163 :
164 23200 : subroutine runTestsWith(failed, errmsg)
165 :
166 : logical(LK), intent(out), optional :: failed
167 : character(*, SK), intent(out), optional :: errmsg
168 :
169 23200 : if (allocated(arrayInit)) deallocate(arrayInit)
170 23200 : if (allocated(array_ref)) deallocate(array_ref)
171 :
172 : ! Test the missing `size` interface.
173 23200 : assumedSize = logical(getUnifRand(0., 1.) < 0.1, LK)
174 : #if setRefilled_D0_ENABLED
175 400 : lb = 1_IK
176 400 : lbold = 1_IK
177 400 : call setUnifRand(ubold, lbold, ubmax)
178 400 : if (assumedSize) then
179 38 : ub = ubold * 2_IK
180 : else
181 362 : call setUnifRand(ub, lb, 2 * ubmax)
182 : end if
183 400 : allocate(character(ub,SKC) :: array_ref)
184 400 : allocate(character(ubold,SKC) :: arrayInit)
185 3601 : lower = repeat(SKC_"a", len(arrayInit))
186 3601 : upper = repeat(SKC_"z", len(arrayInit))
187 : #else
188 60800 : call setUnifRand(lbold, lbmin, ubmax)
189 60800 : call setUnifRand(ubold, lbold, ubmax)
190 22800 : lb = lbold ! call setUnifRand(lb, -15_IK, +5_IK)
191 22800 : if (assumedSize) then
192 6067 : ub = lb + (ubold - lbold + 1_IK) * 2_IK - 1_IK
193 : else
194 54733 : call setUnifRand(ub, lb, 2 * ubmax)
195 : end if
196 59200 : allocate(TYPE_KIND SET_BND(array_ref, lb, ub))
197 59200 : allocate(TYPE_KIND SET_BND(arrayInit, lbold, ubold))
198 : #endif
199 1291629 : call setUnifRand(arrayInit, lower, upper)
200 308945 : if (all([lb] <= [lbold]) .and. all([ubold] <= [ub]) .and. getUnifRand()) then
201 8228 : if (assumedSize) then
202 : ! Test the expansion interface without `size`.
203 1210 : lbc = lbold
204 1210 : lbcold = lbold
205 1210 : ubcold = ubold
206 1210 : if (allocated(array)) deallocate(array)
207 70735 : allocate(array, source = arrayInit)
208 3196 : call setCoreHalo(array_ref, array, fill, lbc - lb)
209 : !write(*,*) "lb, ub", lb, ub
210 2366 : call setRefilled(array, fill, failed, errmsg)
211 1210 : call report(__LINE__, failed, errmsg)
212 : end if
213 : ! Test the expansion interface.
214 8228 : lbc = lbold
215 8228 : lbcold = lbold
216 8228 : ubcold = ubold
217 8228 : if (allocated(array)) deallocate(array)
218 314449 : allocate(array, source = arrayInit)
219 20303 : call setCoreHalo(array_ref, array, fill, lbc - lb)
220 : !write(*,*) "lb, ub", lb, ub
221 28379 : call setRefilled(array, fill, ub - lb + 1_IK, failed, errmsg)
222 8228 : call report(__LINE__, failed, errmsg)
223 : ! Test the expansion + shift interface.
224 20303 : call setUnifRand(lbc, lb, ub - (ubcold - lbcold))
225 : !write(*,*) "lb, ub, lbc, lbcold, ubcold", lb, ub, lbc, lbcold, ubcold
226 8228 : if (allocated(array)) deallocate(array)
227 314449 : allocate(array, source = arrayInit)
228 20303 : call setCoreHalo(array_ref, array, fill, lbc - lb)
229 20303 : call setRefilled(array, fill, ub - lb + 1_IK, lbc, failed, errmsg)
230 8228 : call report(__LINE__, failed, errmsg)
231 : end if
232 : ! Test the expansion/contraction + shift + subset interface.
233 23200 : if (allocated(array)) deallocate(array)
234 1333629 : allocate(array, source = arrayInit)
235 61200 : call setUnifRand(lbcold, lbold, ubold)
236 61200 : call setUnifRand(ubcold, lbcold, min(ubold, lbcold + min(ubold - lbold, ub - lb)))
237 61200 : call setUnifRand(lbc, lb, ub - (ubcold - lbcold))
238 : !write(*,*) "GET_LBOUND(array), GET_UBOUND(array), lbcold, ubcold", GET_LBOUND(array), GET_UBOUND(array), lbcold, ubcold
239 : !write(*,*) "SET_BND(array, lbcold, ubcold)", SET_BND(array, lbcold, ubcold)
240 : !write(*,*) "array_ref", array_ref
241 193212 : call setCoreHalo(array_ref, SET_BND(array, lbcold, ubcold), fill, lbc - lb)
242 : !write(*,*) "array_ref, lb, ub, lbc, lbcold, ubcold", array_ref, lb, ub, lbc, lbcold, ubcold
243 84400 : call setRefilled(array, fill, ub - lb + 1_IK, lbc, lbcold, ubcold, failed, errmsg)
244 23200 : call report(__LINE__, failed, errmsg)
245 :
246 23200 : end subroutine
247 :
248 : !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
249 :
250 40866 : subroutine report(line, failed, errmsg)
251 : integer, intent(in) :: line
252 : logical(LK), intent(in), optional :: failed
253 : character(*, SK), intent(in), optional :: errmsg
254 81374 : call checkFailure(line, failed, errmsg)
255 211324 : assertion = assertion .and. ALL(GET_LBOUND(array) == GET_LBOUND(array_ref))
256 40866 : call display()
257 122598 : 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))
258 211324 : assertion = assertion .and. ALL(GET_UBOUND(array) == GET_UBOUND(array_ref))
259 40866 : call display()
260 122598 : 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))
261 16156115 : assertion = assertion .and. ALL(array IS_EQUAL array_ref)
262 40866 : call display()
263 122598 : call test%assert(assertion, SK_"Call to setRefilled() must correctly rebind and refill `array` with present(failed), present(errmsg) = "//getStr([present(failed), present(errmsg)]), int(line, IK))
264 40866 : end subroutine
265 :
266 : !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
267 :
268 122598 : subroutine display()
269 122598 : if (test%traceable .and. .not. assertion) then
270 : ! LCOV_EXCL_START
271 : call disp%skip()
272 : call disp%show("rank(array)")
273 : call disp%show( rank(array) )
274 : call disp%show("lbold")
275 : call disp%show( lbold )
276 : call disp%show("ubold")
277 : call disp%show( ubold )
278 : call disp%show("lb")
279 : call disp%show( lb )
280 : call disp%show("ub")
281 : call disp%show( ub )
282 : call disp%show("lbc")
283 : call disp%show( lbc )
284 : call disp%show("lbcold")
285 : call disp%show( lbcold )
286 : call disp%show("ubcold")
287 : call disp%show( ubcold )
288 : call disp%show("arrayInit")
289 : call disp%show( arrayInit )
290 : call disp%show("array_ref")
291 : call disp%show( array_ref )
292 : call disp%show("array")
293 : call disp%show( array )
294 : call disp%show("array == array_ref")
295 : call disp%show( array IS_EQUAL array_ref )
296 : call disp%skip()
297 : ! LCOV_EXCL_STOP
298 : end if
299 122598 : end subroutine
300 :
301 : !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
302 :
303 : #undef GET_LBOUND
304 : #undef GET_UBOUND
305 : #undef TYPE_KIND
306 : #undef IS_EQUAL
307 : #undef SET_SIZE
308 : #undef SET_BND
309 : #undef SET_DIM
310 : #undef ALL
|
