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
  18         call MPI_Initialized( flag, ierr )
  19         if (.not. flag) then
  20            call MPI_Init( ierr )
  21         endif
  22
  23         dbgflag = .false.
  24         call MPI_Comm_rank( MPI_COMM_WORLD, wrank, ierr )
  25         end
  26 C
  27         subroutine MTest_Finalize( errs )
  28         implicit none
  29         include 'mpif.h'
  30         integer errs
  31         integer rank, toterrs, ierr
  32
  33         call MPI_Comm_rank( MPI_COMM_WORLD, rank, ierr )
  34
  35         call MPI_Allreduce( errs, toterrs, 1, MPI_INTEGER, MPI_SUM,
  36      *        MPI_COMM_WORLD, ierr )
  37
  38         if (rank .eq. 0) then
  39            if (toterrs .gt. 0) then
  40                 print *, " Found ", toterrs, " errors"
  41            else
  42                 print *, " No Errors"
  43            endif
  44         endif
  45         end
  46 C
  47 C A simple get intracomm for now
  48         logical function MTestGetIntracomm( comm, min_size, qsmaller )
  49         implicit none
  50         include 'mpif.h'
  51         integer ierr
  52         integer comm, min_size, size, rank
  53         logical qsmaller
  54         integer myindex
  55         save myindex
  56         data myindex /0/
  57
  58         if (.false.) then
  59            qsmaller = qsmaller
  60         endif
  61         comm = MPI_COMM_NULL
  62         if (myindex .eq. 0) then
  63            comm = MPI_COMM_WORLD
  64         else if (myindex .eq. 1) then
  65            call mpi_comm_dup( MPI_COMM_WORLD, comm, ierr )
  66         else if (myindex .eq. 2) then
  67            call mpi_comm_size( MPI_COMM_WORLD, size, ierr )
  68            call mpi_comm_rank( MPI_COMM_WORLD, rank, ierr )
  69            call mpi_comm_split( MPI_COMM_WORLD, 0, size - rank, comm,
  70      &                                 ierr )
  71         else
  72            if (min_size .eq. 1 .and. myindex .eq. 3) then
  73               comm = MPI_COMM_SELF
  74            endif
  75         endif
  76         myindex = mod( myindex, 4 ) + 1
  77         MTestGetIntracomm = comm .ne. MPI_COMM_NULL
  78         end
  79 C
  80         subroutine MTestFreeComm( comm )
  81         implicit none
  82         include 'mpif.h'
  83         integer comm, ierr
  84         if (comm .ne. MPI_COMM_WORLD .and.
  85      &      comm .ne. MPI_COMM_SELF  .and.
  86      &      comm .ne. MPI_COMM_NULL) then
  87            call mpi_comm_free( comm, ierr )
  88         endif
  89         end
  90 C
  91         subroutine MTestPrintError( errcode )
  92         implicit none
  93         include 'mpif.h'
  94         integer errcode
  95         integer errclass, slen, ierr
  96         character*(MPI_MAX_ERROR_STRING) string
  97
  98         call MPI_Error_class( errcode, errclass, ierr )
  99         call MPI_Error_string( errcode, string, slen, ierr )
 100         print *, "Error class ", errclass, "(", string(1:slen), ")"
 101         end
 102 C
 103         subroutine MTestPrintErrorMsg( msg, errcode )
 104         implicit none
 105         include 'mpif.h'
 106         character*(*) msg
 107         integer errcode
 108         integer errclass, slen, ierr
 109         character*(MPI_MAX_ERROR_STRING) string
 110
 111         call MPI_Error_class( errcode, errclass, ierr )
 112         call MPI_Error_string( errcode, string, slen, ierr )
 113         print *, msg, ": Error class ", errclass, "
 114      $       (", string(1:slen), ")"
 115         end