!-------------------------------------- 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 --------------------------------------
!
SUBROUTINE SUBLAYER (z1,z2,z3,x1,x2,imode, 4
& t1,t2,w1,w2,pzs1,pzs2,pzps)
C
IMPLICIT NONE
REAL*8 z1,z2,z3,x1,x2,t1,t2,w1,w2,pzs1,pzs2,pzps
INTEGER imode
#include "comlun.cdk"
C
#if defined (DOC)
*-----------------------------------------------------------------
*
* Written by Yves J. Rochon *ARQX/EC, Nov. 2005
*
* Revisions:
* Saroja Polavarapu *ARMA/EC, Nov 2005
* - Setting of y1 and y2 moved from calling routine.
*
* Revisions:
*
* Purpose: Determine weight coefficients to assign to NWP variables
* at x1 and x2. Weights are determined from integration over
* the range (y1,y2), which is within the ranges of the
* NWP layer (x1,x2) and of the RTM layer (z1,z2). Intergrals
* are approximated via the trapezoidal rule:
*
* integral of f(x) from y1 to y2 = (f(y1)+f(y2))/2*abs(y1-y2)
*
* This is synonomous to having an integrand linear in x.
*
* Normalization done in calling routine.
*
* Input:
*
* z1.........Outer boundary of RTM level (could be above are below z2)
* z2.........Inner boundary of RTM level
* (position of RTM reference level)
* z3.........Second outer boundary
* x1.........Upper boundary of NWP layer (x1<x2)
* x2.........Lower boundary of NWP layer
* imode......0: Forward interpolator and linear model contribution
* to TLM only
* >0: Also provide NLM contribution to TLM (gradients
* w.r.t. Ps)
* t1.........Variable value at upper NWP level.
* t2.........Variable value at lower NWP level.
* dzs1.......dlnP/dPs = dx1/dPs
* dzs2.......dlnP/dPs = dx2/dPs
* pzps.......Current gradient contribution for weights*variable w.r.t Ps
*
* Output:
*
* w1.........Weight assigned to variable at upper NWP level
* w2.........Weight assigned to variable at lower NWP level
* pzps.......Updated gradient contribution for weights*variable w.r.t Ps
*
* Other:
*
* tot........Evaluated integral
* g1.........Gradient of weights*variables w.r.t. x1
* g2.........Gradient of weights*variables w.r.t. x2
*
*-----------------------------------------------------------------
#endif
C
REAL*8 y1,y2,tot,d,w10,w20,dz,dx,dy,dzd,dxd,g1,g2
REAL*8 a1,a2,aa1,aa2
integer ibot,itop
C
C --- Identify and set upper and lower boundaries of
C integration/averaging layers.
C
C y1.........Upper boundary of integral range (y1<y2)
C y2.........Lower boundary of integral range
C
itop=0
ibot=0
if (z1.lt.z3) then
y1=z1
if (x1.gt.z1) then
y1=x1
itop=1
endif
y2=z2
if (x2.lt.z2) then
y2=x2
ibot=1
endif
else
y1=z2
if (x1.gt.z2) then
y1=x1
itop=1
endif
y2=z1
if (x2.lt.z1) then
y2=x2
ibot=1
endif
endif
C
C --- Set weights for forward interpolator and linear model contribution to TLM
C
dy=y2-y1
dz=z1-z2
C dzd=1.0/dz
if (abs(dz).lt.1E-10) then
write(nulout,*) 'SUBLAYER: ERROR: dz is zero. dz = ',dz
write(nulout,*) 'z1,z2,z3 = ',z1,z2,z3
write(nulout,*) 'x1,x2 = ',x1,x2
write(nulout,*) 't1,t2 = ',t1,t2
cbue stop
w1=0.0
w2=0.0
return
else
dzd=1.0/dz
endif
w1=(z1-y1)*dzd*dy
w2=(z1-y2)*dzd*dy
w10=w1
w20=w2
dx=(x2-x1)
C dxd=1.0/dx
if (abs(dx).lt.1E-10) then
write(nulout,*) 'SUBLAYER: ERROR: dx is zero. dx = ',dx
write(nulout,*) 'z1,z2,z3 = ',z1,z2,z3
write(nulout,*) 'x1,x2 = ',x1,x2
write(nulout,*) 't1,t2 = ',t1,t2
cbue stop
w1=0.0
w2=0.0
return
else
dxd=1.0/dx
endif
C
if (z1.lt.z3.and.ibot.eq.0) then
d=(x2-z2)*dxd
w1=w1+w2*d
w2=w2*(1.0-d)
else if (z1.gt.z3.and.itop.eq.0) then
d=(x2-z2)*dxd
w2=w2+w1*(1.0-d)
w1=w1*d
end if
tot=t1*w1+t2*w2
C
C --- Provide NLM contribution to TLM (gradients w.r.t. Ps)
C
IF (imode.gt.0) THEN
C
C Determine gradient of 'tot' w.r.t. x1
C
aa1=0.0
aa2=0.0
a1=0.0
a2=0.0
if (itop.eq.1) then
a1=-(dy+(z1-y1))*dzd
a2=-(z1-y2)*dzd
else if (z1.gt.z3) then
a1=(x2-z2)*dxd*dxd*w10
a2=-a1
end if
if (z1.lt.z3.and.ibot.eq.0) then
aa2=(x2-z2)*dxd*dxd*w20
aa1=-aa2
if (itop.eq.1) then
a1=a1+a2*d+aa1
a2=a2*(1.0-d)+aa2
end if
end if
g1=a1*t1+a2*t2
C
C Determine gradient of 'tot' w.r.t. x2
C
aa1=0.0
aa2=0.0
a1=0.0
a2=0.0
if (ibot.eq.1) then
a1=dzd*(z1-y1)
a2=((z1-y2)-dy)*dzd
else if (z1.lt.z3) then
a1=((x2-z2)*dxd+1.0)*dxd*w20
a2=-a1
end if
if (z1.gt.z3.and.itop.eq.0) then
aa1=(1.0-(x2-z2)*dxd)*dxd*w10
aa2=-aa1
if (ibot.eq.1) then
a2=a2+a1*(1.0-d)+aa2
a1=a1*d+aa1
end if
end if
g2=a1*t1+a2*t2
C
C Accumulate for gradient w.r.t. Ps
C
pzps=pzps+g1*pzs1+g2*pzs2
C
ENDIF
C
RETURN
END