1 ! This file created from test/mpi/f77/util/mtestf.f with f77tof90
2 ! -*- Mode: Fortran; -*-
4 ! (C) 2003 by Argonne National Laboratory.
5 ! See COPYRIGHT in top-level directory.
7 subroutine MTest_Init( ierr )
8 ! Place the include first so that we can automatically create a
9 ! Fortran 90 version that uses the mpi module instead. If
10 ! the module is in a different place, the compiler can complain
11 ! about out-of-order statements
17 common /mtest/ dbgflag, wrank
19 call MPI_Initialized( flag, ierr )
25 call MPI_Comm_rank( MPI_COMM_WORLD, wrank, ierr )
28 subroutine MTest_Finalize( errs )
31 integer rank, toterrs, ierr
33 call MPI_Comm_rank( MPI_COMM_WORLD, rank, ierr )
35 call MPI_Allreduce( errs, toterrs, 1, MPI_INTEGER, MPI_SUM, &
36 & MPI_COMM_WORLD, ierr )
39 if (toterrs .gt. 0) then
40 print *, " Found ", toterrs, " errors"
47 ! A simple get intracomm for now
48 logical function MTestGetIntracomm( comm, min_size, qsmaller )
51 integer comm, min_size, size, rank
58 if (myindex .eq. 0) then
60 else if (myindex .eq. 1) then
61 call mpi_comm_dup( MPI_COMM_WORLD, comm, ierr )
62 else if (myindex .eq. 2) then
63 call mpi_comm_size( MPI_COMM_WORLD, size, ierr )
64 call mpi_comm_rank( MPI_COMM_WORLD, rank, ierr )
65 call mpi_comm_split( MPI_COMM_WORLD, 0, size - rank, comm, &
68 if (min_size .eq. 1 .and. myindex .eq. 3) then
72 myindex = mod( myindex, 4 ) + 1
73 MTestGetIntracomm = comm .ne. MPI_COMM_NULL
76 subroutine MTestFreeComm( comm )
79 if (comm .ne. MPI_COMM_WORLD .and. &
80 & comm .ne. MPI_COMM_SELF .and. &
81 & comm .ne. MPI_COMM_NULL) then
82 call mpi_comm_free( comm, ierr )
86 subroutine MTestPrintError( errcode )
89 integer errclass, slen, ierr
90 character*(MPI_MAX_ERROR_STRING) string
92 call MPI_Error_class( errcode, errclass, ierr )
93 call MPI_Error_string( errcode, string, slen, ierr )
94 print *, "Error class ", errclass, "(", string(1:slen), ")"
97 subroutine MTestPrintErrorMsg( msg, errcode )
101 integer errclass, slen, ierr
102 character*(MPI_MAX_ERROR_STRING) string
104 call MPI_Error_class( errcode, errclass, ierr )
105 call MPI_Error_string( errcode, string, slen, ierr )
106 print *, msg, ": Error class ", errclass, " &
107 & (", string(1:slen), ")"