teshsuite/smpi/mpich3-test/f77/attr/commattrf.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 errs, ierr
  10       include 'attraints.h'
  11       integer comm1, comm2
  12       integer curcount, keyval
  13       logical flag
  14       external mycopyfn, mydelfn
  15       integer callcount, delcount
  16       common /myattr/ callcount, delcount
  17 C
  18 C The only difference between the MPI-2 and MPI-1 attribute caching
  19 C routines in Fortran is that the take an address-sized integer
  20 C instead of a simple integer.  These still are not pointers,
  21 C so the values are still just integers.
  22 C
  23       errs      = 0
  24       callcount = 0
  25       delcount  = 0
  26       call mtest_init( ierr )
  27       call mpi_comm_dup( MPI_COMM_WORLD, comm1, ierr )
  28 C
  29       extrastate = 1001
  30       call mpi_comm_create_keyval( mycopyfn, mydelfn, keyval,
  31      &                             extrastate, ierr )
  32       flag = .true.
  33       call mpi_comm_get_attr( comm1, keyval, valout, flag, ierr )
  34       if (flag) then
  35          errs = errs + 1
  36          print *, ' get attr returned true when no attr set'
  37       endif
  38
  39       valin = 2003
  40       call mpi_comm_set_attr( comm1, keyval, valin, ierr )
  41       flag = .false.
  42       valout = -1
  43       call mpi_comm_get_attr( comm1, keyval, valout, flag, ierr )
  44       if (valout .ne. 2003) then
  45          errs = errs + 1
  46          print *, 'Unexpected value (should be 2003)', valout,
  47      &            ' from attr'
  48       endif
  49
  50       valin = 2001
  51       call mpi_comm_set_attr( comm1, keyval, valin, ierr )
  52       flag = .false.
  53       valout = -1
  54       call mpi_comm_get_attr( comm1, keyval, valout, flag, ierr )
  55       if (valout .ne. 2001) then
  56          errs = errs + 1
  57          print *, 'Unexpected value (should be 2001)', valout,
  58      &            ' from attr'
  59       endif
  60
  61 C
  62 C Test the copy function
  63       valin = 5001
  64       call mpi_comm_set_attr( comm1, keyval, valin, ierr )
  65       call mpi_comm_dup( comm1, comm2, ierr )
  66       flag = .false.
  67       call mpi_comm_get_attr( comm1, keyval, valout, flag, ierr )
  68       if (valout .ne. 5001) then
  69          errs = errs + 1
  70          print *, 'Unexpected output value in comm ', valout
  71       endif
  72       flag = .false.
  73       call mpi_comm_get_attr( comm2, keyval, valout, flag, ierr )
  74       if (valout .ne. 5003) then
  75          errs = errs + 1
  76          print *, 'Unexpected output value in comm2 ', valout
  77       endif
  78 C Test the delete function
  79       curcount = delcount
  80       call mpi_comm_free( comm2, ierr )
  81       if (delcount .ne. curcount + 1) then
  82          errs = errs + 1
  83          print *, ' did not get expected value of delcount ',
  84      &          delcount, curcount + 1
  85       endif
  86 C
  87 C Test the attr delete function
  88       call mpi_comm_dup( comm1, comm2, ierr )
  89       valin      = 6001
  90       extrastate = 1001
  91       call mpi_comm_set_attr( comm2, keyval, valin, ierr )
  92       delcount   = 0
  93       call mpi_comm_delete_attr( comm2, keyval, ierr )
  94       if (delcount .ne. 1) then
  95          errs = errs + 1
  96          print *, ' Delete_attr did not call delete function'
  97       endif
  98       flag = .true.
  99       call mpi_comm_get_attr( comm2, keyval, valout, flag, ierr )
 100       if (flag) then
 101          errs = errs + 1
 102          print *, ' Delete_attr did not delete attribute'
 103       endif
 104       call mpi_comm_free( comm2, ierr )
 105 C
 106       ierr = -1
 107       call mpi_comm_free_keyval( keyval, ierr )
 108       if (ierr .ne. MPI_SUCCESS) then
 109          errs = errs + 1
 110          call mtestprinterror( ierr )
 111       endif
 112       call mpi_comm_free( comm1, ierr )
 113
 114       call mtest_finalize( errs )
 115       call mpi_finalize( ierr )
 116       end
 117 C
 118       subroutine mycopyfn( oldcomm, keyval, extrastate, valin, valout,
 119      &                     flag, ierr )
 120       implicit none
 121       include 'mpif.h'
 122       integer oldcomm, keyval, ierr
 123       include 'attraints.h'
 124       logical flag
 125       integer callcount, delcount
 126       common /myattr/ callcount, delcount
 127 C increment the attribute by 2
 128       valout = valin + 2
 129       callcount = callcount + 1
 130       if (extrastate .eq. 1001) then
 131          flag = .true.
 132          ierr = MPI_SUCCESS
 133       else
 134          print *, ' Unexpected value of extrastate = ', extrastate
 135          flag = .false.
 136          ierr = MPI_ERR_OTHER
 137       endif
 138       end
 139 C
 140       subroutine mydelfn( comm, keyval, val, extrastate, ierr )
 141       implicit none
 142       include 'mpif.h'
 143       integer comm, keyval, ierr
 144       include 'attraints.h'
 145       integer callcount, delcount
 146       common /myattr/ callcount, delcount
 147       delcount = delcount + 1
 148       if (extrastate .eq. 1001) then
 149          ierr = MPI_SUCCESS
 150       else
 151          print *, ' Unexpected value of extrastate = ', extrastate
 152          ierr = MPI_ERR_OTHER
 153       endif
 154       end