1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
|
SUBROUTINE collect_results(test)
USE parallel_include
USE tester
IMPLICIT NONE
!
TYPE(tester_t) :: test
INTEGER :: itottests, itoterr, ierr, me
!
#if defined(__MPI)
!
CALL MPI_REDUCE(test%n_errors, itoterr, 1, MPI_INTEGER, MPI_SUM, &
0, MPI_COMM_WORLD, ierr)
! Fail in case MPI fails...
IF (ierr /= 0) CALL test%assert_equal(0, ierr)
!
CALL MPI_REDUCE(test%n_tests, itottests, 1, MPI_INTEGER, MPI_SUM, &
0, MPI_COMM_WORLD, ierr)
! Fail in case MPI fails...
IF (ierr /= 0) CALL test%assert_equal(0, ierr)
!
test%n_tests = itottests
test%n_errors = itoterr
!
IF (ierr /= 0) CALL test%assert_equal(0, ierr)
!
CALL MPI_Comm_rank(MPI_COMM_WORLD, me, ierr);
!
IF (ierr /= 0) CALL test%assert_equal(0, ierr)
!
#endif
END SUBROUTINE collect_results
SUBROUTINE save_random_seed(test_name, mpime)
IMPLICIT NONE
CHARACTER(len=*), INTENT(IN) :: test_name
INTEGER, INTENT(IN) :: mpime
!
INTEGER, PARAMETER :: in_unit=20, out_unit=21
CHARACTER(len=80) :: fname
INTEGER :: n, istat
INTEGER, ALLOCATABLE :: seed(:)
!
CALL random_seed(size = n)
ALLOCATE(seed(n))
! First try if the OS provides a random number generator
OPEN(UNIT=in_unit, file="/dev/urandom", access="stream", &
form="unformatted", action="read", status="old", iostat=istat)
IF (istat == 0) THEN
READ(in_unit) seed
CLOSE(in_unit)
ELSE
! Fallback to stupid algorithm. Actually we do not really need
! high-quality random numbers
CALL random_seed(get=seed)
seed = seed + mpime
END IF
!
CALL random_seed(put=seed)
!
WRITE(fname, '("rnd_seed_",A,I4.4)') TRIM(test_name), mpime
fname = TRIM(fname)
!
OPEN (UNIT=out_unit,FILE=fname,ACTION="write",STATUS="replace")
!
WRITE (out_unit,*) n
WRITE (out_unit,*) seed
CLOSE (out_unit)
DEALLOCATE(seed)
!
END SUBROUTINE save_random_seed
SUBROUTINE no_test
USE parallel_include
USE tester
IMPLICIT NONE
!TYPE(tester_t) :: test
INTEGER :: ierr
!
#if defined(__MPI)
CALL MPI_Init(ierr)
#endif
!CALL test%init()
!CALL print_results(test)
#if defined(__MPI)
CALL mpi_finalize(ierr)
#endif
END SUBROUTINE no_test
|
