Line data Source code
1 : !--------------------------------------------------------------------------------------------------!
2 : ! CP2K: A general program to perform molecular dynamics simulations !
3 : ! Copyright 2000-2026 CP2K developers group <https://cp2k.org> !
4 : ! !
5 : ! SPDX-License-Identifier: GPL-2.0-or-later !
6 : !--------------------------------------------------------------------------------------------------!
7 :
8 2 : PROGRAM parallel_rng_types_TEST
9 2 : USE message_passing, ONLY: mp_world_finalize, &
10 : mp_world_init, &
11 : mp_comm_type
12 : USE kinds, ONLY: dp
13 : USE machine, ONLY: m_walltime, &
14 : default_output_unit
15 : USE parallel_rng_types, ONLY: GAUSSIAN, &
16 : UNIFORM, &
17 : check_rng, &
18 : rng_stream_type, &
19 : rng_stream_type_from_record, &
20 : rng_name_length, &
21 : rng_record_length
22 :
23 : IMPLICIT NONE
24 :
25 : INTEGER :: i, nsamples, nargs, stat
26 : LOGICAL :: ionode
27 : REAL(KIND=dp) :: t, tend, tmax, tmin, tstart, tsum, tsum2
28 : TYPE(mp_comm_type) :: mpi_comm
29 : TYPE(rng_stream_type) :: rng_stream
30 : CHARACTER(len=32) :: arg
31 :
32 2 : nsamples = 1000
33 2 : nargs = command_argument_count()
34 :
35 2 : IF (nargs > 1) then
36 0 : ERROR STOP "Usage: parallel_rng_types_TEST [<int:nsamples>]"
37 : end if
38 :
39 2 : IF (nargs == 1) THEN
40 2 : CALL get_command_argument(1, arg)
41 2 : READ (arg, *, iostat=stat) nsamples
42 2 : IF (stat /= 0) then
43 0 : ERROR STOP "Usage: parallel_rng_types_TEST [<int:nsamples>]"
44 : end if
45 : END IF
46 :
47 2 : CALL mp_world_init(mpi_comm)
48 2 : ionode = mpi_comm%is_source()
49 :
50 2 : CALL check_rng(default_output_unit, ionode)
51 :
52 : ! Check performance
53 :
54 2 : IF (ionode) THEN
55 : WRITE (UNIT=default_output_unit, FMT="(/,/,T2,A,I10,A)") &
56 1 : "Check distributions using", nsamples, " random numbers:"
57 : END IF
58 :
59 : ! Test uniform distribution [0,1]
60 :
61 : rng_stream = rng_stream_type(name="Test uniform distribution [0,1]", &
62 : distribution_type=UNIFORM, &
63 2 : extended_precision=.TRUE.)
64 :
65 2 : IF (ionode) then
66 1 : CALL rng_stream%write(default_output_unit)
67 : end if
68 :
69 2 : tmax = -HUGE(0.0_dp)
70 2 : tmin = +HUGE(0.0_dp)
71 2 : tsum = 0.0_dp
72 2 : tsum2 = 0.0_dp
73 :
74 2 : tstart = m_walltime()
75 2002 : DO i = 1, nsamples
76 2000 : t = rng_stream%next()
77 2000 : tsum = tsum + t
78 2000 : tsum2 = tsum2 + t*t
79 2000 : IF (t > tmax) tmax = t
80 2002 : IF (t < tmin) tmin = t
81 : END DO
82 2 : tend = m_walltime()
83 :
84 2 : IF (ionode) THEN
85 1 : CALL rng_stream%write(default_output_unit, write_all=.TRUE.)
86 : WRITE (UNIT=default_output_unit, FMT="(/,(T4,A,F12.6))") &
87 1 : "Minimum: ", tmin, &
88 1 : "Maximum: ", tmax, &
89 1 : "Average: ", tsum/REAL(nsamples, KIND=dp), &
90 1 : "Variance:", tsum2/REAL(nsamples, KIND=dp), &
91 2 : "Time [s]:", tend - tstart
92 : END IF
93 :
94 : ! Test normal Gaussian distribution
95 :
96 : rng_stream = rng_stream_type(name="Test normal Gaussian distribution", &
97 : distribution_type=GAUSSIAN, &
98 2 : extended_precision=.TRUE.)
99 :
100 2 : IF (ionode) then
101 1 : CALL rng_stream%write(default_output_unit)
102 : end if
103 :
104 2 : tmax = -HUGE(0.0_dp)
105 2 : tmin = +HUGE(0.0_dp)
106 2 : tsum = 0.0_dp
107 2 : tsum2 = 0.0_dp
108 :
109 2 : tstart = m_walltime()
110 2002 : DO i = 1, nsamples
111 2000 : t = rng_stream%next()
112 2000 : tsum = tsum + t
113 2000 : tsum2 = tsum2 + t*t
114 2000 : IF (t > tmax) tmax = t
115 2002 : IF (t < tmin) tmin = t
116 : END DO
117 2 : tend = m_walltime()
118 :
119 2 : IF (ionode) THEN
120 1 : CALL rng_stream%write(default_output_unit)
121 : WRITE (UNIT=default_output_unit, FMT="(/,(T4,A,F12.6))") &
122 1 : "Minimum: ", tmin, &
123 1 : "Maximum: ", tmax, &
124 1 : "Average: ", tsum/REAL(nsamples, KIND=dp), &
125 1 : "Variance:", tsum2/REAL(nsamples, KIND=dp), &
126 2 : "Time [s]:", tend - tstart
127 : END IF
128 :
129 2 : IF (ionode) THEN
130 1 : CALL dump_reload_check()
131 1 : CALL shuffle_check()
132 : END IF
133 :
134 2 : CALL mp_world_finalize()
135 :
136 : CONTAINS
137 : ! **************************************************************************************************
138 : !> \brief ...
139 : ! **************************************************************************************************
140 1 : SUBROUTINE dump_reload_check()
141 : TYPE(rng_stream_type) :: rng_stream
142 : CHARACTER(len=rng_record_length) :: rng_record
143 : REAL(KIND=dp), DIMENSION(3, 2) :: ig, ig_orig, cg, cg_orig, bg, bg_orig
144 : CHARACTER(len=rng_name_length) :: name, name_orig
145 : CHARACTER(len=*), PARAMETER :: serialized_string = &
146 : "qtb_rng_gaussian 1 F T F 0.0000000000000000E+00&
147 : & 12.0 12.0 12.0&
148 : & 12.0 12.0 12.0&
149 : & 12.0 12.0 12.0&
150 : & 12.0 12.0 12.0&
151 : & 12.0 12.0 12.0&
152 : & 12.0 12.0 12.0"
153 :
154 : WRITE (UNIT=default_output_unit, FMT="(/,/,T2,A)") &
155 1 : "Checking dump and load round trip:"
156 :
157 : rng_stream = rng_stream_type(name="Roundtrip for normal Gaussian distrib", &
158 : distribution_type=GAUSSIAN, &
159 1 : extended_precision=.TRUE.)
160 :
161 1 : CALL rng_stream%advance(7, 42)
162 1 : CALL rng_stream%get(ig=ig_orig, cg=cg_orig, bg=bg_orig, name=name_orig)
163 1 : CALL rng_stream%dump(rng_record)
164 :
165 1 : rng_stream = rng_stream_type_from_record(rng_record)
166 1 : CALL rng_stream%get(ig=ig, cg=cg, bg=bg, name=name)
167 :
168 : IF (ANY(ig /= ig_orig) .OR. ANY(cg /= cg_orig) .OR. ANY(bg /= bg_orig) &
169 27 : .OR. (name /= name_orig)) then
170 0 : ERROR STOP "Stream dump and load roundtrip failed"
171 : end if
172 :
173 : WRITE (UNIT=default_output_unit, FMT="(T4,A)") &
174 1 : "Roundtrip successful"
175 :
176 : WRITE (UNIT=default_output_unit, FMT="(/,/,T2,A)") &
177 1 : "Checking dumped format:"
178 :
179 9 : ig(:, :) = 12.0_dp
180 : rng_stream = rng_stream_type(name="qtb_rng_gaussian", &
181 : distribution_type=GAUSSIAN, &
182 : extended_precision=.TRUE., &
183 1 : seed=ig)
184 :
185 1 : CALL rng_stream%dump(rng_record)
186 :
187 : WRITE (UNIT=default_output_unit, FMT="(T4,A10,A433)") &
188 1 : "EXPECTED:", serialized_string
189 :
190 : WRITE (UNIT=default_output_unit, FMT="(T4,A10,A433)") &
191 1 : "GENERATED:", rng_record
192 :
193 1 : IF (rng_record /= serialized_string) then
194 0 : ERROR STOP "Serialized record does not match the expected output"
195 : end if
196 :
197 : WRITE (UNIT=default_output_unit, FMT="(T4,A)") &
198 1 : "Serialized record matches the expected output"
199 :
200 25 : END SUBROUTINE dump_reload_check
201 :
202 : ! **************************************************************************************************
203 : !> \brief ...
204 : ! **************************************************************************************************
205 1 : SUBROUTINE shuffle_check()
206 : TYPE(rng_stream_type) :: rng_stream
207 :
208 : INTEGER, PARAMETER :: sz = 20
209 : INTEGER, DIMENSION(1:sz) :: arr, arr2, orig
210 : LOGICAL, DIMENSION(1:sz) :: mask
211 : INTEGER :: idx
212 : REAL(KIND=dp), DIMENSION(3, 2), PARAMETER :: ig = 12.0_dp
213 :
214 : WRITE (UNIT=default_output_unit, FMT="(/,/,T2,A)", ADVANCE="no") &
215 1 : "Checking shuffle()"
216 :
217 1 : rng_stream = rng_stream_type(name="shuffle() check", seed=ig)
218 1 : orig = [(idx, idx=1, sz)]
219 :
220 1 : arr = orig
221 1 : CALL rng_stream%shuffle(arr)
222 :
223 1 : IF (ALL(arr == orig)) then
224 0 : ERROR STOP "shuffle failed: array was left untouched"
225 : end if
226 1 : WRITE (UNIT=default_output_unit, FMT="(A)", ADVANCE="no") "."
227 :
228 21 : IF (ANY(arr /= orig(arr))) then
229 0 : ERROR STOP "shuffle failed: the shuffled original is not the shuffled original"
230 : end if
231 1 : WRITE (UNIT=default_output_unit, FMT="(A)", ADVANCE="no") "."
232 :
233 : ! sort and compare to orig
234 21 : mask = .TRUE.
235 21 : DO idx = 1, size(orig)
236 420 : IF (MINVAL(arr, mask) /= orig(idx)) then
237 0 : ERROR STOP "shuffle failed: there is at least one unknown index"
238 : end if
239 481 : mask(MINLOC(arr, mask)) = .FALSE.
240 : END DO
241 1 : WRITE (UNIT=default_output_unit, FMT="(A)", ADVANCE="no") "."
242 :
243 1 : arr2 = orig
244 1 : CALL rng_stream%reset()
245 1 : CALL rng_stream%shuffle(arr2)
246 :
247 21 : IF (ANY(arr2 /= arr)) then
248 0 : ERROR STOP "shuffle failed: array was shuffled differently with same rng state"
249 : end if
250 1 : WRITE (UNIT=default_output_unit, FMT="(A)", ADVANCE="no") "."
251 :
252 : WRITE (UNIT=default_output_unit, FMT="(T4,A)") &
253 1 : " successful"
254 27 : END SUBROUTINE shuffle_check
255 : END PROGRAM parallel_rng_types_TEST
256 : ! vim: set ts=3 sw=3 tw=132 :
|
