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
19 : !> [getPadded](@ref pm_arrayPad::getPadded),
20 : !> [setPadded](@ref pm_arrayPad::setPadded).
21 : !>
22 : !> \todo
23 : !> \phigh The tests in this file still benefit from expansion and improvement.
24 : !>
25 : !> \fintest
26 : !>
27 : !> \author
28 : !> \AmirShahmoradi, September 1, 2017, 11:35 PM, Institute for Computational Engineering and Sciences (ICES), The University of Texas at Austin
29 :
30 : !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
31 :
32 : !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
33 : #if getPadded_ENABLED || setPadded_ENABLED
34 : !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
35 :
36 : #if LK_ENABLED
37 : #define IS_EQUAL .eqv.
38 : #else
39 : #define IS_EQUAL ==
40 : #endif
41 : #if SK_ENABLED && D0_ENABLED
42 : #define GET_LBOUND(Array) 1_IK
43 : #define GEN_UBOUND(Array) len(Array, kind = IK)
44 : #define GET_SIZE(Array) len(Array, kind = IK)
45 : #define GEN_LBOLD(lb) 1_IK
46 : #define GEN_LBNEW(lb) 1_IK
47 : #elif getPadded_ENABLED
48 : #define GET_LBOUND(Array) 1_IK
49 : #define GEN_UBOUND(Array) size(Array, kind = IK)
50 : #define GET_SIZE(Array) size(Array, kind = IK)
51 : #define GEN_LBOLD(lb) 1_IK
52 : #define GEN_LBNEW(lb) 1_IK
53 : #else
54 : #define GET_LBOUND(Array) lbound(Array, dim = 1, kind = IK)
55 : #define GEN_UBOUND(Array) ubound(Array, dim = 1, kind = IK)
56 : #define GET_SIZE(Array) size(Array, kind = IK)
57 : #define GEN_LBOLD(lb) lb
58 : #define GEN_LBNEW(lb) lb
59 : #endif
60 :
61 : #if SK_ENABLED && D0_ENABLED
62 : #define ALL
63 2 : character(:,SKC), allocatable :: Array, arrayPadded
64 : character(1,SKC), parameter :: lpfill = SKC_"/"
65 : character(1,SKC), parameter :: rpfill = SKC_"*"
66 : character(1,SKC), parameter :: lmfill = SKC_"-"
67 : character(1,SKC), parameter :: rmfill = SKC_"+"
68 : #elif SK_ENABLED && D1_ENABLED
69 : character(2,SKC), dimension(:), allocatable :: Array, arrayPadded
70 : character(2,SKC), parameter :: lpfill = SKC_"//"
71 : character(2,SKC), parameter :: rpfill = SKC_"**"
72 : character(2,SKC), parameter :: lmfill = SKC_"--"
73 : character(2,SKC), parameter :: rmfill = SKC_"++"
74 : #elif IK_ENABLED && D1_ENABLED
75 : integer(IKC) , dimension(:), allocatable :: Array, arrayPadded
76 : integer(IKC) , parameter :: lpfill = huge(1_IKC)
77 : integer(IKC) , parameter :: rpfill = huge(1_IKC)
78 : integer(IKC) , parameter :: lmfill = huge(1_IKC)
79 : integer(IKC) , parameter :: rmfill = huge(1_IKC)
80 : #elif LK_ENABLED && D1_ENABLED
81 : logical(LKC) , dimension(:), allocatable :: Array, arrayPadded
82 : logical(LKC) , parameter :: lpfill = .false._LKC
83 : logical(LKC) , parameter :: rpfill = .false._LKC
84 : logical(LKC) , parameter :: lmfill = .false._LKC
85 : logical(LKC) , parameter :: rmfill = .false._LKC
86 : #elif CK_ENABLED && D1_ENABLED
87 : complex(CKC) , dimension(:), allocatable :: Array, arrayPadded
88 : complex(CKC) , parameter :: lpfill = cmplx(huge(0._CKC), huge(0._CKC), kind = CKC)
89 : complex(CKC) , parameter :: rpfill = cmplx(huge(0._CKC), huge(0._CKC), kind = CKC)
90 : complex(CKC) , parameter :: lmfill = cmplx(huge(0._CKC), huge(0._CKC), kind = CKC)
91 : complex(CKC) , parameter :: rmfill = cmplx(huge(0._CKC), huge(0._CKC), kind = CKC)
92 : #elif RK_ENABLED && D1_ENABLED
93 : real(RKC) , dimension(:), allocatable :: Array, arrayPadded
94 : real(RKC) , parameter :: lpfill = huge(0._RKC)
95 : real(RKC) , parameter :: rpfill = huge(0._RKC)
96 : real(RKC) , parameter :: lmfill = huge(0._RKC)
97 : real(RKC) , parameter :: rmfill = huge(0._RKC)
98 : #else
99 : #error "Unrecognized interface."
100 : #endif
101 : !integer(IK) :: sizepadded
102 : !integer(IK) :: sizeold, sizenew
103 : !integer(IK) :: lpsize, rpsize
104 : !integer(IK) :: lmsize, rmsize
105 : !integer(IK) :: lbcold, ubcold
106 : !integer(IK) :: lbcnew, ubcnew
107 : !integer(IK) :: lbold, ubold
108 : !integer(IK) :: lbnew, ubnew
109 : !logical(LK) :: menabled
110 : integer(IK) :: i, j, k
111 :
112 : !> \bug
113 : !> Avoid zero margin and pad sizes in the following because of the GNU gfortran bug as of 10.3.
114 : integer(IK) , parameter :: SizePad(2,3) = reshape ( [ 1_IK, 3_IK &
115 : , 2_IK, 2_IK &
116 : , 3_IK, 1_IK &
117 : ], shape = shape(SizePad) )
118 : integer(IK) , parameter :: SizeMarg(2,3) = reshape( [ 1_IK, 3_IK &
119 : , 2_IK, 2_IK &
120 : , 2_IK, 1_IK &
121 : ], shape = shape(SizePad) )
122 : integer(IK) , parameter :: SizeArray(3) = [ 1_IK &
123 : , 2_IK &
124 : , 3_IK &
125 : ] ! Avoid zero-sized arrays in the following because it messes up with the array lower bounds and resets it to 1 which causes the tests to wrongly fail.
126 : #if setPadded_ENABLED
127 : logical(LK) :: failed
128 : #endif
129 :
130 : !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
131 :
132 40 : assertion = .true._LK
133 162 : do i = 1, size(SizeArray,1,IK)
134 520 : do j = 1, size(SizePad,2,IK)
135 1560 : do k = 1, size(SizeMarg,2,IK)
136 1080 : call runTestsWith(sizeOld = SizeArray(i), lpsize = SizePad(1,j), rpsize = SizePad(2,j), lpfill = lpfill, rpfill = rpfill)
137 1080 : call runTestsWith(sizeOld = SizeArray(i), lpsize = SizePad(1,j), rpsize = SizePad(2,j), lpfill = lpfill, rpfill = rpfill, lmsize = SizeMarg(1,k), rmsize = SizeMarg(2,k))
138 1080 : call runTestsWith(sizeOld = SizeArray(i), lpsize = SizePad(1,j), rpsize = SizePad(2,j), lpfill = lpfill, rpfill = rpfill, lmsize = SizeMarg(1,k), rmsize = SizeMarg(2,k), lmfill = lmfill)
139 1080 : call runTestsWith(sizeOld = SizeArray(i), lpsize = SizePad(1,j), rpsize = SizePad(2,j), lpfill = lpfill, rpfill = rpfill, lmsize = SizeMarg(1,k), rmsize = SizeMarg(2,k), rmfill = rmfill)
140 1260 : call runTestsWith(sizeOld = SizeArray(i), lpsize = SizePad(1,j), rpsize = SizePad(2,j), lpfill = lpfill, rpfill = rpfill, lmsize = SizeMarg(1,k), rmsize = SizeMarg(2,k), lmfill = lmfill, rmfill = rmfill)
141 : #if setPadded_ENABLED
142 540 : call runTestsWith(sizeOld = SizeArray(i), lpsize = SizePad(1,j), rpsize = SizePad(2,j), lpfill = lpfill, rpfill = rpfill, failed = failed)
143 540 : call runTestsWith(sizeOld = SizeArray(i), lpsize = SizePad(1,j), rpsize = SizePad(2,j), lpfill = lpfill, rpfill = rpfill, lmsize = SizeMarg(1,k), rmsize = SizeMarg(2,k), failed = failed)
144 540 : call runTestsWith(sizeOld = SizeArray(i), lpsize = SizePad(1,j), rpsize = SizePad(2,j), lpfill = lpfill, rpfill = rpfill, lmsize = SizeMarg(1,k), rmsize = SizeMarg(2,k), lmfill = lmfill, failed = failed)
145 540 : call runTestsWith(sizeOld = SizeArray(i), lpsize = SizePad(1,j), rpsize = SizePad(2,j), lpfill = lpfill, rpfill = rpfill, lmsize = SizeMarg(1,k), rmsize = SizeMarg(2,k), rmfill = rmfill, failed = failed)
146 720 : call runTestsWith(sizeOld = SizeArray(i), lpsize = SizePad(1,j), rpsize = SizePad(2,j), lpfill = lpfill, rpfill = rpfill, lmsize = SizeMarg(1,k), rmsize = SizeMarg(2,k), lmfill = lmfill, rmfill = rmfill, failed = failed)
147 : #endif
148 : end do
149 : end do
150 : end do
151 :
152 : !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
153 :
154 : contains
155 :
156 : !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
157 :
158 8100 : subroutine runTestsWith(sizeOld, lpsize, rpsize, lpfill, rpfill, lmsize, rmsize, lmfill, rmfill, failed)
159 :
160 : integer(IK) , intent(in) :: sizeOld
161 : integer(IK) , intent(in) :: lpsize, rpsize
162 : integer(IK) , intent(in), optional :: lmsize, rmsize
163 : logical(LK) , optional :: failed
164 : #if SK_ENABLED && D0_ENABLED
165 : character(1,SKC), intent(in) :: lpfill, rpfill
166 : character(1,SKC), intent(in), optional :: lmfill, rmfill
167 : #elif SK_ENABLED && D1_ENABLED
168 : character(2,SKC), intent(in) :: lpfill, rpfill
169 : character(2,SKC), intent(in), optional :: lmfill, rmfill
170 : #elif IK_ENABLED && D1_ENABLED
171 : integer(IKC) , intent(in) :: lpfill, rpfill
172 : integer(IKC) , intent(in), optional :: lmfill, rmfill
173 : #elif LK_ENABLED && D1_ENABLED
174 : logical(LKC) , intent(in) :: lpfill, rpfill
175 : logical(LKC) , intent(in), optional :: lmfill, rmfill
176 : #elif CK_ENABLED && D1_ENABLED
177 : complex(CKC) , intent(in) :: lpfill, rpfill
178 : complex(CKC) , intent(in), optional :: lmfill, rmfill
179 : #elif RK_ENABLED && D1_ENABLED
180 : real(RKC) , intent(in) :: lpfill, rpfill
181 : real(RKC) , intent(in), optional :: lmfill, rmfill
182 : #else
183 : #error "Unrecognized interface."
184 : #endif
185 : logical(LK) :: menabled
186 : integer(IK) :: sizeNew, lmsize_def, rmsize_def
187 : integer(IK) :: lbp, ubp
188 : type :: OldNew_type
189 : integer(IK) :: old, new
190 : end type OldNew_type
191 : type(OldNew_type) :: lb, ub, lbc, ubc
192 :
193 8100 : if (present(lmsize) .neqv. present(rmsize)) error stop "Internal ParaMonte Testing error occurred: `lmsize` and `rmsize` must be both present or both missing."
194 8100 : menabled = present(lmsize) .and. present(rmsize)
195 :
196 : !> \bug
197 : !> GNU Fortran 10.3 cannot concatenate empty character array of length 2 with a non-empty character array of the same length.
198 : !> Fortran runtime error: Different CHARACTER lengths (0/2) in array constructor
199 8100 : if (present(lmsize) .and. present(rmsize)) then
200 6480 : if (lmsize == 0_IK .and. rmsize == 0_IK) error stop "Internal ParaMonte Testing error occurred: GNU bug exception."
201 : end if
202 :
203 8100 : lmsize_def = getOption(0_IK, lmsize)
204 8100 : rmsize_def = getOption(0_IK, rmsize)
205 :
206 8100 : assertion = .true._LK
207 :
208 : ! Enlarge and pad and empty array.
209 :
210 8100 : call reset()
211 :
212 8100 : call setUnifRand(lb%old, -10_IK, 10_IK)
213 8100 : lb%old = GEN_LBOLD(lb%old)
214 8100 : ub%old = lb%old + sizeOld - 1_IK
215 : lbc%old = lb%old
216 : ubc%old = ub%old
217 :
218 8100 : sizeNew = sizeOld + lmsize_def + lpsize + rpsize + rmsize_def
219 8100 : lb%new = lb%old
220 5130 : ub%new = lb%new + sizeNew - 1_IK
221 8100 : lbp = lb%new + lmsize_def
222 5130 : ubp = ub%new - rmsize_def
223 : lbc%new = lbp + lpsize
224 : ubc%new = ubp - rpsize
225 :
226 : #if SK_ENABLED && D0_ENABLED
227 405 : allocate(character(sizeOld,SKC) :: Array)
228 2025 : call setUnifRand(Array, repeat(SKC_"A",len(Array)), repeat(SKC_"Z",len(Array)))
229 1377 : arrayPadded = genRepeat(lmsize_def,lmfill)//genRepeat(lpsize,lpfill)//Array//genRepeat(rpsize,rpfill)//genRepeat(rmsize_def,rmfill)
230 : #else
231 8505 : allocate(Array(lb%old : ub%old))
232 : #if SK_ENABLED && D1_ENABLED
233 1215 : call setUnifRand(Array, SKC_"AA", SKC_"ZZ")
234 : #elif IK_ENABLED && D1_ENABLED
235 6075 : call setUnifRand(Array, -100_IKC, +100_IKC)
236 : #elif LK_ENABLED && D1_ENABLED
237 6075 : call setUnifRand(Array)
238 : #elif CK_ENABLED && D1_ENABLED
239 4860 : call setUnifRand(Array, (-100._CKC,-500._CKC), (+100._CKC,+500._CKC))
240 : #elif RK_ENABLED && D1_ENABLED
241 4860 : call setUnifRand(Array, -100._RKC, +100._RKC)
242 : #endif
243 8505 : allocate(arrayPadded(lb%new : ub%new))
244 : !> \bug
245 : !> Bypass the GNU 10.3 bug for concatenation of zero-sized character arrays.
246 7695 : if (lmsize_def > 0_IK .and. rmsize_def > 0_IK) then
247 149796 : arrayPadded(:) = [genRepeat(lmsize_def,lmfill), genRepeat(lpsize,lpfill), Array, genRepeat(rpsize,rpfill), genRepeat(rmsize_def,rmfill)]
248 1539 : elseif (lmsize_def > 0_IK) then
249 0 : arrayPadded(:) = [genRepeat(lmsize_def,lmfill), genRepeat(lpsize,lpfill), Array, genRepeat(rpsize,rpfill)]
250 1539 : elseif (rmsize_def > 0_IK) then
251 0 : arrayPadded(:) = [genRepeat(lpsize,lpfill), Array, genRepeat(rpsize,rpfill), genRepeat(rmsize_def,rmfill)]
252 : else
253 23085 : arrayPadded(:) = [genRepeat(lpsize,lpfill), Array, genRepeat(rpsize,rpfill)]
254 : end if
255 : #endif
256 :
257 : #if setPadded_ENABLED
258 5400 : if (menabled) then
259 4752 : call setPadded(Array, lpsize, rpsize, lpfill, rpfill, lmsize, rmsize, lmfill, rmfill, failed)
260 : else
261 1080 : call setPadded(Array, lpsize, rpsize, lpfill, rpfill, failed)
262 : end if
263 : #elif getPadded_ENABLED
264 2700 : if (menabled) then
265 44100 : Array = getPadded(Array, lpsize, rpsize, lpfill, rpfill, lmsize, rmsize, lmfill, rmfill)
266 : else
267 7209 : Array = getPadded(Array, lpsize, rpsize, lpfill, rpfill)
268 : end if
269 : #else
270 : #error "Unrecognized interface."
271 : #endif
272 :
273 8100 : if (present(failed)) then
274 2700 : assertion = assertion .and. .not. failed
275 2700 : call report()
276 2700 : call test%assert(assertion, SK_"Call to setPadded() must happen without failure.")
277 : end if
278 :
279 8100 : assertion = assertion .and. GET_SIZE(Array) == GET_SIZE(arrayPadded)
280 8100 : call report()
281 24300 : call test%assert(assertion, SK_"Call to setPadded()/getPadded() must yield an array of proper size, with present(lmfill), present(rmfill) = "//getStr([present(lmfill), present(rmfill)]), int(__LINE__, IK))
282 :
283 18360 : assertion = assertion .and. GET_LBOUND(Array) == GET_LBOUND(arrayPadded)
284 8100 : call report()
285 32400 : call test%assert(assertion, SK_"Call to setPadded()/getPadded() must properly set the lower bound of the output array, with present(lmfill), present(rmfill), present(failed) = "//getStr([present(lmfill), present(rmfill), present(failed)]), int(__LINE__, IK))
286 :
287 18360 : assertion = assertion .and. GEN_UBOUND(Array) == GEN_UBOUND(arrayPadded)
288 8100 : call report()
289 32400 : call test%assert(assertion, SK_"Call to setPadded()/getPadded() must properly set the upper bound of the output array, with present(lmfill), present(rmfill), present(failed) = "//getStr([present(lmfill), present(rmfill), present(failed)]), int(__LINE__, IK))
290 :
291 54270 : assertion = assertion .and. ALL(Array(lbp : ubp) IS_EQUAL arrayPadded(lbp : ubp))
292 8100 : call report()
293 24300 : call test%assert(assertion, SK_"Call to setPadded()/getPadded() must properly set the contents of the output array, with present(lmfill), present(rmfill) = "//getStr([present(lmfill), present(rmfill)]), int(__LINE__, IK))
294 :
295 8100 : if (menabled .and. present(lmfill)) then
296 8370 : assertion = assertion .and. ALL(Array(lb%new : lbp - 1_IK) IS_EQUAL arrayPadded(lb%new : lbp - 1_IK))
297 3240 : call report()
298 3240 : call test%assert(assertion, SK_"Call to setPadded()/getPadded() must properly fill the new left margin elements with `lmfill`", int(__LINE__, IK))
299 : end if
300 :
301 8100 : if (menabled .and. present(rmfill)) then
302 9396 : assertion = assertion .and. ALL(Array(ubp + 1_IK : ub%new) IS_EQUAL arrayPadded(ubp + 1_IK : ub%new))
303 3240 : call report()
304 3240 : call test%assert(assertion, SK_"Call to setPadded()/getPadded() must properly fill the new right margin elements with `lmfill`", int(__LINE__, IK))
305 : end if
306 :
307 8100 : end subroutine
308 :
309 : !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
310 :
311 8100 : subroutine reset()
312 8100 : if (allocated(Array)) deallocate(Array)
313 8100 : if (allocated(arrayPadded)) deallocate(arrayPadded)
314 8100 : end subroutine
315 :
316 : !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
317 :
318 1620 : pure function genRepeat(count,fill) result(Array)
319 : integer(IK) , intent(in) :: count
320 : #if SK_ENABLED && D0_ENABLED
321 : character(1,SKC), intent(in), optional :: fill
322 : character(count,SKC) :: Array
323 3834 : if (present(fill)) Array(:) = repeat(fill, count)
324 : #else
325 : #if SK_ENABLED && D1_ENABLED
326 : character(2,SKC), intent(in), optional :: fill
327 : character(2,SKC) :: Array(count)
328 : #elif IK_ENABLED && D1_ENABLED
329 : integer(IKC) , intent(in), optional :: fill
330 : integer(IKC) :: Array(count)
331 : #elif LK_ENABLED && D1_ENABLED
332 : logical(LKC) , intent(in), optional :: fill
333 : logical(LKC) :: Array(count)
334 : #elif CK_ENABLED && D1_ENABLED
335 : complex(CKC) , intent(in), optional :: fill
336 : complex(CKC) :: Array(count)
337 : #elif RK_ENABLED && D1_ENABLED
338 : real(RKC) , intent(in), optional :: fill
339 : real(RKC) :: Array(count)
340 : #else
341 : #error "Unrecognized interface."
342 : #endif
343 69768 : if (present(fill)) Array(:) = fill
344 : #endif
345 1620 : end function
346 :
347 : !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
348 :
349 41580 : subroutine report()
350 41580 : if (test%traceable .and. .not. assertion) then
351 : ! LCOV_EXCL_START
352 : write(test%disp%unit,"(*(g0,:,', '))")
353 : write(test%disp%unit,"(*(g0,:,', '))") "Array ", Array
354 : write(test%disp%unit,"(*(g0,:,', '))") "arrayPadded ", arrayPadded
355 : write(test%disp%unit,"(*(g0,:,', '))") "GET_LBOUND(Array ) ", GET_LBOUND(Array )
356 : write(test%disp%unit,"(*(g0,:,', '))") "GET_LBOUND(arrayPadded) ", GET_LBOUND(arrayPadded)
357 : write(test%disp%unit,"(*(g0,:,', '))") "GEN_UBOUND(Array ) ", GEN_UBOUND(Array )
358 : write(test%disp%unit,"(*(g0,:,', '))") "GEN_UBOUND(arrayPadded) ", GEN_UBOUND(arrayPadded)
359 : write(test%disp%unit,"(*(g0,:,', '))")
360 : ! LCOV_EXCL_STOP
361 : end if
362 41580 : end subroutine
363 :
364 : !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
365 :
366 : #undef GEN_UBOUND
367 : #undef GET_LBOUND
368 : #undef GEN_LBOLD
369 : #undef GEN_LBNEW
370 : #undef IS_EQUAL
371 : #undef GET_SIZE
372 : #undef ALL
373 :
374 : !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
375 : #elif getPaddedl_ENABLED || setPaddedl_ENABLED
376 : !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
377 :
378 : #if LK_ENABLED
379 : #define IS_EQUAL .eqv.
380 : #else
381 : #define IS_EQUAL ==
382 : #endif
383 :
384 : #if SK_ENABLED && D0_ENABLED
385 : #define GET_LBOUND(Array) 1_IK
386 : #define GEN_UBOUND(Array) len(Array, kind = IK)
387 : #define GET_SIZE(Array) len(Array, kind = IK)
388 : #define GEN_LBOLD(lb) 1_IK
389 : #define GEN_LBNEW(lb) 1_IK
390 : #elif getPaddedl_ENABLED
391 : #define GET_LBOUND(Array) 1_IK
392 : #define GEN_UBOUND(Array) size(Array, kind = IK)
393 : #define GET_SIZE(Array) size(Array, kind = IK)
394 : #define GEN_LBOLD(lb) 1_IK
395 : #define GEN_LBNEW(lb) 1_IK
396 : #else
397 : #define GET_LBOUND(Array) lbound(Array, dim = 1, kind = IK)
398 : #define GEN_UBOUND(Array) ubound(Array, dim = 1, kind = IK)
399 : #define GET_SIZE(Array) size(Array, kind = IK)
400 : #define GEN_LBOLD(lb) lb
401 : #define GEN_LBNEW(lb) lb
402 : #endif
403 :
404 : #if SK_ENABLED && D0_ENABLED
405 : #define ALL
406 2 : character(:,SKC), allocatable :: Array, arrayPadded
407 : character(1,SKC), parameter :: lpfill = SKC_"/"
408 : character(1,SKC), parameter :: lmfill = SKC_"-"
409 : #elif SK_ENABLED && D1_ENABLED
410 : character(2,SKC), dimension(:), allocatable :: Array, arrayPadded
411 : character(2,SKC), parameter :: lpfill = SKC_"//"
412 : character(2,SKC), parameter :: lmfill = SKC_"--"
413 : #elif IK_ENABLED && D1_ENABLED
414 : integer(IKC) , dimension(:), allocatable :: Array, arrayPadded
415 : integer(IKC) , parameter :: lpfill = huge(1_IKC)
416 : integer(IKC) , parameter :: lmfill = huge(1_IKC)
417 : #elif LK_ENABLED && D1_ENABLED
418 : logical(LKC) , dimension(:), allocatable :: Array, arrayPadded
419 : logical(LKC) , parameter :: lpfill = .false._LKC
420 : logical(LKC) , parameter :: lmfill = .false._LKC
421 : #elif CK_ENABLED && D1_ENABLED
422 : complex(CKC) , dimension(:), allocatable :: Array, arrayPadded
423 : complex(CKC) , parameter :: lpfill = cmplx(huge(0._CKC), huge(0._CKC), kind = CKC)
424 : complex(CKC) , parameter :: lmfill = cmplx(huge(0._CKC), huge(0._CKC), kind = CKC)
425 : #elif RK_ENABLED && D1_ENABLED
426 : real(RKC) , dimension(:), allocatable :: Array, arrayPadded
427 : real(RKC) , parameter :: lpfill = huge(0._RKC)
428 : real(RKC) , parameter :: lmfill = huge(0._RKC)
429 : #else
430 : #error "Unrecognized interface."
431 : #endif
432 : integer(IK) :: i, j, k
433 :
434 : !> \bug
435 : !> Avoid zero margin and setPaddedl sizes in the following because of the GNU gfortran bug as of 10.3.
436 : integer(IK) , parameter :: SizePad(3) = [ 1_IK &
437 : , 2_IK &
438 : , 3_IK &
439 : ]
440 : integer(IK) , parameter :: SizeMarg(3)= [ 1_IK &
441 : , 2_IK &
442 : , 2_IK &
443 : ]
444 : integer(IK) , parameter :: SizeArray(3) = [ 1_IK &
445 : , 2_IK &
446 : , 3_IK &
447 : ] ! Avoid zero-sized arrays in the following because it messes up with the array lower bounds and resets it to 1 which causes the tests to wrongly fail.
448 : #if setPaddedl_ENABLED
449 : logical(LK) :: failed
450 : #endif
451 :
452 : !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
453 :
454 40 : assertion = .true._LK
455 162 : do i = 1, size(SizeArray,1,IK)
456 520 : do j = 1, size(SizePad,1,IK)
457 1560 : do k = 1, size(SizeMarg,1,IK)
458 1080 : call runTestsWith(sizeOld = SizeArray(i), lpsize = SizePad(j), lpfill = lpfill)
459 1080 : call runTestsWith(sizeOld = SizeArray(i), lpsize = SizePad(j), lpfill = lpfill, lmsize = SizeMarg(k))
460 1260 : call runTestsWith(sizeOld = SizeArray(i), lpsize = SizePad(j), lpfill = lpfill, lmsize = SizeMarg(k), lmfill = lmfill)
461 : #if setPaddedl_ENABLED
462 540 : call runTestsWith(sizeOld = SizeArray(i), lpsize = SizePad(j), lpfill = lpfill, failed = failed)
463 540 : call runTestsWith(sizeOld = SizeArray(i), lpsize = SizePad(j), lpfill = lpfill, lmsize = SizeMarg(k), failed = failed)
464 720 : call runTestsWith(sizeOld = SizeArray(i), lpsize = SizePad(j), lpfill = lpfill, lmsize = SizeMarg(k), lmfill = lmfill, failed = failed)
465 : #endif
466 : end do
467 : end do
468 : end do
469 :
470 : contains
471 :
472 4860 : subroutine runTestsWith(sizeOld, lpsize, lpfill, lmsize, lmfill, failed)
473 :
474 : integer(IK) , intent(in) :: sizeOld
475 : integer(IK) , intent(in) :: lpsize
476 : integer(IK) , intent(in), optional :: lmsize
477 : logical(LK) , optional :: failed
478 : #if SK_ENABLED && D0_ENABLED
479 : character(1,SKC), intent(in) :: lpfill
480 : character(1,SKC), intent(in), optional :: lmfill
481 : #elif SK_ENABLED && D1_ENABLED
482 : character(2,SKC), intent(in) :: lpfill
483 : character(2,SKC), intent(in), optional :: lmfill
484 : #elif IK_ENABLED && D1_ENABLED
485 : integer(IKC) , intent(in) :: lpfill
486 : integer(IKC) , intent(in), optional :: lmfill
487 : #elif LK_ENABLED && D1_ENABLED
488 : logical(LKC) , intent(in) :: lpfill
489 : logical(LKC) , intent(in), optional :: lmfill
490 : #elif CK_ENABLED && D1_ENABLED
491 : complex(CKC) , intent(in) :: lpfill
492 : complex(CKC) , intent(in), optional :: lmfill
493 : #elif RK_ENABLED && D1_ENABLED
494 : real(RKC) , intent(in) :: lpfill
495 : real(RKC) , intent(in), optional :: lmfill
496 : #else
497 : #error "Unrecognized interface."
498 : #endif
499 : integer(IK) :: sizeNew, lmsize_def
500 : integer(IK) :: lbp, ubp
501 : type :: OldNew_type
502 : integer(IK) :: old, new
503 : end type OldNew_type
504 : type(OldNew_type) :: lb, ub, lbc, ubc
505 :
506 : !> \bug
507 : !> GNU Fortran 10.3 cannot concatenate empty character array of length 2 with a non-empty character array of the same length.
508 : !> Fortran runtime error: Different CHARACTER lengths (0/2) in array constructor
509 4860 : if (present(lmsize)) then
510 3240 : if (lmsize == 0_IK) error stop "Internal ParaMonte Testing error occurred: GNU bug exception."
511 : end if
512 :
513 4860 : lmsize_def = getOption(0_IK, lmsize)
514 :
515 4860 : assertion = .true._LK
516 :
517 : ! Enlarge and setPaddedl and empty array
518 :
519 4860 : call reset()
520 :
521 4860 : call setUnifRand(lb%old, -10_IK, 10_IK)
522 4860 : lb%old = GEN_LBOLD(lb%old)
523 4860 : ub%old = lb%old + sizeOld - 1_IK
524 : lbc%old = lb%old
525 : ubc%old = ub%old
526 :
527 4860 : sizeNew = sizeOld + lmsize_def + lpsize
528 4860 : lb%new = lb%old
529 3078 : ub%new = lb%new + sizeNew - 1_IK
530 4860 : lbp = lb%new + lmsize_def
531 : ubp = ub%new
532 : lbc%new = lbp + lpsize
533 : ubc%new = ubp
534 :
535 : #if SK_ENABLED && D0_ENABLED
536 243 : allocate(character(sizeOld,SKC) :: Array)
537 1215 : call setUnifRand(Array, repeat(SKC_"A",len(Array)), repeat(SKC_"Z",len(Array)))
538 567 : arrayPadded = genRepeat(lmsize_def,lmfill)//genRepeat(lpsize,lpfill)//Array
539 : #else
540 5103 : allocate(Array(lb%old : ub%old))
541 : #if SK_ENABLED && D1_ENABLED
542 729 : call setUnifRand(Array, SKC_"AA", SKC_"ZZ")
543 : #elif LK_ENABLED && D1_ENABLED
544 3645 : call setUnifRand(Array)
545 : #elif IK_ENABLED && D1_ENABLED
546 3645 : call setUnifRand(Array, -100_IKC, +100_IKC)
547 : #elif CK_ENABLED && D1_ENABLED
548 2916 : call setUnifRand(Array, (-100._CKC,-500._CKC), (+100._CKC,+500._CKC))
549 : #elif RK_ENABLED && D1_ENABLED
550 2916 : call setUnifRand(Array, -100._RKC, +100._RKC)
551 : #endif
552 5103 : allocate(arrayPadded(lb%new : ub%new))
553 : !> \bug
554 : !> Bypass the GNU 10.3 bug for concatenation of zero-sized character arrays.
555 4617 : if (lmsize_def > 0_IK) then
556 44118 : arrayPadded(:) = [genRepeat(lmsize_def,lmfill), genRepeat(lpsize,lpfill), Array]
557 : else
558 15390 : arrayPadded(:) = [genRepeat(lpsize,lpfill), Array]
559 : end if
560 : #endif
561 :
562 : #if setPaddedl_ENABLED
563 3240 : if (present(lmsize)) then
564 2268 : call setPaddedl(Array, lpsize, lpfill, lmsize, lmfill, failed)
565 : else
566 1080 : call setPaddedl(Array, lpsize, lpfill, failed)
567 : end if
568 : #elif getPaddedl_ENABLED
569 1620 : if (present(lmsize)) then
570 13788 : Array = getPaddedl(Array, lpsize, lpfill, lmsize, lmfill)
571 : else
572 5157 : Array = getPaddedl(Array, lpsize, lpfill)
573 : end if
574 : #else
575 : #error "Unrecognized interface."
576 : #endif
577 :
578 4860 : if (present(failed)) then
579 1620 : assertion = assertion .and. .not. failed
580 1620 : call report()
581 1620 : call test%assert(assertion, desc = "Call to setPaddedl() must happen without failure.")
582 : end if
583 :
584 4860 : assertion = assertion .and. GET_SIZE(Array) == GET_SIZE(arrayPadded)
585 4860 : call report()
586 9720 : call test%assert(assertion, desc = "Call to setPaddedl()/getPaddedl() must yield an array of proper size, with present(lmfill) = "//getStr([present(lmfill)]))
587 :
588 11016 : assertion = assertion .and. GET_LBOUND(Array) == GET_LBOUND(arrayPadded)
589 4860 : call report()
590 14580 : call test%assert(assertion, desc = "Call to setPaddedl()/getPaddedl() must properly set the lower bound of the output array, with present(lmfill), present(failed) = "//getStr([present(lmfill), present(failed)]))
591 :
592 11016 : assertion = assertion .and. GEN_UBOUND(Array) == GEN_UBOUND(arrayPadded)
593 4860 : call report()
594 14580 : call test%assert(assertion, desc = "Call to setPaddedl()/getPaddedl() must properly set the upper bound of the output array, with present(lmfill), present(failed) = "//getStr([present(lmfill), present(failed)]))
595 :
596 23328 : assertion = assertion .and. ALL(Array(lbp : ubp) IS_EQUAL arrayPadded(lbp : ubp))
597 4860 : call report()
598 9720 : call test%assert(assertion, desc = "Call to setPaddedl()/getPaddedl() must properly set the contents of the output array, with present(lmfill) = "//getStr([present(lmfill)]))
599 :
600 4860 : if (present(lmsize) .and. present(lmfill)) then
601 4185 : assertion = assertion .and. ALL(Array(lb%new : lbp - 1_IK) IS_EQUAL arrayPadded(lb%new : lbp - 1_IK))
602 1620 : call report()
603 1620 : call test%assert(assertion, desc = "Call to setPaddedl()/getPaddedl() must properly fill the new left margin elements with `lmfill`")
604 : end if
605 :
606 4860 : end subroutine
607 :
608 : !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
609 :
610 4860 : subroutine reset()
611 4860 : if (allocated(Array)) deallocate(Array)
612 4860 : if (allocated(arrayPadded)) deallocate(arrayPadded)
613 4860 : end subroutine
614 :
615 : !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
616 :
617 486 : pure function genRepeat(count,fill) result(Array)
618 : integer(IK) , intent(in) :: count
619 : #if SK_ENABLED && D0_ENABLED
620 : character(1,SKC), intent(in), optional :: fill
621 : character(count,SKC) :: Array
622 1107 : if (present(fill)) Array(:) = repeat(fill, count)
623 : #else
624 : #if SK_ENABLED && D1_ENABLED
625 : character(2,SKC), intent(in), optional :: fill
626 : character(2,SKC) :: Array(count)
627 : #elif LK_ENABLED && D1_ENABLED
628 : logical(LKC) , intent(in), optional :: fill
629 : logical(LKC) :: Array(count)
630 : #elif IK_ENABLED && D1_ENABLED
631 : integer(IKC) , intent(in), optional :: fill
632 : integer(IKC) :: Array(count)
633 : #elif CK_ENABLED && D1_ENABLED
634 : complex(CKC) , intent(in), optional :: fill
635 : complex(CKC) :: Array(count)
636 : #elif RK_ENABLED && D1_ENABLED
637 : real(RKC) , intent(in), optional :: fill
638 : real(RKC) :: Array(count)
639 : #else
640 : #error "Unrecognized interface."
641 : #endif
642 19494 : if (present(fill)) Array(:) = fill
643 : #endif
644 486 : end function
645 :
646 : !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
647 :
648 22680 : subroutine report()
649 22680 : if (test%traceable .and. .not. assertion) then
650 : ! LCOV_EXCL_START
651 : write(test%disp%unit,"(*(g0,:,', '))")
652 : write(test%disp%unit,"(*(g0,:,', '))") "Array ", Array
653 : write(test%disp%unit,"(*(g0,:,', '))") "arrayPadded ", arrayPadded
654 : write(test%disp%unit,"(*(g0,:,', '))") "GET_LBOUND(Array ) ", GET_LBOUND(Array )
655 : write(test%disp%unit,"(*(g0,:,', '))") "GET_LBOUND(arrayPadded) ", GET_LBOUND(arrayPadded)
656 : write(test%disp%unit,"(*(g0,:,', '))") "GEN_UBOUND(Array ) ", GEN_UBOUND(Array )
657 : write(test%disp%unit,"(*(g0,:,', '))") "GEN_UBOUND(arrayPadded) ", GEN_UBOUND(arrayPadded)
658 : write(test%disp%unit,"(*(g0,:,', '))")
659 : ! LCOV_EXCL_STOP
660 : end if
661 22680 : end subroutine
662 :
663 : !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
664 :
665 : #undef GEN_UBOUND
666 : #undef GET_LBOUND
667 : #undef GEN_LBOLD
668 : #undef GEN_LBNEW
669 : #undef IS_EQUAL
670 : #undef GET_SIZE
671 : #undef ALL
672 :
673 : !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
674 : #elif getPaddedr_ENABLED || setPaddedr_ENABLED
675 : !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
676 :
677 : #if LK_ENABLED
678 : #define IS_EQUAL .eqv.
679 : #else
680 : #define IS_EQUAL ==
681 : #endif
682 :
683 : #if SK_ENABLED && D0_ENABLED
684 : #define GET_LBOUND(Array) 1_IK
685 : #define GEN_UBOUND(Array) len(Array, kind = IK)
686 : #define GET_SIZE(Array) len(Array, kind = IK)
687 : #define GEN_LBOLD(lb) 1_IK
688 : #define GEN_LBNEW(lb) 1_IK
689 : #elif getPaddedr_ENABLED
690 : #define GET_LBOUND(Array) 1_IK
691 : #define GEN_UBOUND(Array) size(Array, kind = IK)
692 : #define GET_SIZE(Array) size(Array, kind = IK)
693 : #define GEN_LBOLD(lb) 1_IK
694 : #define GEN_LBNEW(lb) 1_IK
695 : #else
696 : #define GET_LBOUND(Array) lbound(Array, dim = 1, kind = IK)
697 : #define GEN_UBOUND(Array) ubound(Array, dim = 1, kind = IK)
698 : #define GET_SIZE(Array) size(Array, kind = IK)
699 : #define GEN_LBOLD(lb) lb
700 : #define GEN_LBNEW(lb) lb
701 : #endif
702 :
703 : #if SK_ENABLED && D0_ENABLED
704 : #define ALL
705 2 : character(:,SKC), allocatable :: Array, arrayPadded
706 : character(1,SKC), parameter :: rpfill = SKC_"/"
707 : character(1,SKC), parameter :: rmfill = SKC_"-"
708 : #elif SK_ENABLED && D1_ENABLED
709 : character(2,SKC), dimension(:), allocatable :: Array, arrayPadded
710 : character(2,SKC), parameter :: rpfill = SKC_"//"
711 : character(2,SKC), parameter :: rmfill = SKC_"--"
712 : #elif IK_ENABLED && D1_ENABLED
713 : integer(IKC) , dimension(:), allocatable :: Array, arrayPadded
714 : integer(IKC) , parameter :: rpfill = huge(1_IKC)
715 : integer(IKC) , parameter :: rmfill = huge(1_IKC)
716 : #elif LK_ENABLED && D1_ENABLED
717 : logical(LKC) , dimension(:), allocatable :: Array, arrayPadded
718 : logical(LKC) , parameter :: rpfill = .false._LKC
719 : logical(LKC) , parameter :: rmfill = .false._LKC
720 : #elif CK_ENABLED && D1_ENABLED
721 : complex(CKC) , dimension(:), allocatable :: Array, arrayPadded
722 : complex(CKC) , parameter :: rpfill = cmplx(huge(0._CKC), huge(0._CKC), kind = CKC)
723 : complex(CKC) , parameter :: rmfill = cmplx(huge(0._CKC), huge(0._CKC), kind = CKC)
724 : #elif RK_ENABLED && D1_ENABLED
725 : real(RKC) , dimension(:), allocatable :: Array, arrayPadded
726 : real(RKC) , parameter :: rpfill = huge(0._RKC)
727 : real(RKC) , parameter :: rmfill = huge(0._RKC)
728 : #else
729 : #error "Unrecognized interface."
730 : #endif
731 : integer(IK) :: i, j, k
732 :
733 : !> \bug
734 : !> Avoid zero margin and setPaddedr sizes in the following because of the GNU gfortran bug as of 10.3.
735 : integer(IK) , parameter :: SizePad(3) = [ 1_IK &
736 : , 2_IK &
737 : , 3_IK &
738 : ]
739 : integer(IK) , parameter :: SizeMarg(3)= [ 1_IK &
740 : , 2_IK &
741 : , 2_IK &
742 : ]
743 : integer(IK) , parameter :: SizeArray(3) = [ 1_IK &
744 : , 2_IK &
745 : , 3_IK &
746 : ] ! Avoid zero-sized arrays in the following because it messes up with the array lower bounds and resets it to 1 which causes the tests to wrongly fail.
747 : #if setPaddedr_ENABLED
748 : logical(LK) :: failed
749 : #endif
750 :
751 : !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
752 :
753 40 : assertion = .true._LK
754 162 : do i = 1, size(SizeArray,1,IK)
755 520 : do j = 1, size(SizePad,1,IK)
756 1560 : do k = 1, size(SizeMarg,1,IK)
757 1080 : call runTestsWith(sizeOld = SizeArray(i), rpsize = SizePad(j), rpfill = rpfill)
758 1080 : call runTestsWith(sizeOld = SizeArray(i), rpsize = SizePad(j), rpfill = rpfill, rmsize = SizeMarg(k))
759 1260 : call runTestsWith(sizeOld = SizeArray(i), rpsize = SizePad(j), rpfill = rpfill, rmsize = SizeMarg(k), rmfill = rmfill)
760 : #if setPaddedr_ENABLED
761 540 : call runTestsWith(sizeOld = SizeArray(i), rpsize = SizePad(j), rpfill = rpfill, failed = failed)
762 540 : call runTestsWith(sizeOld = SizeArray(i), rpsize = SizePad(j), rpfill = rpfill, rmsize = SizeMarg(k), failed = failed)
763 720 : call runTestsWith(sizeOld = SizeArray(i), rpsize = SizePad(j), rpfill = rpfill, rmsize = SizeMarg(k), rmfill = rmfill, failed = failed)
764 : #endif
765 : end do
766 : end do
767 : end do
768 :
769 : contains
770 :
771 4860 : subroutine runTestsWith(sizeOld, rpsize, rpfill, rmsize, rmfill, failed)
772 :
773 : integer(IK) , intent(in) :: sizeOld
774 : integer(IK) , intent(in) :: rpsize
775 : integer(IK) , intent(in), optional :: rmsize
776 : logical(LK) , optional :: failed
777 : #if SK_ENABLED && D0_ENABLED
778 : character(1,SKC), intent(in) :: rpfill
779 : character(1,SKC), intent(in), optional :: rmfill
780 : #elif SK_ENABLED && D1_ENABLED
781 : character(2,SKC), intent(in) :: rpfill
782 : character(2,SKC), intent(in), optional :: rmfill
783 : #elif IK_ENABLED && D1_ENABLED
784 : integer(IKC) , intent(in) :: rpfill
785 : integer(IKC) , intent(in), optional :: rmfill
786 : #elif LK_ENABLED && D1_ENABLED
787 : logical(LKC) , intent(in) :: rpfill
788 : logical(LKC) , intent(in), optional :: rmfill
789 : #elif CK_ENABLED && D1_ENABLED
790 : complex(CKC) , intent(in) :: rpfill
791 : complex(CKC) , intent(in), optional :: rmfill
792 : #elif RK_ENABLED && D1_ENABLED
793 : real(RKC) , intent(in) :: rpfill
794 : real(RKC) , intent(in), optional :: rmfill
795 : #else
796 : #error "Unrecognized interface."
797 : #endif
798 : integer(IK) :: sizeNew, rmsize_def
799 : integer(IK) :: lbp, ubp
800 : type :: OldNew_type
801 : integer(IK) :: old, new
802 : end type OldNew_type
803 : type(OldNew_type) :: lb, ub, lbc, ubc
804 :
805 : !> \bug
806 : !> GNU Fortran 10.3 cannot concatenate empty character array of length 2 with a non-empty character array of the same length.
807 : !> Fortran runtime error: Different CHARACTER lengths (0/2) in array constructor
808 4860 : if (present(rmsize)) then
809 3240 : if (rmsize == 0_IK) error stop "Internal ParaMonte Testing error occurred: GNU bug exception."
810 : end if
811 :
812 4860 : rmsize_def = getOption(0_IK, rmsize)
813 :
814 4860 : assertion = .true._LK
815 :
816 : ! Enlarge and setPaddedr and empty array.
817 :
818 4860 : call reset()
819 :
820 4860 : call setUnifRand(lb%old, -10_IK, 10_IK)
821 4860 : lb%old = GEN_LBOLD(lb%old)
822 4860 : ub%old = lb%old + sizeOld - 1_IK
823 : lbc%old = lb%old
824 : ubc%old = ub%old
825 :
826 4860 : sizeNew = sizeOld + rmsize_def + rpsize
827 4860 : lb%new = lb%old
828 3078 : ub%new = lb%new + sizeNew - 1_IK
829 : lbp = lb%new
830 4860 : ubp = ub%new - rmsize_def
831 : lbc%new = lbp
832 : ubc%new = ubp - rpsize
833 :
834 : #if SK_ENABLED && D0_ENABLED
835 243 : allocate(character(sizeOld,SKC) :: Array)
836 1215 : call setUnifRand(Array, repeat(SKC_"A",len(Array,IK)), repeat(SKC_"Z",len(Array,IK)))
837 567 : arrayPadded = Array//genRepeat(rpsize,rpfill)//genRepeat(rmsize_def,rmfill)
838 : #else
839 5103 : allocate(Array(lb%old : ub%old))
840 : #if SK_ENABLED && D1_ENABLED
841 729 : call setUnifRand(Array, SKC_"AA", SKC_"ZZ")
842 : #elif LK_ENABLED && D1_ENABLED
843 3645 : call setUnifRand(Array)
844 : #elif IK_ENABLED && D1_ENABLED
845 3645 : call setUnifRand(Array, -100_IKC, +100_IKC)
846 : #elif CK_ENABLED && D1_ENABLED
847 2916 : call setUnifRand(Array, (-100._CKC,-500._CKC), (+100._CKC,+500._CKC))
848 : #elif RK_ENABLED && D1_ENABLED
849 2916 : call setUnifRand(Array, -100._RKC, +100._RKC)
850 : #endif
851 5103 : allocate(arrayPadded(lb%new : ub%new))
852 : !> \bug
853 : !> Bypass the GNU 10.3 bug for concatenation of zero-sized character arrays.
854 4617 : if (rmsize_def > 0_IK) then
855 44118 : arrayPadded(:) = [Array, genRepeat(rpsize,rpfill), genRepeat(rmsize_def,rmfill)]
856 : else
857 15390 : arrayPadded(:) = [Array, genRepeat(rpsize,rpfill)]
858 : end if
859 : #endif
860 :
861 : #if setPaddedr_ENABLED
862 3240 : if (present(rmsize)) then
863 2268 : call setPaddedr(Array, rpsize, rpfill, rmsize, rmfill, failed)
864 : else
865 1080 : call setPaddedr(Array, rpsize, rpfill, failed)
866 : end if
867 : #elif getPaddedr_ENABLED
868 1620 : if (present(rmsize)) then
869 13788 : Array = getPaddedr(Array, rpsize, rpfill, rmsize, rmfill)
870 : else
871 5157 : Array = getPaddedr(Array, rpsize, rpfill)
872 : end if
873 : #else
874 : #error "Unrecognized interface."
875 : #endif
876 :
877 4860 : if (present(failed)) then
878 1620 : assertion = assertion .and. .not. failed
879 1620 : call report()
880 1620 : call test%assert(assertion, desc = "Call to setPaddedr() must happen without failure.")
881 : end if
882 :
883 4860 : assertion = assertion .and. GET_SIZE(Array) == GET_SIZE(arrayPadded)
884 4860 : call report()
885 9720 : call test%assert(assertion, desc = "Call to setPaddedr()/getPaddedr() must yield an array of proper size, with present(rmfill) = "//getStr([present(rmfill)]))
886 :
887 11016 : assertion = assertion .and. GET_LBOUND(Array) == GET_LBOUND(arrayPadded)
888 4860 : call report()
889 14580 : call test%assert(assertion, desc = "Call to setPaddedr()/getPaddedr() must properly set the lower bound of the output array, with present(rmfill), present(failed) = "//getStr([present(rmfill), present(failed)]))
890 :
891 11016 : assertion = assertion .and. GEN_UBOUND(Array) == GEN_UBOUND(arrayPadded)
892 4860 : call report()
893 14580 : call test%assert(assertion, desc = "Call to setPaddedr()/getPaddedr() must properly set the upper bound of the output array, with present(rmfill), present(failed) = "//getStr([present(rmfill), present(failed)]))
894 :
895 23328 : assertion = assertion .and. ALL(Array(lbp : ubp) IS_EQUAL arrayPadded(lbp : ubp))
896 4860 : call report()
897 9720 : call test%assert(assertion, desc = "Call to setPaddedr()/getPaddedr() must properly set the contents of the output array, with present(rmfill) = "//getStr([present(rmfill)]))
898 :
899 4860 : if (present(rmsize) .and. present(rmfill)) then
900 1620 : assertion = assertion .and. ALL(Array(lb%new : lbp - 1_IK) IS_EQUAL arrayPadded(lb%new : lbp - 1_IK))
901 1620 : call report()
902 1620 : call test%assert(assertion, desc = "Call to setPaddedr()/getPaddedr() must properly fill the new right margin elements with `rmfill`")
903 : end if
904 :
905 4860 : end subroutine
906 :
907 : !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
908 :
909 4860 : subroutine reset()
910 4860 : if (allocated(Array)) deallocate(Array)
911 4860 : if (allocated(arrayPadded)) deallocate(arrayPadded)
912 4860 : end subroutine
913 :
914 : !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
915 :
916 486 : pure function genRepeat(count,fill) result(Array)
917 : integer(IK) , intent(in) :: count
918 : #if SK_ENABLED && D0_ENABLED
919 : character(1,SKC), intent(in), optional :: fill
920 : character(count,SKC) :: Array
921 1107 : if (present(fill)) Array(:) = repeat(fill, count)
922 : #else
923 : #if SK_ENABLED && D1_ENABLED
924 : character(2,SKC), intent(in), optional :: fill
925 : character(2,SKC) :: Array(count)
926 : #elif LK_ENABLED && D1_ENABLED
927 : logical(LKC) , intent(in), optional :: fill
928 : logical(LKC) :: Array(count)
929 : #elif IK_ENABLED && D1_ENABLED
930 : integer(IKC) , intent(in), optional :: fill
931 : integer(IKC) :: Array(count)
932 : #elif CK_ENABLED && D1_ENABLED
933 : complex(CKC) , intent(in), optional :: fill
934 : complex(CKC) :: Array(count)
935 : #elif RK_ENABLED && D1_ENABLED
936 : real(RKC) , intent(in), optional :: fill
937 : real(RKC) :: Array(count)
938 : #else
939 : #error "Unrecognized interface."
940 : #endif
941 19494 : if (present(fill)) Array(:) = fill
942 : #endif
943 486 : end function
944 :
945 : !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
946 :
947 22680 : subroutine report()
948 22680 : if (test%traceable .and. .not. assertion) then
949 : ! LCOV_EXCL_START
950 : write(test%disp%unit,"(*(g0,:,', '))")
951 : write(test%disp%unit,"(*(g0,:,', '))") "Array ", Array
952 : write(test%disp%unit,"(*(g0,:,', '))") "arrayPadded ", arrayPadded
953 : write(test%disp%unit,"(*(g0,:,', '))") "GET_LBOUND(Array ) ", GET_LBOUND(Array )
954 : write(test%disp%unit,"(*(g0,:,', '))") "GET_LBOUND(arrayPadded) ", GET_LBOUND(arrayPadded)
955 : write(test%disp%unit,"(*(g0,:,', '))") "GEN_UBOUND(Array ) ", GEN_UBOUND(Array )
956 : write(test%disp%unit,"(*(g0,:,', '))") "GEN_UBOUND(arrayPadded) ", GEN_UBOUND(arrayPadded)
957 : write(test%disp%unit,"(*(g0,:,', '))")
958 : ! LCOV_EXCL_STOP
959 : end if
960 22680 : end subroutine
961 :
962 : !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
963 :
964 : #undef GEN_UBOUND
965 : #undef GET_LBOUND
966 : #undef GEN_LBOLD
967 : #undef GEN_LBNEW
968 : #undef IS_EQUAL
969 : #undef GET_SIZE
970 : #undef ALL
971 :
972 : #else
973 : !%%%%%%%%%%%%%%%%%%%%%%%%
974 : #error "Unrecognized interface."
975 : !%%%%%%%%%%%%%%%%%%%%%%%%
976 : #endif
|
