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