teshsuite/smpi/mpich3-test/f77/attr/typeattr3f.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 much like the test in typeattr2f
   9 C
  10       program main
  11       implicit none
  12       include 'mpif.h'
  13       integer errs, ierr
  14       include 'attraints.h'
  15       integer type1, type2
  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       type1 = MPI_INTEGER
  27 C
  28       extrastate = 1001
  29       call mpi_type_create_keyval( MPI_TYPE_NULL_COPY_FN,
  30      &                             MPI_TYPE_NULL_DELETE_FN, keyval,
  31      &                             extrastate, ierr )
  32       flag = .true.
  33       call mpi_type_get_attr( type1, 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_type_set_attr( type1, keyval, valin, ierr )
  42       call mpi_type_dup( type1, type2, 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_type_get_attr( type1, keyval, valout, flag, ierr )
  47       if (valout .ne. 5001) then
  48          errs = errs + 1
  49          print *, 'Unexpected output value in type ', valout
  50       endif
  51       flag = .true.
  52       call mpi_type_get_attr( type2, keyval, valout, flag, ierr )
  53       if (flag) then
  54          errs = errs + 1
  55          print *, ' Attribute incorrectly present on dup datatype'
  56       endif
  57 C Test the delete function
  58       call mpi_type_free( type2, ierr )
  59 C
  60 C Test the attr delete function
  61       call mpi_type_dup( type1, type2, ierr )
  62       valin      = 6001
  63       extrastate = 1001
  64       call mpi_type_set_attr( type2, keyval, valin, ierr )
  65       call mpi_type_delete_attr( type2, keyval, ierr )
  66       flag = .true.
  67       call mpi_type_get_attr( type2, 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_type_free( type2, ierr )
  73 C
  74       ierr = -1
  75       call mpi_type_free_keyval( keyval, ierr )
  76       if (ierr .ne. MPI_SUCCESS) then
  77          errs = errs + 1
  78          call mtestprinterror( ierr )
  79       endif
  80
  81       call mtest_finalize( errs )
  82       call mpi_finalize( ierr )
  83       end