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 tests of [pm_sampleMean](@ref pm_sampleMean).
19 : !>
20 : !> \fintest
21 : !>
22 : !> \author
23 : !> \FatemehBagheri, Wednesday 5:03 PM, August 11, 2021, Dallas, TX
24 :
25 : !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
26 :
27 : real(TKC), parameter :: rtol = epsilon(1._TKC) * 100
28 : ! Define the sample type.
29 : #if CK_ENABLED
30 : #define TYPE_OF_SAMPLE complex(TKC)
31 : complex(TKC), parameter :: ONE = (1._TKC, 1._TKC), TWO = 2 * (1._TKC, 1._TKC), ctol = (rtol, rtol)
32 : #elif RK_ENABLED
33 : #define TYPE_OF_SAMPLE real(TKC)
34 : real(TKC), parameter :: ONE = 1._TKC, TWO = 2._TKC, ctol = rtol
35 : #else
36 : #error "Unrecognized interface."
37 : #endif
38 : !%%%%%%%%%%%%%%
39 : #if getMean_ENABLED
40 : !%%%%%%%%%%%%%%
41 :
42 : real(TKC) :: rweisum
43 : integer(IK) :: iweisum
44 : integer(IK) :: itry, nsam, ndim, dim
45 : real(TKC), allocatable :: rweight(:)
46 : integer(IK), allocatable :: iweight(:)
47 : TYPE_OF_SAMPLE, allocatable :: sample(:,:), mean(:), mean_ref(:), diff(:)
48 8 : assertion = .true._LK
49 :
50 408 : do itry = 1, 50
51 :
52 400 : dim = 0
53 400 : nsam = getUnifRand(1_IK, 5_IK)
54 :
55 : ! test sample D2 DIM interface.
56 :
57 : block
58 :
59 400 : dim = getChoice([1, 2])
60 400 : ndim = getUnifRand(1_IK, 5_IK)
61 400 : call setResized(mean_ref, ndim)
62 400 : call setResized(mean, ndim)
63 400 : if (dim == 2) then
64 2837 : sample = getUnifRand(ONE, TWO, ndim, nsam)
65 : else
66 2884 : sample = getUnifRand(ONE, TWO, nsam, ndim)
67 : end if
68 2038 : rweight = getUnifRand(1._TKC, 9._TKC, nsam)
69 2038 : iweight = getUnifRand(1_IK, 9_IK, nsam)
70 :
71 : ! integer weighted
72 :
73 2006 : mean = getMean(sample, dim, iweight)
74 400 : call setMean(mean_ref, sample, dim, iweight, iweisum)
75 :
76 2612 : diff = abs(mean - mean_ref)
77 1606 : assertion = assertion .and. all(diff < ctol)
78 400 : call report(__LINE__, SK_"The `mean` must be computed correctly for integer-weighted sample.")
79 :
80 : ! real weighted
81 :
82 2006 : mean = getMean(sample, dim, rweight)
83 400 : call setMean(mean_ref, sample, dim, rweight, rweisum)
84 :
85 2612 : diff = abs(mean - mean_ref)
86 1606 : assertion = assertion .and. all(diff < ctol)
87 400 : call report(__LINE__, SK_"The `mean` must be computed correctly for real-weighted sample.")
88 :
89 : ! unweighted
90 :
91 2006 : mean = getMean(sample, dim)
92 400 : call setMean(mean_ref, sample, dim)
93 :
94 2612 : diff = abs(mean - mean_ref)
95 1606 : assertion = assertion .and. all(diff < ctol)
96 400 : call report(__LINE__, SK_"The `mean` must be computed correctly for unweighted sample.")
97 :
98 : end block
99 :
100 : ! test sample D2 ALL interface.
101 :
102 : block
103 :
104 400 : dim = 0
105 400 : ndim = getUnifRand(1_IK, 5_IK)
106 400 : call setResized(mean_ref, 1_IK)
107 400 : call setResized(mean, 1_IK)
108 400 : if (getUnifRand()) then
109 3250 : sample = getUnifRand(ONE, TWO, ndim, nsam)
110 : else
111 2511 : sample = getUnifRand(ONE, TWO, nsam, ndim)
112 : end if
113 4533 : rweight = getUnifRand(1._TKC, 9._TKC, nsam * ndim)
114 4533 : iweight = getUnifRand(1_IK, 9_IK, nsam * ndim)
115 :
116 : ! integer weighted
117 :
118 400 : mean(1) = getMean(sample, iweight)
119 400 : call setMean(mean_ref(1), sample, iweight, iweisum)
120 :
121 1400 : diff = abs(mean - mean_ref)
122 800 : assertion = assertion .and. all(diff < ctol)
123 400 : call report(__LINE__, SK_"The `mean` must be computed correctly for integer-weighted sample.")
124 :
125 : ! real weighted
126 :
127 400 : mean(1) = getMean(sample, rweight)
128 400 : call setMean(mean_ref(1), sample, rweight, rweisum)
129 :
130 1400 : diff = abs(mean - mean_ref)
131 800 : assertion = assertion .and. all(diff < ctol)
132 400 : call report(__LINE__, SK_"The `mean` must be computed correctly for real-weighted sample.")
133 :
134 : ! unweighted
135 :
136 400 : mean(1) = getMean(sample)
137 400 : call setMean(mean_ref(1), sample)
138 :
139 1400 : diff = abs(mean - mean_ref)
140 800 : assertion = assertion .and. all(diff < ctol)
141 400 : call report(__LINE__, SK_"The `mean` must be computed correctly for unweighted sample.")
142 :
143 : end block
144 :
145 : ! test sample D1 DIM interface.
146 :
147 : block
148 :
149 400 : dim = 1_IK
150 400 : ndim = 1_IK
151 400 : call setResized(mean, 1_IK)
152 400 : call setResized(mean_ref, 1_IK)
153 2438 : sample = getUnifRand(ONE, TWO, nsam, ndim)
154 2038 : rweight = getUnifRand(1._TKC, 9._TKC, nsam)
155 2038 : iweight = getUnifRand(1_IK, 9_IK, nsam)
156 :
157 : ! integer weighted
158 :
159 400 : mean(1) = getMean(sample(:,1), dim, iweight)
160 400 : call setMean(mean_ref(1), sample(:,1), dim, iweight, iweisum)
161 :
162 1400 : diff = abs(mean - mean_ref)
163 800 : assertion = assertion .and. all(diff < ctol)
164 400 : call report(__LINE__, SK_"The `mean` must be computed correctly for integer-weighted sample.")
165 :
166 : ! real weighted
167 :
168 400 : mean(1) = getMean(sample(:,1), dim, rweight)
169 400 : call setMean(mean_ref(1), sample(:,1), dim, rweight, rweisum)
170 :
171 1400 : diff = abs(mean - mean_ref)
172 800 : assertion = assertion .and. all(diff < ctol)
173 400 : call report(__LINE__, SK_"The `mean` must be computed correctly for real-weighted sample.")
174 :
175 : ! unweighted
176 :
177 400 : mean(1) = getMean(sample(:,1), dim)
178 400 : call setMean(mean_ref(1), sample(:,1), dim)
179 :
180 1400 : diff = abs(mean - mean_ref)
181 800 : assertion = assertion .and. all(diff < ctol)
182 400 : call report(__LINE__, SK_"The `mean` must be computed correctly for unweighted sample.")
183 :
184 : end block
185 :
186 : ! test sample D1 ALL interface.
187 :
188 1608 : block
189 :
190 400 : dim = 1_IK
191 400 : ndim = 1_IK
192 400 : call setResized(mean, 1_IK)
193 400 : call setResized(mean_ref, 1_IK)
194 2438 : sample = getUnifRand(ONE, TWO, nsam, ndim)
195 2038 : rweight = getUnifRand(1._TKC, 9._TKC, nsam)
196 2038 : iweight = getUnifRand(1_IK, 9_IK, nsam)
197 :
198 : ! integer weighted
199 :
200 400 : mean(1) = getMean(sample(:,1), iweight)
201 400 : call setMean(mean_ref(1), sample(:,1), iweight, iweisum)
202 :
203 1400 : diff = abs(mean - mean_ref)
204 800 : assertion = assertion .and. all(diff < ctol)
205 400 : call report(__LINE__, SK_"The `mean` must be computed correctly for integer-weighted sample.")
206 :
207 : ! real weighted
208 :
209 400 : mean(1) = getMean(sample(:,1), rweight)
210 400 : call setMean(mean_ref(1), sample(:,1), rweight, rweisum)
211 :
212 1400 : diff = abs(mean - mean_ref)
213 800 : assertion = assertion .and. all(diff < ctol)
214 400 : call report(__LINE__, SK_"The `mean` must be computed correctly for real-weighted sample.")
215 :
216 : ! unweighted
217 :
218 400 : mean(1) = getMean(sample(:,1))
219 400 : call setMean(mean_ref(1), sample(:,1))
220 :
221 1400 : diff = abs(mean - mean_ref)
222 800 : assertion = assertion .and. all(diff < ctol)
223 400 : call report(__LINE__, SK_"The `mean` must be computed correctly for unweighted sample.")
224 :
225 : end block
226 :
227 : end do
228 :
229 : contains
230 :
231 4800 : subroutine report(line, msg)
232 : integer, intent(in) :: line
233 : character(*, SK), intent(in) :: msg
234 4800 : if (test%traceable .and. .not. assertion) then
235 : ! LCOV_EXCL_START
236 : call test%disp%skip()
237 : call test%disp%show("[ndim, nsam, dim, shape(sample, IK)]")
238 : call test%disp%show( [ndim, nsam, dim, shape(sample, IK)] )
239 : call test%disp%show("sample")
240 : call test%disp%show( sample )
241 : call test%disp%show("iweight")
242 : call test%disp%show( iweight )
243 : call test%disp%show("rweight")
244 : call test%disp%show( rweight )
245 : call test%disp%show("mean_ref")
246 : call test%disp%show( mean_ref )
247 : call test%disp%show("mean")
248 : call test%disp%show( mean )
249 : call test%disp%show("diff")
250 : call test%disp%show( diff )
251 : call test%disp%skip()
252 : ! LCOV_EXCL_STOP
253 : end if
254 4800 : call test%assert(assertion, msg, int(line, IK))
255 4800 : end subroutine
256 :
257 : !%%%%%%%%%%%%%%
258 : #elif setMean_ENABLED
259 : !%%%%%%%%%%%%%%
260 :
261 : integer(IK) :: itry, nsam, ndim, dim
262 : real(TKC) :: rweisum, rweisum_ref
263 : real(TKC), allocatable :: rweight(:)
264 : integer(IK) :: iweisum, iweisum_ref
265 : integer(IK), allocatable :: iweight(:)
266 : TYPE_OF_SAMPLE, allocatable :: sample(:,:), mean(:), mean_ref(:), diff(:)
267 8 : assertion = .true._LK
268 :
269 408 : do itry = 1, 50
270 :
271 400 : dim = 0
272 400 : nsam = getUnifRand(1_IK, 5_IK)
273 :
274 : ! test XY interface.
275 :
276 : block
277 :
278 400 : ndim = 2_IK
279 400 : call setResized(mean, ndim)
280 4102 : sample = getUnifRand(ONE, TWO, nsam, ndim)
281 2051 : rweight = getUnifRand(1._TKC, 9._TKC, nsam)
282 2051 : iweight = getUnifRand(1_IK, 9_IK, nsam)
283 1651 : iweisum_ref = sum(iweight)
284 1651 : rweisum_ref = sum(rweight)
285 400 : iweisum = 0
286 400 : rweisum = 0
287 :
288 : ! integer weighted
289 :
290 2851 : mean_ref = getMeanD2(sample, 1_IK, real(iweight, TKC))
291 400 : call setMean(mean, sample(:,1), sample(:,2), iweight, iweisum)
292 :
293 2000 : diff = abs(mean - mean_ref)
294 1200 : assertion = assertion .and. all(diff < ctol)
295 400 : call report(__LINE__, SK_"The `mean` must be computed correctly for integer-weighted sample.")
296 :
297 400 : assertion = assertion .and. iweisum == iweisum_ref
298 400 : call report(__LINE__, SK_"The `weisum` must be computed correctly for integer-weighted sample.")
299 :
300 : ! real weighted
301 :
302 1600 : mean_ref = getMeanD2(sample, 1_IK, rweight)
303 400 : call setMean(mean, sample(:,1), sample(:,2), rweight, rweisum)
304 :
305 2000 : diff = abs(mean - mean_ref)
306 1200 : assertion = assertion .and. all(diff < ctol)
307 400 : call report(__LINE__, SK_"The `mean` must be computed correctly for real-weighted sample.")
308 :
309 400 : assertion = assertion .and. abs(rweisum - rweisum_ref) <= rtol * abs(rweisum_ref)
310 400 : call report(__LINE__, SK_"The `weisum` must be computed correctly for real-weighted sample.")
311 :
312 : ! unweighted
313 :
314 1600 : mean_ref = getMeanD2(sample, 1_IK)
315 400 : call setMean(mean, sample(:,1), sample(:,2))
316 :
317 2000 : diff = abs(mean - mean_ref)
318 1200 : assertion = assertion .and. all(diff < ctol)
319 400 : call report(__LINE__, SK_"The `mean` must be computed correctly for unweighted sample.")
320 :
321 : end block
322 :
323 : ! test sample D2 DIM interface.
324 :
325 : block
326 :
327 400 : dim = getChoice([1, 2])
328 400 : ndim = getUnifRand(1_IK, 5_IK)
329 400 : call setResized(mean, ndim)
330 400 : if (dim == 2) then
331 3167 : sample = getUnifRand(ONE, TWO, ndim, nsam)
332 : else
333 2767 : sample = getUnifRand(ONE, TWO, nsam, ndim)
334 : end if
335 2051 : rweight = getUnifRand(1._TKC, 9._TKC, nsam)
336 2051 : iweight = getUnifRand(1_IK, 9_IK, nsam)
337 1651 : iweisum_ref = sum(iweight)
338 1651 : rweisum_ref = sum(rweight)
339 400 : iweisum = 0
340 400 : rweisum = 0
341 :
342 : ! integer weighted
343 :
344 3292 : mean_ref = getMeanD2(sample, dim, real(iweight, TKC))
345 : call setMean(mean, sample, dim, iweight, iweisum)
346 :
347 2658 : diff = abs(mean - mean_ref)
348 1641 : assertion = assertion .and. all(diff < ctol)
349 400 : call report(__LINE__, SK_"The `mean` must be computed correctly for integer-weighted sample.")
350 :
351 400 : assertion = assertion .and. iweisum == iweisum_ref
352 400 : call report(__LINE__, SK_"The `weisum` must be computed correctly for integer-weighted sample.")
353 :
354 : ! real weighted
355 :
356 2041 : mean_ref = getMeanD2(sample, dim, rweight)
357 200 : call setMean(mean, sample, dim, rweight, rweisum)
358 :
359 2658 : diff = abs(mean - mean_ref)
360 1641 : assertion = assertion .and. all(diff < ctol)
361 400 : call report(__LINE__, SK_"The `mean` must be computed correctly for real-weighted sample.")
362 :
363 400 : assertion = assertion .and. abs(rweisum - rweisum_ref) <= rtol * abs(rweisum_ref)
364 400 : call report(__LINE__, SK_"The `weisum` must be computed correctly for real-weighted sample.")
365 :
366 : ! unweighted
367 :
368 2041 : mean_ref = getMeanD2(sample, dim)
369 400 : call setMean(mean, sample, dim)
370 :
371 2658 : diff = abs(mean - mean_ref)
372 1641 : assertion = assertion .and. all(diff < ctol)
373 400 : call report(__LINE__, SK_"The `mean` must be computed correctly for unweighted sample.")
374 :
375 : end block
376 :
377 : ! test sample D2 ALL interface.
378 :
379 : block
380 :
381 400 : dim = 0
382 400 : ndim = getUnifRand(1_IK, 5_IK)
383 400 : call setResized(mean, 1_IK)
384 400 : if (getUnifRand()) then
385 3047 : sample = getUnifRand(ONE, TWO, ndim, nsam)
386 : else
387 2849 : sample = getUnifRand(ONE, TWO, nsam, ndim)
388 : end if
389 4646 : rweight = getUnifRand(1._TKC, 9._TKC, nsam * ndim)
390 4646 : iweight = getUnifRand(1_IK, 9_IK, nsam * ndim)
391 4246 : iweisum_ref = sum(iweight)
392 4246 : rweisum_ref = sum(rweight)
393 400 : iweisum = 0
394 400 : rweisum = 0
395 :
396 : ! integer weighted
397 :
398 5046 : mean_ref = getMeanD2(sample, weight = real(iweight, TKC))
399 400 : call setMean(mean(1), sample, iweight, iweisum)
400 :
401 1400 : diff = abs(mean - mean_ref)
402 800 : assertion = assertion .and. all(diff < ctol)
403 400 : call report(__LINE__, SK_"The `mean` must be computed correctly for integer-weighted sample.")
404 :
405 400 : assertion = assertion .and. iweisum == iweisum_ref
406 400 : call report(__LINE__, SK_"The `weisum` must be computed correctly for integer-weighted sample.")
407 :
408 : ! real weighted
409 :
410 1200 : mean_ref = getMeanD2(sample, weight = rweight)
411 400 : call setMean(mean(1), sample, rweight, rweisum)
412 :
413 1400 : diff = abs(mean - mean_ref)
414 800 : assertion = assertion .and. all(diff < ctol)
415 400 : call report(__LINE__, SK_"The `mean` must be computed correctly for real-weighted sample.")
416 :
417 400 : assertion = assertion .and. abs(rweisum - rweisum_ref) <= rtol * abs(rweisum_ref)
418 400 : call report(__LINE__, SK_"The `weisum` must be computed correctly for real-weighted sample.")
419 :
420 : ! unweighted
421 :
422 1200 : mean_ref = getMeanD2(sample)
423 400 : call setMean(mean(1), sample)
424 :
425 1400 : diff = abs(mean - mean_ref)
426 800 : assertion = assertion .and. all(diff < ctol)
427 400 : call report(__LINE__, SK_"The `mean` must be computed correctly for unweighted sample.")
428 :
429 : end block
430 :
431 : ! test sample D1 DIM interface.
432 :
433 : block
434 :
435 400 : dim = 1_IK
436 400 : ndim = 1_IK
437 400 : call setResized(mean, 1_IK)
438 2451 : sample = getUnifRand(ONE, TWO, nsam, ndim)
439 2051 : rweight = getUnifRand(1._TKC, 9._TKC, nsam)
440 2051 : iweight = getUnifRand(1_IK, 9_IK, nsam)
441 1651 : iweisum_ref = sum(iweight)
442 1651 : rweisum_ref = sum(rweight)
443 400 : iweisum = 0
444 400 : rweisum = 0
445 :
446 : ! integer weighted
447 :
448 1651 : mean_ref = getMeanD1(sample(:,1), real(iweight, TKC))
449 400 : call setMean(mean(1), sample(:,1), dim, iweight, iweisum)
450 :
451 1400 : diff = abs(mean - mean_ref)
452 800 : assertion = assertion .and. all(diff < ctol)
453 400 : call report(__LINE__, SK_"The `mean` must be computed correctly for integer-weighted sample.")
454 :
455 400 : assertion = assertion .and. iweisum == iweisum_ref
456 400 : call report(__LINE__, SK_"The `weisum` must be computed correctly for integer-weighted sample.")
457 :
458 : ! real weighted
459 :
460 400 : mean_ref = getMeanD1(sample(:,1), weight = rweight)
461 400 : call setMean(mean(1), sample(:,1), dim, rweight, rweisum)
462 :
463 1400 : diff = abs(mean - mean_ref)
464 800 : assertion = assertion .and. all(diff < ctol)
465 400 : call report(__LINE__, SK_"The `mean` must be computed correctly for real-weighted sample.")
466 :
467 400 : assertion = assertion .and. abs(rweisum - rweisum_ref) <= rtol * abs(rweisum_ref)
468 400 : call report(__LINE__, SK_"The `weisum` must be computed correctly for real-weighted sample.")
469 :
470 : ! unweighted
471 :
472 400 : mean_ref = getMeanD1(sample(:,1))
473 400 : call setMean(mean(1), sample(:,1), dim)
474 :
475 1400 : diff = abs(mean - mean_ref)
476 800 : assertion = assertion .and. all(diff < ctol)
477 400 : call report(__LINE__, SK_"The `mean` must be computed correctly for unweighted sample.")
478 :
479 : end block
480 :
481 : ! test sample D1 ALL interface.
482 :
483 1608 : block
484 :
485 400 : dim = 1_IK
486 400 : ndim = 1_IK
487 400 : call setResized(mean, 1_IK)
488 2451 : sample = getUnifRand(ONE, TWO, nsam, ndim)
489 2051 : rweight = getUnifRand(1._TKC, 9._TKC, nsam)
490 2051 : iweight = getUnifRand(1_IK, 9_IK, nsam)
491 1651 : iweisum_ref = sum(iweight)
492 1651 : rweisum_ref = sum(rweight)
493 400 : iweisum = 0
494 400 : rweisum = 0
495 :
496 : ! integer weighted
497 :
498 1651 : mean_ref = getMeanD1(sample(:,1), real(iweight, TKC))
499 400 : call setMean(mean(1), sample(:,1), iweight, iweisum)
500 :
501 1400 : diff = abs(mean - mean_ref)
502 800 : assertion = assertion .and. all(diff < ctol)
503 400 : call report(__LINE__, SK_"The `mean` must be computed correctly for integer-weighted sample.")
504 :
505 400 : assertion = assertion .and. iweisum == iweisum_ref
506 400 : call report(__LINE__, SK_"The `weisum` must be computed correctly for integer-weighted sample.")
507 :
508 : ! real weighted
509 :
510 400 : mean_ref = getMeanD1(sample(:,1), weight = rweight)
511 400 : call setMean(mean(1), sample(:,1), rweight, rweisum)
512 :
513 1400 : diff = abs(mean - mean_ref)
514 800 : assertion = assertion .and. all(diff < ctol)
515 400 : call report(__LINE__, SK_"The `mean` must be computed correctly for real-weighted sample.")
516 :
517 400 : assertion = assertion .and. abs(rweisum - rweisum_ref) <= rtol * abs(rweisum_ref)
518 400 : call report(__LINE__, SK_"The `weisum` must be computed correctly for real-weighted sample.")
519 :
520 : ! unweighted
521 :
522 400 : mean_ref = getMeanD1(sample(:,1))
523 400 : call setMean(mean(1), sample(:,1))
524 :
525 1400 : diff = abs(mean - mean_ref)
526 800 : assertion = assertion .and. all(diff < ctol)
527 400 : call report(__LINE__, SK_"The `mean` must be computed correctly for unweighted sample.")
528 :
529 : end block
530 :
531 : end do
532 :
533 : contains
534 :
535 10000 : subroutine report(line, msg)
536 : integer, intent(in) :: line
537 : character(*, SK), intent(in) :: msg
538 10000 : if (test%traceable .and. .not. assertion) then
539 : ! LCOV_EXCL_START
540 : call test%disp%skip()
541 : call test%disp%show("[ndim, nsam, dim, shape(sample, IK)]")
542 : call test%disp%show( [ndim, nsam, dim, shape(sample, IK)] )
543 : call test%disp%show("sample")
544 : call test%disp%show( sample )
545 : call test%disp%show("iweight")
546 : call test%disp%show( iweight )
547 : call test%disp%show("iweisum")
548 : call test%disp%show( iweisum )
549 : call test%disp%show("iweisum_ref")
550 : call test%disp%show( iweisum_ref )
551 : call test%disp%show("rweight")
552 : call test%disp%show( rweight )
553 : call test%disp%show("rweisum")
554 : call test%disp%show( rweisum )
555 : call test%disp%show("rweisum_ref")
556 : call test%disp%show( rweisum_ref )
557 : call test%disp%show("mean_ref")
558 : call test%disp%show( mean_ref )
559 : call test%disp%show("mean")
560 : call test%disp%show( mean )
561 : call test%disp%show("diff")
562 : call test%disp%show( diff )
563 : call test%disp%skip()
564 : ! LCOV_EXCL_STOP
565 : end if
566 10000 : call test%assert(assertion, msg, int(line, IK))
567 10000 : end subroutine
568 :
569 8523 : pure function getMeanD1(sample, weight) result(mean)
570 : real(TKC), intent(in), optional :: weight(:)
571 : TYPE_OF_SAMPLE, intent(in) :: sample(:)
572 : TYPE_OF_SAMPLE :: mean(1)
573 8523 : if (present(weight)) then
574 52626 : mean = sum(sample * weight) / sum(weight)
575 : else
576 14577 : mean = sum(sample) / size(sample, 1, IK)
577 : end if
578 8523 : end function
579 :
580 3600 : pure function getMeanD2(sample, dim, weight) result(mean)
581 : real(TKC), intent(in), optional :: weight(:)
582 : TYPE_OF_SAMPLE, intent(in) :: sample(:,:)
583 : integer(IK), intent(in), optional :: dim
584 : TYPE_OF_SAMPLE, allocatable :: mean(:)
585 : integer(IK) :: idim
586 3600 : if (present(dim)) then
587 2400 : allocate(mean(size(sample, 3 - dim, IK)))
588 8523 : do idim = 1, size(sample, 3 - dim, IK)
589 8523 : if (dim == 2) then
590 2632 : mean(idim:idim) = getMeanD1(sample(idim,:), weight)
591 : else
592 5532 : mean(idim:idim) = getMeanD1(sample(:,idim), weight)
593 : end if
594 : end do
595 : else
596 1200 : if (present(weight)) then
597 20184 : mean = [sum(reshape(sample, [product(shape(sample))]) * weight) / sum(weight)]
598 : else
599 6296 : mean = [sum(sample) / size(sample, kind = IK)]
600 : end if
601 : end if
602 3600 : end function
603 :
604 : !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
605 : #elif getMeanMerged_ENABLED || setMeanMerged_ENABLED
606 : !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
607 :
608 : real(TKC) :: fracA
609 : integer(IK) :: itry, ndim, dim
610 : integer(IK) :: nsam, nsamA, nsamB
611 : TYPE_OF_SAMPLE, allocatable :: sample(:,:), meanA(:), meanB(:), mean(:), mean_ref(:), diff(:)
612 16 : assertion = .true._LK
613 16 : dim = 2_IK
614 :
615 816 : do itry = 1, 50
616 :
617 800 : nsamA = getUnifRand(1_IK, 5_IK)
618 800 : nsamB = getUnifRand(1_IK, 5_IK)
619 800 : nsam = nsamA + nsamB
620 800 : fracA = real(nsamA, TKC) / real(nsam, TKC)
621 :
622 : ! test D2 interface.
623 :
624 : block
625 :
626 800 : ndim = getUnifRand(1_IK, 5_IK)
627 800 : call setResized(mean, ndim)
628 20497 : sample = getUnifRand(ONE, TWO, ndim, nsam)
629 :
630 4024 : mean_ref = getMean(sample, dim)
631 4024 : meanA = getMean(sample(:,1:nsamA), dim)
632 4024 : meanB = getMean(sample(:,nsamA+1:), dim)
633 :
634 : #if getMeanMerged_ENABLED
635 1979 : mean = getMeanMerged(meanB, meanA, fracA)
636 2559 : diff = abs(mean - mean_ref)
637 1579 : assertion = assertion .and. all(diff < ctol)
638 400 : call report(__LINE__, SK_"The new `meanMerged` must be computed correctly.")
639 : #elif setMeanMerged_ENABLED
640 : ! new
641 400 : call setMeanMerged(mean, meanB, meanA, fracA)
642 2686 : diff = abs(mean - mean_ref)
643 1645 : assertion = assertion .and. all(diff < ctol)
644 400 : call report(__LINE__, SK_"The new `meanMerged` must be computed correctly.")
645 : ! old
646 2045 : mean = meanB
647 400 : call setMeanMerged(mean, meanA, fracA)
648 2686 : diff = abs(mean - mean_ref)
649 1645 : assertion = assertion .and. all(diff < ctol)
650 400 : call report(__LINE__, SK_"The in-place `meanMerged` must be computed correctly.")
651 : #endif
652 :
653 : end block
654 :
655 : ! test D1 interface.
656 :
657 16 : block
658 :
659 800 : ndim = 1_IK
660 800 : call setResized(mean, ndim)
661 11036 : sample = getUnifRand(ONE, TWO, ndim, nsam)
662 :
663 2400 : mean_ref = getMean(sample, dim)
664 2400 : meanA = getMean(sample(:,1:nsamA), dim)
665 2400 : meanB = getMean(sample(:,nsamA+1:), dim)
666 :
667 : #if getMeanMerged_ENABLED
668 400 : mean(1) = getMeanMerged(meanB(1), meanA(1), fracA)
669 1400 : diff = abs(mean - mean_ref)
670 800 : assertion = assertion .and. all(diff < ctol)
671 400 : call report(__LINE__, SK_"The new `meanMerged` must be computed correctly.")
672 : #elif setMeanMerged_ENABLED
673 : ! new
674 400 : call setMeanMerged(mean(1), meanB(1), meanA(1), fracA)
675 1400 : diff = abs(mean - mean_ref)
676 800 : assertion = assertion .and. all(diff < ctol)
677 400 : call report(__LINE__, SK_"The new `meanMerged` must be computed correctly.")
678 : ! old
679 1200 : mean = meanB
680 400 : call setMeanMerged(mean(1), meanA(1), fracA)
681 1400 : diff = abs(mean - mean_ref)
682 800 : assertion = assertion .and. all(diff < ctol)
683 400 : call report(__LINE__, SK_"The in-place `meanMerged` must be computed correctly.")
684 : #endif
685 : end block
686 :
687 : end do
688 :
689 : contains
690 :
691 2400 : subroutine report(line, msg)
692 : integer, intent(in) :: line
693 : character(*, SK), intent(in) :: msg
694 2400 : if (test%traceable .and. .not. assertion) then
695 : ! LCOV_EXCL_START
696 : call test%disp%skip()
697 : call test%disp%show("[ndim, nsamA, nsamB, nsam, dim, shape(sample, IK)]")
698 : call test%disp%show( [ndim, nsamA, nsamB, nsam, dim, shape(sample, IK)] )
699 : call test%disp%show("sample")
700 : call test%disp%show( sample )
701 : call test%disp%show("meanA")
702 : call test%disp%show( meanA )
703 : call test%disp%show("meanB")
704 : call test%disp%show( meanB )
705 : call test%disp%show("mean_ref")
706 : call test%disp%show( mean_ref )
707 : call test%disp%show("mean")
708 : call test%disp%show( mean )
709 : call test%disp%show("diff")
710 : call test%disp%show( diff )
711 : call test%disp%skip()
712 : ! LCOV_EXCL_STOP
713 : end if
714 2400 : call test%assert(assertion, msg, int(line, IK))
715 2400 : end subroutine
716 :
717 : #else
718 : !%%%%%%%%%%%%%%%%%%%%%%%%
719 : #error "Unrecognized interface."
720 : !%%%%%%%%%%%%%%%%%%%%%%%%
721 : #endif
722 : #undef TYPE_OF_SAMPLE
|
