subroutine preproc 7,48
#if defined (DOC)
*
***s/r preproc - Control of the preprocessing of the 3D variational assimilation
*
*
*Author : S. Pellerin *ARMA/AES Nov., 1999
*Revision:
* : C. Charette *ARMA/AES Oct 2001
* - Added LTOPOFILT
* S. Pellerin *ARMA/SMC nov. 2001
* - reordering of declaration dependencies (for Linux compilation)
* N. Wagneur *CMDA/SMC Juin 2002
* - Ajout du calcul de Jo pour la famille GOES
* J. St-James *CMDA/SMC July 2003
* - Add profiler family to Jo
* JM Belanger CMDA/SMC Feb 2004
* - Introduce "scatterometer family SC"
* D. Anselmo *ARMA/SMC Oct. 2004
* - Add calls to DHUPPP.ftn and DHUSFC.ftn to compute O-P for LQ.
* Y. Yang (UofT) and Y.J. Rochon (ARQX/SMC), 2004
* - Addition of Jo calc for the TR family (constituents)
* - Added #include "comchem.cdk" for TR family
* Y. Yang (UofT) Feb. 2005
* - Removed 'OZ' since ozone is now part of 'TR'
* J. Halle *CMDA/SMC June 2005
* - Adapt for RTTOV-8.
* Y.J. Rochon and Y. Yang, AQRB/MSC, October 2004 - July 2005
* - Introduced control module for the constituents forward
* models from which different models can be called:
* ch_jocalc for calls to forward (or TLM) models
* Y. Yang (ARQI) July 2005
* - added call to randhbht1, following Mark Buehner's code
* Y.Nezlin (ARQX/UofT) Oct, 2005
* - added background perturbations (based on Mark Buehner code).
* Use of module PERTBG1
* Y.J Rochon ARQX/EC Feb 2006
* - Added call to CH_MODBGSTD
* J.M. Aparicio *ARMA/MSC* October 2006
* - Adapt for GPSRO
* P.KOCLAS *CMDA/MSC* MAR 2008
* - Add Background check for GPSRO
* Y.J Rochon ARQX/EC Apr 2008
* - Added optional perturbation of simulated observations for
* storage in burp file.
* S. Pellerin, ARMA, August 2008
* - Added calls to 'tmg_*' subroutines
* S. Pellerin, ARMA, January 2009
* - Add call to mask generators
* Y.Yang ARQI Jan. 2010
* - changed call ch_jocalc to call CH_oda_Htr
* - add call to ch_oda_masktr for chemistry markers.
* R. Sarrazin *CMDA June 2008
* - add "CALL SOBSCSBT"
* R. Sarrazin, Nov 2006
* - add call to dhupp for family AI
* Y.J. Rochon Feb,Aug 2010
* - Added CTRSTNID(JJ) and NETR(JJ) to Jo output for TR subfamilies
* Y. Yang and Y.J. Rochon, March 2010
* - Added calls to ch_tunebgcoef and ch_tuneobs based on previous
* 3D-Var-Chem
* Y.J. Rochon (ARQX) March 2010
* - Added call to ch_diagn
* Y. Yang and Y.J.Rochon, Aug 2010
* - Added call to ch_nsumobs.
* M. Rezska, Sept 2010
* - Moved call to RANDHBHT1 after ODA_MASK* as it requires use
* of the masks
* Y. Yang Oct. 2010
* - added call to diagn_to_chan for diagnostics of TO family sensors
* and their channels - similar to ch_diagn
* -------------------
** Purpose: to initialize * the background state
* . * the observations
* . * the background error statistics
* . * write or read (HXb -Z)
* . * the observation error statistics
* . * check the consistency between the background and the observations
*
*Arguments
* -NONE-
#endif
IMPLICIT NONE
*implicits
#include "pardim.cdk"
#include "comct0.cdk"
#include "comdim.cdk"
#include "com1obs.cdk"
#include "comlun.cdk"
#include "comgem.cdk"
#include "comdimo.cdk"
#include "comchem.cdk"
#include "commvo.cdk"
#include "commvog.cdk"
#include "comoabdy.cdk"
#include "comoahdr.cdk"
#include "comoba.cdk"
#include "comvarqc.cdk"
#include "comcva.cdk"
#include "cparbrp.cdk"
#include "cominterp.cdk"
#include "comcst.cdk"
#include "comfilt.cdk"
#include "comgdpar.cdk"
C
integer ierr
real*8 zjo,zjoraob,zjosatem,zjohumsat,zjosatwind,zjosurfc
real*8 zjosfcsf,zjosfcua,zjotov,zjogoes,zjoairep,zjosfcsc,zjoprof
integer jk,jj
REAL*8 ZJOFM(NCMTMAX)
INTEGER IJOFM(NCMTMAX)
real*8 zjogpsro
c
call printrev("SUBROUTINE preproc :",17)
c
c Initialization of interpolation parameters
c
lvintbgstat = .false.
lhintdelhu = .true.
c
call readnml('NAMINTERP',IERR)
c
call tmg_start(15,'SUCVA')
CALL SUCVA(NULOUT)
call tmg_stop(15)
c
c Read in scaling factors to adjust obs error std dev in cma
c and background error std. dev. scaling factor
c
if(ntunestats.eq.5) then
call rdtunebgobs
endif
C
if (LCHEM) then
C
C TEMPORARY: The following could be incorporated (or adpated) at
C some point to be part of 'rdtunebgobs'.
C
C Set background error std. dev. scaling factors for constiuents
C
if (ntunetrbg.eq.5) call ch_tunebgcoef
C
C Apply longitude variation to species background std. dev. scaling
C field by applying proportionality to the sqrt(mixing ratio).
C
call ch_modbgstd
C
C Tune the TR observation error statistics
C
if (ntunetrobs.eq.5) call ch_tuneobs
C
end if
c
c ***********************************************************
c
c For a perturbed Monte Carlo cycle:
c
c Perturb the forecast
c
IF(NPERTBG.gt.0) THEN
write(nulout,*) 'NPERTBG>0; CALL PERTBG '
CALL PERTBG1
ENDIF
c
c ***********************************************************
c
c Reading, horizontal interpolation and unit conversions of the 3D trial
c fields
c
call tmg_start(16,'SUGOMOBS')
call sugomobs
call tmg_stop(16)
c
C*****************************************************************
* *
* * COMPUTATION of INNOVATION * *
* * * With COMMVO set to model state on FIRST GUESS levels * * *
* * * * * *
* * * *
*
C
c Calculate ES=T-TD from T and Q
c from GOMQHR and GOMTHR and put it in GOMESHR
c
call tmg_start(17,'MHUAESVHR')
call mhuaesvhr
call tmg_stop(17)
c
c Using T, q and PS in GOMOBSHR, computes GZ and stores it in GOMGZHR
c N.B. uses vlevhr
c
call tmg_start(18,'TT2PHIHR')
call tt2phihr
call tmg_stop(18)
c
c Reject observed elements too far below the surface. Pressure values
c for elements slightly below the surface are replaced by the surface
c pressure values of the trial field.
c
IF(.NOT.LONEOBS ) THEN
IF (LTOPOFILT) THEN
write(NULOUT,*)' *****************************************'
write(NULOUT,*)' * PREPROC PREPROC PREPROC PREPROC *'
write(NULOUT,*)' * *'
write(NULOUT,*)' * FILTER OF OBS DUE TO TOPOGRAPHY *'
write(NULOUT,*)' * *'
write(NULOUT,*)' *****************************************'
CALL SOBSSFC
CALL SOBSRAOB
CALL SOBSHUMSAT
CALL SOBSAISW
CALL SOBSPROF
CALL SOBSCSBT
ELSE
write(NULOUT,*)' *****************************************'
write(NULOUT,*)' * PREPROC PREPROC PREPROC PREPROC *'
write(NULOUT,*)' * *'
write(NULOUT,*)' * NO FILTER OF OBS DUE TO TOPOGRAPHY *'
write(NULOUT,*)' * *'
write(NULOUT,*)' *****************************************'
ENDIF
IF(NCONF .EQ. 141 .OR. NINT(NCONF/100.0).EQ.6) CALL SFCWNDZAP
ENDIF
c
c Find interpolation layer in model profiles and reference level
c of thickness data for SATEMS
c
CALL VOBSLYRS('HR')
c
c ***********************************************************
c
c For a perturbed Monte Carlo cycle:
c
c Perturb the observations
c
IF(LPERTOBS.AND.(.NOT.LSIMOB)) THEN
write(nulout,*) 'LPERTOBS=TRUE; CALL PERTOBS '
CALL SETERRGPSRO ! Set improved GPSRO obs error std. dev. estimate
CALL PERTOBS
ENDIF
c
c ***********************************************************
c
c---- Calculate the normalized inovations (Z - H(X))/sigma
c and place the results in CMA at NCMOMA references
C
C RAOBS
C------------------------------
call tmg_start(22,'NL_OBS_OPER')
ZJORAOB = 0.0d0
CALL DOBSPPP(ZJORAOB,'UA')
C
C HUMSAT
C--------------------------------
ZJOHUMSAT = 0.0d0
CALL DOBSPPP(ZJOHUMSAT,'HU')
c CALL OBSCORHU(ZJOHUMSAT)
C
C AIREPS
C--------------------------------
ZJOAIREP=0.0D0
CALL DOBSPPP(ZJOAIREP,'AI')
C
C SATWINDS
C--------------------------------
ZJOSATWIND=0.0D0
CALL DOBSPPP(ZJOSATWIND,'SW')
C
C SURFACE
C-------------------------------
ZJOSURFC=0.0D0
ZJOSFCSF=0.0D0
ZJOSFCUA=0.0D0
ZJOSFCSC=0.0D0
CALL DOBSSFC(ZJOSFCSF,'SF')
CALL DOBSSFC(ZJOSFCUA,'UA')
CALL DOBSSFC(ZJOSFCSC,'SC')
ZJOSURFC = ZJOSFCUA + ZJOSFCSF + ZJOSFCSC
C
C SATEMS
C------------------------------
ZJOSATEM = 0.0d0
CALL DOBSSATEM(ZJOSATEM)
c CALL OBSCORST(ZJOSATEM)
C
C TOVS - RADIANCE
C-------------------------------
ZJOTOV=0.0D0
CALL TOVS_OBS ('HR',ZJOTOV)
C
C GOES - RADIANCE
C-------------------------------
ZJOGOES=0.0D0
CALL DOBSGOES(ZJOGOES)
C
C TR family: INCLUDES CONSTITUENT DATA SOURCES
C---------------------------
ZJOFM(:)=0.0D0
IJOFM(:)=0
IF (NCMTASSI.GT.0) THEN
C
C NOTE: CH_JOCALC could/should be replaced by CH_ODA_HTR
C when preproc is replaced by its ODA equivalent.
C Currently, all the TR forward models are linear:
C
C CALL ch_oda_Htr('HR')
C
CALL ch_jocalc(ZJOFM,IJOFM,NCMTMAX,'TR','HR')
ENDIF
C
C PROFILER
C------------------------------
ZJOPROF = 0.0d0
CALL DOBSZZZ(ZJOPROF,'PR')
C
C GPS - RADIO OCCULTATION
C-------------------------------
ZJOGPSRO=0.0D0
C IF (.NOT.(LPERTOBS.AND.(.NOT.LSIMOB))) CALL SETERRGPSRO
CALL SETERRGPSRO
CALL FILTERGPSRO
CALL DOBSGPSRO(ZJOGPSRO)
call tmg_stop(22)
C=======================================================================
ZJO = ZJORAOB + ZJOSATEM + ZJOHUMSAT + ZJOAIREP + ZJOSATWIND +
$ ZJOSURFC + ZJOTOV + ZJOGOES + ZJOPROF + ZJOGPSRO
C=======================================================================
DO JJ=1,NCMTASSI
ZJO=ZJO+ZJOFM(JJ)
END DO
C
write(nulout,'(a15,G23.16)') 'JORAOB= ',ZJORAOB
write(nulout,'(a15,G23.16)') 'JOSATEM= ',ZJOSATEM
write(nulout,'(a15,G23.16)') 'JOHUMSAT= ',ZJOHUMSAT
write(nulout,'(a15,G23.16)') 'JOAIREP= ',ZJOAIREP
write(nulout,'(a15,G23.16)') 'JOSURFC= ',ZJOSURFC
write(nulout,'(3X,a15,G23.16)') 'JOSFCSF= ',ZJOSFCSF
write(nulout,'(3X,a15,G23.16)') 'JOSFCUA= ',ZJOSFCUA
write(nulout,'(3X,a15,G23.16)') 'JOSFCSC= ',ZJOSFCSC
write(nulout,'(a15,G23.16)') 'JOTOV= ',ZJOTOV
write(nulout,'(a15,G23.16)') 'JOGOES= ',ZJOGOES
write(nulout,'(a15,G23.16)') 'JOSATWIND= ',ZJOSATWIND
write(nulout,'(a15,G23.16)') 'JOPROF= ',ZJOPROF
write(nulout,'(a15,G23.16)') 'JOGPSRO= ',ZJOGPSRO
IF (NCMTASSI.GT.0) THEN
write(nulout,'(a15,G23.16)') 'JO_TR= ',sum(zjofm)
do JJ=1,NCMTASSI
write(nulout,'(3x,a8,a4,a3,G23.16,2x,i10,a5,i7,1x,a9)')
1 'JO(',CNAMANAL(JJ),')= ',ZJOFM(JJ),IJOFM(JJ),
2 ' for ',NETR(JJ),CTRSTNID(JJ)
end do
end if
write(nulout,'(a15,G23.16)') 'Total Jo = ',ZJO
c
c------ Calculate the normalized innovations (Z - H(X))/sigma
c for ln q for atmospheric and surface obs.
C
CALL DHUPPP('UA')
CALL DHUPPP('AI')
CALL DHUSFC('UA')
CALL DHUSFC('SF')
c
c Perturb simulated observations.
c
IF(LPERTOBS.AND.LSIMOB) THEN
write(nulout,*) 'LPERTOBS=TRUE; CALL PERTOBS '
CALL PERTOBS
ENDIF
C
IF (LSIMOB) RETURN
c
c Diagnostics for TO family sensors and their channels
c
c IF (NCONF.eq.141) call diagn_to_chan('OmP')
call diagn_to_chan('OmP')
C
C Diagnostics for TR subfamilies
C
IF (LCHEM.and.NCONF.eq.141) call ch_diagn('OmP')
c
c Find interpolation layer in model profiles and reference level
c of thickness data for SATEMS
c
CALL VOBSLYRS('BG')
c
IF (LVARQC) THEN
call suasym2
C CALL SUASYM2(NVADIM,VATRA(1),VATRA(NVADIM+1))
endif
c
call oda_masksf('UA')
call oda_masksf('SF')
call oda_masksf('SC')
call oda_maskpp('UA')
call oda_maskpp('AI')
call oda_maskpp('SW')
call oda_maskto
call oda_maskgo
call oda_maskro
call oda_maskzp('PR')
IF (NCMTASSI.GT.0) THEN
call ch_oda_masktr('TR')
ENDIF
C
C Calculate and store e_b = H B^1/2 e_rand for calculating HBH^T
C
call tmg_start(25,'randhbht')
IF(NCONF.eq.141.and.LHBHT1) THEN
call randhbht1
ENDIF
call tmg_stop(25)
C
C Calc and output number of obs to be assimilated for each family.
C
call oda_nsumobs
C
RETURN
END