teshsuite/smpi/mpich-test/context/commnamesf.f

   1 C
   2 C Check the communicator naming functions from Fortran
   3 C
   4
   5       include 'mpif.h'
   6
   7       integer error, namelen
   8       integer errcnt, rank
   9       character*40 the_name
  10       character*40 other_name
  11
  12       call mpi_init (error)
  13
  14       errcnt = 0
  15       call xify(the_name)
  16
  17       call mpi_comm_get_name (MPI_COMM_WORLD, the_name, namelen, error)
  18       if (error .ne. mpi_success) then
  19          errcnt = errcnt + 1
  20          print *,'Failed to get the name from MPI_COMM_WORLD'
  21          call MPI_Abort( MPI_COMM_WORLD, 1, error )
  22       end if
  23
  24       if (the_name .ne. 'MPI_COMM_WORLD') then
  25          errcnt = errcnt + 1
  26          print *,'The name on MPI_COMM_WORLD is not "MPI_COMM_WORLD"'
  27          call MPI_Abort( MPI_COMM_WORLD, 1, error )
  28       end if
  29
  30       other_name = 'foobarH'
  31       call mpi_comm_set_name(MPI_COMM_WORLD, other_name(1:6), error)
  32
  33       if (error .ne. mpi_success) then
  34          errcnt = errcnt + 1
  35          print *,'Failed to put a name onto MPI_COMM_WORLD'
  36          call MPI_Abort( MPI_COMM_WORLD, 1, error )
  37       end if
  38
  39       call xify(the_name)
  40
  41       call mpi_comm_get_name (MPI_COMM_WORLD, the_name, namelen, error)
  42       if (error .ne. mpi_success) then
  43          errcnt = errcnt + 1
  44          print *,'Failed to get the name from MPI_COMM_WORLD ',
  45      $        'after setting it'
  46          call MPI_Abort( MPI_COMM_WORLD, 1, error )
  47       end if
  48
  49       if (the_name .ne. 'foobar') then
  50          errcnt = errcnt + 1
  51          print *,'The name on MPI_COMM_WORLD is not "foobar"'
  52          print *, 'Got ', the_name
  53          call MPI_Abort( MPI_COMM_WORLD, 1, error )
  54       end if
  55
  56       call mpi_comm_rank( MPI_COMM_WORLD, rank, error )
  57       if (errcnt .eq. 0 .and. rank .eq. 0) then
  58          print *, ' No Errors'
  59       endif
  60       call mpi_finalize(error)
  61       end
  62
  63
  64       subroutine xify( string )
  65       character*(*) string
  66
  67       integer i
  68
  69       do i = 1,len(string)
  70          string(i:i) = 'X'
  71       end do
  72
  73       end
  74
  75