!-------------------------------------- LICENCE BEGIN ------------------------------------
!Environment Canada - Atmospheric Science and Technology License/Disclaimer,
! version 3; Last Modified: May 7, 2008.
!This is free but copyrighted software; you can use/redistribute/modify it under the terms
!of the Environment Canada - Atmospheric Science and Technology License/Disclaimer
!version 3 or (at your option) any later version that should be found at:
!http://collaboration.cmc.ec.gc.ca/science/rpn.comm/license.html
!
!This software is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY;
!without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
!See the above mentioned License/Disclaimer for more details.
!You should have received a copy of the License/Disclaimer along with this software;
!if not, you can write to: EC-RPN COMM Group, 2121 TransCanada, suite 500, Dorval (Quebec),
!CANADA, H9P 1J3; or send e-mail to service.rpn@ec.gc.ca
!-------------------------------------- LICENCE END --------------------------------------
***S/P LIN_SGOFLX1_AD
*
subroutine lin_sgoflx1_ad(uu,vv,utend,vtend, 1,34
+ tth,ttf,ss,ssh,
+ uu5,vv5,tth5,ttf5,
+ ilev,lref,ilg,il1,il2,
+ grav,rgas,rgocp,tau,taufac,
+ gc,height,slope,xcent,mtdir,
+ psurf,fcor,
+ gwdrag,blocking,orolift,leewave,
+ aa1,aa2,applytend)
*
#include "phy_macros_f.h"
#include "impnone.cdk"
*
*
logical gwdrag,blocking,orolift,leewave,applytend
*
integer ilev,lref,ilg,il1,il2
real grav,rgas,rgocp,tau,taufac
real*8 aa1,aa2
real*8 uu(ilg,ilev), vv(ilg,ilev), utend(ilg,ilev),
+ vtend(ilg,ilev), tth(ilg,ilev), ttf(ilg,ilev),
+ uu5(ilg,ilev), vv5(ilg,ilev),
+ tth5(ilg,ilev), ttf5(ilg,ilev),
+ ss(ilg,ilev), ssh(ilg,ilev), gc(ilg),
+ height(ilg), slope(ilg), xcent(ilg),
+ mtdir(ilg), psurf(ilg), fcor(ilg)
*
*Author
* A. Zadra - May 2002
*
*Object
* Simplified version of subgrid orographic drag (sgoflx2) scheme:
* - reduced, non-smoothed buoyancy frequency
* - shortened gravity-wave drag (McFarlane 87)
* - shortened low-level blocking (Lott & Miller 97)
* - orographic lift (not yet included)
* - lee-wave breaking (not yet included)
*
*
*Arguments
*
*
**
AUTOMATIC ( VMOD5 , REAL*8 , (ILG ) )
AUTOMATIC ( UUB5 , REAL*8 , (ILG ) )
AUTOMATIC ( VVB5 , REAL*8 , (ILG ) )
AUTOMATIC ( UB5 , REAL*8 , (ILG ) )
AUTOMATIC ( VB5 , REAL*8 , (ILG ) )
AUTOMATIC ( VMODB5 , REAL*8 , (ILG ) )
AUTOMATIC ( UAV5 , REAL*8 , (ILG ) )
AUTOMATIC ( VAV5 , REAL*8 , (ILG ) )
AUTOMATIC ( VELAV5 , REAL*8 , (ILG ) )
AUTOMATIC ( DELZ5 , REAL*8 , (ILG ) )
AUTOMATIC ( HBLK5 , REAL*8 , (ILG ) )
AUTOMATIC ( FDIR5 , REAL*8 , (ILG ) )
AUTOMATIC ( PSI5 , REAL*8 , (ILG ) )
AUTOMATIC ( CPSI5 , REAL*8 , (ILG ) )
AUTOMATIC ( SPSI5 , REAL*8 , (ILG ) )
AUTOMATIC ( AMPD5 , REAL*8 , (ILG ) )
c
AUTOMATIC ( VMOD , REAL*8 , (ILG ) )
AUTOMATIC ( UUB , REAL*8 , (ILG ) )
AUTOMATIC ( VVB , REAL*8 , (ILG ) )
AUTOMATIC ( DRAG , INTEGER , (ILG ) )
AUTOMATIC ( UB , REAL*8 , (ILG ) )
AUTOMATIC ( VB , REAL*8 , (ILG ) )
AUTOMATIC ( VMODB , REAL*8 , (ILG ) )
AUTOMATIC ( ENV , REAL*8 , (ILG ) )
AUTOMATIC ( SLP2 , REAL*8 , (ILG ) )
AUTOMATIC ( SLPF , REAL*8 , (ILG ) )
AUTOMATIC ( GAMMA , REAL*8 , (ILG ) )
AUTOMATIC ( THETA , REAL*8 , (ILG ) )
AUTOMATIC ( IZT1 , INTEGER , (ILG ) )
AUTOMATIC ( IZT2 , INTEGER , (ILG ) )
AUTOMATIC ( IZT3 , INTEGER , (ILG ) )
AUTOMATIC ( IZB , INTEGER , (ILG ) )
AUTOMATIC ( UAV , REAL*8 , (ILG ) )
AUTOMATIC ( VAV , REAL*8 , (ILG ) )
AUTOMATIC ( VELAV , REAL*8 , (ILG ) )
AUTOMATIC ( DELZ , REAL*8 , (ILG ) )
AUTOMATIC ( FDIR , REAL*8 , (ILG ) )
AUTOMATIC ( BLOFF , REAL*8 , (ILG ) )
AUTOMATIC ( PSI , REAL*8 , (ILG ) )
AUTOMATIC ( CPSI , REAL*8 , (ILG ) )
AUTOMATIC ( SPSI , REAL*8 , (ILG ) )
AUTOMATIC ( AMPD , REAL*8 , (ILG ) )
c
AUTOMATIC ( UTEND5 , REAL*8 , (ILG,ILEV) )
AUTOMATIC ( VTEND5 , REAL*8 , (ILG,ILEV) )
AUTOMATIC ( U5 , REAL*8 , (ILG,ILEV) )
AUTOMATIC ( V5 , REAL*8 , (ILG,ILEV) )
AUTOMATIC ( TF5 , REAL*8 , (ILG,ILEV) )
AUTOMATIC ( TH5 , REAL*8 , (ILG,ILEV) )
AUTOMATIC ( AUX5 , REAL*8 , (ILG,ILEV) )
AUTOMATIC ( BVFREQ5 , REAL*8 , (ILG,ILEV) )
AUTOMATIC ( UTENDGWD5, REAL*8 , (ILG,ILEV) )
AUTOMATIC ( VTENDGWD5, REAL*8 , (ILG,ILEV) )
AUTOMATIC ( VELN5 , REAL*8 , (ILG,ILEV) )
AUTOMATIC ( ASQ5 , REAL*8 , (ILG,ILEV) )
AUTOMATIC ( ASQI5 , REAL*8 , (ILG,ILEV) )
AUTOMATIC ( ASQS5 , REAL*8 , (ILG,ILEV) )
AUTOMATIC ( DEPFAC5 , REAL*8 , (ILG,ILEV) )
AUTOMATIC ( GRAD5 , REAL*8 , (ILG,ILEV) )
AUTOMATIC ( DENFAC5 , REAL*8 , (ILG,ILEV) )
AUTOMATIC ( ETA , REAL*8 , (ILG,ILEV) )
AUTOMATIC ( ZB5 , REAL*8 , (ILG,ILEV) )
AUTOMATIC ( FVERT5 , REAL*8 , (ILG,ILEV) )
AUTOMATIC ( IMPAUX5 , REAL*8 , (ILG,ILEV) )
AUTOMATIC ( UTENDLLB5, REAL*8 , (ILG,ILEV) )
AUTOMATIC ( VTENDLLB5, REAL*8 , (ILG,ILEV) )
AUTOMATIC ( UTENDLFT5, REAL*8 , (ILG,ILEV) )
AUTOMATIC ( VTENDLFT5, REAL*8 , (ILG,ILEV) )
AUTOMATIC ( UTENDLWB5, REAL*8 , (ILG,ILEV) )
AUTOMATIC ( VTENDLWB5, REAL*8 , (ILG,ILEV) )
AUTOMATIC ( UTENDTOT5, REAL*8 , (ILG,ILEV) )
AUTOMATIC ( VTENDTOT5, REAL*8 , (ILG,ILEV) )
AUTOMATIC ( AUX , REAL*8 , (ILG,ILEV) )
c
AUTOMATIC ( U , REAL*8 , (ILG,ILEV) )
AUTOMATIC ( V , REAL*8 , (ILG,ILEV) )
AUTOMATIC ( TF , REAL*8 , (ILG,ILEV) )
AUTOMATIC ( TH , REAL*8 , (ILG,ILEV) )
AUTOMATIC ( S , REAL*8 , (ILG,ILEV) )
AUTOMATIC ( SH , REAL*8 , (ILG,ILEV) )
AUTOMATIC ( BVFREQ , REAL*8 , (ILG,ILEV) )
AUTOMATIC ( UTENDGWD , REAL*8 , (ILG,ILEV) )
AUTOMATIC ( VTENDGWD , REAL*8 , (ILG,ILEV) )
AUTOMATIC ( VELN , REAL*8 , (ILG,ILEV) )
AUTOMATIC ( ASQ , REAL*8 , (ILG,ILEV) )
AUTOMATIC ( ASQI , REAL*8 , (ILG,ILEV) )
AUTOMATIC ( ASQS , REAL*8 , (ILG,ILEV) )
AUTOMATIC ( DEPFAC , REAL*8 , (ILG,ILEV) )
AUTOMATIC ( GRAD , REAL*8 , (ILG,ILEV) )
AUTOMATIC ( DENFAC , REAL*8 , (ILG,ILEV) )
AUTOMATIC ( ZB , REAL*8 , (ILG,ILEV) )
AUTOMATIC ( FVERT , REAL*8 , (ILG,ILEV) )
AUTOMATIC ( IMPAUX , REAL*8 , (ILG,ILEV) )
AUTOMATIC ( UTENDLLB , REAL*8 , (ILG,ILEV) )
AUTOMATIC ( VTENDLLB , REAL*8 , (ILG,ILEV) )
AUTOMATIC ( UTENDLFT , REAL*8 , (ILG,ILEV) )
AUTOMATIC ( VTENDLFT , REAL*8 , (ILG,ILEV) )
AUTOMATIC ( UTENDLWB , REAL*8 , (ILG,ILEV) )
AUTOMATIC ( VTENDLWB , REAL*8 , (ILG,ILEV) )
AUTOMATIC ( UTENDTOT , REAL*8 , (ILG,ILEV) )
AUTOMATIC ( VTENDTOT , REAL*8 , (ILG,ILEV) )
**
integer i,l,ii,len,lrefm,jyes,jno
real*8 dz,dz5,uparl5,piotwo,vmin,v0,hmin,zero,unit,cdblk
**
vmin = 2.
v0 = 1.e-12
hmin = 3.
zero = 0.
unit = 1.
cdblk = 1.
**
len = il2 - il1 + 1
lref = ilev
lrefm = lref - 1
cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
c *** TRAJECTORY ***
ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
c INITIAL STEPS
c
c--------------------------------------------------------------------
c Initialize total tendency
c
do l=1,ilev
do i=il1,il2
utend5(i,l) = zero
vtend5(i,l) = zero
enddo
enddo
c-------------------------------------------------------------------
c Find and gather active grid columns
c
c Wind and unit vector at reference level LREFM:
c
do i=il1,il2
vmod5(i) = sqrt ( uu5(i,lrefm)**2 + vv5(i,lrefm)**2 )
if (vmod5(i).le.vmin) vmod5(i) = vmin
uub5(i) = uu5(i,lrefm)/vmod5(i)
vvb5(i) = vv5(i,lrefm)/vmod5(i)
enddo
c
c-------------------------------------------------------------------
c Gather columns where orographic drag is active
c
jyes = 0
jno = len + 1
c
do i=il1,il2
if ( gc(i).eq.-1. .and. vmod5(i).gt.vmin .and.
+ height(i).ge.hmin ) then
jyes = jyes + 1
drag(jyes) = i
else
jno = jno - 1
drag(jno) = i
endif
enddo
c
c Check if there is AT LEAST ONE active column
c
if (jyes.le.0) then
goto 600
endif
c
do i=1,len
ii = drag(i) + il1 - 1
ub5(i) = uub5(ii)
vb5(i) = vvb5(ii)
vmodb5(i) = vmod5(ii)
env(i) = height(ii)
slp2(i) = slope(ii)
gamma(i) = xcent(ii)
theta(i) = mtdir(ii)
enddo
c
do i=1,len
if (env(i) .lt. hmin) then
slpf(i) = slp2(i)/hmin
else
slpf(i) = slp2(i)/env(i)
endif
enddo
c
do l=1,ilev
do i=1,len
ii = drag(i) + il1 - 1
u5(i,l) = uu5(ii,l)
v5(i,l) = vv5(ii,l)
tf5(i,l) = ttf5(ii,l)
th5(i,l) = tth5(ii,l)
s(i,l) = ss(ii,l)
sh(i,l) = ssh(ii,l)
enddo
enddo
c
c--------------------------------------------------------------------
c Recalculate temperature at intermediate levels
c using a geometric average:
c
do l=1,ilev-1
do i=1,len
th5(i,l) = sqrt( tf5(i,l)*tf5(i,l+1) )
enddo
enddo
do i=1,len
th5(i,ilev) = tf5(i,ilev)
enddo
c
c--------------------------------------------------------------------
c Calculate BF frequency at all active levels (no smoothing):
c
do l=2,ilev
do i=1,len
aux5(i,l) = ( grav*grav/(rgas*tf5(i,l)) )*
+ ( rgocp - (s(i,l)/tf5(i,l))*
+ (th5(i,l)- th5(i,l-1))/
+ (sh(i,l) - sh(i,l-1)) )
if (aux5(i,l).le.1.0e-10) then
bvfreq5(i,l) = 1.0e-5
else
bvfreq5(i,l) = sqrt( aux5(i,l) )
endif
enddo
enddo
do i=1,len
bvfreq5(i,1) = bvfreq5(i,2)
enddo
c
ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
c GRAVITY-WAVE DRAG
c
c--------------------------------------------------------------------
c Initialize tendencies
do l=1,ilev
do i=1,len
utendgwd5(i,l) = zero
vtendgwd5(i,l) = zero
enddo
enddo
c
if (gwdrag) then
c
c--------------------------------------------------------------------
c Project wind field on reference wind:
c
do l=1,ilev
do i=1,jyes
veln5(i,l) = u5(i,l)*ub5(i)+v5(i,l)*vb5(i)
if (veln5(i,l).le.v0) veln5(i,l) = v0
enddo
enddo
c
c--------------------------------------------------------------------
c Stress field
c
c Compute stress at reference level:
c
do i=1,jyes
asq5(i,lref) = env(i)*env(i)
asqs5(i,lref) = env(i)*env(i)
asqi5(i,lref) = env(i)*env(i)
depfac5(i,lref) = taufac*grav
+ *(bvfreq5(i,lrefm)*s(i,lrefm)*vmodb5(i)/tf5(i,lrefm))
+ *asq5(i,lref)/rgas
enddo
c
c Compute stress at other levels (bottom-up):
c
do l=lrefm,1,-1
do i=1,jyes
asqi5(i,l) = asq5(i,l+1)
+ *(bvfreq5(i,l+1)*s(i,l+1)*veln5(i,l+1)/tf5(i,l+1))
+ /(bvfreq5(i,l) *s(i,l) *veln5(i,l) /tf5(i,l) )
if (veln5(i,l).ge.1.) then
asqs5(i,l) = 0.5*(veln5(i,l)/bvfreq5(i,l))**2
else
asqs5(i,l) = 1.e-6
endif
if (asqi5(i,l).le.asqs5(i,l)) then
asq5(i,l) = asqi5(i,l)
else
asq5(i,l) = asqs5(i,l)
endif
depfac5(i,l) = taufac*grav
+ *(bvfreq5(i,l)*s(i,l)*veln5(i,l)/tf5(i,l))
+ *asq5(i,l)/rgas
enddo
enddo
do i=1,jyes
depfac5(i,lref) = depfac5(i,lrefm)
enddo
c
c--------------------------------------------------------------------
c Compute gwd tendencies:
c
do i=1,jyes
if ((depfac5(i,2) - depfac5(i,1)).gt.1.e-10) then
eta(i,1) = 1.
else
eta(i,1) = 0.
endif
c
grad5(i,1) = 2.*eta(i,1)*depfac5(i,1)
+ /( 2.*sh(i,1) + eta(i,1)*3.*tau*depfac5(i,1)/veln5(i,1) )
utendgwd5(i,1) = -ub5(i)*grad5(i,1)
vtendgwd5(i,1) = -vb5(i)*grad5(i,1)
denfac5(i,1) = grad5(i,1)*3.*tau*depfac5(i,1)/veln5(i,1)
utendgwd5(i,lref) = zero
vtendgwd5(i,lref) = zero
enddo
c
do l=2,lrefm
do i=1,jyes
if ((depfac5(i,l) - depfac5(i,l-1)).gt.1.e-10) then
eta(i,l) = 1.
else
eta(i,l) = 0.
endif
grad5(i,l) = ( 2.*depfac5(i,l)-2.*depfac5(i,l-1) +
+ eta(i,l)*denfac5(i,l-1) )/
+ ( 2.*(sh(i,l)-sh(i,l-1)) +
+ eta(i,l)*3.*tau*depfac5(i,l)/veln5(i,l) )
utendgwd5(i,l) = -ub5(i)*grad5(i,l)
vtendgwd5(i,l) = -vb5(i)*grad5(i,l)
denfac5(i,l) = grad5(i,l)*3.*tau*depfac5(i,l)/veln5(i,l)
enddo
enddo
c
endif
c
cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
c LOW-LEVEL BLOCKING
c
c--------------------------------------------------------------------
c Initialize arrays
do l=1,ilev
do i=1,len
zb5(i,l) = zero
utendllb5(i,l) = zero
vtendllb5(i,l) = zero
enddo
enddo
c
do i=1,len
izt1(i) = ilev-1
izt2(i) = ilev
izt3(i) = ilev
hblk5(i) = zero
izb(i) = ilev
uav5(i) = v0
vav5(i) = v0
velav5(i) = v0
delz5(i) = zero
fdir5(i) = unit
bloff(i) = 0
enddo
c
if (blocking) then
c--------------------------------------------------------------------
c Build elevation field:
do i=1,jyes
zb5(i,ilev) = -(rgas/grav)*tf5(i,ilev)*log(sh(i,ilev))
enddo
do l=ilev-1,1,-1
do i=1,jyes
zb5(i,l) = zb5(i,l+1) +
+ (rgas/grav)*tf5(i,l)*log(sh(i,l+1)/sh(i,l))
enddo
enddo
c
c--------------------------------------------------------------------
c Blocking height
c
c Find maximum blocking level, upper level for averaging and
c lower level for averaging:
do l=ilev-2,1,-1
do i=1,jyes
if (zb5(i,l).lt.(1.5*env(i))) izt3(i) = l
if (zb5(i,l).lt. env(i) ) izt1(i) = l
enddo
enddo
c
do l=ilev-1,1,-1
do i=1,jyes
if (zb5(i,l).lt.(0.5*env(i))) izt2(i) = l
enddo
enddo
c
c Compute averages:
do l=ilev,2,-1
do i=1,jyes
if (l.le.izt2(i) .and. l.ge.izt1(i)) then
dz5 = zb5(i,l-1) - zb5(i,l)
delz5(i) = delz5(i) + dz5
uav5(i) = uav5(i) + dz5*u5(i,l)
vav5(i) = vav5(i) + dz5*v5(i,l)
endif
enddo
enddo
do i=1,jyes
uav5(i) = uav5(i)/delz5(i)
vav5(i) = vav5(i)/delz5(i)
if (abs(vav5(i)).lt.v0 .and. abs(uav5(i)).lt.v0) then
velav5(i) = v0
else
velav5(i) = sqrt( uav5(i)**2 + vav5(i)**2 )
endif
enddo
c
c Compute blocking height and blocking level:
c
do l=2,ilev
do i=1,jyes
if (l.ge.izt3(i) .and. bloff(i).eq.0) then
dz5 = zb5(i,l-1) - zb5(i,l)
uparl5 = (u5(i,l)*uav5(i) + v5(i,l)*vav5(i))/velav5(i)
if (uparl5 .lt. v0) then
izb(i) = l-1
bloff(i) = 1
else
hblk5(i) = hblk5(i) + dz5*bvfreq5(i,l)/uparl5
if (hblk5(i) .gt. 0.5) then
izb(i) = l-1
bloff(i) = 1
endif
endif
endif
enddo
enddo
c
c--------------------------------------------------------------------
c Compute directional factor:
c
piotwo = .5*acos(-1.)
do i=1,jyes
c
c Angle between mean wind and topography:
if ( abs(vav5(i)) .lt. v0 .and. abs(uav5(i)) .lt. v0) then
psi5(i) = zero
else
psi5(i) = theta(i) - atan2(vav5(i),uav5(i))
if (psi5(i) .gt. piotwo ) psi5(i) = psi5(i) - 2.*piotwo
if (psi5(i) .lt. (-piotwo)) psi5(i) = psi5(i) + 2.*piotwo
endif
cpsi5(i) = ( cos(psi5(i)) )**2
spsi5(i) = ( sin(psi5(i)) )**2
c
c Directional factor:
ampd5(i) = cpsi5(i) + gamma(i)*spsi5(i)
if (ampd5(i) .lt. 1.e-10) then
ampd5(i) = zero
else
ampd5(i) = 2. - ( gamma(i)*cpsi5(i) + spsi5(i) )
+ /( cpsi5(i) + gamma(i)*spsi5(i) )
if (ampd5(i).lt.zero) ampd5(i) = zero
endif
fdir5(i) = ampd5(i)*
+ ( (1.-.18*gamma(i) -.04*(gamma(i)**2))*cpsi5(i)
+ +( .48*gamma(i) +.30*(gamma(i)**2))*spsi5(i) )
c
enddo
c--------------------------------------------------------------------
c Compute llb tendencies:
c
do l=ilev,1,-1
do i=1,jyes
if ( velav5(i).ge.vmin .and.
+ l.gt.izb(i) .and. zb5(i,izb(i)).ge.hmin ) then
c
c Vertical factor:
fvert5(i,l) = sqrt( (zb5(i,izb(i)) - zb5(i,l))
+ /(0.5*env(i) + zb5(i,l)) )
c
* Implicit calculation of llb tendencies:
*
impaux5(i,l) = 0.5*cdblk*slpf(i)*fdir5(i)*fvert5(i,l)
+ *sqrt(u5(i,l)*u5(i,l) + v5(i,l)*v5(i,l))
utendllb5(i,l) = -impaux5(i,l)*u5(i,l)
+ /(1.0+impaux5(i,l)*tau)
vtendllb5(i,l) = -impaux5(i,l)*v5(i,l)
+ /(1.0+impaux5(i,l)*tau)
*
endif
enddo
enddo
c
endif
c
cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
c OROGRAPHIC LIFT
c
c--------------------------------------------------------------------
c Initialize arrays
do l=1,ilev
do i=1,len
utendlft5(i,l) = zero
vtendlft5(i,l) = zero
enddo
enddo
c
if (orolift) then
c
endif
c
cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
c LEE-WAVE BREAKING
c
c--------------------------------------------------------------------
c Initialize arrays
do l=1,ilev
do i=1,len
utendlwb5(i,l) = zero
vtendlwb5(i,l) = zero
enddo
enddo
c
if (leewave) then
c
endif
cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
c TOTAL DRAG AND RESULTING WIND FIELD
c
c--------------------------------------------------------------------
do l=1,ilev
do i=1,len
utendtot5(i,l) = zero
vtendtot5(i,l) = zero
enddo
enddo
c
c Add and scatter tendencies
do l=1,ilev
do i=1,jyes
utendtot5(i,l) = utendgwd5(i,l) +
+ utendllb5(i,l) +
+ utendlft5(i,l) +
+ utendlwb5(i,l)
vtendtot5(i,l) = vtendgwd5(i,l) +
+ vtendllb5(i,l) +
+ vtendlft5(i,l) +
+ vtendlwb5(i,l)
enddo
enddo
c
do l=1,ilev
do i=1,len
ii = drag(i) + il1 - 1
utend5(ii,l) = utendtot5(i,l)
vtend5(ii,l) = vtendtot5(i,l)
enddo
enddo
c
c--------------------------------------------------------------------
600 continue
c--------------------------------------------------------------------
c
ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
c *** ADJOINT MODEL ***
ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
c Initialize adjoint fields
c
dz = 0.
c
do i=1,ilg
fdir(i) = 0.
spsi(i) = 0.
cpsi(i) = 0.
ampd(i) = 0.
psi(i) = 0.
uav(i) = 0.
vav(i) = 0.
velav(i) = 0.
delz(i) = 0.
vb(i) = 0.
ub(i) = 0.
vmodb(i) = 0.
vmod(i) = 0.
vvb(i) = 0.
uub(i) = 0.
enddo
c
do l=1,ilev
do i=1,ilg
vtendtot(i,l) = 0.
utendtot(i,l) = 0.
vtendlwb(i,l) = 0.
vtendlft(i,l) = 0.
vtendllb(i,l) = 0.
vtendgwd(i,l) = 0.
utendlwb(i,l) = 0.
utendlft(i,l) = 0.
utendllb(i,l) = 0.
utendgwd(i,l) = 0.
impaux(i,l) = 0.
v(i,l) = 0.
u(i,l) = 0.
fvert(i,l) = 0.
zb(i,l) = 0.
veln(i,l) = 0.
depfac(i,l) = 0.
grad(i,l) = 0.
denfac(i,l) = 0.
asq(i,l) = 0.
bvfreq(i,l) = 0.
asqi(i,l) = 0.
asqs(i,l) = 0.
aux(i,l) = 0.
tf(i,l) = 0.
th(i,l) = 0.
enddo
enddo
c
c
if (applytend) then
c
do l=ilev,1,-1
do i=il2,il1,-1
vtend(i,l) = vtend(i,l) + tau*vv(i,l)
vv(i,l) = vv(i,l)
utend(i,l) = utend(i,l) + tau*uu(i,l)
uu(i,l) = uu(i,l)
enddo
enddo
c
endif
c
if (jyes.le.0) then
goto 700
endif
c
do l=ilev,1,-1
do i=len,1,-1
ii = drag(i) + il1 - 1
vtendtot(i,l) = vtendtot(i,l) + vtend(ii,l)
vtend(ii,l) = 0.
utendtot(i,l) = utendtot(i,l) + utend(ii,l)
utend(ii,l) = 0.
enddo
enddo
c
do l=ilev,1,-1
do i=len,1,-1
vtendlwb(i,l) = vtendlwb(i,l) + vtendtot(i,l)
vtendlft(i,l) = vtendlft(i,l) + vtendtot(i,l)
vtendllb(i,l) = vtendllb(i,l) + vtendtot(i,l)
vtendgwd(i,l) = vtendgwd(i,l) + vtendtot(i,l)
vtendtot(i,l) = 0.
utendlwb(i,l) = utendlwb(i,l) + utendtot(i,l)
utendlft(i,l) = utendlft(i,l) + utendtot(i,l)
utendllb(i,l) = utendllb(i,l) + utendtot(i,l)
utendgwd(i,l) = utendgwd(i,l) + utendtot(i,l)
utendtot(i,l) = 0.
enddo
enddo
c
do l=ilev,1,-1
do i=len,1,-1
vtendtot(i,l) = 0.
utendtot(i,l) = 0.
enddo
enddo
c
c LEE-WAVE BREAKING
if (leewave) then
c
endif
do l=ilev,1,-1
do i=len,1,-1
vtendlwb(i,l) = 0.
utendlwb(i,l) = 0.
enddo
enddo
c
c OROGRAPHIC LIFT
if (orolift) then
c
endif
do l=ilev,1,-1
do i=len,1,-1
vtendlft(i,l) = 0.
utendlft(i,l) = 0.
enddo
enddo
c
c LOW-LEVEL BLOCKING
if (blocking) then
c
do l=1,ilev
do i=jyes,1,-1
if ( velav5(i).ge.vmin .and.
+ l.gt.izb(i) .and. zb5(i,izb(i)).ge.hmin ) then
impaux(i,l) = impaux(i,l)
+ -vtendllb(i,l)*v5(i,l)/((1.0+impaux5(i,l)*tau)**2)
v(i,l) = v(i,l)
+ -vtendllb(i,l)*impaux5(i,l)/(1.0+impaux5(i,l)*tau)
vtendllb(i,l) = 0.
*
impaux(i,l) = impaux(i,l)
+ -utendllb(i,l)*u5(i,l)/((1.0+impaux5(i,l)*tau)**2)
u(i,l) = u(i,l)
+ -utendllb(i,l)*impaux5(i,l)/(1.0+impaux5(i,l)*tau)
utendllb(i,l) = 0.
*
v(i,l) = v(i,l)
+ +impaux(i,l)*0.5*cdblk*slpf(i)*fdir5(i)*fvert5(i,l)
+ *v5(i,l)/sqrt(u5(i,l)*u5(i,l) + v5(i,l)*v5(i,l))
u(i,l) = u(i,l)
+ +impaux(i,l)*0.5*cdblk*slpf(i)*fdir5(i)*fvert5(i,l)
+ *u5(i,l)/sqrt(u5(i,l)*u5(i,l) + v5(i,l)*v5(i,l))
fvert(i,l) = fvert(i,l)
+ +impaux(i,l)*aa2*0.5*cdblk*slpf(i)*fdir5(i)
+ *sqrt(u5(i,l)*u5(i,l) + v5(i,l)*v5(i,l))
fdir(i) = fdir(i)
+ +impaux(i,l)*aa1*0.5*cdblk*slpf(i)*fvert5(i,l)
+ *sqrt(u5(i,l)*u5(i,l) + v5(i,l)*v5(i,l))
impaux(i,l) = 0.
c
zb(i,l) = zb(i,l)
+ - fvert(i,l)*.5*fvert5(i,l)*
+ ( 1./(zb5(i,izb(i)) - zb5(i,l)) +
+ 1./(0.5*env(i) + zb5(i,l)) )
zb(i,izb(i)) = zb(i,izb(i))
+ + fvert(i,l)*.5*fvert5(i,l)/
+ (zb5(i,izb(i)) - zb5(i,l))
fvert(i,l) = 0.
c
endif
enddo
enddo
c
do i=jyes,1,-1
spsi(i) = spsi(i)
+ + fdir(i)*ampd5(i)*
+ ( .48*gamma(i) +.30*(gamma(i)**2))
cpsi(i) = cpsi(i)
+ + fdir(i)*ampd5(i)*
+ (1.-.18*gamma(i) -.04*(gamma(i)**2))
ampd(i) = ampd(i)
+ + fdir(i)*
+ ( (1.-.18*gamma(i) -.04*(gamma(i)**2))*cpsi5(i)
+ +( .48*gamma(i) +.30*(gamma(i)**2))*spsi5(i) )
fdir(i) = 0.
c
if ((cpsi5(i) + gamma(i)*spsi5(i)) .lt. 1.e-10) then
ampd(i) = 0.
else
if (ampd5(i).lt.zero) ampd(i) = 0.
spsi(i) = spsi(i)
+ + ampd(i)*(
+ gamma(i)*( gamma(i)*cpsi5(i) + spsi5(i) )/
+ (( cpsi5(i) + gamma(i)*spsi5(i) )**2) -
+ 1./( cpsi5(i) + gamma(i)*spsi5(i) ) )
cpsi(i) = cpsi(i)
+ + ampd(i)*(
+ ( gamma(i)*cpsi5(i) + spsi5(i) )/
+ (( cpsi5(i) + gamma(i)*spsi5(i) )**2) -
+ gamma(i)/( cpsi5(i) + gamma(i)*spsi5(i) ) )
ampd(i) = 0.
endif
psi(i) = psi(i) + spsi(i)*sin(2*psi5(i))
spsi(i) = 0.
psi(i) = psi(i) - cpsi(i)*sin(2*psi5(i))
cpsi(i) = 0.
if ( abs(vav5(i)) .lt. v0 .and. abs(uav5(i)) .lt. v0) then
psi(i) = 0.
else
uav(i) = uav(i) + psi(i)*vav5(i)/(velav5(i)**2)
vav(i) = vav(i) - psi(i)*uav5(i)/(velav5(i)**2)
psi(i) = 0.
endif
enddo
c
do i=jyes,1,-1
if (abs(vav5(i)).lt.v0 .and. abs(uav5(i)).lt.v0) then
velav(i) = 0.
else
vav(i) = vav(i) + velav(i)*vav5(i)/velav5(i)
uav(i) = uav(i) + velav(i)*uav5(i)/velav5(i)
velav(i) = 0.
endif
delz(i) = delz(i) - vav(i)*vav5(i)/delz5(i)
vav(i) = vav(i)/delz5(i)
delz(i) = delz(i) - uav(i)*uav5(i)/delz5(i)
uav(i) = uav(i)/delz5(i)
enddo
c
do l=2,ilev
do i=jyes,1,-1
if (l.le.izt2(i) .and. l.ge.izt1(i)) then
dz5 = zb5(i,l-1) - zb5(i,l)
v(i,l) = v(i,l) + vav(i)*dz5
dz = dz + vav(i)*v5(i,l)
vav(i) = vav(i)
u(i,l) = u(i,l) + uav(i)*dz5
dz = dz + uav(i)*u5(i,l)
uav(i) = uav(i)
dz = dz + delz(i)
delz(i) = delz(i)
zb(i,l) = zb(i,l) - dz
zb(i,l-1) = zb(i,l-1) + dz
dz = 0.
endif
enddo
enddo
c
do l=1,ilev-1
do i=jyes,1,-1
tf(i,l) = tf(i,l)
+ + zb(i,l)*(rgas/grav)*log(sh(i,l+1)/sh(i,l))
zb(i,l+1) = zb(i,l+1) + zb(i,l)
zb(i,l) = 0.
enddo
enddo
do i=jyes,1,-1
tf(i,ilev) = tf(i,ilev)
+ - zb(i,ilev)*(rgas/grav)*log(sh(i,ilev))
zb(i,ilev) = 0.
enddo
c
endif
c
do i=len,1,-1
uav(i) = 0.
vav(i) = 0.
velav(i) = 0.
delz(i) = 0.
fdir(i) = 0.
enddo
c
do l=ilev,1,-1
do i=len,1,-1
zb(i,l) = 0.
utendllb(i,l) = 0.
vtendllb(i,l) = 0.
enddo
enddo
c
c GRAVITY-WAVE DRAG
if (gwdrag) then
c
do l=lrefm,2,-1
do i=jyes,1,-1
veln(i,l) = veln(i,l)
+ - denfac(i,l)*denfac5(i,l)/veln5(i,l)
depfac(i,l) = depfac(i,l)
+ + denfac(i,l)*denfac5(i,l)/depfac5(i,l)
grad(i,l) = grad(i,l)
+ + denfac(i,l)*3.*tau*depfac5(i,l)/veln5(i,l)
denfac(i,l) = 0.
c
grad(i,l) = grad(i,l) - vtendgwd(i,l)*vb5(i)
vb(i) = vb(i) - vtendgwd(i,l)*grad5(i,l)
vtendgwd(i,l) = 0.
c
grad(i,l) = grad(i,l) - utendgwd(i,l)*ub5(i)
ub(i) = ub(i) - utendgwd(i,l)*grad5(i,l)
utendgwd(i,l) = 0.
c
veln(i,l) = veln(i,l)
+ + grad(i,l)*grad5(i,l)*eta(i,l)*3.*tau*
+ depfac5(i,l)*(1./(veln5(i,l)**2))/
+ ( 2.*(sh(i,l)-sh(i,l-1)) +
+ eta(i,l)*3.*tau*depfac5(i,l)/veln5(i,l) )
depfac(i,l) = depfac(i,l)
+ + grad(i,l)*( 2./
+ ( 2.*(sh(i,l)-sh(i,l-1)) +
+ eta(i,l)*3.*tau*depfac5(i,l)/veln5(i,l) )
+ -(grad5(i,l)*eta(i,l)*3.*tau/veln5(i,l))/
+ ( 2.*(sh(i,l)-sh(i,l-1)) +
+ eta(i,l)*3.*tau*depfac5(i,l)/veln5(i,l) ) )
denfac(i,l-1) = denfac(i,l-1)
+ + grad(i,l)*eta(i,l)/
+ ( 2.*(sh(i,l)-sh(i,l-1)) +
+ eta(i,l)*3.*tau*depfac5(i,l)/veln5(i,l) )
depfac(i,l-1) = depfac(i,l-1)
+ - grad(i,l)*2./
+ ( 2.*(sh(i,l)-sh(i,l-1)) +
+ eta(i,l)*3.*tau*depfac5(i,l)/veln5(i,l) )
grad(i,l) = 0.
enddo
enddo
c
do i=jyes,1,-1
vtendgwd(i,lref) = 0.
utendgwd(i,lref) = 0.
c
veln(i,1) = veln(i,1)
+ - denfac(i,1)*denfac5(i,1)/veln5(i,1)
depfac(i,1) = depfac(i,1)
+ + denfac(i,1)*denfac5(i,1)/depfac5(i,1)
grad(i,1) = grad(i,1)
+ + denfac(i,1)*3.*tau*depfac5(i,1)/veln5(i,1)
denfac(i,1) = 0.
c
grad(i,1) = grad(i,1) - vtendgwd(i,1)*vb5(i)
vb(i) = vb(i) - vtendgwd(i,1)*grad5(i,1)
vtendgwd(i,1) = 0.
c
grad(i,1) = grad(i,1) - utendgwd(i,1)*ub5(i)
ub(i) = ub(i) - utendgwd(i,1)*grad5(i,1)
utendgwd(i,1) = 0.
c
veln(i,1) = veln(i,1)
+ + grad(i,1)*grad5(i,1)*eta(i,1)*3.*tau*
+ depfac5(i,1)*(1./(veln5(i,1)**2))/
+ ( 2.*sh(i,1)+eta(i,1)*3.*tau*
+ depfac5(i,1)/veln5(i,1) )
depfac(i,1) = depfac(i,1)
+ + grad(i,1)*( 2.*eta(i,1)/
+ ( 2.*sh(i,1)+eta(i,1)*3.*tau*depfac5(i,1)
+ /veln5(i,1) )
+ -(grad5(i,1)*eta(i,1)*3.*tau/veln5(i,1))/
+ ( 2.*sh(i,1)+eta(i,1)*3.*tau*depfac5(i,1)
+ /veln5(i,1) ) )
grad(i,1) = 0.
enddo
c
do i=jyes,1,-1
depfac(i,lrefm) = depfac(i,lrefm) + depfac(i,lref)
depfac(i,lref) = 0.
enddo
c
do l=1,lrefm
do i=jyes,1,-1
asq(i,l) = asq(i,l)
+ + depfac(i,l)*depfac5(i,l)/asq5(i,l)
tf(i,l) = tf(i,l)
+ - depfac(i,l)*depfac5(i,l)/tf5(i,l)
veln(i,l) = veln(i,l)
+ + depfac(i,l)*depfac5(i,l)/veln5(i,l)
bvfreq(i,l) = bvfreq(i,l)
+ + depfac(i,l)*depfac5(i,l)/bvfreq5(i,l)
depfac(i,l) = 0.
if (asqi5(i,l).le.asqs5(i,l)) then
asqi(i,l) = asqi(i,l) + asq(i,l)
asq(i,l) = 0.
else
asqs(i,l) = asqs(i,l) + asq(i,l)
asq(i,l) = 0.
endif
if (veln5(i,l).ge.1.) then
bvfreq(i,l) = bvfreq(i,l)
+ - asqs(i,l)*2.*asqs5(i,l)/bvfreq5(i,l)
veln(i,l) = veln(i,l)
+ + asqs(i,l)*2.*asqs5(i,l)/veln5(i,l)
asqs(i,l) = 0.
else
asqs(i,l) = 0.
endif
tf(i,l) = tf(i,l)
+ + asqi(i,l)*asqi5(i,l)/tf5(i,l)
veln(i,l) = veln(i,l)
+ - asqi(i,l)*asqi5(i,l)/veln5(i,l)
bvfreq(i,l) = bvfreq(i,l)
+ - asqi(i,l)*asqi5(i,l)/bvfreq5(i,l)
tf(i,l+1) = tf(i,l+1)
+ - asqi(i,l)*asqi5(i,l)/tf5(i,l+1)
veln(i,l+1) = veln(i,l+1)
+ + asqi(i,l)*asqi5(i,l)/veln5(i,l+1)
bvfreq(i,l+1) = bvfreq(i,l+1)
+ + asqi(i,l)*asqi5(i,l)/bvfreq5(i,l+1)
asq(i,l+1) = asq(i,l+1)
+ + asqi(i,l)*asqi5(i,l)/asq5(i,l+1)
asqi(i,l) = 0.
enddo
enddo
c
do i=jyes,1,-1
asq(i,lref) = asq(i,lref)
+ + depfac(i,lref)*depfac5(i,lref)/asq5(i,lref)
tf(i,lrefm) = tf(i,lrefm)
+ - depfac(i,lref)*depfac5(i,lref)/tf5(i,lrefm)
vmodb(i) = vmodb(i)
+ + depfac(i,lref)*depfac5(i,lref)/vmodb5(i)
bvfreq(i,lrefm) = bvfreq(i,lrefm)
+ + depfac(i,lref)*depfac5(i,lref)/bvfreq5(i,lrefm)
depfac(i,lref) = 0.
c
asqi(i,lref) = 0.
asqs(i,lref) = 0.
asq(i,lref) = 0.
enddo
c
do l=ilev,1,-1
do i=jyes,1,-1
if (veln5(i,l).le.v0) veln(i,l) = 0.
vb(i) = vb(i) + veln(i,l)*v5(i,l)
v(i,l) = v(i,l) + veln(i,l)*vb5(i)
ub(i) = ub(i) + veln(i,l)*u5(i,l)
u(i,l) = u(i,l) + veln(i,l)*ub5(i)
veln(i,l) = 0.
enddo
enddo
c
endif
c
do l=ilev,1,-1
do i=len,1,-1
vtendgwd(i,l) = 0.
utendgwd(i,l) = 0.
enddo
enddo
c
do i=len,1,-1
bvfreq(i,2) = bvfreq(i,2) + bvfreq(i,1)
bvfreq(i,1) = 0.
enddo
c
do l=ilev,2,-1
do i=len,1,-1
if (aux5(i,l).le.1.0e-10) then
bvfreq(i,l) = 0.
else
aux(i,l) = aux(i,l)
+ + bvfreq(i,l)*0.5/sqrt( aux5(i,l) )
bvfreq(i,l) = 0.
endif
th(i,l-1) = th(i,l-1)
+ + aux(i,l)*(grav*grav/(rgas*tf5(i,l)))*
+ (s(i,l)/tf5(i,l))/(sh(i,l) - sh(i,l-1))
th(i,l) = th(i,l)
+ - aux(i,l)*(grav*grav/(rgas*tf5(i,l)))*
+ (s(i,l)/tf5(i,l))/(sh(i,l) - sh(i,l-1))
tf(i,l) = tf(i,l)
+ + aux(i,l)*( (grav*grav/(rgas*tf5(i,l)))*
+ (s(i,l)/(tf5(i,l)**2))*
+ (th5(i,l)-th5(i,l-1))/(sh(i,l)-sh(i,l-1))
+ - aux5(i,l)/tf5(i,l) )
aux(i,l) = 0.
enddo
enddo
c
do i=len,1,-1
tf(i,ilev) = tf(i,ilev) + th(i,ilev)
th(i,ilev) = 0.
enddo
do l=ilev-1,1,-1
do i=len,1,-1
tf(i,l+1) = tf(i,l+1)
+ + th(i,l)*0.5*tf5(i,l)/th5(i,l)
tf(i,l) = tf(i,l)
+ + th(i,l)*0.5*tf5(i,l+1)/th5(i,l)
th(i,l) = 0.
enddo
enddo
c
do l=ilev,1,-1
do i=len,1,-1
ii = drag(i) + il1 - 1
tth(ii,l) = tth(ii,l) + th(i,l)
th(i,l) = 0.
ttf(ii,l) = ttf(ii,l) + tf(i,l)
tf(i,l) = 0.
vv(ii,l) = vv(ii,l) + v(i,l)
v(i,l) = 0.
uu(ii,l) = uu(ii,l) + u(i,l)
u(i,l) = 0.
enddo
enddo
c
do i=len,1,-1
ii = drag(i) + il1 - 1
vmod(ii) = vmod(ii) + vmodb(i)
vmodb(i) = 0.
vvb(ii) = vvb(ii) + vb(i)
vb(i) = 0.
uub(ii) = uub(ii) + ub(i)
ub(i) = 0.
enddo
c
700 continue
c
do i=il2,il1,-1
vmod(i) = vmod(i)
+ - vvb(i)*vvb5(i)/vmod5(i)
vv(i,lrefm) = vv(i,lrefm)
+ + vvb(i)/vmod5(i)
vvb(i) = 0.
vmod(i) = vmod(i)
+ - uub(i)*uub5(i)/vmod5(i)
uu(i,lrefm) = uu(i,lrefm)
+ + uub(i)/vmod5(i)
uub(i) = 0.
if (vmod5(i).le.vmin) vmod(i) = 0.
vv(i,lrefm) = vv(i,lrefm) + vmod(i)*vvb5(i)
uu(i,lrefm) = uu(i,lrefm) + vmod(i)*uub5(i)
vmod(i) = 0.
enddo
c
do l=ilev,1,-1
do i=il2,il1,-1
vtend(i,l) = 0.
utend(i,l) = 0.
enddo
enddo
c
cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
return
end