SUBROUTINE CH_VERTAVG(CDBGTYP, pveta, pvtotal, ptop, pbtm, 1,3
1 qpeta, knflev, kfirst, plat, klat, pstate,
1 knulout,cvar,kgenoper,ktot,kmod,kobstyp)
C
IMPLICIT NONE
C
C* Declaration of arguments
C
CHARACTER*(*) CDBGTYP
CHARACTER*(*) cvar
INTEGER knflev,knulout,kfirst,ktot,kgenoper,kmod,klat,kobstyp
REAL*8 pveta(knflev),pstate(knflev),qpeta(knflev)
REAL*8 pvtotal,plat
REAL*8 pbtm,ptop
C
*---------------------------------------------------------------------
#if defined (DOC)
*
***s/r CH_VERTAVG -- Vertical averaging model to calculate partial (or total)
* column value of model state profile 'pveta' or used for
* adjoint calculations.
*
************************************
*
* NOT YET TESTED/VALIDATED!!!!
*
************************************
*
*Author : Y.J. Rochon, ARQX/MSC May 2005
* - Based on CH_VERTINTG
*Revision:
*
** Purpose: Vertical avg in ln(p) to calculate partial (or total)
* column value of model state profile 'pveta' or used for adjoint calc..
* Layer boundaries are taken as mid-point between eta levels in lnP
* coordinate.
*
* Applications:
*
* 1) KMOD=0; Forward/innovation model: Produce the integral PVTOTAL
* given the background state profile PVETA.
* 2) KMOD=1; Adjoint model: Create PVETA array given PVTOTAL.
*
*Arguments:
*
* Input pveta(nvlev) -- background values at eta levels when kmod=0
* pvtotal -- Column amount when kmod=1
* kmod -- Flag indicating purpose of call:
* 0: Use with forward model
* 1: Use with adjoint of forward model.
* knvlev -- # of vertical levels
* qpeta -- pressure at eta levels
* ptop -- obs top - level pressure (in Pascal)
* pbtm -- obs bottom -level pressure (in Pascal)
* kfirst -- Initialization flag.
* When jfirst=1, calc peta,pres, and vmid
* plat -- Latitude of obs. (=ROBHDR(NMCLAT,obsindex)
* klat -- Latitude index (=MOBHDR(NCMTLA,obsindex)
* knulout -- Output unit index
* cvar -- Model variable name
* pstate(knflev) -- State profile for possible use in CH_GENOPER
* CDBGTYP -- 'HR' for high resolution (trial field) grid
* 'BG' for low resolution (rebm) grid
* kobstyp -- Straight summation if kobstyp=4
*
* Output pvtotal -- partial (or total column) value between
* pressure levels ptop and pbtm when kmod=0
* pveta(knvlev) -- Array for adjoint of forward model when kmod=1
* ktot -- Flag indicating of pvtotal (or pveta) was
* correctly produced (1 for yes)
*
* Local common block
* qpres -- pressures at analysis layer boundaries
* vh -- Storage array for elements contributing
* to the forward model.
*
*Comments:
*
* 1. VH is an intermediate work array used for setting the forward model array ZH.
*
* Description of i,j in vh(i,j):
*
* i: eta/analysis level index (index for eta, qpeta and pveta)
* j: layer index (index for layer between pressures qpres(j) & qpres(j+1))
*
* 2. Analysis layer boundaries set midpoint in alog(p) between analysis levels
*
* N.B.: exp(0.5*(alog(x)+alog(y)) = sqrt(x*y)
*
* 3. Averaring in alog(P).
*
*---------------------------------------------------------------------
#endif
C
C* Global variables
C
#include "pardim.cdk"
#include "comdim.cdk"
#include "comdimo.cdk"
#include "comgem.cdk"
#include "comcst.cdk"
#include "comphy.cdk"
#include "comoabdy.cdk"
#include "comoahdr.cdk"
#include "comoba.cdk"
#include "comnumbr.cdk"
#include "cvcord.cdk"
#include "comstate.cdk"
#include "comvarqc.cdk"
#include "comlun.cdk"
#include "commvohr.cdk"
C
C Common block used only in this routine
C
INTEGER ivh
PARAMETER (ivh=2)
REAL*8 vh(jpnflev,jpnflev)
REAL*8 qpres(jpnflev+1)
COMMON /VERTING/ qpres,vh
C
C* Declaration of local variables
C
INTEGER J,JK,ILMAX2,ILMIN2
INTEGER ILMIN, ILMAX
REAL*8 zet, zp, zp1, zp2, zp3, zr1, zr2, zr3,zsum,zhwhm
REAL*8 zdumeta,zwin,zh(jpnflev),zhp(jpnflev),zg(jpnflev)
INTEGER ch_igetmodlev
C
EXTERNAL ch_igetmodlev
C
C* Determine P boundaries of analysis layers and save weights for
C use in setting innovation operator array.
C
C N.B.: Boundaries of layers set to mid-point
C
if (kfirst.eq.1) then
C
C Initialize innovation operator element array to zero
C
vh(:,:)=0.0D0
C
C Calculate layer boundaries
C
qpres(1)=qpeta(1)
qpres(knflev+1)= qpeta(knflev)
C
DO JK = 2, KNFLEV
qpres(jk)=sqrt(qpeta(jk-1)*qpeta(jk))
END DO
end if
C
C* Initialize innovation operator arrays to zero
C
C ZH: Initial innovation model array (other than conversion constants)
C ZHP: Part of innovation operator not related to resolution
C ZG: Final innovation operator
C
zh(:)=0.0D0
zhp(:)=0.0D0
zg(:)=0.0D0
C
C* Verify vertical range
C
ktot=1
C
if ((ptop.le.qpeta(1).and.pbtm.le.qpeta(1)).or.ptop.ge.pbtm*0.99.or.
& (ptop.ge.qpeta(knflev).and.pbtm.ge.qpeta(knflev))) then
if (kmod.eq.0) then
pvtotal=0.0D0
else
pveta(:)=0.0D0
end if
ktot=0
return
end if
C
if (ptop.le.qpeta(1)*1.01) ptop=qpeta(1)*1.001
if (pbtm.gt.qpeta(knflev)*0.99) pbtm=qpeta(knflev)
C
C* Find the range of vertical levels over which to perform the integration
C and set innovation operator ZH over this range.
C
ilmin=1
ilmax=knflev
if (ptop.le.qpres(1)*1.01.and.pbtm.ge.qpeta(knflev)*0.99) then
C
C Total column integration part
C
do j = 1,knflev
zh(j)=log(qpres(j+1)/qpres(j))
zhp(j)=1.0
end do
C
else
C
C Partial column integration part (special treatment at boundaries)
C
C Identify analysis layer boundaries just above and below obs layer.
C
ilmin = CH_IGETMODLEV(ptop, qpres, 'top', knflev+1)
ilmax = CH_IGETMODLEV(pbtm, qpres, 'btm', knflev+1)
C
if (ilmin.eq.ilmax-1) then
C
C Entire obs layer within one analysis layer
C
j=ilmin
if (j.lt.2) j=2
if (j.gt.knflev-1) j=knflev-1
zp1=log(qpeta(j-1))
zp2=log(qpeta(j))
zp=log(ptop*pbtm)/2.0
zr1=(zp-zp2)/(zp1-zp2)
zr2=(zp-zp1)/(zp2-zp1)
C
zh(j-1)=log(pbtm/ptop)*zr1
zh(j)=log(pbtm/ptop)*zr2
zhp(j-1)=zr1
zhp(j)=zr2
ilmin=j-1
ilmax=j
C
else
C
C Determine terms from the inner layers (excluding the lower and upper
C boundary layers when these layers not covering entire analyses layers)
C
if (pbtm.ge.qpeta(knflev)*0.99) then
ilmax2=knflev
else
ilmax2=ilmax-1
end if
if (ptop.le.qpres(1)*1.01) then
ilmin=1
ilmin2=ilmin
else
ilmin2=ilmin
end if
if (ilmin2.le.ilmax2) then
do j = ilmin2,ilmax2
zh(j)=log(qpres(j+1)/qpres(j))
zhp(j)=1.0
end do
end if
C
C Determine terms from the lower and upper boundary layers
C when these layers do not cover entire analyses layers.
C
if (pbtm.lt.qpeta(knflev)*0.99) then
C
j=ilmax+1
if (j.gt.knflev) j=knflev
if (j.lt.3) j=3
zp1=log(qpeta(j-2))
zp2=log(qpeta(j-1))
zp3=log(qpeta(j))
zp=log(qpres(ilmax)*pbtm)/2.0
zr1=(zp-zp2)*(zp-zp3)/(zp1-zp2)/(zp1-zp3)
zr2=(zp-zp1)*(zp-zp3)/(zp2-zp1)/(zp2-zp3)
zr3=(zp-zp2)*(zp-zp1)/(zp3-zp2)/(zp3-zp1)
C
zh(j-2)=zh(j-2)+log(pbtm/qpres(ilmax))*zr1
zh(j-1)=zh(j-1)+log(pbtm/qpres(ilmax))*zr2
zh(j)=zh(j)+log(pbtm/qpres(ilmax))*zr3
zhp(j-2)=zhp(j-2)+zr1
zhp(j-1)=zhp(j-1)+zr2
zhp(j)=zhp(j)+zr3
ilmax=j
C
end if
C
if (ptop.gt.qpres(1)*1.01) then
C
j=ilmin-1
if (j.lt.1) j=1
if (j.gt.knflev-2) j=knflev-2
zp1= log(qpeta(j))
zp2= log(qpeta(j+1))
zp3= log(qpeta(j+2))
zp = log(qpres(ilmin)*ptop)/2.0
zr1=(zp-zp2)*(zp-zp3)/(zp1-zp2)/(zp1-zp3)
zr2=(zp-zp1)*(zp-zp3)/(zp2-zp1)/(zp2-zp3)
zr3=(zp-zp2)*(zp-zp1)/(zp3-zp2)/(zp3-zp1)
C
zh(j)=zh(j)+log(qpres(ilmin)/ptop)*zr1
zh(j+1)=zh(j+1)+log(qpres(ilmin)/ptop)*zr2
zh(j+2)=zh(j+2)+log(qpres(ilmin)/ptop)*zr3
zhp(j)=zhp(j)+zr1
zhp(j+1)=zhp(j+1)+zr2
zhp(j+2)=zhp(j+2)+zr3
ilmin=j
if (ilmax.lt.j+2) ilmax=j+2
C
end if
if (ilmin.gt.ilmax-2) ilmin=ilmax-2
end if
end if
C
zg(1:knflev)=zh(1:knflev)
if (kobstyp.eq.4) zg(1:knflev)=zhp(1:knflev)
C
if (CDBGTYP.EQ.'BG'.and.kgenoper.eq.1.and.kobstyp.ne.4) then
C
C* Determine generalized innovation operator.
C Applicable only to increments.
C
zwin=0.01
CALL CH_GENOPER(plat,klat,knulout,qpeta,1,pstate,
1 cvar,zwin,zh,zhp,zg,knflev)
end if
C
if (kmod.eq.0) then
C
C* Forward model (innovation) calc.
C
pvtotal=0.0D0
pvtotal=dot_product(pveta(ilmin:ilmax),zg(ilmin:ilmax))
if (kobstyp.ne.4) pvtotal=pvtotal/log(pbtm/ptop)
c DO JK = ilmin,ilmax
c pvtotal = pvtotal + pveta(JK)*zg(jk)/log(pbtm/ptop)
c END DO
C
else
C
C* Adjoint of forward model calc.
C
pveta(:)=0.0D0
pveta(ilmin:ilmax)=pvtotal*zg(ilmin:ilmax)
if (kobstyp.ne.4) pveta(ilmin:ilmax)=pveta(ilmin:ilmax)/log(pbtm/ptop)
c DO JK=ilmin,ilmax
c pveta(jk) = pvtotal*zg(jk)/log(pbtm/ptop)
c END DO
C
end if
C
RETURN
END