!-------------------------------------- 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 varouthigh 2,29
use mod4dv
, only : l4dvar
#if defined (DOC)
*
***s/r varouthigh - Output analysis increments and analysis fields at high (trial) resolution
* onto RPN standard file.
*
!Author : Luc Fillion - ARMA/EC - sept 2009
!Revision: Luc Fillion - ARMA/EC - 31 May 2010 - Extend to allow grd_typ= 'LU' mode.
#endif
C
use modfgat, only : nstamplist
IMPLICIT NONE
*implicits
#include "taglam4d.cdk"
#include "pardim.cdk"
#include "comdim.cdk"
#include "comlun.cdk"
#include "comgem.cdk"
#include "compost.cdk"
#include "cvcord.cdk"
#include "rpnstd.cdk"
#include "comgdpar.cdk"
#include "comcst.cdk"
#include "cominterp.cdk"
#include "comct0.cdk"
#include "comfilt.cdk"
#include "comgrd_param.cdk"
#include "comgrd.cdk"
#include "comgemla.cdk"
#include "comcva.cdk"
#include "comleg.cdk"
*
integer vfstluk,write_encode_hyb,fstecr
integer jvar, jcol
integer jlev,inbrlev,imode,inbitstr,ilimlvhu
integer gddst
integer ezgdef_fmem
#include "localpost.cdk"
C
integer idatyp_la,inbits_la
integer itrlgid,ip0gid,igidv_trl,iip1,iip2,ji,jj,jk
integer ip1_pak_trl,ip1_vco_trl,ip1_pak_anl,ip1_vco_anl
integer ip1_pak_inclr,ip1_pak_hy,ip1_vco_inclr,iip1_hyb_prm
integer itrlnlev,iwindnlev,igdgid,iip3
integer iip2_image,iip3_image
integer iig1,iig2,iig3,iig4,ezgprm,ikey,iwindgid,vezsint
integer iig1V,iig2V,iig3V,iig4V
integer ibrpstamp,inpak_inc,ikind
!
character*1 clgrtypwind,clgrtyp_image,clstring,cltypinc,cltypanl
integer k,koutmpg
integer ig1tic,ig2tic,ig3tic,ig4tic
integer ig1in,ig2in,ig3in
integer iip1s_trl(jpnflev)
integer ig1in_u,ig2in_u,ig3in_u
integer ig1in_v,ig2in_v,ig3in_v
!
real*8 zmin,zmax,zdlon,zwork
real*8 zptophr, zprefhr,zrcoefhr
real*8 zlowvar(mni_in,mnj_in)
real*8 zlow_uu(mni_in,mnj_in,nflev),zlow_vv(mni_in,mnj_in,nflev)
real*8 zhigh_uu(nit,njt,nflev),zhigh_vv(nit,njt,nflev)
real*8 zhighvar(nit,njt)
real*8 zanal_uu(nit,njt)
real*8 zanal_vv(nit,njt)
real*8 ztrl_uu(nit,njt)
real*8 ztrl_vv(nit,njt)
real*8 z2d(nit,njt)
real*8 zlev_trl(jpnflev)
!
real zptop4, zpref4,zrcoef4,zdummy
real ax(mni_in),ay(mnj_in)
real ax_u(mni_in),ay_v(mnj_in)
real zxlon1_4,zxlat1_4,zxlon2_4,zxlat2_4
!
character*2 clvar
character*3 clname
character*3 clnomvar_image
character*3 clnomvar_3
LOGICAL llimplemented,lldebug
data cltypinc,cltypanl /'R','A'/
!
!!
WRITE(NULOUT,FMT='(/,4X,"Starting varouthigh",//)')
!
idatyp_la = 5 ! can be used for other grd_typ also
inbits_la = -32 ! can be used for other grd_typ also
cetikinc='ANINCHIG'
!
if(l4dvar) then
ibrpstamp=nstamplist(1)
else
ibrpstamp=nbrpstamp
endif
!
!*2 Define Grids
! ************
!
zxlon1_4 = grd_xlon1
zxlat1_4 = grd_xlat1
zxlon2_4 = grd_xlon2
zxlat2_4 = grd_xlat2
!
do ji=1,mni_in
ax(ji) = grd_x_8(ji)
enddo
!
do ji=1,mni_in-1
ax_u(ji) = grd_u_x_8(ji)
enddo
!
if(grd_typ.eq.'LU') then ! to be removed once done properly
do ji=1,mni_in-1
ax_u(ji) = ax(ji)
enddo
endif
!
do jj=1,mnj_in
ay(jj) = grd_y_8(jj)
enddo
!
do jj=1,mnj_in-1
ay_v(jj) = grd_v_y_8(jj)
enddo
!
if(grd_typ.eq.'LU') then ! to be removed once done properly
do jj=1,mnj_in-1
ay_v(jj) = ay(jj)
enddo
endif
!
call cxgaig('E',ig1tic,ig2tic,ig3tic,ig4tic,
& zxlat1_4,zxlon1_4,zxlat2_4,zxlon2_4)
!
call cigaxg('E', zxlat1_4, zxlon1_4, zxlat2_4, zxlon2_4,
& ig1tic,ig2tic,ig3tic,ig4tic)
!
ngid_in = ezgdef_fmem(mni_in,mnj_in,'Z','E',ig1tic, ig2tic,ig3tic,ig4tic,
& ax,ay)
ngidu_in = ezgdef_fmem(mni_in-1,mnj_in,'Z','E',ig1tic, ig2tic,ig3tic,ig4tic,
& ax_u,ay)
ngidv_in = ezgdef_fmem(mni_in,mnj_in-1,'Z','E',ig1tic, ig2tic,ig3tic,ig4tic,
& ax,ay_v)
!
! Set ip1,ip2,ip3 of positional parameters (= ig1,ig2,ig3 of scalar fields)
!
call ipig(ig1in,ig2in,ig3in,
& grd_dx,grd_dy,mni_in,mnj_in,mni_in,mnj_in,
& grd_rot_8,grd_roule)
ig3in = 0
!
! write(nulout,*) 'varouthigh: ig1in=',ig1in
! write(nulout,*) 'varouthigh: ig2in=',ig2in
! write(nulout,*) 'varouthigh: ig3in=',ig3in
!
ig2in_u=ig2in+1
ig2in_v=ig2in+2
!
if(ig1in.lt.0) then
write(nulout,*) 'varouthigh: ig1in = ',ig1in
call abort3d(nulout,'varouthigh: ig1in.le.0')
endif
if(ig2in.lt.0) then
write(nulout,*) 'varouthigh: ig2in = ',ig2in
call abort3d(nulout,'varouthigh: ig2in.le.0')
endif
if(ig3in.lt.0) then
write(nulout,*) 'varouthigh: ig3in = ',ig3in
call abort3d(nulout,'varouthigh: ig3in.le.0')
endif
!
nip2 = 0
niter=0
clgrtyp='Z'
!
!*3. Get target high resolution grid ID from trial file
! --------------------------------------------------
!
clname = 'UU'
call getfldprm2(IIP1S_TRL,IIP2,IIP3,ITRLNLEV,CLETIKET,CLTYPVAR
& ,ITRLGID,clname,ibrpstamp,jpnflev,ninmpg
& ,nulout,ip1_pak_trl,ip1_vco_trl,ntrials,koutmpg)
!
!*4. First interpolate winds from analysis to trial horizontal resolution
! Then write on file
! --------------------------------------------------------------------
!
do jvar = 1,nppcvar ! first build UU and VV arrays prior to interpolation
do jlev = 1,mdimppcvar(jvar)
call gdout2(cppcvar(jvar),zlowvar,mni_in,mnj_in
& ,jlev,llimplemented,iip1s_trl(jlev))
!
if (cppcvar(jvar).eq.'UU') then
zlow_uu(:,:,jlev) = zlowvar(:,:)
else if (cppcvar(jvar).eq.'VV') then
zlow_vv(:,:,jlev) = zlowvar(:,:)
endif
enddo
enddo
!
ierr = ezgprm(itrlgid,clgrtyp,ini,inj,iig1,iig2,iig3,iig4) ! get file parameters of trial field
!
do jlev = 1,nflev
call hintvec2(zlow_uu(1,1,jlev),zlow_vv(1,1,jlev),mni_in*mnj_in,ngid_in,
& zhigh_uu(1,1,jlev),zhigh_vv(1,1,jlev),nit*njt,
& itrlgid,1,'CUBIC')
!
z2d(:,:) = zhigh_uu(:,:,jlev)
ierr = vfstecr(z2d,zwork,inbits_la
& ,nulinchr,ibrpstamp,ideet,inpas,nit,njt,1,iip1s_trl(jlev)
& ,nip2,niter,cltypinc,'UU',cetikinc,clgrtyp,iig1
& ,iig2,iig3,iig4,idatyp_la,.true.)
!
z2d(:,:) = zhigh_vv(:,:,jlev)
ierr = vfstecr(z2d,zwork,inbits_la
& ,nulinchr,ibrpstamp,ideet,inpas,nit,njt,1,iip1s_trl(jlev)
& ,nip2,niter,cltypinc,'VV',cetikinc,clgrtyp,iig1
& ,iig2,iig3,iig4,idatyp_la,.true.)
enddo
!
!*4.1 Get trial winds and add to analysis increments to produce analysis. Then write on file.
! ---------------------------------------------------------------------------------------
!
!
do jlev = 1,nflev
!! UU
cletiket = ' '
cltypvar = ' '
ikey = FSTINF(koutmpg, INI, INJ, INK, ibrpstamp, cletiket,
& iip1s_trl(jlev), iip2, iip3,cltypvar,'UU')
!
if (ikey.lt.0) then
write(nulout,*) 'Problems finding variable '
& ,'UU',' at level ',iip1s_trl(jlev)
& ,' in trial file'
call abort3d(nulout,'varouthigh')
endif
!
ikey = VFSTLUK(ztrl_uu,ikey, INI, INJ, 1)
!
zanal_uu(:,:) = ztrl_uu(:,:) + zhigh_uu(:,:,jlev)
!
cletiket = 'ANALYSIS'
cltypinc = 'A'
ierr = vfstecr(zanal_uu,zwork,inbits_la
& ,nulstd,ibrpstamp,ideet,inpas,nit,njt,1,iip1s_trl(jlev)
& ,nip2,niter,cltypinc,'UU',cetikinc,clgrtyp,iig1
& ,iig2,iig3,iig4,idatyp_la,.true.)
!
! VV
cletiket = ' '
cltypvar = ' '
ikey = FSTINF(koutmpg, INI, INJ, INK, ibrpstamp, cletiket,
& iip1s_trl(jlev), iip2, iip3,cltypvar,'VV')
!
if (ikey.lt.0) then
write(nulout,*) 'Problems finding variable '
& ,'VV',' at level ',iip1s_trl(jlev)
& ,' in trial file'
call abort3d(nulout,'varouthigh')
endif
!
ikey = VFSTLUK(ztrl_vv,ikey, INI, INJ, 1)
zanal_vv(:,:) = ztrl_vv(:,:) + zhigh_vv(:,:,jlev)
!
cletiket = 'ANALYSIS'
cltypinc = 'A'
ierr = vfstecr(zanal_vv,zwork,inbits_la
& ,nulstd,ibrpstamp,ideet,inpas,nit,njt,1,iip1s_trl(jlev)
& ,nip2,niter,cltypinc,'VV',cletiket,clgrtyp,iig1
& ,iig2,iig3,iig4,idatyp_la,.true.)
enddo
!
!*5. Output rest of fields
! ---------------------
!
do jvar = 1,nppcvar
if(cppcvar(jvar).ne.'UU'.or.cppcvar(jvar).ne.'VV') then
write(nulout,*) 'varouthigh: writing ',cppcvar(jvar)
write(nulout,*) 'varouthigh: mdimppcvar(jvar)= ',mdimppcvar(jvar)
do jlev = 1,mdimppcvar(jvar)
call gdout2(cppcvar(jvar),zlowvar,mni_in,mnj_in
& ,jlev,llimplemented,iip1s_trl(jlev))
call hintscal(zlowvar,mni_in*mnj_in,ngid_in,
& zhighvar,nit*njt,itrlgid,1,'CUBIC')
!
ierr = vfstecr(zhighvar,zwork,inbits_la
& ,nulinchr,ibrpstamp,ideet,inpas,nit,njt,1,iip1s_trl(jlev)
& ,nip2,niter,cltypinc,cppcvar(jvar),cletiket,clgrtyp,iig1
& ,iig2,iig3,iig4,idatyp_la,.true.)
!
! Get Trial field
cletiket = ' '
cltypvar = ' '
ikey = FSTINF(koutmpg, INI, INJ, INK, ibrpstamp, cletiket,
& iip1s_trl(jlev), iip2, iip3,cltypvar,cppcvar(jvar))
!
if (ikey.lt.0) then
write(nulout,*) 'No field '
& ,cppcvar(jvar),' at level ',iip1s_trl(jlev)
& ,' in trial file'
! call abort3d(nulout,'varouthigh')
else
!
ikey = VFSTLUK(ztrl_uu,ikey, INI, INJ, 1)
!
! Trial + Anal. Incr
if(cppcvar(jvar).eq.'HU') zhighvar(:,:)=0.0 ! cluc remove... it is just a test for Ervig...
zanal_uu(:,:) = ztrl_uu(:,:) + zhighvar(:,:)
!
cletiket = 'ANALYSIS'
cltypinc = 'A'
ierr = vfstecr(zanal_uu,zwork,inbits_la
& ,nulstd,ibrpstamp,ideet,inpas,nit,njt,1,iip1s_trl(jlev)
& ,nip2,niter,cltypinc,cppcvar(jvar),cletiket,clgrtyp,iig1
& ,iig2,iig3,iig4,idatyp_la,.true.)
endif
enddo
endif
enddo
!
!*6. Writing positional parameters (For both analysis incr. file and analysis file)
! ------------------------------------------------------------------------------
!
if (clgrtyp.eq.'Z') then
cletiket = ' '
cltypvar = 'X'
ikey = FSTINF(koutmpg, iNI, iNJ, iNK, -1,cletiket, iig1
& ,iig2,iig3,cltypvar,'>>')
c
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)
c
ikey = VFSTLUK(zhighvar, ikey, iNI, iNJ, iNK)
!
! >> Analysis Incr file
!
if(nulinchr.ne.0) then ! Anal. Incr file
cletiket = 'ANALYSIS'
cltypvar = 'A'
ierr = vfstecr(zhighvar, zwork, inbits_la, nulinchr, idateo
& ,ideet,inpas, ini, inj, ink, ip1, ip2, ip3, cltypvar
& ,clnomvar,cletiket,clgrtyp,ig1, ig2, ig3, ig4, idatyp
& ,.true.)
endif
!
! >> Analysis file
!
if(nulstd.ne.0) then ! Analysis file
ierr = vfstecr(zhighvar, zwork, inbits_la, nulstd, idateo
& ,ideet,inpas, ini, inj, ink, ip1, ip2, ip3, cltypvar
& ,clnomvar,cletiket,clgrtyp,ig1, ig2, ig3, ig4, idatyp
& ,.true.)
endif
!
! ^^ Analysis Incr file
!
cletiket = ' '
cltypvar = 'X'
ikey = FSTINF(koutmpg, iNI, iNJ, iNK, -1,cletiket, iig1
& ,iig2,iig3,cltypvar,'^^')
c
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)
c
c
ikey = VFSTLUK(zhighvar, ikey, iNI, iNJ, iNK)
c
if(nulinchr.ne.0) then
ierr = vfstecr(zhighvar, zwork, inbits_la, nulinchr, idateo
& ,ideet,inpas, ini, inj, ink, ip1, ip2, ip3, cltypvar
& ,clnomvar,cletiket,clgrtyp,ig1, ig2, ig3, ig4, idatyp
& ,.true.)
endif
!
! ^^ Analysis file
!
if(nulstd.ne.0) then ! Analysis file
ierr = vfstecr(zhighvar, zwork, inbits_la, nulstd, idateo
& ,ideet,inpas, ini, inj, ink, ip1, ip2, ip3, cltypvar
& ,clnomvar,cletiket,clgrtyp,ig1, ig2, ig3, ig4, idatyp
& ,.true.)
endif
endif ! grdtyp .eq. Z
!
!*7 Set and write hybrid vertical coordinate parameters from trial field
! ********************************************************************
!
call gethybprm2(ninmpg,nulout,-1,-1,' ',-1,zptop4,zpref4,zrcoef4
& ,iip1_hyb_prm,ntrials)
zptophr = zptop4
zprefhr = zpref4
zrcoefhr= zrcoef4
if(lldebug) then
write(nulout,*)'varoutla:zptop4,zpref4,zrcoef4 '
& ,zptophr,zprefhr,zrcoefhr
endif
c
c Writing HY to analysis file
c
if(nulstd.ne.0) then
write(nulout,*) 'Writing variable HY on analysis file'
c Determine the style in which ip1 is encoded (15bits or 31 bits)
c A value <= 32767 (2**16 -1) means that ip1 is compacted in 15 bits
c Determine the type of P which was encoded in IP1
c
if(iip1_hyb_prm .le. 32767) then
ip1_pak_hy = 3
else
ip1_pak_hy = 2
c set encoding of IP1 to 28 bits for write_encode_hyb
imode = 0
CALL CONVIP(iip1_hyb_prm,ZDUMMY,IKIND,imode,clstring,.false.)
endif
ierr = write_encode_hyb(nulstd,'HY',nip2,niter,cetikinc
& ,ibrpstamp,zptop4,zpref4,zrcoef4)
ierr = write_encode_hyb(nulinclr,'HY',nip2,niter,cetikinc
& ,ibrpstamp,zptop4,zpref4,zrcoef4)
ierr = write_encode_hyb(nulinchr,'HY',nip2,niter,cetikinc
& ,ibrpstamp,zptop4,zpref4,zrcoef4)
endif
!
write(nulout,*) 'END of varouthigh'
!
RETURN
END