subroutine ch_tunebgcoef 2
#if defined (DOC)
*
***s/r ch_tunebgcoef - Set scaling factor for tunning bg variances for
* constituents.
*
* THIS IS R&D CODE. SETTING UP OF SCALING FACTORS FOR OPERATIONAL USE
* MAY NEED REVISION AND/OR INTEGRATION AS PART OF THE "RDTUNEBGOBS" MODULE.
*
*Author : Y. Yang Oct. 2005 by referencing M. Buehner's code tunebg
*Revision:
* Y.J. Rochon March 2010
* - Reset for use only for constituents to avoid conflicts with
* rdtunebgobs module
* - Rewritten to ensure consistency of DAMPLIBG subsets to ordering
* of incremental analysis variables and to simplify code.
* - Added above comment on usage for R&D.
*
*Remarks:
* Unused comdecks remain to be removed.
*
* -------------------
*
*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 "comgdpar.cdk"
#include "rpnstd.cdk"
#include "comgd0.cdk"
#include "comsp.cdk"
#include "comspg.cdk"
#include "compost.cdk"
#include "comfilt.cdk"
#include "comleg.cdk"
#include "compstat.cdk"
#include "comnumbr.cdk"
#include "comchem.cdk"
#include "comstate.cdk"
c
integer jk,ji,jj,kk,kulfile
integer isrchila,jregion,klatn,klatn2,klats,klats2
logical lexist
REAL*8, ALLOCATABLE :: zpresin(:), zfacttr2d(:,:)
REAL*8, ALLOCATABLE :: zfacttrin(:,:), zfacttrout(:,:)
integer ielement, istat
REAL*8 zplevel
character*8 cfam_name
real*8 znorth, zsouth, ztrop
real*8 zet, zmeanps, qpeta(nflev)
integer npin, nregions
integer npos, idspec, npinmax
real*8 ztodeg,ztorad
c
integer klun,knum,ifound
character*10 name
character*4 nomv
real*8 pmass
c
write(nulout, *) 'BEGIN ch_tunebgcoef'
C
ztodeg = 1.d0/(rpi/180.d0)
ztorad = 1.d0/ztodeg
kulfile=39
C
C Number of input pressure levels -- default
C
npinmax = 100
nregions = 3
c
c Allocate local arrays
c
allocate(zfacttrin(npinmax, nregions))
allocate(zpresin(npinmax))
allocate(zfacttrout(nflev,nregions))
allocate(zfacttr2d(nflev,nj))
c
c Read in input BG error variance tuning factors
c
inquire(file='./background_tune.dat', exist=lexist)
if(.not.lexist) then
write(nulout, *) '************* WARNING !!! *************'
write(nulout, *) 'File of BG variance tuning coefficients should exist but does not'
return
endif
open(unit=kulfile,form='formatted',file='./background_tune.dat')
read(kulfile,FMT=*)
read(kulfile,FMT=*)
read(kulfile,FMT=*)
klun=0
ierr=fnom(klun,'tablespecies','FTN+R/O',0)
if (ierr.lt.0) then
CALL ABORT3D(NULOUT,'CH_TUNEBGCOEF: File "tablespecies" not found.')
end if
do while (.true.)
read(66,FMT=*, IOSTAT=istat) npin
if(istat .lt. 0) exit
c
c Following code assumes the list of length 'npin' is for
c a single set of idspec and cfam_name.
c
read(kulfile, fmt=*, IOSTAT=istat) cfam_name, ielement,
& idspec, zplevel, znorth, ztrop, zsouth
if(istat .lt. 0) then
CALL ABORT3D(NULOUT,'CH_TUNEBGCOEF: Problem with stats coeff file.')
end if
c
c Identify constituent and position in list of GD (CGNEED) 3D variables
c
call ch_speciesinfo(1,name,idspec,pmass,nomv,1,knum,klun,nulout)
ifound=0
do npos=1,NGCMT
if (nomv.eq.CGCMT(npos)) then
ifound=1
exit
end if
end do
if (ifound.eq.0.or.trim(cfam_name).ne.trim(ctunetrbg)) then
do kk = 2, npin
read(kulfile, fmt=*, IOSTAT=istat)
end do
cycle
end if
zfacttrin(npin,1) = sqrt(znorth)
zfacttrin(npin,2) = sqrt(ztrop)
zfacttrin(npin,3) = sqrt(zsouth)
c
zpresin(npin) = zplevel*100.
do kk = 2, npin
read(kulfile, fmt=*, IOSTAT=istat) cfam_name, ielement, idspec, zplevel, znorth, ztrop, zsouth
if(istat .lt. 0) then
CALL ABORT3D(NULOUT,'CH_TUNEBGCOEF: Problem with stats coeff file.')
end if
zfacttrin(npin-kk+1,1) = sqrt(znorth)
zfacttrin(npin-kk+1,2) = sqrt(ztrop)
zfacttrin(npin-kk+1,3) = sqrt(zsouth)
c
zpresin(npin-kk+1) = zplevel*100.
enddo !(kk)
c
c print out profiles
c
write(nulout,*) 'Input BG stddev tuning coefficients for constituent ', idspec,cfam_name
do jk=1,npin
write(nulout,'(3x, f10.4, 3(4x, f10.4))')
+ zpresin(jk)/100.,(zfacttrin(jk,jregion), jregion=1,nregions)
enddo
c
c Interpolate scaling factors from input levels to incremental analysis levels
c
c First, set "approx." destination pressure levels from eta increment analysis levels.
c
zet=rptopinc/rprefinc
zmeanps = 101300.
DO JK=1,NFLEV
qpeta(jk)=rprefinc*vhybinc(jk)+(zmeanps-rprefinc)
+ *((vhybinc(jk)-zet)/(1.0-zet))**rcoefinc
ENDDO
DO KK=1, NREGIONS
call LINTV2(zpresin,zfacttrin(1:npin,kk),npinmax,
+ npin,1, nflev, qpeta, zfacttrout(1:npin,kk))
ENDDO
write(nulout,*) 'BG stddev tuning coefficients after vertical interpolation'
do jk=1,nflev
write(nulout,'(3x, f10.4, 3(4x, f10.4))')
+ qpeta(jk)/100.,(zfacttrout(jk,jregion), jregion=1,nregions)
enddo
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
write(nulout, *)'Grid boundaries=',klatn,klatn2,klats,klats2
do jk=1,nflev
do jj=1,NJ
if(jj.lt.klatn) then
c North of 25: constant
zfacttr2d(jk,jj)=zfacttrout(jk,1)
elseif(jj.gt.klats) then
c South of -25: constant
zfacttr2d(jk,jj)=zfacttrout(jk,3)
elseif(jj.le.klatn2.and.jj.ge.klatn) then
c Interpolate in between 15N and 25N
zfacttr2d(jk,jj)=((jj-klatn)*zfacttrout(jk,2)+
+ (klatn2-jj)*zfacttrout(jk,1))/(klatn2-klatn)
elseif(jj.le.klats.and.jj.ge.klats2) then
c Interpolate in between 15S and 25S
zfacttr2d(jk,jj)=((jj-klats2)*zfacttrout(jk,3)+
+ (klats-jj)*zfacttrout(jk,2))/(klats-klats2)
else
c Tropics: constant
zfacttr2d(jk,jj)=zfacttrout(jk,2)
endif
enddo
enddo
write(nulout,*) 'Interpolated scaling factors:'
do jk=1,nflev
write(nulout,'(I4,10F8.3)') jk,(zfacttr2d(jk,jj), jj =1,nj,2)
enddo
c Store BG std dev scaling to DAMPLIBG
c Offset of 4*nflev+1 in damplibg to respect assignment
c for meteo variables in rdtunebgobs.ftn (and its use elsewhere).
c 'npos' value starts at one for the first constituent.
do jj=1,nj
do jk=1,nflev
do ji=1,ni
damplibg(ji,jk+(npos-1+4)*nflev,jj)=zfacttr2d(jk,jj)
enddo
enddo
enddo
enddo !while
c
ierr=fclos(klun)
close(kulfile)
c
c deallocate dynamic variables
c
deallocate(zfacttrin)
deallocate(zpresin)
deallocate(zfacttrout)
deallocate(zfacttr2d)
write(nulout, *) 'END ch_tunebgcoef'
return
end