teshsuite/smpi/mpich3-test/f77/comm/commnamef.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       program main
   7       implicit none
   8       include 'mpif.h'
   9       integer errs, ierr
  10       integer comm(4), i, rlen, ln
  11       integer ncomm
  12       character*(MPI_MAX_OBJECT_NAME) inname(4), cname
  13       logical MTestGetIntracomm
  14
  15       errs = 0
  16       call mtest_init( ierr )
  17
  18 C Test the predefined communicators
  19       do ln=1,MPI_MAX_OBJECT_NAME
  20          cname(ln:ln) = 'X'
  21       enddo
  22       call mpi_comm_get_name( MPI_COMM_WORLD, cname, rlen, ierr )
  23       do ln=MPI_MAX_OBJECT_NAME,1,-1
  24          if (cname(ln:ln) .ne. ' ') then
  25             if (ln .ne. rlen) then
  26                errs = errs + 1
  27                print *, 'result len ', rlen,' not equal to actual len ',
  28      &              ln
  29             endif
  30             goto 110
  31          endif
  32       enddo
  33       if (cname(1:rlen) .ne. 'MPI_COMM_WORLD') then
  34          errs = errs + 1
  35          print *, 'Did not get MPI_COMM_WORLD for world'
  36       endif
  37  110  continue
  38 C
  39       do ln=1,MPI_MAX_OBJECT_NAME
  40          cname(ln:ln) = 'X'
  41       enddo
  42       call mpi_comm_get_name( MPI_COMM_SELF, cname, rlen, ierr )
  43       do ln=MPI_MAX_OBJECT_NAME,1,-1
  44          if (cname(ln:ln) .ne. ' ') then
  45             if (ln .ne. rlen) then
  46                errs = errs + 1
  47                print *, 'result len ', rlen,' not equal to actual len ',
  48      &              ln
  49             endif
  50             goto 120
  51          endif
  52       enddo
  53       if (cname(1:rlen) .ne. 'MPI_COMM_SELF') then
  54          errs = errs + 1
  55          print *, 'Did not get MPI_COMM_SELF for world'
  56       endif
  57  120  continue
  58 C
  59       do i = 1, 4
  60          if (MTestGetIntracomm( comm(i), 1, .true. )) then
  61             ncomm = i
  62             write( inname(i), '(a,i1)') 'myname',i
  63             call mpi_comm_set_name( comm(i), inname(i), ierr )
  64          else
  65             goto 130
  66          endif
  67       enddo
  68  130   continue
  69 C
  70 C     Now test them all
  71       do i=1, ncomm
  72          call mpi_comm_get_name( comm(i), cname, rlen, ierr )
  73          if (inname(i) .ne. cname) then
  74             errs = errs + 1
  75             print *, ' Expected ', inname(i), ' got ', cname
  76          endif
  77          call MTestFreeComm( comm(i) )
  78       enddo
  79 C
  80       call mtest_finalize( errs )
  81       call mpi_finalize( ierr )
  82       end