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 of [pm_arraySort](@ref pm_arraySort).
19 : !>
20 : !> \fintest
21 : !>
22 : !> \author
23 : !> \AmirShahmoradi, April 21, 2017, 1:54 AM, Institute for Computational Engineering and Sciences (ICES), The University of Texas at Austin
24 :
25 : !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
26 :
27 : !%%%%%%%%%%%%%%%%
28 : #if setSorted_ENABLED
29 : !%%%%%%%%%%%%%%%%
30 :
31 : #if Ind_ENABLED
32 : integer(IK), allocatable :: index(:)
33 : #else
34 : #if Arr_ENABLED && Qsorti_ENABLED
35 : #define METHOD_TYPE qsorti_type
36 : #elif Arr_ENABLED && Qsortr_ENABLED
37 : #define METHOD_TYPE qsortr_type
38 : #elif Arr_ENABLED && Qsortrdp_ENABLED
39 : #define METHOD_TYPE qsortrdp_type
40 : #elif Arr_ENABLED && Bubble_ENABLED
41 : #define METHOD_TYPE bubble_type
42 : #elif Arr_ENABLED && Heapi_ENABLED
43 : #define METHOD_TYPE heapi_type
44 : #elif Arr_ENABLED && Heapr_ENABLED
45 : #define METHOD_TYPE heapr_type
46 : #elif Arr_ENABLED && Insertionl_ENABLED
47 : #define METHOD_TYPE insertionl_type
48 : #elif Arr_ENABLED && Insertionb_ENABLED
49 : #define METHOD_TYPE insertionb_type
50 : #elif Arr_ENABLED && Merger_ENABLED
51 : #define METHOD_TYPE merger_type
52 : #elif Arr_ENABLED && Selection_ENABLED
53 : #define METHOD_TYPE selection_type
54 : #elif Arr_ENABLED && Shell_ENABLED
55 : #define METHOD_TYPE shell_type
56 : #else
57 : #error "Unrecognized Interface."
58 : #endif
59 : type(METHOD_TYPE), parameter :: method = METHOD_TYPE()
60 : #endif
61 : ! test data.
62 : integer(IK), parameter :: NDATA = 1000_IK
63 : #if SK_ENABLED && D0_ENABLED
64 : #define GET_SIZE(array) len(array, kind = IK)
65 : #define GET_INDEX(i) i:i
66 : character(0,SKC) :: empty
67 12 : character(:,SKC) , allocatable :: array
68 : character(1,SKC) , parameter :: LOWER = SKC_"a", UPPER = SKC_"z"
69 : #else
70 : #define GET_INDEX(i) i
71 : #define GET_SIZE(array) size(array, kind = IK)
72 : #if SK_ENABLED && D1_ENABLED
73 : character(2,SKC) :: empty(0)
74 : character(2,SKC) , allocatable :: array(:)
75 : character(2,SKC) , parameter :: LOWER = SKC_"aA", UPPER = SKC_"zZ"
76 : #elif IK_ENABLED && D1_ENABLED
77 : integer(IKC) :: empty(0)
78 : integer(IKC) , allocatable :: array(:)
79 : integer(IKC) , parameter :: LOWER = 1_IKC, UPPER = huge(1_IKC)
80 : #elif LK_ENABLED && D1_ENABLED
81 : logical(LKC) :: empty(0)
82 : logical(LKC) , allocatable :: array(:)
83 : logical(LKC) , parameter :: LOWER = .false._LKC, UPPER = .true._LKC
84 : #elif CK_ENABLED && D1_ENABLED
85 : complex(CKC) :: empty(0)
86 : complex(CKC) , allocatable :: array(:)
87 : complex(CKC) , parameter :: LOWER = cmplx(1._CKC, -huge(1._CKC), CKC), UPPER = cmplx(huge(1._CKC), -1._CKC, CKC)
88 : #elif RK_ENABLED && D1_ENABLED
89 : real(RKC) :: empty(0)
90 : real(RKC) , allocatable :: array(:)
91 : real(RKC) , parameter :: LOWER = 1._RKC, UPPER = huge(1._RKC)
92 : #elif PSSK_ENABLED && D1_ENABLED
93 : integer(IK) :: i
94 : type(css_pdt(SKC)) :: empty(0)
95 : type(css_pdt(SKC)) , allocatable :: array(:)
96 : do i = 1, NDATA
97 : allocate(character(SKC,2) :: array(i)%val)
98 : call setUnifRand(array(i)%val, SKC_"AA", SKC_"ZZ")
99 : end do
100 : !write(*,"(1(g0,:,' '))") array
101 : !error stop
102 : #else
103 : #error "Unrecognized Interface."
104 : #endif
105 : #endif
106 240 : assertion = .true._LK
107 240 : call runTestsWith()
108 240 : call runTestsWith(isSortedElement)
109 :
110 : contains
111 :
112 480 : subroutine runTestsWith(isSortedElement)
113 : procedure(logical(LK)), optional :: isSortedElement
114 : logical(LK) :: isPresentMethod
115 : integer(IK) :: i, lenArray
116 96480 : do i = 1_IK, 200_IK
117 96000 : isPresentMethod = getUnifRand()
118 96000 : lenArray = getUnifRand(0, 500)
119 96000 : if (allocated(array)) deallocate(array)
120 : #if SK_ENABLED && D0_ENABLED
121 4800 : allocate(character(lenArray,SKC) :: array)
122 : !call setUnifRand(array, repeat(SKC_"a", len(array)), repeat(SKC_"z", len(array)))
123 4800 : call setUnifRand(array)
124 : #else
125 100783 : allocate(array(1 : lenArray))
126 22883343 : call setUnifRand(array)!, LOWER, UPPER) ! bounds are commented out due to a potential gfortran-13 bug. See commnets below for info.
127 : #endif
128 : #if Ind_ENABLED
129 8000 : call setResized(index, lenArray)
130 8000 : if (present(isSortedElement)) then
131 4000 : call setSorted(array, index, isSortedElement)
132 4000 : assertion = assertion .and. isDescending(getRemapped(array, index))
133 : else
134 4000 : call setSorted(array, index)
135 4000 : assertion = assertion .and. isAscending(getRemapped(array, index))
136 : end if
137 : #elif Arr_ENABLED
138 88000 : if (present(isSortedElement)) then
139 44000 : if (isPresentMethod) then
140 21942 : call setSorted(array, isSortedElement, method)
141 : else
142 22058 : call setSorted(array, isSortedElement)
143 : end if
144 44000 : assertion = assertion .and. isDescending(array)
145 : else
146 44000 : if (isPresentMethod) then
147 22012 : call setSorted(array, method)
148 : else
149 21988 : call setSorted(array)
150 : end if
151 44000 : assertion = assertion .and. isAscending(array)
152 : end if
153 : #endif
154 96000 : if (test%traceable .and. .not. assertion) then
155 : ! LCOV_EXCL_START
156 : call test%disp%skip()
157 : call test%disp%show("present(isSortedElement)")
158 : call test%disp%show( present(isSortedElement) )
159 : #if Ind_ENABLED
160 : call test%disp%show("index")
161 : call test%disp%show( index )
162 : #elif Arr_ENABLED
163 : call test%disp%show("isPresentMethod")
164 : call test%disp%show( isPresentMethod )
165 : #endif
166 : call test%disp%show("array")
167 : call test%disp%show( array )
168 : call test%disp%skip()
169 : ! LCOV_EXCL_STOP
170 : end if
171 96480 : call test%assert(assertion, SK_"setSorted() must correctly sort the input array or its index.", int(__LINE__, IK))
172 : end do
173 : #if Ind_ENABLED
174 40 : if (present(isSortedElement)) then
175 20 : if (isPresentMethod) then
176 10 : call setSorted(empty, isSortedElement)
177 : else
178 10 : call setSorted(empty, isSortedElement)
179 : end if
180 : else
181 20 : if (isPresentMethod) then
182 12 : call setSorted(empty)
183 : else
184 8 : call setSorted(empty)
185 : end if
186 : end if
187 40 : call test%assert(assertion, SK_"setSorted() must handle empty array sorting with present(isSortedElement) = "//getStr(present(isSortedElement)), int(__LINE__, IK))
188 : #elif Arr_ENABLED
189 440 : if (present(isSortedElement)) then
190 220 : if (isPresentMethod) then
191 129 : call setSorted(empty, isSortedElement, method)
192 : else
193 91 : call setSorted(empty, isSortedElement)
194 : end if
195 : else
196 220 : if (isPresentMethod) then
197 118 : call setSorted(empty, method)
198 : else
199 102 : call setSorted(empty)
200 : end if
201 : end if
202 440 : call test%assert(assertion, SK_"setSorted() must handle empty array sorting with present(isSortedElement) = "//getStr(present(isSortedElement)), int(__LINE__, IK))
203 : #endif
204 480 : end subroutine runTestsWith
205 :
206 340015640 : pure function isSortedElement(a, b) result(sorted)
207 : logical(LK) :: sorted
208 : #if SK_ENABLED && D0_ENABLED
209 : character(1,SKC) , intent(in) :: a, b
210 : #elif SK_ENABLED && D1_ENABLED
211 : character(*,SKC) , intent(in) :: a, b
212 : #elif IK_ENABLED && D1_ENABLED
213 : integer(IKC) , intent(in) :: a, b
214 : #elif LK_ENABLED && D1_ENABLED
215 : logical(LKC) , intent(in) :: a, b
216 : #elif CK_ENABLED && D1_ENABLED
217 : complex(CKC) , intent(in) :: a, b
218 : #elif RK_ENABLED && D1_ENABLED
219 : real(RKC) , intent(in) :: a, b
220 : #elif PSSK_ENABLED && D1_ENABLED
221 : type(css_pdt(SKC)) , intent(in) :: a, b
222 : #else
223 : #error "Unrecognized interface."
224 : #endif
225 340015640 : sorted = a > b
226 340015640 : end function
227 :
228 : !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
229 : #elif isSorted_ENABLED || isAscending_ENABLED || isDescending_ENABLED
230 : !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
231 :
232 : #if isSorted_ENABLED
233 : use pm_arraySort, only: isOrdered => isSorted
234 : #elif isAscending_ENABLED
235 : use pm_arraySort, only: isOrdered => isAscending
236 : #elif isDescending_ENABLED
237 : use pm_arraySort, only: isOrdered => isDescending
238 : #else
239 : #error "Unrecognized interface."
240 : #endif
241 : integer(IK) , parameter :: NDATA = 1000_IK
242 : #if D0_ENABLED && SK_ENABLED
243 : character(0,SKC) :: Empty
244 : character(NDATA) :: dataUnsorted
245 3 : call setUnifRand(dataUnsorted, repeat(SKC_"A", len(dataUnsorted,IK)), repeat(SKC_"Z", len(dataUnsorted,IK)))
246 : #elif D1_ENABLED && SK_ENABLED
247 : character(2,SKC) :: Empty(0)
248 : character(2,SKC) :: dataUnsorted(NDATA)
249 3003 : call setUnifRand(dataUnsorted, SKC_"AA", SKC_"ZZ")
250 : #elif D1_ENABLED && IK_ENABLED
251 : integer(IKC) :: Empty(0)
252 : integer(IKC) :: dataUnsorted(NDATA)
253 15015 : call setUnifRand(dataUnsorted, 1_IKC, huge(1_IKC))
254 : #elif D1_ENABLED && LK_ENABLED
255 : logical(LKC) :: Empty(0)
256 : logical(LKC) :: dataUnsorted(NDATA)
257 15015 : call setUnifRand(dataUnsorted)
258 : #elif D1_ENABLED && CK_ENABLED
259 : complex(CKC) , parameter :: LB = cmplx(0., -9., CKC), UB = cmplx(9., 0., CKC)
260 : complex(CKC) :: dataUnsorted(NDATA)
261 : complex(CKC) :: Empty(0)
262 : ! \bug
263 : ! gfortran-13 release mode heap-memory nocheck shared-lib passes NAN values to `setUnifRand()` for some of the input bounds.
264 : ! This caused infinite loops in `setUnifRand()`. Thus, the implementation of `setUnifRand()` was modified to handle NANs gracefully.
265 : ! The root cause of this remains unknown. For now, the bounds are excluded to allow testing to proceed.
266 : ! This issue could be related to the `elemental` attribute of `setUnifRand()` as similar problems
267 : ! have been also observed for other `elemental` routines.
268 12012 : call setUnifRand(dataUnsorted)!, LB, UB)
269 : #elif D1_ENABLED && RK_ENABLED
270 : real(RKC) :: dataUnsorted(NDATA)
271 : real(RKC) :: Empty(0)
272 12012 : call setUnifRand(dataUnsorted, 1._RKC, huge(1._RKC))
273 : #elif D1_ENABLED && PSSK_ENABLED
274 : integer(IK) :: i
275 : type(css_pdt(SKC)) :: Empty(0)
276 : type(css_pdt(SKC)) :: dataUnsorted(NDATA)
277 : do i = 1, NDATA
278 : allocate(character(SKC,2) :: dataUnsorted(i)%val)
279 : call setUnifRand(dataUnsorted(i)%val, SKC_"AA", SKC_"ZZ")
280 : end do
281 : #else
282 : #error "Unrecognized Interface."
283 : #endif
284 : ! Test for contiguous input arrays.
285 : ! The following tests may, in extremely rare conditions fail, for example, when the generated random array is fully sorted.
286 :
287 : !call random_seed()
288 60 : assertion = isOrdered(Empty)
289 60 : call test%assert(assertion, SK_"isOrdered() must return `.true.` for an input `contiguous` array of rank 1 of length 0.", int(__LINE__, IK))
290 :
291 60 : assertion = .not. isOrdered(dataUnsorted)
292 60 : call test%assert(assertion, SK_"isOrdered() must return `.false.` for an input contiguous unsorted array.", int(__LINE__, IK))
293 :
294 60 : call setSorted(dataUnsorted)
295 : #if isSorted_ENABLED || isAscending_ENABLED
296 40 : assertion = isOrdered(dataUnsorted)
297 : #elif isDescending_ENABLED
298 20 : assertion = .not. isOrdered(dataUnsorted)
299 : #endif
300 60 : call test%assert(assertion, SK_"isOrdered() must return a valid result for an input contiguous ascending-sorted array.", int(__LINE__, IK))
301 57060 : dataUnsorted = getReversed(dataUnsorted) ! This is called due to a GFortran bug as of GFortran version 10.3.
302 : #if isSorted_ENABLED || isDescending_ENABLED
303 40 : assertion = isOrdered(dataUnsorted)
304 : #elif isAscending_ENABLED
305 20 : assertion = .not. isOrdered(dataUnsorted)
306 : #endif
307 60 : call test%assert(assertion, SK_"isOrdered() must return a valid result for an input contiguous descending-sorted array.", int(__LINE__, IK))
308 :
309 : #if D0_ENABLED && SK_ENABLED
310 3003 : dataUnsorted(:) = repeat(dataUnsorted(1:1), len(dataUnsorted, kind = IK))
311 : #else
312 60060 : dataUnsorted(:) = dataUnsorted(1)
313 : #endif
314 60 : assertion = isOrdered(dataUnsorted)
315 60 : call test%assert(assertion, SK_"isOrdered() must return `.true.` for an input contiguous identically-valued array.", int(__LINE__, IK))
316 : #else
317 : !%%%%%%%%%%%%%%%%%%%%%%%%
318 : #error "Unrecognized interface."
319 : !%%%%%%%%%%%%%%%%%%%%%%%%
320 : #endif
321 : #undef METHOD_TYPE
322 : #undef COMPONENT
323 : #undef GET_INDEX
324 : #undef GET_SIZE
325 : #undef METHOD
|
