!-------------------------------------- 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 varoutla,90
use mod4dv
, only : l4dvar
#if defined (DOC)
*
***s/r varoutla - Output analysis increments on
* . standard file at analysis and trial resolutions.
* N.B.: correct scaling factors to apply on analysis increments
* coming as input and actually written here come from a call
* to gdout2 which pass the contend of GD0 to a local array and
* apply correct scaling required by RPN standard file.
*
*Author : Luc Fillion - LAM4D output subroutine from varout.ftn from Simon Pellerin.
*Revision:
* Luc Fillion - ARMA/EC - 13 Jan 2009 - Upgrade to v_10_1_2 of 3dvar.
#endif
C
use modfgat, only : nstamplist
IMPLICIT NONE
*implicits
#include "taglam4d.cdk"
#include "pardim.cdk"
#include "comdim.cdk"
#include "comlun.cdk"
#include "comgem.cdk"
#include "compost.cdk"
#include "cvcord.cdk"
#include "rpnstd.cdk"
#include "comgdpar.cdk"
#include "comcst.cdk"
#include "cominterp.cdk"
#include "comct0.cdk"
#include "comfilt.cdk"
#include "comgrd_param.cdk"
#include "comgrd.cdk"
#include "comgemla.cdk"
#include "comcva.cdk"
*
integer vfstluk,write_encode_hyb,fstecr
integer jvar, jcol
integer jlev,inbrlev,imode,inbitstr,ilimlvhu
integer gddst
integer ezgdef_fmem
#include "localpost.cdk"
C
logical llextrap,lldebug,lladjhum
integer idatyp_la,inbits_la
integer itrlgid,ip0gid,igidv_trl,iip1s(jpnflev),iip1,iip2,ji,jj,jk
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 iip2_image,iip3_image
integer iig1,iig2,iig3,iig4,ezgprm,ikey,iwindgid,vezsint
integer iig1V,iig2V,iig3V,iig4V
integer iniwind,injwind,inkwind,iig1wind,iig2wind,iig3wind
integer inidim,injdim
integer iig4wind,ikind,iset,ibrpstamp
integer inig1,inig2,inig3,inig4
integer imagegid,idum,iig1_image,iig2_image,iig3_image,iig4_image
integer inpak_gz,inpak_vt,inpak_inc
integer, allocatable, dimension(:) :: inpak_anl
integer INIX, INJX, INKX
integer iniv,injv,idum1,idum2,idum3,idum4
real*8 zmin,zmax
real*8 zhighvar(1),zwork,zhighwind(1),zpstrl,zpsanl(1),zpttrl(1)
real*8 zainch_U(nit-1,njt,nkt)
real*8 zainch_V(nit,njt-1,nkt)
real*8 zanal_U(nit-1,njt,nkt)
real*8 zanal_V(nit,njt-1,nkt)
real*8 ztrial_U_2d(nit-1,njt)
real*8 ztrial_V_2d(nit,njt-1)
real*8 zvhvarV(nit,njt-1,nkt)
real zanal_U4(nit-1,njt)
real zanal_V4(nit,njt-1)
real zainch_U4(nit-1,njt)
real zainch_V4(nit,njt-1)
real*8 zpresanl(1)
real*8 zprofi(1),zprofo(1),zvhvar(1),zimage(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),zgzvar2(1)
real*8 zptophr, zprefhr,zrcoefhr
!
real zptop4, zpref4,zrcoef4,zdummy
real ax(mni_in),ay(mnj_in)
integer k,koutmpg
!
character*1 clgrtypwind,clgrtyp_image,clstring,cltypinc,cltypanl
character*2 clvar
character*3 clname
character*3 clnomvar_image
character*3 clnomvar_3
pointer (pzhighvar,zhighvar)
pointer (pzhighwind,zhighwind)
real zwork4
real zwkU(mni_in-1,mnj_in,nflev)
real zwkV(mni_in,mnj_in-1,nflev)
real*8 zwkU8(mni_in-1,mnj_in,nflev)
real*8 zwkV8(mni_in,mnj_in-1,nflev)
real*8 zlowvar(mni_in,mnj_in,nflev)
real*8 zlowwind(mni_in,mnj_in,nflev)
pointer (pxpstrl,zpstrl),(pxpttrl,zpttrl),(pxpresanl,zpresanl)
pointer (pxprestrl,zprestrl),(pxprofi,zprofi),(pxprofo,zprofo)
pointer (pximage,zimage)
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),(pxgzvar2,zgzvar2),(pxpsanl,zpsanl)
LOGICAL llimplemented,llwind,llhigh,llvarout,llclip,llp0
logical llgettrl
logical :: llvint
data cltypinc,cltypanl /'R','A'/
data llclip,llp0 /.true.,.false./
c
real*8 ZHUMIN(JPNFLEV)
!
!!
WRITE(NULOUT,FMT='(/,4X,"Starting VAROUTLA",//)')
llvint = .false.
lldebug = .false.
lladjhum = .false. ! cluc
if(lsw) lladjhum = .false.
if(l1obs) lladjhum = .false.
!
! set some parameters needed for Mesovar use of 'EZ' subs. for interpolation (e.g. hintscal.ftn)
! and for writing fields on RPN files so as to ensure fields outside LAM once interpolated to trial are really zero.
!
if(grd_typ.eq.'LU') then
llextrap = .true.
else
llextrap = .false.
endif
!
idatyp_la = 5 ! can be used for other grd_typ also
inbits_la = -32 ! can be used for other grd_typ also
!
!*1 SET DIAGNOSTIC VARIABLES ON IF FIRST VAR IS PP (for GENINCR branch)
! *******************************************************************
!
IF(CPPCVAR(1).EQ.'PP') LVARDIAG=.TRUE.
c
if(l4dvar) then
ibrpstamp=nstamplist(1)
else
ibrpstamp=nbrpstamp
endif
!
!*2 Grid properties
! ***************
!
if(Grd_typ.ne.'LU') then
igdgid = ezqkdef(mni_in, mnj_in, 'G', 0,0,0,0,0)
else
do ji=1,mni_in
ax(ji)=grd_x_8(ji)
enddo
do jj=1,mnj_in
ay(jj)=grd_y_8(jj)
enddo
!
ngid_in= ezgdef_fmem(mni_in,mnj_in,'Z','E',mig1tic, mig2tic,mig3tic,mig4tic,
& ax,ay) ! tic tac same as extended grid
igdgid = ngid_in
ngidu_in= ezgdef_fmem(mni_in-1,mnj_in,'Z','E',mig1tic, mig2tic,mig3tic,mig4tic,
& ax,ay) ! tic tac same as extended grid
ngidv_in= ezgdef_fmem(mni_in,mnj_in-1,'Z','E',mig1tic, mig2tic,mig3tic,mig4tic,
& ax,ay) ! tic tac same as extended grid
!
! Writing positional parameters for low-resolution analysis increments scalar grid
!
! Write >>:
cltypvar = 'X'
clnomvar = '>>'
clgrtyp = 'E'
ierr = vfstecr(grd_x_8,zwork,-inbits,nulinclr,ibrpstamp,
& ideet,inpas,mni_in,1,1,mig1in,mig2in,mig3in,cltypvar
& ,clnomvar,cetikinc,clgrtyp,mig1tic,mig2tic,mig3tic,mig4tic
& ,ndtinc,.true.)
!
! Write ^^
cltypvar = 'X'
clnomvar = '^^'
clgrtyp = 'E'
ierr = vfstecr(grd_y_8,zwork,-inbits,nulinclr,ibrpstamp,
& ideet,inpas,1,mnj_in,1,mig1in,mig2in,mig3in,cltypvar
& ,clnomvar,cetikinc,clgrtyp,mig1tic,mig2tic,mig3tic,mig4tic
& ,ndtinc,.true.)
!
! Writing positional parameters for low-resolution analysis increments U grid
!
! Write >>:
cltypvar = 'X'
clnomvar = '>>'
clgrtyp = 'E'
ierr = vfstecr(grd_x_8,zwork,-inbits,nulinclr,ibrpstamp,
& ideet,inpas,mni_in-1,1,1,mig1in_u,mig2in_u,mig3in_u,cltypvar
& ,clnomvar,cetikinc,clgrtyp,mig1tic,mig2tic,mig3tic,mig4tic
& ,ndtinc,.true.)
!
! Write ^^
cltypvar = 'X'
clnomvar = '^^'
clgrtyp = 'E'
ierr = vfstecr(grd_y_8,zwork,-inbits,nulinclr,ibrpstamp,
& ideet,inpas,1,mnj_in,1,mig1in_u,mig2in_u,mig3in_u,cltypvar
& ,clnomvar,cetikinc,clgrtyp,mig1tic,mig2tic,mig3tic,mig4tic
& ,ndtinc,.true.)
!
! Writing positional parameters for low-resolution analysis increments V grid
!
! Write >>:
cltypvar = 'X'
clnomvar = '>>'
clgrtyp = 'E'
ierr = vfstecr(grd_x_8,zwork,-inbits,nulinclr,ibrpstamp,
& ideet,inpas,mni_in,1,1,mig1in_v,mig2in_v,mig3in_v,cltypvar
& ,clnomvar,cetikinc,clgrtyp,mig1tic,mig2tic,mig3tic,mig4tic
& ,ndtinc,.true.)
!
! Write ^^
cltypvar = 'X'
clnomvar = '^^'
clgrtyp = 'E'
ierr = vfstecr(grd_y_8,zwork,-inbits,nulinclr,ibrpstamp,
& ideet,inpas,1,mnj_in-1,1,mig1in_v,mig2in_v,mig3in_v,cltypvar
& ,clnomvar,cetikinc,clgrtyp,mig1tic,mig2tic,mig3tic,mig4tic
& ,ndtinc,.true.)
endif
c
WRITE(NULOUT,FMT='(/,4X,''Transfer of the gridpoint model'',
S '' state on file at iteration No.'',I3)')
S NITER
!
!*3 Set hybrid vertical coordinate parameters from trial field
! **********************************************************
!
call gethybprm2(ninmpg,nulout,-1,-1,' ',-1,zptop4,zpref4,zrcoef4
& ,iip1_hyb_prm,ntrials)
zptophr = zptop4
zprefhr = zpref4
zrcoefhr= zrcoef4
if(lldebug) then
write(nulout,*)'varoutla:zptop4,zpref4,zrcoef4 '
& ,zptophr,zprefhr,zrcoefhr
endif
c
c Writing HY to analysis file
c
if(nulstd.ne.0) then
write(nulout,*) 'Writing variable HY on analysis file'
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
!
!*4 Get P0 from trial fields for vertical interpolation definition
! **************************************************************
!
write(nulout,*)
& 'Reading P0 and hybrid coordinate parameters of trial field '
& ,' for vertical interpolation'
c
clnomvar = 'P0'
cletiket = ' '
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
cletiket = ' '
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,'varoutla')
endif
c
cletiket = ' '
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)
!
!*5 Writing PT to analysis file when R coefficient = 1.0
! 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
if(lldebug) then
write(nulout,*) 'Writing PT field on analysis file unit= '
& ,nulstd
write(nulout,*)'xxx PT inbitstr= ',inbitstr
endif
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,'varoutla')
endif
call hpdeallc(pxpttrl,ierr,1)
endif
endif
!
!*6 Analysis grid hybrid vertical coordinate parameters
! ***************************************************
!
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(nppcvar))
c
inpak_inc = -12
if(npakanl .ne. -999) then
inpak_gz = npakanl
inpak_vt = npakanl
do jvar = 1, nppcvar
inpak_anl(jvar)= -12
!cluc inpak_anl(jvar)= npakanl
enddo
else
inpak_gz = -12
!cluc inpak_gz = -24
inpak_vt = -32
! inpak_vt = -16
do jvar = 1, nppcvar
cletiket = ' '
ikey = FSTINF(koutmpg, INIX, INJX, INKX, ibrpstamp, cletiket,
& -1, -1, -1,cltypvar,cppcvar(jvar))
if(ikey .ge. 0) then
cletiket = ' '
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) = -12
!cluc inpak_anl(jvar) = -inbits
else
inpak_anl(jvar) = -12
!cluc 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
if(lldebug) then
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,*)'-----------------------------------------'
endif
!
!*7 Winds have not been processed yet
! Reset switch llvint=.true. if nflev .ne. itrlnlev
! (ie when the number of levels of the analysis grid
! is not equal to the number of levels of the trial field grid)
! *************************************************************
!
llwind = .false.
!
cletiket = ' '
call getfldprm2(IIP1S_TRL,IIP2,IIP3,ITRLNLEV,CLETIKET,CLTYPVAR
& ,ITRLGID,'UU',ibrpstamp,jpnflev,ninmpg
& ,nulout,ip1_pak_trl,ip1_vco_trl,ntrials,koutmpg)
!
c
if (nflev .ne. itrlnlev) then
llvint = .true.
endif
!
!*8 Array allocation
! ****************
!
call hpalloc(pxtopo,ini*inj,ierr,8)
call hpalloc(pxpsanl,ini*inj,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)
call hpalloc(pxgzvar2,ini*inj*itrlnlev,ierr,8)
!
!*9 Loop over variables
! *******************
!
do 900 jvar = 1, nppcvar
!
write(nulout,*) 'varoutla: Treating variable',cppcvar(jvar)
!
!*9.2 Some variable may be requested for other to be computed but not
! necessarily wanted as output..
! ---------------------------------------------------------------
!
llvarout = .true.
llgettrl = .true.
if(cppcvar(jvar).eq.'TT'.and..not.lttout) llvarout = .false.
if(cppcvar(jvar).eq.'HU'.and..not.lhuout) llvarout = .false.
llimplemented = .true.
!
!*9.3 For current variable: Interpolate Horizontally&Vertically and add to trial and write
! N.B.: If the trial field associated to cppcvar(jvar) isnt on the background file,
! getfldprm2 will have ITRLNLEV=0 so no treatment done for High increments and analysis...
! ---------------------------------------------------------------------------------------------
!
if ((cppcvar(jvar).ne.'UU'.and.cppcvar(jvar).ne.'VV').or.
& .not.llwind) then
!
!*9.3.1 Fields associated with model variables
!
cletiket = ' '
clname = cppcvar(jvar)
if(cppcvar(jvar).eq.'U1') clname='UT1'
if(cppcvar(jvar).eq.'V1') clname='VT1'
!
call getfldprm2(IIP1S_TRL,IIP2,IIP3,ITRLNLEV,CLETIKET,CLTYPVAR
& ,ITRLGID,clname,ibrpstamp,jpnflev,ninmpg
& ,nulout,ip1_pak_trl,ip1_vco_trl,ntrials,koutmpg)
!
! Sort the levels encoded in IIP1S_TRL
! 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. )
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. )
enddo
!
!*9.3.2 Do setup to properly interpolate the analysed increments to
! the model levels and model high resolution grid and to encode
! IP1 on unit nulinchr (increments) and on unit nulstd (analysis)
! with the same coded values found on the trial field (unit ninmpg)
!
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,'varoutla')
endif
!
!*9.3.3 Encode zlev_anl in iip1s_anl
!
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
!
!*9.3.4
!
! Pass here only if llwind is initially set to llwind = .FALSE.
! at the beginning of Sec. 9.3...
!
if (cppcvar(jvar).eq.'UU'.or.cppcvar(jvar).eq.'VV') then
llwind = .true.
if (cppcvar(jvar).eq.'UU') then
clnomvar = 'VV'
else
clnomvar = 'UU'
endif
endif
if (cppcvar(jvar).eq.'U1'.or.cppcvar(jvar).eq.'V1') then
if (cppcvar(jvar).eq.'U1') then
clnomvar_image = 'VT1'
else
clnomvar_image = 'UT1'
endif
endif
!
!
!*9.3.5
!
if (itrlnlev.ne.0) then
ierr = ezgprm(itrlgid,clgrtyp,ini,inj,iig1,iig2,iig3,iig4)
!
if (cppcvar(jvar).eq.'UU'.or.cppcvar(jvar).eq.'VV') then ! True-Wind
cletiket = ' '
call getfldprm2(IIP1S,IIP2,IIP3,IWINDNLEV,CLETIKET,CLTYPVAR
& ,IWINDGID,clnomvar,ibrpstamp,jpnflev,ninmpg
& ,nulout,ip1_pak_trl,ip1_vco_trl,ntrials,koutmpg)
!
ierr = ezgprm(iwindgid,clgrtypwind,iniwind,injwind
& ,iig1wind,iig2wind,iig3wind,iig4wind)
else if (cppcvar(jvar).eq.'U1'.or.cppcvar(jvar).eq.'V1') then ! Wind-Image
cletiket = ' '
call getfldprm2(IIP1S,iip2_image,iip3_image,idum,CLETIKET,CLTYPVAR
& ,imagegid,'V1',ibrpstamp,jpnflev,ninmpg
& ,nulout,ip1_pak_trl,ip1_vco_trl,ntrials,koutmpg)
!
ierr = ezgprm(imagegid,clgrtyp_image,iniv,injv
& ,iig1_image,iig2_image,iig3_image,iig4_image)
!
endif
endif
!
!*9.3.6 Setup before writing
! --------------------
!
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
ip1_pak_inclr = nip1_pak_inc
!
!*9.3.7 Write low-resolution analysis increments on unit nulinclr
! ---------------------------------------------------------
!
! AINC LOW
ip1 = -1
jlev = 1
c
do while (jlev.le.nflev.and.ip1.ne.0 )
c
c Go get the desired field (with correct output scaling) via gdout2:
c Result in zlowvar array
c
call gdout2(cppcvar(jvar),zlowvar(1,1,jlev),mni_in,mnj_in
& ,jlev,llimplemented,IIP1S_INCLR(jlev))
c
c If variable cppcvar is not implemented skip to the next variable
if (.not.llimplemented) goto 900
c
if(nulinclr.ne.0.and.llvarout) then
if(grd_typ.eq.'LU') then
inig1=mig1in
inig2=mig2in
inig3=mig3in
else
inig1=nig1
inig2=nig2
inig3=nig3
endif
!
inidim = mni_in
injdim = mnj_in
!
if((cppcvar(jvar).eq.'U1').or.(cppcvar(jvar).eq.'V1')) then
!
if(cppcvar(jvar).eq.'U1') then
do jj=1,injdim
do ji=1,inidim-1
zwkU(ji,jj,jlev)=zlowvar(ji,jj,jlev)
zwkU8(ji,jj,jlev)=zlowvar(ji,jj,jlev)
enddo
enddo
write(nulout,*) 'varoutla: Level = ',jlev
call maxmin(zwkU8(1,1,jlev),inidim,injdim,1,zmin,zmax,
& idum1,idum2,idum3,idum4,'varoutla ','U1')
else if(cppcvar(jvar).eq.'V1') then
do jj=1,injdim-1
do ji=1,inidim
zwkV(ji,jj,jlev)=zlowvar(ji,jj,jlev)
zwkV8(ji,jj,jlev)=zlowvar(ji,jj,jlev)
enddo
enddo
endif
!
if(cppcvar(jvar).eq.'U1') then
inidim=mni_in-1
injdim=mnj_in
inig1=mig1in_u
inig2=mig2in_u
inig3=mig3in_u
clnomvar_3='UT1'
else if(cppcvar(jvar).eq.'V1') then
inidim=mni_in
injdim=mnj_in-1
inig1=mig1in_v
inig2=mig2in_v
inig3=mig3in_v
clnomvar_3='VT1'
endif
if(cppcvar(jvar).eq.'U1') then
!
ierr= fstecr(zwkU(1,1,jlev),zwork4,inpak_inc,nulinclr,ibrpstamp,ndeet,npas,
& inidim,injdim,1,iip1s_inclr(jlev),nip2,niter,cltypinc,clnomvar_3,
& cetikinc,cgrtyp,inig1,inig2,inig3,0,nidatyp,.true.)
else if(cppcvar(jvar).eq.'V1') then
ierr= fstecr(zwkV(1,1,jlev),zwkV(1,1,jlev),inpak_inc,nulinclr,ibrpstamp,ndeet,npas,
& inidim,injdim,1,iip1s_inclr(jlev),nip2,niter,cltypinc,clnomvar_3,
& cetikinc,cgrtyp,inig1,inig2,inig3,0,nidatyp,.true.)
endif
else
! if(cppcvar(jvar).eq.'TT') then
! write(nulout,*) 'varoutla: mni_in,mnj_in=',mni_in,mnj_in
! do ji=1,mni_in
! do jj=1,mnj_in
! write(nulout,*) 'varoutla: jj,tt0(50,40,jj)=',jj,tt0(50,40,jj)
! zlowvar(ji,jj,jlev)=tt0(ji,jlev,jj)
! enddo
! enddo
! endif
!
IERR = VFSTECR(zlowvar(1,1,jlev),zwork,inpak_inc
& ,nulinclr,ibrpstamp,ndeet,npas,inidim,injdim,1,iip1s_inclr(jlev)
& ,nip2,niter,cltypinc,cppcvar(jvar),cetikinc,cgrtyp,inig1
& ,inig2,inig3,0,nidatyp,.true.)
endif
endif
!
!
! If cppcvar is a wind component look for the other component
! This also applies for wind images
! (see above in section 9.3.4 for correct initialization of clnomvar)
!
! Go get the desired field (with correct output scaling) via gdout2:
! Result in zlowwind array
!
if(cppcvar(jvar).eq.'VV'.or.cppcvar(jvar).eq.'UU') then
!
call gdout2(clnomvar,zlowwind(1,1,jlev),mni_in,mnj_in,jlev
& ,llimplemented,IIP1S_INCLR(jlev))
c
if(nulinclr.ne.0.and.llvarout) then
!
if(grd_typ.eq.'LU') then
inig1=mig1in
inig2=mig2in
inig3=mig3in
else
inig1=nig1
inig2=nig2
inig3=nig3
endif
!
IERR = VFSTECR(zlowwind(1,1,jlev),zwork,inpak_inc
& ,nulinclr,ibrpstamp,ndeet,npas,mni_in,mnj_in,1,iip1s_inclr(jlev)
& ,nip2,niter,cltypinc,clnomvar,cetikinc,cgrtyp,inig1,inig2
& ,inig3,0,nidatyp,.true.)
endif
endif
jlev = jlev + 1
enddo ! enddo while
!
!*9.3.8 Horizontal Interpolation of Analysis Increments from Low to High grids
! N.B.: Done only if background variable asked is present on file, except LQ case...
! ----------------------------------------------------------------------------------
!
! AINC HIGH
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
!
if (itrlnlev.gt.1) then
inbrlev = nflev
else if (cppcvar(jvar).eq.'LQ') then ! to allow output of LQ anal. incr on high resolution file.
inbrlev = nflev
else
inbrlev = 1
endif
!
if(itrlnlev.ne.0) then
if (cppcvar(jvar).eq. 'UU') then
call hintvec2(zlowvar,zlowwind,mni_in*mnj_in,igdgid
& ,zhighvar,zhighwind
& ,ini*inj,itrlgid,inbrlev,'CUBIC')
elseif(cppcvar(jvar).eq.'VV') then
call hintvec2(zlowwind,zlowvar,mni_in*mnj_in,igdgid
& ,zhighwind,zhighvar
& ,ini*inj,itrlgid,inbrlev,'CUBIC')
elseif(cppcvar(jvar).eq.'U1') then
if(nit.ne.ini+1) then
call abort3d(nulout,'varoutla: (nit.ne.ini+1) for UT1')
else if(njt.ne.inj) then
call abort3d(nulout,'varoutla: (njt.ne.inj) for UT1')
else if(nkt.ne.inbrlev) then
call abort3d(nulout,'varoutla: (nkt.ne.inbrlev) for UT1')
endif
call hintscal(zwkU8,(mni_in-1)*mnj_in,ngidu_in,
& zainch_U,ini*inj,itrlgid,inbrlev,'CUBIC')
elseif(cppcvar(jvar).eq.'V1') then
if(nit.ne.iniv) then
write(nulout,*) 'varoutla: nkt = ',nkt
write(nulout,*) 'varoutla: inbrlev = ',inbrlev
call abort3d(nulout,'varoutla: (nit.ne.iniv) for UT1')
else if(njt.ne.injv+1) then
write(nulout,*) 'varoutla: nkt = ',nkt
write(nulout,*) 'varoutla: inbrlev = ',inbrlev
call abort3d(nulout,'varoutla: (njt.ne.injv+1) for UT1')
else if(nkt.ne.inbrlev) then
write(nulout,*) 'varoutla: nkt = ',nkt
write(nulout,*) 'varoutla: inbrlev = ',inbrlev
call abort3d(nulout,'varoutla: (nkt.ne.inbrlev) for VT1')
endif
if(lldebug) then
call maxmin(zwkV8(1,1,10),inidim,injdim,1,zmin,zmax,
& idum1,idum2,idum3,idum4,'varoutla ','V1')
endif
call hintscal(zwkV8,mni_in*(mnj_in-1),ngidv_in,
& zainch_V,ini*inj,imagegid,inbrlev,'CUBIC')
if(lldebug) then
call maxmin(zainch_V(1,1,10),iniv,injv,1,zmin,zmax,
& idum1,idum2,idum3,idum4,'varoutla ','VH')
endif
else
write(nulout,*) 'varoutla: Horizontal Interpolation to High grid:',cppcvar(jvar)
call hintscal(zlowvar,mni_in*mnj_in,igdgid,
& zhighvar,ini*inj,itrlgid,inbrlev,'CUBIC')
endif
!
! weird output section... Luc
!
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
IERR = VFSTECR(zhighwind((jlev-1)*iniwind*injwind+1)
& ,zwork,inbits_la,nulinchr,ibrpstamp
& ,ndeet,npas,iniwind,injwind,1,iip1s_anl(jlev)
& ,nip2,niter,cltypinc,clnomvar,cetikinc,clgrtyp
& ,iig1wind,iig2wind,iig3wind,iig4wind,idatyp_la,
& .false.)
enddo
endif
endif
c
if(cppcvar(jvar).eq.'HU'.and.lolqout.and. .not. lhintdelhu
& ) then
do jlev = 1, inbrlev
IERR = VFSTECR(zhighvar((jlev-1)*ini*inj+1),zwork,
& inbits_la,nulinchr,ibrpstamp,ndeet,npas
& ,ini,inj,1,iip1s_anl(jlev),nip2,niter,cltypinc
& ,'LQ',cetikinc,clgrtyp,iig1,iig2,iig3,iig4
& ,idatyp_la,.true.)
enddo
elseif((cppcvar(jvar).ne.'HU'.or. lhintdelhu) .and.
& llvarout) then
do jlev = 1, inbrlev
IERR = VFSTECR(zhighvar((jlev-1)*ini*inj+1),zwork
& ,inbits_la,nulinchr,ibrpstamp,ndeet,npas
& ,ini,inj,1,iip1s_anl(jlev),nip2,niter,cltypinc
& ,cppcvar(jvar),cetikinc,clgrtyp,iig1,iig2,iig3
& ,iig4,idatyp_la,.true.)
enddo
endif
endif
endif
!
!*9.3.9. Bring analysis increment to high resolution grid and also produce total analysis fields
! ---------------------------------------------------------------------------------------
!
!*9.3.9.0 Decide if current variable will go through further treatment
! for output on high res. file via logical llhigh
!
if(cppcvar(jvar).eq.'GZ'.or.cppcvar(jvar).eq.'VT') then
!
! Those variables are re-computed from dependent total analysed variables
! This means that no vertical interpolation are required but increments
! can be diagnosed and even interpolated horizontally if corresponding
! template variable are present in the trial file.
!
llvint = .false.
endif
!
if (itrlnlev.gt.1) then
llhigh = .true.
else if (itrlnlev.eq.1) then
if (cppcvar(jvar).eq.'LQ') then
llhigh = .true.
else
llhigh = .false.
endif
endif
!
if (llhigh) then
!
!*9.3.9.1 Vertical Interpolation for 3D-Fields
!
if (llvint.and.nflev.ne.1) then
c Interpolation of high res. P0 and PT to high res. variable grid
ierr = ezsetopt('INTERP_DEGREE','CUBIC')
iset = ezdefset(itrlgid,ip0gid)
ierr = vezsint(zps,zpstrl,ini,inj,1,ini,inj,1)
c
call calcpres(zpresanl,vhybinc,nflev,zps,rptopinc*rpatmb
& ,rprefinc*rpatmb,rcoefinc,ini*inj)
c
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
write(nulout,*) 'varoutla: ---------------------------------'
write(nulout,*) 'varoutla: Vertical Interpolation for ',cppcvar(jvar)
write(nulout,*) 'varoutla: ---------------------------------'
!
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
write(nulout,*) 'varoutla: ---------------------------------'
write(nulout,*) 'varoutla: No Vertical Interpolation for ',cppcvar(jvar)
write(nulout,*) 'varoutla: ---------------------------------'
if(cppcvar(jvar).ne.'U1') then
if(cppcvar(jvar).ne.'V1') then
do jlev = 1, itrlnlev
do jcol = 1, ini*inj
zvhvar((jlev-1)*ini*inj+jcol) = ! just transfer to other array
& zhighvar((jlev-1)*ini*inj+jcol)
enddo
enddo
endif
endif
endif ! llvint
!
!*9.3.9.2
!
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 P0
call calcpres(zprestrl,zlev_int,itrlnlev,zps,zptophr
& ,zprefhr,zrcoefhr,ini*inj)
endif
!
!*9.3.9.3 Build Analysis = Trial + Anal.-Incr.
!
write(nulout,*)'varoutla: cppcvar(jvar),itrlnlev=',cppcvar(jvar),itrlnlev
!
do jlev = 1,itrlnlev
!
if(nulinchr.ne.0) then
!
clname=cppcvar(jvar)
if(clname.eq.'LQ'.or.clname.eq.'HU') then ! HU contains zhu... see postmin.ftn and gdout2.ftn
IERR = VFSTECR(zvhvar((jlev-1)*ini*inj+1),zwork
& ,inbits_la,nulinchr,ibrpstamp,ndeet,npas
& ,ini,inj,1,iip1s_anl(jlev),nip2,niter,cltypinc
& ,clname,cetikinc,clgrtyp,iig1,iig2,iig3,iig4
& ,idatyp_la,.true.)
!
elseif((cppcvar(jvar).ne.'HU'.or.lhintdelhu).and
& .llvarout) then
!
! write analysis increments on high-resolution grid on file
!
clname = cppcvar(jvar)
if(cppcvar(jvar).eq.'U1') then
clname = 'UT1'
do ji=1,ini
do jj=1,inj
zainch_U4(ji,jj)=zainch_U(ji,jj,jlev)
enddo
enddo
IERR = FSTECR(zainch_U4(1,1),zwork4
& ,inbits_la,nulinchr,ibrpstamp,ndeet,npas
& ,ini,inj,1,iip1s_anl(jlev),nip2,niter,cltypinc
& ,clname,cetikinc,clgrtyp,iig1,iig2,iig3
& ,iig4,idatyp_la,.true.)
else if(cppcvar(jvar).eq.'V1') then
clname = 'VT1'
do ji=1,ini
do jj=1,inj
zainch_V4(ji,jj)=zainch_V(ji,jj,jlev)
enddo
enddo
IERR = FSTECR(zainch_V4(1,1),zwork4
& ,inbits_la,nulinchr,ibrpstamp,ndeet,npas
& ,iniv,injv,1,iip1s_anl(jlev),nip2,niter,cltypinc
& ,clname,cetikinc,clgrtyp,iig1_image,iig2_image,iig3_image
& ,iig4_image,idatyp_la,.true.)
else
IERR = VFSTECR(zvhvar((jlev-1)*ini*inj+1),zwork
& ,inbits_la,nulinchr,ibrpstamp,ndeet,npas
& ,ini,inj,1,iip1s_anl(jlev),nip2,niter,cltypinc
& ,clname,cetikinc,clgrtyp,iig1,iig2,iig3
& ,iig4,idatyp_la,.true.)
endif
endif
endif
c
c Look for corresponding trial field
c
if(llgettrl) then
cletiket = ' '
clname = cppcvar(jvar)
if(cppcvar(jvar).eq.'U1') clname='UT1'
if(cppcvar(jvar).eq.'V1') clname='VT1'
if(lldebug) then
write(nulout,*) 'varoutla: point 6f'
write(nulout,*) 'varoutla: point 6f1: ibrpstamp=',ibrpstamp
write(nulout,*) 'varoutla: point 6f1: iip1s_trl(jlev)=',iip1s_trl(jlev)
write(nulout,*) 'varoutla: point 6f1: iip2,iip3=',iip2,iip3
write(nulout,*) 'varoutla: point 6f1: cltypvar=',cltypvar
write(nulout,*) 'varoutla: point 6f1: clname=',clname
endif
ikey = FSTINF(koutmpg, INI, INJ, INK, ibrpstamp, cletiket,
& iip1s_trl(jlev), iip2, iip3,cltypvar,clname)
if(lldebug) then
write(nulout,*) 'varoutla: point 6g: iip2, iip3=',iip2, iip3
write(nulout,*) 'varoutla: point 6g: INI, INJ, INK=',INI, INJ, INK
endif
c
if (ikey.lt.0) then
write(nulout,*) 'Problems finding variable '
& ,cppcvar(jvar),' at level ',zlev_trl(jlev)
& ,' in trial file'
call abort3d(nulout,'varoutla')
endif
c
if(cppcvar(jvar).eq.'U1') then
ikey = VFSTLUK(ztrial_U_2d,ikey, INI, INJ, INK)
else if(cppcvar(jvar).eq.'V1') then
ikey = VFSTLUK(ztrial_V_2d,ikey, INI, INJ, INK)
else
ikey = VFSTLUK(zhighvar,ikey, INI, INJ, INK)
endif
!
if(lldebug) then
if(cppcvar(jvar).eq.'U1') then
write(nulout,*) 'varoutla: Level = ',jlev
write(nulout,*) '***********************'
call maxmin(ztrial_U_2d(1,1),INI,INJ,1,zmin,zmax,
& idum1,idum2,idum3,idum4,'varoutla ','UB')
endif
endif
c
c Sum of increments and trial field
c
if(cppcvar(jvar).eq.'HU') then
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 Save 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
else
if(cppcvar(jvar).eq.'U1') then
do jj = 1, inj
do ji = 1, ini
zanal_U(ji,jj,jlev) = ztrial_U_2d(ji,jj) +
& zainch_U(ji,jj,jlev)
enddo
enddo
else if(cppcvar(jvar).eq.'V1') then
do jj = 1, inj
do ji = 1, ini
zanal_V(ji,jj,jlev) = ztrial_V_2d(ji,jj) +
& zainch_V(ji,jj,jlev)
enddo
enddo
else
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
enddo
endif
endif
else
write(nulout,*) 'varoutla: '
& ,cppcvar(jvar),' at level ',zlev_trl(jlev)
& ,' in trial file'
endif
enddo ! jlev
!
!*9.3.9.4 Special adjustments to humidity analysis field
!
if(cppcvar(jvar).eq.'HU'.and.lladjhum) then
c
c CAREFULL: un-ajusted trial specific humidity copied in variable zprestrl
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
c
ilimlvhu=nint(rlimlvhu)
c
c trial specific humidity ajustment (zprestrl)
c
write(nulout,*) ' '
write(nulout,*) ' *** TRIAL SPECIFIC HUMIDITY AJUSTMENT '
write(nulout,*) ' '
call AJHUM(zprofo,zttvar,zprestrl,zvtvar,zwrkvec,ini,inj
& ,itrlnlev,zlev_trl,zhumin,llclip)
c
c specific humidity analysis ajustment (zvhvar)
c
write(nulout,*) ' '
write(nulout,*) ' *** ANAL SPECIFIC HUMIDITY AJUSTMENT '
write(nulout,*) ' '
call AJHUM(zprofo,zttvar,zvhvar,zvtvar,zwrkvec,ini,inj
& ,itrlnlev,zlev_anl,zhumin,llclip)
c
c T-Td analysis after ajustments (zesvar)
c
if(lanlhu2es) then
c
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
c
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
c
CALL MHUAESGD2(zesvar,zvhvar,zwrkvec,zincq,ini,inj
& ,itrlnlev,lswphes)
c
c set T-TD between zero and rlimit_es read namelist
c
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
IERR = VFSTECR(zincq((jlev-1)*ini*inj+1),zwork
& ,inbits_la,nulinchr,ibrpstamp,ndeet,npas
& ,ini,inj,1,iip1s_anl(jlev),nip2,niter,cltypinc
& ,cppcvar(jvar),cetikinc,clgrtyp,iig1,iig2,iig3
& ,iig4,idatyp_la,.true.)
c
enddo
endif
c
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
c temperature conversion for mfotvt
c
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)
c
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 ! cppcvar(jvar).eq.'HU'
c
if (cppcvar(jvar).eq.'HU'.and.lgzout) then
c
c Looking for topography
c
cletiket = ' '
ikey = FSTINF(koutmpg, INI, INJ, INK, ibrpstamp, cletiket,
& iip1s_trl(itrlnlev), iip2, iip3,cltypvar,'GZ')
c
if (ikey.lt.0) then
write(nulout,*) 'Problems finding variable '
& ,'GZ',' at level ',zlev_trl(itrlnlev),' in trial file'
call abort3d(nulout,'varoutla')
endif
c
ikey = VFSTLUK(ztopo,ikey, INI, INJ, INK)
c
call calgz(zprofo,zvtvar,zgzvar,ztopo,ini,inj,itrlnlev
& ,iip1s_trl)
c
c ztrlq here contain vt from q fitred increment
c
call calgz(zprofo,ztrlq,zgzvar2,ztopo,ini,inj,itrlnlev
& ,iip1s_trl)
endif
!
!*9.3.9.5 Write Analysis fields on file
! -----------------------------
!
if(nulstd.ne.0) then
c
do jlev = 1,itrlnlev
c
if(llvarout) then
clname = cppcvar(jvar)
if(cppcvar(jvar).eq.'U1') then
clname='UT1'
do jj=1,inj
do ji=1,ini
zanal_U4(ji,jj) = zanal_U(ji,jj,jlev)
enddo
enddo
IERR = fstecr(zanal_U4(1,1),zwork4
& ,inpak_anl(jvar),nulstd,ibrpstamp,ndeet,npas,ini
& ,inj,1,iip1s_anl(jlev),nip2,niter,cltypanl
& ,clname,cetikinc,clgrtyp,iig1,iig2,iig3
& ,iig4,nidatyp,.true.)
else if(cppcvar(jvar).eq.'V1') then
clname='VT1'
do jj=1,inj
do ji=1,ini
zanal_V4(ji,jj) = zanal_V(ji,jj,jlev)
enddo
enddo
IERR = fstecr(zanal_V4(1,1),zwork4
& ,inpak_anl(jvar),nulstd,ibrpstamp,ndeet,npas,ini
& ,inj,1,iip1s_anl(jlev),nip2,niter,cltypanl
& ,clname,cetikinc,clgrtyp,iig1_image,iig2_image,iig3_image
& ,iig4_image,nidatyp,.true.)
else
write(nulout,*) 'varoutla: writing analysis VAR = ',cppcvar(jvar)
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
& ,clname,cetikinc,clgrtyp,iig1,iig2,iig3
& ,iig4,nidatyp,.true.)
endif
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
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
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
enddo
endif
!
!*9.3.9.6 Wind Treatment
!
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.and.nflev.ne.1) 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
do jlev = 1, itrlnlev
do jcol = 1, iniwind*injwind
zvhvar((jlev-1)*iniwind*injwind+jcol) =
& zprofo((jcol-1)*itrlnlev+jlev)
enddo
enddo
else
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
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
cletiket = ' '
ikey = FSTINF(koutmpg, INI, INJ, INK, ibrpstamp, cletiket
& ,iip1s_trl(jlev), iip2, iip3,cltypvar,clnomvar)
c
if (ikey.lt.0) then
write(nulout,*) 'Problems finding variable '
& ,cppcvar(jvar),' at level ',zlev_trl(jlev)
& ,' in trial file'
call abort3d(nulout,'varoutla')
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
enddo
c
c Write Wind-Components analysis fields
c
do jlev = 1,itrlnlev
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
endif
c
elseif(itrlnlev.eq.1) then
!
!*9.3.10 Treatment of 2D-Fields
! ----------------------
!
c
c Sum of increments and trial field for 2d variables
c
c Looking for corresponding trial field
cletiket = ' '
ikey = fstinf(koutmpg, INI, INJ, INK, ibrpstamp, cletiket,
& iip1s_trl(itrlnlev), iip2, iip3,cltypvar,cppcvar(jvar))
c
if (ikey.lt.0) then
write(nulout,*) 'Problems finding variable ',cppcvar(jvar)
& ,' at level ',zlev_trl(itrlnlev),' in trial file'
call abort3d(nulout,'varoutla')
endif
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.)
endif
c
endif ! END 3D FIELDS and 2D FIELDS
c
!
!*9.3.11 Writing positional parameters
! -----------------------------
!
if (clgrtyp.eq.'Z') then
cletiket = ' '
cltypvar = 'X'
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_la, 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 = 'X'
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 = 'X'
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 = 'X'
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 ! grdtyp .eq. Z
endif ! end of Sec. 9.3
900 continue ! jvar loop
!
!*10. Deallocation of local arrays (Abort on error)
! ---------------------------------------------
!
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(pxgzvar2,ierr,1)
call hpdeallc(pxpsanl,ierr,1)
call hpdeallc(pxpstrl,ierr,1)
call hpdeallc(pxtopo,ierr,1)
call hpdeallc(pxps,ierr,1)
call hpdeallc(pxptop,ierr,1)
deallocate(inpak_anl)
c
write(nulout,*) 'END of varoutla'
c
RETURN
END