!-------------------------------------- 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 LAYERAVG(KFLAG,PX1,PX2,PY2,PY2INCR,KN1,KN2,KI, 1,2
& PPS,PMEAN,PZ,PZS,PZPS)
C
IMPLICIT NONE
C
C* Declaration of arguments
C
INTEGER KN1,KN2,KI,KFLAG
REAL*8 PX1(KN1),PX2(KN2),PY2(KN2),PY2INCR(KN2)
REAL*8 PPS,PMEAN,PZ(KN2),PZPS,PZS(KN2)
C
*---------------------------------------------------------
#if defined (DOC)
*
***s/r LAYERAVG - Perform integration between points PX1(KI-1) and
* PX1(KI+1) with piecewise linear weighting having
* weights of zero at ki-1 and ki+1 and max weight at ki.
*
* Output: Weighted mean value, its contribution to
* the TLM*increment or to the adjoint.
*
*Author : Y.J. Rochon *ARQX/EC Nov. 2005
*
**Revisions:
*
* -------------------
*
*Purpose: Perform integration between points PX1(KI-1) and
* PX1(KI+1) with piecewise linear weighting having
* weights of zero at ki-1 and ki+1 and max weight at ki.
*
* Output: Weighted mean value, its contribution to
* the TLM*increment or to the adjoint.
*
*Arguments:
*
* INPUT
*
* KFLAG: Indicates purpose of calc
* 0 - Application as forward interpolator
* 1 - Application for TLM* increments
* 2 - Setting of adjoint elements
*
* PX1: Reference levels (e.g. lnP; in increasing values)
* PX2: Available levels (e.g. lnP; in increasing values)
* PY2: Values at levels (e.g. temperature)
* PY2INCR: Not relevant when kflag=0 or 2
* Increments when kflag=1
* PZ: Extra array related to gradients w.r.t. Ps for KFLAG.gt.0
* PMEAN: Mean weigthed value for PX1(KI-1) to PX1(KI+1) when KFLAG=2.
* Output otherwise.
* KN1: Dimension of PX1.
* KN2: Dimension of other arrays.
* PZS: dlnP/dPs
* KI: Identifies region of interest: PX1(KI-1) to PX1(KI+1)
* PPS: Surface pressure increment when KFLAG=1, not needed otherwise.
*
* OUTPUT:
*
* PMEAN: Mean weigthed value for PX1(KI-1) to PX1(KI+1) using
* background values when kflag=0 and increments when kflag=1.
* PZ: Resultant accumulated contribution factors
* Adjoint when KFLAG=2
* TLM when KFLAG=1 or 0.
* PZPS: Surface pressure related adjoint term when KFLAG=2
* Surface pressure related TLM*increment term when KFLAG=1
*
*-----------------------------------------------------------
#endif
C
C* Declaration of local variables
C
REAL*8 Z1,Z2,Z3,ZW1,ZW2
REAL*8 zsum
INTEGER J,IC,ISKIP
C
C --- Identify boundary points
C
z2=px1(ki)
C
if (ki.eq.1) then
z1=2.0*z2-px1(ki+1)
else
z1=px1(ki-1)
endif
C
if (ki.eq.kn1) then
z3=2.0*z2-z1
else
z3=px1(ki+1)
endif
if (z3.gt.px2(kn2)) z3=px2(kn2)
C
iskip=0
if (z2.ge.px2(kn2)) then
z3=px2(kn2)
z2=px2(kn2)
iskip=1
endif
C
C --- Determine forward interpolator (kflag=0) or TLM (kflag>0)
C
pzps=0.0
pz(1:kn2)=0.0
ic=0
do j=1,kn2-1
if (px2(j).ge.z3) go to 1000
C
if (px2(j).le.z2.and.px2(j+1).gt.z1) then
C
call sublayer
(z1,z2,z3,px2(j),px2(j+1),kflag,
& py2(j),py2(j+1),zw1,zw2,
& pzs(j),pzs(j+1),pzps)
pz(j)=pz(j)+zw1
pz(j+1)=pz(j+1)+zw2
ic=1
endif
C
if (px2(j).lt.z3.and.px2(j+1).ge.z2.and.iskip.eq.0) then
C
call sublayer(z3,z2,z1,px2(j),px2(j+1),kflag,
& py2(j),py2(j+1),zw1,zw2,
& pzs(j),pzs(j+1),pzps)
pz(j)=pz(j)+zw1
pz(j+1)=pz(j+1)+zw2
ic=1
endif
enddo
1000 continue
if (ic.eq.0) pz(j)=1.0
C
C --- Apply forward interpolator (kflag=0), determine TLM*increment (kflag=1)
C or use TLM for adjoint calc (kflag=2)
C
zsum=0.0
if (kflag.eq.0) then
pmean=0.0
do j=1,kn2
pmean=pmean+pz(j)*py2(j)
zsum=zsum+pz(j)
end do
pmean=pmean/zsum
else if (kflag.eq.1) then
pmean=0.0
do j=1,kn2
pmean=pmean+pz(j)*py2incr(j)
zsum=zsum+pz(j)
end do
pmean=pmean/zsum
if (ic.ne.0) pzps=pzps*pps/zsum
else if (kflag.eq.2) then
do j=1,kn2
zsum=zsum+pz(j)
end do
pz(1:kn2)=pz(1:kn2)*pmean/zsum
if (ic.ne.0) pzps=pzps*pmean/zsum
endif
C
RETURN
END