!-------------------------------------- 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 WRITECORNS(KULCORNS,CDFLCORNS 1,3
S ,KULSTDEV,CDFLSTDEV,KDATESTAMP, KENSEMBLE)
#if defined (DOC)
*
***s/r WRITECORNS - Output CORNS and RSTDDEV on RPN standard files
*
*
*Author : P. Gauthier *ARMA/AES December, 1996
*Revision:
* . P. Gauthier *ARMA/AES August 3, 1994: the normalized increments
* . can be split on several files and a restart is now
* . possible. Control of CSE1 is through the namelist
* . NAMCSE1 and COMCSE1
* JM Belanger CMDA/SMC Jul 2000
* . 32 bits conversion
*
* -------------------
** Purpose: to estimate the forecast error correlation from an
* . ensemble of normalized and unbiased residuals such
* . as differences between 24/48h forecast valid at the
* . same time
*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 "comdim.cdk"
#include "comcorr.cdk"
#include "comcst.cdk"
#include <rpnmacros_f.h>
*
* Arguments
*
CHARACTER*16 CDFLCORNS, CDFLSTDEV
INTEGER KULCORNS, KULSTDEV, KDATESTAMP, KENSEMBLE
*
* Local variables
*
INTEGER JN, IERR, IPAK, ILEN,JK,JL, ISIZ
REAL*8 PRCOR(NKSDIM,NKSDIM)
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
*-------------------------------------------------------------------
C
IERR = FNOM (KULCORNS,CDFLCORNS,'RND',0)
IERR = FSTOUV(KULCORNS,'RND')
C
IERR = FNOM (KULSTDEV,CDFLSTDEV,'RND',0)
IERR = FSTOUV(KULSTDEV,'RND')
C
IPAK = -32
IDATYP = 5
IP1 = 0
IP3 = KENSEMBLE
IDATEO = KDATESTAMP
C
C * . 3.3 Write the normalized correlations in spectral form
C
330 CONTINUE
DO JN = 0, NTRUNC
IP2 = JN
IERR = VFSTECR(CORNS(1,1,JN,1),CORNS(1,1,JN,1),IPAK,KULCORNS
S ,IDATEO,0,0,NKSDIM,NKSDIM,1
S ,IP1,IP2,IP3,'X','ZZ','CORRNS ','X'
S ,0,0,0,0,IDATYP,.TRUE.)
END DO
C
C * . 3.4 Write the spectral variances on file
C
DO JN = 0, NTRUNC
IP2 = JN
IERR = VFSTECR(RSTDDEV(1,JN),RSTDDEV(1,JN),IPAK,KULSTDEV
S ,IDATEO,0,0,NKSDIM,1,1
S ,IP1,IP2,IP3,'X','SS','RSTDDEV ','X'
S ,0,0,0,0,IDATYP,.TRUE.)
END DO
C
C * . 3.5 Calcultate total vertical correlation matrix and
C write on file
C
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
C * 4. Close all files
C
400 CONTINUE
C
CALL UNSTAKW(PACOR)
C
IERR = FSTFRM(KULCORNS)
IERR = FSTFRM(KULSTDEV)
IERR = FCLOS (KULCORNS)
IERR = FCLOS (KULSTDEV)
C
RETURN
END