!-------------------------------------- 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 hesseigen(n,nev,ncv,Eval,v,tol) 1,2
#if defined (DOC)
*
***s/r hesseigen - Driver for ARPACK solver to calculate hessian eigen vectors
*
*Author : M. Buehner June, 2002
*Revision : S. Pellerin, January 2009
* .Call to new simulator (simvar)
c-----------------------------------------------------------------------
c SUBROUTINE: HESSEIGEN
c Driver subroutine for calling Lanczos algorithm to calculate
c Hessian eigenvectors
c
c\Routines called:
c ssaupd ARPACK reverse communication interface routine.
c sseupd ARPACK routine that returns Ritz values and (optionally)
c Ritz vectors.
c snrm2 Level 1 BLAS that computes the norm of a vector.
c saxpy Level 1 BLAS that computes y <- alpha*x+y.
c avhess Matrix vector multiplication routine that computes A*x.
c tv Matrix vector multiplication routine that computes T*x,
c where T is a tridiagonal matrix. It is used in routine
c avhess.
c n - dimension of space
c nev - number of modes to compute
c ncv - twice (or thrice) the number of modes (for internal workspace)
c-----------------------------------------------------------------------
#endif
c
c Arguments
#include "comlun.cdk"
Integer n,nev,ncv
Real*8 v(n,ncv), Eval(nev)
Real*8 tol
c
c | Local Arrays |
Real*8 workl(ncv*(ncv+8)),workd(3*n),
& d(ncv,2), resid(n),ax(n)
logical select(ncv)
c
POINTER (PTworkl,workl)
POINTER (PTworkd,workd)
POINTER (PTd,d)
POINTER (PTresid,resid)
POINTER (PTax,ax)
POINTER (PTselect,select)
c
integer iparam(11), ipntr(11)
c
c | Local Scalars |
character bmat*1, which*2
integer ido, lworkl, info, ierr, j,
& nconv, maxitr, mode, ishfts
logical rvec
Real*8
& sigma
c | Parameters |
Real*8
& zero
parameter (zero = 0.0E+0)
c | BLAS & LAPACK routines used |
Real*8
& dnrm2
external dnrm2, daxpy
c | Intrinsic function |
intrinsic dabs
c
c Allocate local arrays
c
ilen = ncv*(ncv+8)
CALL HPALLOC(PTworkl ,MAX(ILEN,1),IERR,8)
ilen = 3*n
CALL HPALLOC(PTworkd ,MAX(ILEN,1),IERR,8)
ilen = 2*ncv
CALL HPALLOC(PTd ,MAX(ILEN,1),IERR,8)
ilen = n
CALL HPALLOC(PTresid ,MAX(ILEN,1),IERR,8)
ilen = n
CALL HPALLOC(PTax ,MAX(ILEN,1),IERR,8)
ilen = ncv
CALL HPALLOC(PTselect ,MAX(ILEN,1),IERR,8)
c
write(nulout,*) 'STARTING SSDRVTEST'
bmat = 'I'
which = 'LM'
c
lworkl = ncv*(ncv+8)
c tol = zero
info = 0
ido = 0
c
ishfts = 1
maxitr = 300
mode = 1
c
iparam(1) = ishfts
iparam(3) = maxitr
iparam(7) = mode
c
c %-------------------------------------------%
c | M A I N L O O P (Reverse communication) |
c %-------------------------------------------%
c
10 continue
c
c %---------------------------------------------%
c | Repeatedly call the routine SSAUPD and take |
c | actions indicated by parameter IDO until |
c | either convergence is indicated or maxitr |
c | has been exceeded. |
c %---------------------------------------------%
c
c write(nulout,*) 'CALLING SSAUPD'
call dsaupd ( ido, bmat, n, which, nev, tol, resid,
& ncv, v, n, iparam, ipntr, workd, workl,
& lworkl, info )
c
if (ido .eq. -1 .or. ido .eq. 1) then
c
call avhess (n, workd(ipntr(1)), workd(ipntr(2)))
c
go to 10
c
end if
c
c write(nulout,*) 'finished looping on ssaupd'
if ( info .lt. 0 ) then
c
write(nulout,*) ' '
write(nulout,*) ' Error with _saupd, info = ', info
write(nulout,*) ' Check documentation in _saupd '
write(nulout,*) ' '
c
else
c
rvec = .true.
c
call dseupd ( rvec, 'All', select, d, v, n, sigma,
& bmat, n, which, nev, tol, resid, ncv, v, n,
& iparam, ipntr, workd, workl, lworkl, ierr )
c
c | Eigenvalues are returned in the first column |
c | of the two dimensional array D and the |
c | corresponding eigenvectors are returned in |
c | the first NEV columns of the two dimensional |
c | array V if requested. |
c
if ( ierr .ne. 0) then
c
write(nulout,*) ' '
write(nulout,*) ' Error with _seupd, info = ', ierr
write(nulout,*) ' Check the documentation of _seupd. '
write(nulout,*) ' '
c
else
c
nconv = iparam(5)
do 20 j=1, nconv
c
c %---------------------------%
c | Compute the residual norm |
c | |
c | || A*x - lambda*x || |
c | |
c | for the NCONV accurately |
c | computed eigenvalues and |
c | eigenvectors. (iparam(5) |
c | indicates how many are |
c | accurate to the requested |
c | tolerance) |
c %---------------------------%
c
call avhess(n, v(1,j), ax)
call daxpy(n, -d(j,1), v(1,j), 1, ax, 1)
d(j,2) = dnrm2(n, ax, 1)
d(j,2) = d(j,2) / dabs(d(j,1))
c
20 continue
c
call dmout(6, nconv, 2, d, ncv, -6,
& 'Ritz values and relative residuals')
end if
c
if ( info .eq. 1) then
write(nulout,*) ' '
write(nulout,*) ' Maximum number of iterations reached.'
write(nulout,*) ' '
else if ( info .eq. 3) then
write(nulout,*) ' '
write(nulout,*) ' No shifts could be applied during implicit',
& ' Arnoldi update, try increasing NCV.'
write(nulout,*) ' '
end if
c
write(nulout,*) ' '
write(nulout,*) ' _SDRV1 '
write(nulout,*) ' ====== '
write(nulout,*) ' '
write(nulout,*) ' Size of the matrix is ', n
write(nulout,*) ' The number of Ritz values requested is ', nev
write(nulout,*) ' The number of Arnoldi vectors generated',
& ' (NCV) is ', ncv
write(nulout,*) ' What portion of the spectrum: ', which
write(nulout,*) ' The number of converged Ritz values is ',
& nconv
write(nulout,*) ' The number of Implicit Arnoldi update',
& ' iterations taken is ', iparam(3)
write(nulout,*) ' The number of OP*x is ', iparam(9)
write(nulout,*) ' The convergence criterion is ', tol
write(nulout,*) ' '
do j=1,nev
Eval(j)=d(j,1)
enddo
c
end if
c
9000 continue
c
c Deallocate local arrays
c
CALL HPDEALLC(PTworkl ,IERR,1)
CALL HPDEALLC(PTworkd ,IERR,1)
CALL HPDEALLC(PTd ,IERR,1)
CALL HPDEALLC(PTresid ,IERR,1)
CALL HPDEALLC(PTax ,IERR,1)
CALL HPDEALLC(PTselect ,IERR,1)
c
end
c
c ------------------------------------------------------------------
c matrix vector subroutine
c
c Computes w <--- OP*v, where OP is the Hessian of Jo in space of
c control vector
c ------------------------------------------------------------------
subroutine avhess (n, v, w) 2,2
IMPLICIT NONE
#include "comdim.cdk"
#include "comlun.cdk"
#include "comcva.cdk"
#include "comvarqc.cdk"
c
integer n, j, i, indic, iprecon
INTEGER JN,JM,ILA,JK
LOGICAL LVQC
Real*8
& v(n), w(n), zjsp
c
INDIC = 3
DO i=1,NVADIM
VAZG(i) = 0.0
VAZX(i) = V(i)
ENDDO
LVQC=LVARQC
LVARQC=.false.
iprecon=nprecon
nprecon=0
write(nulout,*) 'CALLING simvar'
call vflush(nulout)
call simvar(indic,nvadim,vazx,zjsp,vazg)
nprecon=iprecon
LVARQC=LVQC
DO i=1,N
W(i)=0.0
ENDDO
DO i=1,NVADIM
W(i)=VAZG(i)
ENDDO
c
return
end