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