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"
48 integer, dimension(:), allocatable :: myindex
52 ! A simple get intracomm for now
53 logical function MTestGetIntracomm( comm, min_size, qsmaller )
58 integer comm, min_size, size, rank
62 call mpi_comm_size( MPI_COMM_WORLD, size, ierr )
64 if(.not. allocated(myindex)) then
65 allocate(myindex(size), STAT=status)
66 call mpi_comm_rank( MPI_COMM_WORLD, rank, ierr )
74 if (myindex(rank+1) .eq. 0) then
76 else if (myindex(rank+1) .eq. 1) then
77 call mpi_comm_dup( MPI_COMM_WORLD, comm, ierr )
78 else if (myindex(rank+1) .eq. 2) then
79 call mpi_comm_size( MPI_COMM_WORLD, size, ierr )
80 call mpi_comm_rank( MPI_COMM_WORLD, rank, ierr )
81 call mpi_comm_split( MPI_COMM_WORLD, 0, size - rank, comm, &
84 if (min_size .eq. 1 .and. myindex(rank+1) .eq. 3) then
88 myindex(rank+1) = mod( myindex(rank+1), 4 ) + 1
89 MTestGetIntracomm = comm .ne. MPI_COMM_NULL
92 subroutine MTestFreeComm( comm )
95 if (comm .ne. MPI_COMM_WORLD .and. &
96 & comm .ne. MPI_COMM_SELF .and. &
97 & comm .ne. MPI_COMM_NULL) then
98 call mpi_comm_free( comm, ierr )
102 subroutine MTestPrintError( errcode )
105 integer errclass, slen, ierr
106 character*(MPI_MAX_ERROR_STRING) string
108 call MPI_Error_class( errcode, errclass, ierr )
109 call MPI_Error_string( errcode, string, slen, ierr )
110 print *, "Error class ", errclass, "(", string(1:slen), ")"
113 subroutine MTestPrintErrorMsg( msg, errcode )
117 integer errclass, slen, ierr
118 character*(MPI_MAX_ERROR_STRING) string
120 call MPI_Error_class( errcode, errclass, ierr )
121 call MPI_Error_string( errcode, string, slen, ierr )
122 print *, msg, ": Error class ", errclass, " &
123 & (", string(1:slen), ")"