!-------------------------------------- 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 sugomobs 1,55
use modfgat
, only : nstamplist, nobsgid, nobs, notag, nstepobs
use stag_shared, only : tg_vco_trl,tg_vgrid_trl
#if defined (DOC)
*
***s/r sumgomobs
*
*
* Author : S. Pellerin ARMA/AES Nov. 1999
* Revision:
* Revision: C.Chouinard ARMA/SMC Aout 2000
* Ajouter la lecture de TG champ 2D
* JM Belanger CMDA/SMC Aug 2000
* . 32 bits conversion
** S. Pellerin *ARMA/SMC nov. 2001
* . Management of first guess at appropriate time
* C. Charette - ARMA/SMC - Sep. 2004
* . Conversion to hybrid vertical coordinate
* C. Charette - ARMA/SMC - Apr. 2006
* . Replaced "call subasic" by "call subasic_obs"
* Note subasic_obs is the version of subasic for the
* hybrid coordinate.
* Bin He - *ARMA/SMC - Jan. 2008
* . Added reading multiple trial files.
* S. Pellerin, ARMA, August 2008
* . Simplification
* . Work on allocation/deallocation (hpalloc -> allocate)
* . Optimisation
* . Remove of the horizontal staggered trials
* mechanism
* . Call to getfldprm2(multiple trial files)
* L. Fillion - Jul 08 - Introduce parameter nkt (to complement nit,njt of trial).
* S. Pellerin, ARMA, January 2009
* . Remove a debug printout line
* L. Fillion - ARMA/EC - 07 May 2009 - Upgrade 3dvar LU and GU mode to v_10_2_2.
* 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: Fill in GOMOBS with trial profiles
*
*
*
*
*
*Arguments
*
#endif
implicit none
*implicits
#include "comlun.cdk"
#include "pardim.cdk"
#include "comdim.cdk"
#include "comdimo.cdk"
#include "commvo.cdk"
#include "commvog.cdk"
#include "comgem.cdk"
#include "comgdpar.cdk"
#include "cvcord.cdk"
#include "comcst.cdk"
#include "commvohr.cdk"
c
c----------------------------------------------------------
c
integer vfstlir,vezuvint,vezsint,ezdefset,ezqkdef,ezgprm,ip1f
integer ezsetopt,fclos,jstep
integer jlev,jobs,ier,iset,jij,gdll
integer ini, inj, iig1, iig2, iig3, iig4,ink,jvar,fnom
integer ikeys(jpnflev),itrlnlev,itrlnlev2,istep,iultemp
character*1 clgrtyp,cltypvar
character*8 cletiket
real*8 zlat(354,415),zlon(354,415)
real*8, allocatable, dimension(:,:) :: zvar,zvar2,zmobs,zmobs2
cnwa Ajoute vecteurs pour la pression des niveaux thermo et momentum
real*8, allocatable, dimension(:,:) :: zmobs_T,zmobs_M,zmobs2_M
real*8, allocatable, dimension(:,:) :: zmobs_MT,zmobs2_MT
real*8, allocatable, dimension(:,:) :: zppobs_MT,zppobs_T,zppobs_M
real*8 zovar(1),zovar2(1),zpt(1)
real*8, allocatable, dimension(:) :: zopart,zopart2,zlev,zhybhr
real*8 zom(1),zom_T(1),zom_M(1)
real*8 vlevf
integer VHYBRID_TO_PRES
integer ipmode,ipkind,ip1_pak_trl,ip1_vco_trl
real*8 zptophr,zrcoefhr,zprefhr
real zptop4,zrcoef4,zpref4
character*1 clstring
logical llpt
logical lluv,lllochr_T,lllochr_M
integer nlv_T,nlv_M,nlvtot
c
integer itrlgid,itrlgid2,iip1s(jpnflev),iip1,iip2,iip3,ip1_hyb_prm
integer iip1s2(jpnflev*2)
c
integer, allocatable, dimension(:) :: idate,itime,nultrl
integer :: newdate,nstepanltime
integer :: k ! the unit which has the selected records.
pointer (pzovar,zovar)
pointer (pzovar2,zovar2)
pointer (pzpt,zpt),(pzom,zom),(pzom_T,zom_T),(pzom_M,zom_M)
c
lllochr_T = .false.
lllochr_M = .false.
c
write(nulout,*) ' '
write(nulout,*) '-------- ENTERING SUGOMOBS ---------'
write(nulout,*) ' '
c
call hpalloc(pzom,max(nflev*nobtot,1),ier,8)
call hpalloc(pzom_T,max(nflev*nobtot,1),ier,8)
call hpalloc(pzom_M,max(nflev*nobtot,1),ier,8)
call hpalloc(pzovar,max(nobtot,1),ier,8)
call hpalloc(pzovar2,max(nobtot,1),ier,8)
allocate(zopart(max(maxval(nobs),1)))
allocate(zopart2(max(maxval(nobs),1)))
llpt = .false.
if(llpt) then
call hpalloc(pzpt,max(nobtot,1),ier,8)
c-------endif de llpt
endif
allocate(idate(max(nstepobs,1)))
allocate(itime(max(nstepobs,1)))
allocate(nultrl(max(nstepobs,1)))
c Computing date and time of step obs for error message
do jstep = 1,nstepobs
ier = newdate(nstamplist(jstep),idate(jstep),itime(jstep),-3)
itime(jstep) = itime(jstep)
enddo
c
c Setting degree of horizontal interpolations
c
ier = ezsetopt('INTERP_DEGREE', 'LINEAR')
c
c------- fill gomobsg with zero
c
do jlev=1,nkgdimo
do jobs=1,nobtot
gomobsg(jlev,jobs) = 0.
enddo
enddo
c
c Get vertical coordinate parameters from trial field !! structure
c
nlv_M = tg_vco_trl%ink_M
nlv_T = tg_vco_trl%ink_T
nlvtot = nlv_M + nlv_M
write(nulout,*)'sugomobs:niv thermo:',nlv_T,' momentum',nlv_M
c
zptophr = tg_vco_trl%dpt_T
zprefhr = tg_vco_trl%dprf_T
zrcoefhr= tg_vco_trl%drcf2
c
write(nulout,*)'sugomobs:zptophr,zprefhr,zrcoefhr ',zptophr
& ,zprefhr,zrcoefhr
c
c Allocation des tableaux a remplir par fillmvo
c
istep = nlv_T
nlevtrl = nlv_T
nlevtrl_T = nlv_T
nlevtrl_M = nlv_M
nkt = nlv_T
nkgdimohr = nvo3d*istep + nvo2d
call locptgomhr(istep)
c
c reading 2D fields
c
nultrl=0
do jvar=1, nfstvar2d
do jstep = 1,nstepobs
if(nstamplist(jstep) == nbrpstamp) nstepanltime = jstep
if(nultrl(jstep) == 0) then
call getfldprm2(IIP1S,IIP2,IIP3,ITRLNLEV,CLETIKET,CLTYPVAR
& ,ITRLGID,cfstvar2d(jvar),nstamplist(jstep),jpnflev
& ,ninmpg,nulout,ip1_pak_trl,ip1_vco_trl,ntrials
& ,nultrl(jstep))
else
call getfldprm(IIP1S,IIP2,IIP3,ITRLNLEV
& ,CLETIKET,CLTYPVAR,ITRLGID,cfstvar2d(jvar)
& ,nstamplist(jstep),jpnflev,nultrl(jstep),nulout
& ,ip1_pak_trl,ip1_vco_trl)
endif
if(nobs(jstep) > 0) then
if(itrlnlev <= 0) then
write(nulout,1002) cfstvar2d(jvar),idate(jstep)
& ,itime(jstep)
call abort3d(nulout
& ,'SUGOMOBS:Problem with background file')
endif
c
ier = ezgprm(itrlgid,clgrtyp,ini,inj,iig1,iig2,iig3,iig4)
c
if (.not. allocated(zvar)) allocate(zvar(ini,inj))
c
ier=vfstlir(zvar,nultrl(jstep),ini,inj,ink,
& nstamplist(jstep) ,cletiket,iip1s(1),iip2,iip3,
& cltypvar,cfstvar2d(jvar))
if(ier.lt.0)then
write(nulout,1001) cfstvar2d(jvar),iip1s(1),idate(jstep)
& ,itime(jstep)
call abort3d(nulout
& ,'SUGOMOBS:Problem with background file')
end if
c
iset = ezdefset(nobsgid(jstep),itrlgid)
ier = vezsint(zopart(1:nobs(jstep)),zvar,nobs(jstep),1,1,ini
& ,inj,1)
do jobs = 1, nobs(jstep)
zovar(notag(jobs,jstep)) = zopart(jobs)
enddo
endif
enddo
c
call fillmvo('BG',cfstvar2d(jvar),'NA',zovar,1,nobtot)
c
enddo
c
c
c-----Derive the pressure fields at observation points from the hybrid
C levels(vhybinc), the hybrid coordinate parameters of the
C increment analysis and the surface pressure of the trial field
do jobs = 1,nobtot
zovar(jobs) = gompsg(1,jobs)
enddo
c
call calcpres(RPPOBS(1,1),vhybinc,nflev,zovar,rptopinc
& ,rprefinc,rcoefinc,nobtot)
c write(nulout,*) 'sugomobs: jlev, vhybinc(jlev), RPPOBS(jlev,1) '
if (nobtot.gt.0) then
do jlev = 1,nflev
write(nulout,*) jlev,vhybinc(jlev),RPPOBS(jlev,1)
enddo
else
write(nulout,*) 'sugomobs: NO jlev, RPPOBS(jlev,1) TO PRINT since NOBTOT = 0'
endif
c
CCC plug in
c ------- Interpolation of the 3D fields
c
if (.not. allocated(zmobs)) allocate(zmobs( nlv_T,max(nobtot,1)))
if (.not. allocated(zmobs_T)) allocate(zmobs_T( nlv_T,max(nobtot,1)))
if (.not. allocated(zmobs_MT)) allocate(zmobs_MT( nlv_T,max(nobtot,1)))
if (.not. allocated(zmobs2_MT)) allocate(zmobs2_MT(nlv_T,max(nobtot,1)))
if (.not. allocated(zppobs_MT)) allocate(zppobs_MT(nlv_T,max(nobtot,1)))
if (.not. allocated(zppobs_T)) allocate(zppobs_T( nlv_T,max(nobtot,1)))
if (.not. allocated(zmobs_M)) allocate(zmobs_M( nlv_M,max(nobtot,1)))
if (.not. allocated(zmobs2_M)) allocate(zmobs2_M (nlv_M,max(nobtot,1)))
if (.not. allocated(zppobs_M)) allocate(zppobs_M( nlv_M,max(nobtot,1)))
if (.not. allocated(zhybhr)) allocate(zhybhr( nlv_T))
if (.not. allocated(zlev)) allocate(zlev( nlv_T))
c
c------- Calculate profiles of pressure values at station location
write(nulout,*) 'sugomobs:iversion= ',tg_vco_trl%iversion
write(nulout,*) 'sugomobs:ikind= ',tg_vco_trl%ikind
write(nulout,*) 'sugomobs:svcod= ',tg_vco_trl%svcod
c do jobs = 1,nobtot
c zovar(jobs) = gompsg(1,jobs)
c enddo
c-------Staggered hybrid trial field
if (tg_vco_trl%iversion .eq. 5002) then
call calcpres_vgrid(tg_vgrid_trl,zovar, tg_vco_trl%ip1_M
& ,nlv_M,nobtot,nulout,zppobs_M(1,1))
call calcpres_vgrid(tg_vgrid_trl,zovar, tg_vco_trl%ip1_T
& ,nlv_T,nobtot,nulout,zppobs_T(1,1))
c Copier le niveaux du bas momentum dans le dernier niveau du
c vecteur surdimentionne
cnwa zppobs_M(nlv_T,:) = zppobs_M(nlv_M,:)
c-------ETA trial field
elseif(tg_vco_trl%iversion .eq. 5001) then
call calcpres_vgrid(tg_vgrid_trl,zovar, tg_vco_trl%ip1_M
& ,tg_vco_trl%ink_M,nobtot,nulout,zppobs_M(1,1))
zptophr = tg_vco_trl%dpt_M
zprefhr = tg_vco_trl%dprf_M
zrcoefhr= tg_vco_trl%drcf2
itrlnlev = tg_vco_trl%ink_M
zhybhr = tg_vco_trl%dhyb_M
do jlev = 1,nlv_M
zhybhr(jlev) = tg_vco_trl%dhyb_M(jlev)
enddo
call calcpres(zppobs_M,zhybhr,nlv_M,zovar,zptophr
& ,zprefhr,zrcoefhr,nobtot)
do jlev = 1,nlv_M
do jobs = 1,nobtot
zppobs_T(jlev,jobs) = zppobs_M(jlev,jobs)
enddo
enddo
else
call abort3d(nulout
& ,'SUGOMOBS:Problem with vertical lvls in trial file')
c
endif
c
c Remplir dans un vecteur surdimentionne en repetant le dernier niveau
do jlev = 1, nlv_M
do jobs = 1, nobtot
zppobs_MT(jlev,jobs) = zppobs_M(jlev,jobs)
enddo
enddo
do jobs = 1, nobtot
zppobs_MT(nlv_T,jobs) = zppobs_M(nlv_M,jobs)
enddo
c
c Remplir la pression sur le niveaux du trial au points d'observations
call fillmvo('HR','PP','MM',zppobs_MT,nlv_T,nobtot)
call fillmvo('HR','PP','TH',zppobs_T,nlv_T,nobtot)
call fillmvo('HR','PP','NA',zppobs_T,nlv_T,nobtot)
c
c Remplir les valeur eta ou zeta des niveaux du trial
c surdimension (de 1) vecteur des niveaux momentum
do jlev = 1,nlv_M
zhybhr(jlev) = tg_vco_trl%dhyb_M(jlev)
ccc write(nulout,*) 'MM ZLEV =',tg_vco_trl%dhyb_M(jlev)
ccc write(nulout,*) 'MM IP1 =',tg_vco_trl%ip1_M(jlev)
enddo
c On copie le dernier niveau pour le niveau suplementaire
zhybhr(nlv_T) = zhybhr(nlv_M)
c
call fillmvo('HR','HY','MM',zhybhr,nlv_T,1)
call fillmvo('HR','HY','NA',zhybhr,nlv_T,1)
c
do jlev = 1,nlv_T
zhybhr(jlev) = tg_vco_trl%dhyb_T(jlev)
ccc write(nulout,*) 'TH ZLEV =',tg_vco_trl%dhyb_T(jlev)
ccc write(nulout,*) 'TH IP1 =',tg_vco_trl%ip1_T(jlev)
enddo
call fillmvo('HR','HY','TH',zhybhr,nlv_T,1)
cnwa call fillmvo('HR','LV','NA',zlev,itrlnlev,1)
c
c stop
CCC plug outc
c
c Boucle sur les champs a anlayser
c do jvar=1, nfstvar
c select case ( cfstvar(jvar) )
c
c Variable GZ qui se trouve sur les niveaux momentum et thermodynamiques
c
c case ('GZ')
c
c---- Read topography in model coordinates => Boundary condition for GZ
c
write(nulout,*)' ----- Initializing GZ ----'
c
c Get horizontal field parameters
c
call getfldprm(iip1s2,iip2,iip3,itrlnlev,cletiket,cltypvar
& ,itrlgid,'GZ',nbrpstamp,jpnflev*2
& ,nultrl(nstepanltime),nulout,ip1_pak_trl,ip1_vco_trl)
if(itrlnlev <= 0 ) then
write(nulout,1002) 'GZ',idate((nstepobs-1)/2 + 1)
& ,itime((nstepobs-1)/2 + 1)
call abort3d(nulout
& ,'SUGOMOBS:Problem with background file')
endif
write(nulout,*) ' ITRLNLEV =',itrlnlev
c
ier = ezgprm(itrlgid,clgrtyp,ini,inj,iig1,iig2,iig3,iig4)
c
c Lire les GZ des niveaux Momentum
c
do jlev = 1,nlv_M
do jstep = 1,nstepobs
if(nobs(jstep) > 0) then
ZLEV = tg_vco_trl%dhyb_M(jlev)
IIP1 = tg_vco_trl%ip1_M(jlev)
ccc write(nulout,*) ' ZLEV =',tg_vco_trl%dhyb_M(jlev)
ccc write(nulout,*) ' IP1 =',tg_vco_trl%ip1_M(jlev)
c
ier=vfstlir(ZVAR,nultrl(jstep),ini,inj,ink,
& nstamplist(jstep) ,cletiket,iip1,-1,-1,
& cltypvar,'GZ')
if(ier.lt.0)then
write(nulout,1001) 'GZ',iip1,idate(jstep)
& ,itime(jstep)
call abort3d(nulout
& ,'SUGOMOBS:Problem with background file')
end if
c
iset = ezdefset(nobsgid(jstep),itrlgid)
ier = vezsint(zopart(1:nobs(jstep)),zvar,nobs(jstep),1,1,ini
& ,inj,1)
do jobs = 1, nobs(jstep)
cnwa zmobs((jlev),notag(jobs,jstep)) = zopart(jobs) *10.*rg
c on fait le calcul dans fillmvo
zmobs((jlev),notag(jobs,jstep)) = zopart(jobs)
c Copier le niveaux du bas momentum dans le dernier niveau du
c vecteur surdimentionne
if ( jlev == nlv_M )
& zmobs(nlv_T,notag(jobs,jstep)) = zmobs(jlev,notag(jobs,jstep))
enddo
endif
enddo
enddo
c
c remplir gomobsgzhr_M avec la dimention des niveaux thermo
write(nulout,*) 'sugomobs:GZ_MM(*10.*rg '
do jlev = 1,nlv_T
write(nulout,*) 'GZ,',jlev
& ,zPPOBS_T(jlev,1),zmobs(jlev,1)*10.*rg
enddo
call fillmvo('HR','GZ','MM',zmobs,nlv_T,nobtot)
c
c remplir aussi gomobsgzhr avec le GZ momentum
call fillmvo('HR','GZ','NA',zmobs,nlv_T,nobtot)
c
c Lire les GZ des niveaux Thermodynamique
c
do jlev = 1, nlv_T
do jstep = 1,nstepobs
if(nobs(jstep) > 0) then
ZLEV = tg_vco_trl%dhyb_T(jlev)
IIP1 = tg_vco_trl%ip1_T(jlev)
c write(nulout,*) ' ZLEV =',tg_vco_trl%dhyb_T(jlev)
c write(nulout,*) ' IP1 =',tg_vco_trl%ip1_T(jlev)
c
ier=vfstlir(ZVAR,nultrl(jstep),ini,inj,ink,
& nstamplist(jstep) ,cletiket,iip1,-1,-1,
& cltypvar,'GZ')
if(ier.lt.0)then
write(nulout,1001) 'GZ',iip1,idate(jstep)
& ,itime(jstep)
call abort3d(nulout
& ,'SUGOMOBS:Problem with background file')
end if
c
iset = ezdefset(nobsgid(jstep),itrlgid)
ier = vezsint(zopart(1:nobs(jstep)),zvar,nobs(jstep),1,1,ini
& ,inj,1)
do jobs = 1, nobs(jstep)
c zmobs(jlev,notag(jobs,jstep)) = zopart(jobs) *10.*rg
c La conversion d unite sa fait dasn fillmvo
zmobs(jlev,notag(jobs,jstep)) = zopart(jobs)
c On remplis aussi le champs de GZ a la surface rmtmobs
if (jlev == nlv_T) rmtmobs(notag(jobs,jstep)) = zopart(jobs) *10.*rg
enddo
endif
enddo
enddo
c
c remplir gomobsgzhr_T
write(nulout,*) 'sugomobs:GZ_TH (*10.*rg)'
do jlev = 1,nlv_T
write(nulout,*)'GZ,',jlev
& ,zPPOBS_T(jlev,1),zmobs(jlev,1)*10.*rg
enddo
call fillmvo('HR','GZ','TH',zmobs,nlv_T,nobtot)
c
do jvar=1, nfstvar
select case ( cfstvar(jvar) )
c
c Variables sur les niveaux momentum
c
case ('UU')
write(nulout,*)' '
write(nulout,*)' ----- Initializing UU and VV ----'
write(nulout,*)' '
c
call vflush(nulout)
call getfldprm(iip1s,iip2,iip3,itrlnlev,cletiket,cltypvar
& ,itrlgid,cfstvar(jvar),nbrpstamp,jpnflev
& ,nultrl(nstepanltime),nulout,ip1_pak_trl,ip1_vco_trl)
if(itrlnlev <= 0 .or. itrlnlev /= nlv_M ) then
write(nulout,1002) cfstvar(jvar),idate((nstepobs-1)/2 + 1)
& ,itime((nstepobs-1)/2 + 1)
call abort3d(nulout
& ,'SUGOMOBS:Problem with background file')
endif
write(nulout,*) ' ITRLNLEV =',itrlnlev,' nlv_M ',nlv_M
ier = ezgprm(itrlgid,clgrtyp,ini,inj,iig1,iig2,iig3,iig4)
c
c loop through levels of field jvar
c
c
c Reading 3D fields
c
if (.not. allocated(zvar2)) allocate(zvar2(ini,inj))
call tmg_start(27,'XHR2XY')
do jlev = 1,nlv_M
IIP1=tg_vco_trl%ip1_M(jlev)
do jstep = 1,nstepobs
if(nobs(jstep) > 0) then
iset = ezdefset(nobsgid(jstep),itrlgid)
c
ier=vfstlir(zvar,nultrl(jstep),INI,INJ,INK,
& nstamplist(jstep),cletiket,iip1,-1,-1,
& cltypvar,'UU')
if(ier.lt.0)then
write(nulout,1001) 'UU',iip1,idate(jstep)
& ,itime(jstep)
call abort3d(nulout
& ,'SUGOMOBS:Problem with background file')
end if
c
zvar2 = 0.d0
ier = vezuvint(zopart(1:nobs(jstep))
& ,zopart2(1:nobs(jstep)),zvar,zvar2,nobs(jstep)
& ,ini*inj)
do jobs = 1, nobs(jstep)
zmobs_M(jlev,notag(jobs,jstep)) = zopart(jobs)
zmobs2_M(jlev,notag(jobs,jstep)) = zopart2(jobs)
enddo
c
ier=vfstlir(zvar2,nultrl(jstep),INI,INJ,INK,
& nstamplist(jstep) ,cletiket,iip1,-1,-1,
& cltypvar,'VV')
if(ier.lt.0)then
write(nulout,1001) 'VV',iip1,idate(jstep)
& ,itime(jstep)
call abort3d(nulout
& ,'SUGOMOBS:Problem with background file')
endif
c
zvar = 0.d0
ier = vezuvint(zopart(1:nobs(jstep))
& ,zopart2(1:nobs(jstep)),zvar,zvar2,nobs(jstep)
& ,ini*inj)
c
do jobs = 1, nobs(jstep)
zmobs_M(jlev,notag(jobs,jstep)) = zmobs_M(jlev
& ,notag(jobs,jstep)) + zopart(jobs)
zmobs2_M(jlev,notag(jobs,jstep)) = zmobs2_M(jlev
& ,notag(jobs,jstep)) + zopart2(jobs)
enddo
c Utiliser ceci si on ne veut plus fait l'inerpolation vectorielle
c ier=vfstlir(zvar,nultrl(jstep),INI,INJ,INK,
c & nstamplist(jstep) ,cletiket,iip1,-1,-1,
c & cltypvar,cfstvar(jvar))
c if(ier.lt.0)then
c write(nulout,1001) cfstvar(jvar),iip1,idate(jstep)
c & ,itime(jstep)
c call abort3d(nulout
c & ,'SUGOMOBS:Problem with background file')
c end if
c
c ier = vezsint(zopart(1:nobs(jstep)),zvar,nobs(jstep),1
c & ,1,ini,inj,1)
c do jobs = 1, nobs(jstep)
c zmobs_M(jlev,notag(jobs,jstep)) = zopart(jobs)
c enddo
endif
enddo
enddo
c
ccc do jobs = 1,nobtot
ccc zovar(jobs) = gompsg(1,jobs)
ccc enddo
c
ccc print*,'calcpres zppobs_M',itrlnlev,zovar,zptophr
ccc & ,zprefhr,zrcoefhr,nobtot
ccc write(nulout,*) 'sugomobs:jlev,zhybhr(jlev),zPPOBS_M(jlev,1)'
ccc do jlev = 1,nflev
ccc write(nulout,*) jlev,zhybhr(jlev),zPPOBS_M(jlev,1)
ccc enddo
ccc a deplacer call tmg_stop(28)
call tmg_start(29,'VINTPROF')
call flush(6)
c
call vintprof(zom_M,rppobs,nflev,zmobs_M,zppobs_M,nlv_M,nobtot)
call flush(6)
call fillmvo('BG','UU','NA',zom_M,nflev,nobtot)
c
call flush(6)
call vintprof(zom_M,rppobs,nflev,zmobs2_M,zppobs_M,nlv_M,nobtot)
call flush(6)
call fillmvo('BG','VV','NA',zom_M,nflev,nobtot)
c
call flush(6)
c Remplir dans un vecteur surdimentionne en repetant le dernier niveau
do jlev = 1, nlv_M
zmobs_MT(jlev,:) = zmobs_M(jlev,:)
zmobs2_MT(jlev,:) = zmobs2_M(jlev,:)
enddo
call flush(6)
zmobs_MT(nlv_T,:) = zmobs_M(nlv_M,:)
zmobs2_MT(nlv_T,:) = zmobs2_M(nlv_M,:)
call flush(6)
ccc dbug in
write(nulout,*) 'sugomobs: UU ,nlev= ',nlv_T
do jlev = 1,nlv_T
write(nulout,*) cfstvar(jvar),jvar,jlev
& ,zPPOBS_T(jlev,1),zmobs_MT(jlev,1)
enddo
write(nulout,*) 'sugomobs: VV ,nlev= ',nlv_T
do jlev = 1,nlv_T
write(nulout,*) cfstvar(jvar),jvar,jlev
& ,zPPOBS_T(jlev,1),zmobs2_MT(jlev,1)
enddo
ccc dbug out
call fillmvo('HR','UU','NA',zmobs_MT,nlv_T,nobtot)
call flush(6)
call fillmvo('HR','VV','NA',zmobs2_MT,nlv_T,nobtot)
c
call tmg_stop(29)
c
c Variable sur les niveaux thermodynamiques
c
case ('TT','HU')
write(nulout,*)' '
write(nulout,*)' ----- Initializing ',cfstvar(jvar),' ----'
write(nulout,*)' '
c
call vflush(nulout)
call getfldprm(iip1s,iip2,iip3,itrlnlev,cletiket,cltypvar
& ,itrlgid,cfstvar(jvar),nbrpstamp,jpnflev
& ,nultrl(nstepanltime),nulout,ip1_pak_trl,ip1_vco_trl)
if(itrlnlev <= 0 .or. itrlnlev /= nlv_T) then
write(nulout,1002) cfstvar(jvar),idate((nstepobs-1)/2 + 1)
& ,itime((nstepobs-1)/2 + 1)
call abort3d(nulout
& ,'SUGOMOBS:Problem with background file')
endif
cnwa pas besoin
write(nulout,*) ' ITRLNLEV =',itrlnlev,' nlv_T ',nlv_T
c
do jlev = 1,nlv_T
zhybhr(jlev) = tg_vco_trl%dhyb_T(jlev)
ccc write(nulout,*) ' ZLEV =',tg_vco_trl%dhyb_T(jlev)
ccc write(nulout,*) ' IP1 =',tg_vco_trl%ip1_T(jlev)
enddo
c
ier = ezgprm(itrlgid,clgrtyp,ini,inj,iig1,iig2,iig3,iig4)
c
c loop through levels of field jvar
c
c Reading 3D fields
c
call tmg_start(27,'XHR2XY')
do jlev = 1,nlv_T
IIP1=tg_vco_trl%ip1_T(jlev)
do jstep = 1,nstepobs
if(nobs(jstep) > 0) then
iset = ezdefset(nobsgid(jstep),itrlgid)
ier=vfstlir(zvar,nultrl(jstep),INI,INJ,INK,
& nstamplist(jstep) ,cletiket,iip1,-1,-1,
& cltypvar,cfstvar(jvar))
if(ier.lt.0)then
write(nulout,1001) cfstvar(jvar),iip1,idate(jstep)
& ,itime(jstep)
call abort3d(nulout
& ,'SUGOMOBS:Problem with background file')
end if
c
ier = vezsint(zopart(1:nobs(jstep)),zvar,nobs(jstep),1
& ,1,ini,inj,1)
do jobs = 1, nobs(jstep)
zmobs_T(jlev,notag(jobs,jstep)) =zopart(jobs)
enddo
endif
enddo
enddo
call tmg_stop(27)
c
do jobs = 1,nobtot
zovar(jobs) = gompsg(1,jobs)
enddo
c
ccc a deplacer call tmg_start(28,'CALCPRES')
zptophr = tg_vco_trl%dpt_T
zprefhr = tg_vco_trl%dprf_T
zrcoefhr= tg_vco_trl%drcf1
itrlnlev = tg_vco_trl%ink_T
zhybhr = tg_vco_trl%dhyb_T
c
c print*,'calcpres zppobs',nlv_T,zovar,zptophr
c & ,zprefhr,zrcoefhr,nobtot
c call calcpres(zppobs,zhybhr,itrlnlev,zovar,zptophr
c & ,zprefhr,zrcoefhr,nobtot)
c write(nulout,*) 'sugomobs: jlev, zhybhr(jlev),zPPOBS(jlev,1)'
c do jlev = 1,nflev
c write(nulout,*) jlev,zhybhr(jlev),zPPOBS(jlev,1)
c enddo
ccc print*,'calcpres zppobs_T',nlv_T,zovar,zptophr
ccc & ,zprefhr,zrcoefhr,nobtot
c call calcpres(zppobs_T,zhybhr,nlv_T,zovar,zptophr
c & ,zprefhr,zrcoefhr,nobtot)
ccc write(nulout,*) 'sugomobs:jlev,zhybhr(jlev),zPPOBS_T(jlev,1)'
ccc dbug in
cnwa write(nulout,*) 'sugomobs:cfstvar(jvar),jvar,nlev= '
cnwa & ,cfstvar(jvar),jvar,nlv_T
cnwa do jlev = 1,nlv_T
cnwa write(nulout,*) cfstvar(jvar),jvar,jlev,zhybhr(jlev)
cnwa & ,zPPOBS_T(jlev,1),zmobs_T(jlev,1)
cnwa enddo
cccdbug out
c
call vintprof(zom_T,rppobs,nflev,zmobs_T,zppobs_T,nlv_T,nobtot)
c
call tmg_start(30,'FILLMVO')
call fillmvo('BG',cfstvar(jvar),'NA',zom_T,nflev,nobtot)
call fillmvo('HR',cfstvar(jvar),'NA',zmobs_T,nlv_T,nobtot)
call tmg_stop(30)
c
endselect
enddo
c
c Uncomment to write profiled model state in prof file (this will abort
c the
C execution after closing the prof file)
c
c call wrgomobs
*
*****************************************************************
* *
* * * *
* * * With COMMVO set to model state on ANALYSIS levels ... * * *
* * * * * *
* * * *
*
c
c Initialisation of TLM operators using GOMOBS1 as working space
c
call tmg_start(32,'SUBASIC')
call subasic_obs
call tmg_stop(32)
c
c Calculate ES=T-TD from T and Q
c from GOMQG and GOMTG and put it in GOMESG
c
call tmg_start(33,'MHUAESV')
call mhuaesv
call tmg_stop(33)
c
c Using T, q and PS in GOMOBSG, computes GZ and stores it in GOMGZG
c N.B. uses vlev
c
call tmg_start(34,'TT2PHI')
call tt2phi
call tmg_stop(34)
c
c At this point COMMVOG is complete and contains the background state
C projected on analysis levels.
c
c Copy 2D variable from GOMOBSG to GOMOBSHR
c
call transfer('HR2D')
c
c At this point COMMVOHR contains background state on original levels
c
if(llpt) then
call hpdeallc(pzpt,ier,1)
c-------endif de llpt
endif
c
call hpdeallc(pzom,ier,1)
call hpdeallc(pzom_T,ier,1)
call hpdeallc(pzom_M,ier,1)
call hpdeallc(pzovar,ier,1)
call hpdeallc(pzovar2,ier,1)
if(nobtot.gt.0) then
deallocate(zvar,zvar2,zmobs,zmobs_T)
else
deallocate( zvar2,zmobs,zmobs_T)
endif
deallocate(zmobs_M,zmobs2_M)
deallocate(zmobs_MT,zmobs2_MT)
deallocate(zppobs_T,zppobs_M,zppobs_MT)
deallocate(zopart,zopart2,zlev,zhybhr)
deallocate(nultrl)
deallocate(idate)
deallocate(itime)
c
write(nulout,*) ' '
write(nulout,*) '-------- Leaving SUGOMOBS ---------'
write(nulout,*) ' '
1000 format(1x,f10.5,1x,f10.5)
1001 format(1x,'SUGOMOBS: Problem finding variable',1x,a4,1x,'at level'
& ,i10,1x,', on',1x,i8,1x,'at',1x,i8.8,1x,'HHMMSSss')
1002 format(1x,'SUGOMOBS: Problem finding variable',1x,a4,1x
& ,', on',1x,i8,1x,'at',1x,i8.8,1x,'HHMMSSss')
c
return
end