MODULE SPPCFLS_MOD
CONTAINS
SUBROUTINE SPPCFLS(KIDIA,KFDIA,KLON,&
 & PUMLEV,PVMLEV,PQMLEV,PAPHMS,PGEOMLEV,PCPTGZLEV,&
 & PCPTS,PQSAM,PZ0MM,PZ0HM,PZ0QM,PBUOM,&
! OUPUTS     
 & PU10  ,PV10  ,P10NU  ,P10NV  ,PT2   ,PD2 ,PQ2 )  

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

USE YOS_CST   , ONLY : RG       ,RD       ,RCPD     ,RETV     ,RTT  
USE YOS_THF   , ONLY : R2ES     ,R3LES    ,R4LES    ,&
 & RVTMP2
USE YOS_EXC   , ONLY : RKAP     ,REPDU2   ,RPARZI

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

!**   *SPPCFLS* - COMPUTES THE SURFACE (2 M) TEMPERATURE AND HUMIDITY
!                   WITH STABILITY FROM GELEYN'S INTERPOLATION

!     J.F. MAHFOUF                E.C.M.W.F.    04/10/95.
!     Modified   P. Viterbo ECMWF 12/05/2005 Externalize SURF
!                                   (based on vdfppcfls)
!                H. Hersbach ECMWF 04/12/2009 10-m neutral wind

!     PURPOSE
!     -------

!     COMPUTE WIND COMPONENTS, TEMPERATURE AND DEWPOINT TEMPERATURE
!     AT SCREEN LEVEL HEIGHT

!     INTERFACE
!     ---------

!     *SPPCFLS* IS CALLED BY *VDFMAIN*

!     INPUT PARAMETERS (INTEGER):

!     *KIDIA*        START POINT
!     *KFDIA*        END POINT
!     *KLON*         NUMBER OF GRID POINTS PER PACKET

!     INPUT PARAMETERS (REAL):

!     *PUMLEV*       X-VELOCITY COMPONENT AT T-1, lowest atmospheric level
!     *PVMLEV*       Y-VELOCITY COMPONENT AT T-1, lowest atmospheric level
!     *PQMLEV*       SPECIFIC HUMUDITY AT T-1, lowest atmospheric level
!     *PAPHMS*       Surface PRESSURE AT T-1
!     *PGEOMLEV*     GEOPOTENTIAL AT T-1, lowest atmospheric level
!     *PCPTGZLEV*    DRY STATIC ENERGY AT LOWEST MODEL LEVEL
!     *PCPTS*        DRY STATIC ENERGY AT THE SURFACE
!     *PQSAM*        SPECIFIC HUMIDITY AT THE SURFACE
!     *PZ0MM*        AERODYNAMIC ROUGHNESS LENGTH
!     *PZ0HM*        ROUGHNESS LENGTH FOR TEMPERATURE
!     *PZ0QM*        ROUGHNESS LENGTH FOR MOISTURE
!     *PBUOM*        BUOYANCE FLUX AT THE SURFACE

!     OUTPUT PARAMETERS (REAL):

!     *PU10*         U-COMPONENT WIND AT 10 M
!     *PV10*         V-COMPONENT WIND AT 10 M
!     *P10NU*        U-COMPONENT NEUTRAL WIND AT 10 M
!     *P10NV*        V-COMPONENT NEUTRAL WIND AT 10 M
!     *PT2*          TEMPERATURE AT 2 M
!     *PD2*          DEW POINT TEMPERATURE AT 2 M
!     *PQ2*          SPECIFIC HUMIDITY AT 2 M

!     METHOD
!     ------

!     ANALYTIC INTERPOLATION - GELEYN (1988) TELLUS 40A 347-351

!     ------------------------------------------------------------------
!     REMARK : THE MAIN JUSTIFICATION OF THIS ROUTINE IS 
!              FOR USE IN TL AND AD VERSIONS OF IFS
!     ------------------------------------------------------------------

IMPLICIT NONE

INTEGER(KIND=JPIM),INTENT(IN)    :: KLON 
INTEGER(KIND=JPIM),INTENT(IN)    :: KIDIA 
INTEGER(KIND=JPIM),INTENT(IN)    :: KFDIA 
REAL(KIND=JPRB)   ,INTENT(IN)    :: PUMLEV(:) 
REAL(KIND=JPRB)   ,INTENT(IN)    :: PVMLEV(:) 
REAL(KIND=JPRB)   ,INTENT(IN)    :: PQMLEV(:) 
REAL(KIND=JPRB)   ,INTENT(IN)    :: PAPHMS(:) 
REAL(KIND=JPRB)   ,INTENT(IN)    :: PGEOMLEV(:) 
REAL(KIND=JPRB)   ,INTENT(IN)    :: PCPTGZLEV(:) 
REAL(KIND=JPRB)   ,INTENT(IN)    :: PCPTS(:) 
REAL(KIND=JPRB)   ,INTENT(IN)    :: PQSAM(:) 
REAL(KIND=JPRB)   ,INTENT(IN)    :: PZ0MM(:) 
REAL(KIND=JPRB)   ,INTENT(IN)    :: PZ0HM(:) 
REAL(KIND=JPRB)   ,INTENT(IN)    :: PZ0QM(:) 
REAL(KIND=JPRB)   ,INTENT(IN)    :: PBUOM(:) 
REAL(KIND=JPRB)   ,INTENT(OUT)   :: PU10(:) 
REAL(KIND=JPRB)   ,INTENT(OUT)   :: PV10(:) 
REAL(KIND=JPRB)   ,INTENT(OUT)   :: P10NU(:) 
REAL(KIND=JPRB)   ,INTENT(OUT)   :: P10NV(:) 
REAL(KIND=JPRB)   ,INTENT(OUT)   :: PT2(:) 
REAL(KIND=JPRB)   ,INTENT(OUT)   :: PD2(:) 
REAL(KIND=JPRB)   ,INTENT(OUT)   :: PQ2(:) 

!*            LOCAL STORAGE
!             ----- -------

REAL(KIND=JPRB) ::  Z1DZ0M(KLON)  ,Z1DZ0H(KLON),  Z1DZ0Q(KLON)  ,&
 & ZXLNM(KLON) , ZXLNH(KLON) , ZXLNQ(KLON) , ZDU2(KLON)  , ZNLEV(KLON) ,&
 & Z1DZ1D(KLON)  
REAL(KIND=JPRB) ::  ZRICLS(KLON)  ,&
 & ZCFM(KLON)  , ZCFH(KLON)  , ZCFQ(KLON)      ,&
 & ZCDNM(KLON) , ZCDNH(KLON) , ZCDNQ(KLON)   
REAL(KIND=JPRB) :: ZZQM1(KLON)

INTEGER(KIND=JPIM) :: JL

REAL(KIND=JPRB) :: Z10M, Z10UIV, Z10NIV, Z2B, Z2M, Z2QIV, Z2SIV, Z3B,&
 & ZAPH2M, ZBD, ZBH, ZBN, ZBNH, ZBNQ, ZBQ, ZCH, &
 & ZCH0, ZCM, ZCM0, ZCON1, ZCON2, ZCORQ, ZCORS, &
 & ZCORU, ZCPT2M, ZCQ, ZCQ0, ZD, &
 & ZDRORO, ZFRAC, ZIPBL, ZLOGQ, ZLOGS, &
 & ZLOGU, ZMU, ZMUQ, ZPH, ZPM, ZPQ, ZRS, ZRU, &
 & ZWST2, Z2S, Z5S, Z6S, Z7S, Z8S, ZSDIV, ZMULTI, ZEPS1
REAL(KIND=JPRB) :: ZHOOK_HANDLE

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

!*       1.   INITIALIZE CONSTANTS
!             ---------- ----------

IF (LHOOK) CALL DR_HOOK('SPPCFLS_MOD:SPPCFLS',0,ZHOOK_HANDLE)
ZCON1  =RVTMP2-RETV
ZCON2  =2.0_JPRB/3._JPRB
ZEPS1  =1.0E-12_JPRB

!     CONSTANTS FOR THE STABILITY FUNCTIONS

Z2B=10._JPRB
ZD=5._JPRB
Z3B=15._JPRB

!     PBL HEIGHT FOR W* - EFFECT

ZIPBL=RPARZI

!     THIS SPECIFIES THE HEIGHT FOR U,V (10 M) AND T,Q (2 M)

Z10M=10._JPRB
Z2M=2.0_JPRB

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

!*       2.   COMPUTATION OF SURFACE EXCHANGE COEFFICIENTS
!             ---------------------------------------------

DO JL=KIDIA,KFDIA

!             (W*)**2, WIND SHEAR, RICHARDSON NUMBER,

  IF (PBUOM(JL)  <  ZEPS1) THEN
    ZWST2=0.0_JPRB
  ELSE
    ZWST2=(PBUOM(JL)*ZIPBL)**ZCON2
  ENDIF
  ZDU2(JL)=MAX(REPDU2,PUMLEV(JL)**2+PVMLEV(JL)**2+ZWST2)
  Z2S = PCPTGZLEV(JL)+PCPTS(JL)-PGEOMLEV(JL)
  ZDRORO=2.0_JPRB*(PCPTGZLEV(JL)-PCPTS(JL))/Z2S &
   & -ZCON1*(PQMLEV(JL)-PQSAM(JL))  
  ZRICLS(JL)=PGEOMLEV(JL)*ZDRORO/ZDU2(JL)

!             COMMON FACTORS IN NEUTRAL FORMULAE AND
!             DRAG COEFFICIENTS.

  ZNLEV (JL)=PGEOMLEV(JL)/RG+PZ0MM(JL)
  Z1DZ0M(JL)=ZNLEV(JL)/PZ0MM(JL)
  Z1DZ0H(JL)=ZNLEV(JL)/PZ0HM(JL)
  Z1DZ0Q(JL)=ZNLEV(JL)/PZ0QM(JL)
  Z1DZ1D(JL)=Z1DZ0M(JL)/(Z1DZ0M(JL)-1.0_JPRB)
  ZXLNM(JL) =LOG(Z1DZ0M(JL))
  ZXLNH(JL) =LOG(Z1DZ0H(JL))
  ZXLNQ(JL) =LOG(Z1DZ0Q(JL))

!              NEUTRAL DRAG COEFFICIENTS

  ZCDNH(JL) =(RKAP**2)/(ZXLNM(JL)*ZXLNH(JL))
  ZCDNQ(JL) =(RKAP**2)/(ZXLNM(JL)*ZXLNQ(JL))
  ZCDNM(JL) =(RKAP**2)/(ZXLNM(JL)*ZXLNM(JL))

!          PARAMETERS DEPENDING ON RATIO OF ROUGHNESS LENGTHS

  ZMU =  LOG (MIN(100.0_JPRB,PZ0MM(JL)/PZ0HM(JL)))
  ZMUQ = LOG (MIN(100.0_JPRB,PZ0MM(JL)/PZ0QM(JL)))

  ZCM0 = (6.8741_JPRB + ZMU*( 2.6933_JPRB + ZMU*(-0.3601_JPRB + ZMU &
   & * 0.0154_JPRB)))  
  ZPM  = (0.5233_JPRB + ZMU*(-0.0815_JPRB + ZMU*( 0.0135_JPRB + ZMU &
   & *(-0.001_JPRB))))  
  ZCH0 = (3.2165_JPRB + ZMU*( 4.3431_JPRB + ZMU*( 0.5360_JPRB + ZMU &
   & *(-0.0781_JPRB))))  
  ZPH  = (0.5802_JPRB + ZMU*(-0.1571_JPRB + ZMU*( 0.0327_JPRB + ZMU &
   & *(-0.0026_JPRB))))  
  ZCQ0 = (3.2165_JPRB + ZMUQ*( 4.3431_JPRB + ZMUQ*(0.5360_JPRB + ZMUQ &
   & *(-0.0781_JPRB))))  
  ZPQ  = (0.5802_JPRB + ZMUQ*(-0.1571_JPRB + ZMUQ*(0.0327_JPRB + ZMUQ &
   & *(-0.0026_JPRB))))  

  ZCM = ZCM0*Z1DZ0M(JL)**ZPM
  ZCH = ZCH0*Z1DZ0H(JL)**ZPH
  ZCQ = ZCQ0*Z1DZ0Q(JL)**ZPQ

!            STABILITY FUNCTIONS 

  IF (ZRICLS(JL) > 0.0_JPRB) THEN
    Z5S = SQRT(1.0_JPRB+ZD*ZRICLS(JL))
    ZSDIV = 1.0_JPRB+Z2B*ZRICLS(JL)/Z5S
    ZMULTI = 1.0_JPRB/(1.0_JPRB+Z3B*ZRICLS(JL)*Z5S)

    ZCFM(JL) = ZCDNM(JL)/ZSDIV
    ZCFH(JL) = ZCDNH(JL)*ZMULTI
    ZCFQ(JL) = ZCDNQ(JL)*ZMULTI
  ELSE
    Z6S = SQRT(ABS(ZRICLS(JL)))
    ZCFM(JL)=ZCDNM(JL)*(1.0_JPRB-Z2B*ZRICLS(JL)/&
     & (1.0_JPRB+Z3B*ZCDNM(JL)*ZCM*Z6S))
    ZCFH(JL)=ZCDNH(JL)*(1.0_JPRB-Z3B*ZRICLS(JL)/&
     & (1.0_JPRB+Z3B*ZCDNH(JL)*ZCH*Z6S))                 
    ZCFQ(JL)=ZCDNQ(JL)*(1.0_JPRB-Z3B*ZRICLS(JL)/&
     & (1.0_JPRB+Z3B*ZCDNQ(JL)*ZCQ*Z6S))                 
  ENDIF

ENDDO

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

!*       3.   COMPUTATION OF WIND COMPONENT AND TEMPERATURE
!             ----------------------------------------------

DO JL=KIDIA,KFDIA
  Z7S = SQRT(ZCDNM(JL))
  ZBN  = RKAP/Z7S
  ZBNH = RKAP*Z7S/ZCDNH(JL)
  ZBNQ = RKAP*Z7S/ZCDNQ(JL)


  Z8S = SQRT(ZCFM(JL))
  ZBD  = RKAP/Z8S
  ZBH  = RKAP*Z8S/ZCFH(JL)
  ZBQ  = RKAP*Z8S/ZCFQ(JL)

  ZRU=Z10M/ZNLEV(JL)
  ZRS=Z2M/ZNLEV(JL)

  ZLOGU=LOG(1.0_JPRB+ZRU*(EXP(ZBN )-1.0_JPRB))
  ZLOGS=LOG(1.0_JPRB+ZRS*(EXP(ZBNH)-1.0_JPRB))
  ZLOGQ=LOG(1.0_JPRB+ZRS*(EXP(ZBNQ)-1.0_JPRB))
  IF (ZRICLS(JL) > 0.0_JPRB) THEN
    ZCORU=ZRU*(ZBN-ZBD)
    ZCORS=ZRS*(ZBNH-ZBH)
    ZCORQ=ZRS*(ZBNQ-ZBQ)
  ELSE
    ZCORU=LOG(1.0_JPRB+ZRU*(EXP(MIN(200.0_JPRB,MAX(0.0_JPRB,ZBN -ZBD)))-1.0_JPRB))
    ZCORS=LOG(1.0_JPRB+ZRS*(EXP(MIN(200.0_JPRB,MAX(0.0_JPRB,ZBNH-ZBH)))-1.0_JPRB))
    ZCORQ=LOG(1.0_JPRB+ZRS*(EXP(MIN(200.0_JPRB,MAX(0.0_JPRB,ZBNQ-ZBQ)))-1.0_JPRB))
  ENDIF

!     10 M WIND COMPONENT

  Z10UIV=MAX(0.0_JPRB,MIN(1.0_JPRB,(ZLOGU-ZCORU)/ZBD))

  PU10(JL)=PUMLEV(JL)*Z10UIV
  PV10(JL)=PVMLEV(JL)*Z10UIV

!     10 M NEUTRAL WIND COMPONENT

  Z10NIV=MAX(0.0_JPRB,ZLOGU/ZBD)

  P10NU(JL)=PUMLEV(JL)*Z10NIV
  P10NV(JL)=PVMLEV(JL)*Z10NIV

!     2M TEMPERATURE AND 2M SPECIFIC HUMIDITY

  Z2SIV=MAX(0.0_JPRB,MIN(1.0_JPRB,(ZLOGS-ZCORS)/ZBH))
  Z2QIV=MAX(0.0_JPRB,MIN(1.0_JPRB,(ZLOGQ-ZCORQ)/ZBQ))

  ZCPT2M=PCPTS(JL)+ (PCPTGZLEV(JL)-PCPTS(JL))*Z2SIV

  ZZQM1(JL)=MAX(1.E-12_JPRB,PQMLEV(JL))
  PQ2(JL)=PQSAM(JL) + (ZZQM1(JL)-PQSAM(JL))*Z2QIV

!     APPROXIMATE MOISTURE CORRECTION IN CP WITH QNLEV

  PT2(JL)=(ZCPT2M-RG*Z2M)/( RCPD*(1.0_JPRB+RVTMP2*ZZQM1(JL)) )

ENDDO

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

!        4.   COMPUTE  DEW POINT TEMPERATURE
!             ------------------------------

DO JL=KIDIA,KFDIA
  ZAPH2M=PAPHMS(JL)*(1.0_JPRB-Z2M/(RD*PT2(JL)*(1.0_JPRB+RETV*ZZQM1(JL))))

! Note the use of saturation with respect to water in conformance to WMO
!  observation dissemination practice

  ZFRAC=LOG(ZAPH2M*PQ2(JL)/(R2ES*(1.0_JPRB+RETV*PQ2(JL))))/R3LES
  PD2(JL)=(RTT-ZFRAC*R4LES)/(1.0_JPRB-ZFRAC)

!     LIMIT DEW POINT TEMPERATURE < TEMPERATURE

  PD2(JL)=MIN(PT2(JL),PD2(JL))
ENDDO

IF (LHOOK) CALL DR_HOOK('SPPCFLS_MOD:SPPCFLS',1,ZHOOK_HANDLE)
END SUBROUTINE SPPCFLS
END MODULE SPPCFLS_MOD
