SUBROUTINE CH_SETFGE 1,7
C
*---------------------------------------------------------
#if defined (DOC)
*
***s/r CH_SETFGE - Compute THE FIRST GUESS ERROR STD. DEV.
* of F(x) related to 'TR' family obs.
*
*
*Author : Y.J. Rochon *ARQX/EC March 2006
* Based on SETFGEFAM by P. Koclas *CMC/CMSV November 1998
* and CH_JOCALC by Y.J. Rochon
*
*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, 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: - Compute THE FIRST GUESS ERROR STD. DEV. of F(x).
* It assumes a linear interpolation in ln(p) of
* the trial field is performed.
*
**
*
* Comments:
*
* 1) This routine must be quasi-identical to CH_JOCALC.
* When the call to a new TLM is added to CH_JOCALC,
* then it should also be added to CH_SETFGE.
*
** Assumptions:
*
* 1) GOMOBS contains forecast error std. dev.
*
* 2) Estimation of max std. dev. done by doing calc.
* as though all points are entirely correlated with
* the others (correlation coefficients of 1).
*
* Why: Accounting for correlations more complicated.
*
* Allows direct use of TLM by subsituting the
* the increments by the std. dev. That is,
* the resultant std. dev. is
*
* the sum of weights values
*
* instead of
*
* the root of sum of squared weighted values
* + accounting for correlation effects.
*
*-----------------------------------------------------------
#endif
IMPLICIT NONE
*implicits
#include "pardim.cdk"
#include "comdim.cdk"
#include "comdimo.cdk"
#include "comgem.cdk"
#include "comoabdy.cdk"
#include "comoahdr.cdk"
#include "comoba.cdk"
#include "comstate.cdk"
#include "commvo.cdk"
#include "commvog.cdk"
#include "commvohr.cdk"
#include "comnumbr.cdk"
#include "cvcord.cdk"
#include "comlun.cdk"
#include "comchem.cdk"
#include "cparbrp.cdk"
#include "comcst.cdk"
C
C* Declaration of local variables
C
INTEGER IOBS,IPOS,I1,I2
INTEGER JDATA,J,IBEGIN,ILAST,JJ
INTEGER IOBSNMB, IOBSTYP,IOBSLEV,IIFLAG,ID
INTEGER JOBS, IDATA, IDATEND, J1
INTEGER IBEGIN1, ILAST1,ILAT
INTEGER JLT,ILMAX,IREJECT
INTEGER IDIM
PARAMETER (IDIM=500) ! Must be >=JPNFLEV
INTEGER ICOND(IDIM)
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),ZDUM(JPNFLEV)
INTEGER ITRCODE
INTEGER INUMS,INUM,IKERN
INTEGER CH_KGETPOS
C
EXTERNAL CH_KGETPOS
CHARACTER*2 CLFAM
INTEGER IPB,IPT,IK
REAL*8 ZWB,ZWT
REAL*8 ZLEV,ZPB,ZPT
C
CLFAM='TR'
ILMAX = NFLEV
ZTODEG=180./RPI
C
DO J = 1,NFILES
IF (CFAMTYP(J).EQ.CLFAM.AND.NBEGINTYP(J).GT.0.AND.
& NENDTYP(J).GE.NBEGINTYP(J)) THEN
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)
C
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 Initialize std. dev. array. to PPMIS
C
ROBDATA(NCMFGE,IDATA:IDATEND)=PPMIS
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_SETFGE: Level inconsistency.'
goto 150
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) GO TO 150
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, *) 'CH_SETFGE: Species ', IOBSNMB,' not processed!'
go to 150
END IF
C
C* Identify background/increment arrays at obs lat/long location
C
ZSTATE(1:ILMAX)=0.0
IF (CNAMANAL(JLT).EQ.'HU'.OR.CNAMANAL(JLT).EQ.'LQ') THEN
C
C Requires LQ trial field for variable transformation.
C
ZSTATE(1:ILMAX)=GOMQHR(1:ILMAX,IOBS) ! Store LQ
ELSE IF (NLOGTR.NE.0.AND.ITRCODE.NE.0) THEN
C
C Requires trial field for species variable transformation.
C
ZSTATE(1:ILMAX)=GOMOBSHR(1:ILMAX,IOBS)
END IF
I1=1+IPOS*ILMAX
I2=ILMAX+IPOS*ILMAX
c zvtr(1:ILMAX) = GOMOBSHR(I1:I2,iobs)
zvtr(1:ILMAX) = GOMOBS(I1:I2,iobs)
if (iobsnmb.eq.nvnumb(58)) zvtr2(1:ILMAX) =
& GOMOBS(I1+ILMAX:I2+ILMAX,iobs)
c & GOMOBSHR(I1+ILMAX:I2+ILMAX,iobs)
ztemp(1:ILMAX)=GOMTHR(1:ILMAX,IOBS)
zpress(1:ILMAX)=RPPOBSHR(1:ILMAX,IOBS)
C
C* Initialize ROBDATA8 to zero at obs location
C
ROBDATA(NCMFGE,IDATA:IDATEND)=PPMIS
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) 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,NOBTOT),MOBHDR(NCMETM,NOBTOT),
& INUMS,ZOBSLEV,ZALT,daynightp(jlt),
& RPPOBS(1:ILMAX,IOBS),
& GOMGZG(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 Set unit conversion factor ZVTR
C
IF (IREJECT.EQ.0) THEN
CALL CH_CONVERT(IOBSNMB,ITRCODE,speciesm(jlt),
& CNAMANAL(JLT),ZVTR,ZSTATE,ZTEMP,ZPRESS,ILMAX,
& 'HR',1,NLOGTR,IREJECT)
IF (IREJECT.EQ.1) THEN
WRITE(NULOUT,*)
& 'CH_SETFGE: 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
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 (IREJECT.EQ.1) THEN
C
C Obs was rejected.
C
ELSE 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)
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,
& 'HR',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,
& 'HR',ZVTR,zobslev,zobslev2,
& ZPRESS,ilmax,zlat,ilat,zstate,
& CSTNID(JOBS),CNAMANAL(JLT),0,IKERN)
C
END IF
C
C Save in ROBDAT(NCMFGE,*)
C
DO JJ=1,INUMS
IF (MOBDATA(NCMASS,IDATA+JJ-1).EQ.1) THEN
IF (MOBDATA(NCMXTR,IDATA+JJ-1).EQ.2) THEN
ROBDATA(NCMFGE,IDATA+JJ-1)=ZTRIAL(INUMS)
ELSE IF (MOBDATA(NCMXTR,JJ).EQ.1) THEN
ROBDATA(NCMFGE,IDATA+JJ-1)=ZTRIAL(1)
ELSE
ROBDATA(NCMFGE,IDATA+JJ-1)=ZTRIAL(JJ)
END IF
END IF
END DO
C
150 CONTINUE
END DO
END DO
END IF
END DO
C
RETURN
END