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

   1 ! This file created from test/mpi/f77/rma/winattrf.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 (kind=MPI_ADDRESS_KIND) extrastate, valin, valout, val
  11
  12       integer comm, win, buf(10)
  13       integer curcount, keyval
  14       logical flag
  15       external mycopyfn, mydelfn
  16       integer callcount, delcount
  17       common /myattr/ callcount, delcount
  18 !
  19 ! The only difference between the MPI-2 and MPI-1 attribute caching
  20 ! routines in Fortran is that the take an address-sized integer
  21 ! instead of a simple integer.  These still are not pointers,
  22 ! so the values are still just integers.
  23 !
  24       errs      = 0
  25       callcount = 0
  26       delcount  = 0
  27       call mtest_init( ierr )
  28       call mpi_comm_dup( MPI_COMM_WORLD, comm, ierr )
  29 ! Create a new window; use val for an address-sized int
  30       val = 10
  31       call mpi_win_create( buf, val, 1, &
  32       &                        MPI_INFO_NULL, comm, win, ierr )
  33 !
  34       extrastate = 1001
  35       call mpi_win_create_keyval( mycopyfn, mydelfn, keyval,  &
  36       &                             extrastate, ierr )
  37       flag = .true.
  38       call mpi_win_get_attr( win, keyval, valout, flag, ierr )
  39       if (flag) then
  40          errs = errs + 1
  41          print *, ' get attr returned true when no attr set'
  42       endif
  43
  44       valin = 2003
  45       call mpi_win_set_attr( win, keyval, valin, ierr )
  46       flag = .false.
  47       valout = -1
  48       call mpi_win_get_attr( win, keyval, valout, flag, ierr )
  49       if (valout .ne. 2003) then
  50          errs = errs + 1
  51          print *, 'Unexpected value (should be 2003)', valout,  &
  52       &            ' from attr'
  53       endif
  54
  55       valin = 2001
  56       call mpi_win_set_attr( win, keyval, valin, ierr )
  57       flag = .false.
  58       valout = -1
  59       call mpi_win_get_attr( win, keyval, valout, flag, ierr )
  60       if (valout .ne. 2001) then
  61          errs = errs + 1
  62          print *, 'Unexpected value (should be 2001)', valout,  &
  63       &            ' from attr'
  64       endif
  65 !
  66 ! Test the attr delete function
  67       delcount   = 0
  68       call mpi_win_delete_attr( win, keyval, ierr )
  69       if (delcount .ne. 1) then
  70          errs = errs + 1
  71          print *, ' Delete_attr did not call delete function'
  72       endif
  73       flag = .true.
  74       call mpi_win_get_attr( win, keyval, valout, flag, ierr )
  75       if (flag) then
  76          errs = errs + 1
  77          print *, ' Delete_attr did not delete attribute'
  78       endif
  79
  80 ! Test the delete function on window free
  81       valin = 2001
  82       call mpi_win_set_attr( win, keyval, valin, ierr )
  83       curcount = delcount
  84       call mpi_win_free( win, ierr )
  85       if (delcount .ne. curcount + 1) then
  86          errs = errs + 1
  87          print *, ' did not get expected value of delcount ',  &
  88       &          delcount, curcount + 1
  89       endif
  90
  91       ierr = -1
  92       call mpi_win_free_keyval( keyval, ierr )
  93       if (ierr .ne. MPI_SUCCESS) then
  94          errs = errs + 1
  95          call mtestprinterror( ierr )
  96       endif
  97 !
  98 ! The MPI standard defines null copy and duplicate functions.
  99 ! However, are only used when an object is duplicated.  Since
 100 ! MPI_Win objects cannot be duplicated, so under normal circumstances,
 101 ! these will not be called.  Since they are defined, they should behave
 102 ! as defined.  To test them, we simply call them here
 103       flag   = .false.
 104       valin  = 7001
 105       valout = -1
 106       ierr   = -1
 107       call MPI_WIN_DUP_FN( win, keyval, extrastate, valin, valout, &
 108       &     flag, ierr )
 109       if (.not. flag) then
 110          errs = errs + 1
 111          print *, " Flag was false after MPI_WIN_DUP_FN"
 112       else if (valout .ne. 7001) then
 113          errs = errs + 1
 114          if (valout .eq. -1 ) then
 115           print *, " output attr value was not copied in MPI_WIN_DUP_FN"
 116          endif
 117          print *, " value was ", valout, " but expected 7001"
 118       else if (ierr .ne. MPI_SUCCESS) then
 119          errs = errs + 1
 120          print *, " MPI_WIN_DUP_FN did not return MPI_SUCCESS"
 121       endif
 122
 123       flag   = .true.
 124       valin  = 7001
 125       valout = -1
 126       ierr   = -1
 127       call MPI_WIN_NULL_COPY_FN( win, keyval, extrastate, valin, valout &
 128       &     ,flag, ierr )
 129       if (flag) then
 130          errs = errs + 1
 131          print *, " Flag was true after MPI_WIN_NULL_COPY_FN"
 132       else if (valout .ne. -1) then
 133          errs = errs + 1
 134          print *, &
 135       &        " output attr value was copied in MPI_WIN_NULL_COPY_FN"
 136       else if (ierr .ne. MPI_SUCCESS) then
 137          errs = errs + 1
 138          print *, " MPI_WIN_NULL_COPY_FN did not return MPI_SUCCESS"
 139       endif
 140 !
 141       call mpi_comm_free( comm, ierr )
 142       call mtest_finalize( errs )
 143       call mpi_finalize( ierr )
 144       end
 145 !
 146 ! Note that the copyfn is unused for MPI windows, since there is
 147 ! (and because of alias rules, can be) no MPI_Win_dup function
 148       subroutine mycopyfn( oldwin, keyval, extrastate, valin, valout, &
 149       &                     flag, ierr )
 150       use mpi
 151       integer oldwin, keyval, ierr
 152       integer (kind=MPI_ADDRESS_KIND) extrastate, valin, valout, val
 153
 154       logical flag
 155       integer callcount, delcount
 156       common /myattr/ callcount, delcount
 157 ! increment the attribute by 2
 158       valout = valin + 2
 159       callcount = callcount + 1
 160 !
 161 ! Since we should *never* call this, indicate an error
 162       print *, ' Unexpected use of mycopyfn'
 163       flag = .false.
 164       ierr = MPI_ERR_OTHER
 165       end
 166 !
 167       subroutine mydelfn( win, keyval, val, extrastate, ierr )
 168       use mpi
 169       integer win, keyval, ierr
 170       integer (kind=MPI_ADDRESS_KIND) extrastate, valin, valout, val
 171
 172       integer callcount, delcount
 173       common /myattr/ callcount, delcount
 174       delcount = delcount + 1
 175       if (extrastate .eq. 1001) then
 176          ierr = MPI_SUCCESS
 177       else
 178          print *, ' Unexpected value of extrastate = ', extrastate
 179          ierr = MPI_ERR_OTHER
 180       endif
 181       end