!-------------------------------------- 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 1,71
use mod4dv
, only : l4dvar
#if defined (DOC)
*
***s/r varout - 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
#endif
C
use modfgat, only : nstamplist
IMPLICIT NONE
*implicits
#include "pardim.cdk"
#include "comdim.cdk"
#include "comlun.cdk"
#include "comcva.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"
*
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_anl(jpnflev),iip1s_inclr(jpnflev),iip1s_trl(jpnflev)
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,ezqkdef,ezsetopt,ezdefset,iip3
integer iig1,iig2,iig3,iig4,ezgprm,ikey,iwindgid,vezsint
integer iniwind,injwind,inkwind,iig1wind,iig2wind,iig3wind
integer iig4wind,ikind,iset,ibrpstamp
integer inpak_gz,inpak_vt,inpak_inc
integer, allocatable, dimension(:) :: inpak_anl
integer INIX, INJX, INKX
real*8 zhighvar(1),zwork,zhighwind(1),zpstrl,zpsanl(1),zpttrl(1)
real*8 zpresanl(1)
real*8 zprofi(1),zprofo(1),zvhvar(1),zvtvar(1),zesvar(1)
real*8 zlev_int(jpnflev),zlev_anl(jpnflev),zlev_trl(jpnflev)
real*8 zlev_inclr(jpnflev)
real*8 zps,zptop,zttvar(1),zwrkvec(1),zprestrl(1),zgzvar(1)
real*8 ztrlq(1),zincq(1),ztopo,zanlq(1)
real zptop4, zpref4,zrcoef4,zdummy
real*8 zptophr, zprefhr,zrcoefhr
integer k,koutmpg
character*1 clgrtypwind,clstring,cltypinc,cltypanl
character*8 cletik
pointer (pzhighvar,zhighvar)
pointer (pzhighwind,zhighwind)
pointer (pzlowvar,zlowvar(ni,nj,nflev))
pointer (pzlowwind,zlowwind(ni,nj,nflev))
pointer (pxpstrl,zpstrl),(pxpttrl,zpttrl),(pxpresanl,zpresanl)
pointer (pxprestrl,zprestrl),(pxprofi,zprofi),(pxprofo,zprofo)
pointer (pxvhvar,zvhvar),(pxps,zps),(pxptop,zptop)
pointer (pxvtvar,zvtvar),(pxttvar,zttvar),(pxwrkvec,zwrkvec)
pointer (pxgzvar,zgzvar),(pxtopo,ztopo),(pxtrlq,ztrlq)
pointer (pxincq, zincq),(pxesvar,zesvar)
pointer (pxanlq,zanlq),(pxpsanl,zpsanl)
LOGICAL llimplemented,llwind,llbasevar,llvarout,llclip,llp0
logical llgettrl, lladjhum
logical :: llvint
data cltypinc,cltypanl /'R','A'/
data llclip,llp0 /.true.,.false./
c
real*8 ZHUMIN(JPNFLEV)
!
!!
WRITE(NULOUT,FMT='(/,4X,"Starting VAROUT: v_10_2_1",//)')
!
llvint = .false.
lladjhum = .true. ! cluc
if(lsw) lladjhum = .false.
if(l1obs) lladjhum = .false.
c
c Setting degree of horizontal interpolations
c
igdgid = ezqkdef(ni, nj, 'G', 0,0,0,0,0)
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
c SET DIAGNOSTIC VARIABLES ON IF FIRST VAR IS PP (for GENINCR branch)
c
IF(CPPCVAR(1).EQ.'PP') LVARDIAG=.TRUE.
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:zptop4,zpref4,zrcoef4 '
& ,zptophr,zprefhr,zrcoefhr
c ----Writing HY to analysis file
c
if(nulstd.ne.0) then
cprnt write(nulout,*)'varout:nIP2,niter,cetkinc,ibrpstamp,ptop,pref,coef '
cprnt & ,nIP2,niter,cetikinc,ibrpstamp,zptop4,zpref4,zrcoef4
write(nulout,*) 'Writing variable HY on analysis file'
c
C
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
c ****************************************************************
c Get P0 from trial fields for vertical interpolation definition
c
write(nulout,*)
& 'Reading P0 and hybride coordinate parameters of trial field '
& ,' for vertical interpolation'
c
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
ikey = FSTINF(koutmpg, INI, INJ, INK, ibrpstamp, cletiket,
& iip1s_trl(1), iip2, iip3,cltypvar,clnomvar)
c
if(ikey.lt.0) then
write(nulout,*) ' ******* ERROR ******* '
write(nulout,*) 'No P0 found in ',ninmpg
call abort3d(nulout,'VAROUT')
endif
c
ierr = FSTPRM(ikey, IDATEO, IDEET, IPAS, INI, INJ, INK, INBITSTR,
& IDATYP,IP1,IP2, IP3, CLTYPVAR, CLNOMVAR, CLETIKET, CLGRTYP,
& IG1, IG2,IG3,IG4, ISWA, ILENGTH, IDLTF, IUBC, IEXTR1,
& IEXTR2,IEXTR3)
c
if (npakanl .ne. -999) inbitstr = -npakanl
c
call hpalloc(pxpstrl,ini*inj,ierr,8)
c
ikey = VFSTLUK(zpstrl, ikey, INI, INJ, INK)
c
c ****************************************************************
c
c-------Writing PT to analysis file when R coefficient = 1.0
c Use grid parameters from P0
if (nulstd.ne.0) then
if(nint(zrcoef4) .eq. 1)then
ierr = ezgprm(ip0gid,clgrtyp,ini,inj,iig1,iig2,iig3,iig4)
call hpalloc(pxpttrl,ini*inj,ierr,8)
iip1 = 0
do jcol = 1,ini*inj
zpttrl(jcol) = zptophr
enddo
write(nulout,*) 'Writing PT field on analysis file unit= '
& ,nulstd
write(nulout,*)'xxx PT inbitstr= ',inbitstr
IERR = VFSTECR(zpttrl,zwork,inbitstr
& ,nulstd,ibrpstamp,ndeet,npas,ini,inj,1,iip1_hyb_prm,nip2
& ,niter,cltypanl,'PT',cetikinc,clgrtyp,iig1,iig2
& ,iig3,iig4,nidatyp,.false.)
if(ierr.lt.0) then
write(nulout,*) ' ******* ERROR ******* '
write(nulout,*) 'Problem writing PT field on ',nulstd
call abort3d(nulout,'VAROUT')
endif
call hpdeallc(pxpttrl,ierr,1)
endif
endif
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
allocate(inpak_anl(nppcvar))
c
inpak_inc = -16
if(npakanl .ne. -999) then
inpak_gz = npakanl
inpak_vt = npakanl
do jvar = 1, nppcvar
inpak_anl(jvar)= npakanl
enddo
else
inpak_gz = -24
inpak_vt = -16
do jvar = 1, nppcvar
ikey = FSTINF(koutmpg, INIX, INJX, INKX, ibrpstamp,
& cletiket,-1, -1, -1,cltypvar,cppcvar(jvar))
if(ikey .ge. 0) then
ierr = fstprm(ikey,idateo,ideet,inpas,inix,injx,inkx, inbits,
& idatyp,ip1,ip2,ip3,cltypvar,clnomvar,cletiket,clgrtyp
& ,ig1,ig2,ig3,ig4,iswa,ilength,idltf,iubc,iextr1
& ,iextr2,iextr3)
inpak_anl(jvar) = -inbits
else
inpak_anl(jvar) = -16
endif
if(cppcvar(jvar) .eq. 'TT') inpak_vt = inpak_anl(jvar)
if(cppcvar(jvar) .eq. 'GZ') inpak_gz = inpak_anl(jvar)
enddo
endif
write(nulout,*)' '
write(nulout,*)'************************************** '
write(nulout,*)
do jvar =1,nppcvar
write(nulout,*) 'PACKING for analysed var ',cppcvar(jvar),' is '
& ,inpak_anl(jvar)
enddo
write(nulout,*) 'PACKING for analysed GZ is ',inpak_gz
write(nulout,*) 'PACKING for analysed VT is ',inpak_vt
write(nulout,*) 'PACKING for increments is ',inpak_inc
write(nulout,*)' '
write(nulout,*)'************************************** '
c
c Winds have not been processed yet
c
llwind = .false.
c
call getfldprm(IIP1S_TRL,IIP2,IIP3,ITRLNLEV,CLETIKET,CLTYPVAR
& ,ITRLGID,'UU',ibrpstamp,jpnflev,koutmpg
& ,nulout,ip1_pak_trl,ip1_vco_trl)
c Reset switch llvint=.true. if nflev .ne. itrlnlev
c (ie when the number of levels of the analysis grid
c is not equal to the number of levels of the trial field grid)
c
if (nflev .ne. itrlnlev) then
llvint = .true.
endif
call hpalloc(pxtopo,ini*inj,ierr,8)
call hpalloc(pxpsanl,ini*inj,ierr,8)
call hpalloc(pzlowwind,ni*nj*nflev,ierr,8)
call hpalloc(pzhighvar,ini*inj*nflev,ierr,8)
call hpalloc(pzhighwind,ini*inj*nflev,ierr,8)
call hpalloc(pxpresanl,ini*inj*nflev,ierr,8)
call hpalloc(pxprofi,ini*inj*nflev,ierr,8)
call hpalloc(pxps,ini*inj,ierr,8)
call hpalloc(pxptop,ini*inj,ierr,8)
call hpalloc(pxprofo,ini*inj*itrlnlev,ierr,8)
call hpalloc(pxprestrl,ini*inj*itrlnlev,ierr,8)
call hpalloc(pxvhvar,ini*inj*itrlnlev,ierr,8)
call hpalloc(pxttvar,ini*inj*itrlnlev,ierr,8)
call hpalloc(pxtrlq,ini*inj*itrlnlev,ierr,8)
call hpalloc(pxincq,ini*inj*itrlnlev,ierr,8)
call hpalloc(pxanlq,ini*inj*itrlnlev,ierr,8)
call hpalloc(pxvtvar,ini*inj*itrlnlev,ierr,8)
call hpalloc(pxwrkvec,ini*inj*itrlnlev,ierr,8)
call hpalloc(pxesvar,ini*inj*itrlnlev,ierr,8)
call hpalloc(pxgzvar,ini*inj*itrlnlev,ierr,8)
do jvar = 1, nppcvar
if(cppcvar(jvar).eq.'GZ'.or.cppcvar(jvar).eq.'VT') then
c
c Those variables are re-computed from dependent total analysed variables
c This means that no vertical interpolation are required but increments
c can be diagnosed and even interpolated horizontally if corresponding
c template variable are present in the trial file.
c
llbasevar = .false.
else
c
c those variables will be interpolated vertically as long as
c corresponding fields are present in the trial file.
c
llbasevar = .true.
endif
c
c Some variable may be request for other to be computed but not
c necessaraly wanted as output..
c
llvarout = .true.
llgettrl = .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
if ((cppcvar(jvar).ne.'UU'.and.cppcvar(jvar).ne.'VV').or.
& .not.llwind) then
c
write(nulout,*) 'Writing variable ',cppcvar(jvar)
c
C . 2.1 Fields associated with model variables
C
C
call getfldprm(IIP1S_TRL,IIP2,IIP3,ITRLNLEV,CLETIKET,CLTYPVAR
& ,ITRLGID,cppcvar(jvar),ibrpstamp,jpnflev,koutmpg
& ,nulout,ip1_pak_trl,ip1_vco_trl)
c
c
c---------Sort the levels encoded in IIP1S_TRL
c
c---------Decode the levels
imode = -1
ikind = ip1_vco_trl
do jlev = 1,itrlnlev
call VCONVIP( iip1s_trl(jlev), zlev_trl(jlev), ikind, imode,
& clstring,.false. )
cprnt write(nulout,*)'varout decode iip1s_trl:'
cprnt write(nulout,*)'varout trl:var,jlev,itrlnlev,ip1strl,lev,knd,mod '
cprnt & ,cppcvar(jvar),jlev,itrlnlev,iip1s_trl(jlev),zlev_trl(jlev)
cprnt & ,ikind, imode
enddo
c
call vsort(zlev_trl,itrlnlev)
c
c---------Encode iip1s_trl to match the sorted zlev_trl
imode = ip1_pak_trl
ikind = ip1_vco_trl
do jlev = 1,itrlnlev
call VCONVIP( iip1s_trl(jlev), zlev_trl(jlev), ikind, imode,
& clstring,.false. )
cprnt write(nulout,*)'varout encode iip1s_trl:'
cprnt write(nulout,*)'varout trl:var,jlev,itrlnlev,ip1strl,lev,knd,mod '
cprnt & ,cppcvar(jvar),jlev,itrlnlev,iip1s_trl(jlev),zlev_trl(jlev)
cprnt & ,ikind, imode
enddo
c
c---------Do setup to properly interpolate the analysed increments to
C the model levels and model high resolution grid and to encode
C IP1 on unit nulinchr (increments) and on unit nulstd (analysis)
C with the same coded values found on the trial field (unit ninmpg)
c
c Type of vertical coord accepted are
C ip1_vco_trl = 1 (eta levels)
c ip1_vco_trl = 2 (2D fields have value 0.0 in pressure coordinate)
C ip1_vco_trl = 5 (hybrid levels)
ip1_pak_anl = ip1_pak_trl
ip1_vco_anl = ip1_vco_trl
if(ip1_vco_trl .eq. 1 ) then ! trial on eta coord
do jlev = 1,itrlnlev
zlev_int(jlev) = zlev_trl(jlev) + (1.0 - zlev_trl(jlev))
& *(zptophr/zprefhr)
zlev_anl(jlev) = zlev_trl(jlev)
enddo
elseif(ip1_vco_trl .eq. 5 .or. ip1_vco_trl .eq. 2) then
do jlev = 1,itrlnlev
zlev_int(jlev) = zlev_trl(jlev)
zlev_anl(jlev) = zlev_trl(jlev)
enddo
else
write(nulout,*) ' **** ERROR IN TYPE OF VERTICAL COORD **** '
write(nulout,*) 'Variable= ',cppcvar(jvar)
& ,' Type= ',ip1_vco_trl
call abort3d(nulout,'VAROUT')
endif
c
c---------Encode zlev_anl in iip1s_anl
c
imode = ip1_pak_anl
ikind = ip1_vco_anl
do jlev = 1,itrlnlev
cprnt write(nulout,*)'varoutanl av convip:',
cprnt & 'var,jlev,itrlnlev,hy_a,hy_i,ikd,imd '
cprnt & ,cppcvar(jvar),jlev,itrlnlev
cprnt & ,zlev_anl(jlev),zlev_int(jlev),ikind, imode
call VCONVIP( iip1s_anl(jlev), zlev_anl(jlev), ikind, imode,
& clstring,.false. )
cprnt write(nulout,*)'varoutanl:',
cprnt & 'var,jlev,itrlnlev,iip1s_anl,hy_a,hy_i,ikd,imd '
cprnt & ,cppcvar(jvar),jlev,itrlnlev,iip1s_anl(jlev)
cprnt & ,zlev_anl(jlev),zlev_int(jlev),ikind, imode
enddo
if (cppcvar(jvar).eq.'UU'.or.cppcvar(jvar).eq.'VV') then
c
llwind = .true.
c
if (cppcvar(jvar).eq.'UU') then
clnomvar = 'VV'
else
clnomvar = 'UU'
endif
c
endif
c
if (itrlnlev.ne.0) then
c
ierr = ezgprm(itrlgid,clgrtyp,ini,inj,iig1,iig2,iig3,iig4)
c
if (cppcvar(jvar).eq.'UU'.or.cppcvar(jvar).eq.'VV') then
c
call getfldprm(IIP1S,IIP2,IIP3,IWINDNLEV,CLETIKET,CLTYPVAR
& ,IWINDGID,clnomvar,ibrpstamp,jpnflev,koutmpg
& ,nulout,ip1_pak_trl,ip1_vco_trl)
c
c
ierr = ezgprm(iwindgid,clgrtypwind,iniwind,injwind
& ,iig1wind,iig2wind,iig3wind,iig4wind)
c
endif
endif
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 If the logical switch LANLHU2ES=.T., then the high resolution
C analysis of T-TD (ES) will be derived from the analyses of HU and TT.
c If the logical switch LANLHU2ES=.F., then the high resolution
C analysis of T-TD (ES) will be the sum of trial field of T-TD
C plus the high resolution analysed increments T-TD. The resulting
C analysis of T-TD will NOT be consistent with the analysis of HU
c
if(cppcvar(jvar).eq.'ES'.and. lanlhu2es) then
llvarout = .false.
llgettrl = .false.
endif
write(nulout,*)'varout: jvar,cppvar,llvarout,llgettrl= ',jvar
& ,cppcvar(jvar),llvarout,llgettrl
ccc_mhuaes
ccc if (ip1.ne.0) then
if (itrlnlev.gt.1) then
inbrlev = nflev
else
inbrlev = 1
endif
c
cprnt write(nulout,*)' avant if(itrlnlev.ne.0) ',cppcvar(jvar)
if(itrlnlev.ne.0) then
call tmg_start(95,'HINT_INC')
if (cppcvar(jvar).eq. 'UU') then
c
call hintvec2(zlowvar,zlowwind,ni*nj,igdgid
& ,zhighvar,zhighwind
& ,ini*inj,itrlgid,inbrlev,'CUBIC')
c
elseif(cppcvar(jvar).eq.'VV') then
c
call hintvec2(zlowwind,zlowvar,ni*nj,igdgid
& ,zhighwind,zhighvar
& ,ini*inj,itrlgid,inbrlev,'CUBIC')
else
call hintscal(zlowvar,ni*nj,igdgid,
& zhighvar,ini*inj,itrlgid,inbrlev,'CUBIC')
endif
call tmg_stop(95)
c
c To write horizontal high res residuals on on analysis levels uncomment
c the following line ...
c if(nulinchr.ne.0) then
c ... and comment the next one.
cprnt write(nulout,*)' avant if(nulinchr.ne.0.and.inbrlev.eq.1) '
cprnt & ,cppcvar(jvar),inbrlev
if(nulinchr.ne.0.and.inbrlev.eq.1) then
if(llvarout) then
if(cppcvar(jvar).eq.'VV'.or.cppcvar(jvar).eq.'UU') then
do jlev = 1, inbrlev
cprnt write(nulout,*)'varout:var,jlev,iip1s_anl(jlev) '
cprnt & ,clnomvar,jlev,iip1s_anl(jlev)
cprnt write(nulout,*)'rehm inpak_inc= ',jlev,inpak_inc
cprnt & ,clnomvar
IERR = VFSTECR(zhighwind((jlev-1)*iniwind*injwind+1)
& ,zwork,inpak_inc,nulinchr,ibrpstamp
& ,ndeet,npas,iniwind,injwind,1,iip1s_anl(jlev)
& ,nip2,niter,cltypinc,clnomvar,cetikinc,clgrtyp
& ,iig1wind,iig2wind,iig3wind,iig4wind,nidatyp,
& .false.)
enddo
endif
endif
c
c ... and write high resolution residuals to rpn standard file ...
c
if(cppcvar(jvar).eq.'HU'.and.lolqout.and. .not. lhintdelhu
& ) then
do jlev = 1, inbrlev
cprnt write(nulout,*)'rehm LQ inpak_inc= ',jlev,inpak_inc
IERR = VFSTECR(zhighvar((jlev-1)*ini*inj+1),zwork,
& inpak_inc,nulinchr,ibrpstamp,ndeet,npas
& ,ini,inj,1,iip1s_anl(jlev),nip2,niter,cltypinc
& ,'LQ',cetikinc,clgrtyp,iig1,iig2,iig3,iig4
& ,nidatyp,.true.)
enddo
elseif((cppcvar(jvar).ne.'HU'.or. lhintdelhu) .and.
& llvarout) then
do jlev = 1, inbrlev
cprnt write(nulout,*)'rehm inpak_inc= ',jlev,inpak_inc
cprnt & ,cppcvar(jvar)
IERR = VFSTECR(zhighvar((jlev-1)*ini*inj+1),zwork
& ,inpak_inc,nulinchr,ibrpstamp,ndeet,npas
& ,ini,inj,1,iip1s_anl(jlev),nip2,niter,cltypinc
& ,cppcvar(jvar),cetikinc,clgrtyp,iig1,iig2,iig3
& ,iig4,nidatyp,.true.)
enddo
endif
endif
endif
c
cprnt write(nulout,*)' avant if(itrlnlev.gt.1.and.llbasevar) '
cprnt & ,cppcvar(jvar),inbrlev,llbasevar
if (itrlnlev.gt.1.and.llbasevar) then ! BEGIN 3D FIELDS
c
c ------ Vertical interpolation to trial levels ------
c
c Computation of pressure values on analysis profiles of the high
c resolution horizonal grid
c
c Interpolation of high res. P0 and PT to high res. variable grid
c
if (llvint) then
ierr = ezsetopt('INTERP_DEGREE','CUBIC')
iset = ezdefset(itrlgid,ip0gid)
ierr = vezsint(zps,zpstrl,ini,inj,1,ini,inj,1)
call calcpres(zpresanl,vhybinc,nflev,zps,rptopinc*rpatmb
& ,rprefinc*rpatmb,rcoefinc,ini*inj)
c
c Computation of pressure values on trial profiles of the high
c resolution horizonal grid
c
cprnt write(nulout,*)' avant calcpres (zprestrl '
call calcpres(zprestrl,zlev_int,itrlnlev,zps,zptophr
& ,zprefhr,zrcoefhr,ini*inj)
c
do jlev = 1, nflev
do jcol = 1, ini*inj
zprofi((jcol-1)*nflev + jlev) = zhighvar((jlev-1)*ini
& *inj+jcol)
enddo
enddo
c
cprnt write(nulout,*)' avant vintprof '
call vintprof(zprofo,zprestrl,itrlnlev,zprofi,
& zpresanl,nflev,ini*inj)
c
do jlev = 1, itrlnlev
do jcol = 1, ini*inj
zvhvar((jlev-1)*ini*inj+jcol) =
& zprofo((jcol-1)*itrlnlev+jlev)
enddo
enddo
else
do jlev = 1, itrlnlev
do jcol = 1, ini*inj
zvhvar((jlev-1)*ini*inj+jcol) =
& zhighvar((jlev-1)*ini*inj+jcol)
enddo
enddo
endif
if(cppcvar(jvar).eq. 'HU') then
ierr = ezsetopt('INTERP_DEGREE','CUBIC')
iset = ezdefset(itrlgid,ip0gid)
c interpolation of ANALYSED surface pressure on HU grid
ierr = vezsint(zps,zpsanl,ini,inj,1,ini,inj,1)
c computation of pressure values on eta trial levels based on ANALYSED
C P0
call calcpres(zprestrl,zlev_int,itrlnlev,zps,zptophr
& ,zprefhr,zrcoefhr,ini*inj)
endif
c
c Writing to standard files
c
call tmg_start(96,'WR_HR_INC')
do jlev = 1,itrlnlev
cprnt write(nulout,*)'avant if(nulinchr.ne.0 ',CPPCVAR(JVAR)
cprnt & ,jlev,IIP1S_ANL(JLEV)
if(nulinchr.ne.0) then
if(cppcvar(jvar).eq.'HU'.and.lolqout.and. .not.
& lhintdelhu)then
cprnt write(nulout,*)'rehm LQ inpak_inc= ',jlev,inpak_inc
IERR = VFSTECR(zvhvar((jlev-1)*ini*inj+1),zwork
& ,inpak_inc,nulinchr,ibrpstamp,ndeet,npas
& ,ini,inj,1,iip1s_anl(jlev),nip2,niter,cltypinc
& ,'LQ',cetikinc,clgrtyp,iig1,iig2,iig3,iig4
& ,nidatyp,.true.)
elseif((cppcvar(jvar).ne.'HU'.or.lhintdelhu).and
& .llvarout) then
cprnt write(nulout,*)'avant vfstecr nulinchr ',CPPCVAR(JVAR),jlev
cprnt & ,IIP1S_ANL(JLEV)
IERR = VFSTECR(zvhvar((jlev-1)*ini*inj+1),zwork
& ,inpak_inc,nulinchr,ibrpstamp,ndeet,npas
& ,ini,inj,1,iip1s_anl(jlev),nip2,niter,cltypinc
& ,cppcvar(jvar),cetikinc,clgrtyp,iig1,iig2,iig3
& ,iig4,nidatyp,.true.)
cprnt write(nulout,*)'apres vfstecr nulinchr ',CPPCVAR(JVAR)
cprnt & ,jlev,IIP1S_ANL(JLEV)
endif
endif
c
c Look for corresponding trial field
c
if(llgettrl) then
ikey = FSTINF(koutmpg, INI, INJ, INK, ibrpstamp,
& cletiket,iip1s_trl(jlev), iip2, iip3,cltypvar
& ,cppcvar(jvar))
c
cprnt write(nulout,*)'varoutW:cppcvar(jvar),ikey',cppcvar(jvar)
cprnt & ,ikey
if (ikey.lt.0) then
write(nulout,*) 'Problems finding variable '
& ,cppcvar(jvar),' at level ',zlev_trl(jlev)
& ,' in trial file'
call abort3d(nulout,'VAROUT')
endif
c
ikey = VFSTLUK(zhighvar,ikey, INI, INJ, INK)
c
c Sum of increments and trial field
c
if(cppcvar(jvar).eq.'HU') then
c
if (lhintdelhu) then
do jcol = 1, ini*inj
zvhvar((jlev-1)*ini*inj+jcol) = max(zhighvar(jcol)
& ,1.0D-12) +zvhvar((jlev-1)*ini*inj+jcol)
enddo
else
do jcol = 1, ini*inj
zvhvar((jlev-1)*ini*inj+jcol) =
& exp(
& log(max(zhighvar(jcol),1.0D-12))
& + zvhvar((jlev-1)*ini*inj+jcol)
& )
enddo
endif
c
c Get the trial specific humidity for increment ajustment
c
do jcol = 1, ini*inj
ztrlq((jlev-1)*ini*inj+jcol) = zhighvar(jcol)
c
c CAREFULL: zprofo is now re-used as re-alligned
c pressure vector for use with AJHUM
c Note: zprestrl contains pressure column based
c on corrected surface pressure
zprofo((jlev-1)*ini*inj+jcol) =
& zprestrl((jcol-1)*itrlnlev+jlev)
enddo
c
else
c
do jcol = 1, ini*inj
zvhvar((jlev-1)*ini*inj+jcol) = zhighvar(jcol) +
& zvhvar((jlev-1)*ini*inj+jcol)
c
if(cppcvar(jvar).eq.'TT'.and.(lhuout.or.lvtout.or
& .lgzout)) then
zttvar((jlev-1)*ini*inj+jcol) = zvhvar((jlev-1)*ini
& *inj+jcol)
endif
c
enddo
c
endif
c
else
write(nulout,*) 'VAROUT: '
& ,cppcvar(jvar),' at level ',zlev_trl(jlev)
& ,' in trial file'
endif
c
enddo
call tmg_stop(96)
c
if(cppcvar(jvar).eq.'HU'.and.lladjhum) then
c
c CAREFULL: un-ajusted trial specific humidity copied in variable zprestrl
c
do jlev = 1,itrlnlev
zhumin(jlev)=0.04
do jcol = 1, ini*inj
zprestrl((jlev-1)*ini*inj+jcol) =
& ztrlq((jlev-1)*ini*inj+jcol)
zanlq((jlev-1)*ini*inj+jcol) =
& zvhvar((jlev-1)*ini*inj+jcol)
if (ztrlq((jlev-1)*ini*inj+jcol).lt.zhumin(jlev)
& .and.ztrlq((jlev-1)*ini*inj+jcol).gt.0.0)
& zhumin(jlev)=ztrlq((jlev-1)*ini*inj+jcol)
enddo
enddo
ilimlvhu=nint(rlimlvhu)
c trial specific humidity ajustment (zprestrl)
write(nulout,*) ' '
write(nulout,*) ' *** TRIAL SPECIFIC HUMIDITY AJUSTMENT '
write(nulout,*) ' '
call tmg_start(97,'AJ_HU')
call AJHUM(zprofo,zttvar,zprestrl,zvtvar,zwrkvec,ini,inj
& ,itrlnlev,zlev_trl,zhumin,llclip)
c specific humidity analysis ajustment (zvhvar)
write(nulout,*) ' '
write(nulout,*) ' *** ANAL SPECIFIC HUMIDITY AJUSTMENT '
write(nulout,*) ' '
call AJHUM(zprofo,zttvar,zvhvar,zvtvar,zwrkvec,ini,inj
& ,itrlnlev,zlev_anl,zhumin,llclip)
call tmg_stop(97)
c
ccc_mhuaes
c
c T-Td analysis after ajustments (zesvar)
if(lanlhu2es) then
c ES analysis calculation and writing
c zhvar = specific humidity;
C zwrkvec= true temperature in kelvin
C zttvar = true temperature in celsius
C zprofo = pressure in mb
C zincq = pressure in pascal
do jlev = 1,itrlnlev
do jcol = 1, ini*inj
zwrkvec((jlev-1)*ini*inj+jcol) =
& zttvar((jlev-1)*ini*inj+jcol) + 273.16D0
zincq((jlev-1)*ini*inj+jcol) =
& zprofo((jlev-1)*ini*inj+jcol) * 100.0D0
enddo
enddo
call tmg_start(3,'MHUAESGD2')
CALL MHUAESGD2(zesvar,zvhvar,zwrkvec,zincq,ini,inj
& ,itrlnlev,lswphes)
call tmg_stop(3)
C set T-TD between zero and rlimit_es read namelist
do jlev = 1,itrlnlev
do jcol = 1, ini*inj
zesvar((jlev-1)*ini*inj+jcol) =
& max(zesvar((jlev-1)*ini*inj+jcol),0.0D0)
zesvar((jlev-1)*ini*inj+jcol) =
& min(zesvar((jlev-1)*ini*inj+jcol),rlimit_es)
enddo
enddo
endif
C
if (cvcord(1:3).eq.'MAM'.and.nulinchr.ne.0) then
c
c Adjust HU increment such that
c
c Q = Q(adjusted) - Q
c inc a t
c
do jlev = 1,itrlnlev
do jcol = 1, ini*inj
zincq((jlev-1)*ini*inj+jcol) =
& zvhvar((jlev-1)*ini*inj+jcol)-
& ztrlq((jlev-1)*ini*inj+jcol)
enddo
c
cprnt write(nulout,*)'varout dans if(MAM) avant VFSTECR'
cprnt & ,CPPCVAR(JVAR),jlev,iip1s_anl(jlev)
IERR = VFSTECR(zincq((jlev-1)*ini*inj+1),zwork
& ,inpak_inc,nulinchr,ibrpstamp,ndeet,npas
& ,ini,inj,1,iip1s_anl(jlev),nip2,niter,cltypinc
& ,cppcvar(jvar),cetikinc,clgrtyp,iig1,iig2,iig3
& ,iig4,nidatyp,.true.)
c
enddo
end if
c------------- Computation of new specific humidity analysis based on ajusted
c increments:
c
c Q = Q + ( Q(ajusted) - Q(ajusted) )
c a t a t
c
do jlev = 1,itrlnlev
do jcol = 1, ini*inj
zanlq((jlev-1)*ini*inj+jcol) =
& ztrlq((jlev-1)*ini*inj+jcol) +
& (zvhvar((jlev-1)*ini*inj+jcol) -
& zprestrl((jlev-1)*ini*inj+jcol))
c temperature conversion for mfotvt
zwrkvec((jlev-1)*ini*inj+jcol) =
& zttvar((jlev-1)*ini*inj+jcol) + 273.16D0
enddo
enddo
c
c here ztrlq is filled with new virtual temperature based on
C ajusted HU
c
CALL MFOTVT8(ztrlq,zwrkvec,zanlq,ini*inj,itrlnlev,ini*inj)
do jlev = 1,itrlnlev
do jcol = 1, ini*inj
ztrlq((jlev-1)*ini*inj+jcol) =
& ztrlq((jlev-1)*ini*inj+jcol) -
& zwrkvec((jlev-1)*ini*inj+jcol)
ENDDO
ENDDO
endif
c
call tmg_start(98,'COMP_GZ')
if (cppcvar(jvar).eq.'HU'.and.lgzout) then
c Looking for topography
ikey = FSTINF(koutmpg, INI, INJ, INK, ibrpstamp,
& cletiket,iip1s_trl(itrlnlev), iip2, iip3,cltypvar
& ,'GZ')
c
cprnt write(nulout,*)'varoutZ:cppcvar(jvar),ikey',cppcvar(jvar)
cprnt & ,ikey
if (ikey.lt.0) then
write(nulout,*) 'Problems finding variable '
& ,'GZ',' at level ',zlev_trl(itrlnlev),' in trial file'
call abort3d(nulout,'VAROUT')
endif
c
ikey = VFSTLUK(ztopo,ikey, INI, INJ, INK)
c
if(.not.lcva_hemis) then
call calgz(zprofo,zvtvar,zgzvar,ztopo,ini,inj,itrlnlev
& ,iip1s_trl)
endif
c
c ztrlq here contain vt from q fitred increment
c
endif
c
call tmg_stop(98)
c
call tmg_start(5,'WR_HR_AN')
if(nulstd.ne.0) then
do jlev = 1,itrlnlev
c
c Writing analysis field
c
if(llvarout) then
IERR = VFSTECR(zvhvar((jlev-1)*ini*inj+1),zwork
& ,inpak_anl(jvar),nulstd,ibrpstamp,ndeet,npas,ini
& ,inj,1,iip1s_anl(jlev),nip2,niter,cltypanl
& ,cppcvar(jvar),cetikinc,clgrtyp,iig1,iig2,iig3
& ,iig4,nidatyp,.true.)
endif
c
if(cppcvar(jvar).eq.'HU') then
if(lvtout) then
c VT writing
IERR = VFSTECR(zvtvar((jlev-1)*ini*inj+1),zwork
& ,inpak_vt,nulstd,ibrpstamp,ndeet,npas,ini,inj
& ,1,iip1s_anl(jlev),nip2,niter,cltypanl,'VT'
& ,cetikinc,clgrtyp,iig1,iig2,iig3,iig4,nidatyp
& ,.false.)
endif
ccc_mhuaes
c ES analysis writing
IF(LANLHU2ES) THEN
IERR = VFSTECR(zesvar((jlev-1)*ini*inj+1),zwork
& ,inpak_vt,nulstd,ibrpstamp,ndeet,npas,ini,inj
& ,1,iip1s_anl(jlev),nip2,niter,cltypanl,'ES'
& ,cetikinc,clgrtyp,iig1,iig2,iig3,iig4,nidatyp
& ,.true.)
ENDIF
if(lgzout) then
c GZ writing
if(lcva_hemis.and.jlev.eq.nflev) then
IERR = VFSTECR(ztopo,zwork
& ,inpak_gz,nulstd,ibrpstamp,ndeet,npas,ini,inj
& ,1,iip1s_anl(nflev),nip2,niter,cltypanl,'GZ'
& ,cetikinc,clgrtyp,iig1,iig2,iig3,iig4,nidatyp
& ,.true.)
else if(.not.lcva_hemis) then
IERR = VFSTECR(zgzvar((jlev-1)*ini*inj+1),zwork
& ,inpak_gz,nulstd,ibrpstamp,ndeet,npas,ini,inj
& ,1,iip1s_anl(jlev),nip2,niter,cltypanl,'GZ'
& ,cetikinc,clgrtyp,iig1,iig2,iig3,iig4,nidatyp
& ,.true.)
endif
endif
endif
enddo
endif
call tmg_stop(5)
c
if(cppcvar(jvar).eq.'VV'.or.cppcvar(jvar).eq.'UU') then
c
c ------ Vertical interpolation to trial levels ------
c
c Computation of pressure values on analysis profiles of the high
c resolution horizonal grid
c
c Interpolation of high res. P0 and PT to high res. variable grid
c
if (llvint) then
ierr = ezsetopt('INTERP_DEGREE','CUBIC')
iset = ezdefset(iwindgid,ip0gid)
ierr = vezsint(zps,zpstrl,iniwind,injwind,1,ini,inj,1)
c
call calcpres(zpresanl,vhybinc,nflev,zps,rptopinc*rpatmb
& ,rprefinc*rpatmb,rcoefinc,iniwind*injwind)
c
c Computation of pressure values on trial profiles of the high
c resolution horizonal grid
c
c
call calcpres(zprestrl,zlev_int,itrlnlev,zps,zptophr
& ,zprefhr,zrcoefhr,iniwind*injwind)
c
do jlev = 1, nflev
do jcol = 1, iniwind*injwind
zprofi((jcol-1)*nflev + jlev) =
& zhighwind((jlev-1)*iniwind*injwind+jcol)
enddo
enddo
c
call vintprof(zprofo,zprestrl,itrlnlev,zprofi,zpresanl
& ,nflev,iniwind*injwind)
c
c
do jlev = 1, itrlnlev
do jcol = 1, iniwind*injwind
zvhvar((jlev-1)*iniwind*injwind+jcol) =
& zprofo((jcol-1)*itrlnlev+jlev)
enddo
enddo
else
ccc zvhvar = zhighwind
do jlev = 1, itrlnlev
do jcol = 1, iniwind*injwind
zvhvar((jlev-1)*iniwind*injwind+jcol) =
& zhighwind((jlev-1)*iniwind*injwind+jcol)
enddo
enddo
endif
c
c Writing to standard files
c
call tmg_start(5,'WR_HR_AN')
do jlev = 1,itrlnlev
if(nulinchr.ne.0) then
IERR = VFSTECR(zvhvar((jlev-1)*iniwind*injwind+1)
& ,zwork,inpak_inc,nulinchr,ibrpstamp,ndeet
& ,npas,iniwind,injwind,1,iip1s_anl(jlev),nip2
& ,niter,cltypinc,clnomvar,cetikinc,clgrtyp
& ,iig1wind,iig2wind,iig3wind,iig4wind,nidatyp,
& .false.)
endif
c
c Look for corresponding trial field
c
do k=1,ntrials
ikey = FSTINF(ninmpg(k), INI, INJ, INK, ibrpstamp, cletiket
& ,iip1s_trl(jlev), iip2, iip3,cltypvar,clnomvar)
if(ikey >=0) exit
enddo
c
cprnt write(nulout,*)'varoutY:cppcvar(jvar),ikey',cppcvar(jvar),ikey
if (ikey.lt.0) then
write(nulout,*) 'Problems finding variable '
& ,cppcvar(jvar),' at level ',zlev_trl(jlev)
& ,' in trial file'
call abort3d(nulout,'VAROUT')
endif
c
ikey = VFSTLUK(zhighvar,ikey, INI, INJ, INK)
c
c Sum of increments and trial field
c
do jcol = 1, ini*inj
zvhvar((jlev-1)*ini*inj+jcol) = zhighvar(jcol) +
& zvhvar((jlev-1)*ini*inj+jcol)
enddo
c
enddo
c
do jlev = 1,itrlnlev
c Writing analysis field
c
if(nulstd.ne.0) then
IERR = VFSTECR(zvhvar((jlev-1)*ini*inj+1),zwork
& ,inpak_anl(jvar),nulstd,ibrpstamp,ndeet,npas,ini
& ,inj,1,iip1s_anl(jlev),nip2,niter,cltypanl
& ,clnomvar,cetikinc,clgrtyp,iig1wind,iig2wind
& ,iig3wind,iig4wind,nidatyp,.true.)
endif
enddo
call tmg_stop(5)
endif
c
c ------ End of vertical interpolation ------
c
c 2D variables
elseif(itrlnlev.eq.1) then ! BEGIN 2D FIELDS
c
c Sum of increments and trial field for 2d variables
c
c Looking for corresponding trial field
c
ikey = fstinf(koutmpg, INI, INJ, INK, ibrpstamp,
& cletiket,iip1s_trl(itrlnlev), iip2, iip3,cltypvar
& ,cppcvar(jvar))
c
cprnt write(nulout,*)'varoutX 2d field:cppcvar(jvar),ikey'
cprnt & ,cppcvar(jvar),ikey
if (ikey.lt.0) then
write(nulout,*) 'Problems finding variable ',cppcvar(jvar)
& ,' at level ',zlev_trl(itrlnlev),' in trial file'
call abort3d(nulout,'VAROUT')
endif
c
c
ikey = vfstluk(zvhvar,ikey, INI, INJ, INK)
c
c Sum of increments and trial field
c
if(cppcvar(jvar).eq.'P0') then
llp0 = .true.
do jcol = 1, ini*inj
zhighvar(jcol) = zvhvar(jcol) + zhighvar(jcol)
zpsanl(jcol) = zhighvar(jcol)
enddo
else
do jcol = 1, ini*inj
zhighvar(jcol) = zvhvar(jcol) + zhighvar(jcol)
enddo
endif
c
c Writing analysis field
c
if(nulstd.ne.0) then
IERR = VFSTECR(zhighvar,zwork,inpak_anl(jvar),nulstd
& ,ibrpstamp,ndeet,npas,ini,inj,1,iip1s_anl(itrlnlev)
& ,nip2,niter,cltypanl,cppcvar(jvar),cetikinc,clgrtyp
& ,iig1,iig2,iig3,iig4,nidatyp,.true.)
cprnt write(nulout,*)'varout fstecr anlm:var= ',CPPCVAR(JVAR)
endif
c
endif ! END 3D FIELDS and 2D FIELDS
c
call tmg_start(6,'2D_FIELD_OUT')
if (clgrtyp.eq.'Z') then
c
c ----- Writing positional parameters
c
cletiket = ' '
cltypvar = ' '
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, nulinchr, idateo
& ,ideet,inpas, ini, inj, ink, ip1, ip2, ip3, cltypvar
& ,clnomvar,cletiket,clgrtyp,ig1, ig2, ig3, ig4, idatyp
& ,.true.)
endif
if(nulstd.ne.0) then
ierr = vfstecr(zhighvar, zwork, -inbits, nulstd, idateo
& ,ideet,inpas, ini, inj, ink, ip1, ip2, ip3, cltypvar
& ,clnomvar,cletiket,clgrtyp,ig1, ig2, ig3, ig4, idatyp
& ,.true.)
endif
c
c
cletiket = ' '
cltypvar = ' '
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, nulinchr, idateo
& ,ideet,inpas, ini, inj, ink, ip1, ip2, ip3, cltypvar
& ,clnomvar,cletiket,clgrtyp,ig1, ig2, ig3, ig4, idatyp
& ,.true.)
endif
c
if(nulstd.ne.0) then
ierr = vfstecr(zhighvar, zwork, -inbits, nulstd, idateo
& ,ideet,inpas, ini, inj, ink, ip1, ip2, ip3, cltypvar
& ,clnomvar,cletiket,clgrtyp,ig1, ig2, ig3, ig4, idatyp
& ,.true.)
endif
c
c
if(cppcvar(jvar).eq.'VV'.or.cppcvar(jvar).eq.'UU') then
c
cletiket = ' '
cltypvar = ' '
ikey = FSTINF(koutmpg, iNI, iNJ, iNK, -1,cletiket,
& iig1wind,iig2wind,iig3wind,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,nulinchr,idateo
& ,ideet,inpas, ini, inj, ink, ip1, ip2, ip3
& ,cltypvar,clnomvar,cletiket,clgrtyp,ig1, ig2, ig3
& ,ig4,idatyp,.true.)
endif
if(nulstd.ne.0) then
ierr = vfstecr(zhighvar, zwork, -inbits, nulstd, idateo
& ,ideet,inpas, ini, inj, ink, ip1, ip2, ip3,cltypvar
& ,clnomvar,cletiket,clgrtyp,ig1, ig2, ig3, ig4
& ,idatyp,.true.)
endif
c
c
cletiket = ' '
cltypvar = ' '
ikey = FSTINF(koutmpg, iNI, iNJ, iNK, -1,cletiket,
& iig1wind,iig2wind,iig3wind,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,nulinchr,idateo
& ,ideet,inpas, ini, inj, ink, ip1, ip2, ip3
& ,cltypvar,clnomvar,cletiket,clgrtyp,ig1, ig2, ig3
& ,ig4,idatyp,.true.)
endif
if(nulstd.ne.0) then
ierr = vfstecr(zhighvar, zwork, -inbits, nulstd, idateo
& ,ideet,inpas, ini, inj, ink, ip1, ip2, ip3,cltypvar
& ,clnomvar,cletiket,clgrtyp,ig1, ig2, ig3, ig4
& ,idatyp,.true.)
endif
endif
endif
call tmg_stop(6)
endif
c
200 enddo
c
c* 9. Deallocation of local arrays (Abort on error)
c . ---------------------------------------------
c
call hpdeallc(pzhighvar,ierr,1)
call hpdeallc(pzhighwind,ierr,1)
call hpdeallc(pxpresanl,ierr,1)
call hpdeallc(pxprofi,ierr,1)
call hpdeallc(pxprofo,ierr,1)
call hpdeallc(pxprestrl,ierr,1)
call hpdeallc(pxvhvar,ierr,1)
call hpdeallc(pxttvar,ierr,1)
call hpdeallc(pxtrlq,ierr,1)
call hpdeallc(pxincq,ierr,1)
call hpdeallc(pxanlq,ierr,1)
call hpdeallc(pxvtvar,ierr,1)
call hpdeallc(pxwrkvec,ierr,1)
call hpdeallc(pxesvar,ierr,1)
call hpdeallc(pxgzvar,ierr,1)
call hpdeallc(pxpsanl,ierr,1)
call hpdeallc(pxpstrl,ierr,1)
call hpdeallc(pzlowvar,ierr,1)
call hpdeallc(pxtopo,ierr,1)
call hpdeallc(pzlowwind,ierr,1)
call hpdeallc(pxps,ierr,1)
call hpdeallc(pxptop,ierr,1)
deallocate(inpak_anl)
c
write(nulout,*) 'END of VAROUT'
c
RETURN
END