SUBROUTINE SLCOMM2A(KASLB1,KSLPROCS,KSLRPT,&
 & KSLSPT,KSLSENDPOS,KSLRECVPOS,KSENDPTR,KRECVPTR,KSLCOMM,&
 & KFIXFLD,LDEXCLUDE,KMASK1,KMASK2,KMASK2A,KMASK3,&
 & KFLDSLB,LDINC,PB1A,KFIELD_TYPE,LDSLCOMM)  
!****-------------------------------------------------------------------
!**** *SLCOMM2A* - Interpolation buffer communication
!****-------------------------------------------------------------------
!     Purpose.
!     --------
!           This routine is called to perform the inter-processor 
!     communication required for schemes needing horizontal interpolations.

!**   Interface.
!     ----------
!        *CALL* *SLCOMM2A

!        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. 
!          LDEXCLUDE      - .true. - exclude fields in range specified by KFIXFLD
!                           .false.- include fields in range specified by KFIXFLD
!          KMASK1         - Masks for on demand-comms
!          KMASK2/2A      - Masks for on demand-comms
!          KMASK3         - Masks for on demand-comms
!          LDINC          - increment flag for interpolation buffer
!          KFIELD_TYPE    - Field Type
!                           - 1 for 32 point stencil
!                           - 2 for  8 point stencil
!        INPUT/OUTPUT:
!          PB1A           - interpolation buffer.
!          LDSLCOMM       - Optional: flag indicating whether this processor needs to
!                           communicate with a specific processor.

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

!     Method.
!     -------
!       Copy of SLCOMM2 for 'on demand' Semi-Lagrangian Communications
!       Special version which only communicates data necessary for stencil

!     Externals.
!     ----------
!        MPL_BARRIER,  MPL_SEND, MPL_RECV, MPL_WAIT
!                                   - Communication Interface

!        Is called by SCAN2M, SCAN2MTL, CPCLIMO, CPCLIMI, FPMODPREC

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

!     Author.
!     -------
!        Deborah Salmond and John Hague

!     Modifications
!     -------------
!        M.Hamrud      01-Oct-2003 CY28 Cleaning

!        00-09-01  D.Dent:  conversion from MPE to MPL
!        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
!        G.Mozdzynski  10-Nov-2005 Optimised OpenMP parallelisation
!        M.Jidane 09-04-2006 : Cleaning CY31
!        G.Mozdzynski  01-Jan-2008 Cleanup
!        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
USE YOMTAG   , ONLY : MTAGSLAG
USE YOMVAR   , ONLY : NSIM4D
USE YOMSLREP , ONLY : LSLADREP
USE MPL_MODULE

IMPLICIT NONE

!     DUMMY:
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)    :: LDEXCLUDE 
INTEGER(KIND=JPIM)               :: KMASK1(KASLB1+4) ! Argument NOT used
INTEGER(KIND=JPIM),INTENT(IN)    :: KMASK2(KASLB1+4) 
INTEGER(KIND=JPIM),INTENT(IN)    :: KMASK2A(KASLB1+4) 
INTEGER(KIND=JPIM),INTENT(INOUT) :: KMASK3(KASLB1+4) 
LOGICAL           ,INTENT(IN)    :: LDINC 
REAL(KIND=JPRB)   ,INTENT(INOUT) :: PB1A(KASLB1,KFLDSLB) 
INTEGER(KIND=JPIM),INTENT(IN)    :: KFIELD_TYPE(KFLDSLB) 
LOGICAL,OPTIONAL  ,INTENT(INOUT) :: LDSLCOMM(KSLPROCS)
REAL(KIND=JPRB),ALLOCATABLE :: ZSENDBUF(:),ZRECVBUF(:)
REAL(KIND=JPRB) :: ZDUM(2)

INTEGER(KIND=JPIM) :: IRECVMAP(0:KSLRPT,KSLPROCS)
INTEGER(KIND=JPIM) :: ISENDMAP(0:KSLSPT,KSLPROCS)

INTEGER(KIND=JPIM) :: ISENDTOT (KSLPROCS)
INTEGER(KIND=JPIM) :: IRECVTOT (KSLPROCS)
INTEGER(KIND=JPIM) :: IREQ     (KSLPROCS*2)
INTEGER(KIND=JPIM) :: JPOS     (KSLPROCS)
INTEGER(KIND=JPIM) :: JSEND    (KSLPROCS)
INTEGER(KIND=JPIM) :: ISEND_POS(KSLPROCS)
INTEGER(KIND=JPIM) :: IRECV_POS(KSLPROCS)
INTEGER(KIND=JPIM) :: ILENB    (KSLPROCS,2)
LOGICAL            :: LLSLCOMM (KSLPROCS)
INTEGER(KIND=JPIM) :: IFIXFLD(2)
INTEGER(KIND=JPIM) :: IDUM(2)

INTEGER(KIND=JPIM) :: IBEG, IEND, ILEN, &
 & IPT, IRECVPROC, ISENDPROC, &
 & ITAG, J, JJ, JFLD, JNUM, ITOT,  INUMFIELDS, &
 & JR, JS, INUMSENT, I_KPOS, IR

INTEGER(KIND=JPIM) :: ISENDCOUNT,IRECVCOUNT
INTEGER(KIND=JPIM),ALLOCATABLE :: IPTA(:,:,:)
INTEGER(KIND=JPIM),ALLOCATABLE :: I_KPOSJ(:,:)

INTEGER(KIND=JPIM) :: JM1, JM2, IFLD

LOGICAL :: LLCOMMDBGL
INTEGER(KIND=JPIM) :: I_MAPSENDTOT, I_MAPRECVTOT
REAL(KIND=JPRB) :: ZHOOK_HANDLE

#include "abor1.intfb.h"

!IF(MYPROC == 1)CALL XL__TRBK()

IF (LHOOK) CALL DR_HOOK('SLCOMM2A',0,ZHOOK_HANDLE)


CALL GSTATS(1813,0)
IFIXFLD(1)=KFIXFLD(1)
IFIXFLD(2)=KFIXFLD(2)

!     Mark all processors as having no outstanding receives,
!     nothing sent or received.

JR=0
JS=0
INUMSENT=0
ISENDCOUNT=0
IRECVCOUNT=0
IF(LDEXCLUDE)THEN
  INUMFIELDS=KFLDSLB-(IFIXFLD(2)-IFIXFLD(1)+1)
ELSE
  INUMFIELDS=IFIXFLD(2)-IFIXFLD(1)+1
ENDIF

DO J=1,KSLPROCS
  ISENDTOT(J)=KSENDPTR(J+1)-KSENDPTR(J)
  IRECVTOT(J)=KRECVPTR(J+1)-KRECVPTR(J)
  IF(ISENDTOT(J) > 0 ) THEN
    JS=JS+1
  ENDIF
  IF(IRECVTOT(J) > 0 ) THEN
    JR=JR+1
  ENDIF
  ISENDCOUNT=MAX(ISENDCOUNT,ISENDTOT(J))
  IRECVCOUNT=MAX(IRECVCOUNT,IRECVTOT(J))
ENDDO

ITAG=MTAGSLAG

LLCOMMDBGL=.FALSE.

IF( LLCOMMDBGL )THEN
  DO J=1,KSLPROCS
    WRITE(NULOUT,'("SLCOMM2A: 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

IF(.NOT.LDINC)THEN
  DO IPT=KASLB1,1,-1
    IF(KMASK2(IPT) == 4) THEN
      KMASK3(IPT  )=MAX(KMASK3(IPT  ),1)
      KMASK3(IPT+1)=2
      KMASK3(IPT+2)=2
      KMASK3(IPT+3)=MAX(KMASK3(IPT+3),1)
    ELSEIF(KMASK2A(IPT) == 2) THEN
      KMASK3(IPT+1)=MAX(KMASK3(IPT+1),1)
      KMASK3(IPT+2)=MAX(KMASK3(IPT+2),1)
    ENDIF
  ENDDO
ELSE
  CALL ABOR1('SLCOMM2A: NOT DONE FOR LDINC')
ENDIF
CALL GSTATS(1813,1)


CALL GSTATS_BARRIER(758)
CALL GSTATS(502,0)
DO J=1,KSLPROCS
  ITOT=0
  ISENDPROC=KSLCOMM(J)
  IBEG=KRECVPTR(J)
  IEND=KRECVPTR(J+1)-1
  DO JNUM=IBEG,IEND
    IPT=KSLRECVPOS(JNUM)
    IRECVMAP(JNUM-IBEG+1,J)= KMASK3(IPT)
    IF(KMASK3(IPT) >= 1)ITOT=ITOT+1
  ENDDO
  IRECVMAP(0,J)=ITOT
  IF(IRECVMAP(0,J) == 0) IRECVTOT(J)=0 
ENDDO
IR=0
DO J=1,KSLPROCS
  ISENDMAP(0,J)=0
  IF( LLSLCOMM(J) )THEN
    IR=IR+1
    IRECVPROC=KSLCOMM(J)
    ILEN=(KSENDPTR(J+1)-KSENDPTR(J))
    CALL MPL_RECV(ISENDMAP(0:ILEN,J),KSOURCE=NPRCIDS(IRECVPROC),KTAG=ITAG,&
     & KMP_TYPE=JP_NON_BLOCKING_STANDARD,KREQUEST=IREQ(IR), &
     & CDSTRING='SLCOMM2A: RECV MAP ' )  
  ENDIF
ENDDO
DO J=1,KSLPROCS
  IF( LLSLCOMM(J) )THEN
    IR=IR+1
    ISENDPROC=KSLCOMM(J)
    ILEN=(KRECVPTR(J+1)-KRECVPTR(J))
    CALL MPL_SEND(IRECVMAP(0:ILEN,J),KDEST=NPRCIDS(ISENDPROC),KTAG=ITAG, &
     & KMP_TYPE=JP_NON_BLOCKING_STANDARD,KREQUEST=IREQ(IR), &
     & CDSTRING='SLCOMM2A: SEND MAP ' )  
  ENDIF
ENDDO
IF( IR > 0 )THEN
  CALL MPL_WAIT(IDUM,KREQUEST=IREQ(1:IR), &
   & CDSTRING='SLCOMM2A: WAIT FOR MAP SENDS AND RECEIVES')  
ENDIF
DO J=1,KSLPROCS
  IF(ISENDMAP(0,J) == 0) ISENDTOT(J)=0 
ENDDO

IF( PRESENT(LDSLCOMM) .AND. NSIM4D==0 .AND. .NOT.LSLADREP )THEN
  DO J=1,KSLPROCS
    LDSLCOMM(J)=ISENDTOT(J)>0 .OR. IRECVTOT(J)>0
  ENDDO
ENDIF

CALL GSTATS(502,1)
CALL GSTATS_BARRIER2(758)

ISEND_POS(1)=0
IRECV_POS(1)=0

DO J=2,KSLPROCS
  ISEND_POS(J)=ISEND_POS(J-1)+ISENDMAP(0,J-1)*INUMFIELDS+1
  IRECV_POS(J)=IRECV_POS(J-1)+IRECVMAP(0,J-1)*INUMFIELDS+1
ENDDO

I_MAPSENDTOT=ISEND_POS(KSLPROCS)+ISENDMAP(0,KSLPROCS)*INUMFIELDS
I_MAPRECVTOT=IRECV_POS(KSLPROCS)+IRECVMAP(0,KSLPROCS)*INUMFIELDS

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

IF (I_MAPSENDTOT > 0 ) ALLOCATE (ZSENDBUF(0:I_MAPSENDTOT))
IF (I_MAPRECVTOT > 0 ) ALLOCATE (ZRECVBUF(0:I_MAPRECVTOT))

!     Loop over the number of processors we need to communicate with

ITAG=ITAG+1

!       Pack loop.............................................................

CALL GSTATS(1121,0)

ALLOCATE(IPTA(MAX(ISENDCOUNT,IRECVCOUNT),KSLPROCS,2))
ALLOCATE(I_KPOSJ(KFLDSLB,KSLPROCS))
!$OMP PARALLEL DO SCHEDULE(DYNAMIC,1)&
!$OMP& PRIVATE(J,IRECVPROC,IBEG,IEND,JM1,JM2,JNUM,I_KPOS,JFLD,IFLD)
DO J=1,KSLPROCS
  IF( ISENDTOT(J) > 0 .AND. LLSLCOMM(J) )THEN
    IRECVPROC=KSLCOMM(J)
    IBEG=KSENDPTR(J)
    IEND=KSENDPTR(J+1)-1
    JM1=0
    JM2=0
    DO JNUM=IBEG,IEND
      IF(ISENDMAP((JNUM-KSENDPTR(J)+1),J) >= 1)THEN
        JM1=JM1+1
        IPTA(JM1,J,1)=KSLSENDPOS(JNUM)
      ENDIF
      IF(ISENDMAP((JNUM-KSENDPTR(J)+1),J) == 2)THEN
        JM2=JM2+1
        IPTA(JM2,J,2)=KSLSENDPOS(JNUM)
      ENDIF
    ENDDO
    ILENB(J,1)=JM1
    ILENB(J,2)=JM2
    I_KPOS=0
    IF(LDEXCLUDE)THEN
      DO JFLD=1,KFLDSLB
          IF(JFLD < IFIXFLD(1).OR.JFLD > IFIXFLD(2)) THEN
          I_KPOSJ(JFLD,J)=I_KPOS
          IFLD=KFIELD_TYPE(JFLD)
          IF    (IFLD == 1)THEN
             I_KPOS=I_KPOS+JM1
          ELSEIF(IFLD == 2)THEN
             I_KPOS=I_KPOS+JM2
          ELSE
            WRITE(NULOUT,'("SLCOMM2A: PACK INVALID IFLD=",I6," JFLD=",I6)')&
             &IFLD,JFLD
            CALL ABOR1('SLCOMM2A: PACK INVALID IFLD')
          ENDIF
        ENDIF
      ENDDO
    ELSE
      DO JFLD=IFIXFLD(1),IFIXFLD(2)
        I_KPOSJ(JFLD,J)=I_KPOS
        IFLD=KFIELD_TYPE(JFLD)
        IF    (IFLD == 1)THEN
           I_KPOS=I_KPOS+JM1
        ELSEIF(IFLD == 2)THEN
           I_KPOS=I_KPOS+JM2
        ELSE
          WRITE(NULOUT,'("SLCOMM2A: PACK INVALID IFLD=",I6," JFLD=",I6)')&
           &IFLD,JFLD
          CALL ABOR1('SLCOMM2A: PACK INVALID IFLD')
        ENDIF
      ENDDO
    ENDIF
    JPOS(J)=I_KPOS
    ZSENDBUF(ISEND_POS(J))=ISENDTOT(J)
    IF( LLCOMMDBGL )THEN
      WRITE(NULOUT,'("SLCOMM2A: SENDING ",I6," TO ",I6,&
       & " ITAG=",I9)')ISENDTOT(J),IRECVPROC,ITAG
      CALL FLUSH(NULOUT)
    ENDIF
    JSEND(J)=NPRCIDS(IRECVPROC)
  ENDIF
ENDDO
!$OMP END PARALLEL DO

IF(LDEXCLUDE)THEN
!$OMP PARALLEL DO SCHEDULE(STATIC) PRIVATE(JFLD,J,ILEN,I_KPOS,JJ)
  DO JFLD=1,IFIXFLD(1)-1
    DO J=1,KSLPROCS
      IF( ISENDTOT(J) > 0 .AND. LLSLCOMM(J) )THEN
        ILEN=ILENB(J,KFIELD_TYPE(JFLD))
        I_KPOS=ISEND_POS(J)+I_KPOSJ(JFLD,J)
        DO JJ=1,ILEN
          ZSENDBUF(I_KPOS+JJ)=PB1A(IPTA(JJ,J,KFIELD_TYPE(JFLD)),JFLD)
        ENDDO
      ENDIF
    ENDDO
  ENDDO
!$OMP END PARALLEL DO

!$OMP PARALLEL DO SCHEDULE(STATIC) PRIVATE(JFLD,J,ILEN,I_KPOS,JJ)
  DO JFLD=IFIXFLD(2)+1,KFLDSLB
    DO J=1,KSLPROCS
      IF( ISENDTOT(J) > 0 .AND. LLSLCOMM(J) )THEN
        ILEN=ILENB(J,KFIELD_TYPE(JFLD))
        I_KPOS=ISEND_POS(J)+I_KPOSJ(JFLD,J)
        DO JJ=1,ILEN
          ZSENDBUF(I_KPOS+JJ)=PB1A(IPTA(JJ,J,KFIELD_TYPE(JFLD)),JFLD)
        ENDDO
      ENDIF
    ENDDO
  ENDDO
!$OMP END PARALLEL DO
ELSE
!$OMP PARALLEL DO SCHEDULE(STATIC) PRIVATE(JFLD,J,ILEN,I_KPOS,JJ)
  DO JFLD=IFIXFLD(1),IFIXFLD(2)
    DO J=1,KSLPROCS
      IF( ISENDTOT(J) > 0 .AND. LLSLCOMM(J) )THEN
        ILEN=ILENB(J,KFIELD_TYPE(JFLD))
        I_KPOS=ISEND_POS(J)+I_KPOSJ(JFLD,J)
        DO JJ=1,ILEN
          ZSENDBUF(I_KPOS+JJ)=PB1A(IPTA(JJ,J,KFIELD_TYPE(JFLD)),JFLD)
        ENDDO
      ENDIF
    ENDDO
  ENDDO
!$OMP END PARALLEL DO
ENDIF

DEALLOCATE(IPTA)
DEALLOCATE(I_KPOSJ)

CALL GSTATS(1121,1)

IR=0
CALL GSTATS_BARRIER(749)
CALL GSTATS(512,0)

!       Receive loop.........................................................
DO J=1,KSLPROCS
  IF( IRECVTOT(J) > 0 .AND. LLSLCOMM(J) )THEN
    IR=IR+1
    ISENDPROC=KSLCOMM(J)
    IF( LLCOMMDBGL )THEN
      WRITE(NULOUT,'("SLCOMM2A: RECEIVING ",I6," FROM ",I6,&
       & " ITAG=",I9)')ISENDPROC,ITAG  
      CALL FLUSH(NULOUT)
    ENDIF
    ILEN=IRECVMAP(0,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='SLCOMM2A: RECV' )  
  ENDIF
ENDDO

!       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)+JPOS(J)),&
     & KDEST=JSEND(J), &
     & KMP_TYPE=JP_NON_BLOCKING_STANDARD,KREQUEST=IREQ(IR), &
     & KTAG=ITAG,CDSTRING='SLCOMM2A: SEND ' )  
  ENDIF
ENDDO

!       Wait for all outstanding sends

IF(IR > 0) THEN
  CALL MPL_WAIT(ZDUM,KREQUEST=IREQ(1:IR), &
   & CDSTRING='SLCOMM2A: WAIT FOR SENDS AND RECEIVES')  
ENDIF

CALL GSTATS(512,1)
CALL GSTATS_BARRIER2(749)

!     Unpack loop.............................................................
CALL GSTATS(1118,0)

ALLOCATE(IPTA(MAX(ISENDCOUNT,IRECVCOUNT),KSLPROCS,2))
ALLOCATE(I_KPOSJ(KFLDSLB,KSLPROCS))
!$OMP PARALLEL DO SCHEDULE(DYNAMIC,1)&
!$OMP& PRIVATE(J,ISENDPROC,IBEG,IEND,JM1,JM2,JNUM,I_KPOS,JFLD,IFLD)
DO J=1,KSLPROCS
  IF( IRECVTOT(J) > 0 .AND. LLSLCOMM(J) )THEN
    ISENDPROC=KSLCOMM(J)
    IBEG=KRECVPTR(J)
    IEND=KRECVPTR(J)+ZRECVBUF(IRECV_POS(J))-1
!       Extract communication buffer data and place in right position of PB1A.
!       Polar mimics are handled by the routine slextpol.F
    JM1=0
    JM2=0
    DO JNUM=IBEG,IEND
      IF(IRECVMAP((JNUM-KRECVPTR(J)+1),J) >= 1)THEN
        JM1=JM1+1
        IPTA(JM1,J,1)=KSLRECVPOS(JNUM)
      ENDIF
      IF(IRECVMAP((JNUM-KRECVPTR(J)+1),J) == 2)THEN
        JM2=JM2+1
        IPTA(JM2,J,2)=KSLRECVPOS(JNUM)
      ENDIF
    ENDDO
    ILENB(J,1)=JM1
    ILENB(J,2)=JM2
    I_KPOS=0
    IF(LDEXCLUDE)THEN
      DO JFLD=1,KFLDSLB
        IF(JFLD < IFIXFLD(1).OR.JFLD > IFIXFLD(2)) THEN
          I_KPOSJ(JFLD,J)=I_KPOS
          IFLD=KFIELD_TYPE(JFLD)
          IF    (IFLD == 1)THEN
             I_KPOS=I_KPOS+JM1
          ELSEIF(IFLD == 2)THEN
             I_KPOS=I_KPOS+JM2
          ELSE
            WRITE(NULOUT,'("SLCOMM2A: UNPACK INVALID IFLD=",I6," JFLD=",I6)')&
             &IFLD,JFLD
            CALL ABOR1('SLCOMM2A: UNPACK INVALID IFLD')
          ENDIF
        ENDIF
      ENDDO
    ELSE
      DO JFLD=IFIXFLD(1),IFIXFLD(2)
        I_KPOSJ(JFLD,J)=I_KPOS
        IFLD=KFIELD_TYPE(JFLD)
        IF    (IFLD == 1)THEN
           I_KPOS=I_KPOS+JM1
        ELSEIF(IFLD == 2)THEN
           I_KPOS=I_KPOS+JM2
        ELSE
          WRITE(NULOUT,'("SLCOMM2A: UNPACK INVALID IFLD=",I6," JFLD=",I6)')&
           &IFLD,JFLD
          CALL ABOR1('SLCOMM2A: UNPACK INVALID IFLD')
        ENDIF
      ENDDO
    ENDIF
    JPOS(J)=I_KPOS
  ENDIF
ENDDO
!$OMP END PARALLEL DO

IF(LDEXCLUDE)THEN
!$OMP PARALLEL DO SCHEDULE(STATIC) PRIVATE(JFLD,J,ILEN,I_KPOS,JJ)
  DO JFLD=1,IFIXFLD(1)-1
    DO J=1,KSLPROCS
      IF( IRECVTOT(J) > 0 .AND. LLSLCOMM(J) )THEN
        ILEN=ILENB(J,KFIELD_TYPE(JFLD))
        I_KPOS=IRECV_POS(J)+I_KPOSJ(JFLD,J)
        DO JJ=1,ILEN
          PB1A(IPTA(JJ,J,KFIELD_TYPE(JFLD)),JFLD)=ZRECVBUF(I_KPOS+JJ)
        ENDDO
      ENDIF
    ENDDO
  ENDDO
!$OMP END PARALLEL DO

!$OMP PARALLEL DO SCHEDULE(STATIC) PRIVATE(JFLD,J,ILEN,I_KPOS,JJ)
  DO JFLD=IFIXFLD(2)+1,KFLDSLB
    DO J=1,KSLPROCS
      IF( IRECVTOT(J) > 0 .AND. LLSLCOMM(J) )THEN
        ILEN=ILENB(J,KFIELD_TYPE(JFLD))
        I_KPOS=IRECV_POS(J)+I_KPOSJ(JFLD,J)
        DO JJ=1,ILEN
          PB1A(IPTA(JJ,J,KFIELD_TYPE(JFLD)),JFLD)=ZRECVBUF(I_KPOS+JJ)
        ENDDO
      ENDIF
    ENDDO
  ENDDO
!$OMP END PARALLEL DO
ELSE
!$OMP PARALLEL DO SCHEDULE(STATIC) PRIVATE(JFLD,J,ILEN,I_KPOS,JJ)
  DO JFLD=IFIXFLD(1),IFIXFLD(2)
    DO J=1,KSLPROCS
      IF( IRECVTOT(J) > 0 .AND. LLSLCOMM(J) )THEN
        ILEN=ILENB(J,KFIELD_TYPE(JFLD))
        I_KPOS=IRECV_POS(J)+I_KPOSJ(JFLD,J)
        DO JJ=1,ILEN
          PB1A(IPTA(JJ,J,KFIELD_TYPE(JFLD)),JFLD)=ZRECVBUF(I_KPOS+JJ)
        ENDDO
      ENDIF
    ENDDO
  ENDDO
!$OMP END PARALLEL DO
ENDIF

DEALLOCATE(IPTA)
DEALLOCATE(I_KPOSJ)

CALL GSTATS(1118,1)

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

IF (LHOOK) CALL DR_HOOK('SLCOMM2A',1,ZHOOK_HANDLE)

END SUBROUTINE SLCOMM2A

