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

   1 ! This file created from test/mpi/f77/rma/baseattrwinf.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 (kind=MPI_ADDRESS_KIND) extrastate, valin, valout, val
  10
  11       logical flag
  12       integer ierr, errs
  13       integer base(1024)
  14       integer disp
  15       integer win
  16       integer commsize
  17 ! Include addsize defines asize as an address-sized integer
  18       integer (kind=MPI_ADDRESS_KIND) asize
  19
  20
  21       errs = 0
  22
  23       call mtest_init( ierr )
  24       call mpi_comm_size( MPI_COMM_WORLD, commsize, ierr )
  25
  26 ! Create a window; then extract the values
  27       asize    = 1024
  28       disp = 4
  29       call MPI_Win_create( base, asize, disp, MPI_INFO_NULL,  &
  30       &  MPI_COMM_WORLD, win, ierr )
  31 !
  32 ! In order to check the base, we need an address-of function.
  33 ! We use MPI_Get_address, even though that isn't strictly correct
  34       call MPI_Win_get_attr( win, MPI_WIN_BASE, valout, flag, ierr )
  35       if (.not. flag) then
  36          errs = errs + 1
  37          print *, "Could not get WIN_BASE"
  38 !
  39 ! There is no easy way to get the actual value of base to compare
  40 ! against.  MPI_Address gives a value relative to MPI_BOTTOM, which
  41 ! is different from 0 in Fortran (unless you can define MPI_BOTTOM
  42 ! as something like %pointer(0)).
  43 !      else
  44 !
  45 !C For this Fortran 77 version, we use the older MPI_Address function
  46 !         call MPI_Address( base, baseadd, ierr )
  47 !         if (valout .ne. baseadd) then
  48 !           errs = errs + 1
  49 !           print *, "Got incorrect value for WIN_BASE (", valout,
  50 !     &             ", should be ", baseadd, ")"
  51 !         endif
  52       endif
  53
  54       call MPI_Win_get_attr( win, MPI_WIN_SIZE, valout, flag, ierr )
  55       if (.not. flag) then
  56          errs = errs + 1
  57          print *, "Could not get WIN_SIZE"
  58       else
  59         if (valout .ne. asize) then
  60             errs = errs + 1
  61             print *, "Got incorrect value for WIN_SIZE (", valout,  &
  62       &        ", should be ", asize, ")"
  63          endif
  64       endif
  65
  66       call MPI_Win_get_attr( win, MPI_WIN_DISP_UNIT, valout, flag, ierr)
  67       if (.not. flag) then
  68          errs = errs + 1
  69          print *, "Could not get WIN_DISP_UNIT"
  70       else
  71          if (valout .ne. disp) then
  72             errs = errs + 1
  73             print *, "Got wrong value for WIN_DISP_UNIT (", valout,  &
  74       &               ", should be ", disp, ")"
  75          endif
  76       endif
  77
  78       call MPI_Win_free( win, ierr )
  79
  80       call mtest_finalize( errs )
  81       call MPI_Finalize( ierr )
  82
  83       end