SUBROUTINE OBSHORAD(&
 & KIBUFP1,KASLB1,KPROMB,KPROMBMP,&
 & PPARITY,POBB1)  

!     *OBSHORAD* - Horizontal interpolation of the model variables
!                  from grid points to observation points (adjoint part)

!     Purpose.
!     -------
!        To prepare use of semi-lagrangian interpolation routines.

!     Interface.
!     ---------
!        CALL OBSHORAD(...)

!     Explicit arguments :
!     --------------------
!            KIBUFP1  = S/L BUFFERS TABLE
!            PPARITY  = INDICATOR FOR SCALAR (1) OR VECTOR (-1) FIELD
!            POBB1    = S/L BUFFER

!     Externals
!     ---------
!        SLINTAD - S/L INTERPOLATOR

!     Author
!     ------
!        Drasko Vasiljevic *ECMWF*

!     Modifications
!     -------------
!     90-05-19 Original by D. Vasiljevic
!     92-12-01 JN.Thepaut  : change of name conventions.
!     92-11-03 F.Bouttier  : Process just one obs for the E.K.F.
!     94-09-18 M.Hamrud    : Multi-tasking change
!     95-09-20 H.Jarvinen  : New CMA- file format
!     95-12-07 F.Bouttier  : Add LDMVO5 option, clean Canari
!     96-12-01 M.Hamrud    : Message passing including 4D-var
!     97-05-27 F.Taillefer : Add DL and DM for the wind orientation
!     97-11-17 E.Andersson : Introduce CIW and O3
!     99-07-02 A. Horanyi  : Bug corrections for ALADIN 3DVAR in order to 
!              avoid inconsistency between direct and adjoint code
!     02-06-19 S.Saarinen  : CALL GETDB to get ABNOB, MAPOMM & OBSTYPE
!     02-03-27 C. Fischer  : Modified correction of compas (adapted from P Moll)
!        M.Hamrud      01-Oct-2003 CY28 Cleaning
!     09-12-04 H. Hersbach : 10-m neutral wind; argument PPARITY
!    -------------------------------------------------------------------

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

USE YOMDIM   , ONLY : NDGSAG   ,NDGENG   ,NFLEVG
USE YOMCST   , ONLY : RPI
USE YOMCT0   , ONLY : LELAM    
USE YOMGEM   , ONLY : NSTTYP
USE YOMSC2   , ONLY : NFLDOBB1
USE YOMECTAB , ONLY : NTSLOTNO
USE YOMGLOBS , ONLY : NSTARECVAD,RLATRECVAD,&
 & RLONRECVAD,NGLOBKEYAD,LPREMPOBS  
USE YOMDB
USE YOMLUN   , ONLY : NULERR
USE GOMS_MIX     , ONLY : NGOMGFL
USE OBSHOR_CACHE_MIX

IMPLICIT NONE

! * DUMMY:
INTEGER(KIND=JPIM),INTENT(IN)    :: KASLB1 
INTEGER(KIND=JPIM),INTENT(IN)    :: KIBUFP1(NDGSAG:NDGENG) 
INTEGER(KIND=JPIM),INTENT(IN)    :: KPROMB 
INTEGER(KIND=JPIM),INTENT(IN)    :: KPROMBMP
REAL(KIND=JPRB)   ,INTENT(OUT)   :: PPARITY(NFLDOBB1) 
REAL(KIND=JPRB)   ,INTENT(INOUT) :: POBB1(KASLB1,NFLDOBB1) 

! * LOCAL
REAL(KIND=JPRB),TARGET  :: ZSL((3+NGOMGFL)*NFLEVG+8,KPROMB)
REAL(KIND=JPRB),POINTER :: ZSLU    (:,:)
REAL(KIND=JPRB),POINTER :: ZSLV    (:,:)
REAL(KIND=JPRB),POINTER :: ZSLT    (:,:)
REAL(KIND=JPRB),POINTER :: ZSLGFL  (:,:)
REAL(KIND=JPRB),POINTER :: ZSLSP   (:)
REAL(KIND=JPRB),POINTER :: ZSLTS   (:)
REAL(KIND=JPRB),POINTER :: ZSLWS   (:)
REAL(KIND=JPRB),POINTER :: ZSLSN   (:)
REAL(KIND=JPRB),POINTER :: ZSLZ0   (:)
REAL(KIND=JPRB),POINTER :: ZSLWL   (:)
REAL(KIND=JPRB),POINTER :: ZSLU10N (:)
REAL(KIND=JPRB),POINTER :: ZSLV10N (:)
REAL(KIND=JPRB) :: ZSLDL   (KPROMB)
REAL(KIND=JPRB) :: ZSLDM   (KPROMB)
REAL(KIND=JPRB) :: ZLON(KPROMB,1),ZLAT(KPROMB,1)
INTEGER(KIND=JPIM), POINTER :: IOBTYP(:)
INTEGER(KIND=JPIM), POINTER :: IOBNUM(:),IOBNUMA(:)

INTEGER(KIND=JPIM) :: IOBS, IOFFTS,&
 & IPT, ITS, JLEV, JOBS, IRET, INFO(0),J,IDIM2

REAL(KIND=JPRB) :: ZDL2, ZDM2, ZEPS, ZINFO(0), ZRAY
REAL(KIND=JPRB) :: ZHOOK_HANDLE

#include "fcobs.h"

INTERFACE
#include "getdb.h"
#include "putdb.h"
#include "abortdb.h"
END INTERFACE

#include "mpobseqad.intfb.h"
#include "mpobseqad_unpck.intfb.h"
#include "slintad.intfb.h"

#include "openmp_obs.h"

!    --------------------------------------------------------------------
!*       1. PRESET
!           ------

IF (LHOOK) CALL DR_HOOK('OBSHORAD',0,ZHOOK_HANDLE)
CALL GSTATS(44,0)

ITS = NTSLOTNO

CALL GSTATS(1861,0)
PPARITY(1:NFLDOBB1)=1
IPT = 0
ZSLU => ZSL(IPT+1:IPT+NFLEVG,:)
    PPARITY(IPT+1:IPT+NFLEVG)=-1
IPT = IPT+NFLEVG
ZSLV => ZSL(IPT+1:IPT+NFLEVG,:)
    PPARITY(IPT+1:IPT+NFLEVG)=-1
IPT = IPT+NFLEVG
ZSLT => ZSL(IPT+1:IPT+NFLEVG,:)
IPT = IPT+NFLEVG
ZSLGFL => ZSL(IPT+1:IPT+NGOMGFL*NFLEVG,:)
IPT = IPT+NGOMGFL*NFLEVG
ZSLSP => ZSL(IPT+1,:)
IPT = IPT+1
ZSLTS => ZSL(IPT+1,:)
IPT = IPT+1
ZSLWS => ZSL(IPT+1,:)
IPT = IPT+1
ZSLSN => ZSL(IPT+1,:)
IPT = IPT+1
ZSLZ0 => ZSL(IPT+1,:)
IPT = IPT+1
ZSLWL => ZSL(IPT+1,:)
IPT = IPT+1
ZSLU10N => ZSL(IPT+1,:)
       PPARITY(IPT+1)=-1
IPT = IPT+1
ZSLV10N => ZSL(IPT+1,:)
       PPARITY(IPT+1)=-1
IPT = IPT+1

!*       1.1   EXTRACT LAT., LON., OBS. TYPE AND OBS. NUMBERS

IOFFTS = NSTARECVAD(1,ITS)
DO JOBS=1,KPROMB
  IOBS = NGLOBKEYAD(IOFFTS+JOBS)
  ZLAT(IOBS,1) = RLATRECVAD(IOFFTS+JOBS)
  ZLON(IOBS,1) = RLONRECVAD(IOFFTS+JOBS)
ENDDO

DO JOBS=1,KPROMB
  IF ( .NOT. LELAM) THEN
    IF (ZLON(JOBS,1) < 0.0_JPRB) THEN
      ZLON(JOBS,1) = ZLON(JOBS,1) + 2.0_JPRB*RPI
    ENDIF
    IF (ZLON(JOBS,1) >= 2.0_JPRB*RPI) THEN
      ZLON(JOBS,1) = ZLON(JOBS,1) - 2.0_JPRB*RPI
    ENDIF
  ENDIF
ENDDO


CALL OBSHOR_CACHE_ALLOC('OBSHORAD', ITS, KPROMBMP)
CALL GSTATS(1861,1)

IF (.NOT.OBSHOR_CACHE(ITS)%PROCESSED) THEN
  IRET = 0
  CALL GETDB('OBSHOR', 0, IRET, INFO, 0, ZINFO, 0,   &! Get ROBSU
   & -1, ITS, -1, -1, -1, -1)  

  IF (IRET /= KPROMBMP) THEN
    WRITE(NULERR,*) '*** Error in OBSHORAD: INCONSISTENT NO. OF OBSERVATIONS FROM GETDB'
    WRITE(NULERR,*) 'For timeslot=',ITS,' expecting =',KPROMBMP,', but got =',IRET
    CALL ABORTDB('OBSHORAD','INCONSISTENCIES FROM GETDB',IRET)
  ENDIF

  IF (KPROMBMP > 0) THEN
    DO JOBS=1,KPROMBMP
      OBSHOR_CACHE(ITS)%OBSTYPE(JOBS) = ROBSU(JOBS, MDBOTP)
      OBSHOR_CACHE(ITS)%MAPOMM(JOBS)  = ROBSU(JOBS, MDB_MAPOMM_AT_INDEX)
      OBSHOR_CACHE(ITS)%ABNOB(JOBS)   = ROBSU(JOBS, MDB_ABNOB_AT_INDEX)
    ENDDO

  ENDIF

  CALL PUTDB('OBSHOR', 0, IRET, INFO, 0, ZINFO, 0)

  OBSHOR_CACHE(ITS)%PROCESSED = .TRUE.
ENDIF

!-- Avoid copying, because this is timecritical
IOBTYP  => OBSHOR_CACHE(ITS)%OBSTYPE
IOBNUM  => OBSHOR_CACHE(ITS)%MAPOMM
IOBNUMA => OBSHOR_CACHE(ITS)%ABNOB

!    -------------------------------------------------------------------
!*       2. TAKE INTERPOLATED VARIABLES FROM GOMU ETC.
!           ------------------------------------------

! No worries : We quarantee at least one element allocation for IOB*() in OBSHOR_CACHE_MIX !

!*      2.2  EXCHANGE OBS.EQ.


CALL GSTATS(1076,0)
IDIM2 = SIZE(ZSL,2)
!$OMP PARALLEL DO SCHEDULE(STATIC) PRIVATE(J)
DO J=1,IDIM2
  ZSL(:,J) = 0.0_JPRB
ENDDO
!$OMP END PARALLEL DO
CALL GSTATS(1076,1)

IF(.NOT. LPREMPOBS) THEN
  CALL GSTATS(44,2)
  CALL GSTATS(94,0)
  CALL MPOBSEQAD
  CALL GSTATS(94,1)
  CALL GSTATS(44,3)
ENDIF
CALL MPOBSEQAD_UNPCK(KPROMB,IOBTYP,IOBNUM,IOBNUMA,&
 & ZSLU,ZSLV,ZSLT,ZSLGFL,&
 & ZSLSP,&
 & ZSLDL,ZSLDM,&
 & ZSLTS,ZSLWS,ZSLSN,ZSLZ0,ZSLWL,&
 & ZSLU10N,ZSLV10N)  


!    -------------------------------------------------------------------
!*       3.  S/L INTERPOLATOR
!            ----------------

!*      3.1   Convert u and v from geographical to model grid

IF (NSTTYP == 2.OR.LELAM) THEN
  ZEPS=1.E-8_JPRB
  DO JOBS = 1 , KPROMB
    ZRAY=SQRT(ZSLDL(JOBS)*ZSLDL(JOBS)+ZSLDM(JOBS)*ZSLDM(JOBS))
    IF (ZRAY < ZEPS*SQRT(2.0_JPRB)) THEN
      ZSLDL(JOBS)=SIGN(ZEPS,ZSLDL(JOBS))
      ZSLDM(JOBS)=SIGN(ZEPS,ZSLDM(JOBS))
    ENDIF
    ZRAY=MAX(ZRAY,ZEPS*SQRT(2.0_JPRB))
    ZSLDL(JOBS)=ZSLDL(JOBS)/ZRAY
    ZSLDM(JOBS)=ZSLDM(JOBS)/ZRAY
  ENDDO

  DO JLEV = 1 , NFLEVG
    DO JOBS = 1 , KPROMB
      ZDL2=ZSLU(JLEV,JOBS)*ZSLDM(JOBS)+ZSLV(JLEV,JOBS)*ZSLDL(JOBS)
      ZDM2=-ZSLU(JLEV,JOBS)*ZSLDL(JOBS)+ZSLV(JLEV,JOBS)*ZSLDM(JOBS)
      ZSLU(JLEV,JOBS)=ZDL2
      ZSLV(JLEV,JOBS)=ZDM2
    ENDDO
  ENDDO
ENDIF

!*      3.2   Interpolation

IF(KPROMB > 0) THEN
  CALL SLINTAD(KPROMB,KIBUFP1,KASLB1,IPT,&
   & ZLAT    ,ZLON    ,POBB1   ,ZSL)  
ENDIF

CALL GSTATS(44,1)

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

IF (LHOOK) CALL DR_HOOK('OBSHORAD',1,ZHOOK_HANDLE)
END SUBROUTINE OBSHORAD
