SUBROUTINE CH_GENOPER(PLAT,JLAT,KNULOUT,PRESS,KSTATE,PSTATE, 2
1 CDVAR,PWIN,PH,PHP,PG,KNFLEV)
c
IMPLICIT NONE
c
c* Declaration of arguments
c
CHARACTER*(*) CDVAR
INTEGER KNULOUT,KNFLEV,KSTATE,JLAT
REAL*8 PWIN,PH(KNFLEV),PHP(KNFLEV),PG(KNFLEV)
REAL*8 PRESS(KNFLEV),PLAT,PSTATE(KNFLEV)
C
#if defined (DOC)
*----------------------------------------------------------------------
*
***s/r CH_GENOPER
*
*Author : Y.J. Rochon *ARQX/MSC November 2004
*Revision:
* Y.J. Rochon *ARQX/MSC Dec 2012
* - Corrections and simplications
*
* -------------------
*
** Purpose: Set generalized innovation operator for individual
* integral obs.
*
*Arguments:
*
* INPUT:
*
* KNULOUT: Output unit index
* CDVAR: Model variable name
* PWIN: Fractional windowing/cutoff value applied to be applied
* PHP. If <=0 or >=1, no windowing performed.
* PRESS: Pressure levels (Pascal)
* KNFLEV: Array dimension (must be >= NFLEV)
* PLAT: Latitude of obs. (=ROBHDR(NMCLAT,obs index)
* JLAT: Latitude index (=MOBHDR(NCMTLA,obs index)
* PH(NFLEV): Complete TLM
* PHP(NFLEV):Part of TLM with physics (excludes resolution dependence)
* KSTATE: Flag indicating if the state profile will be part of the
* generalized innovation operator (1 for yes, 0 for no)
* PSTATE(NFLEV):
* State profile provided when KSTATE=1
*
* OUTPUT:
*
* PG(NFLEV): Final innovation operator.
*
*Comments:
*
* (1) Must only be applied when knflev=nflev.
*
* (2) This routine prepares an alternative operator g (PG), called
* the generalized innovation operator, to take the place of the
* innovation (TLM) operator h (row array; PH). The operator g is
* specified as:
*
* g = a*w
*
* where a is a proportionality constant ensuring that the innovation
* increment remains unchanged for the 1D case in the absence
* of other obs., i.e.,
*
* a^2 = (h*B*h^T)(w*B*w^T)^{-1},
* B is the initial physical space covariance matrix
* (includes variances and vertical correlation matrix only),
* w is a weigthing array (row array) specified below.
*
* The weighting array w is set as:
*
* w=h'*P*S^{-1} or w = h'*x*P*S^{-1} or w=h'*P*V*B^{-1}
* or w=h'*x*P*V*B^{-1}
*
* where h' is the part of h which excludes resolution dependence
* (only contains the physics part of h; PHP),
* x is the state profile PSTATE (when KSTATE=1)
* P is a diagonal window/cutoff matrix (see PWIN), and
* V is an alternative vertical correlation matrix (PHWHM, VCOR)
* B is the original covariance matrix (in 2D)
*
* Application of the state profile (KSTATE=1) is to make the
* increment profile be more proportional to the state profile.
*
*-----------------------------------------------------------------------
#endif
c
c* Global variables
c
#include "pardim.cdk"
#include "comdim.cdk"
#include "comlun.cdk"
#include "comcorr.cdk"
#include "comgem.cdk"
#include "comleg.cdk"
#include "comstate.cdk"
#include "comgdpar.cdk"
#include "rpnstd.cdk"
#include "comspg.cdk"
#include "comvarstd.cdk"
#include "comcorvert.cdk"
#include "comchem.cdk"
c
integer istart
common /istart/istart
c
c* Declaration of local variables
c
integer ivar,jk,j,ilev
real*8 zsum,zg(nflev),zwbw,zhbh,za,zsum2
real*8 zstd(nflev),zvar(nflev),zc1,zc2,zmax
c
real*8 scaleh(nflev)
istart=istart+1
scaleh(:)=1.0
c
if (knflev.ne.nflev) then
call abort3d(knulout,
& 'CH_GENOPER: Dimension not compatible')
end if
c
c* Identify index of variable according to ng*
c in sustate.ftn, comstate.cdk, and comchem.cdk). 3D field assumed.
c
ivar=0
if (CDVAR.eq.'UU') then
ivar=nguu
else if (CDVAR.eq.'VV') then
ivar=ngvv
else if (CDVAR.eq.'GZ') then
ivar=nggz
else if (CDVAR.eq.'TT') then
ivar=ngtt
else if (CDVAR.eq.'HU') then
ivar=ngq
else
do j=1,NGCMT
if (CDVAR.eq.CGCMT(j)) then
ivar=ngtr(J)
if (CDVAR.EQ.'O3') then
scaleh(1:6)=800.
do jk=7,12
scaleh(jk)=800.-400*(jk-6)/(13.-6.)
end do
scaleh(13)=400.
do jk=14,32
scaleh(jk)=400.-190*(jk-13)/(33.-13.)
end do
scaleh(33)=210.
do jk=34,79
scaleh(jk)=210.-60*(jk-33)/(80.-33.)
end do
scaleh(80)=150.
scaleh(1:79)=scaleh(1:79)/scaleh(80)
scaleh(80)=1.0
end if
go to 500
end if
end do
500 continue
end if
if (ivar.eq.0) then
write(knulout,2010) cdvar
call abort3d(knulout,
& 'CH_GENOPER: Field not found')
end if
2010 FORMAT(//,'Variable: ',A2)
c
c* Apply cutoff to PHP (set h'*P)
c
if (pwin.gt.0.0.and.pwin.lt.1.0) then
zmax=0.0D0
do j=1,nflev
if (dabs(php(j)).gt.zmax) zmax=dabs(php(j))
end do
zmax=pwin*zmax
do j=1,nflev
if (dabs(php(j)).lt.zmax) php(j)=0.0D0
end do
end if
c
c* Apply state vector if requested
c
cc if (kstate.eq.1) php(1:nflev)=php(1:nflev)*pstate(1:nflev)
cc zg(1:nflev)=php(1:nflev)
if (kstate.eq.1) php(1:nflev)=php(1:nflev)*pstate(1:nflev)
zg(1:nflev)=php(1:nflev)
C
C Identify background error std. dev.
C
zc1=(PLAT-RLATI(jlat+1))/(RLATI(jlat)-RLATI(jlat+1))
zc2=zc2*zc2
c
ilev=nflev*(ivar-1)
do j=1,nflev
zvar(j)=rgsig(jlat,ilev+j)*rgsig(jlat,ilev+j)*zc2+
& rgsig(jlat+1,ilev+j)*rgsig(jlat+1,ilev+j)*zc1
zstd(j)=sqrt(zvar(j))
end do
c
c Finalize w
c
do jk=1,nflev
zsum=dot_product(corvertt(jk,1:nflev,ivar),zstd(1:nflev))
zvar(jk)=zstd(jk)*zsum
c3 zvar(jk)=zstd(jk)*zstd(jk)
end do
zvar(1:nflev)=zvar(1:nflev)*scaleh(1:nflev)
pg(1:nflev)=zg(1:nflev)/zvar(1:nflev)
c
c* Determine proportionality factor 'a'
c
c First determine/estimate w*B*w^T and h*B*h^T
c
zwbw=0.0D0
zhbh=0.0D0
do jk=1,nflev
zsum=0.0D0
zsum2=0.0D0
do j=1,nflev
za=corvertt(jk,j,ivar)*zstd(j)*sqrt(scaleh(j))
zsum=zsum+za*pg(j)
zsum2=zsum2+za*ph(j)
end do
za=zstd(jk)*sqrt(scaleh(jk))
zwbw=zwbw+pg(jk)*za*zsum
zhbh=zhbh+ph(jk)*za*zsum2
end do
c
c1 zwbw=dot_product(pg(1:nflev)*pg(1:nflev),zvar(1:nflev))
c1 zhbh=dot_product(ph(1:nflev)*ph(1:nflev),zvar(1:nflev))
c
c Set 'a'
c
za=sqrt(zhbh/zwbw)
c
c* Set innovation operator g
c
pg(1:nflev)=pg(1:nflev)*za
c
return
end