teshsuite/smpi/mpich3-test/f90/util/mtestf90.f90

   1 ! This file created from test/mpi/f77/util/mtestf.f with f77tof90
   2 ! -*- Mode: Fortran; -*-
   3 !
   4 !  (C) 2003 by Argonne National Laboratory.
   5 !      See COPYRIGHT in top-level directory.
   6 !
   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
  12         use mpi
  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 !
  28         subroutine MTest_Finalize( errs )
  29         use mpi
  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
  47 module array
  48         integer, dimension(:), allocatable :: myindex
  49 end module
  50
  51 !
  52 ! A simple get intracomm for now
  53         logical function MTestGetIntracomm( comm, min_size, qsmaller )
  54         use array
  55         use mpi
  56
  57         integer ierr
  58         integer comm, min_size, size, rank
  59         logical qsmaller
  60
  61         integer status
  62         call mpi_comm_size( MPI_COMM_WORLD, size, ierr )
  63
  64         if(.not. allocated(myindex)) then
  65             allocate(myindex(size), STAT=status)
  66             call mpi_comm_rank( MPI_COMM_WORLD, rank, ierr )
  67             myindex(rank+1)=0
  68         endif
  69
  70         !data myindex /0/
  71
  72
  73
  74         if (myindex(rank+1) .eq. 0) then
  75            comm = MPI_COMM_WORLD
  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,  &
  82       &                                 ierr )
  83         else
  84            if (min_size .eq. 1 .and. myindex(rank+1) .eq. 3) then
  85               comm = MPI_COMM_SELF
  86            endif
  87         endif
  88         myindex(rank+1) = mod( myindex(rank+1), 4 ) + 1
  89         MTestGetIntracomm = comm .ne. MPI_COMM_NULL
  90         qsmaller=.true.
  91         end
  92 !
  93         subroutine MTestFreeComm( comm )
  94         use mpi
  95         integer comm, ierr
  96         if (comm .ne. MPI_COMM_WORLD .and. &
  97       &      comm .ne. MPI_COMM_SELF  .and. &
  98       &      comm .ne. MPI_COMM_NULL) then
  99            call mpi_comm_free( comm, ierr )
 100         endif
 101         end
 102 !
 103         subroutine MTestPrintError( errcode )
 104         use mpi
 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 *, "Error class ", errclass, "(", string(1:slen), ")"
 112         end
 113 !
 114         subroutine MTestPrintErrorMsg( msg, errcode )
 115         use mpi
 116         character*(*) msg
 117         integer errcode
 118         integer errclass, slen, ierr
 119         character*(MPI_MAX_ERROR_STRING) string
 120
 121         call MPI_Error_class( errcode, errclass, ierr )
 122         call MPI_Error_string( errcode, string, slen, ierr )
 123         print *, msg, ": Error class ", errclass, " &
 124       &       (", string(1:slen), ")"
 125         end