1 C -*- Mode: Fortran; -*-
3 C (C) 2003 by Argonne National Laboratory.
4 C See COPYRIGHT in top-level directory.
13 integer curcount, keyval
15 external mycopyfn, mydelfn
16 integer callcount, delcount
17 common /myattr/ callcount, delcount
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.
27 call mtest_init( ierr )
29 C Attach an attribute to a predefined object
32 call mpi_type_create_keyval( mycopyfn, mydelfn, keyval,
35 call mpi_type_get_attr( type1, keyval, valout, flag, ierr )
38 print *, ' get attr returned true when no attr set'
42 call mpi_type_set_attr( type1, keyval, valin, ierr )
45 call mpi_type_get_attr( type1, keyval, valout, flag, ierr )
46 if (valout .ne. 2003) then
48 print *, 'Unexpected value (should be 2003)', valout,
53 call mpi_type_set_attr( type1, keyval, valin, ierr )
56 call mpi_type_get_attr( type1, keyval, valout, flag, ierr )
57 if (valout .ne. 2001) then
59 print *, 'Unexpected value (should be 2001)', valout,
64 C Test the copy function
66 call mpi_type_set_attr( type1, keyval, valin, ierr )
67 call mpi_type_dup( type1, type2, ierr )
69 call mpi_type_get_attr( type1, keyval, valout, flag, ierr )
70 if (valout .ne. 5001) then
72 print *, 'Unexpected output value in type ', valout
75 call mpi_type_get_attr( type2, keyval, valout, flag, ierr )
76 if (valout .ne. 5003) then
78 print *, 'Unexpected output value in type2 ', valout
80 C Test the delete function
82 call mpi_type_free( type2, ierr )
83 if (delcount .ne. curcount + 1) then
85 print *, ' did not get expected value of delcount ',
86 & delcount, curcount + 1
89 C Test the attr delete function
90 call mpi_type_dup( type1, type2, ierr )
93 call mpi_type_set_attr( type2, keyval, valin, ierr )
95 call mpi_type_delete_attr( type2, keyval, ierr )
96 if (delcount .ne. 1) then
98 print *, ' Delete_attr did not call delete function'
101 call mpi_type_get_attr( type2, keyval, valout, flag, ierr )
104 print *, ' Delete_attr did not delete attribute'
106 call mpi_type_free( type2, ierr )
109 call mpi_type_free_keyval( keyval, ierr )
110 if (ierr .ne. MPI_SUCCESS) then
112 call mtestprinterror( ierr )
115 call mtest_finalize( errs )
116 call mpi_finalize( ierr )
119 subroutine mycopyfn( oldtype, keyval, extrastate, valin, valout,
123 integer oldtype, keyval, ierr
124 include 'attraints.h'
126 integer callcount, delcount
127 common /myattr/ callcount, delcount
128 C increment the attribute by 2
130 callcount = callcount + 1
131 if (extrastate .eq. 1001) then
135 print *, ' Unexpected value of extrastate = ', extrastate
141 subroutine mydelfn( type, keyval, val, extrastate, ierr )
144 integer type, keyval, ierr
145 include 'attraints.h'
146 integer callcount, delcount
147 common /myattr/ callcount, delcount
148 delcount = delcount + 1
149 if (extrastate .eq. 1001) then
152 print *, ' Unexpected value of extrastate = ', extrastate