SUBROUTINE CH_oda_Htr(CDBGTYP),7
C
IMPLICIT NONE
C
C* Declaration of arguments
C
CHARACTER*(*) CDBGTYP
C
*---------------------------------------------------------
#if defined (DOC)
*
***s/r CH_JOCALC - Computation of Jo contribution and the residuals
* for all observations of the TR (constituents) family.
*
*Author : Y. J. Rochon and Y. Yang, AQRB/MSC, July 2005
* Original module name: ch_jocalc
*
*Revision:
* Y.J. Rochon, ARQX/EC, Feb 2007
* - Addition of IREJECT flag and
* SUM(MOBDATA(NCMASS,IDATA:IDATEND)).NE.0 condition
* - Added option of applying day/night/near-terminator
* obs acceptance criteria
* Y.J. Rochon ARQX, Apr 2008
* - Addition of obs simulation option with LSIMOB=.TRUE.
* 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
* Y.J. Rochon ARQI Feb 2013
* - Added iobstyp=4 option
*
* -------------------
*
** Purpose: Computation of Jo contributions and the residuals
* for all observations of the TR (constituents) family.
*
*Arguments:
*
* INPUT
*
* CDBGTYP: 'HR' for high resolution (trial field) grid (for gom*hr)
* 'BG' for low resolution (rebm) grid
*
* OUTPUT
*
*
* OTHER:
*
* IOBSTYP......Flag for observation handling and forward model selection.
* defined 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:
*
*
* 1) This routine must be quasi-identical to CH_SETFGE.
* When the call to a new TLM is added to CH_JOCALC,
* then it should also be added to CH_SETFGE.
*
* 2) Other output: ROBDATA8(NCMOMN,*), ROBDATA8(NCMOMA,*),
* ROBDATA8(NCMOMI,*), and updated MOBDATA(NCMASS,*)
* and MOBDATA(NCMXTR,*)
*
*-----------------------------------------------------------
#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 "commvog.cdk"
#include "commvohr.cdk"
#include "comcst.cdk"
#include "comct0.cdk"
#include "comvarqc.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,ILMAX,ILAT
INTEGER IDIM
PARAMETER (IDIM=500) ! Must be >= JPNFLEV
REAL*8 ZOBSLEV(IDIM),ZOBSLEV2(IDIM),ZTRIAL(IDIM)
REAL*8 ZLAT,ZSTATE(JPNFLEV),ZVTR(IDIM),ZLON,ZTODEG
REAL*8 ZPRESS(JPNFLEV),ZTEMP(JPNFLEV),ZALT(JPNFLEV)
REAL*8 ZVTR2(IDIM),ZTRIAL2(IDIM),ZOER,ZDUM(JPNFLEV)
INTEGER ITRCODE,ICOND(IDIM)
INTEGER IC,INUMS,INUM,IREJECT,IKERN
INTEGER CH_KGETPOS
C
EXTERNAL CH_KGETPOS
C
C Note on loops:
C
C J: 1 to NFILES : Obs family counter for CMA data arrays
C JOBS: IBEGIN1 to ILAST1 : Obs report counter within family
C J1: 1 to INUM : Obs (profile) counter within report
C INUM=1 for report with single obs profile.
C
C One obs can consist of one or more obs elements.
C
C* Initialization
C
istart=0
ZTODEG=180./RPI
C
C* Number of background/increment vertical levels
C
ILMAX = NFLEV
IF (CDBGTYP.eq.'HR'.or.CDBGTYP.eq.'hr') ILMAX=NLEVTRL
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 (profiles) 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_Htr: Level inconsistency.'
CYCLE
END IF
C
C Obtain obs type to identify appropriate forward model (or TLM).
C
IOBSTYP = MOBDATA(NCMCORD1,IDATA)
C
IF (IOBSTYP.NE.1.AND.IOBSTYP.NE.2.AND.
& IOBSTYP.NE.3.AND.IOBSTYP.NE.4) CYCLE
C
C Obtain latitude and longitude of obs report
C
ZLAT=ROBHDR(NCMLAT,JOBS)
ILAT=MOBHDR(NCMTLA,JOBS)
ZLON=ROBHDR(NCMLON,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
END IF
C
C* Identify background/increment arrays at obs lat/long location
C
ZSTATE(1:ILMAX)=0.0
I1=1+IPOS*ILMAX
I2=ILMAX+IPOS*ILMAX
if (CDBGTYP .eq. 'HR' .or. CDBGTYP .eq. 'hr') then
zvtr(1:ILMAX) = GOMOBSHR(I1:I2,iobs)
if (iobsnmb.eq.nvnumb(58)) zvtr2(1:ILMAX) =
& GOMOBSHR(I1+ILMAX:I2+ILMAX,iobs)
ztemp(1:ILMAX)=GOMTHR(1:ILMAX,IOBS)
zpress(1:ILMAX)=RPPOBSHR(1:ILMAX,IOBS)
else
zvtr(1:ILMAX) = GOMOBS(I1:I2,iobs)
if (iobsnmb.eq.nvnumb(58)) zvtr2(1:ILMAX) =
& GOMOBS(I1+ILMAX:I2+ILMAX,iobs)
zstate(1:ILMAX)=GOMOBSG(I1:I2,iobs)
ztemp(1:ILMAX)=GOMTG(1:ILMAX,IOBS)
zpress(1:ILMAX)=RPPOBS(1:ILMAX,IOBS)
end if
C
C* Initialize ROBDATA8 to zero at obs location
C
ROBDATA8(NCMOMA,IDATA:IDATEND)=0.0D0
ZTRIAL(1:INUMS)=0.0D0
ZTRIAL2(1:INUMS)=0.0D0
C
IREJECT=1
IF (SUM(MOBDATA(NCMASS,IDATA:IDATEND)).NE.0) THEN
C
IREJECT=0
C
C Apply day/night/near-terminator criterion if requested
C For acceptance, point must be either under day or
C night condition for both the obs time and analysis
C time.
C
IF (daynightp(jlt).gt.0.0.and.
& (CDBGTYP.EQ.'HR'.or.CDBGTYP.EQ.'hr')) THEN
C
IF (MOBDATA(NCMVCO,IDATA).NE.0) THEN
IF (MOBDATA(NCMVCO,IDATA).EQ.2) THEN
ZALT(:)=-1.0 ! Obs coord. not altitude
ELSE
C Obs vert. coord. is altitude (m)
ZALT(1:INUMS)=
& ROBDATA8(NCMPPP,IDATA:IDATEND)
END IF
call ch_termcond(zlat*ztodeg,zlon*ztodeg,
& MOBHDR(NCMDAT,JOBS),MOBHDR(NCMETM,JOBS),
& INUMS,ZOBSLEV,ZALT,daynightp(jlt),
& zpress(1:ILMAX),
& GOMGZHR(1:ILMAX,IOBS)/RG,
& ILMAX,NULOUT,ICOND)
WHERE (ICOND(1:INUMS).EQ.0)
MOBDATA(NCMASS,IDATA:IDATEND)=0
MOBDATA(NCMFLG,IDATA:IDATEND)=
& MOBDATA(NCMFLG,IDATA:IDATEND)+131072+512
C ! Same flag as for QCvar rejection
ENDWHERE
IF (SUM(MOBDATA(NCMASS,IDATA:IDATEND)).EQ.0)
& IREJECT=1
END IF
END IF
C
C Apply unit conversion factor and variable
C transformations to ensure consistency of F(x)/Hx units
C with obs units.
C
IF (IREJECT.EQ.0) THEN
CALL CH_CONVERT(IOBSNMB,ITRCODE,speciesm(jlt),
& CNAMANAL(JLT),ZVTR,ZSTATE,ZTEMP,ZPRESS,ILMAX,
& CDBGTYP,0,NLOGTR,IREJECT)
IF (IREJECT.EQ.1) THEN
WRITE(NULOUT,*)
& 'CH_ods_Htr: Obs rejected via CH_CONVERT: ',
& CNAMANAL(JLT)
MOBDATA(NCMASS,IDATA:IDATEND)=0
MOBDATA(NCMFLG,IDATA:IDATEND)=
& MOBDATA(NCMFLG,IDATA:IDATEND)+131072+512
C ! Same flag as for QCvar rejection
END IF
END IF
END IF
IF (IREJECT.EQ.1) CYCLE
C
C* If not rejected, select and apply forward model
C "F(x)" (or TLM "Hx") for obs profile (with all
C elements at same lat/long)
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,
& ILMAX,ZOBSLEV,ZPRESS,ZVTR,ZVTR2,
& ROBDATA(NCMDWN,IDATA:IDATEND),
& ZTRIAL,ZTRIAL2,0,IDIM)
C
else
C
CALL CH_VPROF(MOBDATA(NCMASS,IDATA:IDATEND),
& MOBDATA(NCMXTR,IDATA:IDATEND),
& ROBDATA(NCMLYR,IDATA:IDATEND),INUMS,
& ILMAX,ZOBSLEV,ZPRESS,ZVTR,ZTRIAL,0,IDIM,IKERN)
C
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),
& ZTRIAL,ZDUM,
& CDBGTYP,ZVTR,zobslev,zobslev2,
& zpress,ilmax,zlat,ilat,zstate,
& CNAMANAL(JLT),0,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),
& ZTRIAL,ZDUM,
& CDBGTYP,ZVTR,zobslev,zobslev2,
& zpress,ilmax,zlat,ilat,zstate,
& CSTNID(JOBS),CNAMANAL(JLT),0,IKERN)
C
END IF
C
C* Update flags
C
IF (.NOT.LSIMOB.AND.(CDBGTYP.eq.'HR'.or.CDBGTYP.eq.'hr')) THEN
WHERE (MOBDATA(NCMXTR,IDATA:IDATEND).eq.2)
& MOBDATA(NCMFLG,IDATA:IDATEND)=
& MOBDATA(NCMFLG,IDATA:IDATEND)+262144+512
WHERE (MOBDATA(NCMXTR,IDATA:IDATEND).eq.1)
& MOBDATA(NCMFLG,IDATA:IDATEND)=
& MOBDATA(NCMFLG,IDATA:IDATEND)+2048
END IF
C
IF (.NOT.LSIMOB ) THEN
C
C* Store Hdx into CMA instead of calculating difference and divide
C by std. dev. since these will be done in separate routines
C
WHERE (MOBDATA(NCMASS,IDATA:IDATEND).EQ.1.and.
& MOBDATA(NCMXTR,IDATA:IDATEND).eq.0)
ROBDATA8(NCMOMA,IDATA:IDATEND)= ztrial(1:INUMS)
ENDWHERE
ELSE
C
C* Store simulated/forecast value as observations
C
WHERE (MOBDATA(NCMASS,IDATA:IDATEND).EQ.1.and.
& MOBDATA(NCMXTR,IDATA:IDATEND).eq.0)
ROBDATA8(NCMOMA,IDATA:IDATEND)=0.0D0
ROBDATA8(NCMVAR,IDATA:IDATEND)=ztrial(1:INUMS)
ENDWHERE
END IF
C
END DO ! (J1)
END DO ! (JOBS)
END IF
END DO ! (NFILES)
C
RETURN
END