SUBROUTINE CH_RDSBALOPER 1,2
C
*---------------------------------------------------------
#if defined (DOC)
*
**s/r ch_rdsbaloper - Read in balance operators spectral coefficients
* related to species
*
*Author : Y.J. Rochon, ARQX/MSC April 2007
*
*Revision:
*
* -------------------
*
* PURPOSE: Read in balance operators spectral coefficients
* related to species
*
* NOTES:
*
* 1) See rdspptot.ftn for reference in constructing/reading file.
*
* 2) Providing of the correct covariances of the transformed variable
* is the user's responsibility. Note that the NOMVAR of stored
* covariances for the transformed and untransformed is assumed
* the same.
*
* One option the user/originator has is to include
* a covariance transformation in this routine instead of
* reading new covariances for the transformed variable.
*
*
*Arguments:
*
* INPUT
*
* OUTPUT
*
*-----------------------------------------------------------
#endif
IMPLICIT NONE
C
C Global variables
C
#include "comdim.cdk"
#include "comlun.cdk"
#include "comchem.cdk"
#include "comstate.cdk"
#include "combalop.cdk"
#include "comspg.cdk"
#include "rpnstd.cdk"
C
C* Local variables
C
integer j,in1,in2,j1,ifound,ikey
real*8 zbalop(nflev,nflev,nj)
real*8 zbuffer(nj,nflev)
logical sigtrans
C
sigtrans=.TRUE.
if (nbalop.eq.0) return
C
WRITE(NULOUT,*) ' '
WRITE(NULOUT,*) 'Enter CH_RDSBALOPER: NBALOP=',NBALOP
WRITE(NULOUT,*) ' '
C
IF (NBALOP.GT.NBALNUM1.OR.NBALOP*NJ.GT.NBALNUM2.OR.
& NFLEV.GT.NBALNUM3) THEN
WRITE(NULOUT,*) 'NBALOP,NBALOP*NJ,NFLEV =',
& NBALOP,NBALOP*NJ,NFLEV
CALL ABORT3D(NULOUT,'CH_RDSBALOPER: Dimension error!')
END IF
C
open(unit=668,file='./unbalanced_stddev.asc',status='UNKNOWN')
open(unit=667,file='./total_stddev.asc',status='UNKNOWN')
DO J=1,NBALOP
C
WRITE(NULOUT,*) 'J ',J
C
C Identify index of source field (in GD)
C
IFOUND=0
IF (CBALOPSRC(J).eq.'UU') THEN
IFOUND=NGPOSIT(NGUU)
ELSE IF (CBALOPSRC(J).eq.'VV') THEN
IFOUND=NGPOSIT(NGVV)
ELSE IF (CBALOPSRC(J).eq.'GZ') THEN
IFOUND=NGPOSIT(NGGZ)
ELSE IF (CBALOPSRC(J).eq.'HU'.or.CBALOPSRC(J).eq.'LQ') THEN
IFOUND=NGPOSIT(NGQ)
CBALOPSRC(J)='LQ'
ELSE IF (CBALOPSRC(J).eq.'TT') THEN
IFOUND=NGPOSIT(NGTT)
ELSE IF (CBALOPSRC(J).eq.'VV') THEN
IFOUND=NGPOSIT(NGVV)
ELSE IF (CBALOPSRC(J).eq.'P0') THEN
IFOUND=NGPOSIT(NGPS)
ELSE IF (CBALOPSRC(J).eq.'TG') THEN
IFOUND=NGPOSIT(NGTG)
ELSE
DO J1=1,NGCMT
IF (CBALOPSRC(J).eq.CGCMT(J1)) THEN
IFOUND=NGPOSIT(NGTR(J1))
EXIT
END IF
END DO
END IF
IF (IFOUND.GT.0) THEN
NBALSRC(J)=IFOUND
WRITE(NULOUT,*) 'CBALOPSRC(J),ILOC = ',CBALOPSRC(J),IFOUND
ELSE
WRITE(NULOUT,*) 'CBALOPSRC = ',CBALOPSRC(J)
CALL ABORT3D(NULOUT,'CH_RDSBALOPER: SRC field not found!')
END IF
C
C Identify index of destination field (in GD)
C
IFOUND=0
IF (CBALOPDEST(J).eq.'UU') THEN
IFOUND=NGPOSIT(NGUU)
ELSE IF (CBALOPDEST(J).eq.'VV') THEN
IFOUND=NGPOSIT(NGVV)
ELSE IF (CBALOPDEST(J).eq.'GZ') THEN
IFOUND=NGPOSIT(NGGZ)
ELSE IF (CBALOPDEST(J).eq.'HU'.or.CBALOPDEST(J).eq.'LQ') THEN
IFOUND=NGPOSIT(NGQ)
CBALOPDEST(J)='LQ'
ELSE IF (CBALOPDEST(J).eq.'TT') THEN
IFOUND=NGPOSIT(NGTT)
ELSE IF (CBALOPDEST(J).eq.'VV') THEN
IFOUND=NGPOSIT(NGVV)
ELSE IF (CBALOPDEST(J).eq.'P0') THEN
IFOUND=NGPOSIT(NGPS)
ELSE IF (CBALOPDEST(J).eq.'TG') THEN
IFOUND=NGPOSIT(NGTG)
ELSE
DO J1=1,NGCMT
IF (CBALOPDEST(J).eq.CGCMT(J1)) THEN
IFOUND=NGPOSIT(NGTR(J1))
EXIT
END IF
END DO
END IF
IF (IFOUND.GT.0) THEN
NBALDEST(J)=IFOUND
WRITE(NULOUT,*) 'CBALOPDEST(J),ILOC = ',CBALOPDEST(J),IFOUND
ELSE
WRITE(NULOUT,*) 'CBALOPDEST = ',CBALOPDEST(J)
CALL ABORT3D(NULOUT,'CH_RDSBALOPER: Dest. field not found!')
END IF
C
C Read and store any requested operator (input file name and
C form of expected operator hardcoded by originator)
C
CALL CH_RDBALOP(CBALOPFILE,CBALOPDEST(J),CBALOPETIK(J),
& in1,in2,zbalop,nj,nflev)
C
nbali(J)=in1
if ((in1.ne.1.and.in1.ne.nflev).or.in2.ne.nflev)
& CALL ABORT3D(NULOUT,'CH_RDSBALOPER: Dimension error!')
C
balop(1:in1,1:in2,1+(j-1)*nj:j*nj)=
& zbalop(1:in1,1:in2,1:nj)
C
c write(6,*) 'baloper ',balop(1,1+nflev/3,1+(j-1)*nj:j*nj)
C
C Correspondindly modify std. dev. of unbalanced/destination field
C
if (sigtrans) then
C
C Identify location of fields in std. dev. arrays
C
ifound=0
if (CBALOPDEST(J).eq.'UU') then
ifound=NSPOSIT(NSVOR)
else if (CBALOPDEST(J).eq.'VV') then
ifound=NSPOSIT(NSDIV)
else if (CBALOPDEST(J).eq.'TT') then
ifound=NSPOSIT(NSTT)
else if (CBALOPDEST(J).eq.'LQ'.OR.CBALOPDEST(J).eq.'HU') then
ifound=NSPOSIT(NSQ)
else if (CBALOPDEST(J).eq.'GZ') then
ifound=NSPOSIT(NSGZ)
else if (CBALOPDEST(J).eq.'P0') then
ifound=NSPOSIT(NSPS)
else if (CBALOPDEST(J).eq.'TG') then
ifound=NSPOSIT(NSTG)
else
DO J1=1,NSCMT
IF (CBALOPDEST(J).eq.CSCMT(J1)) THEN
IFOUND=NSPOSIT(NSTR(J1))
EXIT
END IF
END DO
end if
IF (IFOUND.GT.0) THEN
in1=IFOUND
WRITE(NULOUT,*) 'CBALOPDEST(J) sigma field index = ',IFOUND
ELSE
WRITE(NULOUT,*) 'CBALOPDEST = ',CBALOPDEST(J)
CALL ABORT3D(NULOUT,'CH_RDSBALOPER: Dest. field not found!')
END IF
C
ifound=0
if (CBALOPSRC(J).eq.'PP') then
ifound=NSPOSIT(NSVOR)
else if (CBALOPSRC(J).eq.'UC') then
ifound=NSPOSIT(NSDIV)
else if (CBALOPSRC(J).eq.'UT') then
ifound=NSPOSIT(NSTT)
else if (CBALOPSRC(J).eq.'HU'.OR.CBALOPSRC(J).eq.'LQ') then
ifound=NSPOSIT(NSQ)
else if (CBALOPSRC(J).eq.'GZ') then
ifound=NSPOSIT(NSGZ)
else if (CBALOPSRC(J).eq.'P0') then
ifound=NSPOSIT(NSPS)
else if (CBALOPSRC(J).eq.'TG') then
ifound=NSPOSIT(NSTG)
else
DO J1=1,NSCMT
IF (CBALOPSRC(J).eq.CSCMT(J1)) THEN
IFOUND=NSPOSIT(NSTR(J1))
EXIT
END IF
END DO
end if
IF (IFOUND.GT.0) THEN
in2=IFOUND
zbuffer=rgsig(1:nj,in2:in2+nflev-1)
WRITE(NULOUT,*) 'CBALOPSRC(J) sigma field index = ',IFOUND
ELSE
IKEY = VFSTLIR(ZBUFFER,nulbgst,INI,INJ,INK,-1
& ,'STDDEV',-1,-1,-1,' ',CBALOPSRC(J))
if (ikey.gt.0) then
WRITE(NULOUT,*) 'CBALOPSRC(J) std. dev. found.'
else
WRITE(NULOUT,*) 'CBALOPSRC = ',CBALOPSRC(J)
CALL ABORT3D(NULOUT,'CH_RDSBALOPER: Dest. field not found!')
end if
END IF
C
C Complete balance operator and apply std. dev. adjustment
C
c write(nulout,*) 'Init. rgsig: ',rgsig(1:nj,in1+nflev/3)
C
do j1=0, nflev-1
write(667, 400)(rgsig(in2,in1+j1),in2=nj,1,-1)
enddo
write(667,*)
C
IF (NBALI(J).eq.1) THEN
C
C Matrix operator: Does not include spatial correlation and
C is a function only of latitude and vertical level.
C
C---- Correlation coefficients were provided. First,
C convert to decoupling (balance) operator.
C
zbalop(1,1:nflev,1:nj)=zbalop(1,1:nflev,1:nj)*
& transpose(rgsig(1:nj,in1:in1+nflev-1))/
& transpose(zbuffer)
balop(1,1:nflev,1+(j-1)*nj:j*nj)=
& zbalop(1,1:nflev,1:nj)
C
C----
rgsig(1:nj,in1:in1+nflev-1)=
& sqrt(max(0.0001*rgsig(1:nj,in1:in1+nflev-1)**2,
& rgsig(1:nj,in1:in1+nflev-1)**2-
& (transpose(zbalop(1,1:nflev,1:nj))*zbuffer)**2))
C
ELSE
C
C Matrix operator: Includes vertical correlation and
C is a function only of latitude and vertical level.
C
C TBD
C
END IF
C
do j1=0, nflev-1
write(668, 400)(rgsig(in2,in1+j1),in2=nj,1,-1)
enddo
write(668,*)
C
c write(nulout,*) 'balop: ',zbalop(1,1+nflev/3,1:nj)
c write(nulout,*) 'zbuffer: ',zbuffer(1:nj,1+nflev/3)
c write(nulout,*) 'final rgsig: ',rgsig(1:nj,in1+nflev/3)
C
end if
C
END DO
C
WRITE(NULOUT,*) ' '
WRITE(NULOUT,*) 'Exit CH_RDSBALOPER'
WRITE(NULOUT,*) ' '
C
close (unit=667,status='KEEP')
close (unit=668,status='KEEP')
400 format(2x, 7(g11.5, 3x))
return
end