1 ! This file created from test/mpi/f77/rma/winattrf.f with f77tof90
2 ! -*- Mode: Fortran; -*-
4 ! (C) 2003 by Argonne National Laboratory.
5 ! See COPYRIGHT in top-level directory.
10 integer (kind=MPI_ADDRESS_KIND) extrastate, valin, valout, val
12 integer comm, win, buf(10)
13 integer curcount, keyval
15 external mycopyfn, mydelfn
16 integer callcount, delcount
17 common /myattr/ callcount, delcount
19 ! The only difference between the MPI-2 and MPI-1 attribute caching
20 ! routines in Fortran is that the take an address-sized integer
21 ! instead of a simple integer. These still are not pointers,
22 ! so the values are still just integers.
27 call mtest_init( ierr )
28 call mpi_comm_dup( MPI_COMM_WORLD, comm, ierr )
29 ! Create a new window; use val for an address-sized int
31 call mpi_win_create( buf, val, 1, &
32 & MPI_INFO_NULL, comm, win, ierr )
35 call mpi_win_create_keyval( mycopyfn, mydelfn, keyval, &
38 call mpi_win_get_attr( win, keyval, valout, flag, ierr )
41 print *, ' get attr returned true when no attr set'
45 call mpi_win_set_attr( win, keyval, valin, ierr )
48 call mpi_win_get_attr( win, keyval, valout, flag, ierr )
49 if (valout .ne. 2003) then
51 print *, 'Unexpected value (should be 2003)', valout, &
56 call mpi_win_set_attr( win, keyval, valin, ierr )
59 call mpi_win_get_attr( win, keyval, valout, flag, ierr )
60 if (valout .ne. 2001) then
62 print *, 'Unexpected value (should be 2001)', valout, &
66 ! Test the attr delete function
68 call mpi_win_delete_attr( win, keyval, ierr )
69 if (delcount .ne. 1) then
71 print *, ' Delete_attr did not call delete function'
74 call mpi_win_get_attr( win, keyval, valout, flag, ierr )
77 print *, ' Delete_attr did not delete attribute'
80 ! Test the delete function on window free
82 call mpi_win_set_attr( win, keyval, valin, ierr )
84 call mpi_win_free( win, ierr )
85 if (delcount .ne. curcount + 1) then
87 print *, ' did not get expected value of delcount ', &
88 & delcount, curcount + 1
92 call mpi_win_free_keyval( keyval, ierr )
93 if (ierr .ne. MPI_SUCCESS) then
95 call mtestprinterror( ierr )
98 ! The MPI standard defines null copy and duplicate functions.
99 ! However, are only used when an object is duplicated. Since
100 ! MPI_Win objects cannot be duplicated, so under normal circumstances,
101 ! these will not be called. Since they are defined, they should behave
102 ! as defined. To test them, we simply call them here
107 call MPI_WIN_DUP_FN( win, keyval, extrastate, valin, valout, &
111 print *, " Flag was false after MPI_WIN_DUP_FN"
112 else if (valout .ne. 7001) then
114 if (valout .eq. -1 ) then
115 print *, " output attr value was not copied in MPI_WIN_DUP_FN"
117 print *, " value was ", valout, " but expected 7001"
118 else if (ierr .ne. MPI_SUCCESS) then
120 print *, " MPI_WIN_DUP_FN did not return MPI_SUCCESS"
127 call MPI_WIN_NULL_COPY_FN( win, keyval, extrastate, valin, valout &
131 print *, " Flag was true after MPI_WIN_NULL_COPY_FN"
132 else if (valout .ne. -1) then
135 & " output attr value was copied in MPI_WIN_NULL_COPY_FN"
136 else if (ierr .ne. MPI_SUCCESS) then
138 print *, " MPI_WIN_NULL_COPY_FN did not return MPI_SUCCESS"
141 call mpi_comm_free( comm, ierr )
142 call mtest_finalize( errs )
143 call mpi_finalize( ierr )
146 ! Note that the copyfn is unused for MPI windows, since there is
147 ! (and because of alias rules, can be) no MPI_Win_dup function
148 subroutine mycopyfn( oldwin, keyval, extrastate, valin, valout, &
151 integer oldwin, keyval, ierr
152 integer (kind=MPI_ADDRESS_KIND) extrastate, valin, valout, val
155 integer callcount, delcount
156 common /myattr/ callcount, delcount
157 ! increment the attribute by 2
159 callcount = callcount + 1
161 ! Since we should *never* call this, indicate an error
162 print *, ' Unexpected use of mycopyfn'
167 subroutine mydelfn( win, keyval, val, extrastate, ierr )
169 integer win, keyval, ierr
170 integer (kind=MPI_ADDRESS_KIND) extrastate, valin, valout, val
172 integer callcount, delcount
173 common /myattr/ callcount, delcount
174 delcount = delcount + 1
175 if (extrastate .eq. 1001) then
178 print *, ' Unexpected value of extrastate = ', extrastate