SUBROUTINE TRMTOS(PSPVOR,PSPDIV,PSPT,PSPSPD,PSPSVD,PSPSNHX, &
 & PSPGFL,PSPSP,PSPAUX,PSPSEL3D,PSPSEL2D, &
 & PSPVORG,PSPDIVG,PSPTG,PSPSPDG,PSPSVDG,PSPSNHXG, &
 & PSPGFLG,PSPSPG,PSPAUXG,PSPSEL3DG,PSPSEL2DG, &
 & LDSELECT3D,LDSELECT2D,LDFULLM)  

!**** *trmtos * - Transposition from horizontal to vertical spectral
!                 coefficients

!     Purpose.
!     --------
!              Transpose data from SPXX arrays to SPxxG arrays.
!              The semi-implicit calculations require vertical
!              columns of PSPT, PSPDIV, and PSPSP.
!              This is done during the spectral space calculations.
!              Also used in Jb calculations.
!              This routine is the inverse of TRSTOM.


!**   Interface.
!     ----------
!        *call* *trmtos

!        Explicit arguments :
!        --------------------
!          PSPVOR     -  distributed vorticity
!          PSPDIV     -  distributed divergence
!          PSPT       -  distributed temperature
!          PSPSPD     -  distributed NH pressure departure variable
!          PSPSVD     -  distributed NH vertical divergence variable
!          PSPSNHX    -  distributed NH "X" part divergence variable
!          PSPGFL     -  distributed spectral GFL
!          PSPSP      -  distributed surface pressure
!          PSPAUX     -  distributed auxiliary field
!          PSPSEL3D   -  3d fields for selection
!          PSPSEL2D   -  2d fields for selection
!          PSPVORG    -  vorticity columns
!          PSPDIVG    -  divergence columns
!          PSPTG      -  temperature columns
!          PSPSPDG    -  NH pressure departure variable columns
!          PSPSVDG    -  NH vertical divergence variable columns
!          PSPSNHXG   -  NH "X" part divergence variable columns
!          PSPGFLG    -  GFL columns
!          PSPSPG     -  surface pressure
!          PSPAUX     -  auxiliary field columns
!          PSPSEL3DG  -  selected 3d fields
!          PSPSEL2DG  -  selected 2d fields
!          LDSELECT3D - .T.=> select this 3d field
!          LDSELECT2D - .T.=> select this 2d field
!          LDFULLM    - .T. if full m-columns are used

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

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

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

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

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

!     Modifications.
!     --------------
!        Original       : 95-10-01 
!        L. Isaksen     : 96-02-20 NFLSURL,NFLSURG -> NFLSUR,NFLEVG
!        L. Isaksen     : 96-05-05 Use for cvar-calculations too (KTYPE),
!                                  interface block ,change data strucure
!        L. Isaksen     : 96-12-12 New KTYPE added
!        E. Holm        : 97-08-20 Ozone included
!        D.Dent         : 00-09-01 MPE to MPL conversion
!        D.Salmond      : 01-11-23 LIMP_NOOLAP Option for non-overlapping
!                                  message passing and buffer packing
!        M.Hamrud       : 03-10-01 CY28 Cleaning
!        M.Hamrud       : 03-12-01 CY28R1 Cleaning
!        K. Yessad      : 05-02-08 NH variables + cleaning
!        L. Isaksen     : 04-09-01 Optional arguments, more flexible
!        M. Fisher      : 05-08-22 Even more flexible (selected 2d,3d fields)
!        G. Mozdzynski  : 08-01-01 Cleanup
!        F. Vana + NEC  : 08-09-09 optimization
!        T. Wilhelmsson : 09-09-22 Add auxiliary field
!     ------------------------------------------------------------------

USE PARKIND1  ,ONLY : JPIM     ,JPRB

USE YOMHOOK   ,ONLY : LHOOK,   DR_HOOK
USE YOMDIM   , ONLY : NFLEVL   ,NFLEVG
USE YOMCT0   , ONLY : LNHDYN   ,NPRTRV   ,NPRTRN
USE YOMDYNA  , ONLY : LNHX
USE YOMMP    , ONLY : NPRCIDS  ,NPTRSV   , &
 & MYSETV   ,MYSETN   ,NPTRSVF  ,NPTRLL   ,&
 & NPSURF   ,NPSP     ,NSPEC2V  ,NSPEC2VF ,&
 & MYSETW   ,MYSETM
USE YOMTAG   , ONLY : MTAGMS
USE YOMLUN   , ONLY : NULOUT
USE MPL_MODULE  , ONLY : MPL_SEND, MPL_RECV, MPL_WAIT,&
 & JP_NON_BLOCKING_STANDARD

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

IMPLICIT NONE

REAL(KIND=JPRB)   ,OPTIONAL, INTENT(IN)    :: PSPVOR(:,:) 
REAL(KIND=JPRB)   ,OPTIONAL, INTENT(IN)    :: PSPDIV(:,:) 
REAL(KIND=JPRB)   ,OPTIONAL, INTENT(IN)    :: PSPT(:,:) 
REAL(KIND=JPRB)   ,OPTIONAL, INTENT(IN)    :: PSPSPD(:,:) 
REAL(KIND=JPRB)   ,OPTIONAL, INTENT(IN)    :: PSPSVD(:,:) 
REAL(KIND=JPRB)   ,OPTIONAL, INTENT(IN)    :: PSPSNHX(:,:) 
REAL(KIND=JPRB)   ,OPTIONAL, INTENT(IN)    :: PSPGFL(:,:,:) 
REAL(KIND=JPRB)   ,OPTIONAL, INTENT(IN)    :: PSPSP(:) 
REAL(KIND=JPRB)   ,OPTIONAL, INTENT(IN)    :: PSPAUX(:,:) 
REAL(KIND=JPRB)   ,OPTIONAL, INTENT(IN)    :: PSPSEL3D(:,:,:) 
REAL(KIND=JPRB)   ,OPTIONAL, INTENT(IN)    :: PSPSEL2D(:,:) 
REAL(KIND=JPRB)   ,OPTIONAL, INTENT(OUT)   :: PSPVORG(:,:) 
REAL(KIND=JPRB)   ,OPTIONAL, INTENT(OUT)   :: PSPDIVG(:,:) 
REAL(KIND=JPRB)   ,OPTIONAL, INTENT(OUT)   :: PSPTG(:,:) 
REAL(KIND=JPRB)   ,OPTIONAL, INTENT(OUT)   :: PSPSPDG(:,:) 
REAL(KIND=JPRB)   ,OPTIONAL, INTENT(OUT)   :: PSPSVDG(:,:) 
REAL(KIND=JPRB)   ,OPTIONAL, INTENT(OUT)   :: PSPSNHXG(:,:) 
REAL(KIND=JPRB)   ,OPTIONAL, INTENT(INOUT) :: PSPGFLG(:,:,:) 
REAL(KIND=JPRB)   ,OPTIONAL, INTENT(OUT)   :: PSPSPG(:) 
REAL(KIND=JPRB)   ,OPTIONAL, INTENT(OUT)   :: PSPAUXG(:,:) 
REAL(KIND=JPRB)   ,OPTIONAL, INTENT(INOUT) :: PSPSEL3DG(:,:,:) 
REAL(KIND=JPRB)   ,OPTIONAL, INTENT(INOUT) :: PSPSEL2DG(:,:) 
LOGICAL           ,OPTIONAL, INTENT(IN)    :: LDSELECT3D(:)
LOGICAL           ,OPTIONAL, INTENT(IN)    :: LDSELECT2D(:)
LOGICAL           ,OPTIONAL, INTENT(IN)    :: LDFULLM 

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

REAL(KIND=JPRB),ALLOCATABLE :: ZCOMBUFS(:,:),ZCOMBUFR(:,:)
INTEGER(KIND=JPIM) :: IPTRSV(NPRTRV+1)
INTEGER(KIND=JPIM) :: ISENT    (NPRTRV-1)
INTEGER(KIND=JPIM) :: IRCVD    (NPRTRV-1)
INTEGER(KIND=JPIM) :: ISENDTOT (NPRTRV-1)
INTEGER(KIND=JPIM) :: IRECVTOT (NPRTRV-1)
INTEGER(KIND=JPIM) :: ISENDREQ (2*NPRTRV-1)
INTEGER(KIND=JPIM) :: ISEND_START (NPRTRV-1)
INTEGER(KIND=JPIM) :: ISEND_TOTAL (NPRTRV-1)
INTEGER(KIND=JPIM) :: IBUFLEFT (NPRTRV-1)
INTEGER(KIND=JPIM) :: IRECV_START
INTEGER(KIND=JPIM) :: IRECV_END

LOGICAL :: LLVOR, LLDIV, LLT, LLSPD, LLSVD, LLGFL,&
         & LLSP, LLAUX, LLSEL3D, LLSEL2D, LLFULLM, LLSNHX
INTEGER(KIND=JPIM) :: IPOS, IRECV, IRECVSET,&
 & ISEND, ISENDSET, ISP, ISPEC2V, ISPECMIN, IL1, IL2, ILN, &
 & JL, JROCB, JR, JVERSP, ILEV, IISP, IBUFLENR, IBUFLENS, &
 & IHEAD, ISPNUM, ISEL, JFIELD
INTEGER(KIND=JPIM) :: IMINIMUM (NPRTRV-1), JPOS(NPRTRV-1)
INTEGER(KIND=JPIM) :: ISENDCOUNT,IRECVCOUNT,J,INSEND,INRECV
INTEGER(KIND=JPIM) :: JSEND(NPRTRV-1),JRECV(NPRTRV-1)

INTEGER(KIND=JPIM) :: MYSENDSET,MYRECVSET,INUMSPGFL,INUMSEL3D,INUMSEL2D
INTEGER(KIND=JPIM) :: IR
REAL(KIND=JPRB) :: ZDUM(2)
REAL(KIND=JPRB) :: ZHOOK_HANDLE

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

#include "abor1.intfb.h"
#include "set2pe.intfb.h"

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

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

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


IF(PRESENT(PSPVOR)) THEN
  IF(PRESENT(PSPVORG)) THEN
    LLVOR=.TRUE.
  ELSE
    CALL ABOR1('TRMTOS: PSPVOR PRESENT BUT PSPVORG MISSING')  
  ENDIF
ELSE
  LLVOR=.FALSE.
ENDIF

IF(PRESENT(PSPDIV)) THEN
  IF(PRESENT(PSPDIVG)) THEN
    LLDIV=.TRUE.
  ELSE
    CALL ABOR1('TRMTOS: PSPDIV PRESENT BUT PSPDIVG MISSING')  
  ENDIF
ELSE
  LLDIV=.FALSE.
ENDIF

IF(PRESENT(PSPT)) THEN
  IF(PRESENT(PSPTG)) THEN
    LLT=.TRUE.
  ELSE
    CALL ABOR1('TRMTOS: PSPT PRESENT BUT PSPTG MISSING')  
  ENDIF
ELSE
  LLT=.FALSE.
ENDIF


! * For NH variables 'SPD' and 'SVD' we keep this test inside TRMTOS
!   to allow to call TRMTOS with these optional arguments even in the
!   hydrostatic model (that avoids to duplicate all the CALL TRMTOS according
!   to the value of LNHDYN in the callers).
IF (LNHDYN) THEN
  IF(PRESENT(PSPSPD)) THEN
    IF(PRESENT(PSPSPDG)) THEN
      LLSPD=.TRUE.
    ELSE
      CALL ABOR1('TRMTOS: PSPSPD PRESENT BUT PSPSPDG MISSING')  
    ENDIF
  ELSE
    LLSPD=.FALSE.
  ENDIF
  IF(PRESENT(PSPSVD)) THEN
    IF(PRESENT(PSPSVDG)) THEN
      LLSVD=.TRUE.
    ELSE
      CALL ABOR1('TRMTOS: PSPSVD PRESENT BUT PSPSVDG MISSING')  
    ENDIF
  ELSE
    LLSVD=.FALSE.
  ENDIF
ELSE
  LLSPD=.FALSE.
  LLSVD=.FALSE.
ENDIF

! * For the NH variable 'SNHX' we keep this test inside TRMTOS
!   to allow to call TRMTOS with these optional arguments even in the
!   hydrostatic model (that avoids to duplicate all the CALL TRMTOS according
!   to the value of "LNHX" in the callers).
IF (LNHX) THEN
  IF(PRESENT(PSPSNHX)) THEN
    IF(PRESENT(PSPSNHXG)) THEN
      LLSNHX=.TRUE.
    ELSE
      CALL ABOR1('TRMTOS: PSPSNHX PRESENT BUT PSPSNHXG MISSING')  
    ENDIF
  ELSE
    LLSNHX=.FALSE.
  ENDIF
ELSE
  LLSNHX=.FALSE.
ENDIF

IF(PRESENT(PSPGFL)) THEN
  INUMSPGFL=UBOUND(PSPGFL,3)
  IF (INUMSPGFL>0) THEN
    LLGFL=.TRUE.
    IF(PRESENT(PSPGFLG)) THEN
      IF (UBOUND(PSPGFLG,3) /= INUMSPGFL ) &
       & CALL ABOR1('TRMTOS: PSPGFLG AND PSPGFL NOT SAME NUMBER OF SP FIELDS')  
    ELSE
      CALL ABOR1('TRMTOS: PSPGFL PRESENT BUT PSPGFLG MISSING')  
    ENDIF
  ELSE
    LLGFL=.FALSE.
  ENDIF
ELSE
  LLGFL=.FALSE.
  INUMSPGFL=HUGE(INUMSPGFL)
ENDIF

IF(PRESENT(PSPSP)) THEN
  IF(PRESENT(PSPSPG)) THEN
    LLSP=.TRUE.
  ELSE
    CALL ABOR1('TRMTOS: PSPSP PRESENT BUT PSPSPG MISSING')  
  ENDIF
ELSE
  LLSP=.FALSE.
ENDIF

IF(PRESENT(PSPAUX)) THEN
  IF(PRESENT(PSPAUXG)) THEN
    LLAUX=.TRUE.
  ELSE
    CALL ABOR1('TRMTOS: PSPAUX PRESENT BUT PSPAUXG MISSING')  
  ENDIF
ELSE
  LLAUX=.FALSE.
ENDIF

IF (PRESENT(PSPSEL3D)) THEN
  LLSEL3D=.TRUE.
  IF (PRESENT(LDSELECT3D)) THEN
    IF (UBOUND(LDSELECT3D,1)/=UBOUND(PSPSEL3D,3)) THEN
      CALL ABOR1 ('PSPSEL3D AND LDSELECT3D HAVE DIFFERENT UPPER BOUNDS')
    ENDIF
  ELSE
    CALL ABOR1('TRMTOS: PSPSEL3D PRESENT BUT LDSELECT3D MISSING')  
  ENDIF

  INUMSEL3D=COUNT(LDSELECT3D)
  IF (PRESENT(PSPSEL3DG)) THEN
    IF (UBOUND(PSPSEL3DG,3)/=INUMSEL3D) THEN
      CALL ABOR1 ('PSPSEL3DG /= COUNT(LDSELECT3D)')
    ENDIF
  ELSE
    CALL ABOR1('TRMTOS: PSPSEL3D PRESENT BUT PSPSEL3DG MISSING')  
  ENDIF
ELSE
  INUMSEL3D=0
  LLSEL3D=.FALSE.
ENDIF

IF (PRESENT(PSPSEL2D)) THEN
  LLSEL2D=.TRUE.
  IF (PRESENT(LDSELECT2D)) THEN
    IF (UBOUND(LDSELECT2D,1)/=UBOUND(PSPSEL2D,2)) THEN
      CALL ABOR1 ('PSPSEL2D AND LDSELECT2D HAVE DIFFERENT UPPER BOUNDS')
    ENDIF
  ELSE
    CALL ABOR1('TRMTOS: PSPSEL2D PRESENT BUT LDSELECT2D MISSING')  
  ENDIF

  INUMSEL2D=COUNT(LDSELECT2D)
  IF (PRESENT(PSPSEL2DG)) THEN
    IF (UBOUND(PSPSEL2DG,2)/=INUMSEL2D) THEN
      CALL ABOR1 ('PSPSEL2DG /= COUNT(LDSELECT2D)')
    ENDIF
  ELSE
    CALL ABOR1('TRMTOS: PSPSEL2D PRESENT BUT PSPSEL2DG MISSING')  
  ENDIF
ELSE
  INUMSEL2D=0
  LLSEL2D=.FALSE.
ENDIF

IF (LLSP) THEN
  IISP=1
ELSE
  IISP=0
ENDIF
IF (IISP+INUMSEL2D>1) THEN
  CALL ABOR1 ('TRMTOS: NOT YET CODED FOR >1 2D FIELD')
ENDIF

IF(PRESENT(LDFULLM)) THEN
  LLFULLM=LDFULLM
ELSE
  LLFULLM=.FALSE.
ENDIF

IF (NPRTRV == 1) THEN

  ! * If all PE's have all levels only a plain copy is necessary

!$OMP PARALLEL DO PRIVATE(JL)
  DO JL=1,NFLEVG
  IF (LLVOR)  PSPVORG (JL,:)   = PSPVOR (JL,:)
  IF (LLDIV)  PSPDIVG (JL,:)   = PSPDIV (JL,:)
  IF (LLT)    PSPTG   (JL,:)   = PSPT   (JL,:)
  IF (LLSPD)  PSPSPDG (JL,:)   = PSPSPD (JL,:)
  IF (LLSVD)  PSPSVDG (JL,:)   = PSPSVD (JL,:)
  IF (LLSNHX) PSPSNHXG(JL,:)   = PSPSNHX(JL,:)
  IF (LLAUX)  PSPAUXG (JL,:)   = PSPAUX (JL,:)
  IF (LLGFL)  PSPGFLG (JL,:,:) = PSPGFL (JL,:,:)
  ENDDO
!$OMP END PARALLEL DO

  IF (NPSP ==1 .AND. LLSP)  PSPSPG(:) = PSPSP(:)
  IF (LLSEL3D) THEN
    ISEL=0
    DO JFIELD=1,UBOUND(PSPSEL3D,3)
      IF (LDSELECT3D(JFIELD)) THEN
        ISEL=ISEL+1
        PSPSEL3DG(1:NFLEVG,:,ISEL) = PSPSEL3D(1:NFLEVG,:,JFIELD)
      ENDIF
    ENDDO
  ENDIF
  IF (NPSP==1 .AND. LLSEL2D) THEN
    ISEL=0
    DO JFIELD=1,UBOUND(PSPSEL2D,2)
      IF (LDSELECT2D(JFIELD)) THEN
        ISEL=ISEL+1
        PSPSEL2DG(:,ISEL) = PSPSEL2D(:,JFIELD)
      ENDIF
    ENDDO
  ENDIF

ELSE

  ! * message-passing is necessary

  CALL GSTATS(1112,0)
  IF (LLFULLM) THEN
    ISPEC2V=NSPEC2VF
    IPTRSV(:)=NPTRSVF(:)
  ELSE
    ISPEC2V=NSPEC2V
    IPTRSV(:)=NPTRSV(:)
  ENDIF

! * Transpose data used on local processor
!$OMP PARALLEL DO SCHEDULE(STATIC) &
!$OMP&PRIVATE(JVERSP,ISP,IL1,IL2,JFIELD,ISEL)
  DO JVERSP=1,ISPEC2V
    ISP=IPTRSV(MYSETV)-1+JVERSP
    IL1=NPTRLL(MYSETV)
    IL2=IL1+NFLEVL-1
    IF (LLVOR)  PSPVORG (IL1:IL2,JVERSP)   = PSPVOR (1:NFLEVL,ISP)
    IF (LLDIV)  PSPDIVG (IL1:IL2,JVERSP)   = PSPDIV (1:NFLEVL,ISP)
    IF (LLT)    PSPTG   (IL1:IL2,JVERSP)   = PSPT   (1:NFLEVL,ISP)
    IF (LLSPD)  PSPSPDG (IL1:IL2,JVERSP)   = PSPSPD (1:NFLEVL,ISP)
    IF (LLSVD)  PSPSVDG (IL1:IL2,JVERSP)   = PSPSVD (1:NFLEVL,ISP)
    IF (LLSNHX) PSPSNHXG(IL1:IL2,JVERSP)   = PSPSNHX(1:NFLEVL,ISP)
    IF (LLAUX)  PSPAUXG (IL1:IL2,JVERSP)   = PSPAUX (1:NFLEVL,ISP)
    IF (LLGFL)  PSPGFLG (IL1:IL2,JVERSP,:) = PSPGFL (1:NFLEVL,ISP,:)

    IF (NPSP==1 .AND. LLSP)  PSPSPG(JVERSP)=PSPSP(ISP)
    IF (NPSP==1 .AND. LLSEL2D) THEN
      ISEL=0
      DO JFIELD=1,UBOUND(PSPSEL2D,2)
        IF (LDSELECT2D(JFIELD)) THEN
          ISEL=ISEL+1
          PSPSEL2DG(JVERSP,ISEL) = PSPSEL2D(ISP,JFIELD)
        ENDIF
      ENDDO
    ENDIF

    IF (LLSEL3D) THEN
      ISEL=0
      DO JFIELD=1,UBOUND(PSPSEL3D,3)
        IF (LDSELECT3D(JFIELD)) THEN
          ISEL=ISEL+1
          PSPSEL3DG(IL1:IL2,JVERSP,ISEL) = PSPSEL3D(1:NFLEVL,ISP,JFIELD)
        ENDIF
      ENDDO
    ENDIF
  ENDDO
!$OMP END PARALLEL DO
  CALL GSTATS(1112,1)

  ! * set up tables

  IBUFLENR=0
  IBUFLENS=0
  ISPECMIN=0
  DO JROCB=1,NPRTRV-1
    JR=JROCB
    ISENDSET=MYSENDSET(NPRTRV,MYSETV,JR)
    IRECVSET=MYRECVSET(NPRTRN,MYSETN,JR)
    IPOS=0
    IF (LLVOR)   IPOS=IPOS+1
    IF (LLDIV)   IPOS=IPOS+1
    IF (LLT)     IPOS=IPOS+1
    IF (LLSPD)   IPOS=IPOS+1
    IF (LLSVD)   IPOS=IPOS+1
    IF (LLSNHX)  IPOS=IPOS+1
    IF (LLAUX)   IPOS=IPOS+1
    IF (LLGFL)   IPOS=IPOS+INUMSPGFL
    IF (LLSEL3D) IPOS=IPOS+INUMSEL3D

    IF (NPSP ==1 .AND. (LLSP.OR.LLSEL2D)) THEN
      ILEV=1 ! NB: This assumes only one 2D field needs transposing
    ELSE
      ILEV=0
    ENDIF

    IF (NPSURF(IRECVSET) == 1.AND. (LLSP.OR.LLSEL2D)) THEN
      IISP=1 ! NB: This assumes only one 2D field needs transposing
    ELSE
      IISP=0
    ENDIF

    ISEND_START(JR)=1
    ISEND_TOTAL(JR)=IPTRSV(ISENDSET+1)-IPTRSV(ISENDSET)
    ISPECMIN=MAX(ISPECMIN,(ISEND_TOTAL(JR)))
    IMINIMUM(JR)=NFLEVL*IPOS
    IBUFLEFT(JR)=0
    ISENDTOT(JR)=(IPTRSV(ISENDSET+1)-IPTRSV(ISENDSET))*(NFLEVL*IPOS+ILEV)
    IF (IPTRSV(MYSETN) < IPTRSV(MYSETN+1)) THEN
      IRECVTOT(JR)=ISPEC2V*((NPTRLL(IRECVSET+1)-NPTRLL(IRECVSET))*IPOS+IISP)
    ELSE
      IRECVTOT(JR)=0
    ENDIF
    IRCVD(JR)=0
    ISENT(JR)=0
    IBUFLENR=MAX(IBUFLENR,IRECVTOT(JR))
    IBUFLENS=MAX(IBUFLENS,ISENDTOT(JR))
  ENDDO

  ISENDCOUNT=0
  IRECVCOUNT=0
  INSEND=0
  INRECV=0
  DO JR=1,NPRTRV-1
    ISENDCOUNT=MAX(ISENDCOUNT,ISENDTOT(JR))
    IRECVCOUNT=MAX(IRECVCOUNT,IRECVTOT(JR))
    IF(ISENDTOT(JR) > 0 )THEN
      INSEND=INSEND+1
      JSEND(INSEND)=JR
    ENDIF
    IF(IRECVTOT(JR) > 0 )THEN
      INRECV=INRECV+1
      JRECV(INRECV)=JR
    ENDIF
  ENDDO

  IF (IBUFLENS > 0) ALLOCATE (ZCOMBUFS(-1:ISENDCOUNT,NPRTRV-1))
  IF (IBUFLENR > 0) ALLOCATE (ZCOMBUFR(-1:IRECVCOUNT,NPRTRV-1))
  if (LNHDYN .AND. IPOS > MIN(IRECVCOUNT,ISENDCOUNT)) THEN
    write(nulout,*) ' trmtos: IPOS > MIN(IRECVCOUNT,ISENDCOUNT) '
    write(nulout,*) ' IPOS=',IPOS,'  ISENDCOUNT=',ISENDCOUNT,'  IRECVCOUNT=',IRECVCOUNT
    call flush(nulout)
  endif

  IHEAD=2


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

  CALL GSTATS(1113,0)
  JPOS=0
!$OMP PARALLEL DO SCHEDULE(STATIC) PRIVATE(J,JR,ISENDSET,IPOS,ISPNUM)  
  DO J=1,INSEND
    JR=JSEND(J)
    ISENDSET=MYSENDSET(NPRTRV,MYSETV,JR)
    ZCOMBUFS(-1,JR)=1
    IPOS=0
    ISPNUM=0
    CALL MTOS_PACK(JR,ISENDSET,IPOS,ISPNUM)

    ZCOMBUFS(0,JR)=ISPNUM
    JPOS(JR)=IPOS
  ENDDO
!$OMP END PARALLEL DO
  CALL GSTATS(1113,1) 

  CALL GSTATS_BARRIER(765)

    ! * Send/Recv loop .................................................
    CALL GSTATS(508,0)
    IR=0
    DO JR=1,NPRTRV-1
      IF( IRECVTOT(JR) > 0 )THEN
        IRECVSET=MYRECVSET(NPRTRN,MYSETN,JR)
        IF (IPTRSV(MYSETN) < IPTRSV(MYSETN+1)) THEN
          CALL SET2PE(IRECV,0,0,MYSETM,IRECVSET)
          IR=IR+1
          CALL MPL_RECV(ZCOMBUFR(:,JR),KSOURCE=NPRCIDS(IRECV),&
           & KMP_TYPE=JP_NON_BLOCKING_STANDARD,KREQUEST=ISENDREQ(IR), &
           & KTAG=MTAGMS,CDSTRING='TRMTOS:')
        ENDIF
      ENDIF
    ENDDO
    DO JR=1,NPRTRV-1
      IPOS=JPOS(JR)
      IF (IPOS > 0) THEN
        ISENDSET=MYSENDSET(NPRTRV,MYSETV,JR)
        CALL SET2PE(ISEND,0,0,MYSETW,ISENDSET)
        IR=IR+1
        CALL MPL_SEND(ZCOMBUFS(-1:IPOS,JR),KDEST=NPRCIDS(ISEND), &
         & KMP_TYPE=JP_NON_BLOCKING_STANDARD,KREQUEST=ISENDREQ(IR), &
         & KTAG=MTAGMS,CDSTRING='TRMTOS:' )
      ENDIF
    ENDDO
      IF(IR > 0)THEN
        CALL MPL_WAIT(ZDUM,KREQUEST=ISENDREQ(1:IR), &
         & CDSTRING='TRMTOS: WAIT FOR SENDS and RECEIVES')
      ENDIF
    CALL GSTATS(508,1)

  CALL GSTATS_BARRIER2(765)

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

  CALL GSTATS(1114,0)
!$OMP PARALLEL DO SCHEDULE(STATIC)&
!$OMP&PRIVATE(J,JR,IRECVSET,IPOS,IRECV_START,IRECV_END)
  DO J=1,INRECV
    JR=JRECV(J)
    IRECVSET=MYRECVSET(NPRTRN,MYSETN,JR)
    IF (IPTRSV(MYSETN) < IPTRSV(MYSETN+1)) THEN
      IRECV_START=ZCOMBUFR(-1,JR)
      IRECV_END  =ZCOMBUFR( 0,JR)
      IPOS=0
      CALL MTOS_UNPACK(JR,IRECVSET,IPOS,IRECV_START,IRECV_END)
    ENDIF
  ENDDO
!$OMP END PARALLEL DO
  CALL GSTATS(1114,1)

  IF (ALLOCATED(ZCOMBUFS))DEALLOCATE(ZCOMBUFS)
  IF (ALLOCATED(ZCOMBUFR))DEALLOCATE(ZCOMBUFR)

ENDIF

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

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

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

CONTAINS

SUBROUTINE MTOS_PACK(KJR,KSENDSET,KPOS,KSPNUM)

INTEGER(KIND=JPIM),INTENT(IN)    :: KJR
INTEGER(KIND=JPIM),INTENT(IN)    :: KSENDSET
INTEGER(KIND=JPIM),INTENT(INOUT) :: KPOS
INTEGER(KIND=JPIM),INTENT(INOUT) :: KSPNUM

INTEGER(KIND=JPIM) :: JSP,JGFL,JFIELD
REAL(KIND=JPRB) :: ZHOOK_HANDLE

IF (LHOOK) CALL DR_HOOK('TRMTOS:MTOS_PACK',0,ZHOOK_HANDLE)
IF (NPSP == 1.AND. (LLSP.OR.LLSEL2D)) THEN
  IF (ISENT(KJR) == 0) THEN
    IF (LLSP) THEN
      DO JSP=IPTRSV(KSENDSET),IPTRSV(KSENDSET+1)-1
        KPOS=KPOS+1
        ZCOMBUFS(KPOS,KJR)=PSPSP(JSP)
      ENDDO
    ENDIF
    IF (LLSEL2D) THEN
      DO JFIELD=1,UBOUND(PSPSEL2D,2)
        IF (LDSELECT2D(JFIELD)) THEN
          DO JSP=IPTRSV(KSENDSET),IPTRSV(KSENDSET+1)-1
            KPOS=KPOS+1 !NB: Assumes only one 3d field selected
            ZCOMBUFS(KPOS,KJR) = PSPSEL2D(JSP,JFIELD)
          ENDDO
        ENDIF
      ENDDO
    ENDIF
!             tell receiver that this message contains the extra fields
    ZCOMBUFS(-1,KJR)=0
    IBUFLEFT(KJR)=IBUFLEFT(KJR)-ISEND_TOTAL(KJR)
  ENDIF
ENDIF

DO JSP=IPTRSV(KSENDSET),IPTRSV(KSENDSET+1)-1
  KSPNUM=KSPNUM+1
  IF (KSPNUM >= ISEND_START(KJR)) THEN
    IF (LLVOR) ZCOMBUFS(KPOS+1:KPOS+NFLEVL,KJR)=PSPVOR(1:NFLEVL,JSP)
    IF (LLVOR)  KPOS=KPOS+NFLEVL
    IF (LLDIV)  ZCOMBUFS(KPOS+1:KPOS+NFLEVL,KJR)=PSPDIV(1:NFLEVL,JSP)
    IF (LLDIV)  KPOS=KPOS+NFLEVL
    IF (LLT)    ZCOMBUFS(KPOS+1:KPOS+NFLEVL,KJR)=PSPT(1:NFLEVL,JSP)
    IF (LLT)    KPOS=KPOS+NFLEVL
    IF (LLSPD)  ZCOMBUFS(KPOS+1:KPOS+NFLEVL,KJR)=PSPSPD(1:NFLEVL,JSP)
    IF (LLSPD)  KPOS=KPOS+NFLEVL
    IF (LLSVD)  ZCOMBUFS(KPOS+1:KPOS+NFLEVL,KJR)=PSPSVD(1:NFLEVL,JSP)
    IF (LLSVD)  KPOS=KPOS+NFLEVL
    IF (LLSNHX) ZCOMBUFS(KPOS+1:KPOS+NFLEVL,KJR)=PSPSNHX(1:NFLEVL,JSP)
    IF (LLSNHX) KPOS=KPOS+NFLEVL
    IF (LLAUX)  ZCOMBUFS(KPOS+1:KPOS+NFLEVL,KJR)=PSPAUX(1:NFLEVL,JSP)
    IF (LLAUX)  KPOS=KPOS+NFLEVL
    IF (LLGFL) THEN
      DO JGFL=1,INUMSPGFL
        ZCOMBUFS(KPOS+1:KPOS+NFLEVL,KJR)=PSPGFL(1:NFLEVL,JSP,JGFL)
        KPOS=KPOS+NFLEVL
      ENDDO
    ENDIF
  
    IF (LLSEL3D) THEN
      DO JFIELD=1,UBOUND(PSPSEL3D,3)
        IF (LDSELECT3D(JFIELD)) THEN
          ZCOMBUFS(KPOS+1:KPOS+NFLEVL,KJR)=PSPSEL3D(1:NFLEVL,JSP,JFIELD)
          KPOS=KPOS+NFLEVL
        ENDIF
      ENDDO
    ENDIF
    IBUFLEFT(KJR)=IBUFLEFT(KJR)-IMINIMUM(KJR)
  ENDIF
ENDDO

IF (LHOOK) CALL DR_HOOK('TRMTOS:MTOS_PACK',1,ZHOOK_HANDLE)
END SUBROUTINE MTOS_PACK

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

SUBROUTINE MTOS_UNPACK(KJR,KRECVSET,KPOS,KRECV_START,KRECV_END)

INTEGER(KIND=JPIM),INTENT(IN)    :: KJR
INTEGER(KIND=JPIM),INTENT(IN)    :: KRECVSET
INTEGER(KIND=JPIM),INTENT(INOUT) :: KPOS
INTEGER(KIND=JPIM),INTENT(INOUT) :: KRECV_START
INTEGER(KIND=JPIM),INTENT(IN)    :: KRECV_END

INTEGER(KIND=JPIM) :: JSP,JGFL,ISEL,JFIELD,IL1,IL2,ILN

REAL(KIND=JPRB) :: ZHOOK_HANDLE

IF (LHOOK) CALL DR_HOOK('TRMTOS:MTOS_UNPACK',0,ZHOOK_HANDLE)

IF (KRECV_START == 0 ) THEN
!            buffer contains extra 2d spectral field
  IF (LLSP) THEN
    DO JSP=1,ISPEC2V
      KPOS=KPOS+1
      PSPSPG(JSP)=ZCOMBUFR(KPOS,KJR)
    ENDDO
    KRECV_START = 1
  ENDIF
  IF (LLSEL2D) THEN
    ISEL=0
    DO JFIELD=1,UBOUND(PSPSEL2D,2)
      IF (LDSELECT2D(JFIELD)) THEN
        ISEL=ISEL+1
        DO JSP=1,ISPEC2V
          KPOS=KPOS+1 ! Assumes only one field selected
          PSPSEL2DG(JSP,ISEL)= ZCOMBUFR(KPOS,KJR)
        ENDDO
      ENDIF
    ENDDO
    KRECV_START = 1
  ENDIF
ENDIF
DO JSP=KRECV_START,KRECV_END
  IL1=NPTRLL(KRECVSET)
  IL2=NPTRLL(KRECVSET+1)-1
  ILN=IL2-IL1+1
  IF (LLVOR)  PSPVORG(IL1:IL2,JSP)=ZCOMBUFR(KPOS+1:KPOS+ILN,KJR)
  IF (LLVOR)  KPOS=KPOS+ILN
  IF (LLDIV)  PSPDIVG(IL1:IL2,JSP)=ZCOMBUFR(KPOS+1:KPOS+ILN,KJR)
  IF (LLDIV)  KPOS=KPOS+ILN
  IF (LLT)    PSPTG(IL1:IL2,JSP)=ZCOMBUFR(KPOS+1:KPOS+ILN,KJR)
  IF (LLT)    KPOS=KPOS+ILN
  IF (LLSPD)  PSPSPDG(IL1:IL2,JSP)=ZCOMBUFR(KPOS+1:KPOS+ILN,KJR)
  IF (LLSPD)  KPOS=KPOS+ILN
  IF (LLSVD)  PSPSVDG(IL1:IL2,JSP)=ZCOMBUFR(KPOS+1:KPOS+ILN,KJR)
  IF (LLSVD)  KPOS=KPOS+ILN
  IF (LLSNHX) PSPSNHXG(IL1:IL2,JSP)=ZCOMBUFR(KPOS+1:KPOS+ILN,KJR)
  IF (LLSNHX) KPOS=KPOS+ILN
  IF (LLAUX)  PSPAUXG(IL1:IL2,JSP)=ZCOMBUFR(KPOS+1:KPOS+ILN,KJR)
  IF (LLAUX)  KPOS=KPOS+ILN
  IF (LLGFL) THEN
    DO JGFL=1,INUMSPGFL
      PSPGFLG(IL1:IL2,JSP,JGFL)=ZCOMBUFR(KPOS+1:KPOS+ILN,KJR)
      KPOS=KPOS+ILN
    ENDDO
  ENDIF

  IF (LLSEL3D) THEN
    ISEL=0
    DO JFIELD=1,UBOUND(PSPSEL3D,3)
      IF (LDSELECT3D(JFIELD)) THEN
        ISEL=ISEL+1
        PSPSEL3DG(IL1:IL2,JSP,ISEL) = ZCOMBUFR(KPOS+1:KPOS+ILN,KJR)
        KPOS=KPOS+ILN
      ENDIF
    ENDDO
  ENDIF
ENDDO

IF (LHOOK) CALL DR_HOOK('TRMTOS:MTOS_UNPACK',1,ZHOOK_HANDLE)
END SUBROUTINE MTOS_UNPACK

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

END SUBROUTINE TRMTOS
