source: trunk/LMDZ.MARS/libf/phymars/orodrag_mod.F @ 2156

      MODULE orodrag_mod
      
      IMPLICIT NONE
      
      CONTAINS
      
      SUBROUTINE ORODRAG( klon,klev 
     I                 , KGWD, KGWDIM, KDX, KTEST
     R                 , PTSPHY
     R                 , PAPHM1,PAPM1,PGEOM1,PTM1,PUM1
     R                 , PVM1, PVAROR, PSIG, PGAMMA, PTHETA
C OUTPUTS
     R                 , PULOW,PVLOW
     R                 , PVOM,PVOL,PTE )
C
C
C**** *ORODRAG* - DOES THE GRAVITY WAVE PARAMETRIZATION.
C
C     PURPOSE.
C     --------
C
C          THIS ROUTINE COMPUTES THE PHYSICAL TENDENCIES OF THE
C          PROGNOSTIC VARIABLES U,V  AND T DUE TO  VERTICAL TRANSPORTS BY
C          SUBGRIDSCALE OROGRAPHICALLY EXCITED GRAVITY WAVES
C
C     EXPLICIT ARGUMENTS :
C     --------------------
C
C     INPUT :
C
C     NLON               : NUMBER OF HORIZONTAL GRID POINTS
C     NLEV               : NUMBER OF LEVELS
C     KGWD               : NUMBER OF POINTS AT WHICH THE SCHEME IS CALLED
C     KGWDIM             : NUMBER OF POINTS AT WHICH THE SCHEME IS CALLED
C     KDX(NLON)          : POINTS AT WHICH TO CALL THE SCHEME
C     KTEST(NLON)        : MAP OF CALLING POINTS
C     PTSPHY             : LENGTH OF TIME STEP
C     PAPHM1(NLON,NLEV+1): PRESSURE AT MIDDLE LEVELS
C     PAPM1(NLON,NLEV)   : PRESSURE ON MODEL LEVELS
C     PGEOM1(NLON,NLEV)  : GEOPOTENTIAL HIEGHT OF MODEL LEVELS
C     PTM1(NLON,NLEV)    : TEMPERATURE
C     PUM1(NLON,NLEV)    : ZONAL WIND
C     PVM1(NLON,NLEV)    : MERIDIONAL WIND
C     PVAROR(NLON)       : SUB-GRID SCALE STANDARD DEVIATION
C     PSIG(NLON)         : SUB-GRID SCALE SLOPE
C     PGAMMA(NLON)       : SUB-GRID SCALE ANISOTROPY
C     PTHETA(NLON)       : SUB-GRID SCALE PRINCIPAL AXES ANGLE
C
C     OUTPUT :
C
C     PULOW(NLON)        : LOW LEVEL ZONAL WIND
C     PVLOW(NLON)        : LOW LEVEL MERIDIONAL WIND
C     PVOM(NLON,NLEV)    : ZONAL WIND TENDENCY
C     PVOL(NLON,NLEV)    : MERIDIONAL WIND TENDENCY
C     PTE(NLON,NLEV)     : TEMPERATURE TENDENCY
C
C     IMPLICIT ARGUMENTS :
C     --------------------
C
C     comcstfi.h
C     yoegwd.h
C
C     METHOD.
C     -------
C
C     EXTERNALS.
C     ----------
C
C     REFERENCE.
C     ----------
C
C     AUTHOR.
C     -------
C     M.MILLER + B.RITTER   E.C.M.W.F.     15/06/86.
C
C     F.LOTT + M. MILLER    E.C.M.W.F.     22/11/94
C-----------------------------------------------------------------------
      use dimradmars_mod, only: ndlo2
      USE gwstress_mod, ONLY: gwstress
      USE gwprofil_mod, ONLY: gwprofil
      USE comcstfi_h, ONLY: g, cpp
      implicit none
C
C
      integer klon,klev,kidia
      parameter(kidia=1)
      integer, save :: kfdia ! =NDLO2

      include "yoegwd.h"
C-----------------------------------------------------------------------
C
C*       0.1   ARGUMENTS
C              ---------
C
C
      REAL  PTE(NDLO2,klev),
     *      PVOL(NDLO2,klev),
     *      PVOM(NDLO2,klev),
     *      PULOW(NDLO2),
     *      PVLOW(NDLO2)
      REAL  PUM1(NDLO2,klev),
     *      PVM1(NDLO2,klev),
     *      PTM1(NDLO2,klev),
     *      PVAROR(NDLO2),PSIG(NDLO2),PGAMMA(NDLO2),PTHETA(NDLO2),
     *      PGEOM1(NDLO2,klev),
     *      PAPM1(NDLO2,klev),
     *      PAPHM1(NDLO2,klev+1)
C
      integer kgwd,kgwdim
      real ptsphy
      INTEGER  KDX(NDLO2),KTEST(NDLO2)
C-----------------------------------------------------------------------
C
C*       0.2   LOCAL ARRAYS
C              ------------
      INTEGER  ISECT(NDLO2),
     *         ICRIT(NDLO2),
     *         IKCRITH(NDLO2),
     *         IKenvh(NDLO2),
     *         IKNU(NDLO2),
     *         IKNU2(NDLO2),
     *         IKCRIT(NDLO2),
     *         IKHLIM(NDLO2)
      integer ji,jk,jl,klevm1,ilevp1
C      real gkwake
      real ztmst,pvar(NDLO2,4),ztauf(NDLO2,klev+1)
      real zrtmst,zdelp,zb,zc,zbet
      real zconb,zabsv,zzd1,ratio,zust,zvst,zdis,ztemp
C
      REAL   ZTAU(NDLO2,klev+1),
     *       ZSTAB(NDLO2,klev+1),
     *       ZVPH(NDLO2,klev+1),
     *       ZRHO(NDLO2,klev+1),
     *       ZRI(NDLO2,klev+1),
     *       ZpsI(NDLO2,klev+1),
     *       Zzdep(NDLO2,klev)
      REAL   ZDUDT(NDLO2),
     *       ZDVDT(NDLO2),
     *       ZDTDT(NDLO2),
     *       ZDEDT(NDLO2),
     *       ZVIDIS(NDLO2),
     *       ZTFR(NDLO2),
     *       Znu(NDLO2),
     *       Zd1(NDLO2),
     *       Zd2(NDLO2),
     *       Zdmod(NDLO2)
C
C------------------------------------------------------------------
C
C*         1.    INITIALIZATION
C                --------------
C
 100  CONTINUE
C
C     ------------------------------------------------------------------
C
C*         1.1   COMPUTATIONAL CONSTANTS
C                -----------------------
C
 110  CONTINUE
C
      kfdia=NDLO2
      
c     ZTMST=TWODT
c     IF(NSTEP.EQ.NSTART) ZTMST=0.5*TWODT
      KLEVM1=KLEV-1
      ZTMST=PTSPHY
      ZRTMST=1./ZTMST
C     ------------------------------------------------------------------
C
 120  CONTINUE
C
C     ------------------------------------------------------------------
C
C*         1.3   CHECK WHETHER ROW CONTAINS POINT FOR PRINTING
C                ---------------------------------------------
C
 130  CONTINUE
C
C     ------------------------------------------------------------------
C
C*         2.     PRECOMPUTE BASIC STATE VARIABLES.
C*                ---------- ----- ----- ----------
C*                DEFINE LOW LEVEL WIND, PROJECT WINDS IN PLANE OF
C*                LOW LEVEL WIND, DETERMINE SECTOR IN WHICH TO TAKE
C*                THE VARIANCE AND SET INDICATOR FOR CRITICAL LEVELS.
C
  200 CONTINUE
C
C
C
      CALL OROSETUP
     *     ( klon, klev , KTEST 
     *     , IKCRIT, IKCRITH, ICRIT, ISECT, IKHLIM, ikenvh,IKNU,iknu2
     *     , PAPHM1, PAPM1 , PUM1   , PVM1 , PTM1 , PGEOM1, pvaror
     *     , ZRHO  , ZRI   , ZSTAB  , ZTAU , ZVPH , zpsi, zzdep
     *     , PULOW, PVLOW 
     *     , ptheta,pgamma,znu  ,zd1,  zd2,  zdmod                )
C
C
C
C***********************************************************
C
C
C*         3.      COMPUTE LOW LEVEL STRESSES USING SUBCRITICAL AND
C*                 SUPERCRITICAL FORMS.COMPUTES ANISOTROPY COEFFICIENT
C*                 AS MEASURE OF OROGRAPHIC TWODIMENSIONALITY.
C
  300 CONTINUE
C
      CALL GWSTRESS
     *    ( klon  , klev
     *    , IKCRIT, ISECT, IKHLIM, KTEST, IKCRITH, ICRIT, ikenvh, IKNU
     *    , ZRHO  , ZSTAB, ZVPH  , PVAR , pvaror,  psig
     *    , ZTFR   , ZTAU 
     *    , pgeom1,pgamma,zd1,zd2,zdmod,znu)
C
C*         4.      COMPUTE STRESS PROFILE.
C*                 ------- ------ --------
C
  400 CONTINUE
C
C
      CALL GWPROFIL
     *       (  klon , klev
     *       , kgwd   , kdx  , KTEST
     *       , IKCRIT, IKCRITH, ICRIT  , ikenvh, IKNU
     *       ,iknu2 , pAPHM1, ZRHO   , ZSTAB , ZTFR   , ZVPH
     *       , ZRI   , ZTAU   , ztauf
     *       , zdmod , znu    , psig  , pgamma , pvaror   )
C
C
C*         5.      COMPUTE TENDENCIES.
C*                 -------------------
C
  500 CONTINUE
C
C  EXPLICIT SOLUTION AT ALL LEVELS FOR THE GRAVITY WAVE
C  IMPLICIT SOLUTION FOR THE BLOCKED LEVELS

      DO 510 JL=KIDIA,KFDIA
      ZVIDIS(JL)=0.0
      ZDUDT(JL)=0.0
      ZDVDT(JL)=0.0
      ZDTDT(JL)=0.0
  510 CONTINUE
C
      ILEVP1=KLEV+1
C
C
      DO 524 JK=1,klev
C
CDIR$ IVDEP
C
C      GKWAKE=0.5
C
C     NOW SET IN SUGWD.F
C
      DO 523 JL=1,KGWD
      JI=KDX(JL)
      ZDELP=pAPHM1(Ji,JK+1)-pAPHM1(Ji,JK)
      ZTEMP=-g*(ZTAU(Ji,JK+1)-ZTAU(Ji,JK))/(ZVPH(Ji,ILEVP1)*ZDELP)
      ZDUDT(JI)=(PULOW(JI)*Zd1(ji)-pvlow(ji)*zd2(ji))*ztemp/zdmod(ji)
      ZDVDT(JI)=(pvLOW(JI)*Zd1(ji)+pulow(ji)*zd2(ji))*ztemp/zdmod(ji)
      if(jk.ge.ikenvh(ji)) then
         zb=1.0-0.18*pgamma(ji)-0.04*pgamma(ji)**2
         zc=0.48*pgamma(ji)+0.3*pgamma(ji)**2
         zconb=2.*ztmst*GKWAKE*psig(ji)/(4.*pvaror(ji))
         zabsv=sqrt(PUM1(JI,JK)**2+PVM1(JI,JK)**2)/2.
         zzd1=zb*cos(zpsi(ji,jk))**2+zc*sin(zpsi(ji,jk))**2
         ratio=(cos(zpsi(ji,jk))**2+pgamma(ji)*sin(zpsi(ji,jk))**2)/
     *   (pgamma(ji)*cos(zpsi(ji,jk))**2+sin(zpsi(ji,jk))**2)
         zbet=max(0.,2.-1./ratio)*zconb*zzdep(ji,jk)*zzd1*zabsv
         zdudt(ji)=-pum1(ji,jk)/ztmst
         zdvdt(ji)=-pvm1(ji,jk)/ztmst
         zdudt(ji)=zdudt(ji)*(zbet/(1.+zbet))
         zdvdt(ji)=zdvdt(ji)*(zbet/(1.+zbet))
      end if
      PVOM(JI,JK)=ZDUDT(JI)
      PVOL(JI,JK)=ZDVDT(JI)
      ZUST=PUM1(JI,JK)+ZTMST*ZDUDT(JI)
      ZVST=PVM1(JI,JK)+ZTMST*ZDVDT(JI)
      ZDIS=0.5*(PUM1(JI,JK)**2+PVM1(JI,JK)**2-ZUST**2-ZVST**2)
      ZDEDT(JI)=ZDIS/ZTMST
      ZVIDIS(JI)=ZVIDIS(JI)+ZDIS*ZDELP
      ZDTDT(JI)=ZDEDT(JI)/cpp
      PTE(JI,JK)=ZDTDT(JI)

  523 CONTINUE

  524 CONTINUE
C
C

      END SUBROUTINE ORODRAG
      
      END MODULE orodrag_mod