SUBROUTINE CH_oda_HTtr,8
C
IMPLICIT NONE
C
C
*---------------------------------------------------------
#if defined (DOC)
*
***s/r CH_oda_HTtr - Apply adjoint of forward models (or TLM) for constituent obs
* for use in calculating the gradient of Jo
*
*Author : Y.J. Rochon and Y. Yang, AQRB/MSC, July 2005
* (original module name: ch_adjoint)
*
*Revision:
* Y.J. Rochon, ARQX/EC, Feb 2007
* - Addition of SUM(MOBDATA(NCMASS,IDATA:IDATEND)).NE.0 condition
* and IREJECT flag.
* Y.J. Rochon ARQX, June 2008
* - Addition of Doppler wind operator CH_DOPWIND
* (iobsnmb.eq.nvnumb(58))
* Y.J. Rochon ARQX Aug 2010
* - Added possible use of avg kernel matrices
* - Reset ZVAR to ROBDATA8(NCMOMI,*) as done in other
* oda_HT* modules
* Y.J. Rochon ARQI Feb 2013
* - Added iobstyp=4 option
**
* -------------------
*
** Purpose: Apply adjoint of forward models (or TLM) for constituent obs
* for use in calculating the gradient of Jo. Required output
* is an updated GOMOBS field.
*
*Arguments:
*
* Input:
*
* Other:
*
* IOBSTYP......Flag for observation handling and forward/adjoint
* model selection. Provided by MOBHDR(NCMCORD1, IOBS).
* Set in CH_OBSTYP called by CH_RBBRPDATA.
* 1: Observation to be treated as point by point
* profile
* 2: Observation to be treated as piecewise
* constant profile (layer averages).
* 3: Observation to be treated as total or
* partial column amounts
* 4: Observation to be treated as piecewise sum
*
*Comments:
*
*-----------------------------------------------------------
#endif
C
C* Global variables
C
#include "pardim.cdk"
#include "comdim.cdk"
#include "comdimo.cdk"
#include "comgem.cdk"
#include "comnumbr.cdk"
#include "comoabdy.cdk"
#include "comoahdr.cdk"
#include "comoba.cdk"
#include "comchem.cdk"
#include "comstate.cdk"
#include "commvo.cdk"
#include "commvo1.cdk"
#include "commvog.cdk"
#include "commvohr.cdk"
#include "comcst.cdk"
#include "cvcord.cdk"
#include "comlun.cdk"
#include "cparbrp.cdk"
C
integer istart
common /istart/istart
C
C* Declaration of local variables
C
INTEGER IOBS,IPOS,I1,I2
INTEGER JDATA,J,IBEGIN,ILAST
INTEGER IOBSNMB, IOBSTYP,IOBSLEV,IIFLAG
INTEGER JOBS, IDATA, IDATEND,J1
INTEGER IBEGIN1, ILAST1
INTEGER JL,JLT,ILAT
REAL*8 ZLAT
INTEGER IDIM
PARAMETER (IDIM=500) ! Must be >= NFLEV
REAL*8 ZOBSLEV(IDIM),ZOBSLEV2(IDIM),zvar(IDIM),zwork(IDIM)
REAL*8 ZSTATE(nflev),ZVTR(IDIM),ZPRESS(NFLEV),ZTEMP(NFLEV)
REAL*8 ZVTR2(IDIM),ZVAR2(IDIM), ZWORK2(IDIM)
INTEGER INUM,INUMS
INTEGER ITRCODE,IREJECT,IKERN
INTEGER CH_KGETPOS
C
EXTERNAL CH_KGETPOS
C
C Initialization
C
istart=0
C
C* Loop over obs familes.
C
DO J=1,NFILES
C
C Check for target family
C
IF (CFAMTYP(J).EQ.'TR'.AND.NBEGINTYP(J).GT.0.AND.
1 NENDTYP(J).GE.NBEGINTYP(J)) THEN
C
C Identify range of observation reports
C
IBEGIN=NBEGINTYP(J)
ILAST=NENDTYP(J)
IBEGIN1 = MOBDATA(NCMOBS,IBEGIN)
ILAST1 = MOBDATA(NCMOBS,ILAST)
C
C Loop over obs reports in a subfamily
C
DO JOBS = IBEGIN1, ILAST1
C
C Loop over obs in a report (normally only one obs in a report).
C
INUM=MOBHDR(NCMNUM,JOBS)
INUMS=MOBHDR(NCMNLV,JOBS)
DO J1=1,INUM
C
C Identify range of elements for an obs in the report
C
IF (J1.EQ.1) THEN
IDATA = MOBHDR(NCMRLN,JOBS)
IF (INUM.GT.1) INUMS=MOBDATA(NCMNUM1,IDATA)
IDATEND = INUMS + IDATA - 1
ELSE
IDATA=IDATA+INUMS
IF (INUM.GT.1) INUMS=MOBDATA(NCMNUM1,IDATA)
IDATEND=INUMS+IDATA-1
END IF
C
C Check observation vertical coordinate and convert
C to pressure when necessary.
C
CALL CH_VOBS_TO_P(NULOUT,JOBS,ZOBSLEV,ZOBSLEV2,
1 IDATA,IDATEND,IOBSLEV,IDIM,IIFLAG)
IF (IIFLAG.NE.0.OR.IOBSLEV.NE.INUMS) THEN
write(nulout,*) 'CH_oda_HTtr: Level inconsistency.'
CYCLE
END IF
C
C Obtain obs type to identify appropriate adjoint model.
C
IOBSTYP = MOBDATA(NCMCORD1,IDATA)
IF (IOBSTYP.NE.1.AND.IOBSTYP.NE.2.AND.
& IOBSTYP.NE.3.AND.IOBSTYP.NE.4) CYCLE
C
C Obtain latitude of obs report
C
ZLAT=ROBHDR(NCMLAT,JOBS)
ILAT=MOBHDR(NCMTLA,JOBS)
C
IOBSNMB = MOBDATA(NCMVNM,IDATA)
IOBS = MOBDATA(NCMOBS,IDATA)
IPOS = MOBDATA(NCMPOS,IDATA)
ITRCODE = MOBDATA(NCMSPEC,IDATA)
C
JLT = CH_KGETPOS(IOBSNMB, ITRCODE,CSTNID(JOBS))
IF (JLT .LT. 0) THEN
write(nulout, *)' Species ', IOBSNMB, ' not to be assimilated!'
write(nulout,*) ITRCODE,CSTNID(JOBS),JOBS
CYCLE
ENDIF
C
C* Identify background/increment arrays at obs lat/long location
C
I1=1+IPOS*NFLEV
I2=NFLEV+IPOS*NFLEV
zstate(1:NFLEV)=GOMOBSG(I1:I2,iobs)
ztemp(1:NFLEV)=GOMTG(1:NFLEV,IOBS)
zpress(1:NFLEV)=RPPOBS(1:NFLEV,IOBS)
C
C* Store required obs/sigma array at obs location.
C
c zvar(1:inums) = ROBDATA8(NCMOMN,IDATA:IDATEND)
c & /ROBDATA8(NCMOER,IDATA:IDATEND)
zvar(1:inums)=ROBDATA8(NCMOMI,IDATA:IDATEND)
zwork(1:NFLEV)=0.0D0
zwork2(1:NFLEV)=0.0D0
C
IREJECT=1
IF (SUM(MOBDATA(NCMASS,IDATA:IDATEND)).NE.0) THEN
C
C* Apply unit conversion and variable transformations to zstate
C (if required) when adjoint/TLM depend on the state.
C
IREJECT=0
zwork(1:NFLEV)=0.0D0
CALL CH_CONVERT(IOBSNMB,ITRCODE,speciesm(jlt),
& CNAMANAL(JLT),ZWORK,ZSTATE,ZTEMP,ZPRESS,NFLEV,
& 'BG',0,NLOGTR,IREJECT)
zwork(1:NFLEV)=0.0D0
END IF
IF (IREJECT.EQ.1) CYCLE
C
C* If not rejected, select and apply adjoint of TLM.
C for obs profile (with all elements at same lat/long)
C
C* Application of adjoint of obs averaging kernel matrix
C multiplication.
C
IKERN=0
IF (MOBHDR(NCMKER,JOBS).gt.0) IKERN=MOBHDR(NCMKER,JOBS)-INUM+J1
C
If (iobstyp.eq.1) then
C
C Point profiles.
C
if (iobsnmb.eq.nvnumb(58)) then
C
C Doppler wind measurement
C
CALL CH_DOPWIND(MOBDATA(NCMASS,IDATA:IDATEND),
& MOBDATA(NCMXTR,IDATA:IDATEND),
& ROBDATA(NCMLYR,IDATA:IDATEND),INUMS,
& NFLEV,ZOBSLEV,ZPRESS,ZVAR,ZVAR2,
& ROBDATA(NCMDWN,IDATA:IDATEND),
& ZWORK,ZWORK2,1,IDIM)
C
else
C
CALL CH_VPROF(MOBDATA(NCMASS,IDATA:IDATEND),
& MOBDATA(NCMXTR,IDATA:IDATEND),
& ROBDATA(NCMLYR,IDATA:IDATEND),INUMS,
& NFLEV,ZOBSLEV,ZPRESS,ZVAR,
& ZWORK,1,IDIM,IKERN)
end if
C
ELSE IF (iobstyp.eq.2.or.iobstyp.eq.4) then
C
C Layer average observation elements.
C
CALL CH_VAVG(INUMS,MOBDATA(NCMASS,IDATA:IDATEND),
& MOBDATA(NCMXTR,IDATA:IDATEND),
& ZVAR,ZWORK,'BG',zvtr,zobslev,zobslev2,
& zpress,nflev,zlat,ilat,zstate,
& CNAMANAL(JLT),1,iobstyp)
C
ELSE IF (iobstyp.eq.3) then
C
C Total or partial column amounts.
C
CALL CH_VCOLM(INUMS,MOBDATA(NCMASS,IDATA:IDATEND),
& MOBDATA(NCMXTR,IDATA:IDATEND),
& ZVAR,ZWORK,'BG',zvtr,zobslev,zobslev2,
& zpress,nflev,zlat,ilat,zstate,
& CSTNID(JOBS),CNAMANAL(JLT),1,IKERN)
C
END IF
C
C* Apply adjoint of unit conversion and variable
C transformations. (Assumed not needed for ZWORK2)
C
CALL CH_CONVERT(IOBSNMB,ITRCODE,speciesm(jlt),
& CNAMANAL(JLT),ZWORK,ZSTATE,ZTEMP,ZPRESS,
& NFLEV,'BG',1,NLOGTR,IREJECT)
C
GOMOBS(I1:I2,IOBS)=GOMOBS(I1:I2,IOBS)+ZWORK(1:NFLEV)
if (iobsnmb.eq.nvnumb(58)) GOMOBS(I1+NFLEV:I2+NFLEV,IOBS)=
& GOMOBS(I1+NFLEV:I2+NFLEV,IOBS)+ZWORK2(1:NFLEV)
C
END DO ! (J1)
END DO ! (JOBS)
ENDIF
END DO ! (NFILES)
C
RETURN
END