SUBROUTINE CH_READCORNS2(KDATESTAMP,KENSEMBLE,poper,knstatlev 1,11
& ,kulbgsto,klatbin)
*
#if defined (DOC)
*
*s/r CH_READCORNS2 - 1) Read CORNS and RSTDDEV from RPN standard
* files for meteo fields and constituents
* 2) Factorize Correlation by RSTDDEV
* 3) Vertical (optionally) interpolation of correlations
* 4) Set cross-variable correlations to zero
* 4) Filter (optionally) eigenvalue of corralations
* 5) Convolution of filtred and interpolated
* RSTDDEV
* 6) Write (optionally) resulting RSTDDEV and CORNS
* 7) Re-build filtred-interpolated-convoluted
* correlation matrix
*
*Author : READCORNS2 by S. Pellerin *ARMA/AES March 2000
* Extended to CH_READCORNS2 for species by Y. Rochon, June 2005
*
*Revisions: (see readcorns2.ftn for READCORNS2 revisions)
* Y.J. Rochon ARQX/MSC June 2005, Feb 2006
* - Extension consists of additions related to new routines
* CH_CORRNS_ADD, CH_RSTDDEV_ADD, and CH_NUMSPECIES
* Y.J. Rochon ARQX Aug 2010
* - Account for klatbin
*
* -------------------
*
* Purpose: Read and add species CORNS and RSTDDEV to
* to combined CORNS and RSTDDEV
*
* Arguments
*
* KDATESTAMP: date of validity
* KENSEMBLE : number of members in the ensemble used to
* estimate these correlations
* POPER(nflev,knstatlev): explicit vertical interpolation operator
* KNSTATLEV : Number of level of the original statistics
* kulbgsto : Logical unit of backgroud stat output
* klatbin : Lat band index
*
#endif
IMPLICIT NONE
*implicits
*
* Global variables
*
#include "pardim.cdk"
#include "comdim.cdk"
#include "comlun.cdk"
#include "comcorr.cdk"
#include "comstate.cdk"
#include "compstat.cdk"
#include "cominterp.cdk"
#include "comchem.cdk"
*
* Arguments
*
integer ispec,i2d
*
character*1 clblock
integer kdatestamp,kensemble,knstatlev,kulbgsto,klatbin,kip1
integer jn, istdkey,icornskey,iuleigen,j1,j2,ivsp
integer iksdim,ilen,inbrblock,jcol,jrow,jblock,jlevo,jlevi
c
c Number of additional 2D variable not in CORNS (SS) standard file records
c
real*8 zwork,poper(nflev,knstatlev)
real*8, allocatable, dimension(:) :: zstdsrc, zcornsw
real*8, allocatable, dimension(:,:) :: zcornssrc, zcornsmix
real*8 zproj,ztpsproj,zeigen,ztpseigen,zeigenv,
& ztpseigenv,zeigmin,zalpha,ztpscorr,zeigminblocks
logical llrenorm,llprint,llfilttps
pointer (pxztpscorr,ztpscorr(nflev+1,nflev+1))
pointer (pxzeigminblocks,zeigminblocks(nvsp+nvsaux,0:ntrunc+1))
c
pointer (pxzproj,zproj(nflev,nflev))
pointer (pxzeigen,zeigen(nflev,nflev))
pointer (pxzeigenv,zeigenv(nflev))
pointer (pxztpsproj,ztpsproj(nflev+1,nflev+1))
pointer (pxztpseigen,ztpseigen(nflev+1,nflev+1))
pointer (pxztpseigenv,ztpseigenv(nflev+1))
c
c pointer (pxzstdsrc,zstdsrc((NVSP+NVSAUX)*knstatlev+NVSP2D))
c pointer (pxzcornsmix,zcornsmix(nksdim,(NVSP+NVSAUX)*knstatlev
c & +nvsp2d))
c
#include "rpnstd.cdk"
*-------------------------------------------------------------------
C
iksdim = (NVSP+NVSAUX)*knstatlev+NVSP2D - nsexist(nstg)
allocate(zcornssrc(iksdim,iksdim))
allocate(zcornsw(iksdim*iksdim))
c call hpalloc(pxzcornssrc,max(1,iksdim**2),ierr,8)
allocate(zstdsrc(iksdim))
c call hpalloc(pxzstdsrc,max(1,iksdim),ierr,8)
ilen = nksdim*iksdim
allocate(zcornsmix(nksdim,iksdim))
c call hpalloc(pxzcornsmix,max(1,ilen),ierr,8)
ilen = (nflev+1)*(nflev+1)
call hpalloc(pxztpscorr,max(1,ilen),ierr,8)
call hpalloc(pxztpsproj,max(1,ilen),ierr,8)
call hpalloc(pxztpseigen,max(1,ilen),ierr,8)
ilen = nflev+1
call hpalloc(pxztpseigenv,max(1,ilen),ierr,8)
c
ilen = nflev*nflev
call hpalloc(pxzproj,max(1,ilen),ierr,8)
call hpalloc(pxzeigen,max(1,ilen),ierr,8)
ilen = nflev
call hpalloc(pxzeigenv,max(1,ilen),ierr,8)
ilen=(nvsp+nvsaux)*(ntrunc+2)
call hpalloc(pxzeigminblocks,max(1,ilen),ierr,8)
c
inbrblock = nvsp+nvsaux
llfilttps = .false.
llrenorm = .false.
llprint = .false.
zalpha = 0.0
ispec=0
i2d=NVSP2D-nsexist(nstg)
write(nulout,*)'CH_READCORNS2 FOR REGION #',klatbin
*
* . Read the RSTDDEV spectral coefficients
*
kip1=klatbin
if(nlatbin.eq.1) kip1=-1
c
do jn = 0, ntrunc
write(nulout,*)' Reading RSTDDEV spectral coefficients number'
& ,jn
c
c Looking for FST record parameters..
c
idateo = -1
cletiket = 'RSTDDEV'
ip1 = kip1
ip2 = JN
ip3 = -1
cltypvar = 'X'
clnomvar = 'SS'
c
istdkey = vfstlir(ZSTDSRC,nulbgst,INI,INJ,INK,idateo,cletiket,
& ip1,ip2,ip3,cltypvar,clnomvar)
c
if(istdkey .lt.0 ) then
write(nulout,*) 'Key: ',istdkey
call abort3d(nulout
& ,'CH_READCORNS2: Problem with background stat file')
endif
c
if (ini .lt. iksdim) then
C
if (NULBGSTR.EQ.0)
& CALL ABORT3D(NULOUT,
& 'CH_READCORNS2: NO SPECIES BACKGROUND STAT FILE!!')
c
c Ensure that all species are taken into account
c
CALL CH_NUMSPECIES
c
c Identify number of additional 3D fields for which stats will
c be read
c
ivsp = (ini+nsexist(nstg)-NVSP2D-NVSAUX*knstatlev)/knstatlev+1
ispec=nvsp-ivsp+1
c
if (ispec*knstatlev+ini.ne.iksdim) then
call abort3d(nulout
& ,'CH_READCORNS2: BG stat levels inconsitencies')
end if
c
c Read stats for specified fields and place in appropriate
c location in ZSTDSRC (re-arranges array)
c
CALL CH_RSTDDEV_ADD(ZSTDSRC,ini,iksdim,knstatlev,
& i2d,ispec,ip2,csneed(ivsp:nvsp))
c
endif
c
c Looking for FST record parameters..
c
idateo = -1
cletiket = 'CORRNS'
ip1 = kip1
IP2 = JN
ip3 = -1
cltypvar = 'X'
clnomvar = 'ZZ'
c icornskey = vfstlir(ZCORNSSRC,nulbgst,INI,INJ,INK
icornskey = vfstlir(ZCORNSW,nulbgst,INI,INJ,INK
S ,idateo,cletiket,ip1,ip2,ip3,cltypvar,clnomvar)
c
if(icornskey .lt.0 ) then
call abort3d(nulout
& ,'CH_READCORNS2: Problem with background stat file')
else
ZCORNSSRC(:,:)=0.0
do j2=1,ini
do j1=1,ini
ZCORNSSRC(j1,j2)=ZCORNSW(j1+(j2-1)*ini)
end do
end do
endif
c
if (ini .lt. iksdim) then
c
if (ispec*knstatlev+ini.ne.iksdim) then
call abort3d(nulout
& ,'CH_READCORNS2: BG stat levels inconsitencies')
end if
c
c Read stats for specified fields and place in appropriate
c location in ZCORNSSRC (re-arranges array)
c
CALL CH_CORRNS_ADD(ZCORNSSRC,ini,iksdim,knstatlev,i2d,
& ispec,ip2,csneed(ivsp:nvsp))
c
endif
c
if(lvintbgstat) then
c
c Factorization of CORNS with RSTDDEV
c
do jcol = 1,iksdim
do jrow = 1,iksdim
zcornssrc(jrow,jcol) = zstdsrc(jrow) * zcornssrc(jrow,jcol
& )* zstdsrc(jcol)
enddo
enddo
c
c Vertical interpolation of correlation matrix: C'' = VCV
c
c 1 step: Interpolation of the knstatlev rows of zcornssrc (C matrix) to
c the nflev rows of zcornsmix (C' matrix) for each of the inbrblock 3D
c variable block
c
c 1) C' = VC
c where
c C': zcornsmix
c V : poper
c C : zcornssrc (correlations on original levels)
c
do jblock= 1, inbrblock
c
call mxmaop(
& poper,1,nflev,zcornssrc(knstatlev*(jblock-1)+1
& ,1),1,iksdim,zcornsmix(nflev
& *(jblock-1)+1,1),1,nksdim,nflev
& ,knstatlev,iksdim)
c
enddo
c
c Copy of correlation rows corresponding to 2D variables
c
do jcol = 1,iksdim
do jrow = 1,nvsp2d - nsexist(nstg)
zcornsmix(inbrblock*nflev+jrow,jcol) =
& zcornssrc(inbrblock*knstatlev+jrow,jcol)
enddo
enddo
c
c Step 2: Interpolation of the knstatlev columns of zcornsmix (C')
c to the nflev columns of corns (C'') for each of the inbrblock 3D
c variable block
c T
c 2) C'' = C'V
c where
c C' : zcornsmix
c V : poper (vertical interpolator)
c C'' : corns (correlation on targetted levels)
c
do jblock= 1, inbrblock
call mxmaop(
& zcornsmix(1,knstatlev*(jblock-1)+1)
& ,1,nksdim,poper,knstatlev,1,corns(1,nflev*(jblock
& -1)+1,jn,klatbin),1,nksdim,nksdim,knstatlev,nflev)
enddo
c
c Copy of correlation collumns corresponding to 2D var
c
do jrow = 1,nksdim
do jcol = 1,nvsp2d - nsexist(nstg)
corns(jrow,inbrblock*nflev+jcol,jn,klatbin) =
& zcornsmix(jrow,inbrblock*knstatlev+jcol)
enddo
enddo
c
c Rest only the lowest and rightmost elements of correlations to copy
c
do jcol = 1,nvsp2d -nsexist(nstg)
do jrow = 1,nvsp2d - nsexist(nstg)
corns(inbrblock*nflev+jrow,inbrblock*nflev+jcol,jn,klatbin) =
& zcornssrc(inbrblock*knstatlev+jrow,inbrblock
& *knstatlev+jcol)
enddo
enddo
else
c
c No vertical interpolation of correlations
c N.B. zcornssrc does not contain the diagonal (rstddev) in this case
c
do jcol = 1,iksdim
do jrow = 1, iksdim
corns(jrow,jcol,jn,klatbin) = zcornssrc(jrow,jcol)
enddo
enddo
c
endif
c
c So far cross-variables correlations have been interpolated
c along with block diagonal variables.
c
c Set cross-variable correlations to zero except between T' and ln(ps')
c
call setcrosscorr(jn,klatbin)
c
if(leigfilt.and.lvintbgstat) then
c
c Filtering of eigenvalues for each block diagonal
c
do jblock= 1, inbrblock
if(llprint) then
write(clblock,'(i1)') jblock
iuleigen = 0
ierr = fnom(iuleigen,'eigenv_block_'//clblock//'.asc'
& ,'APPEND+FMT',0)
c open(iuleigen,file='eigenv_block_'//clblock//'.asc',access
c & ='APPEND',form='FORMATTED',IOSTAT=ierr)
write(iuleigen,*) ' '
write(iuleigen,*) '------------ Coefficient: ',jn,
& ' ------------'
endif
c
if(jblock.ne.nstt .or. .not. llfilttps) then
c
c Filtering all blocks (but T'T' if llfilttps is true)
c
if(jblock.eq.nsvor) then
zeigmin = reigminpsi
elseif(jblock.eq.nsdiv) then
zeigmin = reigminchi
elseif(jblock.eq.nstt) then
zeigmin = reigmintt
elseif(jblock.eq.nsps) then
zeigmin = reigminlq
else
zeigmin = 0.0
endif
c
call filtmatrix2(corns(nflev*(jblock-1)+1,nflev*(jblock-1)
& +1,jn,klatbin),nksdim,zproj,zeigen,zeigenv,nflev,zeigmin
& ,zalpha,llrenorm,iuleigen,llprint)
c
if(llprint) then
c
if(jn.eq.0) zeigminblocks(jblock,ntrunc+1) = zeigenv(1)
zeigminblocks(jblock,jn) = zeigenv(1)
c
do jcol = 1,nflev
zeigminblocks(jblock,jn) = min(zeigenv(jcol)
& ,zeigminblocks(jblock,jn))
zeigminblocks(jblock,ntrunc+1) = min(zeigenv(jcol)
& ,zeigminblocks(jblock,ntrunc+1))
enddo
endif
c
else
zeigmin = reigmintt
c
c Filtering combined T'T' and T'ln(ps') block matrix
c
do jcol = 1,nflev
do jrow = 1,nflev
ztpscorr(jrow,jcol) = corns(nsposit(nstt)+jrow-1
& ,nsposit(nstt)+jcol-1,jn,klatbin)
enddo
ztpscorr(nflev+1,jcol) = corns(nsposit(nsps)
& ,nsposit(nstt)+jcol-1,jn,klatbin)
enddo
do jrow = 1,nflev
ztpscorr(jrow,nflev+1) = corns(nsposit(nstt)+jrow-1
& ,nsposit(nsps),jn,klatbin)
enddo
ztpscorr(nflev+1,nflev+1) = corns(nsposit(nsps)
& ,nsposit(nsps),jn,klatbin)
c
call filtmatrix2(ztpscorr,nflev+1,ztpsproj,ztpseigen
& ,ztpseigenv,nflev+1,zeigmin,zalpha,llrenorm,iuleigen
& ,llprint)
c
if(llprint) then
c
if(jn.eq.0) zeigminblocks(jblock,ntrunc+1) = zeigenv(1)
zeigminblocks(jblock,jn) = zeigenv(1)
c
do jcol = 1,nflev
zeigminblocks(jblock,jn) = min(zeigenv(jcol)
& ,zeigminblocks(jblock,jn))
zeigminblocks(jblock,ntrunc+1) = min(zeigenv(jcol)
& ,zeigminblocks(jblock,ntrunc+1))
enddo
endif
c
do jcol = 1,nflev
do jrow = 1,nflev
corns(nsposit(nstt)+jrow-1,nsposit(nstt)+jcol-1,jn,klatbin) =
& ztpscorr(jrow,jcol)
enddo
corns(nsposit(nsps),nsposit(nstt)+jcol-1,jn,klatbin) =
& ztpscorr(nflev+1,jcol)
enddo
do jrow = 1,nflev
corns(nsposit(nstt)+jrow-1,nsposit(nsps),jn,klatbin) =
& ztpscorr(jrow,nflev+1)
enddo
corns(nsposit(nsps),nsposit(nsps),jn,klatbin) = ztpscorr(nflev+1
& ,nflev+1)
endif
if(llprint) ierr = fclos (iuleigen)
enddo
c
endif
c
if(lvintbgstat) then
c
c Get the filtred and interpolated RSTDDEV from diagonal of correlations
c
do jrow = 1, nksdim
rstddev(jrow,jn) = sqrt(corns(jrow,jrow,jn,klatbin))
enddo
c
c Un-factorize filtred and interpolated correlation matrix with
C resulting RSTDDEV
c
do jrow = 1, nksdim
do jcol = 1, nksdim
corns(jrow,jcol,jn,klatbin) = corns(jrow,jcol,jn,klatbin)/(rstddev(jrow,jn
& )*rstddev(jcol,jn))
enddo
enddo
else
do jrow = 1, iksdim
rstddev(jrow,jn) = zstdsrc(jrow)
enddo
endif
c
enddo
c
if (leigfilt.and.llprint.and.lvintbgstat) then
do jblock = 1, inbrblock
write(clblock,'(i1)') jblock
iuleigen = 0
ierr = fnom(iuleigen,'eigenv_block_'//clblock//'.asc'
& ,'APPEND+FMT',0)
c open(nulusr5,file='eigenv_block_'//clblock//'.asc',access
c & ='APPEND',form='FORMATTED',IOSTAT=ierr)
write(iuleigen,*)
& ' ----- Summary of original minimum eigenvalues -----'
write(iuleigen,*) 'wave number - minimum value'
write(iuleigen,1001) (jn,zeigminblocks(jblock,jn),jn=0,ntrunc)
write(iuleigen,1000) zeigminblocks(jblock,ntrunc+1)
close(iuleigen)
enddo
1000 format(//,1x,'Absolute original minimum eigenvalue : ',g12.3)
1001 format(1x,i3,1x,g12.3)
endif
c
c Apply convolution to RSTDDEV correlations
c
call convol
c
do jn = 0, ntrunc
if ( kulbgsto .gt. 0 ) then
c
c Writing starndard deviation to file
c
ierr = fstprm(istdkey,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 = nksdim
inj = 1
ink = 1
ip2 = jn
c
ierr = vfstecr(rstddev(1,jn), zwork, -inbits, kulbgsto, idateo
& , ideet,inpas, ini, inj, ink, ip1, ip2, ip3, cltypvar,
& clnomvar,cletiket,clgrtyp,ig1, ig2, ig3, ig4, idatyp,
& .true.)
c
c Writing correlation matrix to file
c
ierr = fstprm(icornskey,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 = nksdim
inj = nksdim
ink = 1
ip2 = jn
c
ierr = vfstecr(corns(1,1,jn,klatbin), zwork, -inbits, kulbgsto, idateo
& , ideet,inpas, ini, inj, ink, ip1, ip2, ip3, cltypvar,
& clnomvar,cletiket,clgrtyp,ig1, ig2, ig3, ig4, idatyp,
& .true.)
endif
c
c Re-build of correlation matrix: factorization of corns with
c convoluted RSTDDEV
c
do jcol = 1,nksdim
do jrow = 1,nksdim
corns(jrow,jcol,jn,klatbin) = rstddev(jrow,jn) * corns(jrow,jcol
& ,jn,klatbin)* rstddev(jcol,jn)
enddo
enddo
c
enddo
c
kensemble = ip3
kdatestamp = idateo
c
deallocate(zcornssrc)
deallocate(zcornsw)
c call hpdeallc(pxzcornssrc,ierr,1)
deallocate(zstdsrc)
c call hpdeallc(pxzstdsrc,ierr,1)
deallocate(zcornsmix)
c call hpdeallc(pxzcornsmix,ierr,1)
c
call hpdeallc(pxzproj,ierr,1)
call hpdeallc(pxzeigen,ierr,1)
call hpdeallc(pxzeigenv,ierr,1)
call hpdeallc(pxztpscorr,ierr,1)
call hpdeallc(pxztpsproj,ierr,1)
call hpdeallc(pxztpseigen,ierr,1)
call hpdeallc(pxztpseigenv,ierr,1)
call hpdeallc(pxzeigminblocks,ierr,1)
c
c Prepare avg. physical space correlation matrices.
c
IF (NGENOPER.EQ.1) CALL CH_AVGCORNS(NULOUT,0,KNSTATLEV)
c
write(nulout,*) 'Done in CH_READCORNS2'
c
return
end