!-------------------------------------- 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 vhfstfld(pvar,kcol,ktrggid,pvv,kcolvv,kvvgid,knk 14,22
& ,ptrglev,cdnomvar,kstampv,kulfst,ktrials,kulout,
& kmaxlev,ldvint ,cddgint)
*
#if defined (DOC)
*
***s/r vhfstfld - Interpolate background fields on analysis grid.
* These fields are need for posprocessing diagnostic
* analysis increments on the analysis grid using
* TL observation operators.
*
*Author : S. Pellerin *ARMA/SMC May 2000
*Revision:
* JM Belanger CMDA/SMC Jul 2000
* . 32 bits conversion
* M. Buehner *ARMA/SMC Feb. 2002
* . Fix to wind interpolations
* C. Charette - ARMA/SMC - Sep. 2004
* . Conversion to hybrid vertical coordinate
* Bin He - ARMA/SMC - Apr. 2008
* . Dealing with multiple trial files.
* S. Pellerin, ARMA, August 2008
* . Call to gethybprm2 and getfstprm2
* L. Fillion, ARMA/EC, May 2010
* . Slight improvement in printout
*
*
*Arguments
* Output:
* pvar(kcol,knk) : Interpolated Output variable (contains UU if
* cdnomvar = UV)
* pvv(kcolvv,knk): Interpolated Output V componant (if cdnomvar = UV)
* Input:
* kcol : Number of collums
* ktrggid : grid id of output variable
* kcolvv : Number of collums for V
* kvvgid : Grid descriptor of targeted V grid
* knk : Number of level of targetted variable
* ptrglev : values hybrid coord levels of targetted variable
* cdnomvar : Variable nomvar (UV if vectorial interpolation desired)
* kstampv : Valid CMC date-time stamp values for reserch in
* fst source file
* kulfst : Unit of pre-opened standard file containing src fields
* ktrials : number of trial files.
* kulout : Standard output printout messages
* kmaxlev : Max number of levels that can be found in the
* source file
* ldvint : Logical that control if vertical interpolation
* is wanted
* cddgint : Degree of interpolation for horizontal interpolation
*
#endif
C
IMPLICIT NONE
*implicits
#include "comlun.cdk"
#include "pardim.cdk"
#include "comdim.cdk"
#include "comgem.cdk"
#include "comcst.cdk"
ccc#include "comhybprm.cdk"
#include "rpnstd.cdk"
*
INTEGER ktrials
INTEGER kulfst(ktrials)
INTEGER KCOL,KNK,ktrggid,kstampv,kulout,kmaxlev,kcolvv
integer kvvgid,inlev
real*8 pvar(kcol,knk), pvv(kcolvv,knk),ptrglev(knk)
character*2 cdnomvar
character*(*) cddgint
logical ldvint
c
integer read_decode_hyb
integer jlev,iip1s,iip1,iip2,iip3,itrlnlev,itrlgid,ip1_hyb_prm
integer ikey,ezgprm,ip0gid,iptgid,vfstluk,ezqkdef,ezsetopt
integer ezdefset,iset,vezsint,jcol,ivvgid,inivv,injvv,jlen
integer ikind,imode,ip1style,ip1kind
REAL*8 zeta,zhighvar(1),zpstrl,zpttrl(1),zhighvv(1),zlowvar(1)
real*8 zpresanl(1),zlowvv(1)
real*8 zps,zprestrl(1),zprofi(1),zprofo(1)
real zptop4, zpref4,zrcoef4
real*8 zptophr, zprefhr,zrcoefhr
logical llhy
character*1 clstring
POINTER (pxprofi,zprofi)
pointer (pxprofo,zprofo)
pointer (pxhighvar,zhighvar),(pxpstrl,zpstrl)
pointer (pxpresanl,zpresanl),(pxps,zps)
pointer (pxprestrl,zprestrl)
pointer (pxip1s,iip1s(kmaxlev))
pointer (pxeta,zeta(kmaxlev)),(pxhighvv,zhighvv)
pointer (pxlowvar,zlowvar),(pxlowvv,zlowvv)
pointer (pxpttrl,zpttrl)
integer k,koutmpg
C
EXTERNAL ABORT3D
c
WRITE(KULOUT,FMT='(/,4X,"Starting VHFSTFLD",//)')
c
if (cdnomvar .eq. 'UV') then
clnomvar = 'UU'
else
clnomvar = cdnomvar
endif
C
C* 2 Allocate space for the buffer
C -----------------------------
C
call hpalloc(pxeta,kmaxlev,ierr,8)
call hpalloc(pxip1s,kmaxlev,ierr,8)
c
c
c* 3. Read desired fields
c . -------------------
c
c *********************************************************
c set hybride vertical coordinate parameters from trial field
c
call gethybprm2 (kulfst,kulout,-1,-1,' ',-1,zptop4,zpref4,zrcoef4
& ,ip1_hyb_prm,ktrials)
zptophr = zptop4
zprefhr = zpref4
zrcoefhr= zrcoef4
write(nulout,*)'vhfstfld:zptophr,zprefhr,zrcoefhr ',zptophr
& ,zprefhr,zrcoefhr
c
c get field parameters from trial field
c
call getfldprm2(IIP1S,IIP2,IIP3,ITRLNLEV,CLETIKET,CLTYPVAR
& ,ITRLGID,clnomvar,kstampv,kmaxlev,kulfst
& ,kulout,ip1style,ip1kind,ktrials,koutmpg)
c
c-----Convert ip1 to real value P
imode = -1
ikind = ip1kind
do jlev = 1,itrlnlev
call VCONVIP( iip1s(jlev), zeta(jlev), ikind, imode, clstring,
& .false. )
enddo
c
call vsort(zeta,itrlnlev)
c
c-----Convert real value P to IP
imode = ip1style
ikind = ip1kind
do jlev = 1,itrlnlev
call VCONVIP(iip1s(jlev),zeta(jlev),ikind,imode,clstring,.false.)
enddo
c
c-----Denormalize zeta if the type of vertical coord is ETA
if(ip1kind .eq. 1 ) then
do jlev = 1,itrlnlev
zeta(jlev) = zeta(jlev) + (1.0D0-zeta(jlev))
& *zptophr/zprefhr
enddo
endif
ierr = ezgprm(itrlgid,clgrtyp,ini,inj,ig1,ig2,ig3,ig4)
call hpalloc(pxhighvar,ini*inj*itrlnlev,ierr,8)
c
write(kulout,*)'vhfstfld: reading ',clnomvar
c
do JLEV = 1,itrlnlev
c
!cluc write(kulout,*)'vhfstfld: jlev, ip1s(jlev)',jlev, iip1s(jlev)
!
ikey = fstinf(koutmpg, INI, INJ, INK, kstampv, cletiket,
& iip1s(jlev), iip2, iip3,cltypvar,clnomvar)
c
if (ikey.lt.0) then
write(kulout,*) 'Problems finding variable '
& ,clnomvar,' at level ',iip1s(jlev),' in trial file'
call abort3d(kulout,'VHFSTFLD')
endif
c
ikey = VFSTLUK(zhighvar((jlev-1)*ini*inj+1),ikey,INI,INJ,INK)
c
enddo
c
call hpalloc(pxlowvar,kcol*itrlnlev,ierr,8)
c
if(cdnomvar.ne.'UV') then
c
c Horizontal interpolation
c
call hintscal(zhighvar,ini*inj,itrlgid,zlowvar,kcol,ktrggid
& ,itrlnlev,cddgint)
c
else
c
c Get VV component
c
call getfldprm(IIP1S,IIP2,IIP3,ITRLNLEV,CLETIKET,CLTYPVAR
& ,IVVGID,'VV',kstampv,kmaxlev,koutmpg
& ,kulout,ip1style,ip1kind)
c
ierr = ezgprm(ivvgid,clgrtyp,inivv,injvv,ig1,ig2,ig3,ig4)
call hpalloc(pxhighvv,inivv*injvv*itrlnlev,ierr,8)
c
write(kulout,*)'vhfstfld: reading ','VV'
c
do JLEV = 1,itrlnlev
c
ikey = fstinf(koutmpg, INI, INJ, INK, kstampv, cletiket,
& iip1s(jlev), iip2, iip3,cltypvar,'VV')
c
if (ikey.lt.0) then
write(kulout,*) 'Problems finding variable '
& ,'VV',' at level ',iip1s(jlev)
& ,' in trial file'
call abort3d(kulout,'VHFSTFLD')
endif
c
ikey = VFSTLUK(zhighvv((jlev-1)*inivv*injvv+1),ikey,INI
& ,INJ,INK)
c
enddo
c
c Horizontal interpolation
c
call hpalloc(pxlowvv,kcolvv*itrlnlev,ierr,8)
c
call hintvec(zhighvar,ini*inj,itrlgid
& ,zhighvv,inivv*injvv,ivvgid,zlowvar
& ,kcol,ktrggid,zlowvv,kcolvv
& ,kvvgid,itrlnlev,cddgint)
c
call hpdeallc(pxhighvv,ierr,1)
endif
c
call hpdeallc(pxhighvar,ierr,1)
c
c Vertical interpolation:
c
if (itrlnlev.gt.1.and.ldvint) then
c
write(kulout,*)
& 'vhfstfld: Reading P0 trial field for vertical interpolation'
c
call getfldprm(IIP1S,IIP2,IIP3,INLEV,CLETIKET,CLTYPVAR
& ,IP0GID,'P0',kstampv,kmaxlev,koutmpg
& ,kulout,ip1style,ip1kind)
c
ikey = FSTINF(koutmpg, INI, INJ, INK, kstampv, cletiket,
& iip1s(1), iip2, iip3,cltypvar,'P0')
c
if(ikey.lt.0) then
write(kulout,*) ' ******* ERROR ******* '
write(kulout,*) 'No P0 found in ',koutmpg
call abort3d(kulout,'VHFSTFLD')
endif
c
ierr = ezgprm(ip0gid,clgrtyp,ini,inj,ig1,ig2,ig3,ig4)
c
call hpalloc(pxpstrl,ini*inj,ierr,8)
c
ikey = VFSTLUK(zpstrl, ikey, INI, INJ, INK)
c
call hpalloc(pxpresanl,kcol*knk,ierr,8)
call hpalloc(pxps,kcol,ierr,8)
call hpalloc(pxprestrl,kcol*itrlnlev,ierr,8)
call hpalloc(pxprofi,kcol*itrlnlev,ierr,8)
call hpalloc(pxprofo,kcol*knk,ierr,8)
c
c Interpolation of high res. P0 to low res. variable grid
c
ierr = ezsetopt('INTERP_DEGREE','LINEAR')
iset = ezdefset(ktrggid,ip0gid)
ierr = vezsint(zps,zpstrl,kcol,1,1,ini,inj,1)
call calcpres(zpresanl,ptrglev,knk,zps,rptopinc*rpatmb
& ,rprefinc*rpatmb,rcoefinc,kcol)
c
c Computation of pressure values on trial profiles of the high
c resolution horizonal grid
c
call calcpres(zprestrl,zeta,itrlnlev,zps,zptophr
& ,zprefhr,zrcoefhr,kcol)
c
do jlev = 1, itrlnlev
do jcol = 1, kcol
zprofi((jcol-1)*itrlnlev + jlev) =
& zlowvar((jlev-1)*kcol+jcol)
enddo
enddo
c
call vintprof(zprofo,zpresanl,knk,zprofi,zprestrl,itrlnlev,kcol)
c
do jlev = 1, knk
do jcol = 1, kcol
pvar(jcol,jlev) = zprofo((jcol-1)*knk+jlev)
enddo
enddo
c
call hpdeallc(pxpresanl,ierr,1)
call hpdeallc(pxps,ierr,1)
call hpdeallc(pxprestrl,ierr,1)
call hpdeallc(pxprofi,ierr,1)
call hpdeallc(pxprofo,ierr,1)
c
if (cdnomvar.eq.'UV') then
c
call hpalloc(pxpresanl,kcolvv*knk,ierr,8)
call hpalloc(pxps,kcolvv,ierr,8)
call hpalloc(pxprestrl,kcolvv*itrlnlev,ierr,8)
call hpalloc(pxprofi,kcolvv*itrlnlev,ierr,8)
call hpalloc(pxprofo,kcolvv*knk,ierr,8)
c
c Interpolation of high res. P0 to high res. variable grid
c
ierr = ezsetopt('INTERP_DEGREE','LINEAR')
iset = ezdefset(kvvgid,ip0gid)
ierr = vezsint(zps,zpstrl,kcolvv,1,1,ini,inj,1)
call calcpres(zpresanl,ptrglev,knk,zps,rptopinc*rpatmb
& ,rprefinc*rpatmb,rcoefinc,kcolvv)
c
c Computation of pressure values on trial profiles of the high
c resolution horizonal grid
c
call calcpres(zprestrl,zeta,itrlnlev,zps,zptophr
& ,zprefhr,zrcoefhr,kcolvv)
c
do jlev = 1, itrlnlev
do jcol = 1, kcolvv
zprofi((jcol-1)*itrlnlev + jlev) =
& zlowvv((jlev-1)*kcolvv+jcol)
enddo
enddo
c
call vintprof(zprofo,zpresanl,knk,zprofi,zprestrl,itrlnlev
& ,kcolvv)
c
do jlev = 1, knk
do jcol = 1, kcolvv
pvv(jcol,jlev) = zprofo((jcol-1)*knk+jlev)
enddo
enddo
c
call hpdeallc(pxlowvv,ierr,1)
call hpdeallc(pxpresanl,ierr,1)
call hpdeallc(pxps,ierr,1)
call hpdeallc(pxprestrl,ierr,1)
call hpdeallc(pxprofi,ierr,1)
call hpdeallc(pxprofo,ierr,1)
endif
c
call hpdeallc(pxpstrl,ierr,1)
c
else
if (knk.ne.itrlnlev) then
write(kulout,*) ' *********** ERROR ***********'
write(kulout,*) 'Number of level inconsistancies'
write(kulout,*) knk,' levels asked on output and '
write(kulout,*) itrlnlev,' levels found in standard file'
write(kulout,*) ' *********** ERROR ***********'
call abort3d(kulout,'VHFSTFLD')
else
do jlev = 1, knk
do jcol = 1, kcol
pvar(jcol,jlev) = zlowvar((jlev-1)*kcol+jcol)
enddo
enddo
c
if (cdnomvar.eq.'UV') then
do jlev = 1, knk
do jcol = 1, kcolvv
pvv(jcol,jlev) = zlowvv((jlev-1)*kcol+jcol)
enddo
enddo
call hpdeallc(pxlowvv,ierr,1)
endif
endif
endif
c
c End of vertical interpolation
c
c . ---------------------------------
c
call hpdeallc(pxlowvar,ierr,1)
call hpdeallc(pxip1s,ierr,1)
call hpdeallc(pxeta,ierr,1)
c
write(kulout,*) 'END of VHFSTFLD'
c
return
end