! (C) Copyright 1995- ECMWF.
! (C) Copyright 1995- Meteo-France.
! 
! This software is licensed under the terms of the Apache Licence Version 2.0
! which can be obtained at http://www.apache.org/licenses/LICENSE-2.0.
! In applying this licence, ECMWF does not waive the privileges and immunities
! granted to it by virtue of its status as an intergovernmental organisation
! nor does it submit to any jurisdiction.
!

MODULE TRLTOG_MOD

PUBLIC TRLTOG
PRIVATE TRLTOG_PROLOG, TRLTOG_COMM, TRLTOG_COMM_HEAP, TRLTOG_COMM_STACK

CONTAINS

SUBROUTINE TRLTOG(PGLAT,KF_FS,KF_GP,KF_SCALARS_G,KVSET,KPTRGP,&
 &PGP,PGPUV,PGP3A,PGP3B,PGP2)

!**** *TRLTOG * - head routine for transposition of grid point data from latitudinal
!                 to column structure (this takes place between inverse
!                 FFT and grid point calculations)
!                 TRLTOG is the inverse of TRGTOL

!**   Interface.
!     ----------
!        *call* *TRLTOG(...)

!        Explicit arguments :
!        --------------------
!           PGLAT    -  Latitudinal data ready for direct FFT (input)
!           PGP    -  Blocked grid point data    (output)
!           KVSET    - "v-set" for each field      (input)

!        Implicit arguments :
!        --------------------

!     Method.
!     -------
!        See documentation

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

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

!     Author.
!     -------
!        R. El Khatib *Meteo-France*

!     Modifications.
!     --------------
!        Original  : 18-Aug-2014 from trltog
!        R. El Khatib 09-Sep-2020 NSTACK_MEMORY_TR
!     ------------------------------------------------------------------

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

USE TPM_GEN         ,ONLY : NSTACK_MEMORY_TR
USE TPM_DISTR       ,ONLY : D, NPRTRNS, NPROC
USE TPM_TRANS       ,ONLY : NGPBLKS

IMPLICIT NONE

INTEGER(KIND=JPIM),INTENT(IN)  :: KF_FS,KF_GP
INTEGER(KIND=JPIM),INTENT(IN)  :: KF_SCALARS_G
REAL(KIND=JPRB),INTENT(IN)     :: PGLAT(KF_FS,D%NLENGTF)
INTEGER(KIND=JPIM), INTENT(IN) :: KVSET(KF_GP)
INTEGER(KIND=JPIM) ,OPTIONAL, INTENT(IN) :: KPTRGP(:)
REAL(KIND=JPRB),OPTIONAL,INTENT(OUT)     :: PGP(:,:,:)
REAL(KIND=JPRB),OPTIONAL,INTENT(OUT)     :: PGPUV(:,:,:,:)
REAL(KIND=JPRB),OPTIONAL,INTENT(OUT)     :: PGP3A(:,:,:,:)
REAL(KIND=JPRB),OPTIONAL,INTENT(OUT)     :: PGP3B(:,:,:,:)
REAL(KIND=JPRB),OPTIONAL,INTENT(OUT)     :: PGP2(:,:,:)

INTEGER(KIND=JPIM) :: ISENDCOUNT
INTEGER(KIND=JPIM) :: IRECVCOUNT
INTEGER(KIND=JPIM) :: INSEND
INTEGER(KIND=JPIM) :: INRECV
INTEGER(KIND=JPIM) :: ISENDTOT (NPROC)
INTEGER(KIND=JPIM) :: IRECVTOT (NPROC)
INTEGER(KIND=JPIM) :: ISEND    (NPROC)
INTEGER(KIND=JPIM) :: IRECV    (NPROC)
INTEGER(KIND=JPIM) :: IINDEX(D%NLENGTF)
INTEGER(KIND=JPIM) :: INDOFF(NPROC)
INTEGER(KIND=JPIM) :: IGPTRSEND(2,NGPBLKS,NPRTRNS)
INTEGER(KIND=JPIM) :: ISETAL(NPROC), ISETBL(NPROC), ISETWL(NPROC), ISETVL(NPROC)

REAL(KIND=JPHOOK) :: ZHOOK_HANDLE

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

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

CALL TRLTOG_PROLOG(KF_FS,KF_GP,KVSET,&
 & ISENDCOUNT,IRECVCOUNT,INSEND,INRECV,ISENDTOT,IRECVTOT,ISEND,IRECV,IINDEX,INDOFF,IGPTRSEND, &
 & ISETAL,ISETBL,ISETWL,ISETVL)
IF (NSTACK_MEMORY_TR==0) THEN
  CALL TRLTOG_COMM_HEAP(PGLAT,KF_FS,KF_GP,KF_SCALARS_G,KVSET, &
   & ISENDCOUNT,IRECVCOUNT,INSEND,INRECV,ISENDTOT,IRECVTOT,ISEND,IRECV,IINDEX,INDOFF,IGPTRSEND, &
   & KPTRGP,PGP,PGPUV,PGP3A,PGP3B,PGP2,&
   & ISETAL,ISETBL,ISETWL,ISETVL)
ELSE
  CALL TRLTOG_COMM_STACK(PGLAT,KF_FS,KF_GP,KF_SCALARS_G,KVSET, &
   & ISENDCOUNT,IRECVCOUNT,INSEND,INRECV,ISENDTOT,IRECVTOT,ISEND,IRECV,IINDEX,INDOFF,IGPTRSEND, &
   & KPTRGP,PGP,PGPUV,PGP3A,PGP3B,PGP2,&
   & ISETAL,ISETBL,ISETWL,ISETVL)
ENDIF

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

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

END SUBROUTINE TRLTOG

SUBROUTINE TRLTOG_PROLOG(KF_FS,KF_GP,KVSET,&
 & KSENDCOUNT,KRECVCOUNT,KNSEND,KNRECV,KSENDTOT,KRECVTOT,KSEND,KRECV,KINDEX,KNDOFF,KGPTRSEND, &
 & KSETAL,KSETBL,KSETWL,KSETVL)

!**** *TRLTOG_PROLOG * - prolog for transposition of grid point data from latitudinal
!                 to column structure (this takes place between inverse
!                 FFT and grid point calculations) : the purpose is essentially 
!                 to compute the size of communication buffers in order to enable
!                 the use of automatic arrays later.
!                 TRLTOG_PROLOG is the inverse of TRGTOL_PROLOG

!     Purpose.
!     --------

!**   Interface.
!     ----------
!        *call* *TRLTOG_PROLOG(...)

!        Explicit arguments :
!        --------------------
!           KVSET    - "v-set" for each field      (input)

!        Implicit arguments :
!        --------------------

!     Method.
!     -------
!        See documentation

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

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

!     Author.
!     -------
!        R. El Khatib *Meteo-France*

!     Modifications.
!     --------------
!        Original  : 18-Aug-2014 from trltog
!     ------------------------------------------------------------------

USE PARKIND1  ,ONLY : JPIM

USE TPM_DISTR       ,ONLY : D, MYSETW, NPRTRNS, MYPROC, NPROC
USE TPM_TRANS       ,ONLY : NGPBLKS

USE INIGPTR_MOD     ,ONLY : INIGPTR
USE PE2SET_MOD      ,ONLY : PE2SET
!

IMPLICIT NONE

INTEGER(KIND=JPIM),INTENT(IN)  :: KF_FS,KF_GP
INTEGER(KIND=JPIM),INTENT(IN)  :: KVSET(KF_GP)

INTEGER(KIND=JPIM), INTENT(OUT) :: KSENDCOUNT
INTEGER(KIND=JPIM), INTENT(OUT) :: KRECVCOUNT
INTEGER(KIND=JPIM), INTENT(OUT) :: KNSEND
INTEGER(KIND=JPIM), INTENT(OUT) :: KNRECV
INTEGER(KIND=JPIM), INTENT(OUT) :: KSENDTOT (NPROC)
INTEGER(KIND=JPIM), INTENT(OUT) :: KRECVTOT (NPROC)
INTEGER(KIND=JPIM), INTENT(OUT) :: KSEND    (NPROC)
INTEGER(KIND=JPIM), INTENT(OUT) :: KRECV    (NPROC)
INTEGER(KIND=JPIM), INTENT(OUT) :: KINDEX(D%NLENGTF)
INTEGER(KIND=JPIM), INTENT(OUT) :: KNDOFF(NPROC)
INTEGER(KIND=JPIM), INTENT(OUT) :: KGPTRSEND(2,NGPBLKS,NPRTRNS)
INTEGER(KIND=JPIM), INTENT(OUT) :: KSETAL(NPROC)
INTEGER(KIND=JPIM), INTENT(OUT) :: KSETBL(NPROC)
INTEGER(KIND=JPIM), INTENT(OUT) :: KSETWL(NPROC)
INTEGER(KIND=JPIM), INTENT(OUT) :: KSETVL(NPROC)

INTEGER(KIND=JPIM) :: IGPTRRECV(NPRTRNS)
INTEGER(KIND=JPIM) :: IFIRSTLAT, IGL, IGLL, ILASTLAT, IPOS, ISETA, ISETB, ISETV
INTEGER(KIND=JPIM) :: ISEND, JFLD, JGL, JL, ISETW, JROC, J
INTEGER(KIND=JPIM) :: INDOFFX,IBUFLENS,IBUFLENR

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

!*       0.    Some initializations
!              --------------------

CALL GSTATS(1806,0)

CALL INIGPTR(KGPTRSEND,IGPTRRECV)

INDOFFX  = 0
IBUFLENS = 0
IBUFLENR = 0
KNRECV = 0
KNSEND = 0

DO JROC=1,NPROC

  CALL PE2SET(JROC,KSETAL(JROC),KSETBL(JROC),KSETWL(JROC),KSETVL(JROC))
  ISEND      = JROC
  ISETA=KSETAL(JROC)
  ISETB=KSETBL(JROC)
  ISETW=KSETWL(JROC)
  ISETV=KSETVL(JROC)
!             count up expected number of fields
  IPOS = 0
  DO JFLD=1,KF_GP
    IF(KVSET(JFLD) == ISETV .OR. KVSET(JFLD) == -1) IPOS = IPOS+1
  ENDDO
  KRECVTOT(JROC) = IGPTRRECV(ISETW)*IPOS
  IF(KRECVTOT(JROC) > 0 .AND. MYPROC /= JROC) THEN
    KNRECV = KNRECV + 1
    KRECV(KNRECV)=JROC
  ENDIF

  IF( JROC /= MYPROC) IBUFLENR = MAX(IBUFLENR,KRECVTOT(JROC))

  IFIRSTLAT = MAX(D%NPTRLS(MYSETW),D%NFRSTLAT(ISETA))
  ILASTLAT  = MIN(D%NPTRLS(MYSETW)+D%NULTPP(MYSETW)-1,D%NLSTLAT(ISETA))

  IPOS = 0
  DO JGL=IFIRSTLAT,ILASTLAT
    IGL  = D%NPTRFRSTLAT(ISETA)+JGL-D%NFRSTLAT(ISETA)
    IPOS = IPOS+D%NONL(IGL,ISETB)
  ENDDO

  KSENDTOT(JROC) = IPOS*KF_FS
  IF( JROC /= MYPROC) THEN
    IBUFLENS = MAX(IBUFLENS,KSENDTOT(JROC))
    IF(KSENDTOT(JROC) > 0) THEN
      KNSEND = KNSEND+1
      KSEND(KNSEND)=JROC
    ENDIF
  ENDIF

  IF(IPOS > 0) THEN
    KNDOFF(JROC) = INDOFFX
    INDOFFX = INDOFFX+IPOS
    IPOS = 0
    DO JGL=IFIRSTLAT,ILASTLAT
      IGL  = D%NPTRFRSTLAT(ISETA)+JGL-D%NFRSTLAT(ISETA)
      IGLL = JGL-D%NPTRLS(MYSETW)+1
      DO JL=D%NSTA(IGL,ISETB)+D%NSTAGTF(IGLL),&
       &D%NSTA(IGL,ISETB)+D%NSTAGTF(IGLL)+D%NONL(IGL,ISETB)-1
        IPOS = IPOS+1
        KINDEX(IPOS+KNDOFF(JROC)) = JL
      ENDDO
    ENDDO
  ENDIF
ENDDO

KSENDCOUNT=0
KRECVCOUNT=0
DO J=1,NPROC
  KSENDCOUNT=MAX(KSENDCOUNT,KSENDTOT(J))
  KRECVCOUNT=MAX(KRECVCOUNT,KRECVTOT(J))
ENDDO

CALL GSTATS(1806,1)

END SUBROUTINE TRLTOG_PROLOG

SUBROUTINE TRLTOG_COMM_HEAP(PGLAT,KF_FS,KF_GP,KF_SCALARS_G,KVSET,&
 & KSENDCOUNT,KRECVCOUNT,KNSEND,KNRECV,KSENDTOT,KRECVTOT,KSEND,KRECV,KINDEX,KNDOFF,KGPTRSEND,&
 & KPTRGP,PGP,PGPUV,PGP3A,PGP3B,PGP2, &
 & KSETAL, KSETBL,KSETWL,KSETVL)

USE PARKIND1  ,ONLY : JPIM     ,JPRB
USE TPM_DISTR ,ONLY : D, NPRTRNS, NPROC
USE TPM_TRANS ,ONLY : NGPBLKS

IMPLICIT NONE

INTEGER(KIND=JPIM), INTENT(IN) :: KF_FS,KF_GP
REAL(KIND=JPRB),INTENT(IN)     :: PGLAT(KF_FS,D%NLENGTF)
INTEGER(KIND=JPIM), INTENT(IN) :: KVSET(KF_GP)
INTEGER(KIND=JPIM), INTENT(IN) :: KF_SCALARS_G
INTEGER(KIND=JPIM), INTENT(IN) :: KSENDCOUNT
INTEGER(KIND=JPIM), INTENT(IN) :: KRECVCOUNT
INTEGER(KIND=JPIM), INTENT(IN) :: KNSEND
INTEGER(KIND=JPIM), INTENT(IN) :: KNRECV
INTEGER(KIND=JPIM), INTENT(IN) :: KSENDTOT (NPROC)
INTEGER(KIND=JPIM), INTENT(IN) :: KRECVTOT (NPROC)
INTEGER(KIND=JPIM), INTENT(IN) :: KSEND    (NPROC)
INTEGER(KIND=JPIM), INTENT(IN) :: KRECV    (NPROC)
INTEGER(KIND=JPIM), INTENT(IN) :: KINDEX(D%NLENGTF)
INTEGER(KIND=JPIM), INTENT(IN) :: KNDOFF(NPROC)
INTEGER(KIND=JPIM), INTENT(IN) :: KGPTRSEND(2,NGPBLKS,NPRTRNS)
INTEGER(KIND=JPIM) ,OPTIONAL, INTENT(IN) :: KPTRGP(:)
REAL(KIND=JPRB),OPTIONAL,INTENT(OUT)     :: PGP(:,:,:)
REAL(KIND=JPRB),OPTIONAL,INTENT(OUT)     :: PGPUV(:,:,:,:)
REAL(KIND=JPRB),OPTIONAL,INTENT(OUT)     :: PGP3A(:,:,:,:)
REAL(KIND=JPRB),OPTIONAL,INTENT(OUT)     :: PGP3B(:,:,:,:)
REAL(KIND=JPRB),OPTIONAL,INTENT(OUT)     :: PGP2(:,:,:)
INTEGER(KIND=JPIM), INTENT(IN) :: KSETAL(NPROC)
INTEGER(KIND=JPIM), INTENT(IN) :: KSETBL(NPROC)
INTEGER(KIND=JPIM), INTENT(IN) :: KSETWL(NPROC)
INTEGER(KIND=JPIM), INTENT(IN) :: KSETVL(NPROC)

REAL(KIND=JPRB), ALLOCATABLE, SAVE :: ZCOMBUFS_HEAP(:,:)
REAL(KIND=JPRB), ALLOCATABLE, SAVE :: ZCOMBUFR_HEAP(:,:)
INTEGER(KIND=JPIM), SAVE :: INRECV_PREV = -1
INTEGER(KIND=JPIM), SAVE :: INSEND_PREV = -1
INTEGER(KIND=JPIM), SAVE :: IRECVCOUNT_PREV = -1
INTEGER(KIND=JPIM), SAVE :: ISENDCOUNT_PREV = -1

IF ( .NOT. ALLOCATED(ZCOMBUFS_HEAP) ) THEN
  ALLOCATE(ZCOMBUFS_HEAP(-1:KSENDCOUNT,KNSEND))
  ISENDCOUNT_PREV = KSENDCOUNT
  INSEND_PREV = KNSEND
ELSEIF ( KSENDCOUNT .NE. ISENDCOUNT_PREV .OR. KNSEND .NE. INSEND_PREV ) THEN
  DEALLOCATE(ZCOMBUFS_HEAP)
  ALLOCATE(ZCOMBUFS_HEAP(-1:KSENDCOUNT,KNSEND))
  ISENDCOUNT_PREV = KSENDCOUNT
  INSEND_PREV = KNSEND
ENDIF

! Now, force the OS to allocate this shared array right now, not when it starts to be used which is
! an OPEN-MP loop, that would cause a threads synchronization lock :
IF (KNSEND > 0 .AND. KSENDCOUNT >= -1) ZCOMBUFS_HEAP(-1,1) = HUGE(1._JPRB)

IF ( .NOT. ALLOCATED(ZCOMBUFR_HEAP) ) THEN
  ALLOCATE(ZCOMBUFR_HEAP(-1:KRECVCOUNT,KNRECV))
  IRECVCOUNT_PREV = KRECVCOUNT
  INRECV_PREV = KNRECV
ELSEIF ( KRECVCOUNT .NE. IRECVCOUNT_PREV .OR. KNRECV .NE. INRECV_PREV ) THEN
  DEALLOCATE(ZCOMBUFR_HEAP)
  ALLOCATE(ZCOMBUFR_HEAP(-1:KRECVCOUNT,KNRECV))
  IRECVCOUNT_PREV = KRECVCOUNT
  INRECV_PREV = KNRECV
ENDIF

CALL TRLTOG_COMM(PGLAT,KF_FS,KF_GP,KF_SCALARS_G,KVSET,&
 & KSENDCOUNT,KRECVCOUNT,KNSEND,KNRECV,KSENDTOT,KRECVTOT,KSEND,KRECV,KINDEX,KNDOFF,KGPTRSEND,&
 & ZCOMBUFS_HEAP,ZCOMBUFR_HEAP, &
 & KPTRGP,PGP,PGPUV,PGP3A,PGP3B,PGP2, &
 & KSETAL, KSETBL,KSETWL,KSETVL)

END SUBROUTINE TRLTOG_COMM_HEAP

SUBROUTINE TRLTOG_COMM_STACK(PGLAT,KF_FS,KF_GP,KF_SCALARS_G,KVSET,&
 & KSENDCOUNT,KRECVCOUNT,KNSEND,KNRECV,KSENDTOT,KRECVTOT,KSEND,KRECV,KINDEX,KNDOFF,KGPTRSEND,&
 & KPTRGP,PGP,PGPUV,PGP3A,PGP3B,PGP2, &
 & KSETAL, KSETBL,KSETWL,KSETVL)

USE PARKIND1  ,ONLY : JPIM     ,JPRB
USE TPM_DISTR ,ONLY : D, NPRTRNS, NPROC
USE TPM_TRANS ,ONLY : NGPBLKS

IMPLICIT NONE

INTEGER(KIND=JPIM), INTENT(IN) :: KF_FS,KF_GP
REAL(KIND=JPRB),INTENT(IN)     :: PGLAT(KF_FS,D%NLENGTF)
INTEGER(KIND=JPIM), INTENT(IN) :: KVSET(KF_GP)
INTEGER(KIND=JPIM), INTENT(IN) :: KF_SCALARS_G
INTEGER(KIND=JPIM), INTENT(IN) :: KSENDCOUNT
INTEGER(KIND=JPIM), INTENT(IN) :: KRECVCOUNT
INTEGER(KIND=JPIM), INTENT(IN) :: KNSEND
INTEGER(KIND=JPIM), INTENT(IN) :: KNRECV
INTEGER(KIND=JPIM), INTENT(IN) :: KSENDTOT (NPROC)
INTEGER(KIND=JPIM), INTENT(IN) :: KRECVTOT (NPROC)
INTEGER(KIND=JPIM), INTENT(IN) :: KSEND    (NPROC)
INTEGER(KIND=JPIM), INTENT(IN) :: KRECV    (NPROC)
INTEGER(KIND=JPIM), INTENT(IN) :: KINDEX(D%NLENGTF)
INTEGER(KIND=JPIM), INTENT(IN) :: KNDOFF(NPROC)
INTEGER(KIND=JPIM), INTENT(IN) :: KGPTRSEND(2,NGPBLKS,NPRTRNS)
INTEGER(KIND=JPIM) ,OPTIONAL, INTENT(IN) :: KPTRGP(:)
REAL(KIND=JPRB),OPTIONAL,INTENT(OUT)     :: PGP(:,:,:)
REAL(KIND=JPRB),OPTIONAL,INTENT(OUT)     :: PGPUV(:,:,:,:)
REAL(KIND=JPRB),OPTIONAL,INTENT(OUT)     :: PGP3A(:,:,:,:)
REAL(KIND=JPRB),OPTIONAL,INTENT(OUT)     :: PGP3B(:,:,:,:)
REAL(KIND=JPRB),OPTIONAL,INTENT(OUT)     :: PGP2(:,:,:)
INTEGER(KIND=JPIM), INTENT(IN) :: KSETAL(NPROC)
INTEGER(KIND=JPIM), INTENT(IN) :: KSETBL(NPROC)
INTEGER(KIND=JPIM), INTENT(IN) :: KSETWL(NPROC)
INTEGER(KIND=JPIM), INTENT(IN) :: KSETVL(NPROC)

REAL(KIND=JPRB) :: ZCOMBUFS_STACK(-1:KSENDCOUNT,KNSEND)
REAL(KIND=JPRB) :: ZCOMBUFR_STACK(-1:KRECVCOUNT,KNRECV)

CALL TRLTOG_COMM(PGLAT,KF_FS,KF_GP,KF_SCALARS_G,KVSET,&
 & KSENDCOUNT,KRECVCOUNT,KNSEND,KNRECV,KSENDTOT,KRECVTOT,KSEND,KRECV,KINDEX,KNDOFF,KGPTRSEND,&
 & ZCOMBUFS_STACK,ZCOMBUFR_STACK, &
 & KPTRGP,PGP,PGPUV,PGP3A,PGP3B,PGP2, &
 & KSETAL, KSETBL,KSETWL,KSETVL)

END SUBROUTINE TRLTOG_COMM_STACK

SUBROUTINE TRLTOG_COMM(PGLAT,KF_FS,KF_GP,KF_SCALARS_G,KVSET,&
 & KSENDCOUNT,KRECVCOUNT,KNSEND,KNRECV,KSENDTOT,KRECVTOT,KSEND,KRECV,KINDEX,KNDOFF,KGPTRSEND,&
 & PCOMBUFS,PCOMBUFR, &
 & KPTRGP,PGP,PGPUV,PGP3A,PGP3B,PGP2, &
 & KSETAL, KSETBL,KSETWL,KSETVL)
 

!**** *trltog * - transposition of grid point data from latitudinal
!                 to column structure. This takes place between inverse
!                 FFT and grid point calculations.
!                 TRLTOG_COMM is the inverse of TRGTOL

!     Purpose.
!     --------

!**   Interface.
!     ----------
!        *call* *trltog(...)

!        Explicit arguments :
!        --------------------
!           PGLAT    -  Latitudinal data ready for direct FFT (input)
!           PGP    -  Blocked grid point data    (output)
!           KVSET    - "v-set" for each field      (input)

!        Implicit arguments :
!        --------------------

!     Method.
!     -------
!        See documentation

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

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

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

!     Modifications.
!     --------------
!        Original  : 95-10-01
!        D.Dent    : 97-08-04 Reorganisation to allow NPRTRV
!                             to differ from NPRGPEW
!        =99-03-29= Mats Hamrud and Deborah Salmond
!                   JUMP in FFT's changed to 1
!                   KINDEX introduced and PCOMBUF not used for same PE
!         01-11-23  Deborah Salmond and John Hague
!                   LIMP_NOOLAP Option for non-overlapping message passing
!                               and buffer packing
!         01-12-18  Peter Towers
!                   Improved vector performance of LTOG_PACK,LTOG_UNPACK
!         03-0-02   G. Radnoti: Call barrier always when nproc>1
!         08-01-01  G.Mozdzynski: cleanup
!         09-01-02  G.Mozdzynski: use non-blocking recv and send
!        R. El Khatib 09-Sep-2020 64 bits addressing for PGLAT
!     ------------------------------------------------------------------

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

USE MPL_MODULE  ,ONLY : MPL_RECV, MPL_SEND, MPL_WAIT, JP_NON_BLOCKING_STANDARD, MPL_WAITANY, &
     & JP_BLOCKING_STANDARD, MPL_BARRIER, JP_BLOCKING_BUFFERED

USE TPM_GEN         ,ONLY : NOUT, NTRANS_SYNC_LEVEL
USE TPM_DISTR       ,ONLY : D, MYSETV, MYSETW, MTAGLG,      &
     &                      NPRCIDS, NPRTRNS, MYPROC, NPROC
USE TPM_TRANS       ,ONLY : LDIVGP, LSCDERS, LUVDER, LVORGP, NGPBLKS

USE PE2SET_MOD      ,ONLY : PE2SET
USE ABORT_TRANS_MOD ,ONLY : ABORT_TRANS

IMPLICIT NONE


INTEGER(KIND=JPIM), INTENT(IN) :: KF_FS,KF_GP
REAL(KIND=JPRB),INTENT(IN)     :: PGLAT(KF_FS,D%NLENGTF)
INTEGER(KIND=JPIM), INTENT(IN) :: KVSET(KF_GP)
INTEGER(KIND=JPIM), INTENT(IN) :: KF_SCALARS_G
INTEGER(KIND=JPIM), INTENT(IN) :: KSENDCOUNT
INTEGER(KIND=JPIM), INTENT(IN) :: KRECVCOUNT
INTEGER(KIND=JPIM), INTENT(IN) :: KNSEND
INTEGER(KIND=JPIM), INTENT(IN) :: KNRECV
INTEGER(KIND=JPIM), INTENT(IN) :: KSENDTOT (NPROC)
INTEGER(KIND=JPIM), INTENT(IN) :: KRECVTOT (NPROC)
INTEGER(KIND=JPIM), INTENT(IN) :: KSEND    (NPROC)
INTEGER(KIND=JPIM), INTENT(IN) :: KRECV    (NPROC)
INTEGER(KIND=JPIM), INTENT(IN) :: KINDEX(D%NLENGTF)
INTEGER(KIND=JPIM), INTENT(IN) :: KNDOFF(NPROC)
INTEGER(KIND=JPIM), INTENT(IN) :: KGPTRSEND(2,NGPBLKS,NPRTRNS)
REAL(KIND=JPRB), INTENT(INOUT) :: PCOMBUFS(-1:KSENDCOUNT,KNSEND)
REAL(KIND=JPRB), INTENT(INOUT) :: PCOMBUFR(-1:KRECVCOUNT,KNRECV)
INTEGER(KIND=JPIM) ,OPTIONAL, INTENT(IN) :: KPTRGP(:)
REAL(KIND=JPRB),OPTIONAL,INTENT(OUT)     :: PGP(:,:,:)
REAL(KIND=JPRB),OPTIONAL,INTENT(OUT)     :: PGPUV(:,:,:,:)
REAL(KIND=JPRB),OPTIONAL,INTENT(OUT)     :: PGP3A(:,:,:,:)
REAL(KIND=JPRB),OPTIONAL,INTENT(OUT)     :: PGP3B(:,:,:,:)
REAL(KIND=JPRB),OPTIONAL,INTENT(OUT)     :: PGP2(:,:,:)
INTEGER(KIND=JPIM), INTENT(IN) :: KSETAL(NPROC)
INTEGER(KIND=JPIM), INTENT(IN) :: KSETBL(NPROC)
INTEGER(KIND=JPIM), INTENT(IN) :: KSETWL(NPROC)
INTEGER(KIND=JPIM), INTENT(IN) :: KSETVL(NPROC)

! LOCAL VARIABLES

INTEGER(KIND=JPIM) :: IPOSPLUS(KNRECV)
INTEGER(KIND=JPIM) :: ISETW(KNRECV)
INTEGER(KIND=JPIM) :: JPOS(NGPBLKS,KNRECV)
INTEGER(KIND=JPIM) :: IFLDA(KF_GP,KNRECV)
INTEGER(KIND=JPIM) :: IREQ_SEND(NPROC)
INTEGER(KIND=JPIM) :: IREQ_RECV(NPROC)

INTEGER(KIND=JPIM) :: IFIRST, IFLD, ILAST, IPOS, ISETA, ISETB, IRECV, ISETV
INTEGER(KIND=JPIM) :: ISEND, ITAG,  JBLK, JFLD, JK, JL, IFLDS, INR, INS
INTEGER(KIND=JPIM) :: II,ILEN, IFLDT, JI, JJ, J

INTEGER(KIND=JPIB) :: JFLD64

LOGICAL   :: LLPGPUV,LLPGP3A,LLPGP3B,LLPGP2,LLPGPONLY
LOGICAL   :: LLUV(KF_GP),LLGP2(KF_GP),LLGP3A(KF_GP),LLGP3B(KF_GP)
LOGICAL   :: LLINDER
INTEGER(KIND=JPIM) :: IUVLEVS(KF_GP),IUVPARS(KF_GP),IGP2PARS(KF_GP)
INTEGER(KIND=JPIM) :: IGP3APARS(KF_GP),IGP3ALEVS(KF_GP),IGP3BPARS(KF_GP),IGP3BLEVS(KF_GP)
INTEGER(KIND=JPIM) :: IUVPAR,IUVLEV,IGP2PAR,IGP3ALEV,IGP3APAR,IGP3BLEV,IGP3BPAR,IPAROFF
INTEGER(KIND=JPIM) :: IOFF,IOFF1,IOFFNS,IOFFEW,J1,J2, JNR
INTEGER(KIND=JPIM) :: IFLDOFF(KF_FS)
INTEGER(KIND=JPIM) :: IRECV_FLD_START,IRECV_FLD_END
INTEGER(KIND=JPIM) :: ISEND_FLD_START,ISEND_FLD_END
INTEGER(KIND=JPIM) :: IGPTROFF(NGPBLKS)

REAL(KIND=JPHOOK) :: ZHOOK_HANDLE_BAR

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

!*       0.    Some initializations
!              --------------------

ITAG   = MTAGLG

IF (LHOOK) CALL DR_HOOK('TRLTOG_BAR',0,ZHOOK_HANDLE_BAR)
CALL GSTATS_BARRIER(762)
IF (LHOOK) CALL DR_HOOK('TRLTOG_BAR',1,ZHOOK_HANDLE_BAR)

CALL GSTATS(805,0)

IF (NTRANS_SYNC_LEVEL <= 0) THEN
   !...Receive loop.........................................................
   DO INR=1,KNRECV
      IRECV=KRECV(INR)
      CALL MPL_RECV(PCOMBUFR(-1:KRECVTOT(IRECV),INR), &
           & KSOURCE=NPRCIDS(IRECV), &
           & KMP_TYPE=JP_NON_BLOCKING_STANDARD,KREQUEST=IREQ_RECV(INR), &
           & KTAG=ITAG,CDSTRING='TRLTOG_COMM: NON-BLOCKING IRECV' )
   ENDDO
ENDIF

CALL GSTATS(805,1)

CALL GSTATS(1806,0)
LLINDER = .FALSE.
LLPGPUV = .FALSE.
LLPGP3A = .FALSE.
LLPGP3B = .FALSE.
LLPGP2  = .FALSE.
LLPGPONLY = .FALSE.
IF(PRESENT(KPTRGP))  LLINDER = .TRUE.
IF(PRESENT(PGP))     LLPGPONLY=.TRUE.
IF(PRESENT(PGPUV))   LLPGPUV=.TRUE.
IF(PRESENT(PGP3A))   LLPGP3A=.TRUE.
IF(PRESENT(PGP3B))   LLPGP3B=.TRUE.
IF(PRESENT(PGP2))    LLPGP2=.TRUE.

IUVPAR=0
IUVLEV=0
IOFF1=0
IOFFNS=KF_SCALARS_G
IOFFEW=2*KF_SCALARS_G

LLUV(:) = .FALSE.
IF (LLPGPUV) THEN
  IOFF=0
  IUVLEV=UBOUND(PGPUV,2)
  IF(LVORGP) THEN
    IUVPAR=IUVPAR+1
    DO J=1,IUVLEV
      IUVLEVS(IOFF+J)=J
      IUVPARS(IOFF+J)=IUVPAR
      LLUV(IOFF+J)=.TRUE.
    ENDDO
    IOFF=IOFF+IUVLEV
  ENDIF
  IF(LDIVGP) THEN
    IUVPAR=IUVPAR+1
    DO J=1,IUVLEV
      IUVLEVS(IOFF+J)=J
      IUVPARS(IOFF+J)=IUVPAR
      LLUV(IOFF+J)=.TRUE.
    ENDDO
    IOFF=IOFF+IUVLEV
  ENDIF
  DO J=1,IUVLEV
    IUVLEVS(IOFF+J)=J
    IUVPARS(IOFF+J)=IUVPAR+1
    IUVLEVS(IOFF+J+IUVLEV)=J
    IUVPARS(IOFF+J+IUVLEV)=IUVPAR+2
  ENDDO
  IUVPAR=IUVPAR+2
  LLUV(IOFF+1:IOFF+2*IUVLEV)=.TRUE.
  IOFF=IOFF+2*IUVLEV
  IOFF1=IOFF
  IOFFNS=IOFFNS+IOFF
  IOFFEW=IOFFEW+IOFF

  IOFF=IUVPAR*IUVLEV+KF_SCALARS_G
  IF(LUVDER) THEN
    IF(LSCDERS) IOFF=IOFF+KF_SCALARS_G
    DO J=1,IUVLEV
      IUVLEVS(IOFF+J)=J
      IUVPARS(IOFF+J)=IUVPAR+1
      LLUV(IOFF+J)=.TRUE.
      IUVLEVS(IOFF+J+IUVLEV)=J
      IUVPARS(IOFF+J+IUVLEV)=IUVPAR+2
      LLUV(IOFF+J+IUVLEV)=.TRUE.
    ENDDO
    IUVPAR=IUVPAR+2
    IOFF=IOFF+2*IUVLEV
    IOFFEW=IOFFEW+2*IUVLEV
  ENDIF
ENDIF

LLGP2(:)=.FALSE.
IF(LLPGP2) THEN
  IOFF=IOFF1
  IGP2PAR=UBOUND(PGP2,2)
  IF(LSCDERS) IGP2PAR=IGP2PAR/3
  DO J=1,IGP2PAR
    LLGP2(J+IOFF) = .TRUE.
    IGP2PARS(J+IOFF)=J
  ENDDO
  IOFF1=IOFF1+IGP2PAR
  IF(LSCDERS) THEN
    IOFF=IOFFNS
    DO J=1,IGP2PAR
      LLGP2(J+IOFF) = .TRUE.
      IGP2PARS(J+IOFF)=J+IGP2PAR
    ENDDO
    IOFFNS=IOFF+IGP2PAR
    IOFF=IOFFEW
    DO J=1,IGP2PAR
      LLGP2(J+IOFF) = .TRUE.
      IGP2PARS(J+IOFF)=J+2*IGP2PAR
    ENDDO
    IOFFEW=IOFF+IGP2PAR
  ENDIF
ENDIF

LLGP3A(:) = .FALSE.
IF(LLPGP3A) THEN
  IGP3ALEV=UBOUND(PGP3A,2)
  IGP3APAR=UBOUND(PGP3A,3)
  IF(LSCDERS) IGP3APAR=IGP3APAR/3
  IOFF=IOFF1
  DO J1=1,IGP3APAR
    DO J2=1,IGP3ALEV
      LLGP3A(J2+(J1-1)*IGP3ALEV+IOFF) = .TRUE.
      IGP3APARS(J2+(J1-1)*IGP3ALEV+IOFF)=J1
      IGP3ALEVS(J2+(J1-1)*IGP3ALEV+IOFF)=J2
    ENDDO
  ENDDO
  IPAROFF=IGP3APAR
  IOFF1=IOFF1+IGP3APAR*IGP3ALEV
  IF(LSCDERS) THEN
    IOFF=IOFFNS
    DO J1=1,IGP3APAR
      DO J2=1,IGP3ALEV
        LLGP3A(J2+(J1-1)*IGP3ALEV+IOFF) = .TRUE.
        IGP3APARS(J2+(J1-1)*IGP3ALEV+IOFF)=J1+IPAROFF
        IGP3ALEVS(J2+(J1-1)*IGP3ALEV+IOFF)=J2
      ENDDO
    ENDDO
    IPAROFF=IPAROFF+IGP3APAR
    IOFFNS=IOFFNS+IGP3APAR*IGP3ALEV
    IOFF=IOFFEW
    DO J1=1,IGP3APAR
      DO J2=1,IGP3ALEV
        LLGP3A(J2+(J1-1)*IGP3ALEV+IOFF) = .TRUE.
        IGP3APARS(J2+(J1-1)*IGP3ALEV+IOFF)=J1+IPAROFF
        IGP3ALEVS(J2+(J1-1)*IGP3ALEV+IOFF)=J2
      ENDDO
    ENDDO
    IOFFEW=IOFFEW+IGP3APAR*IGP3ALEV
  ENDIF
ENDIF

LLGP3B(:) = .FALSE.
IF(LLPGP3B) THEN
  IGP3BLEV=UBOUND(PGP3B,2)
  IGP3BPAR=UBOUND(PGP3B,3)
  IF(LSCDERS) IGP3BPAR=IGP3BPAR/3
  IOFF=IOFF1
  DO J1=1,IGP3BPAR
    DO J2=1,IGP3BLEV
      LLGP3B(J2+(J1-1)*IGP3BLEV+IOFF) = .TRUE.
      IGP3BPARS(J2+(J1-1)*IGP3BLEV+IOFF)=J1
      IGP3BLEVS(J2+(J1-1)*IGP3BLEV+IOFF)=J2
    ENDDO
  ENDDO
  IPAROFF=IGP3BPAR
  IOFF1=IOFF1+IGP3BPAR*IGP3BLEV
  IF(LSCDERS) THEN
    IOFF=IOFFNS
    DO J1=1,IGP3BPAR
      DO J2=1,IGP3BLEV
        LLGP3B(J2+(J1-1)*IGP3BLEV+IOFF) = .TRUE.
        IGP3BPARS(J2+(J1-1)*IGP3BLEV+IOFF)=J1+IPAROFF
        IGP3BLEVS(J2+(J1-1)*IGP3BLEV+IOFF)=J2
      ENDDO
    ENDDO
    IPAROFF=IPAROFF+IGP3BPAR
    IOFFNS=IOFFNS+IGP3BPAR*IGP3BLEV
    IOFF=IOFFEW
    DO J1=1,IGP3BPAR
      DO J2=1,IGP3BLEV
        LLGP3B(J2+(J1-1)*IGP3BLEV+IOFF) = .TRUE.
        IGP3BPARS(J2+(J1-1)*IGP3BLEV+IOFF)=J1+IPAROFF
        IGP3BLEVS(J2+(J1-1)*IGP3BLEV+IOFF)=J2
      ENDDO
    ENDDO
    IOFFEW=IOFFEW+IGP3BPAR*IGP3BLEV
  ENDIF
ENDIF  

CALL GSTATS(1806,1)


! Copy local contribution
IF( KRECVTOT(MYPROC) > 0 )THEN
  IFLDS = 0
  DO JFLD=1,KF_GP
    IF(KVSET(JFLD) == MYSETV .OR. KVSET(JFLD) == -1) THEN
      IFLDS = IFLDS+1
      IF(LLINDER) THEN
        IFLDOFF(IFLDS) = KPTRGP(JFLD)
      ELSE
        IFLDOFF(IFLDS) = JFLD
      ENDIF
    ENDIF
  ENDDO

  IPOS=0
  DO JBLK=1,NGPBLKS
    IGPTROFF(JBLK)=IPOS
    IFIRST = KGPTRSEND(1,JBLK,MYSETW)
    IF(IFIRST > 0) THEN
      ILAST = KGPTRSEND(2,JBLK,MYSETW)
      IPOS=IPOS+ILAST-IFIRST+1
    ENDIF
  ENDDO

  CALL GSTATS(1604,0)
#ifdef __NEC__
! Loops inversion is still better on Aurora machines, according to CHMI. REK.
!$OMP PARALLEL DO SCHEDULE(DYNAMIC) PRIVATE(JFLD64,JBLK,JK,IFLD,IPOS,IFIRST,ILAST)
#else
!$OMP PARALLEL DO SCHEDULE(STATIC) PRIVATE(JFLD64,JBLK,JK,IFLD,IPOS,IFIRST,ILAST)
#endif
  DO JBLK=1,NGPBLKS
    IFIRST = KGPTRSEND(1,JBLK,MYSETW)
    IF(IFIRST > 0) THEN
      ILAST = KGPTRSEND(2,JBLK,MYSETW)
! Address PGLAT over 64 bits because its size may exceed 2 GB for big data and
! small number of tasks.
      IF(LLPGPONLY) THEN
        DO JFLD64=1,IFLDS
          IFLD = IFLDOFF(JFLD64)
!DIR$ VECTOR ALWAYS
          DO JK=IFIRST,ILAST
            IPOS = KNDOFF(MYPROC)+IGPTROFF(JBLK)+JK-IFIRST+1
            PGP(JK,IFLD,JBLK) = PGLAT(JFLD64,KINDEX(IPOS))
          ENDDO
        ENDDO
      ELSE
        DO JFLD64=1,IFLDS
          IFLD = IFLDOFF(JFLD64)
          IF(LLUV(IFLD)) THEN
!DIR$ VECTOR ALWAYS
            DO JK=IFIRST,ILAST
              IPOS = KNDOFF(MYPROC)+IGPTROFF(JBLK)+JK-IFIRST+1
              PGPUV(JK,IUVLEVS(IFLD),IUVPARS(IFLD),JBLK) = PGLAT(JFLD64,KINDEX(IPOS))
            ENDDO
          ELSEIF(LLGP2(IFLD)) THEN
!DIR$ VECTOR ALWAYS
            DO JK=IFIRST,ILAST
              IPOS = KNDOFF(MYPROC)+IGPTROFF(JBLK)+JK-IFIRST+1
              PGP2(JK,IGP2PARS(IFLD),JBLK)=PGLAT(JFLD64,KINDEX(IPOS))
            ENDDO
          ELSEIF(LLGP3A(IFLD)) THEN
!DIR$ VECTOR ALWAYS
            DO JK=IFIRST,ILAST
              IPOS = KNDOFF(MYPROC)+IGPTROFF(JBLK)+JK-IFIRST+1
              PGP3A(JK,IGP3ALEVS(IFLD),IGP3APARS(IFLD),JBLK)=PGLAT(JFLD64,KINDEX(IPOS))
            ENDDO
          ELSEIF(LLGP3B(IFLD)) THEN
!DIR$ VECTOR ALWAYS
            DO JK=IFIRST,ILAST
              IPOS = KNDOFF(MYPROC)+IGPTROFF(JBLK)+JK-IFIRST+1
              PGP3B(JK,IGP3BLEVS(IFLD),IGP3BPARS(IFLD),JBLK)=PGLAT(JFLD64,KINDEX(IPOS))
            ENDDO
          ELSE
            WRITE(NOUT,*)'TRLTOG_MOD: ERROR',JFLD64,IFLD
            CALL ABORT_TRANS('TRLTOG_MOD: ERROR')
          ENDIF
        ENDDO
      ENDIF
    ENDIF
  ENDDO
!$OMP END PARALLEL DO
  CALL GSTATS(1604,1)

ENDIF

!
! loop over the number of processors we need to communicate with.
! NOT MYPROC
!
! Now overlapping buffer packing/unpacking with sends/waits
! Time as if all communications to avoid double accounting

CALL GSTATS(805,0)

!  Pack+send loop.........................................................

ISEND_FLD_START = 1
ISEND_FLD_END   = KF_FS
DO INS=1,KNSEND
  ISEND=KSEND(INS)
  ILEN = KSENDTOT(ISEND)/KF_FS
!$OMP PARALLEL DO SCHEDULE(STATIC) PRIVATE(JFLD,JL,II)
  DO JL=1,ILEN
    II = KINDEX(KNDOFF(ISEND)+JL)
    DO JFLD=ISEND_FLD_START,ISEND_FLD_END
      PCOMBUFS((JFLD-ISEND_FLD_START)*ILEN+JL,INS) = PGLAT(JFLD,II)
    ENDDO
  ENDDO
!$OMP END PARALLEL DO
  PCOMBUFS(-1,INS) = 1
  PCOMBUFS(0,INS)  = KF_FS
  IF (NTRANS_SYNC_LEVEL <= 1) THEN
     CALL MPL_SEND(PCOMBUFS(-1:KSENDTOT(ISEND),INS),KDEST=NPRCIDS(ISEND),&
          & KMP_TYPE=JP_NON_BLOCKING_STANDARD,KREQUEST=IREQ_SEND(INS), &
          & KTAG=ITAG,CDSTRING='TRLTOG_COMM: NON-BLOCKING ISEND')
  ELSE
     CALL MPL_SEND(PCOMBUFS(-1:KSENDTOT(ISEND),INS),KDEST=NPRCIDS(ISEND),&
          & KMP_TYPE=JP_BLOCKING_BUFFERED, &
          & KTAG=ITAG,CDSTRING='TRLTOG_COMM: BLOCKING BUFFERED BSEND')
  ENDIF
ENDDO

!  Unpack loop.........................................................

!$OMP PARALLEL DO SCHEDULE(STATIC) PRIVATE(INR,IRECV,ISETA,ISETB,ISETV,IFLD,JFLD,IPOS,JBLK,IFIRST,ILAST)
DO INR=1,KNRECV
  IRECV=KRECV(INR)
  
  ISETA=KSETAL(IRECV)
  ISETB=KSETBL(IRECV)
  ISETW(INR)=KSETWL(IRECV)
  ISETV=KSETVL(IRECV)
  IFLD = 0
  DO JFLD=1,KF_GP
    IF(KVSET(JFLD) == ISETV .OR. KVSET(JFLD) == -1 ) THEN
      IFLD = IFLD+1
      IFLDA(IFLD,INR)=JFLD
    ENDIF
  ENDDO
  IPOS = 0
  IPOSPLUS(INR)=0
  DO JBLK=1,NGPBLKS
    IFIRST = KGPTRSEND(1,JBLK,ISETW(INR))
    IF(IFIRST > 0) THEN
      ILAST = KGPTRSEND(2,JBLK,ISETW(INR))
      JPOS(JBLK,INR)=IPOS
      IPOSPLUS(INR)=IPOSPLUS(INR)+(ILAST-IFIRST+1)
      IPOS=IPOS+(ILAST-IFIRST+1)
    ENDIF
  ENDDO
ENDDO
!$OMP END PARALLEL DO

DO JNR=1,KNRECV
  
  IF (NTRANS_SYNC_LEVEL <= 0) THEN
     CALL MPL_WAITANY(KREQUEST=IREQ_RECV(1:KNRECV),KINDEX=INR,&
          & CDSTRING='TRLTOG_COMM: WAIT FOR ANY RECEIVES')
  ELSE
     INR = JNR
     IRECV=KRECV(INR)
     CALL MPL_RECV(PCOMBUFR(-1:KRECVTOT(IRECV),INR), &
          & KSOURCE=NPRCIDS(IRECV), &
          & KMP_TYPE=JP_BLOCKING_STANDARD, &
          & KTAG=ITAG,CDSTRING='TRLTOG_COMM: BLOCKING RECV' )
  ENDIF

  IPOS=IPOSPLUS(INR)
  IRECV_FLD_START = PCOMBUFR(-1,INR)
  IRECV_FLD_END   = PCOMBUFR(0,INR)
  
!$OMP PARALLEL DO SCHEDULE(STATIC) PRIVATE(IFLDT,IFIRST,ILAST,JK,JJ,JI,JBLK)
  DO JJ=IRECV_FLD_START,IRECV_FLD_END
    IFLDT=IFLDA(JJ,INR)
    DO JBLK=1,NGPBLKS
      IFIRST = KGPTRSEND(1,JBLK,ISETW(INR))
      IF(IFIRST > 0) THEN
        ILAST = KGPTRSEND(2,JBLK,ISETW(INR))
        IF(LLINDER) THEN
          DO JK=IFIRST,ILAST
            JI=(JJ-IRECV_FLD_START)*IPOS+JPOS(JBLK,INR)+JK-IFIRST+1
            PGP(JK,KPTRGP(IFLDT),JBLK) = PCOMBUFR(JI,INR)
          ENDDO
        ELSEIF(LLPGPONLY) THEN
          DO JK=IFIRST,ILAST
            JI=(JJ-IRECV_FLD_START)*IPOS+JPOS(JBLK,INR)+JK-IFIRST+1
            PGP(JK,IFLDT,JBLK) = PCOMBUFR(JI,INR)
          ENDDO
        ELSEIF(LLUV(IFLDT)) THEN
          DO JK=IFIRST,ILAST
            JI=(JJ-IRECV_FLD_START)*IPOS+JPOS(JBLK,INR)+JK-IFIRST+1
            PGPUV(JK,IUVLEVS(IFLDT),IUVPARS(IFLDT),JBLK) = PCOMBUFR(JI,INR)
          ENDDO
        ELSEIF(LLGP2(IFLDT)) THEN
          DO JK=IFIRST,ILAST
            JI=(JJ-IRECV_FLD_START)*IPOS+JPOS(JBLK,INR)+JK-IFIRST+1
            PGP2(JK,IGP2PARS(IFLDT),JBLK) = PCOMBUFR(JI,INR)
          ENDDO
        ELSEIF(LLGP3A(IFLDT)) THEN
          DO JK=IFIRST,ILAST
            JI=(JJ-IRECV_FLD_START)*IPOS+JPOS(JBLK,INR)+JK-IFIRST+1
            PGP3A(JK,IGP3ALEVS(IFLDT),IGP3APARS(IFLDT),JBLK) = PCOMBUFR(JI,INR)
          ENDDO
        ELSEIF(LLGP3B(IFLDT)) THEN
          DO JK=IFIRST,ILAST
            JI=(JJ-IRECV_FLD_START)*IPOS+JPOS(JBLK,INR)+JK-IFIRST+1
            PGP3B(JK,IGP3BLEVS(IFLDT),IGP3BPARS(IFLDT),JBLK) = PCOMBUFR(JI,INR)
          ENDDO
        ENDIF
      ENDIF
    ENDDO
  ENDDO
!$OMP END PARALLEL DO
ENDDO

IF (NTRANS_SYNC_LEVEL <= 1) THEN
   IF(KNSEND > 0) THEN
      CALL MPL_WAIT(KREQUEST=IREQ_SEND(1:KNSEND),CDSTRING='TRLTOG_COMM: WAIT FOR ISENDS')
   ENDIF
ENDIF

IF (NTRANS_SYNC_LEVEL >= 1) THEN
   CALL MPL_BARRIER(CDSTRING='TRLTOG_COMM: BARRIER AT END')
ENDIF

CALL GSTATS(805,1)

CALL GSTATS_BARRIER2(762)

END SUBROUTINE TRLTOG_COMM
END MODULE TRLTOG_MOD
