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