*=*=*=*= gwd.html =*=*=*=*
subroutine gwd

subroutine gwd


      subroutine gwd(ngrid,nlayer,ptimestep,
     $               pplay,pplev,pu,pv,pt,
     $               zdudt,zdvdt,zdtdt)
c
c     Gravity wave drag scheme
c     started 20/3/95.
c     Orographic drag only and no low level drag (see UGAMP scheme)
c
#include "dimensions.h"
#include "dimphys.h"
#include "comgwd.h"
#include "comcstfi.h"
c
c     arguments
c
      integer ngrid,nlayer
      real ptimestep
      real pplay(ngrid,nlayer)    ! Pressure at the middle of the layers (Pa)
      real pplev(ngrid,nlayer+1)  ! intermediate pressure levels (Pa)
      real pu(ngrid,nlayer)       ! u component of the wind (ms-1)
      real pv(ngrid,nlayer)       ! v component of the wind (ms-1)
      real pt(ngrid,nlayer)       ! Temperature (K)
      real zdudt(ngrid,nlayer)    ! U wind tendency
      real zdvdt(ngrid,nlayer)    ! V wind tendency
      real zdtdt(ngrid,nlayer)    ! T tendency
c
c     local variables
c
      real cpplay(ngridmx,nlayermx)   !
      real cpplev(ngridmx,nlayermx+1) !
      real cpu(ngridmx,nlayermx)      ! Copies of above
      real cpv(ngridmx,nlayermx)      !
      real cpt(ngridmx,nlayermx)      !
      real zdp(ngridmx,nlayermx)      ! Half level Delta P
      real zrho(ngridmx,nlayermx+1)   ! Density
      real zstab(ngridmx,nlayermx+1)  ! Static Stability
      real zri(ngridmx,nlayermx)      ! Richardson Number
      real zri_min(ngridmx,nlayermx)  ! Min Richardson No.
      real zdedt(ngridmx,nlayermx)    ! Energy tendency
      real czdudt(ngridmx,nlayermx)   ! Copy of U wind tendency
      real czdvdt(ngridmx,nlayermx)   ! Copy of V wind tendency
      real czdtdt(ngridmx,nlayermx)   ! Copy of T tendency
      real zulow(ngridmx)
      real zvlow(ngridmx)
      real znorm(ngridmx)
      real zvph(ngridmx,nlayermx+1)
      real zvpf(ngridmx,nlayermx)
      real zkx(ngridmx)
      real zky(ngridmx)
      real ztau(ngridmx,nlayermx+1)   ! Stress
      real zdz2(ngridmx)
      integer isect(ngridmx)        ! Sector number for orog. variance
      integer icrit(ngridmx)
      integer ildtop(ngridmx)
      logical lo,lo1
c
c     2.05 UGAMP scheme has vertical levels the other way round. Make
c     copies of variables and swap them over
c
      do ig=1,ngrid
        do l=1,nlayer
          cpplay(ig,l)=pplay(ig,l)
          cpt(ig,l)=pt(ig,l)
          cpu(ig,l)=pu(ig,l)
          cpv(ig,l)=pv(ig,l)
        enddo
        do l=1,nlayer+1
          cpplev(ig,l)=pplev(ig,l)
        enddo
        do l=1,nlayer
          pplay(ig,l)=cpplay(ig,nlayer+1-l)
          pt(ig,l)=cpt(ig,nlayer+1-l)
          pu(ig,l)=cpu(ig,nlayer+1-l)
          pv(ig,l)=cpv(ig,nlayer+1-l)
        enddo
        do l=1,nlayer+1
          pplev(ig,l)=cpplev(ig,nlayer+2-l)
        enddo
      enddo
c
c     2.1 Half Level Delta P
c
      do ig=1,ngrid
        do l=2,nlayer
          zdp(ig,l)=pplay(ig,l)-pplay(ig,l-1)
        enddo
      enddo
c
c     2.2 Static Stability and Density
c
      do ig=1,ngrid
        zrho(ig,nlayer+1)=pplay(ig,nlayer-1)*zcons1/pt(ig,nlayer-1)
        zstab(ig,nlayer+1)=(zcons2/pt(ig,nlayer-1))
     :            *(1.0-cpp*zrho(ig,nlayer+1)
     :            *(pt(ig,nlayer-1)-pt(ig,nlayer-2))
     :              /(zdp(ig,nlayer-2)))
        zstab(ig,nlayer+1)=max(zstab(ig,nlayer+1),zssec)
        do l=nlayer,2,-1
          zrho(ig,l)=2.0*pplev(ig,l)*zcons1/(pt(ig,l)+pt(ig,l-1))
          zstab(ig,l)=2.0*zcons2/(pt(ig,l)+pt(ig,l-1))*
     :              (1.0-cpp*zrho(ig,l)*(pt(ig,l)-pt(ig,l-1))
     :              /zdp(ig,l))
          zstab(ig,l)=max(zstab(ig,l),zssec)
        enddo
      enddo
c
c     2.3 Mean Flow Richardson Number
c
      do ig=1,ngrid
        do l=2,nlayer
          zdu=pu(ig,l)-pu(ig,l-1)
          zdv=pv(ig,l)-pv(ig,l-1)
          zdwind=max(sqrt(zdu**2+zdv**2),zvsec)
          zri(ig,l)=zstab(ig,l)*(zdp(ig,l)
     :            /(g*zrho(ig,l)*zdwind))**2
          zri(ig,l)=max(zri(ig,l),zrcrit)
        enddo
      enddo
c
c     2.4 Initialise U and V tendencies and surface stress
c
      do ig=1,ngrid
        do l=1,nlayer
          zdudt(ig,l)=0.0
          zdvdt(ig,l)=0.0
          zdedt(ig,l)=0.0
          zdtdt(ig,l)=0.0
        enddo
c        ustrgw(ig)=0.0
c        vstrgw(ig)=0.0
      enddo
c
c     3.0 Wave sources
c
c
c     3.05 Define level of wave source
c
      do ig=1,ngrid
        ildtop(ig)=nlayer+1
c
c     3.1 Wave source (UGAMP scheme averages wind in 3 lowest levels)
c
        zulow(ig)=(pu(ig,nlayer)*(pplev(ig,nlayer+1)-pplev(ig,nlayer))+
     :         pu(ig,nlayer-1)*(pplev(ig,nlayer)-pplev(ig,nlayer-1))+
     :         pu(ig,nlayer-2)*(pplev(ig,nlayer-1)-pplev(ig,nlayer-2)))
     :             /(pplev(ig,nlayer+1)-pplev(ig,nlayer-2))
        zvlow(ig)=(pv(ig,nlayer)*(pplev(ig,nlayer+1)-pplev(ig,nlayer))+
     :         pv(ig,nlayer-1)*(pplev(ig,nlayer)-pplev(ig,nlayer-1))+
     :         pv(ig,nlayer-2)*(pplev(ig,nlayer-1)-pplev(ig,nlayer-2)))
     :             /(pplev(ig,nlayer+1)-pplev(ig,nlayer-2))
        znorm(ig)=max(sqrt(zulow(ig)**2+zvlow(ig)**2),zvsec)
        zvph(ig,nlayer+1)=znorm(ig)
        zkx(ig)=zulow(ig)/znorm(ig)
        zky(ig)=zvlow(ig)/znorm(ig)

        ilsrc=nlayer+1
        zc=0.0
c
c       Determine sector in which to take variance
c
        lo=(zulow(ig).lt.zvsec).and.(zulow(ig).ge.-zvsec)
        if (lo) then
          zu=zulow(ig)+2.0*zvsec
        else
          zu=zulow(ig)
        endif
        ztheta=atan(zvlow(ig)/zu)
        isect(ig)=mod(int((ztheta/pi+0.625)*4.0),4)+1
      enddo
c
c     3.2 Project wind in direction of wave and find critical level
c
      do ig=1,ngrid
        icrit(ig)=1
        do l=1,nlayer
          zvpf(ig,l)=zkx(ig)*pu(ig,l)+zky(ig)*pv(ig,l)-zc
        enddo
        do l=2,nlayer
          zvph(ig,l)=((pplev(ig,l)-pplay(ig,l-1))*zvpf(ig,l)+
     :              (pplay(ig,l)-pplev(ig,l))*zvpf(ig,l-1))
     :              /zdp(ig,l)
        enddo
        do l=2,ilsrc-1
          lo=(zvph(ig,l)*sign(1.0,zvph(ig,l+1)).lt.zvsec)
          if (lo) then
            zvph(ig,l)=sign(zvsec,zvph(ig,ilsrc))
            icrit(ig)=l
          endif
        enddo
      enddo
c
c     3.3 Stress at source level.
c
      do ig=1,ngrid
        l1=jkcrit-1
        zr=2.0+1.0/sqrt(zri(ig,l1))
        zdz2n=(zvph(ig,l1)*(2.0*sqrt(zr)-zr))**2
     :       /zstab(ig,l1)
        zvar=orog_var(ig,isect(ig))
        zvar=min(zvar,zdz2n)
        ztau(ig,nlayer+1)=zrho(ig,nlayer+1)*zkdrag
     :           *sqrt(zstab(ig,nlayer+1))*zvar*zvph(ig,nlayer+1)
        lo=(ztau(ig,nlayer+1).lt.ztsec)
     :     .or.(icrit(ig).ge.jkcrit)
     :     .or.(zvph(ig,nlayer+1).lt.zvcrit)
        if (lo) then
          icrit(ig)=nlayer+1
          ztau(ig,nlayer+1)=0.0
        endif
      enddo
c
c     4.0 Compute Stress Profile
c
      do ig=1,ngrid
        do l=ilsrc-1,2,-1
          znorm(ig)=zrho(ig,l)*zkdrag*sqrt(zstab(ig,l))
     :            *zvph(ig,l)
          zdz2(ig)=ztau(ig,l+1)/znorm(ig)
c
c     4.2 Wave Richardson number, new wave displacement ans stress
c
          lo1=(l.lt.jkcrit)
          if (l.lt.ildtop(ig)) then
            zsqr=sqrt(zri(ig,l))
            zalfa=sqrt(zstab(ig,l)*zdz2(ig))/abs(zvph(ig,l))
            zriw=zri(ig,l)*(1.0-zalfa)/((1.0+zalfa*zsqr)**2)
            zri_min(ig,nlayer+1-l)=zriw
c
c           zrcrit=0.25 is imlicit in this formula
c
            zr=2.0+1.0/zsqr
            zdz2n=(zvph(ig,l)*(2.0*sqrt(zr)-zr))**2/zstab(ig,l)
c
c           Check for saturation
c
            lo=(zriw.lt.zrcrit).and.lo1
            if (lo) then
              ztau(ig,l)=znorm(ig)*zdz2n
            else
              ztau(ig,l)=znorm(ig)*zdz2(ig)
            endif
c
c           Check for critical level
c
            lo=(abs(ztau(ig,l+1)).lt.ztsec).or.(l.le.icrit(ig))
            if (lo) then
              ztau(ig,l)=0.0
            endif
          endif
        enddo
      enddo
c
c     top layer stress = 0.0
c
      do ig=1,ngrid
        ztau(ig,1)=0.0
        zstab(ig,1)=0.0
        zri(ig,1)=0.0
        zvph(ig,1)=0.0
      enddo
c
c     5.0 Tendencies
c
c     5.1 U and V
c
      do ig=1,ngrid
        do l=1,nlayer
          zzdudt=-g*zkx(ig)*(ztau(ig,l+1)-ztau(ig,l))
     :          /(pplev(ig,l+1)-pplev(ig,l))
          zdudt(ig,l)=zdudt(ig,l)+zzdudt
          zzdvdt=-g*zky(ig)*(ztau(ig,l+1)-ztau(ig,l))
     :          /(pplev(ig,l+1)-pplev(ig,l))
          zdvdt(ig,l)=zdvdt(ig,l)+zzdvdt
          zdedt(ig,l)=zdedt(ig,l)
     :               +zzdudt*(zc*zkx(ig)-pu(ig,l))
     :               +zzdvdt*(zc*zky(ig)-pv(ig,l))
          zdtdt(ig,l)=zdedt(ig,l)/cpp
        enddo
      enddo
c
c     5.2 update surface stress
c
c      do ig=1,ngrid
c        ustrgw(ig)=ustrgw(ig)+zdiagt*ztau(ig,nlayer+1)*zkx(ig)
c        vstrgw(ig)=vstrgw(ig)+zdiagt*ztau(ig,nlayer+1)*zky(ig)
c      enddo
c
c     swap round arrays again
c
      do ig=1,ngrid
        do l=1,nlayer
          cpplay(ig,l)=pplay(ig,l)
          cpt(ig,l)=pt(ig,l)
          cpu(ig,l)=pu(ig,l)
          cpv(ig,l)=pv(ig,l)
          czdudt(ig,l)=zdudt(ig,l)
          czdvdt(ig,l)=zdvdt(ig,l)
          czdtdt(ig,l)=zdtdt(ig,l)
        enddo
        do l=1,nlayer+1
          cpplev(ig,l)=pplev(ig,l)
        enddo
        do l=1,nlayer
          pplay(ig,l)=cpplay(ig,nlayer+1-l)
          pt(ig,l)=cpt(ig,nlayer+1-l)
          pu(ig,l)=cpu(ig,nlayer+1-l)
          pv(ig,l)=cpv(ig,nlayer+1-l)
c
c         Don't Dimensionalis Tendencies
c
          zdudt(ig,l)=czdudt(ig,nlayer+1-l)
          zdvdt(ig,l)=czdvdt(ig,nlayer+1-l)
          zdtdt(ig,l)=czdtdt(ig,nlayer+1-l)
        enddo
        do l=1,nlayer+1
          pplev(ig,l)=cpplev(ig,nlayer+2-l)
        enddo
      enddo
cc
cc     triangular filter in the vertical
cc
c      do ig=1,ngrid
c        do l=3,nlayer-2
c          zdudt(ig,l)=(1.0*zdudt(ig,l-2)+2.0*zdudt(ig,l-1)+
c     :                 3.0*zdudt(ig,l  )+2.0*zdudt(ig,l+1)+
c     :                 1.0*zdudt(ig,l+2))/9.0
c          zdvdt(ig,l)=(1.0*zdvdt(ig,l-2)+2.0*zdvdt(ig,l-1)+
c     :                 3.0*zdvdt(ig,l  )+2.0*zdvdt(ig,l+1)+
c     :                 1.0*zdvdt(ig,l+2))/9.0
c          zdtdt(ig,l)=(1.0*zdtdt(ig,l-2)+2.0*zdtdt(ig,l-1)+
c     :                 3.0*zdtdt(ig,l  )+2.0*zdtdt(ig,l+1)+
c     :                 1.0*zdtdt(ig,l+2))/9.0
c         enddo
c      enddo
c
c     End of scheme
c
      return
      end