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 file contains procedure implementations of [test_pm_arrayChoice](@ref test_pm_arrayChoice).
19 : !>
20 : !> \fintest
21 : !>
22 : !> \author
23 : !> \AmirShahmoradi, September 1, 2017, 11:35 PM, Institute for Computational Engineering and Sciences (ICES), The University of Texas at Austin
24 :
25 : !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
26 :
27 : #if LK_ENABLED
28 : #define IS_EQUAL .eqv.
29 : #else
30 : #define IS_EQUAL ==
31 : #endif
32 :
33 : #if SK_ENABLED && D0_ENABLED
34 : #define GET_SIZE(Array) len(Array, kind = IK)
35 : #define GET_SLICE(i) i:i
36 : #elif D1_ENABLED
37 : #define GET_SIZE(Array) size(Array, 1, IK)
38 : #define GET_SLICE(i) i
39 : #elif !D2_ENABLED
40 : #error "Unrecognized interface."
41 : #endif
42 : #if SK_ENABLED && D0_ENABLED
43 2 : character(:,SKC) , allocatable :: choices, set
44 : character(1,SKC) , parameter :: lb = "A", ub = "Z"
45 : !character(1,SKC) :: choice
46 : #elif SK_ENABLED && D1_ENABLED
47 : character(2,SKC) , allocatable :: choices(:), set(:)
48 : character(2,SKC) , parameter :: lb = "AA", ub = "AZ"
49 : !character(2,SKC) :: choice
50 : #elif IK_ENABLED && D1_ENABLED
51 : integer(IKC) , allocatable :: choices(:), set(:)
52 : integer(IKC) , parameter :: lb = 0, ub = 9
53 : !integer(IKC) :: choice
54 : #elif LK_ENABLED && D1_ENABLED
55 : logical(LKC) , allocatable :: choices(:), set(:)
56 : logical(LKC) , parameter :: lb = .false., ub = .true.
57 : !logical(LKC) :: choice
58 : #elif CK_ENABLED && D1_ENABLED
59 : complex(CKC) , allocatable :: choices(:), set(:)
60 : complex(CKC) , parameter :: lb = (-9._CKC, 0._CKC), ub = (0._CKC, +9._CKC)
61 : !complex(CKC) :: choice
62 : #elif RK_ENABLED && D1_ENABLED
63 : real(RKC) , allocatable :: choices(:), set(:)
64 : real(RKC) , parameter :: lb = 0._RKC, ub = 9._RKC
65 : !real(RKC) :: choice
66 : #else
67 : #error "Unrecognized interface."
68 : #endif
69 : logical(LK) :: unique
70 : logical(LK) :: rngfUsed
71 : integer(IK) :: itry, csize
72 40 : type(display_type) :: disp
73 : type(xoshiro256ssw_type) :: rngx
74 40 : assertion = .true._LK
75 :
76 40 : rngx = xoshiro256ssw_type()
77 :
78 4240 : do itry = 1, 100
79 :
80 4000 : call setResized(set, getUnifRand(1_IK, 9_IK))
81 23051 : call setUnifRand(set, lb, ub)
82 36926 : set = getUnique(set)
83 4000 : csize = getUnifRand(0_IK, 2 * GET_SIZE(set))
84 4000 : unique = csize <= GET_SIZE(set)
85 4000 : rngfUsed = getUnifRand()
86 :
87 4000 : call setResized(choices, csize)
88 : #if getChoice_ENABLED
89 11458 : choices = getChoice(set, csize)
90 : #elif setChoice_ENABLED
91 2000 : if (rngfUsed) then
92 1006 : call setChoice(rngf, choices, set)
93 : else
94 994 : call setChoice(rngx, choices, set)
95 : end if
96 : #else
97 : #error "Unrecognized interface."
98 : #endif
99 4000 : assertion = assertion .and. GET_SIZE(choices) == csize
100 4000 : call report()
101 4000 : call test%assert(assertion, SK_"The size of the output `choices` must be set correctly.", int(__LINE__, IK))
102 :
103 : #if getChoice_ENABLED
104 11458 : choices = getChoice(set, csize)
105 : #elif setChoice_ENABLED
106 2000 : if (rngfUsed) then
107 1006 : call setChoice(rngf, choices, set)
108 : else
109 994 : call setChoice(rngx, choices, set)
110 : end if
111 : #endif
112 4000 : assertion = assertion .and. (choices .allin. set)
113 4000 : call report()
114 4000 : call test%assert(assertion, SK_"All output choices must be members of the input set.", int(__LINE__, IK))
115 :
116 : #if getChoice_ENABLED
117 11458 : choices = getChoice(set, csize, unique)
118 : #elif setChoice_ENABLED
119 2000 : if (rngfUsed) then
120 1006 : call setChoice(rngf, choices, set, unique)
121 : else
122 994 : call setChoice(rngx, choices, set, unique)
123 : end if
124 : #endif
125 4000 : assertion = assertion .and. (choices .allin. set)
126 4000 : call report(unique)
127 4000 : call test%assert(assertion, SK_"All output choices must be members of the input set.", int(__LINE__, IK))
128 4000 : if (unique) then
129 2254 : assertion = assertion .and. isUniqueAll(choices)
130 2254 : call report()
131 2254 : call test%assert(assertion, SK_"All output choices must be members of the input set.", int(__LINE__, IK))
132 : end if
133 :
134 4000 : csize = 1
135 4000 : call setResized(choices, csize)
136 : #if getChoice_ENABLED
137 2000 : choices(GET_SLICE(1)) = getChoice(set)
138 : #elif setChoice_ENABLED
139 2000 : if (rngfUsed) then
140 1006 : call setChoice(rngf, choices(GET_SLICE(1)), set)
141 : else
142 994 : call setChoice(rngx, choices(GET_SLICE(1)), set)
143 : end if
144 : #endif
145 4000 : assertion = assertion .and. (choices .allin. set)
146 4000 : call report()
147 4040 : call test%assert(assertion, SK_"The output scalar choice must be member of the input set.", int(__LINE__, IK))
148 :
149 : end do
150 :
151 : contains
152 :
153 18254 : subroutine report(unique)
154 : logical(LK), intent(in), optional :: unique
155 18254 : if (test%traceable .and. .not. assertion) then
156 : ! LCOV_EXCL_START
157 : call disp%skip
158 : call disp%show("set")
159 : call disp%show( set )
160 : call disp%show("choices")
161 : call disp%show( choices )
162 : call disp%show("csize")
163 : call disp%show( csize )
164 : call disp%show("present(unique)")
165 : call disp%show( present(unique) )
166 : if (present(unique)) then
167 : call disp%show("unique")
168 : call disp%show( unique )
169 : end if
170 : #if setChoice_ENABLED
171 : call disp%show("rngfUsed")
172 : call disp%show( rngfUsed )
173 : #endif
174 : call disp%skip
175 : ! LCOV_EXCL_STOP
176 : end if
177 18254 : end subroutine
178 :
179 : #undef GET_SLICE
180 : #undef IS_EQUAL
181 : #undef GET_SIZE
182 : #undef ALL
|
