!-------------------------------------- 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 rdtunebgobs 3,9
*
IMPLICIT NONE
#include "pardim.cdk"
#include "comdim.cdk"
#include "comgem.cdk"
#include "comct0.cdk"
#include "comlun.cdk"
#include "comcva.cdk"
#include "comoahdr.cdk"
#include "comoabdy.cdk"
#include "comoba.cdk"
#include "commvo.cdk"
#include "commvohr.cdk"
#include "com1obs.cdk"
#include "comvarqc.cdk"
#include "comfilt.cdk"
#include "comgdpar.cdk"
#include "rpnstd.cdk"
#include "compost.cdk"
#include "compstat.cdk"
#include "cvcord.cdk"
#include "comdimo.cdk"
#include "comnumbr.cdk"
#include "comcst.cdk"
#include "comgd1.cdk"
#include "comsp.cdk"
#include "comleg.cdk"
*
integer jlev,jdata,jj,j
REAL*8 zsaveoer(ndata)
real*8 zso2p_to_3(50),zso2p_sw_3(19,3)
real*8 zso2p_ua_3(19,3,3),zso2p_ai_3(19,3)
integer jjj,iobs,kcnt1,kcnt2,kcnt3
logical lexist
integer kpreslev,kulfile
REAL*8 zpreslev(19),zpreslev2(20)
INTEGER kvar,kchan1,kchan2,ityp,jvar
c
integer jk,jk2,ji,jm,jn,ila
integer isrchila,jregion,klatn,klatn2,klats,klats2,ilen
real*8 zfactttold(nflev,3),zfactuuold(nflev,3),zfactesold(nflev,3)
real*8 zfactuu2(nflev,nj),zfacttt2(nflev,nj),zfactes2(nflev,nj)
real*8 zfact,zfactuv,zfactlq,ztodeg,ztorad,zpress(nflev,3),zlat
call printrev("SUBROUTINE rdtunebgobs :",26)
kulfile=39
ztodeg = 1.d0/(rpi/180.d0)
ztorad = 1.d0/ztodeg
c
c ----------------------------------------------------
c Read in obs error variance tuning factors
c ----------------------------------------------------
c
kchan1=1
kchan2=50
kpreslev=19
kvar=3
zpreslev( 1)= 500.0d0
zpreslev( 2)= 2000.0d0
zpreslev( 3)= 3000.0d0
zpreslev( 4)= 5000.0d0
zpreslev( 5)= 7000.0d0
zpreslev( 6)= 10000.0d0
zpreslev( 7)= 15000.0d0
zpreslev( 8)= 20000.0d0
zpreslev( 9)= 25000.0d0
zpreslev(10)= 30000.0d0
zpreslev(11)= 40000.0d0
zpreslev(12)= 50000.0d0
zpreslev(13)= 60000.0d0
zpreslev(14)= 70000.0d0
zpreslev(15)= 80000.0d0
zpreslev(16)= 85000.0d0
zpreslev(17)= 90000.0d0
zpreslev(18)= 95000.0d0
zpreslev(19)=110000.0d0
zpreslev2(1)=zpreslev(1)
zpreslev2(kpreslev+1)=zpreslev(kpreslev)
do ji=2,kpreslev
zpreslev2(ji)=0.5*(zpreslev(ji-1)+zpreslev(ji))
enddo
c
c save obs
c
DO JDATA=1,NDATA
zsaveoer(jdata) = ROBDATA8(NCMOER,JDATA)
ENDDO
*
DO jlev=1,kpreslev
DO jvar=1,kvar
do jregion=1,3
zso2p_ua_3(jlev,jvar,jregion)=1.d0
enddo
zso2p_ai_3(jlev,jvar)=1.d0
zso2p_sw_3(jlev,jvar)=1.d0
enddo
enddo
DO jlev=kchan1,kchan2
zso2p_to_3(jlev)=1.d0
enddo
c
inquire(file=CFLTUNEOBS,exist=lexist)
print*,'Check if tuning file exists=',lexist
if(lexist)then
open(unit=kulfile,file=CFLTUNEOBS)
read(kulfile,*) !'-------UA---------'
do jregion=1,3
DO jlev=1,kpreslev
read(kulfile,1)zpreslev(jlev),(zso2p_ua_3(jlev,jvar,jregion),jvar=1,kvar)
do jvar=1,kvar
write(nulout,*) 'UA OER TUNING:',jvar,zpreslev(jlev),zso2p_ua_3(jlev,jvar,jregion)
enddo
enddo
enddo
read(kulfile,*) !'-------AI---------'
DO jlev=1,kpreslev
read(kulfile,1)zpreslev(jlev),(zso2p_ai_3(jlev,jvar),jvar=1,kvar)
do jvar=1,kvar
write(nulout,*) 'AI OER TUNING:',zpreslev(jlev),zso2p_ai_3(jlev,jvar)
enddo
enddo
read(kulfile,*) !'-------SW---------'
DO jlev=1,kpreslev
read(kulfile,1)zpreslev(jlev),(zso2p_sw_3(jlev,jvar),jvar=1,kvar)
do jvar=1,kvar
write(nulout,*) 'SW OER TUNING:',zpreslev(jlev),zso2p_sw_3(jlev,jvar)
enddo
enddo
read(kulfile,*) !'-------TO---------'
DO jlev=kchan1,kchan2
read(kulfile,2)jjj,zso2p_to_3(jlev)
write(nulout,*) 'TOVS OER TUNING:',jlev,jjj,zso2p_to_3(jlev)
enddo
close(kulfile)
endif
1 format(f10.2,3(f20.17))
2 format(i3,f20.17)
c
c Apply tuning to each family in Jo
c
kcnt1=0
kcnt2=0
kcnt3=0
DO J = 1,NFILES
DO JDATA=NBEGINTYP(J),NENDTYP(J)
IF(CFAMTYP(J) .EQ. 'UA') THEN
IF ( MOBDATA(NCMVCO,JDATA) .EQ. 1 ) THEN
ZFACT=1.0
ELSE IF ( MOBDATA(NCMVCO,JDATA) .EQ. 2) THEN
DO jlev=1,kpreslev
IF(ROBDATA8(NCMPPP,JDATA).ge.zpreslev2(jlev ).and.
+ ROBDATA8(NCMPPP,JDATA).lt.zpreslev2(jlev+1) ) THEN
ITYP = MOBDATA(NCMVNM,JDATA)
JVAR= 0
IF(ITYP.eq.NEUU.or.ITYP.eq.NEVV.or.
+ ITYP.eq.NEUS.or.ITYP.eq.NEVS) JVAR = 1
IF(ITYP.eq.NETT.or.ITYP.eq.NETS) JVAR = 2
IF(ITYP.eq.NEES.or.ITYP.eq.NESS) JVAR = 3
iobs = mobdata(ncmobs,jdata)
ZLAT=ROBHDR(NCMLAT,IOBS)*ztodeg
if(zlat.ge. 20.0) then
jregion=1
kcnt1=kcnt1+1
elseif(zlat.le.-20.0) then
jregion=3
kcnt3=kcnt3+1
else
jregion=2
kcnt2=kcnt2+1
endif
ZFACT=1.0d0
IF(JVAR.ne.0) THEN
ZFACT=sqrt(zso2p_ua_3(jlev,jvar,jregion))
ROBDATA8(NCMOER,JDATA) = zsaveoer(jdata) *zfact
endif
endif
enddo
endif
ELSEIF(CFAMTYP(J) .EQ. 'AI') THEN
DO jlev=1,kpreslev
IF(ROBDATA8(NCMPPP,JDATA).ge.zpreslev2(jlev ).and.
+ ROBDATA8(NCMPPP,JDATA).lt.zpreslev2(jlev+1) ) THEN
ITYP = MOBDATA(NCMVNM,JDATA)
JVAR= 0
IF(ITYP.eq.NEUU.or.ITYP.eq.NEVV.or.
+ ITYP.eq.NEUS.or.ITYP.eq.NEVS) JVAR = 1
IF(ITYP.eq.NETT.or.ITYP.eq.NETS) JVAR = 2
IF(ITYP.eq.NEES.or.ITYP.eq.NESS) JVAR = 3
ZFACT=1.0d0
IF(JVAR.ne.0) THEN
ZFACT=sqrt(zso2p_ai_3(jlev,jvar))
ROBDATA8(NCMOER,JDATA) = zsaveoer(jdata) *zfact
endif
endif
enddo
ELSEIF(CFAMTYP(J) .EQ. 'SF') THEN
ZFACT=1.0
ROBDATA8(NCMOER,JDATA) = zsaveoer(jdata) *zfact
ELSEIF(CFAMTYP(J) .EQ. 'SW') THEN
DO jlev=1,kpreslev
IF(ROBDATA8(NCMPPP,JDATA).ge.zpreslev2(jlev ).and.
+ ROBDATA8(NCMPPP,JDATA).lt.zpreslev2(jlev+1) ) THEN
ITYP = MOBDATA(NCMVNM,JDATA)
JVAR= 0
IF(ITYP.eq.NEUU.or.ITYP.eq.NEVV.or.
+ ITYP.eq.NEUS.or.ITYP.eq.NEVS) JVAR = 1
IF(ITYP.eq.NETT.or.ITYP.eq.NETS) JVAR = 2
IF(ITYP.eq.NEES.or.ITYP.eq.NESS) JVAR = 3
ZFACT=1.0d0
IF(JVAR.ne.0) THEN
c !!!do not use SATWIND scaling factors!!!
c ZFACT=sqrt(zso2p_sw_3(jlev,jvar))
ROBDATA8(NCMOER,JDATA) = zsaveoer(jdata) *zfact
endif
endif
enddo
ELSEIF(CFAMTYP(J) .EQ. 'TO') THEN
DO jlev=kchan1,kchan2
ZFACT=1.0d0
IF(NINT(ROBDATA8(NCMPPP,JDATA)).eq.jlev ) THEN
ZFACT=sqrt(zso2p_to_3(jlev))
ROBDATA8(NCMOER,JDATA) = zsaveoer(jdata) *zfact
ENDIF
enddo
ELSE
ZFACT=1.0d0
ROBDATA8(NCMOER,JDATA) = zsaveoer(jdata) *zfact
ENDIF
ENDDO
ENDDO
c
c -----------------------------------------------------------------
c Read in Background error variance tuning factors
c -----------------------------------------------------------------
c
c Read in previous factors for time filtering
c
inquire(file=CFLTUNEBG,exist=lexist)
if(lexist) then
open(unit=kulfile,file=CFLTUNEBG)
write(nulout,*) 'READING SCALE FACTORS FOR BG VARIANCES'
do jregion=1,3
do jk=1,nflev
read(kulfile,*) zpress(jk,jregion),zfactuuold(jk,jregion),zfactttold(jk,jregion),zfactesold(jk,jregion)
enddo
enddo
do jregion=1,3
do jk=1,nflev
zfactuuold(jk,jregion)=sqrt(zfactuuold(jk,jregion))
zfactttold(jk,jregion)=sqrt(zfactttold(jk,jregion))
zfactesold(jk,jregion)=sqrt(zfactesold(jk,jregion))
enddo
enddo
else
write(nulout,*) 'NO FILE OF SCALE FACTORS FOR TUNING OF BG VARIANCES'
do jregion=1,3
do jk=1,nflev
zfactttold(jk,jregion)=1.0d0
zfactuuold(jk,jregion)=1.0d0
zfactesold(jk,jregion)=1.0d0
enddo
enddo
endif
close(kulfile)
c
c print out profiles
c
do jregion=1,3
do jk=1,nflev
write(86,*) jk,zpress(jk,jregion),jregion,zfactttold(jk,jregion)
enddo
do jk=1,nflev
write(86,*) jk,zpress(jk,jregion),jregion,zfactuuold(jk,jregion)
enddo
do jk=1,nflev
write(86,*) jk,zpress(jk,jregion),jregion,zfactesold(jk,jregion)
enddo
enddo !end loop on regions
call flush(86)
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)=zfactuuold(jk,1)
zfacttt2(jk,jj)=zfactttold(jk,1)
zfactes2(jk,jj)=zfactesold(jk,1)
c south of -25: constant
elseif(jj.gt.klats) then
zfactuu2(jk,jj)=zfactuuold(jk,3)
zfacttt2(jk,jj)=zfactttold(jk,3)
zfactes2(jk,jj)=zfactesold(jk,3)
c interpolate in between 15N and 25N
elseif(jj.le.klatn2.and.jj.ge.klatn) then
zfactuu2(jk,jj)=((jj-klatn)*zfactuuold(jk,2)+
+ (klatn2-jj)*zfactuuold(jk,1))/(klatn2-klatn)
zfacttt2(jk,jj)=((jj-klatn)*zfactttold(jk,2)+
+ (klatn2-jj)*zfactttold(jk,1))/(klatn2-klatn)
zfactes2(jk,jj)=((jj-klatn)*zfactesold(jk,2)+
+ (klatn2-jj)*zfactesold(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)*zfactuuold(jk,3)+
+ (klats-jj)*zfactuuold(jk,2))/(klats-klats2)
zfacttt2(jk,jj)=((jj-klats2)*zfactttold(jk,3)+
+ (klats-jj)*zfactttold(jk,2))/(klats-klats2)
zfactes2(jk,jj)=((jj-klats2)*zfactesold(jk,3)+
+ (klats-jj)*zfactesold(jk,2))/(klats-klats2)
c tropics: constant
else
zfactuu2(jk,jj)=zfactuuold(jk,2)
zfacttt2(jk,jj)=zfactttold(jk,2)
zfactes2(jk,jj)=zfactesold(jk,2)
endif
enddo
enddo
c
c filter the scaling coefficients to smooth out horizontal gradients (T50)
c
if(.true.) then
call transfer('ZGD1')
do jj=1,nj
do jk=1,nflev
do ji=1,ni
ut1(ji,jk,jj)=zfactuu2(jk,jj)
vt1(ji,jk,jj)=zfactuu2(jk,jj)
tt1(ji,jk,jj)=zfacttt2(jk,jj)
q1(ji,jk,jj) =zfactes2(jk,jj)
enddo
enddo
enddo
call reespe(nksdim,sp,gd1
s ,nla,nibeg,niend,njbeg,njend,nksdim)
do jk=1,nksdim
do jn=(50+1),ntrunc
do jm=0,jn
ila = nind(jm) +jn-jm
sp(ila,1,jk)= 0.0
sp(ila,2,jk)= 0.0
enddo
enddo
enddo
call speree(nksdim,sp,gd1
s ,nla,nibeg,niend,njbeg,njend,nksdim)
do jj=1,nj
do jk=1,nflev
do ji=1,ni
zfactuu2(jk,jj)=ut1(ji,jk,jj)
zfacttt2(jk,jj)=tt1(ji,jk,jj)
zfactes2(jk,jj)=q1(ji,jk,jj)
enddo
enddo
enddo
call transfer('ZGD1')
endif
c
c
write(nulout,*) 'INTERPOLATED SCALING FACTOR: U,T,ES'
do jk=1,nflev
do jj=1,nj
write(nulout,'(2I4,5F8.3)')
+ jk,jj,zfactuu2(jk,jj),zfacttt2(jk,jj),zfactes2(jk,jj)
enddo
enddo
c set bg std dev scaling to old factors (damplibg)
do jj=1,nj
do jk=1,nflev
zfactuv= zfactuu2(jk,jj)
zfact= zfacttt2(jk,jj)
zfactlq= zfactes2(jk,jj)
do ji=1,ni
damplibg(ji,jk ,jj)=zfactuv ! psi
damplibg(ji,jk+1*nflev,jj)=zfactuv ! chi
damplibg(ji,jk+2*nflev,jj)=zfact ! temp
damplibg(ji,jk+3*nflev,jj)=zfactlq ! log(hu)
enddo
enddo
enddo
do jj=1,nj
zfactuv=zfactuu2(nflev,jj)
do ji=1,ni
damplibg(ji,1+4*nflev,jj)=zfactuv ! ps
enddo
enddo
c
write(nulout,*) 'UA OBS ERROR COUNTS=',kcnt1,kcnt2,kcnt3
c
return
end