Yet Another eXchange Tool  0.9.0
ftest_common.f90
1 
12 
13 !
14 ! Maintainer: Jörg Behrens <behrens@dkrz.de>
15 ! Moritz Hanke <hanke@dkrz.de>
16 ! Thomas Jahns <jahns@dkrz.de>
17 ! URL: https://doc.redmine.dkrz.de/yaxt/html/
18 !
19 ! Redistribution and use in source and binary forms, with or without
20 ! modification, are permitted provided that the following conditions are
21 ! met:
22 !
23 ! Redistributions of source code must retain the above copyright notice,
24 ! this list of conditions and the following disclaimer.
25 !
26 ! Redistributions in binary form must reproduce the above copyright
27 ! notice, this list of conditions and the following disclaimer in the
28 ! documentation and/or other materials provided with the distribution.
29 !
30 ! Neither the name of the DKRZ GmbH nor the names of its contributors
31 ! may be used to endorse or promote products derived from this software
32 ! without specific prior written permission.
33 !
34 ! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS
35 ! IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED
36 ! TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A
37 ! PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER
38 ! OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL,
39 ! EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO,
40 ! PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR
41 ! PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF
42 ! LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING
43 ! NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
44 ! SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
45 !
46 MODULE ftest_common
47  USE mpi
48  USE xt_core, ONLY: i2, i4, i8
49  USE iso_c_binding, ONLY: c_int, c_bool, c_double, &
50  c_int16_t, c_int32_t, c_int64_t
51  IMPLICIT NONE
52  PRIVATE
53  INTEGER, PUBLIC, PARAMETER :: dp = selected_real_kind(12, 307)
54 
55  TYPE timer
56  CHARACTER(len=20) :: label = 'undef'
57  INTEGER :: istate = -1
58  REAL(dp) :: t0 = 0.0_dp
59  REAL(dp) :: dt_work = 0.0_dp
60  END TYPE timer
61 
62  INTERFACE test_abort
63  MODULE PROCEDURE test_abort_cmsl_f
64  MODULE PROCEDURE test_abort_msl_f
65  END INTERFACE test_abort
66 
67  INTERFACE icmp
68  MODULE PROCEDURE icmp_2d
69  MODULE PROCEDURE icmp_3d
70  END INTERFACE icmp
71 
72  INTERFACE
73  SUBROUTINE posix_exit(code) BIND(c, name="exit")
74  IMPORT :: c_int
75  INTEGER(c_int), VALUE, INTENT(in) :: code
76  END SUBROUTINE posix_exit
77  END INTERFACE
78  PUBLIC :: posix_exit
79 
80  INTERFACE cmp_arrays
81 
82  FUNCTION cmp_dbl_arrays_(asize, a, b) bind(c, name='cmp_dbl_arrays')
83  IMPORT :: c_bool, c_int, c_double
84 #ifdef HAVE_FC_LOGICAL_C_BOOL
85  LOGICAL(c_bool) :: cmp_dbl_arrays_
86 #define cmp_dbl_arrays(asize,a,b) LOGICAL(cmp_dbl_arrays_(asize,a,b))
87 #else
88  INTEGER(c_int) :: cmp_dbl_arrays_
89 #define cmp_dbl_arrays(asize,a,b) (cmp_dbl_arrays_(asize,a,b) /= 0)
90 #endif
91  INTEGER(c_int), VALUE, INTENT(in) :: asize
92  REAL(c_double), INTENT(in) :: a(asize), b(asize)
93  END FUNCTION cmp_dbl_arrays_
94 
95  FUNCTION cmp_int16_arrays_(asize, a, b) bind(c, name='cmp_int16_arrays')
96  IMPORT :: c_bool, c_int, c_int16_t
97 #ifdef HAVE_FC_LOGICAL_C_BOOL
98  LOGICAL(c_bool) :: cmp_int16_arrays_
99 #define cmp_int16_arrays(asize,a,b) LOGICAL(cmp_int16_arrays_(asize,a,b))
100 #else
101  INTEGER(c_int) :: cmp_int16_arrays_
102 #define cmp_int16_arrays(asize,a,b) (cmp_int16_arrays_(asize,a,b) /= 0)
103 #endif
104  INTEGER(c_int), VALUE, INTENT(in) :: asize
105  INTEGER(c_int16_t), INTENT(in) :: a(asize), b(asize)
106  END FUNCTION cmp_int16_arrays_
107 
108  FUNCTION cmp_int32_arrays_(asize, a, b) bind(c, name='cmp_int32_arrays')
109  IMPORT :: c_bool, c_int, c_int32_t
110 #ifdef HAVE_FC_LOGICAL_C_BOOL
111  LOGICAL(c_bool) :: cmp_int32_arrays_
112 #define cmp_int32_arrays(asize,a,b) LOGICAL(cmp_int32_arrays_(asize,a,b))
113 #else
114  INTEGER(c_int) :: cmp_int32_arrays_
115 #define cmp_int32_arrays(asize,a,b) (cmp_int32_arrays_(asize,a,b) /= 0)
116 #endif
117  INTEGER(c_int), VALUE, INTENT(in) :: asize
118  INTEGER(c_int32_t), INTENT(in) :: a(asize), b(asize)
119  END FUNCTION cmp_int32_arrays_
120 
121  FUNCTION cmp_int64_arrays_(asize, a, b) bind(c, name='cmp_int64_arrays')
122  IMPORT :: c_bool, c_int, c_int64_t
123 #ifdef HAVE_FC_LOGICAL_C_BOOL
124  LOGICAL(c_bool) :: cmp_int64_arrays_
125 #define cmp_int64_arrays(asize,a,b) LOGICAL(cmp_int64_arrays_(asize,a,b))
126 #else
127  INTEGER(c_int) :: cmp_int64_arrays_
128 #define cmp_int64_arrays(asize,a,b) (cmp_int64_arrays_(asize,a,b) /= 0)
129 #endif
130  INTEGER(c_int), VALUE, INTENT(in) :: asize
131  INTEGER(c_int64_t), INTENT(in) :: a(asize), b(asize)
132  END FUNCTION cmp_int64_arrays_
133 
134  MODULE PROCEDURE cmp_dbl_arrays_a1d_a1d
135  MODULE PROCEDURE cmp_dbl_arrays_a2d_a2d
136  MODULE PROCEDURE cmp_dbl_arrays_a3d_a3d
137  MODULE PROCEDURE cmp_i2_arrays_a1d_a1d
138  MODULE PROCEDURE cmp_i4_arrays_a1d_a1d
139  MODULE PROCEDURE cmp_i8_arrays_a1d_a1d
140  MODULE PROCEDURE cmp_i2_arrays_a2d_a2d
141  MODULE PROCEDURE cmp_i4_i2_arrays_a2d_a2d
142  MODULE PROCEDURE cmp_i4_arrays_a2d_a2d
143  MODULE PROCEDURE cmp_i4_i8_arrays_a2d_a2d
144  MODULE PROCEDURE cmp_i8_arrays_a2d_a2d
145  MODULE PROCEDURE cmp_i2_arrays_a3d_a3d
146  MODULE PROCEDURE cmp_i4_i2_arrays_a3d_a3d
147  MODULE PROCEDURE cmp_i4_arrays_a3d_a3d
148  MODULE PROCEDURE cmp_i4_i8_arrays_a3d_a3d
149  MODULE PROCEDURE cmp_i8_arrays_a3d_a3d
150  END INTERFACE cmp_arrays
151 
152  INTERFACE id_map
153  MODULE PROCEDURE id_map_i2, id_map_i4, id_map_i8
154  END INTERFACE id_map
155 
156  INTERFACE icbrt
157  MODULE PROCEDURE icbrt_i2, icbrt_i4, icbrt_i8
158  END INTERFACE icbrt
159 
160  REAL(dp) :: sync_dt_sum = 0.0_dp
161  LOGICAL, PARAMETER :: debug = .false.
162  LOGICAL :: verbose = .false.
163 
164  PUBLIC :: init_mpi, finish_mpi
165  PUBLIC :: timer, treset, tstart, tstop, treport, mysync
166  PUBLIC :: id_map, icbrt, icmp, factorize, regular_deco
167  PUBLIC :: test_abort, set_verbose, get_verbose
168  PUBLIC :: cmp_arrays
169  PUBLIC :: run_randomized_tests, init_fortran_random
170  CHARACTER(len=*), PARAMETER :: filename = 'ftest_common.f90'
171 CONTAINS
172 
173  SUBROUTINE init_mpi
174  CHARACTER(len=*), PARAMETER :: context = 'init_mpi: '
175  INTEGER :: ierror
176  CALL mpi_init(ierror)
177  IF (ierror /= mpi_success) CALL test_abort(context//'MPI_INIT failed', &
178  filename, __line__)
179  END SUBROUTINE init_mpi
180 
181  SUBROUTINE finish_mpi
182  CHARACTER(len=*), PARAMETER :: context = 'finish_mpi: '
183  INTEGER :: ierror
184  CALL mpi_finalize(ierror)
185  IF (ierror /= mpi_success) CALL test_abort(context//'MPI_FINALIZE failed', &
186  filename, &
187  __line__)
188  END SUBROUTINE finish_mpi
189 
190  SUBROUTINE set_verbose(verb)
191  LOGICAL, INTENT(in) :: verb
192  verbose = verb
193  END SUBROUTINE set_verbose
194 
195  SUBROUTINE get_verbose(verb)
196  LOGICAL, INTENT(out) :: verb
197  verb = verbose
198  END SUBROUTINE get_verbose
199 
200  PURE SUBROUTINE treset(t, label)
201  TYPE(timer), INTENT(inout) :: t
202  CHARACTER(len=*), INTENT(in) :: label
203  t%label = label
204  t%istate = 0
205  t%t0 = 0.0_dp
206  t%dt_work = 0.0_dp
207  END SUBROUTINE treset
208 
209  SUBROUTINE tstart(t)
210  TYPE(timer), INTENT(inout) :: t
211  IF (debug) WRITE(0,*) 'tstart: ',t%label
212  CALL mysync
213  t%istate = 1
214  t%t0 = work_time()
215  END SUBROUTINE tstart
216 
217  SUBROUTINE tstop(t)
218  TYPE(timer), INTENT(inout) :: t
219  REAL(dp) :: t1
220  IF (debug) WRITE(0,*) 'tstop: ',t%label
221  t1 = work_time()
222  t%dt_work = t%dt_work + (t1 - t%t0)
223  t%istate = 0
224  CALL mysync
225 
226  END SUBROUTINE tstop
227 
228  SUBROUTINE treport(t,extra_label,comm)
229  TYPE(timer), INTENT(in) :: t
230  CHARACTER(len=*), INTENT(in) :: extra_label
231  INTEGER, INTENT(in) :: comm
232 
233  CHARACTER(len=*), PARAMETER :: context = 'treport: '
234  REAL(dp) :: work_sum, work_max, work_avg, e
235  REAL(dp) :: sbuf(1)
236  REAL(dp), ALLOCATABLE :: rbuf(:)
237  INTEGER :: nprocs, rank, ierror
238 
239  sbuf(1) = t%dt_work
240  CALL mpi_comm_rank(comm, rank, ierror)
241  IF (ierror /= mpi_success) &
242  CALL test_abort(context//'mpi_comm_rank failed', filename, __line__)
243  CALL mpi_comm_size(comm, nprocs, ierror)
244  IF (ierror /= mpi_success) &
245  CALL test_abort(context//'mpi_comm_size failed', filename, __line__)
246  ALLOCATE(rbuf(0:nprocs-1))
247  rbuf = -1.0_dp
248  CALL mpi_gather(sbuf, 1, mpi_double_precision, &
249  & rbuf, 1, mpi_double_precision, &
250  & 0, comm, ierror)
251  IF (ierror /= mpi_success) CALL test_abort(context//'MPI_GATHER failed', &
252  filename, __line__)
253 
254  IF (rank == 0) THEN
255  IF (cmp_dbl_arrays(1, rbuf, sbuf)) &
256  CALL test_abort(context//'internal error (1)', &
257  filename, __line__)
258  IF (any(rbuf < 0.0_dp)) CALL test_abort(context//'internal error (2)', &
259  filename, __line__)
260  work_sum = sum(rbuf)
261  work_max = maxval(rbuf)
262  work_avg = work_sum / real(nprocs, dp)
263  e = work_avg / (work_max + 1.e-20_dp)
264 
265  IF (verbose) WRITE(0,'(A,I4,2X,A16,3F18.8)') &
266  'nprocs, label, wmax, wavg, e =', &
267  nprocs, extra_label//':'//t%label, &
268  work_max, work_avg, e
269  ENDIF
270 
271  END SUBROUTINE treport
272 
273  SUBROUTINE mysync
274  CHARACTER(len=*), PARAMETER :: context = 'mysync: '
275  INTEGER :: ierror
276  REAL(dp) :: t0, dt
277 
278  t0 = mpi_wtime()
279 
280  CALL mpi_barrier(mpi_comm_world, ierror)
281  IF (ierror /= mpi_success) CALL test_abort(context//'MPI_BARRIER failed', &
282  filename, __line__)
283 
284  dt = (mpi_wtime() - t0)
285  sync_dt_sum = sync_dt_sum + dt
286 
287  END SUBROUTINE mysync
288 
289  REAL(dp) FUNCTION work_time()
290  work_time = mpi_wtime() - sync_dt_sum
291  RETURN
292  END FUNCTION work_time
293 
294  PURE SUBROUTINE id_map_i2(map)
295  INTEGER(i2), INTENT(out) :: map(:,:)
296 
297  INTEGER :: i, j, m, n
298 
299  m = SIZE(map, 1)
300  n = SIZE(map, 2)
301  DO j = 1, n
302  DO i = 1, m
303  map(i,j) = int((j - 1) * m + i, i2)
304  ENDDO
305  ENDDO
306 
307  END SUBROUTINE id_map_i2
308 
309  PURE SUBROUTINE id_map_i4(map)
310  INTEGER(i4), INTENT(out) :: map(:,:)
311 
312  INTEGER :: i, j, m, n
313 
314  m = SIZE(map, 1)
315  n = SIZE(map, 2)
316  DO j = 1, n
317  DO i = 1, m
318  map(i,j) = int((j - 1) * m + i, i4)
319  ENDDO
320  ENDDO
321 
322  END SUBROUTINE id_map_i4
323 
324  PURE SUBROUTINE id_map_i8(map)
325  INTEGER(i8), INTENT(out) :: map(:,:)
326 
327  INTEGER :: i, j, m, n
328 
329  m = SIZE(map, 1)
330  n = SIZE(map, 2)
331  DO j = 1, n
332  DO i = 1, m
333  map(i,j) = int((j - 1) * m + i, i8)
334  ENDDO
335  ENDDO
336 
337  END SUBROUTINE id_map_i8
338 
339  SUBROUTINE test_abort_msl_f(msg, source, line)
340  CHARACTER(*), INTENT(in) :: msg
341  CHARACTER(*), INTENT(in) :: source
342  INTEGER, INTENT(in) :: line
343  CALL test_abort_cmsl_f(mpi_comm_world, msg, source, line)
344  END SUBROUTINE test_abort_msl_f
345 
346  SUBROUTINE test_abort_cmsl_f(comm, msg, source, line)
347  INTEGER, INTENT(in):: comm
348  CHARACTER(*), INTENT(in) :: msg
349  CHARACTER(*), INTENT(in) :: source
350  INTEGER, INTENT(in) :: line
351 
352  INTERFACE
353  SUBROUTINE c_abort() bind(c, name='abort')
354  END SUBROUTINE c_abort
355  END INTERFACE
356 
357  INTEGER :: ierror
358  LOGICAL :: flag
359 
360  WRITE (0, '(3a,i0,2a)') 'Fatal error in ', source, ', line ', line, &
361  ': ', trim(msg)
362  FLUSH(0)
363  CALL mpi_initialized(flag, ierror)
364  IF (ierror == mpi_success .AND. flag) &
365  CALL mpi_abort(comm, 1, ierror)
366  CALL c_abort
367  END SUBROUTINE test_abort_cmsl_f
368 
369  SUBROUTINE icmp_2d(label, f,g, rank)
370  CHARACTER(len=*), PARAMETER :: context = 'ftest_common::icmp_2d: '
371  CHARACTER(len=*), INTENT(in) :: label
372  INTEGER, INTENT(in) :: f(:,:), g(:,:)
373  INTEGER, INTENT(in) :: rank
374 
375  INTEGER :: i, j, n1, n2
376  LOGICAL :: mismatch_found
377 
378  n1 = SIZE(f,1)
379  n2 = SIZE(f,2)
380  IF (SIZE(g,1) /= n1 .OR. SIZE(g,2) /= n2) &
381  CALL test_abort(context//'shape mismatch error', filename, __line__)
382 
383  mismatch_found = .false.
384  DO j = 1, n2
385  DO i = 1, n1
386  mismatch_found = mismatch_found .OR. f(i,j) /= g(i,j)
387  END DO
388  END DO
389  IF (mismatch_found) THEN
390  DO j = 1, n2
391  DO i = 1, n1
392  IF (f(i,j) /= g(i,j)) THEN
393  WRITE(0,'(2a,4(a,i0))') context, label, ' test failed: i=', &
394  i, ', j=', j, ', f(i,j)=', f(i,j), ', g(i,j)=', g(i,j)
395  CALL test_abort(context//label//' test failed', filename, __line__)
396  ENDIF
397  ENDDO
398  ENDDO
399  END IF
400  IF (verbose) WRITE(0,*) rank,':',context//label//' passed'
401  END SUBROUTINE icmp_2d
402 
403  SUBROUTINE icmp_3d(label, f,g, rank)
404  CHARACTER(len=*), PARAMETER :: context = 'ftest_common::icmp_3d: '
405  CHARACTER(len=*), INTENT(in) :: label
406  INTEGER, INTENT(in) :: f(:,:,:), g(:,:,:)
407  INTEGER, INTENT(in) :: rank
408 
409  INTEGER :: i1, i2, i3, n1, n2, n3
410  LOGICAL :: mismatch_found
411 
412  n1 = SIZE(f,1)
413  n2 = SIZE(f,2)
414  n3 = SIZE(f,3)
415  IF (SIZE(g,1) /= n1 .OR. SIZE(g,2) /= n2 .OR. SIZE(g,3) /= n3) &
416  CALL test_abort(context//label//' shape mismatch', filename, __line__)
417 
418  mismatch_found = .false.
419  DO i3 = 1, n3
420  DO i2 = 1, n2
421  DO i1 = 1, n1
422  mismatch_found = mismatch_found .OR. f(i1,i2,i3) /= g(i1,i2,i3)
423  END DO
424  END DO
425  END DO
426  IF (mismatch_found) THEN
427  DO i3 = 1, n3
428  DO i2 = 1, n2
429  DO i1 = 1, n1
430  IF (f(i1,i2,i3) /= g(i1,i2,i3)) THEN
431  WRITE(0,*) context,label,&
432  ' test failed: i1, i2, i3, f(i1,i2,i3), g(i1,i2,i3) =', &
433  i1, i2, i3, f(i1,i2,i3), g(i1,i2,i3)
434  CALL test_abort(context//label//' test failed', &
435  filename, __line__)
436  ENDIF
437  ENDDO
438  ENDDO
439  ENDDO
440  END IF
441  IF (verbose) WRITE(0,*) rank,':',context//label//' passed'
442  END SUBROUTINE icmp_3d
443 
444 
445  FUNCTION cmp_dbl_arrays_a1d_a1d(a, b) RESULT(differ)
446  DOUBLE PRECISION, INTENT(in) :: a(:), b(:)
447  LOGICAL :: differ
448  INTEGER :: asize, bsize
449  INTEGER(c_int) :: asize_c
450 
451  asize = SIZE(a)
452  bsize = SIZE(b)
453  IF (asize /= bsize) THEN
454  WRITE (0, '(a)') 'warning: comparing arrays of different size'
455  differ = .true.
456  ELSE IF (asize > 0) THEN
457  asize_c = int(asize, c_int)
458  differ = cmp_dbl_arrays(asize_c, a, b)
459  ELSE
460  differ = .false.
461  END IF
462  END FUNCTION cmp_dbl_arrays_a1d_a1d
463 
464  FUNCTION cmp_dbl_arrays_a2d_a2d(a, b) RESULT(differ)
465  DOUBLE PRECISION, INTENT(in) :: a(:,:), b(:,:)
466  LOGICAL :: differ
467  INTEGER :: asize, bsize
468  INTEGER(c_int) :: asize_c
469 
470  asize = SIZE(a)
471  bsize = SIZE(b)
472  IF (asize /= bsize) THEN
473  WRITE (0, '(a)') 'warning: comparing arrays of different size'
474  differ = .true.
475  ELSE IF (asize > 0) THEN
476  asize_c = int(asize, c_int)
477  differ = cmp_dbl_arrays(asize_c, a, b)
478  ELSE
479  differ = .false.
480  END IF
481  END FUNCTION cmp_dbl_arrays_a2d_a2d
482 
483  FUNCTION cmp_dbl_arrays_a3d_a3d(a, b) RESULT(differ)
484  DOUBLE PRECISION, INTENT(in) :: a(:,:,:), b(:,:,:)
485  LOGICAL :: differ
486  INTEGER :: asize, bsize
487  INTEGER(c_int) :: asize_c
488 
489  asize = SIZE(a)
490  bsize = SIZE(b)
491  IF (asize /= bsize) THEN
492  WRITE (0, '(a)') 'warning: comparing arrays of different size'
493  differ = .true.
494  ELSE IF (asize > 0) THEN
495  asize_c = int(asize, c_int)
496  differ = cmp_dbl_arrays(asize_c, a, b)
497  ELSE
498  differ = .false.
499  END IF
500  END FUNCTION cmp_dbl_arrays_a3d_a3d
501 
502  FUNCTION cmp_i2_arrays_a1d_a1d(a, b) RESULT(differ)
503  INTEGER(i2), INTENT(in) :: a(:), b(:)
504  LOGICAL :: differ
505  INTEGER :: asize, bsize
506  INTEGER(c_int) :: asize_c
507 
508  asize = SIZE(a)
509  bsize = SIZE(b)
510  IF (asize /= bsize) THEN
511  WRITE (0, '(a)') 'warning: comparing arrays of different size'
512  differ = .true.
513  ELSE IF (asize > 0) THEN
514  asize_c = int(asize, c_int)
515  differ = cmp_int16_arrays(asize_c, a, b)
516  ELSE
517  differ = .false.
518  END IF
519  END FUNCTION cmp_i2_arrays_a1d_a1d
520 
521  FUNCTION cmp_i4_arrays_a1d_a1d(a, b) RESULT(differ)
522  INTEGER(i4), INTENT(in) :: a(:), b(:)
523  LOGICAL :: differ
524  INTEGER :: asize, bsize
525  INTEGER(c_int) :: asize_c
526 
527  asize = SIZE(a)
528  bsize = SIZE(b)
529  IF (asize /= bsize) THEN
530  WRITE (0, '(a)') 'warning: comparing arrays of different size'
531  differ = .true.
532  ELSE IF (asize > 0) THEN
533  asize_c = int(asize, c_int)
534  differ = cmp_int32_arrays(asize_c, a, b)
535  ELSE
536  differ = .false.
537  END IF
538  END FUNCTION cmp_i4_arrays_a1d_a1d
539 
540  FUNCTION cmp_i8_arrays_a1d_a1d(a, b) RESULT(differ)
541  INTEGER(i8), INTENT(in) :: a(:), b(:)
542  LOGICAL :: differ
543  INTEGER :: asize, bsize
544  INTEGER(c_int) :: asize_c
545 
546  asize = SIZE(a)
547  bsize = SIZE(b)
548  IF (asize /= bsize) THEN
549  WRITE (0, '(a)') 'warning: comparing arrays of different size'
550  differ = .true.
551  ELSE IF (asize > 0) THEN
552  asize_c = int(asize, c_int)
553  differ = cmp_int64_arrays(asize_c, a, b)
554  ELSE
555  differ = .false.
556  END IF
557  END FUNCTION cmp_i8_arrays_a1d_a1d
558 
559  FUNCTION cmp_i2_arrays_a2d_a2d(a, b) RESULT(differ)
560  INTEGER(i2), INTENT(in) :: a(:,:), b(:,:)
561  LOGICAL :: differ
562  INTEGER :: asize, bsize
563  INTEGER(c_int) :: asize_c
564 
565  asize = SIZE(a)
566  bsize = SIZE(b)
567  IF (asize /= bsize) THEN
568  WRITE (0, '(a)') 'warning: comparing arrays of different size'
569  differ = .true.
570  ELSE IF (asize > 0) THEN
571  asize_c = int(asize, c_int)
572  differ = cmp_int16_arrays(asize_c, a, b)
573  ELSE
574  differ = .false.
575  END IF
576  END FUNCTION cmp_i2_arrays_a2d_a2d
577 
578  FUNCTION cmp_i4_arrays_a2d_a2d(a, b) RESULT(differ)
579  INTEGER(i4), INTENT(in) :: a(:,:), b(:,:)
580  LOGICAL :: differ
581  INTEGER :: asize, bsize
582  INTEGER(c_int) :: asize_c
583 
584  asize = SIZE(a)
585  bsize = SIZE(b)
586  IF (asize /= bsize) THEN
587  WRITE (0, '(a)') 'warning: comparing arrays of different size'
588  differ = .true.
589  ELSE IF (asize > 0) THEN
590  asize_c = int(asize, c_int)
591  differ = cmp_int32_arrays(asize_c, a, b)
592  ELSE
593  differ = .false.
594  END IF
595  END FUNCTION cmp_i4_arrays_a2d_a2d
596 
597  FUNCTION cmp_i8_arrays_a2d_a2d(a, b) RESULT(differ)
598  INTEGER(i8), INTENT(in) :: a(:,:), b(:,:)
599  LOGICAL :: differ
600  INTEGER :: asize, bsize
601  INTEGER(c_int) :: asize_c
602 
603  asize = SIZE(a)
604  bsize = SIZE(b)
605  IF (asize /= bsize) THEN
606  WRITE (0, '(a)') 'warning: comparing arrays of different size'
607  differ = .true.
608  ELSE IF (asize > 0) THEN
609  asize_c = int(asize, c_int)
610  differ = cmp_int64_arrays(asize_c, a, b)
611  ELSE
612  differ = .false.
613  END IF
614  END FUNCTION cmp_i8_arrays_a2d_a2d
615 
616  FUNCTION cmp_i2_arrays_a3d_a3d(a, b) RESULT(differ)
617  INTEGER(i2), INTENT(in) :: a(:,:,:), b(:,:,:)
618  LOGICAL :: differ
619  INTEGER :: asize, bsize
620  INTEGER(c_int) :: asize_c
621 
622  asize = SIZE(a)
623  bsize = SIZE(b)
624  IF (asize /= bsize) THEN
625  WRITE (0, '(a)') 'warning: comparing arrays of different size'
626  differ = .true.
627  ELSE IF (asize > 0) THEN
628  asize_c = int(asize, c_int)
629  differ = cmp_int16_arrays(asize_c, a, b)
630  ELSE
631  differ = .false.
632  END IF
633  END FUNCTION cmp_i2_arrays_a3d_a3d
634 
635  FUNCTION cmp_i4_arrays_a3d_a3d(a, b) RESULT(differ)
636  INTEGER(i4), INTENT(in) :: a(:,:,:), b(:,:,:)
637  LOGICAL :: differ
638  INTEGER :: asize, bsize
639  INTEGER(c_int) :: asize_c
640 
641  asize = SIZE(a)
642  bsize = SIZE(b)
643  IF (asize /= bsize) THEN
644  WRITE (0, '(a)') 'warning: comparing arrays of different size'
645  differ = .true.
646  ELSE IF (asize > 0) THEN
647  asize_c = int(asize, c_int)
648  differ = cmp_int32_arrays(asize_c, a, b)
649  ELSE
650  differ = .false.
651  END IF
652  END FUNCTION cmp_i4_arrays_a3d_a3d
653 
654  FUNCTION cmp_i4_i2_arrays_a2d_a2d(a, b) RESULT(differ)
655  INTEGER(i4), INTENT(in) :: a(:,:)
656  INTEGER(i2), INTENT(in) :: b(:,:)
657  LOGICAL :: differ
658  INTEGER :: i, j, m, n
659 
660  m = SIZE(a, 1)
661  n = SIZE(a, 2)
662  IF (m /= SIZE(b, 1) .OR. n /= SIZE(b, 2)) THEN
663  WRITE (0, '(a)') 'warning: comparing arrays of different shape'
664  differ = .true.
665  ELSE IF (SIZE(a) > 0) THEN
666  differ = .false.
667  DO j = 1, n
668  DO i = 1, m
669  differ = differ .OR. a(i, j) /= int(b(i, j), i4)
670  END DO
671  END DO
672  ELSE
673  differ = .false.
674  END IF
675  END FUNCTION cmp_i4_i2_arrays_a2d_a2d
676 
677  FUNCTION cmp_i4_i8_arrays_a2d_a2d(a, b) RESULT(differ)
678  INTEGER(i4), INTENT(in) :: a(:,:)
679  INTEGER(i8), INTENT(in) :: b(:,:)
680  LOGICAL :: differ
681  INTEGER :: i, j, m, n
682 
683  m = SIZE(a, 1)
684  n = SIZE(a, 2)
685  IF (m /= SIZE(b, 1) .OR. n /= SIZE(b, 2)) THEN
686  WRITE (0, '(a)') 'warning: comparing arrays of different shape'
687  differ = .true.
688  ELSE IF (SIZE(a) > 0) THEN
689  differ = .false.
690  DO j = 1, n
691  DO i = 1, m
692  differ = differ .OR. int(a(i, j), i8) /= b(i, j)
693  END DO
694  END DO
695  ELSE
696  differ = .false.
697  END IF
698  END FUNCTION cmp_i4_i8_arrays_a2d_a2d
699 
700  FUNCTION cmp_i4_i2_arrays_a3d_a3d(a, b) RESULT(differ)
701  INTEGER(i4), INTENT(in) :: a(:,:,:)
702  INTEGER(i2), INTENT(in) :: b(:,:,:)
703  LOGICAL :: differ
704  INTEGER :: i, j, k, m, n, o
705 
706  m = SIZE(a, 1)
707  n = SIZE(a, 2)
708  o = SIZE(a, 3)
709  IF (m /= SIZE(b, 1) .OR. n /= SIZE(b, 2) .OR. o /= SIZE(b, 3)) THEN
710  WRITE (0, '(a)') 'warning: comparing arrays of different shape'
711  differ = .true.
712  ELSE IF (SIZE(a) > 0) THEN
713  differ = .false.
714  DO k = 1, o
715  DO j = 1, n
716  DO i = 1, m
717  differ = differ .OR. a(i, j, k) /= int(b(i, j, k), i4)
718  END DO
719  END DO
720  END DO
721  ELSE
722  differ = .false.
723  END IF
724  END FUNCTION cmp_i4_i2_arrays_a3d_a3d
725 
726  FUNCTION cmp_i4_i8_arrays_a3d_a3d(a, b) RESULT(differ)
727  INTEGER(i4), INTENT(in) :: a(:,:,:)
728  INTEGER(i8), INTENT(in) :: b(:,:,:)
729  LOGICAL :: differ
730  INTEGER :: i, j, k, m, n, o
731 
732  m = SIZE(a, 1)
733  n = SIZE(a, 2)
734  o = SIZE(a, 3)
735  IF (m /= SIZE(b, 1) .OR. n /= SIZE(b, 2) .OR. o /= SIZE(b, 3)) THEN
736  WRITE (0, '(a)') 'warning: comparing arrays of different shape'
737  differ = .true.
738  ELSE IF (SIZE(a) > 0) THEN
739  differ = .false.
740  DO k = 1, o
741  DO j = 1, n
742  DO i = 1, m
743  differ = differ .OR. int(a(i, j, k), i8) /= b(i, j, k)
744  END DO
745  END DO
746  END DO
747  ELSE
748  differ = .false.
749  END IF
750  END FUNCTION cmp_i4_i8_arrays_a3d_a3d
751 
752  FUNCTION cmp_i8_arrays_a3d_a3d(a, b) RESULT(differ)
753  INTEGER(i8), INTENT(in) :: a(:,:,:), b(:,:,:)
754  LOGICAL :: differ
755  INTEGER :: asize, bsize
756  INTEGER(c_int) :: asize_c
757 
758  asize = SIZE(a)
759  bsize = SIZE(b)
760  IF (asize /= bsize) THEN
761  WRITE (0, '(a)') 'warning: comparing arrays of different size'
762  differ = .true.
763  ELSE IF (asize > 0) THEN
764  asize_c = int(asize, c_int)
765  differ = cmp_int64_arrays(asize_c, a, b)
766  ELSE
767  differ = .false.
768  END IF
769  END FUNCTION cmp_i8_arrays_a3d_a3d
770 
771  SUBROUTINE factorize(c, a, b)
772  INTEGER, INTENT(in) :: c
773  INTEGER, INTENT(out) :: a, b ! c = a*b
774 
775  INTEGER :: x0, i
776 
777  IF (c<1) CALL test_abort('factorize: invalid process space', &
778  filename, __line__)
779  IF (c <= 3 .OR. c == 5 .OR. c == 7) THEN
780  a = c
781  b = 1
782  RETURN
783  ENDIF
784 
785  ! simple approach, we try to be near c = (2*x) * x
786  x0 = int(sqrt(0.5 * real(c)) + 0.5)
787  a = 2*x0
788  f_loop: DO i = a, 1, -1
789  IF (mod(c,i) == 0) THEN
790  a = i
791  b = c/i
792  EXIT f_loop
793  ENDIF
794  ENDDO f_loop
795 
796  END SUBROUTINE factorize
797 
799  FUNCTION icbrt_i2(n) RESULT(icbrt)
800  INTEGER(i2), INTENT(in) :: n
801  INTEGER(i2) :: icbrt
802  INTEGER(i2), PARAMETER :: nbits = bit_size(n)-1_i2
803  INTEGER(i2) :: s
804  INTEGER(i2) :: b, x
805 
806  x = abs(n)
807  icbrt = 0_i2
808  DO s = nbits, 0_i2, -3_i2
809  icbrt = icbrt + icbrt
810  b = 3_i2 * icbrt * (icbrt + 1_i2) + 1_i2
811  IF (ishft(x, -s) >= b) THEN
812  x = x - ishft(b, s)
813  icbrt = icbrt + 1_i2
814  END IF
815  END DO
816  icbrt = sign(icbrt, n)
817  END FUNCTION icbrt_i2
818 
820  FUNCTION icbrt_i4(n) RESULT(icbrt)
821  INTEGER(i4), INTENT(in) :: n
822  INTEGER(i4) :: icbrt
823  INTEGER(i4), PARAMETER :: nbits = bit_size(n)-1_i4
824  INTEGER(i4) :: s
825  INTEGER(i4) :: b, x
826 
827  x = abs(n)
828  icbrt = 0_i4
829  DO s = nbits-1, 0_i4, -3_i4
830  icbrt = icbrt + icbrt
831  b = 3_i4 * icbrt * (icbrt + 1_i4) + 1_i4
832  IF (ishft(x, -s) >= b) THEN
833  x = x - ishft(b, s)
834  icbrt = icbrt + 1_i4
835  END IF
836  END DO
837  icbrt = sign(icbrt, n)
838  END FUNCTION icbrt_i4
839 
841  FUNCTION icbrt_i8(n) RESULT(icbrt)
842  INTEGER(i8), INTENT(in) :: n
843  INTEGER(i8) :: icbrt
844  INTEGER(i8), PARAMETER :: nbits = bit_size(n)-1_i8
845  INTEGER(i8) :: s
846  INTEGER(i8) :: b, x
847 
848  x = abs(n)
849  icbrt = 0_i8
850  DO s = nbits, 0_i8, -3_i8
851  icbrt = icbrt + icbrt
852  b = 3_i8 * icbrt * (icbrt + 1_i8) + 1_i8
853  IF (ishft(x, -s) >= b) THEN
854  x = x - ishft(b, s)
855  icbrt = icbrt + 1_i8
856  END IF
857  END DO
858  icbrt = sign(icbrt, n)
859  END FUNCTION icbrt_i8
860 
861 
862  SUBROUTINE regular_deco(g_cn, c0, cn)
863  INTEGER, INTENT(in) :: g_cn
864  INTEGER, INTENT(out) :: c0(0:), cn(0:)
865 
866  ! convention: process space coords start at 0, grid point coords start at 1
867 
868  integer :: tn
869  INTEGER :: d, m
870  INTEGER :: it
871 
872  tn = SIZE(c0)
873  IF (tn<0) CALL test_abort('(tn<0)', filename, __line__)
874  IF (tn>g_cn) CALL test_abort('regular_deco: too many task for such a core&
875  & region', &
876  filename, __line__)
877 
878  d = g_cn/tn
879  m = mod(g_cn, tn)
880 
881  DO it = 0, m-1
882  cn(it) = d + 1
883  ENDDO
884  DO it = m, tn-1
885  cn(it) = d
886  ENDDO
887 
888  c0(0)=0
889  DO it = 1, tn-1
890  c0(it) = c0(it-1) + cn(it-1)
891  ENDDO
892  IF (c0(tn-1)+cn(tn-1) /= g_cn) &
893  CALL test_abort('regular_deco: internal error 1', filename, __line__)
894  END SUBROUTINE regular_deco
895 
896  FUNCTION run_randomized_tests() RESULT(fully_random_tests)
897  LOGICAL :: fully_random_tests
898  CHARACTER(len=32) :: envval
899  INTEGER :: envlen, envstat
900  CALL get_environment_variable("YAXT_FULLY_RANDOM_TESTS", envval, envlen, &
901  status=envstat)
902  IF (envstat == 0 .AND. (envlen == 1 .OR. envlen == 3)) THEN
903  IF (envlen == 1 .AND. (envval(1:1) == 'y' .OR. envval(1:1) == 'Y' &
904  & .OR. envval(1:1) == '1')) THEN
905  fully_random_tests = .true.
906  ELSE IF (str2lower(envval(1:3)) == 'yes') THEN
907  fully_random_tests = .true.
908  ELSE
909  fully_random_tests = .false.
910  END IF
911  ELSE
912  fully_random_tests = .false.
913  END IF
914  END FUNCTION run_randomized_tests
915 
916  FUNCTION str2lower(s) RESULT(t)
917  CHARACTER(len=*), INTENT(in) :: s
918  CHARACTER(len=LEN(s)) :: t
919  INTEGER, PARAMETER :: idel = ichar('a')-ichar('A')
920  INTEGER :: i
921  DO i = 1, len_trim(s)
922  t(i:i) = char( ichar(s(i:i)) &
923  + merge(idel, 0, ichar(s(i:i)) >= ichar('A') &
924  & .AND. ichar(s(i:i)) <= ichar('Z')))
925  ENDDO
926  END FUNCTION str2lower
927 
928  SUBROUTINE init_fortran_random(full_random)
929  LOGICAL, INTENT(in) :: full_random
930  INTEGER, ALLOCATABLE :: rseed(:)
931 
932  INTEGER :: rseed_size, i
933  CHARACTER(len=32) :: fmt
934  INTEGER :: tparts(8), timeseed
935  INTEGER :: days_per_month(12), days_prefix
936  INTEGER, PARAMETER :: tparts_mult(7) = (/ &
937  365 * 24 * 60 * 60, & ! year
938  0, & ! sum over days_per_month added to day
939  24 * 60 * 60, & ! day
940  0, & ! ignore timezone offset
941  60 * 60, & ! hour of day
942  60, & ! minute of hour
943  1 /) ! seconnd
944  CHARACTER(len=32) :: envval
945  INTEGER :: envlen, envstat
946 
947  CALL random_seed(size=rseed_size)
948  ALLOCATE(rseed(rseed_size))
949  DO i = 1, rseed_size
950  rseed(i) = 4711
951  END DO
952  IF (full_random) THEN
953 
954  CALL date_and_time(values=tparts)
955  days_per_month( 1) = 31
956  days_per_month( 2) = merge(28, 29, &
957  mod(tparts(1), 4) == 0 .AND. ( mod(tparts(1), 100) /= 0 &
958  & .OR. mod(tparts(1), 400) == 0))
959  days_per_month( 3) = 31
960  days_per_month( 4) = 30
961  days_per_month( 5) = 31
962  days_per_month( 6) = 30
963  days_per_month( 7) = 31
964  days_per_month( 8) = 31
965  days_per_month( 9) = 30
966  days_per_month(10) = 31
967  days_per_month(11) = 30
968  days_per_month(12) = 31
969  tparts(1) = tparts(1) - 1970
970  days_prefix = sum(days_per_month(1:tparts(2)-1))
971  tparts(3) = tparts(3) + days_prefix - 1
972  tparts(2) = 0
973  timeseed = sum(tparts(1:7) * tparts_mult)
974  timeseed = ieor(tparts(8), timeseed) ! mix in microseconds
975  rseed(1) = timeseed
976  CALL get_environment_variable("YAXT_RANDOM_SEED", envval, envlen, &
977  status=envstat)
978  IF (envstat == 0) THEN
979  WRITE (fmt, '(a,i0,a)') '(i', digits(rseed), ')'
980  READ(envval(1:envlen), fmt) rseed(1)
981  END IF
982  WRITE(0, '(a,i0)') 'used extra seed=', rseed(1)
983  FLUSH(0)
984  END IF
985  CALL random_seed(put=rseed)
986  END SUBROUTINE init_fortran_random
987 
988 END MODULE ftest_common
989 !
990 ! Local Variables:
991 ! f90-continuation-indent: 5
992 ! coding: utf-8
993 ! indent-tabs-mode: nil
994 ! show-trailing-whitespace: t
995 ! require-trailing-newline: t
996 ! End:
997 !
integer, parameter, public i8
Definition: xt_core_f.f90:60
integer, parameter, public i4
Definition: xt_core_f.f90:59
integer, parameter, public i2
Definition: xt_core_f.f90:58