!OPTIONS XOPT(HSFUN)
SUBROUTINE GWDRAGS( KIDIA,KFDIA,KLON,KLEV,&
 & PTSPHY, KSTEP, KSTART,&
 & PAPHM1,PAPM1,PGEOM1,&
 & PTM1,PUM1,PVM1,&
 & PHSTD  , PGAMMA, PTHETA, PSIG,&
 ! OUTPUTS
 & PUSTRGW,PVSTRGW,PVDISGW,PVOL,PVOM,PTE,&
 !  FLUX OUTPUTS
 & PSTRDU,PSTRDV                              )  

!**** *GWDRAG* - DOES THE GRAVITY WAVE PARAMETRIZATION.

!     PURPOSE.
!     --------

!          THIS ROUTINE COMPUTES THE PHYSICAL TENDENCIES OF THE
!     PROGNOSTIC VARIABLES U,V  AND T DUE TO  VERTICAL TRANSPORTS BY
!     SUBGRIDSCALE OROGRAPHICALLY EXCITED GRAVITY WAVES

!**   INTERFACE.
!     ----------
!          CALLED FROM *CALLPAR*.

!          THE ROUTINE TAKES ITS INPUT FROM THE LONG-TERM STORAGE:
!          U,V,T AND P AT T-1.

!        EXPLICIT ARGUMENTS :
!        --------------------
!     ==== INPUTS ===

!        *KIDIA*       START POINT
!        *KFDIA*       END POINT
!        *KLON*        NUMBER OF GRID POINTS PER PACKET
!        *KLEV*        NUMBER OF VERTICAL LEVELS
!        *KGL1*        ROW NUMBER FOR PRINTINGS  (UNSUED)
!        *KSTEP*       CURRENT TIME STEP INDEX
!        *KSTART*      FIRST STEP OF THE MODEL
!        *PTSPHY*      TIME STEP OF THE PHYSICS
!        *PHSTD*       STANDARD DEVIATION OF THE SUBGRID SCALE OROGRAPHY
!        *PTHETA*      GEOGRAPHICAL ORIENTATION 
!                      OF THE SUBGRID SCALE OROGRAPHY
!        *PGAMMA*      ANISOTROPY OF THE SUBGRID SCALE OROGRAPHY
!        *PSIG*        MEAN SLOPE OF THE SUBGRID SCALE OROGRAPHY
!        *PAPHM1*      PRESSURE AT HALF LEVELS AT T-1
!        *PAPM1*       PRESSURE AT FULL LEVELS AT T-1
!        *PGEOM1*      GEOPOTENTIAL AT T-1
!        *PTM1*        TEMPERATURE AT T-1
!        *PUM1*        X-VELOCITY COMPONENT AT T-1
!        *PVM1*        Y-VELOCITY COMPONENT AT T-1

!     ==== OUTPUTS ===

!        *PUSTRGW*     SURFACE FLUX OF U-MOMENTUM
!        *PVSTRGW*     SURFACE FLUX OF V-MOMENTUM
!        *PVDISGW*     DISSIPATION OF KINETIC ENERGY 
!        *PVOM*        TENDENCY OF U-COMP. OF WIND 
!        *PVOL*        TENDENCY OF V-COMP. OF WIND
!        *PTE*         TEMPERATURE TENDENCY    
!        *PSTRDU*      FLUX OF U-MOMENTUM
!        *PSTRDV*      FLUX OF V-MOMENTUM

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

!     METHOD.
!     -------
!          THE SCHEME CONSISTS OF THREE PARTS,THE CALCULATION OF LOWLEVEL
!         DRAG DUE TO WAKE EFFECTS OF THE SUBGRID OROGRAPHY,THE GRAVITY 
!         WAVE STRESS AND THE STRESS PROFILE IN THE VERTICAL.
!         THE STRESS IS COMPUTED USING A LOW-LEVEL WIND,STATIC STABILITY
!         AND  SUBGRID OROGRAPHIC PARAMETERS.THESE ARE THE STANDARD 
!         DEVIATION OF THE HEIGHT,THE ANGLE RELATIVE TO EAST, THE
!         ANISOTROPY,AND THE SLOPE.
!         A WAVE RICHARDSON NUMBER IS COMPUTED AT EACH LEVEL AND BY
!         REQUIRING THAT ITS VALUE IS NEVER LESS THAN A CRITICAL ONE
!         A VALUE OF STRESS IS DETERMINED AT EACH MODEL LEVEL.
!         THE CRITICAL FROUDE NUMBER OF THE FLOW DETERMINES THE DEPTH OF
!         THE LOWLEVEL DRAG.  

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

!     REFERENCE.
!     ----------
!         SEE MODEL DOCUMENTATION

!        SEE ECMWF RESEARCH DEPARTMENT DOCUMENTATION OF THE "I.F.S."

!     AUTHOR.
!     -------
!     M.MILLER + B.RITTER   E.C.M.W.F.     15/06/86.

!     MODIFICATIONS.
!     --------------
!     REVISED BY MARTIN MILLER   E.C.M.W.F.   22/03/89.
!     NEW VERSION MARTIN MILLER  E.C.M.W.F.   1993
!     CODED FOR IFS BY F.LOTT    E.C.M.W.F.   22/11/93
!     D.Salmond (15-10-01) FULLIMP mods
!        M.Hamrud      01-Oct-2003 CY28 Cleaning
!        A.Brown       17-Aug-2004 Introduction of cutoff moutain
!     P.Bechtold 14-Jan-2009 move IKTOP computation to setup routine
!-----------------------------------------------------------------------

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

USE YOMCST   , ONLY : RG       ,RCPD
USE YOEGWD   , ONLY : GKDRAG   ,GKWAKE  ,NGWDLIM,  GTENLIM,&
                     &NGWDTOP  ,GRFPLM
USE YOEPHLI  , ONLY : LPHYLIN  ,RLPDRAG

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 
REAL(KIND=JPRB)   ,INTENT(IN)    :: PTSPHY 
INTEGER(KIND=JPIM),INTENT(IN)    :: KSTEP 
INTEGER(KIND=JPIM),INTENT(IN)    :: KSTART 
REAL(KIND=JPRB)   ,INTENT(IN)    :: PAPHM1(KLON,0:KLEV) !note callpar indexing convention
REAL(KIND=JPRB)   ,INTENT(IN)    :: PAPM1(KLON,KLEV) 
REAL(KIND=JPRB)   ,INTENT(IN)    :: PGEOM1(KLON,KLEV) 
REAL(KIND=JPRB)   ,INTENT(IN)    :: PTM1(KLON,KLEV) 
REAL(KIND=JPRB)   ,INTENT(IN)    :: PUM1(KLON,KLEV) 
REAL(KIND=JPRB)   ,INTENT(IN)    :: PVM1(KLON,KLEV) 
REAL(KIND=JPRB)   ,INTENT(IN)    :: PHSTD(KLON) 
REAL(KIND=JPRB)   ,INTENT(INOUT) :: PGAMMA(KLON) 
REAL(KIND=JPRB)   ,INTENT(IN)    :: PTHETA(KLON) 
REAL(KIND=JPRB)   ,INTENT(IN)    :: PSIG(KLON) 
REAL(KIND=JPRB)   ,INTENT(OUT)   :: PUSTRGW(KLON) 
REAL(KIND=JPRB)   ,INTENT(OUT)   :: PVSTRGW(KLON) 
REAL(KIND=JPRB)   ,INTENT(OUT)   :: PVDISGW(KLON) 
REAL(KIND=JPRB)   ,INTENT(INOUT) :: PVOL(KLON,KLEV) 
REAL(KIND=JPRB)   ,INTENT(INOUT) :: PVOM(KLON,KLEV) 
REAL(KIND=JPRB)   ,INTENT(INOUT) :: PTE(KLON,KLEV) 
REAL(KIND=JPRB)   ,INTENT(OUT)   :: PSTRDU(KLON,KLEV+1) 
REAL(KIND=JPRB)   ,INTENT(OUT)   :: PSTRDV(KLON,KLEV+1) 

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

!*       0.1   ARGUMENTS
!              ---------

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

!              ------------
INTEGER(KIND=JPIM) ::  &
 & ICRIT(KLON),&
 & IKCRITH(KLON),&
 & IKENVH(KLON),&
 & IKNU(KLON),&
 & IKNU2(KLON)  

LOGICAL :: LLGWD(KLON)

REAL(KIND=JPRB) ::   ZTAU(KLON,KLEV+1),&
 & ZSTAB(KLON,KLEV+1),&
 & ZVPH(KLON,KLEV+1),&
 & ZRHO(KLON,KLEV+1),&
 & ZRI(KLON,KLEV+1),&
 & ZPSI(KLON,KLEV+1),&
 & ZZDEP(KLON,KLEV)  
REAL(KIND=JPRB) ::   ZDUDT(KLON),&
 & ZDVDT(KLON),&
 & ZDTDT(KLON),&
 & ZDEDT(KLON),&
 & ZVIDIS(KLON),&
 & ZULOW(KLON),&
 & ZVLOW(KLON),&
 & ZNU(KLON),&
 & ZD1(KLON),&
 & ZD2(KLON),&
 & ZDMOD(KLON)  

REAL(KIND=JPRB) :: ZUEA(KLON,KLEV),ZVEA(KLON,KLEV)

INTEGER(KIND=JPIM) :: ILEVP1, ILONS, JK, JL, IKTOP

REAL(KIND=JPRB) :: ZABSV, ZB, ZBET, ZBLOCK, ZC, ZCONB, ZCONS1,&
 & ZCS, ZDELP, ZDELP0, ZDIAGT, ZDIS, ZEFF, ZGDPH, ZKDRAG, &
 & ZRATIO, ZRTMST, ZSS, ZSTD, ZTEMP, ZTMST, &
 & ZUST, ZVST, ZZD1
REAL(KIND=JPRB) :: ZHOOK_HANDLE

#include "gwprofil.intfb.h"
#include "gwsetup.intfb.h"

!*************************************************************

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

!*         1.    INITIALIZATION
!                --------------

IF (LHOOK) CALL DR_HOOK('GWDRAGS',0,ZHOOK_HANDLE)
ILONS=KFDIA-KIDIA+1
!     ------------------------------------------------------------------

!*         1.1   COMPUTATIONAL CONSTANTS
!                -----------------------

ZTMST=PTSPHY
ZRTMST=1.0_JPRB/ZTMST
IF(KSTEP == KSTART) THEN
  ZDIAGT=ZTMST
ELSE
  ZDIAGT=0.5_JPRB*ZTMST
ENDIF
ZCONS1=1.0_JPRB/(RG*ZTMST)

!       SELECT POINTS FOR SCHEME TO OPERATE(SGS OROG >50METRES)  ****

DO JL=KIDIA,KFDIA
  IF (PHSTD(JL) > 50._JPRB) THEN
    LLGWD(JL)=.TRUE.
  ELSE
    LLGWD(JL)=.FALSE.
  ENDIF
ENDDO

!       Constant for surface stress

IF (LPHYLIN) THEN
  ZKDRAG=RLPDRAG
ELSE
  ZKDRAG=GKDRAG
ENDIF

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

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

!*         1.4   SAVING PROGNOSTIC VARIABLES
!                ---------------------------

DO JK=1,KLEV
  DO JL=KIDIA,KFDIA
    ZUEA(JL,JK)=PVOM(JL,JK)
    ZVEA(JL,JK)=PVOL(JL,JK)
  ENDDO
ENDDO

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

!*         2.     PRECOMPUTE BASIC STATE VARIABLES.
!*                ---------- ----- ----- ----------

CALL GWSETUP &
 & ( KIDIA , KFDIA , KLON  , KLEV , LLGWD,&
 & IKCRITH, ICRIT,&
 & IKENVH,IKNU,IKNU2,&
 & PAPHM1, PAPM1 , PUM1   , PVM1 , PTM1 , PGEOM1, PHSTD,&
 & ZRHO  , ZRI   , ZSTAB  , ZTAU , ZVPH , ZPSI , ZZDEP,&
 & ZULOW , ZVLOW,&
 & PTHETA , PGAMMA,ZNU  ,ZD1  , ZD2, ZDMOD )  

!***********************************************************

!*         3.      COMPUTE THE SURFACE GRAVITY WAVE STRESS
!                  ---------------------------------------

ZBLOCK=0.0_JPRB

DO JL=KIDIA,KFDIA
  IF(LLGWD(JL)) THEN
 
!    ZSTD=PHSTD(JL)
!    ZEFF=MAX(0.0_JPRB,2.0_JPRB*ZSTD-ZBLOCK)
!    ZTAU(JL,KLEV+1)=ZKDRAG*ZRHO(JL,KLEV+1)*PSIG(JL)*ZEFF**2 &
!     & /4._JPRB/ZSTD*ZVPH(JL,KLEV+1)*ZDMOD(JL)*SQRT(ZSTAB(JL,KLEV+1))  

 ZBLOCK=(PGEOM1(JL,IKENVH(JL))/RG)    
    ZSTD=PHSTD(JL)
    ZEFF=MAX(0.0_JPRB,3._JPRB*ZSTD-ZBLOCK)
    ZTAU(JL,KLEV+1)=ZKDRAG*ZRHO(JL,KLEV+1)*PSIG(JL)*ZEFF**2 &
     &/9._JPRB/ZSTD*ZVPH(JL,KLEV+1)*ZDMOD(JL)*SQRT(ZSTAB(JL,KLEV+1))

  ELSE
    ZTAU(JL,KLEV+1)=0.0_JPRB
  ENDIF

ENDDO

!*         4.      COMPUTE STRESS PROFILE.
!*                 ------- ------ --------

CALL GWPROFIL &
 & ( KIDIA ,  KFDIA , KLON , KLEV,&
 & LLGWD,&
 & IKCRITH, ICRIT , IKENVH, IKNU,&
 & IKNU2  , PAPHM1, ZRHO  , ZSTAB , ZVPH,&
 & ZRI    , ZTAU  , ZDMOD , PSIG  , PHSTD)  

!*         5.      COMPUTE TENDENCIES.
!*                 -------------------

DO JL=KIDIA,KFDIA
  ZVIDIS(JL)=0.0_JPRB
  ZDUDT(JL)=0.0_JPRB
  ZDVDT(JL)=0.0_JPRB
  ZDTDT(JL)=0.0_JPRB
ENDDO

ILEVP1=KLEV+1

!     COMPUTES AND ADDS THE LOWLEVEL DRAG TENDENCIES TO THE GWD ONES 
!     LOWLEVEL CALCULATION IN PARTLY IMPLICIT FORM

!ZRFPLM=990._JPRB

IKTOP=NGWDTOP

DO JK=1,KLEV

!OCL  VCT(CEX)
  DO JL=KIDIA,KFDIA
    IF(LLGWD(JL)) THEN
      ZDELP =PAPHM1(JL,JK)-PAPHM1(JL,JK-1)
! adjust in pressure < 10hPa
      IF( PAPM1(JL,JK) < GRFPLM) THEN
        ZDELP0=PAPHM1(JL,IKTOP)-PAPHM1(JL,0)
        ZTEMP=-RG*(ZTAU(JL,IKTOP+1)-ZTAU(JL,1))*ZDELP/ &
         &        (ZVPH(JL,ILEVP1)*ZDELP0**2)
      ELSE
        ZTEMP =-RG*(ZTAU(JL,JK+1)-ZTAU(JL,JK))/(ZDELP*ZVPH(JL,ILEVP1))
      ENDIF
      ZDUDT(JL)=(ZULOW(JL)*ZD1(JL)-ZVLOW(JL)*ZD2(JL))*ZTEMP/ZDMOD(JL)
      ZDVDT(JL)=(ZVLOW(JL)*ZD1(JL)+ZULOW(JL)*ZD2(JL))*ZTEMP/ZDMOD(JL)

!LIMIT THE WIND TENDENCIES IN THE STRATOSPHERE
      IF(JK < NGWDLIM) THEN
        ZDUDT(JL)=SIGN(MIN(ABS(ZDUDT(JL)),GTENLIM),ZDUDT(JL))
        ZDVDT(JL)=SIGN(MIN(ABS(ZDVDT(JL)),GTENLIM),ZDVDT(JL))
      ENDIF

      IF(JK >= IKENVH(JL)) THEN
        ZB    =1.0_JPRB-0.18_JPRB*PGAMMA(JL)-0.04_JPRB*PGAMMA(JL)**2
        ZC    =0.48_JPRB*PGAMMA(JL)+0.3_JPRB*PGAMMA(JL)**2
        ZCS   =COS(ZPSI(JL,JK))**2
        ZSS   =1.0_JPRB-ZCS
        ZCONB =ZTMST*GKWAKE*PSIG(JL)/(2.0_JPRB*PHSTD(JL))
        ZABSV =0.5_JPRB*SQRT(PUM1(JL,JK)**2+PVM1(JL,JK)**2)
        ZZD1  =ZB*ZCS+ZC*ZSS
        ZRATIO=(ZCS+PGAMMA(JL)*ZSS)/(PGAMMA(JL)*ZCS+ZSS)
        ZBET  =MAX(0.0_JPRB,2.0_JPRB-1.0_JPRB/ZRATIO)*ZCONB*ZZDEP(JL,JK)*ZZD1*ZABSV
        ZDUDT(JL)=-PUM1(JL,JK)/ZTMST-PVOM(JL,JK)
        ZDVDT(JL)=-PVM1(JL,JK)/ZTMST-PVOL(JL,JK)
        ZDUDT(JL)=ZDUDT(JL)*(ZBET/(1.0_JPRB+ZBET))
        ZDVDT(JL)=ZDVDT(JL)*(ZBET/(1.0_JPRB+ZBET))
      ENDIF

      PVOM(JL,JK)=PVOM(JL,JK)+ZDUDT(JL)
      PVOL(JL,JK)=PVOL(JL,JK)+ZDVDT(JL)
      ZUST=PUM1(JL,JK)+ZTMST*ZDUDT(JL)
      ZVST=PVM1(JL,JK)+ZTMST*ZDVDT(JL)
      ZDIS=0.5_JPRB*(PUM1(JL,JK)**2+PVM1(JL,JK)**2-ZUST**2-ZVST**2)
      ZDEDT(JL) =ZDIS/ZTMST
      ZVIDIS(JL)=ZVIDIS(JL)+ZDIS*ZDELP
      ZDTDT(JL) =ZDEDT(JL)/RCPD
      PTE(JL,JK)=PTE(JL,JK)+ZDTDT(JL)
    ENDIF
  ENDDO

ENDDO
!**
!**     5.3     UPDATE STRESS COMPONENTS AND DISSIPATION
!**
DO JL=KIDIA,KFDIA
  PUSTRGW(JL)=0.0_JPRB
  PVSTRGW(JL)=0.0_JPRB
  PVDISGW(JL)=0.0_JPRB
ENDDO

DO JL=KIDIA,KFDIA
  IF(LLGWD(JL)) THEN
    PVDISGW(JL)=ZCONS1*ZVIDIS(JL)
  ENDIF
ENDDO

!*******************************************************************

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

!*         5.5    FLUX COMPUTATIONS
!                 --------- -------

DO JL=KIDIA,KFDIA
  PSTRDU(JL,1)=0.0_JPRB
  PSTRDV(JL,1)=0.0_JPRB
ENDDO

DO JK=1,KLEV
  DO JL=KIDIA,KFDIA
    ZGDPH=-RG  /(PAPHM1(JL,JK)-PAPHM1(JL,JK-1))
    PSTRDU(JL,JK+1)=(PVOM(JL,JK)-ZUEA(JL,JK))/ZGDPH + PSTRDU(JL,JK)
    PSTRDV(JL,JK+1)=(PVOL(JL,JK)-ZVEA(JL,JK))/ZGDPH + PSTRDV(JL,JK)
  ENDDO
ENDDO

DO JL=KIDIA,KFDIA
  PUSTRGW(JL)=PSTRDU(JL,KLEV+1)
  PVSTRGW(JL)=PSTRDV(JL,KLEV+1)
ENDDO

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

!     Possible problem: dT/dt does not appear anymore in the GWD code,
!       but is accounted for in new CPTEND, CPUTQY

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