*=*=*=*= gwd.html =*=*=*=*
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