SUBROUTINE DOBSGOES(PJO) 3
#if defined (DOC)
*
***s/r DOBSGOES - Computation of Jo and the residuals to the
* radiance (for GOES) observations
*
*
*Author : N.Wagneur *CMDA/MSC April 23, 2001
*
*Revision :
* C. Charette - ARMA/SMC - Sept 2004
* - Conversion to hybrid vertical coordinate
* Return if no data to process
* Y.J. Rochon *AQRX/MSC Feb 2005
* - Added comnumbr.cdk
* as JPNBRELEM of comnumbr required by cvcord.
* Y.J. Rochon ARQX, Jan 2010
* - Addition of obs simulation option with LSIMOB=.TRUE.
*
* -------------------
** Purpose:
*
*Arguments
* PJO: total value of Jo for GOES
*
#endif
IMPLICIT NONE
*implicits
#include "comdim.cdk"
#include "comdimo.cdk"
#include "comlun.cdk"
#include "comcst.cdk"
#include "comoabdy.cdk"
#include "comoahdr.cdk"
#include "comoba.cdk"
#include "commvohr.cdk"
#include "partov.cdk"
#include "cparamgoes.cdk"
#include "comgoes.cdk"
#include "comgoesst.cdk"
#include "comjacgoes.cdk"
#include "comnumbr.cdk"
#include "cvcord.cdk"
#include "comct0.cdk"
*
C
REAL*8 ZVAR, ZOER
REAL*8 ZTODEG
REAL*8 DLSUM
REAL*8 PJO, ZQMIN, ZJOALL, ZAVGALL
C
REAL*8 ZPS (JPPFGO)
REAL*8 ZTG (JPPFGO)
REAL*8 ZLAT(JPPFGO),ZO3OBS(JPPFGO)
REAL*8 ZVLEV(JPPFGO,NLEVTRL)
REAL*8 ZT (JPPFGO,NLEVTRL)
REAL*8 ZLQ (JPPFGO,NLEVTRL)
REAL*8 ZQ (JPPFGO,NLEVTRL)
REAL*8 PANGL(JPPFGO),PANGS(JPPFGO)
REAL*8 ZTBO(JPCHPFGO),ZDTB(JPCHPFGO)
REAL*8 ZDTBOM1(JPCHPFGO)
REAL*8 ZJOCH (0:JPCHGO,JPNSATGO)
REAL*8 ZAVGNRM(0:JPCHGO,JPNSATGO)
REAL*8 PAV(NLEVTRL,JPNAVGO,JPPFGO),PSAV(JPNSAVGO,JPPFGO)
REAL*8 PSSV(JPNSSVGO,JPPFGO),PCV(JPNCVGO,JPPFGO)
REAL*8 PEMISGO(JPPFGO,JPCHGO)
REAL*8 PGOES(JPCHPFGO),ZPTB(JPCHPFGO)
REAL*8 TAUSFC(JPCHPFGO)
C
INTEGER J,JCH,I,ISAT,KSAT,JOFF,IO,JF,ISATON,KCNT
INTEGER IBEGIN, IBEGINOB, ILAST, ILASTOB
INTEGER ILOWLVL, IMODE
INTEGER KNPF, KNCHPF, INOBSJO
INTEGER JO, JDATA, IDATA, ITYP, IDATEND, IDATYP
INTEGER JK, JN, ICHN, IPROCES, JL, INDX
INTEGER ILANSEA, INDXREG, INDXCLD, INUMCHN
INTEGER KLENPF,KNAV,KNSAV,KNSSV,KNCV
C
INTEGER KSURF(JPPFGO)
INTEGER KCHAN(JPCHPFGO),KPROF(JPCHPFGO)
INTEGER KCHNESDIS(JPCHPFGO)
INTEGER KFAIL(JPCHPFGO)
INTEGER IPTOBS (JPPFGO)
INTEGER IPTDATA (JPCHPFGO)
INTEGER IPTCHPF(JPPFGO,JPCHGO)
INTEGER IPTREG(JPPFGO)
INTEGER IPTCLD(JPPFGO)
INTEGER ISCANPOS(JPPFGO)
INTEGER ISATZEN(JPPFGO)
INTEGER INOBSCH(0:JPCHGO,JPNSATGO)
INTEGER IFAIL(JPPFGO,JPNSATGO)
C
INTEGER ISRCHEQ, MRFVOI, MRFCLS
EXTERNAL ISRCHEQ, MRFVOI, MRFCLS
EXTERNAL LINTV2, EXTRAP
C
LOGICAL ASSIM
C
if(nobgoes.eq.0) return ! Exit if there are not GOES data
C
C* 1. Initialization
C . --------------
C
c
KCNT = 0
C
ZTODEG = 180.0 / RPI
KLENPF = NLEVTRL
KNAV = JPNAVGO
KNSAV = JPNSAVGO
KNSSV = JPNSSVGO
KNCV = JPNCVGO
C
C
C* 1.1 Set index for model's lowest level
C . ----------------------------------
C
IF ( VLEVHR(1) .LT. VLEVHR(NLEVTRL) ) THEN
ILOWLVL = NLEVTRL
ELSE
ILOWLVL = 1
ENDIF
C
C* 1.2 Initialize RT global common block
C . ---------------------------------
C
DO J = 1, NOBGOES
MJOGO(J) = 0
ENDDO
C
C* 2. Computation of (HX - Z)/SIGMA for GOES data only
C . ------------------------------------------------
C
200 CONTINUE
C
DLSUM = 0.0D0
INOBSJO = 0
DO J = 1, NSATGO
DO I = 0, JPCHGO
INOBSCH(I,J) = 0
ZJOCH (I,J) = 0.0
ZAVGNRM(I,J) = 0.0
ENDDO
ENDDO
DO I = 0, JPCHGO
ZO3OBS(I) = 0.0
ENDDO
C
C** Loop over all files
C
DO 295 JF = 1, NFILES
IF ( CFAMTYP(JF).EQ.'GO' .AND. NBEGINTYP(JF).GT.0 ) THEN
IBEGIN = NBEGINTYP(JF)
ILAST = NENDTYP (JF)
IBEGINOB = MOBDATA(NCMOBS,IBEGIN)
ILASTOB = MOBDATA(NCMOBS,ILAST )
C
C** Loop over all satellites specified by user
C
DO 290 KSAT = 1, NSATGO
KNPF=0
DO I = 1, JPCHPFGO
ZPTB (I) = 0.
PGOES (I) = 0.
ZDTB (I) = 0.
ZTBO (I) = 0.
KFAIL (I) = 1
IPTDATA (I) = 1
ENDDO
DO I = 1, JPPFGO
DO J = 1, NLEVTRL
ZT (I,J) = 0.
ZQ (I,J) = 0.
ZLQ (I,J) = 0.
ZVLEV (I,J) = 0.
ENDDO
ZLAT (I) = 0.
ZPS (I) = 0.
ZTG (I) = 0.
PANGL(I) = 0.
DO J = 1, JPCHGO
PEMISGO(I,J) = 0.
ENDDO
ENDDO
DO 290 JO = IBEGINOB, ILASTOB
C
C* . 2.1 Extract general information for this observation point
C . ------------------------------------------------------
C
C* Only process GOES/RADIANCES data (codtype = 180) to be assimilated?
C
IDATYP = MOD(MOBHDR(NCMITY,JO),1000)
IF ( IDATYP .EQ. 180 ) THEN
IDATA = MOBHDR(NCMRLN,JO)
IDATEND = MOBHDR(NCMNLV,JO) + IDATA - 1
ASSIM = .FALSE.
DO JDATA= IDATA, IDATEND
IF ( MOBDATA(NCMASS,JDATA).EQ.1 ) THEN
ASSIM = .TRUE.
ENDIF
ENDDO
C
ISAT = MOD(MOBHDR(NCMITY,JO)/1000,1000)
cnwa
C
C* Currently processed satellite
C* N.B.: 252=GOES08, 253=GOES09, 254=GOES10,
C* 255=GOES11, 256=GOES12, etc...
C
ISAT = ISAT - 244
C
IF ( ASSIM .AND. (ISAT .EQ. NIDSATGO(KSAT)) ) THEN
C
KCNT = KCNT + 1
KNPF = KNPF + 1
C
MJOGO(KCNT) = JO
ISATON = ISAT
C
C* Extract Latitude
C
ZLAT(KNPF) = ROBHDR(NCMLAT,JO) * ZTODEG
C
C* Extract land/sea flag
C
ILANSEA = MOBHDR(NCMOFL,JO)
cnwa INDXREG = ISRCHEQ ( MLISREG, NREGST, ILANSEA )
KSURF(KNPF) = ILANSEA
C
C* Extract processing technique
C
IPROCES = MOBHDR(NCMITY,JO)/1000000
cnwa INDXCLD = ISRCHEQ ( MLISCLD, NCLDST, IPROCES )
C
C* Extract scan position
C
ISCANPOS(KNPF) = MOD(MOBHDR(NCMBOX,JO),100)
C
C* Extract satellite zenith angle
C
ISATZEN(KNPF) = MOBHDR(NCMBOX,JO)/10000
PANGL(KNPF) = (ISATZEN(KNPF)-9000) / 100.0
C
IPTCLD(KNPF) = 1
IPTREG(KNPF) = 1
C
ZTG(KNPF) = GOMTGRHR(1,JO)
ZPS(KNPF) = GOMPSHR(1,JO)
C
DO JL = 1, NLEVTRL
ZT (KNPF,JL) = GOMTHR(JL,JO)
ZLQ (KNPF,JL) = GOMQHR(JL,JO)
ZQ (KNPF,JL) = EXP(GOMQHR(JL,JO))
ZVLEV(KNPF,JL) = RPPOBSHR(JL,JO)
ENDDO
c
IPTOBS(KNPF) = JO
DO JDATA = IDATA, IDATEND
ITYP = MOBDATA(NCMVNM,JDATA)
C
C A emissivity (elements )?
IF ( ITYP.EQ.12163 ) THEN
ZVAR = ROBDATA8(NCMPRL,JDATA)
ICHN = NINT(ROBDATA8(NCMPPP,JDATA))
PEMISGO(KNPF,ICHN) = ZVAR
ENDIF
ENDDO
ENDIF
ENDIF
IF ( KNPF .LE. 0 ) GO TO 290
IF ( KNPF .NE. JPPFGO .AND. JO .NE. ILASTOB ) GO TO 290
C
C
C* . 2.4 Extrapolation of humidity profile above 300mb (kg/kg)
C . -----------------------------------------------------
C
cnwa Not done ....
C
IF ( LDBGGO ) THEN
JOFF = 0
WRITE(NULOUT,*)'KNPF, KNCHPF, KSAT = ',
& KNPF, KNCHPF, KSAT
DO JN = 1, KNPF
WRITE(NULOUT,*)'KFAIL = ', KFAIL(JN)
WRITE(NULOUT,*)'IPTCLD = ', IPTCLD(JN)
WRITE(NULOUT,*)'IPTREG = ', IPTREG(JN)
WRITE(NULOUT,*)'Temperature profile (K)'
WRITE(NULOUT,*)(JN,I,ZT(JN,I),ZQ(JN,I),I=1,NLEVTRL)
WRITE(NULOUT,*)'Surface air variables: T(K),',
& 'lnq(kg/kg),Ps(hpa)'
WRITE(NULOUT,*)ZT(JN,ILOWLVL),LOG(ZQ(JN,ILOWLVL)),ZPS(JN)
WRITE(NULOUT,*)'Surface skin variables: Tskin(K)'
WRITE(NULOUT,*)ZTG(JN)
INUMCHN = NCHNAGO(IPTCLD(JN),IPTREG(JN),KSAT)
WRITE(NULOUT,*)'Angles: satzen,satazim,solzen,',
& 'relsolazim(deg)'
WRITE(NULOUT,*) PANGL(JN)
WRITE(NULOUT,*)'Surface type'
WRITE(NULOUT,*) KSURF(JN)
JOFF = JOFF + INUMCHN
ENDDO
ENDIF
c 290 CONTINUE
C
C* . 2.6 Forward RT model
C . ----------------
C
C* On desactive le calcul de la matrice Jacobienne
C
IMODE = 0
C
CALL RTGOES(ZPTB,PGOES,ZPS,ZT,ZQ,
& ZTG,PANGL,ZLAT,ZO3OBS,NLEVTRL,PEMISGO,
& KSURF,KNPF,ZVLEV,NIDSATGO(KSAT),KCNT,IMODE)
C
C
C
C
C* . 2.7 Extract GOES observations of radiance (brightness temps.)
C . ------------------------------------------------------------------
C
KNCHPF = KNPF * JPCHGO
DO I = 1, KNCHPF
ZTBO (I) = 0.0
ZDTB (I) = 0.0
ZDTBOM1 (I) = 0.0
IPTDATA (I) = 0
KFAIL (I) = 1
ENDDO
C
DO 280 JN = 1, KNPF
IO = IPTOBS(JN)
IDATA = MOBHDR(NCMRLN,IO)
IDATEND = MOBHDR(NCMNLV,IO)+IDATA - 1
C
C* Loop through data. Extract and store temporarily brightness temps.
C
DO 270 JDATA = IDATA, IDATEND
ITYP = MOBDATA(NCMVNM,JDATA)
C
C A radiance (elements 12163)?
IF ( ITYP.EQ.12163 ) THEN
C
ZVAR = ROBDATA8(NCMVAR,JDATA)
ICHN = NINT(ROBDATA8(NCMPPP,JDATA))
C
C* channel to be assimilated?
IF ( MOBDATA(NCMASS,JDATA).EQ.0 ) GO TO 270
C
MOBDATA(NCMXTR,JDATA) = 0
INDX = ICHN + (JN-1) * JPCHGO
IF ( LDBGGO ) THEN
WRITE (NULOUT,*) ' indx,ichn,jn = ',indx,ichn,jn
WRITE (NULOUT,'("ZPTB,O-P= ",
S 2F10.6)') ZPTB(INDX),ZVAR-ZPTB(INDX)
ENDIF
ZTBO (INDX) = ZVAR
IPTDATA (INDX) = JDATA
KFAIL(INDX) = 0
ENDIF
270 CONTINUE
C
280 CONTINUE
C
C* . 2.8 Compute residuals
C . -----------------
C
DO I = 1, KNCHPF
IF ( KFAIL(I) .EQ. 0 ) THEN
ZDTB(I) = ZPTB(I) - ZTBO(I)
ENDIF
ENDDO
C
C* . 2.9 Store (HX - Z)/SIGMA in CMA
C . ---------------------------
c
******commented vectorization directive**** *vdir nodep
DO I = 1, KNCHPF
IF (IPTDATA(I) .NE. 0 ) THEN
ZOER = ROBDATA8(NCMOER,IPTDATA(I))
if (.NOT.LSIMOB) then
ROBDATA8(NCMOMA,IPTDATA(I)) = ZDTB(I)/ZOER
ROBDATA8(NCMOMI,IPTDATA(I)) =
S ROBDATA8(NCMOMA,IPTDATA(I))
ZDTBOM1(I) = ZDTB(I)/(ZOER*ZOER)
DLSUM = DLSUM
S + ROBDATA8(NCMOMA,IPTDATA(I))*
S ROBDATA8(NCMOMA,IPTDATA(I))
else
ROBDATA8(NCMOMA,JDATA) = 0.0D0
ROBDATA8(NCMOMI,JDATA) = 0.0D0
ROBDATA8(NCMVAR,JDATA) = ZPTB(I)
end if
INOBSJO = INOBSJO + 1
ENDIF
ENDDO
C
C* . 2.10 Transfer RT variables to RT global common block
C . -----------------------------------------------
C
C ................. not done anymore ...............
C
C** Next bunch !
c
285 KNPF = 0
DO I = 1, JPCHPFGO
ZPTB (I) = 0.
PGOES(I) = 0.
ZDTB (I) = 0.
ZTBO (I) = 0.
ENDDO
DO I = 1, JPPFGO
DO J = 1, NLEVTRL
ZT (I,J) = 0.
ZQ (I,J) = 0.
ZLQ (I,J) = 0.
ZVLEV (I,J) = 0.
ENDDO
DO J = 1, JPCHGO
PEMISGO(I,J) = 0.
ENDDO
ZLAT (I) = 0.
ZPS (I) = 0.
ZTG (I) = 0.
PANGL(I) = 0.
ENDDO
C
290 CONTINUE
C
ENDIF
295 CONTINUE
C
C* 3. Close up
C . --------
C
300 CONTINUE
C
NGOES = KCNT
PJO = DLSUM
*
*
9000 FORMAT(//,10X,"-DOBSGOES: computing Jo and residuals to GOES"
S ," observations")
C
RETURN
END