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_arrayChange](@ref test_pm_arrayChange).
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 : #if SK_ENABLED && D0_ENABLED
33 : #define GET_SIZE(Array) len(Array, kind = IK)
34 : #define GET_SLICE(i) i:i
35 : #elif D1_ENABLED
36 : #define GET_SIZE(Array) size(Array, 1, IK)
37 : #define GET_SLICE(i) i
38 : #elif !D2_ENABLED
39 : #error "Unrecognized interface."
40 : #endif
41 : #if SK_ENABLED && D0_ENABLED
42 : #define GET_DIFF(X,Y) ichar(X, IK) - ichar(Y, IK)
43 : integer(IK) , parameter :: START_STEP = 1_IK
44 2 : character(:,SKC) , allocatable :: choices, set
45 : character(1,SKC) , parameter :: lb = "A", ub = "Z"
46 : character(1,SKC) :: start, finit
47 : integer(IK) :: step
48 : #elif IK_ENABLED && D1_ENABLED
49 : #define GET_DIFF(X,Y) X - Y
50 : integer(IKC) , parameter :: START_STEP = 1_IKC
51 : integer(IKC) , allocatable :: choices(:), set(:)
52 : integer(IKC) , parameter :: lb = 1 , ub = 9
53 : integer(IKC) :: start, finit
54 : integer(IKC) :: step
55 : #elif RK_ENABLED && D1_ENABLED
56 : #define GET_DIFF(X,Y) X - Y
57 : real(RKC) , parameter :: START_STEP = 1._RKC
58 : real(RKC) , allocatable :: choices(:), set(:)
59 : real(RKC) , parameter :: lb = 1._RKC, ub = 9._RKC
60 : real(RKC) :: start, finit
61 : real(RKC) :: step
62 : #else
63 : #error "Unrecognized interface."
64 : #endif
65 : logical(LK) :: unique
66 : logical(LK) :: rngfUsed
67 : integer(IK) :: itry, csize
68 20 : type(display_type) :: disp
69 : type(xoshiro256ssw_type) :: rngx
70 20 : rngx = xoshiro256ssw_type()
71 20 : assertion = .true._LK
72 :
73 2140 : do itry = 1, 100
74 :
75 2000 : call setUnifRand(start, lb, ub)
76 2000 : call setUnifRand(finit, lb, ub)
77 2000 : if (finit < start) then
78 941 : step = -getUnifRand(START_STEP, START_STEP + GET_DIFF(start,finit))
79 : else
80 1059 : step = +getUnifRand(START_STEP, START_STEP + GET_DIFF(finit,start))
81 : end if
82 7237 : set = getRange(start, finit, step)
83 2000 : csize = getUnifRand(0_IK, 2 * GET_SIZE(set))
84 2000 : unique = csize <= GET_SIZE(set)
85 2000 : rngfUsed = getUnifRand()
86 :
87 2000 : call setResized(choices, csize)
88 : #if getChange_ENABLED
89 3549 : choices = getChange(csize, start, finit, step)
90 : #elif setChange_ENABLED
91 1000 : if (rngfUsed) then
92 483 : call setChange(rngf, choices, start, finit, step)
93 : else
94 517 : call setChange(rngx, choices, start, finit, step)
95 : end if
96 : #else
97 : #error "Unrecognized interface."
98 : #endif
99 2000 : assertion = assertion .and. GET_SIZE(choices) == csize
100 2000 : call report()
101 2000 : call test%assert(assertion, SK_"The size of the output `choices` must be set correctly.", int(__LINE__, IK))
102 :
103 : #if getChange_ENABLED
104 3549 : choices = getChange(csize, start, finit, step)
105 : #elif setChange_ENABLED
106 1000 : if (rngfUsed) then
107 483 : call setChange(rngf, choices, start, finit, step)
108 : else
109 517 : call setChange(rngx, choices, start, finit, step)
110 : end if
111 : #endif
112 2000 : assertion = assertion .and. (choices .allin. set)
113 2000 : call report()
114 2000 : call test%assert(assertion, SK_"All output choices must be members of the input set.", int(__LINE__, IK))
115 :
116 : #if getChange_ENABLED
117 3549 : choices = getChange(csize, start, finit, step, unique)
118 : #elif setChange_ENABLED
119 1000 : if (rngfUsed) then
120 483 : call setChange(rngf, choices, start, finit, step, unique)
121 : else
122 517 : call setChange(rngx, choices, start, finit, step, unique)
123 : end if
124 : #endif
125 2000 : assertion = assertion .and. (choices .allin. set)
126 2000 : call report(unique)
127 2000 : call test%assert(assertion, SK_"All output choices must be members of the input set.", int(__LINE__, IK))
128 2020 : if (unique) then
129 1263 : assertion = assertion .and. isUniqueAll(choices)
130 1263 : call report()
131 1263 : call test%assert(assertion, SK_"All output choices must be members of the input set.", int(__LINE__, IK))
132 : end if
133 :
134 : end do
135 :
136 : contains
137 :
138 7263 : subroutine report(unique)
139 : logical(LK), intent(in), optional :: unique
140 7263 : if (test%traceable .and. .not. assertion) then
141 : ! LCOV_EXCL_START
142 : call disp%skip
143 : call disp%show("set")
144 : call disp%show( set )
145 : call disp%show("choices")
146 : call disp%show( choices )
147 : call disp%show("csize")
148 : call disp%show( csize )
149 : call disp%show("present(unique)")
150 : call disp%show( present(unique) )
151 : if (present(unique)) then
152 : call disp%show("unique")
153 : call disp%show( unique )
154 : end if
155 : #if setChange_ENABLED
156 : call disp%show("rngfUsed")
157 : call disp%show( rngfUsed )
158 : #endif
159 : call disp%skip
160 : ! LCOV_EXCL_STOP
161 : end if
162 7263 : end subroutine
163 :
164 : #undef GET_SLICE
165 : #undef IS_EQUAL
166 : #undef GET_SIZE
167 : #undef GET_DIFF
168 : #undef ALL
|
