!-------------------------------------- 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 SUCORNS,3
IMPLICIT NONE
#if defined (DOC)
*
***s/r SUCORNS - produce matrix that scales and rotates controls according to
* eigenmodes/values of CORNS to create new control vector that
* diagonalize the Jb term
* - this matrix is phi*lambda^-0.5 where phi and lambda are the
* eigenvectors and eigenvalues of the background covariance matrix
* - called from SUCOV when NANALVAR=3
* - matrix used in SPA2SP, SPA2SPAD
*
*Author : M. Buehner November 97
*Revision:
* S. Pellerin *ARMA/SMC May 2000
* . Check for negative eigenvalues
* JM Belanger CMDA/SMC Aug 2000
* . 32 bits conversion
* (MXMA8, DSYEV instead of MXMA, SSYEV)
* M. Buehner ARMA May 2008
* . Added vertical localization of correlations
* Bin HE *ARMA/MBR* Nov. 2011
* . Replaced MAMX8 with DGEMUL of ESSL.
*
#endif
#include "pardim.cdk"
#include "comdim.cdk"
#include "comlun.cdk"
#include "comcorr.cdk"
#include "comcva.cdk"
#include "comgem.cdk"
#include "comleg.cdk"
#include "comcst.cdk"
#include "comspg.cdk"
#include "rpnstd.cdk"
#include "dgemul.h"
*
REAL*8 EIGENV(NKSDIM), EIGEN(NKSDIM,NKSDIM),
& SQRTIN(NKSDIM,NKSDIM)
C
INTEGER IJ,II,IN,jk1,jk2
INTEGER IER,ILWORK,INFO
integer iulcorvert, ikey
C
REAL*8 RESULT(NKSDIM,NKSDIM),RESULT2(NKSDIM,NKSDIM),ZWORK(1)
real*8 zpres1,ztlen,zlc,zcorr,zr,zpres2,zprof(JPNFLEV),zps
c
POINTER(PXWRK,ZWORK)
POINTER(PXRES,RESULT)
POINTER(PXRES2,RESULT2)
POINTER(PXEV,EIGENV)
POINTER(PXE,EIGEN)
POINTER(PXSQI,SQRTIN)
EXTERNAL DSYEV
C
C
C 0. Memory allocation
C
CALL HPALLOC(PXWRK, 2*4*NKSDIM, IER,8)
CALL HPALLOC(PXRES,4*NKSDIM*NKSDIM, IER,8)
CALL HPALLOC(PXRES2,4*NKSDIM*NKSDIM, IER,8)
CALL HPALLOC(PXEV,4*NKSDIM, IER,8)
CALL HPALLOC(PXE,4*NKSDIM*NKSDIM, IER,8)
CALL HPALLOC(PXSQI,4*NKSDIM*NKSDIM, IER,8)
C
write(NULOUT,*)' *******************************'
WRITE(NULOUT,*)' SUCORNS --- Calculate CORNS^(0.5)'
C
ILWORK=4*NKSDIM*2
C
C Apply vertical localization to corrns
C
zps = 101000. 0
call calcpres(ZPROF,vhybinc,nflev,ZPS,rptopinc
& ,rprefinc,rcoefinc,1)
C
do jk1=1,nflev
write(nulout,*)'sucorns:lev,hyb,zprof,log= ',jk1,vhybinc(jk1)
& ,zprof(jk1),log(zprof(jk1))
enddo
c
c unbalanced temperature (and t'-ps')
c
ztlen=RVLOCUNBALT
write(nulout,*)'sucorns:ztlen(UNBALT)= ',ztlen
if(ztlen.gt.0.0) then
c calculate 5'th order function (from Gaspari and Cohn)
do jk1=1,nflev
zpres1=log(ZPROF(jk1))
do jk2=1,nflev
ZLC=ztlen/2.0
zpres2=log(ZPROF(jk2))
ZR = abs(zpres2 - zpres1)
if(ZR.le.ZLC) then
zcorr=-0.250*(ZR/ZLC)**5+0.5*(ZR/ZLC)**4
+ +0.625*(ZR/ZLC)**3-(5.0/3.0)*(ZR/ZLC)**2+1.0
elseif(ZR.le.(2.0*ZLC)) then
zcorr=(1.0/12.0)*(ZR/ZLC)**5-0.5*(ZR/ZLC)**4
+ +0.625*(ZR/ZLC)**3+(5.0/3.0)*(ZR/ZLC)**2
+ -5.0*(ZR/ZLC)+4.0-(2.0/3.0)*(ZLC/ZR)
else
zcorr= 0.0
endif
if(zcorr.lt.0.0) zcorr=0.0
do in=0,ntrunc
c unbalanced temperature
corns(jk1+2*nflev,jk2+2*nflev,IN,1) =corns(jk1+2*nflev,jk2+2*nflev,IN,1)*zcorr
if(jk1.eq.nflev) then
c t' <-> ps'
corns(1+4*nflev,jk2+2*nflev,IN,1) =corns(1+4*nflev,jk2+2*nflev,IN,1)*zcorr
corns(jk2+2*nflev,1+4*nflev,IN,1) =corns(jk2+2*nflev,1+4*nflev,IN,1)*zcorr
endif
enddo
enddo
enddo
endif
c
c streamfunction
c
ztlen= RVLOCPSI ! specify length scale (in units of ln(Pressure))
write(nulout,*)'sucorns:ztlen(PSI)= ',ztlen
if(ZTLEN.gt.0.0) then
c calculate 5'th order function (from Gaspari and Cohn)
ZLC=ZTLEN/2.0
do jk1=1,nflev
zpres1=log(ZPROF(jk1))
do jk2=1,nflev
zpres2=log(ZPROF(jk2))
ZR = abs(zpres2 - zpres1)
if(ZR.le.ZLC) then
zcorr=-0.250*(ZR/ZLC)**5+0.5*(ZR/ZLC)**4
+ +0.625*(ZR/ZLC)**3-(5.0/3.0)*(ZR/ZLC)**2+1.0
elseif(ZR.le.(2.0*ZLC)) then
zcorr=(1.0/12.0)*(ZR/ZLC)**5-0.5*(ZR/ZLC)**4
+ +0.625*(ZR/ZLC)**3+(5.0/3.0)*(ZR/ZLC)**2
+ -5.0*(ZR/ZLC)+4.0-(2.0/3.0)*(ZLC/ZR)
else
zcorr= 0.0
endif
if(zcorr.lt.0.0) zcorr=0.0
do in=0,ntrunc
corns(jk1,jk2,IN,1) =corns(jk1,jk2,IN,1)*zcorr
enddo
enddo
enddo
endif
c
c velocity potential (unbalanced)
c
ztlen= RVLOCCHI ! specify length scale (in units of ln(Pressure))
write(nulout,*)'sucorns:ztlen(CHI)= ',ztlen
if(ZTLEN.gt.0.0) then
c calculate 5'th order function (from Gaspari and Cohn)
ZLC=ZTLEN/2.0
do jk1=1,nflev
zpres1=log(ZPROF(jk1))
do jk2=1,nflev
zpres2=log(ZPROF(jk2))
ZR = abs(zpres2 - zpres1)
if(ZR.le.ZLC) then
zcorr=-0.250*(ZR/ZLC)**5+0.5*(ZR/ZLC)**4
+ +0.625*(ZR/ZLC)**3-(5.0/3.0)*(ZR/ZLC)**2+1.0
elseif(ZR.le.(2.0*ZLC)) then
zcorr=(1.0/12.0)*(ZR/ZLC)**5-0.5*(ZR/ZLC)**4
+ +0.625*(ZR/ZLC)**3+(5.0/3.0)*(ZR/ZLC)**2
+ -5.0*(ZR/ZLC)+4.0-(2.0/3.0)*(ZLC/ZR)
else
zcorr= 0.0
endif
if(zcorr.lt.0.0) zcorr=0.0
do in=0,ntrunc
corns(jk1+nflev,jk2+nflev,IN,1 ) =corns(jk1+nflev,jk2+nflev,IN,1 )*zcorr
enddo
enddo
enddo
endif
c
c humidity
c
ztlen= RVLOCLQ ! specify length scale (in units of ln(Pressure))
write(nulout,*)'sucorns:ztlen(LQ)= ',ztlen
if(ZTLEN.gt.0.0) then
c calculate 5'th order function (from Gaspari and Cohn)
ZLC=ZTLEN/2.0
do jk1=1,nflev
zpres1=log(ZPROF(jk1))
do jk2=1,nflev
zpres2=log(ZPROF(jk2))
ZR = abs(zpres2 - zpres1)
if(ZR.le.ZLC) then
zcorr=-0.250*(ZR/ZLC)**5+0.5*(ZR/ZLC)**4
+ +0.625*(ZR/ZLC)**3-(5.0/3.0)*(ZR/ZLC)**2+1.0
elseif(ZR.le.(2.0*ZLC)) then
zcorr=(1.0/12.0)*(ZR/ZLC)**5-0.5*(ZR/ZLC)**4
+ +0.625*(ZR/ZLC)**3+(5.0/3.0)*(ZR/ZLC)**2
+ -5.0*(ZR/ZLC)+4.0-(2.0/3.0)*(ZLC/ZR)
else
zcorr= 0.0
endif
if(zcorr.lt.0.0) zcorr=0.0
do in=0,ntrunc
corns(jk1+3*nflev,jk2+3*nflev,IN,1 ) =corns(jk1+3*nflev,jk2+3*nflev,IN,1 )*zcorr
enddo
enddo
enddo
endif
c
c compute total vertical correlations (after localization)
c
if(.true.) then
DO JK2 = 1, NKSDIM
DO JK1 = 1, NKSDIM
CORVERT(JK1,JK2) = 0.0
DO IN = 0, NTRUNC
CORVERT(JK1,JK2) = CORVERT(JK1,JK2)+((2*IN+1)*CORNS(JK1,JK2,IN,1))
ENDDO
ENDDO
ENDDO
write(701,*) corvert
iulcorvert = 0
if(.true.) then
ierr = fnom(iulcorvert,'corvert.fst','RND',0)
ierr = fstouv(iulcorvert,'RND')
ikey = fstinf(NULBGST,ini,inj,ink,-1,'CORNS',-1,0,-1,' ','ZZ')
ierr = fstprm(ikey,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
ip1 = 0
ip2 = ntrunc
ip3 = 0
clnomvar= 'ZV'
cletiket= 'CORVERT'
idatyp = 5
c
ierr = vfstecr(corvert, corvert, -inbits, iulcorvert, idateo
& , ideet,inpas, ini, inj, ink, ip1, ip2, ip3, cltypvar,
& clnomvar,cletiket,clgrtyp,ig1, ig2, ig3, ig4, idatyp,
& .true.)
ierr = vfstlir(corvert,iulcorvert,INI,INJ,INK
S ,idateo,cletiket,ip1,ip2,ip3,cltypvar,clnomvar)
c
ierr = fstfrm(iulcorvert)
endif
endif
C
C calculate CORNS^(0.5) for each total wave number
C
DO IN=0,NTRUNC
C
DO IJ=1,NKSDIM
DO II=1,NKSDIM
EIGEN(II,IJ)=CORNS(II,IJ,IN,1)
END DO
END DO
C
C 1. CALCULATE EIGENVALUES AND EIGENVECTORS.
C
CALL DSYEV('V','U',NKSDIM, EIGEN,NKSDIM, EIGENV,
+ ZWORK, ILWORK, INFO )
C
DO IJ=1,NKSDIM
DO II=1,NKSDIM
SQRTIN(II,IJ)=0.
END DO
END DO
C
DO II=1,NKSDIM
if(EIGENV(II).lt.0.0) then
sqrtin(ii,ii) = 0.0
else
SQRTIN(II,II)=SQRT(EIGENV(II))
endif
END DO
C
C 2. CALCULATE THE PRODUCT AND STORE IT BACK IN CORNS
C
CCC-- INSERER COMMENTAIRES POUR EXPLIQUER LA DIFFERENCE ENTRE LES 2 APPROCHES
C POUR L'INSTANT ON FAIT LA DISTINCTION POUR REPRODUIRE LES RESULTATS
C QUAND CVCORD .EQ. 'PRESS'
C VOIR LUC ET MARK
CCC
C
c CALL MXMA8(EIGEN,1,NKSDIM, SQRTIN,1,NKSDIM, RESULT2,1,
c + NKSDIM,NKSDIM,NKSDIM,NKSDIM)
CALL DGEMUL(EIGEN,NKSDIM,'N',SQRTIN,NKSDIM,'N',RESULT2,
+ NKSDIM,NKSDIM,NKSDIM,NKSDIM)
c CALL MXMA8(RESULT2,1,NKSDIM, EIGEN,NKSDIM,1, RESULT,1,
c + NKSDIM,NKSDIM,NKSDIM,NKSDIM)
CALL DGEMUL(RESULT2,NKSDIM,'N',EIGEN,NKSDIM,'N',RESULT,
+ NKSDIM,NKSDIM,NKSDIM,NKSDIM)
C
DO IJ=1,NKSDIM
DO II=1,NKSDIM
CORNS(II,IJ,IN,1)=RESULT(II,IJ)
ENDDO
ENDDO
C
ENDDO !! IN=0,NTRUNC
c
CALL HPDEALLC(PXWRK, IER,1)
CALL HPDEALLC(PXRES, IER,1)
CALL HPDEALLC(PXEV, IER,1)
CALL HPDEALLC(PXE, IER,1)
CALL HPDEALLC(PXSQI, IER,1)
C
RETURN
END