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_arrayRebill](@ref pm_arrayRebill).
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 setRebilled_D1_SK_ENABLED || setRebilled_D2_SK_ENABLED || setRebilled_D3_SK_ENABLED
29 : #define TYPE_KIND character(2,SKC) ::
30 : #else
31 : #define TYPE_KIND
32 : #endif
33 :
34 : #if setRebilled_D1_LK_ENABLED || setRebilled_D2_LK_ENABLED || setRebilled_D3_LK_ENABLED
35 : #define IS_EQUAL .eqv.
36 : #else
37 : #define IS_EQUAL ==
38 : #endif
39 :
40 : #if setRebilled_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 : #define ALL
45 : #elif setRebilled_D2_ENABLED
46 : #define SET_BND(X,lb,ub) X(lb(1) : ub(1), lb(2) : ub(2))
47 : #define SET_SIZE(X) X(rank(array))
48 : #define SET_DIM(X) X(:,:)
49 : #elif setRebilled_D3_ENABLED
50 : #define SET_BND(X,lb,ub) X(lb(1) : ub(1), lb(2) : ub(2), lb(3) : ub(3))
51 : #define SET_SIZE(X) X(rank(array))
52 : #define SET_DIM(X) X(:,:,:)
53 : #else
54 : #error "Unrecognized interface."
55 : #endif
56 :
57 : #if setRebilled_D1_SK_ENABLED || setRebilled_D2_SK_ENABLED || setRebilled_D3_SK_ENABLED
58 : character(2,SKC), allocatable :: SET_DIM(array), SET_DIM(arrayInit), SET_DIM(array_ref)
59 : character(2,SKC), parameter :: fill = SKC_"--", lower = SKC_"aa", upper = SKC_"zz"
60 : #elif setRebilled_D1_IK_ENABLED || setRebilled_D2_IK_ENABLED || setRebilled_D3_IK_ENABLED
61 : integer(IKC) , allocatable :: SET_DIM(array), SET_DIM(arrayInit), SET_DIM(array_ref)
62 : integer(IKC) , parameter :: fill = huge(0_IKC), lower = -huge(0_IKC), upper = huge(0_IKC)
63 : #elif setRebilled_D1_LK_ENABLED || setRebilled_D2_LK_ENABLED || setRebilled_D3_LK_ENABLED
64 : logical(LKC) , allocatable :: SET_DIM(array), SET_DIM(arrayInit), SET_DIM(array_ref)
65 : logical(LKC) , parameter :: fill = .false._LKC, lower = .false._LKC, upper = .true._LKC
66 : #elif setRebilled_D1_CK_ENABLED || setRebilled_D2_CK_ENABLED || setRebilled_D3_CK_ENABLED
67 : complex(CKC) , allocatable :: SET_DIM(array), SET_DIM(arrayInit), SET_DIM(array_ref)
68 : complex(CKC) , parameter :: fill = cmplx(huge(0._CKC), huge(0._CKC), kind = CKC)
69 : complex(CKC) , parameter :: lower = -fill, upper = fill
70 : #elif setRebilled_D1_RK_ENABLED || setRebilled_D2_RK_ENABLED || setRebilled_D3_RK_ENABLED
71 : real(RKC) , allocatable :: SET_DIM(array), SET_DIM(arrayInit), SET_DIM(array_ref)
72 : real(RKC) , parameter :: fill = huge(0._RKC)
73 : real(RKC) , parameter :: lower = -fill, upper = fill
74 : #else
75 : #error "Unrecognized interface."
76 : #endif
77 : character(127, SK) :: errmsg
78 : logical(LK) :: failed
79 : integer(IK) :: SET_SIZE(lb)
80 : integer(IK) :: SET_SIZE(ub)
81 : integer(IK) :: SET_SIZE(lbc)
82 : integer(IK) :: SET_SIZE(lbold)
83 : integer(IK) :: SET_SIZE(ubold)
84 : integer(IK) :: SET_SIZE(lbcold)
85 : integer(IK) :: SET_SIZE(ubcold)
86 : integer :: itest
87 57 : type(display_type) :: disp
88 57 : disp = display_type()
89 57 : assertion = .true._LK
90 :
91 11457 : do itest = 1, 200
92 11400 : call runTestsWith()
93 11400 : call runTestsWith(failed)
94 11400 : call runTestsWith(errmsg = errmsg)
95 22857 : call runTestsWith(failed, errmsg)
96 : end do
97 :
98 : ! Test with unallocated input `array`.
99 57 : call runTestsWithUnalloc()
100 57 : call runTestsWithUnalloc(failed)
101 57 : call runTestsWithUnalloc(errmsg = errmsg)
102 57 : call runTestsWithUnalloc(failed, errmsg)
103 :
104 : !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
105 :
106 : contains
107 :
108 : !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
109 :
110 54112 : subroutine checkFailure(line, failed, errmsg)
111 : integer, intent(in) :: line
112 : logical(LK), intent(in), optional :: failed
113 : character(*, SK), intent(in), optional :: errmsg
114 54112 : if (present(failed)) then
115 27036 : assertion = assertion .and. .not. failed
116 81108 : call test%assert(assertion, SK_"The `array` resizing must not fail with present(failed), present(errmsg) = "//getStr([present(failed), present(errmsg)]), int(line, IK))
117 : end if
118 54112 : end subroutine
119 :
120 : !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
121 :
122 228 : subroutine runTestsWithUnalloc(failed, errmsg)
123 : logical(LK), intent(out), optional :: failed
124 : character(*, SK), intent(out), optional :: errmsg
125 228 : if (allocated(array_ref)) deallocate(array_ref)
126 608 : call setUnifRand(lb, -5_IK, 10_IK)
127 608 : call setUnifRand(ub, lb - 1_IK, 20_IK)
128 577 : allocate(TYPE_KIND SET_BND(array_ref, lb, ub))
129 71209 : array_ref = fill
130 228 : if (allocated(array)) deallocate(array)
131 456 : call setRebilled(array, fill, lb, ub, failed, errmsg)
132 228 : call checkFailure(__LINE__, failed, errmsg)
133 1187 : assertion = assertion .and. all(lbound(array) == lbound(array_ref))
134 : 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
135 2724 : getStr([present(failed), present(errmsg)])//SK_", "//getStr([lbound(array), lbound(array_ref)]), int(__LINE__, IK))
136 1187 : assertion = assertion .and. all(ubound(array) == ubound(array_ref))
137 : 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
138 2724 : getStr([present(failed), present(errmsg)])//SK_", "//getStr([ubound(array), ubound(array_ref)]), int(__LINE__, IK))
139 71209 : assertion = assertion .and. all(array IS_EQUAL array_ref)
140 684 : 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))
141 228 : end subroutine
142 :
143 : !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
144 :
145 45600 : subroutine runTestsWith(failed, errmsg)
146 :
147 : logical(LK), intent(out), optional :: failed
148 : character(*, SK), intent(out), optional :: errmsg
149 :
150 45600 : if (allocated(arrayInit)) deallocate(arrayInit)
151 45600 : if (allocated(array_ref)) deallocate(array_ref)
152 :
153 121600 : call setUnifRand(lbold, -5_IK, +5_IK)
154 121600 : call setUnifRand(ubold, lbold, +10_IK)
155 121600 : call setUnifRand(lb, -15_IK, +5_IK)
156 121600 : call setUnifRand(ub, lb, +15_IK)
157 118400 : allocate(TYPE_KIND SET_BND(arrayInit, lbold, ubold))
158 118400 : allocate(TYPE_KIND SET_BND(array_ref, lb, ub))
159 4721886 : call setUnifRand(arrayInit, lower, upper)
160 153029 : if (ALL(lb <= lbold) .and. ALL(ubold <= ub) .and. getUnifRand()) then
161 : ! Test the expansion interface.
162 4142 : lbc = lbold
163 4142 : lbcold = lbold
164 4142 : ubcold = ubold
165 4142 : if (allocated(array)) deallocate(array)
166 109680 : allocate(array, source = arrayInit)
167 7380 : call setCoreHalo(array_ref, array, fill, lbc - lb)
168 : !write(*,*) "lb, ub", lb, ub
169 8264 : call setRebilled(array, fill, lb, ub, failed, errmsg)
170 4142 : call report(__LINE__, failed, errmsg)
171 : ! Test the expansion + shift interface.
172 7380 : call setUnifRand(lbc, lb, ub - (ubcold - lbcold))
173 : !write(*,*) "lb, ub, lbc, lbcold, ubcold", lb, ub, lbc, lbcold, ubcold
174 4142 : if (allocated(array)) deallocate(array)
175 109680 : allocate(array, source = arrayInit)
176 7380 : call setCoreHalo(array_ref, array, fill, lbc - lb)
177 4142 : call setRebilled(array, fill, lb, ub, lbc, failed, errmsg)
178 4142 : call report(__LINE__, failed, errmsg)
179 : end if
180 : ! Test the expansion/contraction + shift + subset interface.
181 45600 : if (allocated(array)) deallocate(array)
182 4805886 : allocate(array, source = arrayInit)
183 121600 : call setUnifRand(lbcold, lbold, ubold)
184 121600 : call setUnifRand(ubcold, lbcold, min(ubold, lbcold + min(ubold - lbold, ub - lb)))
185 121600 : call setUnifRand(lbc, lb, ub - (ubcold - lbcold))
186 : !write(*,*) "lbound(array), ubound(array), lbcold, ubcold", lbound(array), ubound(array), lbcold, ubcold
187 : !write(*,*) "SET_BND(array, lbcold, ubcold)", SET_BND(array, lbcold, ubcold)
188 : !write(*,*) "array_ref", array_ref
189 453611 : call setCoreHalo(array_ref, SET_BND(array, lbcold, ubcold), fill, lbc - lb)
190 : !write(*,*) "array_ref, lbc - lb", array_ref, lbc - lb
191 91200 : call setRebilled(array, fill, lb, ub, lbc, lbcold, ubcold, failed, errmsg)
192 45600 : call report(__LINE__, failed, errmsg)
193 :
194 45600 : end subroutine
195 :
196 : !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
197 :
198 53884 : subroutine report(line, failed, errmsg)
199 : integer, intent(in) :: line
200 : logical(LK), intent(in), optional :: failed
201 : character(*, SK), intent(in), optional :: errmsg
202 107728 : call checkFailure(line, failed, errmsg)
203 279660 : assertion = assertion .and. all(lbound(array) == lbound(array_ref))
204 53884 : call display()
205 161652 : 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))
206 279660 : assertion = assertion .and. all(ubound(array) == ubound(array_ref))
207 53884 : call display()
208 161652 : 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))
209 29267918 : assertion = assertion .and. all(array IS_EQUAL array_ref)
210 53884 : call display()
211 161652 : call test%assert(assertion, SK_"Call to setRebilled() must correctly rebind and refill `array` with present(failed), present(errmsg) = "//getStr([present(failed), present(errmsg)]), int(line, IK))
212 53884 : end subroutine
213 :
214 : !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
215 :
216 161652 : subroutine display()
217 161652 : if (test%traceable .and. .not. assertion) then
218 : ! LCOV_EXCL_START
219 : call disp%skip()
220 : call disp%show("rank(array)")
221 : call disp%show( rank(array) )
222 : call disp%show("lbold")
223 : call disp%show( lbold )
224 : call disp%show("ubold")
225 : call disp%show( ubold )
226 : call disp%show("lb")
227 : call disp%show( lb )
228 : call disp%show("ub")
229 : call disp%show( ub )
230 : call disp%show("lbc")
231 : call disp%show( lbc )
232 : call disp%show("lbcold")
233 : call disp%show( lbcold )
234 : call disp%show("ubcold")
235 : call disp%show( ubcold )
236 : call disp%show("arrayInit")
237 : call disp%show( arrayInit )
238 : call disp%show("array_ref")
239 : call disp%show( array_ref )
240 : call disp%show("array")
241 : call disp%show( array )
242 : call disp%show("array == array_ref")
243 : call disp%show( array IS_EQUAL array_ref )
244 : call disp%skip()
245 : ! LCOV_EXCL_STOP
246 : end if
247 161652 : end subroutine
248 :
249 : !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
250 :
251 : #undef TYPE_KIND
252 : #undef IS_EQUAL
253 : #undef SET_SIZE
254 : #undef SET_BND
255 : #undef SET_DIM
256 : #undef ALL
|
