1! This file created from test/mpi/f77/attr/typeattr3f.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 much like the test in typeattr2f
10!
11      program main
12      use mpi
13      integer errs, ierr
14      integer (kind=MPI_ADDRESS_KIND) extrastate, valin, valout, val
15
16      integer type1, type2
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      type1 = MPI_INTEGER
28!
29      extrastate = 1001
30      call mpi_type_create_keyval( MPI_TYPE_NULL_COPY_FN,  &
31      &                             MPI_TYPE_NULL_DELETE_FN, keyval,  &
32      &                             extrastate, ierr )
33      flag = .true.
34      call mpi_type_get_attr( type1, 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_type_set_attr( type1, keyval, valin, ierr )
43      call mpi_type_dup( type1, type2, 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_type_get_attr( type1, keyval, valout, flag, ierr )
48      if (valout .ne. 5001) then
49         errs = errs + 1
50         print *, 'Unexpected output value in type ', valout
51      endif
52      flag = .true.
53      call mpi_type_get_attr( type2, keyval, valout, flag, ierr )
54      if (flag) then
55         errs = errs + 1
56         print *, ' Attribute incorrectly present on dup datatype'
57      endif
58! Test the delete function
59      call mpi_type_free( type2, ierr )
60!
61! Test the attr delete function
62      call mpi_type_dup( type1, type2, ierr )
63      valin      = 6001
64      extrastate = 1001
65      call mpi_type_set_attr( type2, keyval, valin, ierr )
66      call mpi_type_delete_attr( type2, keyval, ierr )
67      flag = .true.
68      call mpi_type_get_attr( type2, 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_type_free( type2, ierr )
74!
75      ierr = -1
76      call mpi_type_free_keyval( keyval, ierr )
77      if (ierr .ne. MPI_SUCCESS) then
78         errs = errs + 1
79         call mtestprinterror( ierr )
80      endif
81
82      call mtest_finalize( errs )
83      call mpi_finalize( ierr )
84      end
85