!-------------------------------------- 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 SIGMAOP 3,31
#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)
* J. St-James *CMDA/SMC - July 2003
* . Add code for profiler data
* J.M. Aparicio *ARMA/MSC* October 2006
* . Adapt for GPSRO
* Luc Fillion *ARMA/EC - 4 Aug 2009
* . Include lcva_hemis option.
* S. Macpherson *ARMA/EC - 11 Sep 2009
* . Add code for GB-GPS data
#endif
IMPLICIT NONE
#include "comlun.cdk"
#include "comcst.cdk"
#include "pardim.cdk"
#include "comdim.cdk"
#include "comcva.cdk"
#include "comgem.cdk"
#include "comgd0.cdk"
#include "compstat.cdk"
INTEGER JLAT, JLON ,J
CHARACTER*8 CLETIKET
CHARACTER*1 CLTYPVAR,CLGRTYP
CHARACTER*2 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
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'
if(lcva_hemis) CLETIKET = 'SDZONAL'
write(nulout,*) 'sigmaop: CLETIKET = ',CLETIKET
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) = (ZBUFFER(JLAT,J)/CONPHY(JLAT))*RMSKNT
else
UT0(JLON,J,JLAT) = (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
CALL BILIN
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 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
if(.not.lcva_hemis) then
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
endif
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+4*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 READ IN LN Q FIRST-GUESS ERRORS FOR SETFGEGPS
C ---------------------------------------------
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
C
C Apply 3D amplification factor to LQ
C
!
DO JLAT = 1, NJ
DO J = 1, NFLEV
DO JLON = 1, NI
Q0(JLON,J,JLAT)=
+ 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 GB-GPS ZTD DATA
C ------------------------------------------------
C
CALL SETFGEGPS
C
CALL HPDEALLC(PXZBUFFER,IERR,1)
CALL HPDEALLC(PXTRANS,IERR,1)
RETURN
END