!-------------------------------------- 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 varout_rebm 1,11
use mod4dv
, only : l4dvar
#if defined (DOC)
*
***s/r varout_rebm - Transfert of the content of COMGD0 on a RPN
* . standard file
*
*Author : S. Pellerin *ARMA/AES April 2000
*Revision:
* JM Belanger CMDA/SMC Aug 2000
* . 32 bits conversion
* S. Pellerin *ARMA/SMC Feb. 2002
* . Analysis packing based on trials
* . Sum of apropriate model cube in 4Dvar mode
* C. Charette - ARMA/SMC - Sep. 2004
* . Conversion to hybrid vertical coordinate
* S. Pellerin *ARMA/SMC Jul. 2005
* . Logical switch llvint to do vertical interpolation
* only vhen necessary
* C. Charette - ARMA/SMC - Nov. 2005
* . INI,INJ,INK are no longer overwritten when npakanl=-999
* . Introduced logical switch llgettrl
* Bin He - ARMA/SMC - Apr. 2008
* . Added reading multiple trial files.
* S. Pellerin, ARMA, August 2008
* . Call to gethybprm2 and getfldprm2
* . Avoid loop over trial files and multiple call to fstinf
* . Call to 'tmg_' subroutines
* . Remove useless call to calgz
* L. Fillion - ARMA/EC - 04 Apr 2008
* . introduce lladjhum.
* L. Fillion - ARMA/EC - Upgrade lam4d to v_10_1_2 3dvar.
* L. Fillion - ARMA/EC - 7 Jun 2010 - Restric output of GZ to
* lowest level for Topography. Let the model build its GZ from
* analysis TT,q
* J.W. Blezius - ARMA - Aug. 2010
* . reduce varout to writing rebm; the rest is in AddAnalInc
#endif
C
use modfgat, only : nstamplist
IMPLICIT NONE
*implicits
#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"
*
integer vfstluk,write_encode_hyb
integer jvar, jcol
integer ji,jj,jlev,inbrlev,imode,inbitstr,ilimlvhu
real*8 zlowvar,zlowwind
#include "localpost.cdk"
C
integer itrlgid,ip0gid,iip1s(jpnflev),iip1,iip2
integer iip1s_inclr(jpnflev),iip1s_trl(jpnflev)
integer ip1_pak_trl,ip1_vco_trl
integer ip1_pak_inclr,ip1_pak_hy,ip1_vco_inclr,iip1_hyb_prm
integer itrlnlev,iwindnlev,igdgid,iip3
integer iig1,iig2,iig3,iig4,ikey,iwindgid
integer iniwind,injwind,inkwind,iig1wind,iig2wind,iig3wind
integer iig4wind,ikind,iset,ibrpstamp
integer inpak_inc
integer INIX, INJX, INKX
real*8 zwork,zpttrl(1)
real*8 zlev_inclr(jpnflev)
real zptop4, zpref4,zrcoef4,zdummy
real*8 zptophr, zprefhr,zrcoefhr
integer k,koutmpg
character*1 clgrtypwind,clstring,cltypinc,cltypanl
character*8 cletik
pointer (pzlowvar,zlowvar(ni,nj,nflev))
pointer (pzlowwind,zlowwind(ni,nj,nflev))
pointer (pxpttrl,zpttrl)
LOGICAL llimplemented,llvarout,llclip,llp0
data cltypinc,cltypanl /'R','A'/
data llclip,llp0 /.true.,.false./
c
real*8 ZHUMIN(JPNFLEV)
!
!!
WRITE(NULOUT,FMT='(/,4X,"Starting varout_rebm: v_10_2_1",//)')
c
CALL HPALLOC(PZLOWVAR,MAX(NI*NJ*nflev,1),IERR,8)
C
WRITE(NULOUT,FMT='(/,4X,''Transfer of the gridpoint model'',
S '' state on file at iteration No.'',I3)')
S NITER
c
if(l4dvar) then
ibrpstamp=nstamplist(1)
else
ibrpstamp=nbrpstamp
endif
c *********************************************************
c Set hybride vertical coordinate parameters from trial field
c
call gethybprm2(ninmpg,nulout,-1,-1,' ',-1,zptop4,zpref4,zrcoef4
& ,iip1_hyb_prm,ntrials)
zptophr = zptop4
zprefhr = zpref4
zrcoefhr= zrcoef4
write(nulout,*)'varout_rebm:zptop4,zpref4,zrcoef4 '
& ,zptophr,zprefhr,zrcoefhr
c
if(nulstd.ne.0) then
cprnt write(nulout,*)'varout_rebm:nIP2,niter,cetikinc,ibrpstamp,ptop,pref,coef '
cprnt & ,nIP2,niter,cetikinc,ibrpstamp,zptop4,zpref4,zrcoef4
write(nulout,*) 'Writing variable HY on analysis-increment file'
c
ierr = write_encode_hyb(nulinclr,'HY',nip2,niter,cetikinc
& ,ibrpstamp,zptop4,zpref4,zrcoef4)
endif
c ****************************************************************
c For a reasong that I (jwb) don't understand, this call to getfldprm2
c is necessary for the next call to getfldprm to succeed.
clnomvar = 'P0'
c
call getfldprm2(IIP1S_TRL,IIP2,IIP3,ITRLNLEV,CLETIKET,CLTYPVAR
& ,IP0GID,clnomvar,ibrpstamp,jpnflev,ninmpg
& ,nulout,ip1_pak_trl,ip1_vco_trl,ntrials,koutmpg)
c
c ****************************************************************
c
c-----Analysis grid hybride vertical coordinate parameters
c
write(nulout,*)' '
write(nulout,*)'************************************** '
write(nulout,*)
& ' The hybride coordinate parameters from increment'
& ,' analysis grid are:'
write(nulout,*) ' PTOP = ',rptopinc*rpatmb,' MB'
write(nulout,*) ' PREF = ',rprefinc*rpatmb,' MB'
write(nulout,*) ' RCOEF= ',rcoefinc
write(nulout,*)'************************************** '
write(nulout,*)' '
c
c-----Setup packing for each variable
c
inpak_inc = -32 ! 32 bits are needed by AAI
write(nulout,*)' '
write(nulout,*)'************************************** '
write(nulout,*)
write(nulout,*) 'PACKING for increments is ',inpak_inc
write(nulout,*)' '
write(nulout,*)'************************************** '
c
call getfldprm(IIP1S_TRL,IIP2,IIP3,ITRLNLEV,CLETIKET,CLTYPVAR
& ,ITRLGID,'UU',ibrpstamp,jpnflev,koutmpg
& ,nulout,ip1_pak_trl,ip1_vco_trl)
call hpalloc(pzlowwind,ni*nj*nflev,ierr,8)
do jvar = 1, nppcvar
c
c Some variable may be request for other to be computed but not
c necessaraly wanted as output..
c
llvarout = .true.
if(cppcvar(jvar).eq.'TT'.and..not.lttout) llvarout = .false.
if(cppcvar(jvar).eq.'HU'.and..not.lhuout) llvarout = .false.
c
llimplemented = .true.
c
write(nulout,*) 'Writing variable ',cppcvar(jvar)
c
C . 2.1 Fields associated with model variables
c
c
c-------Do setup and write the analysed increments on the unit
C nulinclr (low resolution working grid of the 3dvar)
c
if(vlev(1) .eq. 0.0 .or. rptopinc .eq. 0.0) then
c ETA or SIGMA levels were read from namelist
ip1_vco_inclr = 1
do jlev = 1,nflev
zlev_inclr(jlev) = vlev(jlev)
enddo
else
c HYBRID levels read from namelist
ip1_vco_inclr = 5
do jlev = 1,nflev
zlev_inclr(jlev) = vhybinc(jlev)
enddo
endif
c
ip1_pak_inclr = nip1_pak_inc
c
ip1 = -1
jlev = 1
cprnt write(nulout,*)' avant do while',cppcvar(jvar)
do while (jlev.le.nflev.and.ip1.ne.0 )
c
c Get the variable cppcvar(jvar) in zlowvar vector
c
call gdout2(cppcvar(jvar),ZLOWVAR(1,1,jlev),ni,nj
& ,jlev,llimplemented,IIP1S_INCLR(jlev))
cprnt write(nulout,*)'apres gdout2',cppcvar(jvar),jvar,jlev
cprnt & ,IIP1S_INCLR(jlev),llimplemented
c
c If variable cppcvar is not implemented skip to the next variable
c
if (.not.llimplemented) goto 200
c
c ... otherwise write low resolution residuals to rpn standard file.
c
if(cppcvar(jvar).eq.'P0') then ! stag to output constant 1010 hPa for Cecilien for stag work
!cluc zlowvar(:,:,:) = 1010.
!cluc cletik = 'C240_120'
if(nulinclr.ne.0.and.llvarout) then
IERR = VFSTECR(ZLOWVAR(1,1,jlev),zwork,inpak_inc
& ,nulinclr,ibrpstamp,ndeet,npas,ni,nj,1,iip1s_inclr(jlev)
& ,nip2,niter,cltypinc,cppcvar(jvar),cletik,cgrtyp,nig1
& ,nig2,nig3,nig4,nidatyp,.true.)
endif
endif ! stag
!
if(nulinclr.ne.0.and.llvarout) then
cprnt write(nulout,*)'rebm inpak_inc= ',jlev,inpak_inc
cprnt & ,cppcvar(jvar)
IERR = VFSTECR(ZLOWVAR(1,1,jlev),zwork,inpak_inc
& ,nulinclr,ibrpstamp,ndeet,npas,ni,nj,1,iip1s_inclr(jlev)
& ,nip2,niter,cltypinc,cppcvar(jvar),cetikinc,cgrtyp,nig1
& ,nig2,nig3,nig4,nidatyp,.true.)
endif
c
if(cppcvar(jvar).eq.'HU' .and. .not. lhintdelhu) then
c
c Get the variable cppcvar(jvar) in zlowvar vector
c
call gdout2('LQ',ZLOWVAR(1,1,jlev),ni,nj
& ,jlev,llimplemented,IIP1S_INCLR(jlev))
c
endif
c
c If cppcvar is a wind component look for the other component
c
if(cppcvar(jvar).eq.'VV'.or.cppcvar(jvar).eq.'UU') then
c
call gdout2(clnomvar,ZLOWWIND(1,1,jlev),ni,nj,jlev
& ,llimplemented,IIP1S_INCLR(jlev))
c
if(nulinclr.ne.0.and.llvarout) then
ccc write(nulout,*)'xxx inpak_inc= ',jlev,inpak_inc,clnomvar
IERR = VFSTECR(zlowwind(1,1,jlev),zwork,inpak_inc
& ,nulinclr,ibrpstamp,ndeet,npas,ni,nj,1,iip1s_inclr(jlev)
& ,nip2,niter,cltypinc,clnomvar,cetikinc,cgrtyp,nig1,nig2
& ,nig3,nig4,nidatyp,.true.)
endif
c
endif
c
jlev = jlev + 1
c
enddo ! enddo while
c
100 continue
ccc_mhuaes
c At this point the low resolution analysed increments have been
C written to the file on unit nulinclr.
c
200 enddo
c
c* 9. Deallocation of local arrays (Abort on error)
c . ---------------------------------------------
c
call hpdeallc(pzlowvar,ierr,1)
call hpdeallc(pzlowwind,ierr,1)
c
write(nulout,*) 'END of varout_rebm'
c
RETURN
END