!-------------------------------------- LICENCE BEGIN ------------------------------------
!Environment Canada - Atmospheric Science and Technology License/Disclaimer,
! version 3; Last Modified: May 7, 2008.
!This is free but copyrighted software; you can use/redistribute/modify it under the terms
!of the Environment Canada - Atmospheric Science and Technology License/Disclaimer
!version 3 or (at your option) any later version that should be found at:
!http://collaboration.cmc.ec.gc.ca/science/rpn.comm/license.html
!
!This software is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY;
!without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
!See the above mentioned License/Disclaimer for more details.
!You should have received a copy of the License/Disclaimer along with this software;
!if not, you can write to: EC-RPN COMM Group, 2121 TransCanada, suite 500, Dorval (Quebec),
!CANADA, H9P 1J3; or send e-mail to service.rpn@ec.gc.ca
!-------------------------------------- LICENCE END --------------------------------------
!
subroutine readcornsgl 1,9
*
#if defined (DOC)
*
*Author : Luc Fillion - 3 Jun 2009.
*Revision:
* Luc Fillion - ARMA/EC - 6 Jul 2010 - Ensure proper normalization of spectral densities
* in case truncation actually used here is lower than the one used to normalise them originally by
* the statistics program.
* Luc Fillion - ARMA/EC - 7 Jul 2010 - Improve reading conditions of CORNS or CORNSLOC.
*
* -------------------
** Purpose:
*Arguments
#endif
IMPLICIT NONE
*implicits
*
* Global variables
*
#include "taglam4d.cdk"
#include "pardim.cdk"
#include "comct0.cdk"
#include "comdim.cdk"
#include "comcva.cdk"
#include "comlun.cdk"
#include "comcorr.cdk"
#include "comstate.cdk"
#include "compstat.cdk"
#include "comfftla.cdk"
#include "comgdpar.cdk"
#include "comcse1.cdk"
#include "rpnstd.cdk"
!
logical llout,llprint
integer istdkey,icornskey,iuleigen,jk,jn
integer ilen,jcol,jrow,jlevo,jlevi
real*8 zmbandsp(nbandmax)
real*8 zwork,zsum,dsummed
real*8 zstdsrc(nksdim2)
real*8 zcornssrc(nksdim2,nksdim2,1)
real*8 zspdev(nband)
!
integer jband,index,ilev
!
!!
write(nulout,*) 'readcornsgl: lgauscor=',lgauscor
llprint = .false.
llout = .false.
!
!1. Read the RSTDDEV spectral coefficients up to ntrunc desired
! -----------------------------------------------------------
!
! RSTDDEV
do jband = 1, nband
idateo = -1
cletiket = 'RSTDDEV'
ip1 = -1
ip2 = jband-1
ip3 = -1
! cltypvar = 'X' ! old
! clnomvar = 'SS' ! old
! cltypvar = 'S' ! new
! clnomvar = 'ZZ' ! new
istdkey = vfstlir(zstdsrc,nulbgst,INI,INJ,INK,idateo,cletiket,
& ip1,ip2,ip3,cltypvar,clnomvar)
!
if(istdkey .lt.0 ) then
call abort3d(nulout
& ,'readcornsgl: Problem reading RSTDDEV ')
endif
if (ini .ne. nksdim2) then
write(nulout,*) 'readcornsgl: ini, nksdim2 =',ini,nksdim2
call abort3d(nulout
& ,'readcornsgl: BG stat levels inconsitencies')
endif
!
do jk = 1, nksdim2
rstddev(jk,jband-1) = zstdsrc(jk)
enddo
enddo ! jband
!
! do jband = 1, nband
! do jk = 1, nksdim2
! write(nulout,*) 'readcornsgl: jband,jk,rstddev(jk,jband-1)=',
! & jband,jk,rstddev(jk,jband-1)
! enddo
! enddo
!
!*2 Ensure normalization according to actual truncation
! and Multiply by sqrt(0.5) to make valid for m.ne.0
! ---------------------------------------------------
!
do jk = 1, nksdim2
DSUMMED=0.0
do jband = 1, nband
DSUMMED=DSUMMED +
& (RSTDDEV(JK,jband-1)**2)*((2.0D0*(jband-1))+1.0D0)/2.0D0
enddo
do jband = 1, nband
IF(DSUMMED.NE.0.0)
& RSTDDEV(JK,jband-1)=RSTDDEV(JK,jband-1)*SQRT(0.5D0/DSUMMED)
enddo
enddo
!
!*3 Compute and print horizontal correlation lengths
! ------------------------------------------------
!
call corrlengthglb(999,.false.,.false.)
!
!*4 Build CORNS
! -----------
!
idateo = -1
if(mbal_order.eq.0.and.nconf.eq.141) then
cletiket = 'CORNSLOC' ! Get Localized correlations for Minimization
else
cletiket = 'CORRNS'
endif
ip1 = -1
ip3 = -1
! cltypvar = 'X' ! old
! cltypvar = 'S' ! new
! clnomvar = 'ZZ'
!
do jband = 1, nband
IP2 = jband-1
icornskey = vfstlir(ZCORNSSRC,nulbgst,INI,INJ,INK
& ,idateo,cletiket,ip1,ip2,ip3,cltypvar,clnomvar)
!
if(icornskey .lt.0 ) then
call abort3d(nulout
& ,'readcornsgl: CORRNS etiket probably not set properly here...')
endif
!
if (ini .ne. nksdim2 .or. inj .ne. nksdim2) then
call abort3d(nulout
& ,'readcornsgl: BG stat levels inconsitencies')
endif
!
! Ensure vertical correlations of 3D fields are = 1.0
!
do jcol = 1,nksdim2-nfstvar2d
do jrow = 1, nksdim2-nfstvar2d
corns(jrow,jcol,jband-1,1) = zcornssrc(jrow,jcol,1)
if(jcol.eq.jrow) then
if(corns(jrow,jcol,jband-1,1).ne.1.0) then
write(nulout,*) 'readcornsgl: jband, Level, CORNSLOC =',
& jband,jrow,corns(jrow,jcol,jband-1,1)
call abort3d(nulout
& ,'readcornsgl: Directly from file: Diagonal CORNS .ne. 1.0')
endif
endif
enddo
enddo
!
! if(llprint) then
! write(nulout,*) 'readcornsgl: jband,rstddev for P0 =',
! & jband,rstddev(nksdim2-nfstvar2d+1,jband-1) ! P0
! endif
!
enddo ! jband loop
!
if(llprint) then
!
! Print-out PSI-PSI correlations for wvnb = 1
!
write(nulout,*) '*********************************************************'
write(nulout,*) 'readcornsgl: Print-out PSI-PSI correlations for wvnb = 1'
write(nulout,*) '*********************************************************'
!
do jcol = 1,10
do jrow = 1, nflev
write(nulout,*) 'readcornsgl: jrow,jcol,corns(jrow,jcol,1,1) = ',
& jrow,jcol,corns(jrow,jcol,1,1)
enddo
enddo
endif
!
do jband = 1, nband
do jcol = 1,nksdim2
do jrow = 1,nksdim2
corns(jrow,jcol,jband-1,1) = rstddev(jrow,jband-1)
& * corns(jrow,jcol,jband-1,1)*rstddev(jcol,jband-1)
enddo
enddo
enddo
!
if(lsetcross.and.nanalvar.ne.4) then
do jband = 1, nband
call setcrosscorr(jband-1,1) ! Set to zero all cross-variable correlations but T'ln(ps')
enddo
endif
!
write(nulout,*) 'Done in readcornsgl'
!
return
end