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