SUBROUTINE MPOBSEQAD

!**** *MPOBSEQAD* Message passing of obs.eq.

!     Purpose : Exchange GOM arrays
!     ---------

!     Interface : CALL MPOBSEQAD(..)
!     -----------

!     Explicit arguments : 
!     -------------------- 


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

!     Externals :   MPL_RECV - recieve message
!     ---------     MPL_SEND - send message

!     Author : Mats Hamrud *ECMWF*
!     ------

!     Modifications :
!     -------------
!     95-12-08 M.Hamrud    : Original
!     96-12-01 M.Hamrud    : 4-D var
!     97-11-17 E.Andersson : Introduce CIW and O3, Flexible GOM-arrays.
!     99-07-08 M.Siroka    : debug ALADIN 3DVAR (treat PSLDL, PSLDM for 1 proc.)
!     00-09-01 D.Dent      : MPE to MPL conversion
!     02-08-01 Deborah Salmond  LIMP_NOOLAP Option for non-overlapping
!                            message passing and buffer packing
!        M.Hamrud      01-Oct-2003 CY28 Cleaning
!        M.Hamrud      15-Feb-2005 New-style GOM arrays
!     05-12-08 N.Bormann   : Bugfix for 2d surface GOM arrays
!     H. Hersbach   04-Dec-2009 10-m neutral wind
!    -------------------------------------------------------------------

USE PARKIND1  ,ONLY : JPIM     ,JPRB
USE YOMHOOK   ,ONLY : LHOOK,   DR_HOOK
USE YOMDIM   , ONLY : NFLEVG
USE YOMCT0   , ONLY : NPROC
USE YOMLUN   , ONLY : NULERR  
USE YOMCOCTP , ONLY : NOOBST
USE YOMGLOBS , ONLY : &
 & NOBSRECVAD,NOBSSENDAD,&
 & NSTASENDAD,NLOCSENDAD,NLOCPROFAD,&
 & RECVBUFAD,LPREMPOBS,NSTRECVTSLAD,NENRECVTSLAD  
USE YOMECTAB , ONLY : NTSLOTNO
USE YOMMP    , ONLY : NPRCIDS  ,MYPROC
USE YOMTAG   , ONLY : MTAGOBSEQAD
USE GOMS_MIX , ONLY : YGOMUA,YGOMS,YGOMEC,YGOMUA_2D,YGOMS_2D,YGOMEC_2D,&
 & LGOMUA,NGOMGFL
USE MPL_MODULE , ONLY :  MPL_SEND, MPL_RECV, MPL_WAIT, &
 & JP_BLOCKING_STANDARD, JP_NON_BLOCKING_STANDARD
USE OBSHOR_CACHE_MIX

IMPLICIT NONE

INTEGER(KIND=JPIM) :: ISTTSLT(NACTIM),IENTSLT(NACTIM)
REAL(KIND=JPRB),ALLOCATABLE :: ZBUFS(:) ! Send buffer

INTEGER(KIND=JPIM) :: IBP, IBUFLENR, IBUFLENS,&
 & IOBS,  IOFF, &
 & IRECV, ISEND, ISN, &
 & ITAG, ITS, &
 & ITYP, JOBS, JROC, IOBSSEND, IOBSRECV, &
 & IBUFLENP, ISS, IEND,INUM,ISTR,IPROF,JTYP,JGFL,IGFL,&
 & ISTGFL, IENGFL , JTS, ITSLOTB, ITSLOTE,ITSLOTS,IEXPLEN
INTEGER(KIND=JPIM) :: ISENDREQ(NPROC-1), ILRECV(NPROC)


INTEGER(KIND=JPIM), DIMENSION(NPROC) :: ISTARTS,IENDS
INTEGER(KIND=JPIM), DIMENSION(NPROC) :: ISTARTR,IENDR
REAL(KIND=JPRB) :: ZHOOK_HANDLE

#include "abor1.intfb.h"

!    -------------------------------------------------------------------
!*       0.  ZERO OBS EQ.
!            ------------

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

IF(LPREMPOBS) THEN
  ITSLOTB = 1
  ITSLOTE = NACTIM
ELSE
  ITSLOTB = NTSLOTNO
  ITSLOTE = NTSLOTNO
ENDIF
ITSLOTS = ITSLOTE-ITSLOTB+1

IOBSSEND = SUM(NOBSSENDAD(:,ITSLOTB:ITSLOTE))-SUM(NOBSSENDAD(MYPROC,ITSLOTB:ITSLOTE))
IOBSRECV = SUM(NOBSRECVAD(:,ITSLOTB:ITSLOTE))-SUM(NOBSRECVAD(MYPROC,ITSLOTB:ITSLOTE))

ITAG  = MTAGOBSEQAD

ISN  = 0
DO JTYP=1,NOOBST
  ISN = MAX(ISN,COUNT(LGOMUA(JTYP,:)))
ENDDO
ISN = ISN*NFLEVG
IBUFLENP = ISN+12+2

ISS = 1
DO JROC=1,NPROC
  IF(JROC /= MYPROC) THEN
    ISTARTR(JROC) = ISS
    ISS = ISS+SUM(NOBSRECVAD(JROC,ITSLOTB:ITSLOTE))*IBUFLENP+2*ITSLOTS
  ENDIF
ENDDO
IENDR(:) = ISTARTR(:)

ISS = 1
DO JROC=1,NPROC
  IF(JROC /= MYPROC) THEN
    ISTARTS(JROC) = ISS
    ISS = ISS+SUM(NOBSSENDAD(JROC,ITSLOTB:ITSLOTE))*IBUFLENP+2*ITSLOTS
  ENDIF
ENDDO

IBUFLENS = IBUFLENP*IOBSSEND+2*ITSLOTS*(NPROC-1)
ALLOCATE(ZBUFS(IBUFLENS))
IBUFLENR = IBUFLENP*IOBSRECV+2*ITSLOTS*(NPROC-1)
IF(.NOT.ALLOCATED(RECVBUFAD))  ALLOCATE(RECVBUFAD(IBUFLENR))

!    ----------------------------------------------------------------------
!*       1.  EXCHANGE OBS.EQ. WITH OTHER PROCESSORS.
!            ---------------------------------------


!    ----------------------------------------------------------------------
!*           PACK SEND BUFFER
!           ------------------
CALL GSTATS(1075,0)
!$OMP PARALLEL DO SCHEDULE(DYNAMIC,1)&
!$OMP&PRIVATE(JROC,IBP,ISEND,JTS,ITS,ISTTSLT,IENTSLT)
DO JROC=1,NPROC-1
  ISTTSLT(:) = 0
  IENTSLT(:) = -1
  ISEND = MOD(MYPROC+JROC-1,NPROC)+1
  IBP = ISTARTS(ISEND)-1
  IF(ANY(NOBSSENDAD(ISEND,ITSLOTB:ITSLOTE) > 0)) THEN
    IBP = IBP+2*ITSLOTS
    DO JTS=ITSLOTB,ITSLOTE
      ITS = JTS
      IF(NOBSSENDAD(ISEND,ITS) > 0) THEN
        ISTTSLT(ITS) = IBP+1-ISTARTS(ISEND)
        CALL PACK_SEND(IBP,ISEND,ZBUFS,ITS)
        IENTSLT(ITS) = IBP-ISTARTS(ISEND)
      ENDIF
    ENDDO
    ZBUFS(ISTARTS(ISEND):ISTARTS(ISEND)+ITSLOTS-1) = ISTTSLT(ITSLOTB:ITSLOTE)
    ZBUFS(ISTARTS(ISEND)+ITSLOTS:ISTARTS(ISEND)+2*ITSLOTS-1) = IENTSLT(ITSLOTB:ITSLOTE)
  ENDIF
  IENDS(ISEND)=IBP
ENDDO
!$OMP END PARALLEL DO
CALL GSTATS(1075,1)

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

!       SEND/RECEIVE MESSAGES
!       ---------------------

CALL GSTATS_BARRIER(768)
CALL GSTATS(514,0)
DO JROC=1,NPROC-1
  ISEND = MOD(MYPROC+JROC-1,NPROC)+1
  IF(IENDS(ISEND) >= ISTARTS(ISEND) ) THEN
    CALL MPL_SEND(ZBUFS(ISTARTS(ISEND):IENDS(ISEND)),&
     & KDEST=NPRCIDS(ISEND),KTAG=ITAG, &
     & KMP_TYPE=JP_NON_BLOCKING_STANDARD,KREQUEST=ISENDREQ(JROC), &
     & CDSTRING='MPOBSEQAD:')  
  ENDIF
ENDDO

DO JROC=1,NPROC-1
  IRECV = MOD(-JROC-1+MYPROC+NPROC,NPROC)+1
  IF(ANY(NOBSRECVAD(IRECV,ITSLOTB:ITSLOTE) > 0)) THEN
    ISTR=ISTARTR(IRECV)
    IEND=ISTARTR(IRECV)+SUM(NOBSRECVAD(IRECV,ITSLOTB:ITSLOTE))*IBUFLENP-1+2*ITSLOTS
    CALL MPL_RECV(RECVBUFAD(ISTR:IEND), KSOURCE=NPRCIDS(IRECV), &
     & KMP_TYPE=JP_BLOCKING_STANDARD,KTAG=ITAG,&
     & KOUNT=ILRECV(IRECV),CDSTRING='MPOBSEQAD:')
    IEXPLEN = MAXVAL(NINT(RECVBUFAD(ISTR+ITSLOTS:ISTR+2*ITSLOTS-1)))+1
    IF(ILRECV(IRECV) /= IEXPLEN ) THEN
      WRITE(NULERR,*)'MYPROC,IRECV,ILRECV(IRECV),ITSLOTS,RECVBUFAD(1:2*ITSLOTS) ',&
      & MYPROC,IRECV,ILRECV(IRECV),ITSLOTS,NINT(RECVBUFAD(ISTR:ISTR+2*ITSLOTS-1))
      CALL ABOR1(' MPOBSEQAD - WRONG RECV LENGTH')
    ENDIF
    NSTRECVTSLAD(ITSLOTB:ITSLOTE,IRECV) = &
     & NINT(RECVBUFAD(ISTR:ISTR+ITSLOTS-1))+ISTARTR(IRECV)
    NENRECVTSLAD(ITSLOTB:ITSLOTE,IRECV) = &
     & NINT(RECVBUFAD(ISTR+ITSLOTS:ISTR+2*ITSLOTS-1))+ISTARTR(IRECV)
  ENDIF
ENDDO

DO JROC=1,NPROC-1
  ISEND = MOD(MYPROC+JROC-1,NPROC)+1
  IF(IENDS(ISEND) >= ISTARTS(ISEND) ) THEN
    CALL MPL_WAIT(ZBUFS, KREQUEST=ISENDREQ(JROC), &
     & CDSTRING='MPOBSEQAD: WAIT FOR SEND' )  
  ENDIF
ENDDO
CALL GSTATS(514,1)
CALL GSTATS_BARRIER2(768)

DEALLOCATE(ZBUFS)

IF (LHOOK) CALL DR_HOOK('MPOBSEQAD',1,ZHOOK_HANDLE)
CONTAINS
SUBROUTINE PACK_SEND(KBP,KSEND,PBUFS,KTS)
INTEGER(KIND=JPIM),INTENT(INOUT) :: KBP
INTEGER(KIND=JPIM),INTENT(IN)    :: KSEND
REAL(KIND=JPRB)   ,INTENT(OUT)   :: PBUFS(:)
INTEGER(KIND=JPIM),INTENT(IN)    :: KTS

INTEGER(KIND=JPIM) :: IOFF,IOBS,ITYP,JOBS,IPROF,INUM
INTEGER(KIND=JPIM) :: JGFL,IGFL,ISTGFL,IENGFL
REAL(KIND=JPRB) :: ZHOOK_HANDLE

IF (LHOOK) CALL DR_HOOK('MPOBSEQAD:PACK_SEND',0,ZHOOK_HANDLE)
IOFF = NSTASENDAD(KSEND,KTS)  ! Offset within send ar.
DO JOBS = 1,NOBSSENDAD(KSEND,KTS)
  IOBS = NLOCSENDAD(IOFF+JOBS)
  IPROF = NLOCPROFAD(IOFF +JOBS)
  ITYP = OBSHOR_CACHE(KTS)%OBSTYPE(IOBS)
  INUM = OBSHOR_CACHE(KTS)%MAPOMM(IOBS)
  IF(IPROF == 0) THEN
    IF(INUM /= YGOMUA(INUM)%IOBS) THEN
      WRITE(NULERR,*) 'MPOBSEQAD - INUM /= YGOMUA(INUM)%IOBS ',&
       & KSEND,JOBS,IOBS,INUM,YGOMUA(INUM)%IOBS
      CALL ABOR1('MPOBSEQAD - INUM /= YGOMUA(INUM)%IOBS ')
    ENDIF
    IF(YGOMUA(INUM)%LU) THEN
      PBUFS(KBP+1:KBP+NFLEVG) = YGOMUA(INUM)%U(:)
      KBP = KBP+NFLEVG
    ENDIF
    IF(YGOMUA(INUM)%LV) THEN
      PBUFS(KBP+1:KBP+NFLEVG) = YGOMUA(INUM)%V(:)
      KBP = KBP+NFLEVG
    ENDIF
    IF(YGOMUA(INUM)%LT) THEN
      PBUFS(KBP+1:KBP+NFLEVG) = YGOMUA(INUM)%T(:)
      KBP = KBP+NFLEVG
    ENDIF
    IGFL = 0
    DO JGFL=1,NGOMGFL
      IF(YGOMUA(INUM)%LGFL(JGFL)) THEN
        IGFL = IGFL+1
        ISTGFL = 1+(IGFL-1)*NFLEVG
        IENGFL = ISTGFL+NFLEVG-1
        PBUFS(KBP+1:KBP+NFLEVG) = YGOMUA(INUM)%GFL(ISTGFL:IENGFL)
        KBP = KBP+NFLEVG
      ENDIF
    ENDDO
    
    PBUFS(KBP+1) = YGOMS(INUM)%UL
    PBUFS(KBP+2) = YGOMS(INUM)%VL
    PBUFS(KBP+3) = YGOMS(INUM)%SP
    PBUFS(KBP+4) = YGOMS(INUM)%TS
    PBUFS(KBP+5) = YGOMS(INUM)%WS 
    PBUFS(KBP+6) = YGOMS(INUM)%SN
    PBUFS(KBP+7) = YGOMS(INUM)%Z0
    PBUFS(KBP+8) = YGOMS(INUM)%WL 
    PBUFS(KBP+9) = YGOMS(INUM)%TL 
    PBUFS(KBP+10)= YGOMS(INUM)%QL 
    PBUFS(KBP+11)= YGOMS(INUM)%U10N
    PBUFS(KBP+12)= YGOMS(INUM)%V10N
    KBP = KBP+12
    PBUFS(KBP+1) = YGOMEC(INUM)%ECDL 
    PBUFS(KBP+2) = YGOMEC(INUM)%ECDM
    KBP = KBP+2
  ELSE
    IF(INUM /= YGOMUA_2D(INUM)%IOBS) THEN
      WRITE(NULERR,*) 'MPOBSEQAD - INUM /= YGOMUA_2D(INUM)%IOBS ',&
       & KSEND,JOBS,IOBS,INUM,YGOMUA_2D(INUM)%IOBS
      CALL ABOR1('MPOBSEQAD - INUM /= YGOMUA_2D(INUM)%IOBS ')
    ENDIF
    IF(YGOMUA_2D(INUM)%LU) THEN
      PBUFS(KBP+1:KBP+NFLEVG) = YGOMUA_2D(INUM)%U(:,IPROF)
      KBP = KBP+NFLEVG
    ENDIF
    IF(YGOMUA_2D(INUM)%LV) THEN
      PBUFS(KBP+1:KBP+NFLEVG) = YGOMUA_2D(INUM)%V(:,IPROF)
      KBP = KBP+NFLEVG
    ENDIF
    IF(YGOMUA_2D(INUM)%LT) THEN
      PBUFS(KBP+1:KBP+NFLEVG) = YGOMUA_2D(INUM)%T(:,IPROF)
      KBP = KBP+NFLEVG
    ENDIF
    IGFL = 0
    DO JGFL=1,NGOMGFL
      IF(YGOMUA_2D(INUM)%LGFL(JGFL)) THEN
        IGFL = IGFL+1
        ISTGFL = 1+(IGFL-1)*NFLEVG
        IENGFL = ISTGFL+NFLEVG-1
        PBUFS(KBP+1:KBP+NFLEVG) = YGOMUA_2D(INUM)%GFL(ISTGFL:IENGFL,IPROF)
        KBP = KBP+NFLEVG
      ENDIF
    ENDDO

    PBUFS(KBP+1) = YGOMS_2D(INUM)%UL(IPROF)
    PBUFS(KBP+2) = YGOMS_2D(INUM)%VL(IPROF)
    PBUFS(KBP+3) = YGOMS_2D(INUM)%SP(IPROF)
    PBUFS(KBP+4) = YGOMS_2D(INUM)%TS(IPROF)
    PBUFS(KBP+5) = YGOMS_2D(INUM)%WS(IPROF) 
    PBUFS(KBP+6) = YGOMS_2D(INUM)%SN(IPROF)
    PBUFS(KBP+7) = YGOMS_2D(INUM)%Z0(IPROF)
    PBUFS(KBP+8) = YGOMS_2D(INUM)%WL(IPROF) 
    PBUFS(KBP+9) = YGOMS_2D(INUM)%TL(IPROF) 
    PBUFS(KBP+10)= YGOMS_2D(INUM)%QL(IPROF) 
    PBUFS(KBP+11)= YGOMS_2D(INUM)%U10N(IPROF)
    PBUFS(KBP+12)= YGOMS_2D(INUM)%V10N(IPROF)
    KBP = KBP+12
    PBUFS(KBP+1) = YGOMEC_2D(INUM)%ECDL(IPROF) 
    PBUFS(KBP+2) = YGOMEC_2D(INUM)%ECDM(IPROF)
    KBP = KBP+2
  ENDIF
ENDDO
IF (KBP > IBUFLENS) THEN
  WRITE(NULERR,*) ' MPOBSEQAD:',MYPROC,KSEND,KBP,IBUFLENS
  CALL ABOR1(' MPOBSEQAD: SEND BUFFER TOO SMALL')
ENDIF
IF (LHOOK) CALL DR_HOOK('MPOBSEQAD:PACK_SEND',1,ZHOOK_HANDLE)

END SUBROUTINE PACK_SEND


END SUBROUTINE MPOBSEQAD
