mpl_probe_mod.F90

Go to the documentation of this file.

MODULE mpl_probe_mod

!**** MPL_PROBE - Check for incoming message

!     Purpose.
!     --------
!     Look for existence of an incoming message.

!**   Interface.
!     ----------
!        CALL MPL_PROBE

!        Input required arguments :
!        -------------------------
!           none

!        Input optional arguments :
!        -------------------------
!           KSOURCE  -  rank of process sending the message
!                       default is MPI_ANY_SOURCE
!           KTAG     -  tag of incoming message
!                       default is MPI_ANY_TAG
!           KCOMM    -  Communicator number if different from MPI_COMM_WORLD 
!           LDWAIT   -  = TRUE : waits for a message to be available
!                       = FALSE: return immediately and set
!                                LDFLAG to indicate if a message exists
!           CDSTRING -  Character string for ABORT messages
!                       used when KERROR is not provided

!        Output required arguments :
!        -------------------------
!           none

!        Output optional arguments :
!        -------------------------
!           KERROR   -  return error code.     If not supplied, 
!                       MPL_PROBE aborts when an error is detected.
!           LDFLAG   -  must be supplied if LDWAIT=false
!                       = TRUE if a message exists
!     Author.
!     -------
!        D.Dent, M.Hamrud     ECMWF

!     Modifications.
!     --------------
!        Original: 2000-09-01
!        P. Marguinaud : 01-Jan-2011 : Extends original interface with 
!                                      KCOUNT,KRECVTAG,KFROM (same meaning as
!                                      in all MPL_* routines)

!     ------------------------------------------------------------------

USE parkind1  ,ONLY : jpim     ,jprb

USE mpl_mpif
USE mpl_data_module
USE mpl_message_mod

IMPLICIT NONE

PUBLIC mpl_probe

PRIVATE

!--- Moved into subroutine to make thrreadsafe----
! INTEGER(KIND=JPIM) :: IRECV_STATUS(MPI_STATUS_SIZE)
! INTEGER(KIND=JPIM) :: ICOMM,ITAG,ISOURCE,IERROR
! LOGICAL :: LLWAIT,LLABORT=.TRUE.

CONTAINS

SUBROUTINE mpl_probe(KSOURCE,KTAG,KCOMM,LDWAIT,LDFLAG,CDSTRING,KERROR,KCOUNT,KRECVTAG,KFROM)


#ifdef USE_8_BYTE_WORDS
  USE mpi4to8, ONLY : &
    mpi_probe => mpi_probe8, mpi_iprobe => mpi_iprobe8
#endif


INTEGER(KIND=JPIM),INTENT(IN), OPTIONAL  :: KSOURCE,KTAG,KCOMM
INTEGER(KIND=JPIM),INTENT(OUT),OPTIONAL  :: KERROR
LOGICAL,INTENT(IN), OPTIONAL  :: LDWAIT
LOGICAL,INTENT(OUT),OPTIONAL  :: LDFLAG
CHARACTER*(*),INTENT(IN),OPTIONAL :: CDSTRING
INTEGER(KIND=JPIM),INTENT(OUT),OPTIONAL  :: KCOUNT, KRECVTAG, KFROM

INTEGER(KIND=JPIM) :: IRECV_STATUS(mpi_status_size)
INTEGER(KIND=JPIM) :: ICOMM,ITAG,ISOURCE,IERROR
LOGICAL :: LLWAIT,LLABORT=.true.
INTEGER(KIND=JPIM) :: ITID
itid = oml_my_thread()
IF(mpl_numproc < 1) CALL mpl_message( &
  & cdmessage='MPL_PROBE: MPL NOT INITIALISED ',ldabort=llabort) 

IF(PRESENT(kcomm)) THEN
  icomm=kcomm
ELSE
  icomm=mpl_comm_oml(itid)
ENDIF
IF(PRESENT(ksource)) THEN
  isource=ksource-1
ELSE
  isource=mpi_any_source
ENDIF
IF(PRESENT(ktag)) THEN
  itag=ktag
ELSE
  itag=mpi_any_tag
ENDIF

IF(PRESENT(ldwait)) THEN
  llwait=ldwait
ELSE
  llwait=.true.
ENDIF

IF(llwait) THEN
  CALL mpi_probe(isource,itag,icomm,irecv_status,ierror)
  IF (ierror == 0) THEN
    IF (PRESENT (kcount))   CALL mpi_get_count (irecv_status, mpi_character, kcount, ierror) 
    IF (PRESENT (krecvtag)) krecvtag = irecv_status(mpi_tag)
    IF (PRESENT (kfrom))    kfrom    = irecv_status(mpi_source)+1
  ENDIF
ELSE
  IF(PRESENT(ldflag)) THEN
    CALL mpi_iprobe(isource,itag,icomm,ldflag,irecv_status,ierror)
    IF (ierror == 0 .AND. ldflag) THEN
      IF (PRESENT (kcount))   CALL mpi_get_count (irecv_status, mpi_character, kcount, ierror)
      IF (PRESENT (krecvtag)) krecvtag = irecv_status(mpi_tag)
      IF (PRESENT (kfrom))    kfrom    = irecv_status(mpi_source)+1
    ENDIF
  ELSE
    CALL mpl_message(ierror,'MPL_PROBE: MUST PROVIDE LDFLAG ',cdstring, &
                    & ldabort=llabort)
  ENDIF
ENDIF
IF(PRESENT(kerror)) THEN
  kerror=ierror
ELSE
  IF(ierror /= 0 ) CALL mpl_message(ierror,'MPL_PROBE',cdstring,ldabort=llabort)
ENDIF
  
RETURN
END SUBROUTINE mpl_probe

END MODULE mpl_probe_mod