SUBROUTINE CH_VAVG(KNUM,KFLAG,KFLAG2,PINOUT,PROF, 4,1
1 CDBGTYP,pvtr,pobslev,pobslev2,
1 pressa,knflev,plat,klat,pstate,
1 cdvar,kmod,kobstyp)
C
IMPLICIT NONE
C
C* Declaration of arguments
C
CHARACTER*(*) CDBGTYP
CHARACTER*(*) cdvar
INTEGER knflev,kmod,knum,klat
INTEGER KFLAG(knum),KFLAG2(knum),kobstyp
REAL*8 pvtr(knflev),pstate(knflev),pinout(knum),prof(knflev)
REAL*8 plat,pobslev(knum),pobslev2(knum),pressa(knflev)
C
*---------------------------------------------------------------------
#if defined (DOC)
*
***s/r CH_VAVG -- Control module for forward model or adjoit model calculations
* related to observations of columnar/layer averages.
*
*Author : Y.J. Rochon and Y. Yang AQRB/MSC July 2005
*
*Revision:
*
** Purpose: Control module for forward model or adjoint model calculations
* related to observations of columnar/layer averages.
*
*Arguments:
*
* Input pvtr(nvlev) -- background values at eta levels when kmod=0
* pinout(knum) -- Layer averages (divided by std. dev.)
* when kmod=1
* kmod -- Flag indicating purpose of call:
* 0: Use as forward model
* 1: Use as adjoint of forward model.
* knvlev -- # of analysis vertical levels
* plat -- Latitude of obs. (=ROBHDR(NMCLAT,obsindex)
* klat -- Latitude index (=MOBHDR(NCMLAT,obsindex)
* cdvar -- Model variable name
* pstate(knflev) -- State profile for possible use in CH_GENOPER
* (see CH_VERTAVG)
* CDBGTYP -- 'HR' for high resolution (trial field) grid
* 'BG' for low resolution (rebm) grid
* knum -- # of obs elements in the obs profile
* kflag(knum) -- MOBDATA(NCMASS,*) for obs elements
* kflag2(knum) -- MOBDATA(NCMXTR,*) for obs elements
* prof(knflev) -- Initial GOMOBS segment when kmod=1
* kobstyp -- Straight summation if kobstyp=4
*
* Output pinout(knum) -- Layer averages when kmod=0
* prof(knflev) -- Updated GOMOBS segment when kmod=1
* kflag(knum) -- MOBDATA(NCMASS,*) for obs elements
* kflag2(knum) -- MOBDATA(NCMXTR,*) for obs elements
*
* Others ztot -- partial (or total column) value between
* pressure levels ptop and pbtm when kmod=0
* itot -- Flag indicating of pinout(j) (or pvtr) was
* correctly produced (1 for yes)
*
*Comments:
*
*---------------------------------------------------------------------
#endif
C
C* Global variables
C
#include "pardim.cdk"
#include "comdim.cdk"
#include "comlun.cdk"
#include "comgem.cdk"
#include "comchem.cdk"
C
INTEGER J,J1,ITOT,KFIRST
REAL*8 ZTOT,ZPTOP,ZPBTM
C
C Loop over observation elements in a profile
C (with common lat-long)
C
if (kmod.eq.0) pinout(:)=0.0
C
kfirst=1
DO J=1,knum
C
C Check for partial columns which extend above the top analysis level
C or are entirely below surface.
C
if (kflag(j).EQ.1.AND.kflag2(j).EQ.0) then
if (POBSLEV2(J).lt.PRESSA(1)*10.0.and.POBSLEV(J).lt.PRESSA(1)) then
kflag2(j)=1
else if (POBSLEV2(J).gt.PRESSA(KNFLEV).and.POBSLEV(J).gt.PRESSA(KNFLEV)) then
kflag(j)=0
kflag2(j)=2
end if
end if
C
if (kflag(j).EQ.1.AND.kflag2(j).EQ.0) then
C
C Set range of vertical levels
C
ZPTOP = POBSLEV(J)
ZPBTM = POBSLEV2(J)
if (ZPBTM.gt.PRESSA(KNFLEV)) ZPBTM=PRESSA(KNFLEV)
IF (ZPTOP.EQ.ZPBTM.OR.ZPTOP.GT.ZPBTM) THEN
call abort3d(nulout,'CH_VAVG: Boundary problem')
END IF
C
C Perform the integration
C
CALL CH_VERTAVG(CDBGTYP, pvtr, pinout(j),zptop,zpbtm,
1 pressa,knflev,kfirst,plat,klat,pstate,
1 nulout,cdvar,ngenoper,itot,kmod,kobstyp)
kfirst=2
C
if (itot.eq.0) then
kflag(j)=0
else if (kmod.eq.0) then
C
C Forward/TLM model calc. - output is 'pinout'
C
else if (kmod.eq.1) then
C
C Adjoint of TLM model calc.
C
do j1=1,knflev
prof(j1)=prof(j1)+pvtr(j1)
end do
end if
end if
END DO
C
RETURN
END