1 ! This file created from test/mpi/f77/pt2pt/greqf.f with f77tof90
2 ! -*- Mode: Fortran; -*-
4 ! (C) 2003 by Argonne National Laboratory.
5 ! See COPYRIGHT in top-level directory.
7 subroutine query_fn( extrastate, status, ierr )
9 integer status(MPI_STATUS_SIZE), ierr
10 integer (kind=MPI_ADDRESS_KIND) extrastate
13 ! set a default status
14 status(MPI_SOURCE) = MPI_UNDEFINED
15 status(MPI_TAG) = MPI_UNDEFINED
16 call mpi_status_set_cancelled( status, .false., ierr)
17 call mpi_status_set_elements( status, MPI_BYTE, 0, ierr )
19 extrastate = extrastate
22 subroutine free_fn( extrastate, ierr )
25 integer (kind=MPI_ADDRESS_KIND) extrastate
28 common /fnccalls/ freefncall
30 ! For testing purposes, the following print can be used to check whether
31 ! the free_fn is called
32 ! print *, 'Free_fn called'
34 extrastate = extrastate - 1
35 ! The value returned by the free function is the error code
36 ! returned by the wait/test function
40 subroutine cancel_fn( extrastate, complete, ierr )
44 integer (kind=MPI_ADDRESS_KIND) extrastate
53 ! This is a very simple test of generalized requests. Normally, the
54 ! MPI_Grequest_complete function would be called from another routine,
55 ! often running in a separate thread. This simple code allows us to
56 ! check that requests can be created, tested, and waited on in the
57 ! case where the request is complete before the wait is called.
59 ! Note that MPI did *not* define a routine that can be called within
60 ! test or wait to advance the state of a generalized request.
61 ! Most uses of generalized requests will need to use a separate thread.
67 integer status(MPI_STATUS_SIZE)
69 external query_fn, free_fn, cancel_fn
70 integer (kind=MPI_ADDRESS_KIND) extrastate
73 common /fnccalls/ freefncall
78 call MTest_Init( ierr )
81 call mpi_grequest_start( query_fn, free_fn, cancel_fn, &
82 & extrastate, request, ierr )
83 call mpi_test( request, flag, status, ierr )
86 print *, 'Generalized request marked as complete'
89 call mpi_grequest_complete( request, ierr )
91 call MPI_Wait( request, status, ierr )
94 call mpi_grequest_start( query_fn, free_fn, cancel_fn, &
95 & extrastate, request, ierr )
96 call mpi_grequest_complete( request, ierr )
97 call mpi_wait( request, MPI_STATUS_IGNORE, ierr )
99 ! The following routine may prevent an optimizing compiler from
100 ! just remembering that extrastate was set in grequest_start
101 call dummyupdate(extrastate)
102 if (extrastate .ne. 0) then
104 if (freefncall .eq. 0) then
105 print *, 'Free routine not called'
107 print *, 'Free routine did not update extra_data'
108 print *, 'extrastate = ', extrastate
112 call MTest_Finalize( errs )
113 call mpi_finalize( ierr )