!-------------------------------------- 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 LAYERAVG2(KFLAG,PX1,PX2,PY2,PY2INCR,KNO,KNI, 2,2
& PPS,PMEAN,PZ,PZS,PZPS,knprof,pvo)
C
IMPLICIT NONE
C
C* Declaration of arguments
C
INTEGER KNO,KNI,KFLAG,knprof
REAL*8 PX1(KNO),PX2(KNI,knprof),PY2(KNI,knprof),PY2INCR(KNI,knprof
& )
REAL*8 PPS(knprof),PMEAN(kno,knprof),PZ(KNI),PZPS(kno,knprof)
& ,PZS(KNI,knprof),pvo(kno,knprof)
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
c .
*
* Output: Weighted mean value, its contribution to
* the TLM*increment or to the adjoint.
*
*Author : Y.J. Rochon *ARQX/EC Nov. 2005
*
**Revisions:
* S. Pellerin, ARMA, August 2008
* - Introduction of version 2
* - Introduction of profile and kno loops to reduce the
* number of calls (optimisation)
*
* -------------------
*
*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
c .0
* PMEAN: Mean weigthed value for PX1(KI-1) to PX1(KI+1) when
c KFLAG=2.
* Output otherwise.
* KNO: Dimension of PX1.
* KNI: 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
c otherwise.
*
* OUTPUT:
*
* PMEAN: Mean weigthed value for PX1(KI-1) to PX1(KI+1) using
* background values when kflag=0 and increments when kflag
c =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,jo,jn
C
C --- Identify boundary points
C
do jn = 1, knprof
do jo = 1, kno
z2=px1(jo)
C
if (jo.eq.1) then
z1=2.0*z2-px1(jo+1)
else
z1=px1(jo-1)
endif
C
if (jo.eq.kno) then
z3=2.0*z2-z1
else
z3=px1(jo+1)
endif
if (z3.gt.px2(kni,jn)) z3=px2(kni,jn)
C
iskip=0
if (z2.ge.px2(kni,jn)) then
z3=px2(kni,jn)
z2=px2(kni,jn)
iskip=1
endif
C
C --- Determine forward interpolator (kflag=0) or TLM (kflag>0)
C
pzps(jo,jn)=0.0
pz(1:kni)=0.0
ic=0
c call sublayer2(z1,z2,z3,px2(:,jn),kflag,
c & py2(:,jn),pzs(:,jn),pzps(jo,jn),pz,kni,ic,iskip)
do j=1,kni-1
if (px2(j,jn).ge.z3) go to 1000
C
if (px2(j,jn).le.z2.and.px2(j+1,jn).gt.z1) then
C
call sublayer
(z1,z2,z3,px2(j,jn),px2(j+1,jn),kflag,
& py2(j,jn),py2(j+1,jn),zw1,zw2,
& pzs(j,jn),pzs(j+1,jn),pzps(jo,jn))
pz(j)=pz(j)+zw1
pz(j+1)=pz(j+1)+zw2
ic=1
endif
C
if (px2(j,jn).lt.z3.and.px2(j+1,jn).ge.z2.and.iskip.eq.0)
& then
C
call sublayer(z3,z2,z1,px2(j,jn),px2(j+1,jn),kflag,
& py2(j,jn),py2(j+1,jn),zw1,zw2,
& pzs(j,jn),pzs(j+1,jn),pzps(jo,jn))
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 --- Apply forward interpolator (kflag=0), determine TLM*increment
c (kflag=1)
C or use TLM for adjoint calc (kflag=2)
zsum=0.0
if (kflag.eq.0) then
pmean(jo,jn)=0.0
do j=1,kni
pmean(jo,jn)=pmean(jo,jn)+pz(j)*py2(j,jn)
zsum=zsum+pz(j)
end do
pmean(jo,jn)=pmean(jo,jn)/zsum
else if (kflag.eq.1) then
pmean(jo,jn)=0.0
do j=1,kni
pmean(jo,jn)=pmean(jo,jn)+pz(j)*py2incr(j,jn)
zsum=zsum+pz(j)
end do
pmean(jo,jn)=pmean(jo,jn)/zsum
if (ic.ne.0) pzps(jo,jn)=pzps(jo,jn)*pps(jn)/zsum
PVO(JO,JN)=pmean(jo,jn)+PZPS(jo,jn)
else if (kflag.eq.2) then
do j=1,kni
zsum=zsum+pz(j)
end do
pz(1:kni)=pz(1:kni)*pmean(jo,jn)/zsum
py2incr(1:KNI,JN)=py2incr(1:KNI,JN)+PZ(1:KNI)
if (ic.ne.0) pzps(jo,jn)=pzps(jo,jn)*pmean(jo,jn)/zsum
PPS(JN)=PPS(JN)+PZPS(jo,jn)
endif
enddo
enddo
C
RETURN
END