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, valin, valout, val
  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       end
  20 !
  21       subroutine free_fn( extrastate, ierr )
  22       use mpi
  23       integer value, ierr
  24       integer (kind=MPI_ADDRESS_KIND) extrastate, valin, valout, val
  25
  26       integer freefncall
  27       common /fnccalls/ freefncall
  28 !
  29 !   For testing purposes, the following print can be used to check whether
  30 !   the free_fn is called
  31 !      print *, 'Free_fn called'
  32 !
  33       extrastate = extrastate - 1
  34 !   The value returned by the free function is the error code
  35 !   returned by the wait/test function
  36       ierr = MPI_SUCCESS
  37       end
  38 !
  39       subroutine cancel_fn( extrastate, complete, ierr )
  40       use mpi
  41       integer ierr
  42       logical complete
  43       integer (kind=MPI_ADDRESS_KIND) extrastate, valin, valout, val
  44
  45
  46       ierr = MPI_SUCCESS
  47       end
  48 !
  49 !
  50 ! This is a very simple test of generalized requests.  Normally, the
  51 ! MPI_Grequest_complete function would be called from another routine,
  52 ! often running in a separate thread.  This simple code allows us to
  53 ! check that requests can be created, tested, and waited on in the
  54 ! case where the request is complete before the wait is called.
  55 !
  56 ! Note that MPI did *not* define a routine that can be called within
  57 ! test or wait to advance the state of a generalized request.
  58 ! Most uses of generalized requests will need to use a separate thread.
  59 !
  60        program main
  61        use mpi
  62        integer errs, ierr
  63        logical flag
  64        integer status(MPI_STATUS_SIZE)
  65        integer request
  66        external query_fn, free_fn, cancel_fn
  67        integer (kind=MPI_ADDRESS_KIND) extrastate, valin, valout, val
  68
  69        integer freefncall
  70        common /fnccalls/ freefncall
  71
  72        errs = 0
  73        freefncall = 0
  74
  75        call MTest_Init( ierr )
  76
  77        extrastate = 0
  78        call mpi_grequest_start( query_fn, free_fn, cancel_fn,  &
  79       &            extrastate, request, ierr )
  80        call mpi_test( request, flag, status, ierr )
  81        if (flag) then
  82           errs = errs + 1
  83           print *, 'Generalized request marked as complete'
  84        endif
  85
  86        call mpi_grequest_complete( request, ierr )
  87
  88        call MPI_Wait( request, status, ierr )
  89
  90        extrastate = 1
  91        call mpi_grequest_start( query_fn, free_fn, cancel_fn,  &
  92       &                          extrastate, request, ierr )
  93        call mpi_grequest_complete( request, ierr )
  94        call mpi_wait( request, MPI_STATUS_IGNORE, ierr )
  95 !
  96 !      The following routine may prevent an optimizing compiler from
  97 !      just remembering that extrastate was set in grequest_start
  98        call dummyupdate(extrastate)
  99        if (extrastate .ne. 0) then
 100           errs = errs + 1
 101           if (freefncall .eq. 0) then
 102               print *, 'Free routine not called'
 103           else
 104               print *, 'Free routine did not update extra_data'
 105               print *, 'extrastate = ', extrastate
 106           endif
 107        endif
 108 !
 109        call MTest_Finalize( errs )
 110        call mpi_finalize( ierr )
 111        end
 112 !