SUBROUTINE CH_VERTINTG(pveta, ptop, pbtm, 10,2
1 qpeta, knflev, kfirst, pstate,
1 knulout,cvar,ktot,zh,zhp)
C
IMPLICIT NONE
C
C* Declaration of arguments
C
CHARACTER*(*) cvar
INTEGER knflev,knulout,kfirst,ktot
REAL*8 pveta(knflev),pstate(knflev),qpeta(knflev)
REAL*8 zh(knflev),zhp(knflev)
REAL*8 pbtm,ptop
C
*---------------------------------------------------------------------
#if defined (DOC)
*
***s/r CH_VERTINTG -- Vertical integration model to calculate partial (or total)
* column value of model state profile 'pveta' or used for
* adjoint calculations.
*
*Author : Y. Yang, based on Y. Rochon and S. Ren's program
*Revision:
* Yves J. Rochon, ARQX/MSC Nov 2004
* - Code strealining and changes for call and use
* of generalized innovation operator routine (ch_genoper)
* - Adapted for use with both the forward and adjoint models
* Yves J. Rochon, ARQX/MSC March 2007
* - Minor correction of text.
* Yves J. Rochon, ARQI Dec 2012
* - Reduced to setting of innovation operator terms
*
** Purpose: Calculate innovation operator terms required for vertical
* integration w.r.t. pressure 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. Layer values are set to be the values interpolated
* to the mid-point in P within the various layers. Interpolation
* in P is done quadratically. (Some of above comments repeated below.)
*
*
*Arguments:
*
* Input pveta(nvlev) -- background values at eta levels when kmod=0
* 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
* knulout -- Output unit index
* cvar -- Model variable name
* pstate(knflev) -- State profile for possible use in CH_GENOPER
*
* Output
* zh(knflev) -- Initial innovation model array
* (other than conversion constants)
* zhp(knflev) -- Part of innovation operator not
* related to resolution
*
* 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. Since integration is in P (and not alog(P)), value of analysis variables
* are interpolated to middle of analysis layers in P.
*
*---------------------------------------------------------------------
#endif
C
C Common block used only in this routine
C
#include "pardim.cdk"
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
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
C
C Interpolation of pveta to mid-layer level in P using
C second degree Lagrangian interpolator.
C N.B.: Integration is w.r.t. P
C
C Calculating for jk=1
C
zp1= qpeta(1)
zp2= qpeta(2)
zp3= qpeta(3)
zp = (qpres(2)+qpres(1))/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 vmid(1)=pveta(1)*zr1+pveta(2)*zr2
c + +pveta(3)*zr3
vh(1,1)=zr1
vh(2,1)=zr2
vh(3,1)=zr3
C
DO JK=2,knflev-1
zp1=qpeta(jk-1)
zp2=qpeta(jk)
zp3=qpeta(jk+1)
zp=(qpres(jk+1)+qpres(jk))/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 vmid(jk)=pveta(jk-1)*zr1+pveta(jk)*zr2
c + +pveta(jk+1)*zr3
vh(jk-1,jk)=zr1
vh(jk,jk)=zr2
vh(jk+1,jk)=zr3
ENDDO
C
C Calculating for jk=knflev
C
zp1= qpeta(knflev-2)
zp2= qpeta(knflev-1)
zp3= qpeta(knflev)
zp = (qpres(knflev+1)+qpres(knflev))/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 vmid(knflev)=pveta(knflev-2)*zr1+pveta(knflev-1)*zr2
c + +pveta(knflev)*zr3
vh(knflev-2,knflev)=zr1
vh(knflev-1,knflev)=zr2
vh(knflev,knflev)=zr3
C
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
zh(:)=0.0D0
zhp(:)=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
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 jk = 1,knflev
do j=max(1,jk-ivh),min(knflev,jk+ivh)
zh(jk)=zh(jk)+(qpres(j+1)-qpres(j))*vh(jk,j)
zhp(jk)=zhp(jk)+vh(jk,j)
end do
end do
C
else
C
C Partial column integration part (special treatment at boundaries)
C
C Identify analysis layer boundaries just within 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.3) j=3
if (j.gt.knflev) j=knflev
zp1=qpeta(j-2)
zp2=qpeta(j-1)
zp3=qpeta(j)
zp=(ptop+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)=(pbtm-ptop)*zr1
zh(j-1)=(pbtm-ptop)*zr2
zh(j)=(pbtm-ptop)*zr3
zhp(j-2)=zr1
zhp(j-1)=zr2
zhp(j)=zr3
ilmin=j-2
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 jk = ilmin2,ilmax2
do j=max(1,jk-ivh),min(knflev,jk+ivh)
zh(jk)=zh(jk)+(qpres(j+1)-qpres(j))*vh(jk,j)
zhp(jk)=zhp(jk)+vh(jk,j)
end do
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=qpeta(j-2)
zp2=qpeta(j-1)
zp3=qpeta(j)
zp=(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)+(pbtm - qpres(ilmax))*zr1
zh(j-1)=zh(j-1)+(pbtm - qpres(ilmax))*zr2
zh(j)=zh(j)+(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= qpeta(j)
zp2= qpeta(j+1)
zp3= qpeta(j+2)
zp = (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)+(qpres(ilmin)-ptop)*zr1
zh(j+1)=zh(j+1)+(qpres(ilmin)-ptop)*zr2
zh(j+2)=zh(j+2)+(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
RETURN
END