SUBROUTINE SIGMAOP 2,29
#if defined (DOC)
*Author : P. Koklas CMDA/SMC
*
*Revision:
* JM Belanger CMDA/SMC Jan 2001
* . 32 bits conversion
* C Charette ARMA/SMC Oct 2001
* . Replace logical unit NULSTAT by NULBGST
* S. Pellerin *ARMA/SMC nov. 2001
* . reordering of declaration dependencies (for Linux compilation)
* Y. Yang Nov. 2003
* . Added reading for background ozone and other species.
* . Changed calls from BILIN to NEWBILIN.
* J. St-James *CMDA/SMC - July 2003
* . Add code for profiler data
* J.M. Aparicio *ARMA/MSC* October 2006
* . Adapt for GPSRO
*
* Y.J. Rochon ARQX/EC Feb 2006
* . Use of NULBGSTR for 'TR' family.
* . Added call to ch_setfge for 'TR' family.
* Y.J. Rochon ARQX/EC Feb 2007
* . Changes for allowance of water vapour obs in
* 'TR' family. Requires LQ std. dev. instead of
* ES std. dev.
* Y.J. Rochon ARQX/EC June 2010
* . Updated use of DAMPLIBG for GTR0 and PS0
*
#endif
IMPLICIT NONE
#include "comlun.cdk"
#include "comcst.cdk"
#include "pardim.cdk"
#include "comdim.cdk"
#include "comchem.cdk"
#include "comstate.cdk"
#include "comgem.cdk"
#include "comgd0.cdk"
#include "compstat.cdk"
INTEGER JLAT, JLON ,J
CHARACTER*12 CLETIKET
CHARACTER*2 CLTYPVAR
CHARACTER*1 CLGRTYP
CHARACTER*4 CLNOMVAR
INTEGER IULSSF,IDATEO
INTEGER VFSTLIR,FSTPRM,FNOM,FSTOUV,FCLOS,FSTFRM
INTEGER IKEY,ILEN,IERR,IDATE
REAL*8 ZBUFFER(NJ,NFLEV),ZTRANS(NI,NJ),ZJO
POINTER (PXZBUFFER,ZBUFFER),(PXTRANS,ZTRANS)
INTEGER INI,INJ,INK, INPAS, INBITS, IDATYP, IDEET
+ ,IP1,IP2,IP3,IG1,IG2,IG3,IG4,ISWA,ILENGTH,IDLTF
+ ,IUBC,IEXTR1,IEXTR2,IEXTR3
INTEGER LL, NLEV
C----------------------------------------------------------------------
ILEN = NJ*NFLEV
CALL HPALLOC(PXZBUFFER,MAX(1,ILEN),IERR,8)
ILEN = NJ*NI
CALL HPALLOC(PXTRANS,MAX(1,ILEN),IERR,8)
C
C 1. Opening the statistics file
C
IULSSF=NULBGST
C
C . 2.1 Background error standard deviations
C
CLETIKET = 'STDDEV'
IDATE = -1
IP1 = -1
IP2 = -1
IP3 = -1
CLTYPVAR =' '
ILEN = (NJEND -NJBEG +1)*NKGDIM
C
C READ IN STANDARD DEVIATION FOR EACH OBSERVATION TYPE
C
CLNOMVAR = 'UU'
IKEY = VFSTLIR(ZBUFFER,IULSSF,INI,INJ,INK,IDATE
S ,CLETIKET,IP1,IP2,IP3,CLTYPVAR,CLNOMVAR)
IERR = FSTPRM(IKEY,IDATEO,IDEET,INPAS
+ ,INI,INJ,INK, INBITS, IDATYP
+ ,IP1,IP2,IP3,CLTYPVAR,CLNOMVAR,CLETIKET,CLGRTYP
+ ,IG1,IG2,IG3,IG4,ISWA,ILENGTH,IDLTF
+ ,IUBC,IEXTR1,IEXTR2,IEXTR3)
DO J = 1, NFLEV
DO JLAT = 1, NJ
DO JLON=1,NI
ZTRANS(JLON,JLAT) = ZBUFFER(JLAT,J)*RMSKNT
if(IG2 .eq. 0) then
UT0(JLON,J,INJ-JLAT+1) =
1 (ZBUFFER(JLAT,J)/CONPHY(JLAT))*RMSKNT
else
UT0(JLON,J,JLAT) =
1 (ZBUFFER(JLAT,J)/CONPHY(JLAT))*RMSKNT
endif
END DO
END DO
END DO
C
CLNOMVAR = 'VV'
IKEY = VFSTLIR(ZBUFFER,IULSSF,INI,INJ,INK,IDATE
+ ,CLETIKET,IP1,IP2,IP3,CLTYPVAR,CLNOMVAR)
DO J = 1, NFLEV
DO JLAT = 1, NJ
DO JLON=1,NI
ZTRANS(JLON,JLAT) = ZBUFFER(JLAT,J)*RMSKNT
if(IG2 .eq. 0) then
VT0(JLON,J,INJ-JLAT+1) = (ZBUFFER(JLAT,J)/CONPHY(JLAT))*RMSKNT
else
VT0(JLON,J,JLAT) = (ZBUFFER(JLAT,J)/CONPHY(JLAT))*RMSKNT
endif
END DO
END DO
END DO
CLNOMVAR = 'ES'
IKEY = VFSTLIR(ZBUFFER,IULSSF,INI,INJ,INK,IDATE
+ ,CLETIKET,IP1,IP2,IP3,CLTYPVAR,CLNOMVAR)
DO J = 1, NFLEV
DO JLAT = 1, NJ
DO JLON=1,NI
if(IG2 .eq. 0) then
Q0(JLON,J,INJ-JLAT+1) = ZBUFFER(JLAT,J)
else
Q0(JLON,J,JLAT) = ZBUFFER(JLAT,J)
endif
ZTRANS(JLON,JLAT) = ZBUFFER(JLAT,J)
END DO
END DO
END DO
CLNOMVAR = 'GZ'
IKEY = VFSTLIR(ZBUFFER,IULSSF,INI,INJ,INK,IDATE
+ ,CLETIKET,IP1,IP2,IP3,CLTYPVAR,CLNOMVAR)
DO J = 1, NFLEV
DO JLAT = 1, NJ
DO JLON=1,NI
if(IG2 .eq. 0) then
TT0(JLON,J,INJ-JLAT+1) = ZBUFFER(JLAT,J)*RG*10.
else
TT0(JLON,J,JLAT) = ZBUFFER(JLAT,J)*RG*10.
endif
ZTRANS(JLON,JLAT) = ZBUFFER(JLAT,J)
END DO
END DO
END DO
C
C Apply 3D amplification factor
C
DO JLAT = 1, NJ
DO J = 1, NFLEV
DO JLON = 1, NI
UT0(JLON,J,JLAT)=
+ UT0(JLON,J,JLAT)*damplibg(JLON,J,JLAT)
VT0(JLON,J,JLAT)=
+ VT0(JLON,J,JLAT)*damplibg(JLON,J,JLAT)
cbue comment out, because tuning is for LQ, not ES
cbue Q0(JLON,J,JLAT)=
cbue + Q0(JLON,J,JLAT)*damplibg(JLON,J+3*NFLEV,JLAT)
END DO
END DO
END DO
C
C* Background species
C
DO LL = 1, NGCMT
CLNOMVAR = CGCMT(LL)
IF(NGEXIST(NGTR(LL)) .EQ. 1) THEN
if (NULBGSTR.EQ.0)
& CALL ABORT3D(NULOUT,
& 'SIGMAOP: NO SPECIES BACKGROUND STAT FILE!!')
IKEY = VFSTLIR(ZBUFFER,NULBGSTR,INI,INJ,INK,IDATE
+ ,CLETIKET,IP1,IP2,IP3,CLTYPVAR,CLNOMVAR)
NLEV = (LL-1)*NFLEV
DO J = 1, NFLEV
DO JLAT = 1, NJ
DO JLON=1,NI
if(IG2 .eq. 0) then
GTR0(JLON,NLEV+J,INJ-JLAT+1) = ZBUFFER(JLAT,J)
else
GTR0(JLON,NLEV+J,JLAT) = ZBUFFER(JLAT,J)
endif
ZTRANS(JLON,JLAT) = ZBUFFER(JLAT,J)
END DO
END DO
END DO
C
C Apply 3D amplification factor
C
GTR0(1:NI,1+NLEV:NFLEV+NLEV,1:NJ)=GTR0(1:NI,1+NLEV:NFLEV+NLEV,1:NJ)
1 *DAMPLIBG(1:NI,1+(LL-1+4)*NFLEV:NFLEV+(LL-1+4)*NFLEV,1:NJ)
C
ENDIF
ENDDO
c CALL BILIN
CALL NEWBILIN
CALL TRQTOES
CALL TRTTOGZ
C
C SET THE FIRST-GUESS ERRORS FOR CONVENTIONAL DATA ON PRESSURE LEVELS
C --------------------------------------------------------------------
C
CALL SETFGEFAM('AI')
CALL SETFGEFAM('SW')
CALL SETFGEFAM('UA')
CALL SETFGEFAM('SF')
CALL SETFGEFAM('HU')
CALL SETFGEFAMZ('PR')
C
C SET THE FIRST-GUESS ERRORS FOR RADIO OCCULTATION DATA
C -----------------------------------------------------
C
CALL SETFGEDIF('RO')
C
C SET THE FIRST-GUESS ERRORS FOR 'TR' FAMILY DATA
C -----------------------------------------------
C
C 'TR' family (mostly chemical species obs)
C
C First reload with LQ std. dev. instead of ES std. dev.
C in case it is needed for water vapour obs.
C
CLNOMVAR = 'LQ'
IKEY = VFSTLIR(ZBUFFER,IULSSF,INI,INJ,INK,IDATE
+ ,CLETIKET,IP1,IP2,IP3,CLTYPVAR,CLNOMVAR)
DO J = 1, NFLEV
DO JLAT = 1, NJ
DO JLON=1,NI
if(IG2 .eq. 0) then
Q0(JLON,J,INJ-JLAT+1) = ZBUFFER(JLAT,J)
else
Q0(JLON,J,JLAT) = ZBUFFER(JLAT,J)
endif
END DO
END DO
END DO
call gd2mvo('Q0',nflev)
C
CALL CH_SETFGE
C
C DO TEMPERATURE FIRST-GUESS ERROR
C ---------------------------------
C
CLNOMVAR = 'TT'
IKEY = VFSTLIR(ZBUFFER,IULSSF,INI,INJ,INK,IDATE
+ ,CLETIKET,IP1,IP2,IP3,CLTYPVAR,CLNOMVAR)
DO J = 1, NFLEV
DO JLAT = 1, NJ
DO JLON=1,NI
if(IG2 .eq. 0) then
TT0(JLON,J,INJ-JLAT+1) = ZBUFFER(JLAT,J)
else
TT0(JLON,J,JLAT) = ZBUFFER(JLAT,J)
endif
ZTRANS(JLON,JLAT) = ZBUFFER(JLAT,J)
END DO
END DO
END DO
C
C Apply 3D amplification factor
C
DO JLAT = 1, NJ
DO J = 1, NFLEV
DO JLON = 1, NI
TT0(JLON,J,JLAT)=
+ TT0(JLON,J,JLAT)*damplibg(JLON,J+2*NFLEV,JLAT)
END DO
END DO
END DO
CALL BILIN
CALL SETFGETT
C
C
C DO SATEM FIRST-GUESS ERROR
C --------------------------
C
CLNOMVAR = 'DZ'
IKEY = VFSTLIR(ZBUFFER,IULSSF,INI,INJ,INK,IDATE
+ ,CLETIKET,IP1,IP2,IP3,CLTYPVAR,CLNOMVAR)
DO J = 1, INK
DO JLAT = 1, NJ
DO JLON=1,NI
if(IG2 .eq. 0) then
TT0(JLON,J,INJ-JLAT+1) = ZBUFFER(JLAT,J)*10.
else
TT0(JLON,J,JLAT) = ZBUFFER(JLAT,J)*10.
endif
ZTRANS(JLON,JLAT) = ZBUFFER(JLAT,J)
END DO
END DO
END DO
CALL BILIN
call trttogz
CALL SETFGEST
C
C RELOAD DATA TO DO SURFACE FIRST-GUESS ERRORS
C ---------------------------------------------
C
CLNOMVAR = 'P0'
IKEY = VFSTLIR(ZBUFFER,IULSSF,INI,INJ,INK,IDATE
+ ,CLETIKET,IP1,IP2,IP3,CLTYPVAR,CLNOMVAR)
DO J = 1, INK
DO JLAT = 1, NJ
DO JLON=1,NI
if(IG2 .eq. 0) then
GPS0(JLON,J,INJ-JLAT+1) = ZBUFFER(JLAT,J)*RMBTPA
else
GPS0(JLON,J,JLAT) = ZBUFFER(JLAT,J)*RMBTPA
endif
END DO
END DO
END DO
C
CLNOMVAR = 'UU'
IKEY = VFSTLIR(ZBUFFER,IULSSF,INI,INJ,INK,IDATE
+ ,CLETIKET,IP1,IP2,IP3,CLTYPVAR,CLNOMVAR)
DO J = 1, NFLEV
DO JLAT = 1, NJ
DO JLON=1,NI
if(IG2 .eq. 0) then
UT0(JLON,J,INJ-JLAT+1) = (ZBUFFER(JLAT,J)/CONPHY(JLAT))*RMSKNT
else
UT0(JLON,J,JLAT) = (ZBUFFER(JLAT,J)/CONPHY(JLAT))*RMSKNT
endif
END DO
END DO
END DO
CLNOMVAR = 'VV'
IKEY = VFSTLIR(ZBUFFER,IULSSF,INI,INJ,INK,IDATE
+ ,CLETIKET,IP1,IP2,IP3,CLTYPVAR,CLNOMVAR)
DO J = 1, NFLEV
DO JLAT = 1, NJ
DO JLON=1,NI
if(IG2 .eq. 0) then
VT0(JLON,J,INJ-JLAT+1) = (ZBUFFER(JLAT,J)/CONPHY(JLAT))*RMSKNT
else
VT0(JLON,J,JLAT) = (ZBUFFER(JLAT,J)/CONPHY(JLAT))*RMSKNT
endif
END DO
END DO
END DO
CLNOMVAR = 'TT'
IKEY = VFSTLIR(ZBUFFER,IULSSF,INI,INJ,INK,IDATE
+ ,CLETIKET,IP1,IP2,IP3,CLTYPVAR,CLNOMVAR)
DO J = 1, NFLEV
DO JLAT = 1, NJ
DO JLON=1,NI
if(IG2 .eq. 0) then
TT0(JLON,J,INJ-JLAT+1) = ZBUFFER(JLAT,J)
else
TT0(JLON,J,JLAT) = ZBUFFER(JLAT,J)
endif
END DO
END DO
END DO
CLNOMVAR = 'ES'
IKEY = VFSTLIR(ZBUFFER,IULSSF,INI,INJ,INK,IDATE
+ ,CLETIKET,IP1,IP2,IP3,CLTYPVAR,CLNOMVAR)
DO J = 1, NFLEV
DO JLAT = 1, NJ
DO JLON=1,NI
if(IG2 .eq. 0) then
Q0(JLON,J,INJ-JLAT+1) = ZBUFFER(JLAT,J)
else
Q0(JLON,J,JLAT) = ZBUFFER(JLAT,J)
endif
END DO
END DO
END DO
C
C Apply 3D amplification factor
C
DO JLAT = 1, NJ
DO JLON = 1, NI
GPS0(JLON,1,JLAT) =
+ GPS0(JLON,1,JLAT)*damplibg(JLON,1+(nvgd+nvgaux)*NFLEV,JLAT)
END DO
END DO
DO JLAT = 1, NJ
DO J = 1, NFLEV
DO JLON = 1, NI
UT0(JLON,J,JLAT)=
+ UT0(JLON,J,JLAT)*damplibg(JLON,J,JLAT)
VT0(JLON,J,JLAT)=
+ VT0(JLON,J,JLAT)*damplibg(JLON,J,JLAT)
TT0(JLON,J,JLAT)=
+ TT0(JLON,J,JLAT)*damplibg(JLON,J+2*NFLEV,JLAT)
cbue comment out, because tuning is for LQ, not ES
cbue Q0(JLON,J,JLAT)=
cbue + Q0(JLON,J,JLAT)*damplibg(JLON,J+3*NFLEV,JLAT)
END DO
END DO
END DO
CALL BILIN
C
C SET THE FIRST-GUESS ERRORS FOR THE SURFACE DATA
C ------------------------------------------------
C
CALL SETFGESURF
C
CALL HPDEALLC(PXZBUFFER,IERR,1)
CALL HPDEALLC(PXTRANS,IERR,1)
RETURN
END