teshsuite/smpi/mpich3-test/f90/pt2pt/greqf90.f90

   1 ! This file created from test/mpi/f77/pt2pt/greqf.f with f77tof90
   2 ! -*- Mode: Fortran; -*-
   3 !
   4 !  (C) 2003 by Argonne National Laboratory.
   5 !      See COPYRIGHT in top-level directory.
   6 !
   7       subroutine query_fn( extrastate, status, ierr )
   8       use mpi
   9       integer status(MPI_STATUS_SIZE), ierr
  10       integer (kind=MPI_ADDRESS_KIND) extrastate
  11
  12 !
  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 )
  18       ierr = MPI_SUCCESS
  19       extrastate = extrastate
  20       end
  21 !
  22       subroutine free_fn( extrastate, ierr )
  23       use mpi
  24       integer ierr
  25       integer (kind=MPI_ADDRESS_KIND) extrastate
  26
  27       integer freefncall
  28       common /fnccalls/ freefncall
  29 !
  30 !   For testing purposes, the following print can be used to check whether
  31 !   the free_fn is called
  32 !      print *, 'Free_fn called'
  33 !
  34       extrastate = extrastate - 1
  35 !   The value returned by the free function is the error code
  36 !   returned by the wait/test function
  37       ierr = MPI_SUCCESS
  38       end
  39 !
  40       subroutine cancel_fn( extrastate, complete, ierr )
  41       use mpi
  42       integer ierr
  43       logical complete
  44       integer (kind=MPI_ADDRESS_KIND) extrastate
  45
  46
  47       ierr = MPI_SUCCESS
  48       complete=.true.
  49       extrastate=extrastate
  50       end
  51 !
  52 !
  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.
  58 !
  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.
  62 !
  63        program main
  64        use mpi
  65        integer errs, ierr
  66        logical flag
  67        integer status(MPI_STATUS_SIZE)
  68        integer request
  69        external query_fn, free_fn, cancel_fn
  70        integer (kind=MPI_ADDRESS_KIND) extrastate
  71
  72        integer freefncall
  73        common /fnccalls/ freefncall
  74
  75        errs = 0
  76        freefncall = 0
  77
  78        call MTest_Init( ierr )
  79
  80        extrastate = 0
  81        call mpi_grequest_start( query_fn, free_fn, cancel_fn,  &
  82       &            extrastate, request, ierr )
  83        call mpi_test( request, flag, status, ierr )
  84        if (flag) then
  85           errs = errs + 1
  86           print *, 'Generalized request marked as complete'
  87        endif
  88
  89        call mpi_grequest_complete( request, ierr )
  90
  91        call MPI_Wait( request, status, ierr )
  92
  93        extrastate = 1
  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 )
  98 !
  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
 103           errs = errs + 1
 104           if (freefncall .eq. 0) then
 105               print *, 'Free routine not called'
 106           else
 107               print *, 'Free routine did not update extra_data'
 108               print *, 'extrastate = ', extrastate
 109           endif
 110        endif
 111 !
 112        call MTest_Finalize( errs )
 113        call mpi_finalize( ierr )
 114        end
 115 !