!-------------------------------------- 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 getfstgla(ptg,pgzg,pqg,pug,pvg,pesg,ppsg,ppt) 1,25
use mod4dv
, only : l4dvar
*
#if defined (DOC)
*
***s/r getfstgla - Get some background fields on LAM analysis grid.
! (1) Interpolate from trial grid to non-extended analysis grid
! (2) Biperiodize the fields.
* These fields are needed for:
* (1) Dedining the balanced part of analysis increments when
* constructing the control vector (and vice-versa: see cv2gd)
* (2) Postprocessing diagnostic analysis increments on the analysis grid
* using TL observation operators.
* (3) On output, pug,pvg contains wind-images.
*
*Author : L. Fillion *ARMA/AES - 28 Apr 2008.
*Revision:
* L. Fillion *ARMA/EC - 17 Jul 2009. Introduce lcva_3db
* L. Fillion *ARMA/EC - 20 may 2010. 3 Char vrbl in maxmin call.
*
*Arguments
*
#endif
C
use modfgat, only : nstamplist
IMPLICIT NONE
*implicits
#include "pardim.cdk"
#include "comdim.cdk"
#include "comlun.cdk"
#include "comct0.cdk"
#include "comgem.cdk"
#include "comcva.cdk"
#include "comgemla.cdk"
#include "rpnstd.cdk"
#include "cvcord.cdk"
#include "comgrd_param.cdk"
#include "comgrd.cdk"
#include "comgdpar.cdk"
*
REAL*8 SFOQST8,SFOEW8
EXTERNAL SFOQST8,SFOEW8
!
integer ibrpstamp
real*8 ptg(ni,nflev,nj), pqg(ni,nflev,nj), pesg(ni,nflev,nj)
real*8 pug(ni,nflev,nj), pvg(ni,nflev,nj), pgzg(ni,nflev,nj)
real*8 ppt(ni,nj),ppsg(ni,nj)
!
integer igrdin,idim
character*1 clgr, ctyp
character*2 cnom
character*3 clvar
character*8 cetiket
integer idatet,idt,ibits,idtyp
integer ilng,ix1,ix2,ix3
integer ier,ikey,ji,jj,jk,jlev
integer igdgid,ezqkdef,ezgdef_fmem
integer itrggid,ivvgid
integer idum1,idum2,idum3,idum4
real*8 zmin,zmax
!
LOGICAL ldhu2es
real ax(ni),ay(nj)
REAL*8 zqsat,zpresa,zpresb
!
REAL*8 z2din(mni_in,mnj_in),z3din(mni_in,mnj_in,nflev)
REAL*8 z3din2(mni_in,mnj_in,nflev)
!
REAL*8 ztrans(ni,nj,nflev)
REAL*8 zuug(ni,nj,nflev),zvvg(ni,nj,nflev)
REAL*8 zttg(ni,nj,nflev),zqqg(ni,nj,nflev)
REAL*8 zgzg(ni,nj,nflev)
REAL*8 ZPPG(ni,nj,nflev),zpsg(ni,nj)
!
!!
WRITE(NULOUT,FMT='(/,4X,"Starting getfstgla",//)')
!
if(l4dvar.and.(.not.lcva_3db)) then
ibrpstamp=nstamplist(1)
else
ibrpstamp=nbrpstamp
endif
!
! define grid id info before calling inteprolation subroutine below
! -----------------------------------------------------------------
!
do ji=1,ni
ax(ji)=grd_x_8(ji)
enddo
do jj=1,nj
ay(jj)=grd_y_8(jj)
enddo
!
igdgid = ezgdef_fmem(mni_in,mnj_in,'Z','E',mig1tic, mig2tic,mig3tic,mig4tic, ! mig2tic etc already built by sugeom...
& ax,ay)
!
itrggid = igdgid
ivvgid = igdgid ! winds on same grid as other fields
!
! -------------------------------------------------------
!
! The sequence below is:
! (1) Read the trial field
! (2) Interpolate to non-extended analysis grid
! (3) Biperiodize
! (4) Transform to correct physical units
!
! -------------------------------------------------------
!
IDATE(1) = -1
CLETIKET = ' '
CLTYPVAR = 'P'
!
idim = ni*nj
call zero(idim,zpsg)
idim = ni*nj*nflev
call zero(idim,zttg)
call zero(idim,zgzg)
call zero(idim,zqqg)
call zero(idim,zuug)
call zero(idim,zvvg)
!
! Surface-pressure
! ----------------
!
write(nulout,*)'reading P0'
CLNOMVAR = 'P0'
!
write(nulout,*) 'getfstgla: ibrpstamp = ',ibrpstamp
!
igrdin = mni_in*mnj_in
call vhfstfld(z2din,igrdin,itrggid,zvvg,igrdin,ivvgid,1
& ,vhybinc,clnomvar,ibrpstamp,ninmpg,ntrials,nulout,nflev,.true.
& ,'LINEAR')
call maxmin(z2din,mni_in,mnj_in,1,zmin,zmax,
& idum1,idum2,idum3,idum4,'getfstgla ',
& 'P09')
if(zmin.le.500.or.zmax.gt.1060) then ! P0 in hPa at this point...
call abort3d(nulout,
& 'getfstgla: P0 from trial file is out of physical bounds')
endif
!
do jj=1,mnj_in
do ji=1,mni_in
zpsg(ji,jj) = z2din(ji,jj) ! extended part of zpsg will remain zero until biperiodicization
enddo
enddo
!
CALL INITGDG2(ppsg,zpsg,ni,nj,1,0,CLNOMVAR)
!
cletiket='BASICGD '
clvar = 'P0 '
if(Grd_typ.eq.'LU') then
!cluc call write_fld(ppsg,clvar,cletiket,kpak,kbrpstamp,kdeet,kpas,
!cluc & kdatyp,cdtypinc,nulinclr,0,1)
endif
!
! Temperature
! -----------
!
write(nulout,*)'reading TT'
CLNOMVAR = 'TT'
call vhfstfld(z3din,igrdin,itrggid,zvvg,igrdin,ivvgid,nflev
& ,vhybinc,clnomvar,ibrpstamp,ninmpg,ntrials,nulout,nflev,.true.
& ,'LINEAR')
!
do jk=1,nflev
do jj=1,mnj_in
do ji=1,mni_in
zttg(ji,jj,jk) = z3din(ji,jj,jk) ! extended part of zttg will remain zero until biperiodicization
enddo
enddo
enddo
!
CALL INITGDG2(ptg,zttg,ni,nj,nflev,0,CLNOMVAR)
!
cletiket='BASICGD '
clvar = 'TT '
if(grd_typ.eq.'LU') then
!cluc call write_fld(ptg,clvar,cletiket,nulinclr,0,nflev)
endif
!
! Geopotential
! ------------
!
write(nulout,*)'reading GZ'
CLNOMVAR = 'GZ'
!
call vhfstfld(z3din,igrdin,itrggid,zvvg,igrdin,ivvgid,nflev
& ,vhybinc,clnomvar,ibrpstamp,ninmpg,ntrials,nulout,nflev,.true.
& ,'LINEAR')
!
do jk=1,nflev
do jj=1,mnj_in
do ji=1,mni_in
zgzg(ji,jj,jk) = z3din(ji,jj,jk)
enddo
enddo
enddo
!
CALL INITGDG2(pgzg,zgzg,ni,nj,nflev,0,CLNOMVAR)
!
cletiket='BASICGD '
clvar = 'GZ '
if(Grd_typ.eq.'LU') then
! call write_fld(pgzg,clvar,cletiket,nulinclr,0,nflev)
endif
!
! Specific-Humidity
! -----------------
!
write(nulout,*)'reading HU'
CLNOMVAR = 'HU'
!
call vhfstfld(z3din,igrdin,itrggid,zvvg,igrdin,ivvgid,nflev
& ,vhybinc,clnomvar,ibrpstamp,ninmpg,ntrials,nulout,nflev,.true.
& ,'LINEAR')
!
do jk=1,nflev
do jj=1,mnj_in
do ji=1,mni_in
zqqg(ji,jj,jk) = z3din(ji,jj,jk)
enddo
enddo
enddo
!
CALL INITGDG2(pqg,zqqg,ni,nj,nflev,0,CLNOMVAR)
!
cletiket='BASICGD '
clvar = 'HU '
call maxmin(pqg,ni,nj,nflev,zmin,zmax,
& idum1,idum2,idum3,idum4,'getfstgla ',
& 'HU9')
if(Grd_typ.eq.'LU') then
!cluc call write_fld(pqg,clvar,cletiket,nulinclr,0,nflev)
endif
!
! Dewpoint depression
! -------------------
!
write(nulout,*)'Calculating ES from HU and TT'
do jlev = 1,nflev
do jj = 1,mnj_in
do ji = 1,mni_in
zpresb = ((vhybinc(jlev) - rptopinc/rprefinc)
& /(1.0D0-rptopinc/rprefinc))**rcoefinc
zpresa = rprefinc * (vhybinc(jlev)-zpresb)
zppg(ji,jj,jlev) = zpresa + zpresb*zpsg(ji,jj)*100.0D0
enddo
enddo
enddo
!
! ES trial fld calculation (water phase)
! pqg = specific humidity;
! pug = true temperature in kelvin (work fld)
! ptg = true temperature in celsius
! pvg = pressure in pascal (work fld)
!
do jlev = 1,nflev
do jj = 1, mnj_in
do ji = 1, mni_in
zttg(ji,jj,jlev) = zttg(ji,jj,jlev) + 273.16D0
zqsat= SFOQST8(zttg(ji,jj,jlev),zppg(ji,jj,jlev))
zqqg(ji,jj,jlev)= MIN ( zqsat ,zqqg(ji,jj,jlev) )
enddo
enddo
enddo
!
CALL MHUAESGD2(ztrans,zqqg,zttg,zppg,ni,nj,nflev,.false.)
CALL INITGDG2(pesg,ztrans,ni,nj,nflev,0,CLNOMVAR)
!
! U wind-image component
! ----------------------
!
write(nulout,*)'reading UU and VV'
CLNOMVAR = 'UU'
!
call vhfstfld(z3din,igrdin,itrggid,z3din2,igrdin,ivvgid,nflev ! z3din=uu,z3din2=vv interpolated...
& ,vhybinc,'UV',ibrpstamp,ninmpg,ntrials,nulout,nflev,.true.
& ,'LINEAR')
!
do jk=1,nflev
do jj=1,mnj_in
do ji=1,mni_in
zuug(ji,jj,jk) = z3din(ji,jj,jk)
zvvg(ji,jj,jk) = z3din2(ji,jj,jk)
enddo
enddo
enddo
!
CALL INITGDG2(pug,zuug,ni,nj,nflev,0,CLNOMVAR) ! on output, pug contains U wind-image.
!
cletiket='BASICGD '
clvar = 'UU '
if(Grd_typ.eq.'LU') then
!cluc call write_fld(pug,clvar,cletiket,nulinclr,0,nflev)
endif
!
! V wind-image component
! ----------------------
!
CLNOMVAR = 'VV'
CALL INITGDG2(pvg,zvvg,ni,nj,nflev,0,CLNOMVAR) ! on output, pvg contains V wind-image.
!
cletiket='BASICGD '
clvar = 'VV '
if(Grd_typ.eq.'LU') then
!cluc call write_fld(pvg,clvar,cletiket,nulinclr,0,nflev)
endif
!
return
end