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 )
110 call mpi_type_delete_attr( type1, keyval, ierr )
111 if (ierr .ne. MPI_SUCCESS) then
113 call mtestprinterror( ierr )
117 call mpi_type_free_keyval( keyval, ierr )
118 if (ierr .ne. MPI_SUCCESS) then
120 call mtestprinterror( ierr )
123 call mtest_finalize( errs )
124 call mpi_finalize( ierr )
127 subroutine mycopyfn( oldtype, keyval, extrastate, valin, valout,
131 integer oldtype, keyval, ierr
132 include 'attraints.h'
134 integer callcount, delcount
135 common /myattr/ callcount, delcount
136 C increment the attribute by 2
138 callcount = callcount + 1
139 if (extrastate .eq. 1001) then
143 print *, ' Unexpected value of extrastate = ', extrastate
149 subroutine mydelfn( type, keyval, val, extrastate, ierr )
152 integer type, keyval, ierr
153 include 'attraints.h'
154 integer callcount, delcount
155 common /myattr/ callcount, delcount
156 delcount = delcount + 1
157 if (extrastate .eq. 1001) then
160 print *, ' Unexpected value of extrastate = ', extrastate