teshsuite/smpi/mpich3-test/f77/attr/commattr3f.f

   1 C -*- Mode: Fortran; -*-
   2 C
   3 C  (C) 2004 by Argonne National Laboratory.
   4 C      See COPYRIGHT in top-level directory.
   5 C
   6 C  This tests the null copy function (returns flag false; thus the
   7 C  attribute should not be propagated to a dup'ed communicator
   8 C  This is must like the test in commattr2f
   9 C
  10       program main
  11       implicit none
  12       include 'mpif.h'
  13       integer errs, ierr
  14       include 'attraints.h'
  15       integer comm1, comm2
  16       integer keyval
  17       logical flag
  18 C
  19 C The only difference between the MPI-2 and MPI-1 attribute caching
  20 C routines in Fortran is that the take an address-sized integer
  21 C instead of a simple integer.  These still are not pointers,
  22 C so the values are still just integers.
  23 C
  24       errs      = 0
  25       call mtest_init( ierr )
  26       call mpi_comm_dup( MPI_COMM_WORLD, comm1, ierr )
  27 C
  28       extrastate = 1001
  29       call mpi_comm_create_keyval( MPI_COMM_NULL_COPY_FN,
  30      &                             MPI_COMM_NULL_DELETE_FN, 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 C Test the null copy function
  40       valin = 5001
  41       call mpi_comm_set_attr( comm1, keyval, valin, ierr )
  42       call mpi_comm_dup( comm1, comm2, ierr )
  43 C Because we set NULL_COPY_FN, the attribute should not
  44 C appear on the dup'ed communicator
  45       flag = .false.
  46       call mpi_comm_get_attr( comm1, keyval, valout, flag, ierr )
  47       if (valout .ne. 5001) then
  48          errs = errs + 1
  49          print *, 'Unexpected output value in comm ', valout
  50       endif
  51       flag = .true.
  52       call mpi_comm_get_attr( comm2, keyval, valout, flag, ierr )
  53       if (flag) then
  54          errs = errs + 1
  55          print *, ' Attribute incorrectly present on dup communicator'
  56       endif
  57 C Test the delete function
  58       call mpi_comm_free( comm2, ierr )
  59 C
  60 C Test the attr delete function
  61       call mpi_comm_dup( comm1, comm2, ierr )
  62       valin      = 6001
  63       extrastate = 1001
  64       call mpi_comm_set_attr( comm2, keyval, valin, ierr )
  65       call mpi_comm_delete_attr( comm2, keyval, ierr )
  66       flag = .true.
  67       call mpi_comm_get_attr( comm2, keyval, valout, flag, ierr )
  68       if (flag) then
  69          errs = errs + 1
  70          print *, ' Delete_attr did not delete attribute'
  71       endif
  72       call mpi_comm_free( comm2, ierr )
  73 C
  74       ierr = -1
  75       call mpi_comm_free_keyval( keyval, ierr )
  76       if (ierr .ne. MPI_SUCCESS) then
  77          errs = errs + 1
  78          call mtestprinterror( ierr )
  79       endif
  80       call mpi_comm_free( comm1, ierr )
  81
  82       call mtest_finalize( errs )
  83       call mpi_finalize( ierr )
  84       end