!-------------------------------------- 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 writecornsla(pcorns,peig_vec,peig_val,kulcorns,cdflcorns, 6,10
& kdatestamp,kensemble,cdcase,ldnorm)
*
*
#if defined (DOC)
*
***s/r writecornsla - For Mesovar case: Output CORNS and RSTDDEV on kulcorns RPN standard files
*
*
*Author : L. Fillion - ARMA/MSC - 3 Oct 2005.
*Revision:
*
* L. Fillion - ARMA/EC - 14 Sep 2006 - Output spatial resolution on output file using IP1 parameter.
* L. Fillion - ARMA/EC - 15 Dec 2008 - All output on kulcorns file only.
* L. Fillion - ARMA/EC - 14 Jan 2009 - Upgrade lam4d to v_10_1_2. Extra dimension for CORNS.
* L. Fillion - ARMA/EC - 9 Mar 2009 - Introduce arguments peig_vec,peig_val
* L. Fillion - ARMA/EC - Sept 2009 - Write desired correlation block on ASCI file for publication
* -------------------
** Purpose: to estimate the forecast error correlation from an
* . ensemble of normalized and unbiased residuals such
* . as differences between 12/24h forecast valid at the
* . same time
*Arguments
* KULCORNS : logical unit assigned to the CORNS file
* CDFLCORNS : filename for CORNS
* KDATESTAMP: date of validity
* KENSEMBLE : number of members in the ensemble used to
* . estimate these correlations
#endif
IMPLICIT NONE
*implicits
*
* Global variables
*
#include "taglam4d.cdk"
#include "comdim.cdk"
#include "comcorr.cdk"
#include "comcst.cdk"
#include "comgrd_param.cdk"
#include "comgrd.cdk"
#include "comlun.cdk"
#include "comlunla.cdk"
#include "comfftla.cdk"
#include "comcva.cdk"
#include "comcse1.cdk"
#include <rpnmacros_f.h>
*
* Arguments
*
character*3 cdcase
CHARACTER*16 CDFLCORNS
INTEGER KULCORNS, KDATESTAMP, KENSEMBLE
real*8 pcorns(nksdim2,nksdim2,0:nband-1,1)
real*8 peig_vec(nksdim2,nksdim2,nband), peig_val(nksdim2,nband)
*
* Local variables
*
character*2 cltypvar,clnomvar
character*8 cletiket
character*2 clfield
integer ii,ji,jj,ij
real*8 zppttcor(nflev,nflev)
!
logical ldnorm
integer jband,ii,ii2,ij,ifois,jrow,jcol
data ifois/0/
INTEGER JN, IERR, IPAK, ILEN,JK,JL, ISIZ
integer idum1,idum2,idum3,idum4
real*8 zmin,zmax
real*8 zcon, zfact
REAL*8 zcorr(nflev,nflev)
REAL*8 zcorr2(nksdim2,nksdim2)
REAL*8 zmbandsp(nband)
real*8 zstdsrc(nksdim2)
real*8 ztt(nflev,nflev,nband)
real*8 ztpsi(nflev,nflev,nband)
real*8 zcorns(nksdim2,nksdim2,0:nband-1,1)
real*8 zmaxmin(nksdim2,nksdim2)
*
INTEGER VFSTECR
*
* * RPN Standard files parameters
*
INTEGER IP1,IP2,IP3, IDATYP, IDATEO
*
!
!!
write(nulout,*) 'writecornsla: cdcase = ',cdcase
zcorr(:,:) = 0.0
!
IPAK = -32
IDATYP = 5
IP1 = 0
IP3 = KENSEMBLE
IDATEO = KDATESTAMP
!
if(ifois.eq.0) then
ifois = 1
!
! MBANDSP
!
do jband = 1, nband
zmbandsp(jband) = real(mbandsp(jband))
enddo
!
ip1 = anint(111.*(1.e3)*grd_dx) ! grid resolution in meters
IP2 = 0
IERR = VFSTECR(zmbandsp,zmbandsp,IPAK,KULCORNS
& ,IDATEO,0,0,nband,1,1
& ,IP1,IP2,IP3,'SS','ZZ','MBANDSP ','X'
& ,0,0,0,0,IDATYP,.TRUE.)
!
ip1 = anint(111.*(1.e3)*grd_dx) ! grid resolution in meters
!
! RSTDDEV
!
do jband = 1, nband
do jk = 1, nksdim2
zstdsrc(jk) = RSTDDEV(jk,jband-1)
enddo
! do jk = 1, nksdim2
! write(nulout,*) 'writecornsla: jband,jk,rstddev(jk,jband-1)=',
! & jband,jk,rstddev(jk,jband-1)
! enddo
!
IP2 = jband-1
IERR = VFSTECR(zstdsrc,zstdsrc,IPAK,kulcorns
S ,IDATEO,0,0,nksdim2,1,1
S ,IP1,IP2,IP3,'SS','ZZ','RSTDDEV ','X'
S ,0,0,0,0,IDATYP,.TRUE.)
enddo
IERR = VFSTECR(zstdsrc,zstdsrc,IPAK,kulcorns
S ,IDATEO,0,0,nksdim2,nband-1,1
S ,IP1,IP2,IP3,'SS','ZZ','RSTDDEV2','X'
S ,0,0,0,0,IDATYP,.TRUE.)
endif
!
! CORNS
!
if(cdcase.eq.'ORI') then
cltypvar = 'SS'
clnomvar = 'ZZ'
cletiket = 'CORRNS '
else if(cdcase.eq.'LOC') then
cltypvar = 'XX'
clnomvar = 'ZN'
cletiket = 'CORNSLOC'
else if(cdcase.eq.'MIN') then
cltypvar = 'XX'
clnomvar = 'ZN'
cletiket = 'CORNSMIN'
endif
!
do jband = 1, nband
do jcol = 1,nksdim2
do jrow = 1,nksdim2
zcorns(jrow,jcol,jband-1,1) = pcorns(jrow,jcol,jband-1,1)
zmaxmin(jrow,jcol)=zcorns(jrow,jcol,jband-1,1)
enddo
enddo
write(nulout,*) 'writecornsla: Point 1, jband = ',jband
call maxmin(zmaxmin,nksdim2,1,nksdim2,zmin,zmax,
& idum1,idum2,idum3,idum4,'writecornsla',
& 'COR')
enddo
!
if(.not.ldnorm.and.(cdcase.ne.'MIN')) call scalecorns(zcorns,'D')
!
do jband = 1, nband
IP2 = jband-1
IERR = VFSTECR(zcorns(1,1,jband-1,1),zcorns(1,1,jband-1,1),IPAK,KULCORNS
& ,IDATEO,0,0,nksdim2,nksdim2,1
& ,IP1,IP2,IP3,cltypvar,clnomvar,cletiket,'X'
& ,0,0,0,0,IDATYP,.TRUE.)
enddo
!
! * . 3.5 Calcultate the total vertical correlation matrix and
! write on file (cf. step 7. of "Summary" section of Lam4d document)
!
if(cdcase.ne.'MIN') then
if(cdcase.eq.'ORI') then
cletiket = 'CORV_ORI'
else if(cdcase.eq.'LOC') then
cletiket = 'CORV_LOC'
endif
!
DO JK = 1, nflev
DO JL = 1, nflev
zcorr(JK,JL) = 0.0
do jband = 1, nband
zcon = 2.d0
if(jband.eq.1) zcon = 1.d0
zfact = 2.d0*mbandsp(jband) - zcon
if(jband.eq.1) zfact = 2.*zfact
zcorr(JK,JL) = zcorr(JK,JL) +
& zfact*wvnbtot(jband)*RSTDDEV(JK,jband-1)*RSTDDEV(JL,jband-1)
& * zcorns(JK,JL,jband-1,1)
END DO
END DO
END DO
!
DO JK = 1, nflev
DO JL = 1, nflev
if(zcorr(JK,JK).gt.0.0.and.zcorr(JL,JL).gt.0.0) then ! avoid zero corns due to spectral filtering...
zcorr(JK,JL) = zcorr(JK,JL) / (SQRT(zcorr(JK,JK)
& * zcorr(JL,JL)))
endif
END DO
END DO
DO JK = 1, nflev
write(nulout,*) 'writecornsla: jk, zcorr(nflev/2,jk) = ',jk,zcorr(nflev/2,JK)
enddo
!
IERR = VFSTECR(zcorr(1,1),zcorr(1,1),IPAK,KULCORNS
& ,IDATEO,0,0,nflev,nflev,1
& ,IP1,IP2,IP3,cltypvar,'TT',cletiket,'X'
& ,0,0,0,0,IDATYP,.TRUE.)
endif
!
! Write desired correlation block on ASCI file for publication
! ------------------------------------------------------------
!
clfield = 'CO'
!
jn = 5
!
do ji = 1, nflev
ii = 2*nflev+ji
do jj = 1, nflev
ij = 2*nflev+jj
zppttcor(ji,jj) = zcorns(ji,ij,jn,1)
enddo
enddo
!
open (unit=nutemp,file='psi_tt_corr_wvnb_05_lam.od')
write(nutemp,910) nflev,nflev,1
write(nutemp,'(A2)') clfield
jk = 1
write(nutemp,920) jk
do jj = 1, nflev
write(nutemp,800) (zppttcor(ji,jj),ji=1,nflev)
enddo
close(nutemp)
!
800 format(100(E13.7,1X))
900 format(E13.7,1X,$)
901 format(E13.7)
910 format(3(I4,1X))
920 format(I4)
!
if(cdcase.eq.'EIG') then
!
write(nulout,*) 'writecornsla: writing eigenvalues/eigenvectors of CORNS'
!
! EIGVAL
!
do jk = 1, nksdim2
write(nulout,*) 'writecornsla: jband,jk,peig_val(jk,5)=',
& jband,jk,peig_val(jk,5)
enddo
!
IP2 = nband
IERR = VFSTECR(peig_val,peig_val,IPAK,kulcorns
S ,IDATEO,0,0,nksdim2,nband,1
S ,IP1,IP2,IP3,'X','EI','EIGENVAL','X'
S ,0,0,0,0,IDATYP,.TRUE.)
!
! EIGVEC
!
do jband = 1, nband
IP2 = jband-1
IERR = VFSTECR(peig_vec(1,1,jband),peig_vec(1,1,jband),IPAK,KULCORNS
& ,IDATEO,0,0,nksdim2,nksdim2,1
& ,IP1,IP2,IP3,'X','EV','EIGENVEC','X'
& ,0,0,0,0,IDATYP,.TRUE.)
enddo
!
call outhoriz2d(peig_val,'eigvalcor.od','EI',1,
& 1,nksdim2,1,nksdim2,nksdim2,nksdim2,1)
!
endif
998 continue
!
END