teshsuite/smpi/mpich3-test/f77/pt2pt/greqf.f

   1 C -*- Mode: Fortran; -*-
   2 C
   3 C  (C) 2003 by Argonne National Laboratory.
   4 C      See COPYRIGHT in top-level directory.
   5 C
   6       subroutine query_fn( extrastate, status, ierr )
   7       implicit none
   8       include 'mpif.h'
   9       integer status(MPI_STATUS_SIZE), ierr
  10       include 'attr1aints.h'
  11 C
  12 C    set a default status
  13       status(MPI_SOURCE) = MPI_UNDEFINED
  14       status(MPI_TAG)    = MPI_UNDEFINED
  15       call mpi_status_set_cancelled( status, .false., ierr)
  16       call mpi_status_set_elements( status, MPI_BYTE, 0, ierr )
  17       ierr = MPI_SUCCESS
  18       end
  19 C
  20       subroutine free_fn( extrastate, ierr )
  21       implicit none
  22       include 'mpif.h'
  23       integer value, ierr
  24       include 'attr1aints.h'
  25       integer freefncall
  26       common /fnccalls/ freefncall
  27 C
  28 C   For testing purposes, the following print can be used to check whether
  29 C   the free_fn is called
  30 C      print *, 'Free_fn called'
  31 C
  32       extrastate = extrastate - 1
  33 C   The value returned by the free function is the error code
  34 C   returned by the wait/test function
  35       ierr = MPI_SUCCESS
  36       end
  37 C
  38       subroutine cancel_fn( extrastate, complete, ierr )
  39       implicit none
  40       include 'mpif.h'
  41       integer ierr
  42       logical complete
  43       include 'attr1aints.h'
  44
  45       ierr = MPI_SUCCESS
  46       end
  47 C
  48 C
  49 C This is a very simple test of generalized requests.  Normally, the
  50 C MPI_Grequest_complete function would be called from another routine,
  51 C often running in a separate thread.  This simple code allows us to
  52 C check that requests can be created, tested, and waited on in the
  53 C case where the request is complete before the wait is called.
  54 C
  55 C Note that MPI did *not* define a routine that can be called within
  56 C test or wait to advance the state of a generalized request.
  57 C Most uses of generalized requests will need to use a separate thread.
  58 C
  59        program main
  60        implicit none
  61        include 'mpif.h'
  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        include 'attr1aints.h'
  68        integer freefncall
  69        common /fnccalls/ freefncall
  70
  71        errs = 0
  72        freefncall = 0
  73
  74        call MTest_Init( ierr )
  75
  76        extrastate = 0
  77        call mpi_grequest_start( query_fn, free_fn, cancel_fn,
  78      &            extrastate, request, ierr )
  79        call mpi_test( request, flag, status, ierr )
  80        if (flag) then
  81           errs = errs + 1
  82           print *, 'Generalized request marked as complete'
  83        endif
  84
  85        call mpi_grequest_complete( request, ierr )
  86
  87        call MPI_Wait( request, status, ierr )
  88
  89        extrastate = 1
  90        call mpi_grequest_start( query_fn, free_fn, cancel_fn,
  91      &                          extrastate, request, ierr )
  92        call mpi_grequest_complete( request, ierr )
  93        call mpi_wait( request, MPI_STATUS_IGNORE, ierr )
  94 C
  95 C      The following routine may prevent an optimizing compiler from
  96 C      just remembering that extrastate was set in grequest_start
  97        call dummyupdate(extrastate)
  98        if (extrastate .ne. 0) then
  99           errs = errs + 1
 100           if (freefncall .eq. 0) then
 101               print *, 'Free routine not called'
 102           else
 103               print *, 'Free routine did not update extra_data'
 104               print *, 'extrastate = ', extrastate
 105           endif
 106        endif
 107 C
 108        call MTest_Finalize( errs )
 109        call mpi_finalize( ierr )
 110        end
 111 C