1!
2! Copyright (C) by Argonne National Laboratory
3!     See COPYRIGHT in top-level directory
4!
5
6! This file created from f77/util/mtestf.f with f77tof90
7
8        subroutine MTest_Init( ierr )
9!       Place the include first so that we can automatically create a
10!       Fortran 90 version that uses the mpi module instead.  If
11!       the module is in a different place, the compiler can complain
12!       about out-of-order statements
13        use mpi
14        integer ierr
15        logical flag
16        logical dbgflag
17        integer wrank
18        common /mtest/ dbgflag, wrank
19
20        call MPI_Initialized( flag, ierr )
21        if (.not. flag) then
22           call MPI_Init( ierr )
23        endif
24
25        dbgflag = .false.
26        call MPI_Comm_rank( MPI_COMM_WORLD, wrank, ierr )
27        end
28!
29        subroutine MTest_Finalize( errs )
30        use mpi
31        integer errs
32        integer rank, toterrs, ierr
33
34        call MPI_Comm_rank( MPI_COMM_WORLD, rank, ierr )
35
36        call MPI_Allreduce( errs, toterrs, 1, MPI_INTEGER, MPI_SUM,  &
37      &        MPI_COMM_WORLD, ierr )
38
39        if (rank .eq. 0) then
40           if (toterrs .gt. 0) then
41                print *, " Found ", toterrs, " errors"
42           else
43                print *, " No Errors"
44           endif
45        endif
46
47        call MPI_Finalize( ierr )
48        end
49!
50! A simple get intracomm for now
51        logical function MTestGetIntracomm( comm, min_size, qsmaller )
52        use mpi
53        integer ierr
54        integer comm, min_size, size, rank
55        logical qsmaller
56        integer myindex
57        save myindex
58        data myindex /0/
59
60        comm = MPI_COMM_NULL
61        if (myindex .eq. 0) then
62           comm = MPI_COMM_WORLD
63        else if (myindex .eq. 1) then
64           call mpi_comm_dup( MPI_COMM_WORLD, comm, ierr )
65        else if (myindex .eq. 2) then
66           call mpi_comm_size( MPI_COMM_WORLD, size, ierr )
67           call mpi_comm_rank( MPI_COMM_WORLD, rank, ierr )
68           call mpi_comm_split( MPI_COMM_WORLD, 0, size - rank, comm,  &
69      &                                 ierr )
70        else
71           if (min_size .eq. 1 .and. myindex .eq. 3) then
72              comm = MPI_COMM_SELF
73           endif
74        endif
75        myindex = mod( myindex, 4 ) + 1
76        MTestGetIntracomm = comm .ne. MPI_COMM_NULL
77        end
78!
79        subroutine MTestFreeComm( comm )
80        use mpi
81        integer comm, ierr
82        if (comm .ne. MPI_COMM_WORLD .and. &
83      &      comm .ne. MPI_COMM_SELF  .and. &
84      &      comm .ne. MPI_COMM_NULL) then
85           call mpi_comm_free( comm, ierr )
86        endif
87        end
88!
89        subroutine MTestPrintError( errcode )
90        use mpi
91        integer errcode
92        integer errclass, slen, ierr
93        character*(MPI_MAX_ERROR_STRING) string
94
95        call MPI_Error_class( errcode, errclass, ierr )
96        call MPI_Error_string( errcode, string, slen, ierr )
97        print *, "Error class ", errclass, "(", string(1:slen), ")"
98        end
99!
100        subroutine MTestPrintErrorMsg( msg, errcode )
101        use mpi
102        character*(*) msg
103        integer errcode
104        integer errclass, slen, ierr
105        character*(MPI_MAX_ERROR_STRING) string
106
107        call MPI_Error_class( errcode, errclass, ierr )
108        call MPI_Error_string( errcode, string, slen, ierr )
109        print *, msg, ": Error class ", errclass, " &
110      &       (", string(1:slen), ")"
111        end
112
113        subroutine MTestSpawnPossible( can_spawn, errs )
114        use mpi
115        integer can_spawn
116        integer errs
117        integer(kind=MPI_ADDRESS_KIND) val
118        integer ierror
119        logical flag
120        integer comm_size
121
122        call mpi_comm_get_attr( MPI_COMM_WORLD, MPI_UNIVERSE_SIZE, val, &
123      &                          flag, ierror )
124        if ( ierror .ne. MPI_SUCCESS ) then
125!       MPI_UNIVERSE_SIZE keyval missing from MPI_COMM_WORLD attributes
126            can_spawn = -1
127            errs = errs + 1
128        else
129            if ( flag ) then
130                comm_size = -1
131
132                call mpi_comm_size( MPI_COMM_WORLD, comm_size, ierror )
133                if ( ierror .ne. MPI_SUCCESS ) then
134!       MPI_COMM_SIZE failed for MPI_COMM_WORLD
135                    can_spawn = -1
136                    errs = errs + 1
137                    return
138                endif
139
140                if ( val .le. comm_size ) then
141!       no additional processes can be spawned
142                    can_spawn = 0
143                else
144                    can_spawn = 1
145                endif
146            else
147!       No attribute associated with key MPI_UNIVERSE_SIZE of MPI_COMM_WORLD
148                can_spawn = -1
149            endif
150        endif
151        end
152