SUBROUTINE CH_JOCALC(PJO,KNO,KPJO,CDFAM,CDBGTYP) 1,7
C
IMPLICIT NONE
C
C* Declaration of arguments
C
INTEGER KPJO
INTEGER KNO(KPJO)
REAL*8 PJO(KPJO)
CHARACTER*(*) CDFAM
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
*
*Revision:
* Yulia Nezlin and Y.J. Rochon, April-July, 2005
* - Addition for variational quality control
* 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
*
* KPJO: Max number of data types
* CDFAM: observation family name
* CDBGTYP: 'HR' for high resolution (trial field) grid (for gom*hr)
* 'BG' for low resolution (rebm) grid
*
* OUTPUT
*
* PJO: Total value of Jo for each data type
* KNO: Number of obs element for each data type
*
*
* 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,*)
*
* 3) Usage of ch_jocalc as TLM has been replaced by module ch_oda_Htr.
* Once preproc has been replaced by its ODA equivalent, ch_oda_Htr
* will replace ch_jocalc entirely (ch_jocalc could be removed from use).
*
*-----------------------------------------------------------
#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,JDATA2
INTEGER IOBSNMB, IOBSTYP,IOBSLEV,IIFLAG
INTEGER JOBS, IDATA, IDATEND, J1
INTEGER IBEGIN1, ILAST1
INTEGER JL,JLT,ILMAX,ILAT
REAL*8 ZQCARG, ZJON, ZGAMI,ZHU
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),ZSCL2,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
kno(:)=0
pjo(:)=0.0D0
ZTODEG=180./RPI
C
C* Number of background/increment vertical levels
C* and whether or not 1/2 is multiplied for PJO
C
ZSCL2=0.5
ILMAX = NFLEV
IF (CDBGTYP.eq.'HR'.or.CDBGTYP.eq.'hr') THEN
ILMAX=NLEVTRL
ZSCL2=1.0
END IF
C
C* Loop over obs familes.
C
DO J=1,NFILES
C
C Check for target family
C
IF (CFAMTYP(J).EQ.cdfam.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_JOCALC: Level inconsistency.'
CYCLE
END IF
C
C Obtain obs type to identify appropriate forward model (or TLM).
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 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_JOCALC: 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
C TEMPORARY
C
c IF (LSIMOB) THEN
c IF (trim(CSTNID(JOBS)).EQ.'IRLSPREM') THEN
C
C Mark points contaminated by clouds and/or water content.
C Assumes points ordered from lowest altitude to highest.
C
c DO JDATA=IDATEND,IDATA,-1
c JDATA2=ROBDATA(NCMLYR,JDATA)
C
C Note: 1.E-4 g/m^3 converted to kg/kg
C
c
c IF (GOMQCHR(JDATA2,IOBS).gt.
c & 1.E-4*RDCJ*GOMTHR(JDATA2,IOBS)
c & /(RMD*ZPRESS(JDATA2))) THEN !.OR.
C & GOMFNHR(JDATA2,IOBS).GT.0.05) THEN
C
c DO I1=IDATA,JDATA
c MOBDATA(NCMASS,I1)=0
c MOBDATA(NCMFLG,I1)=524288+2048
c END DO
c EXIT
c END IF
c END DO
C
c ELSE IF (trim(CSTNID(JOBS)).EQ.'MWLSPREM') THEN
C
C Mark points contaminated by clouds and/or water content.
C Assumes points ordered from lowest altitude to highest.
C
c DO JDATA=IDATEND,IDATA,-1
c JDATA2=ROBDATA(NCMLYR,JDATA)
C
C Note: 1.5E-2 g/m^3 converted to kg/kg
C 3.E-4 vmr = 300 ppmv.
C
c ZHU=exp(GOMQHR(JDATA2,IOBS))
c IF (GOMQCHR(JDATA2,IOBS).gt.
c & 1.5E-2*RDCJ*GOMTHR(JDATA2,IOBS)
c & /(RMD*ZPRESS(JDATA2)).OR.
c & ZHU/(1.0-ZHU)*RMD/18.02.GT.3.E-4) THEN
C
c DO I1=IDATA,JDATA
c MOBDATA(NCMASS,I1)=0
c MOBDATA(NCMFLG,I1)=524288+2048
c END DO
c EXIT
c END IF
c END DO
c END IF
c END IF
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
MOBDATA(NCMXTR,IDATA:IDATEND)=0
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
MOBDATA(NCMXTR,IDATA:IDATEND)=0
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 TEMPORARY
C
IF (LSIMOB.AND.(trim(CSTNID(JOBS)).EQ.'IRLSPREM'.OR.
& trim(CSTNID(JOBS)).EQ.'MWLSPREM').AND.
& IOBSNMB.NE.12001) THEN
C
C Set sigma before apply avg kernel
C
WHERE (MOBDATA(NCMASS,IDATA:IDATEND).EQ.1.and.
& MOBDATA(NCMXTR,IDATA:IDATEND).eq.0)
& ROBDATA8(NCMOER,IDATA:IDATEND)=ztrial(1:INUMS)*
& ROBDATA8(NCMOER,IDATA:IDATEND)*1.E6
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
C* Calculate difference (divided by std. dev.).
C
IF (.NOT.LSIMOB.OR.
& (CDBGTYP.ne.'HR'.and.CDBGTYP.ne.'hr')) THEN
WHERE (MOBDATA(NCMASS,IDATA:IDATEND).EQ.1.and.
& MOBDATA(NCMXTR,IDATA:IDATEND).eq.0)
ROBDATA8(NCMOMA,IDATA:IDATEND)=
& (ztrial(1:INUMS)-ROBDATA8(NCMVAR,IDATA:IDATEND))
& /ROBDATA8(NCMOER,IDATA:IDATEND)
ENDWHERE
ELSE
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
C* Any future application of obs vertical correlations would
C be applied here to ROBDATA8(NCMOMA,*).
C This could be done by including multiplication by the
C inverse of the square root of the obs vertical
C correlation matrix. This would also require availability
C of the full (unflagged) ROBDATA8 profile.
C
C .....
C
IF (.NOT.LVARQC.OR.(CDBGTYP.eq.'HR'.or.CDBGTYP.eq.'hr')) THEN
WHERE (MOBDATA(NCMASS,IDATA:IDATEND).EQ.1.and.
& MOBDATA(NCMXTR,IDATA:IDATEND).eq.0)
& ROBDATA8(NCMOMI,IDATA:IDATEND)=
& ROBDATA8(NCMOMA,IDATA:IDATEND)
END IF
IF (CDBGTYP.ne.'HR'.and.CDBGTYP.ne.'hr') THEN
WHERE (MOBDATA(NCMASS,IDATA:IDATEND).EQ.1.and.
& MOBDATA(NCMXTR,IDATA:IDATEND).eq.0)
& ROBDATA8(NCMOMN,IDATA:IDATEND)=
& ROBDATA8(NCMOMA,IDATA:IDATEND)
END IF
C
C* Take dot-product of ROBDATA8(NCMOMA,*) with itself
C (and divide by 2) as contribution to cost function Jo (PJO).
C
IF (.NOT.LVARQC.OR.CDBGTYP.eq.'HR'.or.CDBGTYP.eq.'hr') THEN
IF (.NOT.LSIMOB.OR.
& (CDBGTYP.ne.'HR'.and.CDBGTYP.ne.'hr')) THEN
PJO(JLT)=PJO(JLT)+
& ZSCL2*SUM(ROBDATA8(NCMOMA,IDATA:IDATEND)*
& ROBDATA8(NCMOMA,IDATA:IDATEND),
& MASK=MOBDATA(NCMASS,IDATA:IDATEND).eq.1.and.
& MOBDATA(NCMXTR,IDATA:IDATEND).eq.0)
END IF
C
ELSE IF (LVARQC.AND.CDBGTYP.ne.'HR'.and.CDBGTYP.ne.'hr') THEN
C
C* Apply variational quality control.
C
DO JDATA=IDATA,IDATEND
if (MOBDATA(NCMASS,JDATA).EQ.1.and.
& MOBDATA(NCMXTR,JDATA).eq.0) then
ZGAMI=ROBDATA(NCMPOB,JDATA)
ZJON =ROBDATA8(NCMOMA,JDATA)
& *ROBDATA8(NCMOMA,JDATA)
ZJON =ZJON*ZSCL2
ZQCARG=ZGAMI + EXP(-1.0D0*ZJON)
ROBDATA8(NCMOMN,JDATA)= ROBDATA8(NCMOMA,JDATA)
& *(1.D0-ZGAMI/ZQCARG)
PJO(JLT)=PJO(JLT)-LOG(ZQCARG/(ZGAMI+1.D0))
end if
END DO
END IF
C
KNO(JLT)=KNO(JLT)+COUNT(MOBDATA(NCMASS,IDATA:IDATEND).eq.1.and.
& MOBDATA(NCMXTR,IDATA:IDATEND).eq.0)
C
END DO ! (J1)
END DO ! (JOBS)
END IF
END DO ! (NFILES)
RETURN
END