teshsuite/smpi/mpich3-test/f77/rma/winattr2f.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  This is a modified version of winattrf.f that uses two of the
   6 C  default functions
   7 C
   8       program main
   9       implicit none
  10       include 'mpif.h'
  11       integer errs, ierr
  12       include 'attraints.h'
  13       integer comm, win, buf(10)
  14       integer keyval
  15       logical flag
  16 C
  17 C The only difference between the MPI-2 and MPI-1 attribute caching
  18 C routines in Fortran is that the take an address-sized integer
  19 C instead of a simple integer.  These still are not pointers,
  20 C so the values are still just integers.
  21 C
  22       errs      = 0
  23       call mtest_init( ierr )
  24       call mpi_comm_dup( MPI_COMM_WORLD, comm, ierr )
  25 C Create a new window; use val for an address-sized int
  26       val = 10
  27       call mpi_win_create( buf, val, 1,
  28      &                        MPI_INFO_NULL, comm, win, ierr )
  29 C
  30       extrastate = 1001
  31       call mpi_win_create_keyval( MPI_WIN_DUP_FN,
  32      &                            MPI_WIN_NULL_DELETE_FN, keyval,
  33      &                             extrastate, ierr )
  34       flag = .true.
  35       call mpi_win_get_attr( win, keyval, valout, flag, ierr )
  36       if (flag) then
  37          errs = errs + 1
  38          print *, ' get attr returned true when no attr set'
  39       endif
  40
  41       valin = 2003
  42       call mpi_win_set_attr( win, keyval, valin, ierr )
  43       flag = .false.
  44       valout = -1
  45       call mpi_win_get_attr( win, keyval, valout, flag, ierr )
  46       if (valout .ne. 2003) then
  47          errs = errs + 1
  48          print *, 'Unexpected value (should be 2003)', valout,
  49      &            ' from attr'
  50       endif
  51
  52       valin = 2001
  53       call mpi_win_set_attr( win, keyval, valin, ierr )
  54       flag = .false.
  55       valout = -1
  56       call mpi_win_get_attr( win, keyval, valout, flag, ierr )
  57       if (valout .ne. 2001) then
  58          errs = errs + 1
  59          print *, 'Unexpected value (should be 2001)', valout,
  60      &            ' from attr'
  61       endif
  62 C
  63 C Test the attr delete function
  64       call mpi_win_delete_attr( win, keyval, ierr )
  65       flag = .true.
  66       call mpi_win_get_attr( win, keyval, valout, flag, ierr )
  67       if (flag) then
  68          errs = errs + 1
  69          print *, ' Delete_attr did not delete attribute'
  70       endif
  71
  72 C Test the delete function on window free
  73       valin = 2001
  74       call mpi_win_set_attr( win, keyval, valin, ierr )
  75       call mpi_win_free( win, ierr )
  76       call mpi_comm_free( comm, ierr )
  77       ierr = -1
  78       call mpi_win_free_keyval( keyval, ierr )
  79       if (ierr .ne. MPI_SUCCESS) then
  80          errs = errs + 1
  81          call mtestprinterror( ierr )
  82       endif
  83
  84       call mtest_finalize( errs )
  85       call mpi_finalize( ierr )
  86       end