SUBROUTINE SPPTEN (KIDIA,KFDIA,KLON,KLEV,PTSPHY,&
 & PTSL, PQSL, PA, PAP, PAPH, &
 & PTENUIN,PTENVIN,PTENTIN,PTENQIN,&
 & PMULNOISE, &
 & PTENU  ,PTENV  ,PTENT  ,PTENQ, DPTENQ0, DPTENQ1)  

!**** *SPPTEN * - Add stochastically perturbed parametrization tendencies

!     PURPOSE.
!     --------
!       Add stochastically perturbed parametrization tendencies (SPPT)

!**   INTERFACE.
!     ----------
!        *CALL* *SPPTEN(...)*

!     INPUT ARGUMENTS.

!     KIDIA   : start of horizontal loop
!     KFDIA   : start of horizontal loop
!     KLON    : horizontal dimension
!     KLEV    : end of vertical loop and vertical dimension
!     PMULNOISE: multiplicative noise (minus 1) applied to U, V, T, Q
!     PTENxIN : initial tendency OF U, V, T and Q 
!     PA      : cloud fraction
!     PAP     : full-level pressure
!     PAPH    : half-level pressure
!
!     OUTPUT ARGUMENTS.

!     PTENx   : tendency of U, V, T, and Q
!     DPTENQ0, DPTENQ1: Initial and final physical tendencies for Q modified by SPPT

!     EXTERNALS.  NONE
!     ---------  

!     REFERENCE.
!     ----------
!        ECMWF Research Department documentation of the IFS

!     AUTHOR.
!     -------
!     14-Dec-2009  Martin Leutbecher

!     MODIFICATIONS.
!     --------------
!     June 2015 - Jost von Hardenberg *ISAC-CNR* Added modifications for FIXSPPT (making sure that average tendencies are conserved)
!-----------------------------------------------------------------------

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

USE YOMSPSDT  ,ONLY : LQPERTLIMIT2, LTAPER_BL0, XSIGMATOP, XSIGMABOT,&
     & XTAPER3, XTAPER2, XTAPER1, XTAPER0,&
     & LTAPER_ST0, XPRESSTOP_ST0, XPRESSBOT_ST0,&
     & XTAPER3_ST0, XTAPER2_ST0, XTAPER1_ST0, XTAPER0_ST0, &
     & NQSAT_SDT,  XMEANRED_THICKNESS_SDT

USE YOMCST   , ONLY : RETV     ,RTT      ,RLSTT    ,RLVTT

USE YOETHF   , ONLY : R2ES     ,R3LES    ,R3IES    ,R4LES    ,&
 & R4IES    ,R5LES    ,R5IES    ,R5ALVCP  ,R5ALSCP  ,&
 & RALVDCP  ,RALSDCP  ,RTWAT    ,&
 & RTICE    ,RTICECU  ,&
 & RTWAT_RTICE_R      ,RTWAT_RTICECU_R  ,&
 & RKOOP1   ,RKOOP2
USE YOECLDP  , ONLY : NSSOPT 
IMPLICIT NONE

INTEGER(KIND=JPIM),INTENT(IN)    :: KIDIA 
INTEGER(KIND=JPIM),INTENT(IN)    :: KFDIA 
INTEGER(KIND=JPIM),INTENT(IN)    :: KLON
INTEGER(KIND=JPIM),INTENT(IN)    :: KLEV 
REAL(KIND=JPRB)   ,INTENT(IN)    :: PTSPHY 
REAL(KIND=JPRB)   ,INTENT(IN)    :: PTSL(KLON,KLEV) 
REAL(KIND=JPRB)   ,INTENT(IN)    :: PQSL(KLON,KLEV) 
REAL(KIND=JPRB)   ,INTENT(IN)    :: PA(KLON,KLEV)
REAL(KIND=JPRB)   ,INTENT(IN)    :: PAP(KLON,KLEV)    ! full level pressure
REAL(KIND=JPRB)   ,INTENT(IN)    :: PAPH(KLON,KLEV+1) ! half level pressure
REAL(KIND=JPRB)   ,INTENT(IN)    :: PTENUIN(KLON,KLEV) 
REAL(KIND=JPRB)   ,INTENT(IN)    :: PTENVIN(KLON,KLEV) 
REAL(KIND=JPRB)   ,INTENT(IN)    :: PTENTIN(KLON,KLEV) 
REAL(KIND=JPRB)   ,INTENT(IN)    :: PTENQIN(KLON,KLEV) 
REAL(KIND=JPRB)   ,INTENT(IN)    :: PMULNOISE(KLON,KLEV) 
REAL(KIND=JPRB)   ,INTENT(INOUT) :: PTENU(KLON,KLEV) 
REAL(KIND=JPRB)   ,INTENT(INOUT) :: PTENV(KLON,KLEV) 
REAL(KIND=JPRB)   ,INTENT(INOUT) :: PTENT(KLON,KLEV) 
REAL(KIND=JPRB)   ,INTENT(INOUT) :: PTENQ(KLON,KLEV) 
REAL(KIND=JPRB)   ,INTENT(OUT) :: DPTENQ0(KLON,KLEV,4), DPTENQ1(KLON,KLEV,4)

INTEGER(KIND=JPIM) :: JK, JL

REAL(KIND=JPRB) :: ZTP1(KLON,KLEV), ZQP1(KLON,KLEV)
REAL(KIND=JPRB) :: ZQS, ZFACT, ZZR
REAL(KIND=JPRB), DIMENSION(KLON,KLEV) :: ZDZPQ, ZDZPT, ZDZPU, ZDZPV
REAL(KIND=JPRB) :: ZPERT, ZDELQP, ZRED1, ZRED2, ZQSC, ZDQSDTC, ZRP
REAL(KIND=JPRB) :: ZDELTP,ZDELQAMX, ZDELQP2, ZDQX, ZXKOOP, ZXRETV
REAL(KIND=JPRB) :: ZMEAN(KLON), ZTHICK(KLON), ZTHICK1, ZREDMIN, ZRTHICK
REAL(KIND=JPRB) :: ZHOOK_HANDLE
REAL(KIND=JPRB) :: ZRPBOT(KLON)
REAL(KIND=JPRB), DIMENSION(KLON,KLEV) :: ZRED, ZREDX, ZTAPER
REAL(KIND=JPRB) :: ZSIG, ZPRESS, ZPRESSLIMTOP, ZSIGMALIMBOT
LOGICAL :: LLDONTPERT, LLSUPSAT, LLVINLIM
LOGICAL,  DIMENSION(KLON,KLEV) :: LLPERT
LOGICAL, DIMENSION(KLON) :: LLTHICKENOUGH
LOGICAL :: LLALLTHICKENOUGH
INTEGER(KIND=JPIM)  :: IKS
INTEGER(KIND=JPIM), DIMENSION(1) :: IKS1
REAL(KIND=JPRB), DIMENSION(KLEV) :: ZRX

#include "abor1.intfb.h"
#include "fcttre.h"
#include "fccld.h"

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

!     1.  ADD STOCHATIC PERTURBATION TO PHYSICS TENDENCY IF REQUIRED
!         (FOR EPS, if LSTOPH=.T., with LSTOPH defined in surand1.f)
!         (      or if LSPSDT=.T. )
!         ----------------------------------------------------------

!     The perturbation is defined as:  dp/p=1+a*(1-2*r)
!     where:
!     p  : tendency
!     dp : perturbed tendency
!     a  : perturbation amplitude (=AMAGSTOPH, set in surand1.F)
!     r  : random number, 0<r<1 (PSTOPHx, defined in surand2.F)

!     Thus, depending on a(=AMAGSTOPH), for random numbers selected
!     between 0 and 1, the relative size of the diabatic tendency 
!     perturbation can be:   (1-a) < dp/p < (1+a)

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

ZPRESSLIMTOP=0.5_JPRB*(XPRESSTOP_ST0 + XPRESSBOT_ST0)
ZSIGMALIMBOT=0.5_JPRB*(XSIGMATOP + XSIGMABOT)
ZRTHICK=1._JPRB/XMEANRED_THICKNESS_SDT
ZZR=1._JPRB/PTSPHY
IF (LTAPER_BL0) THEN
  DO JL=KIDIA,KFDIA
    ZRPBOT(JL) = 1._JPRB/PAP(JL,KLEV)
  ENDDO
ENDIF
DO JK=1,KLEV
  DO JL=KIDIA,KFDIA
    ZDZPU(JL,JK)=PTENU(JL,JK)-PTENUIN(JL,JK)
    ZDZPV(JL,JK)=PTENV(JL,JK)-PTENVIN(JL,JK)
    ZDZPT(JL,JK)=PTENT(JL,JK)-PTENTIN(JL,JK)
    ZDZPQ(JL,JK)=PTENQ(JL,JK)-PTENQIN(JL,JK)

    DPTENQ0(JL,JK,1)=ZDZPQ(JL,JK)
    DPTENQ0(JL,JK,2)=ZDZPT(JL,JK)  
    DPTENQ0(JL,JK,3)=ZDZPU(JL,JK)  
    DPTENQ0(JL,JK,4)=ZDZPV(JL,JK)  

    ZPERT = PMULNOISE(JL,JK)
    ZTAPER(JL,JK)=1._jprb
    IF (LTAPER_BL0) THEN
      !
      !   taper perturbations to zero in the boundary layer
      !
      ZSIG=PAP(JL,JK)*ZRPBOT(JL) ! pseudo vertical coordinate for tapering
      IF (ZSIG > XSIGMABOT) THEN
        !
        !   below transition layer
        !
        ZPERT =0._JPRB
        ZTAPER(JL,JK)=0._jprb
      ELSE
        IF (ZSIG > XSIGMATOP) THEN
          !
          !   in transition layer
          !
          ZTAPER(JL,JK)= ((XTAPER3*ZSIG+XTAPER2)*ZSIG+XTAPER1)*ZSIG+XTAPER0
          ZPERT = ZTAPER(JL,JK)* PMULNOISE(JL,JK)
        ENDIF
      ENDIF
    ENDIF
    IF (LTAPER_ST0) THEN
      ZPRESS=PAP(JL,JK)
      !
      !   taper perturbations to zero above tropopause
      !
      IF (ZPRESS < XPRESSTOP_ST0) THEN
        !
        !   above transition layer
        !
        ZPERT =0._JPRB   
        ZTAPER(JL,JK)=0._jprb
      ELSE
        IF (ZPRESS < XPRESSBOT_ST0) THEN
          !
          !   in transition layer
          !
          ZTAPER(JL,JK)= ((XTAPER3_ST0*ZPRESS+XTAPER2_ST0)*ZPRESS+XTAPER1_ST0)*ZPRESS+XTAPER0_ST0
          ZPERT = ZTAPER(JL,JK)* PMULNOISE(JL,JK)
        ENDIF
      ENDIF
    ENDIF
    ZFACT = 1._JPRB+ZPERT
    PTENU(JL,JK)=PTENUIN(JL,JK) + ZFACT*ZDZPU(JL,JK)
    PTENV(JL,JK)=PTENVIN(JL,JK) + ZFACT*ZDZPV(JL,JK) 
    PTENT(JL,JK)=PTENTIN(JL,JK) + ZFACT*ZDZPT(JL,JK) 
    PTENQ(JL,JK)=PTENQIN(JL,JK) + ZFACT*ZDZPQ(JL,JK) 
    ZTP1(JL,JK)=PTSL(JL,JK)+ZPERT*ZDZPT(JL,JK)*PTSPHY
    ZQP1(JL,JK)=PQSL(JL,JK)+ZPERT*ZDZPQ(JL,JK)*PTSPHY
    ! ------------------------------
    !     Supersaturation check
    ! ------------------------------

    ZQS=FOEEWM(ZTP1(JL,JK))/PAP(JL,JK)
    ZQS=MIN(0.5_JPRB,ZQS)
    ZQS=ZQS/(1.0_JPRB-RETV*ZQS)

    !
    ! supersaturation adjustments
    !
    IF (ZTP1(JL,JK)<RTICE.AND.NSSOPT>0) &
    & ZQS=ZQS*(PA(JL,JK)+FOKOOP(ZTP1(JL,JK))*(1.0_JPRB-PA(JL,JK)))
    
    LLDONTPERT=.FALSE.
    IF (LQPERTLIMIT2) THEN
      LLDONTPERT=LLDONTPERT.OR.(ZQP1(JL,JK)< 0._jprb)
    ENDIF
    IF (NQSAT_SDT==0) THEN
      LLDONTPERT=LLDONTPERT.OR.(ZQP1(JL,JK)> ZQS)
    ENDIF
    LLPERT(JL,JK)=.NOT.LLDONTPERT
    IF (LLDONTPERT) THEN
      PTENQ(JL,JK)=PTENQIN(JL,JK)+ZDZPQ(JL,JK)
      PTENT(JL,JK)=PTENTIN(JL,JK)+ZDZPT(JL,JK)
    ENDIF
    !
    !   determine moderation factor using linearised 
    !        saturation humidity function
    !
    LLSUPSAT=(ZQP1(JL,JK) > ZQS)
    LLVINLIM=.TRUE.
    IF (LTAPER_BL0) LLVINLIM=LLVINLIM.AND.(ZSIG<ZSIGMALIMBOT)
    IF (LTAPER_ST0) LLVINLIM=LLVINLIM.AND.(ZPRESS>ZPRESSLIMTOP)
    ZRED(JL,JK) = 1._JPRB
    IF ((NQSAT_SDT==3).AND.LLPERT(JL,JK).AND.LLSUPSAT.AND.LLVINLIM) THEN
      ZRP=1._JPRB/PAP(JL,JK)
      ZQSC=FOEEWM(PTSL(JL,JK))*ZRP ! satur. humidity at final unperturbed point
      ZQSC=MIN(0.5_JPRB,ZQSC)
      ZXRETV=1.0_JPRB/(1.0_JPRB-RETV*ZQSC)
      ZQSC=ZQSC*ZXRETV
      !
      ! d(sat. hum.)/dT at final unpert. point
      !
      ZDQSDTC=FOE_DEWM_DT(PTSL(JL,JK))*ZRP*ZXRETV 
      !
      ! adjust for homogeneous nucleation at cold temperatures
      !
      IF (PTSL(JL,JK)<RTICE.AND.NSSOPT>0) THEN
        ZXKOOP =PA(JL,JK)+FOKOOP(PTSL(JL,JK))*(1.0_JPRB-PA(JL,JK))
        ZQSC   =ZQSC   *ZXKOOP
        ZDQSDTC=ZDQSDTC*ZXKOOP
      ENDIF

      ZRED1=1._JPRB
      ZRED2=1._JPRB
      IF (ZQP1(JL,JK)> ZQS ) THEN
        ZDELQP=ZQP1(JL,JK)-PQSL(JL,JK) ! pos. Q pert.
        ZDELTP=ZTP1(JL,JK)-PTSL(JL,JK) ! pos. T pert.
        ZDELQP2=ZDQSDTC*ZDELTP  ! change in sat. hum. due to T pert
        ZDELQAMX=MAX(ABS(ZDELQP),ABS(ZDELQP2),1.e-9_JPRB)
        ZDQX=ZDELQP - ZDELQP2
        IF (ABS(ZDQX)>=0.001_JPRB*ZDELQAMX) THEN
          ZRED1 = (ZQSC - PQSL(JL,JK))/ZDQX
        ELSE
          ZRED1 =0._JPRB
        ENDIF
      ENDIF
      ZRED(JL,JK) = MIN( 1._JPRB, ZRED1, ZRED2)
      ZRED(JL,JK) = MAX( 0._JPRB, ZRED(JL,JK))
    ENDIF
  ENDDO
ENDDO
!
!  vertical consistency
!
IF (NQSAT_SDT==3) THEN
  ZTHICK(:)=1.E-12_JPRB
  ZMEAN(:) =1.E-12_JPRB
  LLTHICKENOUGH(:)=.FALSE.
  ZREDX(:,:) =  ZRED(:,:)
  JKLOOP: DO JK=1,KLEV
    JLLOOP: DO JL=KIDIA,KFDIA
      !
      !   Is layer thick enough?
      !
      IF (LLTHICKENOUGH(JL)) THEN
        CYCLE JLLOOP
      ELSE
        ZRX(:) = ZREDX(JL,:)
        IKS1 = MINLOC(ZRX)
        IKS  = IKS1(1)
        ZREDX(JL, IKS) = 1._JPRB
        ZTHICK1=PAPH(JL,IKS+1)-PAPH(JL,IKS)
        ZREDMIN  =ZRED(JL,IKS)
        ZMEAN(JL)  = ZMEAN(JL)  + ZTHICK1*ZREDMIN
        ZTHICK(JL) = ZTHICK(JL) + ZTHICK1
        IF ((ZREDMIN>0.999999999_JPRB).OR.&
             &(ZTHICK(JL)>=XMEANRED_THICKNESS_SDT)) THEN
          LLTHICKENOUGH(JL)=.TRUE.
          ZTHICK1=XMEANRED_THICKNESS_SDT-ZTHICK(JL)
          ZMEAN(JL)=ZMEAN(JL) + ZTHICK1*ZREDMIN
          ZTHICK(JL)=XMEANRED_THICKNESS_SDT
        ENDIF
      ENDIF
    ENDDO JLLOOP
    LLALLTHICKENOUGH=ALL(LLTHICKENOUGH(KIDIA:KFDIA))
    IF (LLALLTHICKENOUGH) THEN
      EXIT JKLOOP
    ENDIF
  ENDDO JKLOOP
  IF (.NOT.LLALLTHICKENOUGH) THEN
    CALL ABOR1('XMEANRED_THICKNESS_SDT is too large; LLALLTHICKENOUGH=FALSE despite JK=KLEV')
  ENDIF
  DO JL=KIDIA,KFDIA
    ZMEAN(JL) = ZMEAN(JL)*ZRTHICK
    ZRED(JL,:)= ZMEAN(JL)
  ENDDO
  !
  !   apply reduction factor and update ztp1, zqp1
  !
  DO JK=1,KLEV
    DO JL=KIDIA,KFDIA
      IF ((ZRED(JL,JK) /= 1._JPRB).AND.LLPERT(JL,JK)) THEN
        ZPERT= ZRED(JL,JK)*ZTAPER(JL,JK)*PMULNOISE(JL,JK)
        ZFACT=1._JPRB + ZPERT
        PTENT(JL,JK)=PTENTIN(JL,JK) + ZFACT*ZDZPT(JL,JK) 
        PTENQ(JL,JK)=PTENQIN(JL,JK) + ZFACT*ZDZPQ(JL,JK) 
      ENDIF
    ENDDO
  ENDDO
ENDIF

DO JK=1,KLEV
  DO JL=KIDIA,KFDIA
    DPTENQ1(JL,JK,1)=PTENQ(JL,JK)-PTENQIN(JL,JK)
    DPTENQ1(JL,JK,2)=PTENT(JL,JK)-PTENTIN(JL,JK)
    DPTENQ1(JL,JK,3)=PTENU(JL,JK)-PTENUIN(JL,JK)
    DPTENQ1(JL,JK,4)=PTENV(JL,JK)-PTENVIN(JL,JK)
   ENDDO
ENDDO

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