SUBROUTINE ch_writeunobs(zvar,kini, klev, kinj, ntotvar) 1,18
use mod4dv, only : l4dvar
#if defined (DOC)
*
***s/r ch_writeunobs - output fields related to unobserved species (and their
* . total column amount) into RPN file
*
*Author : Y.Yang June 2005 based on S. Pellerin's code varout
*
*Revision:
*
* Y.Yang ARQI/MSC
* - made corresponding changes as Yves R. did for ch_varout.
* - special ip3 value (ip3_tc=99) for total column variables in
* RPN file
* - If the unobserved variables are output into separate RPN files,
* write positional parameters into those files
* Y.Yang ARQI April 2006
* - incorprated C. Charette's corresponding changes in ch_varout for
* 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
*Arguments
*
* zvar -- variable array to be put into RPN file
* kini -- longitude dimension of the variable
* kinj -- latiude dimension of the variable
* klev -- vertical dimension of the variable
* ntotvar -- total number of variable to write
#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"
#include "comsplit.cdk"
#include "comdimo.cdk"
#include "commvohr.cdk"
*
integer ntotvar, klev, kini, kinj
real*8 zvar(kini, kinj, klev, ntotvar)
integer vfstluk,write_encode_hyb
integer jvar, jcol, ip1_all
integer jlev,inbrlev,imode,inbitstr,ilimlvhu
real*8 zlowvar
character*4 cnomvar
real z4lev_trl(jpnflev)
C
#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,igdgid,ezqkdef,ezsetopt,ezdefset,iip3
integer iig1,iig2,iig3,iig4,ezgprm,ikey,vezsint
integer ikind,iset,ibrpstamp
integer inpak_gz,inpak_vt,inpak_inc
integer, allocatable, dimension(:) :: inpak_anl
integer ii,jj,ji
real*8 zh(jpnflev),zhp(jpnflev)
real*8 zhighvar(1),zwork,zpstrl(1),zpsanl(1),zpttrl(1)
real*8 zpresanl(1)
real*8 zprofi(1),zprofo(1),zvhvar(1),zvtvar(1)
real*8 zvhvar2d(1),ztrial(1)
real*8 zlev_int(jpnflev),zlev_anl(jpnflev),zlev_trl(jpnflev)
real*8 zlev_inclr(jpnflev),zpress(jpnflev),zet
real*8 zps(1),zptop,zttvar(1),zwrkvec(1),zprestrl(1),zgzvar(1)
real*8 ztrlq(1),zincq(1),ztopo,zanlq(1),zgzvar2(1)
real zptop4, zpref4,zrcoef4,zdummy
real*8 zptophr, zprefhr,zrcoefhr
character*1 clstring
character*2 cltypinc,cltypanl
character*4 cnametc
pointer (pzhighvar,zhighvar)
pointer (pzlowvar,zlowvar(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 (pxvhvar2d,zvhvar2d), (pxztrial, ztrial)
pointer (pxvtvar,zvtvar),(pxttvar,zttvar),(pxwrkvec,zwrkvec)
pointer (pxgzvar,zgzvar),(pxtopo,ztopo),(pxtrlq,ztrlq)
pointer (pxincq, zincq)
pointer (pxanlq,zanlq),(pxgzvar2,zgzvar2),(pxpsanl,zpsanl)
LOGICAL llimplemented,llbasevar,llvarout,llclip,llp0
data cltypinc,cltypanl /'R','A'/
data llclip,llp0 /.true.,.false./
c
real*8 ZHUMIN(JPNFLEV)
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
REAL*8 CONV
c
INTEGER ITOT,LL
REAL*8 ZSTATE(1)
pointer (pxzstate, ZSTATE)
c
INTEGER ISCREEN, ip3_tc
CHARACTER*12 cletiket_tc, cletiket_un
logical lnewfile
logical lnowrite_anal
integer idate2,idate3,idatefull
integer newdate, ier, ihrinc
real*8 zcoef
integer koutmpg
c---------------------------------------------------------------------
WRITE(NULOUT,FMT='(/,4X,"Starting ch_writeunobs",//)')
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
conv=1.E5 ! m to 1e-5m (=1DU)
zcoef = 0.5D0
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 if lnowrite_anal=.false, anal of unobserved variables are written to RPN file
c
lnowrite_anal=.false.
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
if(nconf .eq. 888)then
rptophr = zptophr*rmbtpa
rprefhr = zprefhr*rmbtpa
rcoefhr= zrcoefhr
endif
write(nulout,*) 'ch_writeunobs:zptop4,zpref4,zrcoef4 '
& ,zptophr,zprefhr,zrcoefhr
C ****************************************************************
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
if (nconf .eq. 888) ibrpstamp = -1
call getfldprm2(IIP1S_TRL,IIP2,IIP3,ITRLNLEV,CLETIKET,CLTYPVAR
& ,IP0GID,clnomvar,ibrpstamp,jpnflev,ninmpg
& ,nulout,ip1_pak_trl,ip1_vco_trl,ntrials,koutmpg)
c
if (nconf .eq. 888) ibrpstamp = -1
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_WRITEUNOBS')
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 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(ntotvar))
c
inpak_inc = -16
write(nulout,*)'npakanl = ', npakanl
if(npakanl .ne. -999 .and. (nconf .ne. 888)) then
do jvar = 1, ntotvar
inpak_anl(jvar)= npakanl
enddo
else
do jvar = 1, ntotvar
ikey = FSTINF(koutmpg, INI, INJ, INK, ibrpstamp, cletiket,
& -1, -1, -1,cltypvar,cvaranal(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,ntotvar
write(nulout,*) 'PACKING for unobserved var ',cvarunobs(jvar),' is '
& ,inpak_anl(jvar)
enddo
write(nulout,*) 'PACKING for increments is ',inpak_inc
write(nulout,*)' '
write(nulout,*)'************************************** '
c
do jvar = 1, ntotvar
c
c Those variables will be interpolated vertically as long as
c corresponding fields are present in the trial file.
c
llbasevar = .true.
c
c Some variable may be request for other to be computed but not
c necessaraly wanted as output.. but for species we are outputing
C each one in the list
c
llvarout = .true.
c
llimplemented = .true.
c
C Fields associated with model variables
C
call getfldprm(IIP1S_TRL,IIP2,IIP3,ITRLNLEV,CLETIKET,CLTYPVAR
& ,ITRLGID,cvaranal(jvar),ibrpstamp,jpnflev,koutmpg
& ,nulout,ip1_pak_trl,ip1_vco_trl)
ier = newdate(ibrpstamp,idate2,idate3,-3)
idatefull = idate2*100 + idate3/1000000
write(nulout,*)'obs. date = ' , idatefull
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 Do setup to properly interpolate the updated increments to
C the model levels and model high resolution grid and to encode
C IP1 on unit nulinchr_unobs (increments) and on unit nulstd_unobs (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= ',cvaranal(jvar)
& ,' Type= ',ip1_vco_trl
call abort3d(nulout,'CH_WRITEUNOBS')
endif
c
c fill in vhybhr for use in vertical integration since sugomobs is skipped
C when nconf = 888
c
if (NCONF .eq. 888) then
call hpalloc(ptvhybhr,itrlnlev,ier,8)
do jlev = 1,itrlnlev
vhybhr(jlev) = zlev_int(jlev)
enddo
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
c Do setup and write the updated increments on the unit
C nulinclr_unobs (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
c Get the jvar'th variable into zlowvar
C
zlowvar(:,:,:)=zvar(:,:,:,jvar)
C
100 continue
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 Vertical interpolation to trial levels
c
call hpalloc(pxpresanl,ini*inj*nflev,ierr,8)
call hpalloc(pxps,ini*inj,ierr,8)
call hpalloc(pxprofi,ini*inj*nflev,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(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
if (ibrpstamp .eq. -1) then
c
c get the new date
c
cletiket=''
clgrtyp=''
cltypvar=''
cnomvar='P0'
idateo=-1
ideet = -1
inpas = -1
ikey = FSTINF(koutmpg, INI, INJ, INK, ibrpstamp , cletiket,
& -1,-1,-1 ,cltypvar,cnomvar)
ierr = fstprm(ikey,idateo,ideet,inpas,ini,inj,ink, inbits,
& idatyp,ip1,ip2,ip3,cltypvar,cnomvar,cletiket,clgrtyp
& ,ig1,ig2,ig3,ig4,iswa,ilength,idltf,iubc,iextr1
& ,iextr2,iextr3)
ier = newdate(idateo,idate2,idate3,-3)
idatefull = idate2*100 + idate3/1000000
c
c Calculate a new valid date
c
ihrinc=ideet*inpas/3600
call incdat(ibrpstamp, idateo, ihrinc)
ier = newdate(ibrpstamp,idate2,idate3,-3)
idatefull = idate2*100 + idate3/1000000
ndeet=0
npas=0
ibrpstamp=idateo
endif
do jlev = 1,itrlnlev
c
c Look for corresponding trial field
c
ccc ikey = FSTINF(ninmpg_unobs, INI, INJ, INK, ibrpstamp, cletiket,
ccc & iip1s_trl(jlev), iip2, iip3,cltypvar,cvarunobs(jvar))
c
c initialize the cletiket in case the unobs is from another experiment
c
cletiket=''
iip2=-1
iip3=-1
ibrpstamp= -1
c
c use ip1_all(z4lev_trl(jlev),ip1_vco_trl) sometimes encounters problem due to insufficient accuracy
c in decoding the vertical levels, so use iip1s_trl(jlev) instead
c
ikey = FSTINF(ninmpg_unobs, INI, INJ, INK, ibrpstamp, cletiket,
& ip1_all(z4lev_trl(jlev),ip1_vco_trl), iip2, iip3
& ,cltypvar,cvarunobs(jvar))
c
c ikey = FSTINF(ninmpg_unobs, INI, INJ, INK, ibrpstamp, cletiket,
c & iip1s_trl(jlev), iip2, iip3
c & ,cltypvar,cvarunobs(jvar))
c
c get fld info
c
ierr = fstprm(ikey,idateo,ideet,inpas,ini,inj,ink, inbits,
& idatyp,ip1,ip2,ip3,cltypvar,cnomvar,cletiket,clgrtyp
& ,ig1,ig2,ig3,ig4,iswa,ilength,idltf,iubc,iextr1
& ,iextr2,iextr3)
ibrpstamp = idateo
c
c read again with the right time stamp
c
cc ikey = FSTINF(ninmpg_unobs, INI, INJ, INK, ibrpstamp, cletiket,
cc & ip1_all(z4lev_trl(jlev),ip1_vco_trl), iip2, iip3
cc & ,cltypvar,cvarunobs(jvar))
if (ikey.lt.0 .or. ibrpstamp .eq. -1) then
write(nulout,*) 'Problems finding variable '
& ,cvarunobs(jvar),' at level ',z4lev_trl(jlev)
& ,' in trial file ', ninmpg_unobs, ' ibrpstamp= ' , ibrpstamp
write(nulout,*) ' trial field will not be added to increment'
write(nulout,*) 'Or when ibrpstamp .eq. -1, check trlm to get the right date'
c
c Check what's in the trial field file of unobserved and get some parameters
c
c ibrpstamp= -1
clgrtyp=''
cltypvar=''
c cnomvar=''
cnomvar=cvarunobs(jvar)
ikey = FSTINF(ninmpg_unobs, INI, INJ, INK, ibrpstamp , cletiket,
& -1,-1,-1 ,cltypvar,cnomvar)
idateo=-1
ideet = -1
c cnomvar=''
ierr = fstprm(ikey,idateo,ideet,inpas,ini,inj,ink, inbits,
& idatyp,ip1,ip2,ip3,cltypvar,cnomvar,cletiket,clgrtyp
& ,ig1,ig2,ig3,ig4,iswa,ilength,idltf,iubc,iextr1
& ,iextr2,iextr3)
ier = newdate(idateo,idate2,idate3,-3)
idatefull = idate2*100 + idate3/1000000
c write(nulout,*) 'after fstprm, from trial of unobserved, idateo = ' , idateo, 'idatefull = ' , idatefull
c write(nulout,*) 'ikey = ', ikey, ' var = ' ,cnomvar
c checking the trial field of observed variables for parameters
c
ibrpstamp= -1
cletiket=''
clgrtyp=''
cltypvar=''
cnomvar='TT'
idateo=-1
ideet = -1
inpas = -1
ikey = FSTINF(koutmpg, INI, INJ, INK, ibrpstamp , cletiket,
& -1,-1,-1 ,cltypvar,cnomvar)
ierr = fstprm(ikey,idateo,ideet,inpas,ini,inj,ink, inbits,
& idatyp,ip1,ip2,ip3,cltypvar,cnomvar,cletiket,clgrtyp
& ,ig1,ig2,ig3,ig4,iswa,ilength,idltf,iubc,iextr1
& ,iextr2,iextr3)
ndeet=0
npas=0
ibrpstamp= idateo
c
do jcol = 1, ini*inj
zvhvar((jlev-1)*ini*inj+jcol) = zhighvar((jlev-1)*ini*inj+jcol)
ztrial((jlev-1)*ini*inj+jcol) = 0.0
enddo
c
c Will not write anal for unobserved if trlm not present
c
if (ikey.lt.0) lnowrite_anal=.true.
write(nulout,*) 'lnowrite_anal = ', lnowrite_anal
else
ikey = VFSTLUK(zvhvar2d,ikey, INI, INJ, INK)
c get some parameters for trlm of unobserved
c
idateo=-1
ideet = -1
cnomvar=''
ierr = fstprm(ikey,idateo,ideet,inpas,ini,inj,ink, inbits,
& idatyp,ip1,ip2,ip3,cltypvar,cnomvar,cletiket,clgrtyp
& ,ig1,ig2,ig3,ig4,iswa,ilength,idltf,iubc,iextr1
& ,iextr2,iextr3)
cletiket_un=cletiket
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,cvarunobs(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
c put absolute minimum value on O3
c
ISCREEN=1
if (cvarunobs(jvar) .eq. 'TT') ISCREEN=0
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,cvarunobs(jvar))
c
endif
c
enddo !(jlev)
c
c
c write low resolution residuals to rpn standard file.
c
ip1 = -1
jlev = 1
cnomvar=cvarunobs(jvar)
c
c instead use the same etiket from trial field
c
c cletiket_un='UOBS'//trim(cvarunobs(jvar))//trim(cvaranal(jvar))
c
do while (jlev.le.nflev.and.ip1.ne.0 )
iip1s_inclr(jlev) = NIP1(jlev)
if(nulinclr_unobs.ne.0.and.llvarout) then
IERR = VFSTECR(ZLOWVAR(1,1,jlev),zwork,inpak_inc
& ,nulinclr_unobs,ibrpstamp,ndeet,npas,ni,nj,1,iip1s_inclr(jlev)
& ,nip2,niter,cltypinc,cnomvar,cletiket_un,cgrtyp,nig1
& ,nig2,nig3,nig4,nidatyp,.true.)
endif
c
jlev = jlev + 1
c
enddo ! enddo while
c
c Writing analysis field
c
if(nulstd_unobs.ne.0.and.llvarout.and. (.not. lnowrite_anal)) then
do jlev = 1,itrlnlev
IERR = VFSTECR(zvhvar((jlev-1)*ini*inj+1),zwork
& ,inpak_anl(jvar),nulstd_unobs,ibrpstamp,ndeet,npas,ini
& ,inj,1,iip1s_anl(jlev),nip2,niter,cltypanl
& ,cnomvar,cletiket_un,clgrtyp,iig1,iig2,iig3
& ,iig4,nidatyp,.false.)
end do
endif
c
c Writing high resolution increment field
c
if(nulinchr_unobs.ne.0.and.llvarout) then
do jlev = 1,itrlnlev
IERR = VFSTECR(zhighvar((jlev-1)*ini*inj+1),zwork
& ,inpak_inc,nulinchr_unobs,ibrpstamp,ndeet,npas
& ,ini,inj,1,iip1s_anl(jlev),nip2,niter,cltypinc
& ,cnomvar,cletiket_un,clgrtyp,iig1,iig2,iig3
& ,iig4,nidatyp,.true.)
end do
endif
c
c Calculate total column amount and store into increment and analysis files
C
C Vertical integration
C
c if trial field present, use total column anal - total column trial to calcuate
C total column increments
C
if (.not. lnowrite_anal) then
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)
C
C Background profile that is not used
C
zstate(jlev)= 0.0
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 Latitude value that is not used when ignoper = 0
C
PTOP = 0.0
PBTM = rcpps
ifirst=1
C
CALL CH_VERTINTG(workoz, ptop, pbtm,
1 zpress, itrlnlev, ifirst, zstate,
1 nulout,cvarunobs(jvar),itot,zh,zhp)
ztottrial(jcol) = dot_product(workoz(1:itrlnlev),
1 zh(1:itrlnlev))
C
C Analysis field
C
do jlev = 1,itrlnlev
workoz(jlev)= zvhvar((jlev-1)*ini*inj+jcol)
enddo
C
C this time the ifirst is set to 0 to avoid redundant calculations
C
ifirst=0
CALL CH_VERTINTG(workoz, ptop, pbtm,
1 zpress, itrlnlev, ifirst, zstate,
1 nulout,cvarunobs(jvar),itot,zh,zhp)
ztotanal(jcol) = dot_product(workoz(1:itrlnlev),
1 zh(1:itrlnlev))
C
enddo
C
C Multiply by a coefficient to transfer ppv integrated to DU
C
if (cvarunobs(jvar)(1:2).eq.'OZ' .or.
& cvarunobs(jvar)(1:2).eq.'O3') then
coeftotcolm = 1.0/rg/rho_stp*conv
else
coeftotcolm = rav/rmd/rg
end if
C
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
else !(if ( lnowrite_anal))
do jcol = 1, ini*inj
rcpps = zpstrl(jcol)*100.0
C
C Incremental field
C
do jlev = 1,itrlnlev
workoz(jlev)= zhighvar((jlev-1)*ini*inj+jcol)
C
C Background profile that is not used
C
zstate(jlev)= 0.0
enddo
C
C Latitude value that is not used when ignoper = 0
C
PTOP = 0.0
PBTM = rcpps
ifirst=1
C
CALL CH_VERTINTG(workoz, ptop, pbtm,
1 zpress, itrlnlev, ifirst, zstate,
1 nulout,cvarunobs(jvar),itot,zh,zhp)
ztotinc(jcol) = dot_product(workoz(1:itrlnlev),
1 zh(1:itrlnlev))
C
enddo
C
C Multiply by a coefficient to transfer ppv integrated to DU
C
if (cvarunobs(jvar)(1:2).eq.'OZ' .or.
& cvarunobs(jvar)(1:2).eq.'O3') then
coeftotcolm = 1.0/rg/rho_stp*conv
else
coeftotcolm = rav/rmd/rg
end if
C
do jcol = 1, ini*inj
ztotinc(jcol) = ztotinc(jcol) *coeftotcolm
enddo
C
endif !(if (.not. lnowrite_anal) )
c
if (jvar.lt.10) then
write(cnametc,'(A3,I1)') 'TU0',jvar
else
write(cnametc,'(A2,I2)') 'TU',jvar
end if
cletiket_tc='UOBS'//trim(cvarunobs(jvar))//trim(cvaranal(jvar))
ip3_tc=99
C
C Write total column amount into analysis file
C
if (.not. lnowrite_anal) then
IERR = VFSTECR(ztotanal,zwork,inpak_anl(jvar),nulstd_unobs
& ,ibrpstamp,ndeet,npas,ini,inj,1,iip1s_anl(itrlnlev)
& ,nip2,ip3_tc,cltypanl,cnametc,cletiket_tc,clgrtyp
& ,iig1,iig2,iig3,iig4,nidatyp,.false.)
endif
C
C Write low-resolution total column increment
C
IERR = VFSTECR(ztotinc,zwork
& ,inpak_inc,nulinclr_unobs,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 high-resolution total column increment
C
IERR = VFSTECR(ztotinc,zwork
& ,inpak_inc,nulinchr_unobs,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(pxprestrl,ierr,1)
call hpdeallc(pxpresanl,ierr,1)
call hpdeallc(pxprofi,ierr,1)
call hpdeallc(pxprofo,ierr,1)
call hpdeallc(pxvhvar,ierr,1)
call hpdeallc(pxps,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,cvarunobs(jvar))
ikey = fstinf(koutmpg, INI, INJ, INK, ibrpstamp, cletiket,
& ip1_all(z4lev_trl(itrlnlev),ip1_vco_trl), iip2, iip3
& ,cltypvar,cvarunobs(jvar))
c
if (ikey.lt.0) then
write(nulout,*) 'Problems finding variable ',cvarunobs(jvar)
& ,' at level ',z4lev_trl(itrlnlev),' in trial file'
go to 999
endif
c
call hpalloc(pxvhvar,ini*inj,ierr,8)
c
ikey = vfstluk(zvhvar,ikey, INI, INJ, INK)
c
c Sum of increments and trial field
c
do jcol = 1, ini*inj
zhighvar(jcol) = zvhvar(jcol) + zhighvar(jcol)
enddo
cnomvar = cvarunobs(jvar)
c
c Writing analysis field
c
if(nulstd_unobs.ne.0) then
IERR = VFSTECR(zhighvar,zwork,inpak_anl(jvar),nulstd_unobs
& ,ibrpstamp,ndeet,npas,ini,inj,1,iip1s_anl(itrlnlev)
& ,nip2,niter,cltypanl,cnomvar,cletiket_un,clgrtyp
& ,iig1,iig2,iig3,iig4,nidatyp,.false.)
endif
c
call hpdeallc(pxvhvar,ierr,1)
999 continue
endif ! END 3D FIELDS and 2D FIELDS
c
if(itrlnlev.ne.0) then
call hpdeallc(pzhighvar,ierr,1)
endif
c
c If unobserved varables are written into new files, need to store the
C positional parameters as well
c
lnewfile= (nulinchr .ne. nulinchr_unobs) .or. (nulinclr.ne. nulinclr_unobs)
& .or. (nulstd .ne. nulstd_unobs)
if (clgrtyp.eq.'Z' .and. lnewfile) 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 .and. (nulinchr .ne. nulinchr_unobs)) then
ierr = vfstecr(zhighvar, zwork, -inbits, nulinchr_unobs, 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 .and.(nulinclr.ne. nulinclr_unobs) ) then
ierr = vfstecr(zhighvar, zwork, -inbits, nulinclr_unobs, 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 .and. (nulstd .ne. nulstd_unobs)) then
write(nulout, *)' in ch_varout, var >> write to anal, var = ',clnomvar
ierr = vfstecr(zhighvar, zwork, -inbits, nulstd_unobs, 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 .and. (nulinchr .ne. nulinchr_unobs)) then
ierr = vfstecr(zhighvar, zwork, -inbits, nulinchr_unobs, 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.and. (nulinclr .ne. nulinclr_unobs)) then
ierr = vfstecr(zhighvar, zwork, -inbits, nulinclr_unobs, 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.and. (nulstd .ne. nulstd_unobs)) then
write(nulout, *)' in ch_varout, ^^ write to anal, var = ',clnomvar
ierr = vfstecr(zhighvar, zwork, -inbits, nulstd_unobs, 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')
200 enddo !(jvar)
C
c* Deallocation of local arrays (Abort on error)
c ---------------------------------------------
c
deallocate(inpak_anl)
call hpdeallc(pzlowvar,ierr,1)
if(ierr.ne.0)then
call abort3d(nulout,'WRITEUNOBS. Problem with ZLOWVAR.')
END IF
c
call hpdeallc(pxpstrl,ierr,1)
if (llp0) call hpdeallc(pxpsanl,ierr,1)
c
c close the files
c
ierr=fstfrm(nulinclr_unobs)
ierr=fstfrm(nulinchr_unobs)
ierr=fstfrm(nulstd_unobs)
ierr=fclos(nulinclr_unobs)
ierr=fclos(nulinchr_unobs)
ierr=fclos(nulstd_unobs)
write(nulout,*) 'END of WRITEUNOB'
c
RETURN
END