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