SUBROUTINE EXCHCOAD(&
 & KPROMA,KIDIA,KFDIA,&
 & PQ5,PT5,PAPHI5,PAPHIH5,PR5,PTS5,&
 & PQ,PT,PAPHI,PAPHIH,PR,PTS,&
 & PUB5,PVB5,PAZO5,&
 & PUB,PVB,PAZO,&
 & PWET5,PQS5,&
 & PWET,PQS,&
 & PRI5,&
 & PBN,PBM,PBH)  

!**** *EXCHCOAD* - ADJOINT OF TANGENT LINEAR OF
!                  THE EXCHANGE COEFFICIENTS

!     PURPOSE
!     -------
!          COMPUTE THE ADJOINT OF THE TANGENT LINEAR
!          OF DRAG COEFFICIENT FOR MOMENTUM AND HEAT
!          AND OF THE RICHARDSON NUMBER

!**   INTERFACE
!     ---------
!        EXPLICIT ARGUMENTS
!        ------------------

!        KPROMA                    - HORIZONTAL DIMENSION.             (INPUT-C)
!        KIDIA                     - INITIAL POINT
!        KFDIA                     - FINAL POINT
!        PQ(KPROMA)                - SPECIFIC HUMIDITY ON THE LOWER
!                                    LEVEL.                            (INPUT)
!        PT(KPROMA)                - TEMPERATURE ON THE LOWER LEVEL    (INPUT)
!        PAPHI(KPROMA)             - GEOPOTENTIAL LOWER MODEL LEVEL    (INPUT)
!        PTS(KPROMA)               - SURFACE TEMPERATURE               (INPUT)
!        PUB(KPROMA)               - U-WIND COMPONENT                  (INPUT)
!        PVB(KPROMA)               - V-WIND COMPONENT                  (INPUT)
!        PAZO(KPROMA)              - ROUGHNESS DISTRIBUTION            (INPUT)
!        PWET(KPROMA)              - SOIL HUMIDITY                     (INPUT)
!        PQS(KPROMA)               - SURFACE SATURATION HUMIDITY       (INPUT)
!        PRI(KPROMA)               - RICHARSON NUMBER                  (INPUT)
!        PBN(KPROMA)               - NEUTRAL COEFFICIENT               (OUTPUT)
!        PBM(KPROMA)               - MOMENTUM COEFFICIENT              (OUTPUT)
!        PBH(KPROMA)               - HEAT COEFFICIENT                  (OUTPUT)

!        IMPLICIT ARGUMENTS :  NONE.
!        --------------------

!     METHOD.
!     -------
!        SEE DOCUMENTATION

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

!     REFERENCE.
!     ----------
!        ECMWF RESEARCH DEPARTMENT DOCUMENTATION OF THE IFS

!     AUTHOR.
!     -------
!        CARLA CARDINALI *ECMWF*

!     MODIFICATIONS.
!     --------------
!        ORIGINAL : 92-05-22
!        M.Hamrud : 95-09-25 Some cleaning, vectorization problems
!        MODIFICATION : P. MOLL   18 juillet  1996 ACHMT transplantation
!        MODIFICATION : F. VEERSE 11 novembre 1997 Bug correction
!                       1999-06, J.M. Piriou: Richardson critical number variable in the vertical.
!                     2000-03-01, M. Janiskova: REPSEC changed to ZEPSEC since
!                                               REPSEC should not be redefined
!        M.Hamrud      01-Oct-2003 CY28 Cleaning
!     ------------------------------------------------------------------

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

USE YOMCST   , ONLY : RG       ,RD       ,RV       ,RCPD     ,RKAPPA   ,RETV
USE YOETHF   , ONLY : RVTMP2
USE YOEVDF   , ONLY : RKAP     ,REPDU2
USE YOMCT0B  , ONLY : LECMWF
USE YOMPHY0  , ONLY : USURIC   ,USURICL

IMPLICIT NONE

INTEGER(KIND=JPIM),INTENT(IN)    :: KPROMA 
INTEGER(KIND=JPIM),INTENT(IN)    :: KIDIA 
INTEGER(KIND=JPIM),INTENT(IN)    :: KFDIA 
REAL(KIND=JPRB)   ,INTENT(IN)    :: PQ5(KPROMA) 
REAL(KIND=JPRB)   ,INTENT(IN)    :: PT5(KPROMA) 
REAL(KIND=JPRB)   ,INTENT(IN)    :: PAPHI5(KPROMA) 
REAL(KIND=JPRB)   ,INTENT(IN)    :: PAPHIH5(KPROMA) 
REAL(KIND=JPRB)   ,INTENT(IN)    :: PR5(KPROMA) 
REAL(KIND=JPRB)   ,INTENT(IN)    :: PTS5(KPROMA) 
REAL(KIND=JPRB)   ,INTENT(INOUT) :: PQ(KPROMA) 
REAL(KIND=JPRB)   ,INTENT(INOUT) :: PT(KPROMA) 
REAL(KIND=JPRB)   ,INTENT(INOUT) :: PAPHI(KPROMA) 
REAL(KIND=JPRB)   ,INTENT(INOUT) :: PAPHIH(KPROMA) 
REAL(KIND=JPRB)   ,INTENT(INOUT) :: PR(KPROMA) 
REAL(KIND=JPRB)   ,INTENT(INOUT) :: PTS(KPROMA) 
REAL(KIND=JPRB)   ,INTENT(IN)    :: PUB5(KPROMA) 
REAL(KIND=JPRB)   ,INTENT(IN)    :: PVB5(KPROMA) 
REAL(KIND=JPRB)   ,INTENT(IN)    :: PAZO5(KPROMA) 
REAL(KIND=JPRB)   ,INTENT(INOUT) :: PUB(KPROMA) 
REAL(KIND=JPRB)   ,INTENT(INOUT) :: PVB(KPROMA) 
REAL(KIND=JPRB)   ,INTENT(INOUT) :: PAZO(KPROMA) 
REAL(KIND=JPRB)   ,INTENT(IN)    :: PWET5(KPROMA) 
REAL(KIND=JPRB)   ,INTENT(IN)    :: PQS5(KPROMA) 
REAL(KIND=JPRB)   ,INTENT(INOUT) :: PWET(KPROMA) 
REAL(KIND=JPRB)   ,INTENT(INOUT) :: PQS(KPROMA) 
REAL(KIND=JPRB)   ,INTENT(IN)    :: PRI5(KPROMA) 
REAL(KIND=JPRB)   ,INTENT(INOUT) :: PBN(KPROMA) 
REAL(KIND=JPRB)   ,INTENT(INOUT) :: PBM(KPROMA) 
REAL(KIND=JPRB)   ,INTENT(INOUT) :: PBH(KPROMA) 
REAL(KIND=JPRB) :: ZRTI(KPROMA),ZRS(KPROMA)
REAL(KIND=JPRB) :: ZRTI5(KPROMA),ZRS5(KPROMA)
REAL(KIND=JPRB) :: ZDFI(KPROMA),ZDFI5(KPROMA)

INTEGER(KIND=JPIM) :: JL

REAL(KIND=JPRB) :: ZB, ZC, ZCDN, ZCDN1, ZCDN15, ZCDN5, ZCFH,&
 & ZCFH1, ZCFH15, ZCFH5, ZCFM, ZCFM1, ZCFM15, &
 & ZCFM5, ZCONS1, ZCONS2, ZCONS3, ZCONS4, ZD, &
 & ZDPHI, ZDPHI5, ZDU2, ZDU25, ZRI, ZRI5, ZRIV, &
 & ZRIV5, ZRVMD, ZSCF, ZSCF5, ZTVD, ZTVD5, ZTVS, &
 & ZTVS5, ZUCF, ZUCF1, ZUCF15, ZUCF5, ZEPSEC  
REAL(KIND=JPRB) :: ZHOOK_HANDLE

!     1.     DEFINITION OF THE CONSTANTS
!            ---------------------------

!*    1.1    PHYSICAL CONSTANTS

IF (LHOOK) CALL DR_HOOK('EXCHCOAD',0,ZHOOK_HANDLE)
ZRVMD=RV-RD

!     TAKEN FROM COMMON DECKS

!*    1.2  *RKAP* IS THE VON KARMAN CONSTANT, *ZB,* *ZC* AND *ZD* ARE
!          CONSTANTS FOR FORMULAE FOR STABILITY DEPENDENCY
!          RESPECTIVELY   NEAR THE NEUTRAL, IN THE UNSTABLE AND IN THE
!          STABLE CASE.

ZB=5._JPRB
ZC=5._JPRB
ZD=5._JPRB

!*    1.3    SECURITY PARAMETER.
!            *REPDU2* IS A MINIMUM SQUARED WIND INCREMENT
!            TO AVOID DIVIDING BY ZERO IN THE *RICHARDSON NUMBER'S  A
!            CALCULATION.
!            *ZEPSEC* IS A MINIMUM VALUE FOR DRAG COEFFICIENTS.
ZEPSEC=1.E-02_JPRB

!*    1.4     COMPUTATIONAL CONSTANTS.

ZCONS1=3._JPRB*ZB*ZC
ZCONS2=2.0_JPRB*ZB
ZCONS3=3._JPRB*ZB
ZCONS4=1.0_JPRB/RKAP**2

!*      2.1      ADJOINT COMPUTATION

DO JL=KIDIA,KFDIA
  ZDU25=PUB5(JL)**2+PVB5(JL)**2
  IF(ZDU25 > REPDU2) THEN
    ZDU25=ZDU25
  ELSE
    ZDU25=REPDU2
  ENDIF
  ZDPHI5=PAPHI5(JL)/RCPD
  ZTVD5=(PT5(JL)+ZDPHI5/(1.0_JPRB+RVTMP2*PQ5(JL)))*(1.0_JPRB+RETV*PQ5(JL))
  ZTVS5=PTS5(JL)*(1.0_JPRB+RETV*PWET5(JL)*PQS5(JL))

  IF(.NOT.LECMWF)THEN
! achmt Ri number
    ZRS5(JL)=RD+ZRVMD*PQS5(JL)
    ZDFI5(JL)=PAPHI5(JL)-PAPHIH5(JL)
    ZRTI5(JL)=2.0_JPRB/(PR5(JL)*PT5(JL)+RKAPPA*ZDFI5(JL)+ZRS5(JL)*PTS5(JL))
    ZRIV5=ZDFI5(JL)*(PR5(JL)*PT5(JL)+RKAPPA &
     & *ZDFI5(JL)-ZRS5(JL)*PTS5(JL))*ZRTI5(JL)  
    ZRI5=ZRIV5/ZDU25
    ZRI5=ZRI5/(1.0_JPRB+MAX(0.0_JPRB,ZRI5)*USURIC*USURICL)

  ENDIF

  ZCDN15=LOG(1.0_JPRB+PAPHI5(JL)/(RG*PAZO5(JL)))
  ZCDN5=(RKAP/ZCDN15)**2
  IF(PRI5(JL) >= 0.0_JPRB) THEN
    ZSCF5=SQRT(1.0_JPRB+ZD*PRI5(JL))
    ZCFM5=ZCDN5*(1.0_JPRB/(1.0_JPRB+ZCONS2*PRI5(JL)/ZSCF5))
    ZCFH5=ZCDN5*(1.0_JPRB/(1.0_JPRB+ZCONS3*PRI5(JL)*ZSCF5))
  ELSE
    ZUCF15=SQRT(-PRI5(JL)*(1.0_JPRB+PAPHI5(JL)/(RG*PAZO5(JL))))
    ZUCF5=1.0_JPRB/(1.0_JPRB+ZCONS1*ZCDN5*ZUCF15)
    ZCFM5=ZCDN5*(1.0_JPRB-ZCONS2*PRI5(JL)*ZUCF5)
    ZCFH5=ZCDN5*(1.0_JPRB-ZCONS3*PRI5(JL)*ZUCF5)
  ENDIF
  ZCFM15=SQRT(ZCFM5*ZCONS4)
  IF(ZCFM15 > ZEPSEC) THEN
    ZCFM15=ZCFM15
  ELSE
    ZCFM15=ZEPSEC
  ENDIF
  ZCFH15=ZCFH5*ZCONS4/ZCFM15
  IF(ZCFH15 > ZEPSEC) THEN
    ZCFH15=ZCFH15
  ELSE
    ZCFH15=ZEPSEC
  ENDIF

  ZCFH1=0.0_JPRB
  ZCFM1=0.0_JPRB
  ZCDN= 0.0_JPRB
  ZCFH= 0.0_JPRB
  ZCFM= 0.0_JPRB
  ZSCF= 0.0_JPRB
  ZUCF= 0.0_JPRB
  ZUCF1=0.0_JPRB
  ZCDN1=0.0_JPRB
  ZDPHI=0.0_JPRB
  ZRI= 0.0_JPRB
  ZRIV= 0.0_JPRB
  ZTVS= 0.0_JPRB
  ZTVD= 0.0_JPRB
  ZDU2= 0.0_JPRB
  ZCFH1=ZCFH1-1.0_JPRB/ZCFH15**2*PBH(JL)
  ZCFM1=ZCFM1-1.0_JPRB/ZCFM15**2*PBM(JL)
  ZCDN=ZCDN-RKAP/(2.0_JPRB*SQRT(ZCDN5)*ZCDN5)*PBN(JL)
  IF(ZCFH15 > ZEPSEC)THEN
    ZCFH=ZCFH+ZCONS4/ZCFM15*ZCFH1
    ZCFM1=ZCFM1-ZCFH5*ZCONS4/ZCFM15**2*ZCFH1
  ENDIF
  IF(ZCFM15 > ZEPSEC)THEN
    ZCFM=ZCFM+ZCONS4/(2.0_JPRB*ZCFM15)*ZCFM1
  ENDIF
  IF(PRI5(JL) >= 0.0_JPRB) THEN
    ZCDN=ZCDN+(1.0_JPRB/(1.0_JPRB+ZCONS3*PRI5(JL)*ZSCF5))*ZCFH
    ZRI=ZRI-ZCDN5/(1.0_JPRB+ZCONS3*PRI5(JL)*ZSCF5)**2*ZCONS3*ZSCF5*ZCFH
    ZSCF=ZSCF-ZCDN5/(1.0_JPRB+ZCONS3*PRI5(JL)*ZSCF5)**2*ZCONS3*PRI5(JL)*ZCFH
    ZCDN=ZCDN+(1.0_JPRB/(1.0_JPRB+ZCONS2*PRI5(JL)/ZSCF5))*ZCFM
    ZRI=ZRI-ZCDN5/(1.0_JPRB+ZCONS2*PRI5(JL)/ZSCF5)**2*ZCONS2/ZSCF5*ZCFM
    ZSCF=ZSCF+ZCDN5/(1.0_JPRB+ZCONS2*PRI5(JL)/ZSCF5)**2 &
     & *ZCONS2*PRI5(JL)/ZSCF5**2*ZCFM  
    ZRI=ZRI+ZD/(2.0_JPRB*ZSCF5)*ZSCF
  ELSE
    ZCDN=ZCDN+(1.0_JPRB-ZCONS3*PRI5(JL)*ZUCF5)*ZCFH
    ZRI=ZRI-ZCDN5*ZCONS3*ZUCF5*ZCFH
    ZUCF=ZUCF-ZCDN5*ZCONS3*PRI5(JL)*ZCFH
    ZCDN=ZCDN+(1.0_JPRB-ZCONS2*PRI5(JL)*ZUCF5)*ZCFM
    ZRI=ZRI-ZCDN5*ZCONS2*ZUCF5*ZCFM
    ZUCF=ZUCF-ZCDN5*ZCONS2*PRI5(JL)*ZCFM
    ZCDN=ZCDN-ZUCF5**2*ZCONS1*ZUCF15*ZUCF
    ZUCF1=ZUCF1-ZUCF5**2*ZCONS1*ZCDN5*ZUCF
    ZRI=ZRI-1.0_JPRB/(2.0_JPRB*ZUCF15)*(1.0_JPRB+PAPHI5(JL)/(RG*PAZO5(JL)))*ZUCF1
    PAPHI(JL)=PAPHI(JL)-1.0_JPRB/(2.0_JPRB*ZUCF15)*PRI5(JL)/(RG*PAZO5(JL))*ZUCF1
    PAZO(JL)=PAZO(JL)+1.0_JPRB/(2.0_JPRB*ZUCF15)*&
     & PRI5(JL)*PAPHI5(JL)/(RG*PAZO5(JL)**2)*ZUCF1  
  ENDIF
  ZCDN1=ZCDN1-2.0_JPRB*(RKAP/ZCDN15)*RKAP/ZCDN15**2*ZCDN
  PAPHI(JL)=PAPHI(JL)+1.0_JPRB/(RG*PAZO5(JL))&
   & /(1.0_JPRB+PAPHI5(JL)/(RG*PAZO5(JL)))*ZCDN1  
  PAZO(JL)=PAZO(JL)-PAPHI5(JL)/(RG*PAZO5(JL)**2)&
   & /(1.0_JPRB+PAPHI5(JL)/(RG*PAZO5(JL)))*ZCDN1  

  IF(.NOT.LECMWF)THEN
! achmt Ri number
    ZRTI(JL)=0.0_JPRB
    ZDFI(JL)=0.0_JPRB
    ZRS(JL)=0.0_JPRB
    IF(ZRI5 > 0.0_JPRB)THEN
      ZRI=ZRI/(1.0_JPRB+ZRI5*USURIC*USURICL)**2
    ENDIF
    ZDU2=ZDU2-ZRIV5*ZRI/ZDU25**2
    ZRIV=ZRIV+ZDU25*ZRI/ZDU25**2
    ZRI=0.0_JPRB
    PT(JL)=PT(JL)+ZDFI5(JL)*PR5(JL)*ZRTI5(JL)*ZRIV
    PR(JL)=PR(JL)+ZDFI5(JL)*PT5(JL)*ZRTI5(JL)*ZRIV
    ZDFI(JL)=ZDFI(JL)+ZDFI5(JL)*RKAPPA*ZRTI5(JL)*ZRIV
    ZRS(JL)=ZRS(JL)+ZDFI5(JL)*PTS5(JL)*ZRTI5(JL)*ZRIV
    PTS(JL)=PTS(JL)+ZDFI5(JL)*ZRS5(JL)*ZRTI5(JL)*ZRIV
    ZRTI(JL)=ZRTI(JL)+&
     & ZDFI5(JL)*(PR5(JL)*PT5(JL)+RKAPPA &
     & *ZDFI5(JL)-ZRS5(JL)*PTS5(JL))*ZRIV  
    ZDFI(JL)=ZDFI(JL)+(PR5(JL)*PT5(JL)+RKAPPA &
     & *ZDFI5(JL)-ZRS5(JL)*PTS5(JL))*ZRTI5(JL)*ZRIV  
    ZRIV=0.0_JPRB
    PR(JL)=PR(JL)-2.0_JPRB*PT5(JL)*ZRTI(JL)&
     & /(PR5(JL)*PT5(JL)+RKAPPA*ZDFI5(JL)&
     & +ZRS5(JL)*PTS5(JL))**2.0_JPRB  
    PT(JL)=PT(JL)-2.0_JPRB*PR5(JL)*ZRTI(JL)&
     & /(PR5(JL)*PT5(JL)+RKAPPA*ZDFI5(JL)&
     & +ZRS5(JL)*PTS5(JL))**2.0_JPRB  
    ZDFI(JL)=ZDFI(JL)-2.0_JPRB*RKAPPA*ZRTI(JL)&
     & /(PR5(JL)*PT5(JL)+RKAPPA*ZDFI5(JL)&
     & +ZRS5(JL)*PTS5(JL))**2.0_JPRB  
    ZRS(JL)=ZRS(JL)-2.0_JPRB*PTS5(JL)*ZRTI(JL)&
     & /(PR5(JL)*PT5(JL)+RKAPPA*ZDFI5(JL)&
     & +ZRS5(JL)*PTS5(JL))**2.0_JPRB  
    PTS(JL)=PTS(JL)-2.0_JPRB*ZRS5(JL)*ZRTI(JL)&
     & /(PR5(JL)*PT5(JL)+RKAPPA*ZDFI5(JL)&
     & +ZRS5(JL)*PTS5(JL))**2.0_JPRB  
    ZRTI(JL)=0.0_JPRB
    PAPHI(JL)=PAPHI(JL)+ZDFI(JL)
    PAPHIH(JL)=PAPHIH(JL)-ZDFI(JL)
    ZDFI(JL)=0.0_JPRB
    PQS(JL)=PQS(JL)+ZRVMD*ZRS(JL)
    ZRS(JL)=0.0_JPRB

  ENDIF

  PAPHI(JL)=PAPHI(JL)+(1.0_JPRB-ZTVS5/ZTVD5)/ZDU25*ZRI
  ZTVS=ZTVS-PAPHI5(JL)/ZTVD5/ZDU25*ZRI
  ZTVD=ZTVD+PAPHI5(JL)*ZTVS5/ZTVD5**2/ZDU25*ZRI
  ZDU2=ZDU2-PAPHI5(JL)*(1.0_JPRB-ZTVS5/ZTVD5)/ZDU25**2*ZRI
  PTS(JL)=PTS(JL)+(1.0_JPRB+RETV*PWET5(JL)*PQS5(JL))*ZTVS
  PWET(JL)=PWET(JL)+PTS5(JL)*RETV*PQS5(JL)*ZTVS
  PQS(JL)=PQS(JL)+PTS5(JL)*RETV*PWET5(JL)*ZTVS
  PT(JL)=PT(JL)+(1.0_JPRB+RETV*PQ5(JL))*ZTVD
  ZDPHI=ZDPHI+1.0_JPRB/(1.0_JPRB+RVTMP2*PQ5(JL))*(1.0_JPRB+RETV*PQ5(JL))*ZTVD
  PQ(JL)=PQ(JL)+( PT5(JL)*RETV-ZDPHI5*RVTMP2 &
   & *(1.0_JPRB+RETV*PQ5(JL))/(1.0_JPRB+RVTMP2*PQ5(JL))**2 &
   & +ZDPHI5/(1.0_JPRB+RVTMP2*PQ5(JL))*RETV )*ZTVD  
  PAPHI(JL)=PAPHI(JL)+ZDPHI/RCPD
  IF(ZDU25 > REPDU2)THEN
    PUB(JL)=PUB(JL)+2.0_JPRB*PUB5(JL)*ZDU2
    PVB(JL)=PVB(JL)+2.0_JPRB*PVB5(JL)*ZDU2
  ENDIF
  PBN(JL)=0.0_JPRB
  PBH(JL)=0.0_JPRB
  PBM(JL)=0.0_JPRB
ENDDO

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

