!-------------------------------------- LICENCE BEGIN ------------------------------------
!Environment Canada - Atmospheric Science and Technology License/Disclaimer,
! version 3; Last Modified: May 7, 2008.
!This is free but copyrighted software; you can use/redistribute/modify it under the terms
!of the Environment Canada - Atmospheric Science and Technology License/Disclaimer
!version 3 or (at your option) any later version that should be found at:
!http://collaboration.cmc.ec.gc.ca/science/rpn.comm/license.html
!
!This software is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY;
!without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
!See the above mentioned License/Disclaimer for more details.
!You should have received a copy of the License/Disclaimer along with this software;
!if not, you can write to: EC-RPN COMM Group, 2121 TransCanada, suite 500, Dorval (Quebec),
!CANADA, H9P 1J3; or send e-mail to service.rpn@ec.gc.ca
!-------------------------------------- LICENCE END --------------------------------------
!
subroutine suinnov 1,52
use mod4dv
, only : l4dvar
use stag_shared, only : tg_vco_trl,tg_vgrid_trl
#if defined (DOC)
*
***s/r suinnov - Initialise Observation Innovations.
*
*
*Author : Luc Fillion - 28 Mar 2008.
*Revision:
* L. Fillion - ARMA/EC - 22 May 2008 - Upgrade to v_10_1_1.
* S. Macpherson -ARMA/MRD Aug 2008
* - Add ground-based GPS family "GP"
* S. Pellerin, ARMA, January 2009
* - Add call to mask generators
* L. Fillion - ARMA/EC 14 Jan 2009
* - Upgrade lam4d to v_10_2_1 of 3dvar.
* - Comment 'tmg_*' subroutines.
* S. Macpherson -ARMA/MRD Sep 2009
* - Add ground-based GPS family "GP"
* A. Beaulne (2009) transfere de preproc.ftn (R. Sarrazin *CMDA June 2008)
* - Add "CALL SOBSCSBT"
* A. Beaulne (2009) transfere de preproc.ftn (R. Sarrazin, Nov 2006)
* - Add call to dhupp for family AI
* Bin He -ARMA/MRD Feb. 2010
* - Implemented MPI to 3DVAR
* C.Charette - ARMA et N.Wagneur - CMDA - Juillet 2011
* - Ajout de la capacite de lire le champ d'essai de GEM Version 4
* ayant une grille verticale decalee dite "STAGGERED"
* -------------------
** Purpose:
*
*Arguments
* -NONE-
#endif
IMPLICIT NONE
*implicits
#include "pardim.cdk"
#include "comct0.cdk"
#include "comdim.cdk"
#include "comdimo.cdk"
#include "com1obs.cdk"
#include "comlun.cdk"
#include "comvarqc.cdk"
#include "comcva.cdk"
#include "cominterp.cdk"
#include "comfilt.cdk"
#include "comgem.cdk"
#include "comgdpar.cdk"
#include "comgrd_param.cdk"
#include "comgrd.cdk"
#include "comin.cdk"
#include "comoabdy.cdk"
#include "comoba.cdk"
#include "comsim.cdk"
#include "comoahdr.cdk"
#include "comgpsgb.cdk"
c
logical lldo
integer jlev,jobs,jdata,ii,ierr
real*8 zjo,zjoraob,zjosatem,zjohumsat,zjosatwind,zjosurfc
real*8 zjosfcsf,zjosfcua,zjotov,zjogoes,zjoairep,zjosfcsc,zjoprof
real*8 zjogpsro,zjogpsgb,zjosfcgp
c
call printrev("SUBROUTINE SUINNOV :",20)
!
*****************************************************************
* *
* * 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
cnwa Only in non staggerd mode
c
if(.not.lsw .and. tg_vco_trl%iversion .eq. 5001 ) then
! call tmg_start(18,'TT2PHIHR')
call tt2phihr
! call tmg_stop(18)
endif
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
c GB-GPS (met and ZTD) observations are processed in SOBSSFC
c
lldo = .true.
!
if(.not.lsw) 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
if(lldo) CALL VOBSLYRS('HR')
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')
!
ZJOSURFC=0.0D0
ZJOSFCSF=0.0D0
ZJOSFCUA=0.0D0
ZJOSFCSC=0.0D0
ZJOSFCGP=0.0D0
ZJOSATEM = 0.0d0
ZJOTOV=0.0D0
ZJOGOES=0.0D0
ZJOGPSRO=0.0D0
ZJOGPSGB=0.0D0
ZJOPROF = 0.0d0
!
if(.not.lsw) then
C
C SURFACE (SF, UA, SC AND GP FAMILIES)
C-------------------------------
CALL DOBSSFC(ZJOSFCSF,'SF')
CALL DOBSSFC(ZJOSFCUA,'UA')
CALL DOBSSFC(ZJOSFCSC,'SC')
CALL DOBSSFC(ZJOSFCGP,'GP')
ZJOSURFC = ZJOSFCUA + ZJOSFCSF + ZJOSFCSC + ZJOSFCGP
C
C SATEMS
C------------------------------
CALL DOBSSATEM(ZJOSATEM)
c CALL OBSCORST(ZJOSATEM)
C
C TOVS - RADIANCE
C-------------------------------
CALL TOVS_OBS ('HR',ZJOTOV)
C
C GOES - RADIANCE
C-------------------------------
CALL DOBSGOES(ZJOGOES)
C
C PROFILER
C------------------------------
CALL DOBSZZZ(ZJOPROF,'PR')
C
C GPS - RADIO OCCULTATION
C-------------------------------
CALL SETERRGPSRO
CALL FILTERGPSRO
CALL DOBSGPSRO(ZJOGPSRO)
C
C GPS - GROUND-BASED ZENITH DELAY
C-------------------------------
C
!ccc plug in
cnwa Only in non staggerd mode
!ccc According to Stephen MacPherson
!ccc There are no GROUND-BASED ZENITH DELAY obs used in the global analysis
!ccc They are being tested in the regional LAM analysis
!ccc So DOBSGPSGB was not adapted to staggered at this time
!ccc (Jan 18,2011)
c
if(.not.lsw .and. tg_vco_trl%iversion .eq. 5001 ) then
CALL DOBSGPSGB(ZJOGPSGB)
endif
!ccc plug out
if ( ZJOGPSGB .gt. 0.0D0 ) then
C Options to fix/adjust model ZTD to observation height and
C assimilate GPS met data
C
write(NULOUT,*)' '
write(NULOUT,*)' *****************************************'
write(NULOUT,*)' * PREPROC PREPROC PREPROC PREPROC *'
write(NULOUT,*)' * GB-GPS OBSERVATIONS *'
write(NULOUT,*)' * DZ ADJUSTMENT IN GPSZTDOP IF DZ>DZMIN *'
write(NULOUT,*)' * *'
write(NULOUT,*)' *****************************************'
write(NULOUT,*) ' '
write(NULOUT,*) 'DZMIN, DZMAX = ', DZMIN, DZMAX
write(NULOUT,*) 'NJLEVP = ', NJLEVP
write(NULOUT,*) ' '
C
IF (LASSMET) THEN
write(NULOUT,*)' '
write(NULOUT,*)' *****************************************'
write(NULOUT,*)' * PREPROC PREPROC PREPROC PREPROC *'
write(NULOUT,*)' * GB-GPS OBSERVATIONS *'
write(NULOUT,*)' * GPS MET DATA ARE ASSIMILATED *'
write(NULOUT,*)' * *'
write(NULOUT,*)' *****************************************'
write(NULOUT,*) 'YSFERRWGT = ', YSFERRWGT
write(NULOUT,*) 'YZDERRWGT = ', YZDERRWGT
write(NULOUT,*) ' '
ELSE
write(NULOUT,*)' '
write(NULOUT,*)' *****************************************'
write(NULOUT,*)' * PREPROC PREPROC PREPROC PREPROC *'
write(NULOUT,*)' * GB-GPS OBSERVATIONS *'
write(NULOUT,*)' * GPS MET DATA ARE NOT ASSIMILATED *'
write(NULOUT,*)' * *'
write(NULOUT,*)' *****************************************'
write(NULOUT,*) 'YZDERRWGT = ', YZDERRWGT
write(NULOUT,*) ' '
ENDIF
C
IF (YZTDERR .LT. 0.0) THEN
write(NULOUT,*)' '
write(NULOUT,*)' *****************************************'
write(NULOUT,*)' * PREPROC PREPROC PREPROC PREPROC *'
write(NULOUT,*)' * GB-GPS OBSERVATIONS *'
write(NULOUT,*)' * ZTD OBSERVATION ERROR FROM FERR *'
write(NULOUT,*)' * *'
write(NULOUT,*)' *****************************************'
ELSE IF (YZTDERR .GT. 0.0) THEN
write(NULOUT,*)' '
write(NULOUT,*)' *****************************************'
write(NULOUT,*)' * PREPROC PREPROC PREPROC PREPROC *'
write(NULOUT,*)' * GB-GPS OBSERVATIONS *'
write(NULOUT,*)' * ZTD OBSERVATION ERROR IS FIXED *'
write(NULOUT,*)' * *'
write(NULOUT,*)' *****************************************'
write(NULOUT,*)' '
write(NULOUT,*)'YZTDERR (mm) = ', YZTDERR*1000.
ELSE
write(NULOUT,*)' '
write(NULOUT,*)' *****************************************'
write(NULOUT,*)' * PREPROC PREPROC PREPROC PREPROC *'
write(NULOUT,*)' * GB-GPS OBSERVATIONS *'
write(NULOUT,*)' * ZTD OBSERVATION ERROR IS FROM ZTD *'
write(NULOUT,*)' * USING SD(O-P) STATS (REGRESSION) *'
write(NULOUT,*)' * *'
write(NULOUT,*)' *****************************************'
write(NULOUT,*)' '
ENDIF
C
C-------- FILTER GPS DATA (EXPERIMENTAL) --------------------
C
IF (L1GPSOBS) THEN
write(NULOUT,*)' '
write(NULOUT,*)' *****************************************'
write(NULOUT,*)' * PREPROC PREPROC PREPROC PREPROC *'
write(NULOUT,*)' * GB-GPS OBSERVATIONS *'
write(NULOUT,*)' * *'
write(NULOUT,*)' * --- ONE OBSERVATION MODE --- *'
write(NULOUT,*)' * *'
write(NULOUT,*)' *****************************************'
write(NULOUT,*)' '
write(NULOUT,*)' CGPSSTN = ', CGPSSTN
write(NULOUT,*)' '
CALL SUGPSGB(nulout)
ENDIF
c
endif
c
endif
! call tmg_stop(22)
c
c
C=======================================================================
ZJO = ZJORAOB + ZJOSATEM + ZJOHUMSAT + ZJOAIREP + ZJOSATWIND +
$ ZJOSURFC + ZJOTOV + ZJOGOES + ZJOPROF + ZJOGPSRO + ZJOGPSGB
C=======================================================================
write(nulout,'(a15,G12.6)') 'JORAOB= ',ZJORAOB
c write(nulout,'(a15,G12.6)') 'JOSATEM= ',ZJOSATEM
c write(nulout,'(a15,G12.6)') 'JOHUMSAT= ',ZJOHUMSAT
write(nulout,'(a15,G12.6)') 'JOAIREP= ',ZJOAIREP
write(nulout,'(a15,G12.6)') 'JOSURFC= ',ZJOSURFC
write(nulout,'(10X,a15,G12.6)') 'JOSFCSF= ',ZJOSFCSF
write(nulout,'(10X,a15,G12.6)') 'JOSFCUA= ',ZJOSFCUA
write(nulout,'(10X,a15,G12.6)') 'JOSFCSC= ',ZJOSFCSC
write(nulout,'(10X,a15,G12.6)') 'JOSFCGP= ',ZJOSFCGP
write(nulout,'(a15,G12.6)') 'JOTOV= ',ZJOTOV
write(nulout,'(a15,G12.6)') 'JOGOES= ',ZJOGOES
write(nulout,'(a15,G12.6)') 'JOSATWIND= ',ZJOSATWIND
write(nulout,'(a15,G12.6)') 'JOPROF= ',ZJOPROF
write(nulout,'(a15,G12.6)') 'JOGPSRO= ',ZJOGPSRO
write(nulout,'(a15,G12.6)') 'JOGPSGB= ',ZJOGPSGB
c write(nulout,'(a15,G12.6)') 'Total Jo = ',ZJO
c
c------ Calculate the normalized innovations (Z - H(X))/sigma
c for ln q for atmospheric and surface obs.
C
if(.not.lsw) CALL DHUPPP('UA')
if(.not.lsw) CALL DHUPPP('AI')
if(.not.lsw) CALL DHUSFC('UA')
if(.not.lsw) CALL DHUSFC('SF')
if(.not.lsw) CALL DHUSFC('GP')
C
c Find interpolation layer in model profiles and reference level
c of thickness data for SATEMS
c
if(lldo) CALL VOBSLYRS('BG')
c
c Generate realization of BG error in obs space to be saved in posv file
c
! call tmg_start(25,'randhbht')
IF(NCONF.eq.141.and.LHBHT1) THEN
call randhbht1
ENDIF
! call tmg_stop(25)
c
IF (LVARQC) THEN
CALL SUASYM2(NVADIM,VATRA(1),VATRA(NVADIM+1))
endif
c
call oda_masksf('UA')
call oda_masksf('SF')
call oda_masksf('SC')
call oda_masksf('GP')
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')
call oda_maskgp
!
! In Shallow-Water mode: Force all retained data (i.e. cmabdy.ftn using NONELEV)
! to have same interpolation layer index for future use by lobsppp_sw etc...
!
if(lsw) then
call set1lev ! set SW analysis level "mk".
DO JDATA=1,NDATA
if(ROBDATA(NCMLYR,JDATA).ne.0) then
ROBDATA(NCMLYR,JDATA) = mk
endif
ENDDO
endif
!resotre Global Masks.
IF(NCONF == 141) CALL restoreMasks
!
RETURN
END