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
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
|
!
! Copyright (C) by Argonne National Laboratory
! See COPYRIGHT in top-level directory
!
! This file created from f77/util/mtestf.f with f77tof90
subroutine MTest_Init( ierr )
! Place the include first so that we can automatically create a
! Fortran 90 version that uses the mpi module instead. If
! the module is in a different place, the compiler can complain
! about out-of-order statements
use mpi
integer ierr
logical flag
logical dbgflag
integer wrank
common /mtest/ dbgflag, wrank
call MPI_Initialized( flag, ierr )
if (.not. flag) then
call MPI_Init( ierr )
endif
dbgflag = .false.
call MPI_Comm_rank( MPI_COMM_WORLD, wrank, ierr )
end
!
subroutine MTest_Finalize( errs )
use mpi
integer errs
integer rank, toterrs, ierr
call MPI_Comm_rank( MPI_COMM_WORLD, rank, ierr )
call MPI_Allreduce( errs, toterrs, 1, MPI_INTEGER, MPI_SUM, &
& MPI_COMM_WORLD, ierr )
if (rank .eq. 0) then
if (toterrs .gt. 0) then
print *, " Found ", toterrs, " errors"
else
print *, " No Errors"
endif
endif
call MPI_Finalize( ierr )
end
!
! A simple get intracomm for now
logical function MTestGetIntracomm( comm, min_size, qsmaller )
use mpi
integer ierr
integer comm, min_size, size, rank
logical qsmaller
integer myindex
save myindex
data myindex /0/
comm = MPI_COMM_NULL
if (myindex .eq. 0) then
comm = MPI_COMM_WORLD
else if (myindex .eq. 1) then
call mpi_comm_dup( MPI_COMM_WORLD, comm, ierr )
else if (myindex .eq. 2) then
call mpi_comm_size( MPI_COMM_WORLD, size, ierr )
call mpi_comm_rank( MPI_COMM_WORLD, rank, ierr )
call mpi_comm_split( MPI_COMM_WORLD, 0, size - rank, comm, &
& ierr )
else
if (min_size .eq. 1 .and. myindex .eq. 3) then
comm = MPI_COMM_SELF
endif
endif
myindex = mod( myindex, 4 ) + 1
MTestGetIntracomm = comm .ne. MPI_COMM_NULL
end
!
subroutine MTestFreeComm( comm )
use mpi
integer comm, ierr
if (comm .ne. MPI_COMM_WORLD .and. &
& comm .ne. MPI_COMM_SELF .and. &
& comm .ne. MPI_COMM_NULL) then
call mpi_comm_free( comm, ierr )
endif
end
!
subroutine MTestPrintError( errcode )
use mpi
integer errcode
integer errclass, slen, ierr
character*(MPI_MAX_ERROR_STRING) string
call MPI_Error_class( errcode, errclass, ierr )
call MPI_Error_string( errcode, string, slen, ierr )
print *, "Error class ", errclass, "(", string(1:slen), ")"
end
!
subroutine MTestPrintErrorMsg( msg, errcode )
use mpi
character*(*) msg
integer errcode
integer errclass, slen, ierr
character*(MPI_MAX_ERROR_STRING) string
call MPI_Error_class( errcode, errclass, ierr )
call MPI_Error_string( errcode, string, slen, ierr )
print *, msg, ": Error class ", errclass, " &
& (", string(1:slen), ")"
end
subroutine MTestSpawnPossible( can_spawn, errs )
use mpi
integer can_spawn
integer errs
integer(kind=MPI_ADDRESS_KIND) val
integer ierror
logical flag
integer comm_size
call mpi_comm_get_attr( MPI_COMM_WORLD, MPI_UNIVERSE_SIZE, val, &
& flag, ierror )
if ( ierror .ne. MPI_SUCCESS ) then
! MPI_UNIVERSE_SIZE keyval missing from MPI_COMM_WORLD attributes
can_spawn = -1
errs = errs + 1
else
if ( flag ) then
comm_size = -1
call mpi_comm_size( MPI_COMM_WORLD, comm_size, ierror )
if ( ierror .ne. MPI_SUCCESS ) then
! MPI_COMM_SIZE failed for MPI_COMM_WORLD
can_spawn = -1
errs = errs + 1
return
endif
if ( val .le. comm_size ) then
! no additional processes can be spawned
can_spawn = 0
else
can_spawn = 1
endif
else
! No attribute associated with key MPI_UNIVERSE_SIZE of MPI_COMM_WORLD
can_spawn = -1
endif
endif
end
|
