SUBROUTINE RTL_HOP_2D(KDLEN,KLEN,KHORIZ,KMXRAD,KNRAD,KOBSTYPE,YDLIMBGRP, &
  & PICHAN ,PITAN,POROG5,                                                &
  & PPRESH5,PPRESF5,PPXP5,PPXPD5,PUF5,PVF5,PTF5,PQF5,PO3F5,              &
  & PCLWF5,PCIWF5,PCCF5,PTSTAR5,PT05,PLNPR5,PALPH5,PXPP)


!**** *RTL_HOP_2D* - Top level observation operator for RTLIMB

!     N. BORMANN              ECMWF          08/07/05

!     PURPOSE
!     -------
!        Treats one set of observations, performing the following tasks:
!     1. Interpolate to fixed pressure levels.
!     2. Call radiative transfer model

!**   INTERFACE
!     ---------
!        *CALL* *RTL_HOP_2D(KDLEN,KLEN,KHORIZ,KMXRAD,KNRAD,KOBSTYPE,YDLIMBGRP,&
!  & PICHAN ,PITAN,POROG5,                                                &
!  & PPRESH5,PPRESF5,PPXP5,PPXPD5,PUF5,PVF5,PTF5,PQF5,PO3F5,              &
!  & PCLWF5,PCIWF5,PCCF5,PTSTAR5,PT05,PLNPR5,PALPH5,PXPP)*
!     WHERE KDLEN    = First dimension: Max number of observations, this set
!           KLEN     = Actual number of observations
!           KHORIZ   = Number of profiles in plane
!           KMXRAD   = Second dimension (radiance data)
!           KNRAD    = Actual number of radiances per observation
!           KOBSTYPE = Obs. type
!           YDLIMBGRP= Limb group table for this set
!           PICHAN   = Channel numbers
!           PITAN    = Tangent height/pressure numbers
!           POROG5   = Orography
!           PRESH5   = Half level pressures
!           PRESF5   = Full level pressures
!           PXP5     = Intemediate array
!           PXPD5    = .................
!           PUF5     = U at model full levels
!           PVF5     = V at model full levels
!           PTF5     = T at model full levels
!           PQF5     = Q at model full levels
!           PO3F5    = Ozone at model full levels
!           PCLWF5   = Cloud liquid water at model full levels
!           PCIWF5   = Cloud ice at model full levels 
!           PCCF5    = Cloud cover at model full levels 
!           PTSTAR5  = T*
!           PT05     = T0
!           PLNPR5   = Log of the ratio of pressure 
!           PALPH5   = Coefficients of the hydrostatics 
!           PXPP     = Output values

!        RTL_HOP_2D IS CALLED FROM HOP
 

!**   METHOD
!     ------

!**   EXTERNALS

!        PPOBSA     - Interpolation in vertical
!        RTLIMB_HAT - RTLIMB radiative transfer model

!**   MODIFICATIONS
!     -------------
!     -------------------------------------------------------------------------

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

 USE YOMANCS  , ONLY : RDEGREES , RMDI
 USE YOMCST   , ONLY : RD
 USE YOMLUN   , ONLY : NULERR
 USE YOMDIM   , ONLY : NFLEVG   ,NPPM
 USE YOMLIMB  , ONLY : y_limbgrp_t, NPNAV_RTL, NPMXTAN, NJPPF_RTL, LQTAN_PRES,&
  &                    PP_TOLERANCE, PP_MESO_DT_BY_DLNP, PP_MESO_P,    &
  &                    DTHETA
 USE YOMDB

 IMPLICIT NONE

 ! Subroutine arguments

 INTEGER(KIND=JPIM),INTENT(IN)    :: KDLEN ! Max number of obs., this set
 INTEGER(KIND=JPIM),INTENT(IN)    :: KLEN  ! Actual number of obs.
 INTEGER(KIND=JPIM),INTENT(IN)    :: KHORIZ! Number of profiles per plane
 INTEGER(KIND=JPIM),INTENT(IN)    :: KMXRAD! Maximum number of radiance obs. per profile
 INTEGER(KIND=JPIM),INTENT(IN)    :: KNRAD(KDLEN) ! Number of radiance obs.
 INTEGER(KIND=JPIM),INTENT(IN)    :: KOBSTYPE 
 TYPE(y_limbgrp_t)   ,INTENT(IN)  :: YDLIMBGRP ! Info on limb group
!   PICHAN   : Channel index per radiance obs.
!   PITAN    : Tangent height index per radiance obs.
 REAL(KIND=JPRB),   INTENT(IN)    :: PICHAN(KDLEN,KMXRAD)
 REAL(KIND=JPRB),   INTENT(IN)    :: PITAN(KDLEN,KMXRAD)
!   POROG5  :   Model orography at obs points
 REAL(KIND=JPRB),   INTENT(IN)    :: POROG5(KDLEN,KHORIZ)
!   PPRESH5,ZPRESF5 :   Half/Full level pressure values at obs points
 REAL(KIND=JPRB),   INTENT(IN)    :: PPRESH5(KDLEN,0:NFLEVG,KHORIZ)
 REAL(KIND=JPRB),   INTENT(IN)    :: PPRESF5(KDLEN,NFLEVG,KHORIZ)
!   PPXP5,PPXPD5 :   Intermediate variables (see PPINIT)
!   PPXZ5,PPXZD5 :   Intermediate variables (see PPINITZ)
 REAL(KIND=JPRB),   INTENT(IN)    :: PPXP5(KDLEN,0:NFLEVG,NPPM,KHORIZ)
 REAL(KIND=JPRB),   INTENT(IN)    :: PPXPD5(KDLEN,0:NFLEVG,NPPM,KHORIZ)
!   Model U/V/T/Q/O3/CLW/CIW/CC at observation points, model levels
!   (only T/Q/O3 are actually used, but all are arguments to PPOBSA)
 REAL(KIND=JPRB),   INTENT(INOUT) :: PUF5(KDLEN,0:NFLEVG,KHORIZ)
 REAL(KIND=JPRB),   INTENT(INOUT) :: PVF5(KDLEN,0:NFLEVG,KHORIZ)
 REAL(KIND=JPRB),   INTENT(INOUT) :: PTF5(KDLEN,0:NFLEVG,KHORIZ)
 REAL(KIND=JPRB),   INTENT(INOUT) :: PQF5(KDLEN,0:NFLEVG,KHORIZ)
 REAL(KIND=JPRB),   INTENT(INOUT) :: PO3F5(KDLEN,0:NFLEVG,KHORIZ)
 REAL(KIND=JPRB),   INTENT(INOUT) :: PCLWF5(KDLEN,0:NFLEVG,KHORIZ)
 REAL(KIND=JPRB),   INTENT(INOUT) :: PCIWF5(KDLEN,0:NFLEVG,KHORIZ)
 REAL(KIND=JPRB),   INTENT(INOUT) :: PCCF5(KDLEN,0:NFLEVG,KHORIZ)
!   PT05    :   Surface temperature (see CTSTAR)
!   PTSTAR5 :   Surface temperature (see CTSTAR)
 REAL(KIND=JPRB),   INTENT(IN)    :: PT05(KDLEN,KHORIZ)
 REAL(KIND=JPRB),   INTENT(IN)    :: PTSTAR5(KDLEN,KHORIZ)
!   PLNPR5  :   LOG. of the ratio of pressure (see GPXYB)
!   PALPH5  :   Coefficients of the hydrostatics (see GPXYB)
 REAL(KIND=JPRB),   INTENT(IN)    :: PLNPR5(KDLEN,NFLEVG,KHORIZ)
 REAL(KIND=JPRB),   INTENT(IN)    :: PALPH5(KDLEN,NFLEVG,KHORIZ)

 REAL(KIND=JPRB),   INTENT(OUT)   :: PXPP(KDLEN,KMXRAD)

 ! Local variables

 ! LLRADCL_TAN:  Mask for radiances
 LOGICAL            :: LLRADCL_TAN(YDLIMBGRP%nmxchan*NJPPF_RTL,NPMXTAN)  

 INTEGER(KIND=JPIM) :: ICOUNTX(KDLEN)
 INTEGER(KIND=JPIM) :: ICHANNELS(YDLIMBGRP%nmxchan*NJPPF_RTL)
 INTEGER(KIND=JPIM) :: IPROFILES(YDLIMBGRP%nmxchan*NJPPF_RTL)
 INTEGER(KIND=JPIM) :: INTAN(NJPPF_RTL)
 INTEGER(KIND=JPIM) :: IERR(NJPPF_RTL)

 INTEGER(KIND=JPIM) :: ILSAT      ! Number of levels in RT model
 INTEGER(KIND=JPIM) :: JHORIZ    
 INTEGER(KIND=JPIM) :: IEND       
 INTEGER(KIND=JPIM) :: IDONE
 INTEGER(KIND=JPIM) :: IOBS
 INTEGER(KIND=JPIM) :: ILEVMESO   ! Level below PP_MESO_P or model top (whatever is higher) 
 INTEGER(KIND=JPIM) :: ILEVTOP    ! Level below model top
 INTEGER(KIND=JPIM) :: IPACK
 INTEGER(KIND=JPIM) :: JJPACK
 INTEGER(KIND=JPIM) :: JF, JJF
 INTEGER(KIND=JPIM) :: IFIELD(3)
 INTEGER(KIND=JPIM) :: JLEV
 INTEGER(KIND=JPIM) :: JJPF
 INTEGER(KIND=JPIM) :: JCHAN
 INTEGER(KIND=JPIM) :: JRAD
 INTEGER(KIND=JPIM) :: JTAN

 REAL(KIND=JPRB) :: ZPRES(KDLEN,YDLIMBGRP%nlsat)        ! Fixed pres levels
 REAL(KIND=JPRB) :: ZTQOZPP5(KDLEN,YDLIMBGRP%nlsat,NPNAV_RTL,KHORIZ)! Interpol. values
 REAL(KIND=JPRB) :: ZLNPRES(YDLIMBGRP%nlsat)

 REAL(KIND=JPRB) :: ZMAXRT(YDLIMBGRP%nlsat,NPNAV_RTL)   ! Limit profiles
 REAL(KIND=JPRB) :: ZMINRT(YDLIMBGRP%nlsat,NPNAV_RTL)   ! for RTLIMB validity
 REAL(KIND=JPRB) :: ZPROF(YDLIMBGRP%nlsat,NPNAV_RTL,KHORIZ,NJPPF_RTL)! Profile vals
 REAL(KIND=JPRB) :: ZZTAN(NPMXTAN,NJPPF_RTL)           ! Tangent heights
 REAL(KIND=JPRB) :: ZPTAN(NPMXTAN,NJPPF_RTL)           ! Tangent pressures
 REAL(KIND=JPRB) :: ZTHTAN(NPMXTAN,NJPPF_RTL)          ! Tangent thetas
 REAL(KIND=JPRB) :: ZLAT(NJPPF_RTL)                    ! Latitude
 REAL(KIND=JPRB) :: ZRADCRV(NJPPF_RTL)                 ! Radius of curvature
 REAL(KIND=JPRB) :: ZX

 ! ZRADCL_TAN: Limb radiances
 REAL(KIND=JPRB)     :: ZRADCL_TAN(YDLIMBGRP%nmxchan*NJPPF_RTL,NPMXTAN) 

 REAL(KIND=JPRB) :: ZHOOK_HANDLE

#include "ppobsa.intfb.h"
#include "abor1.intfb.h"

#include "openmp_obs.h"

!==============================================================

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

!*    1)     Interpolate T, q, and O3 to fixed pressure levels

 ILSAT = YDLIMBGRP%nlsat
 ICOUNTX(1:KLEN) = ILSAT

 DO JLEV = 1, ILSAT
   ZPRES(1:KLEN,JLEV) = YDLIMBGRP%radpre(JLEV)
   ZLNPRES(JLEV)      = LOG(YDLIMBGRP%radpre(JLEV))
 ENDDO

 DO JHORIZ = 1, KHORIZ
   CALL PPOBSA(KDLEN,KLEN,ILSAT,'RTL',KOBSTYPE,ICOUNTX,ZPRES,        &
    & POROG5(:,JHORIZ),PPRESH5(:,:,JHORIZ),PPRESF5(:,:,JHORIZ),      &
    & PPXP5(:,:,:,JHORIZ),PPXPD5(:,:,:,JHORIZ),                      &
    & PUF5(:,:,JHORIZ),PVF5(:,:,JHORIZ),PTF5(:,:,JHORIZ),            &
    & PQF5(:,:,JHORIZ),PO3F5(:,:,JHORIZ),                            &
    & PCLWF5(:,:,JHORIZ),PCIWF5(:,:,JHORIZ),PCCF5(:,:,JHORIZ),       &
    & PTSTAR5(:,JHORIZ),PT05(:,JHORIZ),                              &
    & PLNPR5(:,:,JHORIZ),PALPH5(:,:,JHORIZ),                         &
    & NPNAV_RTL,ZTQOZPP5(:,:,:,JHORIZ)) 
 ENDDO 

!*    2)     Replace temperature and geopotential extrapolated above model's 
!*           top with values from fixed mesospheric temperature gradient; T=1 

 IOBS=1
 ILEVTOP=0
 DO JLEV = ILSAT, 1, -1
   IF ( YDLIMBGRP%radpre(JLEV) >= PPRESF5(IOBS,1,1) ) ILEVTOP = JLEV
 ENDDO

 ILEVMESO = ILEVTOP
 DO JLEV = ILEVTOP, 1, -1
   IF ( YDLIMBGRP%radpre(JLEV) >= PP_MESO_P ) ILEVMESO = JLEV 
 ENDDO

 DO IOBS = 1, KLEN
   DO JHORIZ = 1, KHORIZ
     DO JLEV = ILEVMESO-1, 1, -1
       ZTQOZPP5(IOBS,JLEV,1,JHORIZ) = ZTQOZPP5(IOBS,ILEVMESO,1,JHORIZ)  &
        &   + (ZLNPRES(JLEV) - ZLNPRES(ILEVMESO)) * PP_MESO_DT_BY_DLNP
     ENDDO

     ! Dry geopotential
     DO JLEV = ILEVTOP-1, 1, -1
       ZTQOZPP5(IOBS,JLEV,3,JHORIZ) = ZTQOZPP5(IOBS,JLEV+1,3,JHORIZ)    &
        &   + 0.5_JPRB * (   ZTQOZPP5(IOBS,JLEV  ,1,JHORIZ)             &
        &                  + ZTQOZPP5(IOBS,JLEV+1,1,JHORIZ))            &
        &     * RD * ( ZLNPRES(JLEV+1) - ZLNPRES(JLEV) )
     ENDDO
   ENDDO
 ENDDO


!*    3)     Separate into suitable chunks of work (following RADTR)
!*           and call RTLIMB model

!*    3.1    Some preparations
!*    ------------------------------------------------------------------

 IPACK=(KLEN-1)/NJPPF_RTL + 1     ! Number of packets

 ZMAXRT(:,1)=YDLIMBGRP%tmaxrt(:)
 ZMAXRT(:,2)=YDLIMBGRP%qmaxrt(:)
 ZMAXRT(:,4)=YDLIMBGRP%o3maxrt(:)
 ZMINRT(:,1)=YDLIMBGRP%tminrt(:)
 ZMINRT(:,2)=YDLIMBGRP%qminrt(:)
 ZMINRT(:,4)=YDLIMBGRP%o3minrt(:)

!        Profile and channel indeces (see 3.2.2)

 DO JJPF = 1, NJPPF_RTL
   DO JCHAN = 1, YDLIMBGRP%nmxchan
     IPROFILES((JJPF-1)*YDLIMBGRP%nmxchan + JCHAN) = JJPF
     ICHANNELS((JJPF-1)*YDLIMBGRP%nmxchan + JCHAN) = JCHAN
   ENDDO
 ENDDO

!*    3.2    Loop through packets
!*    ------------------------------------------------------------------

 IDONE=0
 PACKET_LOOP: DO JJPACK=1,IPACK

   IERR = 0

   IEND = MIN(NJPPF_RTL, KLEN-IDONE)

!*    3.2.1  Check validity limits for regressions
!*           Temperature=1, Humidity=2, Z=3, Ozone=4

   IFIELD = (/ 1, 2, 4 /)
   DO JJF=1,3
     JF = IFIELD(JJF)
     DO JHORIZ=1,KHORIZ
       DO JLEV=1,ILSAT
         DO JJPF=1,IEND
           ZX=ZTQOZPP5(JJPF+IDONE,JLEV,JF,JHORIZ)
           IF(ZX > (1.0_JPRB + PP_TOLERANCE) * ZMAXRT(JLEV,JF)) THEN
             ZPROF(JLEV,JF,JHORIZ,JJPF) =             &
              &    (1.0_JPRB + PP_TOLERANCE) * ZMAXRT(JLEV,JF)
           ELSEIF(ZX < (1.0_JPRB - PP_TOLERANCE) * ZMINRT(JLEV,JF)) THEN
             ZPROF(JLEV,JF,JHORIZ,JJPF) =             &
              &    (1.0_JPRB - PP_TOLERANCE) * ZMINRT(JLEV,JF)
           ELSE
             ZPROF(JLEV,JF,JHORIZ,JJPF) = ZX
           ENDIF
         ENDDO
       ENDDO
     ENDDO
   ENDDO
   DO JHORIZ=1,KHORIZ
     DO JLEV=1,ILSAT
       DO JJPF=1,IEND
         ZPROF(JLEV,3,JHORIZ,JJPF) = ZTQOZPP5(JJPF+IDONE,JLEV,3,JHORIZ)
       ENDDO
     ENDDO
   ENDDO

!*    3.2.2  Set up which channels and tangent heights should be
!*           calculated.
!*           Channels numbers refer to channel numbers in RTLIMB
!*           coefficient file.
!*           Extract tangent height parameters.

   LLRADCL_TAN(:,:) = .FALSE.
   DO JJPF = 1, IEND

     INTAN(JJPF) = NINT(SATHDR(JJPF+IDONE, MDB_NTAN_AT_LIMB))
     IF( INTAN(JJPF) > NPMXTAN )THEN
       WRITE(NULERR,*)'RTL_HOP_2D: ntan too large:',INTAN(JJPF)
       CALL ABOR1('RTL_HOP_2D: ntan too large')
     ENDIF
     DO JTAN = 1, INTAN(JJPF)
       ZZTAN(JTAN,JJPF) = SATHDR(JJPF+IDONE, MDB_ZTAN_AT_LIMB(JTAN))
       ZPTAN(JTAN,JJPF) = SATHDR(JJPF+IDONE, MDB_PTAN_AT_LIMB(JTAN))
       ZTHTAN(JTAN,JJPF) = SATHDR(JJPF+IDONE, MDB_THTAN_AT_LIMB(JTAN))
     ENDDO

     DO JRAD = 1, KNRAD(JJPF+IDONE)
       JCHAN = NINT(PICHAN(JJPF+IDONE,JRAD))
       JTAN  = NINT(PITAN(JJPF+IDONE,JRAD))
       IF( .NOT. LQTAN_PRES                                                   &
        & .OR. (ZPTAN(JTAN,JJPF) > 0.0_JPRB .AND. ZPTAN(JTAN,JJPF) /= RMDI ) )&
        &  LLRADCL_TAN((JJPF-1)*YDLIMBGRP%nmxchan + JCHAN,JTAN) = .TRUE.  
     ENDDO

     ZLAT(JJPF)    = ROBHDR(JJPF+IDONE,MDBLAT)*RDEGREES
     ZRADCRV(JJPF) = ROBHDR(JJPF+IDONE,MDBRADCURV)

   ENDDO

!*    3.2.3  Call RTLIMB

   CALL RTLIMB_HAT(ILSAT, IEND, KHORIZ, YDLIMBGRP%nmxchan, NPMXTAN,          &
    & DTHETA*RDEGREES, ICHANNELS, IPROFILES, INTAN, ZZTAN, ZPTAN, ZTHTAN,    &
    & ZLAT,ZRADCRV,YDLIMBGRP%radpre/100.0_JPRB,ZPROF,                        &
    & YDLIMBGRP%rtcoef_pos,                                                  &
    & LLRADCL_TAN(1:YDLIMBGRP%nmxchan*IEND,:),                               &
    & ZRADCL_TAN(1:YDLIMBGRP%nmxchan*IEND,:), IERR)

   IF(ANY(IERR /= 0))THEN
     WRITE(NULERR,*)'***RTLIMB error***'
     CALL ABOR1('RTL_HOP_2D: RTLIMB error')
   ENDIF

!*    3.2.4  Construct output array containing model radiances

   DO JJPF = 1, IEND
     DO JRAD = 1, KNRAD(JJPF+IDONE)
       JCHAN = NINT(PICHAN(JJPF+IDONE,JRAD))
       JTAN  = NINT(PITAN(JJPF+IDONE,JRAD))
       PXPP(JJPF+IDONE,JRAD) =ZRADCL_TAN((JJPF-1)*YDLIMBGRP%nmxchan+JCHAN,JTAN)
     ENDDO
   ENDDO

   IDONE=IDONE+IEND 
 ENDDO PACKET_LOOP

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

END SUBROUTINE RTL_HOP_2D
