!-------------------------------------- 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 getfstg (ptg,pqg,pug,pvg,pesg,ppsg,ppt,kni,knj,knk),15
use mod4dv
, only : l4dvar
*
#if defined (DOC)
*
***s/r getfstg - Get some background fields on analysis grid.
* These fields are need for posprocessing diagnostic
* analysis increments on the analysis grid using
* TL observation operators.
*
*Author : L. Fillion *ARMA/AES - 13 nov 98
*Revision:
* C. Charette *ARMA/AES Nov 1998
* - Added T-Td field
* S. Pellerin *ARMA/SMC May 2000
* - Horizontal and vertical interpolation from
* trial grid to analysis grid (and levels)
* S. Pellerin *ARMA/SMC Feb. 2002
* - Selection of initial time model cube in 4dvar
* context
* C. Charette *ARMA/SMC Sept 2004
* - Conversion to hybrid vertical coordinate
* Remove reading of PT field
* C. Charette *ARMA/SMC Dec. 2005
* - Derive locally T-TD from TT and HU
* Reading of trial fld of T-TD is removed
* Bin He *ARMA/SMC - Apr. 2008
* - Dealing with multiple trial files.
*
*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 "rpnstd.cdk"
#include "cvcord.cdk"
*
REAL*8 SFOQST8,SFOEW8
EXTERNAL SFOQST8,SFOEW8
c
INTEGER KNI,KNJ,KNK,ibrpstamp
real*8 ptg(kni,knk,knj), pqg(kni,knk,knj), pesg(kni,knj)
real*8 pug(kni,knk,knj), pvg(kni,knk,knj), ppsg(kni,knj)
real*8 ppt(kni,knj)
C
INTEGER JLEV,igdgid,ezqkdef
LOGICAL ldhu2es
ccc debug
integer ji,jj
REAL*8 ZTRANS(ni,nj,nflev),zvvg(ni,nj,nflev)
REAL*8 ZPPG(ni,nj,nflev),ZPSG(ni,nj),zpresa,zpresb
REAL*8 zttg(ni,nj,nflev),zqqg(ni,nj,nflev),zqsat
POINTER (PXTRANS,ZTRANS),(pxvvg,zvvg)
C
EXTERNAL ABORT3D
C
WRITE(NULOUT,FMT='(/,4X,"Starting GETFSTG",//)')
C
if(l4dvar) then
ibrpstamp=nstamplist(1)
else
ibrpstamp=nbrpstamp
endif
c
igdgid = ezqkdef(ni, nj, 'G', 0,0,0,0,0)
C
C* 1. Open the file
C . -------------
C
100 CONTINUE
C
C* 2 Allocate space for the buffer
C -----------------------------
C
200 CONTINUE
CALL HPALLOC(PXTRANS,MAX(ni*nj*nflev,1),IERR,8)
CALL HPALLOC(PXvvg,max(ni*nj*nflev,1),IERR,8)
C
C* 3. Read desired fields
C . -------------------
C
300 CONTINUE
IDATE(1) = -1
CLETIKET = ' '
CLTYPVAR = 'P'
c
c Surface-pressure
c
write(nulout,*)'reading P0'
CLNOMVAR = 'P0'
c
call vhfstfld(zpsg,ni*nj,igdgid,zvvg,ni*nj,igdgid,1
& ,vhybinc,clnomvar,ibrpstamp,ninmpg,ntrials,nulout,
& jpnflev,.true. ,'LINEAR')
CALL INITGDG2(ppsg,zpsg,KNI,KNJ,1,0,CLNOMVAR)
c
c Temperature
c
write(nulout,*)'reading TT'
CLNOMVAR = 'TT'
call vhfstfld(zttg,ni*nj,igdgid,zvvg,ni*nj,igdgid,nflev
& ,vhybinc,clnomvar,ibrpstamp,ninmpg,ntrials,nulout,
& jpnflev,.true. ,'LINEAR')
c
CALL INITGDG2(ptg,zttg,KNI,KNJ,KNK,0,CLNOMVAR)
c
c Specific-Humidity
c
write(nulout,*)'reading HU'
CLNOMVAR = 'HU'
c
call vhfstfld(zqqg,ni*nj,igdgid,zvvg,ni*nj,igdgid,nflev
& ,vhybinc,clnomvar,ibrpstamp,ninmpg,ntrials,nulout,
& jpnflev,.true. ,'LINEAR')
c
CALL INITGDG2(pqg,zqqg,KNI,KNJ,KNK,0,CLNOMVAR)
c
c Dewpoint depression
c
write(nulout,*)'Calculating ES from HU and TT'
do jlev = 1,nflev
do jj = 1,nj
do ji = 1,ni
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
c ES trial fld calculation (water phase)
c pqg = specific humidity;
C pug = true temperature in kelvin (work fld)
C ptg = true temperature in celsius
C pvg = pressure in pascal (work fld)
do jlev = 1,nflev
do jj = 1, nj
do ji = 1, ni
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,KNI,KNJ,KNK,0,CLNOMVAR)
c
c U wind component
c
write(nulout,*)'reading UU and VV'
CLNOMVAR = 'UU'
c
call vhfstfld(ztrans,ni*nj,igdgid,zvvg,ni*nj,igdgid,nflev
& ,vhybinc,'UV',ibrpstamp,ninmpg,ntrials,nulout,
& jpnflev,.true. ,'LINEAR')
CALL INITGDG2(pug,ztrans,KNI,KNJ,KNK,0,CLNOMVAR)
c
c V wind component
c
CLNOMVAR = 'VV'
CALL INITGDG2(pvg,zvvg,KNI,KNJ,KNK,0,CLNOMVAR)
c
C
C* 4. Close the file and release memory
C . ---------------------------------
C
call hpdeallc(pxvvg,ierr,1)
CALL HPDEALLC(PXTRANS,IERR,1)
IF(IERR.NE.0)THEN
CALL ABORT3D(NULOUT,'GETFSTG. Problem with ZTRANS.')
END IF
C
RETURN
END