49 USE iso_c_binding,
ONLY: c_int, c_bool, c_double, &
50 c_int16_t, c_int32_t, c_int64_t
53 INTEGER,
PUBLIC,
PARAMETER :: dp = selected_real_kind(12, 307)
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
63 MODULE PROCEDURE test_abort_cmsl_f
64 MODULE PROCEDURE test_abort_msl_f
65 END INTERFACE test_abort
68 MODULE PROCEDURE icmp_2d
69 MODULE PROCEDURE icmp_3d
73 SUBROUTINE posix_exit(code)
BIND(c, name="exit")
75 INTEGER(c_int),
VALUE,
INTENT(in) :: code
76 END SUBROUTINE posix_exit
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))
88 INTEGER(c_int) :: cmp_dbl_arrays_
89 #define cmp_dbl_arrays(asize,a,b) (cmp_dbl_arrays_(asize,a,b) /= 0)
91 INTEGER(c_int),
VALUE,
INTENT(in) :: asize
92 REAL(c_double),
INTENT(in) :: a(asize), b(asize)
93 END FUNCTION cmp_dbl_arrays_
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))
101 INTEGER(c_int) :: cmp_int16_arrays_
102 #define cmp_int16_arrays(asize,a,b) (cmp_int16_arrays_(asize,a,b) /= 0)
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_
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))
114 INTEGER(c_int) :: cmp_int32_arrays_
115 #define cmp_int32_arrays(asize,a,b) (cmp_int32_arrays_(asize,a,b) /= 0)
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_
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))
127 INTEGER(c_int) :: cmp_int64_arrays_
128 #define cmp_int64_arrays(asize,a,b) (cmp_int64_arrays_(asize,a,b) /= 0)
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_
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
153 MODULE PROCEDURE id_map_i2, id_map_i4, id_map_i8
157 MODULE PROCEDURE icbrt_i2, icbrt_i4, icbrt_i8
160 REAL(dp) :: sync_dt_sum = 0.0_dp
161 LOGICAL,
PARAMETER :: debug = .false.
162 LOGICAL :: verbose = .false.
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
169 PUBLIC :: run_randomized_tests, init_fortran_random
170 CHARACTER(len=*),
PARAMETER :: filename =
'ftest_common.f90'
174 CHARACTER(len=*),
PARAMETER :: context =
'init_mpi: '
176 CALL mpi_init(ierror)
177 IF (ierror /= mpi_success)
CALL test_abort(context//
'MPI_INIT failed', &
179 END SUBROUTINE init_mpi
181 SUBROUTINE finish_mpi
182 CHARACTER(len=*),
PARAMETER :: context =
'finish_mpi: '
184 CALL mpi_finalize(ierror)
185 IF (ierror /= mpi_success)
CALL test_abort(context//
'MPI_FINALIZE failed', &
188 END SUBROUTINE finish_mpi
190 SUBROUTINE set_verbose(verb)
191 LOGICAL,
INTENT(in) :: verb
193 END SUBROUTINE set_verbose
195 SUBROUTINE get_verbose(verb)
196 LOGICAL,
INTENT(out) :: verb
198 END SUBROUTINE get_verbose
200 PURE SUBROUTINE treset(t, label)
201 TYPE(timer),
INTENT(inout) :: t
202 CHARACTER(len=*),
INTENT(in) :: label
207 END SUBROUTINE treset
210 TYPE(timer),
INTENT(inout) :: t
211 IF (debug)
WRITE(0,*)
'tstart: ',t%label
215 END SUBROUTINE tstart
218 TYPE(timer),
INTENT(inout) :: t
220 IF (debug)
WRITE(0,*)
'tstop: ',t%label
222 t%dt_work = t%dt_work + (t1 - t%t0)
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
233 CHARACTER(len=*),
PARAMETER :: context =
'treport: '
234 REAL(dp) :: work_sum, work_max, work_avg, e
236 REAL(dp),
ALLOCATABLE :: rbuf(:)
237 INTEGER :: nprocs, rank, ierror
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))
248 CALL mpi_gather(sbuf, 1, mpi_double_precision, &
249 & rbuf, 1, mpi_double_precision, &
251 IF (ierror /= mpi_success)
CALL test_abort(context//
'MPI_GATHER failed', &
255 IF (cmp_dbl_arrays(1, rbuf, sbuf)) &
256 CALL test_abort(context//
'internal error (1)', &
258 IF (any(rbuf < 0.0_dp))
CALL test_abort(context//
'internal error (2)', &
261 work_max = maxval(rbuf)
262 work_avg = work_sum / real(nprocs, dp)
263 e = work_avg / (work_max + 1.e-20_dp)
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
271 END SUBROUTINE treport
274 CHARACTER(len=*),
PARAMETER :: context =
'mysync: '
280 CALL mpi_barrier(mpi_comm_world, ierror)
281 IF (ierror /= mpi_success)
CALL test_abort(context//
'MPI_BARRIER failed', &
284 dt = (mpi_wtime() - t0)
285 sync_dt_sum = sync_dt_sum + dt
287 END SUBROUTINE mysync
289 REAL(dp) FUNCTION work_time()
290 work_time = mpi_wtime() - sync_dt_sum
292 END FUNCTION work_time
294 PURE SUBROUTINE id_map_i2(map)
295 INTEGER(i2),
INTENT(out) :: map(:,:)
297 INTEGER :: i, j, m, n
303 map(i,j) = int((j - 1) * m + i,
i2)
307 END SUBROUTINE id_map_i2
309 PURE SUBROUTINE id_map_i4(map)
310 INTEGER(i4),
INTENT(out) :: map(:,:)
312 INTEGER :: i, j, m, n
318 map(i,j) = int((j - 1) * m + i,
i4)
322 END SUBROUTINE id_map_i4
324 PURE SUBROUTINE id_map_i8(map)
325 INTEGER(i8),
INTENT(out) :: map(:,:)
327 INTEGER :: i, j, m, n
333 map(i,j) = int((j - 1) * m + i,
i8)
337 END SUBROUTINE id_map_i8
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
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
353 SUBROUTINE c_abort() bind(c, name='abort')
354 END SUBROUTINE c_abort
360 WRITE (0,
'(3a,i0,2a)')
'Fatal error in ', source,
', line ', line, &
363 CALL mpi_initialized(flag, ierror)
364 IF (ierror == mpi_success .AND. flag) &
365 CALL mpi_abort(comm, 1, ierror)
367 END SUBROUTINE test_abort_cmsl_f
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
375 INTEGER :: i, j, n1, n2
376 LOGICAL :: mismatch_found
380 IF (
SIZE(g,1) /= n1 .OR.
SIZE(g,2) /= n2) &
381 CALL test_abort(context//
'shape mismatch error', filename, __line__)
383 mismatch_found = .false.
386 mismatch_found = mismatch_found .OR. f(i,j) /= g(i,j)
389 IF (mismatch_found)
THEN
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__)
400 IF (verbose)
WRITE(0,*) rank,
':',context//label//
' passed'
401 END SUBROUTINE icmp_2d
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
409 INTEGER :: i1, i2, i3, n1, n2, n3
410 LOGICAL :: mismatch_found
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__)
418 mismatch_found = .false.
422 mismatch_found = mismatch_found .OR. f(i1,i2,i3) /= g(i1,i2,i3)
426 IF (mismatch_found)
THEN
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', &
441 IF (verbose)
WRITE(0,*) rank,
':',context//label//
' passed'
442 END SUBROUTINE icmp_3d
445 FUNCTION cmp_dbl_arrays_a1d_a1d(a, b)
RESULT(differ)
446 DOUBLE PRECISION,
INTENT(in) :: a(:), b(:)
448 INTEGER :: asize, bsize
449 INTEGER(c_int) :: asize_c
453 IF (asize /= bsize)
THEN
454 WRITE (0,
'(a)')
'warning: comparing arrays of different size'
456 ELSE IF (asize > 0)
THEN
457 asize_c = int(asize, c_int)
458 differ = cmp_dbl_arrays(asize_c, a, b)
462 END FUNCTION cmp_dbl_arrays_a1d_a1d
464 FUNCTION cmp_dbl_arrays_a2d_a2d(a, b)
RESULT(differ)
465 DOUBLE PRECISION,
INTENT(in) :: a(:,:), b(:,:)
467 INTEGER :: asize, bsize
468 INTEGER(c_int) :: asize_c
472 IF (asize /= bsize)
THEN
473 WRITE (0,
'(a)')
'warning: comparing arrays of different size'
475 ELSE IF (asize > 0)
THEN
476 asize_c = int(asize, c_int)
477 differ = cmp_dbl_arrays(asize_c, a, b)
481 END FUNCTION cmp_dbl_arrays_a2d_a2d
483 FUNCTION cmp_dbl_arrays_a3d_a3d(a, b)
RESULT(differ)
484 DOUBLE PRECISION,
INTENT(in) :: a(:,:,:), b(:,:,:)
486 INTEGER :: asize, bsize
487 INTEGER(c_int) :: asize_c
491 IF (asize /= bsize)
THEN
492 WRITE (0,
'(a)')
'warning: comparing arrays of different size'
494 ELSE IF (asize > 0)
THEN
495 asize_c = int(asize, c_int)
496 differ = cmp_dbl_arrays(asize_c, a, b)
500 END FUNCTION cmp_dbl_arrays_a3d_a3d
502 FUNCTION cmp_i2_arrays_a1d_a1d(a, b)
RESULT(differ)
503 INTEGER(i2),
INTENT(in) :: a(:), b(:)
505 INTEGER :: asize, bsize
506 INTEGER(c_int) :: asize_c
510 IF (asize /= bsize)
THEN
511 WRITE (0,
'(a)')
'warning: comparing arrays of different size'
513 ELSE IF (asize > 0)
THEN
514 asize_c = int(asize, c_int)
515 differ = cmp_int16_arrays(asize_c, a, b)
519 END FUNCTION cmp_i2_arrays_a1d_a1d
521 FUNCTION cmp_i4_arrays_a1d_a1d(a, b)
RESULT(differ)
522 INTEGER(i4),
INTENT(in) :: a(:), b(:)
524 INTEGER :: asize, bsize
525 INTEGER(c_int) :: asize_c
529 IF (asize /= bsize)
THEN
530 WRITE (0,
'(a)')
'warning: comparing arrays of different size'
532 ELSE IF (asize > 0)
THEN
533 asize_c = int(asize, c_int)
534 differ = cmp_int32_arrays(asize_c, a, b)
538 END FUNCTION cmp_i4_arrays_a1d_a1d
540 FUNCTION cmp_i8_arrays_a1d_a1d(a, b)
RESULT(differ)
541 INTEGER(i8),
INTENT(in) :: a(:), b(:)
543 INTEGER :: asize, bsize
544 INTEGER(c_int) :: asize_c
548 IF (asize /= bsize)
THEN
549 WRITE (0,
'(a)')
'warning: comparing arrays of different size'
551 ELSE IF (asize > 0)
THEN
552 asize_c = int(asize, c_int)
553 differ = cmp_int64_arrays(asize_c, a, b)
557 END FUNCTION cmp_i8_arrays_a1d_a1d
559 FUNCTION cmp_i2_arrays_a2d_a2d(a, b)
RESULT(differ)
560 INTEGER(i2),
INTENT(in) :: a(:,:), b(:,:)
562 INTEGER :: asize, bsize
563 INTEGER(c_int) :: asize_c
567 IF (asize /= bsize)
THEN
568 WRITE (0,
'(a)')
'warning: comparing arrays of different size'
570 ELSE IF (asize > 0)
THEN
571 asize_c = int(asize, c_int)
572 differ = cmp_int16_arrays(asize_c, a, b)
576 END FUNCTION cmp_i2_arrays_a2d_a2d
578 FUNCTION cmp_i4_arrays_a2d_a2d(a, b)
RESULT(differ)
579 INTEGER(i4),
INTENT(in) :: a(:,:), b(:,:)
581 INTEGER :: asize, bsize
582 INTEGER(c_int) :: asize_c
586 IF (asize /= bsize)
THEN
587 WRITE (0,
'(a)')
'warning: comparing arrays of different size'
589 ELSE IF (asize > 0)
THEN
590 asize_c = int(asize, c_int)
591 differ = cmp_int32_arrays(asize_c, a, b)
595 END FUNCTION cmp_i4_arrays_a2d_a2d
597 FUNCTION cmp_i8_arrays_a2d_a2d(a, b)
RESULT(differ)
598 INTEGER(i8),
INTENT(in) :: a(:,:), b(:,:)
600 INTEGER :: asize, bsize
601 INTEGER(c_int) :: asize_c
605 IF (asize /= bsize)
THEN
606 WRITE (0,
'(a)')
'warning: comparing arrays of different size'
608 ELSE IF (asize > 0)
THEN
609 asize_c = int(asize, c_int)
610 differ = cmp_int64_arrays(asize_c, a, b)
614 END FUNCTION cmp_i8_arrays_a2d_a2d
616 FUNCTION cmp_i2_arrays_a3d_a3d(a, b)
RESULT(differ)
617 INTEGER(i2),
INTENT(in) :: a(:,:,:), b(:,:,:)
619 INTEGER :: asize, bsize
620 INTEGER(c_int) :: asize_c
624 IF (asize /= bsize)
THEN
625 WRITE (0,
'(a)')
'warning: comparing arrays of different size'
627 ELSE IF (asize > 0)
THEN
628 asize_c = int(asize, c_int)
629 differ = cmp_int16_arrays(asize_c, a, b)
633 END FUNCTION cmp_i2_arrays_a3d_a3d
635 FUNCTION cmp_i4_arrays_a3d_a3d(a, b)
RESULT(differ)
636 INTEGER(i4),
INTENT(in) :: a(:,:,:), b(:,:,:)
638 INTEGER :: asize, bsize
639 INTEGER(c_int) :: asize_c
643 IF (asize /= bsize)
THEN
644 WRITE (0,
'(a)')
'warning: comparing arrays of different size'
646 ELSE IF (asize > 0)
THEN
647 asize_c = int(asize, c_int)
648 differ = cmp_int32_arrays(asize_c, a, b)
652 END FUNCTION cmp_i4_arrays_a3d_a3d
654 FUNCTION cmp_i4_i2_arrays_a2d_a2d(a, b)
RESULT(differ)
655 INTEGER(i4),
INTENT(in) :: a(:,:)
656 INTEGER(i2),
INTENT(in) :: b(:,:)
658 INTEGER :: i, j, m, n
662 IF (m /=
SIZE(b, 1) .OR. n /=
SIZE(b, 2))
THEN
663 WRITE (0,
'(a)')
'warning: comparing arrays of different shape'
665 ELSE IF (
SIZE(a) > 0)
THEN
669 differ = differ .OR. a(i, j) /= int(b(i, j),
i4)
675 END FUNCTION cmp_i4_i2_arrays_a2d_a2d
677 FUNCTION cmp_i4_i8_arrays_a2d_a2d(a, b)
RESULT(differ)
678 INTEGER(i4),
INTENT(in) :: a(:,:)
679 INTEGER(i8),
INTENT(in) :: b(:,:)
681 INTEGER :: i, j, m, n
685 IF (m /=
SIZE(b, 1) .OR. n /=
SIZE(b, 2))
THEN
686 WRITE (0,
'(a)')
'warning: comparing arrays of different shape'
688 ELSE IF (
SIZE(a) > 0)
THEN
692 differ = differ .OR. int(a(i, j),
i8) /= b(i, j)
698 END FUNCTION cmp_i4_i8_arrays_a2d_a2d
700 FUNCTION cmp_i4_i2_arrays_a3d_a3d(a, b)
RESULT(differ)
701 INTEGER(i4),
INTENT(in) :: a(:,:,:)
702 INTEGER(i2),
INTENT(in) :: b(:,:,:)
704 INTEGER :: i, j, k, m, n, o
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'
712 ELSE IF (
SIZE(a) > 0)
THEN
717 differ = differ .OR. a(i, j, k) /= int(b(i, j, k),
i4)
724 END FUNCTION cmp_i4_i2_arrays_a3d_a3d
726 FUNCTION cmp_i4_i8_arrays_a3d_a3d(a, b)
RESULT(differ)
727 INTEGER(i4),
INTENT(in) :: a(:,:,:)
728 INTEGER(i8),
INTENT(in) :: b(:,:,:)
730 INTEGER :: i, j, k, m, n, o
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'
738 ELSE IF (
SIZE(a) > 0)
THEN
743 differ = differ .OR. int(a(i, j, k),
i8) /= b(i, j, k)
750 END FUNCTION cmp_i4_i8_arrays_a3d_a3d
752 FUNCTION cmp_i8_arrays_a3d_a3d(a, b)
RESULT(differ)
753 INTEGER(i8),
INTENT(in) :: a(:,:,:), b(:,:,:)
755 INTEGER :: asize, bsize
756 INTEGER(c_int) :: asize_c
760 IF (asize /= bsize)
THEN
761 WRITE (0,
'(a)')
'warning: comparing arrays of different size'
763 ELSE IF (asize > 0)
THEN
764 asize_c = int(asize, c_int)
765 differ = cmp_int64_arrays(asize_c, a, b)
769 END FUNCTION cmp_i8_arrays_a3d_a3d
771 SUBROUTINE factorize(c, a, b)
772 INTEGER,
INTENT(in) :: c
773 INTEGER,
INTENT(out) :: a, b
777 IF (c<1)
CALL test_abort(
'factorize: invalid process space', &
779 IF (c <= 3 .OR. c == 5 .OR. c == 7)
THEN
786 x0 = int(sqrt(0.5 * real(c)) + 0.5)
788 f_loop:
DO i = a, 1, -1
789 IF (mod(c,i) == 0)
THEN
796 END SUBROUTINE factorize
799 FUNCTION icbrt_i2(n)
RESULT(icbrt)
800 INTEGER(i2),
INTENT(in) :: n
802 INTEGER(i2),
PARAMETER :: nbits = bit_size(n)-1_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
816 icbrt = sign(icbrt, n)
817 END FUNCTION icbrt_i2
820 FUNCTION icbrt_i4(n)
RESULT(icbrt)
821 INTEGER(i4),
INTENT(in) :: n
823 INTEGER(i4),
PARAMETER :: nbits = bit_size(n)-1_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
837 icbrt = sign(icbrt, n)
838 END FUNCTION icbrt_i4
841 FUNCTION icbrt_i8(n)
RESULT(icbrt)
842 INTEGER(i8),
INTENT(in) :: n
844 INTEGER(i8),
PARAMETER :: nbits = bit_size(n)-1_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
858 icbrt = sign(icbrt, n)
859 END FUNCTION icbrt_i8
862 SUBROUTINE regular_deco(g_cn, c0, cn)
863 INTEGER,
INTENT(in) :: g_cn
864 INTEGER,
INTENT(out) :: c0(0:), cn(0:)
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&
890 c0(it) = c0(it-1) + cn(it-1)
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
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, &
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.
909 fully_random_tests = .false.
912 fully_random_tests = .false.
914 END FUNCTION run_randomized_tests
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')
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')))
926 END FUNCTION str2lower
928 SUBROUTINE init_fortran_random(full_random)
929 LOGICAL,
INTENT(in) :: full_random
930 INTEGER,
ALLOCATABLE :: rseed(:)
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, &
944 CHARACTER(len=32) :: envval
945 INTEGER :: envlen, envstat
947 CALL random_seed(size=rseed_size)
948 ALLOCATE(rseed(rseed_size))
952 IF (full_random)
THEN
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
973 timeseed = sum(tparts(1:7) * tparts_mult)
974 timeseed = ieor(tparts(8), timeseed)
976 CALL get_environment_variable(
"YAXT_RANDOM_SEED", envval, envlen, &
978 IF (envstat == 0)
THEN
979 WRITE (fmt,
'(a,i0,a)')
'(i', digits(rseed),
')'
980 READ(envval(1:envlen), fmt) rseed(1)
982 WRITE(0,
'(a,i0)')
'used extra seed=', rseed(1)
985 CALL random_seed(put=rseed)
986 END SUBROUTINE init_fortran_random
988 END MODULE ftest_common
integer, parameter, public i8
integer, parameter, public i4
integer, parameter, public i2