!-------------------------------------- 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 sigmaopgl,22
#if defined (DOC)
*Author : Luc Fillion - ARMA/EC - May 2010 - Grdtyp = 'GU', lcva_hemis = .true. : For Regional system.
! N.B.: Amplification factor totally discarded here.
! N.B.: Validated only for Input fields defined on same Gaussian grid and dimensions as ni,nj.
*Author : Luc Fillion - ARMA/EC - 6 Aug 2010 - Improve naming of
* cletiket where we expect 3D global st-dev of basic gridpoint variables for background check.
*
*Revision:
#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"
#include "comgrd_param.cdk"
#include "comgemla.cdk"
!
logical llinterp
INTEGER JLAT, JLON
CHARACTER*8 CLETIKET,cletiket2
CHARACTER*1 CLTYPVAR,CLGRTYP
CHARACTER*2 CLNOMVAR
INTEGER IULSSF,IDATEO
INTEGER VFSTLIR,FSTPRM,FNOM,FSTOUV,FCLOS,FSTFRM
INTEGER IKEY,IERR,IDATE
integer ikind,ibrpstamp,fstinf
integer ip1_pak_trl,ip1_vco_trl
integer :: k,koutmpg ! the unit which has the selected records.
!
INTEGER INI,INJ,INK, INPAS, INBITS, IDATYP, IDEET
+ ,IP1,IP2,IP3,IG1,IG2,IG3,IG4,ISWA,ILENGTH,IDLTF
+ ,IUBC,IEXTR1,IEXTR2,IEXTR3
integer iini
integer jj,ig1tic,ig2tic,ig3tic,ig4tic
integer inlev,jk,ji,ezgdef_fmem,ezqkdef
integer igridid_glb,itargetid
integer iip1s_trl(jpnflev)
integer iip2,iip3
!
real zptop4, zpref4,zrcoef4,zdummy
!
!
real*8 z2dglb(ni,nj)
!
!!
!
!*1. Set global grid identifier and dimensions assumed present in the statistics file
! It is assumed the input st-dev are on a non-rotated Gaussian grid
! of same ni,nj
! --------------------------------------------------------------------------------
!
ibrpstamp = -1
cletiket = 'GDGUSDEV'
write(nulout,*) 'sigmaopgl: Look for etiket = ',CLETIKET
cltypvar = ' '
!
ikey = fstinf(nulbgst,ini,inj,ink,-1,cletiket,
& -1,-1,-1,' ','TT')
write(nulout,*) 'sigmaopgl: ini,inj = ',ini,inj
write(nulout,*) 'sigmaopgl: ni,nj = ',ni,nj
if(ini.ne.ni.or.inj.ne.nj) then
call abort3d(nulout,'sigmaopgl: Input grid ini,inj not OK !!')
endif
!
! Get IP1 values from trial field
!
call getfldprm2(IIP1S_TRL,IIP2,IIP3,INK,cletiket2,cltypvar
& ,igridid_glb,'TT',-1,nflev,nulbgst
& ,nulout,ip1_pak_trl,ip1_vco_trl,ntrials,koutmpg)
!
!*3. READ IN STANDARD DEVIATION FOR EACH OBSERVATION TYPE
! ----------------------------------------------------
!
IULSSF=NULBGST
!
IDATE = -1
IP1 = -1
IP2 = -1
IP3 = -1
CLTYPVAR =' '
!
CLNOMVAR = 'P0'
IKEY = VFSTLIR(z2dglb,IULSSF,INI,INJ,INK,IDATE
& ,CLETIKET,IP1,IP2,IP3,CLTYPVAR,CLNOMVAR)
!
DO JLAT = 1, INJ
DO JLON=1,INI
if(IG2 .eq. 0) then
GPS0(JLON,1,INJ-JLAT+1) = z2dglb(jlon,JLAT)*RMBTPA
else
GPS0(JLON,1,JLAT) = z2dglb(jlon,JLAT)*RMBTPA
endif
END DO
END DO
!
! Loop over Levels for each 3D Variables
! --------------------------------------
!
DO jk = 1, NFLEV
ip1 = iip1s_trl(jk)
!
CLNOMVAR = 'UU'
IKEY = VFSTLIR(z2dglb,IULSSF,INI,INJ,INK,IDATE
& ,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 JLAT = 1, INJ
DO JLON=1,INI
if(IG2 .eq. 0) then
UT0(JLON,jk,INJ-JLAT+1) = (z2dglb(jlon,JLAT)/CONPHY(JLAT))*RMSKNT
else
UT0(JLON,jk,JLAT) = (z2dglb(jlon,JLAT)/CONPHY(JLAT))*RMSKNT
endif
END DO
END DO
!
CLNOMVAR = 'VV'
IKEY = VFSTLIR(z2dglb,IULSSF,INI,INJ,INK,IDATE
& ,CLETIKET,IP1,IP2,IP3,CLTYPVAR,CLNOMVAR)
!
DO JLAT = 1, INJ
DO JLON=1,INI
if(IG2 .eq. 0) then
VT0(JLON,jk,INJ-JLAT+1) = (z2dglb(jlon,JLAT)/CONPHY(JLAT))*RMSKNT
else
VT0(JLON,jk,JLAT) = (z2dglb(jlon,JLAT)/CONPHY(JLAT))*RMSKNT
endif
END DO
END DO
!
CLNOMVAR = 'ES'
IKEY = VFSTLIR(z2dglb,IULSSF,INI,INJ,INK,IDATE
& ,CLETIKET,IP1,IP2,IP3,CLTYPVAR,CLNOMVAR)
!
DO JLAT = 1, INJ
DO JLON=1,INI
if(IG2 .eq. 0) then
q0(JLON,jk,INJ-JLAT+1) = z2dglb(jlon,JLAT)
else
q0(JLON,jk,JLAT) = z2dglb(jlon,JLAT)
endif
END DO
END DO
!
CLNOMVAR = 'GZ' ! n.b. Being put into tt0 below....
IKEY = VFSTLIR(z2dglb,IULSSF,INI,INJ,INK,IDATE
& ,CLETIKET,IP1,IP2,IP3,CLTYPVAR,CLNOMVAR)
!
DO JLAT = 1, INJ
DO JLON=1,INI
if(IG2 .eq. 0) then
tt0(JLON,jk,INJ-JLAT+1) = z2dglb(jlon,JLAT)*RG*10.
else
tt0(JLON,jk,JLAT) = z2dglb(jlon,JLAT)*RG*10.
endif
END DO
END DO
END DO ! end loop on jk
!
call bilin
!cluc call bilin_sigmab
CALL TRQTOES
!cluc CALL TRTTOGZ j'ai deja rempli gomgz et gomtt proprement...
!
! SET THE FIRST-GUESS ERRORS FOR CONVENTIONAL DATA ON PRESSURE LEVELS
! --------------------------------------------------------------------
!
CALL SETFGEFAM('AI')
CALL SETFGEFAM('SW')
CALL SETFGEFAM('UA')
CALL SETFGEFAM('SF')
CALL SETFGEFAM('HU')
CALL SETFGEFAMZ('PR')
!
! SET THE FIRST-GUESS ERRORS FOR RADIO OCCULTATION DATA
! -----------------------------------------------------
!
CALL SETFGEDIF('RO')
C
C DO TEMPERATURE FIRST-GUESS ERROR
C ---------------------------------
C
CLNOMVAR = 'TT'
IKEY = VFSTLIR(z2dglb,IULSSF,INI,INJ,INK,IDATE
& ,CLETIKET,IP1,IP2,IP3,CLTYPVAR,CLNOMVAR)
!
DO JLAT = 1, INJ
DO JLON=1,INI
if(IG2 .eq. 0) then
tt0(JLON,jk,INJ-JLAT+1) = z2dglb(jlon,JLAT)
else
tt0(JLON,jk,JLAT) = z2dglb(jlon,JLAT)
endif
END DO
END DO
!
CALL SETFGETT
!
! SET THE FIRST-GUESS ERRORS FOR THE SURFACE DATA
! ------------------------------------------------
!
CALL SETFGESURF
! READ IN LN Q FIRST-GUESS ERRORS FOR SETFGEGPS
! ---------------------------------------------
!
CLNOMVAR = 'LQ'
!
DO jk = 1, NFLEV
IKEY = VFSTLIR(z2dglb,IULSSF,INI,INJ,INK,IDATE
& ,CLETIKET,IP1,IP2,IP3,CLTYPVAR,CLNOMVAR)
!
DO JLAT = 1, inj
DO JLON=1, ini
if(IG2 .eq. 0) then
Q0(JLON,jk,INJ-JLAT+1) = z2dglb(jlon,JLAT)
else
Q0(JLON,jk,JLAT) = z2dglb(jlon,JLAT)
endif
END DO
END DO
END DO
!
CALL bilin
!cluc CALL bilin_sigmab
!
! SET THE FIRST-GUESS ERRORS FOR GB-GPS ZTD DATA
! ----------------------------------------------
!
CALL SETFGEGPS
!
!
RETURN
END