SUBROUTINE HRADP(KIND,KDLEN,KLEN,KDFS,KSET,POROG5,POROGOB,&
 & PNVANG,PZEANG,KCOEF,&
 & PPRESH5,PPRESF5,PTF5,PTSTAR5,PT05,PTQOPP5,&
 & PLS5,PCI5,PPS5,PTS5,PT2M5,PQ2M5,PCTOP5,PCAMT5)  

!****  HRADP  - PREPARATION FOR THE RADIANCE INTERPOLATION

!     ERIK ANDERSSON          01/04/99       ECMWF

!     PURPOSE
!     -------

!        HRADP PREPARES INTERPOLATION FOR ONE SET OF OBSERVATIONS.

!**   INTERFACE
!     ---------

!        CALL HRADP(KIND,KDLEN,KLEN,KSET,POROG5,POROGOB,&
!    &PNVANG,PZEANG,KCOEF,&
!    &PPRESH5,PPRESF5,PTF5,PTSTAR5,PT05,PTQOPP5,&
!    &PLS5,PPS5,PTS5,PT2M5,PQ2M5)

!        Where KIND    = Mode of call, 1=SCREEN, 2=FWD, 3=TL, 4=AD
!              KDLEN   = First dimension (Number of observations)
!              KLEN    = Actual number of observations
!              KSET    = Number (numero) of the obs set to be treated
!              POROG5  = Model's orography
!              POROGOB = Observation's orography
!              PNVANG  = Nadir viewing angle
!              PZEANG  = Zenith angle
!              KCOEF   = Location of rttov transmittance coeffs, for this sat
!              PPRESH5 = Half-level pressures
!              PPRESF5 = Full-level pressures
!              PTF5    = Model level temperature
!              PTSTAR5 = Surface temperature (see CTSTAR)
!              PT05    = Surface temperature (see CTSTAR)
!              PTQOPP5 =Model T,Q and O3 on NLSAT pressure levels
!              PLS5    = Land/Sea Mask
!              PCI5    = Sea-ice fraction
!              PPS5    = Surface pressure at TOVS locations
!              PTS5    = Surface skin temperature
!              PT2M5   = Two-metre temperature, for rttov
!              PQ2M5   = Two-metre spec. humidity, for rttov

!        HRADP IS CALLED FROM HOP

!**   METHOD
!     ------

!**   EXTERNALS
!     ---------

!**   MODIFICATIONS
!     -------------
!     E.Andersson 990104 : Original
!     P.Viterbo   990901 : Sea-ice fraction
!     Xu Li       000523 : Add FOV information for VTPR
!     N. Bormann  010622 : Altered call to HSATANG
!     P.Viterbo   28.05.2004 surf library and modified surface units
!     ------------------------------------------------------------------

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

USE YOMCT0   , ONLY : LOBSREF  ,LOBSC1
USE YOMCT0B  , ONLY : LECMWF
USE YOMCMA   , ONLY :   NRESUPD
USE GOMS_MIX     , ONLY : LGOMUA,YGOMV
USE YOMDIMO  , ONLY : NLSAT, NPNAV
USE YOMDIM   , ONLY : NFLEVG
USE YOMTVRAD , ONLY : O3CLRT   ,RADPRE   ,SATGRP_TABLE,TOVSCVX  ,&
 & TOVSCVX5 ,TVTSBGE_LAND,TVTSBGE_SEA,TVTSBGE_ICE,&
 & SATOBGRP_TABLE, CO2BGE_S, CO2CLRT_S, CO2BGE_T, CO2CLRT_T
USE YOMCST   , ONLY : RPI
USE YOMANCS  , ONLY : RMDI
USE YOMVAR   , ONLY : LTOVSCV  ,NUPTRA, LCO2, LCLDSINK , CTOPBGE , CAMTBGE
USE YOMCOCTP , ONLY : NGTHRB   , NSATOB
USE YOMOBSET , ONLY : MTYPOB
USE YOMVRTL  , ONLY : LTLINT   ,LOBSTL
USE YOMDB

IMPLICIT NONE

INTEGER(KIND=JPIM),INTENT(IN)    :: KIND 
INTEGER(KIND=JPIM),INTENT(IN)    :: KDLEN 
INTEGER(KIND=JPIM),INTENT(IN)    :: KLEN 
INTEGER(KIND=JPIM),INTENT(IN)    :: KDFS
INTEGER(KIND=JPIM),INTENT(IN)    :: KSET 
REAL(KIND=JPRB)   ,INTENT(IN)    :: POROG5(KDLEN) 
REAL(KIND=JPRB)   ,INTENT(IN)    :: POROGOB(KDLEN) 
REAL(KIND=JPRB)   ,INTENT(OUT)   :: PNVANG(KDLEN) 
REAL(KIND=JPRB)   ,INTENT(OUT)   :: PZEANG(KDLEN)
INTEGER(KIND=JPIM),INTENT(OUT)   :: KCOEF 
REAL(KIND=JPRB)   ,INTENT(IN)    :: PPRESH5(KDLEN,0:NFLEVG) 
REAL(KIND=JPRB)   ,INTENT(IN)    :: PPRESF5(KDLEN,NFLEVG) 
REAL(KIND=JPRB)   ,INTENT(IN)    :: PTF5(KDLEN,0:NFLEVG) 
REAL(KIND=JPRB)   ,INTENT(IN)    :: PTSTAR5(KDLEN) 
REAL(KIND=JPRB)   ,INTENT(IN)    :: PT05(KDLEN) 
REAL(KIND=JPRB)   ,INTENT(INOUT) :: PTQOPP5(KDLEN,NLSAT,KDFS) 
REAL(KIND=JPRB)   ,INTENT(IN)    :: PLS5(KDLEN) 
REAL(KIND=JPRB)   ,INTENT(IN)    :: PCI5(KDLEN) 
REAL(KIND=JPRB)   ,INTENT(INOUT) :: PPS5(KDLEN) 
REAL(KIND=JPRB)   ,INTENT(INOUT) :: PTS5(KDLEN) 
REAL(KIND=JPRB)   ,INTENT(OUT)   :: PT2M5(KDLEN) 
REAL(KIND=JPRB)   ,INTENT(OUT)   :: PQ2M5(KDLEN),PCTOP5(KDLEN),PCAMT5(KDLEN) 
REAL(KIND=JPRB), ALLOCATABLE :: Z_PTFOUT(:,:)
REAL(KIND=JPRB), ALLOCATABLE :: Z_PTFINP(:,:)
INTEGER(KIND=JPIM), PARAMETER :: JP_T=1, JP_Q=2, JP_O3=3, JP_CO2=4

INTEGER(KIND=JPIM), DIMENSION(KDLEN) :: ILTROP

INTEGER(KIND=JPIM) :: IOBSTYPE,ICDTYP_TOVS,IGRP,ISERIES
INTEGER(KIND=JPIM) :: IPOSM,INLAMTOP,IOBS,IPMOTOV
INTEGER(KIND=JPIM) :: JOBS,JLEV
REAL(KIND=JPRB), DIMENSION(KDLEN) :: ZORDIF
REAL(KIND=JPRB) :: ZPSINFL,ZDP5,ZA5,ZTSER,ZRCIMIN
LOGICAL :: LLRAD1C,LLSATOB
REAL(KIND=JPRB) :: ZHOOK_HANDLE

INTERFACE
#include "surf_inq.h"
END INTERFACE

#include "extrap.intfb.h"
#include "hsatang.intfb.h"
#include "pppmer.intfb.h"
#include "tropopause.intfb.h"

#include "fcobs.h"

#include "openmp_obs.h"

! ---------------------------------------------------------------------
!*          1.0   Initiate, set switches

IF (LHOOK) CALL DR_HOOK('HRADP',0,ZHOOK_HANDLE)
CALL SURF_INQ(PRCIMIN=ZRCIMIN)
IOBSTYPE = MOD(MTYPOB(KSET),100)
IGRP = MOD(MTYPOB(KSET)/100,100)

LLSATOB = IOBSTYPE == NSATOB

IF(LLSATOB) THEN
  ICDTYP_TOVS = SATOBGRP_TABLE(IGRP)%codetype
  ISERIES     = SATOBGRP_TABLE(IGRP)%rtseries
  KCOEF       = SATOBGRP_TABLE(IGRP)%rtcoef_pos
ELSE
  ICDTYP_TOVS = SATGRP_TABLE(IGRP)%codetype
  ISERIES     = SATGRP_TABLE(IGRP)%rtseries
  KCOEF       = SATGRP_TABLE(IGRP)%rtcoef_pos
ENDIF

LLRAD1C = ICDTYP_TOVS == NGTHRB 

!*          1.1   Compute satellite nadir and viewing angles.
CALL HSATANG(KDLEN,KLEN,IOBSTYPE,ISERIES,ICDTYP_TOVS,IGRP,PNVANG,PZEANG)

!*          1.2   TOVS control variable, Skin temperature.
IF(LTOVSCV .AND. LLRAD1C) THEN
!OCL NOVREC
  DO JOBS = 1,KLEN
    IF(LOBSC1) THEN
      IF(NUPTRA == 0) THEN
        IF(PCI5(JOBS) > ZRCIMIN) THEN
          ZTSER=TVTSBGE_SEA+PCI5(JOBS)*(TVTSBGE_ICE-TVTSBGE_SEA)
        ELSE
          ZTSER=TVTSBGE_SEA+PLS5(JOBS)*(TVTSBGE_LAND-TVTSBGE_SEA)
        ENDIF
        SATHDR(JOBS,MDB1BCP13A)=ZTSER
      ELSE
        PTS5(JOBS) = SATHDR(JOBS,MDB1BCP14A)
      ENDIF
      IF(NUPTRA /= NRESUPD) &
       & SATHDR(JOBS,MDB1BCPTS1(NUPTRA+1))=PTS5(JOBS)  
    ELSEIF(LOBSREF) THEN
      PTS5(JOBS) = SATHDR(JOBS,MDB1BCPTS1(NUPTRA+1))
    ELSE
      IPOSM  = ROBHDR(JOBS,MDB_MAPOMM_AT_INDEX)
      IF((LTLINT .AND. LOBSTL) .OR. KIND == 4) THEN
        PTS5(JOBS) = TOVSCVX5(IPOSM,1)
      ELSE
        PTS5(JOBS) = TOVSCVX(IPOSM,1)
      ENDIF
    ENDIF
    IF(KIND /= 4) SATHDR(JOBS,MDB1BCP14A)=PTS5(JOBS)
  ENDDO
ENDIF

!*          1.2a   TOVS control variable, cloud sink variables

IF(LTOVSCV .AND. LLRAD1C .AND. LCLDSINK) THEN
!OCL NOVREC
  DO JOBS = 1,KLEN
    IF(LOBSC1) THEN
      IF(NUPTRA == 0) THEN
       IF(KIND == 1) THEN  ! when called by HRETR   
        ROBSU(JOBS,MDB_CTOPBG_AT_CLOUD_SINK)=1050.0_JPRB !no active estimates available yet   
        ROBSU(JOBS,MDB_CAMTBG_AT_CLOUD_SINK)= 0.0_JPRB !no active estimates available yet   
        ROBSU(JOBS,MDB_CTOPER_AT_CLOUD_SINK)=CTOPBGE 
        ROBSU(JOBS,MDB_CAMTER_AT_CLOUD_SINK)=CAMTBGE 
        PCTOP5(JOBS)=  ROBSU(JOBS,MDB_CTOPBG_AT_CLOUD_SINK)
        PCAMT5(JOBS)=  ROBSU(JOBS,MDB_CAMTBG_AT_CLOUD_SINK)
       ELSE                 ! when called by HOP
        IF(SATHDR(JOBS,MDB_CLDNE2_AT_ATOVS)>=0.0_JPRB .AND. &
         & SATHDR(JOBS,MDB_CLDNE2_AT_ATOVS)<=0.99_JPRB) THEN
          ! active value but not overcast use clear system
          ROBSU(JOBS,MDB_CTOPBG_AT_CLOUD_SINK)= 555.0_JPRB                             
          ROBSU(JOBS,MDB_CAMTBG_AT_CLOUD_SINK)= 0.0_JPRB                                
          ROBSU(JOBS,MDB_CTOPER_AT_CLOUD_SINK)=0.000001_JPRB  !disable cloud analysis for non-overcast
          ROBSU(JOBS,MDB_CAMTER_AT_CLOUD_SINK)=0.000001_JPRB  !disable cloud analysis for non-overcast
          PCTOP5(JOBS)=  ROBSU(JOBS,MDB_CTOPBG_AT_CLOUD_SINK) 
          PCAMT5(JOBS)=  ROBSU(JOBS,MDB_CAMTBG_AT_CLOUD_SINK)    
        ELSEIF (SATHDR(JOBS,MDB_CLDNE2_AT_ATOVS)>0.99_JPRB .AND. &
         &      SATHDR(JOBS,MDB_CLDNE2_AT_ATOVS)<=1.01_JPRB) THEN
          ! active value overcast use cloud sink system
          ROBSU(JOBS,MDB_CTOPBG_AT_CLOUD_SINK)= SATHDR(JOBS,MDB_CLDPTOP2_AT_ATOVS)
          ROBSU(JOBS,MDB_CAMTBG_AT_CLOUD_SINK)= SATHDR(JOBS,MDB_CLDNE2_AT_ATOVS)
          ROBSU(JOBS,MDB_CTOPER_AT_CLOUD_SINK)=CTOPBGE       
          ROBSU(JOBS,MDB_CAMTER_AT_CLOUD_SINK)=CAMTBGE 
          PCTOP5(JOBS)=  ROBSU(JOBS,MDB_CTOPBG_AT_CLOUD_SINK)
          PCAMT5(JOBS)=  ROBSU(JOBS,MDB_CAMTBG_AT_CLOUD_SINK)    
          PCTOP5(JOBS)= MIN(MAX(PCTOP5(JOBS),51.0_JPRB),1012.0_JPRB)     ! trap cloud top pressure     
        ELSE 
          ! no active value use clear system   
          ROBSU(JOBS,MDB_CTOPBG_AT_CLOUD_SINK)= 555.0_JPRB
          ROBSU(JOBS,MDB_CAMTBG_AT_CLOUD_SINK)= 0.0_JPRB
          ROBSU(JOBS,MDB_CTOPER_AT_CLOUD_SINK)=0.000001_JPRB  !disable cloud analysis for non-overcast
          ROBSU(JOBS,MDB_CAMTER_AT_CLOUD_SINK)=0.000001_JPRB  !disable cloud analysis for non-overcast
          PCTOP5(JOBS)=  ROBSU(JOBS,MDB_CTOPBG_AT_CLOUD_SINK)
          PCAMT5(JOBS)=  ROBSU(JOBS,MDB_CAMTBG_AT_CLOUD_SINK) 
        ENDIF
       ENDIF
      ELSE
        PCTOP5(JOBS)=  ROBSU(JOBS,MDB_CTOPINC_AT_CLOUD_SINK)
        PCAMT5(JOBS)=  ROBSU(JOBS,MDB_CAMTINC_AT_CLOUD_SINK)
        PCTOP5(JOBS)=  MIN(MAX(PCTOP5(JOBS),51.0_JPRB),1012.0_JPRB)     ! trap cloud top pressure
      ENDIF
      IF(NUPTRA /= NRESUPD) THEN
        ROBSU(JOBS,MDB_CTOP_AT_CLOUD_SINK(NUPTRA+1))=PCTOP5(JOBS)
        ROBSU(JOBS,MDB_CAMT_AT_CLOUD_SINK(NUPTRA+1))=PCAMT5(JOBS)
      ENDIF
    ELSE
      IPOSM  = ROBHDR(JOBS,MDB_MAPOMM_AT_INDEX)
        PCTOP5(JOBS)=TOVSCVX5(IPOSM,2)
        PCAMT5(JOBS)=TOVSCVX5(IPOSM,3)
    ENDIF
    IF(KIND /= 4) THEN
      ROBSU(JOBS,MDB_CTOPINC_AT_CLOUD_SINK)=PCTOP5(JOBS)                
      ROBSU(JOBS,MDB_CAMTINC_AT_CLOUD_SINK)=PCAMT5(JOBS)                   
    ENDIF
  ENDDO
ENDIF


!*          1.2a   TOVS control variable, CO2.

IF(LTOVSCV .AND. LLRAD1C .AND. LCO2) THEN

!* Calculate tropopause level at observation location (taken from SUSHFCE.F90)

  CALL TROPOPAUSE(KDLEN,KLEN,PTQOPP5,ILTROP)


!OCL NOVREC
  DO JOBS = 1,KLEN
    IF(LOBSC1) THEN
      IF(NUPTRA == 0) THEN
        ROBDDR(JOBS,MDB_CO2BG_T_AT_CO2_SINK)=CO2CLRT_T
        ROBDDR(JOBS,MDB_CO2BG_S_AT_CO2_SINK)=CO2CLRT_S

        ROBDDR(JOBS,MDB_CO2ER_S_AT_CO2_SINK)=CO2BGE_S
        ROBDDR(JOBS,MDB_CO2ER_T_AT_CO2_SINK)=CO2BGE_T

        PTQOPP5(JOBS,1:ILTROP(JOBS)-1,JP_CO2)=CO2CLRT_S
        PTQOPP5(JOBS,ILTROP(JOBS):NLSAT,JP_CO2)=CO2CLRT_T
      ELSE
        PTQOPP5(JOBS,1:ILTROP(JOBS)-1,JP_CO2)=ROBDDR(JOBS,MDB_CO2INC_S_AT_CO2_SINK)
        PTQOPP5(JOBS,ILTROP(JOBS):NLSAT,JP_CO2)=ROBDDR(JOBS,MDB_CO2INC_T_AT_CO2_SINK)
      ENDIF
      IF(NUPTRA /= NRESUPD) THEN
        ROBDDR(JOBS,MDB_CO2_S_AT_CO2_SINK(NUPTRA+1))=PTQOPP5(JOBS,1,JP_CO2)
        ROBDDR(JOBS,MDB_CO2_T_AT_CO2_SINK(NUPTRA+1))=PTQOPP5(JOBS,NLSAT,JP_CO2)
      ENDIF
    ELSEIF(LOBSREF) THEN
      PTQOPP5(JOBS,1:ILTROP(JOBS)-1,JP_CO2)=ROBDDR(JOBS,MDB_CO2_S_AT_CO2_SINK(NUPTRA+1)) !almost obsolete
      PTQOPP5(JOBS,ILTROP(JOBS):NLSAT,JP_CO2)=ROBDDR(JOBS,MDB_CO2_T_AT_CO2_SINK(NUPTRA+1)) !almost obsolete
    ELSE
      IPOSM  = ROBHDR(JOBS,MDB_MAPOMM_AT_INDEX)
      IF((LTLINT .AND. LOBSTL) .OR. KIND == 4) THEN
        PTQOPP5(JOBS,1:ILTROP(JOBS)-1,JP_CO2)=TOVSCVX5(IPOSM,2)
        PTQOPP5(JOBS,ILTROP(JOBS):NLSAT,JP_CO2)=TOVSCVX5(IPOSM,3)
      ELSE
        PTQOPP5(JOBS,1:ILTROP(JOBS)-1,JP_CO2)=TOVSCVX(IPOSM,2) !almost obsolete
        PTQOPP5(JOBS,ILTROP(JOBS):NLSAT,JP_CO2)=TOVSCVX(IPOSM,3) !almost obsolete
      ENDIF
    ENDIF
    IF(KIND /= 4) THEN
      ROBDDR(JOBS,MDB_CO2INC_S_AT_CO2_SINK)=PTQOPP5(JOBS,1,JP_CO2)
      ROBDDR(JOBS,MDB_CO2INC_T_AT_CO2_SINK)=PTQOPP5(JOBS,NLSAT,JP_CO2)
    ENDIF
  ENDDO
ENDIF

!*          1.3   Replace ozone with climate, if not avalable as model field.

IF(.NOT.LGOMUA(IOBSTYPE,YGOMV%MO3)) THEN
  DO JLEV = 1,NLSAT
    PTQOPP5(1:KLEN,JLEV,JP_O3)=O3CLRT(JLEV)
  ENDDO
ENDIF

!*          1.4   Find fix pressure level corresponding to model's top
!                 (Assumes top model level is a pressure surface)
!                 Check is performed in terms of integer-Pascals.

IOBS=1
INLAMTOP=0
DO JLEV = 1,NLSAT
  IF(NINT(RADPRE(JLEV)) < NINT(PPRESF5(IOBS,1))) INLAMTOP=JLEV
ENDDO

!*          1.5   Replace temperature above model's top

IF((LLRAD1C .OR. LLSATOB) .AND. KIND /= 1) THEN
  IF (LECMWF) THEN 
    DO JLEV = 1,INLAMTOP
      PTQOPP5(1:KLEN,JLEV,JP_T)=273.0_JPRB !dummy strat, if needed
    ENDDO
  ELSE   
    IPMOTOV = NLSAT-INLAMTOP-1
    ALLOCATE(Z_PTFINP(KLEN,IPMOTOV))
    ALLOCATE(Z_PTFOUT(KLEN,NLSAT))
    Z_PTFINP(1:KLEN,1:IPMOTOV)=PTQOPP5(1:KLEN,INLAMTOP+2:NLSAT, JP_T)
    CALL EXTRAP(Z_PTFINP, Z_PTFOUT, KLEN)
    DO JLEV = 1,INLAMTOP
      PTQOPP5(1:KLEN,JLEV,JP_T)= Z_PTFOUT(1:KLEN,JLEV)
    ENDDO
    DEALLOCATE(Z_PTFINP, Z_PTFOUT)
  ENDIF
ENDIF

!*          1.6   Perform the post-processing of 2M temperature and humidity.
!                 A)  T2M is taken equal to T(NFLEVG): Lowest model level,
!                 B) HU2M is taken equal to HU(NLSAT): Lowest TOVS level.

PT2M5(1:KLEN)=PTF5(1:KLEN,NFLEVG)
PQ2M5(1:KLEN)=PTQOPP5(1:KLEN,NLSAT,JP_Q)

!*          1.7   Find out pressure at the 'station height' of each
!                 TOVS location. The post processing routine for Mean
!                 Sea Level Pressure is used.

WHERE(POROGOB(1:KLEN) == RMDI)
  ZORDIF(1:KLEN) = 0.0_JPRB
ELSEWHERE
  ZORDIF(1:KLEN) = POROG5(1:KLEN)-POROGOB(1:KLEN)
ENDWHERE
CALL PPPMER(KDLEN,1,KLEN,PPRESH5(1,NFLEVG),ZORDIF,PTSTAR5,PT05,PPS5)

!*          1.8   If any of the 43 levels are within 20 mbar of the
!                 surface, add a correction to the temperature at that
!                 level to make sure that the level temperature
!                 approaches (sinuously) the near-surface (2M)
!                 temperature as surface pressure approaches that level
!                 pressure. do the same for humidity.
!                 Define domaine (ZPSINFL) in wich Ps has an influence
!                 on level temp. Linear weight (ZA5) is a function of
!                 Ps (and P)

ZPSINFL=2000._JPRB
DO JLEV = 1,NLSAT
  DO JOBS = 1,KLEN
    ZDP5=PPS5(JOBS)-RADPRE(JLEV)
    IF(ABS(ZDP5) < ZPSINFL) THEN
      ZA5=0.5_JPRB*(1.0_JPRB+SIN(RPI/ZPSINFL*(ZDP5-ZPSINFL*0.5_JPRB)))
      ZA5=MAX(ZA5,0.0001_JPRB)
      PTQOPP5(JOBS,JLEV,JP_T)=ZA5*PTQOPP5(JOBS,JLEV,JP_T)+(1.0_JPRB-ZA5)*PT2M5(JOBS)
      PTQOPP5(JOBS,JLEV,JP_Q)=ZA5*PTQOPP5(JOBS,JLEV,JP_Q)+(1.0_JPRB-ZA5)*PQ2M5(JOBS)
    ENDIF
  ENDDO
ENDDO

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