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

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