SUBROUTINE CH_VCOLM(KNUM,KFLAG,KFLAG2,PINOUT,PROF, 4,2
1 CDBGTYP,pvtr,pobslev,pobslev2,
1 pressa,knflev,plat,klat,pstate,
1 cdstnid,cdvar,kmod,KKERN)
C
IMPLICIT NONE
C
C* Declaration of arguments
C
CHARACTER*(*) CDBGTYP,CDSTNID
CHARACTER*(*) cdvar
INTEGER knflev,kmod,knum,klat
INTEGER KFLAG(knum),KFLAG2(knum),KKERN
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_VCOLM -- Control module for forward/TLM model or adjoint model calculations
* related to observations of partial or total column amounts.
*
*Author : Y.J. Rochon and Y. Yang AQRB/MSC July 2005
*
*Revision:
*
** Purpose: Control module for forward/TLM model or adjoint model calculations
* related to observations of partial or total column amounts.
*
*Arguments:
*
* Input pvtr(nvlev) -- background/increment values at eta levels when kmod=0
* pinout(knum) -- Column amount (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(NCMTLA,obsindex)
* cdvar -- Model variable name
* pstate(knflev) -- State profile for possible use in CH_GENOPER
* (see CH_VERTINTG)
* 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
* kkern -- Use of averaging kernel
* 0 for no, position index for yes
*
* Output pinout(knum) -- Total or partial column amounts 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"
#include "commatrix.cdk"
C
INTEGER J,J1,ITOT,KFIRST
REAL*8 ZTOT,ZPTOP,ZPBTM,zwin
REAL*8 zh(knum,knflev),zhp(knum,knflev),zhw(knflev),zhpw(knflev)
REAL*8 zg(knflev)
C
C Total or partial column amounts.
C
C Loop over observation elements in a profile
C (with common lat-long)
C
if (kmod.eq.0) pinout(:)=0.0
C
C First determine integration weights and flags
C
zh(:,:)=0.0
zhp(:,:)=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).or.kkern.gt.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.GE.ZPBTM) THEN
write(nulout,*) 'CH_VCOLM: Boundary problem: skip data'
write(nulout,*) 'ZPTOP.GE.ZPBTM ',ZPTOP,ZPBTM
kflag(j)=0
c call abort3d(nulout,'CH_VCOLM: Boundary problem')
END IF
C
C Calculate innovation operator terms
C
CALL CH_VERTINTG(pvtr, zptop,zpbtm,
1 pressa,knflev,kfirst,pstate,
1 nulout,cdvar,itot,
1 zhw(1:knflev),zhpw(1:knflev))
if (itot.eq.0) kflag(j)=0
kfirst=2
if (kkern.gt.0) then
C
C Incorporate averaging kernels
C
do j1=1,knum
zh(j1,1:knflev)=zh(j1,1:knflev)+zhw(1:knflev)*ravgkern(j1,j,kkern)
zhp(j1,1:knflev)=zhp(j1,1:knflev)+zhpw(1:knflev)*ravgkern(j1,j,kkern)
end do
else
zh(j,1:knflev)=zhw(1:knflev)
zhp(j,1:knflev)=zhpw(1:knflev)
end if
end if
end do
C
C Apply observation, TLM or adjoint operator
C
DO J=1,knum
if (kflag(j).EQ.1.AND.kflag2(j).EQ.0) then
if (CDBGTYP.EQ.'BG'.and.ngenoper.eq.1) then
c write(nulout,*) j
c write(nulout,*) 'zhp ',zhp(j,1:40)
C
C* Determine generalized innovation operator.
C Applicable only to increments.
C
zwin=0.01
CALL CH_GENOPER(plat,klat,nulout,pressa,1,pstate,
1 cdvar,zwin,zh(j,1:knflev),zhp(j,1:knflev),zg,knflev)
else
zg(1:knflev)=zh(j,1:knflev)
end if
C
if (kmod.eq.0) then
C
C* Forward model (innovation) calc.
C
c if (CDBGTYP.EQ.'BG'.and.ngenoper.eq.1) then
c write(nulout,*) 'pstate ',pstate(1:40)
c write(nulout,*) 'zhp ',zhp(j,1:40)
c write(nulout,*) 'zg ',zg(1:40)
c end if
pinout(j)=dot_product(pvtr,zg)
C
else
C
C* Adjoint of forward model calc.
C
prof(1:knflev)=prof(1:knflev)+pinout(j)*zg(1:knflev)
C
end if
end if
END DO
c if (CDBGTYP.EQ.'BG'.and.ngenoper.eq.1) call abort3d(nulout,'DONE')
C
RETURN
END