!-------------------------------------- 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 varoutlow_glb,6
use mod4dv
, only : l4dvar
#if defined (DOC)
*
***s/r varoutlow_glb - For grd_typ = 'GU', lcv_hemis = .false.
* Output analysis increments at analysis resolution onto RPN standard file.
*
#endif
!Author : Luc Fillion - ARMA/EC - 12 Aug 2010
!Revision:
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
integer iig4wind,ikind
!
integer k,koutmpg
integer ig1tic,ig2tic,ig3tic,ig4tic
integer ig1in,ig2in,ig3in
integer iip1s_inclr(jpnflev)
integer ig1in_u,ig2in_u,ig3in_u
integer ig1in_v,ig2in_v,ig3in_v
integer ezqkdef
!
real*8 zmin,zmax,zdlon,zwork
real*8 zptophr, zprefhr,zrcoefhr
real*8 zlowvar(mni_in,mnj_in)
!
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*1 cltypinc,cltypanl
character*1 clstring
character*2 clvar
character*3 clname
character*3 clnomvar_image
character*3 clnomvar_3
LOGICAL llimplemented
data cltypinc,cltypanl /'R','A'/
!
!!
WRITE(NULOUT,FMT='(/,4X,"Starting varoutlow_glb",//)')
!
!
!*1 File labels
! -----------
!
idatyp_la = 5 ! can be used for other grd_typ also
inbits_la = -32 ! can be used for other grd_typ also
cetikinc='ANINCLOW'
!
if(l4dvar) then
ibrpstamp=nstamplist(1)
else
ibrpstamp=nbrpstamp
endif
!
!*2 Grid properties
! ---------------
!
igdgid = ezqkdef(ni, nj, 'G', 0,0,0,0,0)
!
!*2.1 Set 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
write(nulout,*)'varoutlow_glb:zptop4,zpref4,zrcoef4 '
& ,zptophr,zprefhr,zrcoefhr
!
!*2.2 Writing HY to analysis file
!
if(nulstd.ne.0) then
write(nulout,*) 'Writing variable HY on analysis file'
!
! Determine the style in which ip1 is encoded (15bits or 31 bits)
! A value <= 32767 (2**16 -1) means that ip1 is compacted in 15 bits
! Determine the type of P which was encoded in IP1
!
if(iip1_hyb_prm .le. 32767) then
ip1_pak_hy = 3
else
ip1_pak_hy = 2
! 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
!
!*3 Output
! ******
!
nip2 = 0
niter=0
clgrtyp='G'
!
do jvar = 1,nppcvar
do jlev = 1,mdimppcvar(jvar)
call gdout2(cppcvar(jvar),zlowvar,mni_in,mnj_in
& ,jlev,llimplemented,IIP1S_INCLR(jlev))
!
! write(nulout,*) 'varoutlow_glb: inbits_la =',inbits_la
! write(nulout,*) 'varoutlow_glb: nulinclr =',nulinclr
! write(nulout,*) 'varoutlow_glb: ibrpstamp =',ibrpstamp
! write(nulout,*) 'varoutlow_glb: ideet =',ideet
! write(nulout,*) 'varoutlow_glb: inpas =',inpas
! write(nulout,*) 'varoutlow_glb: mni_in =',mni_in
! write(nulout,*) 'varoutlow_glb: mnj_in =',mnj_in
! write(nulout,*) 'varoutlow_glb: jlev =',jlev
! write(nulout,*) 'varoutlow_glb: iip1s_inclr(jlev) =',iip1s_inclr(jlev)
! write(nulout,*) 'varoutlow_glb: nip2 =',nip2
! write(nulout,*) 'varoutlow_glb: niter =',niter
! write(nulout,*) 'varoutlow_glb: cltypinc =',cltypinc
! write(nulout,*) 'varoutlow_glb: jvar =',jvar
! write(nulout,*) 'varoutlow_glb: cppcvar(jvar) =',cppcvar(jvar)
! write(nulout,*) 'varoutlow_glb: cetikinc =',cetikinc
! write(nulout,*) 'varoutlow_glb: clgrtyp =',clgrtyp
! write(nulout,*) 'varoutlow_glb: ig1in =',ig1in
! write(nulout,*) 'varoutlow_glb: ig2in =',ig2in
! write(nulout,*) 'varoutlow_glb: ig3in =',ig3in
! write(nulout,*) 'varoutlow_glb: idatyp_la =',idatyp_la
!
! if(cppcvar(jvar).eq.'P0') then
! zlowvar(:,:) = 1010.e3
! cetikinc = 'CST1010'
! endif
IERR = VFSTECR(zlowvar,zwork,inbits_la
& ,nulinclr,ibrpstamp,ideet,npas,ni,nj,1,iip1s_inclr(jlev)
& ,nip2,niter,cltypinc,cppcvar(jvar),cetikinc,clgrtyp,nig1
& ,nig2,nig3,nig4,nidatyp,.true.)
!stag cetikinc='ANINCLOW'
!
if(ierr.lt.0) then
write(nulout,*) 'varoutlow_glb: writing field ',cppcvar(jvar)
call abort3d(nulout,'varoutlow_glb: ierr < 0')
endif
enddo
enddo
!
write(nulout,*) 'END of varoutlow_glb'
!
RETURN
END