!OPTIONS XOPT(NOEVAL)
SUBROUTINE ACDIFV2 ( KIDIA,KFDIA,KLON,KTDIA,KLEV,&
 !-----------------------------------------------------------------------
 ! - INPUT  2D .
 & PAPRS,&
 & PCFAQ,PCFAS,PCFAU,&
 & PCFBQ,PCFBS,PCFBU,PCFBV,&
 & PKTROV,PKUROV,&
 ! - INPUT  1D .
 & PCOEFA,PALPHA1,PLVT,PQICE,&
 & PFCS,PFEV,PFMDU,PFMDV,&
 & PTSN,PXHROV,&
 ! - OUTPUT 2D .
 & PDIFTQ,PDIFTS,PSTRTU,PSTRTV,&
 & PDIFTQL,PDIFTQI,&
 ! - LOCK ARGUMENTS .
 & CDLOCK)  

!**** *ACDIFV2 * - DIFFUSION VERTICALE TURBULENTE.

!     Sujet.
!     ------
!     - ROUTINE DE CALCUL ACTIF .
!       CALCULS DE DIFFUSION VERTICALE TURBULENTE PAR SUBSTITUTION
!       ASCENDANTE, FLUX TURBULENTS VERTICAUX, 
!       CORRECTION DES FLUX DE RAYONNEMENT THERMIQUE.
!       CAS DU SCHEMA DE SOL VEGETATION EXTERNE (CLE LSVEXT).
!     - COMPUTATION OF VERTICAL TURBULENT DIFFUSION BY BACK
!       SUBSTITUTION, VERTICAL TURBULENT FLUXES,
!       THERMAL RADIATION FLUXES' CORRECTION.
!       CASE OF EXTERNAL SOIL VEGETATION SCHEME (LSVEXT KEY).

!**   Interface.
!     ----------
!        *CALL* *ACDIFV2*

!-----------------------------------------------------------------------
! WARNING: THE ENGLISH VERSION OF VARIABLES' NAMES IS TO BE READ IN THE
!          "APLPAR" CODE.
!-----------------------------------------------------------------------

! -   ARGUMENTS D'ENTREE.
!     -------------------

! - NOM DES PARAMETRES DE DIMENSIONNEMENT DE LA PHYSIQUE.

! KIDIA      : INDICE DE DEPART DES BOUCLES VECTORISEES SUR L'HORIZONT..
! KFDIA      : INDICE DE FIN DES BOUCLES VECTORISEES SUR L'HORIZONTALE.
! KLON       : DIMENSION HORIZONTALE DES TABLEAUX.
! KTDIA      : INDICE DE DEPART DES BOUCLES VERTICALES (1 EN GENERAL).
! KLEV       : DIMENSION VERTICALE DES TABLEAUX "FULL LEVEL".

! - NOM DES VARIABLES DE LA PHYSIQUE (PAR ORDRE ALPHABETIQUE DANS CHAQUE
!   CATEGORIE).

! - 2D (0:KLEV) .

! PAPRS      : PRESSION AUX DEMI-NIVEAUX.
! PKTROV     : COEFFICIENT D'ECHANGE VERTICAL DE T ET Q EN KG/(M*M*S).
! PKUROV     : COEFFICIENT D'ECHANGE VERTICAL DE U ET V EN KG/(M*M*S).

! - 2D (1:KLEV) .

! PCFAQ      : COEFFICIENT D'ELIMINATION POUR Q.
! PCFAS      : COEFFICIENT D'ELIMINATION POUR S.
! PCFAU      : COEFFICIENT D'ELIMINATION POUR U ET V.
! PCFBQ      : SECOND MEMBRE POUR Q.
! PCFBS      : SECOND MEMBRE POUR S.
! PCFBU      : SECOND MEMBRE POUR U.
! PCFBV      : SECOND MEMBRE POUR V.

! - 1D (PROGNOSTIQUE) .

! PTSN       : TEMPERATURE DE SURFACE AU PAS DE TEMPS +.

! - 1D (DIAGNOSTIQUE) .

! PFCS       : FLUX DE CHALEUR SENSIBLE EN SURFACE.
! PFEV       : FLUX D'EVAPORATION EN SURFACE.
! PFMDU      : FLUX DE QUANTITE DE MOUVEMENT (U) EN SURFACE.
! PFMDV      : FLUX DE QUANTITE DE MOUVEMENT (V) EN SURFACE.
! PXHROV     : MULTIPLICATEUR "ANTI-FIBRILLATION" EN SURFACE POUR S ET Q.

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

! -   ARGUMENTS DE SORTIE.
!     --------------------

! - 2D (0:KLEV) .

! PDIFTQ     : FLUX TURBULENT (ET Q NEGATIF) D'HUMIDITE SPECIFIQUE.
! PDIFTS     : FLUX TURBULENT D'ENTHALPIE (OU D'ENERGIE STATIQUE SECHE).
! PSTRTU     : FLUX TURBULENT DE QUANTITE DE MOUVEMENT "U".
! PSTRTV     : FLUX TURBULENT DE QUANTITE DE MOUVEMENT "V".

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

! -   ARGUMENTS IMPLICITES.
!     ---------------------

! COMMON/YOMCST /
! COMMON/YOMPHY2/
! COMMON/YOMPHY4/
! COMMON/FCTTRM /

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

!     Externes.
!     ---------

!     Methode.
!     --------

!     Auteur.
!     -------
!        2002-01, A.L. Gibelin d'apres ACDIFUS et Polcher et al (1998)

!     Modifications.
!     --------------
!        2002-06, Flux de quantite de mouvement en surface externalisation
!                 du calcul de PGZ0F - A.L. Gibelin
!        2004-05, Adaptation a la nouvelle version d'Arpege-Climat (4.2): 
!                 Calcul des flux de ql/qi (PDIFTQL/N) et utilisation en
!                 entree de PKQROV/PKQLROV (J.F. Gueremy) - I. Zuurendonk
!        2004-09: Supprimer calcul de PFRTH pour externalisation boucle
!                 temporelle du schema de surface - I. Zuurendonk
!        M.Hamrud      01-Oct-2003 CY28 Cleaning
!        2007-05, Bug correction on antifibrillation - F. Bouyssel
!        2008-02, Projection sur Ql & Qi si L3MT - R. Brozkova
!        2008-10, Suppression correction humidite negative - F. Bouyssel

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

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

USE YOMPHY   , ONLY : LDIFCONS, L3MT, LSTRAPRO
USE YOMPHY0  , ONLY : RDTFAC

USE YOMCST   , ONLY :         &
 & RV       ,RCPD     ,RCPV     ,RETV     ,RCW      ,&
 & RCS      ,RLVTT    ,RLSTT    ,RTT      ,RALPW    ,&
 & RBETW    ,RGAMW    ,RALPS    ,RBETS    ,RGAMS    ,&
 & RALPD    ,RBETD    ,RGAMD    ,RATM     ,RKAPPA   ,&
 & RDT 
USE YOMARPHY  ,ONLY : LMSE


IMPLICIT NONE

INTEGER(KIND=JPIM),INTENT(IN)    :: KLON 
INTEGER(KIND=JPIM),INTENT(IN)    :: KLEV 
INTEGER(KIND=JPIM),INTENT(IN)    :: KIDIA 
INTEGER(KIND=JPIM),INTENT(IN)    :: KFDIA 
INTEGER(KIND=JPIM),INTENT(IN)    :: KTDIA 
REAL(KIND=JPRB)   ,INTENT(IN)    :: PAPRS(KLON,0:KLEV) 
REAL(KIND=JPRB)   ,INTENT(IN)    :: PCFAQ(KLON,KLEV) 
REAL(KIND=JPRB)   ,INTENT(IN)    :: PCFAS(KLON,KLEV) 
REAL(KIND=JPRB)   ,INTENT(IN)    :: PCFAU(KLON,KLEV) 
REAL(KIND=JPRB)   ,INTENT(IN)    :: PCFBQ(KLON,KLEV) 
REAL(KIND=JPRB)   ,INTENT(IN)    :: PCFBS(KLON,KLEV) 
REAL(KIND=JPRB)   ,INTENT(IN)    :: PCFBU(KLON,KLEV) 
REAL(KIND=JPRB)   ,INTENT(IN)    :: PCFBV(KLON,KLEV) 
REAL(KIND=JPRB)   ,INTENT(IN)    :: PKTROV(KLON,0:KLEV) 
REAL(KIND=JPRB)   ,INTENT(IN)    :: PKUROV(KLON,0:KLEV) 
REAL(KIND=JPRB)   ,INTENT(IN)    :: PFCS(KLON) 
REAL(KIND=JPRB)   ,INTENT(IN)    :: PFEV(KLON) 
REAL(KIND=JPRB)   ,INTENT(IN)    :: PFMDU(KLON) 
REAL(KIND=JPRB)   ,INTENT(IN)    :: PFMDV(KLON) 
REAL(KIND=JPRB)   ,INTENT(IN)    :: PTSN(KLON) 
REAL(KIND=JPRB)   ,INTENT(IN)    :: PXHROV(KLON) 

REAL(KIND=JPRB)   ,INTENT(IN)    :: PALPHA1(KLON,0:KLEV)
REAL(KIND=JPRB)   ,INTENT(IN)    :: PCOEFA(KLON,0:KLEV)
REAL(KIND=JPRB)   ,INTENT(IN)    :: PLVT(KLON,0:KLEV)
REAL(KIND=JPRB)   ,INTENT(IN)    :: PQICE(KLON,0:KLEV)


REAL(KIND=JPRB)   ,INTENT(OUT)   :: PDIFTQ(KLON,0:KLEV) 
REAL(KIND=JPRB)   ,INTENT(OUT)   :: PDIFTS(KLON,0:KLEV) 
REAL(KIND=JPRB)   ,INTENT(OUT)   :: PSTRTU(KLON,0:KLEV) 
REAL(KIND=JPRB)   ,INTENT(OUT)   :: PSTRTV(KLON,0:KLEV) 

REAL(KIND=JPRB)   ,INTENT(OUT)   :: PDIFTQL(KLON,0:KLEV)
REAL(KIND=JPRB)   ,INTENT(OUT)   :: PDIFTQI(KLON,0:KLEV)


CHARACTER(LEN=7)  ,INTENT(IN)    :: CDLOCK 
REAL(KIND=JPRB) :: ZKQRV(KLON,0:KLEV)&
 & ,ZKSRV(KLON,0:KLEV),ZN1(KLON,KLEV),ZN2(KLON,KLEV)

INTEGER(KIND=JPIM) :: JLEV, JLON

REAL(KIND=JPRB) :: ZCPVMD,ZEXNER
REAL(KIND=JPRB) :: ZDIFTS,ZDIFTQ,ZDIFTQC
REAL(KIND=JPRB) :: ZHOOK_HANDLE

#include "abor1.intfb.h"

!     FUNCTIONS THERMODYNAMIQUES DE BASE
#include "fcttrm.h"
#include "fctdoi.h"

!     CHECK RELIABILITY OF INPUT ARGUMENTS.

IF (LHOOK) CALL DR_HOOK('ACDIFV2',0,ZHOOK_HANDLE)
IF(CDLOCK /= 'ACDIFV2') CALL ABOR1('BAD NUMBER OF ARGUMENTS : ACDIFV2 !')

!*
!     ------------------------------------------------------------------
!     I - CONSTANTES AUXILIAIRES.

!         AUXILIARY CONSTANTS.

ZCPVMD=RCPV-RCPD

!*
!     ------------------------------------------------------------------
!     IV - CALCULS POUR LA QUANTITE DE MOUVEMENT : CONDITION DE SURFACE,
!     CALCUL DE "CHARNOCK" PUIS SUBSTITUTION AVEC CALCUL DES FLUX A TOUS
!     LES NIVEAUX.

!          COMPUTATION FOR MOMENTUM : SURFACE CONDITION, "CHARNOCK-TYPE"
!     CALCULATION THEN SUBSTITUTION WITH FLUXES' COMPUTATION AT ALL
!     LEVELS.

DO JLEV=KTDIA,KLEV
  DO JLON=KIDIA,KFDIA
    ZN1(JLON,JLEV)=PCFBU(JLON,JLEV)
    ZN2(JLON,JLEV)=PCFBV(JLON,JLEV)
  ENDDO
ENDDO


!     CALCULS EN SURFACE.
!     SURFACE CALCULATIONS.

DO JLON=KIDIA,KFDIA
  PSTRTU(JLON,KLEV) = PFMDU(JLON)
  PSTRTV(JLON,KLEV) = PFMDV(JLON)
ENDDO


IF (LMSE) THEN
  DO JLON=KIDIA,KFDIA
    ZN1(JLON,KLEV) = ZN1(JLON,KLEV) + PCFAU(JLON,KLEV)*PSTRTU(JLON,KLEV)
    ZN2(JLON,KLEV) = ZN2(JLON,KLEV) + PCFAU(JLON,KLEV)*PSTRTV(JLON,KLEV)
  ENDDO
ENDIF


!     SUBSTITUTION POUR UNE COUCHE STANDARD ET AU SOMMET.
!     BACK-SUBSTITUTION FOR A STANDARD LAYER AND AT THE TOP.

DO JLEV=KLEV-1,KTDIA,-1
  DO JLON=KIDIA,KFDIA
    ZN1(JLON,JLEV)=ZN1(JLON,JLEV)+PCFAU(JLON,JLEV)*ZN1(JLON,JLEV+1)
    ZN2(JLON,JLEV)=ZN2(JLON,JLEV)+PCFAU(JLON,JLEV)*ZN2(JLON,JLEV+1)
    PSTRTU(JLON,JLEV)=PKUROV(JLON,JLEV)*(ZN1(JLON,JLEV)-ZN1(JLON,JLEV+1))
    PSTRTV(JLON,JLEV)=PKUROV(JLON,JLEV)*(ZN2(JLON,JLEV)-ZN2(JLON,JLEV+1))
  ENDDO
ENDDO

!     CONDITION A LA LIMITE SUPERIEURE.
!     UPPER BOUNDARY CONDITION.

DO JLON=KIDIA,KFDIA
  PSTRTU(JLON,KTDIA-1)=0.0_JPRB
  PSTRTV(JLON,KTDIA-1)=0.0_JPRB
ENDDO

!*
!     ------------------------------------------------------------------
!     V - CALCULS POUR L'ENERGIE STATIQUE SECHE ET L'HUMIDITE SPECIFIQUE :
!     CALCULS D'ELIMINATION EN SURFACE POUR S ET  Q.

!          COMPUTATIONS FOR TEMPERATURE AND SPECIFIC HUMIDITY :
!     SURFACE ELIMINATION CALCULATION  FOR  S AND Q.

! - TEMPORAIRE(S) 2D (0:KLEV) .

! ZKQRV     : VALEUR (DUPLIQUEE DE PKTROV) POUR LA DIFFUSION DE Q.
!            : VALUE (DUPLICATED FROM PKTROV) FOR THE Q DIFFUSION.
! ZKSRV     : VALEUR (DUPLIQUEE DE PKTROV) POUR LA DIFFUSION DE S.
!            : VALUE (DUPLICATED FROM PKTROV) FOR THE S DIFFUSION.

!     DUPLICATION DES COEFFICIENTS D'ECHANGE VERTICAL DE S POUR Q.
!     DUPLICATION OF THE VERTICAL EXCHANGE COEFFICIENTS FOR S AND Q.

DO JLEV=KTDIA,KLEV-1
  DO JLON=KIDIA,KFDIA
    ZKQRV(JLON,JLEV)=PKTROV(JLON,JLEV)
    ZKSRV(JLON,JLEV)=PKTROV(JLON,JLEV)
  ENDDO
ENDDO

DO JLEV=KTDIA,KLEV
  DO JLON=KIDIA,KFDIA
    ZN1(JLON,JLEV)=PCFBS(JLON,JLEV)
    ZN2(JLON,JLEV)=PCFBQ(JLON,JLEV)
  ENDDO
ENDDO


IF (LMSE) THEN

  DO JLON=KIDIA,KFDIA
    ZEXNER       =  (PAPRS(JLON,KLEV)/RATM)**RKAPPA
    PDIFTQ(JLON,KLEV) = PFEV(JLON)
    PDIFTS(JLON,KLEV) = PFCS(JLON)*ZEXNER + PFEV(JLON)*ZCPVMD*PTSN(JLON)
  ENDDO

  DO JLON=KIDIA,KFDIA
    ZN1(JLON,KLEV)  =ZN1(JLON,KLEV)+&
      &PXHROV(JLON)*PCFAS(JLON,KLEV)*PDIFTS(JLON,KLEV)
    ZN2(JLON,KLEV)  =ZN2(JLON,KLEV)+&
      &PXHROV(JLON)*PCFAQ(JLON,KLEV)*PDIFTQ(JLON,KLEV)
  ENDDO


!*
!     ------------------------------------------------------------------
!     VI - CALCULS POUR LA TEMPERATURE ET L'HUMIDITE SPECIFIQUE : PARTIE
!     SUBSTITUTION ET CALCUL DES FLUX A TOUS LES NIVEAUX

!          COMPUTATIONS FOR TEMPERATURE AND SPECIFIC HUMIDITY :
!     BACK-SUBSTITUTION PART AND CALCULATION OF FLUXES AT ALL LEVELS


!     SUBSTITUTION POUR UNE COUCHE STANDARD ET AU SOMMET POUR S ET Q.
!     BACK-SUBSTITUTION FOR A STANDARD LEVEL AND AT THE TOP FOR S AND Q.

  DO JLEV=KLEV-1,KTDIA,-1
    DO JLON=KIDIA,KFDIA
      ZN1(JLON,JLEV)=ZN1(JLON,JLEV)+PCFAS(JLON,JLEV)*ZN1(JLON,JLEV+1)
      ZN2(JLON,JLEV)=ZN2(JLON,JLEV)+PCFAQ(JLON,JLEV)*ZN2(JLON,JLEV+1)
      PDIFTQ(JLON,JLEV)=ZKQRV(JLON,JLEV)*(ZN2(JLON,JLEV)-ZN2(JLON,JLEV+1))
      PDIFTS(JLON,JLEV)=ZKSRV(JLON,JLEV)*(ZN1(JLON,JLEV)-ZN1(JLON,JLEV+1))
    ENDDO
  ENDDO

!     CONDITIONS A LA LIMITE SUPERIEURE.
!     UPPER BOUNDARY CONDITIONS.

  DO JLON=KIDIA,KFDIA
    PDIFTQ(JLON,KTDIA-1)=0.0_JPRB
    PDIFTS(JLON,KTDIA-1)=0.0_JPRB
  ENDDO

ELSE

  IF ( (L3MT.OR.LSTRAPRO) .AND. LDIFCONS ) THEN

  !     ON PASSE DES VARIABLES "CONSERVATIVES" AUX VARIABLES "SECHES".
  !     FROM "MOIST AND  CONSERVATIVE" VARIABLES TO THE "DRY" ONES.

    DO JLEV = KLEV-1,KTDIA,-1
      DO JLON = KIDIA, KFDIA
        ZDIFTS=ZKSRV(JLON,JLEV)*(ZN1(JLON,JLEV)-ZN1(JLON,JLEV+1))
        ZDIFTQ=ZKQRV(JLON,JLEV)*(ZN2(JLON,JLEV)-ZN2(JLON,JLEV+1))
        ZDIFTQC=PCOEFA(JLON,JLEV)*(ZDIFTQ-PALPHA1(JLON,JLEV)*ZDIFTS)
        PDIFTS (JLON,JLEV)=ZDIFTS+ZDIFTQC*PLVT(JLON,JLEV)
        PDIFTQ (JLON,JLEV)=ZDIFTQ-ZDIFTQC
        PDIFTQL(JLON,JLEV)=ZDIFTQC*(1.0_JPRB-PQICE(JLON,JLEV))
        PDIFTQI(JLON,JLEV)=ZDIFTQC*PQICE(JLON,JLEV)
      ENDDO
    ENDDO

  ELSE

    DO JLEV=KLEV-1,KTDIA,-1
      DO JLON=KIDIA,KFDIA
        PDIFTS (JLON,JLEV)=ZKSRV(JLON,JLEV)*(ZN1(JLON,JLEV)-ZN1(JLON,JLEV+1))
        PDIFTQ (JLON,JLEV)=ZKQRV(JLON,JLEV)*(ZN2(JLON,JLEV)-ZN2(JLON,JLEV+1))
        PDIFTQL(JLON,JLEV)=0.0_JPRB
        PDIFTQI(JLON,JLEV)=0.0_JPRB
      ENDDO
    ENDDO

  ENDIF

!     CONDITION A LA LIMITE SUPERIEURE.
!     UPPER BOUNDARY CONDITION.

  DO JLON=KIDIA,KFDIA
    PDIFTQ (JLON,KTDIA-1)=0.0_JPRB
    PDIFTS (JLON,KTDIA-1)=0.0_JPRB
    PDIFTQL(JLON,KTDIA-1)=0.0_JPRB
    PDIFTQI(JLON,KTDIA-1)=0.0_JPRB
  ENDDO

!     CONDITIONS A LA LIMITE INFERIEURE.
!     LOWER BOUNDARY CONDITIONS.

  DO JLON=KIDIA,KFDIA
    PDIFTQL(JLON,KLEV)=0.0_JPRB
    PDIFTQI(JLON,KLEV)=0.0_JPRB
  ENDDO

ENDIF

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