1C -*- Mode: Fortran; -*- 2C 3C (C) 2004 by Argonne National Laboratory. 4C See COPYRIGHT in top-level directory. 5C 6C This tests the null copy function (returns flag false; thus the 7C attribute should not be propagated to a dup'ed communicator 8C This is must like the test in commattr2f 9C 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 18C 19C The only difference between the MPI-2 and MPI-1 attribute caching 20C routines in Fortran is that the take an address-sized integer 21C instead of a simple integer. These still are not pointers, 22C so the values are still just integers. 23C 24 errs = 0 25 call mtest_init( ierr ) 26 call mpi_comm_dup( MPI_COMM_WORLD, comm1, ierr ) 27C 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 39C 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 ) 43C Because we set NULL_COPY_FN, the attribute should not 44C 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 57C Test the delete function 58 call mpi_comm_free( comm2, ierr ) 59C 60C 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 ) 73C 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 85