SUBROUTINE SLCOMM(KASLB1,KSLPROCS,KSLRPT,&
 & KSLSPT,KSLSENDPOS,KSLRECVPOS,KSENDPTR,KRECVPTR,KSLCOMM,&
 & KFIXFLD,KFLDSLB,LDINC,KTYP,PB1A,LDSLCOMM)  

!****-------------------------------------------------------------------
!**** *SLCOMM* - Interpolation buffer communication
!                 Particular version used in SL scheme when "on demand"
!                 communications are activated.
!****-------------------------------------------------------------------
!     Purpose.
!     --------
!           This routine is called to perform the inter-processor 
!     communication required for schemes needing horizontal interpolations.

!**   Interface.
!     ----------
!        *CALL* *SLCOMM

!        Explicit arguments :
!        --------------------
!        INPUT:
!          KASLB1         - local inner dimension of interpolation buffer.
!          KSLPROCS       - number of processors to communicate with.
!          KSLRPT         - dimension for KSLRECVPOS.
!          KSLSPT         - dimension for KSLSENDPOS.
!          KSLSENDPOS     - the addresses within the interpolation buffer 
!                           of point sent from this PE.
!          KSLRECVPOS     - the addresses within the interpolation buffer 
!                           of point received on this PE.
!          KSENDPTR       - pointer to the first point for each of the PE's 
!                           that has to receive interpolation halo-data from 
!                           this. Used for addressing KSLSENDPOS().
!          KRECVPTR       - pointer to the first point for each of the PE's 
!                           that are sending interpolation halo-data to this PE.
!                           Used for addressing KSLRECVPOS().
!          KSLCOMM        - interpolation buffer communication: list of the
!                           processors this processor has to communicate with.
!          KFLDSLB        - number of fields in interpolation buffer.
!          KFIXFLD        - description of 'fixed' fields.
!                           These are always sent for all levels.
!                           KFIXFLD(1)=index into interpolation buffer for the
!                                      first fixed field
!                           KFIXFLD(2)=index into interpolation buffer for the
!                                      last level of the last fixed field
!          LDINC          - increment flag for interpolation buffer
!          KTYP           - type of communication.
!                           0 = cf. old CY35 version of SLCOMM
!                           1 = cf. old CY35 version of SLCOMM1
!          LDSLCOMM       - Optional: flag indicating whether this processor needs to
!                           communicate with a specific processor.
!        INPUT/OUTPUT:
!          PB1A           - interpolation buffer.

!        Implicit arguments :  None.
!        --------------------

!     Method.
!     -------
!     The method used is to send and receive data in blocks of a fixed
!     number of grid columns each of size KFLDSLB words. In this method
!     we will only send the next block to a particular processor if 
!     there is no outstanding block to receive from that processor. 
!     We adopt this approach to both minimize the message buffer 
!     requirements for interpolation buffer communication and also to perform
!     dynamic communication. Dynamic communication simply means that we
!     only continue communicating with those processors that are in 
!     SLCOMM and are sending us data. By probing for messages we avoid 
!     waiting for any processor on a receive.

!     FORMAT of message:
!     (1)   first point number (index into KSLSENDPOS table)
!     (2)   last  point number (index into KSLSENDPOS table)
!     (3)   first fixed field  (index into PB1A field dimension)
!     (4)   last  fixed field  (index into PB1A field dimension)
!     (5)   position of dynamic table (located after the field data)
!           = 0 if no dynamic table

!     Externals.
!     ----------

!     Reference.
!     ----------
!        ECMWF Research Department documentation of the IFS

!     Author.
!     -------
!        MPP Group *ECMWF*

!     Modifications.
!     --------------
!        Original : 97-06-04
!        Modified by K. YESSAD (JAN 1998): adaptation in order to make
!         this routine more general, for ex to be used for FULL-POS
!         horizontal interpolations.
!        =99-03-29= Deborah Salmond. Optimised loop to copy out of buffer
!        =99-09-29= D.Dent & Deborah Salmond. 'On demand' communications
!         00-09-01  D.Dent           MPE to MPL conversion
!         01-11-23  Deborah Salmond  LIMP_NOOLAP Option for non-overlapping 
!                                    message passing and buffer packing
!         26-05-02  Deborah Salmond  Memory save for LIMP_NOOLAP
!         02-10-01  G.Mozdzynski     support for radiation on-demand comms
!         03-01-07  Deborah Salmond  Tidy up
!        M.Hamrud      01-Oct-2003 CY28 Cleaning
!        G.Mozdzynski  10-Nov-2005 Optimised OpenMP parallelisation
!        G.Mozdzynski  01-Jan-2008 Cleanup
!        Y. Seity  : add barrier under LSYNC_SLCOM key
!        K. Yessad (Oct 2008) : unified SLCOMM (=merge SLCOMM+SLCOMM1) + clean.
!        G.Mozdzynski  02-Jan-2009 use non-blocking recv and send
!        G.Mozdzynski  27-Jul-2009 Optimise SL communications (LDSLCOMM)
!     ------------------------------------------------------------------

USE PARKIND1  ,ONLY : JPIM     ,JPRB
USE YOMHOOK   ,ONLY : LHOOK,   DR_HOOK

USE YOMLUN   , ONLY : NULOUT
USE YOMMP    , ONLY : NPRCIDS, LSYNC_SLCOM
USE YOMTAG   , ONLY : MTAGSLAG
USE YOMVAR   , ONLY : NSIM4D
USE YOMSLREP , ONLY : LSLADREP
USE MPL_MODULE, ONLY : MPL_SEND, MPL_RECV, MPL_WAIT, MPL_BARRIER, &
 & JP_NON_BLOCKING_STANDARD

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

IMPLICIT NONE

INTEGER(KIND=JPIM),INTENT(IN)    :: KASLB1 
INTEGER(KIND=JPIM),INTENT(IN)    :: KSLPROCS 
INTEGER(KIND=JPIM),INTENT(IN)    :: KSLRPT 
INTEGER(KIND=JPIM),INTENT(IN)    :: KSLSPT 
INTEGER(KIND=JPIM),INTENT(IN)    :: KFLDSLB 
INTEGER(KIND=JPIM),INTENT(IN)    :: KSLSENDPOS(KSLSPT) 
INTEGER(KIND=JPIM),INTENT(IN)    :: KSLRECVPOS(KSLRPT) 
INTEGER(KIND=JPIM),INTENT(IN)    :: KSENDPTR(KSLPROCS+1) 
INTEGER(KIND=JPIM),INTENT(IN)    :: KRECVPTR(KSLPROCS+1) 
INTEGER(KIND=JPIM),INTENT(IN)    :: KSLCOMM(KSLPROCS) 
INTEGER(KIND=JPIM),INTENT(IN)    :: KFIXFLD(2)
LOGICAL           ,INTENT(IN)    :: LDINC 
INTEGER(KIND=JPIM),INTENT(IN)    :: KTYP
REAL(KIND=JPRB)   ,INTENT(INOUT) :: PB1A(KASLB1,KFLDSLB) 
LOGICAL,OPTIONAL  ,INTENT(IN)    :: LDSLCOMM(KSLPROCS)

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

REAL(KIND=JPRB),ALLOCATABLE :: ZSENDBUF(:),ZRECVBUF(:)
REAL(KIND=JPRB) :: ZDUM(2)

INTEGER(KIND=JPIM) :: ISENDTOT (KSLPROCS)
INTEGER(KIND=JPIM) :: IRECVTOT (KSLPROCS)
INTEGER(KIND=JPIM) :: IREQ     (KSLPROCS*2)
INTEGER(KIND=JPIM) :: IJPOS    (KSLPROCS)
INTEGER(KIND=JPIM) :: ISEND    (KSLPROCS)
INTEGER(KIND=JPIM) :: ISEND_POS(KSLPROCS)
INTEGER(KIND=JPIM) :: IRECV_POS(KSLPROCS)
LOGICAL            :: LLSLCOMM(KSLPROCS)
INTEGER(KIND=JPIM) :: IFIXFLD(2)

INTEGER(KIND=JPIM) :: IBEG, IEND, ILEN, &
 & IRECVPROC, ISENDPROC, ITAG, INUMFIELDS, IJR, IJS, I_KPOS, IR 
INTEGER(KIND=JPIM) :: I_MSENDTOT, I_MRECVTOT
INTEGER(KIND=JPIM) :: J, JJ, JFLD

LOGICAL :: LLCOMMDBGL
REAL(KIND=JPRB) :: ZHOOK_HANDLE

!     ------------------------------------------------------------------
IF (LHOOK) CALL DR_HOOK('SLCOMM',0,ZHOOK_HANDLE)
!     ------------------------------------------------------------------


!     1/ Preliminary calculations.

IF (KTYP == 0) THEN
  IFIXFLD(1)=1
  IFIXFLD(2)=KFLDSLB
ELSEIF (KTYP == 1) THEN
  IFIXFLD(1)=KFIXFLD(1)
  IFIXFLD(2)=KFIXFLD(2)
ENDIF
  
!     2/ Mark all processors as having no outstanding receives,
!        nothing sent or received.

IJR=0
IJS=0
I_MSENDTOT=0
I_MRECVTOT=0
INUMFIELDS=IFIXFLD(2)-IFIXFLD(1)+1
DO J=1,KSLPROCS
  ISENDTOT(J)=KSENDPTR(J+1)-KSENDPTR(J)
  IRECVTOT(J)=KRECVPTR(J+1)-KRECVPTR(J)
  IF(ISENDTOT(J) > 0 ) THEN
    IJS=IJS+1
    ISEND_POS(J)=I_MSENDTOT*INUMFIELDS
    I_MSENDTOT=I_MSENDTOT+ISENDTOT(J)+1
  ENDIF
  IF(IRECVTOT(J) > 0 ) THEN
    IJR=IJR+1
    IRECV_POS(J)=I_MRECVTOT*INUMFIELDS
    I_MRECVTOT=I_MRECVTOT+IRECVTOT(J)+1
  ENDIF
ENDDO

IF (IJS > 0 ) ALLOCATE (ZSENDBUF(0:I_MSENDTOT*INUMFIELDS))
IF (IJR > 0 ) ALLOCATE (ZRECVBUF(0:I_MRECVTOT*INUMFIELDS))

!     3/ Determine the maximum number of grid columns that can be communicated.

ITAG=MTAGSLAG

LLCOMMDBGL=.FALSE.

IF( LLCOMMDBGL )THEN
  DO J=1,KSLPROCS
    WRITE(NULOUT,'("SLCOMM: J,KSLCOMM(J),ISENDTOT(J),",&
     & "IRECVTOT(J)=",4I6)')J,KSLCOMM(J),ISENDTOT(J),IRECVTOT(J)  
    CALL FLUSH(NULOUT)
  ENDDO
ENDIF

DO J=1,KSLPROCS
  IF(PRESENT(LDSLCOMM))THEN
    IF(NSIM4D > 0)THEN
      LLSLCOMM(J)=LDSLCOMM(J)
    ELSE
      LLSLCOMM(J)=.TRUE.
    ENDIF
    IF( LSLADREP ) LLSLCOMM(J)=.TRUE.
  ELSE
    LLSLCOMM(J)=.TRUE.
  ENDIF
ENDDO

!     4/ Pack loop.

IF (KTYP == 0) THEN
  CALL GSTATS(1115,0)
ELSEIF (KTYP == 1) THEN
  CALL GSTATS(1119,0)
ENDIF

DO J=1,KSLPROCS
  IF( ISENDTOT(J) > 0 .AND. LLSLCOMM(J) )THEN
    IRECVPROC=KSLCOMM(J)
    IBEG=KSENDPTR(J)
    IEND=KSENDPTR(J+1)-1
    ILEN=IEND-IBEG+1
    IJPOS(J)=(IFIXFLD(2)-IFIXFLD(1)+1)*ILEN
    ISEND(J)=NPRCIDS(IRECVPROC)
    ZSENDBUF(ISEND_POS(J))=ISENDTOT(J)
    IF( LLCOMMDBGL )THEN
      WRITE(NULOUT,'("SLCOMM: SENDING ",I6," TO ",I6,&
       & " ITAG=",I9)')ISENDTOT(J),IRECVPROC,ITAG  
      CALL FLUSH(NULOUT)
    ENDIF
  ENDIF
ENDDO
!$OMP PARALLEL DO SCHEDULE(STATIC) PRIVATE(JFLD,J,IBEG,IEND,ILEN,I_KPOS,JJ)
DO JFLD=IFIXFLD(1),IFIXFLD(2)
  DO J=1,KSLPROCS
    IF( ISENDTOT(J) > 0 .AND. LLSLCOMM(J) )THEN
      IBEG=KSENDPTR(J)
      IEND=KSENDPTR(J+1)-1
      ILEN=IEND-IBEG+1
      I_KPOS=ISEND_POS(J)+(JFLD-IFIXFLD(1))*ILEN
      DO JJ=IBEG,IEND
        ZSENDBUF(I_KPOS+JJ-IBEG+1)=PB1A(KSLSENDPOS(JJ),JFLD)
      ENDDO
    ENDIF
  ENDDO
ENDDO
!$OMP END PARALLEL DO

IF (KTYP == 0) THEN
  CALL GSTATS(1115,1)
ELSEIF (KTYP == 1) THEN
  CALL GSTATS(1119,1)
ENDIF

!     5/ Receive loop.

IR=0
IF (KTYP == 0) THEN
  CALL GSTATS_BARRIER(760)
ELSEIF (KTYP == 1) THEN
  CALL GSTATS_BARRIER(757)
ENDIF
CALL GSTATS(509,0)

IF (LSYNC_SLCOM) THEN
  CALL MPL_BARRIER(CDSTRING='SLCOMM')
ENDIF

DO J=1,KSLPROCS
  IF( IRECVTOT(J) > 0 .AND. LLSLCOMM(J) )THEN
    IR=IR+1
    ISENDPROC=KSLCOMM(J)
    IF( LLCOMMDBGL )THEN
      WRITE(NULOUT,'("SLCOMM: RECEIVING FROM ",I6,&
       & " ITAG=",I9)')ISENDPROC,ITAG  
      CALL FLUSH(NULOUT)
    ENDIF
    ILEN=IRECVTOT(J)*INUMFIELDS
    CALL MPL_RECV(ZRECVBUF(IRECV_POS(J):IRECV_POS(J)+ILEN),&
     & KSOURCE=NPRCIDS(ISENDPROC), &
     & KMP_TYPE=JP_NON_BLOCKING_STANDARD,KREQUEST=IREQ(IR), &
     & KTAG=ITAG,CDSTRING='SLCOMM: RECV' )  
  ENDIF
ENDDO

!     6/ Send loop.

DO J=1,KSLPROCS
  IF( ISENDTOT(J) > 0 .AND. LLSLCOMM(J) )THEN
    IR=IR+1
    CALL MPL_SEND(ZSENDBUF(ISEND_POS(J):ISEND_POS(J)+IJPOS(J)),&
     & KDEST=ISEND(J),&
     & KMP_TYPE=JP_NON_BLOCKING_STANDARD,KREQUEST=IREQ(IR), &
     & KTAG=ITAG,CDSTRING='SLCOMM: SEND ' )
  ENDIF
ENDDO

!     7/ Wait for all outstanding sends.

IF(IR > 0) THEN
  CALL MPL_WAIT(ZDUM,KREQUEST=IREQ(1:IR), &
   & CDSTRING='SLCOMM: WAIT FOR SENDS AND RECEIVES')  
ENDIF
CALL GSTATS(509,1)
IF (KTYP == 0) THEN
  CALL GSTATS_BARRIER2(760)
ELSEIF (KTYP == 1) THEN
  CALL GSTATS_BARRIER2(757)
ENDIF

!     8/ Unpack loop:

!     Extract communication buffer data and place in right position of PB1A.
!     Polar mimics are handled by the routine (E)SLEXTPOL.

IF (KTYP == 0) THEN
  CALL GSTATS(1116,0)
ELSEIF (KTYP == 1) THEN
  CALL GSTATS(1120,0)
ENDIF

IF( LDINC )THEN
!$OMP PARALLEL DO SCHEDULE(STATIC) PRIVATE(JFLD,J,IBEG,IEND,ILEN,I_KPOS,JJ)
  DO JFLD=IFIXFLD(1),IFIXFLD(2)
    DO J=1,KSLPROCS
      IF( IRECVTOT(J) > 0 )THEN
        IBEG=KRECVPTR(J)
        IEND=KRECVPTR(J)+ZRECVBUF(IRECV_POS(J))-1
        ILEN=IEND-IBEG+1
        I_KPOS=IRECV_POS(J)+(JFLD-IFIXFLD(1))*ILEN
        DO JJ=IBEG,IEND
          PB1A(KSLRECVPOS(JJ),JFLD)=PB1A(KSLRECVPOS(JJ),JFLD) &
           & +ZRECVBUF(I_KPOS+JJ-IBEG+1)
        ENDDO
      ENDIF
    ENDDO
  ENDDO
!$OMP END PARALLEL DO
ELSE
!$OMP PARALLEL DO SCHEDULE(STATIC) PRIVATE(JFLD,J,IBEG,IEND,ILEN,I_KPOS,JJ)
  DO JFLD=IFIXFLD(1),IFIXFLD(2)
    DO J=1,KSLPROCS
      IF( IRECVTOT(J) > 0 .AND. LLSLCOMM(J) )THEN
        IBEG=KRECVPTR(J)
        IEND=KRECVPTR(J)+ZRECVBUF(IRECV_POS(J))-1
        ILEN=IEND-IBEG+1
        I_KPOS=IRECV_POS(J)+(JFLD-IFIXFLD(1))*ILEN
        DO JJ=IBEG,IEND
          PB1A(KSLRECVPOS(JJ),JFLD)=ZRECVBUF(I_KPOS+JJ-IBEG+1)
        ENDDO
      ENDIF
    ENDDO
  ENDDO
!$OMP END PARALLEL DO
ENDIF

IF (KTYP == 0) THEN
  CALL GSTATS(1116,1)
ELSEIF (KTYP == 1) THEN
  CALL GSTATS(1120,1)
ENDIF

IF (ALLOCATED(ZSENDBUF)) DEALLOCATE (ZSENDBUF)
IF (ALLOCATED(ZRECVBUF)) DEALLOCATE (ZRECVBUF)

!     ------------------------------------------------------------------
IF (LHOOK) CALL DR_HOOK('SLCOMM',1,ZHOOK_HANDLE)
END SUBROUTINE SLCOMM
