teshsuite/smpi/mpich3-test/f90/rma/winnamef90.f90

   1 ! This file created from test/mpi/f77/rma/winnamef.f with f77tof90
   2 ! -*- Mode: Fortran; -*-
   3 !
   4 !  (C) 2003 by Argonne National Laboratory.
   5 !      See COPYRIGHT in top-level directory.
   6 !
   7       program main
   8       use mpi
   9       integer errs, ierr
  10       integer win, rlen, ln
  11       character*(MPI_MAX_OBJECT_NAME) cname
  12       integer buf(10)
  13       integer intsize
  14 ! Include addsize defines asize as an address-sized integer
  15       integer (kind=MPI_ADDRESS_KIND) asize
  16
  17       logical found
  18 !
  19       errs = 0
  20       call mtest_init( ierr )
  21 !
  22 ! Create a window and get, set the names on it
  23 !
  24       call mpi_type_size( MPI_INTEGER, intsize, ierr )
  25       asize = 10
  26       call mpi_win_create( buf, asize, intsize,  &
  27       &     MPI_INFO_NULL, MPI_COMM_WORLD, win, ierr )
  28 !
  29 !     Check that there is no name yet
  30       cname = 'XXXXXX'
  31       rlen  = -1
  32       call mpi_win_get_name( win, cname, rlen, ierr )
  33       if (rlen .ne. 0) then
  34          errs = errs + 1
  35          print *, ' Did not get empty name from new window'
  36       else if (cname(1:6) .ne. 'XXXXXX') then
  37          found = .false.
  38          do ln=MPI_MAX_OBJECT_NAME,1,-1
  39             if (cname(ln:ln) .ne. ' ') then
  40                found = .true.
  41             endif
  42          enddo
  43          if (found) then
  44             errs = errs + 1
  45             print *, ' Found a non-empty name'
  46          endif
  47       endif
  48 !
  49 ! Now, set a name and check it
  50       call mpi_win_set_name( win, 'MyName', ierr )
  51       cname = 'XXXXXX'
  52       rlen = -1
  53       call mpi_win_get_name( win, cname, rlen, ierr )
  54       if (rlen .ne. 6) then
  55          errs = errs + 1
  56          print *, ' Expected 6, got ', rlen, ' for rlen'
  57          if (rlen .gt. 0 .and. rlen .lt. MPI_MAX_OBJECT_NAME) then
  58             print *, ' Cname = ', cname(1:rlen)
  59          endif
  60       else if (cname(1:6) .ne. 'MyName') then
  61          errs = errs + 1
  62          print *, ' Expected MyName, got ', cname(1:6)
  63       else
  64          found = .false.
  65          do ln=MPI_MAX_OBJECT_NAME,7,-1
  66             if (cname(ln:ln) .ne. ' ') then
  67                found = .true.
  68             endif
  69          enddo
  70          if (found) then
  71             errs = errs + 1
  72             print *, ' window name is not blank padded'
  73          endif
  74       endif
  75 !
  76       call mpi_win_free( win, ierr )
  77       call mtest_finalize( errs )
  78       call mpi_finalize( ierr )
  79       end