teshsuite/smpi/mpich-test/context/attrtest.f

   1       PROGRAM MAIN
   2
   3       include 'mpif.h'
   4
   5 C. Data layout
   6 C. Number of tests
   7       integer PM_GLOBAL_ERROR, PM_NUM_NODES
   8       integer PM_MAX_TESTS
   9       parameter (PM_MAX_TESTS=3)
  10 C. Test data
  11       integer PM_TEST_INTEGER, fuzzy, Error, FazAttr
  12       integer PM_RANK_SELF
  13       integer Faz_World, FazTag
  14       integer errs
  15       parameter (PM_TEST_INTEGER=12345)
  16       logical FazFlag
  17       external FazCreate, FazDelete
  18 C
  19 C. Initialize MPI
  20       errs = 0
  21       call MPI_INIT(PM_GLOBAL_ERROR)
  22
  23       PM_GLOBAL_ERROR = MPI_SUCCESS
  24 C. Find out the number of processes
  25       call MPI_COMM_SIZE (MPI_COMM_WORLD,PM_NUM_NODES,PM_GLOBAL_ERROR)
  26       call MPI_COMM_RANK (MPI_COMM_WORLD,PM_RANK_SELF,PM_GLOBAL_ERROR)
  27
  28
  29       call MPI_keyval_create ( FazCreate, FazDelete, FazTag,
  30      &                         fuzzy, Error )
  31
  32 C. Make sure that we can get an attribute that hasn't been set yet (flag
  33 C. is false)
  34       call MPI_attr_get (MPI_COMM_WORLD, FazTag, FazAttr,
  35      &                   FazFlag, Error)
  36
  37       if (FazFlag) then
  38          errs = errs + 1
  39          print *, 'Did not get flag==false when attr_get of key that'
  40          print *, 'had not had a value set with attr_put'
  41       endif
  42
  43       FazAttr = 120
  44       call MPI_attr_put (MPI_COMM_WORLD, FazTag, FazAttr, Error)
  45
  46 C. Check that the put worked
  47       call MPI_attr_get (MPI_COMM_WORLD, FazTag, FazAttr,
  48      &                   FazFlag, Error)
  49
  50       if (FazAttr .ne. 120) then
  51          errs = errs + 1
  52          print 1, ' Proc=',PM_Rank_self, ' ATTR=', FazAttr
  53       endif
  54 C. Duplicate the Communicator and it's cached attributes
  55
  56       call MPI_Comm_Dup (MPI_COMM_WORLD, Faz_WORLD, Error)
  57
  58
  59       call MPI_Attr_Get ( Faz_WORLD, FazTag, FazAttr,
  60      &                    FazFlag, Error)
  61
  62       if (FazFlag) then
  63         if (FazAttr .ne. 121) then
  64            errs = errs + 1
  65            print 1, ' T-Flag, Proc=',PM_Rank_self,' ATTR=', FazAttr
  66         endif
  67       else
  68          errs = errs + 1
  69          print 1, ' F-Flag, Proc=',PM_Rank_self,' ATTR=',FazAttr
  70       end if
  71  1    format( a, i5, a, i5 )
  72
  73 C. Clean up MPI
  74       if (PM_Rank_self .eq. 0) then
  75          if (errs .eq. 0) then
  76             print *, ' No Errors'
  77          else
  78             print *, ' Found ', errs, ' errors'
  79          endif
  80       endif
  81       call MPI_Comm_free( Faz_WORLD, Error )
  82       call MPI_FINALIZE (PM_GLOBAL_ERROR)
  83
  84       end
  85 C
  86 C MPI 1.1 changed these from functions to subroutines.
  87 C
  88       SUBROUTINE FazCreate (comm, keyval, fuzzy,
  89      &                    attr_in, attr_out, flag, ierr )
  90       INTEGER comm, keyval, fuzzy, attr_in, attr_out
  91       LOGICAL flag
  92       include 'mpif.h'
  93       attr_out = attr_in + 1
  94       flag = .true.
  95       ierr = MPI_SUCCESS
  96       END
  97
  98       SUBROUTINE FazDelete (comm, keyval, attr, extra, ierr )
  99       INTEGER comm, keyval, attr, extra, ierr
 100       include 'mpif.h'
 101       ierr = MPI_SUCCESS
 102       if (keyval .ne. MPI_KEYVAL_INVALID)then
 103          attr = attr -  1
 104       end if
 105       END