subroutine pertbg1 1,33
#if defined (DOC)
*
***s/r pertbg - Perturb background fields to account for model error in Monte Carlo cycle
*
*
*Author : M. Buehner *ARMA/MSC Aor 2003
*Revision: Yulia Nezlin
* - Added an option for creation of the background error sample
* in accordance with specified background error covariance matrix.
*
* If LmodelEr=.false. then the settting of background errors
* does not include application of the 'model error' estimation
* procedure.
* If LmodelEr=true. then the background error sample will be scaled
* according to the 'model error' estimation procedure (M.Buehner)
*
* Y. Yang ARQI Feb. 2010
* - replace calls to linear forward operators lobsppp, lobssfc, .. lvgoes by ODA
* wrapper oda_H to be consistent with ODA conventions.
*
* -------------------
** Purpose: *
* . *
* . *
* . *
* . *
*
*Arguments
* -NONE-
#endif
IMPLICIT NONE
*implicits
#include "comct0.cdk"
#include "pardim.cdk"
#include "comdim.cdk"
#include "com1obs.cdk"
#include "comlun.cdk"
#include "comgem.cdk"
#include "comdimo.cdk"
#include "commvo.cdk"
#include "commvohr.cdk"
#include "commvog.cdk"
#include "comoabdy.cdk"
#include "comoahdr.cdk"
#include "comoba.cdk"
#include "comvarqc.cdk"
#include "comcva.cdk"
#include "cparbrp.cdk"
#include "cominterp.cdk"
#include "comcst.cdk"
#include "comrand.cdk"
#include "localpost.cdk"
#include "comgdpar.cdk"
#include "rpnstd.cdk"
#include "comnumbr.cdk"
#include "cvcord.cdk"
#include "comgd0.cdk"
#include "comsp.cdk"
#include "comspg.cdk"
#include "compost.cdk"
#include "comfilt.cdk"
#include "comleg.cdk"
#include "comstato.cdk"
c
integer jk,jk2,ii,jj,kulcntl,jdata,jobs,iobs,nsamphbht,jsamp,remove_c
integer numst,jvar,jrec,jloc,klevel,jk1,kulfile,kultemp,kultime,kchan
integer klat,klon,isrchila,klatlist(1000),klonlist(1000),jkinnov(10)
integer jregion,klatn,klatn2,klats,klats2,nonzero
integer ik,ipt,ipb,ketalev(ndata),kusetune1(ndata),kusetune2(ndata)
real*8 zzpt,zzpb,zwt,zwb,ww(10),alphatime,zapfact
real*8 varinntt(nflev),varinnuu(nflev),varinnvv(nflev),varinnbt(nflev)
real*8 avginntt(nflev),avginnuu(nflev),avginnvv(nflev),avginnbt(nflev)
real*8 varobstt(nflev),varobsuu(nflev),varobsvv(nflev),varobsbt(nflev)
real*8 zjo,dla2,zfacttt(nflev,3),zfactuu(nflev,3),zfactvv(nflev,3),zfactbt(nflev,3)
real*8 zfactttold(nflev,3),zfactuuold(nflev,3),zfactvvold(nflev,3),zfactbtold(nflev,3)
real*8 zfactuu2(nflev,nj),zfactvv2(nflev,nj),zfacttt2(nflev,nj),zfactbt2(nflev,nj)
real*8 zlon,zlat,zlat1,zlat2,zpress(nflev),ptop,zwork,ztemp
integer knttt(nflev,3),kntuu(nflev,3),kntvv(nflev,3),kntbt(nflev,3)
integer kntttver(nflev,3),kntuuver(nflev,3),kntvvver(nflev,3),kntbtver(nflev,3)
integer kntttavg(nflev,3),kntuuavg(nflev,3),kntvvavg(nflev,3),kntbtavg(nflev,3)
integer kntttold(nflev,3),kntuuold(nflev,3),kntvvold(nflev,3),kntbtold(nflev,3)
character str1,strlat,strlon
character*5 str5
logical lexist
real*8 gasdev,varprett(nflev),varpreuu(nflev),varprevv(nflev),varprebt(nflev),zfact
real*8 zfactuv,zfact1,zfact2,zfact3,zfact4,zprestovs(10)
real*8 zcmaobs(ndata),zcmabg(ndata),zcmacntl(ndata),zcmapert(ndata)
real*8 zcmapertmean(ndata),zcmapertstd(ndata)
real*8 varhbhtt(nflev),varhbhuu(nflev),varhbhvv(nflev),varhbhbt(nflev)
real*8 ztrans(ni,nj,nflev),zvvg2(ni,nj,nflev),zvvc2(ni,nj,nflev)
real*8 ztrans2(ni,nj)
pointer (pxtrans,ztrans),(pxvvg2,zvvg2),(pxtrans2,ztrans2)
integer idatebrp,itimebrp
integer ifind,newdate,ilen
real*8 zjoraob,zjoairep,zjosatwind,zjosurfc,zjosfcsf,zjosfcua,zjotov,zjogoes
real*8 ztodeg,ztorad
external gasdev
integer kfile_use
c
call printrev("SUBROUTINE pertbg :",19)
ii = newdate(nbrpstamp,idatebrp,itimebrp,-3)
print *,'NBRPSTAMP=',nbrpstamp
print *,'idate=',idatebrp
print *,'itime=',itimebrp
itimebrp=int(float(itimebrp)/1000000.0)
print *,'itime=',itimebrp
ztodeg = 1.d0/(rpi/180.d0)
ztorad = 1.d0/ztodeg
nsamphbht=10
c
c Allocate local arrays including localpost.cdk
c
ilen = ni*nflev*nj
call hpalloc(pxtrans,max(1,ilen),ierr,8)
call hpalloc(pxtrans2,max(1,ni*nj),ierr,8)
c
call hpalloc(pxttg,max(1,ilen),ierr,8)
call hpalloc(pxhug,max(1,ilen),ierr,8)
call hpalloc(pxuug,max(1,ilen),ierr,8)
call hpalloc(pxvvg,max(1,ilen),ierr,8)
call hpalloc(pxpp,max(1,ilen),ierr,8)
call hpalloc(pxqq,max(1,ilen),ierr,8)
call hpalloc(pxcc,max(1,ilen),ierr,8)
call hpalloc(pxqr,max(1,ilen),ierr,8)
call hpalloc(pxdd,max(1,ilen),ierr,8)
call hpalloc(pxttb,max(1,ilen),ierr,8)
call hpalloc(pxttu,max(1,ilen),ierr,8)
call hpalloc(pxtv,max(1,ilen),ierr,8)
call hpalloc(pxgz,max(1,ilen),ierr,8)
call hpalloc(pxgzb,max(1,ilen),ierr,8)
call hpalloc(pxgzu,max(1,ilen),ierr,8)
call hpalloc(pxes,max(1,ilen),ierr,8)
call hpalloc(pxesg,max(1,ilen),ierr,8)
call hpalloc(pxhu,max(1,ilen),ierr,8)
call hpalloc(pxo3,max(1,ni*nj),ierr,8)
call hpalloc(pxpsg,max(1,ni*nj),ierr,8)
call hpalloc(pxtgg,max(1,ni*nj),ierr,8)
call hpalloc(pxpsb,max(1,ni*nj),ierr,8)
call hpalloc(pxtgb,max(1,ni*nj),ierr,8)
call hpalloc(pxpsu,max(1,ni*nj),ierr,8)
call hpalloc(pxpt,max(1,ni*nj),ierr,8)
*
call zero(ilen,zqq(1,1,1))
call zero(ilen,zqr(1,1,1))
call zero(ilen,zpp(1,1,1))
call zero(ilen,zdd(1,1,1))
call zero(ilen,zcc(1,1,1))
call zero(ilen,zuug(1,1,1))
call zero(ilen,zvvg(1,1,1))
call zero(ilen,zttg(1,1,1))
call zero(ilen,zttb(1,1,1))
call zero(ilen,zttu(1,1,1))
call zero(ilen,ztv(1,1,1))
call zero(ilen,zgz(1,1,1))
call zero(ilen,zgzb(1,1,1))
call zero(ilen,zgzu(1,1,1))
call zero(ilen,zes(1,1,1))
call zero(ilen,zesg(1,1,1))
call zero(ilen,zhu(1,1,1))
call zero(ilen,zhug(1,1,1))
call zero(ni*nj,zo3(1,1))
call zero(ni*nj,zpsg(1,1))
call zero(ni*nj,ztgg(1,1))
call zero(ni*nj,zpsb(1,1))
call zero(ni*nj,ztgb(1,1))
call zero(ni*nj,zpsu(1,1))
call zero(ni*nj,zpt(1,1))
c
c initialize pressure levels corresponding to TOVS channels
c
zprestovs(3)=62500.0
zprestovs(4)=61000.0
zprestovs(5)=43000.0
zprestovs(6)=29000.0
zprestovs(7)=14000.0
zprestovs(8)=12000.0
zprestovs(9)= 7000.0
zprestovs(10)=3700.0
c
c initialize random number generator seed
c
inquire(file='./randnum.dat',
+ exist=lexist)
if(lexist) then
open(unit=39,form='unformatted',file='./randnum.dat')
read(39) (rrand(jj),jj=1,97)
read(39) ix1,ix2,ix3,iff
close(39)
write(nulout,*) 'READING IN RANDNUM'
endif
c
c Produce samples directly using B
c
if(npertbg.eq.1) then
c Random perturbation
write(nulout,*)'pertBg gasdev=',gasdev(1),gasdev(1)
do jj=1,nvadim
vazx(jj)=gasdev(1)
enddo
call cain(nvadim,vazx)
call spa2sp
call spgd
endif
if(npertbg.eq.3) then
kulfile=0
cc ierr = fnom(kulfile,'/users/dor/arma/bue/gpfs/Bsamples.fst',
ierr = fnom(kulfile,'./Bsamples.fst',
+ 'RND',0)
if(ierr.ge.0)then
ierr = fstouv(kulfile,'RND')
else
call abort3d(nulout,'Bsamples.fst:PROBLEM WITH FILE')
endif
npak=-16
do jsamp=1,1 !128
c Random perturbation
write(nulout,*)'pertBg gasdev=',gasdev(1),gasdev(1)
do jj=1,nvadim
vazx(jj)=gasdev(1)
enddo
call cain(nvadim,vazx)
call spa2sp
call spgd
call postproc(kulfile,jsamp,'GRID','B_SAMPLE')
enddo
ierr = fstfrm(kulfile)
ierr = fclos(kulfile)
call abort3d(nulout,'finished with Bsamples.fst')
endif
IF(LMODELER) THEN
c
c Read in previous factors for time filtering
c
kultime=0
c inquire(file='/users/dor/arma/bue/gpfs/data/timefilt.bin',exist=lexist)
inquire(file='./timefilt.bin',exist=lexist)
ierr = fnom(kultime,'./timefilt.bin','FTN+SEQ+UNF',0)
c ierr = fnom(kultime,'/users/dor/arma/bue/gpfs/data/timefilt.bin','FTN+SEQ+UNF',0)
if(lexist.and.ierr.ge.0) then
write(nulout,*) 'READING OLD SCALE FACTORS FOR TIME FILTERING'
read(kultime) zfactttold,zfactuuold,zfactvvold,zfactbtold
read(kultime) kntttold, kntuuold, kntvvold, kntbtold
else
write(nulout,*) 'NO FILE OF OLD SCALE FACTORS FOR TIME FILTERING'
do jregion=1,3
do jk=1,nflev
kntttold(jk,jregion)=0
kntuuold(jk,jregion)=0
kntvvold(jk,jregion)=0
kntbtold(jk,jregion)=0
zfactttold(jk,jregion)=0.0d0
zfactuuold(jk,jregion)=0.0d0
zfactvvold(jk,jregion)=0.0d0
zfactbtold(jk,jregion)=0.0d0
enddo
enddo
endif
ierr=fclos(kultime)
ierr=remove_c('/users/tor/arpx/yna/timefilt.bin')
c ierr=remove_c('/users/dor/arma/bue/gpfs/data/timefilt.bin')
c
c print out profiles
c
do jregion=1,3
do jk=1,nflev
write(86,*) jk,jregion,kntttold(jk,jregion),zfactttold(jk,jregion)
enddo
do jk=1,nflev
write(86,*) jk,jregion,kntuuold(jk,jregion),zfactuuold(jk,jregion)
enddo
do jk=1,nflev
write(86,*) jk,jregion,kntvvold(jk,jregion),zfactvvold(jk,jregion)
enddo
do jk=1,nflev
write(86,*) jk,jregion,kntbtold(jk,jregion),zfactbtold(jk,jregion)
enddo
enddo !end loop on regions
call flush(86)
c
c Save contents of CMA (observed values)
c
do jdata = 1, ndata
zcmaobs(jdata)=robdata8(ncmvar,jdata)
robdata8(ncmvar,jdata)=0.0
robdata8(ncmoma,jdata)=-888.0
enddo
c
c Read in trial field and store in CMA structure (from perturbed cycle)
c
call sugomobs
call mhuaesvhr
call tt2phihr
if (ltopofilt) then
call sobssfc
call sobsraob
call sobsaisw
endif
if(nconf .eq. 141 .or. nint(nconf/100.0).eq.6
+ .or. nint(nconf/100.0).eq.7) call sfcwndzap
call vobslyrs('HR')
zjoraob = 0.0d0
call dobsppp(zjoraob,'UA')
zjoairep=0.0d0
call dobsppp(zjoairep,'AI')
zjosatwind=0.0d0
call dobsppp(zjosatwind,'SW')
zjosurfc=0.0d0
zjosfcsf=0.0d0
zjosfcua=0.0d0
call dobssfc(zjosfcsf,'SF')
call dobssfc(zjosfcua,'UA')
zjosurfc = zjosfcua + zjosfcsf
zjotov=0.0d0
call TOVS_OBS ('HR',ZJOTOV)
zjogoes=0.0d0
call dobsgoes(zjogoes)
write(nulout,'(a15,G12.6)') 'JORAOB= ',ZJORAOB
write(nulout,'(a15,G12.6)') 'JOAIREP= ',ZJOAIREP
write(nulout,'(a15,G12.6)') 'JOSURFC= ',ZJOSURFC
write(nulout,'(a15,G12.6)') 'JOTOV= ',ZJOTOV
write(nulout,'(a15,G12.6)') 'JOGOES= ',ZJOGOES
write(nulout,'(a15,G12.6)') 'JOSATWIND= ',ZJOSATWIND
c
c Only use UA family, pressure level obs for tuning
c
do jdata = 1, ndata
kusetune1(jdata)=0
enddo
do jj=1,nfiles
if ((cfamtyp(jj).eq.'UA'.or.cfamtyp(jj).eq.'TO')
+ .and.(nbegintyp(jj).gt.0)) then
do jdata=nbegintyp(jj),nendtyp(jj)
if(cfamtyp(jj).eq.'UA'
& .and. mobdata(ncmvco,jdata) .eq. 2
& .and. mobdata(ncmass,jdata) .eq. 1
& .and. mobdata(ncmxtr,jdata) .eq. 0) then
kusetune1(jdata)=1
elseif(cfamtyp(jj).eq.'TO'
& .and.mobdata(ncmass,jdata).eq.1) then
kusetune1(jdata)=2
endif
enddo
endif
enddo
c
c undo normalization wrt ncmoer and store (obs already set to zero)
c
do jdata = 1, ndata
zcmabg(jdata)=robdata8(ncmoma,jdata)*robdata8(ncmoer,jdata)
robdata8(ncmoma,jdata)=-888.0
enddo
c
c Read in control forecast
c (Patch in 3D-Var launch script should copy control forecast into cntl.fst)
kulcntl=0
ierr=fnom(kulcntl,'./cntl.fst','RND+OLD',0)
c ierr=fnom(kulcntl,'/users/dor/arma/bue/gpfs/data/cntl.fst','RND+OLD',0)
if ( ierr .ne. 0 ) then
write(nulout,*) 'CONTROL - File : cntl.fst'
write(nulout,*) ' NOT FOUND SKIPPING THIS...'
goto 999
endif
write(nulout,*) 'CONTROL - File : cntl.fst'
write(nulout,*) ' opened as unit file ',kulcntl
ierr = fstouv(kulcntl,'RND')
c switch unit numbers to make sugomobs read cntl.fst instead of trlm
c
c since there can now be multipal trial fields, use the middle one if
c there is more than one
C
kfile_use= max(ntrials/2, 1)
kultemp=ninmpg(kfile_use)
ninmpg(kfile_use)=kulcntl
c
c Read in trial field and store in CMA structure
c
call sugomobs
call mhuaesvhr
call tt2phihr
if (ltopofilt) then
call sobssfc
call sobsraob
call sobsaisw
endif
if(nconf .eq. 141 .or. nint(nconf/100.0).eq.6
+ .or. nint(nconf/100.0).eq.7) call sfcwndzap
call vobslyrs('HR')
zjoraob = 0.0d0
call dobsppp(zjoraob,'UA')
zjoairep=0.0d0
call dobsppp(zjoairep,'AI')
zjosatwind=0.0d0
call dobsppp(zjosatwind,'SW')
zjosurfc=0.0d0
zjosfcsf=0.0d0
zjosfcua=0.0d0
call dobssfc(zjosfcsf,'SF')
call dobssfc(zjosfcua,'UA')
zjosurfc = zjosfcua + zjosfcsf
zjotov=0.0d0
call TOVS_OBS ('HR',ZJOTOV)
zjogoes=0.0d0
call dobsgoes(zjogoes)
write(nulout,'(a15,G12.6)') 'JORAOB= ',ZJORAOB
write(nulout,'(a15,G12.6)') 'JOAIREP= ',ZJOAIREP
write(nulout,'(a15,G12.6)') 'JOSURFC= ',ZJOSURFC
write(nulout,'(a15,G12.6)') 'JOTOV= ',ZJOTOV
write(nulout,'(a15,G12.6)') 'JOGOES= ',ZJOGOES
write(nulout,'(a15,G12.6)') 'JOSATWIND= ',ZJOSATWIND
c
c undo normalization wrt ncmoer and store (obs still set to zero)
c
do jdata = 1, ndata
zcmacntl(jdata)=robdata8(ncmoma,jdata)*robdata8(ncmoer,jdata)
robdata8(ncmoma,jdata)=-888.0
enddo
ninmpg(kfile_use)=kultemp ! reset unit number for perturbed trial
c 888 do jdata = 1, ndata
c zcmacntl(jdata)=0.0
c robdata8(ncmoma,jdata)=-888.0
c enddo
c ENDIF
c
c Estimate HBHT using random perturbations
c
do jdata = 1, ndata
zcmapertmean(jdata)=0.0d0
zcmapertstd(jdata)=0.0d0
enddo
c
do jsamp=1,nsamphbht
write(nulout,*) 'REALIZATION NUMBER FOR HBHT=',jsamp
write(nulout,*) 'test gasdev=',gasdev(1),gasdev(1),gasdev(1)
do jj=1,nvadim
vazx(jj)=gasdev(1)
enddo
call cain(nvadim,vazx)
call spa2sp
call spgd
c
c Interpolate perturbation into obs space with linearized (wrt cntl) obs operators
c now replace calling interfaces by ODA wrapper according to ODA conventions.
c
c call newbilin
c call lpreobs
c call lobsppp(zjoraob,'UA')
c call lobsppp(zjoairep,'AI')
c call lobsppp(zjosatwind,'SW')
c call lobssfc(zjosfcsf,'UA')
c call lobssfc(zjosfcua,'SF')
c call lvtov(zjotov)
c call robsgoes(zjogoes)
c call lvgoes(zjogoes)
call oda_L
call oda_H ! Modify NCMOMA ! Hdx
c
c undo normalization wrt ncmoer and store (obs still zero, I hope)
c
do jdata = 1, ndata
zcmapert(jdata) =robdata8(ncmoma,jdata)*robdata8(ncmoer,jdata)
zcmapertmean(jdata)=zcmapertmean(jdata) + zcmapert(jdata)
zcmapertstd(jdata) =zcmapertstd(jdata) +
+ zcmapert(jdata)*zcmapert(jdata)
enddo
c
enddo
c
do jdata = 1, ndata
zcmapertmean(jdata)=zcmapertmean(jdata)/nsamphbht
zcmapertstd(jdata)=zcmapertstd(jdata)/nsamphbht -
+ zcmapertmean(jdata)*zcmapertmean(jdata)
if(zcmapertstd(jdata).gt.0.0) then
zcmapertstd(jdata)=sqrt(zcmapertstd(jdata))
else
zcmapertstd(jdata)=0.0d0
endif
enddo
c
c Only use UA family, pressure level obs for tuning
c
do jdata = 1, ndata
kusetune2(jdata)=0
enddo
do jj=1,nfiles
if ((cfamtyp(jj).eq.'UA'.or.cfamtyp(jj).eq.'TO').and.(nbegintyp(jj).gt.0)) then
do jdata=nbegintyp(jj),nendtyp(jj)
if(cfamtyp(jj).eq.'UA'
& .and. mobdata(ncmvco,jdata) .eq. 2
& .and. mobdata(ncmass,jdata) .eq. 1
& .and. mobdata(ncmxtr,jdata) .eq. 0
& .and. kusetune1(jdata) .eq. 1) then
kusetune2(jdata)=1
elseif(cfamtyp(jj).eq.'TO'
& .and.mobdata(ncmass,jdata).eq.1
& .and.kusetune1(jdata) .eq.2) then
kusetune2(jdata)=2
endif
enddo
endif
enddo
c
c figure which eta level each obs is closest to
c
do jdata = 1, ndata
if(kusetune2(jdata).eq.1) then
ik = robdata(ncmlyr,jdata)
ipt = ik + mobdata(ncmpos,jdata)*nlevtrl
ipb = ipt+1
zzpt = rppobshr(ik,mobdata(ncmobs,jdata))
zzpb = rppobshr(ik+1,mobdata(ncmobs,jdata))
zwb = log(robdata8(ncmppp,jdata)/zzpt)/log(zzpb/zzpt)
zwt = 1. - zwb
if(zwb.gt.zwt) then
ketalev(jdata)=ik+1
else
ketalev(jdata)=ik
endif
elseif(kusetune2(jdata).eq.2) then
c TOVS data
kchan=nint(robdata8(ncmppp,jdata))-27
c if(kchan.eq.10) then
c write(nulout,*) 'TESTING TOVS:',
c + zcmabg(jdata),zcmaobs(jdata),robdata8(ncmoer,jdata)
c endif
if(kchan.gt.10.or.kchan.lt.5) then
c write(nulout,*) 'TOVS channel out of range:',kchan
ketalev(jdata)=-1
else
ik=0
do jk=1,(nflev-1)
if(zprestovs(kchan).gt.rppobshr(jk,mobdata(ncmobs,jdata)))then
ik=jk
endif
enddo
if(ik.gt.0) then
zzpt = rppobshr(ik,mobdata(ncmobs,jdata))
zzpb = rppobshr(ik+1,mobdata(ncmobs,jdata))
zwb = log(zprestovs(kchan)/zzpt)/log(zzpb/zzpt)
zwt = 1. - zwb
if(zwb.gt.zwt) then
ketalev(jdata)=ik+1
else
ketalev(jdata)=ik
endif
else
write(nulout,*) 'TOVS pressure out of range:',zprestovs(kchan)
ketalev(jdata)=-1
endif
endif
else
ketalev(jdata)=-1
endif
enddo
c
c calculate tuning factor for each level
c
do jregion=1,3
do jk=1,nflev
varinntt(jk)=0.0d0
varinnuu(jk)=0.0d0
varinnvv(jk)=0.0d0
varinnbt(jk)=0.0d0
avginntt(jk)=0.0d0
avginnuu(jk)=0.0d0
avginnvv(jk)=0.0d0
avginnbt(jk)=0.0d0
varobstt(jk)=0.0d0
varobsuu(jk)=0.0d0
varobsvv(jk)=0.0d0
varobsbt(jk)=0.0d0
varprett(jk)=0.0d0
varpreuu(jk)=0.0d0
varprevv(jk)=0.0d0
varprebt(jk)=0.0d0
varhbhtt(jk)=0.0d0
varhbhuu(jk)=0.0d0
varhbhvv(jk)=0.0d0
varhbhbt(jk)=0.0d0
knttt(jk,jregion)=0
kntuu(jk,jregion)=0
kntvv(jk,jregion)=0
kntbt(jk,jregion)=0
do jdata = 1, ndata
iobs = mobdata(ncmobs,jdata)
zlat = robhdr(ncmlat,iobs)*ztodeg
if(ketalev(jdata).eq.jk.and.
+ ( (jregion.eq.1.and.zlat.gt.20.0).or.
+ (jregion.eq.3.and.zlat.lt.-20.0.and.zlat.ge.-60.0).or.
+ (jregion.eq.2.and.zlat.le.20.0.and.zlat.ge.-20.0) ) ) then
zfact =(zcmacntl(jdata)-zcmaobs(jdata))*(zcmacntl(jdata)-zcmaobs(jdata))
zfact1=(zcmacntl(jdata)-zcmaobs(jdata))
zfact2=robdata8(ncmoer,jdata)*robdata8(ncmoer,jdata)
zfact3=(zcmacntl(jdata)-zcmabg(jdata))*(zcmacntl(jdata)-zcmabg(jdata))
zfact4=zcmapertstd(jdata)*zcmapertstd(jdata)
if(mobdata(ncmvnm,jdata).eq.nett) then
varinntt(jk)=varinntt(jk)+zfact
avginntt(jk)=avginntt(jk)+zfact1
varobstt(jk)=varobstt(jk)+zfact2
varprett(jk)=varprett(jk)+zfact3
varhbhtt(jk)=varhbhtt(jk)+zfact4
knttt(jk,jregion)=knttt(jk,jregion)+1
elseif(mobdata(ncmvnm,jdata).eq.neuu) then
varinnuu(jk)=varinnuu(jk)+zfact
avginnuu(jk)=avginnuu(jk)+zfact1
varobsuu(jk)=varobsuu(jk)+zfact2
varpreuu(jk)=varpreuu(jk)+zfact3
varhbhuu(jk)=varhbhuu(jk)+zfact4
kntuu(jk,jregion)=kntuu(jk,jregion)+1
elseif(mobdata(ncmvnm,jdata).eq.nevv) then
varinnvv(jk)=varinnvv(jk)+zfact
avginnvv(jk)=avginnvv(jk)+zfact1
varobsvv(jk)=varobsvv(jk)+zfact2
varprevv(jk)=varprevv(jk)+zfact3
varhbhvv(jk)=varhbhvv(jk)+zfact4
kntvv(jk,jregion)=kntvv(jk,jregion)+1
elseif(mobdata(ncmvnm,jdata).eq.nbt1.or.
+ mobdata(ncmvnm,jdata).eq.nbt2.or.
+ mobdata(ncmvnm,jdata).eq.nbt3) then
varinnbt(jk)=varinnbt(jk)+zfact
avginnbt(jk)=avginnbt(jk)+zfact1
varobsbt(jk)=varobsbt(jk)+zfact2
varprebt(jk)=varprebt(jk)+zfact3
varhbhbt(jk)=varhbhbt(jk)+zfact4
kntbt(jk,jregion)=kntbt(jk,jregion)+1
endif
endif
enddo
if(knttt(jk,jregion).gt.10) then
varinntt(jk)=varinntt(jk)/knttt(jk,jregion)
avginntt(jk)=avginntt(jk)/knttt(jk,jregion)
varinntt(jk)=varinntt(jk)-avginntt(jk)*avginntt(jk)
varobstt(jk)=varobstt(jk)/knttt(jk,jregion)
varprett(jk)=varprett(jk)/knttt(jk,jregion)
varhbhtt(jk)=varhbhtt(jk)/knttt(jk,jregion)
else
varinntt(jk)=0.0d0
avginntt(jk)=0.0d0
varobstt(jk)=0.0d0
varprett(jk)=0.0d0
varhbhtt(jk)=0.0d0
knttt(jk,jregion)=0
endif
if(kntuu(jk,jregion).gt.10) then
varinnuu(jk)=varinnuu(jk)/kntuu(jk,jregion)
avginnuu(jk)=avginnuu(jk)/kntuu(jk,jregion)
varinnuu(jk)=varinnuu(jk)-avginnuu(jk)*avginnuu(jk)
varobsuu(jk)=varobsuu(jk)/kntuu(jk,jregion)
varpreuu(jk)=varpreuu(jk)/kntuu(jk,jregion)
varhbhuu(jk)=varhbhuu(jk)/kntuu(jk,jregion)
else
varinnuu(jk)=0.0d0
avginnuu(jk)=0.0d0
varobsuu(jk)=0.0d0
varpreuu(jk)=0.0d0
varhbhuu(jk)=0.0d0
kntuu(jk,jregion)=0
endif
if(kntvv(jk,jregion).gt.10) then
varinnvv(jk)=varinnvv(jk)/kntvv(jk,jregion)
avginnvv(jk)=avginnvv(jk)/kntvv(jk,jregion)
varinnvv(jk)=varinnvv(jk)-avginnvv(jk)*avginnvv(jk)
varobsvv(jk)=varobsvv(jk)/kntvv(jk,jregion)
varprevv(jk)=varprevv(jk)/kntvv(jk,jregion)
varhbhvv(jk)=varhbhvv(jk)/kntvv(jk,jregion)
else
varinnvv(jk)=0.0d0
avginnvv(jk)=0.0d0
varobsvv(jk)=0.0d0
varprevv(jk)=0.0d0
varhbhvv(jk)=0.0d0
kntvv(jk,jregion)=0
endif
if(kntbt(jk,jregion).gt.10) then
varinnbt(jk)=varinnbt(jk)/kntbt(jk,jregion)
avginnbt(jk)=avginnbt(jk)/kntbt(jk,jregion)
varinnbt(jk)=varinnbt(jk)-avginnbt(jk)*avginnbt(jk)
varobsbt(jk)=varobsbt(jk)/kntbt(jk,jregion)
varprebt(jk)=varprebt(jk)/kntbt(jk,jregion)
varhbhbt(jk)=varhbhbt(jk)/kntbt(jk,jregion)
else
varinnbt(jk)=0.0d0
avginnbt(jk)=0.0d0
varobsbt(jk)=0.0d0
varprebt(jk)=0.0d0
varhbhbt(jk)=0.0d0
kntbt(jk,jregion)=0
endif
enddo
c
c zap the top 5 layers for radiosondes (force new var_bg towards old)
c
if(jregion.eq.2) then
zapfact=1.0
else
zapfact=0.7
endif
do jk=1,5
varinntt(jk)=zapfact*varhbhtt(jk)
varobstt(jk)=0.0
varinnuu(jk)=zapfact*varhbhuu(jk)
varobsuu(jk)=0.0
varinnvv(jk)=zapfact*varhbhvv(jk)
varobsvv(jk)=0.0
enddo
c
c print out profiles before vertical smoothing
c
do jk=1,nflev
write(85,*) jk,jregion,knttt(jk,jregion),
+ varinntt(jk),varobstt(jk),
+ varprett(jk),varhbhtt(jk)
enddo
do jk=1,nflev
write(85,*) jk,jregion,kntuu(jk,jregion),
+ varinnuu(jk),varobsuu(jk),
+ varpreuu(jk),varhbhuu(jk)
enddo
do jk=1,nflev
write(85,*) jk,jregion,kntvv(jk,jregion),
+ varinnvv(jk),varobsvv(jk),
+ varprevv(jk),varhbhvv(jk)
enddo
do jk=1,nflev
write(85,*) jk,jregion,kntbt(jk,jregion),
+ varinnbt(jk),varobsbt(jk),
+ varprebt(jk),varhbhbt(jk)
enddo
call flush(85)
c
c calculate scaling factors for region
c
c use vertical smoothing weights ww=[0.5 0.4 0.3 0.15 0.075];
ww(1)=0.5d0
ww(2)=0.4d0
ww(3)=0.3d0
ww(4)=0.15d0
ww(5)=0.075d0
do jk=1,nflev
c tt variable
zfact1=0.0d0
zfact2=0.0d0
zfact3=0.0d0
do jk2=max(1,(jk-4)),min(nflev,(jk+4))
zfact1=zfact1 + knttt(jk2,jregion)*ww(1+abs(jk2-jk))*
+ (varinntt(jk2)-varprett(jk2)-varobstt(jk2))
zfact2=zfact2 + knttt(jk2,jregion)*ww(1+abs(jk2-jk))*
+ (varhbhtt(jk2))
zfact3=zfact3 + dble(knttt(jk2,jregion))*ww(1+abs(jk2-jk))
enddo
kntttver(jk,jregion)=nint(zfact3)
if(zfact2.gt.0.0) then
zfacttt(jk,jregion)=zfact1/zfact2
if(zfacttt(jk,jregion).gt.0.0) then
zfacttt(jk,jregion)=sqrt(zfacttt(jk,jregion))
else
zfacttt(jk,jregion)=0.0d0
endif
else
zfacttt(jk,jregion)=0.0d0
kntttver(jk,jregion)=0
endif
c uu variable
zfact1=0.0d0
zfact2=0.0d0
zfact3=0.0d0
do jk2=max(1,(jk-4)),min(nflev,(jk+4))
zfact1=zfact1 + kntuu(jk2,jregion)*ww(1+abs(jk2-jk))*
+ (varinnuu(jk2)-varpreuu(jk2)-varobsuu(jk2))
zfact2=zfact2 + kntuu(jk2,jregion)*ww(1+abs(jk2-jk))*
+ (varhbhuu(jk2))
zfact3=zfact3 + dble(kntuu(jk2,jregion))*ww(1+abs(jk2-jk))
enddo
kntuuver(jk,jregion)=nint(zfact3)
if(zfact2.gt.0.0) then
zfactuu(jk,jregion)=zfact1/zfact2
if(zfactuu(jk,jregion).gt.0.0) then
zfactuu(jk,jregion)=sqrt(zfactuu(jk,jregion))
else
zfactuu(jk,jregion)=0.0d0
endif
else
zfactuu(jk,jregion)=0.0d0
kntuuver(jk,jregion)=0
endif
c vv variable
zfact1=0.0d0
zfact2=0.0d0
zfact3=0.0d0
do jk2=max(1,(jk-4)),min(nflev,(jk+4))
zfact1=zfact1 + kntvv(jk2,jregion)*ww(1+abs(jk2-jk))*
+ (varinnvv(jk2)-varprevv(jk2)-varobsvv(jk2))
zfact2=zfact2 + kntvv(jk2,jregion)*ww(1+abs(jk2-jk))*
+ (varhbhvv(jk2))
zfact3=zfact3 + dble(kntvv(jk2,jregion))*ww(1+abs(jk2-jk))
enddo
kntvvver(jk,jregion)=nint(zfact3)
if(zfact2.gt.0.0) then
zfactvv(jk,jregion)=zfact1/zfact2
if(zfactvv(jk,jregion).gt.0.0) then
zfactvv(jk,jregion)=sqrt(zfactvv(jk,jregion))
else
zfactvv(jk,jregion)=0.0d0
endif
else
zfactvv(jk,jregion)=0.0d0
kntvvver(jk,jregion)=0
endif
c bt variable
zfact1=0.0d0
zfact2=0.0d0
zfact3=0.0d0
do jk2=max(1,(jk-4)),min(nflev,(jk+4))
zfact1=zfact1 + kntbt(jk2,jregion)*ww(1+abs(jk2-jk))*
+ (varinnbt(jk2)-varprebt(jk2)-varobsbt(jk2))
zfact2=zfact2 + kntbt(jk2,jregion)*ww(1+abs(jk2-jk))*
+ (varhbhbt(jk2))
zfact3=zfact3 + dble(kntbt(jk2,jregion))*ww(1+abs(jk2-jk))
enddo
kntbtver(jk,jregion)=nint(zfact3)
if(zfact2.gt.0.0) then
zfactbt(jk,jregion)=zfact1/zfact2
if(zfactbt(jk,jregion).gt.0.0) then
zfactbt(jk,jregion)=sqrt(zfactbt(jk,jregion))
else
zfactbt(jk,jregion)=0.0d0
endif
else
zfactbt(jk,jregion)=0.0d0
kntbtver(jk,jregion)=0
endif
enddo
c
c print out profiles after vertical smoothing
c
do jk=1,nflev
write(89,*) jk,jregion,knttt(jk,jregion),
+ varinntt(jk),varobstt(jk),
+ varprett(jk),varhbhtt(jk),avginntt(jk),
+ zfacttt(jk,jregion)
enddo
do jk=1,nflev
write(89,*) jk,jregion,kntuu(jk,jregion),
+ varinnuu(jk),varobsuu(jk),
+ varpreuu(jk),varhbhuu(jk),avginnuu(jk),
+ zfactuu(jk,jregion)
enddo
do jk=1,nflev
write(89,*) jk,jregion,kntvv(jk,jregion),
+ varinnvv(jk),varobsvv(jk),
+ varprevv(jk),varhbhvv(jk),avginnvv(jk),
+ zfactvv(jk,jregion)
enddo
do jk=1,nflev
write(89,*) jk,jregion,kntbt(jk,jregion),
+ varinnbt(jk),varobsbt(jk),
+ varprebt(jk),varhbhbt(jk),avginnbt(jk),
+ zfactbt(jk,jregion)
enddo
call flush(89)
c
c Compute average of new and old factors for time filtering
c
alphatime=0.1
do jk=1,nflev
c tt variable
zfact1= alphatime *dble(kntttver(jk,jregion))
zfact2= (1.0-alphatime)*dble(kntttold(jk,jregion))
zfact=zfact1+zfact2
if(zfact.gt.0.0) then
zfact1=zfact1/zfact
zfact2=zfact2/zfact
else
zfact1=0.0
zfact2=0.0
endif
zfacttt(jk,jregion)= zfact1*zfacttt(jk,jregion) +
+ zfact2*zfactttold(jk,jregion)
if(kntttold(jk,jregion).gt.0) then
kntttavg(jk,jregion)=alphatime *kntttver(jk,jregion) +
+ (1-alphatime)*kntttold(jk,jregion)
else
kntttavg(jk,jregion)=kntttver(jk,jregion)
endif
c uu variable
zfact1= alphatime *dble(kntuuver(jk,jregion))
zfact2= (1.0-alphatime)*dble(kntuuold(jk,jregion))
zfact=zfact1+zfact2
if(zfact.gt.0.0) then
zfact1=zfact1/zfact
zfact2=zfact2/zfact
else
zfact1=0.0
zfact2=0.0
endif
zfactuu(jk,jregion)= zfact1*zfactuu(jk,jregion) +
+ zfact2*zfactuuold(jk,jregion)
if(kntuuold(jk,jregion).gt.0) then
kntuuavg(jk,jregion)=alphatime *kntuuver(jk,jregion) +
+ (1-alphatime)*kntuuold(jk,jregion)
else
kntuuavg(jk,jregion)=kntuuver(jk,jregion)
endif
c vv variable
zfact1= alphatime *dble(kntvvver(jk,jregion))
zfact2= (1.0-alphatime)*dble(kntvvold(jk,jregion))
zfact=zfact1+zfact2
if(zfact.gt.0.0) then
zfact1=zfact1/zfact
zfact2=zfact2/zfact
else
zfact1=0.0
zfact2=0.0
endif
zfactvv(jk,jregion)= zfact1*zfactvv(jk,jregion) +
+ zfact2*zfactvvold(jk,jregion)
if(kntvvold(jk,jregion).gt.0) then
kntvvavg(jk,jregion)=alphatime *kntvvver(jk,jregion) +
+ (1-alphatime)*kntvvold(jk,jregion)
else
kntvvavg(jk,jregion)=kntvvver(jk,jregion)
endif
c bt variable
zfact1= alphatime *dble(kntbtver(jk,jregion))
zfact2= (1.0-alphatime)*dble(kntbtold(jk,jregion))
zfact=zfact1+zfact2
if(zfact.gt.0.0) then
zfact1=zfact1/zfact
zfact2=zfact2/zfact
else
zfact1=0.0
zfact2=0.0
endif
zfactbt(jk,jregion)= zfact1*zfactbt(jk,jregion) +
+ zfact2*zfactbtold(jk,jregion)
if(kntbtold(jk,jregion).gt.0) then
kntbtavg(jk,jregion)=alphatime *kntbtver(jk,jregion) +
+ (1-alphatime)*kntbtold(jk,jregion)
else
kntbtavg(jk,jregion)=kntbtver(jk,jregion)
endif
enddo
c
c print out profiles
c
do jk=1,nflev
write(87,*) jk,jregion,kntttver(jk,jregion),kntttavg(jk,jregion),
+ varinntt(jk),varobstt(jk),
+ varprett(jk),varhbhtt(jk),zfacttt(jk,jregion)
enddo
do jk=1,nflev
write(87,*) jk,jregion,kntuuver(jk,jregion),kntuuavg(jk,jregion),
+ varinnuu(jk),varobsuu(jk),
+ varpreuu(jk),varhbhuu(jk),zfactuu(jk,jregion)
enddo
do jk=1,nflev
write(87,*) jk,jregion,kntvvver(jk,jregion),kntvvavg(jk,jregion),
+ varinnvv(jk),varobsvv(jk),
+ varprevv(jk),varhbhvv(jk),zfactvv(jk,jregion)
enddo
do jk=1,nflev
write(87,*) jk,jregion,kntbtver(jk,jregion),kntbtavg(jk,jregion),
+ varinnbt(jk),varobsbt(jk),
+ varprebt(jk),varhbhbt(jk),zfactbt(jk,jregion)
enddo
c
enddo !end loop on regions
call flush(87)
c
c Write new factors to file for time filtering
c
kultime=0
c ierr = fnom(kultime,'/users/dor/arma/bue/gpfs/data/timefilt.bin','FTN+SEQ+UNF',0)
ierr = fnom(kultime,'./timefilt.bin','FTN+SEQ+UNF',0)
if(ierr.ge.0) then
write(nulout,*) 'FILE OPENED FOR WRITING TIME FILTERING'
else
write(nulout,*) 'PROBLEM WITH WRITING NEW SCALE FACTORS FOR TIME FILTERING'
endif
write(kultime) zfacttt ,zfactuu ,zfactvv ,zfactbt
write(kultime) kntttavg,kntuuavg,kntvvavg,kntbtavg
ierr=fclos(kultime)
c
c interpolate scaling factor between regions
c
klatn =isrchila( 25.0d0 *ztorad)
klatn2=isrchila( 15.0d0 *ztorad)
klats=isrchila(-25.0d0 *ztorad)+1
klats2=isrchila(-15.0d0 *ztorad)+1
print *,'grid boundaries=',klatn,klatn2,klats,klats2
do jk=1,nflev
do jj=1,NJ
c north of 25: constant
if(jj.lt.klatn) then
zfactuu2(jk,jj)=zfactuu(jk,1)
zfactvv2(jk,jj)=zfactvv(jk,1)
zfacttt2(jk,jj)=zfacttt(jk,1)
zfactbt2(jk,jj)=zfactbt(jk,1)
c south of -25: constant
elseif(jj.gt.klats) then
zfactuu2(jk,jj)=zfactuu(jk,3)
zfactvv2(jk,jj)=zfactvv(jk,3)
zfacttt2(jk,jj)=zfacttt(jk,3)
zfactbt2(jk,jj)=zfactbt(jk,3)
c interpolate in between 15N and 25N
elseif(jj.le.klatn2.and.jj.ge.klatn) then
zfactuu2(jk,jj)=((jj-klatn)*zfactuu(jk,2)+
+ (klatn2-jj)*zfactuu(jk,1))/(klatn2-klatn)
zfactvv2(jk,jj)=((jj-klatn)*zfactvv(jk,2)+
+ (klatn2-jj)*zfactvv(jk,1))/(klatn2-klatn)
zfacttt2(jk,jj)=((jj-klatn)*zfacttt(jk,2)+
+ (klatn2-jj)*zfacttt(jk,1))/(klatn2-klatn)
zfactbt2(jk,jj)=((jj-klatn)*zfactbt(jk,2)+
+ (klatn2-jj)*zfactbt(jk,1))/(klatn2-klatn)
c interpolate in between 15S and 25S
elseif(jj.le.klats.and.jj.ge.klats2) then
zfactuu2(jk,jj)=((jj-klats2)*zfactuu(jk,3)+
+ (klats-jj)*zfactuu(jk,2))/(klats-klats2)
zfactvv2(jk,jj)=((jj-klats2)*zfactvv(jk,3)+
+ (klats-jj)*zfactvv(jk,2))/(klats-klats2)
zfacttt2(jk,jj)=((jj-klats2)*zfacttt(jk,3)+
+ (klats-jj)*zfacttt(jk,2))/(klats-klats2)
zfactbt2(jk,jj)=((jj-klats2)*zfactbt(jk,3)+
+ (klats-jj)*zfactbt(jk,2))/(klats-klats2)
c tropics: constant
else
zfactuu2(jk,jj)=zfactuu(jk,2)
zfactvv2(jk,jj)=zfactvv(jk,2)
zfacttt2(jk,jj)=zfacttt(jk,2)
zfactbt2(jk,jj)=zfactbt(jk,2)
endif
enddo
enddo
write(nulout,*) 'INTERPOLATED SCALING FACTOR: U,V,T'
do jk=1,nflev
do jj=1,nj
write(nulout,'(2I4,4F8.3)')
+ jk,jj,zfactuu2(jk,jj),zfactvv2(jk,jj),zfacttt2(jk,jj),zfactbt2(jk,jj)
enddo
enddo
c scale perturbation
do jj=1,nj
do jk=1,nflev
zfactuv=(zfactuu2(jk,jj)+zfactvv2(jk,jj))/2.0
zfact=zfacttt2(jk,jj)
do ii=1,ni
ut0(ii,jk,jj)=ut0(ii,jk,jj)*zfactuv/conphy(jj) ! this undoes conversion in newbilin
vt0(ii,jk,jj)=vt0(ii,jk,jj)*zfactuv/conphy(jj) ! ditto
tt0(ii,jk,jj)=tt0(ii,jk,jj)*zfact
q0(ii,jk,jj)=q0(ii,jk,jj)*zfact
enddo
enddo
enddo
do jj=1,nj
zfactuv=(zfactuu2(nflev,jj)+zfactvv2(nflev,jj))/2.0
do ii=1,ni
gps0(ii,1,jj)=gps0(ii,1,jj)*zfactuv
gtg0(ii,1,jj)=gtg0(ii,1,jj)*zfactuv
enddo
enddo
ENDIF
ctest call transfer('ZGD0')
c
c Add perturbation to HiRes fct and overwrite file - all variables
c (patch in GEM launcher will copy new trlm (ptrm) into the archive)
call getfstg(zttg,zhug,zuug,zvvg,zesg,zpsg,zpt,ni,nj,nflev)
c
if ( chum .eq. 'LQ') then
do jk = 1,nflev
do jj = 1,nj
do ii = 1,ni
ztemp = log(zhug(ii,jk,jj)) + q0(ii,jk,jj)
zhu(ii,jk,jj) = exp(ztemp) - zhug(ii,jk,jj)
enddo
enddo
enddo
endif
call diag3dvar
c
c Output perturbed trial fields and pertubations
c
call pert_varout
c
c set starting point back to zero for minimization
c
do jj=1,nvadim
vazx(jj)=0.0d0
enddo
if (LMODELER) then
ierr= fstfrm(kulcntl)
ierr= fclos(kulcntl)
end if
c
999 continue
if(LMODELER) THEN
do jdata = 1, ndata
robdata8(ncmvar,jdata)=zcmaobs(jdata)
enddo
ENDIF
c
c writing out random number generator seed
c
open(unit=39,form='unformatted',
+ file='./randnum.dat',STATUS='REPLACE')
write(39) (rrand(jj),jj=1,97)
write(39) ix1,ix2,ix3,iff
close(39)
c
call hpdeallc(pxpp,ierr,1)
call hpdeallc(pxqq,ierr,1)
call hpdeallc(pxqr,ierr,1)
call hpdeallc(pxcc,ierr,1)
call hpdeallc(pxdd,ierr,1)
call hpdeallc(pxuug,ierr,1)
call hpdeallc(pxvvg,ierr,1)
call hpdeallc(pxttg,ierr,1)
call hpdeallc(pxttb,ierr,1)
call hpdeallc(pxttu,ierr,1)
call hpdeallc(pxtv,ierr,1)
call hpdeallc(pxgz,ierr,1)
call hpdeallc(pxgzb,ierr,1)
call hpdeallc(pxgzu,ierr,1)
call hpdeallc(pxes,ierr,1)
call hpdeallc(pxesg,ierr,1)
call hpdeallc(pxhu,ierr,1)
call hpdeallc(pxhug,ierr,1)
call hpdeallc(pxo3,ierr,1)
call hpdeallc(pxpsg,ierr,1)
call hpdeallc(pxpsb,ierr,1)
call hpdeallc(pxpsu,ierr,1)
call hpdeallc(pxpt,ierr,1)
c
return
end