SUBROUTINE ch_varout 1,21
use mod4dv, only : l4dvar
#if defined (DOC)
*
***s/r ch_varout - output fields related to chemical species (including
* total column amount) into RPN file
*
*Author : Y.Yang Dec. 2004. Based on S. Pellerin's code varout
* - Added total column amount calculation and writing into
* analysis and increment files
*
*Revisions:
* Yves J. Rochon, ARQX/MSC July 2005
* - Cleanup
* - Identification and removal of exceedingly small
* analysis values and corresponding adjustment of
* rehm increments (rebm increments untouched).
* See module ch_add.
* - Total column amounts in molecules/m^2 for species other than
* ozone.
* Y. Yang ARQI Feb. 2006
* - Added 'O3' in the testing for 'OZ' for total column amounts
* Y. Yang, Feb 2005
* - Added call to 'ch_splitting'.
* - Special ip3 value (ip3_tc=99) for total column variables in
* RPN file
* - Output total column increment into both high- and low- resolution
* increment files
* - Output positonal parameters into low- as well as high- resolution
* increment files
*
* C. Charette - ARMA/SMC - Apr. 2006
* - Use of fst function IP1_ALL to read trial field levels
* Y. Yang ARQ July 2010
* - use of getfldprm2 following later official version varout to deal with
* multiple trial field
*
*Revision:
*
*Arguments
*
*
*Comments:
*
* 1. No vertical interpolation performed.
* Currently assumes that trial levels are same as analysis levels.
* To implement vertical interpolation, see VAROUT routine.
*
#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 "comnumbr.cdk"
#include "cvcord.cdk"
#include "rpnstd.cdk"
#include "comgdpar.cdk"
#include "comcst.cdk"
#include "cominterp.cdk"
#include "comct0.cdk"
#include "comfilt.cdk"
#include "namfilt.cdk"
#include "comchem.cdk"
#include "cparbrp.cdk"
#include "comstate.cdk"
*
integer vfstluk,write_encode_hyb,ip1_all
integer jvar, jcol
integer jlev,inbrlev,imode,inbitstr
C
#include "localpost.cdk"
C
integer itrlgid,ip0gid,iip1s(jpnflev),iip1,iip2,iip3
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,igdgid,ezqkdef,ezsetopt,ezdefset
integer iig1,iig2,iig3,iig4,ezgprm,ikey
integer ikind,iset,ibrpstamp
integer inpak_inc
integer, allocatable, dimension(:) :: inpak_anl
c
real z4lev_trl(jpnflev)
real*8 zlev_int(jpnflev),zlev_anl(jpnflev),zlev_trl(jpnflev)
real*8 zlev_inclr(jpnflev),zwork
real*8 zh(jpnflev),zhp(jpnflev)
real zptop4, zpref4,zrcoef4
real*8 zptophr, zprefhr,zrcoefhr,zpress(jpnflev),zet
character*1 clstring
character*2 cltypinc,cltypanl
character*4 cnametc
c
integer koutmpg
c
real*8 zhighvar(1),zpstrl(1),zpsanl(1)
real*8 zvhvar(1),zvhvar2d(1),ztrial(1),zlowvar
pointer (pzhighvar,zhighvar)
pointer (pzlowvar,zlowvar(ni,nj,nflev))
pointer (pxpstrl,zpstrl)
pointer (pxvhvar,zvhvar)
pointer (pxvhvar2d,zvhvar2d), (pxztrial, ztrial)
pointer (pxpsanl,zpsanl)
c
LOGICAL llimplemented,llbasevar,llvarout
data cltypinc,cltypanl /'R','A'/
c
real*8 PTOP, PBTM, rcpps
real*8 workoz(1)
real*8 ztottrial(1), ztotanal(1), ztotinc(1), ztotoz
real*8 coeftotcolm
pointer (pxworkoz, workoz), (pxztottrial, ztottrial)
pointer (pxztotanal, ztotanal), (pxztotinc, ztotinc)
INTEGER IFIRST,ITOT
REAL*8 CONV,ZSTATE(1)
pointer (pxzstate, ZSTATE)
c
INTEGER VFSTECR
EXTERNAL VFSTECR
c
INTEGER ISCREEN, ip3_tc
CHARACTER*12 cletiket_tc
real*8 zcoef
c
c---------------------------------------------------------------------
WRITE(NULOUT,FMT='(/,4X,"Starting CH_VAROUT",//)')
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
conv=1.E5 ! m to 1e-5m (=1DU)
C
C Set analysis/increment screening flag based on form of analysis variable.
C No screening if NLOGTR=1 (analysis variable = log(vmr)).
C Removal of exceedingly small values otherwise (analysi variable=vmr).
C
ISCREEN=2
IF (NLOGTR.EQ.1) ISCREEN=0
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 ****************************************************************
C
C Get P0 from trial fields for vertical interpolation definition
C
write(nulout,*)
& 'Reading P0 and hybrid 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,'CH_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 Analysis grid hybrid vertical coordinate parameters
c
write(nulout,*)' '
write(nulout,*)'************************************** '
write(nulout,*)
& ' The hybrid 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(nppchem))
c
inpak_inc = -16
if(npakanl .ne. -999) then
do jvar = 1, nppchem
inpak_anl(jvar)= npakanl
enddo
else
do jvar = 1, nppchem
ikey = FSTINF(koutmpg, INI, INJ, INK, ibrpstamp, cletiket,
& -1, -1, -1,cltypvar,cppchem(jvar))
if(ikey .ge. 0) then
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)
inpak_anl(jvar) = -inbits
else
inpak_anl(jvar) = -16
endif
enddo
endif
do jvar =1,nppchem
write(nulout,*) 'PACKING for analysed var ',cppchem(jvar),' is '
& ,inpak_anl(jvar)
enddo
write(nulout,*) 'PACKING for increments is ',inpak_inc
write(nulout,*)' '
write(nulout,*)'************************************** '
c
do jvar = 1, nppchem
c
c Initialize logical flags (mostly for consistency with VAROUT)
c
c Variables will be interpolated vertically as long as
c corresponding fields are present in the trial file.
c (Vertical interpolation not implemented in ch_varout)
c
llbasevar = .true.
c
c Some variables may be request for others to be computed but not
c necessarily wanted as output (not active at the moment).
c Output only for species identified as cppchem(jvar).
c
llvarout = .true.
llimplemented = .true.
c
c Fields associated with model variables
c
call getfldprm(IIP1S_TRL,IIP2,IIP3,ITRLNLEV,CLETIKET,CLTYPVAR
& ,ITRLGID,cppchem(jvar),ibrpstamp,jpnflev,koutmpg
& ,nulout,ip1_pak_trl,ip1_vco_trl)
c
c Sort the levels encoded in IIP1S_TRL
c
c Decode the levels
C
imode = -1
ikind = ip1_vco_trl
do jlev = 1,itrlnlev
call VCONVIP( iip1s_trl(jlev), zlev_trl(jlev), ikind, imode,
& clstring,.false. )
enddo
c
call vsort(zlev_trl,itrlnlev)
c
c Encode iip1s_trl to match the sorted zlev_trl
C
imode = ip1_pak_trl
ikind = ip1_vco_trl
do jlev = 1,itrlnlev
z4lev_trl(jlev) = zlev_trl(jlev)
call VCONVIP( iip1s_trl(jlev), zlev_trl(jlev), ikind, imode,
& clstring,.false. )
enddo
c
c Following would be required prior to vertical interpolation.
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
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= ',cppchem(jvar)
& ,' Type= ',ip1_vco_trl
call abort3d(nulout,'CH_VAROUT')
endif
c
c Encode zlev_anl in iip1s_anl
c
imode = ip1_pak_anl
ikind = ip1_vco_anl
do jlev = 1,itrlnlev
call VCONVIP( iip1s_anl(jlev), zlev_anl(jlev), ikind, imode,
& clstring,.false. )
enddo
c
if (itrlnlev.ne.0) then
c
ierr = ezgprm(itrlgid,clgrtyp,ini,inj,iig1,iig2,iig3,iig4)
c
call hpalloc(pzhighvar,ini*inj*nflev,ierr,8)
c
endif
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
c ETA or SIGMA levels were read from namelist
c
ip1_vco_inclr = 1
do jlev = 1,nflev
zlev_inclr(jlev) = vlev(jlev)
enddo
else
c
c HYBRID levels read from namelist
c
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
c
c zcoef is the reference value used in ch_add to avoid very small or
c negative species analysis
c
zcoef = 0.5D0
C
do while (jlev.le.nflev.and.ip1.ne.0 )
c
c Get the variable cppchem(jvar) in zlowvar vector
c
call gdout2(cppchem(jvar),ZLOWVAR(1,1,jlev),ni,nj
& ,jlev,llimplemented,IIP1S_INCLR(jlev))
c
c If variable cppchem is not implemented skip to the next variable
c
if (.not.llimplemented) goto 200
c
c N.B. Low resolution increment field not subject to any
c transformation from CH_TLMTRANS prior to output.
c
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,cppchem(jvar),cetikinc,cgrtyp,nig1
& ,nig2,nig3,nig4,nidatyp,.true.)
endif
c
jlev = jlev + 1
c
enddo ! enddo while
c
100 continue
c
if (itrlnlev.gt.1) then
inbrlev = nflev
else
inbrlev = 1
endif
c
if(itrlnlev.ne.0) then
C
C Interpolate to high resolution
C
call hintscal(zlowvar,ni*nj,igdgid,
& zhighvar,ini*inj,itrlgid,inbrlev,'LINEAR')
c
endif ! (itrlnlev.ne.0)
c
if (itrlnlev.gt.1.and.llbasevar) then ! BEGIN 3D FIELDS
c
c NOTE: Vertical interpolation not done.
c trial levels = analysis levels assumed!!!
c
call hpalloc(pxvhvar,ini*inj*itrlnlev,ierr,8)
call hpalloc(pxvhvar2d,ini*inj,ierr,8)
call hpalloc(pxztrial,ini*inj*itrlnlev,ierr,8)
C
call hpalloc( pxworkoz, itrlnlev, ierr,8)
call hpalloc(pxztottrial, ini*inj, ierr,8)
call hpalloc( pxztotanal, ini*inj, ierr,8)
call hpalloc( pxztotinc, ini*inj, ierr,8)
call hpalloc( pxzstate, itrlnlev, ierr,8)
C
do jlev = 1,itrlnlev
c
c Look for corresponding trial field
c
ccc ikey = FSTINF(koutmpg, INI, INJ, INK, ibrpstamp, cletiket,
ccc & iip1s_trl(jlev), iip2, iip3,cltypvar,cppchem(jvar))
ikey = FSTINF(koutmpg, INI, INJ, INK, ibrpstamp, cletiket,
& ip1_all(z4lev_trl(jlev),ip1_vco_trl), iip2, iip3
& ,cltypvar,cppchem(jvar))
c
if (ikey.lt.0) then
write(nulout,*) 'Problems finding variable '
& ,cppchem(jvar),' at level ',z4lev_trl(jlev)
& ,' in trial file'
call abort3d(nulout,'CH_VAROUT')
endif
c
ikey = VFSTLUK(zvhvar2d,ikey, INI, INJ, INK)
c
c Apply variable transformations for increments according to
c NLOGTR value.
c
if (NLOGTR.GT.0) then
CALL CH_TLMTRANS(zvhvar2d,
& zhighvar((jlev-1)*ini*inj+1:jlev*ini*inj),
& 1.0D0,0.0D0,INI,INJ,NLOGTR,1,cppchem(jvar))
end if
c
c Sum of increments and trial field and store the trial field
c
ztrial((jlev-1)*ini*inj+1:jlev*ini*inj)=zvhvar2d(:)
c
call ch_add(zvhvar((jlev-1)*ini*inj+1:jlev*ini*inj),
& zvhvar2d,
& zhighvar((jlev-1)*ini*inj+1:jlev*ini*inj),
& ini*inj,1,zcoef,ISCREEN,cppchem(jvar))
c
enddo !(jlev)
c
c Writing analysis field and high resolution increment field
c
if(nulstd.ne.0.and.llvarout) then
write(nulout, *)' in ch_varout, in 3D write to anal, var = ',cppchem(jvar)
do jlev = 1,itrlnlev
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
& ,cppchem(jvar),cetikinc,clgrtyp,iig1,iig2,iig3
& ,iig4,nidatyp,.false.)
c
enddo
endif
if(nulinchr.ne.0.and.llvarout) then
do jlev = 1,itrlnlev
IERR = VFSTECR(zhighvar((jlev-1)*ini*inj+1),zwork
& ,inpak_inc,nulinchr,ibrpstamp,ndeet,npas
& ,ini,inj,1,iip1s_anl(jlev),nip2,niter,cltypinc
& ,cppchem(jvar),cetikinc,clgrtyp,iig1,iig2,iig3
& ,iig4,nidatyp,.true.)
end do
endif
c
c Calculate total column amount and store into increment and analysis files
C
do jcol = 1, ini*inj
rcpps = zpstrl(jcol)*100.0
C
C Trial field
C
do jlev = 1,itrlnlev
workoz(jlev)= ztrial((jlev-1)*ini*inj+jcol)
enddo
C
C Calc pressures
C
zet=rptopinc/rprefinc
do jlev=1,itrlnlev
zpress(jlev)=rprefinc*vhybinc(jlev)+(rcpps-rprefinc)
+ *((vhybinc(jlev)-zet)/(1.0-zet))**rcoefinc
end do
C
C Unused background profile.
C
zstate(1:itrlnlev)= 0.0
C
PTOP = 0.0
PBTM = rcpps
ifirst=1
if (cppchem(jvar)(1:3).eq.'AOD') then
ztottrial(jcol)=sum(workoz(1:itrlnlev))
else
CALL CH_VERTINTG(workoz, ptop, pbtm,
1 zpress, itrlnlev, ifirst, zstate,
1 nulout,cppchem(jvar),itot,zh,zhp)
ztottrial(jcol) = dot_product(workoz(1:itrlnlev),
1 zh(1:itrlnlev))
end if
C
C Analysis field
C
do jlev = 1,itrlnlev
workoz(jlev)= zvhvar((jlev-1)*ini*inj+jcol)
enddo
C
C ifirst is set to 0 to avoid redundant calculations
C
ifirst=0
if (cppchem(jvar)(1:3).eq.'AOD') then
ztotanal(jcol)=sum(workoz(1:itrlnlev))
else
CALL CH_VERTINTG(workoz, ptop, pbtm,
1 zpress, itrlnlev, ifirst, zstate,
1 nulout,cppchem(jvar),itot,zh,zhp)
ztotanal(jcol) = dot_product(workoz(1:itrlnlev),
1 zh(1:itrlnlev))
end if
C
enddo
C
C Multiply by a coefficient to convert integral of vmr*dP to DU
C or molecules/m^2
C
if (cppchem(jvar)(1:2).eq.'OZ'.or.
& cppchem(jvar)(1:2).eq.'O3') then
coeftotcolm = 1.0/rg/rho_stp*conv
else if (cppchem(jvar)(1:3).ne.'AOD') then
coeftotcolm = rav/rmd/rg
else
coeftotcolm=1.0D0
end if
C
999 continue
C
write(nulout, *)'coeftotcolm= ' ,coeftotcolm
do jcol = 1, ini*inj
ztotanal(jcol) = ztotanal(jcol) *coeftotcolm
ztottrial(jcol) = ztottrial(jcol) *coeftotcolm
enddo
C
C Calculate increment from the difference between analysis and trial
C
do jcol = 1, ini*inj
ztotinc(jcol) = ztotanal(jcol) - ztottrial(jcol)
enddo
C
if (len_trim(cppchem(jvar)).eq.1) then
write(cnametc,'(A2,A1)') 'TC',trim(cppchem(jvar))
else if (len_trim(cppchem(jvar)).eq.2) then
write(cnametc,'(A2,A2)') 'TC',trim(cppchem(jvar))
else
if (jvar.lt.10) then
write(cnametc,'(A3,I1)') 'TC0',jvar
else
write(cnametc,'(A2,I2)') 'TC',jvar
end if
end if
cletiket_tc='TOTCOLM_'//cppchem(jvar)
ip3_tc=99
C
C Write total column amount into analysis file.
C
IERR = VFSTECR(ztotanal,zwork,inpak_anl(jvar),nulstd
& ,ibrpstamp,ndeet,npas,ini,inj,1,iip1s_anl(itrlnlev)
& ,nip2,ip3_tc,cltypanl,cnametc,cletiket_tc,clgrtyp
& ,iig1,iig2,iig3,iig4,nidatyp,.false.)
C
C Write high-resolution total column increment
C
IERR = VFSTECR(ztotinc,zwork
& ,inpak_inc,nulinchr,ibrpstamp,ndeet,npas
& ,ini,inj,1,iip1s_anl(itrlnlev),nip2,ip3_tc,cltypinc
& ,cnametc,cletiket_tc,clgrtyp,iig1,iig2,iig3
& ,iig4,nidatyp,.false.)
C
C Write low-resolution total column increment
C
IERR = VFSTECR(ztotinc,zwork
& ,inpak_inc,nulinclr,ibrpstamp,ndeet,npas
& ,ini,inj,1,iip1s_anl(itrlnlev),nip2,ip3_tc,cltypinc
& ,cnametc,cletiket_tc,clgrtyp,iig1,iig2,iig3
& ,iig4,nidatyp,.false.)
C
C Deallocate space for total column amount
C
call hpdeallc(pxztotinc,ierr,1)
call hpdeallc(pxztotanal,ierr,1)
call hpdeallc(pxztottrial,ierr,1)
call hpdeallc(pxworkoz,ierr,1)
call hpdeallc(pxzstate,ierr,1)
c
call hpdeallc(pxztrial, ierr,1)
call hpdeallc(pxvhvar2d,ierr,1)
call hpdeallc(pxvhvar,ierr,1)
c
c End of vertical interpolation
c
elseif(itrlnlev.eq.1) then ! BEGIN 2D FIELDS
c
c 2D variables
c
c Sum of increments and trial field for 2d variables
c
c Looking for corresponding trial field
c
ccc ikey = fstinf(koutmpg, INI, INJ, INK, ibrpstamp, cletiket,
ccc & iip1s_trl(itrlnlev), iip2, iip3,cltypvar,cppchem(jvar))
ikey = fstinf(koutmpg, INI, INJ, INK, ibrpstamp, cletiket,
& ip1_all(z4lev_trl(itrlnlev),ip1_vco_trl), iip2, iip3
& ,cltypvar,cppchem(jvar))
c
if (ikey.lt.0) then
write(nulout,*) 'Problems finding variable ',cppchem(jvar)
& ,' at level ',z4lev_trl(itrlnlev),' in trial file'
call abort3d(nulout,'CH_VAROUT')
endif
c
call hpalloc(pxvhvar,ini*inj,ierr,8)
call hpalloc(pxpsanl,ini*inj,ierr,8)
c
ikey = vfstluk(zvhvar,ikey, INI, INJ, INK)
c
c Sum of increments and trial field
c
if(cppchem(jvar).eq.'P0') then
do jcol = 1, ini*inj
zpsanl(jcol) = zvhvar(jcol) + zhighvar(jcol)
enddo
else
call ch_add(zpsanl(1:ini*inj),
& zvhvar2d,zhighvar(1:ini*inj),
& ini*inj,1,zcoef,ISCREEN,cppchem(jvar))
endif
c
c Writing analysis field
c
if(nulstd.ne.0) then
write(nulout, *)' in ch_varout, in 2D write to anal, var = ',cppchem(jvar)
IERR = VFSTECR(zpsanl,zwork,inpak_anl(jvar),nulstd
& ,ibrpstamp,ndeet,npas,ini,inj,1,iip1s_anl(itrlnlev)
& ,nip2,niter,cltypanl,cppchem(jvar),cetikinc,clgrtyp
& ,iig1,iig2,iig3,iig4,nidatyp,.false.)
endif
c
c
c Write high resolution residuals to rpn standard file ...
c
if(nulinchr.ne.0) then
do jlev = 1, inbrlev
IERR = VFSTECR(zhighvar((jlev-1)*ini*inj+1),zwork
& ,inpak_inc,nulinchr,ibrpstamp,ndeet,npas
& ,ini,inj,1,iip1s_anl(jlev),nip2,niter,cltypinc
& ,cppchem(jvar),cetikinc,clgrtyp,iig1,iig2,iig3
& ,iig4,nidatyp,.false.)
enddo
endif
c
call hpdeallc(pxvhvar,ierr,1)
call hpdeallc(pxpsanl,ierr,1)
c
endif ! END 3D FIELDS and 2D FIELDS
c
if(itrlnlev.ne.0) then
call hpdeallc(pzhighvar,ierr,1)
endif
c
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
c if positional parameter does not exist, skip this part
c
if(ikey .lt.0) go to 300
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
call hpalloc(pzhighvar,ini*inj*ink,ierr,8)
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
c write to low-res inc file as well
c
if(nulinclr.ne.0) then
ierr = vfstecr(zhighvar, zwork, -inbits, nulinclr, 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
write(nulout, *)' in ch_varout, var >> write to anal, var = ',clnomvar
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
call hpdeallc(pzhighvar,ierr,1)
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
call hpalloc(pzhighvar,ini*inj*ink,ierr,8)
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
c write to low-res inc file as well
c
if(nulinclr.ne.0) then
ierr = vfstecr(zhighvar, zwork, -inbits, nulinclr, 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
write(nulout, *)' in ch_varout, ^^ write to anal, var = ',clnomvar
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
call hpdeallc(pzhighvar,ierr,1)
c
300 continue
endif !(clgrtyp .eq. 'Z')
c
200 enddo !(jvar)
C
c* Deallocation of local arrays (Abort on error)
c ---------------------------------------------
c
if (lsplit) then
c
c Update the unobserved variables using splitting-analysis scheme
c
write(nulout, *) 'Calling ch_splitting'
call ch_splitting
endif
c
deallocate(inpak_anl)
call hpdeallc(pzlowvar,ierr,1)
if(ierr.ne.0)then
call abort3d(nulout,'CH_VAROUT. Problem with ZLOWVAR.')
END IF
c
call hpdeallc(pxpstrl,ierr,1)
c
write(nulout,*) 'END of CH_VAROUT'
c
RETURN
END