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 interface [setSorted](@ref pm_arraySelect::setSorted).
19 : !>
20 : !> \author
21 : !> \AmirShahmoradi
22 :
23 : !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
24 :
25 : #if setSelected_D1_PSSK_ENABLED || getSelected_D1_PSSK_ENABLED
26 : #define GET_COMP(X)X%val
27 : #else
28 : #define GET_COMP(X)X
29 : #endif
30 :
31 : #if setSelected_D0_SK_ENABLED || getSelected_D0_SK_ENABLED
32 : #define GET_INDEX(i) i:i
33 : #else
34 : #define GET_INDEX(i) i
35 : #endif
36 :
37 : #if setSelected_D1_CK_ENABLED || getSelected_D1_CK_ENABLED
38 : use pm_complexCompareLex, only: operator(>), operator(<)
39 : #endif
40 :
41 : #if setSelected_D1_LK_ENABLED || getSelected_D1_LK_ENABLED
42 : use pm_logicalCompare, only: operator(>), operator(<)
43 : #define IS_EQUAL .eqv.
44 : #else
45 : #define IS_EQUAL ==
46 : #endif
47 : integer(IK) , parameter :: NDATA = 1000_IK
48 : #if setSelected_D0_SK_ENABLED || getSelected_D0_SK_ENABLED
49 : character(NDATA,SKC) :: dataUnsorted, DataUnsorted_ref
50 : character(1,SKC) :: selection
51 2 : call setUnifRand(DataUnsorted_ref)
52 : #elif setSelected_D1_SK_ENABLED || getSelected_D1_SK_ENABLED
53 : character(2,SKC) :: dataUnsorted(NDATA), DataUnsorted_ref(NDATA), selection
54 2002 : call setUnifRand(DataUnsorted_ref)
55 : #elif setSelected_D1_IK_ENABLED || getSelected_D1_IK_ENABLED
56 : integer(IKC) :: dataUnsorted(NDATA), DataUnsorted_ref(NDATA), selection
57 10010 : call setUnifRand(DataUnsorted_ref, 0_IKC, huge(DataUnsorted_ref) - 1_IKC)
58 : #elif setSelected_D1_LK_ENABLED || getSelected_D1_LK_ENABLED
59 : logical(LKC) :: dataUnsorted(NDATA), DataUnsorted_ref(NDATA), selection
60 10010 : call setUnifRand(DataUnsorted_ref)
61 : #elif setSelected_D1_CK_ENABLED || getSelected_D1_CK_ENABLED
62 : complex(CKC) :: dataUnsorted(NDATA), DataUnsorted_ref(NDATA), selection
63 8008 : call setUnifRand(DataUnsorted_ref)
64 : #elif setSelected_D1_RK_ENABLED || getSelected_D1_RK_ENABLED
65 : real(RKC) :: dataUnsorted(NDATA), DataUnsorted_ref(NDATA), selection
66 8008 : call setUnifRand(DataUnsorted_ref)
67 : #elif setSelected_D1_PSSK_ENABLED || getSelected_D1_PSSK_ENABLED
68 : type(css_pdt(SKC)) :: dataUnsorted(NDATA), DataUnsorted_ref(NDATA), selection
69 : integer(IK) :: stringSize
70 : integer(IK) :: i
71 : do i = 1_IK, NDATA
72 : call setUnifRand(stringSize, 1_IK, 100_IK)
73 : allocate(character(stringSize,SKC) :: DataUnsorted_ref(i)%val)
74 : call setUnifRand(DataUnsorted_ref(i)%val)
75 : end do
76 : #else
77 : #error "Unrecognized Interface."
78 : #endif
79 :
80 40 : assertion = .true._LK
81 :
82 : !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
83 :
84 40 : call runWith()
85 40 : call runWith(isAscending_local)
86 40 : call runWith(isDescending_local)
87 :
88 : !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
89 :
90 : contains
91 :
92 : !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
93 :
94 120 : subroutine runWith(isSorted_local)
95 :
96 : logical(LK), external, optional :: isSorted_local
97 :
98 6120 : dataUnsorted = DataUnsorted_ref; call runTestsWith(rank = 1_IK)
99 6120 : dataUnsorted = DataUnsorted_ref; call runTestsWith(rank = NDATA / 2)
100 6120 : dataUnsorted = DataUnsorted_ref; call runTestsWith(rank = NDATA)
101 :
102 : !> \warning The following tests are ordered.
103 6120 : dataUnsorted = DataUnsorted_ref
104 120 : call runTestsWith(isSorted_local = isSorted_local, rank = 1_IK, lb = 1_IK)
105 120 : call runTestsWith(isSorted_local = isSorted_local, rank = NDATA / 4_IK - 1_IK)
106 120 : call runTestsWith(isSorted_local = isSorted_local, rank = NDATA / 2_IK, lb = NDATA / 4_IK - 1_IK)
107 120 : call runTestsWith(isSorted_local = isSorted_local, rank = NDATA, lb = NDATA / 2_IK + 1_IK)
108 :
109 : !> \warning The following tests are ordered.
110 6120 : dataUnsorted = DataUnsorted_ref
111 120 : call runTestsWith(isSorted_local = isSorted_local, rank = NDATA, ub = NDATA)
112 120 : call runTestsWith(isSorted_local = isSorted_local, rank = 1_IK, ub = 3 * NDATA / 4_IK + 1_IK)
113 120 : call runTestsWith(isSorted_local = isSorted_local, rank = NDATA / 2_IK, ub = 3_IK * NDATA / 4_IK - 1_IK)
114 :
115 : !> \warning The following tests are ordered.
116 6120 : dataUnsorted = DataUnsorted_ref
117 120 : call runTestsWith(isSorted_local = isSorted_local, rank = 1_IK, lb = 1_IK, ub = NDATA)
118 120 : call runTestsWith(isSorted_local = isSorted_local, rank = NDATA / 2_IK, lb = NDATA / 4_IK - 1_IK, ub = 3_IK * NDATA / 4_IK - 1_IK)
119 120 : call runTestsWith(isSorted_local = isSorted_local, rank = NDATA, lb = NDATA / 4_IK + 1_IK, ub = NDATA)
120 :
121 120 : end subroutine
122 :
123 : !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
124 :
125 1560 : subroutine runTestsWith(isSorted_local, rank, lb, ub)
126 :
127 : logical(LK), external, optional :: isSorted_local
128 : integer(IK), optional :: rank, lb, ub
129 :
130 : !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
131 :
132 : #if setSelected_D0_SK_ENABLED || setSelected_D1_SK_ENABLED || setSelected_D1_IK_ENABLED || setSelected_D1_LK_ENABLED || setSelected_D1_CK_ENABLED || setSelected_D1_RK_ENABLED || setSelected_D1_PSSK_ENABLED
133 780 : if (present(isSorted_local)) then
134 400 : call setSelected(selection, dataUnsorted, rank, isSorted_local, lb, ub)
135 : else
136 380 : call setSelected(selection, dataUnsorted, rank, lb, ub)
137 : end if
138 : #elif getSelected_D0_SK_ENABLED || getSelected_D1_SK_ENABLED || getSelected_D1_IK_ENABLED || getSelected_D1_LK_ENABLED || getSelected_D1_CK_ENABLED || getSelected_D1_RK_ENABLED || getSelected_D1_PSSK_ENABLED
139 780 : if (present(isSorted_local)) then
140 400 : selection = getSelected(dataUnsorted, rank, isSorted_local, lb, ub)
141 : else
142 380 : selection = getSelected(dataUnsorted, rank, lb, ub)
143 : end if
144 : #else
145 : #error "Unrecognized interface."
146 : #endif
147 1560 : if (present(isSorted_local)) then
148 800 : call setSorted(dataUnsorted, isSorted = isSorted_local)
149 : else
150 760 : call setSorted(dataUnsorted)
151 : end if
152 1560 : assertion = assertion .and. GET_COMP(dataUnsorted(GET_INDEX(rank))) IS_EQUAL GET_COMP(selection)
153 1560 : if (test%traceable .and. .not. assertion) then
154 : ! LCOV_EXCL_START
155 : call test%disp%skip()
156 : call test%disp%show("GET_COMP(dataUnsorted(GET_INDEX(rank)))")
157 : call test%disp%show( GET_COMP(dataUnsorted(GET_INDEX(rank))) )
158 : call test%disp%show("GET_COMP(selection)")
159 : call test%disp%show( GET_COMP(selection) )
160 : call test%disp%show("rank")
161 : call test%disp%show( rank )
162 : if (present(lb)) then
163 : call test%disp%show("lb")
164 : call test%disp%show( lb )
165 : end if
166 : if (present(ub)) then
167 : call test%disp%show("ub")
168 : call test%disp%show( ub )
169 : end if
170 : call test%disp%skip()
171 : ! LCOV_EXCL_STOP
172 : end if
173 1560 : call test%assert(assertion, SK_"sort() must be able to sort input `contiguous` array of rank 1.")
174 :
175 : !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
176 :
177 1560 : end subroutine runTestsWith
178 :
179 : !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
180 :
181 7619945 : function isAscending_local(a, b) result(sorted)
182 : #if setSelected_D0_SK_ENABLED || getSelected_D0_SK_ENABLED
183 : character(1,SKC), intent(in) :: a, b
184 : #elif setSelected_D1_SK_ENABLED || getSelected_D1_SK_ENABLED
185 : character(*,SKC), intent(in) :: a, b
186 : #elif setSelected_D1_IK_ENABLED || getSelected_D1_IK_ENABLED
187 : integer(IKC) , intent(in) :: a, b
188 : #elif setSelected_D1_LK_ENABLED || getSelected_D1_LK_ENABLED
189 : logical(LKC) , intent(in) :: a, b
190 : #elif setSelected_D1_CK_ENABLED || getSelected_D1_CK_ENABLED
191 : complex(CKC) , intent(in) :: a, b
192 : #elif setSelected_D1_RK_ENABLED || getSelected_D1_RK_ENABLED
193 : real(RKC) , intent(in) :: a, b
194 : #elif setSelected_D1_PSSK_ENABLED || getSelected_D1_PSSK_ENABLED
195 : type(css_pdt(SKC)) , intent(in) :: a, b
196 : #else
197 : #error "Unrecognized interface."
198 : #endif
199 : logical(LK) :: sorted
200 7619945 : sorted = GET_COMP(a) < GET_COMP(b)
201 7619945 : end function
202 :
203 : !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
204 :
205 7634232 : function isDescending_local(a, b) result(sorted)
206 : #if setSelected_D0_SK_ENABLED || getSelected_D0_SK_ENABLED
207 : character(1,SKC), intent(in) :: a, b
208 : #elif setSelected_D1_SK_ENABLED || getSelected_D1_SK_ENABLED
209 : character(*,SKC), intent(in) :: a, b
210 : #elif setSelected_D1_IK_ENABLED || getSelected_D1_IK_ENABLED
211 : integer(IKC) , intent(in) :: a, b
212 : #elif setSelected_D1_LK_ENABLED || getSelected_D1_LK_ENABLED
213 : logical(LKC) , intent(in) :: a, b
214 : #elif setSelected_D1_CK_ENABLED || getSelected_D1_CK_ENABLED
215 : complex(CKC) , intent(in) :: a, b
216 : #elif setSelected_D1_RK_ENABLED || getSelected_D1_RK_ENABLED
217 : real(RKC) , intent(in) :: a, b
218 : #elif setSelected_D1_PSSK_ENABLED || getSelected_D1_PSSK_ENABLED
219 : type(css_pdt(SKC)) , intent(in) :: a, b
220 : #else
221 : #error "Unrecognized interface."
222 : #endif
223 : logical(LK) :: sorted
224 7634232 : sorted = GET_COMP(a) > GET_COMP(b)
225 7634232 : end function
226 :
227 : !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
228 :
229 : #undef GET_INDEX
230 : #undef IS_EQUAL
|
