!-------------------------------------- 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 writecornsglb(pcorns,peig_vec,peig_val,kulcorns,cdflcorns, 5,5
& kdatestamp,kensemble,cdcase,ldnorm,ldwrt_rstddev)
#if defined (DOC)
*
***s/r writecornsglb - For Global case: Output CORNS and RSTDDEV on RPN standard files
*
*
*Author : L. Fillion *ARMA/EC 1 Jun 2009.
*Revision: L. Fillion *ARMA/EC 7 Aug 09 - Write ASCI file of desired corr block for publication.
*Revision: L. Fillion *ARMA/EC 7 Jul 2010 - Write RSTDDEV according to new argument ldwrt_rstddev
*
* -------------------
*Arguments
* KULCORNS : logical unit assigned to the CORNS file
* CDFLCORNS : filename for CORNS
* KULSTDEV : logical unit assigned to the RSTDDEV file
* CDFLSTDEV : filename for RSTDDEV
* 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 "comlun.cdk"
#include "comlunla.cdk"
#include "comcorr.cdk"
#include "comcst.cdk"
#include <rpnmacros_f.h>
*
* Arguments
*
character*2 clfield
character*3 cdcase
logical ldnorm,ldwrt_rstddev
CHARACTER*16 CDFLCORNS, CDFLSTDEV
INTEGER KULCORNS, KULSTDEV, KDATESTAMP, KENSEMBLE
real*8 peig_vec(nksdim2,nksdim2,0:ntrunc), peig_val(nksdim2,0:ntrunc)
real*8 pcorns(nksdim2,nksdim2,0:ntrunc,1)
*
* Local variables
*
INTEGER JN, IERR, IPAK, ILEN,ii,ij,ji,jj,JK,JL, ISIZ
integer jrow,jcol,ibeg,iend
integer idum1,idum2,idum3,idum4
real*8 zmin,zmax
REAL*8 PRCOR(NKSDIM2,NKSDIM2)
character*2 cltypvar,clnomvar
character*8 cletiket
C
INTEGER FNOM, FSTOUV, FSTFRM, FCLOS,VFSTECR
C
C * RPN Standard files parameters
C
INTEGER IP1,IP2,IP3, IDATYP, IDATEO
C
EXTERNAL FNOM, FSTOUV, FSTFRM, FCLOS, STKMEMW, UNSTAKW
C
POINTER (PACOR,PRCOR)
USE_STKMEMW
!
real*8 zcorns(nksdim2,nksdim2,0:ntrunc,1)
real*8 zmaxmin(nksdim2,nksdim2)
real*8 zbloc(nflev,nflev)
!
*-------------------------------------------------------------------
!
write(nulout,*) 'writecornsglb: cdcase = ',cdcase
!
IPAK = -32
IDATYP = 5
IP1 = 0
IP3 = KENSEMBLE
IDATEO = KDATESTAMP
C
C * . 3.3 Write the normalized correlations in spectral form
C
330 CONTINUE
C
C * . 3.4 Write the spectral variances on file
C
if(ldwrt_rstddev) then
DO JN = 0, NTRUNC
IP2 = JN
IERR = VFSTECR(RSTDDEV(1,JN),RSTDDEV(1,JN),IPAK,KULCORNS
S ,IDATEO,0,0,NKSDIM,1,1
S ,IP1,IP2,IP3,'X','SS','RSTDDEV ','X'
S ,0,0,0,0,IDATYP,.TRUE.)
END DO
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 JN = 0, NTRUNC
do jcol = 1,nksdim2
do jrow = 1,nksdim2
zcorns(jrow,jcol,jn,1) = pcorns(jrow,jcol,jn,1)
zmaxmin(jrow,jcol)=zcorns(jrow,jcol,jn,1)
enddo
enddo
write(nulout,*) 'writecornsglb: Point 1, jn = ',jn
call maxmin(zmaxmin,nksdim2,1,nksdim2,zmin,zmax,
& idum1,idum2,idum3,idum4,'writecornsg',
& 'COR')
enddo
!
if(.not.ldnorm.and.(cdcase.ne.'MIN')) then
write(nulout,*) 'writecornsglb: denormalization is applied to corns...'
call scalecorns(zcorns,'D')
endif
!
DO JN = 0, NTRUNC
IP2 = JN
IERR = VFSTECR(zcorns(1,1,JN,1),zcorns(1,1,JN,1),IPAK,KULCORNS
S ,IDATEO,0,0,NKSDIM2,NKSDIM2,1
S ,IP1,IP2,IP3,cltypvar,clnomvar,cletiket,'X'
S ,0,0,0,0,IDATYP,.TRUE.)
END DO
!
! Write desired correlation blocks on ASCI file for publication
! -------------------------------------------------------------
!
clfield = 'CO'
!
jn = 20
!
! PSI-PSI
!
do ji = 1, nflev
ii = ji
do jj = 1, nflev
ij = jj
zbloc(ji,jj) = zcorns(ii,ij,jn,1)
enddo
enddo
!
open (unit=nutemp,file='psi_psi_corr_wvnb_20.od')
write(nutemp,910) nflev,nflev,1
write(nutemp,'(A2)') clfield
jk = 1
write(nutemp,920) jk
do jj = 1, nflev
write(nutemp,800) (zbloc(ji,jj),ji=1,nflev)
enddo
close(nutemp)
!
! PSI-CHI
!
do ji = 1, nflev
ii = ji
do jj = 1, nflev
ij = nflev+jj
zbloc(ji,jj) = zcorns(ii,ij,jn,1)
enddo
enddo
!
open (unit=nutemp,file='psi_chi_corr_wvnb_20.od')
write(nutemp,910) nflev,nflev,1
write(nutemp,'(A2)') clfield
jk = 1
write(nutemp,920) jk
do jj = 1, nflev
write(nutemp,800) (zbloc(ji,jj),ji=1,nflev)
enddo
close(nutemp)
!
! PSI-TT
!
do ji = 1, nflev
ii = ji
do jj = 1, nflev
ij = 2*nflev+jj
zbloc(ji,jj) = zcorns(ii,ij,jn,1)
enddo
enddo
!
open (unit=nutemp,file='psi_tt_corr_wvnb_20.od')
write(nutemp,910) nflev,nflev,1
write(nutemp,'(A2)') clfield
jk = 1
write(nutemp,920) jk
do jj = 1, nflev
write(nutemp,800) (zbloc(ji,jj),ji=1,nflev)
enddo
close(nutemp)
!
! CHI-CHI
!
do ji = 1, nflev
ii = nflev+ji
do jj = 1, nflev
ij = nflev+jj
zbloc(ji,jj) = zcorns(ii,ij,jn,1)
enddo
enddo
!
open (unit=nutemp,file='chi_chi_corr_wvnb_20.od')
write(nutemp,910) nflev,nflev,1
write(nutemp,'(A2)') clfield
jk = 1
write(nutemp,920) jk
do jj = 1, nflev
write(nutemp,800) (zbloc(ji,jj),ji=1,nflev)
enddo
close(nutemp)
!
! TT-TT
!
do ji = 1, nflev
ii = 2*nflev+ji
do jj = 1, nflev
ij = 2*nflev+jj
zbloc(ji,jj) = zcorns(ii,ij,jn,1)
enddo
enddo
!
open (unit=nutemp,file='tt_tt_corr_wvnb_20.od')
write(nutemp,910) nflev,nflev,1
write(nutemp,'(A2)') clfield
jk = 1
write(nutemp,920) jk
do jj = 1, nflev
write(nutemp,800) (zbloc(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)
!
! Calculate total vertical correlation matrix and
! write on file
! -----------------------------------------------
!
ISIZ=NR8SIZ
ILEN = NKSDIM * NKSDIM * ISIZ
CALL STKMEMW (MAX(ILEN,1),PACOR)
C
DO JK = 1, NKSDIM
DO JL = 1, NKSDIM
PRCOR(JK,JL) = 0
DO JN = 0, NTRUNC
PRCOR(JK,JL) = PRCOR(JK,JL) + ((2*JN+1) * RSTDDEV(JK,JN)
S * RSTDDEV(JL,JN)
S * CORNS(JK,JL,JN,1))
END DO
END DO
END DO
C
DO JK = 1, NKSDIM
DO JL = 1, NKSDIM
PRCOR(JK,JL) = PRCOR(JK,JL) / (SQRT(PRCOR(JK,JK)
S * PRCOR(JL,JL)))
END DO
END DO
C
IERR = VFSTECR(PRCOR(1,1),PRCOR(1,1),IPAK,KULCORNS
S ,IDATEO,0,0,NKSDIM,NKSDIM,1
S ,IP1,IP2,IP3,'X','ZV','CORVERT ','X'
S ,0,0,0,0,IDATYP,.TRUE.)
C
RETURN
END