SUBROUTINE pert_varout 1,31
use mod4dv, only : l4dvar
#if defined (DOC)
*
***s/r pert_varout - Saving of the perturbed trial fields and pertubations
* in RPN standard files
*
*Author : M. Buehner (named routine varout3)
* Based on varout.ftn from S. Pellerin *ARMA/AES April 2000
*
*Revision:
* Y. Nezlin, UofT, 2005/06
* - Adapted varout3 from M. Buehner.
* Y. Nezlin and Y.J. Rochon, April 2006
* - Various changes.
* Y.J. Rochon, May 2006
* - Streamlining and some re-organization of code and comments.
* Further removal of non-needed elements could be done.
* Y.J. Rochon - ARQX/EC - Aug 2006
* - Added output of ln(ps) and dln(ps)
* Y. Yang ARQ July 2010
* - use of getfldprm2 following later official version varout to deal with
* multiple trial field
*
*Arguments
*
#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"
*
integer vfstluk,write_encode_hyb
integer jvar, jcol,jlev2
integer jlev,inbrlev,imode,inbitstr,ilimlvhu
real*8 zlowvar,zlowwind
C
#include "localpost.cdk"
C
integer itrlgid,ip0gid,iip1s(jpnflev),iip1,iip2,ibrpstamp
integer iip1s_inclr(jpnflev),iip1s_trl(jpnflev),iip1s_wrk(jpnflev)
integer ip1_pak_trl,ip1_vco_trl,ip1_pak_anl,ip1_vco_anl
integer ip1_pak_inclr,ip1_pak_hy,ip1_vco_inclr,iip1_hyb_prm
integer itrlnlev,iwindnlev,igdgid,ezqkdef,ezsetopt,ezdefset,iip3
integer iig1,iig2,iig3,iig4,ezgprm,ikey,iwindgid,vezsint
integer iniwind,injwind,inkwind,iig1wind,iig2wind,iig3wind
integer iig4wind,ikind,iset
integer inpak_gz,inpak_vt,inpak_inc
integer, allocatable, dimension(:) :: inpak_anl
integer INIX, INJX, INKX
real*8 zhighvar(1),zwork,zhighwind(1),zpstrl,zpsanl(1),zpttrl(1)
real*8 zpresanl(1),zlnpsincr(1),zlnpsanl(1),zdist
real*8 zprofi(1),zprofo(1),zvhvar(1),zvtvar(1),zesvar(1)
real*8 zlev_int(jpnflev),zlev_trl(jpnflev)
real*8 zlev_inclr(jpnflev),zlev_wrk(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 zptop4, zpref4,zrcoef4,zdummy
real*8 zptophr, zprefhr,zrcoefhr
integer iunM,ier, iunMpert
integer kfile_use
character*1 clgrtypwind,clstring
character*2 cltypinc
character*4 clnomvar2
pointer (pzlnpsanl,zlnpsanl)
pointer (pzlnpsincr,zlnpsincr)
pointer (pzhighvar,zhighvar)
pointer (pzhighwind,zhighwind)
pointer (pzlowvar,zlowvar(ni,nj,nflev))
pointer (pzlowwind,zlowwind(ni,nj,nflev))
pointer (pxpstrl,zpstrl),(pxpttrl,zpttrl),(pxpresanl,zpresanl)
pointer (pxprestrl,zprestrl),(pxprofi,zprofi),(pxprofo,zprofo)
pointer (pxvhvar,zvhvar),(pxps,zps),(pxptop,zptop)
pointer (pxvtvar,zvtvar),(pxttvar,zttvar),(pxwrkvec,zwrkvec)
pointer (pxgzvar,zgzvar),(pxtopo,ztopo),(pxtrlq,ztrlq)
pointer (pxincq, zincq),(pxesvar,zesvar)
pointer (pxanlq,zanlq),(pxgzvar2,zgzvar2),(pxpsanl,zpsanl)
LOGICAL llimplemented,llwind,llbasevar,llvarout,llclip,llp0
logical :: llvint
data cltypinc /'R'/
data llclip,llp0 /.true.,.false./
c
WRITE(NULOUT,FMT='(/,4X,"Enter PERT_VAROUT",//)')
c
c--- Open files for writing perturbation fields and perturbed fields
c
c use the middle one among the multiple trial files
c
CC kfile_use= max(ntrials/2, 1)
c
c--- Set desird date stamp.
c
if(l4dvar) then
ibrpstamp=nstamplist(1)
else
ibrpstamp=nbrpstamp
endif
c
c--- Get P0 from trial fields for vertical interpolation definition
c
write(nulout,*)
& 'Reading P0 and hybride coordinate parameters of trial field '
& ,' for vertical interpolation'
c
clnomvar = 'P0'
c
call getfldprm2(IIP1S_TRL,IIP2,IIP3,ITRLNLEV,CLETIKET,CLTYPVAR
& ,IP0GID,clnomvar,ibrpstamp,jpnflev,ninmpg
& ,nulout,ip1_pak_trl,ip1_vco_trl,ntrials,kfile_use)
c
ikey = FSTINF(ninmpg(kfile_use),INI,INJ,INK,-1,CLETIKET,
& IIP1S_TRL(1),iip2, iip3,cltypvar,clnomvar)
c
if(ikey.lt.0) then
write(nulout,*) ' ******* ERROR ******* '
write(nulout,*) 'No P0 found in ',ninmpg(kfile_use)
call abort3d(nulout,'PERT_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)
iunM=ninmpg(kfile_use)
c iunM=0 ! FNOM will assign a unit number
if (iunM.ne.ninmpg(kfile_use)) then
ier = fnom(iunM,'trlm.rpn','STD+RND',0)
if(ier.lt.0) write(nulout,*)'iunM fnom error'
ier = fstouv(iunM, 'RND')
if(ier.lt.0) write(nulout,*)'iunM fstouv error'
end if
write(nulout,*) 'Unit number iunM = ',iunM
c
iunMpert=0 ! FNOM will assign a unit number
ier = fnom(iunMpert,'pert.rpn','STD+RND',0)
if(ier.lt.0) write(nulout,*)'iunMpert fnom error'
ier = fstouv(iunMpert, 'RND')
if(ier.lt.0) write(nulout,*)'iunMpert fstouv error'
write(nulout,*) 'Unit number iunMpert = ',iunMpert
c
call hpalloc(pxpstrl,ini*inj,ierr,8)
c
ikey = VFSTLUK(zpstrl, ikey, INI, INJ, INK)
c
c--- Setting degree of horizontal interpolation from low resolution grid
c
igdgid = ezqkdef(ni, nj, 'G', 0,0,0,0,0)
c
c--- Hybrid vertical coordinate parameters
c
c Read 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,*)'PERT_VAROUT: zptop4,zpref4,zrcoef4 '
& ,zptophr,zprefhr,zrcoefhr
c
c Writing HY as required
c
C Determine the style in which ip1 is encoded (15bits or 31 bits)
C A value <= 32767 (2**16 -1) means that ip1 is compacted in 15 bits
C Determine the type of P which was encoded in IP1
C
if(iip1_hyb_prm .le. 32767) then
ip1_pak_hy = 3
else
ip1_pak_hy = 2
c Set encoding of IP1 to 28 bits for write_encode_hyb
imode = 0
CALL CONVIP(iip1_hyb_prm,ZDUMMY,IKIND,imode,clstring,.false.)
endif
c
c Writing HY when required
c
if (iunMpert.gt.0) then
ierr = write_encode_hyb(iunMpert,'HY',nip2,0,cetikinc
& ,idateo,zptop4,zpref4,zrcoef4)
end if
if (iunM.ne.ninmpg(kfile_use)) then
ierr = write_encode_hyb(iunM,'HY',nip2,0,CLETIKET
& ,idateo,zptop4,zpref4,zrcoef4)
endif
c
c--- Writing PT when R coefficient = 1.0
c Use grid parameters from P0
c
if(nint(zrcoef4) .eq. 1)then
call hpalloc(pxpttrl,ini*inj,ierr,8)
iip1 = 0
do jcol = 1,ini*inj
zpttrl(jcol) = zptophr
enddo
if (iunM.ne.ninmpg(kfile_use)) then
IERR = VFSTECR(zpttrl,zwork
& ,0,iunM,idateo,ideet,ipas,ini
& ,inj,1,0,0,0,cltypvar
& ,'PT',CLETIKET,clgrtyp,IG1, IG2,IG3,IG4
& ,idatyp,.true.)
endif
if (iunMpert.ne.0) then
IERR = VFSTECR(zpttrl,zwork
& ,0,iunMpert,idateo,ideet,ipas,ini
& ,inj,1,0,0,0,cltypvar
& ,'PT',cetikinc,clgrtyp,IG1, IG2,IG3,IG4
& ,idatyp,.true.)
endif
call hpdeallc(pxpttrl,ierr,1)
endif
c
c--- Setup packing for each variable
c
allocate(inpak_anl(nppcvar))
c
inpak_inc = -16
if(npakanl .ne. -999) then
inpak_gz = npakanl
inpak_vt = npakanl
do jvar = 1, nppcvar
inpak_anl(jvar)= npakanl
enddo
else
inpak_gz = -24
inpak_vt = -16
do jvar = 1, nppcvar
ikey = FSTINF(ninmpg(kfile_use), INIX, INJX, INKX,ibrpstamp,CLETIKET,
& -1, -1, -1,cltypvar,cppcvar(jvar))
if(ikey .ge. 0) then
ierr = fstprm(ikey,idateo,ideet,ipas,inix,injx,inkx, inbits,
& idatyp,ip1,ip2,ip3,cltypvar,clnomvar,cletiket,clgrtyp
& ,ig1,ig2,ig3,ig4,iswa,ilength,idltf,iubc,iextr1
& ,iextr2,iextr3)
inpak_anl(jvar) = -inbits
else
inpak_anl(jvar) = -16
endif
if(cppcvar(jvar) .eq. 'TT') inpak_vt = inpak_anl(jvar)
if(cppcvar(jvar) .eq. 'GZ') inpak_gz = inpak_anl(jvar)
enddo
endif
write(nulout,*)' '
write(nulout,*)'************************************** '
write(nulout,*)
do jvar =1,nppcvar
write(nulout,*) 'PACKING for analysed var ',cppcvar(jvar),' is '
& ,inpak_anl(jvar)
enddo
write(nulout,*) 'PACKING for analysed GZ is ',inpak_gz
write(nulout,*) 'PACKING for analysed VT is ',inpak_vt
write(nulout,*) 'PACKING for increments is ',inpak_inc
write(nulout,*)' '
write(nulout,*)'************************************** '
c
c Set flag for processing of wind
c
llwind = .false.
c
c--- Verify need for vertical interpolation
c
call getfldprm(IIP1S_TRL,IIP2,IIP3,ITRLNLEV,CLETIKET,CLTYPVAR
& ,ITRLGID,'UU',ibrpstamp,jpnflev,ninmpg(kfile_use)
& ,nulout,ip1_pak_trl,ip1_vco_trl)
c
c Reset switch llvint=.true. if nflev .ne. itrlnlev
c (ie when the number of levels of the analysis grid
c is not equal to the number of levels of the trial field grid)
c
llvint = .false.
if (nflev .ne. itrlnlev) then
llvint = .true.
endif
c
c--- Allocation of work arrays
c
CALL HPALLOC(PZLOWVAR,MAX(NI*NJ*nflev,1),IERR,8)
call hpalloc(pxtopo,ini*inj,ierr,8)
call hpalloc(pxpsanl,ini*inj,ierr,8)
call hpalloc(pzlowwind,ni*nj*nflev,ierr,8)
call hpalloc(pzhighvar,ini*inj*nflev,ierr,8)
call hpalloc(pzhighwind,ini*inj*nflev,ierr,8)
call hpalloc(pxpresanl,ini*inj*nflev,ierr,8)
call hpalloc(pxprofi,ini*inj*nflev,ierr,8)
call hpalloc(pxps,ini*inj,ierr,8)
call hpalloc(pxptop,ini*inj,ierr,8)
c
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)
c
c--- Loop over variables
c
do jvar = 1, nppcvar
if (cppcvar(jvar).eq.'LQ') go to 200
if (cppcvar(jvar).eq.'GZ'.or.cppcvar(jvar).eq.'VT') then
c
c These variables are re-computed from dependent total variables
c This means that no vertical interpolation are required but perturbations
c can be diagnosed and even interpolated horizontally if corresponding
c template variable are present in the trial file.
c
c llbasevar = .false.
else
c
c These variables will be interpolated vertically as long as
c corresponding fields are present in the trial file.
c
llbasevar = .true.
endif
c
c Some variable may be requested for others to be computed but not
c necessarily wanted as output..
c
llvarout = .true.
if(cppcvar(jvar).eq.'TT'.and..not.lttout) llvarout = .false.
if(cppcvar(jvar).eq.'HU'.and..not.lhuout) llvarout = .false.
c
llimplemented = .true.
c
write(nulout,*) 'Writing variable ',cppcvar(jvar)
c
if ((cppcvar(jvar).ne.'UU'.and.cppcvar(jvar).ne.'VV').or.
& .not.llwind) then
c
c ** Identify and set vertical level array
c
call getfldprm(IIP1S_TRL,IIP2,IIP3,ITRLNLEV,CLETIKET,CLTYPVAR
& ,ITRLGID,cppcvar(jvar),ibrpstamp,jpnflev,ninmpg(kfile_use)
& ,nulout,ip1_pak_trl,ip1_vco_trl)
c
c Sort the levels encoded in IIP1S_TRL
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. )
zlev_wrk(jlev) = zlev_trl(jlev)
iip1s_wrk(jlev)= iip1s_trl(jlev)
enddo
c
if (itrlnlev.gt.1) then
c
call vsort(zlev_trl,itrlnlev)
c
c Encode iip1s_trl to match the sorted zlev_trl
c
do jlev = 1,itrlnlev
zdist=1.D10
do jcol=1,itrlnlev
if (abs(zlev_trl(jlev)-zlev_wrk(jcol)).lt.zdist) then
zdist=abs(zlev_trl(jlev)-zlev_wrk(jcol))
jlev2=jcol
end if
end do
iip1s_trl(jlev)=iip1s_wrk(jlev2)
enddo
end if
c
c Do setup to properly interpolate the perturbatons to
c the model levels and model high resolution grid and to encode
c IP1 on unit iunMpert and on unit iunM.
c
c Type of vertical coord accepted are
C ip1_vco_trl = 1 (eta levels)
c ip1_vco_trl = 2 (2D fields have value 0.0 in pressure coordinate)
C ip1_vco_trl = 5 (hybrid levels)
C
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)
enddo
elseif(ip1_vco_trl .eq. 5 .or. ip1_vco_trl .eq. 2) then
do jlev = 1,itrlnlev
zlev_int(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,'PERT_VAROUT')
endif
c
if (cppcvar(jvar).eq.'UU'.or.cppcvar(jvar).eq.'VV') then
c
llwind = .true.
c
if (cppcvar(jvar).eq.'UU') then
clnomvar = 'VV'
else
clnomvar = 'UU'
endif
c
endif
c
c ** Prepare additional interpolation settings
c
if (itrlnlev.ne.0) then
c
ierr = ezgprm(itrlgid,clgrtyp,ini,inj,iig1,iig2,iig3,iig4)
c
if (cppcvar(jvar).eq.'UU'.or.cppcvar(jvar).eq.'VV') then
c
call getfldprm(IIP1S,IIP2,IIP3,IWINDNLEV,CLETIKET,CLTYPVAR
& ,IWINDGID,clnomvar,ibrpstamp,jpnflev,ninmpg(kfile_use)
& ,nulout,ip1_pak_trl,ip1_vco_trl)
c
c
ierr = ezgprm(iwindgid,clgrtypwind,iniwind,injwind
& ,iig1wind,iig2wind,iig3wind,iig4wind)
c
endif
endif
c
c ** Acquire perturbation fields on low resolution grid
c
ip1 = -1
jlev = 1
do while (jlev.le.nflev.and.ip1.ne.0 )
c
c Get the variable cppcvar(jvar) in zlowvar vector
c
call gdout2(cppcvar(jvar),ZLOWVAR(1,1,jlev),ni,nj
& ,jlev,llimplemented,IIP1S_INCLR(jlev))
c
c If variable cppcvar is not implemented skip to the next variable
c
if (.not.llimplemented) goto 200
c
if(cppcvar(jvar).eq.'HU' .and. .not. lhintdelhu) then
c
c Get the variable cppcvar(jvar) in zlowvar vector
c
call gdout2('LQ',ZLOWVAR(1,1,jlev),ni,nj
& ,jlev,llimplemented,IIP1S_INCLR(jlev))
c
endif
c
c If cppcvar is a wind component look for the other component
c
if(cppcvar(jvar).eq.'VV'.or.cppcvar(jvar).eq.'UU') then
c
call gdout2(clnomvar,ZLOWWIND(1,1,jlev),ni,nj,jlev
& ,llimplemented,IIP1S_INCLR(jlev))
c
c
endif
c
jlev = jlev + 1
c
enddo ! enddo while
c
c If the logical switch LANLHU2ES=.T., then the high resolution
C trial+pert of T-TD (ES) will be derived from the trial+pert
c of HU and TT.
c If the logical switch LANLHU2ES=.F., then the high resolution
C trial+pert of T-TD (ES) will be the sum of trial field of T-TD
C plus the high resolution perturbation T-TD. The resulting
C trial+pert of T-TD will NOT be consistent with the trial+pert of HU
c
if(cppcvar(jvar).eq.'ES'.and.lanlhu2es) then
llvarout = .false.
endif
c
if (itrlnlev.gt.1) then
inbrlev = nflev
else
inbrlev = 1
endif
c
c ** Interpolate perturbations to high resolution grid.
c
c First, horizontal interpolation.
c
if(itrlnlev.ne.0) then
if (cppcvar(jvar).eq. 'UU') then
c
call hintvec2(zlowvar,zlowwind,ni*nj,igdgid
& ,zhighvar,zhighwind
& ,ini*inj,itrlgid,inbrlev,'LINEAR')
c
elseif(cppcvar(jvar).eq.'VV') then
c
call hintvec2(zlowwind,zlowvar,ni*nj,igdgid
& ,zhighwind,zhighvar
& ,ini*inj,itrlgid,inbrlev,'LINEAR')
else
call hintscal(zlowvar,ni*nj,igdgid,
& zhighvar,ini*inj,itrlgid,inbrlev,'LINEAR')
endif
endif
c
c Vertical interpolation to trial levels and
c writing of pert+trial at each level.
c
if (itrlnlev.gt.1.and.llbasevar) then ! BEGIN 3D FIELDS
c
if (llvint) then
ierr = ezsetopt('INTERP_DEGREE','LINEAR')
iset = ezdefset(itrlgid,ip0gid)
ierr = vezsint(zps,zpstrl,ini,inj,1,ini,inj,1)
call calcpres(zpresanl,vhybinc,nflev,zps,rptopinc*rpatmb
& ,rprefinc*rpatmb,rcoefinc,ini*inj)
c
c Computation of pressure values on trial profiles of the high
c resolution horizonal grid
c
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
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
c
do jlev = 1, itrlnlev
do jcol = 1, ini*inj
zvhvar((jlev-1)*ini*inj+jcol) =
& zhighvar((jlev-1)*ini*inj+jcol)
enddo
enddo
end if
c
if(cppcvar(jvar).ne.'HU') then
do jlev = 1,itrlnlev
c
c Look for corresponding trial field
c
ikey = FSTINF(ninmpg(kfile_use), INI, INJ, INK, ibrpstamp, cletiket
& ,iip1s_trl(jlev), iip2, iip3
& ,cltypvar,cppcvar(jvar))
c
if (ikey.lt.0) then
c
write(nulout,*) 'Problems finding variable '
& ,cppcvar(jvar),' at level ',zlev_trl(jlev)
& ,' in trial file'
c
c May skip field if not in trial field file.
c
if (jlev.eq.1) go to 200
call abort3d(nulout,'PERT_VAROUT')
endif
c
ikey = VFSTLUK(zhighvar,ikey, INI, INJ, INK)
c
c Use CLNOMVAR2 below to avoid conflict with CLNOMVAR
c setting when cppcvar(jvar) is .UU. or .VV.
c
ierr = FSTPRM(ikey, IDATEO, IDEET, IPAS, INI, INJ, INK,
& INBITSTR,IDATYP,IP1,IP2, IP3, CLTYPVAR, CLNOMVAR2,
& CLETIKET, CLGRTYP,IG1, IG2,IG3,IG4, ISWA,
& ILENGTH, IDLTF, IUBC, IEXTR1,IEXTR2,IEXTR3)
c
c Writing perturbation field
c
if(iunMpert.ne.0) then
IERR = VFSTECR(zvhvar((jlev-1)*ini*inj+1),zwork
& ,inpak_anl(jvar),iunMpert,idateo,ideet,ipas,ini
& ,inj,1,ip1,ip2,ip3,cltypinc
& ,cppcvar(jvar),cetikinc,clgrtyp,ig1,ig2,ig3
& ,ig4,idatyp,.true.)
end if
c
c Sum of perturbation and trial field
c
do jcol = 1, ini*inj
zvhvar((jlev-1)*ini*inj+jcol) = zhighvar(jcol) +
& zvhvar((jlev-1)*ini*inj+jcol)
c
if(cppcvar(jvar).eq.'TT'.and.(lhuout.or.lvtout.or
& .lgzout)) then
zttvar((jlev-1)*ini*inj+jcol) = zvhvar((jlev-1)*ini
& *inj+jcol)
endif
enddo
c
c Writing trial+pert field
c
IERR = VFSTECR(zvhvar((jlev-1)*ini*inj+1),zwork
& ,inpak_anl(jvar),iunM,idateo,ideet,ipas,ini
& ,inj,1,ip1,ip2,ip3,cltypvar
& ,cppcvar(jvar),cletiket,clgrtyp,ig1,ig2,ig3
& ,ig4,idatyp,.true.)
enddo
endif
c
if(cppcvar(jvar).eq.'VV'.or.cppcvar(jvar).eq.'UU') then
c
c Account for second wind component in
c vertical interpolation to trial levels
c
if (llvint) then
ierr = ezsetopt('INTERP_DEGREE','LINEAR')
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
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
c Writing to standard files
c
do jlev = 1,itrlnlev
c
c Look for corresponding trial field
c
ikey = FSTINF(ninmpg(kfile_use), 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,'PERT_VAROUT')
endif
c
ikey = VFSTLUK(zhighvar,ikey, INI, INJ, INK)
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
c Writing perturbation field
c
if(iunMpert.ne.0) then
IERR = VFSTECR(zvhvar((jlev-1)*ini*inj+1),zwork
& ,inpak_anl(jvar),iunMpert,idateo,ideet,ipas,ini
& ,inj,1,ip1,ip2,ip3,cltypinc
& ,clnomvar,cetikinc,clgrtyp,ig1,ig2,ig3
& ,ig4,idatyp,.true.)
end if
c
c Sum of perturbation and trial field
c
do jcol = 1, ini*inj
zvhvar((jlev-1)*ini*inj+jcol) = zhighvar(jcol) +
& zvhvar((jlev-1)*ini*inj+jcol)
enddo
c
c Writing trial+pert field
c
IERR = VFSTECR(zvhvar((jlev-1)*ini*inj+1),zwork
& ,inpak_anl(jvar),iunM,idateo,ideet,ipas,ini
& ,inj,1,ip1,ip2,ip3,cltypvar
& ,clnomvar,cletiket,clgrtyp,ig1,ig2,ig3
& ,ig4,idatyp,.true.)
enddo
endif
c
if(cppcvar(jvar).eq.'HU') then
ierr = ezsetopt('INTERP_DEGREE','LINEAR')
iset = ezdefset(itrlgid,ip0gid)
c
c Interpolation of trial surface pressure on HU grid
c
ierr = vezsint(zps,zpsanl,ini,inj,1,ini,inj,1)
c
c Computation of pressure values on eta trial levels based
c on trial+pert P0
c
call calcpres(zprestrl,zlev_int,itrlnlev,zps,zptophr
& ,zprefhr,zrcoefhr,ini*inj)
c
do jlev = 1,itrlnlev
c
c Look for corresponding trial field
c
ikey = FSTINF(ninmpg(kfile_use), INI, INJ, INK, ibrpstamp, cletiket
& ,iip1s_trl(jlev), iip2, iip3
& ,cltypvar,cppcvar(jvar))
c
if (ikey.lt.0) then
write(nulout,*) 'Problems finding variable '
& ,cppcvar(jvar),' at level ',zlev_trl(jlev)
& ,' in trial file'
call abort3d(nulout,'PERT_VAROUT')
endif
c
ikey = VFSTLUK(zhighvar,ikey, INI, INJ, INK)
c
c Sum of perturbation and trial field
c
if (lhintdelhu) then
do jcol = 1, ini*inj
zvhvar((jlev-1)*ini*inj+jcol) = max(zhighvar(jcol)
& ,1.0D-12) +zvhvar((jlev-1)*ini*inj+jcol)
enddo
else
do jcol = 1, ini*inj
zvhvar((jlev-1)*ini*inj+jcol) =
& exp(
& log(max(zhighvar(jcol),1.0D-12))
& + zvhvar((jlev-1)*ini*inj+jcol))
enddo
endif
c
c Get the trial specific humidity for increment ajustment
c
do jcol = 1, ini*inj
ztrlq((jlev-1)*ini*inj+jcol) = zhighvar(jcol)
c
c CAREFULL: zprofo is now re-used as re-alligned
c pressure vector for use with AJHUM
c Note: zprestrl contains pressure column based
c on corrected surface pressure
c
zprofo((jlev-1)*ini*inj+jcol) =
& zprestrl((jcol-1)*itrlnlev+jlev)
enddo
end do
c
c CAREFULL: un-adjusted trial specific humidity
c copied in variable zprestrl
c
do jlev = 1,itrlnlev
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)
enddo
enddo
ilimlvhu=nint(rlimlvhu)
c
c Trial specific humidity adjustment (zprestrl)
c
call AJHUM(zprofo,zttvar,zprestrl,zvtvar,zwrkvec,ini,inj
& ,itrlnlev,zlev_trl,llclip)
c
c Specific humidity adjustment (zvhvar)
c
call AJHUM(zprofo,zttvar,zvhvar,zvtvar,zwrkvec,ini,inj
& ,itrlnlev,zlev_trl,llclip)
c
c T-Td trial after adjustments (zesvar)
c
if(lanlhu2es) then
c ES analysis calculation and writing
c zhvar = specific humidity;
c zwrkvec= true temperature in kelvin
c zttvar = true temperature in celsius
c zprofo = pressure in mb
c zincq = pressure in pascal
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
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
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
enddo
c
c Computation of new specific humidity analysis based on adjusted
c perturbation:
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 adjusted HU
c
CALL MFOTVT8(ztrlq,zwrkvec,zanlq,ini*inj,itrlnlev,ini*inj)
do jlev = 1,itrlnlev
do jcol = 1, ini*inj
ztrlq((jlev-1)*ini*inj+jcol) =
& ztrlq((jlev-1)*ini*inj+jcol) -
& zwrkvec((jlev-1)*ini*inj+jcol)
ENDDO
ENDDO
c
if (lgzout) then
c
c Looking for topography
c
ikey = FSTINF(ninmpg(kfile_use), 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,'PERT_VAROUT')
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)
c
c Write to standard files
c
ikey = FSTINF(ninmpg(kfile_use), INI, INJ, INK, ibrpstamp, cletiket
& ,iip1s_trl(1), iip2, iip3
& ,cltypvar,cppcvar(jvar))
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)
do jlev = 1,itrlnlev
c
c Writing adjusted HU perturbation field
c
IERR = VFSTECR(zincq((jlev-1)*ini*inj+1),zwork
& ,inpak_anl(jvar),iunMpert,idateo,ideet,ipas,ini
& ,inj,1,iip1s_trl(jlev),ip2,ip3,cltypvar
& ,cppcvar(jvar),cetikinc,clgrtyp,ig1,ig2,ig3
& ,ig4,idatyp,.true.)
c
c Writing trial+pert fields (HU, VT, ES, GZ)
c
IERR = VFSTECR(zvhvar((jlev-1)*ini*inj+1),zwork
& ,inpak_anl(jvar),iunM,idateo,ideet,ipas,ini
& ,inj,1,iip1s_trl(jlev),ip2,ip3,cltypvar
& ,cppcvar(jvar),cletiket,clgrtyp,ig1,ig2,ig3
& ,ig4,idatyp,.true.)
c
if(lvtout) then
c
c VT writing
c
IERR = VFSTECR(zvtvar((jlev-1)*ini*inj+1),zwork
& ,inpak_vt,iunM,idateo,ideet,ipas,ini,inj
& ,1,iip1s_trl(jlev),ip2,ip3,cltypvar,'VT'
& ,cletiket,clgrtyp,ig1,ig2,ig3,ig4,idatyp
& ,.true.)
endif
c
IF(LANLHU2ES) THEN
c
c ES writing
c
IERR = VFSTECR(zesvar((jlev-1)*ini*inj+1),zwork
& ,inpak_vt,iunM,idateo,ideet,ipas,ini,inj
& ,1,iip1s_trl(jlev),ip2,ip3,cltypvar,'ES'
& ,cletiket,clgrtyp,ig1,ig2,ig3,ig4,idatyp
& ,.true.)
ENDIF
c
if(lgzout) then
c
c GZ writing
c
IERR = VFSTECR(zgzvar((jlev-1)*ini*inj+1),zwork
& ,inpak_gz,iunM,idateo,ideet,ipas,ini,inj
& ,1,iip1s_trl(jlev),ip2,ip3,cltypvar,'GZ'
& ,cletiket,clgrtyp,ig1,ig2,ig3,ig4,idatyp
& ,.true.)
endif
enddo
endif
endif
c
elseif(itrlnlev.eq.1) then ! BEGIN 2D FIELDS
c
c Looking for corresponding trial field
c
ikey = fstinf(ninmpg(kfile_use), 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,'PERT_VAROUT')
endif
c
ikey = vfstluk(zvhvar,ikey, INI, INJ, INK)
c
ierr = FSTPRM(ikey, IDATEO, IDEET, IPAS, 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 Writing perturbation field
c
if (iunMpert.ne.0) then
IERR = VFSTECR(zhighvar,zwork
& ,inpak_anl(jvar),iunMpert,idateo,ideet,ipas,ini
& ,inj,1,ip1,ip2,ip3,cltypinc
& ,cppcvar(jvar),cetikinc,clgrtyp,ig1,ig2,ig3
& ,ig4,idatyp,.true.)
end if
c
c Sum of perturbations and trial field
c
if(cppcvar(jvar).eq.'P0') then
llp0 = .true.
CALL HPALLOC(pzlnpsanl,MAX(INI*INJ,1),IERR,8)
CALL HPALLOC(pzlnpsincr,MAX(INI*INJ,1),IERR,8)
do jcol = 1, ini*inj
zhighvar(jcol) = zvhvar(jcol) + zhighvar(jcol)
zpsanl(jcol) = zhighvar(jcol)
zlnpsanl(jcol) = dlog(zhighvar(jcol))
zlnpsincr(jcol) = zlnpsanl(jcol)-dlog(zvhvar(jcol))
enddo
else
do jcol = 1, ini*inj
zhighvar(jcol) = zvhvar(jcol) + zhighvar(jcol)
enddo
endif
c
c Writing trial+pert field
c
if (iunMpert.ne.0.and.cppcvar(jvar).eq.'P0') then
IERR = VFSTECR(zlnpsincr,zwork,
& inpak_anl(jvar),iunMpert,idateo,ndeet,npas
& ,ini,inj,1,ip1,ip2,ip3,cltypinc
& ,'LNPS',cetikinc,clgrtyp,ig1,ig2,ig3,ig4
& ,idatyp,.true.)
call hpdeallc(pzlnpsincr,ierr,1)
end if
C
IERR = VFSTECR(zhighvar,zwork
& ,inpak_anl(jvar),iunM,idateo,ideet,ipas,ini
& ,inj,1,ip1,ip2,ip3,cltypvar
& ,cppcvar(jvar),cletiket,clgrtyp,ig1,ig2,ig3
& ,ig4,idatyp,.true.)
C
if (cppcvar(jvar).eq.'P0') then
IERR = VFSTECR(zlnpsanl,zwork
& ,inpak_anl(jvar),iunM,idateo,ideet,ipas,ini
& ,inj,1,ip1,ip2,ip3,cltypvar
& ,'LNPS',cletiket,clgrtyp,ig1,ig2,ig3
& ,ig4,idatyp,.true.)
call hpdeallc(pzlnpsanl,ierr,1)
end if
endif ! END 3D FIELDS and 2D FIELDS
c
if (clgrtyp.eq.'Z') then
c
c Writing positional parameters
c
cletiket = ' '
cltypvar = ' '
ikey = FSTINF(ninmpg(kfile_use), iNI, iNJ, iNK, -1,cletiket, iig1
& ,iig2,iig3,cltypvar,'>>')
c
ierr = fstprm(ikey,idateo,ideet,ipas,ini,inj,ink, inbits,
& idatyp,ip1,ip2,ip3,cltypvar,clnomvar,cletiket,clgrtyp
& ,ig1,ig2,ig3,ig4,iswa,ilength,idltf,iubc,iextr1
& ,iextr2,iextr3)
c
ikey = VFSTLUK(zhighvar, ikey, iNI, iNJ, iNK)
c
if(iunM.ne.ninmpg(kfile_use)) then
ierr = vfstecr(zhighvar, zwork, -inbits, iunM, idateo
& ,ideet,ipas, ini, inj, ink, ip1, ip2, ip3, cltypvar
& ,clnomvar,cletiket,clgrtyp,ig1, ig2, ig3, ig4, idatyp
& ,.true.)
endif
if(iunMpert.ne.0) then
ierr = vfstecr(zhighvar, zwork, -inbits, iunMpert, idateo
& ,ideet,ipas, ini, inj, ink, ip1, ip2, ip3, cltypvar
& ,clnomvar,cetikinc,clgrtyp,ig1, ig2, ig3, ig4, idatyp
& ,.true.)
endif
c
cletiket = ' '
cltypvar = ' '
ikey = FSTINF(ninmpg(kfile_use), iNI, iNJ, iNK, -1,cletiket, iig1
& ,iig2,iig3,cltypvar,'^^')
c
ierr = fstprm(ikey,idateo,ideet,ipas,ini,inj,ink, inbits
& ,idatyp,ip1,ip2,ip3,cltypvar,clnomvar,cletiket,clgrtyp
& ,ig1,ig2,ig3,ig4,iswa,ilength,idltf,iubc,iextr1
& ,iextr2,iextr3)
c
ikey = VFSTLUK(zhighvar, ikey, iNI, iNJ, iNK)
c
if(iunM.ne.ninmpg(kfile_use)) then
ierr = vfstecr(zhighvar, zwork, -inbits, iunM, idateo
& ,ideet,ipas, ini, inj, ink, ip1, ip2, ip3, cltypvar
& ,clnomvar,cletiket,clgrtyp,ig1, ig2, ig3, ig4, idatyp
& ,.true.)
endif
if(iunMpert.ne.0) then
ierr = vfstecr(zhighvar, zwork, -inbits, iunMpert, idateo
& ,ideet,ipas, ini, inj, ink, ip1, ip2, ip3, cltypvar
& ,clnomvar,cetikinc,clgrtyp,ig1, ig2, ig3, ig4, idatyp
& ,.true.)
endif
c
if(cppcvar(jvar).eq.'VV'.or.cppcvar(jvar).eq.'UU') then
c
cletiket = ' '
cltypvar = ' '
ikey = FSTINF(ninmpg(kfile_use), iNI, iNJ, iNK, -1,cletiket, iig1wind
& ,iig2wind,iig3wind,cltypvar,'>>')
c
ierr = fstprm(ikey,idateo,ideet,ipas,ini,inj,ink
& ,inbits,idatyp,ip1,ip2,ip3,cltypvar,clnomvar
& ,cletiket,clgrtyp,ig1,ig2,ig3,ig4,iswa,ilength
& ,idltf,iubc,iextr1,iextr2,iextr3)
c
ikey = VFSTLUK(zhighvar, ikey, iNI, iNJ, iNK)
c
if(iunM.ne.ninmpg(kfile_use)) then
ierr = vfstecr(zhighvar, zwork, -inbits, iunM, idateo
& ,ideet,ipas, ini, inj, ink, ip1, ip2, ip3,cltypvar
& ,clnomvar,cletiket,clgrtyp,ig1, ig2, ig3, ig4
& ,idatyp,.true.)
endif
if(iunMpert.ne.0) then
ierr = vfstecr(zhighvar, zwork, -inbits, iunMpert, idateo
& ,ideet,ipas, ini, inj, ink, ip1, ip2, ip3,cltypvar
& ,clnomvar,cetikinc,clgrtyp,ig1, ig2, ig3, ig4
& ,idatyp,.true.)
endif
c
cletiket = ' '
cltypvar = ' '
ikey = FSTINF(ninmpg(kfile_use), iNI, iNJ, iNK, -1,cletiket, iig1wind
& ,iig2wind,iig3wind,cltypvar,'^^')
c
ierr = fstprm(ikey,idateo,ideet,ipas,ini,inj,ink
& ,inbits,idatyp,ip1,ip2,ip3,cltypvar,clnomvar
& ,cletiket,clgrtyp,ig1,ig2,ig3,ig4,iswa,ilength
& ,idltf,iubc,iextr1,iextr2,iextr3)
c
ikey = VFSTLUK(zhighvar, ikey, iNI, iNJ, iNK)
c
if(iunM.ne.ninmpg(kfile_use)) then
ierr = vfstecr(zhighvar, zwork, -inbits, iunM, idateo
& ,ideet,ipas, ini, inj, ink, ip1, ip2, ip3,cltypvar
& ,clnomvar,cletiket,clgrtyp,ig1, ig2, ig3, ig4
& ,idatyp,.true.)
endif
if(iunMpert.ne.0) then
ierr = vfstecr(zhighvar, zwork, -inbits, iunMpert, idateo
& ,ideet,ipas, ini, inj, ink, ip1, ip2, ip3,cltypvar
& ,clnomvar,cetikinc,clgrtyp,ig1, ig2, ig3, ig4
& ,idatyp,.true.)
endif
endif
endif
endif
c
200 enddo
c
c--- Deallocation of local arrays (Abort on error)
c
call hpdeallc(pzhighvar,ierr,1)
call hpdeallc(pzhighwind,ierr,1)
call hpdeallc(pxpresanl,ierr,1)
call hpdeallc(pxprofi,ierr,1)
call hpdeallc(pxprofo,ierr,1)
call hpdeallc(pxprestrl,ierr,1)
call hpdeallc(pxvhvar,ierr,1)
call hpdeallc(pxttvar,ierr,1)
call hpdeallc(pxtrlq,ierr,1)
call hpdeallc(pxincq,ierr,1)
call hpdeallc(pxanlq,ierr,1)
call hpdeallc(pxvtvar,ierr,1)
call hpdeallc(pxwrkvec,ierr,1)
call hpdeallc(pxesvar,ierr,1)
call hpdeallc(pxgzvar,ierr,1)
call hpdeallc(pxgzvar2,ierr,1)
call hpdeallc(pxpsanl,ierr,1)
call hpdeallc(pxpstrl,ierr,1)
call hpdeallc(pzlowvar,ierr,1)
call hpdeallc(pxtopo,ierr,1)
call hpdeallc(pzlowwind,ierr,1)
call hpdeallc(pxps,ierr,1)
call hpdeallc(pxptop,ierr,1)
deallocate(inpak_anl)
c
c--- Close RPN files
c
ierr = fstfrm(iunMpert)
if(ier.lt.0)write(nulout,*)'iunMpert fstfrm error', ierr
ierr = fclos(iunMpert)
if(ier.lt.0) write(nulout,*)'iunMpert fclos error', ierr
write(nulout,*) 'Unit number freed: ',iunMpert
c
if (iunM.ne.ninmpg(kfile_use)) then
ierr = fstfrm(iunM)
if(ier.lt.0)write(nulout,*)'iunM fstfrm error', ierr
ierr = fclos(iunM)
if(ier.lt.0) write(nulout,*)'iunM fclos error', ierr
write(nulout,*) 'Unit number freed: ',iunM
end if
c
write(nulout,*) 'END of PERT_VAROUT'
c
RETURN
END