teshsuite/smpi/mpich3-test/f77/util/mtestf.f

   1 C -*- Mode: Fortran; -*-
   2 C
   3 C  (C) 2003 by Argonne National Laboratory.
   4 C      See COPYRIGHT in top-level directory.
   5 C
   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
  11         implicit none
  12         include 'mpif.h'
  13         integer ierr
  14         logical flag
  15         logical dbgflag
  16         integer wrank
  17         common /mtest/ dbgflag, wrank
  18
  19         call MPI_Initialized( flag, ierr )
  20         if (.not. flag) then
  21            call MPI_Init( ierr )
  22         endif
  23
  24         dbgflag = .false.
  25         call MPI_Comm_rank( MPI_COMM_WORLD, wrank, ierr )
  26         end
  27 C
  28         subroutine MTest_Finalize( errs )
  29         implicit none
  30         include 'mpif.h'
  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         end
  47 C
  48 C A simple get intracomm for now
  49         logical function MTestGetIntracomm( comm, min_size, qsmaller )
  50         implicit none
  51         include 'mpif.h'
  52         integer ierr
  53         integer comm, min_size, size, rank
  54         logical qsmaller
  55         integer myindex
  56         common /grr/ myindex
  57
  58         comm = MPI_COMM_NULL
  59         if (myindex .eq. 0) then
  60            comm = MPI_COMM_WORLD
  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,
  67      &                                 ierr )
  68         else
  69            if (min_size .eq. 1 .and. myindex .eq. 3) then
  70               comm = MPI_COMM_SELF
  71            endif
  72         endif
  73         myindex = mod( myindex, 4 ) + 1
  74         MTestGetIntracomm = comm .ne. MPI_COMM_NULL
  75         qsmaller=.true.
  76         end
  77 C
  78         subroutine MTestFreeComm( comm )
  79         implicit none
  80         include 'mpif.h'
  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 C
  89         subroutine MTestPrintError( errcode )
  90         implicit none
  91         include 'mpif.h'
  92         integer errcode
  93         integer errclass, slen, ierr
  94         character*(MPI_MAX_ERROR_STRING) string
  95
  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), ")"
  99         end
 100 C
 101         subroutine MTestPrintErrorMsg( msg, errcode )
 102         implicit none
 103         include 'mpif.h'
 104         character*(*) msg
 105         integer errcode
 106         integer errclass, slen, ierr
 107         character*(MPI_MAX_ERROR_STRING) string
 108
 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), ")"
 113         end