1 C -*- Mode: Fortran; -*-
3 C (C) 2003 by Argonne National Laboratory.
4 C See COPYRIGHT in top-level directory.
6 subroutine MTest_Init( ierr )
7 C Place the include first so that we can automatically create a
8 C Fortran 90 version that uses the mpi module instead. If
9 C the module is in a different place, the compiler can complain
10 C 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 )
32 integer rank, toterrs, ierr
34 call MPI_Comm_rank( MPI_COMM_WORLD, rank, ierr )
36 call MPI_Allreduce( errs, toterrs, 1, MPI_INTEGER, MPI_SUM,
37 * MPI_COMM_WORLD, ierr )
40 if (toterrs .gt. 0) then
41 print *, " Found ", toterrs, " errors"
48 C A simple get intracomm for now
49 logical function MTestGetIntracomm( comm, min_size, qsmaller )
53 integer comm, min_size, size, rank
59 if (myindex .eq. 0) then
61 else if (myindex .eq. 1) then
62 call mpi_comm_dup( MPI_COMM_WORLD, comm, ierr )
63 else if (myindex .eq. 2) then
64 call mpi_comm_size( MPI_COMM_WORLD, size, ierr )
65 call mpi_comm_rank( MPI_COMM_WORLD, rank, ierr )
66 call mpi_comm_split( MPI_COMM_WORLD, 0, size - rank, comm,
69 if (min_size .eq. 1 .and. myindex .eq. 3) then
73 myindex = mod( myindex, 4 ) + 1
74 MTestGetIntracomm = comm .ne. MPI_COMM_NULL
78 subroutine MTestFreeComm( comm )
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 )
89 subroutine MTestPrintError( errcode )
93 integer errclass, slen, ierr
94 character*(MPI_MAX_ERROR_STRING) string
96 call MPI_Error_class( errcode, errclass, ierr )
97 call MPI_Error_string( errcode, string, slen, ierr )
98 print *, "Error class ", errclass, "(", string(1:slen), ")"
101 subroutine MTestPrintErrorMsg( msg, errcode )
106 integer errclass, slen, ierr
107 character*(MPI_MAX_ERROR_STRING) string
109 call MPI_Error_class( errcode, errclass, ierr )
110 call MPI_Error_string( errcode, string, slen, ierr )
111 print *, msg, ": Error class ", errclass, "
112 $ (", string(1:slen), ")"