teshsuite/smpi/mpich3-test/f77/attr/attrmpi1f.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 value, wsize, wrank, extra, mykey
  10       integer rvalue, svalue, ncomm
  11       logical flag
  12       integer ierr, errs
  13 C
  14       errs = 0
  15       call mtest_init( ierr )
  16       call mpi_comm_size( MPI_COMM_WORLD, wsize, ierr )
  17       call mpi_comm_rank( MPI_COMM_WORLD, wrank, ierr )
  18 C
  19 C     Simple attribute put and get
  20 C
  21       call mpi_keyval_create( MPI_NULL_COPY_FN, MPI_NULL_DELETE_FN,
  22      $     mykey, extra,ierr )
  23       call mpi_attr_get( MPI_COMM_WORLD, mykey, value, flag, ierr )
  24       if (flag) then
  25          errs = errs + 1
  26          print *,
  27      $       "Did not get flag==.false. for attribute that was not set"
  28       endif
  29 C
  30       value = 1234567
  31       svalue = value
  32       call mpi_attr_put( MPI_COMM_WORLD, mykey, value, ierr )
  33       value = -9876543
  34       call mpi_attr_get( MPI_COMM_WORLD, mykey, rvalue, flag, ierr )
  35       if (.not. flag) then
  36          errs = errs + 1
  37          print *, "Did not find attribute after set"
  38       else
  39          if (rvalue .ne. svalue) then
  40             errs = errs + 1
  41             print *, "Attribute value ", rvalue, " should be ", svalue
  42          endif
  43       endif
  44       value = -123456
  45       svalue = value
  46       call mpi_attr_put( MPI_COMM_WORLD, mykey, value, ierr )
  47       value = 987654
  48       call mpi_attr_get( MPI_COMM_WORLD, mykey, rvalue, flag, ierr )
  49       if (.not. flag) then
  50          errs = errs + 1
  51          print *, "Did not find attribute after set (neg)"
  52       else
  53          if (rvalue .ne. svalue) then
  54             errs = errs + 1
  55             print *, "Neg Attribute value ", rvalue," should be ",svalue
  56          endif
  57       endif
  58 C
  59       call mpi_keyval_free( mykey, ierr )
  60       call mtest_finalize( errs )
  61       call mpi_finalize( ierr )
  62       end