SUBROUTINE CH_RDSPLITOPER(poper, knstatlev,jvar,SPLITOPER, SPLITOPERD) 1,6
#if defined (DOC)
*
**s/r ch_rdsplitoper -Read in splitting operator spectral coefficients
* .
* Purpose
* . Read in coefficients for splitting operator for use in updating the
* unobserved species, i.e. Pux(Pxx)^-1
* . Vertical interpolation of operators
*
*Author : Y. Yang, based on S. Pellerin's subroutine rdspptot
*Revision:
*Arguments:
* in:
* poper : operator for vertical interpolation
* knstatlev : number of vertical levels of statistics array read in
* jvar : index of the correlation pairs
#endif
IMPLICIT NONE
*implicits
*
* Global variables
*
#include "comdim.cdk"
#include "comlun.cdk"
#include "comleg.cdk"
#include "comcorr.cdk"
#include "rpnstd.cdk"
#include "cominterp.cdk"
#include "comsplit.cdk"
#include "pardim.cdk"
*
* Local variables
*
integer knstatlev
real*8 poper(nflev,knstatlev)
integer jvar
c REAL*8 SPLITOPER(NFLEV, NFLEV, NJ)
c REAL*8 SPLITOPERD(NFLEV, NJ)
*
integer jn, jk1, jk2, ikey, ilen,jlat,jcol
character*4 clnomvar4
real*8 zopersrc,zspoper,zgroper,zoperecr
& ,zopermix, zspoperd, zgroperd
real*8 zopersrcd
real*8 zleg,zwork
real*8 hsqrt2
pointer (pxzspoper,zspoper(0:ntrunc,nflev,nflev))
pointer (pxzspoperd,zspoperd(0:ntrunc,nflev))
pointer (pxzgroper,zgroper(nj,nflev,nflev))
pointer (pxzgroperd,zgroperd(nj,nflev))
pointer (pxzleg,zleg(0:ntrunc,nj))
pointer (pxzoperecr,zoperecr(nflev,nflev,nj))
*
pointer (pxzopermix,zopermix(nflev,knstatlev))
*
pointer (pxzopersrc,zopersrc(knstatlev,knstatlev))
pointer (pxzopersrcd,zopersrcd(knstatlev))
real z4lev_trl(jpnflev)
integer ip1_all
integer iip1,iip2, iip3,iip1s_trl(jpnflev)
real*8 zlev_trl(jpnflev)
integer itrlnlev,ITRLGID
integer ip1_pak_trl,ip1_vco_trl
real*8 zmean_glb(nflev)
integer ii, jj, jlev, ikind, imode, ibrpstamp
real*8 zvhvar2d(1)
real*8, allocatable :: zmean_trial(:,:)
pointer (pxvhvar2d,zvhvar2d)
c pointer (pxmean_trial,zmean_trial)
character*1 clstring
integer vfstluk
character*4 cnomvar
c logical LSCAL_OPER
C ------------------------------------------------------
write(nulout,*) 'CH_RDSPLITOPER - Begin'
*
* Allocating local arrays
*
ilen = (ntrunc+1) * nflev * nflev
call hpalloc(pxzspoper,max(1,ilen),ierr,8)
ilen = nj * nflev * nflev
call hpalloc(pxzgroper,max(1,ilen),ierr,8)
ilen = nj * nflev
call hpalloc(pxzgroperd,max(1,ilen),ierr,8)
ilen = (ntrunc + 1) * nj
call hpalloc(pxzleg,max(1,ilen),ierr,8)
ilen = nj * nflev * nflev
call hpalloc(pxzoperecr,max(1,ilen),ierr,8)
*
ilen = nflev * knstatlev
call hpalloc(pxzopermix,max(1,ilen),ierr,8)
*
ilen = knstatlev * knstatlev
call hpalloc(pxzopersrc,max(1,ilen),ierr,8)
*
* for diagno operator
*
ilen = (ntrunc+1) * nflev
call hpalloc(pxzspoperd,max(1,ilen),ierr,8)
ilen = knstatlev
call hpalloc(pxzopersrcd,max(1,ilen),ierr,8)
*
* set up simple spectral transforms
*
C for transformation constant
C
hsqrt2=sqrt(2.0D0)/2.0D0
write(nulout,*) 'CH_RDSPLITOPER: set up simple spectral transforms'
call zlegpol(zleg,rmu,nj,ntrunc,ntrunc,nj)
*
if (LDIAGNO) then
*
* diagno-like operator, i.e. without cross-level correlations
*
ip1 = -1
ip3 = -1
idateo = -1
cletiket = 'S_SPLITD'//cvaranal(jvar)
cltypvar = 'X'
clnomvar4 = cvarunobs(jvar)
C
c read of spectral coefficients for theta
c
write(nulout,*) 'CH_RDSPLITOPER: Start reading in diagno operator from unit:'
& ,nulbgst
do jn = 0,ntrunc
ip2 = jn
ikey = vfstlir(zopersrcd,nulsplitoper,ini,inj,ink
& ,idateo,cletiket,ip1,ip2,ip3,cltypvar,clnomvar4)
c
IF(IKEY .LT.0 ) THEN
CALL ABORT3D(NULOUT
& ,'CH_RDSPLITOPER: Problem with diagno stat file')
ENDIF
c
if (ini .ne. knstatlev) then
CALL ABORT3D(NULOUT
& ,'CH_RDSPLITOPER: diagno BG stat levels inconsitencies')
endif
c
c for spectral transform constant
c
zopersrcd(:)=zopersrcd(:)/hsqrt2
if(lvintbgstat) then
c
c Vertical interpolation O'm = Vmn On
c
call mxmaop1(poper,1,nflev,zopersrcd,1,knstatlev,zspoperd(jn,1)
& ,ntrunc+1,1,nflev,knstatlev,1)
else
do jk1 = 1,nflev
zspoperd(jn,jk1) = zopersrcd(jk1)
enddo
endif
*
enddo
*
c converting diagno operator in physical space
c
write(nulout,*) 'CH_RDSPLITOPER: converting diagno operator in physical space'
call zleginv2(zgroperd,zspoperd,zleg,ntrunc,nj,nflev,nj,nflev
& ,ntrunc)
*
do jlat = 1, nj
do jk1 = 1, nflev
splitoperd(jk1,jlat) = zgroperd(jlat,jk1)
end do
end do
c
if ( kulsplitgd .gt. 0 ) then
ierr = fstprm(ikey,idateo,ideet,inpas,ini,inj,ink, inbits,
& idatyp,ip1,ip2,ip3,cltypvar,clnomvar,cletiket,clgrtyp,ig1
& ,ig2,ig3,ig4,iswa,ilength,idltf,iubc,iextr1,iextr2,iextr3)
c
ini = nflev
inj = nj
ink = 1
ip1 = 0
ip2 = 0
cletiket = 'G_SPLITD'//cvaranal(jvar)
c
ierr = vfstecr(splitoperd, zwork, -inbits, kulsplitgd, idateo, ideet,
& inpas, ini, inj, ink, ip1, ip2, ip3, cltypvar, clnomvar4,
& cletiket,clgrtyp,ig1, ig2, ig3, ig4, idatyp, .true.)
c
endif
else !(LDIAGNO)
*
* non-diagno operator, i.e. like the P-TO-T operator with vertical
* correlations
*
write(nulout,*) 'CH_RDSPLITOPER: Start Reading in S_SPLITN from unit:'
& ,nulbgst
write(nulout,*) 'clnomvar4= ' ,clnomvar4, ' cletiket = ' , cletiket
ip1 = -1
ip2 = -1
ip3 = -1
idateo = -1
cletiket = 'S_SPLITN'//cvaranal(jvar)
cltypvar = 'X'
clnomvar4 = cvarunobs(jvar)
C
c read of spectral coefficients for splitting operator
c
do jn = 0,ntrunc
ip2 = jn
ikey = vfstlir(zopersrc,nulsplitoper,ini,inj,ink
s ,idateo,cletiket,ip1,ip2,ip3,cltypvar,clnomvar4)
c
IF(IKEY .LT.0 ) THEN
CALL ABORT3D(NULOUT
& ,'CH_RDSPLITOPER: Problem with non-diagno operator stat file')
ENDIF
c
if (ini .ne. knstatlev .or. inj .ne. knstatlev) then
call abort3d(nulout
& ,'CH_RDSPLITOPER: non-diagno Operator stat levels inconsitencies')
endif
c
c for spectral transform constant
c
zopersrc(:,:)=zopersrc(:,:)/hsqrt2
c
if(lvintbgstat) then
c
c Vertical interpolation of splitting operator
c First Vertical interpolation: P'mn = Vmn Pnn
c
call mxmaop1(poper,1,nflev,zopersrc,1,knstatlev,zopermix,1
& ,nflev,nflev,knstatlev,knstatlev)
c
c Second Vertical interpolation: P''mm = P'mn (Vnm)
c
call mxmaop1(zopermix,1,nflev+1,poper,knstatlev,1,zspoper(jn,1
& ,1),ntrunc+1,(ntrunc+1)*(nflev+1),nflev+1,knstatlev,nflev
& )
c
else
do jk2 = 1,nflev
do jk1 = 1,nflev
zspoper(jn,jk1,jk2) = zopersrc(jk1,jk2)
enddo
enddo
endif
enddo
c
write(nulout,*) 'CH_RDSPLITOPER: converting operator into physical space'
ilen = nflev*nflev
call zleginv2(zgroper,zspoper,zleg,ntrunc,nj,ilen,nj,ilen
& ,ntrunc)
c
do jlat = 1, nj
do jk2 = 1,nflev
do jk1 = 1, nflev
splitoper(jk1,jk2,jlat) = zgroper(jlat,jk1,jk2)
end do
end do
enddo
c
c store diagno elements for plotting
c
do jlat = 1, nj
do jk2 = 1,nflev
splitoperd(jk2,jlat)= splitoper(jk2,jk2,jlat)
end do
enddo
c ---------------------------------------------------
if ( kulsplitgd .gt. 0 ) then
ierr = fstprm(ikey,idateo,ideet,inpas,ini,inj,ink, inbits,
& idatyp,ip1,ip2,ip3,cltypvar,clnomvar4,cletiket,clgrtyp,ig1
& ,ig2,ig3,ig4,iswa,ilength,idltf,iubc,iextr1,iextr2,iextr3)
c
do jlat = 1, nj
do jk2 = 1,nflev
do jk1 = 1, nflev
zoperecr(jk1,jk2,jlat) = splitoper(jk1,jk2,nj-jlat+1)
end do
end do
enddo
c
ini = nflev
inj = nflev
ink = nj
ip1 = 0
ip2 = 0
cletiket = 'G_SPLITN'//cvaranal(jvar)
c
ierr = vfstecr(zoperecr, zwork, -inbits, kulsplitgd, idateo,
& ideet, inpas, ini, inj, ink, ip1, ip2, ip3, cltypvar,
& clnomvar4, cletiket,clgrtyp,ig1, ig2, ig3, ig4, idatyp,
& .true.)
c
endif
endif !(LDIAGNO)
c
c scale the operator by the ratio of zonal mean of concentration to
C the global mean of unobserved variable
c
if (LSCAL_OPER) then
c
C Field parameters associated with unobserved variables
C
cletiket=''
clgrtyp=''
cltypvar=''
iip2=-1
iip3=-1
ibrpstamp=-1
call getfldprm(IIP1S_TRL,IIP2,IIP3,ITRLNLEV,CLETIKET,CLTYPVAR
& ,ITRLGID,cvarunobs(jvar),ibrpstamp,jpnflev,ninmpg_unobs
& ,nulout,ip1_pak_trl,ip1_vco_trl)
c
c Sort the levels encoded in IIP1S_TRL
c
c Decode the levels
C
imode = -1
ikind = ip1_vco_trl
do jlev = 1,itrlnlev
call VCONVIP( iip1s_trl(jlev), zlev_trl(jlev), ikind, imode,
& clstring,.false. )
enddo
c
call vsort(zlev_trl,itrlnlev)
c
c Encode iip1s_trl to match the sorted zlev_trl
C
imode = ip1_pak_trl
ikind = ip1_vco_trl
do jlev = 1,itrlnlev
z4lev_trl(jlev) = zlev_trl(jlev)
call VCONVIP( iip1s_trl(jlev), zlev_trl(jlev), ikind, imode,
& clstring,.false. )
enddo
c
c read trial field of unobserved to calculate zonal mean
c
cletiket=''
clgrtyp=''
cltypvar=''
iip2=-1
iip3=-1
cnomvar=cvarunobs(jvar)
ibrpstamp= -1
c
c get field information
c
ikey = FSTINF(ninmpg_unobs, INI, INJ, INK, ibrpstamp, cletiket,
& ip1_all(z4lev_trl(1),ip1_vco_trl), iip2, iip3
& ,cltypvar,cnomvar)
write(nulout,*) 'in ch_rdsplitoper, after first fstinf, reading trial fld unobserved, var = ', cvarunobs(jvar)
& , ' ikey= ' , ikey, ' ibrpstamp= ' , ibrpstamp , ' ip1= ' , ip1_all(z4lev_trl(1),ip1_vco_trl)
if (ikey.lt.0) then
write(nulout,*) 'problem in reading trial field for unobserved !!'
endif
c
c allocate space
c
call hpalloc(pxvhvar2d,ini*inj,ierr,8)
C call hpalloc(pxmean_trial, inj*nflev, ierr, 8)
allocate(zmean_trial(inj,nflev))
do jlev = 1,itrlnlev
ikey = FSTINF(ninmpg_unobs, INI, INJ, INK, ibrpstamp, cletiket,
& ip1_all(z4lev_trl(jlev),ip1_vco_trl), iip2, iip3
& ,cltypvar,cnomvar)
c write(nulout,*) 'in ch_rdsplitoper, after fstinf, reading trial fld unobserved, var = ', cvarunobs(jvar)
c & , ' ikey= ' , ikey, ' ibrpstamp= ' , ibrpstamp
if (ikey.ge.0) then
ikey = VFSTLUK(zvhvar2d,ikey, INI, INJ, INK)
zmean_trial(1:inj, jlev)=0.
do jj = 1, inj
do ii = 1, ini
zmean_trial(jj, jlev)= zmean_trial(jj, jlev)+zvhvar2d(ii+ (jj-1)*ini)
enddo
enddo
endif
c write(nulout,*) 'zmean_trial, jlev= ' , jlev
c write(nulout,*) (zmean_trial(jj, jlev), jj=1, inj,4)
enddo !jlev
do jlev = 1,itrlnlev
zmean_glb(jlev)= 0.
do jj = 1, inj
zmean_trial(jj, jlev) = zmean_trial(jj, jlev)/float(ini)
c zmean_glb(jlev)=zmean_glb(jlev)+ zmean_trial(jj, jlev)
zmean_glb(jlev)=zmean_glb(jlev)+ zmean_trial(jj, jlev)*zmean_trial(jj, jlev)
enddo
c zmean_glb(jlev)= zmean_glb(jlev)/ float(nflev)
zmean_glb(jlev)= sqrt (zmean_glb(jlev)/ float(nflev))
enddo
write(nulout,*) 'zmean_glb'
write(nulout,*) (zmean_glb(jlev), jlev=1,itrlnlev, 2)
if (LDIAGNO) then
c do jk1 = 1, nflev,2
c write(nulout,*) 'before scaling, splitoperd, jk1= ' ,jk1
c write(nulout,*) (splitoperd(jk1,jlat), jlat = 1, nj,4)
c end do
c write(nulout,*)'*********************************************************'
c write(nulout,*)'*********************************************************'
c do jk1 = 1, nflev,2
cc write(nulout,*) 'before scaling, zmean_trial, jk1= ' ,jk1
cc write(nulout,*) (zmean_trial(jlat, jk1), jlat = 1, nj,4)
c end do
do jlat = 1, nj
do jk1 = 1, nflev
splitoperd(jk1,jlat) = splitoperd(jk1,jlat)*zmean_trial(jlat, jk1)/zmean_glb(jk1)
cc splitoperd(jk1,jlat) = splitoperd(jk1,jlat)*zmean_trial(jlat, jk1)
end do
end do
c write(nulout,*)'*********************************************************'
c write(nulout,*)'*********************************************************'
c do jk1 = 1, nflev,2
c write(nulout,*) 'after scaling, splitoperd, jk1= ' ,jk1
c write(nulout,*) (splitoperd(jk1,jlat), jlat = 1, nj,4)
c end do
else
do jlat = 1, nj
do jk2 = 1,nflev
do jk1 = 1, nflev
splitoper(jk1,jk2,jlat) = splitoper(jk1,jk2,jlat)*zmean_trial(jlat, jk1)/zmean_glb(jk1)
end do
end do
enddo
endif
deallocate(zmean_trial)
call hpdeallc(pxvhvar2d,ierr,1)
endif ! LSCAL_OPER
c
c write out splitting operator into ascii file
c
open(unit=666,form='formatted',
+ file='./split_operator.asc')
write(666, *) cvaranal(jvar),'--', cvarunobs(jvar)
write(666, *) ' LSCAL_OPER= ' , LSCAL_OPER
write(666, *) '**********************************************'
write(666, *) 'splitting operator'
write(666, *) '**********************************************'
do jk1=1, nflev
write(666, 400)(splitoperd(jk1,jlat), jlat= nj, 1 ,-1)
enddo
400 format(2x, 7(g11.5, 3x))
c
* 9. Deallocate local arrays
c
call hpdeallc(pxzspoper,ierr,1)
call hpdeallc(pxzgroper,ierr,1)
call hpdeallc(pxzgroperd,ierr,1)
call hpdeallc(pxzleg,ierr,1)
call hpdeallc(pxzoperecr,ierr,1)
call hpdeallc(pxzopermix,ierr,1)
call hpdeallc(pxzopersrc,ierr,1)
call hpdeallc(pxzspoperd,ierr,1)
call hpdeallc(pxzopersrcd,ierr,1)
c call hpdeallc(pxmean_trial,ierr,1)
*
ierr=fstfrm(kulsplitgd)
close(666)
write(nulout,*)'DONE in CH_RDSPLITOPER'
c
return
end