!-------------------------------------- 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 suprecon 3,15
#if defined (DOC)
*
***s/r suprecon - Setup Hessian preconditioning and estimate analysis
* error variances
*
* Logic: If a preconditioning file is specified in felix and exists then LPCON is TRUE
* and the preconditioner (HEV) are read from the file to be used in the minimization
* Else: call HESSEIGEN to calculate the requested number of HEVs and write to the
* file "phev"
*
*Author : M. Buehner February, 2002
*Revision:
*
* -------------------
** Purpose:
* .
*
*Arguments
* -NONE-
#endif
IMPLICIT NONE
*implicits
#include "pardim.cdk"
#include "comdim.cdk"
#include "comlun.cdk"
#include "comcva.cdk"
#include "comgem.cdk"
#include "comgd0.cdk"
#include "comdimo.cdk"
#include "comoba.cdk"
#include "comoabdy.cdk"
#include "comoahdr.cdk"
#include "comanl.cdk"
#include "comvfiles.cdk"
C
REAL*8 ZTOL
INTEGER JJ,RR,IPRECON
INTEGER JLEV,IERR,JDATA
C
INTEGER FNOM,FCLOS,II,FSTPRM,FSTINF,FSTOUV,VFSTECR,FSTFRM
EXTERNAL FNOM,FCLOS,FSTPRM,FSTINF,FSTOUV,VFSTECR,FSTFRM
c
REAL*8 ZTOL,ZSMALL(NPRECON,NPRECON),ZSAVECMA(NDATA)
REAL*8 ZBUF(NI,NJ),ZGD(NI,NKGDIM,NJ),ZEVAL(1000)
C
C* RPN Standard files parameters
C
INTEGER INI,INJ,INK, INPAS, INBITS, IDATYP, IDEET
+ ,IP1,IP2,IP3,IG1,IG2,IG3,IG4,ISWA,ILENGTH,IDLTF
+ ,IUBC,IEXTR1,IEXTR2,IEXTR3,IKEY
INTEGER IDATE0,KULFILE
REAL*8 zwork
CHARACTER*1 CLTYPVAR,CLGRTYP
CHARACTER*2 CLNOMVAR
CHARACTER*8 CLETIKET
c
call printrev("SUBROUTINE suprecon :",1)
c
write(NULOUT,*) '***CALCULATING HESSIAN EIGENVECTOR***'
c
CALL ZERO(NI*NJ*NKGDIM,ZGD(1,1,1))
c
IF(LPCON) THEN
c
c If filename specified in felix, read in Hessian Eigenvectors (don't call ARPACK)
c
WRITE(NULOUT,*) 'READING IN EIGENVECTORS'
OPEN(unit=39,form='unformatted',file=CPCONF)
READ(39) IPRECON
WRITE(NULOUT,*) 'NUMBER OF EIGENMODES STORED IN FILE:',IPRECON
WRITE(NULOUT,*) 'NUMBER OF EIGENMODES REQUESTED :',NPRECON
DO RR=IPRECON,1,-1
READ(39) Zeval(RR)
ENDDO
II=0
DO RR=(IPRECON-NPRECON+1),IPRECON
II=II+1
HesEval(II)=Zeval(RR)
ENDDO
DO RR=NPRECON,1,-1
READ(39) (RRNK1(II,RR),II=1,NVADIM)
ENDDO
CLOSE(39)
c
ELSE
c
c No filename specified, therefore calculate Hessian Eigenvectors (using ARPACK)
c
WRITE(NULOUT,*) 'CALCULATING EIGENVECTORS'
c
c Save contents of CMA
c
DO JDATA = 1, NDATA
ZSAVECMA(JDATA)=ROBDATA8(NCMVAR,JDATA)
ROBDATA8(NCMVAR,JDATA)=0.0d0
END DO
c
do ii=1,nvadim
vazx(ii)=0.0d0
vazg(ii)=0.0d0
enddo
c
DO RR=1,NCV
DO II=1,NVADIM
RRNK1(II,RR)=0.0d0
ENDDO
ENDDO
c
c Set tolerance and call Lanczos algorithm
c
Ztol=1d-2
call hesseigen(ncordim,nprecon,ncv,HesEval,RRNK1,Ztol)
c
c Put back save cma data
c
DO JDATA = 1, NDATA
ROBDATA8(NCMVAR,JDATA)=ZSAVECMA(JDATA)
END DO
c
c Spit out E-values
c
WRITE(NULOUT,*)'NVADIM,NCORDIM = ',NVADIM,NCORDIM
do ii=1,nprecon
write(NULOUT,*) HesEval(ii)
enddo
c
c Multiply by sqrt of Eval
c
DO RR=1,NPRECON
if(HesEval(RR).lt.0.0d0) call abort3d(nulout,'ZERO E-VALUE')
ENDDO
DO RR=1,NPRECON
DO II=1,NVADIM
RRNK1(II,RR)=RRNK1(II,RR)*sqrt(HesEval(RR))
ENDDO
ENDDO
c
c Write out RRNK1
c
OPEN(unit=39,form='unformatted',file='phev')
WRITE(39) NPRECON
DO RR=NPRECON,1,-1
WRITE(39) HesEval(RR)
ENDDO
DO RR=NPRECON,1,-1
WRITE(39) (RRNK1(II,RR),II=1,NVADIM)
ENDDO
CLOSE(39)
C
ENDIF
c
c P_a = I - RRNK1*inv(I + RRNK1^T*RRNK1)*RRNK1^T = I - RRNK2*RRNK2^T
C Calculate (I + RRNK1^T*RRNK1)**(-0.5)
C
DO II=1,NPRECON
DO JJ=1,NPRECON
ZSMALL(II,JJ)=0.0
ENDDO
ENDDO
DO II=1,NPRECON
DO JJ=1,NPRECON
DO RR=1,NVADIM
ZSMALL(II,JJ)=ZSMALL(II,JJ)+RRNK1(RR,II)*RRNK1(RR,JJ)
ENDDO
ENDDO
ENDDO
DO II=1,NPRECON
ZSMALL(II,II)=ZSMALL(II,II)+1.0d0
ENDDO
CALL MATSQRT(ZSMALL,NPRECON,-1.0d0)
C
C Now pre-Multiply result by RRNK1
C
DO RR=1,NPRECON
DO II=1,NVADIM
RRNK2(II,RR)=0.0d0
ENDDO
ENDDO
DO JJ=1,NPRECON
DO RR=1,NPRECON
DO II=1,NVADIM
RRNK2(II,JJ)=RRNK2(II,JJ)+RRNK1(II,RR)*ZSMALL(RR,JJ)
ENDDO
ENDDO
ENDDO
c
c goto 999
c -----------------------------------------------------
c Write out Analysis Error Std Dev
C
C Multiply result by B**0.5 (with balance turned on or off)
C
LDOBAL=.TRUE.
c
DO RR=1,NPRECON
DO JJ=1,NVADIM
VAZX(JJ)=RRNK2(JJ,RR)
ENDDO
C
CALL CAIN(NVADIM,VAZX)
CALL SPA2SP
CALL SPGD
C
C Calculate the 3D corrections to the standard deviations (balanced or unbalanced vars)
C
DO JLEV = 1, NKGDIM
DO JJ = 1, NJ
DO II = 1, NI
ZGD(II,JLEV,JJ)=
+ ZGD(II,JLEV,JJ)+GD(II,JLEV,JJ)**2
ENDDO
ENDDO
ENDDO
ENDDO
WRITE(NULOUT,*) 'Finished calculating variances'
C
DO JLEV = 1, NKGDIM
DO JJ = 1, NJ
DO II = 1, NI
GD(II,JLEV,JJ)=DSQRT(ZGD(II,JLEV,JJ))
ENDDO
ENDDO
ENDDO
C
C Output to standard file
C
KULFILE=0
IERR = FNOM(KULFILE,'stdhes.fst','RND',0)
IF(IERR.GE.0)THEN
IERR = FSTOUV(KULFILE,'RND')
ELSE
CALL ABORT3D(NULOUT,'stdhes.fst:PROBLEM WITH FILE')
END IF
c
if(LDOBAL) then
c
c Output Std. dev. of Regular variables when LDOBAL=true
c
call postproc(kulfile,NPRECON,'GRID','STDDEV ')
else
c
c Output Std. dev. of UNBALANCED (LDOBAL=false) control variables (PP,UC,UT,UP,LQ)
c
cletiket='STDDEV'
ikey=fstinf(nulbgst,ini,inj,ink,-1,cletiket,
+ -1,-1,-1,' ','PP')
IERR = FSTPRM(ikey,IDATE0,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)
ip3=NPRECON
ini=ni
inj=nj
clgrtyp='G'
CLNOMVAR='PP'
do JLEV=1,NFLEV
DO JJ = 1, NJ
DO II = 1, NI
ZBUF(II,JJ)=UT0(II,JLEV,NJ-JJ+1)
ENDDO
ENDDO
ierr= VFSTECR(ZBUF,zwork,-inbits,kulfile,idate0,ideet,
+ inpas,ini,inj,1,nip1(jlev),ip2,ip3,cltypvar,
+ clnomvar,cletiket,clgrtyp,ig1,ig2,
+ ig3,ig4,idatyp,.true.)
enddo
CLNOMVAR='UC'
do JLEV=1,NFLEV
DO JJ = 1, NJ
DO II = 1, NI
ZBUF(II,JJ)=VT0(II,JLEV,NJ-JJ+1)
ENDDO
ENDDO
ierr= VFSTECR(ZBUF,zwork,-inbits,kulfile,idate0,ideet,
+ inpas,ini,inj,1,nip1(jlev),ip2,ip3,cltypvar,
+ clnomvar,cletiket,clgrtyp,ig1,ig2,
+ ig3,ig4,idatyp,.true.)
enddo
CLNOMVAR='UT'
do JLEV=1,NFLEV
DO JJ = 1, NJ
DO II = 1, NI
ZBUF(II,JJ)=TT0(II,JLEV,NJ-JJ+1)
ENDDO
ENDDO
ierr= VFSTECR(ZBUF,zwork,-inbits,kulfile,idate0,ideet,
+ inpas,ini,inj,1,nip1(jlev),ip2,ip3,cltypvar,
+ clnomvar,cletiket,clgrtyp,ig1,ig2,
+ ig3,ig4,idatyp,.true.)
enddo
CLNOMVAR='LQ'
do JLEV=1,NFLEV
DO JJ = 1, NJ
DO II = 1, NI
ZBUF(II,JJ)=Q0(II,JLEV,NJ-JJ+1)
ENDDO
ENDDO
ierr= VFSTECR(ZBUF,zwork,-inbits,kulfile,idate0,ideet,
+ inpas,ini,inj,1,nip1(jlev),ip2,ip3,cltypvar,
+ clnomvar,cletiket,clgrtyp,ig1,ig2,
+ ig3,ig4,idatyp,.true.)
enddo
CLNOMVAR='UP'
DO JJ = 1, NJ
DO II = 1, NI
ZBUF(II,JJ)=GPS0(II,1,NJ-JJ+1)
ENDDO
ENDDO
ierr= VFSTECR(ZBUF,zwork,-inbits,kulfile,idate0,ideet,
+ inpas,ini,inj,1,0,ip2,ip3,cltypvar,
+ clnomvar,cletiket,clgrtyp,ig1,ig2,
+ ig3,ig4,idatyp,.true.)
endif
c
LDOBAL=.TRUE.
IERR = FSTFRM(KULFILE)
IERR = FCLOS(KULFILE)
C -------------------------------------------------------
999 continue
c
do ii=1,nvadim
vazx(ii)=0.0d0
vazg(ii)=0.0d0
enddo
c
END