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_arrayRebind](@ref pm_arrayRebind).
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 setRebound_D1_SK_ENABLED || setRebound_D2_SK_ENABLED || setRebound_D3_SK_ENABLED
29 : #define TYPE_KIND character(2,SKC) ::
30 : #else
31 : #define TYPE_KIND
32 : #endif
33 :
34 : #if setRebound_D1_LK_ENABLED || setRebound_D2_LK_ENABLED || setRebound_D3_LK_ENABLED
35 : #define IS_EQUAL .eqv.
36 : #else
37 : #define IS_EQUAL ==
38 : #endif
39 :
40 : #if setRebound_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 setRebound_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 setRebound_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 : type(display_type) :: disp
57 : #if setRebound_D1_SK_ENABLED || setRebound_D2_SK_ENABLED || setRebound_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 setRebound_D1_IK_ENABLED || setRebound_D2_IK_ENABLED || setRebound_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 setRebound_D1_LK_ENABLED || setRebound_D2_LK_ENABLED || setRebound_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 setRebound_D1_CK_ENABLED || setRebound_D2_CK_ENABLED || setRebound_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 setRebound_D1_RK_ENABLED || setRebound_D2_RK_ENABLED || setRebound_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 : disp = display_type()
88 57 : assertion = .true._LK
89 :
90 11457 : do itest = 1, 200
91 11400 : call runTestsWith()
92 11400 : call runTestsWith(failed)
93 11400 : call runTestsWith(errmsg = errmsg)
94 22857 : call runTestsWith(failed, errmsg)
95 : end do
96 :
97 : ! Test with unallocated input `array`.
98 57 : call runTestsWithUnalloc()
99 57 : call runTestsWithUnalloc(failed)
100 57 : call runTestsWithUnalloc(errmsg = errmsg)
101 57 : call runTestsWithUnalloc(failed, errmsg)
102 :
103 : !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
104 :
105 : contains
106 :
107 : !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
108 :
109 54138 : subroutine checkFailure(line, failed, errmsg)
110 : integer, intent(in) :: line
111 : logical(LK), intent(in), optional :: failed
112 : character(*, SK), intent(in), optional :: errmsg
113 54138 : if (present(failed)) then
114 27006 : assertion = assertion .and. .not. failed
115 81018 : call test%assert(assertion, SK_"The `array` resizing must not fail with present(failed), present(errmsg) = "//getStr([present(failed), present(errmsg)]), int(line, IK))
116 : end if
117 54138 : end subroutine
118 :
119 : !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
120 :
121 228 : subroutine runTestsWithUnalloc(failed, errmsg)
122 : logical(LK), intent(out), optional :: failed
123 : character(*, SK), intent(out), optional :: errmsg
124 228 : if (allocated(array_ref)) deallocate(array_ref)
125 608 : call setUnifRand(lb, -5_IK, 10_IK)
126 608 : call setUnifRand(ub, lb - 1_IK, 20_IK)
127 576 : allocate(TYPE_KIND SET_BND(array_ref, lb, ub))
128 228 : if (allocated(array)) deallocate(array)
129 456 : call setRebound(array, lb, ub, failed, errmsg)
130 228 : call checkFailure(__LINE__, failed, errmsg)
131 1188 : assertion = assertion .and. all(lbound(array) == lbound(array_ref))
132 : 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
133 2736 : getStr([present(failed), present(errmsg)])//SK_", "//getStr([lbound(array), lbound(array_ref)]), int(__LINE__, IK))
134 1188 : assertion = assertion .and. all(ubound(array) == ubound(array_ref))
135 : 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
136 2736 : getStr([present(failed), present(errmsg)])//SK_", "//getStr([ubound(array), ubound(array_ref)]), int(__LINE__, IK))
137 228 : end subroutine
138 :
139 : !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
140 :
141 45600 : subroutine runTestsWith(failed, errmsg)
142 :
143 : logical(LK), intent(out), optional :: failed
144 : character(*, SK), intent(out), optional :: errmsg
145 :
146 45600 : if (allocated(arrayInit)) deallocate(arrayInit)
147 45600 : if (allocated(array_ref)) deallocate(array_ref)
148 :
149 121600 : call setUnifRand(lbold, -5_IK, +5_IK)
150 121600 : call setUnifRand(ubold, lbold, +10_IK)
151 121600 : call setUnifRand(lb, -15_IK, +5_IK)
152 121600 : call setUnifRand(ub, lb, +15_IK)
153 118400 : allocate(TYPE_KIND SET_BND(arrayInit, lbold, ubold))
154 118400 : allocate(TYPE_KIND SET_BND(array_ref, lb, ub))
155 4724922 : call setUnifRand(arrayInit, lower, upper)
156 152317 : if (ALL(lb <= lbold) .and. ALL(ubold <= ub) .and. getUnifRand()) then
157 : ! Test the expansion interface.
158 4155 : lbc = lbold
159 4155 : lbcold = lbold
160 4155 : ubcold = ubold
161 4155 : if (allocated(array)) deallocate(array)
162 108202 : allocate(array, source = arrayInit)
163 7302 : call setCoreHalo(array_ref, array, fill, lbc - lb)
164 : !write(*,*) "lb, ub", lb, ub
165 8353 : call setRebound(array, lb, ub, failed, errmsg)
166 4155 : call report(__LINE__, failed, errmsg)
167 : ! Test the expansion + shift interface.
168 7302 : call setUnifRand(lbc, lb, ub - (ubcold - lbcold))
169 : !write(*,*) "lb, ub, lbc, lbcold, ubcold", lb, ub, lbc, lbcold, ubcold
170 4155 : if (allocated(array)) deallocate(array)
171 108202 : allocate(array, source = arrayInit)
172 7302 : call setCoreHalo(array_ref, array, fill, lbc - lb)
173 4155 : call setRebound(array, lb, ub, lbc, failed, errmsg)
174 4155 : call report(__LINE__, failed, errmsg)
175 : end if
176 : ! Test the expansion/contraction + shift + subset interface.
177 45600 : if (allocated(array)) deallocate(array)
178 4808922 : allocate(array, source = arrayInit)
179 121600 : call setUnifRand(lbcold, lbold, ubold)
180 121600 : call setUnifRand(ubcold, lbcold, min(ubold, lbcold + min(ubold - lbold, ub - lb)))
181 121600 : call setUnifRand(lbc, lb, ub - (ubcold - lbcold))
182 : !write(*,*) "lbound(array), ubound(array), lbcold, ubcold", lbound(array), ubound(array), lbcold, ubcold
183 : !write(*,*) "SET_BND(array, lbcold, ubcold)", SET_BND(array, lbcold, ubcold)
184 : !write(*,*) "array_ref", array_ref
185 456646 : call setCoreHalo(array_ref, SET_BND(array, lbcold, ubcold), fill, lbc - lb)
186 : !write(*,*) "array_ref, lbc - lb", array_ref, lbc - lb
187 91200 : call setRebound(array, lb, ub, lbc, lbcold, ubcold, failed, errmsg)
188 45600 : call report(__LINE__, failed, errmsg)
189 :
190 45600 : end subroutine
191 :
192 : !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
193 :
194 53910 : subroutine report(line, failed, errmsg)
195 : integer, intent(in) :: line
196 : logical(LK), intent(in), optional :: failed
197 : character(*, SK), intent(in), optional :: errmsg
198 107906 : call checkFailure(line, failed, errmsg)
199 279588 : assertion = assertion .and. all(lbound(array) == lbound(array_ref))
200 53910 : call display()
201 161730 : 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))
202 279588 : assertion = assertion .and. all(ubound(array) == ubound(array_ref))
203 53910 : call display()
204 161730 : 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))
205 : #if setRebound_D1_ENABLED
206 : assertion = assertion .and. all(array(lbc : lbc - lbcold + ubcold) IS_EQUAL & ! LCOV_EXCL_LINE
207 : array_ref(lbc : lbc - lbcold + ubcold) & ! LCOV_EXCL_LINE
208 78635 : )
209 : #elif setRebound_D2_ENABLED
210 : 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
211 : array_ref(lbc(1) : lbc(1) - lbcold(1) + ubcold(1), lbc(2) : lbc(2) - lbcold(2) + ubcold(2)) & ! LCOV_EXCL_LINE
212 166013 : )
213 : #elif setRebound_D3_ENABLED
214 : 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
215 : 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
216 357471 : )
217 : #else
218 : #error "Unrecognized interface."
219 : #endif
220 53910 : call display()
221 161730 : call test%assert(assertion, SK_"Call to setRebound() must correctly rebind and refill `array` with present(failed), present(errmsg) = "//getStr([present(failed), present(errmsg)]), int(line, IK))
222 53910 : end subroutine
223 :
224 : !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
225 :
226 161730 : subroutine display()
227 161730 : if (test%traceable .and. .not. assertion) then
228 : ! LCOV_EXCL_START
229 : call disp%skip()
230 : call disp%show("rank(array)")
231 : call disp%show( rank(array) )
232 : call disp%show("lbold")
233 : call disp%show( lbold )
234 : call disp%show("ubold")
235 : call disp%show( ubold )
236 : call disp%show("lb")
237 : call disp%show( lb )
238 : call disp%show("ub")
239 : call disp%show( ub )
240 : call disp%show("lbc")
241 : call disp%show( lbc )
242 : call disp%show("lbcold")
243 : call disp%show( lbcold )
244 : call disp%show("ubcold")
245 : call disp%show( ubcold )
246 : call disp%show("arrayInit")
247 : call disp%show( arrayInit )
248 : call disp%show("array_ref")
249 : call disp%show( array_ref )
250 : call disp%show("array")
251 : call disp%show( array )
252 : call disp%show("array == array_ref")
253 : call disp%show( array IS_EQUAL array_ref )
254 : call disp%skip()
255 : ! LCOV_EXCL_STOP
256 : end if
257 161730 : end subroutine
258 :
259 : !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
260 :
261 : #undef TYPE_KIND
262 : #undef SET_SIZE
263 : #undef IS_EQUAL
264 : #undef SET_BND
265 : #undef SET_DIM
266 : #undef ALL
|
