SUBROUTINE PPOBSAS(KDLEN,KLEN,KDCOUNT,CDPAR,PINTH,KOBSTYPE,KCOUNT,PZ0SC,&
 & PRESF5,PUF5,PVF5,PTF5,PQF5,PU05,PV05,&
 & PCPTGZ5,PCPTS5,PAPHI5,PES5,&
 & PRI5,PBN5,PBM5,PBH5,&
 & KDPP,PXPP)  

!**** PPOBSAS - POST-PROCESSING SURFACE VARIABLES

!     CARLA CARDINALI        ECMWF           92-18-03

!     PURPOSE
!     -------

!        FIND OUT AN EQUIVALENT MODEL SURFACE PARAMETER FOR A GIVEN OBSERVED.

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

!     CALL PPOBSAS(KDLEN,KLEN,KDCOUNT,CDPAR,PINTH,KOBSTYPE,KCOUNT,PZ0SC,
!    I             PRESF5,PUF5,PVF5,PTF5,PQF5,
!    I             PCPTGZ5,PCPTS5,PAPHI5,PES5,PU05,PV05,
!    I             PRI5,PBN5,PBM5,PBH5,
!    O             KDPP,PXPP)

!     WHERE KDLEN   : FIRST DIMENSION (OBSERVATIONS)
!           KLEN    : ACTUAL NUMBER OF OBSERVATIONS
!           KDCOUNT : SECOND DIMENSION (Data)
!           CDPAR   : PARAMETER FOR POST-PROCESSING
!           PINTH   : INTERPOLATION HEIGHT
!           KOBSTYPE: OBS. TYPE
!           KCOUNT  : COUNTER OF DATA PER OBS
!           PZ0SC   : ROUGHNESS LENGHT COMPUTED FROM SCAT WIND SPEED
!           PRESF5  : FULL LEVEL PRESSURES
!           PUF5    : U AT MODEL FULL LEVELS
!           PVF5    : V AT MODEL FULL LEVELS
!           PTF5    : T AT MODEL FULL LEVELS
!           PQF5    : Q AT MODEL FULL LEVELS
!           PU05    : U-COMP OCEAN CURRENT
!           PV05    : V-COMP OCEAN CURRENT
!           KDPP    : Number of fields, dimension of PXPP.
!           PXPP    : POST-PROCESSED VALUES
!           PCPTGZ5 : STATIC ENERGY (LOWER LEVEL)
!           PCPTS5  : STATIC ENERGY AT THE SURFACE
!           PAPHI5  : GEOPOTENTIAL MODEL LEVELS
!           PRI5    : RICHARDSON NO.
!           PBN5    : STABILITY FUNCTION (NEUTRAL)
!           PBM5      DRAG COEFFICIENT FOR MOMENTUM
!           PBH5      DRAG COEFFICIENT FOR HEAT

!        PPOBSAS IS CALLED FROM SURFACEO/TL/AD

!**   METHOD
!     ------

!**   EXTERNALS
!     ---------
!          PPRH2M  : COMPUTE THE POST-PROCESSED 2M RELATIVE HUMIDITY
!          PPUV10M : COMPUTE THE POST-PROCESSED 10M U/V-WIND COMPONENTS
!          PPT2M   : COMPUTE THE POST-PROCESSED 2M TEMPERATURE

!**   MODIFICATIONS
!     -------------
!     E.Andersson 960201 : Incorporating Scat in SURFACEO
!     E.Andersson 961015 : Add KCOUNT, useful in screening .OR. Scat
!     E.Andersson 971117 : GOM-variables more flexible
!     E.Andersson 980611 : Pass dimension as argument
!     E.Gerard    990505 : If NSATEM U10 doesn't require LGSMU & LGSMV .T.
!     H.Hersbach  080416 : Introduce neutral-wind operator for Scat

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

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

USE YOMDIM   , ONLY : NFLEVG
USE YOMLUN   , ONLY : NULERR
USE YOMOBS   , ONLY : LSCATT_NEUTRAL
USE YOMSTA   , ONLY : STZ
USE GOMS_MIX     , ONLY : LGOMUA,YGOMV
USE YOMCOCTP , ONLY : NSCATT
IMPLICIT NONE

INTEGER(KIND=JPIM),INTENT(IN)    :: KDLEN 
INTEGER(KIND=JPIM),INTENT(IN)    :: KLEN 
INTEGER(KIND=JPIM),INTENT(IN)    :: KDCOUNT
CHARACTER(LEN=3)  ,INTENT(IN)    :: CDPAR 
REAL(KIND=JPRB)   ,INTENT(IN)    :: PINTH(KDLEN) 
INTEGER(KIND=JPIM),INTENT(IN)    :: KOBSTYPE 
INTEGER(KIND=JPIM),INTENT(IN)    :: KCOUNT(KDLEN) 
REAL(KIND=JPRB)   ,INTENT(IN)    :: PZ0SC(KDLEN) 
REAL(KIND=JPRB)   ,INTENT(IN)    :: PRESF5(KDLEN,NFLEVG) 
REAL(KIND=JPRB)   ,INTENT(IN)    :: PUF5(KDLEN,0:NFLEVG) 
REAL(KIND=JPRB)   ,INTENT(IN)    :: PVF5(KDLEN,0:NFLEVG) 
REAL(KIND=JPRB)   ,INTENT(IN)    :: PTF5(KDLEN,0:NFLEVG) 
REAL(KIND=JPRB)   ,INTENT(IN)    :: PQF5(KDLEN,0:NFLEVG) 
REAL(KIND=JPRB)   ,INTENT(IN)    :: PCPTGZ5(KDLEN) 
REAL(KIND=JPRB)   ,INTENT(IN)    :: PCPTS5(KDLEN) 
REAL(KIND=JPRB)   ,INTENT(IN)    :: PAPHI5(KDLEN,NFLEVG) 
REAL(KIND=JPRB)   ,INTENT(INOUT) :: PES5(KDLEN,2) 
REAL(KIND=JPRB)   ,INTENT(IN)    :: PU05(KDLEN)
REAL(KIND=JPRB)   ,INTENT(IN)    :: PV05(KDLEN)
REAL(KIND=JPRB)   ,INTENT(IN)    :: PRI5(KDLEN) 
REAL(KIND=JPRB)   ,INTENT(IN)    :: PBN5(KDLEN) 
REAL(KIND=JPRB)   ,INTENT(IN)    :: PBM5(KDLEN) 
REAL(KIND=JPRB)   ,INTENT(IN)    :: PBH5(KDLEN) 
INTEGER(KIND=JPIM),INTENT(IN)    :: KDPP 
REAL(KIND=JPRB)   ,INTENT(INOUT) :: PXPP(KDLEN,KDCOUNT,KDPP) 
INTEGER(KIND=JPIM) :: ILEN,IMXCNT,INPP
INTEGER(KIND=JPIM) :: JOBS,JC
REAL(KIND=JPRB) :: ZRHMAX,ZRHMIN,Z10,ZLLH,ZLOGC
LOGICAL :: LLH2,LLU10,LLT2,LLAUV,LL_CHKGOM,LLNEUTRAL,LLRELCURR
REAL(KIND=JPRB) :: ZHOOK_HANDLE

#include "abor1.intfb.h"
#include "pprh2m.intfb.h"
#include "ppt2m.intfb.h"
#include "ppuv10m.intfb.h"
!     ------------------------------------------------------------------
!*    1.  PREPARATION
!*    1.1 MAX. NO. OF DATA

IF (LHOOK) CALL DR_HOOK('PPOBSAS',0,ZHOOK_HANDLE)
ILEN=KLEN
IMXCNT = MAXVAL(KCOUNT(1:ILEN))
IF(IMXCNT == 0) GOTO 9
INPP=0

LLH2= CDPAR == 'H2'  .OR. CDPAR == 'BG1'
LLU10=CDPAR == 'U10' .OR. CDPAR == 'FFS' .OR. CDPAR == 'BG1'
LLT2= CDPAR == 'T2'  .OR. CDPAR == 'BG1'
LLAUV=CDPAR == 'AUV'
LLNEUTRAL= (KOBSTYPE == NSCATT .AND. LSCATT_NEUTRAL)
LLRELCURR= (KOBSTYPE == NSCATT)

LL_CHKGOM=(KOBSTYPE /= NSCATT) .AND.CDPAR /= 'BG1'

IF(.NOT.ANY((/LLH2,LLU10,LLT2,LLAUV/))) THEN
  WRITE(NULERR,'('' *** REQUESTED PARAMETER='',A)') CDPAR
  CALL ABOR1('ERROR PPOBSAS: WRONG REQUESTED PARAMETER')
ENDIF

!*    2. 10M U-V COMPONENTS

IF(LLU10) THEN
  IF(INPP+2 > KDPP) CALL ABOR1('PPOBSAS: KDPP EXCEEDED, UV10')
  INPP=INPP+2

  CALL PPUV10M(KDLEN,1,ILEN,LLNEUTRAL,LLRELCURR,PINTH,&
   & PUF5(1,NFLEVG),PVF5(1,NFLEVG),PAPHI5(1,NFLEVG),&
   & PRI5,PBN5,PBM5,PU05,PV05,&
   & PXPP(1,1,INPP-1),PXPP(1,1,INPP))
  DO JC=2,IMXCNT
    WHERE(KCOUNT(1:ILEN) >= JC)
      PXPP(1:ILEN,JC,INPP-1)=PXPP(1:ILEN,1,INPP-1)
      PXPP(1:ILEN,JC,INPP)=PXPP(1:ILEN,1,INPP)
    ENDWHERE
  ENDDO
ENDIF

!*    3. 2M TEMPERATURE

IF(LLT2) THEN
  IF(LL_CHKGOM .AND. .NOT.(LGOMUA(KOBSTYPE,YGOMV%MT) .AND. LGOMUA(KOBSTYPE,YGOMV%MQ)))&
   & CALL ABOR1('PPOBSAS: T2 REQUIRES T AND Q GOM')  
  IF(INPP+1 > KDPP) CALL ABOR1('PPOBSAS: KDPP EXCEEDED, T2')
  INPP=INPP+1

  CALL PPT2M(KDLEN,1,ILEN,PINTH,&
   & PQF5(1,NFLEVG),PAPHI5(1,NFLEVG),&
   & PCPTGZ5,PCPTS5,&
   & PRI5,PBN5,PBH5,&
   & PXPP(1,1,INPP))  
  DO JC=2,IMXCNT
    WHERE(KCOUNT(1:ILEN) >= JC) PXPP(1:ILEN,JC,INPP)=PXPP(1:ILEN,1,INPP)
  ENDDO
ENDIF

!*    4.  2M RELATIVE HUMIDITY

IF(LLH2) THEN
  IF(LL_CHKGOM .AND. .NOT.LGOMUA(KOBSTYPE,YGOMV%MQ)) &
   & CALL ABOR1('PPOBSAS: H2 REQUIRES Q GOM')
  IF(INPP+1 > KDPP) CALL ABOR1('PPOBSAS: KDPP EXCEEDED, H2')
  INPP=INPP+1

  ZRHMAX=1.2_JPRB
  ZRHMIN=-0.2_JPRB
  CALL PPRH2M(KDLEN,1,ILEN,ZRHMAX,ZRHMIN,&
   & PRESF5(1,NFLEVG),PQF5(1,NFLEVG),PTF5(1,NFLEVG),&
   & PES5(1,2),&
   & PXPP(1,1,INPP))  
  DO JC=2,IMXCNT
    WHERE(KCOUNT(1:ILEN) >= JC) PXPP(1:ILEN,JC,INPP)=PXPP(1:ILEN,1,INPP)
  ENDDO
ENDIF

!*    5. AMBIGUOUS SCAT WINDS LOGARITMIC CORRECTION
!*       ZLLH=ICAO height of lowest model level. Truncated
!        in order to have agreement with earlier code (=32m)

IF(LLAUV) THEN
  IF(KOBSTYPE /= NSCATT) CALL ABOR1('PPOBSAS: AUV REQUIRES NSCATT')
  IF(INPP+2 > KDPP) CALL ABOR1('PPOBSAS: KDPP EXCEEDED, AUV')
  INPP=INPP+2

  Z10=10._JPRB
  ZLLH=INT(STZ(NFLEVG))
  DO JOBS=1,ILEN
    ZLOGC=LOG(Z10/PZ0SC(JOBS)) / LOG(ZLLH/PZ0SC(JOBS))
    PXPP(JOBS,1,INPP-1)=ZLOGC*PUF5(JOBS,NFLEVG)
    PXPP(JOBS,1,INPP)=ZLOGC*PVF5(JOBS,NFLEVG)
    IF(KCOUNT(JOBS) == 2) THEN
      PXPP(JOBS,2,INPP-1)=PXPP(JOBS,1,INPP-1)
      PXPP(JOBS,2,INPP)=PXPP(JOBS,1,INPP)
    ENDIF
  ENDDO
  DO JC=3,IMXCNT
    WHERE(KCOUNT(1:ILEN) >= JC)
      PXPP(1:ILEN,JC,INPP-1)=PXPP(1:ILEN,1,INPP-1)
      PXPP(1:ILEN,JC,INPP)=PXPP(1:ILEN,1,INPP)
    ENDWHERE
  ENDDO
ENDIF

!     9.  RETURN

9 CONTINUE
IF (LHOOK) CALL DR_HOOK('PPOBSAS',1,ZHOOK_HANDLE)
END SUBROUTINE PPOBSAS
