Projects/pyblm
Archived
5
0
Fork 0
Code Issues Pull Requests Activity

Added arpack with bindings from scipy sandbox.

Browse Source
This commit is contained in:
Einar Ryeng
2007-10-11 09:45:05 +00:00
parent e932022249
commit e8b1980775
103 changed files with 37986 additions and 0 deletions
Download Patch File Download Diff File Expand all files Collapse all files

384
arpack/ARPACK/LAPACK/clahqr.f Normal file
View File

@@ -0,0 +1,384 @@
SUBROUTINE CLAHQR( WANTT, WANTZ, N, ILO, IHI, H, LDH, W, ILOZ,
$ IHIZ, Z, LDZ, INFO )
*
* -- LAPACK auxiliary routine (version 2.0) --
* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
* Courant Institute, Argonne National Lab, and Rice University
* September 30, 1994
*
* .. Scalar Arguments ..
LOGICAL WANTT, WANTZ
INTEGER IHI, IHIZ, ILO, ILOZ, INFO, LDH, LDZ, N
* ..
* .. Array Arguments ..
COMPLEX H( LDH, * ), W( * ), Z( LDZ, * )
* ..
*
* Purpose
* =======
*
* CLAHQR is an auxiliary routine called by CHSEQR to update the
* eigenvalues and Schur decomposition already computed by CHSEQR, by
* dealing with the Hessenberg submatrix in rows and columns ILO to IHI.
*
* Arguments
* =========
*
* WANTT (input) LOGICAL
* = .TRUE. : the full Schur form T is required;
* = .FALSE.: only eigenvalues are required.
*
* WANTZ (input) LOGICAL
* = .TRUE. : the matrix of Schur vectors Z is required;
* = .FALSE.: Schur vectors are not required.
*
* N (input) INTEGER
* The order of the matrix H. N >= 0.
*
* ILO (input) INTEGER
* IHI (input) INTEGER
* It is assumed that H is already upper triangular in rows and
* columns IHI+1:N, and that H(ILO,ILO-1) = 0 (unless ILO = 1).
* CLAHQR works primarily with the Hessenberg submatrix in rows
* and columns ILO to IHI, but applies transformations to all of
* H if WANTT is .TRUE..
* 1 <= ILO <= max(1,IHI); IHI <= N.
*
* H (input/output) COMPLEX array, dimension (LDH,N)
* On entry, the upper Hessenberg matrix H.
* On exit, if WANTT is .TRUE., H is upper triangular in rows
* and columns ILO:IHI, with any 2-by-2 diagonal blocks in
* standard form. If WANTT is .FALSE., the contents of H are
* unspecified on exit.
*
* LDH (input) INTEGER
* The leading dimension of the array H. LDH >= max(1,N).
*
* W (output) COMPLEX array, dimension (N)
* The computed eigenvalues ILO to IHI are stored in the
* corresponding elements of W. If WANTT is .TRUE., the
* eigenvalues are stored in the same order as on the diagonal
* of the Schur form returned in H, with W(i) = H(i,i).
*
* ILOZ (input) INTEGER
* IHIZ (input) INTEGER
* Specify the rows of Z to which transformations must be
* applied if WANTZ is .TRUE..
* 1 <= ILOZ <= ILO; IHI <= IHIZ <= N.
*
* Z (input/output) COMPLEX array, dimension (LDZ,N)
* If WANTZ is .TRUE., on entry Z must contain the current
* matrix Z of transformations accumulated by CHSEQR, and on
* exit Z has been updated; transformations are applied only to
* the submatrix Z(ILOZ:IHIZ,ILO:IHI).
* If WANTZ is .FALSE., Z is not referenced.
*
* LDZ (input) INTEGER
* The leading dimension of the array Z. LDZ >= max(1,N).
*
* INFO (output) INTEGER
* = 0: successful exit
* > 0: if INFO = i, CLAHQR failed to compute all the
* eigenvalues ILO to IHI in a total of 30*(IHI-ILO+1)
* iterations; elements i+1:ihi of W contain those
* eigenvalues which have been successfully computed.
*
* =====================================================================
*
* .. Parameters ..
COMPLEX ZERO, ONE
PARAMETER ( ZERO = ( 0.0E+0, 0.0E+0 ),
$ ONE = ( 1.0E+0, 0.0E+0 ) )
REAL RZERO, HALF
PARAMETER ( RZERO = 0.0E+0, HALF = 0.5E+0 )
* ..
* .. Local Scalars ..
INTEGER I, I1, I2, ITN, ITS, J, K, L, M, NH, NZ
REAL H10, H21, RTEMP, S, SMLNUM, T2, TST1, ULP
COMPLEX CDUM, H11, H11S, H22, SUM, T, T1, TEMP, U, V2,
$ X, Y
* ..
* .. Local Arrays ..
REAL RWORK( 1 )
COMPLEX V( 2 )
* ..
* .. External Functions ..
REAL CLANHS, SLAMCH
COMPLEX CLADIV
EXTERNAL CLANHS, SLAMCH, CLADIV
* ..
* .. External Subroutines ..
EXTERNAL CCOPY, CLARFG, CSCAL
* ..
* .. Intrinsic Functions ..
INTRINSIC ABS, AIMAG, CONJG, MAX, MIN, REAL, SQRT
* ..
* .. Statement Functions ..
REAL CABS1
* ..
* .. Statement Function definitions ..
CABS1( CDUM ) = ABS( REAL( CDUM ) ) + ABS( AIMAG( CDUM ) )
* ..
* .. Executable Statements ..
*
INFO = 0
*
* Quick return if possible
*
IF( N.EQ.0 )
$ RETURN
IF( ILO.EQ.IHI ) THEN
W( ILO ) = H( ILO, ILO )
RETURN
END IF
*
NH = IHI - ILO + 1
NZ = IHIZ - ILOZ + 1
*
* Set machine-dependent constants for the stopping criterion.
* If norm(H) <= sqrt(OVFL), overflow should not occur.
*
ULP = SLAMCH( 'Precision' )
SMLNUM = SLAMCH( 'Safe minimum' ) / ULP
*
* I1 and I2 are the indices of the first row and last column of H
* to which transformations must be applied. If eigenvalues only are
* being computed, I1 and I2 are set inside the main loop.
*
IF( WANTT ) THEN
I1 = 1
I2 = N
END IF
*
* ITN is the total number of QR iterations allowed.
*
ITN = 30*NH
*
* The main loop begins here. I is the loop index and decreases from
* IHI to ILO in steps of 1. Each iteration of the loop works
* with the active submatrix in rows and columns L to I.
* Eigenvalues I+1 to IHI have already converged. Either L = ILO, or
* H(L,L-1) is negligible so that the matrix splits.
*
I = IHI
10 CONTINUE
IF( I.LT.ILO )
$ GO TO 130
*
* Perform QR iterations on rows and columns ILO to I until a
* submatrix of order 1 splits off at the bottom because a
* subdiagonal element has become negligible.
*
L = ILO
DO 110 ITS = 0, ITN
*
* Look for a single small subdiagonal element.
*
DO 20 K = I, L + 1, -1
TST1 = CABS1( H( K-1, K-1 ) ) + CABS1( H( K, K ) )
IF( TST1.EQ.RZERO )
$ TST1 = CLANHS( '1', I-L+1, H( L, L ), LDH, RWORK )
IF( ABS( REAL( H( K, K-1 ) ) ).LE.MAX( ULP*TST1, SMLNUM ) )
$ GO TO 30
20 CONTINUE
30 CONTINUE
L = K
IF( L.GT.ILO ) THEN
*
* H(L,L-1) is negligible
*
H( L, L-1 ) = ZERO
END IF
*
* Exit from loop if a submatrix of order 1 has split off.
*
IF( L.GE.I )
$ GO TO 120
*
* Now the active submatrix is in rows and columns L to I. If
* eigenvalues only are being computed, only the active submatrix
* need be transformed.
*
IF( .NOT.WANTT ) THEN
I1 = L
I2 = I
END IF
*
IF( ITS.EQ.10 .OR. ITS.EQ.20 ) THEN
*
* Exceptional shift.
*
T = ABS( REAL( H( I, I-1 ) ) ) +
$ ABS( REAL( H( I-1, I-2 ) ) )
ELSE
*
* Wilkinson's shift.
*
T = H( I, I )
U = H( I-1, I )*REAL( H( I, I-1 ) )
IF( U.NE.ZERO ) THEN
X = HALF*( H( I-1, I-1 )-T )
Y = SQRT( X*X+U )
IF( REAL( X )*REAL( Y )+AIMAG( X )*AIMAG( Y ).LT.RZERO )
$ Y = -Y
T = T - CLADIV( U, ( X+Y ) )
END IF
END IF
*
* Look for two consecutive small subdiagonal elements.
*
DO 40 M = I - 1, L + 1, -1
*
* Determine the effect of starting the single-shift QR
* iteration at row M, and see if this would make H(M,M-1)
* negligible.
*
H11 = H( M, M )
H22 = H( M+1, M+1 )
H11S = H11 - T
H21 = H( M+1, M )
S = CABS1( H11S ) + ABS( H21 )
H11S = H11S / S
H21 = H21 / S
V( 1 ) = H11S
V( 2 ) = H21
H10 = H( M, M-1 )
TST1 = CABS1( H11S )*( CABS1( H11 )+CABS1( H22 ) )
IF( ABS( H10*H21 ).LE.ULP*TST1 )
$ GO TO 50
40 CONTINUE
H11 = H( L, L )
H22 = H( L+1, L+1 )
H11S = H11 - T
H21 = H( L+1, L )
S = CABS1( H11S ) + ABS( H21 )
H11S = H11S / S
H21 = H21 / S
V( 1 ) = H11S
V( 2 ) = H21
50 CONTINUE
*
* Single-shift QR step
*
DO 100 K = M, I - 1
*
* The first iteration of this loop determines a reflection G
* from the vector V and applies it from left and right to H,
* thus creating a nonzero bulge below the subdiagonal.
*
* Each subsequent iteration determines a reflection G to
* restore the Hessenberg form in the (K-1)th column, and thus
* chases the bulge one step toward the bottom of the active
* submatrix.
*
* V(2) is always real before the call to CLARFG, and hence
* after the call T2 ( = T1*V(2) ) is also real.
*
IF( K.GT.M )
$ CALL CCOPY( 2, H( K, K-1 ), 1, V, 1 )
CALL CLARFG( 2, V( 1 ), V( 2 ), 1, T1 )
IF( K.GT.M ) THEN
H( K, K-1 ) = V( 1 )
H( K+1, K-1 ) = ZERO
END IF
V2 = V( 2 )
T2 = REAL( T1*V2 )
*
* Apply G from the left to transform the rows of the matrix
* in columns K to I2.
*
DO 60 J = K, I2
SUM = CONJG( T1 )*H( K, J ) + T2*H( K+1, J )
H( K, J ) = H( K, J ) - SUM
H( K+1, J ) = H( K+1, J ) - SUM*V2
60 CONTINUE
*
* Apply G from the right to transform the columns of the
* matrix in rows I1 to min(K+2,I).
*
DO 70 J = I1, MIN( K+2, I )
SUM = T1*H( J, K ) + T2*H( J, K+1 )
H( J, K ) = H( J, K ) - SUM
H( J, K+1 ) = H( J, K+1 ) - SUM*CONJG( V2 )
70 CONTINUE
*
IF( WANTZ ) THEN
*
* Accumulate transformations in the matrix Z
*
DO 80 J = ILOZ, IHIZ
SUM = T1*Z( J, K ) + T2*Z( J, K+1 )
Z( J, K ) = Z( J, K ) - SUM
Z( J, K+1 ) = Z( J, K+1 ) - SUM*CONJG( V2 )
80 CONTINUE
END IF
*
IF( K.EQ.M .AND. M.GT.L ) THEN
*
* If the QR step was started at row M > L because two
* consecutive small subdiagonals were found, then extra
* scaling must be performed to ensure that H(M,M-1) remains
* real.
*
TEMP = ONE - T1
TEMP = TEMP / ABS( TEMP )
H( M+1, M ) = H( M+1, M )*CONJG( TEMP )
IF( M+2.LE.I )
$ H( M+2, M+1 ) = H( M+2, M+1 )*TEMP
DO 90 J = M, I
IF( J.NE.M+1 ) THEN
IF( I2.GT.J )
$ CALL CSCAL( I2-J, TEMP, H( J, J+1 ), LDH )
CALL CSCAL( J-I1, CONJG( TEMP ), H( I1, J ), 1 )
IF( WANTZ ) THEN
CALL CSCAL( NZ, CONJG( TEMP ), Z( ILOZ, J ), 1 )
END IF
END IF
90 CONTINUE
END IF
100 CONTINUE
*
* Ensure that H(I,I-1) is real.
*
TEMP = H( I, I-1 )
IF( AIMAG( TEMP ).NE.RZERO ) THEN
RTEMP = ABS( TEMP )
H( I, I-1 ) = RTEMP
TEMP = TEMP / RTEMP
IF( I2.GT.I )
$ CALL CSCAL( I2-I, CONJG( TEMP ), H( I, I+1 ), LDH )
CALL CSCAL( I-I1, TEMP, H( I1, I ), 1 )
IF( WANTZ ) THEN
CALL CSCAL( NZ, TEMP, Z( ILOZ, I ), 1 )
END IF
END IF
*
110 CONTINUE
*
* Failure to converge in remaining number of iterations
*
INFO = I
RETURN
*
120 CONTINUE
*
* H(I,I-1) is negligible: one eigenvalue has converged.
*
W( I ) = H( I, I )
*
* Decrement number of remaining iterations, and return to start of
* the main loop with new value of I.
*
ITN = ITN - ITS
I = L - 1
GO TO 10
*
130 CONTINUE
RETURN
*
* End of CLAHQR
*
END

410
arpack/ARPACK/LAPACK/dlahqr.f Normal file
View File

@@ -0,0 +1,410 @@
SUBROUTINE DLAHQR( WANTT, WANTZ, N, ILO, IHI, H, LDH, WR, WI,
$ ILOZ, IHIZ, Z, LDZ, INFO )
*
* -- LAPACK auxiliary routine (version 2.0) --
* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
* Courant Institute, Argonne National Lab, and Rice University
* October 31, 1992
*
* .. Scalar Arguments ..
LOGICAL WANTT, WANTZ
INTEGER IHI, IHIZ, ILO, ILOZ, INFO, LDH, LDZ, N
* ..
* .. Array Arguments ..
DOUBLE PRECISION H( LDH, * ), WI( * ), WR( * ), Z( LDZ, * )
* ..
*
* Purpose
* =======
*
* DLAHQR is an auxiliary routine called by DHSEQR to update the
* eigenvalues and Schur decomposition already computed by DHSEQR, by
* dealing with the Hessenberg submatrix in rows and columns ILO to IHI.
*
* Arguments
* =========
*
* WANTT (input) LOGICAL
* = .TRUE. : the full Schur form T is required;
* = .FALSE.: only eigenvalues are required.
*
* WANTZ (input) LOGICAL
* = .TRUE. : the matrix of Schur vectors Z is required;
* = .FALSE.: Schur vectors are not required.
*
* N (input) INTEGER
* The order of the matrix H. N >= 0.
*
* ILO (input) INTEGER
* IHI (input) INTEGER
* It is assumed that H is already upper quasi-triangular in
* rows and columns IHI+1:N, and that H(ILO,ILO-1) = 0 (unless
* ILO = 1). DLAHQR works primarily with the Hessenberg
* submatrix in rows and columns ILO to IHI, but applies
* transformations to all of H if WANTT is .TRUE..
* 1 <= ILO <= max(1,IHI); IHI <= N.
*
* H (input/output) DOUBLE PRECISION array, dimension (LDH,N)
* On entry, the upper Hessenberg matrix H.
* On exit, if WANTT is .TRUE., H is upper quasi-triangular in
* rows and columns ILO:IHI, with any 2-by-2 diagonal blocks in
* standard form. If WANTT is .FALSE., the contents of H are
* unspecified on exit.
*
* LDH (input) INTEGER
* The leading dimension of the array H. LDH >= max(1,N).
*
* WR (output) DOUBLE PRECISION array, dimension (N)
* WI (output) DOUBLE PRECISION array, dimension (N)
* The real and imaginary parts, respectively, of the computed
* eigenvalues ILO to IHI are stored in the corresponding
* elements of WR and WI. If two eigenvalues are computed as a
* complex conjugate pair, they are stored in consecutive
* elements of WR and WI, say the i-th and (i+1)th, with
* WI(i) > 0 and WI(i+1) < 0. If WANTT is .TRUE., the
* eigenvalues are stored in the same order as on the diagonal
* of the Schur form returned in H, with WR(i) = H(i,i), and, if
* H(i:i+1,i:i+1) is a 2-by-2 diagonal block,
* WI(i) = sqrt(H(i+1,i)*H(i,i+1)) and WI(i+1) = -WI(i).
*
* ILOZ (input) INTEGER
* IHIZ (input) INTEGER
* Specify the rows of Z to which transformations must be
* applied if WANTZ is .TRUE..
* 1 <= ILOZ <= ILO; IHI <= IHIZ <= N.
*
* Z (input/output) DOUBLE PRECISION array, dimension (LDZ,N)
* If WANTZ is .TRUE., on entry Z must contain the current
* matrix Z of transformations accumulated by DHSEQR, and on
* exit Z has been updated; transformations are applied only to
* the submatrix Z(ILOZ:IHIZ,ILO:IHI).
* If WANTZ is .FALSE., Z is not referenced.
*
* LDZ (input) INTEGER
* The leading dimension of the array Z. LDZ >= max(1,N).
*
* INFO (output) INTEGER
* = 0: successful exit
* > 0: DLAHQR failed to compute all the eigenvalues ILO to IHI
* in a total of 30*(IHI-ILO+1) iterations; if INFO = i,
* elements i+1:ihi of WR and WI contain those eigenvalues
* which have been successfully computed.
*
* =====================================================================
*
* .. Parameters ..
DOUBLE PRECISION ZERO, ONE
PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 )
DOUBLE PRECISION DAT1, DAT2
PARAMETER ( DAT1 = 0.75D+0, DAT2 = -0.4375D+0 )
* ..
* .. Local Scalars ..
INTEGER I, I1, I2, ITN, ITS, J, K, L, M, NH, NR, NZ
DOUBLE PRECISION CS, H00, H10, H11, H12, H21, H22, H33, H33S,
$ H43H34, H44, H44S, OVFL, S, SMLNUM, SN, SUM,
$ T1, T2, T3, TST1, ULP, UNFL, V1, V2, V3
* ..
* .. Local Arrays ..
DOUBLE PRECISION V( 3 ), WORK( 1 )
* ..
* .. External Functions ..
DOUBLE PRECISION DLAMCH, DLANHS
EXTERNAL DLAMCH, DLANHS
* ..
* .. External Subroutines ..
EXTERNAL DCOPY, DLABAD, DLANV2, DLARFG, DROT
* ..
* .. Intrinsic Functions ..
INTRINSIC ABS, MAX, MIN
* ..
* .. Executable Statements ..
*
INFO = 0
*
* Quick return if possible
*
IF( N.EQ.0 )
$ RETURN
IF( ILO.EQ.IHI ) THEN
WR( ILO ) = H( ILO, ILO )
WI( ILO ) = ZERO
RETURN
END IF
*
NH = IHI - ILO + 1
NZ = IHIZ - ILOZ + 1
*
* Set machine-dependent constants for the stopping criterion.
* If norm(H) <= sqrt(OVFL), overflow should not occur.
*
UNFL = DLAMCH( 'Safe minimum' )
OVFL = ONE / UNFL
CALL DLABAD( UNFL, OVFL )
ULP = DLAMCH( 'Precision' )
SMLNUM = UNFL*( NH / ULP )
*
* I1 and I2 are the indices of the first row and last column of H
* to which transformations must be applied. If eigenvalues only are
* being computed, I1 and I2 are set inside the main loop.
*
IF( WANTT ) THEN
I1 = 1
I2 = N
END IF
*
* ITN is the total number of QR iterations allowed.
*
ITN = 30*NH
*
* The main loop begins here. I is the loop index and decreases from
* IHI to ILO in steps of 1 or 2. Each iteration of the loop works
* with the active submatrix in rows and columns L to I.
* Eigenvalues I+1 to IHI have already converged. Either L = ILO or
* H(L,L-1) is negligible so that the matrix splits.
*
I = IHI
10 CONTINUE
L = ILO
IF( I.LT.ILO )
$ GO TO 150
*
* Perform QR iterations on rows and columns ILO to I until a
* submatrix of order 1 or 2 splits off at the bottom because a
* subdiagonal element has become negligible.
*
DO 130 ITS = 0, ITN
*
* Look for a single small subdiagonal element.
*
DO 20 K = I, L + 1, -1
TST1 = ABS( H( K-1, K-1 ) ) + ABS( H( K, K ) )
IF( TST1.EQ.ZERO )
$ TST1 = DLANHS( '1', I-L+1, H( L, L ), LDH, WORK )
IF( ABS( H( K, K-1 ) ).LE.MAX( ULP*TST1, SMLNUM ) )
$ GO TO 30
20 CONTINUE
30 CONTINUE
L = K
IF( L.GT.ILO ) THEN
*
* H(L,L-1) is negligible
*
H( L, L-1 ) = ZERO
END IF
*
* Exit from loop if a submatrix of order 1 or 2 has split off.
*
IF( L.GE.I-1 )
$ GO TO 140
*
* Now the active submatrix is in rows and columns L to I. If
* eigenvalues only are being computed, only the active submatrix
* need be transformed.
*
IF( .NOT.WANTT ) THEN
I1 = L
I2 = I
END IF
*
IF( ITS.EQ.10 .OR. ITS.EQ.20 ) THEN
*
* Exceptional shift.
*
S = ABS( H( I, I-1 ) ) + ABS( H( I-1, I-2 ) )
H44 = DAT1*S
H33 = H44
H43H34 = DAT2*S*S
ELSE
*
* Prepare to use Wilkinson's double shift
*
H44 = H( I, I )
H33 = H( I-1, I-1 )
H43H34 = H( I, I-1 )*H( I-1, I )
END IF
*
* Look for two consecutive small subdiagonal elements.
*
DO 40 M = I - 2, L, -1
*
* Determine the effect of starting the double-shift QR
* iteration at row M, and see if this would make H(M,M-1)
* negligible.
*
H11 = H( M, M )
H22 = H( M+1, M+1 )
H21 = H( M+1, M )
H12 = H( M, M+1 )
H44S = H44 - H11
H33S = H33 - H11
V1 = ( H33S*H44S-H43H34 ) / H21 + H12
V2 = H22 - H11 - H33S - H44S
V3 = H( M+2, M+1 )
S = ABS( V1 ) + ABS( V2 ) + ABS( V3 )
V1 = V1 / S
V2 = V2 / S
V3 = V3 / S
V( 1 ) = V1
V( 2 ) = V2
V( 3 ) = V3
IF( M.EQ.L )
$ GO TO 50
H00 = H( M-1, M-1 )
H10 = H( M, M-1 )
TST1 = ABS( V1 )*( ABS( H00 )+ABS( H11 )+ABS( H22 ) )
IF( ABS( H10 )*( ABS( V2 )+ABS( V3 ) ).LE.ULP*TST1 )
$ GO TO 50
40 CONTINUE
50 CONTINUE
*
* Double-shift QR step
*
DO 120 K = M, I - 1
*
* The first iteration of this loop determines a reflection G
* from the vector V and applies it from left and right to H,
* thus creating a nonzero bulge below the subdiagonal.
*
* Each subsequent iteration determines a reflection G to
* restore the Hessenberg form in the (K-1)th column, and thus
* chases the bulge one step toward the bottom of the active
* submatrix. NR is the order of G.
*
NR = MIN( 3, I-K+1 )
IF( K.GT.M )
$ CALL DCOPY( NR, H( K, K-1 ), 1, V, 1 )
CALL DLARFG( NR, V( 1 ), V( 2 ), 1, T1 )
IF( K.GT.M ) THEN
H( K, K-1 ) = V( 1 )
H( K+1, K-1 ) = ZERO
IF( K.LT.I-1 )
$ H( K+2, K-1 ) = ZERO
ELSE IF( M.GT.L ) THEN
H( K, K-1 ) = -H( K, K-1 )
END IF
V2 = V( 2 )
T2 = T1*V2
IF( NR.EQ.3 ) THEN
V3 = V( 3 )
T3 = T1*V3
*
* Apply G from the left to transform the rows of the matrix
* in columns K to I2.
*
DO 60 J = K, I2
SUM = H( K, J ) + V2*H( K+1, J ) + V3*H( K+2, J )
H( K, J ) = H( K, J ) - SUM*T1
H( K+1, J ) = H( K+1, J ) - SUM*T2
H( K+2, J ) = H( K+2, J ) - SUM*T3
60 CONTINUE
*
* Apply G from the right to transform the columns of the
* matrix in rows I1 to min(K+3,I).
*
DO 70 J = I1, MIN( K+3, I )
SUM = H( J, K ) + V2*H( J, K+1 ) + V3*H( J, K+2 )
H( J, K ) = H( J, K ) - SUM*T1
H( J, K+1 ) = H( J, K+1 ) - SUM*T2
H( J, K+2 ) = H( J, K+2 ) - SUM*T3
70 CONTINUE
*
IF( WANTZ ) THEN
*
* Accumulate transformations in the matrix Z
*
DO 80 J = ILOZ, IHIZ
SUM = Z( J, K ) + V2*Z( J, K+1 ) + V3*Z( J, K+2 )
Z( J, K ) = Z( J, K ) - SUM*T1
Z( J, K+1 ) = Z( J, K+1 ) - SUM*T2
Z( J, K+2 ) = Z( J, K+2 ) - SUM*T3
80 CONTINUE
END IF
ELSE IF( NR.EQ.2 ) THEN
*
* Apply G from the left to transform the rows of the matrix
* in columns K to I2.
*
DO 90 J = K, I2
SUM = H( K, J ) + V2*H( K+1, J )
H( K, J ) = H( K, J ) - SUM*T1
H( K+1, J ) = H( K+1, J ) - SUM*T2
90 CONTINUE
*
* Apply G from the right to transform the columns of the
* matrix in rows I1 to min(K+3,I).
*
DO 100 J = I1, I
SUM = H( J, K ) + V2*H( J, K+1 )
H( J, K ) = H( J, K ) - SUM*T1
H( J, K+1 ) = H( J, K+1 ) - SUM*T2
100 CONTINUE
*
IF( WANTZ ) THEN
*
* Accumulate transformations in the matrix Z
*
DO 110 J = ILOZ, IHIZ
SUM = Z( J, K ) + V2*Z( J, K+1 )
Z( J, K ) = Z( J, K ) - SUM*T1
Z( J, K+1 ) = Z( J, K+1 ) - SUM*T2
110 CONTINUE
END IF
END IF
120 CONTINUE
*
130 CONTINUE
*
* Failure to converge in remaining number of iterations
*
INFO = I
RETURN
*
140 CONTINUE
*
IF( L.EQ.I ) THEN
*
* H(I,I-1) is negligible: one eigenvalue has converged.
*
WR( I ) = H( I, I )
WI( I ) = ZERO
ELSE IF( L.EQ.I-1 ) THEN
*
* H(I-1,I-2) is negligible: a pair of eigenvalues have converged.
*
* Transform the 2-by-2 submatrix to standard Schur form,
* and compute and store the eigenvalues.
*
CALL DLANV2( H( I-1, I-1 ), H( I-1, I ), H( I, I-1 ),
$ H( I, I ), WR( I-1 ), WI( I-1 ), WR( I ), WI( I ),
$ CS, SN )
*
IF( WANTT ) THEN
*
* Apply the transformation to the rest of H.
*
IF( I2.GT.I )
$ CALL DROT( I2-I, H( I-1, I+1 ), LDH, H( I, I+1 ), LDH,
$ CS, SN )
CALL DROT( I-I1-1, H( I1, I-1 ), 1, H( I1, I ), 1, CS, SN )
END IF
IF( WANTZ ) THEN
*
* Apply the transformation to Z.
*
CALL DROT( NZ, Z( ILOZ, I-1 ), 1, Z( ILOZ, I ), 1, CS, SN )
END IF
END IF
*
* Decrement number of remaining iterations, and return to start of
* the main loop with new value of I.
*
ITN = ITN - ITS
I = L - 1
GO TO 10
*
150 CONTINUE
RETURN
*
* End of DLAHQR
*
END

410
arpack/ARPACK/LAPACK/slahqr.f Normal file
View File

@@ -0,0 +1,410 @@
SUBROUTINE SLAHQR( WANTT, WANTZ, N, ILO, IHI, H, LDH, WR, WI,
$ ILOZ, IHIZ, Z, LDZ, INFO )
*
* -- LAPACK auxiliary routine (version 2.0) --
* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
* Courant Institute, Argonne National Lab, and Rice University
* October 31, 1992
*
* .. Scalar Arguments ..
LOGICAL WANTT, WANTZ
INTEGER IHI, IHIZ, ILO, ILOZ, INFO, LDH, LDZ, N
* ..
* .. Array Arguments ..
REAL H( LDH, * ), WI( * ), WR( * ), Z( LDZ, * )
* ..
*
* Purpose
* =======
*
* SLAHQR is an auxiliary routine called by SHSEQR to update the
* eigenvalues and Schur decomposition already computed by SHSEQR, by
* dealing with the Hessenberg submatrix in rows and columns ILO to IHI.
*
* Arguments
* =========
*
* WANTT (input) LOGICAL
* = .TRUE. : the full Schur form T is required;
* = .FALSE.: only eigenvalues are required.
*
* WANTZ (input) LOGICAL
* = .TRUE. : the matrix of Schur vectors Z is required;
* = .FALSE.: Schur vectors are not required.
*
* N (input) INTEGER
* The order of the matrix H. N >= 0.
*
* ILO (input) INTEGER
* IHI (input) INTEGER
* It is assumed that H is already upper quasi-triangular in
* rows and columns IHI+1:N, and that H(ILO,ILO-1) = 0 (unless
* ILO = 1). SLAHQR works primarily with the Hessenberg
* submatrix in rows and columns ILO to IHI, but applies
* transformations to all of H if WANTT is .TRUE..
* 1 <= ILO <= max(1,IHI); IHI <= N.
*
* H (input/output) REAL array, dimension (LDH,N)
* On entry, the upper Hessenberg matrix H.
* On exit, if WANTT is .TRUE., H is upper quasi-triangular in
* rows and columns ILO:IHI, with any 2-by-2 diagonal blocks in
* standard form. If WANTT is .FALSE., the contents of H are
* unspecified on exit.
*
* LDH (input) INTEGER
* The leading dimension of the array H. LDH >= max(1,N).
*
* WR (output) REAL array, dimension (N)
* WI (output) REAL array, dimension (N)
* The real and imaginary parts, respectively, of the computed
* eigenvalues ILO to IHI are stored in the corresponding
* elements of WR and WI. If two eigenvalues are computed as a
* complex conjugate pair, they are stored in consecutive
* elements of WR and WI, say the i-th and (i+1)th, with
* WI(i) > 0 and WI(i+1) < 0. If WANTT is .TRUE., the
* eigenvalues are stored in the same order as on the diagonal
* of the Schur form returned in H, with WR(i) = H(i,i), and, if
* H(i:i+1,i:i+1) is a 2-by-2 diagonal block,
* WI(i) = sqrt(H(i+1,i)*H(i,i+1)) and WI(i+1) = -WI(i).
*
* ILOZ (input) INTEGER
* IHIZ (input) INTEGER
* Specify the rows of Z to which transformations must be
* applied if WANTZ is .TRUE..
* 1 <= ILOZ <= ILO; IHI <= IHIZ <= N.
*
* Z (input/output) REAL array, dimension (LDZ,N)
* If WANTZ is .TRUE., on entry Z must contain the current
* matrix Z of transformations accumulated by SHSEQR, and on
* exit Z has been updated; transformations are applied only to
* the submatrix Z(ILOZ:IHIZ,ILO:IHI).
* If WANTZ is .FALSE., Z is not referenced.
*
* LDZ (input) INTEGER
* The leading dimension of the array Z. LDZ >= max(1,N).
*
* INFO (output) INTEGER
* = 0: successful exit
* > 0: SLAHQR failed to compute all the eigenvalues ILO to IHI
* in a total of 30*(IHI-ILO+1) iterations; if INFO = i,
* elements i+1:ihi of WR and WI contain those eigenvalues
* which have been successfully computed.
*
* =====================================================================
*
* .. Parameters ..
REAL ZERO, ONE
PARAMETER ( ZERO = 0.0E+0, ONE = 1.0E+0 )
REAL DAT1, DAT2
PARAMETER ( DAT1 = 0.75E+0, DAT2 = -0.4375E+0 )
* ..
* .. Local Scalars ..
INTEGER I, I1, I2, ITN, ITS, J, K, L, M, NH, NR, NZ
REAL CS, H00, H10, H11, H12, H21, H22, H33, H33S,
$ H43H34, H44, H44S, OVFL, S, SMLNUM, SN, SUM,
$ T1, T2, T3, TST1, ULP, UNFL, V1, V2, V3
* ..
* .. Local Arrays ..
REAL V( 3 ), WORK( 1 )
* ..
* .. External Functions ..
REAL SLAMCH, SLANHS
EXTERNAL SLAMCH, SLANHS
* ..
* .. External Subroutines ..
EXTERNAL SCOPY, SLABAD, SLANV2, SLARFG, SROT
* ..
* .. Intrinsic Functions ..
INTRINSIC ABS, MAX, MIN
* ..
* .. Executable Statements ..
*
INFO = 0
*
* Quick return if possible
*
IF( N.EQ.0 )
$ RETURN
IF( ILO.EQ.IHI ) THEN
WR( ILO ) = H( ILO, ILO )
WI( ILO ) = ZERO
RETURN
END IF
*
NH = IHI - ILO + 1
NZ = IHIZ - ILOZ + 1
*
* Set machine-dependent constants for the stopping criterion.
* If norm(H) <= sqrt(OVFL), overflow should not occur.
*
UNFL = SLAMCH( 'Safe minimum' )
OVFL = ONE / UNFL
CALL SLABAD( UNFL, OVFL )
ULP = SLAMCH( 'Precision' )
SMLNUM = UNFL*( NH / ULP )
*
* I1 and I2 are the indices of the first row and last column of H
* to which transformations must be applied. If eigenvalues only are
* being computed, I1 and I2 are set inside the main loop.
*
IF( WANTT ) THEN
I1 = 1
I2 = N
END IF
*
* ITN is the total number of QR iterations allowed.
*
ITN = 30*NH
*
* The main loop begins here. I is the loop index and decreases from
* IHI to ILO in steps of 1 or 2. Each iteration of the loop works
* with the active submatrix in rows and columns L to I.
* Eigenvalues I+1 to IHI have already converged. Either L = ILO or
* H(L,L-1) is negligible so that the matrix splits.
*
I = IHI
10 CONTINUE
L = ILO
IF( I.LT.ILO )
$ GO TO 150
*
* Perform QR iterations on rows and columns ILO to I until a
* submatrix of order 1 or 2 splits off at the bottom because a
* subdiagonal element has become negligible.
*
DO 130 ITS = 0, ITN
*
* Look for a single small subdiagonal element.
*
DO 20 K = I, L + 1, -1
TST1 = ABS( H( K-1, K-1 ) ) + ABS( H( K, K ) )
IF( TST1.EQ.ZERO )
$ TST1 = SLANHS( '1', I-L+1, H( L, L ), LDH, WORK )
IF( ABS( H( K, K-1 ) ).LE.MAX( ULP*TST1, SMLNUM ) )
$ GO TO 30
20 CONTINUE
30 CONTINUE
L = K
IF( L.GT.ILO ) THEN
*
* H(L,L-1) is negligible
*
H( L, L-1 ) = ZERO
END IF
*
* Exit from loop if a submatrix of order 1 or 2 has split off.
*
IF( L.GE.I-1 )
$ GO TO 140
*
* Now the active submatrix is in rows and columns L to I. If
* eigenvalues only are being computed, only the active submatrix
* need be transformed.
*
IF( .NOT.WANTT ) THEN
I1 = L
I2 = I
END IF
*
IF( ITS.EQ.10 .OR. ITS.EQ.20 ) THEN
*
* Exceptional shift.
*
S = ABS( H( I, I-1 ) ) + ABS( H( I-1, I-2 ) )
H44 = DAT1*S
H33 = H44
H43H34 = DAT2*S*S
ELSE
*
* Prepare to use Wilkinson's double shift
*
H44 = H( I, I )
H33 = H( I-1, I-1 )
H43H34 = H( I, I-1 )*H( I-1, I )
END IF
*
* Look for two consecutive small subdiagonal elements.
*
DO 40 M = I - 2, L, -1
*
* Determine the effect of starting the double-shift QR
* iteration at row M, and see if this would make H(M,M-1)
* negligible.
*
H11 = H( M, M )
H22 = H( M+1, M+1 )
H21 = H( M+1, M )
H12 = H( M, M+1 )
H44S = H44 - H11
H33S = H33 - H11
V1 = ( H33S*H44S-H43H34 ) / H21 + H12
V2 = H22 - H11 - H33S - H44S
V3 = H( M+2, M+1 )
S = ABS( V1 ) + ABS( V2 ) + ABS( V3 )
V1 = V1 / S
V2 = V2 / S
V3 = V3 / S
V( 1 ) = V1
V( 2 ) = V2
V( 3 ) = V3
IF( M.EQ.L )
$ GO TO 50
H00 = H( M-1, M-1 )
H10 = H( M, M-1 )
TST1 = ABS( V1 )*( ABS( H00 )+ABS( H11 )+ABS( H22 ) )
IF( ABS( H10 )*( ABS( V2 )+ABS( V3 ) ).LE.ULP*TST1 )
$ GO TO 50
40 CONTINUE
50 CONTINUE
*
* Double-shift QR step
*
DO 120 K = M, I - 1
*
* The first iteration of this loop determines a reflection G
* from the vector V and applies it from left and right to H,
* thus creating a nonzero bulge below the subdiagonal.
*
* Each subsequent iteration determines a reflection G to
* restore the Hessenberg form in the (K-1)th column, and thus
* chases the bulge one step toward the bottom of the active
* submatrix. NR is the order of G.
*
NR = MIN( 3, I-K+1 )
IF( K.GT.M )
$ CALL SCOPY( NR, H( K, K-1 ), 1, V, 1 )
CALL SLARFG( NR, V( 1 ), V( 2 ), 1, T1 )
IF( K.GT.M ) THEN
H( K, K-1 ) = V( 1 )
H( K+1, K-1 ) = ZERO
IF( K.LT.I-1 )
$ H( K+2, K-1 ) = ZERO
ELSE IF( M.GT.L ) THEN
H( K, K-1 ) = -H( K, K-1 )
END IF
V2 = V( 2 )
T2 = T1*V2
IF( NR.EQ.3 ) THEN
V3 = V( 3 )
T3 = T1*V3
*
* Apply G from the left to transform the rows of the matrix
* in columns K to I2.
*
DO 60 J = K, I2
SUM = H( K, J ) + V2*H( K+1, J ) + V3*H( K+2, J )
H( K, J ) = H( K, J ) - SUM*T1
H( K+1, J ) = H( K+1, J ) - SUM*T2
H( K+2, J ) = H( K+2, J ) - SUM*T3
60 CONTINUE
*
* Apply G from the right to transform the columns of the
* matrix in rows I1 to min(K+3,I).
*
DO 70 J = I1, MIN( K+3, I )
SUM = H( J, K ) + V2*H( J, K+1 ) + V3*H( J, K+2 )
H( J, K ) = H( J, K ) - SUM*T1
H( J, K+1 ) = H( J, K+1 ) - SUM*T2
H( J, K+2 ) = H( J, K+2 ) - SUM*T3
70 CONTINUE
*
IF( WANTZ ) THEN
*
* Accumulate transformations in the matrix Z
*
DO 80 J = ILOZ, IHIZ
SUM = Z( J, K ) + V2*Z( J, K+1 ) + V3*Z( J, K+2 )
Z( J, K ) = Z( J, K ) - SUM*T1
Z( J, K+1 ) = Z( J, K+1 ) - SUM*T2
Z( J, K+2 ) = Z( J, K+2 ) - SUM*T3
80 CONTINUE
END IF
ELSE IF( NR.EQ.2 ) THEN
*
* Apply G from the left to transform the rows of the matrix
* in columns K to I2.
*
DO 90 J = K, I2
SUM = H( K, J ) + V2*H( K+1, J )
H( K, J ) = H( K, J ) - SUM*T1
H( K+1, J ) = H( K+1, J ) - SUM*T2
90 CONTINUE
*
* Apply G from the right to transform the columns of the
* matrix in rows I1 to min(K+3,I).
*
DO 100 J = I1, I
SUM = H( J, K ) + V2*H( J, K+1 )
H( J, K ) = H( J, K ) - SUM*T1
H( J, K+1 ) = H( J, K+1 ) - SUM*T2
100 CONTINUE
*
IF( WANTZ ) THEN
*
* Accumulate transformations in the matrix Z
*
DO 110 J = ILOZ, IHIZ
SUM = Z( J, K ) + V2*Z( J, K+1 )
Z( J, K ) = Z( J, K ) - SUM*T1
Z( J, K+1 ) = Z( J, K+1 ) - SUM*T2
110 CONTINUE
END IF
END IF
120 CONTINUE
*
130 CONTINUE
*
* Failure to converge in remaining number of iterations
*
INFO = I
RETURN
*
140 CONTINUE
*
IF( L.EQ.I ) THEN
*
* H(I,I-1) is negligible: one eigenvalue has converged.
*
WR( I ) = H( I, I )
WI( I ) = ZERO
ELSE IF( L.EQ.I-1 ) THEN
*
* H(I-1,I-2) is negligible: a pair of eigenvalues have converged.
*
* Transform the 2-by-2 submatrix to standard Schur form,
* and compute and store the eigenvalues.
*
CALL SLANV2( H( I-1, I-1 ), H( I-1, I ), H( I, I-1 ),
$ H( I, I ), WR( I-1 ), WI( I-1 ), WR( I ), WI( I ),
$ CS, SN )
*
IF( WANTT ) THEN
*
* Apply the transformation to the rest of H.
*
IF( I2.GT.I )
$ CALL SROT( I2-I, H( I-1, I+1 ), LDH, H( I, I+1 ), LDH,
$ CS, SN )
CALL SROT( I-I1-1, H( I1, I-1 ), 1, H( I1, I ), 1, CS, SN )
END IF
IF( WANTZ ) THEN
*
* Apply the transformation to Z.
*
CALL SROT( NZ, Z( ILOZ, I-1 ), 1, Z( ILOZ, I ), 1, CS, SN )
END IF
END IF
*
* Decrement number of remaining iterations, and return to start of
* the main loop with new value of I.
*
ITN = ITN - ITS
I = L - 1
GO TO 10
*
150 CONTINUE
RETURN
*
* End of SLAHQR
*
END

385
arpack/ARPACK/LAPACK/zlahqr.f Normal file
View File

@@ -0,0 +1,385 @@
SUBROUTINE ZLAHQR( WANTT, WANTZ, N, ILO, IHI, H, LDH, W, ILOZ,
$ IHIZ, Z, LDZ, INFO )
*
* -- LAPACK auxiliary routine (version 2.0) --
* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
* Courant Institute, Argonne National Lab, and Rice University
* September 30, 1994
*
* .. Scalar Arguments ..
LOGICAL WANTT, WANTZ
INTEGER IHI, IHIZ, ILO, ILOZ, INFO, LDH, LDZ, N
* ..
* .. Array Arguments ..
COMPLEX*16 H( LDH, * ), W( * ), Z( LDZ, * )
* ..
*
* Purpose
* =======
*
* ZLAHQR is an auxiliary routine called by CHSEQR to update the
* eigenvalues and Schur decomposition already computed by CHSEQR, by
* dealing with the Hessenberg submatrix in rows and columns ILO to IHI.
*
* Arguments
* =========
*
* WANTT (input) LOGICAL
* = .TRUE. : the full Schur form T is required;
* = .FALSE.: only eigenvalues are required.
*
* WANTZ (input) LOGICAL
* = .TRUE. : the matrix of Schur vectors Z is required;
* = .FALSE.: Schur vectors are not required.
*
* N (input) INTEGER
* The order of the matrix H. N >= 0.
*
* ILO (input) INTEGER
* IHI (input) INTEGER
* It is assumed that H is already upper triangular in rows and
* columns IHI+1:N, and that H(ILO,ILO-1) = 0 (unless ILO = 1).
* ZLAHQR works primarily with the Hessenberg submatrix in rows
* and columns ILO to IHI, but applies transformations to all of
* H if WANTT is .TRUE..
* 1 <= ILO <= max(1,IHI); IHI <= N.
*
* H (input/output) COMPLEX*16 array, dimension (LDH,N)
* On entry, the upper Hessenberg matrix H.
* On exit, if WANTT is .TRUE., H is upper triangular in rows
* and columns ILO:IHI, with any 2-by-2 diagonal blocks in
* standard form. If WANTT is .FALSE., the contents of H are
* unspecified on exit.
*
* LDH (input) INTEGER
* The leading dimension of the array H. LDH >= max(1,N).
*
* W (output) COMPLEX*16 array, dimension (N)
* The computed eigenvalues ILO to IHI are stored in the
* corresponding elements of W. If WANTT is .TRUE., the
* eigenvalues are stored in the same order as on the diagonal
* of the Schur form returned in H, with W(i) = H(i,i).
*
* ILOZ (input) INTEGER
* IHIZ (input) INTEGER
* Specify the rows of Z to which transformations must be
* applied if WANTZ is .TRUE..
* 1 <= ILOZ <= ILO; IHI <= IHIZ <= N.
*
* Z (input/output) COMPLEX*16 array, dimension (LDZ,N)
* If WANTZ is .TRUE., on entry Z must contain the current
* matrix Z of transformations accumulated by CHSEQR, and on
* exit Z has been updated; transformations are applied only to
* the submatrix Z(ILOZ:IHIZ,ILO:IHI).
* If WANTZ is .FALSE., Z is not referenced.
*
* LDZ (input) INTEGER
* The leading dimension of the array Z. LDZ >= max(1,N).
*
* INFO (output) INTEGER
* = 0: successful exit
* > 0: if INFO = i, ZLAHQR failed to compute all the
* eigenvalues ILO to IHI in a total of 30*(IHI-ILO+1)
* iterations; elements i+1:ihi of W contain those
* eigenvalues which have been successfully computed.
*
* =====================================================================
*
* .. Parameters ..
COMPLEX*16 ZERO, ONE
PARAMETER ( ZERO = ( 0.0D+0, 0.0D+0 ),
$ ONE = ( 1.0D+0, 0.0D+0 ) )
DOUBLE PRECISION RZERO, HALF
PARAMETER ( RZERO = 0.0D+0, HALF = 0.5D+0 )
* ..
* .. Local Scalars ..
INTEGER I, I1, I2, ITN, ITS, J, K, L, M, NH, NZ
DOUBLE PRECISION H10, H21, RTEMP, S, SMLNUM, T2, TST1, ULP
COMPLEX*16 CDUM, H11, H11S, H22, SUM, T, T1, TEMP, U, V2,
$ X, Y
* ..
* .. Local Arrays ..
DOUBLE PRECISION RWORK( 1 )
COMPLEX*16 V( 2 )
* ..
* .. External Functions ..
DOUBLE PRECISION ZLANHS, DLAMCH
COMPLEX*16 ZLADIV
EXTERNAL ZLANHS, DLAMCH, ZLADIV
* ..
* .. External Subroutines ..
EXTERNAL ZCOPY, ZLARFG, ZSCAL
* ..
* .. Intrinsic Functions ..
INTRINSIC ABS, DIMAG, DCONJG, MAX, MIN, DBLE, SQRT
* ..
* .. Statement Functions ..
DOUBLE PRECISION CABS1
* ..
* .. Statement Function definitions ..
CABS1( CDUM ) = ABS( DBLE( CDUM ) ) + ABS( DIMAG( CDUM ) )
* ..
* .. Executable Statements ..
*
INFO = 0
*
* Quick return if possible
*
IF( N.EQ.0 )
$ RETURN
IF( ILO.EQ.IHI ) THEN
W( ILO ) = H( ILO, ILO )
RETURN
END IF
*
NH = IHI - ILO + 1
NZ = IHIZ - ILOZ + 1
*
* Set machine-dependent constants for the stopping criterion.
* If norm(H) <= sqrt(OVFL), overflow should not occur.
*
ULP = DLAMCH( 'Precision' )
SMLNUM = DLAMCH( 'Safe minimum' ) / ULP
*
* I1 and I2 are the indices of the first row and last column of H
* to which transformations must be applied. If eigenvalues only are
* being computed, I1 and I2 are set inside the main loop.
*
IF( WANTT ) THEN
I1 = 1
I2 = N
END IF
*
* ITN is the total number of QR iterations allowed.
*
ITN = 30*NH
*
* The main loop begins here. I is the loop index and decreases from
* IHI to ILO in steps of 1. Each iteration of the loop works
* with the active submatrix in rows and columns L to I.
* Eigenvalues I+1 to IHI have already converged. Either L = ILO, or
* H(L,L-1) is negligible so that the matrix splits.
*
I = IHI
10 CONTINUE
IF( I.LT.ILO )
$ GO TO 130
*
* Perform QR iterations on rows and columns ILO to I until a
* submatrix of order 1 splits off at the bottom because a
* subdiagonal element has become negligible.
*
L = ILO
DO 110 ITS = 0, ITN
*
* Look for a single small subdiagonal element.
*
DO 20 K = I, L + 1, -1
TST1 = CABS1( H( K-1, K-1 ) ) + CABS1( H( K, K ) )
IF( TST1.EQ.RZERO )
$ TST1 = ZLANHS( '1', I-L+1, H( L, L ), LDH, RWORK )
IF( ABS( DBLE( H( K, K-1 ) ) ).LE.MAX( ULP*TST1, SMLNUM ) )
$ GO TO 30
20 CONTINUE
30 CONTINUE
L = K
IF( L.GT.ILO ) THEN
*
* H(L,L-1) is negligible
*
H( L, L-1 ) = ZERO
END IF
*
* Exit from loop if a submatrix of order 1 has split off.
*
IF( L.GE.I )
$ GO TO 120
*
* Now the active submatrix is in rows and columns L to I. If
* eigenvalues only are being computed, only the active submatrix
* need be transformed.
*
IF( .NOT.WANTT ) THEN
I1 = L
I2 = I
END IF
*
IF( ITS.EQ.10 .OR. ITS.EQ.20 ) THEN
*
* Exceptional shift.
*
T = ABS( DBLE( H( I, I-1 ) ) ) +
$ ABS( DBLE( H( I-1, I-2 ) ) )
ELSE
*
* Wilkinson's shift.
*
T = H( I, I )
U = H( I-1, I )*DBLE( H( I, I-1 ) )
IF( U.NE.ZERO ) THEN
X = HALF*( H( I-1, I-1 )-T )
Y = SQRT( X*X+U )
IF( DBLE( X )*DBLE( Y )+DIMAG( X )*DIMAG( Y ).LT.RZERO )
$ Y = -Y
T = T - ZLADIV( U, ( X+Y ) )
END IF
END IF
*
* Look for two consecutive small subdiagonal elements.
*
DO 40 M = I - 1, L + 1, -1
*
* Determine the effect of starting the single-shift QR
* iteration at row M, and see if this would make H(M,M-1)
* negligible.
*
H11 = H( M, M )
H22 = H( M+1, M+1 )
H11S = H11 - T
H21 = H( M+1, M )
S = CABS1( H11S ) + ABS( H21 )
H11S = H11S / S
H21 = H21 / S
V( 1 ) = H11S
V( 2 ) = H21
H10 = H( M, M-1 )
TST1 = CABS1( H11S )*( CABS1( H11 )+CABS1( H22 ) )
IF( ABS( H10*H21 ).LE.ULP*TST1 )
$ GO TO 50
40 CONTINUE
H11 = H( L, L )
H22 = H( L+1, L+1 )
H11S = H11 - T
H21 = H( L+1, L )
S = CABS1( H11S ) + ABS( H21 )
H11S = H11S / S
H21 = H21 / S
V( 1 ) = H11S
V( 2 ) = H21
50 CONTINUE
*
* Single-shift QR step
*
DO 100 K = M, I - 1
*
* The first iteration of this loop determines a reflection G
* from the vector V and applies it from left and right to H,
* thus creating a nonzero bulge below the subdiagonal.
*
* Each subsequent iteration determines a reflection G to
* restore the Hessenberg form in the (K-1)th column, and thus
* chases the bulge one step toward the bottom of the active
* submatrix.
*
* V(2) is always real before the call to ZLARFG, and hence
* after the call T2 ( = T1*V(2) ) is also real.
*
IF( K.GT.M )
$ CALL ZCOPY( 2, H( K, K-1 ), 1, V, 1 )
CALL ZLARFG( 2, V( 1 ), V( 2 ), 1, T1 )
IF( K.GT.M ) THEN
H( K, K-1 ) = V( 1 )
H( K+1, K-1 ) = ZERO
END IF
V2 = V( 2 )
T2 = DBLE( T1*V2 )
*
* Apply G from the left to transform the rows of the matrix
* in columns K to I2.
*
DO 60 J = K, I2
SUM = DCONJG( T1 )*H( K, J ) + T2*H( K+1, J )
H( K, J ) = H( K, J ) - SUM
H( K+1, J ) = H( K+1, J ) - SUM*V2
60 CONTINUE
*
* Apply G from the right to transform the columns of the
* matrix in rows I1 to min(K+2,I).
*
DO 70 J = I1, MIN( K+2, I )
SUM = T1*H( J, K ) + T2*H( J, K+1 )
H( J, K ) = H( J, K ) - SUM
H( J, K+1 ) = H( J, K+1 ) - SUM*DCONJG( V2 )
70 CONTINUE
*
IF( WANTZ ) THEN
*
* Accumulate transformations in the matrix Z
*
DO 80 J = ILOZ, IHIZ
SUM = T1*Z( J, K ) + T2*Z( J, K+1 )
Z( J, K ) = Z( J, K ) - SUM
Z( J, K+1 ) = Z( J, K+1 ) - SUM*DCONJG( V2 )
80 CONTINUE
END IF
*
IF( K.EQ.M .AND. M.GT.L ) THEN
*
* If the QR step was started at row M > L because two
* consecutive small subdiagonals were found, then extra
* scaling must be performed to ensure that H(M,M-1) remains
* real.
*
TEMP = ONE - T1
TEMP = TEMP / ABS( TEMP )
H( M+1, M ) = H( M+1, M )*DCONJG( TEMP )
IF( M+2.LE.I )
$ H( M+2, M+1 ) = H( M+2, M+1 )*TEMP
DO 90 J = M, I
IF( J.NE.M+1 ) THEN
IF( I2.GT.J )
$ CALL ZSCAL( I2-J, TEMP, H( J, J+1 ), LDH )
CALL ZSCAL( J-I1, DCONJG( TEMP ), H( I1, J ), 1 )
IF( WANTZ ) THEN
CALL ZSCAL( NZ, DCONJG( TEMP ),
$ Z( ILOZ, J ), 1 )
END IF
END IF
90 CONTINUE
END IF
100 CONTINUE
*
* Ensure that H(I,I-1) is real.
*
TEMP = H( I, I-1 )
IF( DIMAG( TEMP ).NE.RZERO ) THEN
RTEMP = ABS( TEMP )
H( I, I-1 ) = RTEMP
TEMP = TEMP / RTEMP
IF( I2.GT.I )
$ CALL ZSCAL( I2-I, DCONJG( TEMP ), H( I, I+1 ), LDH )
CALL ZSCAL( I-I1, TEMP, H( I1, I ), 1 )
IF( WANTZ ) THEN
CALL ZSCAL( NZ, TEMP, Z( ILOZ, I ), 1 )
END IF
END IF
*
110 CONTINUE
*
* Failure to converge in remaining number of iterations
*
INFO = I
RETURN
*
120 CONTINUE
*
* H(I,I-1) is negligible: one eigenvalue has converged.
*
W( I ) = H( I, I )
*
* Decrement number of remaining iterations, and return to start of
* the main loop with new value of I.
*
ITN = ITN - ITS
I = L - 1
GO TO 10
*
130 CONTINUE
RETURN
*
* End of ZLAHQR
*
END

111
arpack/ARPACK/README Normal file
View File

@@ -0,0 +1,111 @@
1. You have successfully unbundled ARPACK and are now in the ARPACK
directory that was created for you.
2. Recent bug fixes are included in patch.tar.gz and ppatch.tar.gz
(only needed if you are using PARPACK also.) If you have not
retrieved these files, please do so and place them in the
directory right above the current directory. (They should
be in the same directory where arpack96.tar reside).
Use uncompress or gunzip to unzip the tar files, and use 'tar -xvf '
to unbundle these patches. The source codes in these patches will
overwrite those contained in arpack96.tar and parpack96.tar.
3. Upon executing the 'ls | more ' command you should see
BLAS
DOCUMENTS
EXAMPLES
LAPACK
README
SRC
UTIL
Makefile
ARmake.inc
ARMAKES
The following entries are directories:
ARMAKES, BLAS, DOCUMENTS, EXAMPLES, LAPACK, SRC, UTIL
The directory SRC contains the top level routines including
the highest level reverse communication interface routines
ssaupd, dsaupd - symmetric single and double precision
snaupd, dnaupd - non-symmetric single and double precision
cnaupd, cnaupd - complex non-symmetric single and double precision
The headers of these routines contain full documentation of calling
sequence and usage. Additional information is in the DOCUMENTS directory.
4. Example driver programs that illustrate all the computational modes,
data types and precisions may be found in the EXAMPLES directory.
Upon executing the 'ls EXAMPLES | more ' command you should see
BAND
COMPLEX
NONSYM
README
SIMPLE
SVD
SYM
Example programs for banded, complex, nonsymmetric, symmetric,
and singular value decomposition may be found in the directories
BAND, COMPLEX, NONSYM, SYM, SVD respectively. Look at the README
file for further information. To get started, get into the SIMPLE
directory to see example programs that illustrate the use of ARPACK in
the simplest modes of operation for the most commonly posed
standard eigenvalue problems.
The following instructions explain how to make the ARPACK library.
5. Before you can compile anything, you must first edit and correct the file
ARmake.inc. Sample ARmake.inc's can be found in the ARMAKES directory.
Edit "ARmake.inc" and change the definition "home" to the root of the
source tree (Top level of ARPACK directory)
The makefile is set up to build a self-contained library which includes
the needed BLAS 1/2/3 and LAPACK routines. If you already have the
BLAS and LAPACK libraries installed on your system you might want to
change the definition of DIRS as indicated in the ARmake.inc file.
*** NOTE *** Unless the LAPACK library on your system is version 2.0,
we strongly recommend that you install the LAPACK routines provided with
ARPACK. Note that the current LAPACK release is version 3.0; if you are
not sure which version of LAPACK is installed, pleaase compile and link
to the subset of LAPACK included with ARPACK.
6. You will also need to change the file "second.f" in the UTIL directory
to whatever is appropriate for timing on your system. The "second" routine
provided works on most workstations. If you are running on a Cray,
you can just edit the makefile in UTIL and take out the reference to
"second.o" to use the system second routine.
7. Do "make lib" in the current directory to build the standard library
"libarpack_$(PLAT).a"
8. Within DOCUMENTS directory there are three files
ex-sym.doc
ex-nonsym.doc and
ex-complex.doc
for templates on how to invoke the computational modes of ARPACK.
Also look in the README file for explanations concerning the
other documents.
Danny Sorensen at sorensen@caam.rice.edu
Richard Lehoucq at rblehou@sandia.gov
Chao Yang at cyang@lbl.gov
Kristi Maschhoff at kristyn@tera.com
If you have questions regarding using ARPACK, please send email
to arpack@caam.rice.edu.
Good luck and enjoy.

83
arpack/ARPACK/SRC/Makefile Normal file
View File

@@ -0,0 +1,83 @@
############################################################################
#
# Program: ARPACK
#
# Module: Makefile
#
# Purpose: Sources Makefile
#
# Creation date: February 22, 1996
#
# Modified: September 9, 1996
#
# Send bug reports, comments or suggestions to arpack.caam.rice.edu
#
############################################################################
#\SCCS Information: @(#)
# FILE: Makefile SID: 2.1 DATE OF SID: 9/9/96 RELEASE: 2
include ../ARmake.inc
############################################################################
# To create or add to the library, enter make followed by one or
# more of the precisions desired. Some examples:
# make single
# make single complex
# make single double complex complex16
# Alternatively, the command
# make
# without any arguments creates a library of all four precisions.
# The name of the library is defined by $(ARPACKLIB) in
# ../ARmake.inc and is created at the next higher directory level.
SOBJ = sgetv0.o slaqrb.o sstqrb.o ssortc.o ssortr.o sstatn.o sstats.o \
snaitr.o snapps.o snaup2.o snaupd.o snconv.o sneigh.o sngets.o \
ssaitr.o ssapps.o ssaup2.o ssaupd.o ssconv.o sseigt.o ssgets.o \
sneupd.o sseupd.o ssesrt.o
DOBJ = dgetv0.o dlaqrb.o dstqrb.o dsortc.o dsortr.o dstatn.o dstats.o \
dnaitr.o dnapps.o dnaup2.o dnaupd.o dnconv.o dneigh.o dngets.o \
dsaitr.o dsapps.o dsaup2.o dsaupd.o dsconv.o dseigt.o dsgets.o \
dneupd.o dseupd.o dsesrt.o
COBJ = cnaitr.o cnapps.o cnaup2.o cnaupd.o cneigh.o cneupd.o cngets.o \
cgetv0.o csortc.o cstatn.o
ZOBJ = znaitr.o znapps.o znaup2.o znaupd.o zneigh.o zneupd.o zngets.o \
zgetv0.o zsortc.o zstatn.o
.f.o:
$(FC) $(FFLAGS) -c $<
all: single double complex complex16
single: $(SOBJ)
$(AR) $(ARFLAGS) $(ARPACKLIB) $(SOBJ)
$(RANLIB) $(ARPACKLIB)
double: $(DOBJ)
$(AR) $(ARFLAGS) $(ARPACKLIB) $(DOBJ)
$(RANLIB) $(ARPACKLIB)
complex: $(COBJ)
$(AR) $(ARFLAGS) $(ARPACKLIB) $(COBJ)
$(RANLIB) $(ARPACKLIB)
complex16: $(ZOBJ)
$(AR) $(ARFLAGS) $(ARPACKLIB) $(ZOBJ)
$(RANLIB) $(ARPACKLIB)
#
sdrv:
ddrv:
cdrv:
zdrv:
#
# clean - remove all object files
#
clean:
rm -f *.o a.out core

414
arpack/ARPACK/SRC/cgetv0.f Normal file
View File

@@ -0,0 +1,414 @@
c\BeginDoc
c
c\Name: cgetv0
c
c\Description:
c Generate a random initial residual vector for the Arnoldi process.
c Force the residual vector to be in the range of the operator OP.
c
c\Usage:
c call cgetv0
c ( IDO, BMAT, ITRY, INITV, N, J, V, LDV, RESID, RNORM,
c IPNTR, WORKD, IERR )
c
c\Arguments
c IDO Integer. (INPUT/OUTPUT)
c Reverse communication flag. IDO must be zero on the first
c call to cgetv0.
c -------------------------------------------------------------
c IDO = 0: first call to the reverse communication interface
c IDO = -1: compute Y = OP * X where
c IPNTR(1) is the pointer into WORKD for X,
c IPNTR(2) is the pointer into WORKD for Y.
c This is for the initialization phase to force the
c starting vector into the range of OP.
c IDO = 2: compute Y = B * X where
c IPNTR(1) is the pointer into WORKD for X,
c IPNTR(2) is the pointer into WORKD for Y.
c IDO = 99: done
c -------------------------------------------------------------
c
c BMAT Character*1. (INPUT)
c BMAT specifies the type of the matrix B in the (generalized)
c eigenvalue problem A*x = lambda*B*x.
c B = 'I' -> standard eigenvalue problem A*x = lambda*x
c B = 'G' -> generalized eigenvalue problem A*x = lambda*B*x
c
c ITRY Integer. (INPUT)
c ITRY counts the number of times that cgetv0 is called.
c It should be set to 1 on the initial call to cgetv0.
c
c INITV Logical variable. (INPUT)
c .TRUE. => the initial residual vector is given in RESID.
c .FALSE. => generate a random initial residual vector.
c
c N Integer. (INPUT)
c Dimension of the problem.
c
c J Integer. (INPUT)
c Index of the residual vector to be generated, with respect to
c the Arnoldi process. J > 1 in case of a "restart".
c
c V Complex N by J array. (INPUT)
c The first J-1 columns of V contain the current Arnoldi basis
c if this is a "restart".
c
c LDV Integer. (INPUT)
c Leading dimension of V exactly as declared in the calling
c program.
c
c RESID Complex array of length N. (INPUT/OUTPUT)
c Initial residual vector to be generated. If RESID is
c provided, force RESID into the range of the operator OP.
c
c RNORM Real scalar. (OUTPUT)
c B-norm of the generated residual.
c
c IPNTR Integer array of length 3. (OUTPUT)
c
c WORKD Complex work array of length 2*N. (REVERSE COMMUNICATION).
c On exit, WORK(1:N) = B*RESID to be used in SSAITR.
c
c IERR Integer. (OUTPUT)
c = 0: Normal exit.
c = -1: Cannot generate a nontrivial restarted residual vector
c in the range of the operator OP.
c
c\EndDoc
c
c-----------------------------------------------------------------------
c
c\BeginLib
c
c\Local variables:
c xxxxxx Complex
c
c\References:
c 1. D.C. Sorensen, "Implicit Application of Polynomial Filters in
c a k-Step Arnoldi Method", SIAM J. Matr. Anal. Apps., 13 (1992),
c pp 357-385.
c
c\Routines called:
c second ARPACK utility routine for timing.
c cvout ARPACK utility routine that prints vectors.
c clarnv LAPACK routine for generating a random vector.
c cgemv Level 2 BLAS routine for matrix vector multiplication.
c ccopy Level 1 BLAS that copies one vector to another.
c cdotc Level 1 BLAS that computes the scalar product of two vectors.
c scnrm2 Level 1 BLAS that computes the norm of a vector.
c
c\Author
c Danny Sorensen Phuong Vu
c Richard Lehoucq CRPC / Rice University
c Dept. of Computational & Houston, Texas
c Applied Mathematics
c Rice University
c Houston, Texas
c
c\SCCS Information: @(#)
c FILE: getv0.F SID: 2.3 DATE OF SID: 08/27/96 RELEASE: 2
c
c\EndLib
c
c-----------------------------------------------------------------------
c
subroutine cgetv0
& ( ido, bmat, itry, initv, n, j, v, ldv, resid, rnorm,
& ipntr, workd, ierr )
c
c %----------------------------------------------------%
c | Include files for debugging and timing information |
c %----------------------------------------------------%
c
include 'debug.h'
include 'stat.h'
c
c %------------------%
c | Scalar Arguments |
c %------------------%
c
character bmat*1
logical initv
integer ido, ierr, itry, j, ldv, n
Real
& rnorm
c
c %-----------------%
c | Array Arguments |
c %-----------------%
c
integer ipntr(3)
Complex
& resid(n), v(ldv,j), workd(2*n)
c
c %------------%
c | Parameters |
c %------------%
c
Complex
& one, zero
Real
& rzero
parameter (one = (1.0E+0, 0.0E+0), zero = (0.0E+0, 0.0E+0),
& rzero = 0.0E+0)
c
c %------------------------%
c | Local Scalars & Arrays |
c %------------------------%
c
logical first, inits, orth
integer idist, iseed(4), iter, msglvl, jj
Real
& rnorm0
Complex
& cnorm
save first, iseed, inits, iter, msglvl, orth, rnorm0
c
c %----------------------%
c | External Subroutines |
c %----------------------%
c
external ccopy, cgemv, clarnv, cvout, second
c
c %--------------------%
c | External Functions |
c %--------------------%
c
Real
& scnrm2, slapy2
Complex
& cdotc
external cdotc, scnrm2, slapy2
c
c %-----------------%
c | Data Statements |
c %-----------------%
c
data inits /.true./
c
c %-----------------------%
c | Executable Statements |
c %-----------------------%
c
c
c %-----------------------------------%
c | Initialize the seed of the LAPACK |
c | random number generator |
c %-----------------------------------%
c
if (inits) then
iseed(1) = 1
iseed(2) = 3
iseed(3) = 5
iseed(4) = 7
inits = .false.
end if
c
if (ido .eq. 0) then
c
c %-------------------------------%
c | Initialize timing statistics |
c | & message level for debugging |
c %-------------------------------%
c
call second (t0)
msglvl = mgetv0
c
ierr = 0
iter = 0
first = .FALSE.
orth = .FALSE.
c
c %-----------------------------------------------------%
c | Possibly generate a random starting vector in RESID |
c | Use a LAPACK random number generator used by the |
c | matrix generation routines. |
c | idist = 1: uniform (0,1) distribution; |
c | idist = 2: uniform (-1,1) distribution; |
c | idist = 3: normal (0,1) distribution; |
c %-----------------------------------------------------%
c
if (.not.initv) then
idist = 2
call clarnv (idist, iseed, n, resid)
end if
c
c %----------------------------------------------------------%
c | Force the starting vector into the range of OP to handle |
c | the generalized problem when B is possibly (singular). |
c %----------------------------------------------------------%
c
call second (t2)
if (bmat .eq. 'G') then
nopx = nopx + 1
ipntr(1) = 1
ipntr(2) = n + 1
call ccopy (n, resid, 1, workd, 1)
ido = -1
go to 9000
end if
end if
c
c %----------------------------------------%
c | Back from computing B*(initial-vector) |
c %----------------------------------------%
c
if (first) go to 20
c
c %-----------------------------------------------%
c | Back from computing B*(orthogonalized-vector) |
c %-----------------------------------------------%
c
if (orth) go to 40
c
call second (t3)
tmvopx = tmvopx + (t3 - t2)
c
c %------------------------------------------------------%
c | Starting vector is now in the range of OP; r = OP*r; |
c | Compute B-norm of starting vector. |
c %------------------------------------------------------%
c
call second (t2)
first = .TRUE.
if (bmat .eq. 'G') then
nbx = nbx + 1
call ccopy (n, workd(n+1), 1, resid, 1)
ipntr(1) = n + 1
ipntr(2) = 1
ido = 2
go to 9000
else if (bmat .eq. 'I') then
call ccopy (n, resid, 1, workd, 1)
end if
c
20 continue
c
if (bmat .eq. 'G') then
call second (t3)
tmvbx = tmvbx + (t3 - t2)
end if
c
first = .FALSE.
if (bmat .eq. 'G') then
cnorm = cdotc (n, resid, 1, workd, 1)
rnorm0 = sqrt(slapy2(real(cnorm),aimag(cnorm)))
else if (bmat .eq. 'I') then
rnorm0 = scnrm2(n, resid, 1)
end if
rnorm = rnorm0
c
c %---------------------------------------------%
c | Exit if this is the very first Arnoldi step |
c %---------------------------------------------%
c
if (j .eq. 1) go to 50
c
c %----------------------------------------------------------------
c | Otherwise need to B-orthogonalize the starting vector against |
c | the current Arnoldi basis using Gram-Schmidt with iter. ref. |
c | This is the case where an invariant subspace is encountered |
c | in the middle of the Arnoldi factorization. |
c | |
c | s = V^{T}*B*r; r = r - V*s; |
c | |
c | Stopping criteria used for iter. ref. is discussed in |
c | Parlett's book, page 107 and in Gragg & Reichel TOMS paper. |
c %---------------------------------------------------------------%
c
orth = .TRUE.
30 continue
c
call cgemv ('C', n, j-1, one, v, ldv, workd, 1,
& zero, workd(n+1), 1)
call cgemv ('N', n, j-1, -one, v, ldv, workd(n+1), 1,
& one, resid, 1)
c
c %----------------------------------------------------------%
c | Compute the B-norm of the orthogonalized starting vector |
c %----------------------------------------------------------%
c
call second (t2)
if (bmat .eq. 'G') then
nbx = nbx + 1
call ccopy (n, resid, 1, workd(n+1), 1)
ipntr(1) = n + 1
ipntr(2) = 1
ido = 2
go to 9000
else if (bmat .eq. 'I') then
call ccopy (n, resid, 1, workd, 1)
end if
c
40 continue
c
if (bmat .eq. 'G') then
call second (t3)
tmvbx = tmvbx + (t3 - t2)
end if
c
if (bmat .eq. 'G') then
cnorm = cdotc (n, resid, 1, workd, 1)
rnorm = sqrt(slapy2(real(cnorm),aimag(cnorm)))
else if (bmat .eq. 'I') then
rnorm = scnrm2(n, resid, 1)
end if
c
c %--------------------------------------%
c | Check for further orthogonalization. |
c %--------------------------------------%
c
if (msglvl .gt. 2) then
call svout (logfil, 1, rnorm0, ndigit,
& '_getv0: re-orthonalization ; rnorm0 is')
call svout (logfil, 1, rnorm, ndigit,
& '_getv0: re-orthonalization ; rnorm is')
end if
c
if (rnorm .gt. 0.717*rnorm0) go to 50
c
iter = iter + 1
if (iter .le. 1) then
c
c %-----------------------------------%
c | Perform iterative refinement step |
c %-----------------------------------%
c
rnorm0 = rnorm
go to 30
else
c
c %------------------------------------%
c | Iterative refinement step "failed" |
c %------------------------------------%
c
do 45 jj = 1, n
resid(jj) = zero
45 continue
rnorm = rzero
ierr = -1
end if
c
50 continue
c
if (msglvl .gt. 0) then
call svout (logfil, 1, rnorm, ndigit,
& '_getv0: B-norm of initial / restarted starting vector')
end if
if (msglvl .gt. 2) then
call cvout (logfil, n, resid, ndigit,
& '_getv0: initial / restarted starting vector')
end if
ido = 99
c
call second (t1)
tgetv0 = tgetv0 + (t1 - t0)
c
9000 continue
return
c
c %---------------%
c | End of cgetv0 |
c %---------------%
c
end

850
arpack/ARPACK/SRC/cnaitr.f Normal file
View File

@@ -0,0 +1,850 @@
c\BeginDoc
c
c\Name: cnaitr
c
c\Description:
c Reverse communication interface for applying NP additional steps to
c a K step nonsymmetric Arnoldi factorization.
c
c Input: OP*V_{k} - V_{k}*H = r_{k}*e_{k}^T
c
c with (V_{k}^T)*B*V_{k} = I, (V_{k}^T)*B*r_{k} = 0.
c
c Output: OP*V_{k+p} - V_{k+p}*H = r_{k+p}*e_{k+p}^T
c
c with (V_{k+p}^T)*B*V_{k+p} = I, (V_{k+p}^T)*B*r_{k+p} = 0.
c
c where OP and B are as in cnaupd. The B-norm of r_{k+p} is also
c computed and returned.
c
c\Usage:
c call cnaitr
c ( IDO, BMAT, N, K, NP, NB, RESID, RNORM, V, LDV, H, LDH,
c IPNTR, WORKD, INFO )
c
c\Arguments
c IDO Integer. (INPUT/OUTPUT)
c Reverse communication flag.
c -------------------------------------------------------------
c IDO = 0: first call to the reverse communication interface
c IDO = -1: compute Y = OP * X where
c IPNTR(1) is the pointer into WORK for X,
c IPNTR(2) is the pointer into WORK for Y.
c This is for the restart phase to force the new
c starting vector into the range of OP.
c IDO = 1: compute Y = OP * X where
c IPNTR(1) is the pointer into WORK for X,
c IPNTR(2) is the pointer into WORK for Y,
c IPNTR(3) is the pointer into WORK for B * X.
c IDO = 2: compute Y = B * X where
c IPNTR(1) is the pointer into WORK for X,
c IPNTR(2) is the pointer into WORK for Y.
c IDO = 99: done
c -------------------------------------------------------------
c When the routine is used in the "shift-and-invert" mode, the
c vector B * Q is already available and do not need to be
c recomputed in forming OP * Q.
c
c BMAT Character*1. (INPUT)
c BMAT specifies the type of the matrix B that defines the
c semi-inner product for the operator OP. See cnaupd.
c B = 'I' -> standard eigenvalue problem A*x = lambda*x
c B = 'G' -> generalized eigenvalue problem A*x = lambda*M**x
c
c N Integer. (INPUT)
c Dimension of the eigenproblem.
c
c K Integer. (INPUT)
c Current size of V and H.
c
c NP Integer. (INPUT)
c Number of additional Arnoldi steps to take.
c
c NB Integer. (INPUT)
c Blocksize to be used in the recurrence.
c Only work for NB = 1 right now. The goal is to have a
c program that implement both the block and non-block method.
c
c RESID Complex array of length N. (INPUT/OUTPUT)
c On INPUT: RESID contains the residual vector r_{k}.
c On OUTPUT: RESID contains the residual vector r_{k+p}.
c
c RNORM Real scalar. (INPUT/OUTPUT)
c B-norm of the starting residual on input.
c B-norm of the updated residual r_{k+p} on output.
c
c V Complex N by K+NP array. (INPUT/OUTPUT)
c On INPUT: V contains the Arnoldi vectors in the first K
c columns.
c On OUTPUT: V contains the new NP Arnoldi vectors in the next
c NP columns. The first K columns are unchanged.
c
c LDV Integer. (INPUT)
c Leading dimension of V exactly as declared in the calling
c program.
c
c H Complex (K+NP) by (K+NP) array. (INPUT/OUTPUT)
c H is used to store the generated upper Hessenberg matrix.
c
c LDH Integer. (INPUT)
c Leading dimension of H exactly as declared in the calling
c program.
c
c IPNTR Integer array of length 3. (OUTPUT)
c Pointer to mark the starting locations in the WORK for
c vectors used by the Arnoldi iteration.
c -------------------------------------------------------------
c IPNTR(1): pointer to the current operand vector X.
c IPNTR(2): pointer to the current result vector Y.
c IPNTR(3): pointer to the vector B * X when used in the
c shift-and-invert mode. X is the current operand.
c -------------------------------------------------------------
c
c WORKD Complex work array of length 3*N. (REVERSE COMMUNICATION)
c Distributed array to be used in the basic Arnoldi iteration
c for reverse communication. The calling program should not
c use WORKD as temporary workspace during the iteration !!!!!!
c On input, WORKD(1:N) = B*RESID and is used to save some
c computation at the first step.
c
c INFO Integer. (OUTPUT)
c = 0: Normal exit.
c > 0: Size of the spanning invariant subspace of OP found.
c
c\EndDoc
c
c-----------------------------------------------------------------------
c
c\BeginLib
c
c\Local variables:
c xxxxxx Complex
c
c\References:
c 1. D.C. Sorensen, "Implicit Application of Polynomial Filters in
c a k-Step Arnoldi Method", SIAM J. Matr. Anal. Apps., 13 (1992),
c pp 357-385.
c 2. R.B. Lehoucq, "Analysis and Implementation of an Implicitly
c Restarted Arnoldi Iteration", Rice University Technical Report
c TR95-13, Department of Computational and Applied Mathematics.
c
c\Routines called:
c cgetv0 ARPACK routine to generate the initial vector.
c ivout ARPACK utility routine that prints integers.
c second ARPACK utility routine for timing.
c cmout ARPACK utility routine that prints matrices
c cvout ARPACK utility routine that prints vectors.
c clanhs LAPACK routine that computes various norms of a matrix.
c clascl LAPACK routine for careful scaling of a matrix.
c slabad LAPACK routine for defining the underflow and overflow
c limits.
c slamch LAPACK routine that determines machine constants.
c slapy2 LAPACK routine to compute sqrt(x**2+y**2) carefully.
c cgemv Level 2 BLAS routine for matrix vector multiplication.
c caxpy Level 1 BLAS that computes a vector triad.
c ccopy Level 1 BLAS that copies one vector to another .
c cdotc Level 1 BLAS that computes the scalar product of two vectors.
c cscal Level 1 BLAS that scales a vector.
c csscal Level 1 BLAS that scales a complex vector by a real number.
c scnrm2 Level 1 BLAS that computes the norm of a vector.
c
c\Author
c Danny Sorensen Phuong Vu
c Richard Lehoucq CRPC / Rice University
c Dept. of Computational & Houston, Texas
c Applied Mathematics
c Rice University
c Houston, Texas
c
c\SCCS Information: @(#)
c FILE: naitr.F SID: 2.3 DATE OF SID: 8/27/96 RELEASE: 2
c
c\Remarks
c The algorithm implemented is:
c
c restart = .false.
c Given V_{k} = [v_{1}, ..., v_{k}], r_{k};
c r_{k} contains the initial residual vector even for k = 0;
c Also assume that rnorm = || B*r_{k} || and B*r_{k} are already
c computed by the calling program.
c
c betaj = rnorm ; p_{k+1} = B*r_{k} ;
c For j = k+1, ..., k+np Do
c 1) if ( betaj < tol ) stop or restart depending on j.
c ( At present tol is zero )
c if ( restart ) generate a new starting vector.
c 2) v_{j} = r(j-1)/betaj; V_{j} = [V_{j-1}, v_{j}];
c p_{j} = p_{j}/betaj
c 3) r_{j} = OP*v_{j} where OP is defined as in cnaupd
c For shift-invert mode p_{j} = B*v_{j} is already available.
c wnorm = || OP*v_{j} ||
c 4) Compute the j-th step residual vector.
c w_{j} = V_{j}^T * B * OP * v_{j}
c r_{j} = OP*v_{j} - V_{j} * w_{j}
c H(:,j) = w_{j};
c H(j,j-1) = rnorm
c rnorm = || r_(j) ||
c If (rnorm > 0.717*wnorm) accept step and go back to 1)
c 5) Re-orthogonalization step:
c s = V_{j}'*B*r_{j}
c r_{j} = r_{j} - V_{j}*s; rnorm1 = || r_{j} ||
c alphaj = alphaj + s_{j};
c 6) Iterative refinement step:
c If (rnorm1 > 0.717*rnorm) then
c rnorm = rnorm1
c accept step and go back to 1)
c Else
c rnorm = rnorm1
c If this is the first time in step 6), go to 5)
c Else r_{j} lies in the span of V_{j} numerically.
c Set r_{j} = 0 and rnorm = 0; go to 1)
c EndIf
c End Do
c
c\EndLib
c
c-----------------------------------------------------------------------
c
subroutine cnaitr
& (ido, bmat, n, k, np, nb, resid, rnorm, v, ldv, h, ldh,
& ipntr, workd, info)
c
c %----------------------------------------------------%
c | Include files for debugging and timing information |
c %----------------------------------------------------%
c
include 'debug.h'
include 'stat.h'
c
c %------------------%
c | Scalar Arguments |
c %------------------%
c
character bmat*1
integer ido, info, k, ldh, ldv, n, nb, np
Real
& rnorm
c
c %-----------------%
c | Array Arguments |
c %-----------------%
c
integer ipntr(3)
Complex
& h(ldh,k+np), resid(n), v(ldv,k+np), workd(3*n)
c
c %------------%
c | Parameters |
c %------------%
c
Complex
& one, zero
Real
& rone, rzero
parameter (one = (1.0E+0, 0.0E+0), zero = (0.0E+0, 0.0E+0),
& rone = 1.0E+0, rzero = 0.0E+0)
c
c %--------------%
c | Local Arrays |
c %--------------%
c
Real
& rtemp(2)
c
c %---------------%
c | Local Scalars |
c %---------------%
c
logical first, orth1, orth2, rstart, step3, step4
integer ierr, i, infol, ipj, irj, ivj, iter, itry, j, msglvl,
& jj
Real
& ovfl, smlnum, tst1, ulp, unfl, betaj,
& temp1, rnorm1, wnorm
Complex
& cnorm
c
save first, orth1, orth2, rstart, step3, step4,
& ierr, ipj, irj, ivj, iter, itry, j, msglvl, ovfl,
& betaj, rnorm1, smlnum, ulp, unfl, wnorm
c
c %----------------------%
c | External Subroutines |
c %----------------------%
c
external caxpy, ccopy, cscal, csscal, cgemv, cgetv0,
& slabad, cvout, cmout, ivout, second
c
c %--------------------%
c | External Functions |
c %--------------------%
c
Complex
& cdotc
Real
& slamch, scnrm2, clanhs, slapy2
external cdotc, scnrm2, clanhs, slamch, slapy2
c
c %---------------------%
c | Intrinsic Functions |
c %---------------------%
c
intrinsic aimag, real, max, sqrt
c
c %-----------------%
c | Data statements |
c %-----------------%
c
data first / .true. /
c
c %-----------------------%
c | Executable Statements |
c %-----------------------%
c
if (first) then
c
c %-----------------------------------------%
c | Set machine-dependent constants for the |
c | the splitting and deflation criterion. |
c | If norm(H) <= sqrt(OVFL), |
c | overflow should not occur. |
c | REFERENCE: LAPACK subroutine clahqr |
c %-----------------------------------------%
c
unfl = slamch( 'safe minimum' )
ovfl = real(one / unfl)
call slabad( unfl, ovfl )
ulp = slamch( 'precision' )
smlnum = unfl*( n / ulp )
first = .false.
end if
c
if (ido .eq. 0) then
c
c %-------------------------------%
c | Initialize timing statistics |
c | & message level for debugging |
c %-------------------------------%
c
call second (t0)
msglvl = mcaitr
c
c %------------------------------%
c | Initial call to this routine |
c %------------------------------%
c
info = 0
step3 = .false.
step4 = .false.
rstart = .false.
orth1 = .false.
orth2 = .false.
j = k + 1
ipj = 1
irj = ipj + n
ivj = irj + n
end if
c
c %-------------------------------------------------%
c | When in reverse communication mode one of: |
c | STEP3, STEP4, ORTH1, ORTH2, RSTART |
c | will be .true. when .... |
c | STEP3: return from computing OP*v_{j}. |
c | STEP4: return from computing B-norm of OP*v_{j} |
c | ORTH1: return from computing B-norm of r_{j+1} |
c | ORTH2: return from computing B-norm of |
c | correction to the residual vector. |
c | RSTART: return from OP computations needed by |
c | cgetv0. |
c %-------------------------------------------------%
c
if (step3) go to 50
if (step4) go to 60
if (orth1) go to 70
if (orth2) go to 90
if (rstart) go to 30
c
c %-----------------------------%
c | Else this is the first step |
c %-----------------------------%
c
c %--------------------------------------------------------------%
c | |
c | A R N O L D I I T E R A T I O N L O O P |
c | |
c | Note: B*r_{j-1} is already in WORKD(1:N)=WORKD(IPJ:IPJ+N-1) |
c %--------------------------------------------------------------%
1000 continue
c
if (msglvl .gt. 1) then
call ivout (logfil, 1, j, ndigit,
& '_naitr: generating Arnoldi vector number')
call svout (logfil, 1, rnorm, ndigit,
& '_naitr: B-norm of the current residual is')
end if
c
c %---------------------------------------------------%
c | STEP 1: Check if the B norm of j-th residual |
c | vector is zero. Equivalent to determine whether |
c | an exact j-step Arnoldi factorization is present. |
c %---------------------------------------------------%
c
betaj = rnorm
if (rnorm .gt. rzero) go to 40
c
c %---------------------------------------------------%
c | Invariant subspace found, generate a new starting |
c | vector which is orthogonal to the current Arnoldi |
c | basis and continue the iteration. |
c %---------------------------------------------------%
c
if (msglvl .gt. 0) then
call ivout (logfil, 1, j, ndigit,
& '_naitr: ****** RESTART AT STEP ******')
end if
c
c %---------------------------------------------%
c | ITRY is the loop variable that controls the |
c | maximum amount of times that a restart is |
c | attempted. NRSTRT is used by stat.h |
c %---------------------------------------------%
c
betaj = rzero
nrstrt = nrstrt + 1
itry = 1
20 continue
rstart = .true.
ido = 0
30 continue
c
c %--------------------------------------%
c | If in reverse communication mode and |
c | RSTART = .true. flow returns here. |
c %--------------------------------------%
c
call cgetv0 (ido, bmat, itry, .false., n, j, v, ldv,
& resid, rnorm, ipntr, workd, ierr)
if (ido .ne. 99) go to 9000
if (ierr .lt. 0) then
itry = itry + 1
if (itry .le. 3) go to 20
c
c %------------------------------------------------%
c | Give up after several restart attempts. |
c | Set INFO to the size of the invariant subspace |
c | which spans OP and exit. |
c %------------------------------------------------%
c
info = j - 1
call second (t1)
tcaitr = tcaitr + (t1 - t0)
ido = 99
go to 9000
end if
c
40 continue
c
c %---------------------------------------------------------%
c | STEP 2: v_{j} = r_{j-1}/rnorm and p_{j} = p_{j}/rnorm |
c | Note that p_{j} = B*r_{j-1}. In order to avoid overflow |
c | when reciprocating a small RNORM, test against lower |
c | machine bound. |
c %---------------------------------------------------------%
c
call ccopy (n, resid, 1, v(1,j), 1)
if ( rnorm .ge. unfl) then
temp1 = rone / rnorm
call csscal (n, temp1, v(1,j), 1)
call csscal (n, temp1, workd(ipj), 1)
else
c
c %-----------------------------------------%
c | To scale both v_{j} and p_{j} carefully |
c | use LAPACK routine clascl |
c %-----------------------------------------%
c
call clascl ('General', i, i, rnorm, rone,
& n, 1, v(1,j), n, infol)
call clascl ('General', i, i, rnorm, rone,
& n, 1, workd(ipj), n, infol)
end if
c
c %------------------------------------------------------%
c | STEP 3: r_{j} = OP*v_{j}; Note that p_{j} = B*v_{j} |
c | Note that this is not quite yet r_{j}. See STEP 4 |
c %------------------------------------------------------%
c
step3 = .true.
nopx = nopx + 1
call second (t2)
call ccopy (n, v(1,j), 1, workd(ivj), 1)
ipntr(1) = ivj
ipntr(2) = irj
ipntr(3) = ipj
ido = 1
c
c %-----------------------------------%
c | Exit in order to compute OP*v_{j} |
c %-----------------------------------%
c
go to 9000
50 continue
c
c %----------------------------------%
c | Back from reverse communication; |
c | WORKD(IRJ:IRJ+N-1) := OP*v_{j} |
c | if step3 = .true. |
c %----------------------------------%
c
call second (t3)
tmvopx = tmvopx + (t3 - t2)
step3 = .false.
c
c %------------------------------------------%
c | Put another copy of OP*v_{j} into RESID. |
c %------------------------------------------%
c
call ccopy (n, workd(irj), 1, resid, 1)
c
c %---------------------------------------%
c | STEP 4: Finish extending the Arnoldi |
c | factorization to length j. |
c %---------------------------------------%
c
call second (t2)
if (bmat .eq. 'G') then
nbx = nbx + 1
step4 = .true.
ipntr(1) = irj
ipntr(2) = ipj
ido = 2
c
c %-------------------------------------%
c | Exit in order to compute B*OP*v_{j} |
c %-------------------------------------%
c
go to 9000
else if (bmat .eq. 'I') then
call ccopy (n, resid, 1, workd(ipj), 1)
end if
60 continue
c
c %----------------------------------%
c | Back from reverse communication; |
c | WORKD(IPJ:IPJ+N-1) := B*OP*v_{j} |
c | if step4 = .true. |
c %----------------------------------%
c
if (bmat .eq. 'G') then
call second (t3)
tmvbx = tmvbx + (t3 - t2)
end if
c
step4 = .false.
c
c %-------------------------------------%
c | The following is needed for STEP 5. |
c | Compute the B-norm of OP*v_{j}. |
c %-------------------------------------%
c
if (bmat .eq. 'G') then
cnorm = cdotc (n, resid, 1, workd(ipj), 1)
wnorm = sqrt( slapy2(real(cnorm),aimag(cnorm)) )
else if (bmat .eq. 'I') then
wnorm = scnrm2(n, resid, 1)
end if
c
c %-----------------------------------------%
c | Compute the j-th residual corresponding |
c | to the j step factorization. |
c | Use Classical Gram Schmidt and compute: |
c | w_{j} <- V_{j}^T * B * OP * v_{j} |
c | r_{j} <- OP*v_{j} - V_{j} * w_{j} |
c %-----------------------------------------%
c
c
c %------------------------------------------%
c | Compute the j Fourier coefficients w_{j} |
c | WORKD(IPJ:IPJ+N-1) contains B*OP*v_{j}. |
c %------------------------------------------%
c
call cgemv ('C', n, j, one, v, ldv, workd(ipj), 1,
& zero, h(1,j), 1)
c
c %--------------------------------------%
c | Orthogonalize r_{j} against V_{j}. |
c | RESID contains OP*v_{j}. See STEP 3. |
c %--------------------------------------%
c
call cgemv ('N', n, j, -one, v, ldv, h(1,j), 1,
& one, resid, 1)
c
if (j .gt. 1) h(j,j-1) = cmplx(betaj, rzero)
c
call second (t4)
c
orth1 = .true.
c
call second (t2)
if (bmat .eq. 'G') then
nbx = nbx + 1
call ccopy (n, resid, 1, workd(irj), 1)
ipntr(1) = irj
ipntr(2) = ipj
ido = 2
c
c %----------------------------------%
c | Exit in order to compute B*r_{j} |
c %----------------------------------%
c
go to 9000
else if (bmat .eq. 'I') then
call ccopy (n, resid, 1, workd(ipj), 1)
end if
70 continue
c
c %---------------------------------------------------%
c | Back from reverse communication if ORTH1 = .true. |
c | WORKD(IPJ:IPJ+N-1) := B*r_{j}. |
c %---------------------------------------------------%
c
if (bmat .eq. 'G') then
call second (t3)
tmvbx = tmvbx + (t3 - t2)
end if
c
orth1 = .false.
c
c %------------------------------%
c | Compute the B-norm of r_{j}. |
c %------------------------------%
c
if (bmat .eq. 'G') then
cnorm = cdotc (n, resid, 1, workd(ipj), 1)
rnorm = sqrt( slapy2(real(cnorm),aimag(cnorm)) )
else if (bmat .eq. 'I') then
rnorm = scnrm2(n, resid, 1)
end if
c
c %-----------------------------------------------------------%
c | STEP 5: Re-orthogonalization / Iterative refinement phase |
c | Maximum NITER_ITREF tries. |
c | |
c | s = V_{j}^T * B * r_{j} |
c | r_{j} = r_{j} - V_{j}*s |
c | alphaj = alphaj + s_{j} |
c | |
c | The stopping criteria used for iterative refinement is |
c | discussed in Parlett's book SEP, page 107 and in Gragg & |
c | Reichel ACM TOMS paper; Algorithm 686, Dec. 1990. |
c | Determine if we need to correct the residual. The goal is |
c | to enforce ||v(:,1:j)^T * r_{j}|| .le. eps * || r_{j} || |
c | The following test determines whether the sine of the |
c | angle between OP*x and the computed residual is less |
c | than or equal to 0.717. |
c %-----------------------------------------------------------%
c
if ( rnorm .gt. 0.717*wnorm ) go to 100
c
iter = 0
nrorth = nrorth + 1
c
c %---------------------------------------------------%
c | Enter the Iterative refinement phase. If further |
c | refinement is necessary, loop back here. The loop |
c | variable is ITER. Perform a step of Classical |
c | Gram-Schmidt using all the Arnoldi vectors V_{j} |
c %---------------------------------------------------%
c
80 continue
c
if (msglvl .gt. 2) then
rtemp(1) = wnorm
rtemp(2) = rnorm
call svout (logfil, 2, rtemp, ndigit,
& '_naitr: re-orthogonalization; wnorm and rnorm are')
call cvout (logfil, j, h(1,j), ndigit,
& '_naitr: j-th column of H')
end if
c
c %----------------------------------------------------%
c | Compute V_{j}^T * B * r_{j}. |
c | WORKD(IRJ:IRJ+J-1) = v(:,1:J)'*WORKD(IPJ:IPJ+N-1). |
c %----------------------------------------------------%
c
call cgemv ('C', n, j, one, v, ldv, workd(ipj), 1,
& zero, workd(irj), 1)
c
c %---------------------------------------------%
c | Compute the correction to the residual: |
c | r_{j} = r_{j} - V_{j} * WORKD(IRJ:IRJ+J-1). |
c | The correction to H is v(:,1:J)*H(1:J,1:J) |
c | + v(:,1:J)*WORKD(IRJ:IRJ+J-1)*e'_j. |
c %---------------------------------------------%
c
call cgemv ('N', n, j, -one, v, ldv, workd(irj), 1,
& one, resid, 1)
call caxpy (j, one, workd(irj), 1, h(1,j), 1)
c
orth2 = .true.
call second (t2)
if (bmat .eq. 'G') then
nbx = nbx + 1
call ccopy (n, resid, 1, workd(irj), 1)
ipntr(1) = irj
ipntr(2) = ipj
ido = 2
c
c %-----------------------------------%
c | Exit in order to compute B*r_{j}. |
c | r_{j} is the corrected residual. |
c %-----------------------------------%
c
go to 9000
else if (bmat .eq. 'I') then
call ccopy (n, resid, 1, workd(ipj), 1)
end if
90 continue
c
c %---------------------------------------------------%
c | Back from reverse communication if ORTH2 = .true. |
c %---------------------------------------------------%
c
if (bmat .eq. 'G') then
call second (t3)
tmvbx = tmvbx + (t3 - t2)
end if
c
c %-----------------------------------------------------%
c | Compute the B-norm of the corrected residual r_{j}. |
c %-----------------------------------------------------%
c
if (bmat .eq. 'G') then
cnorm = cdotc (n, resid, 1, workd(ipj), 1)
rnorm1 = sqrt( slapy2(real(cnorm),aimag(cnorm)) )
else if (bmat .eq. 'I') then
rnorm1 = scnrm2(n, resid, 1)
end if
c
if (msglvl .gt. 0 .and. iter .gt. 0 ) then
call ivout (logfil, 1, j, ndigit,
& '_naitr: Iterative refinement for Arnoldi residual')
if (msglvl .gt. 2) then
rtemp(1) = rnorm
rtemp(2) = rnorm1
call svout (logfil, 2, rtemp, ndigit,
& '_naitr: iterative refinement ; rnorm and rnorm1 are')
end if
end if
c
c %-----------------------------------------%
c | Determine if we need to perform another |
c | step of re-orthogonalization. |
c %-----------------------------------------%
c
if ( rnorm1 .gt. 0.717*rnorm ) then
c
c %---------------------------------------%
c | No need for further refinement. |
c | The cosine of the angle between the |
c | corrected residual vector and the old |
c | residual vector is greater than 0.717 |
c | In other words the corrected residual |
c | and the old residual vector share an |
c | angle of less than arcCOS(0.717) |
c %---------------------------------------%
c
rnorm = rnorm1
c
else
c
c %-------------------------------------------%
c | Another step of iterative refinement step |
c | is required. NITREF is used by stat.h |
c %-------------------------------------------%
c
nitref = nitref + 1
rnorm = rnorm1
iter = iter + 1
if (iter .le. 1) go to 80
c
c %-------------------------------------------------%
c | Otherwise RESID is numerically in the span of V |
c %-------------------------------------------------%
c
do 95 jj = 1, n
resid(jj) = zero
95 continue
rnorm = rzero
end if
c
c %----------------------------------------------%
c | Branch here directly if iterative refinement |
c | wasn't necessary or after at most NITER_REF |
c | steps of iterative refinement. |
c %----------------------------------------------%
c
100 continue
c
rstart = .false.
orth2 = .false.
c
call second (t5)
titref = titref + (t5 - t4)
c
c %------------------------------------%
c | STEP 6: Update j = j+1; Continue |
c %------------------------------------%
c
j = j + 1
if (j .gt. k+np) then
call second (t1)
tcaitr = tcaitr + (t1 - t0)
ido = 99
do 110 i = max(1,k), k+np-1
c
c %--------------------------------------------%
c | Check for splitting and deflation. |
c | Use a standard test as in the QR algorithm |
c | REFERENCE: LAPACK subroutine clahqr |
c %--------------------------------------------%
c
tst1 = slapy2(real(h(i,i)),aimag(h(i,i)))
& + slapy2(real(h(i+1,i+1)), aimag(h(i+1,i+1)))
if( tst1.eq.real(zero) )
& tst1 = clanhs( '1', k+np, h, ldh, workd(n+1) )
if( slapy2(real(h(i+1,i)),aimag(h(i+1,i))) .le.
& max( ulp*tst1, smlnum ) )
& h(i+1,i) = zero
110 continue
c
if (msglvl .gt. 2) then
call cmout (logfil, k+np, k+np, h, ldh, ndigit,
& '_naitr: Final upper Hessenberg matrix H of order K+NP')
end if
c
go to 9000
end if
c
c %--------------------------------------------------------%
c | Loop back to extend the factorization by another step. |
c %--------------------------------------------------------%
c
go to 1000
c
c %---------------------------------------------------------------%
c | |
c | E N D O F M A I N I T E R A T I O N L O O P |
c | |
c %---------------------------------------------------------------%
c
9000 continue
return
c
c %---------------%
c | End of cnaitr |
c %---------------%
c
end

507
arpack/ARPACK/SRC/cnapps.f Normal file
View File

@@ -0,0 +1,507 @@
c\BeginDoc
c
c\Name: cnapps
c
c\Description:
c Given the Arnoldi factorization
c
c A*V_{k} - V_{k}*H_{k} = r_{k+p}*e_{k+p}^T,
c
c apply NP implicit shifts resulting in
c
c A*(V_{k}*Q) - (V_{k}*Q)*(Q^T* H_{k}*Q) = r_{k+p}*e_{k+p}^T * Q
c
c where Q is an orthogonal matrix which is the product of rotations
c and reflections resulting from the NP bulge change sweeps.
c The updated Arnoldi factorization becomes:
c
c A*VNEW_{k} - VNEW_{k}*HNEW_{k} = rnew_{k}*e_{k}^T.
c
c\Usage:
c call cnapps
c ( N, KEV, NP, SHIFT, V, LDV, H, LDH, RESID, Q, LDQ,
c WORKL, WORKD )
c
c\Arguments
c N Integer. (INPUT)
c Problem size, i.e. size of matrix A.
c
c KEV Integer. (INPUT/OUTPUT)
c KEV+NP is the size of the input matrix H.
c KEV is the size of the updated matrix HNEW.
c
c NP Integer. (INPUT)
c Number of implicit shifts to be applied.
c
c SHIFT Complex array of length NP. (INPUT)
c The shifts to be applied.
c
c V Complex N by (KEV+NP) array. (INPUT/OUTPUT)
c On INPUT, V contains the current KEV+NP Arnoldi vectors.
c On OUTPUT, V contains the updated KEV Arnoldi vectors
c in the first KEV columns of V.
c
c LDV Integer. (INPUT)
c Leading dimension of V exactly as declared in the calling
c program.
c
c H Complex (KEV+NP) by (KEV+NP) array. (INPUT/OUTPUT)
c On INPUT, H contains the current KEV+NP by KEV+NP upper
c Hessenberg matrix of the Arnoldi factorization.
c On OUTPUT, H contains the updated KEV by KEV upper Hessenberg
c matrix in the KEV leading submatrix.
c
c LDH Integer. (INPUT)
c Leading dimension of H exactly as declared in the calling
c program.
c
c RESID Complex array of length N. (INPUT/OUTPUT)
c On INPUT, RESID contains the the residual vector r_{k+p}.
c On OUTPUT, RESID is the update residual vector rnew_{k}
c in the first KEV locations.
c
c Q Complex KEV+NP by KEV+NP work array. (WORKSPACE)
c Work array used to accumulate the rotations and reflections
c during the bulge chase sweep.
c
c LDQ Integer. (INPUT)
c Leading dimension of Q exactly as declared in the calling
c program.
c
c WORKL Complex work array of length (KEV+NP). (WORKSPACE)
c Private (replicated) array on each PE or array allocated on
c the front end.
c
c WORKD Complex work array of length 2*N. (WORKSPACE)
c Distributed array used in the application of the accumulated
c orthogonal matrix Q.
c
c\EndDoc
c
c-----------------------------------------------------------------------
c
c\BeginLib
c
c\Local variables:
c xxxxxx Complex
c
c\References:
c 1. D.C. Sorensen, "Implicit Application of Polynomial Filters in
c a k-Step Arnoldi Method", SIAM J. Matr. Anal. Apps., 13 (1992),
c pp 357-385.
c
c\Routines called:
c ivout ARPACK utility routine that prints integers.
c second ARPACK utility routine for timing.
c cmout ARPACK utility routine that prints matrices
c cvout ARPACK utility routine that prints vectors.
c clacpy LAPACK matrix copy routine.
c clanhs LAPACK routine that computes various norms of a matrix.
c clartg LAPACK Givens rotation construction routine.
c claset LAPACK matrix initialization routine.
c slabad LAPACK routine for defining the underflow and overflow
c limits.
c slamch LAPACK routine that determines machine constants.
c slapy2 LAPACK routine to compute sqrt(x**2+y**2) carefully.
c cgemv Level 2 BLAS routine for matrix vector multiplication.
c caxpy Level 1 BLAS that computes a vector triad.
c ccopy Level 1 BLAS that copies one vector to another.
c cscal Level 1 BLAS that scales a vector.
c
c\Author
c Danny Sorensen Phuong Vu
c Richard Lehoucq CRPC / Rice University
c Dept. of Computational & Houston, Texas
c Applied Mathematics
c Rice University
c Houston, Texas
c
c\SCCS Information: @(#)
c FILE: napps.F SID: 2.3 DATE OF SID: 3/28/97 RELEASE: 2
c
c\Remarks
c 1. In this version, each shift is applied to all the sublocks of
c the Hessenberg matrix H and not just to the submatrix that it
c comes from. Deflation as in LAPACK routine clahqr (QR algorithm
c for upper Hessenberg matrices ) is used.
c Upon output, the subdiagonals of H are enforced to be non-negative
c real numbers.
c
c\EndLib
c
c-----------------------------------------------------------------------
c
subroutine cnapps
& ( n, kev, np, shift, v, ldv, h, ldh, resid, q, ldq,
& workl, workd )
c
c %----------------------------------------------------%
c | Include files for debugging and timing information |
c %----------------------------------------------------%
c
include 'debug.h'
include 'stat.h'
c
c %------------------%
c | Scalar Arguments |
c %------------------%
c
integer kev, ldh, ldq, ldv, n, np
c
c %-----------------%
c | Array Arguments |
c %-----------------%
c
Complex
& h(ldh,kev+np), resid(n), shift(np),
& v(ldv,kev+np), q(ldq,kev+np), workd(2*n), workl(kev+np)
c
c %------------%
c | Parameters |
c %------------%
c
Complex
& one, zero
Real
& rzero
parameter (one = (1.0E+0, 0.0E+0), zero = (0.0E+0, 0.0E+0),
& rzero = 0.0E+0)
c
c %------------------------%
c | Local Scalars & Arrays |
c %------------------------%
c
integer i, iend, istart, j, jj, kplusp, msglvl
logical first
Complex
& cdum, f, g, h11, h21, r, s, sigma, t
Real
& c, ovfl, smlnum, ulp, unfl, tst1
save first, ovfl, smlnum, ulp, unfl
c
c %----------------------%
c | External Subroutines |
c %----------------------%
c
external caxpy, ccopy, cgemv, cscal, clacpy, clartg,
& cvout, claset, slabad, cmout, second, ivout
c
c %--------------------%
c | External Functions |
c %--------------------%
c
Real
& clanhs, slamch, slapy2
external clanhs, slamch, slapy2
c
c %----------------------%
c | Intrinsics Functions |
c %----------------------%
c
intrinsic abs, aimag, conjg, cmplx, max, min, real
c
c %---------------------%
c | Statement Functions |
c %---------------------%
c
Real
& cabs1
cabs1( cdum ) = abs( real( cdum ) ) + abs( aimag( cdum ) )
c
c %----------------%
c | Data statments |
c %----------------%
c
data first / .true. /
c
c %-----------------------%
c | Executable Statements |
c %-----------------------%
c
if (first) then
c
c %-----------------------------------------------%
c | Set machine-dependent constants for the |
c | stopping criterion. If norm(H) <= sqrt(OVFL), |
c | overflow should not occur. |
c | REFERENCE: LAPACK subroutine clahqr |
c %-----------------------------------------------%
c
unfl = slamch( 'safe minimum' )
ovfl = real(one / unfl)
call slabad( unfl, ovfl )
ulp = slamch( 'precision' )
smlnum = unfl*( n / ulp )
first = .false.
end if
c
c %-------------------------------%
c | Initialize timing statistics |
c | & message level for debugging |
c %-------------------------------%
c
call second (t0)
msglvl = mcapps
c
kplusp = kev + np
c
c %--------------------------------------------%
c | Initialize Q to the identity to accumulate |
c | the rotations and reflections |
c %--------------------------------------------%
c
call claset ('All', kplusp, kplusp, zero, one, q, ldq)
c
c %----------------------------------------------%
c | Quick return if there are no shifts to apply |
c %----------------------------------------------%
c
if (np .eq. 0) go to 9000
c
c %----------------------------------------------%
c | Chase the bulge with the application of each |
c | implicit shift. Each shift is applied to the |
c | whole matrix including each block. |
c %----------------------------------------------%
c
do 110 jj = 1, np
sigma = shift(jj)
c
if (msglvl .gt. 2 ) then
call ivout (logfil, 1, jj, ndigit,
& '_napps: shift number.')
call cvout (logfil, 1, sigma, ndigit,
& '_napps: Value of the shift ')
end if
c
istart = 1
20 continue
c
do 30 i = istart, kplusp-1
c
c %----------------------------------------%
c | Check for splitting and deflation. Use |
c | a standard test as in the QR algorithm |
c | REFERENCE: LAPACK subroutine clahqr |
c %----------------------------------------%
c
tst1 = cabs1( h( i, i ) ) + cabs1( h( i+1, i+1 ) )
if( tst1.eq.rzero )
& tst1 = clanhs( '1', kplusp-jj+1, h, ldh, workl )
if ( abs(real(h(i+1,i)))
& .le. max(ulp*tst1, smlnum) ) then
if (msglvl .gt. 0) then
call ivout (logfil, 1, i, ndigit,
& '_napps: matrix splitting at row/column no.')
call ivout (logfil, 1, jj, ndigit,
& '_napps: matrix splitting with shift number.')
call cvout (logfil, 1, h(i+1,i), ndigit,
& '_napps: off diagonal element.')
end if
iend = i
h(i+1,i) = zero
go to 40
end if
30 continue
iend = kplusp
40 continue
c
if (msglvl .gt. 2) then
call ivout (logfil, 1, istart, ndigit,
& '_napps: Start of current block ')
call ivout (logfil, 1, iend, ndigit,
& '_napps: End of current block ')
end if
c
c %------------------------------------------------%
c | No reason to apply a shift to block of order 1 |
c | or if the current block starts after the point |
c | of compression since we'll discard this stuff |
c %------------------------------------------------%
c
if ( istart .eq. iend .or. istart .gt. kev) go to 100
c
h11 = h(istart,istart)
h21 = h(istart+1,istart)
f = h11 - sigma
g = h21
c
do 80 i = istart, iend-1
c
c %------------------------------------------------------%
c | Construct the plane rotation G to zero out the bulge |
c %------------------------------------------------------%
c
call clartg (f, g, c, s, r)
if (i .gt. istart) then
h(i,i-1) = r
h(i+1,i-1) = zero
end if
c
c %---------------------------------------------%
c | Apply rotation to the left of H; H <- G'*H |
c %---------------------------------------------%
c
do 50 j = i, kplusp
t = c*h(i,j) + s*h(i+1,j)
h(i+1,j) = -conjg(s)*h(i,j) + c*h(i+1,j)
h(i,j) = t
50 continue
c
c %---------------------------------------------%
c | Apply rotation to the right of H; H <- H*G |
c %---------------------------------------------%
c
do 60 j = 1, min(i+2,iend)
t = c*h(j,i) + conjg(s)*h(j,i+1)
h(j,i+1) = -s*h(j,i) + c*h(j,i+1)
h(j,i) = t
60 continue
c
c %-----------------------------------------------------%
c | Accumulate the rotation in the matrix Q; Q <- Q*G' |
c %-----------------------------------------------------%
c
do 70 j = 1, min(i+jj, kplusp)
t = c*q(j,i) + conjg(s)*q(j,i+1)
q(j,i+1) = - s*q(j,i) + c*q(j,i+1)
q(j,i) = t
70 continue
c
c %---------------------------%
c | Prepare for next rotation |
c %---------------------------%
c
if (i .lt. iend-1) then
f = h(i+1,i)
g = h(i+2,i)
end if
80 continue
c
c %-------------------------------%
c | Finished applying the shift. |
c %-------------------------------%
c
100 continue
c
c %---------------------------------------------------------%
c | Apply the same shift to the next block if there is any. |
c %---------------------------------------------------------%
c
istart = iend + 1
if (iend .lt. kplusp) go to 20
c
c %---------------------------------------------%
c | Loop back to the top to get the next shift. |
c %---------------------------------------------%
c
110 continue
c
c %---------------------------------------------------%
c | Perform a similarity transformation that makes |
c | sure that the compressed H will have non-negative |
c | real subdiagonal elements. |
c %---------------------------------------------------%
c
do 120 j=1,kev
if ( real( h(j+1,j) ) .lt. rzero .or.
& aimag( h(j+1,j) ) .ne. rzero ) then
t = h(j+1,j) / slapy2(real(h(j+1,j)),aimag(h(j+1,j)))
call cscal( kplusp-j+1, conjg(t), h(j+1,j), ldh )
call cscal( min(j+2, kplusp), t, h(1,j+1), 1 )
call cscal( min(j+np+1,kplusp), t, q(1,j+1), 1 )
h(j+1,j) = cmplx( real( h(j+1,j) ), rzero )
end if
120 continue
c
do 130 i = 1, kev
c
c %--------------------------------------------%
c | Final check for splitting and deflation. |
c | Use a standard test as in the QR algorithm |
c | REFERENCE: LAPACK subroutine clahqr. |
c | Note: Since the subdiagonals of the |
c | compressed H are nonnegative real numbers, |
c | we take advantage of this. |
c %--------------------------------------------%
c
tst1 = cabs1( h( i, i ) ) + cabs1( h( i+1, i+1 ) )
if( tst1 .eq. rzero )
& tst1 = clanhs( '1', kev, h, ldh, workl )
if( real( h( i+1,i ) ) .le. max( ulp*tst1, smlnum ) )
& h(i+1,i) = zero
130 continue
c
c %-------------------------------------------------%
c | Compute the (kev+1)-st column of (V*Q) and |
c | temporarily store the result in WORKD(N+1:2*N). |
c | This is needed in the residual update since we |
c | cannot GUARANTEE that the corresponding entry |
c | of H would be zero as in exact arithmetic. |
c %-------------------------------------------------%
c
if ( real( h(kev+1,kev) ) .gt. rzero )
& call cgemv ('N', n, kplusp, one, v, ldv, q(1,kev+1), 1, zero,
& workd(n+1), 1)
c
c %----------------------------------------------------------%
c | Compute column 1 to kev of (V*Q) in backward order |
c | taking advantage of the upper Hessenberg structure of Q. |
c %----------------------------------------------------------%
c
do 140 i = 1, kev
call cgemv ('N', n, kplusp-i+1, one, v, ldv,
& q(1,kev-i+1), 1, zero, workd, 1)
call ccopy (n, workd, 1, v(1,kplusp-i+1), 1)
140 continue
c
c %-------------------------------------------------%
c | Move v(:,kplusp-kev+1:kplusp) into v(:,1:kev). |
c %-------------------------------------------------%
c
call clacpy ('A', n, kev, v(1,kplusp-kev+1), ldv, v, ldv)
c
c %--------------------------------------------------------------%
c | Copy the (kev+1)-st column of (V*Q) in the appropriate place |
c %--------------------------------------------------------------%
c
if ( real( h(kev+1,kev) ) .gt. rzero )
& call ccopy (n, workd(n+1), 1, v(1,kev+1), 1)
c
c %-------------------------------------%
c | Update the residual vector: |
c | r <- sigmak*r + betak*v(:,kev+1) |
c | where |
c | sigmak = (e_{kev+p}'*Q)*e_{kev} |
c | betak = e_{kev+1}'*H*e_{kev} |
c %-------------------------------------%
c
call cscal (n, q(kplusp,kev), resid, 1)
if ( real( h(kev+1,kev) ) .gt. rzero )
& call caxpy (n, h(kev+1,kev), v(1,kev+1), 1, resid, 1)
c
if (msglvl .gt. 1) then
call cvout (logfil, 1, q(kplusp,kev), ndigit,
& '_napps: sigmak = (e_{kev+p}^T*Q)*e_{kev}')
call cvout (logfil, 1, h(kev+1,kev), ndigit,
& '_napps: betak = e_{kev+1}^T*H*e_{kev}')
call ivout (logfil, 1, kev, ndigit,
& '_napps: Order of the final Hessenberg matrix ')
if (msglvl .gt. 2) then
call cmout (logfil, kev, kev, h, ldh, ndigit,
& '_napps: updated Hessenberg matrix H for next iteration')
end if
c
end if
c
9000 continue
call second (t1)
tcapps = tcapps + (t1 - t0)
c
return
c
c %---------------%
c | End of cnapps |
c %---------------%
c
end

801
arpack/ARPACK/SRC/cnaup2.f Normal file
View File

@@ -0,0 +1,801 @@
c\BeginDoc
c
c\Name: cnaup2
c
c\Description:
c Intermediate level interface called by cnaupd.
c
c\Usage:
c call cnaup2
c ( IDO, BMAT, N, WHICH, NEV, NP, TOL, RESID, MODE, IUPD,
c ISHIFT, MXITER, V, LDV, H, LDH, RITZ, BOUNDS,
c Q, LDQ, WORKL, IPNTR, WORKD, RWORK, INFO )
c
c\Arguments
c
c IDO, BMAT, N, WHICH, NEV, TOL, RESID: same as defined in cnaupd.
c MODE, ISHIFT, MXITER: see the definition of IPARAM in cnaupd.
c
c NP Integer. (INPUT/OUTPUT)
c Contains the number of implicit shifts to apply during
c each Arnoldi iteration.
c If ISHIFT=1, NP is adjusted dynamically at each iteration
c to accelerate convergence and prevent stagnation.
c This is also roughly equal to the number of matrix-vector
c products (involving the operator OP) per Arnoldi iteration.
c The logic for adjusting is contained within the current
c subroutine.
c If ISHIFT=0, NP is the number of shifts the user needs
c to provide via reverse comunication. 0 < NP < NCV-NEV.
c NP may be less than NCV-NEV since a leading block of the current
c upper Hessenberg matrix has split off and contains "unwanted"
c Ritz values.
c Upon termination of the IRA iteration, NP contains the number
c of "converged" wanted Ritz values.
c
c IUPD Integer. (INPUT)
c IUPD .EQ. 0: use explicit restart instead implicit update.
c IUPD .NE. 0: use implicit update.
c
c V Complex N by (NEV+NP) array. (INPUT/OUTPUT)
c The Arnoldi basis vectors are returned in the first NEV
c columns of V.
c
c LDV Integer. (INPUT)
c Leading dimension of V exactly as declared in the calling
c program.
c
c H Complex (NEV+NP) by (NEV+NP) array. (OUTPUT)
c H is used to store the generated upper Hessenberg matrix
c
c LDH Integer. (INPUT)
c Leading dimension of H exactly as declared in the calling
c program.
c
c RITZ Complex array of length NEV+NP. (OUTPUT)
c RITZ(1:NEV) contains the computed Ritz values of OP.
c
c BOUNDS Complex array of length NEV+NP. (OUTPUT)
c BOUNDS(1:NEV) contain the error bounds corresponding to
c the computed Ritz values.
c
c Q Complex (NEV+NP) by (NEV+NP) array. (WORKSPACE)
c Private (replicated) work array used to accumulate the
c rotation in the shift application step.
c
c LDQ Integer. (INPUT)
c Leading dimension of Q exactly as declared in the calling
c program.
c
c WORKL Complex work array of length at least
c (NEV+NP)**2 + 3*(NEV+NP). (WORKSPACE)
c Private (replicated) array on each PE or array allocated on
c the front end. It is used in shifts calculation, shifts
c application and convergence checking.
c
c
c IPNTR Integer array of length 3. (OUTPUT)
c Pointer to mark the starting locations in the WORKD for
c vectors used by the Arnoldi iteration.
c -------------------------------------------------------------
c IPNTR(1): pointer to the current operand vector X.
c IPNTR(2): pointer to the current result vector Y.
c IPNTR(3): pointer to the vector B * X when used in the
c shift-and-invert mode. X is the current operand.
c -------------------------------------------------------------
c
c WORKD Complex work array of length 3*N. (WORKSPACE)
c Distributed array to be used in the basic Arnoldi iteration
c for reverse communication. The user should not use WORKD
c as temporary workspace during the iteration !!!!!!!!!!
c See Data Distribution Note in CNAUPD.
c
c RWORK Real work array of length NEV+NP ( WORKSPACE)
c Private (replicated) array on each PE or array allocated on
c the front end.
c
c INFO Integer. (INPUT/OUTPUT)
c If INFO .EQ. 0, a randomly initial residual vector is used.
c If INFO .NE. 0, RESID contains the initial residual vector,
c possibly from a previous run.
c Error flag on output.
c = 0: Normal return.
c = 1: Maximum number of iterations taken.
c All possible eigenvalues of OP has been found.
c NP returns the number of converged Ritz values.
c = 2: No shifts could be applied.
c = -8: Error return from LAPACK eigenvalue calculation;
c This should never happen.
c = -9: Starting vector is zero.
c = -9999: Could not build an Arnoldi factorization.
c Size that was built in returned in NP.
c
c\EndDoc
c
c-----------------------------------------------------------------------
c
c\BeginLib
c
c\Local variables:
c xxxxxx Complex
c
c\References:
c 1. D.C. Sorensen, "Implicit Application of Polynomial Filters in
c a k-Step Arnoldi Method", SIAM J. Matr. Anal. Apps., 13 (1992),
c pp 357-385.
c 2. R.B. Lehoucq, "Analysis and Implementation of an Implicitly
c Restarted Arnoldi Iteration", Rice University Technical Report
c TR95-13, Department of Computational and Applied Mathematics.
c
c\Routines called:
c cgetv0 ARPACK initial vector generation routine.
c cnaitr ARPACK Arnoldi factorization routine.
c cnapps ARPACK application of implicit shifts routine.
c cneigh ARPACK compute Ritz values and error bounds routine.
c cngets ARPACK reorder Ritz values and error bounds routine.
c csortc ARPACK sorting routine.
c ivout ARPACK utility routine that prints integers.
c second ARPACK utility routine for timing.
c cmout ARPACK utility routine that prints matrices
c cvout ARPACK utility routine that prints vectors.
c svout ARPACK utility routine that prints vectors.
c slamch LAPACK routine that determines machine constants.
c slapy2 LAPACK routine to compute sqrt(x**2+y**2) carefully.
c ccopy Level 1 BLAS that copies one vector to another .
c cdotc Level 1 BLAS that computes the scalar product of two vectors.
c cswap Level 1 BLAS that swaps two vectors.
c scnrm2 Level 1 BLAS that computes the norm of a vector.
c
c\Author
c Danny Sorensen Phuong Vu
c Richard Lehoucq CRPC / Rice Universitya
c Chao Yang Houston, Texas
c Dept. of Computational &
c Applied Mathematics
c Rice University
c Houston, Texas
c
c\SCCS Information: @(#)
c FILE: naup2.F SID: 2.6 DATE OF SID: 06/01/00 RELEASE: 2
c
c\Remarks
c 1. None
c
c\EndLib
c
c-----------------------------------------------------------------------
c
subroutine cnaup2
& ( ido, bmat, n, which, nev, np, tol, resid, mode, iupd,
& ishift, mxiter, v, ldv, h, ldh, ritz, bounds,
& q, ldq, workl, ipntr, workd, rwork, info )
c
c %----------------------------------------------------%
c | Include files for debugging and timing information |
c %----------------------------------------------------%
c
include 'debug.h'
include 'stat.h'
c
c %------------------%
c | Scalar Arguments |
c %------------------%
c
character bmat*1, which*2
integer ido, info, ishift, iupd, mode, ldh, ldq, ldv, mxiter,
& n, nev, np
Real
& tol
c
c %-----------------%
c | Array Arguments |
c %-----------------%
c
integer ipntr(13)
Complex
& bounds(nev+np), h(ldh,nev+np), q(ldq,nev+np),
& resid(n), ritz(nev+np), v(ldv,nev+np),
& workd(3*n), workl( (nev+np)*(nev+np+3) )
Real
& rwork(nev+np)
c
c %------------%
c | Parameters |
c %------------%
c
Complex
& one, zero
Real
& rzero
parameter (one = (1.0E+0, 0.0E+0) , zero = (0.0E+0, 0.0E+0) ,
& rzero = 0.0E+0 )
c
c %---------------%
c | Local Scalars |
c %---------------%
c
logical cnorm , getv0, initv , update, ushift
integer ierr , iter , kplusp, msglvl, nconv,
& nevbef, nev0 , np0 , nptemp, i ,
& j
Complex
& cmpnorm
Real
& rnorm , eps23, rtemp
character wprime*2
c
save cnorm, getv0, initv , update, ushift,
& rnorm, iter , kplusp, msglvl, nconv ,
& nevbef, nev0 , np0 , eps23
c
c
c %-----------------------%
c | Local array arguments |
c %-----------------------%
c
integer kp(3)
c
c %----------------------%
c | External Subroutines |
c %----------------------%
c
external ccopy, cgetv0, cnaitr, cneigh, cngets, cnapps,
& csortc, cswap, cmout, cvout, ivout, second
c
c %--------------------%
c | External functions |
c %--------------------%
c
Complex
& cdotc
Real
& scnrm2, slamch, slapy2
external cdotc, scnrm2, slamch, slapy2
c
c %---------------------%
c | Intrinsic Functions |
c %---------------------%
c
intrinsic aimag, real , min, max
c
c %-----------------------%
c | Executable Statements |
c %-----------------------%
c
if (ido .eq. 0) then
c
call second (t0)
c
msglvl = mcaup2
c
nev0 = nev
np0 = np
c
c %-------------------------------------%
c | kplusp is the bound on the largest |
c | Lanczos factorization built. |
c | nconv is the current number of |
c | "converged" eigenvalues. |
c | iter is the counter on the current |
c | iteration step. |
c %-------------------------------------%
c
kplusp = nev + np
nconv = 0
iter = 0
c
c %---------------------------------%
c | Get machine dependent constant. |
c %---------------------------------%
c
eps23 = slamch('Epsilon-Machine')
eps23 = eps23**(2.0E+0 / 3.0E+0 )
c
c %---------------------------------------%
c | Set flags for computing the first NEV |
c | steps of the Arnoldi factorization. |
c %---------------------------------------%
c
getv0 = .true.
update = .false.
ushift = .false.
cnorm = .false.
c
if (info .ne. 0) then
c
c %--------------------------------------------%
c | User provides the initial residual vector. |
c %--------------------------------------------%
c
initv = .true.
info = 0
else
initv = .false.
end if
end if
c
c %---------------------------------------------%
c | Get a possibly random starting vector and |
c | force it into the range of the operator OP. |
c %---------------------------------------------%
c
10 continue
c
if (getv0) then
call cgetv0 (ido, bmat, 1, initv, n, 1, v, ldv, resid, rnorm,
& ipntr, workd, info)
c
if (ido .ne. 99) go to 9000
c
if (rnorm .eq. rzero) then
c
c %-----------------------------------------%
c | The initial vector is zero. Error exit. |
c %-----------------------------------------%
c
info = -9
go to 1100
end if
getv0 = .false.
ido = 0
end if
c
c %-----------------------------------%
c | Back from reverse communication : |
c | continue with update step |
c %-----------------------------------%
c
if (update) go to 20
c
c %-------------------------------------------%
c | Back from computing user specified shifts |
c %-------------------------------------------%
c
if (ushift) go to 50
c
c %-------------------------------------%
c | Back from computing residual norm |
c | at the end of the current iteration |
c %-------------------------------------%
c
if (cnorm) go to 100
c
c %----------------------------------------------------------%
c | Compute the first NEV steps of the Arnoldi factorization |
c %----------------------------------------------------------%
c
call cnaitr (ido, bmat, n, 0, nev, mode, resid, rnorm, v, ldv,
& h, ldh, ipntr, workd, info)
c
if (ido .ne. 99) go to 9000
c
if (info .gt. 0) then
np = info
mxiter = iter
info = -9999
go to 1200
end if
c
c %--------------------------------------------------------------%
c | |
c | M A I N ARNOLDI I T E R A T I O N L O O P |
c | Each iteration implicitly restarts the Arnoldi |
c | factorization in place. |
c | |
c %--------------------------------------------------------------%
c
1000 continue
c
iter = iter + 1
c
if (msglvl .gt. 0) then
call ivout (logfil, 1, iter, ndigit,
& '_naup2: **** Start of major iteration number ****')
end if
c
c %-----------------------------------------------------------%
c | Compute NP additional steps of the Arnoldi factorization. |
c | Adjust NP since NEV might have been updated by last call |
c | to the shift application routine cnapps. |
c %-----------------------------------------------------------%
c
np = kplusp - nev
c
if (msglvl .gt. 1) then
call ivout (logfil, 1, nev, ndigit,
& '_naup2: The length of the current Arnoldi factorization')
call ivout (logfil, 1, np, ndigit,
& '_naup2: Extend the Arnoldi factorization by')
end if
c
c %-----------------------------------------------------------%
c | Compute NP additional steps of the Arnoldi factorization. |
c %-----------------------------------------------------------%
c
ido = 0
20 continue
update = .true.
c
call cnaitr(ido, bmat, n, nev, np, mode, resid, rnorm,
& v , ldv , h, ldh, ipntr, workd, info)
c
if (ido .ne. 99) go to 9000
c
if (info .gt. 0) then
np = info
mxiter = iter
info = -9999
go to 1200
end if
update = .false.
c
if (msglvl .gt. 1) then
call svout (logfil, 1, rnorm, ndigit,
& '_naup2: Corresponding B-norm of the residual')
end if
c
c %--------------------------------------------------------%
c | Compute the eigenvalues and corresponding error bounds |
c | of the current upper Hessenberg matrix. |
c %--------------------------------------------------------%
c
call cneigh (rnorm, kplusp, h, ldh, ritz, bounds,
& q, ldq, workl, rwork, ierr)
c
if (ierr .ne. 0) then
info = -8
go to 1200
end if
c
c %---------------------------------------------------%
c | Select the wanted Ritz values and their bounds |
c | to be used in the convergence test. |
c | The wanted part of the spectrum and corresponding |
c | error bounds are in the last NEV loc. of RITZ, |
c | and BOUNDS respectively. |
c %---------------------------------------------------%
c
nev = nev0
np = np0
c
c %--------------------------------------------------%
c | Make a copy of Ritz values and the corresponding |
c | Ritz estimates obtained from cneigh. |
c %--------------------------------------------------%
c
call ccopy(kplusp,ritz,1,workl(kplusp**2+1),1)
call ccopy(kplusp,bounds,1,workl(kplusp**2+kplusp+1),1)
c
c %---------------------------------------------------%
c | Select the wanted Ritz values and their bounds |
c | to be used in the convergence test. |
c | The wanted part of the spectrum and corresponding |
c | bounds are in the last NEV loc. of RITZ |
c | BOUNDS respectively. |
c %---------------------------------------------------%
c
call cngets (ishift, which, nev, np, ritz, bounds)
c
c %------------------------------------------------------------%
c | Convergence test: currently we use the following criteria. |
c | The relative accuracy of a Ritz value is considered |
c | acceptable if: |
c | |
c | error_bounds(i) .le. tol*max(eps23, magnitude_of_ritz(i)). |
c | |
c %------------------------------------------------------------%
c
nconv = 0
c
do 25 i = 1, nev
rtemp = max( eps23, slapy2( real (ritz(np+i)),
& aimag(ritz(np+i)) ) )
if ( slapy2(real (bounds(np+i)),aimag(bounds(np+i)))
& .le. tol*rtemp ) then
nconv = nconv + 1
end if
25 continue
c
if (msglvl .gt. 2) then
kp(1) = nev
kp(2) = np
kp(3) = nconv
call ivout (logfil, 3, kp, ndigit,
& '_naup2: NEV, NP, NCONV are')
call cvout (logfil, kplusp, ritz, ndigit,
& '_naup2: The eigenvalues of H')
call cvout (logfil, kplusp, bounds, ndigit,
& '_naup2: Ritz estimates of the current NCV Ritz values')
end if
c
c %---------------------------------------------------------%
c | Count the number of unwanted Ritz values that have zero |
c | Ritz estimates. If any Ritz estimates are equal to zero |
c | then a leading block of H of order equal to at least |
c | the number of Ritz values with zero Ritz estimates has |
c | split off. None of these Ritz values may be removed by |
c | shifting. Decrease NP the number of shifts to apply. If |
c | no shifts may be applied, then prepare to exit |
c %---------------------------------------------------------%
c
nptemp = np
do 30 j=1, nptemp
if (bounds(j) .eq. zero) then
np = np - 1
nev = nev + 1
end if
30 continue
c
if ( (nconv .ge. nev0) .or.
& (iter .gt. mxiter) .or.
& (np .eq. 0) ) then
c
if (msglvl .gt. 4) then
call cvout(logfil, kplusp, workl(kplusp**2+1), ndigit,
& '_naup2: Eigenvalues computed by _neigh:')
call cvout(logfil, kplusp, workl(kplusp**2+kplusp+1),
& ndigit,
& '_naup2: Ritz estimates computed by _neigh:')
end if
c
c %------------------------------------------------%
c | Prepare to exit. Put the converged Ritz values |
c | and corresponding bounds in RITZ(1:NCONV) and |
c | BOUNDS(1:NCONV) respectively. Then sort. Be |
c | careful when NCONV > NP |
c %------------------------------------------------%
c
c %------------------------------------------%
c | Use h( 3,1 ) as storage to communicate |
c | rnorm to cneupd if needed |
c %------------------------------------------%
h(3,1) = cmplx(rnorm,rzero)
c
c %----------------------------------------------%
c | Sort Ritz values so that converged Ritz |
c | values appear within the first NEV locations |
c | of ritz and bounds, and the most desired one |
c | appears at the front. |
c %----------------------------------------------%
c
if (which .eq. 'LM') wprime = 'SM'
if (which .eq. 'SM') wprime = 'LM'
if (which .eq. 'LR') wprime = 'SR'
if (which .eq. 'SR') wprime = 'LR'
if (which .eq. 'LI') wprime = 'SI'
if (which .eq. 'SI') wprime = 'LI'
c
call csortc(wprime, .true., kplusp, ritz, bounds)
c
c %--------------------------------------------------%
c | Scale the Ritz estimate of each Ritz value |
c | by 1 / max(eps23, magnitude of the Ritz value). |
c %--------------------------------------------------%
c
do 35 j = 1, nev0
rtemp = max( eps23, slapy2( real (ritz(j)),
& aimag(ritz(j)) ) )
bounds(j) = bounds(j)/rtemp
35 continue
c
c %---------------------------------------------------%
c | Sort the Ritz values according to the scaled Ritz |
c | estimates. This will push all the converged ones |
c | towards the front of ritz, bounds (in the case |
c | when NCONV < NEV.) |
c %---------------------------------------------------%
c
wprime = 'LM'
call csortc(wprime, .true., nev0, bounds, ritz)
c
c %----------------------------------------------%
c | Scale the Ritz estimate back to its original |
c | value. |
c %----------------------------------------------%
c
do 40 j = 1, nev0
rtemp = max( eps23, slapy2( real (ritz(j)),
& aimag(ritz(j)) ) )
bounds(j) = bounds(j)*rtemp
40 continue
c
c %-----------------------------------------------%
c | Sort the converged Ritz values again so that |
c | the "threshold" value appears at the front of |
c | ritz and bound. |
c %-----------------------------------------------%
c
call csortc(which, .true., nconv, ritz, bounds)
c
if (msglvl .gt. 1) then
call cvout (logfil, kplusp, ritz, ndigit,
& '_naup2: Sorted eigenvalues')
call cvout (logfil, kplusp, bounds, ndigit,
& '_naup2: Sorted ritz estimates.')
end if
c
c %------------------------------------%
c | Max iterations have been exceeded. |
c %------------------------------------%
c
if (iter .gt. mxiter .and. nconv .lt. nev0) info = 1
c
c %---------------------%
c | No shifts to apply. |
c %---------------------%
c
if (np .eq. 0 .and. nconv .lt. nev0) info = 2
c
np = nconv
go to 1100
c
else if ( (nconv .lt. nev0) .and. (ishift .eq. 1) ) then
c
c %-------------------------------------------------%
c | Do not have all the requested eigenvalues yet. |
c | To prevent possible stagnation, adjust the size |
c | of NEV. |
c %-------------------------------------------------%
c
nevbef = nev
nev = nev + min(nconv, np/2)
if (nev .eq. 1 .and. kplusp .ge. 6) then
nev = kplusp / 2
else if (nev .eq. 1 .and. kplusp .gt. 3) then
nev = 2
end if
np = kplusp - nev
c
c %---------------------------------------%
c | If the size of NEV was just increased |
c | resort the eigenvalues. |
c %---------------------------------------%
c
if (nevbef .lt. nev)
& call cngets (ishift, which, nev, np, ritz, bounds)
c
end if
c
if (msglvl .gt. 0) then
call ivout (logfil, 1, nconv, ndigit,
& '_naup2: no. of "converged" Ritz values at this iter.')
if (msglvl .gt. 1) then
kp(1) = nev
kp(2) = np
call ivout (logfil, 2, kp, ndigit,
& '_naup2: NEV and NP are')
call cvout (logfil, nev, ritz(np+1), ndigit,
& '_naup2: "wanted" Ritz values ')
call cvout (logfil, nev, bounds(np+1), ndigit,
& '_naup2: Ritz estimates of the "wanted" values ')
end if
end if
c
if (ishift .eq. 0) then
c
c %-------------------------------------------------------%
c | User specified shifts: pop back out to get the shifts |
c | and return them in the first 2*NP locations of WORKL. |
c %-------------------------------------------------------%
c
ushift = .true.
ido = 3
go to 9000
end if
50 continue
ushift = .false.
c
if ( ishift .ne. 1 ) then
c
c %----------------------------------%
c | Move the NP shifts from WORKL to |
c | RITZ, to free up WORKL |
c | for non-exact shift case. |
c %----------------------------------%
c
call ccopy (np, workl, 1, ritz, 1)
end if
c
if (msglvl .gt. 2) then
call ivout (logfil, 1, np, ndigit,
& '_naup2: The number of shifts to apply ')
call cvout (logfil, np, ritz, ndigit,
& '_naup2: values of the shifts')
if ( ishift .eq. 1 )
& call cvout (logfil, np, bounds, ndigit,
& '_naup2: Ritz estimates of the shifts')
end if
c
c %---------------------------------------------------------%
c | Apply the NP implicit shifts by QR bulge chasing. |
c | Each shift is applied to the whole upper Hessenberg |
c | matrix H. |
c | The first 2*N locations of WORKD are used as workspace. |
c %---------------------------------------------------------%
c
call cnapps (n, nev, np, ritz, v, ldv,
& h, ldh, resid, q, ldq, workl, workd)
c
c %---------------------------------------------%
c | Compute the B-norm of the updated residual. |
c | Keep B*RESID in WORKD(1:N) to be used in |
c | the first step of the next call to cnaitr. |
c %---------------------------------------------%
c
cnorm = .true.
call second (t2)
if (bmat .eq. 'G') then
nbx = nbx + 1
call ccopy (n, resid, 1, workd(n+1), 1)
ipntr(1) = n + 1
ipntr(2) = 1
ido = 2
c
c %----------------------------------%
c | Exit in order to compute B*RESID |
c %----------------------------------%
c
go to 9000
else if (bmat .eq. 'I') then
call ccopy (n, resid, 1, workd, 1)
end if
c
100 continue
c
c %----------------------------------%
c | Back from reverse communication; |
c | WORKD(1:N) := B*RESID |
c %----------------------------------%
c
if (bmat .eq. 'G') then
call second (t3)
tmvbx = tmvbx + (t3 - t2)
end if
c
if (bmat .eq. 'G') then
cmpnorm = cdotc (n, resid, 1, workd, 1)
rnorm = sqrt(slapy2(real (cmpnorm),aimag(cmpnorm)))
else if (bmat .eq. 'I') then
rnorm = scnrm2(n, resid, 1)
end if
cnorm = .false.
c
if (msglvl .gt. 2) then
call svout (logfil, 1, rnorm, ndigit,
& '_naup2: B-norm of residual for compressed factorization')
call cmout (logfil, nev, nev, h, ldh, ndigit,
& '_naup2: Compressed upper Hessenberg matrix H')
end if
c
go to 1000
c
c %---------------------------------------------------------------%
c | |
c | E N D O F M A I N I T E R A T I O N L O O P |
c | |
c %---------------------------------------------------------------%
c
1100 continue
c
mxiter = iter
nev = nconv
c
1200 continue
ido = 99
c
c %------------%
c | Error Exit |
c %------------%
c
call second (t1)
tcaup2 = t1 - t0
c
9000 continue
c
c %---------------%
c | End of cnaup2 |
c %---------------%
c
return
end

664
arpack/ARPACK/SRC/cnaupd.f Normal file
View File

@@ -0,0 +1,664 @@
c\BeginDoc
c
c\Name: cnaupd
c
c\Description:
c Reverse communication interface for the Implicitly Restarted Arnoldi
c iteration. This is intended to be used to find a few eigenpairs of a
c complex linear operator OP with respect to a semi-inner product defined
c by a hermitian positive semi-definite real matrix B. B may be the identity
c matrix. NOTE: if both OP and B are real, then ssaupd or snaupd should
c be used.
c
c
c The computed approximate eigenvalues are called Ritz values and
c the corresponding approximate eigenvectors are called Ritz vectors.
c
c cnaupd is usually called iteratively to solve one of the
c following problems:
c
c Mode 1: A*x = lambda*x.
c ===> OP = A and B = I.
c
c Mode 2: A*x = lambda*M*x, M hermitian positive definite
c ===> OP = inv[M]*A and B = M.
c ===> (If M can be factored see remark 3 below)
c
c Mode 3: A*x = lambda*M*x, M hermitian semi-definite
c ===> OP = inv[A - sigma*M]*M and B = M.
c ===> shift-and-invert mode
c If OP*x = amu*x, then lambda = sigma + 1/amu.
c
c
c NOTE: The action of w <- inv[A - sigma*M]*v or w <- inv[M]*v
c should be accomplished either by a direct method
c using a sparse matrix factorization and solving
c
c [A - sigma*M]*w = v or M*w = v,
c
c or through an iterative method for solving these
c systems. If an iterative method is used, the
c convergence test must be more stringent than
c the accuracy requirements for the eigenvalue
c approximations.
c
c\Usage:
c call cnaupd
c ( IDO, BMAT, N, WHICH, NEV, TOL, RESID, NCV, V, LDV, IPARAM,
c IPNTR, WORKD, WORKL, LWORKL, RWORK, INFO )
c
c\Arguments
c IDO Integer. (INPUT/OUTPUT)
c Reverse communication flag. IDO must be zero on the first
c call to cnaupd. IDO will be set internally to
c indicate the type of operation to be performed. Control is
c then given back to the calling routine which has the
c responsibility to carry out the requested operation and call
c cnaupd with the result. The operand is given in
c WORKD(IPNTR(1)), the result must be put in WORKD(IPNTR(2)).
c -------------------------------------------------------------
c IDO = 0: first call to the reverse communication interface
c IDO = -1: compute Y = OP * X where
c IPNTR(1) is the pointer into WORKD for X,
c IPNTR(2) is the pointer into WORKD for Y.
c This is for the initialization phase to force the
c starting vector into the range of OP.
c IDO = 1: compute Y = OP * X where
c IPNTR(1) is the pointer into WORKD for X,
c IPNTR(2) is the pointer into WORKD for Y.
c In mode 3, the vector B * X is already
c available in WORKD(ipntr(3)). It does not
c need to be recomputed in forming OP * X.
c IDO = 2: compute Y = M * X where
c IPNTR(1) is the pointer into WORKD for X,
c IPNTR(2) is the pointer into WORKD for Y.
c IDO = 3: compute and return the shifts in the first
c NP locations of WORKL.
c IDO = 99: done
c -------------------------------------------------------------
c After the initialization phase, when the routine is used in
c the "shift-and-invert" mode, the vector M * X is already
c available and does not need to be recomputed in forming OP*X.
c
c BMAT Character*1. (INPUT)
c BMAT specifies the type of the matrix B that defines the
c semi-inner product for the operator OP.
c BMAT = 'I' -> standard eigenvalue problem A*x = lambda*x
c BMAT = 'G' -> generalized eigenvalue problem A*x = lambda*M*x
c
c N Integer. (INPUT)
c Dimension of the eigenproblem.
c
c WHICH Character*2. (INPUT)
c 'LM' -> want the NEV eigenvalues of largest magnitude.
c 'SM' -> want the NEV eigenvalues of smallest magnitude.
c 'LR' -> want the NEV eigenvalues of largest real part.
c 'SR' -> want the NEV eigenvalues of smallest real part.
c 'LI' -> want the NEV eigenvalues of largest imaginary part.
c 'SI' -> want the NEV eigenvalues of smallest imaginary part.
c
c NEV Integer. (INPUT)
c Number of eigenvalues of OP to be computed. 0 < NEV < N-1.
c
c TOL Real scalar. (INPUT)
c Stopping criteria: the relative accuracy of the Ritz value
c is considered acceptable if BOUNDS(I) .LE. TOL*ABS(RITZ(I))
c where ABS(RITZ(I)) is the magnitude when RITZ(I) is complex.
c DEFAULT = slamch('EPS') (machine precision as computed
c by the LAPACK auxiliary subroutine slamch).
c
c RESID Complex array of length N. (INPUT/OUTPUT)
c On INPUT:
c If INFO .EQ. 0, a random initial residual vector is used.
c If INFO .NE. 0, RESID contains the initial residual vector,
c possibly from a previous run.
c On OUTPUT:
c RESID contains the final residual vector.
c
c NCV Integer. (INPUT)
c Number of columns of the matrix V. NCV must satisfy the two
c inequalities 1 <= NCV-NEV and NCV <= N.
c This will indicate how many Arnoldi vectors are generated
c at each iteration. After the startup phase in which NEV
c Arnoldi vectors are generated, the algorithm generates
c approximately NCV-NEV Arnoldi vectors at each subsequent update
c iteration. Most of the cost in generating each Arnoldi vector is
c in the matrix-vector operation OP*x. (See remark 4 below.)
c
c V Complex array N by NCV. (OUTPUT)
c Contains the final set of Arnoldi basis vectors.
c
c LDV Integer. (INPUT)
c Leading dimension of V exactly as declared in the calling program.
c
c IPARAM Integer array of length 11. (INPUT/OUTPUT)
c IPARAM(1) = ISHIFT: method for selecting the implicit shifts.
c The shifts selected at each iteration are used to filter out
c the components of the unwanted eigenvector.
c -------------------------------------------------------------
c ISHIFT = 0: the shifts are to be provided by the user via
c reverse communication. The NCV eigenvalues of
c the Hessenberg matrix H are returned in the part
c of WORKL array corresponding to RITZ.
c ISHIFT = 1: exact shifts with respect to the current
c Hessenberg matrix H. This is equivalent to
c restarting the iteration from the beginning
c after updating the starting vector with a linear
c combination of Ritz vectors associated with the
c "wanted" eigenvalues.
c ISHIFT = 2: other choice of internal shift to be defined.
c -------------------------------------------------------------
c
c IPARAM(2) = No longer referenced
c
c IPARAM(3) = MXITER
c On INPUT: maximum number of Arnoldi update iterations allowed.
c On OUTPUT: actual number of Arnoldi update iterations taken.
c
c IPARAM(4) = NB: blocksize to be used in the recurrence.
c The code currently works only for NB = 1.
c
c IPARAM(5) = NCONV: number of "converged" Ritz values.
c This represents the number of Ritz values that satisfy
c the convergence criterion.
c
c IPARAM(6) = IUPD
c No longer referenced. Implicit restarting is ALWAYS used.
c
c IPARAM(7) = MODE
c On INPUT determines what type of eigenproblem is being solved.
c Must be 1,2,3; See under \Description of cnaupd for the
c four modes available.
c
c IPARAM(8) = NP
c When ido = 3 and the user provides shifts through reverse
c communication (IPARAM(1)=0), _naupd returns NP, the number
c of shifts the user is to provide. 0 < NP < NCV-NEV.
c
c IPARAM(9) = NUMOP, IPARAM(10) = NUMOPB, IPARAM(11) = NUMREO,
c OUTPUT: NUMOP = total number of OP*x operations,
c NUMOPB = total number of B*x operations if BMAT='G',
c NUMREO = total number of steps of re-orthogonalization.
c
c IPNTR Integer array of length 14. (OUTPUT)
c Pointer to mark the starting locations in the WORKD and WORKL
c arrays for matrices/vectors used by the Arnoldi iteration.
c -------------------------------------------------------------
c IPNTR(1): pointer to the current operand vector X in WORKD.
c IPNTR(2): pointer to the current result vector Y in WORKD.
c IPNTR(3): pointer to the vector B * X in WORKD when used in
c the shift-and-invert mode.
c IPNTR(4): pointer to the next available location in WORKL
c that is untouched by the program.
c IPNTR(5): pointer to the NCV by NCV upper Hessenberg
c matrix H in WORKL.
c IPNTR(6): pointer to the ritz value array RITZ
c IPNTR(7): pointer to the (projected) ritz vector array Q
c IPNTR(8): pointer to the error BOUNDS array in WORKL.
c IPNTR(14): pointer to the NP shifts in WORKL. See Remark 5 below.
c
c Note: IPNTR(9:13) is only referenced by cneupd. See Remark 2 below.
c
c IPNTR(9): pointer to the NCV RITZ values of the
c original system.
c IPNTR(10): Not Used
c IPNTR(11): pointer to the NCV corresponding error bounds.
c IPNTR(12): pointer to the NCV by NCV upper triangular
c Schur matrix for H.
c IPNTR(13): pointer to the NCV by NCV matrix of eigenvectors
c of the upper Hessenberg matrix H. Only referenced by
c cneupd if RVEC = .TRUE. See Remark 2 below.
c
c -------------------------------------------------------------
c
c WORKD Complex work array of length 3*N. (REVERSE COMMUNICATION)
c Distributed array to be used in the basic Arnoldi iteration
c for reverse communication. The user should not use WORKD
c as temporary workspace during the iteration !!!!!!!!!!
c See Data Distribution Note below.
c
c WORKL Complex work array of length LWORKL. (OUTPUT/WORKSPACE)
c Private (replicated) array on each PE or array allocated on
c the front end. See Data Distribution Note below.
c
c LWORKL Integer. (INPUT)
c LWORKL must be at least 3*NCV**2 + 5*NCV.
c
c RWORK Real work array of length NCV (WORKSPACE)
c Private (replicated) array on each PE or array allocated on
c the front end.
c
c
c INFO Integer. (INPUT/OUTPUT)
c If INFO .EQ. 0, a randomly initial residual vector is used.
c If INFO .NE. 0, RESID contains the initial residual vector,
c possibly from a previous run.
c Error flag on output.
c = 0: Normal exit.
c = 1: Maximum number of iterations taken.
c All possible eigenvalues of OP has been found. IPARAM(5)
c returns the number of wanted converged Ritz values.
c = 2: No longer an informational error. Deprecated starting
c with release 2 of ARPACK.
c = 3: No shifts could be applied during a cycle of the
c Implicitly restarted Arnoldi iteration. One possibility
c is to increase the size of NCV relative to NEV.
c See remark 4 below.
c = -1: N must be positive.
c = -2: NEV must be positive.
c = -3: NCV-NEV >= 1 and less than or equal to N.
c = -4: The maximum number of Arnoldi update iteration
c must be greater than zero.
c = -5: WHICH must be one of 'LM', 'SM', 'LR', 'SR', 'LI', 'SI'
c = -6: BMAT must be one of 'I' or 'G'.
c = -7: Length of private work array is not sufficient.
c = -8: Error return from LAPACK eigenvalue calculation;
c = -9: Starting vector is zero.
c = -10: IPARAM(7) must be 1,2,3.
c = -11: IPARAM(7) = 1 and BMAT = 'G' are incompatible.
c = -12: IPARAM(1) must be equal to 0 or 1.
c = -9999: Could not build an Arnoldi factorization.
c User input error highly likely. Please
c check actual array dimensions and layout.
c IPARAM(5) returns the size of the current Arnoldi
c factorization.
c
c\Remarks
c 1. The computed Ritz values are approximate eigenvalues of OP. The
c selection of WHICH should be made with this in mind when using
c Mode = 3. When operating in Mode = 3 setting WHICH = 'LM' will
c compute the NEV eigenvalues of the original problem that are
c closest to the shift SIGMA . After convergence, approximate eigenvalues
c of the original problem may be obtained with the ARPACK subroutine cneupd.
c
c 2. If a basis for the invariant subspace corresponding to the converged Ritz
c values is needed, the user must call cneupd immediately following
c completion of cnaupd. This is new starting with release 2 of ARPACK.
c
c 3. If M can be factored into a Cholesky factorization M = LL`
c then Mode = 2 should not be selected. Instead one should use
c Mode = 1 with OP = inv(L)*A*inv(L`). Appropriate triangular
c linear systems should be solved with L and L` rather
c than computing inverses. After convergence, an approximate
c eigenvector z of the original problem is recovered by solving
c L`z = x where x is a Ritz vector of OP.
c
c 4. At present there is no a-priori analysis to guide the selection
c of NCV relative to NEV. The only formal requirement is that NCV > NEV + 1.
c However, it is recommended that NCV .ge. 2*NEV. If many problems of
c the same type are to be solved, one should experiment with increasing
c NCV while keeping NEV fixed for a given test problem. This will
c usually decrease the required number of OP*x operations but it
c also increases the work and storage required to maintain the orthogonal
c basis vectors. The optimal "cross-over" with respect to CPU time
c is problem dependent and must be determined empirically.
c See Chapter 8 of Reference 2 for further information.
c
c 5. When IPARAM(1) = 0, and IDO = 3, the user needs to provide the
c NP = IPARAM(8) complex shifts in locations
c WORKL(IPNTR(14)), WORKL(IPNTR(14)+1), ... , WORKL(IPNTR(14)+NP).
c Eigenvalues of the current upper Hessenberg matrix are located in
c WORKL(IPNTR(6)) through WORKL(IPNTR(6)+NCV-1). They are ordered
c according to the order defined by WHICH. The associated Ritz estimates
c are located in WORKL(IPNTR(8)), WORKL(IPNTR(8)+1), ... ,
c WORKL(IPNTR(8)+NCV-1).
c
c-----------------------------------------------------------------------
c
c\Data Distribution Note:
c
c Fortran-D syntax:
c ================
c Complex resid(n), v(ldv,ncv), workd(3*n), workl(lworkl)
c decompose d1(n), d2(n,ncv)
c align resid(i) with d1(i)
c align v(i,j) with d2(i,j)
c align workd(i) with d1(i) range (1:n)
c align workd(i) with d1(i-n) range (n+1:2*n)
c align workd(i) with d1(i-2*n) range (2*n+1:3*n)
c distribute d1(block), d2(block,:)
c replicated workl(lworkl)
c
c Cray MPP syntax:
c ===============
c Complex resid(n), v(ldv,ncv), workd(n,3), workl(lworkl)
c shared resid(block), v(block,:), workd(block,:)
c replicated workl(lworkl)
c
c CM2/CM5 syntax:
c ==============
c
c-----------------------------------------------------------------------
c
c include 'ex-nonsym.doc'
c
c-----------------------------------------------------------------------
c
c\BeginLib
c
c\Local variables:
c xxxxxx Complex
c
c\References:
c 1. D.C. Sorensen, "Implicit Application of Polynomial Filters in
c a k-Step Arnoldi Method", SIAM J. Matr. Anal. Apps., 13 (1992),
c pp 357-385.
c 2. R.B. Lehoucq, "Analysis and Implementation of an Implicitly
c Restarted Arnoldi Iteration", Rice University Technical Report
c TR95-13, Department of Computational and Applied Mathematics.
c 3. B.N. Parlett & Y. Saad, "_Complex_ Shift and Invert Strategies for
c Real Matrices", Linear Algebra and its Applications, vol 88/89,
c pp 575-595, (1987).
c
c\Routines called:
c cnaup2 ARPACK routine that implements the Implicitly Restarted
c Arnoldi Iteration.
c cstatn ARPACK routine that initializes the timing variables.
c ivout ARPACK utility routine that prints integers.
c cvout ARPACK utility routine that prints vectors.
c second ARPACK utility routine for timing.
c slamch LAPACK routine that determines machine constants.
c
c\Author
c Danny Sorensen Phuong Vu
c Richard Lehoucq CRPC / Rice University
c Dept. of Computational & Houston, Texas
c Applied Mathematics
c Rice University
c Houston, Texas
c
c\SCCS Information: @(#)
c FILE: naupd.F SID: 2.9 DATE OF SID: 07/21/02 RELEASE: 2
c
c\Remarks
c
c\EndLib
c
c-----------------------------------------------------------------------
c
subroutine cnaupd
& ( ido, bmat, n, which, nev, tol, resid, ncv, v, ldv, iparam,
& ipntr, workd, workl, lworkl, rwork, info )
c
c %----------------------------------------------------%
c | Include files for debugging and timing information |
c %----------------------------------------------------%
c
include 'debug.h'
include 'stat.h'
c
c %------------------%
c | Scalar Arguments |
c %------------------%
c
character bmat*1, which*2
integer ido, info, ldv, lworkl, n, ncv, nev
Real
& tol
c
c %-----------------%
c | Array Arguments |
c %-----------------%
c
integer iparam(11), ipntr(14)
Complex
& resid(n), v(ldv,ncv), workd(3*n), workl(lworkl)
Real
& rwork(ncv)
c
c %------------%
c | Parameters |
c %------------%
c
Complex
& one, zero
parameter (one = (1.0E+0, 0.0E+0), zero = (0.0E+0, 0.0E+0))
c
c %---------------%
c | Local Scalars |
c %---------------%
c
integer bounds, ierr, ih, iq, ishift, iupd, iw,
& ldh, ldq, levec, mode, msglvl, mxiter, nb,
& nev0, next, np, ritz, j
save bounds, ih, iq, ishift, iupd, iw,
& ldh, ldq, levec, mode, msglvl, mxiter, nb,
& nev0, next, np, ritz
c
c %----------------------%
c | External Subroutines |
c %----------------------%
c
external cnaup2, cvout, ivout, second, cstatn
c
c %--------------------%
c | External Functions |
c %--------------------%
c
Real
& slamch
external slamch
c
c %-----------------------%
c | Executable Statements |
c %-----------------------%
c
if (ido .eq. 0) then
c
c %-------------------------------%
c | Initialize timing statistics |
c | & message level for debugging |
c %-------------------------------%
c
call cstatn
call second (t0)
msglvl = mcaupd
c
c %----------------%
c | Error checking |
c %----------------%
c
ierr = 0
ishift = iparam(1)
c levec = iparam(2)
mxiter = iparam(3)
c nb = iparam(4)
nb = 1
c
c %--------------------------------------------%
c | Revision 2 performs only implicit restart. |
c %--------------------------------------------%
c
iupd = 1
mode = iparam(7)
c
if (n .le. 0) then
ierr = -1
else if (nev .le. 0) then
ierr = -2
else if (ncv .le. nev .or. ncv .gt. n) then
ierr = -3
else if (mxiter .le. 0) then
ierr = -4
else if (which .ne. 'LM' .and.
& which .ne. 'SM' .and.
& which .ne. 'LR' .and.
& which .ne. 'SR' .and.
& which .ne. 'LI' .and.
& which .ne. 'SI') then
ierr = -5
else if (bmat .ne. 'I' .and. bmat .ne. 'G') then
ierr = -6
else if (lworkl .lt. 3*ncv**2 + 5*ncv) then
ierr = -7
else if (mode .lt. 1 .or. mode .gt. 3) then
ierr = -10
else if (mode .eq. 1 .and. bmat .eq. 'G') then
ierr = -11
end if
c
c %------------%
c | Error Exit |
c %------------%
c
if (ierr .ne. 0) then
info = ierr
ido = 99
go to 9000
end if
c
c %------------------------%
c | Set default parameters |
c %------------------------%
c
if (nb .le. 0) nb = 1
if (tol .le. 0.0E+0 ) tol = slamch('EpsMach')
if (ishift .ne. 0 .and.
& ishift .ne. 1 .and.
& ishift .ne. 2) ishift = 1
c
c %----------------------------------------------%
c | NP is the number of additional steps to |
c | extend the length NEV Lanczos factorization. |
c | NEV0 is the local variable designating the |
c | size of the invariant subspace desired. |
c %----------------------------------------------%
c
np = ncv - nev
nev0 = nev
c
c %-----------------------------%
c | Zero out internal workspace |
c %-----------------------------%
c
do 10 j = 1, 3*ncv**2 + 5*ncv
workl(j) = zero
10 continue
c
c %-------------------------------------------------------------%
c | Pointer into WORKL for address of H, RITZ, BOUNDS, Q |
c | etc... and the remaining workspace. |
c | Also update pointer to be used on output. |
c | Memory is laid out as follows: |
c | workl(1:ncv*ncv) := generated Hessenberg matrix |
c | workl(ncv*ncv+1:ncv*ncv+ncv) := the ritz values |
c | workl(ncv*ncv+ncv+1:ncv*ncv+2*ncv) := error bounds |
c | workl(ncv*ncv+2*ncv+1:2*ncv*ncv+2*ncv) := rotation matrix Q |
c | workl(2*ncv*ncv+2*ncv+1:3*ncv*ncv+5*ncv) := workspace |
c | The final workspace is needed by subroutine cneigh called |
c | by cnaup2. Subroutine cneigh calls LAPACK routines for |
c | calculating eigenvalues and the last row of the eigenvector |
c | matrix. |
c %-------------------------------------------------------------%
c
ldh = ncv
ldq = ncv
ih = 1
ritz = ih + ldh*ncv
bounds = ritz + ncv
iq = bounds + ncv
iw = iq + ldq*ncv
next = iw + ncv**2 + 3*ncv
c
ipntr(4) = next
ipntr(5) = ih
ipntr(6) = ritz
ipntr(7) = iq
ipntr(8) = bounds
ipntr(14) = iw
end if
c
c %-------------------------------------------------------%
c | Carry out the Implicitly restarted Arnoldi Iteration. |
c %-------------------------------------------------------%
c
call cnaup2
& ( ido, bmat, n, which, nev0, np, tol, resid, mode, iupd,
& ishift, mxiter, v, ldv, workl(ih), ldh, workl(ritz),
& workl(bounds), workl(iq), ldq, workl(iw),
& ipntr, workd, rwork, info )
c
c %--------------------------------------------------%
c | ido .ne. 99 implies use of reverse communication |
c | to compute operations involving OP. |
c %--------------------------------------------------%
c
if (ido .eq. 3) iparam(8) = np
if (ido .ne. 99) go to 9000
c
iparam(3) = mxiter
iparam(5) = np
iparam(9) = nopx
iparam(10) = nbx
iparam(11) = nrorth
c
c %------------------------------------%
c | Exit if there was an informational |
c | error within cnaup2. |
c %------------------------------------%
c
if (info .lt. 0) go to 9000
if (info .eq. 2) info = 3
c
if (msglvl .gt. 0) then
call ivout (logfil, 1, mxiter, ndigit,
& '_naupd: Number of update iterations taken')
call ivout (logfil, 1, np, ndigit,
& '_naupd: Number of wanted "converged" Ritz values')
call cvout (logfil, np, workl(ritz), ndigit,
& '_naupd: The final Ritz values')
call cvout (logfil, np, workl(bounds), ndigit,
& '_naupd: Associated Ritz estimates')
end if
c
call second (t1)
tcaupd = t1 - t0
c
if (msglvl .gt. 0) then
c
c %--------------------------------------------------------%
c | Version Number & Version Date are defined in version.h |
c %--------------------------------------------------------%
c
write (6,1000)
write (6,1100) mxiter, nopx, nbx, nrorth, nitref, nrstrt,
& tmvopx, tmvbx, tcaupd, tcaup2, tcaitr, titref,
& tgetv0, tceigh, tcgets, tcapps, tcconv, trvec
1000 format (//,
& 5x, '=============================================',/
& 5x, '= Complex implicit Arnoldi update code =',/
& 5x, '= Version Number: ', ' 2.3', 21x, ' =',/
& 5x, '= Version Date: ', ' 07/31/96', 16x, ' =',/
& 5x, '=============================================',/
& 5x, '= Summary of timing statistics =',/
& 5x, '=============================================',//)
1100 format (
& 5x, 'Total number update iterations = ', i5,/
& 5x, 'Total number of OP*x operations = ', i5,/
& 5x, 'Total number of B*x operations = ', i5,/
& 5x, 'Total number of reorthogonalization steps = ', i5,/
& 5x, 'Total number of iterative refinement steps = ', i5,/
& 5x, 'Total number of restart steps = ', i5,/
& 5x, 'Total time in user OP*x operation = ', f12.6,/
& 5x, 'Total time in user B*x operation = ', f12.6,/
& 5x, 'Total time in Arnoldi update routine = ', f12.6,/
& 5x, 'Total time in naup2 routine = ', f12.6,/
& 5x, 'Total time in basic Arnoldi iteration loop = ', f12.6,/
& 5x, 'Total time in reorthogonalization phase = ', f12.6,/
& 5x, 'Total time in (re)start vector generation = ', f12.6,/
& 5x, 'Total time in Hessenberg eig. subproblem = ', f12.6,/
& 5x, 'Total time in getting the shifts = ', f12.6,/
& 5x, 'Total time in applying the shifts = ', f12.6,/
& 5x, 'Total time in convergence testing = ', f12.6,/
& 5x, 'Total time in computing final Ritz vectors = ', f12.6/)
end if
c
9000 continue
c
return
c
c %---------------%
c | End of cnaupd |
c %---------------%
c
end

257
arpack/ARPACK/SRC/cneigh.f Normal file
View File

@@ -0,0 +1,257 @@
c\BeginDoc
c
c\Name: cneigh
c
c\Description:
c Compute the eigenvalues of the current upper Hessenberg matrix
c and the corresponding Ritz estimates given the current residual norm.
c
c\Usage:
c call cneigh
c ( RNORM, N, H, LDH, RITZ, BOUNDS, Q, LDQ, WORKL, RWORK, IERR )
c
c\Arguments
c RNORM Real scalar. (INPUT)
c Residual norm corresponding to the current upper Hessenberg
c matrix H.
c
c N Integer. (INPUT)
c Size of the matrix H.
c
c H Complex N by N array. (INPUT)
c H contains the current upper Hessenberg matrix.
c
c LDH Integer. (INPUT)
c Leading dimension of H exactly as declared in the calling
c program.
c
c RITZ Complex array of length N. (OUTPUT)
c On output, RITZ(1:N) contains the eigenvalues of H.
c
c BOUNDS Complex array of length N. (OUTPUT)
c On output, BOUNDS contains the Ritz estimates associated with
c the eigenvalues held in RITZ. This is equal to RNORM
c times the last components of the eigenvectors corresponding
c to the eigenvalues in RITZ.
c
c Q Complex N by N array. (WORKSPACE)
c Workspace needed to store the eigenvectors of H.
c
c LDQ Integer. (INPUT)
c Leading dimension of Q exactly as declared in the calling
c program.
c
c WORKL Complex work array of length N**2 + 3*N. (WORKSPACE)
c Private (replicated) array on each PE or array allocated on
c the front end. This is needed to keep the full Schur form
c of H and also in the calculation of the eigenvectors of H.
c
c RWORK Real work array of length N (WORKSPACE)
c Private (replicated) array on each PE or array allocated on
c the front end.
c
c IERR Integer. (OUTPUT)
c Error exit flag from clahqr or ctrevc.
c
c\EndDoc
c
c-----------------------------------------------------------------------
c
c\BeginLib
c
c\Local variables:
c xxxxxx Complex
c
c\Routines called:
c ivout ARPACK utility routine that prints integers.
c second ARPACK utility routine for timing.
c cmout ARPACK utility routine that prints matrices
c cvout ARPACK utility routine that prints vectors.
c svout ARPACK utility routine that prints vectors.
c clacpy LAPACK matrix copy routine.
c clahqr LAPACK routine to compute the Schur form of an
c upper Hessenberg matrix.
c claset LAPACK matrix initialization routine.
c ctrevc LAPACK routine to compute the eigenvectors of a matrix
c in upper triangular form
c ccopy Level 1 BLAS that copies one vector to another.
c csscal Level 1 BLAS that scales a complex vector by a real number.
c scnrm2 Level 1 BLAS that computes the norm of a vector.
c
c
c\Author
c Danny Sorensen Phuong Vu
c Richard Lehoucq CRPC / Rice University
c Dept. of Computational & Houston, Texas
c Applied Mathematics
c Rice University
c Houston, Texas
c
c\SCCS Information: @(#)
c FILE: neigh.F SID: 2.2 DATE OF SID: 4/20/96 RELEASE: 2
c
c\Remarks
c None
c
c\EndLib
c
c-----------------------------------------------------------------------
c
subroutine cneigh (rnorm, n, h, ldh, ritz, bounds,
& q, ldq, workl, rwork, ierr)
c
c %----------------------------------------------------%
c | Include files for debugging and timing information |
c %----------------------------------------------------%
c
include 'debug.h'
include 'stat.h'
c
c %------------------%
c | Scalar Arguments |
c %------------------%
c
integer ierr, n, ldh, ldq
Real
& rnorm
c
c %-----------------%
c | Array Arguments |
c %-----------------%
c
Complex
& bounds(n), h(ldh,n), q(ldq,n), ritz(n),
& workl(n*(n+3))
Real
& rwork(n)
c
c %------------%
c | Parameters |
c %------------%
c
Complex
& one, zero
Real
& rone
parameter (one = (1.0E+0, 0.0E+0), zero = (0.0E+0, 0.0E+0),
& rone = 1.0E+0)
c
c %------------------------%
c | Local Scalars & Arrays |
c %------------------------%
c
logical select(1)
integer j, msglvl
Complex
& vl(1)
Real
& temp
c
c %----------------------%
c | External Subroutines |
c %----------------------%
c
external clacpy, clahqr, ctrevc, ccopy,
& csscal, cmout, cvout, second
c
c %--------------------%
c | External Functions |
c %--------------------%
c
Real
& scnrm2
external scnrm2
c
c %-----------------------%
c | Executable Statements |
c %-----------------------%
c
c %-------------------------------%
c | Initialize timing statistics |
c | & message level for debugging |
c %-------------------------------%
c
call second (t0)
msglvl = mceigh
c
if (msglvl .gt. 2) then
call cmout (logfil, n, n, h, ldh, ndigit,
& '_neigh: Entering upper Hessenberg matrix H ')
end if
c
c %----------------------------------------------------------%
c | 1. Compute the eigenvalues, the last components of the |
c | corresponding Schur vectors and the full Schur form T |
c | of the current upper Hessenberg matrix H. |
c | clahqr returns the full Schur form of H |
c | in WORKL(1:N**2), and the Schur vectors in q. |
c %----------------------------------------------------------%
c
call clacpy ('All', n, n, h, ldh, workl, n)
call claset ('All', n, n, zero, one, q, ldq)
call clahqr (.true., .true., n, 1, n, workl, ldh, ritz,
& 1, n, q, ldq, ierr)
if (ierr .ne. 0) go to 9000
c
call ccopy (n, q(n-1,1), ldq, bounds, 1)
if (msglvl .gt. 1) then
call cvout (logfil, n, bounds, ndigit,
& '_neigh: last row of the Schur matrix for H')
end if
c
c %----------------------------------------------------------%
c | 2. Compute the eigenvectors of the full Schur form T and |
c | apply the Schur vectors to get the corresponding |
c | eigenvectors. |
c %----------------------------------------------------------%
c
call ctrevc ('Right', 'Back', select, n, workl, n, vl, n, q,
& ldq, n, n, workl(n*n+1), rwork, ierr)
c
if (ierr .ne. 0) go to 9000
c
c %------------------------------------------------%
c | Scale the returning eigenvectors so that their |
c | Euclidean norms are all one. LAPACK subroutine |
c | ctrevc returns each eigenvector normalized so |
c | that the element of largest magnitude has |
c | magnitude 1; here the magnitude of a complex |
c | number (x,y) is taken to be |x| + |y|. |
c %------------------------------------------------%
c
do 10 j=1, n
temp = scnrm2( n, q(1,j), 1 )
call csscal ( n, rone / temp, q(1,j), 1 )
10 continue
c
if (msglvl .gt. 1) then
call ccopy(n, q(n,1), ldq, workl, 1)
call cvout (logfil, n, workl, ndigit,
& '_neigh: Last row of the eigenvector matrix for H')
end if
c
c %----------------------------%
c | Compute the Ritz estimates |
c %----------------------------%
c
call ccopy(n, q(n,1), n, bounds, 1)
call csscal(n, rnorm, bounds, 1)
c
if (msglvl .gt. 2) then
call cvout (logfil, n, ritz, ndigit,
& '_neigh: The eigenvalues of H')
call cvout (logfil, n, bounds, ndigit,
& '_neigh: Ritz estimates for the eigenvalues of H')
end if
c
call second(t1)
tceigh = tceigh + (t1 - t0)
c
9000 continue
return
c
c %---------------%
c | End of cneigh |
c %---------------%
c
end

872
arpack/ARPACK/SRC/cneupd.f Normal file
View File

@@ -0,0 +1,872 @@
c\BeginDoc
c
c\Name: cneupd
c
c\Description:
c This subroutine returns the converged approximations to eigenvalues
c of A*z = lambda*B*z and (optionally):
c
c (1) The corresponding approximate eigenvectors;
c
c (2) An orthonormal basis for the associated approximate
c invariant subspace;
c
c (3) Both.
c
c There is negligible additional cost to obtain eigenvectors. An orthonormal
c basis is always computed. There is an additional storage cost of n*nev
c if both are requested (in this case a separate array Z must be supplied).
c
c The approximate eigenvalues and eigenvectors of A*z = lambda*B*z
c are derived from approximate eigenvalues and eigenvectors of
c of the linear operator OP prescribed by the MODE selection in the
c call to CNAUPD. CNAUPD must be called before this routine is called.
c These approximate eigenvalues and vectors are commonly called Ritz
c values and Ritz vectors respectively. They are referred to as such
c in the comments that follow. The computed orthonormal basis for the
c invariant subspace corresponding to these Ritz values is referred to as a
c Schur basis.
c
c The definition of OP as well as other terms and the relation of computed
c Ritz values and vectors of OP with respect to the given problem
c A*z = lambda*B*z may be found in the header of CNAUPD. For a brief
c description, see definitions of IPARAM(7), MODE and WHICH in the
c documentation of CNAUPD.
c
c\Usage:
c call cneupd
c ( RVEC, HOWMNY, SELECT, D, Z, LDZ, SIGMA, WORKEV, BMAT,
c N, WHICH, NEV, TOL, RESID, NCV, V, LDV, IPARAM, IPNTR, WORKD,
c WORKL, LWORKL, RWORK, INFO )
c
c\Arguments:
c RVEC LOGICAL (INPUT)
c Specifies whether a basis for the invariant subspace corresponding
c to the converged Ritz value approximations for the eigenproblem
c A*z = lambda*B*z is computed.
c
c RVEC = .FALSE. Compute Ritz values only.
c
c RVEC = .TRUE. Compute Ritz vectors or Schur vectors.
c See Remarks below.
c
c HOWMNY Character*1 (INPUT)
c Specifies the form of the basis for the invariant subspace
c corresponding to the converged Ritz values that is to be computed.
c
c = 'A': Compute NEV Ritz vectors;
c = 'P': Compute NEV Schur vectors;
c = 'S': compute some of the Ritz vectors, specified
c by the logical array SELECT.
c
c SELECT Logical array of dimension NCV. (INPUT)
c If HOWMNY = 'S', SELECT specifies the Ritz vectors to be
c computed. To select the Ritz vector corresponding to a
c Ritz value D(j), SELECT(j) must be set to .TRUE..
c If HOWMNY = 'A' or 'P', SELECT need not be initialized
c but it is used as internal workspace.
c
c D Complex array of dimension NEV+1. (OUTPUT)
c On exit, D contains the Ritz approximations
c to the eigenvalues lambda for A*z = lambda*B*z.
c
c Z Complex N by NEV array (OUTPUT)
c On exit, if RVEC = .TRUE. and HOWMNY = 'A', then the columns of
c Z represents approximate eigenvectors (Ritz vectors) corresponding
c to the NCONV=IPARAM(5) Ritz values for eigensystem
c A*z = lambda*B*z.
c
c If RVEC = .FALSE. or HOWMNY = 'P', then Z is NOT REFERENCED.
c
c NOTE: If if RVEC = .TRUE. and a Schur basis is not required,
c the array Z may be set equal to first NEV+1 columns of the Arnoldi
c basis array V computed by CNAUPD. In this case the Arnoldi basis
c will be destroyed and overwritten with the eigenvector basis.
c
c LDZ Integer. (INPUT)
c The leading dimension of the array Z. If Ritz vectors are
c desired, then LDZ .ge. max( 1, N ) is required.
c In any case, LDZ .ge. 1 is required.
c
c SIGMA Complex (INPUT)
c If IPARAM(7) = 3 then SIGMA represents the shift.
c Not referenced if IPARAM(7) = 1 or 2.
c
c WORKEV Complex work array of dimension 2*NCV. (WORKSPACE)
c
c **** The remaining arguments MUST be the same as for the ****
c **** call to CNAUPD that was just completed. ****
c
c NOTE: The remaining arguments
c
c BMAT, N, WHICH, NEV, TOL, RESID, NCV, V, LDV, IPARAM, IPNTR,
c WORKD, WORKL, LWORKL, RWORK, INFO
c
c must be passed directly to CNEUPD following the last call
c to CNAUPD. These arguments MUST NOT BE MODIFIED between
c the the last call to CNAUPD and the call to CNEUPD.
c
c Three of these parameters (V, WORKL and INFO) are also output parameters:
c
c V Complex N by NCV array. (INPUT/OUTPUT)
c
c Upon INPUT: the NCV columns of V contain the Arnoldi basis
c vectors for OP as constructed by CNAUPD .
c
c Upon OUTPUT: If RVEC = .TRUE. the first NCONV=IPARAM(5) columns
c contain approximate Schur vectors that span the
c desired invariant subspace.
c
c NOTE: If the array Z has been set equal to first NEV+1 columns
c of the array V and RVEC=.TRUE. and HOWMNY= 'A', then the
c Arnoldi basis held by V has been overwritten by the desired
c Ritz vectors. If a separate array Z has been passed then
c the first NCONV=IPARAM(5) columns of V will contain approximate
c Schur vectors that span the desired invariant subspace.
c
c WORKL Real work array of length LWORKL. (OUTPUT/WORKSPACE)
c WORKL(1:ncv*ncv+2*ncv) contains information obtained in
c cnaupd. They are not changed by cneupd.
c WORKL(ncv*ncv+2*ncv+1:3*ncv*ncv+4*ncv) holds the
c untransformed Ritz values, the untransformed error estimates of
c the Ritz values, the upper triangular matrix for H, and the
c associated matrix representation of the invariant subspace for H.
c
c Note: IPNTR(9:13) contains the pointer into WORKL for addresses
c of the above information computed by cneupd.
c -------------------------------------------------------------
c IPNTR(9): pointer to the NCV RITZ values of the
c original system.
c IPNTR(10): Not used
c IPNTR(11): pointer to the NCV corresponding error estimates.
c IPNTR(12): pointer to the NCV by NCV upper triangular
c Schur matrix for H.
c IPNTR(13): pointer to the NCV by NCV matrix of eigenvectors
c of the upper Hessenberg matrix H. Only referenced by
c cneupd if RVEC = .TRUE. See Remark 2 below.
c -------------------------------------------------------------
c
c INFO Integer. (OUTPUT)
c Error flag on output.
c = 0: Normal exit.
c
c = 1: The Schur form computed by LAPACK routine csheqr
c could not be reordered by LAPACK routine ctrsen.
c Re-enter subroutine cneupd with IPARAM(5)=NCV and
c increase the size of the array D to have
c dimension at least dimension NCV and allocate at least NCV
c columns for Z. NOTE: Not necessary if Z and V share
c the same space. Please notify the authors if this error
c occurs.
c
c = -1: N must be positive.
c = -2: NEV must be positive.
c = -3: NCV-NEV >= 1 and less than or equal to N.
c = -5: WHICH must be one of 'LM', 'SM', 'LR', 'SR', 'LI', 'SI'
c = -6: BMAT must be one of 'I' or 'G'.
c = -7: Length of private work WORKL array is not sufficient.
c = -8: Error return from LAPACK eigenvalue calculation.
c This should never happened.
c = -9: Error return from calculation of eigenvectors.
c Informational error from LAPACK routine ctrevc.
c = -10: IPARAM(7) must be 1,2,3
c = -11: IPARAM(7) = 1 and BMAT = 'G' are incompatible.
c = -12: HOWMNY = 'S' not yet implemented
c = -13: HOWMNY must be one of 'A' or 'P' if RVEC = .true.
c = -14: CNAUPD did not find any eigenvalues to sufficient
c accuracy.
c = -15: CNEUPD got a different count of the number of converged
c Ritz values than CNAUPD got. This indicates the user
c probably made an error in passing data from CNAUPD to
c CNEUPD or that the data was modified before entering
c CNEUPD
c
c\BeginLib
c
c\References:
c 1. D.C. Sorensen, "Implicit Application of Polynomial Filters in
c a k-Step Arnoldi Method", SIAM J. Matr. Anal. Apps., 13 (1992),
c pp 357-385.
c 2. R.B. Lehoucq, "Analysis and Implementation of an Implicitly
c Restarted Arnoldi Iteration", Rice University Technical Report
c TR95-13, Department of Computational and Applied Mathematics.
c 3. B. Nour-Omid, B. N. Parlett, T. Ericsson and P. S. Jensen,
c "How to Implement the Spectral Transformation", Math Comp.,
c Vol. 48, No. 178, April, 1987 pp. 664-673.
c
c\Routines called:
c ivout ARPACK utility routine that prints integers.
c cmout ARPACK utility routine that prints matrices
c cvout ARPACK utility routine that prints vectors.
c cgeqr2 LAPACK routine that computes the QR factorization of
c a matrix.
c clacpy LAPACK matrix copy routine.
c clahqr LAPACK routine that computes the Schur form of a
c upper Hessenberg matrix.
c claset LAPACK matrix initialization routine.
c ctrevc LAPACK routine to compute the eigenvectors of a matrix
c in upper triangular form.
c ctrsen LAPACK routine that re-orders the Schur form.
c cunm2r LAPACK routine that applies an orthogonal matrix in
c factored form.
c slamch LAPACK routine that determines machine constants.
c ctrmm Level 3 BLAS matrix times an upper triangular matrix.
c cgeru Level 2 BLAS rank one update to a matrix.
c ccopy Level 1 BLAS that copies one vector to another .
c cscal Level 1 BLAS that scales a vector.
c csscal Level 1 BLAS that scales a complex vector by a real number.
c scnrm2 Level 1 BLAS that computes the norm of a complex vector.
c
c\Remarks
c
c 1. Currently only HOWMNY = 'A' and 'P' are implemented.
c
c 2. Schur vectors are an orthogonal representation for the basis of
c Ritz vectors. Thus, their numerical properties are often superior.
c If RVEC = .true. then the relationship
c A * V(:,1:IPARAM(5)) = V(:,1:IPARAM(5)) * T, and
c transpose( V(:,1:IPARAM(5)) ) * V(:,1:IPARAM(5)) = I
c are approximately satisfied.
c Here T is the leading submatrix of order IPARAM(5) of the
c upper triangular matrix stored workl(ipntr(12)).
c
c\Authors
c Danny Sorensen Phuong Vu
c Richard Lehoucq CRPC / Rice University
c Chao Yang Houston, Texas
c Dept. of Computational &
c Applied Mathematics
c Rice University
c Houston, Texas
c
c\SCCS Information: @(#)
c FILE: neupd.F SID: 2.8 DATE OF SID: 07/21/02 RELEASE: 2
c
c\EndLib
c
c-----------------------------------------------------------------------
subroutine cneupd(rvec , howmny, select, d ,
& z , ldz , sigma , workev,
& bmat , n , which , nev ,
& tol , resid , ncv , v ,
& ldv , iparam, ipntr , workd ,
& workl, lworkl, rwork , info )
c
c %----------------------------------------------------%
c | Include files for debugging and timing information |
c %----------------------------------------------------%
c
include 'debug.h'
include 'stat.h'
c
c %------------------%
c | Scalar Arguments |
c %------------------%
c
character bmat, howmny, which*2
logical rvec
integer info, ldz, ldv, lworkl, n, ncv, nev
Complex
& sigma
Real
& tol
c
c %-----------------%
c | Array Arguments |
c %-----------------%
c
integer iparam(11), ipntr(14)
logical select(ncv)
Real
& rwork(ncv)
Complex
& d(nev) , resid(n) , v(ldv,ncv),
& z(ldz, nev),
& workd(3*n) , workl(lworkl), workev(2*ncv)
c
c %------------%
c | Parameters |
c %------------%
c
Complex
& one, zero
parameter (one = (1.0E+0, 0.0E+0), zero = (0.0E+0, 0.0E+0))
c
c %---------------%
c | Local Scalars |
c %---------------%
c
character type*6
integer bounds, ierr , ih , ihbds, iheig , nconv ,
& invsub, iuptri, iwev , j , ldh , ldq ,
& mode , msglvl, ritz , wr , k , irz ,
& ibd , outncv, iq , np , numcnv, jj ,
& ishift
Complex
& rnorm, temp, vl(1)
Real
& conds, sep, rtemp, eps23
logical reord
c
c %----------------------%
c | External Subroutines |
c %----------------------%
c
external ccopy , cgeru, cgeqr2, clacpy, cmout,
& cunm2r, ctrmm, cvout, ivout,
& clahqr
c
c %--------------------%
c | External Functions |
c %--------------------%
c
Real
& scnrm2, slamch, slapy2
external scnrm2, slamch, slapy2
c
Complex
& cdotc
external cdotc
c
c %-----------------------%
c | Executable Statements |
c %-----------------------%
c
c %------------------------%
c | Set default parameters |
c %------------------------%
c
msglvl = mceupd
mode = iparam(7)
nconv = iparam(5)
info = 0
c
c
c %---------------------------------%
c | Get machine dependent constant. |
c %---------------------------------%
c
eps23 = slamch('Epsilon-Machine')
eps23 = eps23**(2.0E+0 / 3.0E+0)
c
c %-------------------------------%
c | Quick return |
c | Check for incompatible input |
c %-------------------------------%
c
ierr = 0
c
if (nconv .le. 0) then
ierr = -14
else if (n .le. 0) then
ierr = -1
else if (nev .le. 0) then
ierr = -2
else if (ncv .le. nev .or. ncv .gt. n) then
ierr = -3
else if (which .ne. 'LM' .and.
& which .ne. 'SM' .and.
& which .ne. 'LR' .and.
& which .ne. 'SR' .and.
& which .ne. 'LI' .and.
& which .ne. 'SI') then
ierr = -5
else if (bmat .ne. 'I' .and. bmat .ne. 'G') then
ierr = -6
else if (lworkl .lt. 3*ncv**2 + 4*ncv) then
ierr = -7
else if ( (howmny .ne. 'A' .and.
& howmny .ne. 'P' .and.
& howmny .ne. 'S') .and. rvec ) then
ierr = -13
else if (howmny .eq. 'S' ) then
ierr = -12
end if
c
if (mode .eq. 1 .or. mode .eq. 2) then
type = 'REGULR'
else if (mode .eq. 3 ) then
type = 'SHIFTI'
else
ierr = -10
end if
if (mode .eq. 1 .and. bmat .eq. 'G') ierr = -11
c
c %------------%
c | Error Exit |
c %------------%
c
if (ierr .ne. 0) then
info = ierr
go to 9000
end if
c
c %--------------------------------------------------------%
c | Pointer into WORKL for address of H, RITZ, WORKEV, Q |
c | etc... and the remaining workspace. |
c | Also update pointer to be used on output. |
c | Memory is laid out as follows: |
c | workl(1:ncv*ncv) := generated Hessenberg matrix |
c | workl(ncv*ncv+1:ncv*ncv+ncv) := ritz values |
c | workl(ncv*ncv+ncv+1:ncv*ncv+2*ncv) := error bounds |
c %--------------------------------------------------------%
c
c %-----------------------------------------------------------%
c | The following is used and set by CNEUPD. |
c | workl(ncv*ncv+2*ncv+1:ncv*ncv+3*ncv) := The untransformed |
c | Ritz values. |
c | workl(ncv*ncv+3*ncv+1:ncv*ncv+4*ncv) := The untransformed |
c | error bounds of |
c | the Ritz values |
c | workl(ncv*ncv+4*ncv+1:2*ncv*ncv+4*ncv) := Holds the upper |
c | triangular matrix |
c | for H. |
c | workl(2*ncv*ncv+4*ncv+1: 3*ncv*ncv+4*ncv) := Holds the |
c | associated matrix |
c | representation of |
c | the invariant |
c | subspace for H. |
c | GRAND total of NCV * ( 3 * NCV + 4 ) locations. |
c %-----------------------------------------------------------%
c
ih = ipntr(5)
ritz = ipntr(6)
iq = ipntr(7)
bounds = ipntr(8)
ldh = ncv
ldq = ncv
iheig = bounds + ldh
ihbds = iheig + ldh
iuptri = ihbds + ldh
invsub = iuptri + ldh*ncv
ipntr(9) = iheig
ipntr(11) = ihbds
ipntr(12) = iuptri
ipntr(13) = invsub
wr = 1
iwev = wr + ncv
c
c %-----------------------------------------%
c | irz points to the Ritz values computed |
c | by _neigh before exiting _naup2. |
c | ibd points to the Ritz estimates |
c | computed by _neigh before exiting |
c | _naup2. |
c %-----------------------------------------%
c
irz = ipntr(14) + ncv*ncv
ibd = irz + ncv
c
c %------------------------------------%
c | RNORM is B-norm of the RESID(1:N). |
c %------------------------------------%
c
rnorm = workl(ih+2)
workl(ih+2) = zero
c
if (msglvl .gt. 2) then
call cvout(logfil, ncv, workl(irz), ndigit,
& '_neupd: Ritz values passed in from _NAUPD.')
call cvout(logfil, ncv, workl(ibd), ndigit,
& '_neupd: Ritz estimates passed in from _NAUPD.')
end if
c
if (rvec) then
c
reord = .false.
c
c %---------------------------------------------------%
c | Use the temporary bounds array to store indices |
c | These will be used to mark the select array later |
c %---------------------------------------------------%
c
do 10 j = 1,ncv
workl(bounds+j-1) = j
select(j) = .false.
10 continue
c
c %-------------------------------------%
c | Select the wanted Ritz values. |
c | Sort the Ritz values so that the |
c | wanted ones appear at the tailing |
c | NEV positions of workl(irr) and |
c | workl(iri). Move the corresponding |
c | error estimates in workl(ibd) |
c | accordingly. |
c %-------------------------------------%
c
np = ncv - nev
ishift = 0
call cngets(ishift, which , nev ,
& np , workl(irz), workl(bounds))
c
if (msglvl .gt. 2) then
call cvout (logfil, ncv, workl(irz), ndigit,
& '_neupd: Ritz values after calling _NGETS.')
call cvout (logfil, ncv, workl(bounds), ndigit,
& '_neupd: Ritz value indices after calling _NGETS.')
end if
c
c %-----------------------------------------------------%
c | Record indices of the converged wanted Ritz values |
c | Mark the select array for possible reordering |
c %-----------------------------------------------------%
c
numcnv = 0
do 11 j = 1,ncv
rtemp = max(eps23,
& slapy2 ( real(workl(irz+ncv-j)),
& aimag(workl(irz+ncv-j)) ))
jj = workl(bounds + ncv - j)
if (numcnv .lt. nconv .and.
& slapy2( real(workl(ibd+jj-1)),
& aimag(workl(ibd+jj-1)) )
& .le. tol*rtemp) then
select(jj) = .true.
numcnv = numcnv + 1
if (jj .gt. nev) reord = .true.
endif
11 continue
c
c %-----------------------------------------------------------%
c | Check the count (numcnv) of converged Ritz values with |
c | the number (nconv) reported by dnaupd. If these two |
c | are different then there has probably been an error |
c | caused by incorrect passing of the dnaupd data. |
c %-----------------------------------------------------------%
c
if (msglvl .gt. 2) then
call ivout(logfil, 1, numcnv, ndigit,
& '_neupd: Number of specified eigenvalues')
call ivout(logfil, 1, nconv, ndigit,
& '_neupd: Number of "converged" eigenvalues')
end if
c
if (numcnv .ne. nconv) then
info = -15
go to 9000
end if
c
c %-------------------------------------------------------%
c | Call LAPACK routine clahqr to compute the Schur form |
c | of the upper Hessenberg matrix returned by CNAUPD. |
c | Make a copy of the upper Hessenberg matrix. |
c | Initialize the Schur vector matrix Q to the identity. |
c %-------------------------------------------------------%
c
call ccopy(ldh*ncv, workl(ih), 1, workl(iuptri), 1)
call claset('All', ncv, ncv ,
& zero , one, workl(invsub),
& ldq)
call clahqr(.true., .true. , ncv ,
& 1 , ncv , workl(iuptri),
& ldh , workl(iheig) , 1 ,
& ncv , workl(invsub), ldq ,
& ierr)
call ccopy(ncv , workl(invsub+ncv-1), ldq,
& workl(ihbds), 1)
c
if (ierr .ne. 0) then
info = -8
go to 9000
end if
c
if (msglvl .gt. 1) then
call cvout (logfil, ncv, workl(iheig), ndigit,
& '_neupd: Eigenvalues of H')
call cvout (logfil, ncv, workl(ihbds), ndigit,
& '_neupd: Last row of the Schur vector matrix')
if (msglvl .gt. 3) then
call cmout (logfil , ncv, ncv ,
& workl(iuptri), ldh, ndigit,
& '_neupd: The upper triangular matrix ')
end if
end if
c
if (reord) then
c
c %-----------------------------------------------%
c | Reorder the computed upper triangular matrix. |
c %-----------------------------------------------%
c
call ctrsen('None' , 'V' , select ,
& ncv , workl(iuptri), ldh ,
& workl(invsub), ldq , workl(iheig),
& nconv , conds , sep ,
& workev , ncv , ierr)
c
if (ierr .eq. 1) then
info = 1
go to 9000
end if
c
if (msglvl .gt. 2) then
call cvout (logfil, ncv, workl(iheig), ndigit,
& '_neupd: Eigenvalues of H--reordered')
if (msglvl .gt. 3) then
call cmout(logfil , ncv, ncv ,
& workl(iuptri), ldq, ndigit,
& '_neupd: Triangular matrix after re-ordering')
end if
end if
c
end if
c
c %---------------------------------------------%
c | Copy the last row of the Schur basis matrix |
c | to workl(ihbds). This vector will be used |
c | to compute the Ritz estimates of converged |
c | Ritz values. |
c %---------------------------------------------%
c
call ccopy(ncv , workl(invsub+ncv-1), ldq,
& workl(ihbds), 1)
c
c %--------------------------------------------%
c | Place the computed eigenvalues of H into D |
c | if a spectral transformation was not used. |
c %--------------------------------------------%
c
if (type .eq. 'REGULR') then
call ccopy(nconv, workl(iheig), 1, d, 1)
end if
c
c %----------------------------------------------------------%
c | Compute the QR factorization of the matrix representing |
c | the wanted invariant subspace located in the first NCONV |
c | columns of workl(invsub,ldq). |
c %----------------------------------------------------------%
c
call cgeqr2(ncv , nconv , workl(invsub),
& ldq , workev, workev(ncv+1),
& ierr)
c
c %--------------------------------------------------------%
c | * Postmultiply V by Q using cunm2r. |
c | * Copy the first NCONV columns of VQ into Z. |
c | * Postmultiply Z by R. |
c | The N by NCONV matrix Z is now a matrix representation |
c | of the approximate invariant subspace associated with |
c | the Ritz values in workl(iheig). The first NCONV |
c | columns of V are now approximate Schur vectors |
c | associated with the upper triangular matrix of order |
c | NCONV in workl(iuptri). |
c %--------------------------------------------------------%
c
call cunm2r('Right', 'Notranspose', n ,
& ncv , nconv , workl(invsub),
& ldq , workev , v ,
& ldv , workd(n+1) , ierr)
call clacpy('All', n, nconv, v, ldv, z, ldz)
c
do 20 j=1, nconv
c
c %---------------------------------------------------%
c | Perform both a column and row scaling if the |
c | diagonal element of workl(invsub,ldq) is negative |
c | I'm lazy and don't take advantage of the upper |
c | triangular form of workl(iuptri,ldq). |
c | Note that since Q is orthogonal, R is a diagonal |
c | matrix consisting of plus or minus ones. |
c %---------------------------------------------------%
c
if ( real( workl(invsub+(j-1)*ldq+j-1) ) .lt.
& real(zero) ) then
call cscal(nconv, -one, workl(iuptri+j-1), ldq)
call cscal(nconv, -one, workl(iuptri+(j-1)*ldq), 1)
end if
c
20 continue
c
if (howmny .eq. 'A') then
c
c %--------------------------------------------%
c | Compute the NCONV wanted eigenvectors of T |
c | located in workl(iuptri,ldq). |
c %--------------------------------------------%
c
do 30 j=1, ncv
if (j .le. nconv) then
select(j) = .true.
else
select(j) = .false.
end if
30 continue
c
call ctrevc('Right', 'Select' , select ,
& ncv , workl(iuptri), ldq ,
& vl , 1 , workl(invsub),
& ldq , ncv , outncv ,
& workev , rwork , ierr)
c
if (ierr .ne. 0) then
info = -9
go to 9000
end if
c
c %------------------------------------------------%
c | Scale the returning eigenvectors so that their |
c | Euclidean norms are all one. LAPACK subroutine |
c | ctrevc returns each eigenvector normalized so |
c | that the element of largest magnitude has |
c | magnitude 1. |
c %------------------------------------------------%
c
do 40 j=1, nconv
rtemp = scnrm2(ncv, workl(invsub+(j-1)*ldq), 1)
rtemp = real(one) / rtemp
call csscal ( ncv, rtemp,
& workl(invsub+(j-1)*ldq), 1 )
c
c %------------------------------------------%
c | Ritz estimates can be obtained by taking |
c | the inner product of the last row of the |
c | Schur basis of H with eigenvectors of T. |
c | Note that the eigenvector matrix of T is |
c | upper triangular, thus the length of the |
c | inner product can be set to j. |
c %------------------------------------------%
c
workev(j) = cdotc(j, workl(ihbds), 1,
& workl(invsub+(j-1)*ldq), 1)
40 continue
c
if (msglvl .gt. 2) then
call ccopy(nconv, workl(invsub+ncv-1), ldq,
& workl(ihbds), 1)
call cvout (logfil, nconv, workl(ihbds), ndigit,
& '_neupd: Last row of the eigenvector matrix for T')
if (msglvl .gt. 3) then
call cmout(logfil , ncv, ncv ,
& workl(invsub), ldq, ndigit,
& '_neupd: The eigenvector matrix for T')
end if
end if
c
c %---------------------------------------%
c | Copy Ritz estimates into workl(ihbds) |
c %---------------------------------------%
c
call ccopy(nconv, workev, 1, workl(ihbds), 1)
c
c %----------------------------------------------%
c | The eigenvector matrix Q of T is triangular. |
c | Form Z*Q. |
c %----------------------------------------------%
c
call ctrmm('Right' , 'Upper' , 'No transpose',
& 'Non-unit', n , nconv ,
& one , workl(invsub), ldq ,
& z , ldz)
end if
c
else
c
c %--------------------------------------------------%
c | An approximate invariant subspace is not needed. |
c | Place the Ritz values computed CNAUPD into D. |
c %--------------------------------------------------%
c
call ccopy(nconv, workl(ritz), 1, d, 1)
call ccopy(nconv, workl(ritz), 1, workl(iheig), 1)
call ccopy(nconv, workl(bounds), 1, workl(ihbds), 1)
c
end if
c
c %------------------------------------------------%
c | Transform the Ritz values and possibly vectors |
c | and corresponding error bounds of OP to those |
c | of A*x = lambda*B*x. |
c %------------------------------------------------%
c
if (type .eq. 'REGULR') then
c
if (rvec)
& call cscal(ncv, rnorm, workl(ihbds), 1)
c
else
c
c %---------------------------------------%
c | A spectral transformation was used. |
c | * Determine the Ritz estimates of the |
c | Ritz values in the original system. |
c %---------------------------------------%
c
if (rvec)
& call cscal(ncv, rnorm, workl(ihbds), 1)
c
do 50 k=1, ncv
temp = workl(iheig+k-1)
workl(ihbds+k-1) = workl(ihbds+k-1) / temp / temp
50 continue
c
end if
c
c %-----------------------------------------------------------%
c | * Transform the Ritz values back to the original system. |
c | For TYPE = 'SHIFTI' the transformation is |
c | lambda = 1/theta + sigma |
c | NOTES: |
c | *The Ritz vectors are not affected by the transformation. |
c %-----------------------------------------------------------%
c
if (type .eq. 'SHIFTI') then
do 60 k=1, nconv
d(k) = one / workl(iheig+k-1) + sigma
60 continue
end if
c
if (type .ne. 'REGULR' .and. msglvl .gt. 1) then
call cvout (logfil, nconv, d, ndigit,
& '_neupd: Untransformed Ritz values.')
call cvout (logfil, nconv, workl(ihbds), ndigit,
& '_neupd: Ritz estimates of the untransformed Ritz values.')
else if ( msglvl .gt. 1) then
call cvout (logfil, nconv, d, ndigit,
& '_neupd: Converged Ritz values.')
call cvout (logfil, nconv, workl(ihbds), ndigit,
& '_neupd: Associated Ritz estimates.')
end if
c
c %-------------------------------------------------%
c | Eigenvector Purification step. Formally perform |
c | one of inverse subspace iteration. Only used |
c | for MODE = 3. See reference 3. |
c %-------------------------------------------------%
c
if (rvec .and. howmny .eq. 'A' .and. type .eq. 'SHIFTI') then
c
c %------------------------------------------------%
c | Purify the computed Ritz vectors by adding a |
c | little bit of the residual vector: |
c | T |
c | resid(:)*( e s ) / theta |
c | NCV |
c | where H s = s theta. |
c %------------------------------------------------%
c
do 100 j=1, nconv
if (workl(iheig+j-1) .ne. zero) then
workev(j) = workl(invsub+(j-1)*ldq+ncv-1) /
& workl(iheig+j-1)
endif
100 continue
c %---------------------------------------%
c | Perform a rank one update to Z and |
c | purify all the Ritz vectors together. |
c %---------------------------------------%
c
call cgeru (n, nconv, one, resid, 1, workev, 1, z, ldz)
c
end if
c
9000 continue
c
return
c
c %---------------%
c | End of cneupd|
c %---------------%
c
end

178
arpack/ARPACK/SRC/cngets.f Normal file
View File

@@ -0,0 +1,178 @@
c\BeginDoc
c
c\Name: cngets
c
c\Description:
c Given the eigenvalues of the upper Hessenberg matrix H,
c computes the NP shifts AMU that are zeros of the polynomial of
c degree NP which filters out components of the unwanted eigenvectors
c corresponding to the AMU's based on some given criteria.
c
c NOTE: call this even in the case of user specified shifts in order
c to sort the eigenvalues, and error bounds of H for later use.
c
c\Usage:
c call cngets
c ( ISHIFT, WHICH, KEV, NP, RITZ, BOUNDS )
c
c\Arguments
c ISHIFT Integer. (INPUT)
c Method for selecting the implicit shifts at each iteration.
c ISHIFT = 0: user specified shifts
c ISHIFT = 1: exact shift with respect to the matrix H.
c
c WHICH Character*2. (INPUT)
c Shift selection criteria.
c 'LM' -> want the KEV eigenvalues of largest magnitude.
c 'SM' -> want the KEV eigenvalues of smallest magnitude.
c 'LR' -> want the KEV eigenvalues of largest REAL part.
c 'SR' -> want the KEV eigenvalues of smallest REAL part.
c 'LI' -> want the KEV eigenvalues of largest imaginary part.
c 'SI' -> want the KEV eigenvalues of smallest imaginary part.
c
c KEV Integer. (INPUT)
c The number of desired eigenvalues.
c
c NP Integer. (INPUT)
c The number of shifts to compute.
c
c RITZ Complex array of length KEV+NP. (INPUT/OUTPUT)
c On INPUT, RITZ contains the the eigenvalues of H.
c On OUTPUT, RITZ are sorted so that the unwanted
c eigenvalues are in the first NP locations and the wanted
c portion is in the last KEV locations. When exact shifts are
c selected, the unwanted part corresponds to the shifts to
c be applied. Also, if ISHIFT .eq. 1, the unwanted eigenvalues
c are further sorted so that the ones with largest Ritz values
c are first.
c
c BOUNDS Complex array of length KEV+NP. (INPUT/OUTPUT)
c Error bounds corresponding to the ordering in RITZ.
c
c
c
c\EndDoc
c
c-----------------------------------------------------------------------
c
c\BeginLib
c
c\Local variables:
c xxxxxx Complex
c
c\Routines called:
c csortc ARPACK sorting routine.
c ivout ARPACK utility routine that prints integers.
c second ARPACK utility routine for timing.
c cvout ARPACK utility routine that prints vectors.
c
c\Author
c Danny Sorensen Phuong Vu
c Richard Lehoucq CRPC / Rice University
c Dept. of Computational & Houston, Texas
c Applied Mathematics
c Rice University
c Houston, Texas
c
c\SCCS Information: @(#)
c FILE: ngets.F SID: 2.2 DATE OF SID: 4/20/96 RELEASE: 2
c
c\Remarks
c 1. This routine does not keep complex conjugate pairs of
c eigenvalues together.
c
c\EndLib
c
c-----------------------------------------------------------------------
c
subroutine cngets ( ishift, which, kev, np, ritz, bounds)
c
c %----------------------------------------------------%
c | Include files for debugging and timing information |
c %----------------------------------------------------%
c
include 'debug.h'
include 'stat.h'
c
c %------------------%
c | Scalar Arguments |
c %------------------%
c
character*2 which
integer ishift, kev, np
c
c %-----------------%
c | Array Arguments |
c %-----------------%
c
Complex
& bounds(kev+np), ritz(kev+np)
c
c %------------%
c | Parameters |
c %------------%
c
Complex
& one, zero
parameter (one = (1.0E+0, 0.0E+0), zero = (0.0E+0, 0.0E+0))
c
c %---------------%
c | Local Scalars |
c %---------------%
c
integer msglvl
c
c %----------------------%
c | External Subroutines |
c %----------------------%
c
external cvout, csortc, second
c
c %-----------------------%
c | Executable Statements |
c %-----------------------%
c
c %-------------------------------%
c | Initialize timing statistics |
c | & message level for debugging |
c %-------------------------------%
c
call second (t0)
msglvl = mcgets
c
call csortc (which, .true., kev+np, ritz, bounds)
c
if ( ishift .eq. 1 ) then
c
c %-------------------------------------------------------%
c | Sort the unwanted Ritz values used as shifts so that |
c | the ones with largest Ritz estimates are first |
c | This will tend to minimize the effects of the |
c | forward instability of the iteration when the shifts |
c | are applied in subroutine cnapps. |
c | Be careful and use 'SM' since we want to sort BOUNDS! |
c %-------------------------------------------------------%
c
call csortc ( 'SM', .true., np, bounds, ritz )
c
end if
c
call second (t1)
tcgets = tcgets + (t1 - t0)
c
if (msglvl .gt. 0) then
call ivout (logfil, 1, kev, ndigit, '_ngets: KEV is')
call ivout (logfil, 1, np, ndigit, '_ngets: NP is')
call cvout (logfil, kev+np, ritz, ndigit,
& '_ngets: Eigenvalues of current H matrix ')
call cvout (logfil, kev+np, bounds, ndigit,
& '_ngets: Ritz estimates of the current KEV+NP Ritz values')
end if
c
return
c
c %---------------%
c | End of cngets |
c %---------------%
c
end

322
arpack/ARPACK/SRC/csortc.f Normal file
View File

@@ -0,0 +1,322 @@
c\BeginDoc
c
c\Name: csortc
c
c\Description:
c Sorts the Complex array in X into the order
c specified by WHICH and optionally applies the permutation to the
c Real array Y.
c
c\Usage:
c call csortc
c ( WHICH, APPLY, N, X, Y )
c
c\Arguments
c WHICH Character*2. (Input)
c 'LM' -> sort X into increasing order of magnitude.
c 'SM' -> sort X into decreasing order of magnitude.
c 'LR' -> sort X with real(X) in increasing algebraic order
c 'SR' -> sort X with real(X) in decreasing algebraic order
c 'LI' -> sort X with imag(X) in increasing algebraic order
c 'SI' -> sort X with imag(X) in decreasing algebraic order
c
c APPLY Logical. (Input)
c APPLY = .TRUE. -> apply the sorted order to array Y.
c APPLY = .FALSE. -> do not apply the sorted order to array Y.
c
c N Integer. (INPUT)
c Size of the arrays.
c
c X Complex array of length N. (INPUT/OUTPUT)
c This is the array to be sorted.
c
c Y Complex array of length N. (INPUT/OUTPUT)
c
c\EndDoc
c
c-----------------------------------------------------------------------
c
c\BeginLib
c
c\Routines called:
c slapy2 LAPACK routine to compute sqrt(x**2+y**2) carefully.
c
c\Author
c Danny Sorensen Phuong Vu
c Richard Lehoucq CRPC / Rice University
c Dept. of Computational & Houston, Texas
c Applied Mathematics
c Rice University
c Houston, Texas
c
c Adapted from the sort routine in LANSO.
c
c\SCCS Information: @(#)
c FILE: sortc.F SID: 2.2 DATE OF SID: 4/20/96 RELEASE: 2
c
c\EndLib
c
c-----------------------------------------------------------------------
c
subroutine csortc (which, apply, n, x, y)
c
c %------------------%
c | Scalar Arguments |
c %------------------%
c
character*2 which
logical apply
integer n
c
c %-----------------%
c | Array Arguments |
c %-----------------%
c
Complex
& x(0:n-1), y(0:n-1)
c
c %---------------%
c | Local Scalars |
c %---------------%
c
integer i, igap, j
Complex
& temp
Real
& temp1, temp2
c
c %--------------------%
c | External functions |
c %--------------------%
c
Real
& slapy2
c
c %--------------------%
c | Intrinsic Functions |
c %--------------------%
Intrinsic
& real, aimag
c
c %-----------------------%
c | Executable Statements |
c %-----------------------%
c
igap = n / 2
c
if (which .eq. 'LM') then
c
c %--------------------------------------------%
c | Sort X into increasing order of magnitude. |
c %--------------------------------------------%
c
10 continue
if (igap .eq. 0) go to 9000
c
do 30 i = igap, n-1
j = i-igap
20 continue
c
if (j.lt.0) go to 30
c
temp1 = slapy2(real(x(j)),aimag(x(j)))
temp2 = slapy2(real(x(j+igap)),aimag(x(j+igap)))
c
if (temp1.gt.temp2) then
temp = x(j)
x(j) = x(j+igap)
x(j+igap) = temp
c
if (apply) then
temp = y(j)
y(j) = y(j+igap)
y(j+igap) = temp
end if
else
go to 30
end if
j = j-igap
go to 20
30 continue
igap = igap / 2
go to 10
c
else if (which .eq. 'SM') then
c
c %--------------------------------------------%
c | Sort X into decreasing order of magnitude. |
c %--------------------------------------------%
c
40 continue
if (igap .eq. 0) go to 9000
c
do 60 i = igap, n-1
j = i-igap
50 continue
c
if (j .lt. 0) go to 60
c
temp1 = slapy2(real(x(j)),aimag(x(j)))
temp2 = slapy2(real(x(j+igap)),aimag(x(j+igap)))
c
if (temp1.lt.temp2) then
temp = x(j)
x(j) = x(j+igap)
x(j+igap) = temp
c
if (apply) then
temp = y(j)
y(j) = y(j+igap)
y(j+igap) = temp
end if
else
go to 60
endif
j = j-igap
go to 50
60 continue
igap = igap / 2
go to 40
c
else if (which .eq. 'LR') then
c
c %------------------------------------------------%
c | Sort XREAL into increasing order of algebraic. |
c %------------------------------------------------%
c
70 continue
if (igap .eq. 0) go to 9000
c
do 90 i = igap, n-1
j = i-igap
80 continue
c
if (j.lt.0) go to 90
c
if (real(x(j)).gt.real(x(j+igap))) then
temp = x(j)
x(j) = x(j+igap)
x(j+igap) = temp
c
if (apply) then
temp = y(j)
y(j) = y(j+igap)
y(j+igap) = temp
end if
else
go to 90
endif
j = j-igap
go to 80
90 continue
igap = igap / 2
go to 70
c
else if (which .eq. 'SR') then
c
c %------------------------------------------------%
c | Sort XREAL into decreasing order of algebraic. |
c %------------------------------------------------%
c
100 continue
if (igap .eq. 0) go to 9000
do 120 i = igap, n-1
j = i-igap
110 continue
c
if (j.lt.0) go to 120
c
if (real(x(j)).lt.real(x(j+igap))) then
temp = x(j)
x(j) = x(j+igap)
x(j+igap) = temp
c
if (apply) then
temp = y(j)
y(j) = y(j+igap)
y(j+igap) = temp
end if
else
go to 120
endif
j = j-igap
go to 110
120 continue
igap = igap / 2
go to 100
c
else if (which .eq. 'LI') then
c
c %--------------------------------------------%
c | Sort XIMAG into increasing algebraic order |
c %--------------------------------------------%
c
130 continue
if (igap .eq. 0) go to 9000
do 150 i = igap, n-1
j = i-igap
140 continue
c
if (j.lt.0) go to 150
c
if (aimag(x(j)).gt.aimag(x(j+igap))) then
temp = x(j)
x(j) = x(j+igap)
x(j+igap) = temp
c
if (apply) then
temp = y(j)
y(j) = y(j+igap)
y(j+igap) = temp
end if
else
go to 150
endif
j = j-igap
go to 140
150 continue
igap = igap / 2
go to 130
c
else if (which .eq. 'SI') then
c
c %---------------------------------------------%
c | Sort XIMAG into decreasing algebraic order |
c %---------------------------------------------%
c
160 continue
if (igap .eq. 0) go to 9000
do 180 i = igap, n-1
j = i-igap
170 continue
c
if (j.lt.0) go to 180
c
if (aimag(x(j)).lt.aimag(x(j+igap))) then
temp = x(j)
x(j) = x(j+igap)
x(j+igap) = temp
c
if (apply) then
temp = y(j)
y(j) = y(j+igap)
y(j+igap) = temp
end if
else
go to 180
endif
j = j-igap
go to 170
180 continue
igap = igap / 2
go to 160
end if
c
9000 continue
return
c
c %---------------%
c | End of csortc |
c %---------------%
c
end

51
arpack/ARPACK/SRC/cstatn.f Normal file
View File

@@ -0,0 +1,51 @@
c
c\SCCS Information: @(#)
c FILE: statn.F SID: 2.2 DATE OF SID: 4/20/96 RELEASE: 2
c
c %---------------------------------------------%
c | Initialize statistic and timing information |
c | for complex nonsymmetric Arnoldi code. |
c %---------------------------------------------%
subroutine cstatn
c
c %--------------------------------%
c | See stat.doc for documentation |
c %--------------------------------%
c
include 'stat.h'
c %-----------------------%
c | Executable Statements |
c %-----------------------%
nopx = 0
nbx = 0
nrorth = 0
nitref = 0
nrstrt = 0
tcaupd = 0.0E+0
tcaup2 = 0.0E+0
tcaitr = 0.0E+0
tceigh = 0.0E+0
tcgets = 0.0E+0
tcapps = 0.0E+0
tcconv = 0.0E+0
titref = 0.0E+0
tgetv0 = 0.0E+0
trvec = 0.0E+0
c %----------------------------------------------------%
c | User time including reverse communication overhead |
c %----------------------------------------------------%
tmvopx = 0.0E+0
tmvbx = 0.0E+0
return
c
c %---------------%
c | End of cstatn |
c %---------------%
c
end

16
arpack/ARPACK/SRC/debug.h Normal file
View File

@@ -0,0 +1,16 @@
c
c\SCCS Information: @(#)
c FILE: debug.h SID: 2.3 DATE OF SID: 11/16/95 RELEASE: 2
c
c %---------------------------------%
c | See debug.doc for documentation |
c %---------------------------------%
integer logfil, ndigit, mgetv0,
& msaupd, msaup2, msaitr, mseigt, msapps, msgets, mseupd,
& mnaupd, mnaup2, mnaitr, mneigh, mnapps, mngets, mneupd,
& mcaupd, mcaup2, mcaitr, mceigh, mcapps, mcgets, mceupd
common /debug/
& logfil, ndigit, mgetv0,
& msaupd, msaup2, msaitr, mseigt, msapps, msgets, mseupd,
& mnaupd, mnaup2, mnaitr, mneigh, mnapps, mngets, mneupd,
& mcaupd, mcaup2, mcaitr, mceigh, mcapps, mcgets, mceupd

419
arpack/ARPACK/SRC/dgetv0.f Normal file
View File

@@ -0,0 +1,419 @@
c-----------------------------------------------------------------------
c\BeginDoc
c
c\Name: dgetv0
c
c\Description:
c Generate a random initial residual vector for the Arnoldi process.
c Force the residual vector to be in the range of the operator OP.
c
c\Usage:
c call dgetv0
c ( IDO, BMAT, ITRY, INITV, N, J, V, LDV, RESID, RNORM,
c IPNTR, WORKD, IERR )
c
c\Arguments
c IDO Integer. (INPUT/OUTPUT)
c Reverse communication flag. IDO must be zero on the first
c call to dgetv0.
c -------------------------------------------------------------
c IDO = 0: first call to the reverse communication interface
c IDO = -1: compute Y = OP * X where
c IPNTR(1) is the pointer into WORKD for X,
c IPNTR(2) is the pointer into WORKD for Y.
c This is for the initialization phase to force the
c starting vector into the range of OP.
c IDO = 2: compute Y = B * X where
c IPNTR(1) is the pointer into WORKD for X,
c IPNTR(2) is the pointer into WORKD for Y.
c IDO = 99: done
c -------------------------------------------------------------
c
c BMAT Character*1. (INPUT)
c BMAT specifies the type of the matrix B in the (generalized)
c eigenvalue problem A*x = lambda*B*x.
c B = 'I' -> standard eigenvalue problem A*x = lambda*x
c B = 'G' -> generalized eigenvalue problem A*x = lambda*B*x
c
c ITRY Integer. (INPUT)
c ITRY counts the number of times that dgetv0 is called.
c It should be set to 1 on the initial call to dgetv0.
c
c INITV Logical variable. (INPUT)
c .TRUE. => the initial residual vector is given in RESID.
c .FALSE. => generate a random initial residual vector.
c
c N Integer. (INPUT)
c Dimension of the problem.
c
c J Integer. (INPUT)
c Index of the residual vector to be generated, with respect to
c the Arnoldi process. J > 1 in case of a "restart".
c
c V Double precision N by J array. (INPUT)
c The first J-1 columns of V contain the current Arnoldi basis
c if this is a "restart".
c
c LDV Integer. (INPUT)
c Leading dimension of V exactly as declared in the calling
c program.
c
c RESID Double precision array of length N. (INPUT/OUTPUT)
c Initial residual vector to be generated. If RESID is
c provided, force RESID into the range of the operator OP.
c
c RNORM Double precision scalar. (OUTPUT)
c B-norm of the generated residual.
c
c IPNTR Integer array of length 3. (OUTPUT)
c
c WORKD Double precision work array of length 2*N. (REVERSE COMMUNICATION).
c On exit, WORK(1:N) = B*RESID to be used in SSAITR.
c
c IERR Integer. (OUTPUT)
c = 0: Normal exit.
c = -1: Cannot generate a nontrivial restarted residual vector
c in the range of the operator OP.
c
c\EndDoc
c
c-----------------------------------------------------------------------
c
c\BeginLib
c
c\Local variables:
c xxxxxx real
c
c\References:
c 1. D.C. Sorensen, "Implicit Application of Polynomial Filters in
c a k-Step Arnoldi Method", SIAM J. Matr. Anal. Apps., 13 (1992),
c pp 357-385.
c 2. R.B. Lehoucq, "Analysis and Implementation of an Implicitly
c Restarted Arnoldi Iteration", Rice University Technical Report
c TR95-13, Department of Computational and Applied Mathematics.
c
c\Routines called:
c second ARPACK utility routine for timing.
c dvout ARPACK utility routine for vector output.
c dlarnv LAPACK routine for generating a random vector.
c dgemv Level 2 BLAS routine for matrix vector multiplication.
c dcopy Level 1 BLAS that copies one vector to another.
c ddot Level 1 BLAS that computes the scalar product of two vectors.
c dnrm2 Level 1 BLAS that computes the norm of a vector.
c
c\Author
c Danny Sorensen Phuong Vu
c Richard Lehoucq CRPC / Rice University
c Dept. of Computational & Houston, Texas
c Applied Mathematics
c Rice University
c Houston, Texas
c
c\SCCS Information: @(#)
c FILE: getv0.F SID: 2.7 DATE OF SID: 04/07/99 RELEASE: 2
c
c\EndLib
c
c-----------------------------------------------------------------------
c
subroutine dgetv0
& ( ido, bmat, itry, initv, n, j, v, ldv, resid, rnorm,
& ipntr, workd, ierr )
c
c %----------------------------------------------------%
c | Include files for debugging and timing information |
c %----------------------------------------------------%
c
include 'debug.h'
include 'stat.h'
c
c %------------------%
c | Scalar Arguments |
c %------------------%
c
character bmat*1
logical initv
integer ido, ierr, itry, j, ldv, n
Double precision
& rnorm
c
c %-----------------%
c | Array Arguments |
c %-----------------%
c
integer ipntr(3)
Double precision
& resid(n), v(ldv,j), workd(2*n)
c
c %------------%
c | Parameters |
c %------------%
c
Double precision
& one, zero
parameter (one = 1.0D+0, zero = 0.0D+0)
c
c %------------------------%
c | Local Scalars & Arrays |
c %------------------------%
c
logical first, inits, orth
integer idist, iseed(4), iter, msglvl, jj
Double precision
& rnorm0
save first, iseed, inits, iter, msglvl, orth, rnorm0
c
c %----------------------%
c | External Subroutines |
c %----------------------%
c
external dlarnv, dvout, dcopy, dgemv, second
c
c %--------------------%
c | External Functions |
c %--------------------%
c
Double precision
& ddot, dnrm2
external ddot, dnrm2
c
c %---------------------%
c | Intrinsic Functions |
c %---------------------%
c
intrinsic abs, sqrt
c
c %-----------------%
c | Data Statements |
c %-----------------%
c
data inits /.true./
c
c %-----------------------%
c | Executable Statements |
c %-----------------------%
c
c
c %-----------------------------------%
c | Initialize the seed of the LAPACK |
c | random number generator |
c %-----------------------------------%
c
if (inits) then
iseed(1) = 1
iseed(2) = 3
iseed(3) = 5
iseed(4) = 7
inits = .false.
end if
c
if (ido .eq. 0) then
c
c %-------------------------------%
c | Initialize timing statistics |
c | & message level for debugging |
c %-------------------------------%
c
call second (t0)
msglvl = mgetv0
c
ierr = 0
iter = 0
first = .FALSE.
orth = .FALSE.
c
c %-----------------------------------------------------%
c | Possibly generate a random starting vector in RESID |
c | Use a LAPACK random number generator used by the |
c | matrix generation routines. |
c | idist = 1: uniform (0,1) distribution; |
c | idist = 2: uniform (-1,1) distribution; |
c | idist = 3: normal (0,1) distribution; |
c %-----------------------------------------------------%
c
if (.not.initv) then
idist = 2
call dlarnv (idist, iseed, n, resid)
end if
c
c %----------------------------------------------------------%
c | Force the starting vector into the range of OP to handle |
c | the generalized problem when B is possibly (singular). |
c %----------------------------------------------------------%
c
call second (t2)
if (bmat .eq. 'G') then
nopx = nopx + 1
ipntr(1) = 1
ipntr(2) = n + 1
call dcopy (n, resid, 1, workd, 1)
ido = -1
go to 9000
end if
end if
c
c %-----------------------------------------%
c | Back from computing OP*(initial-vector) |
c %-----------------------------------------%
c
if (first) go to 20
c
c %-----------------------------------------------%
c | Back from computing B*(orthogonalized-vector) |
c %-----------------------------------------------%
c
if (orth) go to 40
c
if (bmat .eq. 'G') then
call second (t3)
tmvopx = tmvopx + (t3 - t2)
end if
c
c %------------------------------------------------------%
c | Starting vector is now in the range of OP; r = OP*r; |
c | Compute B-norm of starting vector. |
c %------------------------------------------------------%
c
call second (t2)
first = .TRUE.
if (bmat .eq. 'G') then
nbx = nbx + 1
call dcopy (n, workd(n+1), 1, resid, 1)
ipntr(1) = n + 1
ipntr(2) = 1
ido = 2
go to 9000
else if (bmat .eq. 'I') then
call dcopy (n, resid, 1, workd, 1)
end if
c
20 continue
c
if (bmat .eq. 'G') then
call second (t3)
tmvbx = tmvbx + (t3 - t2)
end if
c
first = .FALSE.
if (bmat .eq. 'G') then
rnorm0 = ddot (n, resid, 1, workd, 1)
rnorm0 = sqrt(abs(rnorm0))
else if (bmat .eq. 'I') then
rnorm0 = dnrm2(n, resid, 1)
end if
rnorm = rnorm0
c
c %---------------------------------------------%
c | Exit if this is the very first Arnoldi step |
c %---------------------------------------------%
c
if (j .eq. 1) go to 50
c
c %----------------------------------------------------------------
c | Otherwise need to B-orthogonalize the starting vector against |
c | the current Arnoldi basis using Gram-Schmidt with iter. ref. |
c | This is the case where an invariant subspace is encountered |
c | in the middle of the Arnoldi factorization. |
c | |
c | s = V^{T}*B*r; r = r - V*s; |
c | |
c | Stopping criteria used for iter. ref. is discussed in |
c | Parlett's book, page 107 and in Gragg & Reichel TOMS paper. |
c %---------------------------------------------------------------%
c
orth = .TRUE.
30 continue
c
call dgemv ('T', n, j-1, one, v, ldv, workd, 1,
& zero, workd(n+1), 1)
call dgemv ('N', n, j-1, -one, v, ldv, workd(n+1), 1,
& one, resid, 1)
c
c %----------------------------------------------------------%
c | Compute the B-norm of the orthogonalized starting vector |
c %----------------------------------------------------------%
c
call second (t2)
if (bmat .eq. 'G') then
nbx = nbx + 1
call dcopy (n, resid, 1, workd(n+1), 1)
ipntr(1) = n + 1
ipntr(2) = 1
ido = 2
go to 9000
else if (bmat .eq. 'I') then
call dcopy (n, resid, 1, workd, 1)
end if
c
40 continue
c
if (bmat .eq. 'G') then
call second (t3)
tmvbx = tmvbx + (t3 - t2)
end if
c
if (bmat .eq. 'G') then
rnorm = ddot (n, resid, 1, workd, 1)
rnorm = sqrt(abs(rnorm))
else if (bmat .eq. 'I') then
rnorm = dnrm2(n, resid, 1)
end if
c
c %--------------------------------------%
c | Check for further orthogonalization. |
c %--------------------------------------%
c
if (msglvl .gt. 2) then
call dvout (logfil, 1, rnorm0, ndigit,
& '_getv0: re-orthonalization ; rnorm0 is')
call dvout (logfil, 1, rnorm, ndigit,
& '_getv0: re-orthonalization ; rnorm is')
end if
c
if (rnorm .gt. 0.717*rnorm0) go to 50
c
iter = iter + 1
if (iter .le. 5) then
c
c %-----------------------------------%
c | Perform iterative refinement step |
c %-----------------------------------%
c
rnorm0 = rnorm
go to 30
else
c
c %------------------------------------%
c | Iterative refinement step "failed" |
c %------------------------------------%
c
do 45 jj = 1, n
resid(jj) = zero
45 continue
rnorm = zero
ierr = -1
end if
c
50 continue
c
if (msglvl .gt. 0) then
call dvout (logfil, 1, rnorm, ndigit,
& '_getv0: B-norm of initial / restarted starting vector')
end if
if (msglvl .gt. 3) then
call dvout (logfil, n, resid, ndigit,
& '_getv0: initial / restarted starting vector')
end if
ido = 99
c
call second (t1)
tgetv0 = tgetv0 + (t1 - t0)
c
9000 continue
return
c
c %---------------%
c | End of dgetv0 |
c %---------------%
c
end

521
arpack/ARPACK/SRC/dlaqrb.f Normal file
View File

@@ -0,0 +1,521 @@
c-----------------------------------------------------------------------
c\BeginDoc
c
c\Name: dlaqrb
c
c\Description:
c Compute the eigenvalues and the Schur decomposition of an upper
c Hessenberg submatrix in rows and columns ILO to IHI. Only the
c last component of the Schur vectors are computed.
c
c This is mostly a modification of the LAPACK routine dlahqr.
c
c\Usage:
c call dlaqrb
c ( WANTT, N, ILO, IHI, H, LDH, WR, WI, Z, INFO )
c
c\Arguments
c WANTT Logical variable. (INPUT)
c = .TRUE. : the full Schur form T is required;
c = .FALSE.: only eigenvalues are required.
c
c N Integer. (INPUT)
c The order of the matrix H. N >= 0.
c
c ILO Integer. (INPUT)
c IHI Integer. (INPUT)
c It is assumed that H is already upper quasi-triangular in
c rows and columns IHI+1:N, and that H(ILO,ILO-1) = 0 (unless
c ILO = 1). SLAQRB works primarily with the Hessenberg
c submatrix in rows and columns ILO to IHI, but applies
c transformations to all of H if WANTT is .TRUE..
c 1 <= ILO <= max(1,IHI); IHI <= N.
c
c H Double precision array, dimension (LDH,N). (INPUT/OUTPUT)
c On entry, the upper Hessenberg matrix H.
c On exit, if WANTT is .TRUE., H is upper quasi-triangular in
c rows and columns ILO:IHI, with any 2-by-2 diagonal blocks in
c standard form. If WANTT is .FALSE., the contents of H are
c unspecified on exit.
c
c LDH Integer. (INPUT)
c The leading dimension of the array H. LDH >= max(1,N).
c
c WR Double precision array, dimension (N). (OUTPUT)
c WI Double precision array, dimension (N). (OUTPUT)
c The real and imaginary parts, respectively, of the computed
c eigenvalues ILO to IHI are stored in the corresponding
c elements of WR and WI. If two eigenvalues are computed as a
c complex conjugate pair, they are stored in consecutive
c elements of WR and WI, say the i-th and (i+1)th, with
c WI(i) > 0 and WI(i+1) < 0. If WANTT is .TRUE., the
c eigenvalues are stored in the same order as on the diagonal
c of the Schur form returned in H, with WR(i) = H(i,i), and, if
c H(i:i+1,i:i+1) is a 2-by-2 diagonal block,
c WI(i) = sqrt(H(i+1,i)*H(i,i+1)) and WI(i+1) = -WI(i).
c
c Z Double precision array, dimension (N). (OUTPUT)
c On exit Z contains the last components of the Schur vectors.
c
c INFO Integer. (OUPUT)
c = 0: successful exit
c > 0: SLAQRB failed to compute all the eigenvalues ILO to IHI
c in a total of 30*(IHI-ILO+1) iterations; if INFO = i,
c elements i+1:ihi of WR and WI contain those eigenvalues
c which have been successfully computed.
c
c\Remarks
c 1. None.
c
c-----------------------------------------------------------------------
c
c\BeginLib
c
c\Local variables:
c xxxxxx real
c
c\Routines called:
c dlabad LAPACK routine that computes machine constants.
c dlamch LAPACK routine that determines machine constants.
c dlanhs LAPACK routine that computes various norms of a matrix.
c dlanv2 LAPACK routine that computes the Schur factorization of
c 2 by 2 nonsymmetric matrix in standard form.
c dlarfg LAPACK Householder reflection construction routine.
c dcopy Level 1 BLAS that copies one vector to another.
c drot Level 1 BLAS that applies a rotation to a 2 by 2 matrix.
c
c\Author
c Danny Sorensen Phuong Vu
c Richard Lehoucq CRPC / Rice University
c Dept. of Computational & Houston, Texas
c Applied Mathematics
c Rice University
c Houston, Texas
c
c\Revision history:
c xx/xx/92: Version ' 2.4'
c Modified from the LAPACK routine dlahqr so that only the
c last component of the Schur vectors are computed.
c
c\SCCS Information: @(#)
c FILE: laqrb.F SID: 2.2 DATE OF SID: 8/27/96 RELEASE: 2
c
c\Remarks
c 1. None
c
c\EndLib
c
c-----------------------------------------------------------------------
c
subroutine dlaqrb ( wantt, n, ilo, ihi, h, ldh, wr, wi,
& z, info )
c
c %------------------%
c | Scalar Arguments |
c %------------------%
c
logical wantt
integer ihi, ilo, info, ldh, n
c
c %-----------------%
c | Array Arguments |
c %-----------------%
c
Double precision
& h( ldh, * ), wi( * ), wr( * ), z( * )
c
c %------------%
c | Parameters |
c %------------%
c
Double precision
& zero, one, dat1, dat2
parameter (zero = 0.0D+0, one = 1.0D+0, dat1 = 7.5D-1,
& dat2 = -4.375D-1)
c
c %------------------------%
c | Local Scalars & Arrays |
c %------------------------%
c
integer i, i1, i2, itn, its, j, k, l, m, nh, nr
Double precision
& cs, h00, h10, h11, h12, h21, h22, h33, h33s,
& h43h34, h44, h44s, ovfl, s, smlnum, sn, sum,
& t1, t2, t3, tst1, ulp, unfl, v1, v2, v3
Double precision
& v( 3 ), work( 1 )
c
c %--------------------%
c | External Functions |
c %--------------------%
c
Double precision
& dlamch, dlanhs
external dlamch, dlanhs
c
c %----------------------%
c | External Subroutines |
c %----------------------%
c
external dcopy, dlabad, dlanv2, dlarfg, drot
c
c %-----------------------%
c | Executable Statements |
c %-----------------------%
c
info = 0
c
c %--------------------------%
c | Quick return if possible |
c %--------------------------%
c
if( n.eq.0 )
& return
if( ilo.eq.ihi ) then
wr( ilo ) = h( ilo, ilo )
wi( ilo ) = zero
return
end if
c
c %---------------------------------------------%
c | Initialize the vector of last components of |
c | the Schur vectors for accumulation. |
c %---------------------------------------------%
c
do 5 j = 1, n-1
z(j) = zero
5 continue
z(n) = one
c
nh = ihi - ilo + 1
c
c %-------------------------------------------------------------%
c | Set machine-dependent constants for the stopping criterion. |
c | If norm(H) <= sqrt(OVFL), overflow should not occur. |
c %-------------------------------------------------------------%
c
unfl = dlamch( 'safe minimum' )
ovfl = one / unfl
call dlabad( unfl, ovfl )
ulp = dlamch( 'precision' )
smlnum = unfl*( nh / ulp )
c
c %---------------------------------------------------------------%
c | I1 and I2 are the indices of the first row and last column |
c | of H to which transformations must be applied. If eigenvalues |
c | only are computed, I1 and I2 are set inside the main loop. |
c | Zero out H(J+2,J) = ZERO for J=1:N if WANTT = .TRUE. |
c | else H(J+2,J) for J=ILO:IHI-ILO-1 if WANTT = .FALSE. |
c %---------------------------------------------------------------%
c
if( wantt ) then
i1 = 1
i2 = n
do 8 i=1,i2-2
h(i1+i+1,i) = zero
8 continue
else
do 9 i=1, ihi-ilo-1
h(ilo+i+1,ilo+i-1) = zero
9 continue
end if
c
c %---------------------------------------------------%
c | ITN is the total number of QR iterations allowed. |
c %---------------------------------------------------%
c
itn = 30*nh
c
c ------------------------------------------------------------------
c The main loop begins here. I is the loop index and decreases from
c IHI to ILO in steps of 1 or 2. Each iteration of the loop works
c with the active submatrix in rows and columns L to I.
c Eigenvalues I+1 to IHI have already converged. Either L = ILO or
c H(L,L-1) is negligible so that the matrix splits.
c ------------------------------------------------------------------
c
i = ihi
10 continue
l = ilo
if( i.lt.ilo )
& go to 150
c %--------------------------------------------------------------%
c | Perform QR iterations on rows and columns ILO to I until a |
c | submatrix of order 1 or 2 splits off at the bottom because a |
c | subdiagonal element has become negligible. |
c %--------------------------------------------------------------%
do 130 its = 0, itn
c
c %----------------------------------------------%
c | Look for a single small subdiagonal element. |
c %----------------------------------------------%
c
do 20 k = i, l + 1, -1
tst1 = abs( h( k-1, k-1 ) ) + abs( h( k, k ) )
if( tst1.eq.zero )
& tst1 = dlanhs( '1', i-l+1, h( l, l ), ldh, work )
if( abs( h( k, k-1 ) ).le.max( ulp*tst1, smlnum ) )
& go to 30
20 continue
30 continue
l = k
if( l.gt.ilo ) then
c
c %------------------------%
c | H(L,L-1) is negligible |
c %------------------------%
c
h( l, l-1 ) = zero
end if
c
c %-------------------------------------------------------------%
c | Exit from loop if a submatrix of order 1 or 2 has split off |
c %-------------------------------------------------------------%
c
if( l.ge.i-1 )
& go to 140
c
c %---------------------------------------------------------%
c | Now the active submatrix is in rows and columns L to I. |
c | If eigenvalues only are being computed, only the active |
c | submatrix need be transformed. |
c %---------------------------------------------------------%
c
if( .not.wantt ) then
i1 = l
i2 = i
end if
c
if( its.eq.10 .or. its.eq.20 ) then
c
c %-------------------%
c | Exceptional shift |
c %-------------------%
c
s = abs( h( i, i-1 ) ) + abs( h( i-1, i-2 ) )
h44 = dat1*s
h33 = h44
h43h34 = dat2*s*s
c
else
c
c %-----------------------------------------%
c | Prepare to use Wilkinson's double shift |
c %-----------------------------------------%
c
h44 = h( i, i )
h33 = h( i-1, i-1 )
h43h34 = h( i, i-1 )*h( i-1, i )
end if
c
c %-----------------------------------------------------%
c | Look for two consecutive small subdiagonal elements |
c %-----------------------------------------------------%
c
do 40 m = i - 2, l, -1
c
c %---------------------------------------------------------%
c | Determine the effect of starting the double-shift QR |
c | iteration at row M, and see if this would make H(M,M-1) |
c | negligible. |
c %---------------------------------------------------------%
c
h11 = h( m, m )
h22 = h( m+1, m+1 )
h21 = h( m+1, m )
h12 = h( m, m+1 )
h44s = h44 - h11
h33s = h33 - h11
v1 = ( h33s*h44s-h43h34 ) / h21 + h12
v2 = h22 - h11 - h33s - h44s
v3 = h( m+2, m+1 )
s = abs( v1 ) + abs( v2 ) + abs( v3 )
v1 = v1 / s
v2 = v2 / s
v3 = v3 / s
v( 1 ) = v1
v( 2 ) = v2
v( 3 ) = v3
if( m.eq.l )
& go to 50
h00 = h( m-1, m-1 )
h10 = h( m, m-1 )
tst1 = abs( v1 )*( abs( h00 )+abs( h11 )+abs( h22 ) )
if( abs( h10 )*( abs( v2 )+abs( v3 ) ).le.ulp*tst1 )
& go to 50
40 continue
50 continue
c
c %----------------------%
c | Double-shift QR step |
c %----------------------%
c
do 120 k = m, i - 1
c
c ------------------------------------------------------------
c The first iteration of this loop determines a reflection G
c from the vector V and applies it from left and right to H,
c thus creating a nonzero bulge below the subdiagonal.
c
c Each subsequent iteration determines a reflection G to
c restore the Hessenberg form in the (K-1)th column, and thus
c chases the bulge one step toward the bottom of the active
c submatrix. NR is the order of G.
c ------------------------------------------------------------
c
nr = min( 3, i-k+1 )
if( k.gt.m )
& call dcopy( nr, h( k, k-1 ), 1, v, 1 )
call dlarfg( nr, v( 1 ), v( 2 ), 1, t1 )
if( k.gt.m ) then
h( k, k-1 ) = v( 1 )
h( k+1, k-1 ) = zero
if( k.lt.i-1 )
& h( k+2, k-1 ) = zero
else if( m.gt.l ) then
h( k, k-1 ) = -h( k, k-1 )
end if
v2 = v( 2 )
t2 = t1*v2
if( nr.eq.3 ) then
v3 = v( 3 )
t3 = t1*v3
c
c %------------------------------------------------%
c | Apply G from the left to transform the rows of |
c | the matrix in columns K to I2. |
c %------------------------------------------------%
c
do 60 j = k, i2
sum = h( k, j ) + v2*h( k+1, j ) + v3*h( k+2, j )
h( k, j ) = h( k, j ) - sum*t1
h( k+1, j ) = h( k+1, j ) - sum*t2
h( k+2, j ) = h( k+2, j ) - sum*t3
60 continue
c
c %----------------------------------------------------%
c | Apply G from the right to transform the columns of |
c | the matrix in rows I1 to min(K+3,I). |
c %----------------------------------------------------%
c
do 70 j = i1, min( k+3, i )
sum = h( j, k ) + v2*h( j, k+1 ) + v3*h( j, k+2 )
h( j, k ) = h( j, k ) - sum*t1
h( j, k+1 ) = h( j, k+1 ) - sum*t2
h( j, k+2 ) = h( j, k+2 ) - sum*t3
70 continue
c
c %----------------------------------%
c | Accumulate transformations for Z |
c %----------------------------------%
c
sum = z( k ) + v2*z( k+1 ) + v3*z( k+2 )
z( k ) = z( k ) - sum*t1
z( k+1 ) = z( k+1 ) - sum*t2
z( k+2 ) = z( k+2 ) - sum*t3
else if( nr.eq.2 ) then
c
c %------------------------------------------------%
c | Apply G from the left to transform the rows of |
c | the matrix in columns K to I2. |
c %------------------------------------------------%
c
do 90 j = k, i2
sum = h( k, j ) + v2*h( k+1, j )
h( k, j ) = h( k, j ) - sum*t1
h( k+1, j ) = h( k+1, j ) - sum*t2
90 continue
c
c %----------------------------------------------------%
c | Apply G from the right to transform the columns of |
c | the matrix in rows I1 to min(K+3,I). |
c %----------------------------------------------------%
c
do 100 j = i1, i
sum = h( j, k ) + v2*h( j, k+1 )
h( j, k ) = h( j, k ) - sum*t1
h( j, k+1 ) = h( j, k+1 ) - sum*t2
100 continue
c
c %----------------------------------%
c | Accumulate transformations for Z |
c %----------------------------------%
c
sum = z( k ) + v2*z( k+1 )
z( k ) = z( k ) - sum*t1
z( k+1 ) = z( k+1 ) - sum*t2
end if
120 continue
130 continue
c
c %-------------------------------------------------------%
c | Failure to converge in remaining number of iterations |
c %-------------------------------------------------------%
c
info = i
return
140 continue
if( l.eq.i ) then
c
c %------------------------------------------------------%
c | H(I,I-1) is negligible: one eigenvalue has converged |
c %------------------------------------------------------%
c
wr( i ) = h( i, i )
wi( i ) = zero
else if( l.eq.i-1 ) then
c
c %--------------------------------------------------------%
c | H(I-1,I-2) is negligible; |
c | a pair of eigenvalues have converged. |
c | |
c | Transform the 2-by-2 submatrix to standard Schur form, |
c | and compute and store the eigenvalues. |
c %--------------------------------------------------------%
c
call dlanv2( h( i-1, i-1 ), h( i-1, i ), h( i, i-1 ),
& h( i, i ), wr( i-1 ), wi( i-1 ), wr( i ), wi( i ),
& cs, sn )
if( wantt ) then
c
c %-----------------------------------------------------%
c | Apply the transformation to the rest of H and to Z, |
c | as required. |
c %-----------------------------------------------------%
c
if( i2.gt.i )
& call drot( i2-i, h( i-1, i+1 ), ldh, h( i, i+1 ), ldh,
& cs, sn )
call drot( i-i1-1, h( i1, i-1 ), 1, h( i1, i ), 1, cs, sn )
sum = cs*z( i-1 ) + sn*z( i )
z( i ) = cs*z( i ) - sn*z( i-1 )
z( i-1 ) = sum
end if
end if
c
c %---------------------------------------------------------%
c | Decrement number of remaining iterations, and return to |
c | start of the main loop with new value of I. |
c %---------------------------------------------------------%
c
itn = itn - its
i = l - 1
go to 10
150 continue
return
c
c %---------------%
c | End of dlaqrb |
c %---------------%
c
end

840
arpack/ARPACK/SRC/dnaitr.f Normal file
View File

@@ -0,0 +1,840 @@
c-----------------------------------------------------------------------
c\BeginDoc
c
c\Name: dnaitr
c
c\Description:
c Reverse communication interface for applying NP additional steps to
c a K step nonsymmetric Arnoldi factorization.
c
c Input: OP*V_{k} - V_{k}*H = r_{k}*e_{k}^T
c
c with (V_{k}^T)*B*V_{k} = I, (V_{k}^T)*B*r_{k} = 0.
c
c Output: OP*V_{k+p} - V_{k+p}*H = r_{k+p}*e_{k+p}^T
c
c with (V_{k+p}^T)*B*V_{k+p} = I, (V_{k+p}^T)*B*r_{k+p} = 0.
c
c where OP and B are as in dnaupd. The B-norm of r_{k+p} is also
c computed and returned.
c
c\Usage:
c call dnaitr
c ( IDO, BMAT, N, K, NP, NB, RESID, RNORM, V, LDV, H, LDH,
c IPNTR, WORKD, INFO )
c
c\Arguments
c IDO Integer. (INPUT/OUTPUT)
c Reverse communication flag.
c -------------------------------------------------------------
c IDO = 0: first call to the reverse communication interface
c IDO = -1: compute Y = OP * X where
c IPNTR(1) is the pointer into WORK for X,
c IPNTR(2) is the pointer into WORK for Y.
c This is for the restart phase to force the new
c starting vector into the range of OP.
c IDO = 1: compute Y = OP * X where
c IPNTR(1) is the pointer into WORK for X,
c IPNTR(2) is the pointer into WORK for Y,
c IPNTR(3) is the pointer into WORK for B * X.
c IDO = 2: compute Y = B * X where
c IPNTR(1) is the pointer into WORK for X,
c IPNTR(2) is the pointer into WORK for Y.
c IDO = 99: done
c -------------------------------------------------------------
c When the routine is used in the "shift-and-invert" mode, the
c vector B * Q is already available and do not need to be
c recompute in forming OP * Q.
c
c BMAT Character*1. (INPUT)
c BMAT specifies the type of the matrix B that defines the
c semi-inner product for the operator OP. See dnaupd.
c B = 'I' -> standard eigenvalue problem A*x = lambda*x
c B = 'G' -> generalized eigenvalue problem A*x = lambda*M**x
c
c N Integer. (INPUT)
c Dimension of the eigenproblem.
c
c K Integer. (INPUT)
c Current size of V and H.
c
c NP Integer. (INPUT)
c Number of additional Arnoldi steps to take.
c
c NB Integer. (INPUT)
c Blocksize to be used in the recurrence.
c Only work for NB = 1 right now. The goal is to have a
c program that implement both the block and non-block method.
c
c RESID Double precision array of length N. (INPUT/OUTPUT)
c On INPUT: RESID contains the residual vector r_{k}.
c On OUTPUT: RESID contains the residual vector r_{k+p}.
c
c RNORM Double precision scalar. (INPUT/OUTPUT)
c B-norm of the starting residual on input.
c B-norm of the updated residual r_{k+p} on output.
c
c V Double precision N by K+NP array. (INPUT/OUTPUT)
c On INPUT: V contains the Arnoldi vectors in the first K
c columns.
c On OUTPUT: V contains the new NP Arnoldi vectors in the next
c NP columns. The first K columns are unchanged.
c
c LDV Integer. (INPUT)
c Leading dimension of V exactly as declared in the calling
c program.
c
c H Double precision (K+NP) by (K+NP) array. (INPUT/OUTPUT)
c H is used to store the generated upper Hessenberg matrix.
c
c LDH Integer. (INPUT)
c Leading dimension of H exactly as declared in the calling
c program.
c
c IPNTR Integer array of length 3. (OUTPUT)
c Pointer to mark the starting locations in the WORK for
c vectors used by the Arnoldi iteration.
c -------------------------------------------------------------
c IPNTR(1): pointer to the current operand vector X.
c IPNTR(2): pointer to the current result vector Y.
c IPNTR(3): pointer to the vector B * X when used in the
c shift-and-invert mode. X is the current operand.
c -------------------------------------------------------------
c
c WORKD Double precision work array of length 3*N. (REVERSE COMMUNICATION)
c Distributed array to be used in the basic Arnoldi iteration
c for reverse communication. The calling program should not
c use WORKD as temporary workspace during the iteration !!!!!!
c On input, WORKD(1:N) = B*RESID and is used to save some
c computation at the first step.
c
c INFO Integer. (OUTPUT)
c = 0: Normal exit.
c > 0: Size of the spanning invariant subspace of OP found.
c
c\EndDoc
c
c-----------------------------------------------------------------------
c
c\BeginLib
c
c\Local variables:
c xxxxxx real
c
c\References:
c 1. D.C. Sorensen, "Implicit Application of Polynomial Filters in
c a k-Step Arnoldi Method", SIAM J. Matr. Anal. Apps., 13 (1992),
c pp 357-385.
c 2. R.B. Lehoucq, "Analysis and Implementation of an Implicitly
c Restarted Arnoldi Iteration", Rice University Technical Report
c TR95-13, Department of Computational and Applied Mathematics.
c
c\Routines called:
c dgetv0 ARPACK routine to generate the initial vector.
c ivout ARPACK utility routine that prints integers.
c second ARPACK utility routine for timing.
c dmout ARPACK utility routine that prints matrices
c dvout ARPACK utility routine that prints vectors.
c dlabad LAPACK routine that computes machine constants.
c dlamch LAPACK routine that determines machine constants.
c dlascl LAPACK routine for careful scaling of a matrix.
c dlanhs LAPACK routine that computes various norms of a matrix.
c dgemv Level 2 BLAS routine for matrix vector multiplication.
c daxpy Level 1 BLAS that computes a vector triad.
c dscal Level 1 BLAS that scales a vector.
c dcopy Level 1 BLAS that copies one vector to another .
c ddot Level 1 BLAS that computes the scalar product of two vectors.
c dnrm2 Level 1 BLAS that computes the norm of a vector.
c
c\Author
c Danny Sorensen Phuong Vu
c Richard Lehoucq CRPC / Rice University
c Dept. of Computational & Houston, Texas
c Applied Mathematics
c Rice University
c Houston, Texas
c
c\Revision history:
c xx/xx/92: Version ' 2.4'
c
c\SCCS Information: @(#)
c FILE: naitr.F SID: 2.4 DATE OF SID: 8/27/96 RELEASE: 2
c
c\Remarks
c The algorithm implemented is:
c
c restart = .false.
c Given V_{k} = [v_{1}, ..., v_{k}], r_{k};
c r_{k} contains the initial residual vector even for k = 0;
c Also assume that rnorm = || B*r_{k} || and B*r_{k} are already
c computed by the calling program.
c
c betaj = rnorm ; p_{k+1} = B*r_{k} ;
c For j = k+1, ..., k+np Do
c 1) if ( betaj < tol ) stop or restart depending on j.
c ( At present tol is zero )
c if ( restart ) generate a new starting vector.
c 2) v_{j} = r(j-1)/betaj; V_{j} = [V_{j-1}, v_{j}];
c p_{j} = p_{j}/betaj
c 3) r_{j} = OP*v_{j} where OP is defined as in dnaupd
c For shift-invert mode p_{j} = B*v_{j} is already available.
c wnorm = || OP*v_{j} ||
c 4) Compute the j-th step residual vector.
c w_{j} = V_{j}^T * B * OP * v_{j}
c r_{j} = OP*v_{j} - V_{j} * w_{j}
c H(:,j) = w_{j};
c H(j,j-1) = rnorm
c rnorm = || r_(j) ||
c If (rnorm > 0.717*wnorm) accept step and go back to 1)
c 5) Re-orthogonalization step:
c s = V_{j}'*B*r_{j}
c r_{j} = r_{j} - V_{j}*s; rnorm1 = || r_{j} ||
c alphaj = alphaj + s_{j};
c 6) Iterative refinement step:
c If (rnorm1 > 0.717*rnorm) then
c rnorm = rnorm1
c accept step and go back to 1)
c Else
c rnorm = rnorm1
c If this is the first time in step 6), go to 5)
c Else r_{j} lies in the span of V_{j} numerically.
c Set r_{j} = 0 and rnorm = 0; go to 1)
c EndIf
c End Do
c
c\EndLib
c
c-----------------------------------------------------------------------
c
subroutine dnaitr
& (ido, bmat, n, k, np, nb, resid, rnorm, v, ldv, h, ldh,
& ipntr, workd, info)
c
c %----------------------------------------------------%
c | Include files for debugging and timing information |
c %----------------------------------------------------%
c
include 'debug.h'
include 'stat.h'
c
c %------------------%
c | Scalar Arguments |
c %------------------%
c
character bmat*1
integer ido, info, k, ldh, ldv, n, nb, np
Double precision
& rnorm
c
c %-----------------%
c | Array Arguments |
c %-----------------%
c
integer ipntr(3)
Double precision
& h(ldh,k+np), resid(n), v(ldv,k+np), workd(3*n)
c
c %------------%
c | Parameters |
c %------------%
c
Double precision
& one, zero
parameter (one = 1.0D+0, zero = 0.0D+0)
c
c %---------------%
c | Local Scalars |
c %---------------%
c
logical first, orth1, orth2, rstart, step3, step4
integer ierr, i, infol, ipj, irj, ivj, iter, itry, j, msglvl,
& jj
Double precision
& betaj, ovfl, temp1, rnorm1, smlnum, tst1, ulp, unfl,
& wnorm
save first, orth1, orth2, rstart, step3, step4,
& ierr, ipj, irj, ivj, iter, itry, j, msglvl, ovfl,
& betaj, rnorm1, smlnum, ulp, unfl, wnorm
c
c %-----------------------%
c | Local Array Arguments |
c %-----------------------%
c
Double precision
& xtemp(2)
c
c %----------------------%
c | External Subroutines |
c %----------------------%
c
external daxpy, dcopy, dscal, dgemv, dgetv0, dlabad,
& dvout, dmout, ivout, second
c
c %--------------------%
c | External Functions |
c %--------------------%
c
Double precision
& ddot, dnrm2, dlanhs, dlamch
external ddot, dnrm2, dlanhs, dlamch
c
c %---------------------%
c | Intrinsic Functions |
c %---------------------%
c
intrinsic abs, sqrt
c
c %-----------------%
c | Data statements |
c %-----------------%
c
data first / .true. /
c
c %-----------------------%
c | Executable Statements |
c %-----------------------%
c
if (first) then
c
c %-----------------------------------------%
c | Set machine-dependent constants for the |
c | the splitting and deflation criterion. |
c | If norm(H) <= sqrt(OVFL), |
c | overflow should not occur. |
c | REFERENCE: LAPACK subroutine dlahqr |
c %-----------------------------------------%
c
unfl = dlamch( 'safe minimum' )
ovfl = one / unfl
call dlabad( unfl, ovfl )
ulp = dlamch( 'precision' )
smlnum = unfl*( n / ulp )
first = .false.
end if
c
if (ido .eq. 0) then
c
c %-------------------------------%
c | Initialize timing statistics |
c | & message level for debugging |
c %-------------------------------%
c
call second (t0)
msglvl = mnaitr
c
c %------------------------------%
c | Initial call to this routine |
c %------------------------------%
c
info = 0
step3 = .false.
step4 = .false.
rstart = .false.
orth1 = .false.
orth2 = .false.
j = k + 1
ipj = 1
irj = ipj + n
ivj = irj + n
end if
c
c %-------------------------------------------------%
c | When in reverse communication mode one of: |
c | STEP3, STEP4, ORTH1, ORTH2, RSTART |
c | will be .true. when .... |
c | STEP3: return from computing OP*v_{j}. |
c | STEP4: return from computing B-norm of OP*v_{j} |
c | ORTH1: return from computing B-norm of r_{j+1} |
c | ORTH2: return from computing B-norm of |
c | correction to the residual vector. |
c | RSTART: return from OP computations needed by |
c | dgetv0. |
c %-------------------------------------------------%
c
if (step3) go to 50
if (step4) go to 60
if (orth1) go to 70
if (orth2) go to 90
if (rstart) go to 30
c
c %-----------------------------%
c | Else this is the first step |
c %-----------------------------%
c
c %--------------------------------------------------------------%
c | |
c | A R N O L D I I T E R A T I O N L O O P |
c | |
c | Note: B*r_{j-1} is already in WORKD(1:N)=WORKD(IPJ:IPJ+N-1) |
c %--------------------------------------------------------------%
1000 continue
c
if (msglvl .gt. 1) then
call ivout (logfil, 1, j, ndigit,
& '_naitr: generating Arnoldi vector number')
call dvout (logfil, 1, rnorm, ndigit,
& '_naitr: B-norm of the current residual is')
end if
c
c %---------------------------------------------------%
c | STEP 1: Check if the B norm of j-th residual |
c | vector is zero. Equivalent to determing whether |
c | an exact j-step Arnoldi factorization is present. |
c %---------------------------------------------------%
c
betaj = rnorm
if (rnorm .gt. zero) go to 40
c
c %---------------------------------------------------%
c | Invariant subspace found, generate a new starting |
c | vector which is orthogonal to the current Arnoldi |
c | basis and continue the iteration. |
c %---------------------------------------------------%
c
if (msglvl .gt. 0) then
call ivout (logfil, 1, j, ndigit,
& '_naitr: ****** RESTART AT STEP ******')
end if
c
c %---------------------------------------------%
c | ITRY is the loop variable that controls the |
c | maximum amount of times that a restart is |
c | attempted. NRSTRT is used by stat.h |
c %---------------------------------------------%
c
betaj = zero
nrstrt = nrstrt + 1
itry = 1
20 continue
rstart = .true.
ido = 0
30 continue
c
c %--------------------------------------%
c | If in reverse communication mode and |
c | RSTART = .true. flow returns here. |
c %--------------------------------------%
c
call dgetv0 (ido, bmat, itry, .false., n, j, v, ldv,
& resid, rnorm, ipntr, workd, ierr)
if (ido .ne. 99) go to 9000
if (ierr .lt. 0) then
itry = itry + 1
if (itry .le. 3) go to 20
c
c %------------------------------------------------%
c | Give up after several restart attempts. |
c | Set INFO to the size of the invariant subspace |
c | which spans OP and exit. |
c %------------------------------------------------%
c
info = j - 1
call second (t1)
tnaitr = tnaitr + (t1 - t0)
ido = 99
go to 9000
end if
c
40 continue
c
c %---------------------------------------------------------%
c | STEP 2: v_{j} = r_{j-1}/rnorm and p_{j} = p_{j}/rnorm |
c | Note that p_{j} = B*r_{j-1}. In order to avoid overflow |
c | when reciprocating a small RNORM, test against lower |
c | machine bound. |
c %---------------------------------------------------------%
c
call dcopy (n, resid, 1, v(1,j), 1)
if (rnorm .ge. unfl) then
temp1 = one / rnorm
call dscal (n, temp1, v(1,j), 1)
call dscal (n, temp1, workd(ipj), 1)
else
c
c %-----------------------------------------%
c | To scale both v_{j} and p_{j} carefully |
c | use LAPACK routine SLASCL |
c %-----------------------------------------%
c
call dlascl ('General', i, i, rnorm, one, n, 1,
& v(1,j), n, infol)
call dlascl ('General', i, i, rnorm, one, n, 1,
& workd(ipj), n, infol)
end if
c
c %------------------------------------------------------%
c | STEP 3: r_{j} = OP*v_{j}; Note that p_{j} = B*v_{j} |
c | Note that this is not quite yet r_{j}. See STEP 4 |
c %------------------------------------------------------%
c
step3 = .true.
nopx = nopx + 1
call second (t2)
call dcopy (n, v(1,j), 1, workd(ivj), 1)
ipntr(1) = ivj
ipntr(2) = irj
ipntr(3) = ipj
ido = 1
c
c %-----------------------------------%
c | Exit in order to compute OP*v_{j} |
c %-----------------------------------%
c
go to 9000
50 continue
c
c %----------------------------------%
c | Back from reverse communication; |
c | WORKD(IRJ:IRJ+N-1) := OP*v_{j} |
c | if step3 = .true. |
c %----------------------------------%
c
call second (t3)
tmvopx = tmvopx + (t3 - t2)
step3 = .false.
c
c %------------------------------------------%
c | Put another copy of OP*v_{j} into RESID. |
c %------------------------------------------%
c
call dcopy (n, workd(irj), 1, resid, 1)
c
c %---------------------------------------%
c | STEP 4: Finish extending the Arnoldi |
c | factorization to length j. |
c %---------------------------------------%
c
call second (t2)
if (bmat .eq. 'G') then
nbx = nbx + 1
step4 = .true.
ipntr(1) = irj
ipntr(2) = ipj
ido = 2
c
c %-------------------------------------%
c | Exit in order to compute B*OP*v_{j} |
c %-------------------------------------%
c
go to 9000
else if (bmat .eq. 'I') then
call dcopy (n, resid, 1, workd(ipj), 1)
end if
60 continue
c
c %----------------------------------%
c | Back from reverse communication; |
c | WORKD(IPJ:IPJ+N-1) := B*OP*v_{j} |
c | if step4 = .true. |
c %----------------------------------%
c
if (bmat .eq. 'G') then
call second (t3)
tmvbx = tmvbx + (t3 - t2)
end if
c
step4 = .false.
c
c %-------------------------------------%
c | The following is needed for STEP 5. |
c | Compute the B-norm of OP*v_{j}. |
c %-------------------------------------%
c
if (bmat .eq. 'G') then
wnorm = ddot (n, resid, 1, workd(ipj), 1)
wnorm = sqrt(abs(wnorm))
else if (bmat .eq. 'I') then
wnorm = dnrm2(n, resid, 1)
end if
c
c %-----------------------------------------%
c | Compute the j-th residual corresponding |
c | to the j step factorization. |
c | Use Classical Gram Schmidt and compute: |
c | w_{j} <- V_{j}^T * B * OP * v_{j} |
c | r_{j} <- OP*v_{j} - V_{j} * w_{j} |
c %-----------------------------------------%
c
c
c %------------------------------------------%
c | Compute the j Fourier coefficients w_{j} |
c | WORKD(IPJ:IPJ+N-1) contains B*OP*v_{j}. |
c %------------------------------------------%
c
call dgemv ('T', n, j, one, v, ldv, workd(ipj), 1,
& zero, h(1,j), 1)
c
c %--------------------------------------%
c | Orthogonalize r_{j} against V_{j}. |
c | RESID contains OP*v_{j}. See STEP 3. |
c %--------------------------------------%
c
call dgemv ('N', n, j, -one, v, ldv, h(1,j), 1,
& one, resid, 1)
c
if (j .gt. 1) h(j,j-1) = betaj
c
call second (t4)
c
orth1 = .true.
c
call second (t2)
if (bmat .eq. 'G') then
nbx = nbx + 1
call dcopy (n, resid, 1, workd(irj), 1)
ipntr(1) = irj
ipntr(2) = ipj
ido = 2
c
c %----------------------------------%
c | Exit in order to compute B*r_{j} |
c %----------------------------------%
c
go to 9000
else if (bmat .eq. 'I') then
call dcopy (n, resid, 1, workd(ipj), 1)
end if
70 continue
c
c %---------------------------------------------------%
c | Back from reverse communication if ORTH1 = .true. |
c | WORKD(IPJ:IPJ+N-1) := B*r_{j}. |
c %---------------------------------------------------%
c
if (bmat .eq. 'G') then
call second (t3)
tmvbx = tmvbx + (t3 - t2)
end if
c
orth1 = .false.
c
c %------------------------------%
c | Compute the B-norm of r_{j}. |
c %------------------------------%
c
if (bmat .eq. 'G') then
rnorm = ddot (n, resid, 1, workd(ipj), 1)
rnorm = sqrt(abs(rnorm))
else if (bmat .eq. 'I') then
rnorm = dnrm2(n, resid, 1)
end if
c
c %-----------------------------------------------------------%
c | STEP 5: Re-orthogonalization / Iterative refinement phase |
c | Maximum NITER_ITREF tries. |
c | |
c | s = V_{j}^T * B * r_{j} |
c | r_{j} = r_{j} - V_{j}*s |
c | alphaj = alphaj + s_{j} |
c | |
c | The stopping criteria used for iterative refinement is |
c | discussed in Parlett's book SEP, page 107 and in Gragg & |
c | Reichel ACM TOMS paper; Algorithm 686, Dec. 1990. |
c | Determine if we need to correct the residual. The goal is |
c | to enforce ||v(:,1:j)^T * r_{j}|| .le. eps * || r_{j} || |
c | The following test determines whether the sine of the |
c | angle between OP*x and the computed residual is less |
c | than or equal to 0.717. |
c %-----------------------------------------------------------%
c
if (rnorm .gt. 0.717*wnorm) go to 100
iter = 0
nrorth = nrorth + 1
c
c %---------------------------------------------------%
c | Enter the Iterative refinement phase. If further |
c | refinement is necessary, loop back here. The loop |
c | variable is ITER. Perform a step of Classical |
c | Gram-Schmidt using all the Arnoldi vectors V_{j} |
c %---------------------------------------------------%
c
80 continue
c
if (msglvl .gt. 2) then
xtemp(1) = wnorm
xtemp(2) = rnorm
call dvout (logfil, 2, xtemp, ndigit,
& '_naitr: re-orthonalization; wnorm and rnorm are')
call dvout (logfil, j, h(1,j), ndigit,
& '_naitr: j-th column of H')
end if
c
c %----------------------------------------------------%
c | Compute V_{j}^T * B * r_{j}. |
c | WORKD(IRJ:IRJ+J-1) = v(:,1:J)'*WORKD(IPJ:IPJ+N-1). |
c %----------------------------------------------------%
c
call dgemv ('T', n, j, one, v, ldv, workd(ipj), 1,
& zero, workd(irj), 1)
c
c %---------------------------------------------%
c | Compute the correction to the residual: |
c | r_{j} = r_{j} - V_{j} * WORKD(IRJ:IRJ+J-1). |
c | The correction to H is v(:,1:J)*H(1:J,1:J) |
c | + v(:,1:J)*WORKD(IRJ:IRJ+J-1)*e'_j. |
c %---------------------------------------------%
c
call dgemv ('N', n, j, -one, v, ldv, workd(irj), 1,
& one, resid, 1)
call daxpy (j, one, workd(irj), 1, h(1,j), 1)
c
orth2 = .true.
call second (t2)
if (bmat .eq. 'G') then
nbx = nbx + 1
call dcopy (n, resid, 1, workd(irj), 1)
ipntr(1) = irj
ipntr(2) = ipj
ido = 2
c
c %-----------------------------------%
c | Exit in order to compute B*r_{j}. |
c | r_{j} is the corrected residual. |
c %-----------------------------------%
c
go to 9000
else if (bmat .eq. 'I') then
call dcopy (n, resid, 1, workd(ipj), 1)
end if
90 continue
c
c %---------------------------------------------------%
c | Back from reverse communication if ORTH2 = .true. |
c %---------------------------------------------------%
c
if (bmat .eq. 'G') then
call second (t3)
tmvbx = tmvbx + (t3 - t2)
end if
c
c %-----------------------------------------------------%
c | Compute the B-norm of the corrected residual r_{j}. |
c %-----------------------------------------------------%
c
if (bmat .eq. 'G') then
rnorm1 = ddot (n, resid, 1, workd(ipj), 1)
rnorm1 = sqrt(abs(rnorm1))
else if (bmat .eq. 'I') then
rnorm1 = dnrm2(n, resid, 1)
end if
c
if (msglvl .gt. 0 .and. iter .gt. 0) then
call ivout (logfil, 1, j, ndigit,
& '_naitr: Iterative refinement for Arnoldi residual')
if (msglvl .gt. 2) then
xtemp(1) = rnorm
xtemp(2) = rnorm1
call dvout (logfil, 2, xtemp, ndigit,
& '_naitr: iterative refinement ; rnorm and rnorm1 are')
end if
end if
c
c %-----------------------------------------%
c | Determine if we need to perform another |
c | step of re-orthogonalization. |
c %-----------------------------------------%
c
if (rnorm1 .gt. 0.717*rnorm) then
c
c %---------------------------------------%
c | No need for further refinement. |
c | The cosine of the angle between the |
c | corrected residual vector and the old |
c | residual vector is greater than 0.717 |
c | In other words the corrected residual |
c | and the old residual vector share an |
c | angle of less than arcCOS(0.717) |
c %---------------------------------------%
c
rnorm = rnorm1
c
else
c
c %-------------------------------------------%
c | Another step of iterative refinement step |
c | is required. NITREF is used by stat.h |
c %-------------------------------------------%
c
nitref = nitref + 1
rnorm = rnorm1
iter = iter + 1
if (iter .le. 1) go to 80
c
c %-------------------------------------------------%
c | Otherwise RESID is numerically in the span of V |
c %-------------------------------------------------%
c
do 95 jj = 1, n
resid(jj) = zero
95 continue
rnorm = zero
end if
c
c %----------------------------------------------%
c | Branch here directly if iterative refinement |
c | wasn't necessary or after at most NITER_REF |
c | steps of iterative refinement. |
c %----------------------------------------------%
c
100 continue
c
rstart = .false.
orth2 = .false.
c
call second (t5)
titref = titref + (t5 - t4)
c
c %------------------------------------%
c | STEP 6: Update j = j+1; Continue |
c %------------------------------------%
c
j = j + 1
if (j .gt. k+np) then
call second (t1)
tnaitr = tnaitr + (t1 - t0)
ido = 99
do 110 i = max(1,k), k+np-1
c
c %--------------------------------------------%
c | Check for splitting and deflation. |
c | Use a standard test as in the QR algorithm |
c | REFERENCE: LAPACK subroutine dlahqr |
c %--------------------------------------------%
c
tst1 = abs( h( i, i ) ) + abs( h( i+1, i+1 ) )
if( tst1.eq.zero )
& tst1 = dlanhs( '1', k+np, h, ldh, workd(n+1) )
if( abs( h( i+1,i ) ).le.max( ulp*tst1, smlnum ) )
& h(i+1,i) = zero
110 continue
c
if (msglvl .gt. 2) then
call dmout (logfil, k+np, k+np, h, ldh, ndigit,
& '_naitr: Final upper Hessenberg matrix H of order K+NP')
end if
c
go to 9000
end if
c
c %--------------------------------------------------------%
c | Loop back to extend the factorization by another step. |
c %--------------------------------------------------------%
c
go to 1000
c
c %---------------------------------------------------------------%
c | |
c | E N D O F M A I N I T E R A T I O N L O O P |
c | |
c %---------------------------------------------------------------%
c
9000 continue
return
c
c %---------------%
c | End of dnaitr |
c %---------------%
c
end

647
arpack/ARPACK/SRC/dnapps.f Normal file
View File

@@ -0,0 +1,647 @@
c-----------------------------------------------------------------------
c\BeginDoc
c
c\Name: dnapps
c
c\Description:
c Given the Arnoldi factorization
c
c A*V_{k} - V_{k}*H_{k} = r_{k+p}*e_{k+p}^T,
c
c apply NP implicit shifts resulting in
c
c A*(V_{k}*Q) - (V_{k}*Q)*(Q^T* H_{k}*Q) = r_{k+p}*e_{k+p}^T * Q
c
c where Q is an orthogonal matrix which is the product of rotations
c and reflections resulting from the NP bulge chage sweeps.
c The updated Arnoldi factorization becomes:
c
c A*VNEW_{k} - VNEW_{k}*HNEW_{k} = rnew_{k}*e_{k}^T.
c
c\Usage:
c call dnapps
c ( N, KEV, NP, SHIFTR, SHIFTI, V, LDV, H, LDH, RESID, Q, LDQ,
c WORKL, WORKD )
c
c\Arguments
c N Integer. (INPUT)
c Problem size, i.e. size of matrix A.
c
c KEV Integer. (INPUT/OUTPUT)
c KEV+NP is the size of the input matrix H.
c KEV is the size of the updated matrix HNEW. KEV is only
c updated on ouput when fewer than NP shifts are applied in
c order to keep the conjugate pair together.
c
c NP Integer. (INPUT)
c Number of implicit shifts to be applied.
c
c SHIFTR, Double precision array of length NP. (INPUT)
c SHIFTI Real and imaginary part of the shifts to be applied.
c Upon, entry to dnapps, the shifts must be sorted so that the
c conjugate pairs are in consecutive locations.
c
c V Double precision N by (KEV+NP) array. (INPUT/OUTPUT)
c On INPUT, V contains the current KEV+NP Arnoldi vectors.
c On OUTPUT, V contains the updated KEV Arnoldi vectors
c in the first KEV columns of V.
c
c LDV Integer. (INPUT)
c Leading dimension of V exactly as declared in the calling
c program.
c
c H Double precision (KEV+NP) by (KEV+NP) array. (INPUT/OUTPUT)
c On INPUT, H contains the current KEV+NP by KEV+NP upper
c Hessenber matrix of the Arnoldi factorization.
c On OUTPUT, H contains the updated KEV by KEV upper Hessenberg
c matrix in the KEV leading submatrix.
c
c LDH Integer. (INPUT)
c Leading dimension of H exactly as declared in the calling
c program.
c
c RESID Double precision array of length N. (INPUT/OUTPUT)
c On INPUT, RESID contains the the residual vector r_{k+p}.
c On OUTPUT, RESID is the update residual vector rnew_{k}
c in the first KEV locations.
c
c Q Double precision KEV+NP by KEV+NP work array. (WORKSPACE)
c Work array used to accumulate the rotations and reflections
c during the bulge chase sweep.
c
c LDQ Integer. (INPUT)
c Leading dimension of Q exactly as declared in the calling
c program.
c
c WORKL Double precision work array of length (KEV+NP). (WORKSPACE)
c Private (replicated) array on each PE or array allocated on
c the front end.
c
c WORKD Double precision work array of length 2*N. (WORKSPACE)
c Distributed array used in the application of the accumulated
c orthogonal matrix Q.
c
c\EndDoc
c
c-----------------------------------------------------------------------
c
c\BeginLib
c
c\Local variables:
c xxxxxx real
c
c\References:
c 1. D.C. Sorensen, "Implicit Application of Polynomial Filters in
c a k-Step Arnoldi Method", SIAM J. Matr. Anal. Apps., 13 (1992),
c pp 357-385.
c
c\Routines called:
c ivout ARPACK utility routine that prints integers.
c second ARPACK utility routine for timing.
c dmout ARPACK utility routine that prints matrices.
c dvout ARPACK utility routine that prints vectors.
c dlabad LAPACK routine that computes machine constants.
c dlacpy LAPACK matrix copy routine.
c dlamch LAPACK routine that determines machine constants.
c dlanhs LAPACK routine that computes various norms of a matrix.
c dlapy2 LAPACK routine to compute sqrt(x**2+y**2) carefully.
c dlarf LAPACK routine that applies Householder reflection to
c a matrix.
c dlarfg LAPACK Householder reflection construction routine.
c dlartg LAPACK Givens rotation construction routine.
c dlaset LAPACK matrix initialization routine.
c dgemv Level 2 BLAS routine for matrix vector multiplication.
c daxpy Level 1 BLAS that computes a vector triad.
c dcopy Level 1 BLAS that copies one vector to another .
c dscal Level 1 BLAS that scales a vector.
c
c\Author
c Danny Sorensen Phuong Vu
c Richard Lehoucq CRPC / Rice University
c Dept. of Computational & Houston, Texas
c Applied Mathematics
c Rice University
c Houston, Texas
c
c\Revision history:
c xx/xx/92: Version ' 2.4'
c
c\SCCS Information: @(#)
c FILE: napps.F SID: 2.4 DATE OF SID: 3/28/97 RELEASE: 2
c
c\Remarks
c 1. In this version, each shift is applied to all the sublocks of
c the Hessenberg matrix H and not just to the submatrix that it
c comes from. Deflation as in LAPACK routine dlahqr (QR algorithm
c for upper Hessenberg matrices ) is used.
c The subdiagonals of H are enforced to be non-negative.
c
c\EndLib
c
c-----------------------------------------------------------------------
c
subroutine dnapps
& ( n, kev, np, shiftr, shifti, v, ldv, h, ldh, resid, q, ldq,
& workl, workd )
c
c %----------------------------------------------------%
c | Include files for debugging and timing information |
c %----------------------------------------------------%
c
include 'debug.h'
include 'stat.h'
c
c %------------------%
c | Scalar Arguments |
c %------------------%
c
integer kev, ldh, ldq, ldv, n, np
c
c %-----------------%
c | Array Arguments |
c %-----------------%
c
Double precision
& h(ldh,kev+np), resid(n), shifti(np), shiftr(np),
& v(ldv,kev+np), q(ldq,kev+np), workd(2*n), workl(kev+np)
c
c %------------%
c | Parameters |
c %------------%
c
Double precision
& one, zero
parameter (one = 1.0D+0, zero = 0.0D+0)
c
c %------------------------%
c | Local Scalars & Arrays |
c %------------------------%
c
integer i, iend, ir, istart, j, jj, kplusp, msglvl, nr
logical cconj, first
Double precision
& c, f, g, h11, h12, h21, h22, h32, ovfl, r, s, sigmai,
& sigmar, smlnum, ulp, unfl, u(3), t, tau, tst1
save first, ovfl, smlnum, ulp, unfl
c
c %----------------------%
c | External Subroutines |
c %----------------------%
c
external daxpy, dcopy, dscal, dlacpy, dlarfg, dlarf,
& dlaset, dlabad, second, dlartg
c
c %--------------------%
c | External Functions |
c %--------------------%
c
Double precision
& dlamch, dlanhs, dlapy2
external dlamch, dlanhs, dlapy2
c
c %----------------------%
c | Intrinsics Functions |
c %----------------------%
c
intrinsic abs, max, min
c
c %----------------%
c | Data statments |
c %----------------%
c
data first / .true. /
c
c %-----------------------%
c | Executable Statements |
c %-----------------------%
c
if (first) then
c
c %-----------------------------------------------%
c | Set machine-dependent constants for the |
c | stopping criterion. If norm(H) <= sqrt(OVFL), |
c | overflow should not occur. |
c | REFERENCE: LAPACK subroutine dlahqr |
c %-----------------------------------------------%
c
unfl = dlamch( 'safe minimum' )
ovfl = one / unfl
call dlabad( unfl, ovfl )
ulp = dlamch( 'precision' )
smlnum = unfl*( n / ulp )
first = .false.
end if
c
c %-------------------------------%
c | Initialize timing statistics |
c | & message level for debugging |
c %-------------------------------%
c
call second (t0)
msglvl = mnapps
kplusp = kev + np
c
c %--------------------------------------------%
c | Initialize Q to the identity to accumulate |
c | the rotations and reflections |
c %--------------------------------------------%
c
call dlaset ('All', kplusp, kplusp, zero, one, q, ldq)
c
c %----------------------------------------------%
c | Quick return if there are no shifts to apply |
c %----------------------------------------------%
c
if (np .eq. 0) go to 9000
c
c %----------------------------------------------%
c | Chase the bulge with the application of each |
c | implicit shift. Each shift is applied to the |
c | whole matrix including each block. |
c %----------------------------------------------%
c
cconj = .false.
do 110 jj = 1, np
sigmar = shiftr(jj)
sigmai = shifti(jj)
c
if (msglvl .gt. 2 ) then
call ivout (logfil, 1, jj, ndigit,
& '_napps: shift number.')
call dvout (logfil, 1, sigmar, ndigit,
& '_napps: The real part of the shift ')
call dvout (logfil, 1, sigmai, ndigit,
& '_napps: The imaginary part of the shift ')
end if
c
c %-------------------------------------------------%
c | The following set of conditionals is necessary |
c | in order that complex conjugate pairs of shifts |
c | are applied together or not at all. |
c %-------------------------------------------------%
c
if ( cconj ) then
c
c %-----------------------------------------%
c | cconj = .true. means the previous shift |
c | had non-zero imaginary part. |
c %-----------------------------------------%
c
cconj = .false.
go to 110
else if ( jj .lt. np .and. abs( sigmai ) .gt. zero ) then
c
c %------------------------------------%
c | Start of a complex conjugate pair. |
c %------------------------------------%
c
cconj = .true.
else if ( jj .eq. np .and. abs( sigmai ) .gt. zero ) then
c
c %----------------------------------------------%
c | The last shift has a nonzero imaginary part. |
c | Don't apply it; thus the order of the |
c | compressed H is order KEV+1 since only np-1 |
c | were applied. |
c %----------------------------------------------%
c
kev = kev + 1
go to 110
end if
istart = 1
20 continue
c
c %--------------------------------------------------%
c | if sigmai = 0 then |
c | Apply the jj-th shift ... |
c | else |
c | Apply the jj-th and (jj+1)-th together ... |
c | (Note that jj < np at this point in the code) |
c | end |
c | to the current block of H. The next do loop |
c | determines the current block ; |
c %--------------------------------------------------%
c
do 30 i = istart, kplusp-1
c
c %----------------------------------------%
c | Check for splitting and deflation. Use |
c | a standard test as in the QR algorithm |
c | REFERENCE: LAPACK subroutine dlahqr |
c %----------------------------------------%
c
tst1 = abs( h( i, i ) ) + abs( h( i+1, i+1 ) )
if( tst1.eq.zero )
& tst1 = dlanhs( '1', kplusp-jj+1, h, ldh, workl )
if( abs( h( i+1,i ) ).le.max( ulp*tst1, smlnum ) ) then
if (msglvl .gt. 0) then
call ivout (logfil, 1, i, ndigit,
& '_napps: matrix splitting at row/column no.')
call ivout (logfil, 1, jj, ndigit,
& '_napps: matrix splitting with shift number.')
call dvout (logfil, 1, h(i+1,i), ndigit,
& '_napps: off diagonal element.')
end if
iend = i
h(i+1,i) = zero
go to 40
end if
30 continue
iend = kplusp
40 continue
c
if (msglvl .gt. 2) then
call ivout (logfil, 1, istart, ndigit,
& '_napps: Start of current block ')
call ivout (logfil, 1, iend, ndigit,
& '_napps: End of current block ')
end if
c
c %------------------------------------------------%
c | No reason to apply a shift to block of order 1 |
c %------------------------------------------------%
c
if ( istart .eq. iend ) go to 100
c
c %------------------------------------------------------%
c | If istart + 1 = iend then no reason to apply a |
c | complex conjugate pair of shifts on a 2 by 2 matrix. |
c %------------------------------------------------------%
c
if ( istart + 1 .eq. iend .and. abs( sigmai ) .gt. zero )
& go to 100
c
h11 = h(istart,istart)
h21 = h(istart+1,istart)
if ( abs( sigmai ) .le. zero ) then
c
c %---------------------------------------------%
c | Real-valued shift ==> apply single shift QR |
c %---------------------------------------------%
c
f = h11 - sigmar
g = h21
c
do 80 i = istart, iend-1
c
c %-----------------------------------------------------%
c | Contruct the plane rotation G to zero out the bulge |
c %-----------------------------------------------------%
c
call dlartg (f, g, c, s, r)
if (i .gt. istart) then
c
c %-------------------------------------------%
c | The following ensures that h(1:iend-1,1), |
c | the first iend-2 off diagonal of elements |
c | H, remain non negative. |
c %-------------------------------------------%
c
if (r .lt. zero) then
r = -r
c = -c
s = -s
end if
h(i,i-1) = r
h(i+1,i-1) = zero
end if
c
c %---------------------------------------------%
c | Apply rotation to the left of H; H <- G'*H |
c %---------------------------------------------%
c
do 50 j = i, kplusp
t = c*h(i,j) + s*h(i+1,j)
h(i+1,j) = -s*h(i,j) + c*h(i+1,j)
h(i,j) = t
50 continue
c
c %---------------------------------------------%
c | Apply rotation to the right of H; H <- H*G |
c %---------------------------------------------%
c
do 60 j = 1, min(i+2,iend)
t = c*h(j,i) + s*h(j,i+1)
h(j,i+1) = -s*h(j,i) + c*h(j,i+1)
h(j,i) = t
60 continue
c
c %----------------------------------------------------%
c | Accumulate the rotation in the matrix Q; Q <- Q*G |
c %----------------------------------------------------%
c
do 70 j = 1, min( i+jj, kplusp )
t = c*q(j,i) + s*q(j,i+1)
q(j,i+1) = - s*q(j,i) + c*q(j,i+1)
q(j,i) = t
70 continue
c
c %---------------------------%
c | Prepare for next rotation |
c %---------------------------%
c
if (i .lt. iend-1) then
f = h(i+1,i)
g = h(i+2,i)
end if
80 continue
c
c %-----------------------------------%
c | Finished applying the real shift. |
c %-----------------------------------%
c
else
c
c %----------------------------------------------------%
c | Complex conjugate shifts ==> apply double shift QR |
c %----------------------------------------------------%
c
h12 = h(istart,istart+1)
h22 = h(istart+1,istart+1)
h32 = h(istart+2,istart+1)
c
c %---------------------------------------------------------%
c | Compute 1st column of (H - shift*I)*(H - conj(shift)*I) |
c %---------------------------------------------------------%
c
s = 2.0*sigmar
t = dlapy2 ( sigmar, sigmai )
u(1) = ( h11 * (h11 - s) + t * t ) / h21 + h12
u(2) = h11 + h22 - s
u(3) = h32
c
do 90 i = istart, iend-1
c
nr = min ( 3, iend-i+1 )
c
c %-----------------------------------------------------%
c | Construct Householder reflector G to zero out u(1). |
c | G is of the form I - tau*( 1 u )' * ( 1 u' ). |
c %-----------------------------------------------------%
c
call dlarfg ( nr, u(1), u(2), 1, tau )
c
if (i .gt. istart) then
h(i,i-1) = u(1)
h(i+1,i-1) = zero
if (i .lt. iend-1) h(i+2,i-1) = zero
end if
u(1) = one
c
c %--------------------------------------%
c | Apply the reflector to the left of H |
c %--------------------------------------%
c
call dlarf ('Left', nr, kplusp-i+1, u, 1, tau,
& h(i,i), ldh, workl)
c
c %---------------------------------------%
c | Apply the reflector to the right of H |
c %---------------------------------------%
c
ir = min ( i+3, iend )
call dlarf ('Right', ir, nr, u, 1, tau,
& h(1,i), ldh, workl)
c
c %-----------------------------------------------------%
c | Accumulate the reflector in the matrix Q; Q <- Q*G |
c %-----------------------------------------------------%
c
call dlarf ('Right', kplusp, nr, u, 1, tau,
& q(1,i), ldq, workl)
c
c %----------------------------%
c | Prepare for next reflector |
c %----------------------------%
c
if (i .lt. iend-1) then
u(1) = h(i+1,i)
u(2) = h(i+2,i)
if (i .lt. iend-2) u(3) = h(i+3,i)
end if
c
90 continue
c
c %--------------------------------------------%
c | Finished applying a complex pair of shifts |
c | to the current block |
c %--------------------------------------------%
c
end if
c
100 continue
c
c %---------------------------------------------------------%
c | Apply the same shift to the next block if there is any. |
c %---------------------------------------------------------%
c
istart = iend + 1
if (iend .lt. kplusp) go to 20
c
c %---------------------------------------------%
c | Loop back to the top to get the next shift. |
c %---------------------------------------------%
c
110 continue
c
c %--------------------------------------------------%
c | Perform a similarity transformation that makes |
c | sure that H will have non negative sub diagonals |
c %--------------------------------------------------%
c
do 120 j=1,kev
if ( h(j+1,j) .lt. zero ) then
call dscal( kplusp-j+1, -one, h(j+1,j), ldh )
call dscal( min(j+2, kplusp), -one, h(1,j+1), 1 )
call dscal( min(j+np+1,kplusp), -one, q(1,j+1), 1 )
end if
120 continue
c
do 130 i = 1, kev
c
c %--------------------------------------------%
c | Final check for splitting and deflation. |
c | Use a standard test as in the QR algorithm |
c | REFERENCE: LAPACK subroutine dlahqr |
c %--------------------------------------------%
c
tst1 = abs( h( i, i ) ) + abs( h( i+1, i+1 ) )
if( tst1.eq.zero )
& tst1 = dlanhs( '1', kev, h, ldh, workl )
if( h( i+1,i ) .le. max( ulp*tst1, smlnum ) )
& h(i+1,i) = zero
130 continue
c
c %-------------------------------------------------%
c | Compute the (kev+1)-st column of (V*Q) and |
c | temporarily store the result in WORKD(N+1:2*N). |
c | This is needed in the residual update since we |
c | cannot GUARANTEE that the corresponding entry |
c | of H would be zero as in exact arithmetic. |
c %-------------------------------------------------%
c
if (h(kev+1,kev) .gt. zero)
& call dgemv ('N', n, kplusp, one, v, ldv, q(1,kev+1), 1, zero,
& workd(n+1), 1)
c
c %----------------------------------------------------------%
c | Compute column 1 to kev of (V*Q) in backward order |
c | taking advantage of the upper Hessenberg structure of Q. |
c %----------------------------------------------------------%
c
do 140 i = 1, kev
call dgemv ('N', n, kplusp-i+1, one, v, ldv,
& q(1,kev-i+1), 1, zero, workd, 1)
call dcopy (n, workd, 1, v(1,kplusp-i+1), 1)
140 continue
c
c %-------------------------------------------------%
c | Move v(:,kplusp-kev+1:kplusp) into v(:,1:kev). |
c %-------------------------------------------------%
c
call dlacpy ('A', n, kev, v(1,kplusp-kev+1), ldv, v, ldv)
c
c %--------------------------------------------------------------%
c | Copy the (kev+1)-st column of (V*Q) in the appropriate place |
c %--------------------------------------------------------------%
c
if (h(kev+1,kev) .gt. zero)
& call dcopy (n, workd(n+1), 1, v(1,kev+1), 1)
c
c %-------------------------------------%
c | Update the residual vector: |
c | r <- sigmak*r + betak*v(:,kev+1) |
c | where |
c | sigmak = (e_{kplusp}'*Q)*e_{kev} |
c | betak = e_{kev+1}'*H*e_{kev} |
c %-------------------------------------%
c
call dscal (n, q(kplusp,kev), resid, 1)
if (h(kev+1,kev) .gt. zero)
& call daxpy (n, h(kev+1,kev), v(1,kev+1), 1, resid, 1)
c
if (msglvl .gt. 1) then
call dvout (logfil, 1, q(kplusp,kev), ndigit,
& '_napps: sigmak = (e_{kev+p}^T*Q)*e_{kev}')
call dvout (logfil, 1, h(kev+1,kev), ndigit,
& '_napps: betak = e_{kev+1}^T*H*e_{kev}')
call ivout (logfil, 1, kev, ndigit,
& '_napps: Order of the final Hessenberg matrix ')
if (msglvl .gt. 2) then
call dmout (logfil, kev, kev, h, ldh, ndigit,
& '_napps: updated Hessenberg matrix H for next iteration')
end if
c
end if
c
9000 continue
call second (t1)
tnapps = tnapps + (t1 - t0)
c
return
c
c %---------------%
c | End of dnapps |
c %---------------%
c
end

835
arpack/ARPACK/SRC/dnaup2.f Normal file
View File

@@ -0,0 +1,835 @@
c\BeginDoc
c
c\Name: dnaup2
c
c\Description:
c Intermediate level interface called by dnaupd.
c
c\Usage:
c call dnaup2
c ( IDO, BMAT, N, WHICH, NEV, NP, TOL, RESID, MODE, IUPD,
c ISHIFT, MXITER, V, LDV, H, LDH, RITZR, RITZI, BOUNDS,
c Q, LDQ, WORKL, IPNTR, WORKD, INFO )
c
c\Arguments
c
c IDO, BMAT, N, WHICH, NEV, TOL, RESID: same as defined in dnaupd.
c MODE, ISHIFT, MXITER: see the definition of IPARAM in dnaupd.
c
c NP Integer. (INPUT/OUTPUT)
c Contains the number of implicit shifts to apply during
c each Arnoldi iteration.
c If ISHIFT=1, NP is adjusted dynamically at each iteration
c to accelerate convergence and prevent stagnation.
c This is also roughly equal to the number of matrix-vector
c products (involving the operator OP) per Arnoldi iteration.
c The logic for adjusting is contained within the current
c subroutine.
c If ISHIFT=0, NP is the number of shifts the user needs
c to provide via reverse comunication. 0 < NP < NCV-NEV.
c NP may be less than NCV-NEV for two reasons. The first, is
c to keep complex conjugate pairs of "wanted" Ritz values
c together. The second, is that a leading block of the current
c upper Hessenberg matrix has split off and contains "unwanted"
c Ritz values.
c Upon termination of the IRA iteration, NP contains the number
c of "converged" wanted Ritz values.
c
c IUPD Integer. (INPUT)
c IUPD .EQ. 0: use explicit restart instead implicit update.
c IUPD .NE. 0: use implicit update.
c
c V Double precision N by (NEV+NP) array. (INPUT/OUTPUT)
c The Arnoldi basis vectors are returned in the first NEV
c columns of V.
c
c LDV Integer. (INPUT)
c Leading dimension of V exactly as declared in the calling
c program.
c
c H Double precision (NEV+NP) by (NEV+NP) array. (OUTPUT)
c H is used to store the generated upper Hessenberg matrix
c
c LDH Integer. (INPUT)
c Leading dimension of H exactly as declared in the calling
c program.
c
c RITZR, Double precision arrays of length NEV+NP. (OUTPUT)
c RITZI RITZR(1:NEV) (resp. RITZI(1:NEV)) contains the real (resp.
c imaginary) part of the computed Ritz values of OP.
c
c BOUNDS Double precision array of length NEV+NP. (OUTPUT)
c BOUNDS(1:NEV) contain the error bounds corresponding to
c the computed Ritz values.
c
c Q Double precision (NEV+NP) by (NEV+NP) array. (WORKSPACE)
c Private (replicated) work array used to accumulate the
c rotation in the shift application step.
c
c LDQ Integer. (INPUT)
c Leading dimension of Q exactly as declared in the calling
c program.
c
c WORKL Double precision work array of length at least
c (NEV+NP)**2 + 3*(NEV+NP). (INPUT/WORKSPACE)
c Private (replicated) array on each PE or array allocated on
c the front end. It is used in shifts calculation, shifts
c application and convergence checking.
c
c On exit, the last 3*(NEV+NP) locations of WORKL contain
c the Ritz values (real,imaginary) and associated Ritz
c estimates of the current Hessenberg matrix. They are
c listed in the same order as returned from dneigh.
c
c If ISHIFT .EQ. O and IDO .EQ. 3, the first 2*NP locations
c of WORKL are used in reverse communication to hold the user
c supplied shifts.
c
c IPNTR Integer array of length 3. (OUTPUT)
c Pointer to mark the starting locations in the WORKD for
c vectors used by the Arnoldi iteration.
c -------------------------------------------------------------
c IPNTR(1): pointer to the current operand vector X.
c IPNTR(2): pointer to the current result vector Y.
c IPNTR(3): pointer to the vector B * X when used in the
c shift-and-invert mode. X is the current operand.
c -------------------------------------------------------------
c
c WORKD Double precision work array of length 3*N. (WORKSPACE)
c Distributed array to be used in the basic Arnoldi iteration
c for reverse communication. The user should not use WORKD
c as temporary workspace during the iteration !!!!!!!!!!
c See Data Distribution Note in DNAUPD.
c
c INFO Integer. (INPUT/OUTPUT)
c If INFO .EQ. 0, a randomly initial residual vector is used.
c If INFO .NE. 0, RESID contains the initial residual vector,
c possibly from a previous run.
c Error flag on output.
c = 0: Normal return.
c = 1: Maximum number of iterations taken.
c All possible eigenvalues of OP has been found.
c NP returns the number of converged Ritz values.
c = 2: No shifts could be applied.
c = -8: Error return from LAPACK eigenvalue calculation;
c This should never happen.
c = -9: Starting vector is zero.
c = -9999: Could not build an Arnoldi factorization.
c Size that was built in returned in NP.
c
c\EndDoc
c
c-----------------------------------------------------------------------
c
c\BeginLib
c
c\Local variables:
c xxxxxx real
c
c\References:
c 1. D.C. Sorensen, "Implicit Application of Polynomial Filters in
c a k-Step Arnoldi Method", SIAM J. Matr. Anal. Apps., 13 (1992),
c pp 357-385.
c 2. R.B. Lehoucq, "Analysis and Implementation of an Implicitly
c Restarted Arnoldi Iteration", Rice University Technical Report
c TR95-13, Department of Computational and Applied Mathematics.
c
c\Routines called:
c dgetv0 ARPACK initial vector generation routine.
c dnaitr ARPACK Arnoldi factorization routine.
c dnapps ARPACK application of implicit shifts routine.
c dnconv ARPACK convergence of Ritz values routine.
c dneigh ARPACK compute Ritz values and error bounds routine.
c dngets ARPACK reorder Ritz values and error bounds routine.
c dsortc ARPACK sorting routine.
c ivout ARPACK utility routine that prints integers.
c second ARPACK utility routine for timing.
c dmout ARPACK utility routine that prints matrices
c dvout ARPACK utility routine that prints vectors.
c dlamch LAPACK routine that determines machine constants.
c dlapy2 LAPACK routine to compute sqrt(x**2+y**2) carefully.
c dcopy Level 1 BLAS that copies one vector to another .
c ddot Level 1 BLAS that computes the scalar product of two vectors.
c dnrm2 Level 1 BLAS that computes the norm of a vector.
c dswap Level 1 BLAS that swaps two vectors.
c
c\Author
c Danny Sorensen Phuong Vu
c Richard Lehoucq CRPC / Rice University
c Dept. of Computational & Houston, Texas
c Applied Mathematics
c Rice University
c Houston, Texas
c
c\SCCS Information: @(#)
c FILE: naup2.F SID: 2.8 DATE OF SID: 10/17/00 RELEASE: 2
c
c\Remarks
c 1. None
c
c\EndLib
c
c-----------------------------------------------------------------------
c
subroutine dnaup2
& ( ido, bmat, n, which, nev, np, tol, resid, mode, iupd,
& ishift, mxiter, v, ldv, h, ldh, ritzr, ritzi, bounds,
& q, ldq, workl, ipntr, workd, info )
c
c %----------------------------------------------------%
c | Include files for debugging and timing information |
c %----------------------------------------------------%
c
include 'debug.h'
include 'stat.h'
c
c %------------------%
c | Scalar Arguments |
c %------------------%
c
character bmat*1, which*2
integer ido, info, ishift, iupd, mode, ldh, ldq, ldv, mxiter,
& n, nev, np
Double precision
& tol
c
c %-----------------%
c | Array Arguments |
c %-----------------%
c
integer ipntr(13)
Double precision
& bounds(nev+np), h(ldh,nev+np), q(ldq,nev+np), resid(n),
& ritzi(nev+np), ritzr(nev+np), v(ldv,nev+np),
& workd(3*n), workl( (nev+np)*(nev+np+3) )
c
c %------------%
c | Parameters |
c %------------%
c
Double precision
& one, zero
parameter (one = 1.0D+0, zero = 0.0D+0)
c
c %---------------%
c | Local Scalars |
c %---------------%
c
character wprime*2
logical cnorm , getv0, initv, update, ushift
integer ierr , iter , j , kplusp, msglvl, nconv,
& nevbef, nev0 , np0 , nptemp, numcnv
Double precision
& rnorm , temp , eps23
save cnorm , getv0, initv, update, ushift,
& rnorm , iter , eps23, kplusp, msglvl, nconv ,
& nevbef, nev0 , np0 , numcnv
c
c %-----------------------%
c | Local array arguments |
c %-----------------------%
c
integer kp(4)
c
c %----------------------%
c | External Subroutines |
c %----------------------%
c
external dcopy , dgetv0, dnaitr, dnconv, dneigh,
& dngets, dnapps, dvout , ivout , second
c
c %--------------------%
c | External Functions |
c %--------------------%
c
Double precision
& ddot, dnrm2, dlapy2, dlamch
external ddot, dnrm2, dlapy2, dlamch
c
c %---------------------%
c | Intrinsic Functions |
c %---------------------%
c
intrinsic min, max, abs, sqrt
c
c %-----------------------%
c | Executable Statements |
c %-----------------------%
c
if (ido .eq. 0) then
c
call second (t0)
c
msglvl = mnaup2
c
c %-------------------------------------%
c | Get the machine dependent constant. |
c %-------------------------------------%
c
eps23 = dlamch('Epsilon-Machine')
eps23 = eps23**(2.0D+0 / 3.0D+0)
c
nev0 = nev
np0 = np
c
c %-------------------------------------%
c | kplusp is the bound on the largest |
c | Lanczos factorization built. |
c | nconv is the current number of |
c | "converged" eigenvlues. |
c | iter is the counter on the current |
c | iteration step. |
c %-------------------------------------%
c
kplusp = nev + np
nconv = 0
iter = 0
c
c %---------------------------------------%
c | Set flags for computing the first NEV |
c | steps of the Arnoldi factorization. |
c %---------------------------------------%
c
getv0 = .true.
update = .false.
ushift = .false.
cnorm = .false.
c
if (info .ne. 0) then
c
c %--------------------------------------------%
c | User provides the initial residual vector. |
c %--------------------------------------------%
c
initv = .true.
info = 0
else
initv = .false.
end if
end if
c
c %---------------------------------------------%
c | Get a possibly random starting vector and |
c | force it into the range of the operator OP. |
c %---------------------------------------------%
c
10 continue
c
if (getv0) then
call dgetv0 (ido, bmat, 1, initv, n, 1, v, ldv, resid, rnorm,
& ipntr, workd, info)
c
if (ido .ne. 99) go to 9000
c
if (rnorm .eq. zero) then
c
c %-----------------------------------------%
c | The initial vector is zero. Error exit. |
c %-----------------------------------------%
c
info = -9
go to 1100
end if
getv0 = .false.
ido = 0
end if
c
c %-----------------------------------%
c | Back from reverse communication : |
c | continue with update step |
c %-----------------------------------%
c
if (update) go to 20
c
c %-------------------------------------------%
c | Back from computing user specified shifts |
c %-------------------------------------------%
c
if (ushift) go to 50
c
c %-------------------------------------%
c | Back from computing residual norm |
c | at the end of the current iteration |
c %-------------------------------------%
c
if (cnorm) go to 100
c
c %----------------------------------------------------------%
c | Compute the first NEV steps of the Arnoldi factorization |
c %----------------------------------------------------------%
c
call dnaitr (ido, bmat, n, 0, nev, mode, resid, rnorm, v, ldv,
& h, ldh, ipntr, workd, info)
c
c %---------------------------------------------------%
c | ido .ne. 99 implies use of reverse communication |
c | to compute operations involving OP and possibly B |
c %---------------------------------------------------%
c
if (ido .ne. 99) go to 9000
c
if (info .gt. 0) then
np = info
mxiter = iter
info = -9999
go to 1200
end if
c
c %--------------------------------------------------------------%
c | |
c | M A I N ARNOLDI I T E R A T I O N L O O P |
c | Each iteration implicitly restarts the Arnoldi |
c | factorization in place. |
c | |
c %--------------------------------------------------------------%
c
1000 continue
c
iter = iter + 1
c
if (msglvl .gt. 0) then
call ivout (logfil, 1, iter, ndigit,
& '_naup2: **** Start of major iteration number ****')
end if
c
c %-----------------------------------------------------------%
c | Compute NP additional steps of the Arnoldi factorization. |
c | Adjust NP since NEV might have been updated by last call |
c | to the shift application routine dnapps. |
c %-----------------------------------------------------------%
c
np = kplusp - nev
c
if (msglvl .gt. 1) then
call ivout (logfil, 1, nev, ndigit,
& '_naup2: The length of the current Arnoldi factorization')
call ivout (logfil, 1, np, ndigit,
& '_naup2: Extend the Arnoldi factorization by')
end if
c
c %-----------------------------------------------------------%
c | Compute NP additional steps of the Arnoldi factorization. |
c %-----------------------------------------------------------%
c
ido = 0
20 continue
update = .true.
c
call dnaitr (ido , bmat, n , nev, np , mode , resid,
& rnorm, v , ldv, h , ldh, ipntr, workd,
& info)
c
c %---------------------------------------------------%
c | ido .ne. 99 implies use of reverse communication |
c | to compute operations involving OP and possibly B |
c %---------------------------------------------------%
c
if (ido .ne. 99) go to 9000
c
if (info .gt. 0) then
np = info
mxiter = iter
info = -9999
go to 1200
end if
update = .false.
c
if (msglvl .gt. 1) then
call dvout (logfil, 1, rnorm, ndigit,
& '_naup2: Corresponding B-norm of the residual')
end if
c
c %--------------------------------------------------------%
c | Compute the eigenvalues and corresponding error bounds |
c | of the current upper Hessenberg matrix. |
c %--------------------------------------------------------%
c
call dneigh (rnorm, kplusp, h, ldh, ritzr, ritzi, bounds,
& q, ldq, workl, ierr)
c
if (ierr .ne. 0) then
info = -8
go to 1200
end if
c
c %----------------------------------------------------%
c | Make a copy of eigenvalues and corresponding error |
c | bounds obtained from dneigh. |
c %----------------------------------------------------%
c
call dcopy(kplusp, ritzr, 1, workl(kplusp**2+1), 1)
call dcopy(kplusp, ritzi, 1, workl(kplusp**2+kplusp+1), 1)
call dcopy(kplusp, bounds, 1, workl(kplusp**2+2*kplusp+1), 1)
c
c %---------------------------------------------------%
c | Select the wanted Ritz values and their bounds |
c | to be used in the convergence test. |
c | The wanted part of the spectrum and corresponding |
c | error bounds are in the last NEV loc. of RITZR, |
c | RITZI and BOUNDS respectively. The variables NEV |
c | and NP may be updated if the NEV-th wanted Ritz |
c | value has a non zero imaginary part. In this case |
c | NEV is increased by one and NP decreased by one. |
c | NOTE: The last two arguments of dngets are no |
c | longer used as of version 2.1. |
c %---------------------------------------------------%
c
nev = nev0
np = np0
numcnv = nev
call dngets (ishift, which, nev, np, ritzr, ritzi,
& bounds, workl, workl(np+1))
if (nev .eq. nev0+1) numcnv = nev0+1
c
c %-------------------%
c | Convergence test. |
c %-------------------%
c
call dcopy (nev, bounds(np+1), 1, workl(2*np+1), 1)
call dnconv (nev, ritzr(np+1), ritzi(np+1), workl(2*np+1),
& tol, nconv)
c
if (msglvl .gt. 2) then
kp(1) = nev
kp(2) = np
kp(3) = numcnv
kp(4) = nconv
call ivout (logfil, 4, kp, ndigit,
& '_naup2: NEV, NP, NUMCNV, NCONV are')
call dvout (logfil, kplusp, ritzr, ndigit,
& '_naup2: Real part of the eigenvalues of H')
call dvout (logfil, kplusp, ritzi, ndigit,
& '_naup2: Imaginary part of the eigenvalues of H')
call dvout (logfil, kplusp, bounds, ndigit,
& '_naup2: Ritz estimates of the current NCV Ritz values')
end if
c
c %---------------------------------------------------------%
c | Count the number of unwanted Ritz values that have zero |
c | Ritz estimates. If any Ritz estimates are equal to zero |
c | then a leading block of H of order equal to at least |
c | the number of Ritz values with zero Ritz estimates has |
c | split off. None of these Ritz values may be removed by |
c | shifting. Decrease NP the number of shifts to apply. If |
c | no shifts may be applied, then prepare to exit |
c %---------------------------------------------------------%
c
nptemp = np
do 30 j=1, nptemp
if (bounds(j) .eq. zero) then
np = np - 1
nev = nev + 1
end if
30 continue
c
if ( (nconv .ge. numcnv) .or.
& (iter .gt. mxiter) .or.
& (np .eq. 0) ) then
c
if (msglvl .gt. 4) then
call dvout(logfil, kplusp, workl(kplusp**2+1), ndigit,
& '_naup2: Real part of the eig computed by _neigh:')
call dvout(logfil, kplusp, workl(kplusp**2+kplusp+1),
& ndigit,
& '_naup2: Imag part of the eig computed by _neigh:')
call dvout(logfil, kplusp, workl(kplusp**2+kplusp*2+1),
& ndigit,
& '_naup2: Ritz eistmates computed by _neigh:')
end if
c
c %------------------------------------------------%
c | Prepare to exit. Put the converged Ritz values |
c | and corresponding bounds in RITZ(1:NCONV) and |
c | BOUNDS(1:NCONV) respectively. Then sort. Be |
c | careful when NCONV > NP |
c %------------------------------------------------%
c
c %------------------------------------------%
c | Use h( 3,1 ) as storage to communicate |
c | rnorm to _neupd if needed |
c %------------------------------------------%
h(3,1) = rnorm
c
c %----------------------------------------------%
c | To be consistent with dngets, we first do a |
c | pre-processing sort in order to keep complex |
c | conjugate pairs together. This is similar |
c | to the pre-processing sort used in dngets |
c | except that the sort is done in the opposite |
c | order. |
c %----------------------------------------------%
c
if (which .eq. 'LM') wprime = 'SR'
if (which .eq. 'SM') wprime = 'LR'
if (which .eq. 'LR') wprime = 'SM'
if (which .eq. 'SR') wprime = 'LM'
if (which .eq. 'LI') wprime = 'SM'
if (which .eq. 'SI') wprime = 'LM'
c
call dsortc (wprime, .true., kplusp, ritzr, ritzi, bounds)
c
c %----------------------------------------------%
c | Now sort Ritz values so that converged Ritz |
c | values appear within the first NEV locations |
c | of ritzr, ritzi and bounds, and the most |
c | desired one appears at the front. |
c %----------------------------------------------%
c
if (which .eq. 'LM') wprime = 'SM'
if (which .eq. 'SM') wprime = 'LM'
if (which .eq. 'LR') wprime = 'SR'
if (which .eq. 'SR') wprime = 'LR'
if (which .eq. 'LI') wprime = 'SI'
if (which .eq. 'SI') wprime = 'LI'
c
call dsortc(wprime, .true., kplusp, ritzr, ritzi, bounds)
c
c %--------------------------------------------------%
c | Scale the Ritz estimate of each Ritz value |
c | by 1 / max(eps23,magnitude of the Ritz value). |
c %--------------------------------------------------%
c
do 35 j = 1, numcnv
temp = max(eps23,dlapy2(ritzr(j),
& ritzi(j)))
bounds(j) = bounds(j)/temp
35 continue
c
c %----------------------------------------------------%
c | Sort the Ritz values according to the scaled Ritz |
c | esitmates. This will push all the converged ones |
c | towards the front of ritzr, ritzi, bounds |
c | (in the case when NCONV < NEV.) |
c %----------------------------------------------------%
c
wprime = 'LR'
call dsortc(wprime, .true., numcnv, bounds, ritzr, ritzi)
c
c %----------------------------------------------%
c | Scale the Ritz estimate back to its original |
c | value. |
c %----------------------------------------------%
c
do 40 j = 1, numcnv
temp = max(eps23, dlapy2(ritzr(j),
& ritzi(j)))
bounds(j) = bounds(j)*temp
40 continue
c
c %------------------------------------------------%
c | Sort the converged Ritz values again so that |
c | the "threshold" value appears at the front of |
c | ritzr, ritzi and bound. |
c %------------------------------------------------%
c
call dsortc(which, .true., nconv, ritzr, ritzi, bounds)
c
if (msglvl .gt. 1) then
call dvout (logfil, kplusp, ritzr, ndigit,
& '_naup2: Sorted real part of the eigenvalues')
call dvout (logfil, kplusp, ritzi, ndigit,
& '_naup2: Sorted imaginary part of the eigenvalues')
call dvout (logfil, kplusp, bounds, ndigit,
& '_naup2: Sorted ritz estimates.')
end if
c
c %------------------------------------%
c | Max iterations have been exceeded. |
c %------------------------------------%
c
if (iter .gt. mxiter .and. nconv .lt. numcnv) info = 1
c
c %---------------------%
c | No shifts to apply. |
c %---------------------%
c
if (np .eq. 0 .and. nconv .lt. numcnv) info = 2
c
np = nconv
go to 1100
c
else if ( (nconv .lt. numcnv) .and. (ishift .eq. 1) ) then
c
c %-------------------------------------------------%
c | Do not have all the requested eigenvalues yet. |
c | To prevent possible stagnation, adjust the size |
c | of NEV. |
c %-------------------------------------------------%
c
nevbef = nev
nev = nev + min(nconv, np/2)
if (nev .eq. 1 .and. kplusp .ge. 6) then
nev = kplusp / 2
else if (nev .eq. 1 .and. kplusp .gt. 3) then
nev = 2
end if
np = kplusp - nev
c
c %---------------------------------------%
c | If the size of NEV was just increased |
c | resort the eigenvalues. |
c %---------------------------------------%
c
if (nevbef .lt. nev)
& call dngets (ishift, which, nev, np, ritzr, ritzi,
& bounds, workl, workl(np+1))
c
end if
c
if (msglvl .gt. 0) then
call ivout (logfil, 1, nconv, ndigit,
& '_naup2: no. of "converged" Ritz values at this iter.')
if (msglvl .gt. 1) then
kp(1) = nev
kp(2) = np
call ivout (logfil, 2, kp, ndigit,
& '_naup2: NEV and NP are')
call dvout (logfil, nev, ritzr(np+1), ndigit,
& '_naup2: "wanted" Ritz values -- real part')
call dvout (logfil, nev, ritzi(np+1), ndigit,
& '_naup2: "wanted" Ritz values -- imag part')
call dvout (logfil, nev, bounds(np+1), ndigit,
& '_naup2: Ritz estimates of the "wanted" values ')
end if
end if
c
if (ishift .eq. 0) then
c
c %-------------------------------------------------------%
c | User specified shifts: reverse comminucation to |
c | compute the shifts. They are returned in the first |
c | 2*NP locations of WORKL. |
c %-------------------------------------------------------%
c
ushift = .true.
ido = 3
go to 9000
end if
c
50 continue
c
c %------------------------------------%
c | Back from reverse communication; |
c | User specified shifts are returned |
c | in WORKL(1:2*NP) |
c %------------------------------------%
c
ushift = .false.
c
if ( ishift .eq. 0 ) then
c
c %----------------------------------%
c | Move the NP shifts from WORKL to |
c | RITZR, RITZI to free up WORKL |
c | for non-exact shift case. |
c %----------------------------------%
c
call dcopy (np, workl, 1, ritzr, 1)
call dcopy (np, workl(np+1), 1, ritzi, 1)
end if
c
if (msglvl .gt. 2) then
call ivout (logfil, 1, np, ndigit,
& '_naup2: The number of shifts to apply ')
call dvout (logfil, np, ritzr, ndigit,
& '_naup2: Real part of the shifts')
call dvout (logfil, np, ritzi, ndigit,
& '_naup2: Imaginary part of the shifts')
if ( ishift .eq. 1 )
& call dvout (logfil, np, bounds, ndigit,
& '_naup2: Ritz estimates of the shifts')
end if
c
c %---------------------------------------------------------%
c | Apply the NP implicit shifts by QR bulge chasing. |
c | Each shift is applied to the whole upper Hessenberg |
c | matrix H. |
c | The first 2*N locations of WORKD are used as workspace. |
c %---------------------------------------------------------%
c
call dnapps (n, nev, np, ritzr, ritzi, v, ldv,
& h, ldh, resid, q, ldq, workl, workd)
c
c %---------------------------------------------%
c | Compute the B-norm of the updated residual. |
c | Keep B*RESID in WORKD(1:N) to be used in |
c | the first step of the next call to dnaitr. |
c %---------------------------------------------%
c
cnorm = .true.
call second (t2)
if (bmat .eq. 'G') then
nbx = nbx + 1
call dcopy (n, resid, 1, workd(n+1), 1)
ipntr(1) = n + 1
ipntr(2) = 1
ido = 2
c
c %----------------------------------%
c | Exit in order to compute B*RESID |
c %----------------------------------%
c
go to 9000
else if (bmat .eq. 'I') then
call dcopy (n, resid, 1, workd, 1)
end if
c
100 continue
c
c %----------------------------------%
c | Back from reverse communication; |
c | WORKD(1:N) := B*RESID |
c %----------------------------------%
c
if (bmat .eq. 'G') then
call second (t3)
tmvbx = tmvbx + (t3 - t2)
end if
c
if (bmat .eq. 'G') then
rnorm = ddot (n, resid, 1, workd, 1)
rnorm = sqrt(abs(rnorm))
else if (bmat .eq. 'I') then
rnorm = dnrm2(n, resid, 1)
end if
cnorm = .false.
c
if (msglvl .gt. 2) then
call dvout (logfil, 1, rnorm, ndigit,
& '_naup2: B-norm of residual for compressed factorization')
call dmout (logfil, nev, nev, h, ldh, ndigit,
& '_naup2: Compressed upper Hessenberg matrix H')
end if
c
go to 1000
c
c %---------------------------------------------------------------%
c | |
c | E N D O F M A I N I T E R A T I O N L O O P |
c | |
c %---------------------------------------------------------------%
c
1100 continue
c
mxiter = iter
nev = numcnv
c
1200 continue
ido = 99
c
c %------------%
c | Error Exit |
c %------------%
c
call second (t1)
tnaup2 = t1 - t0
c
9000 continue
c
c %---------------%
c | End of dnaup2 |
c %---------------%
c
return
end

693
arpack/ARPACK/SRC/dnaupd.f Normal file
View File

@@ -0,0 +1,693 @@
c\BeginDoc
c
c\Name: dnaupd
c
c\Description:
c Reverse communication interface for the Implicitly Restarted Arnoldi
c iteration. This subroutine computes approximations to a few eigenpairs
c of a linear operator "OP" with respect to a semi-inner product defined by
c a symmetric positive semi-definite real matrix B. B may be the identity
c matrix. NOTE: If the linear operator "OP" is real and symmetric
c with respect to the real positive semi-definite symmetric matrix B,
c i.e. B*OP = (OP`)*B, then subroutine dsaupd should be used instead.
c
c The computed approximate eigenvalues are called Ritz values and
c the corresponding approximate eigenvectors are called Ritz vectors.
c
c dnaupd is usually called iteratively to solve one of the
c following problems:
c
c Mode 1: A*x = lambda*x.
c ===> OP = A and B = I.
c
c Mode 2: A*x = lambda*M*x, M symmetric positive definite
c ===> OP = inv[M]*A and B = M.
c ===> (If M can be factored see remark 3 below)
c
c Mode 3: A*x = lambda*M*x, M symmetric semi-definite
c ===> OP = Real_Part{ inv[A - sigma*M]*M } and B = M.
c ===> shift-and-invert mode (in real arithmetic)
c If OP*x = amu*x, then
c amu = 1/2 * [ 1/(lambda-sigma) + 1/(lambda-conjg(sigma)) ].
c Note: If sigma is real, i.e. imaginary part of sigma is zero;
c Real_Part{ inv[A - sigma*M]*M } == inv[A - sigma*M]*M
c amu == 1/(lambda-sigma).
c
c Mode 4: A*x = lambda*M*x, M symmetric semi-definite
c ===> OP = Imaginary_Part{ inv[A - sigma*M]*M } and B = M.
c ===> shift-and-invert mode (in real arithmetic)
c If OP*x = amu*x, then
c amu = 1/2i * [ 1/(lambda-sigma) - 1/(lambda-conjg(sigma)) ].
c
c Both mode 3 and 4 give the same enhancement to eigenvalues close to
c the (complex) shift sigma. However, as lambda goes to infinity,
c the operator OP in mode 4 dampens the eigenvalues more strongly than
c does OP defined in mode 3.
c
c NOTE: The action of w <- inv[A - sigma*M]*v or w <- inv[M]*v
c should be accomplished either by a direct method
c using a sparse matrix factorization and solving
c
c [A - sigma*M]*w = v or M*w = v,
c
c or through an iterative method for solving these
c systems. If an iterative method is used, the
c convergence test must be more stringent than
c the accuracy requirements for the eigenvalue
c approximations.
c
c\Usage:
c call dnaupd
c ( IDO, BMAT, N, WHICH, NEV, TOL, RESID, NCV, V, LDV, IPARAM,
c IPNTR, WORKD, WORKL, LWORKL, INFO )
c
c\Arguments
c IDO Integer. (INPUT/OUTPUT)
c Reverse communication flag. IDO must be zero on the first
c call to dnaupd. IDO will be set internally to
c indicate the type of operation to be performed. Control is
c then given back to the calling routine which has the
c responsibility to carry out the requested operation and call
c dnaupd with the result. The operand is given in
c WORKD(IPNTR(1)), the result must be put in WORKD(IPNTR(2)).
c -------------------------------------------------------------
c IDO = 0: first call to the reverse communication interface
c IDO = -1: compute Y = OP * X where
c IPNTR(1) is the pointer into WORKD for X,
c IPNTR(2) is the pointer into WORKD for Y.
c This is for the initialization phase to force the
c starting vector into the range of OP.
c IDO = 1: compute Y = OP * X where
c IPNTR(1) is the pointer into WORKD for X,
c IPNTR(2) is the pointer into WORKD for Y.
c In mode 3 and 4, the vector B * X is already
c available in WORKD(ipntr(3)). It does not
c need to be recomputed in forming OP * X.
c IDO = 2: compute Y = B * X where
c IPNTR(1) is the pointer into WORKD for X,
c IPNTR(2) is the pointer into WORKD for Y.
c IDO = 3: compute the IPARAM(8) real and imaginary parts
c of the shifts where INPTR(14) is the pointer
c into WORKL for placing the shifts. See Remark
c 5 below.
c IDO = 99: done
c -------------------------------------------------------------
c
c BMAT Character*1. (INPUT)
c BMAT specifies the type of the matrix B that defines the
c semi-inner product for the operator OP.
c BMAT = 'I' -> standard eigenvalue problem A*x = lambda*x
c BMAT = 'G' -> generalized eigenvalue problem A*x = lambda*B*x
c
c N Integer. (INPUT)
c Dimension of the eigenproblem.
c
c WHICH Character*2. (INPUT)
c 'LM' -> want the NEV eigenvalues of largest magnitude.
c 'SM' -> want the NEV eigenvalues of smallest magnitude.
c 'LR' -> want the NEV eigenvalues of largest real part.
c 'SR' -> want the NEV eigenvalues of smallest real part.
c 'LI' -> want the NEV eigenvalues of largest imaginary part.
c 'SI' -> want the NEV eigenvalues of smallest imaginary part.
c
c NEV Integer. (INPUT/OUTPUT)
c Number of eigenvalues of OP to be computed. 0 < NEV < N-1.
c
c TOL Double precision scalar. (INPUT)
c Stopping criterion: the relative accuracy of the Ritz value
c is considered acceptable if BOUNDS(I) .LE. TOL*ABS(RITZ(I))
c where ABS(RITZ(I)) is the magnitude when RITZ(I) is complex.
c DEFAULT = DLAMCH('EPS') (machine precision as computed
c by the LAPACK auxiliary subroutine DLAMCH).
c
c RESID Double precision array of length N. (INPUT/OUTPUT)
c On INPUT:
c If INFO .EQ. 0, a random initial residual vector is used.
c If INFO .NE. 0, RESID contains the initial residual vector,
c possibly from a previous run.
c On OUTPUT:
c RESID contains the final residual vector.
c
c NCV Integer. (INPUT)
c Number of columns of the matrix V. NCV must satisfy the two
c inequalities 2 <= NCV-NEV and NCV <= N.
c This will indicate how many Arnoldi vectors are generated
c at each iteration. After the startup phase in which NEV
c Arnoldi vectors are generated, the algorithm generates
c approximately NCV-NEV Arnoldi vectors at each subsequent update
c iteration. Most of the cost in generating each Arnoldi vector is
c in the matrix-vector operation OP*x.
c NOTE: 2 <= NCV-NEV in order that complex conjugate pairs of Ritz
c values are kept together. (See remark 4 below)
c
c V Double precision array N by NCV. (OUTPUT)
c Contains the final set of Arnoldi basis vectors.
c
c LDV Integer. (INPUT)
c Leading dimension of V exactly as declared in the calling program.
c
c IPARAM Integer array of length 11. (INPUT/OUTPUT)
c IPARAM(1) = ISHIFT: method for selecting the implicit shifts.
c The shifts selected at each iteration are used to restart
c the Arnoldi iteration in an implicit fashion.
c -------------------------------------------------------------
c ISHIFT = 0: the shifts are provided by the user via
c reverse communication. The real and imaginary
c parts of the NCV eigenvalues of the Hessenberg
c matrix H are returned in the part of the WORKL
c array corresponding to RITZR and RITZI. See remark
c 5 below.
c ISHIFT = 1: exact shifts with respect to the current
c Hessenberg matrix H. This is equivalent to
c restarting the iteration with a starting vector
c that is a linear combination of approximate Schur
c vectors associated with the "wanted" Ritz values.
c -------------------------------------------------------------
c
c IPARAM(2) = No longer referenced.
c
c IPARAM(3) = MXITER
c On INPUT: maximum number of Arnoldi update iterations allowed.
c On OUTPUT: actual number of Arnoldi update iterations taken.
c
c IPARAM(4) = NB: blocksize to be used in the recurrence.
c The code currently works only for NB = 1.
c
c IPARAM(5) = NCONV: number of "converged" Ritz values.
c This represents the number of Ritz values that satisfy
c the convergence criterion.
c
c IPARAM(6) = IUPD
c No longer referenced. Implicit restarting is ALWAYS used.
c
c IPARAM(7) = MODE
c On INPUT determines what type of eigenproblem is being solved.
c Must be 1,2,3,4; See under \Description of dnaupd for the
c four modes available.
c
c IPARAM(8) = NP
c When ido = 3 and the user provides shifts through reverse
c communication (IPARAM(1)=0), dnaupd returns NP, the number
c of shifts the user is to provide. 0 < NP <=NCV-NEV. See Remark
c 5 below.
c
c IPARAM(9) = NUMOP, IPARAM(10) = NUMOPB, IPARAM(11) = NUMREO,
c OUTPUT: NUMOP = total number of OP*x operations,
c NUMOPB = total number of B*x operations if BMAT='G',
c NUMREO = total number of steps of re-orthogonalization.
c
c IPNTR Integer array of length 14. (OUTPUT)
c Pointer to mark the starting locations in the WORKD and WORKL
c arrays for matrices/vectors used by the Arnoldi iteration.
c -------------------------------------------------------------
c IPNTR(1): pointer to the current operand vector X in WORKD.
c IPNTR(2): pointer to the current result vector Y in WORKD.
c IPNTR(3): pointer to the vector B * X in WORKD when used in
c the shift-and-invert mode.
c IPNTR(4): pointer to the next available location in WORKL
c that is untouched by the program.
c IPNTR(5): pointer to the NCV by NCV upper Hessenberg matrix
c H in WORKL.
c IPNTR(6): pointer to the real part of the ritz value array
c RITZR in WORKL.
c IPNTR(7): pointer to the imaginary part of the ritz value array
c RITZI in WORKL.
c IPNTR(8): pointer to the Ritz estimates in array WORKL associated
c with the Ritz values located in RITZR and RITZI in WORKL.
c
c IPNTR(14): pointer to the NP shifts in WORKL. See Remark 5 below.
c
c Note: IPNTR(9:13) is only referenced by dneupd. See Remark 2 below.
c
c IPNTR(9): pointer to the real part of the NCV RITZ values of the
c original system.
c IPNTR(10): pointer to the imaginary part of the NCV RITZ values of
c the original system.
c IPNTR(11): pointer to the NCV corresponding error bounds.
c IPNTR(12): pointer to the NCV by NCV upper quasi-triangular
c Schur matrix for H.
c IPNTR(13): pointer to the NCV by NCV matrix of eigenvectors
c of the upper Hessenberg matrix H. Only referenced by
c dneupd if RVEC = .TRUE. See Remark 2 below.
c -------------------------------------------------------------
c
c WORKD Double precision work array of length 3*N. (REVERSE COMMUNICATION)
c Distributed array to be used in the basic Arnoldi iteration
c for reverse communication. The user should not use WORKD
c as temporary workspace during the iteration. Upon termination
c WORKD(1:N) contains B*RESID(1:N). If an invariant subspace
c associated with the converged Ritz values is desired, see remark
c 2 below, subroutine dneupd uses this output.
c See Data Distribution Note below.
c
c WORKL Double precision work array of length LWORKL. (OUTPUT/WORKSPACE)
c Private (replicated) array on each PE or array allocated on
c the front end. See Data Distribution Note below.
c
c LWORKL Integer. (INPUT)
c LWORKL must be at least 3*NCV**2 + 6*NCV.
c
c INFO Integer. (INPUT/OUTPUT)
c If INFO .EQ. 0, a randomly initial residual vector is used.
c If INFO .NE. 0, RESID contains the initial residual vector,
c possibly from a previous run.
c Error flag on output.
c = 0: Normal exit.
c = 1: Maximum number of iterations taken.
c All possible eigenvalues of OP has been found. IPARAM(5)
c returns the number of wanted converged Ritz values.
c = 2: No longer an informational error. Deprecated starting
c with release 2 of ARPACK.
c = 3: No shifts could be applied during a cycle of the
c Implicitly restarted Arnoldi iteration. One possibility
c is to increase the size of NCV relative to NEV.
c See remark 4 below.
c = -1: N must be positive.
c = -2: NEV must be positive.
c = -3: NCV-NEV >= 2 and less than or equal to N.
c = -4: The maximum number of Arnoldi update iteration
c must be greater than zero.
c = -5: WHICH must be one of 'LM', 'SM', 'LR', 'SR', 'LI', 'SI'
c = -6: BMAT must be one of 'I' or 'G'.
c = -7: Length of private work array is not sufficient.
c = -8: Error return from LAPACK eigenvalue calculation;
c = -9: Starting vector is zero.
c = -10: IPARAM(7) must be 1,2,3,4.
c = -11: IPARAM(7) = 1 and BMAT = 'G' are incompatable.
c = -12: IPARAM(1) must be equal to 0 or 1.
c = -9999: Could not build an Arnoldi factorization.
c IPARAM(5) returns the size of the current Arnoldi
c factorization.
c
c\Remarks
c 1. The computed Ritz values are approximate eigenvalues of OP. The
c selection of WHICH should be made with this in mind when
c Mode = 3 and 4. After convergence, approximate eigenvalues of the
c original problem may be obtained with the ARPACK subroutine dneupd.
c
c 2. If a basis for the invariant subspace corresponding to the converged Ritz
c values is needed, the user must call dneupd immediately following
c completion of dnaupd. This is new starting with release 2 of ARPACK.
c
c 3. If M can be factored into a Cholesky factorization M = LL`
c then Mode = 2 should not be selected. Instead one should use
c Mode = 1 with OP = inv(L)*A*inv(L`). Appropriate triangular
c linear systems should be solved with L and L` rather
c than computing inverses. After convergence, an approximate
c eigenvector z of the original problem is recovered by solving
c L`z = x where x is a Ritz vector of OP.
c
c 4. At present there is no a-priori analysis to guide the selection
c of NCV relative to NEV. The only formal requrement is that NCV > NEV + 2.
c However, it is recommended that NCV .ge. 2*NEV+1. If many problems of
c the same type are to be solved, one should experiment with increasing
c NCV while keeping NEV fixed for a given test problem. This will
c usually decrease the required number of OP*x operations but it
c also increases the work and storage required to maintain the orthogonal
c basis vectors. The optimal "cross-over" with respect to CPU time
c is problem dependent and must be determined empirically.
c See Chapter 8 of Reference 2 for further information.
c
c 5. When IPARAM(1) = 0, and IDO = 3, the user needs to provide the
c NP = IPARAM(8) real and imaginary parts of the shifts in locations
c real part imaginary part
c ----------------------- --------------
c 1 WORKL(IPNTR(14)) WORKL(IPNTR(14)+NP)
c 2 WORKL(IPNTR(14)+1) WORKL(IPNTR(14)+NP+1)
c . .
c . .
c . .
c NP WORKL(IPNTR(14)+NP-1) WORKL(IPNTR(14)+2*NP-1).
c
c Only complex conjugate pairs of shifts may be applied and the pairs
c must be placed in consecutive locations. The real part of the
c eigenvalues of the current upper Hessenberg matrix are located in
c WORKL(IPNTR(6)) through WORKL(IPNTR(6)+NCV-1) and the imaginary part
c in WORKL(IPNTR(7)) through WORKL(IPNTR(7)+NCV-1). They are ordered
c according to the order defined by WHICH. The complex conjugate
c pairs are kept together and the associated Ritz estimates are located in
c WORKL(IPNTR(8)), WORKL(IPNTR(8)+1), ... , WORKL(IPNTR(8)+NCV-1).
c
c-----------------------------------------------------------------------
c
c\Data Distribution Note:
c
c Fortran-D syntax:
c ================
c Double precision resid(n), v(ldv,ncv), workd(3*n), workl(lworkl)
c decompose d1(n), d2(n,ncv)
c align resid(i) with d1(i)
c align v(i,j) with d2(i,j)
c align workd(i) with d1(i) range (1:n)
c align workd(i) with d1(i-n) range (n+1:2*n)
c align workd(i) with d1(i-2*n) range (2*n+1:3*n)
c distribute d1(block), d2(block,:)
c replicated workl(lworkl)
c
c Cray MPP syntax:
c ===============
c Double precision resid(n), v(ldv,ncv), workd(n,3), workl(lworkl)
c shared resid(block), v(block,:), workd(block,:)
c replicated workl(lworkl)
c
c CM2/CM5 syntax:
c ==============
c
c-----------------------------------------------------------------------
c
c include 'ex-nonsym.doc'
c
c-----------------------------------------------------------------------
c
c\BeginLib
c
c\Local variables:
c xxxxxx real
c
c\References:
c 1. D.C. Sorensen, "Implicit Application of Polynomial Filters in
c a k-Step Arnoldi Method", SIAM J. Matr. Anal. Apps., 13 (1992),
c pp 357-385.
c 2. R.B. Lehoucq, "Analysis and Implementation of an Implicitly
c Restarted Arnoldi Iteration", Rice University Technical Report
c TR95-13, Department of Computational and Applied Mathematics.
c 3. B.N. Parlett & Y. Saad, "Complex Shift and Invert Strategies for
c Real Matrices", Linear Algebra and its Applications, vol 88/89,
c pp 575-595, (1987).
c
c\Routines called:
c dnaup2 ARPACK routine that implements the Implicitly Restarted
c Arnoldi Iteration.
c ivout ARPACK utility routine that prints integers.
c second ARPACK utility routine for timing.
c dvout ARPACK utility routine that prints vectors.
c dlamch LAPACK routine that determines machine constants.
c
c\Author
c Danny Sorensen Phuong Vu
c Richard Lehoucq CRPC / Rice University
c Dept. of Computational & Houston, Texas
c Applied Mathematics
c Rice University
c Houston, Texas
c
c\Revision history:
c 12/16/93: Version '1.1'
c
c\SCCS Information: @(#)
c FILE: naupd.F SID: 2.10 DATE OF SID: 08/23/02 RELEASE: 2
c
c\Remarks
c
c\EndLib
c
c-----------------------------------------------------------------------
c
subroutine dnaupd
& ( ido, bmat, n, which, nev, tol, resid, ncv, v, ldv, iparam,
& ipntr, workd, workl, lworkl, info )
c
c %----------------------------------------------------%
c | Include files for debugging and timing information |
c %----------------------------------------------------%
c
include 'debug.h'
include 'stat.h'
c
c %------------------%
c | Scalar Arguments |
c %------------------%
c
character bmat*1, which*2
integer ido, info, ldv, lworkl, n, ncv, nev
Double precision
& tol
c
c %-----------------%
c | Array Arguments |
c %-----------------%
c
integer iparam(11), ipntr(14)
Double precision
& resid(n), v(ldv,ncv), workd(3*n), workl(lworkl)
c
c %------------%
c | Parameters |
c %------------%
c
Double precision
& one, zero
parameter (one = 1.0D+0, zero = 0.0D+0)
c
c %---------------%
c | Local Scalars |
c %---------------%
c
integer bounds, ierr, ih, iq, ishift, iupd, iw,
& ldh, ldq, levec, mode, msglvl, mxiter, nb,
& nev0, next, np, ritzi, ritzr, j
save bounds, ih, iq, ishift, iupd, iw, ldh, ldq,
& levec, mode, msglvl, mxiter, nb, nev0, next,
& np, ritzi, ritzr
c
c %----------------------%
c | External Subroutines |
c %----------------------%
c
external dnaup2, dvout, ivout, second, dstatn
c
c %--------------------%
c | External Functions |
c %--------------------%
c
Double precision
& dlamch
external dlamch
c
c %-----------------------%
c | Executable Statements |
c %-----------------------%
c
if (ido .eq. 0) then
c
c %-------------------------------%
c | Initialize timing statistics |
c | & message level for debugging |
c %-------------------------------%
c
call dstatn
call second (t0)
msglvl = mnaupd
c
c %----------------%
c | Error checking |
c %----------------%
c
ierr = 0
ishift = iparam(1)
c levec = iparam(2)
mxiter = iparam(3)
c nb = iparam(4)
nb = 1
c
c %--------------------------------------------%
c | Revision 2 performs only implicit restart. |
c %--------------------------------------------%
c
iupd = 1
mode = iparam(7)
c
if (n .le. 0) then
ierr = -1
else if (nev .le. 0) then
ierr = -2
else if (ncv .le. nev+1 .or. ncv .gt. n) then
ierr = -3
else if (mxiter .le. 0) then
ierr = 4
else if (which .ne. 'LM' .and.
& which .ne. 'SM' .and.
& which .ne. 'LR' .and.
& which .ne. 'SR' .and.
& which .ne. 'LI' .and.
& which .ne. 'SI') then
ierr = -5
else if (bmat .ne. 'I' .and. bmat .ne. 'G') then
ierr = -6
else if (lworkl .lt. 3*ncv**2 + 6*ncv) then
ierr = -7
else if (mode .lt. 1 .or. mode .gt. 4) then
ierr = -10
else if (mode .eq. 1 .and. bmat .eq. 'G') then
ierr = -11
else if (ishift .lt. 0 .or. ishift .gt. 1) then
ierr = -12
end if
c
c %------------%
c | Error Exit |
c %------------%
c
if (ierr .ne. 0) then
info = ierr
ido = 99
go to 9000
end if
c
c %------------------------%
c | Set default parameters |
c %------------------------%
c
if (nb .le. 0) nb = 1
if (tol .le. zero) tol = dlamch('EpsMach')
c
c %----------------------------------------------%
c | NP is the number of additional steps to |
c | extend the length NEV Lanczos factorization. |
c | NEV0 is the local variable designating the |
c | size of the invariant subspace desired. |
c %----------------------------------------------%
c
np = ncv - nev
nev0 = nev
c
c %-----------------------------%
c | Zero out internal workspace |
c %-----------------------------%
c
do 10 j = 1, 3*ncv**2 + 6*ncv
workl(j) = zero
10 continue
c
c %-------------------------------------------------------------%
c | Pointer into WORKL for address of H, RITZ, BOUNDS, Q |
c | etc... and the remaining workspace. |
c | Also update pointer to be used on output. |
c | Memory is laid out as follows: |
c | workl(1:ncv*ncv) := generated Hessenberg matrix |
c | workl(ncv*ncv+1:ncv*ncv+2*ncv) := real and imaginary |
c | parts of ritz values |
c | workl(ncv*ncv+2*ncv+1:ncv*ncv+3*ncv) := error bounds |
c | workl(ncv*ncv+3*ncv+1:2*ncv*ncv+3*ncv) := rotation matrix Q |
c | workl(2*ncv*ncv+3*ncv+1:3*ncv*ncv+6*ncv) := workspace |
c | The final workspace is needed by subroutine dneigh called |
c | by dnaup2. Subroutine dneigh calls LAPACK routines for |
c | calculating eigenvalues and the last row of the eigenvector |
c | matrix. |
c %-------------------------------------------------------------%
c
ldh = ncv
ldq = ncv
ih = 1
ritzr = ih + ldh*ncv
ritzi = ritzr + ncv
bounds = ritzi + ncv
iq = bounds + ncv
iw = iq + ldq*ncv
next = iw + ncv**2 + 3*ncv
c
ipntr(4) = next
ipntr(5) = ih
ipntr(6) = ritzr
ipntr(7) = ritzi
ipntr(8) = bounds
ipntr(14) = iw
c
end if
c
c %-------------------------------------------------------%
c | Carry out the Implicitly restarted Arnoldi Iteration. |
c %-------------------------------------------------------%
c
call dnaup2
& ( ido, bmat, n, which, nev0, np, tol, resid, mode, iupd,
& ishift, mxiter, v, ldv, workl(ih), ldh, workl(ritzr),
& workl(ritzi), workl(bounds), workl(iq), ldq, workl(iw),
& ipntr, workd, info )
c
c %--------------------------------------------------%
c | ido .ne. 99 implies use of reverse communication |
c | to compute operations involving OP or shifts. |
c %--------------------------------------------------%
c
if (ido .eq. 3) iparam(8) = np
if (ido .ne. 99) go to 9000
c
iparam(3) = mxiter
iparam(5) = np
iparam(9) = nopx
iparam(10) = nbx
iparam(11) = nrorth
c
c %------------------------------------%
c | Exit if there was an informational |
c | error within dnaup2. |
c %------------------------------------%
c
if (info .lt. 0) go to 9000
if (info .eq. 2) info = 3
c
if (msglvl .gt. 0) then
call ivout (logfil, 1, mxiter, ndigit,
& '_naupd: Number of update iterations taken')
call ivout (logfil, 1, np, ndigit,
& '_naupd: Number of wanted "converged" Ritz values')
call dvout (logfil, np, workl(ritzr), ndigit,
& '_naupd: Real part of the final Ritz values')
call dvout (logfil, np, workl(ritzi), ndigit,
& '_naupd: Imaginary part of the final Ritz values')
call dvout (logfil, np, workl(bounds), ndigit,
& '_naupd: Associated Ritz estimates')
end if
c
call second (t1)
tnaupd = t1 - t0
c
if (msglvl .gt. 0) then
c
c %--------------------------------------------------------%
c | Version Number & Version Date are defined in version.h |
c %--------------------------------------------------------%
c
write (6,1000)
write (6,1100) mxiter, nopx, nbx, nrorth, nitref, nrstrt,
& tmvopx, tmvbx, tnaupd, tnaup2, tnaitr, titref,
& tgetv0, tneigh, tngets, tnapps, tnconv, trvec
1000 format (//,
& 5x, '=============================================',/
& 5x, '= Nonsymmetric implicit Arnoldi update code =',/
& 5x, '= Version Number: ', ' 2.4', 21x, ' =',/
& 5x, '= Version Date: ', ' 07/31/96', 16x, ' =',/
& 5x, '=============================================',/
& 5x, '= Summary of timing statistics =',/
& 5x, '=============================================',//)
1100 format (
& 5x, 'Total number update iterations = ', i5,/
& 5x, 'Total number of OP*x operations = ', i5,/
& 5x, 'Total number of B*x operations = ', i5,/
& 5x, 'Total number of reorthogonalization steps = ', i5,/
& 5x, 'Total number of iterative refinement steps = ', i5,/
& 5x, 'Total number of restart steps = ', i5,/
& 5x, 'Total time in user OP*x operation = ', f12.6,/
& 5x, 'Total time in user B*x operation = ', f12.6,/
& 5x, 'Total time in Arnoldi update routine = ', f12.6,/
& 5x, 'Total time in naup2 routine = ', f12.6,/
& 5x, 'Total time in basic Arnoldi iteration loop = ', f12.6,/
& 5x, 'Total time in reorthogonalization phase = ', f12.6,/
& 5x, 'Total time in (re)start vector generation = ', f12.6,/
& 5x, 'Total time in Hessenberg eig. subproblem = ', f12.6,/
& 5x, 'Total time in getting the shifts = ', f12.6,/
& 5x, 'Total time in applying the shifts = ', f12.6,/
& 5x, 'Total time in convergence testing = ', f12.6,/
& 5x, 'Total time in computing final Ritz vectors = ', f12.6/)
end if
c
9000 continue
c
return
c
c %---------------%
c | End of dnaupd |
c %---------------%
c
end

0
arpack/ARPACK/SRC/dnaupe.f Normal file
View File

146
arpack/ARPACK/SRC/dnconv.f Normal file
View File

@@ -0,0 +1,146 @@
c-----------------------------------------------------------------------
c\BeginDoc
c
c\Name: dnconv
c
c\Description:
c Convergence testing for the nonsymmetric Arnoldi eigenvalue routine.
c
c\Usage:
c call dnconv
c ( N, RITZR, RITZI, BOUNDS, TOL, NCONV )
c
c\Arguments
c N Integer. (INPUT)
c Number of Ritz values to check for convergence.
c
c RITZR, Double precision arrays of length N. (INPUT)
c RITZI Real and imaginary parts of the Ritz values to be checked
c for convergence.
c BOUNDS Double precision array of length N. (INPUT)
c Ritz estimates for the Ritz values in RITZR and RITZI.
c
c TOL Double precision scalar. (INPUT)
c Desired backward error for a Ritz value to be considered
c "converged".
c
c NCONV Integer scalar. (OUTPUT)
c Number of "converged" Ritz values.
c
c\EndDoc
c
c-----------------------------------------------------------------------
c
c\BeginLib
c
c\Local variables:
c xxxxxx real
c
c\Routines called:
c second ARPACK utility routine for timing.
c dlamch LAPACK routine that determines machine constants.
c dlapy2 LAPACK routine to compute sqrt(x**2+y**2) carefully.
c
c\Author
c Danny Sorensen Phuong Vu
c Richard Lehoucq CRPC / Rice University
c Dept. of Computational & Houston, Texas
c Applied Mathematics
c Rice University
c Houston, Texas
c
c\Revision history:
c xx/xx/92: Version ' 2.1'
c
c\SCCS Information: @(#)
c FILE: nconv.F SID: 2.3 DATE OF SID: 4/20/96 RELEASE: 2
c
c\Remarks
c 1. xxxx
c
c\EndLib
c
c-----------------------------------------------------------------------
c
subroutine dnconv (n, ritzr, ritzi, bounds, tol, nconv)
c
c %----------------------------------------------------%
c | Include files for debugging and timing information |
c %----------------------------------------------------%
c
include 'debug.h'
include 'stat.h'
c
c %------------------%
c | Scalar Arguments |
c %------------------%
c
integer n, nconv
Double precision
& tol
c
c %-----------------%
c | Array Arguments |
c %-----------------%
Double precision
& ritzr(n), ritzi(n), bounds(n)
c
c %---------------%
c | Local Scalars |
c %---------------%
c
integer i
Double precision
& temp, eps23
c
c %--------------------%
c | External Functions |
c %--------------------%
c
Double precision
& dlapy2, dlamch
external dlapy2, dlamch
c %-----------------------%
c | Executable Statements |
c %-----------------------%
c
c %-------------------------------------------------------------%
c | Convergence test: unlike in the symmetric code, I am not |
c | using things like refined error bounds and gap condition |
c | because I don't know the exact equivalent concept. |
c | |
c | Instead the i-th Ritz value is considered "converged" when: |
c | |
c | bounds(i) .le. ( TOL * | ritz | ) |
c | |
c | for some appropriate choice of norm. |
c %-------------------------------------------------------------%
c
call second (t0)
c
c %---------------------------------%
c | Get machine dependent constant. |
c %---------------------------------%
c
eps23 = dlamch('Epsilon-Machine')
eps23 = eps23**(2.0D+0 / 3.0D+0)
c
nconv = 0
do 20 i = 1, n
temp = max( eps23, dlapy2( ritzr(i), ritzi(i) ) )
if (bounds(i) .le. tol*temp) nconv = nconv + 1
20 continue
c
call second (t1)
tnconv = tnconv + (t1 - t0)
c
return
c
c %---------------%
c | End of dnconv |
c %---------------%
c
end

314
arpack/ARPACK/SRC/dneigh.f Normal file
View File

@@ -0,0 +1,314 @@
c-----------------------------------------------------------------------
c\BeginDoc
c
c\Name: dneigh
c
c\Description:
c Compute the eigenvalues of the current upper Hessenberg matrix
c and the corresponding Ritz estimates given the current residual norm.
c
c\Usage:
c call dneigh
c ( RNORM, N, H, LDH, RITZR, RITZI, BOUNDS, Q, LDQ, WORKL, IERR )
c
c\Arguments
c RNORM Double precision scalar. (INPUT)
c Residual norm corresponding to the current upper Hessenberg
c matrix H.
c
c N Integer. (INPUT)
c Size of the matrix H.
c
c H Double precision N by N array. (INPUT)
c H contains the current upper Hessenberg matrix.
c
c LDH Integer. (INPUT)
c Leading dimension of H exactly as declared in the calling
c program.
c
c RITZR, Double precision arrays of length N. (OUTPUT)
c RITZI On output, RITZR(1:N) (resp. RITZI(1:N)) contains the real
c (respectively imaginary) parts of the eigenvalues of H.
c
c BOUNDS Double precision array of length N. (OUTPUT)
c On output, BOUNDS contains the Ritz estimates associated with
c the eigenvalues RITZR and RITZI. This is equal to RNORM
c times the last components of the eigenvectors corresponding
c to the eigenvalues in RITZR and RITZI.
c
c Q Double precision N by N array. (WORKSPACE)
c Workspace needed to store the eigenvectors of H.
c
c LDQ Integer. (INPUT)
c Leading dimension of Q exactly as declared in the calling
c program.
c
c WORKL Double precision work array of length N**2 + 3*N. (WORKSPACE)
c Private (replicated) array on each PE or array allocated on
c the front end. This is needed to keep the full Schur form
c of H and also in the calculation of the eigenvectors of H.
c
c IERR Integer. (OUTPUT)
c Error exit flag from dlaqrb or dtrevc.
c
c\EndDoc
c
c-----------------------------------------------------------------------
c
c\BeginLib
c
c\Local variables:
c xxxxxx real
c
c\Routines called:
c dlaqrb ARPACK routine to compute the real Schur form of an
c upper Hessenberg matrix and last row of the Schur vectors.
c second ARPACK utility routine for timing.
c dmout ARPACK utility routine that prints matrices
c dvout ARPACK utility routine that prints vectors.
c dlacpy LAPACK matrix copy routine.
c dlapy2 LAPACK routine to compute sqrt(x**2+y**2) carefully.
c dtrevc LAPACK routine to compute the eigenvectors of a matrix
c in upper quasi-triangular form
c dgemv Level 2 BLAS routine for matrix vector multiplication.
c dcopy Level 1 BLAS that copies one vector to another .
c dnrm2 Level 1 BLAS that computes the norm of a vector.
c dscal Level 1 BLAS that scales a vector.
c
c
c\Author
c Danny Sorensen Phuong Vu
c Richard Lehoucq CRPC / Rice University
c Dept. of Computational & Houston, Texas
c Applied Mathematics
c Rice University
c Houston, Texas
c
c\Revision history:
c xx/xx/92: Version ' 2.1'
c
c\SCCS Information: @(#)
c FILE: neigh.F SID: 2.3 DATE OF SID: 4/20/96 RELEASE: 2
c
c\Remarks
c None
c
c\EndLib
c
c-----------------------------------------------------------------------
c
subroutine dneigh (rnorm, n, h, ldh, ritzr, ritzi, bounds,
& q, ldq, workl, ierr)
c
c %----------------------------------------------------%
c | Include files for debugging and timing information |
c %----------------------------------------------------%
c
include 'debug.h'
include 'stat.h'
c
c %------------------%
c | Scalar Arguments |
c %------------------%
c
integer ierr, n, ldh, ldq
Double precision
& rnorm
c
c %-----------------%
c | Array Arguments |
c %-----------------%
c
Double precision
& bounds(n), h(ldh,n), q(ldq,n), ritzi(n), ritzr(n),
& workl(n*(n+3))
c
c %------------%
c | Parameters |
c %------------%
c
Double precision
& one, zero
parameter (one = 1.0D+0, zero = 0.0D+0)
c
c %------------------------%
c | Local Scalars & Arrays |
c %------------------------%
c
logical select(1)
integer i, iconj, msglvl
Double precision
& temp, vl(1)
c
c %----------------------%
c | External Subroutines |
c %----------------------%
c
external dcopy, dlacpy, dlaqrb, dtrevc, dvout, second
c
c %--------------------%
c | External Functions |
c %--------------------%
c
Double precision
& dlapy2, dnrm2
external dlapy2, dnrm2
c
c %---------------------%
c | Intrinsic Functions |
c %---------------------%
c
intrinsic abs
c
c %-----------------------%
c | Executable Statements |
c %-----------------------%
c
c
c %-------------------------------%
c | Initialize timing statistics |
c | & message level for debugging |
c %-------------------------------%
c
call second (t0)
msglvl = mneigh
c
if (msglvl .gt. 2) then
call dmout (logfil, n, n, h, ldh, ndigit,
& '_neigh: Entering upper Hessenberg matrix H ')
end if
c
c %-----------------------------------------------------------%
c | 1. Compute the eigenvalues, the last components of the |
c | corresponding Schur vectors and the full Schur form T |
c | of the current upper Hessenberg matrix H. |
c | dlaqrb returns the full Schur form of H in WORKL(1:N**2) |
c | and the last components of the Schur vectors in BOUNDS. |
c %-----------------------------------------------------------%
c
call dlacpy ('All', n, n, h, ldh, workl, n)
call dlaqrb (.true., n, 1, n, workl, n, ritzr, ritzi, bounds,
& ierr)
if (ierr .ne. 0) go to 9000
c
if (msglvl .gt. 1) then
call dvout (logfil, n, bounds, ndigit,
& '_neigh: last row of the Schur matrix for H')
end if
c
c %-----------------------------------------------------------%
c | 2. Compute the eigenvectors of the full Schur form T and |
c | apply the last components of the Schur vectors to get |
c | the last components of the corresponding eigenvectors. |
c | Remember that if the i-th and (i+1)-st eigenvalues are |
c | complex conjugate pairs, then the real & imaginary part |
c | of the eigenvector components are split across adjacent |
c | columns of Q. |
c %-----------------------------------------------------------%
c
call dtrevc ('R', 'A', select, n, workl, n, vl, n, q, ldq,
& n, n, workl(n*n+1), ierr)
c
if (ierr .ne. 0) go to 9000
c
c %------------------------------------------------%
c | Scale the returning eigenvectors so that their |
c | euclidean norms are all one. LAPACK subroutine |
c | dtrevc returns each eigenvector normalized so |
c | that the element of largest magnitude has |
c | magnitude 1; here the magnitude of a complex |
c | number (x,y) is taken to be |x| + |y|. |
c %------------------------------------------------%
c
iconj = 0
do 10 i=1, n
if ( abs( ritzi(i) ) .le. zero ) then
c
c %----------------------%
c | Real eigenvalue case |
c %----------------------%
c
temp = dnrm2( n, q(1,i), 1 )
call dscal ( n, one / temp, q(1,i), 1 )
else
c
c %-------------------------------------------%
c | Complex conjugate pair case. Note that |
c | since the real and imaginary part of |
c | the eigenvector are stored in consecutive |
c | columns, we further normalize by the |
c | square root of two. |
c %-------------------------------------------%
c
if (iconj .eq. 0) then
temp = dlapy2( dnrm2( n, q(1,i), 1 ),
& dnrm2( n, q(1,i+1), 1 ) )
call dscal ( n, one / temp, q(1,i), 1 )
call dscal ( n, one / temp, q(1,i+1), 1 )
iconj = 1
else
iconj = 0
end if
end if
10 continue
c
call dgemv ('T', n, n, one, q, ldq, bounds, 1, zero, workl, 1)
c
if (msglvl .gt. 1) then
call dvout (logfil, n, workl, ndigit,
& '_neigh: Last row of the eigenvector matrix for H')
end if
c
c %----------------------------%
c | Compute the Ritz estimates |
c %----------------------------%
c
iconj = 0
do 20 i = 1, n
if ( abs( ritzi(i) ) .le. zero ) then
c
c %----------------------%
c | Real eigenvalue case |
c %----------------------%
c
bounds(i) = rnorm * abs( workl(i) )
else
c
c %-------------------------------------------%
c | Complex conjugate pair case. Note that |
c | since the real and imaginary part of |
c | the eigenvector are stored in consecutive |
c | columns, we need to take the magnitude |
c | of the last components of the two vectors |
c %-------------------------------------------%
c
if (iconj .eq. 0) then
bounds(i) = rnorm * dlapy2( workl(i), workl(i+1) )
bounds(i+1) = bounds(i)
iconj = 1
else
iconj = 0
end if
end if
20 continue
c
if (msglvl .gt. 2) then
call dvout (logfil, n, ritzr, ndigit,
& '_neigh: Real part of the eigenvalues of H')
call dvout (logfil, n, ritzi, ndigit,
& '_neigh: Imaginary part of the eigenvalues of H')
call dvout (logfil, n, bounds, ndigit,
& '_neigh: Ritz estimates for the eigenvalues of H')
end if
c
call second (t1)
tneigh = tneigh + (t1 - t0)
c
9000 continue
return
c
c %---------------%
c | End of dneigh |
c %---------------%
c
end

1063
arpack/ARPACK/SRC/dneupd.f Normal file
View File

File diff suppressed because it is too large Load Diff

231
arpack/ARPACK/SRC/dngets.f Normal file
View File

@@ -0,0 +1,231 @@
c-----------------------------------------------------------------------
c\BeginDoc
c
c\Name: dngets
c
c\Description:
c Given the eigenvalues of the upper Hessenberg matrix H,
c computes the NP shifts AMU that are zeros of the polynomial of
c degree NP which filters out components of the unwanted eigenvectors
c corresponding to the AMU's based on some given criteria.
c
c NOTE: call this even in the case of user specified shifts in order
c to sort the eigenvalues, and error bounds of H for later use.
c
c\Usage:
c call dngets
c ( ISHIFT, WHICH, KEV, NP, RITZR, RITZI, BOUNDS, SHIFTR, SHIFTI )
c
c\Arguments
c ISHIFT Integer. (INPUT)
c Method for selecting the implicit shifts at each iteration.
c ISHIFT = 0: user specified shifts
c ISHIFT = 1: exact shift with respect to the matrix H.
c
c WHICH Character*2. (INPUT)
c Shift selection criteria.
c 'LM' -> want the KEV eigenvalues of largest magnitude.
c 'SM' -> want the KEV eigenvalues of smallest magnitude.
c 'LR' -> want the KEV eigenvalues of largest real part.
c 'SR' -> want the KEV eigenvalues of smallest real part.
c 'LI' -> want the KEV eigenvalues of largest imaginary part.
c 'SI' -> want the KEV eigenvalues of smallest imaginary part.
c
c KEV Integer. (INPUT/OUTPUT)
c INPUT: KEV+NP is the size of the matrix H.
c OUTPUT: Possibly increases KEV by one to keep complex conjugate
c pairs together.
c
c NP Integer. (INPUT/OUTPUT)
c Number of implicit shifts to be computed.
c OUTPUT: Possibly decreases NP by one to keep complex conjugate
c pairs together.
c
c RITZR, Double precision array of length KEV+NP. (INPUT/OUTPUT)
c RITZI On INPUT, RITZR and RITZI contain the real and imaginary
c parts of the eigenvalues of H.
c On OUTPUT, RITZR and RITZI are sorted so that the unwanted
c eigenvalues are in the first NP locations and the wanted
c portion is in the last KEV locations. When exact shifts are
c selected, the unwanted part corresponds to the shifts to
c be applied. Also, if ISHIFT .eq. 1, the unwanted eigenvalues
c are further sorted so that the ones with largest Ritz values
c are first.
c
c BOUNDS Double precision array of length KEV+NP. (INPUT/OUTPUT)
c Error bounds corresponding to the ordering in RITZ.
c
c SHIFTR, SHIFTI *** USE deprecated as of version 2.1. ***
c
c
c\EndDoc
c
c-----------------------------------------------------------------------
c
c\BeginLib
c
c\Local variables:
c xxxxxx real
c
c\Routines called:
c dsortc ARPACK sorting routine.
c dcopy Level 1 BLAS that copies one vector to another .
c
c\Author
c Danny Sorensen Phuong Vu
c Richard Lehoucq CRPC / Rice University
c Dept. of Computational & Houston, Texas
c Applied Mathematics
c Rice University
c Houston, Texas
c
c\Revision history:
c xx/xx/92: Version ' 2.1'
c
c\SCCS Information: @(#)
c FILE: ngets.F SID: 2.3 DATE OF SID: 4/20/96 RELEASE: 2
c
c\Remarks
c 1. xxxx
c
c\EndLib
c
c-----------------------------------------------------------------------
c
subroutine dngets ( ishift, which, kev, np, ritzr, ritzi, bounds,
& shiftr, shifti )
c
c %----------------------------------------------------%
c | Include files for debugging and timing information |
c %----------------------------------------------------%
c
include 'debug.h'
include 'stat.h'
c
c %------------------%
c | Scalar Arguments |
c %------------------%
c
character*2 which
integer ishift, kev, np
c
c %-----------------%
c | Array Arguments |
c %-----------------%
c
Double precision
& bounds(kev+np), ritzr(kev+np), ritzi(kev+np),
& shiftr(1), shifti(1)
c
c %------------%
c | Parameters |
c %------------%
c
Double precision
& one, zero
parameter (one = 1.0, zero = 0.0)
c
c %---------------%
c | Local Scalars |
c %---------------%
c
integer msglvl
c
c %----------------------%
c | External Subroutines |
c %----------------------%
c
external dcopy, dsortc, second
c
c %----------------------%
c | Intrinsics Functions |
c %----------------------%
c
intrinsic abs
c
c %-----------------------%
c | Executable Statements |
c %-----------------------%
c
c %-------------------------------%
c | Initialize timing statistics |
c | & message level for debugging |
c %-------------------------------%
c
call second (t0)
msglvl = mngets
c
c %----------------------------------------------------%
c | LM, SM, LR, SR, LI, SI case. |
c | Sort the eigenvalues of H into the desired order |
c | and apply the resulting order to BOUNDS. |
c | The eigenvalues are sorted so that the wanted part |
c | are always in the last KEV locations. |
c | We first do a pre-processing sort in order to keep |
c | complex conjugate pairs together |
c %----------------------------------------------------%
c
if (which .eq. 'LM') then
call dsortc ('LR', .true., kev+np, ritzr, ritzi, bounds)
else if (which .eq. 'SM') then
call dsortc ('SR', .true., kev+np, ritzr, ritzi, bounds)
else if (which .eq. 'LR') then
call dsortc ('LM', .true., kev+np, ritzr, ritzi, bounds)
else if (which .eq. 'SR') then
call dsortc ('SM', .true., kev+np, ritzr, ritzi, bounds)
else if (which .eq. 'LI') then
call dsortc ('LM', .true., kev+np, ritzr, ritzi, bounds)
else if (which .eq. 'SI') then
call dsortc ('SM', .true., kev+np, ritzr, ritzi, bounds)
end if
c
call dsortc (which, .true., kev+np, ritzr, ritzi, bounds)
c
c %-------------------------------------------------------%
c | Increase KEV by one if the ( ritzr(np),ritzi(np) ) |
c | = ( ritzr(np+1),-ritzi(np+1) ) and ritz(np) .ne. zero |
c | Accordingly decrease NP by one. In other words keep |
c | complex conjugate pairs together. |
c %-------------------------------------------------------%
c
if ( ( ritzr(np+1) - ritzr(np) ) .eq. zero
& .and. ( ritzi(np+1) + ritzi(np) ) .eq. zero ) then
np = np - 1
kev = kev + 1
end if
c
if ( ishift .eq. 1 ) then
c
c %-------------------------------------------------------%
c | Sort the unwanted Ritz values used as shifts so that |
c | the ones with largest Ritz estimates are first |
c | This will tend to minimize the effects of the |
c | forward instability of the iteration when they shifts |
c | are applied in subroutine dnapps. |
c | Be careful and use 'SR' since we want to sort BOUNDS! |
c %-------------------------------------------------------%
c
call dsortc ( 'SR', .true., np, bounds, ritzr, ritzi )
end if
c
call second (t1)
tngets = tngets + (t1 - t0)
c
if (msglvl .gt. 0) then
call ivout (logfil, 1, kev, ndigit, '_ngets: KEV is')
call ivout (logfil, 1, np, ndigit, '_ngets: NP is')
call dvout (logfil, kev+np, ritzr, ndigit,
& '_ngets: Eigenvalues of current H matrix -- real part')
call dvout (logfil, kev+np, ritzi, ndigit,
& '_ngets: Eigenvalues of current H matrix -- imag part')
call dvout (logfil, kev+np, bounds, ndigit,
& '_ngets: Ritz estimates of the current KEV+NP Ritz values')
end if
c
return
c
c %---------------%
c | End of dngets |
c %---------------%
c
end

853
arpack/ARPACK/SRC/dsaitr.f Normal file
View File

@@ -0,0 +1,853 @@
c-----------------------------------------------------------------------
c\BeginDoc
c
c\Name: dsaitr
c
c\Description:
c Reverse communication interface for applying NP additional steps to
c a K step symmetric Arnoldi factorization.
c
c Input: OP*V_{k} - V_{k}*H = r_{k}*e_{k}^T
c
c with (V_{k}^T)*B*V_{k} = I, (V_{k}^T)*B*r_{k} = 0.
c
c Output: OP*V_{k+p} - V_{k+p}*H = r_{k+p}*e_{k+p}^T
c
c with (V_{k+p}^T)*B*V_{k+p} = I, (V_{k+p}^T)*B*r_{k+p} = 0.
c
c where OP and B are as in dsaupd. The B-norm of r_{k+p} is also
c computed and returned.
c
c\Usage:
c call dsaitr
c ( IDO, BMAT, N, K, NP, MODE, RESID, RNORM, V, LDV, H, LDH,
c IPNTR, WORKD, INFO )
c
c\Arguments
c IDO Integer. (INPUT/OUTPUT)
c Reverse communication flag.
c -------------------------------------------------------------
c IDO = 0: first call to the reverse communication interface
c IDO = -1: compute Y = OP * X where
c IPNTR(1) is the pointer into WORK for X,
c IPNTR(2) is the pointer into WORK for Y.
c This is for the restart phase to force the new
c starting vector into the range of OP.
c IDO = 1: compute Y = OP * X where
c IPNTR(1) is the pointer into WORK for X,
c IPNTR(2) is the pointer into WORK for Y,
c IPNTR(3) is the pointer into WORK for B * X.
c IDO = 2: compute Y = B * X where
c IPNTR(1) is the pointer into WORK for X,
c IPNTR(2) is the pointer into WORK for Y.
c IDO = 99: done
c -------------------------------------------------------------
c When the routine is used in the "shift-and-invert" mode, the
c vector B * Q is already available and does not need to be
c recomputed in forming OP * Q.
c
c BMAT Character*1. (INPUT)
c BMAT specifies the type of matrix B that defines the
c semi-inner product for the operator OP. See dsaupd.
c B = 'I' -> standard eigenvalue problem A*x = lambda*x
c B = 'G' -> generalized eigenvalue problem A*x = lambda*M*x
c
c N Integer. (INPUT)
c Dimension of the eigenproblem.
c
c K Integer. (INPUT)
c Current order of H and the number of columns of V.
c
c NP Integer. (INPUT)
c Number of additional Arnoldi steps to take.
c
c MODE Integer. (INPUT)
c Signifies which form for "OP". If MODE=2 then
c a reduction in the number of B matrix vector multiplies
c is possible since the B-norm of OP*x is equivalent to
c the inv(B)-norm of A*x.
c
c RESID Double precision array of length N. (INPUT/OUTPUT)
c On INPUT: RESID contains the residual vector r_{k}.
c On OUTPUT: RESID contains the residual vector r_{k+p}.
c
c RNORM Double precision scalar. (INPUT/OUTPUT)
c On INPUT the B-norm of r_{k}.
c On OUTPUT the B-norm of the updated residual r_{k+p}.
c
c V Double precision N by K+NP array. (INPUT/OUTPUT)
c On INPUT: V contains the Arnoldi vectors in the first K
c columns.
c On OUTPUT: V contains the new NP Arnoldi vectors in the next
c NP columns. The first K columns are unchanged.
c
c LDV Integer. (INPUT)
c Leading dimension of V exactly as declared in the calling
c program.
c
c H Double precision (K+NP) by 2 array. (INPUT/OUTPUT)
c H is used to store the generated symmetric tridiagonal matrix
c with the subdiagonal in the first column starting at H(2,1)
c and the main diagonal in the second column.
c
c LDH Integer. (INPUT)
c Leading dimension of H exactly as declared in the calling
c program.
c
c IPNTR Integer array of length 3. (OUTPUT)
c Pointer to mark the starting locations in the WORK for
c vectors used by the Arnoldi iteration.
c -------------------------------------------------------------
c IPNTR(1): pointer to the current operand vector X.
c IPNTR(2): pointer to the current result vector Y.
c IPNTR(3): pointer to the vector B * X when used in the
c shift-and-invert mode. X is the current operand.
c -------------------------------------------------------------
c
c WORKD Double precision work array of length 3*N. (REVERSE COMMUNICATION)
c Distributed array to be used in the basic Arnoldi iteration
c for reverse communication. The calling program should not
c use WORKD as temporary workspace during the iteration !!!!!!
c On INPUT, WORKD(1:N) = B*RESID where RESID is associated
c with the K step Arnoldi factorization. Used to save some
c computation at the first step.
c On OUTPUT, WORKD(1:N) = B*RESID where RESID is associated
c with the K+NP step Arnoldi factorization.
c
c INFO Integer. (OUTPUT)
c = 0: Normal exit.
c > 0: Size of an invariant subspace of OP is found that is
c less than K + NP.
c
c\EndDoc
c
c-----------------------------------------------------------------------
c
c\BeginLib
c
c\Local variables:
c xxxxxx real
c
c\Routines called:
c dgetv0 ARPACK routine to generate the initial vector.
c ivout ARPACK utility routine that prints integers.
c dmout ARPACK utility routine that prints matrices.
c dvout ARPACK utility routine that prints vectors.
c dlamch LAPACK routine that determines machine constants.
c dlascl LAPACK routine for careful scaling of a matrix.
c dgemv Level 2 BLAS routine for matrix vector multiplication.
c daxpy Level 1 BLAS that computes a vector triad.
c dscal Level 1 BLAS that scales a vector.
c dcopy Level 1 BLAS that copies one vector to another .
c ddot Level 1 BLAS that computes the scalar product of two vectors.
c dnrm2 Level 1 BLAS that computes the norm of a vector.
c
c\Author
c Danny Sorensen Phuong Vu
c Richard Lehoucq CRPC / Rice University
c Dept. of Computational & Houston, Texas
c Applied Mathematics
c Rice University
c Houston, Texas
c
c\Revision history:
c xx/xx/93: Version ' 2.4'
c
c\SCCS Information: @(#)
c FILE: saitr.F SID: 2.6 DATE OF SID: 8/28/96 RELEASE: 2
c
c\Remarks
c The algorithm implemented is:
c
c restart = .false.
c Given V_{k} = [v_{1}, ..., v_{k}], r_{k};
c r_{k} contains the initial residual vector even for k = 0;
c Also assume that rnorm = || B*r_{k} || and B*r_{k} are already
c computed by the calling program.
c
c betaj = rnorm ; p_{k+1} = B*r_{k} ;
c For j = k+1, ..., k+np Do
c 1) if ( betaj < tol ) stop or restart depending on j.
c if ( restart ) generate a new starting vector.
c 2) v_{j} = r(j-1)/betaj; V_{j} = [V_{j-1}, v_{j}];
c p_{j} = p_{j}/betaj
c 3) r_{j} = OP*v_{j} where OP is defined as in dsaupd
c For shift-invert mode p_{j} = B*v_{j} is already available.
c wnorm = || OP*v_{j} ||
c 4) Compute the j-th step residual vector.
c w_{j} = V_{j}^T * B * OP * v_{j}
c r_{j} = OP*v_{j} - V_{j} * w_{j}
c alphaj <- j-th component of w_{j}
c rnorm = || r_{j} ||
c betaj+1 = rnorm
c If (rnorm > 0.717*wnorm) accept step and go back to 1)
c 5) Re-orthogonalization step:
c s = V_{j}'*B*r_{j}
c r_{j} = r_{j} - V_{j}*s; rnorm1 = || r_{j} ||
c alphaj = alphaj + s_{j};
c 6) Iterative refinement step:
c If (rnorm1 > 0.717*rnorm) then
c rnorm = rnorm1
c accept step and go back to 1)
c Else
c rnorm = rnorm1
c If this is the first time in step 6), go to 5)
c Else r_{j} lies in the span of V_{j} numerically.
c Set r_{j} = 0 and rnorm = 0; go to 1)
c EndIf
c End Do
c
c\EndLib
c
c-----------------------------------------------------------------------
c
subroutine dsaitr
& (ido, bmat, n, k, np, mode, resid, rnorm, v, ldv, h, ldh,
& ipntr, workd, info)
c
c %----------------------------------------------------%
c | Include files for debugging and timing information |
c %----------------------------------------------------%
c
include 'debug.h'
include 'stat.h'
c
c %------------------%
c | Scalar Arguments |
c %------------------%
c
character bmat*1
integer ido, info, k, ldh, ldv, n, mode, np
Double precision
& rnorm
c
c %-----------------%
c | Array Arguments |
c %-----------------%
c
integer ipntr(3)
Double precision
& h(ldh,2), resid(n), v(ldv,k+np), workd(3*n)
c
c %------------%
c | Parameters |
c %------------%
c
Double precision
& one, zero
parameter (one = 1.0D+0, zero = 0.0D+0)
c
c %---------------%
c | Local Scalars |
c %---------------%
c
logical first, orth1, orth2, rstart, step3, step4
integer i, ierr, ipj, irj, ivj, iter, itry, j, msglvl,
& infol, jj
Double precision
& rnorm1, wnorm, safmin, temp1
save orth1, orth2, rstart, step3, step4,
& ierr, ipj, irj, ivj, iter, itry, j, msglvl,
& rnorm1, safmin, wnorm
c
c %-----------------------%
c | Local Array Arguments |
c %-----------------------%
c
Double precision
& xtemp(2)
c
c %----------------------%
c | External Subroutines |
c %----------------------%
c
external daxpy, dcopy, dscal, dgemv, dgetv0, dvout, dmout,
& dlascl, ivout, second
c
c %--------------------%
c | External Functions |
c %--------------------%
c
Double precision
& ddot, dnrm2, dlamch
external ddot, dnrm2, dlamch
c
c %-----------------%
c | Data statements |
c %-----------------%
c
data first / .true. /
c
c %-----------------------%
c | Executable Statements |
c %-----------------------%
c
if (first) then
first = .false.
c
c %--------------------------------%
c | safmin = safe minimum is such |
c | that 1/sfmin does not overflow |
c %--------------------------------%
c
safmin = dlamch('safmin')
end if
c
if (ido .eq. 0) then
c
c %-------------------------------%
c | Initialize timing statistics |
c | & message level for debugging |
c %-------------------------------%
c
call second (t0)
msglvl = msaitr
c
c %------------------------------%
c | Initial call to this routine |
c %------------------------------%
c
info = 0
step3 = .false.
step4 = .false.
rstart = .false.
orth1 = .false.
orth2 = .false.
c
c %--------------------------------%
c | Pointer to the current step of |
c | the factorization to build |
c %--------------------------------%
c
j = k + 1
c
c %------------------------------------------%
c | Pointers used for reverse communication |
c | when using WORKD. |
c %------------------------------------------%
c
ipj = 1
irj = ipj + n
ivj = irj + n
end if
c
c %-------------------------------------------------%
c | When in reverse communication mode one of: |
c | STEP3, STEP4, ORTH1, ORTH2, RSTART |
c | will be .true. |
c | STEP3: return from computing OP*v_{j}. |
c | STEP4: return from computing B-norm of OP*v_{j} |
c | ORTH1: return from computing B-norm of r_{j+1} |
c | ORTH2: return from computing B-norm of |
c | correction to the residual vector. |
c | RSTART: return from OP computations needed by |
c | dgetv0. |
c %-------------------------------------------------%
c
if (step3) go to 50
if (step4) go to 60
if (orth1) go to 70
if (orth2) go to 90
if (rstart) go to 30
c
c %------------------------------%
c | Else this is the first step. |
c %------------------------------%
c
c %--------------------------------------------------------------%
c | |
c | A R N O L D I I T E R A T I O N L O O P |
c | |
c | Note: B*r_{j-1} is already in WORKD(1:N)=WORKD(IPJ:IPJ+N-1) |
c %--------------------------------------------------------------%
c
1000 continue
c
if (msglvl .gt. 2) then
call ivout (logfil, 1, j, ndigit,
& '_saitr: generating Arnoldi vector no.')
call dvout (logfil, 1, rnorm, ndigit,
& '_saitr: B-norm of the current residual =')
end if
c
c %---------------------------------------------------------%
c | Check for exact zero. Equivalent to determing whether a |
c | j-step Arnoldi factorization is present. |
c %---------------------------------------------------------%
c
if (rnorm .gt. zero) go to 40
c
c %---------------------------------------------------%
c | Invariant subspace found, generate a new starting |
c | vector which is orthogonal to the current Arnoldi |
c | basis and continue the iteration. |
c %---------------------------------------------------%
c
if (msglvl .gt. 0) then
call ivout (logfil, 1, j, ndigit,
& '_saitr: ****** restart at step ******')
end if
c
c %---------------------------------------------%
c | ITRY is the loop variable that controls the |
c | maximum amount of times that a restart is |
c | attempted. NRSTRT is used by stat.h |
c %---------------------------------------------%
c
nrstrt = nrstrt + 1
itry = 1
20 continue
rstart = .true.
ido = 0
30 continue
c
c %--------------------------------------%
c | If in reverse communication mode and |
c | RSTART = .true. flow returns here. |
c %--------------------------------------%
c
call dgetv0 (ido, bmat, itry, .false., n, j, v, ldv,
& resid, rnorm, ipntr, workd, ierr)
if (ido .ne. 99) go to 9000
if (ierr .lt. 0) then
itry = itry + 1
if (itry .le. 3) go to 20
c
c %------------------------------------------------%
c | Give up after several restart attempts. |
c | Set INFO to the size of the invariant subspace |
c | which spans OP and exit. |
c %------------------------------------------------%
c
info = j - 1
call second (t1)
tsaitr = tsaitr + (t1 - t0)
ido = 99
go to 9000
end if
c
40 continue
c
c %---------------------------------------------------------%
c | STEP 2: v_{j} = r_{j-1}/rnorm and p_{j} = p_{j}/rnorm |
c | Note that p_{j} = B*r_{j-1}. In order to avoid overflow |
c | when reciprocating a small RNORM, test against lower |
c | machine bound. |
c %---------------------------------------------------------%
c
call dcopy (n, resid, 1, v(1,j), 1)
if (rnorm .ge. safmin) then
temp1 = one / rnorm
call dscal (n, temp1, v(1,j), 1)
call dscal (n, temp1, workd(ipj), 1)
else
c
c %-----------------------------------------%
c | To scale both v_{j} and p_{j} carefully |
c | use LAPACK routine SLASCL |
c %-----------------------------------------%
c
call dlascl ('General', i, i, rnorm, one, n, 1,
& v(1,j), n, infol)
call dlascl ('General', i, i, rnorm, one, n, 1,
& workd(ipj), n, infol)
end if
c
c %------------------------------------------------------%
c | STEP 3: r_{j} = OP*v_{j}; Note that p_{j} = B*v_{j} |
c | Note that this is not quite yet r_{j}. See STEP 4 |
c %------------------------------------------------------%
c
step3 = .true.
nopx = nopx + 1
call second (t2)
call dcopy (n, v(1,j), 1, workd(ivj), 1)
ipntr(1) = ivj
ipntr(2) = irj
ipntr(3) = ipj
ido = 1
c
c %-----------------------------------%
c | Exit in order to compute OP*v_{j} |
c %-----------------------------------%
c
go to 9000
50 continue
c
c %-----------------------------------%
c | Back from reverse communication; |
c | WORKD(IRJ:IRJ+N-1) := OP*v_{j}. |
c %-----------------------------------%
c
call second (t3)
tmvopx = tmvopx + (t3 - t2)
c
step3 = .false.
c
c %------------------------------------------%
c | Put another copy of OP*v_{j} into RESID. |
c %------------------------------------------%
c
call dcopy (n, workd(irj), 1, resid, 1)
c
c %-------------------------------------------%
c | STEP 4: Finish extending the symmetric |
c | Arnoldi to length j. If MODE = 2 |
c | then B*OP = B*inv(B)*A = A and |
c | we don't need to compute B*OP. |
c | NOTE: If MODE = 2 WORKD(IVJ:IVJ+N-1) is |
c | assumed to have A*v_{j}. |
c %-------------------------------------------%
c
if (mode .eq. 2) go to 65
call second (t2)
if (bmat .eq. 'G') then
nbx = nbx + 1
step4 = .true.
ipntr(1) = irj
ipntr(2) = ipj
ido = 2
c
c %-------------------------------------%
c | Exit in order to compute B*OP*v_{j} |
c %-------------------------------------%
c
go to 9000
else if (bmat .eq. 'I') then
call dcopy(n, resid, 1 , workd(ipj), 1)
end if
60 continue
c
c %-----------------------------------%
c | Back from reverse communication; |
c | WORKD(IPJ:IPJ+N-1) := B*OP*v_{j}. |
c %-----------------------------------%
c
if (bmat .eq. 'G') then
call second (t3)
tmvbx = tmvbx + (t3 - t2)
end if
c
step4 = .false.
c
c %-------------------------------------%
c | The following is needed for STEP 5. |
c | Compute the B-norm of OP*v_{j}. |
c %-------------------------------------%
c
65 continue
if (mode .eq. 2) then
c
c %----------------------------------%
c | Note that the B-norm of OP*v_{j} |
c | is the inv(B)-norm of A*v_{j}. |
c %----------------------------------%
c
wnorm = ddot (n, resid, 1, workd(ivj), 1)
wnorm = sqrt(abs(wnorm))
else if (bmat .eq. 'G') then
wnorm = ddot (n, resid, 1, workd(ipj), 1)
wnorm = sqrt(abs(wnorm))
else if (bmat .eq. 'I') then
wnorm = dnrm2(n, resid, 1)
end if
c
c %-----------------------------------------%
c | Compute the j-th residual corresponding |
c | to the j step factorization. |
c | Use Classical Gram Schmidt and compute: |
c | w_{j} <- V_{j}^T * B * OP * v_{j} |
c | r_{j} <- OP*v_{j} - V_{j} * w_{j} |
c %-----------------------------------------%
c
c
c %------------------------------------------%
c | Compute the j Fourier coefficients w_{j} |
c | WORKD(IPJ:IPJ+N-1) contains B*OP*v_{j}. |
c %------------------------------------------%
c
if (mode .ne. 2 ) then
call dgemv('T', n, j, one, v, ldv, workd(ipj), 1, zero,
& workd(irj), 1)
else if (mode .eq. 2) then
call dgemv('T', n, j, one, v, ldv, workd(ivj), 1, zero,
& workd(irj), 1)
end if
c
c %--------------------------------------%
c | Orthgonalize r_{j} against V_{j}. |
c | RESID contains OP*v_{j}. See STEP 3. |
c %--------------------------------------%
c
call dgemv('N', n, j, -one, v, ldv, workd(irj), 1, one,
& resid, 1)
c
c %--------------------------------------%
c | Extend H to have j rows and columns. |
c %--------------------------------------%
c
h(j,2) = workd(irj + j - 1)
if (j .eq. 1 .or. rstart) then
h(j,1) = zero
else
h(j,1) = rnorm
end if
call second (t4)
c
orth1 = .true.
iter = 0
c
call second (t2)
if (bmat .eq. 'G') then
nbx = nbx + 1
call dcopy (n, resid, 1, workd(irj), 1)
ipntr(1) = irj
ipntr(2) = ipj
ido = 2
c
c %----------------------------------%
c | Exit in order to compute B*r_{j} |
c %----------------------------------%
c
go to 9000
else if (bmat .eq. 'I') then
call dcopy (n, resid, 1, workd(ipj), 1)
end if
70 continue
c
c %---------------------------------------------------%
c | Back from reverse communication if ORTH1 = .true. |
c | WORKD(IPJ:IPJ+N-1) := B*r_{j}. |
c %---------------------------------------------------%
c
if (bmat .eq. 'G') then
call second (t3)
tmvbx = tmvbx + (t3 - t2)
end if
c
orth1 = .false.
c
c %------------------------------%
c | Compute the B-norm of r_{j}. |
c %------------------------------%
c
if (bmat .eq. 'G') then
rnorm = ddot (n, resid, 1, workd(ipj), 1)
rnorm = sqrt(abs(rnorm))
else if (bmat .eq. 'I') then
rnorm = dnrm2(n, resid, 1)
end if
c
c %-----------------------------------------------------------%
c | STEP 5: Re-orthogonalization / Iterative refinement phase |
c | Maximum NITER_ITREF tries. |
c | |
c | s = V_{j}^T * B * r_{j} |
c | r_{j} = r_{j} - V_{j}*s |
c | alphaj = alphaj + s_{j} |
c | |
c | The stopping criteria used for iterative refinement is |
c | discussed in Parlett's book SEP, page 107 and in Gragg & |
c | Reichel ACM TOMS paper; Algorithm 686, Dec. 1990. |
c | Determine if we need to correct the residual. The goal is |
c | to enforce ||v(:,1:j)^T * r_{j}|| .le. eps * || r_{j} || |
c %-----------------------------------------------------------%
c
if (rnorm .gt. 0.717*wnorm) go to 100
nrorth = nrorth + 1
c
c %---------------------------------------------------%
c | Enter the Iterative refinement phase. If further |
c | refinement is necessary, loop back here. The loop |
c | variable is ITER. Perform a step of Classical |
c | Gram-Schmidt using all the Arnoldi vectors V_{j} |
c %---------------------------------------------------%
c
80 continue
c
if (msglvl .gt. 2) then
xtemp(1) = wnorm
xtemp(2) = rnorm
call dvout (logfil, 2, xtemp, ndigit,
& '_saitr: re-orthonalization ; wnorm and rnorm are')
end if
c
c %----------------------------------------------------%
c | Compute V_{j}^T * B * r_{j}. |
c | WORKD(IRJ:IRJ+J-1) = v(:,1:J)'*WORKD(IPJ:IPJ+N-1). |
c %----------------------------------------------------%
c
call dgemv ('T', n, j, one, v, ldv, workd(ipj), 1,
& zero, workd(irj), 1)
c
c %----------------------------------------------%
c | Compute the correction to the residual: |
c | r_{j} = r_{j} - V_{j} * WORKD(IRJ:IRJ+J-1). |
c | The correction to H is v(:,1:J)*H(1:J,1:J) + |
c | v(:,1:J)*WORKD(IRJ:IRJ+J-1)*e'_j, but only |
c | H(j,j) is updated. |
c %----------------------------------------------%
c
call dgemv ('N', n, j, -one, v, ldv, workd(irj), 1,
& one, resid, 1)
c
if (j .eq. 1 .or. rstart) h(j,1) = zero
h(j,2) = h(j,2) + workd(irj + j - 1)
c
orth2 = .true.
call second (t2)
if (bmat .eq. 'G') then
nbx = nbx + 1
call dcopy (n, resid, 1, workd(irj), 1)
ipntr(1) = irj
ipntr(2) = ipj
ido = 2
c
c %-----------------------------------%
c | Exit in order to compute B*r_{j}. |
c | r_{j} is the corrected residual. |
c %-----------------------------------%
c
go to 9000
else if (bmat .eq. 'I') then
call dcopy (n, resid, 1, workd(ipj), 1)
end if
90 continue
c
c %---------------------------------------------------%
c | Back from reverse communication if ORTH2 = .true. |
c %---------------------------------------------------%
c
if (bmat .eq. 'G') then
call second (t3)
tmvbx = tmvbx + (t3 - t2)
end if
c
c %-----------------------------------------------------%
c | Compute the B-norm of the corrected residual r_{j}. |
c %-----------------------------------------------------%
c
if (bmat .eq. 'G') then
rnorm1 = ddot (n, resid, 1, workd(ipj), 1)
rnorm1 = sqrt(abs(rnorm1))
else if (bmat .eq. 'I') then
rnorm1 = dnrm2(n, resid, 1)
end if
c
if (msglvl .gt. 0 .and. iter .gt. 0) then
call ivout (logfil, 1, j, ndigit,
& '_saitr: Iterative refinement for Arnoldi residual')
if (msglvl .gt. 2) then
xtemp(1) = rnorm
xtemp(2) = rnorm1
call dvout (logfil, 2, xtemp, ndigit,
& '_saitr: iterative refinement ; rnorm and rnorm1 are')
end if
end if
c
c %-----------------------------------------%
c | Determine if we need to perform another |
c | step of re-orthogonalization. |
c %-----------------------------------------%
c
if (rnorm1 .gt. 0.717*rnorm) then
c
c %--------------------------------%
c | No need for further refinement |
c %--------------------------------%
c
rnorm = rnorm1
c
else
c
c %-------------------------------------------%
c | Another step of iterative refinement step |
c | is required. NITREF is used by stat.h |
c %-------------------------------------------%
c
nitref = nitref + 1
rnorm = rnorm1
iter = iter + 1
if (iter .le. 1) go to 80
c
c %-------------------------------------------------%
c | Otherwise RESID is numerically in the span of V |
c %-------------------------------------------------%
c
do 95 jj = 1, n
resid(jj) = zero
95 continue
rnorm = zero
end if
c
c %----------------------------------------------%
c | Branch here directly if iterative refinement |
c | wasn't necessary or after at most NITER_REF |
c | steps of iterative refinement. |
c %----------------------------------------------%
c
100 continue
c
rstart = .false.
orth2 = .false.
c
call second (t5)
titref = titref + (t5 - t4)
c
c %----------------------------------------------------------%
c | Make sure the last off-diagonal element is non negative |
c | If not perform a similarity transformation on H(1:j,1:j) |
c | and scale v(:,j) by -1. |
c %----------------------------------------------------------%
c
if (h(j,1) .lt. zero) then
h(j,1) = -h(j,1)
if ( j .lt. k+np) then
call dscal(n, -one, v(1,j+1), 1)
else
call dscal(n, -one, resid, 1)
end if
end if
c
c %------------------------------------%
c | STEP 6: Update j = j+1; Continue |
c %------------------------------------%
c
j = j + 1
if (j .gt. k+np) then
call second (t1)
tsaitr = tsaitr + (t1 - t0)
ido = 99
c
if (msglvl .gt. 1) then
call dvout (logfil, k+np, h(1,2), ndigit,
& '_saitr: main diagonal of matrix H of step K+NP.')
if (k+np .gt. 1) then
call dvout (logfil, k+np-1, h(2,1), ndigit,
& '_saitr: sub diagonal of matrix H of step K+NP.')
end if
end if
c
go to 9000
end if
c
c %--------------------------------------------------------%
c | Loop back to extend the factorization by another step. |
c %--------------------------------------------------------%
c
go to 1000
c
c %---------------------------------------------------------------%
c | |
c | E N D O F M A I N I T E R A T I O N L O O P |
c | |
c %---------------------------------------------------------------%
c
9000 continue
return
c
c %---------------%
c | End of dsaitr |
c %---------------%
c
end

516
arpack/ARPACK/SRC/dsapps.f Normal file
View File

@@ -0,0 +1,516 @@
c-----------------------------------------------------------------------
c\BeginDoc
c
c\Name: dsapps
c
c\Description:
c Given the Arnoldi factorization
c
c A*V_{k} - V_{k}*H_{k} = r_{k+p}*e_{k+p}^T,
c
c apply NP shifts implicitly resulting in
c
c A*(V_{k}*Q) - (V_{k}*Q)*(Q^T* H_{k}*Q) = r_{k+p}*e_{k+p}^T * Q
c
c where Q is an orthogonal matrix of order KEV+NP. Q is the product of
c rotations resulting from the NP bulge chasing sweeps. The updated Arnoldi
c factorization becomes:
c
c A*VNEW_{k} - VNEW_{k}*HNEW_{k} = rnew_{k}*e_{k}^T.
c
c\Usage:
c call dsapps
c ( N, KEV, NP, SHIFT, V, LDV, H, LDH, RESID, Q, LDQ, WORKD )
c
c\Arguments
c N Integer. (INPUT)
c Problem size, i.e. dimension of matrix A.
c
c KEV Integer. (INPUT)
c INPUT: KEV+NP is the size of the input matrix H.
c OUTPUT: KEV is the size of the updated matrix HNEW.
c
c NP Integer. (INPUT)
c Number of implicit shifts to be applied.
c
c SHIFT Double precision array of length NP. (INPUT)
c The shifts to be applied.
c
c V Double precision N by (KEV+NP) array. (INPUT/OUTPUT)
c INPUT: V contains the current KEV+NP Arnoldi vectors.
c OUTPUT: VNEW = V(1:n,1:KEV); the updated Arnoldi vectors
c are in the first KEV columns of V.
c
c LDV Integer. (INPUT)
c Leading dimension of V exactly as declared in the calling
c program.
c
c H Double precision (KEV+NP) by 2 array. (INPUT/OUTPUT)
c INPUT: H contains the symmetric tridiagonal matrix of the
c Arnoldi factorization with the subdiagonal in the 1st column
c starting at H(2,1) and the main diagonal in the 2nd column.
c OUTPUT: H contains the updated tridiagonal matrix in the
c KEV leading submatrix.
c
c LDH Integer. (INPUT)
c Leading dimension of H exactly as declared in the calling
c program.
c
c RESID Double precision array of length (N). (INPUT/OUTPUT)
c INPUT: RESID contains the the residual vector r_{k+p}.
c OUTPUT: RESID is the updated residual vector rnew_{k}.
c
c Q Double precision KEV+NP by KEV+NP work array. (WORKSPACE)
c Work array used to accumulate the rotations during the bulge
c chase sweep.
c
c LDQ Integer. (INPUT)
c Leading dimension of Q exactly as declared in the calling
c program.
c
c WORKD Double precision work array of length 2*N. (WORKSPACE)
c Distributed array used in the application of the accumulated
c orthogonal matrix Q.
c
c\EndDoc
c
c-----------------------------------------------------------------------
c
c\BeginLib
c
c\Local variables:
c xxxxxx real
c
c\References:
c 1. D.C. Sorensen, "Implicit Application of Polynomial Filters in
c a k-Step Arnoldi Method", SIAM J. Matr. Anal. Apps., 13 (1992),
c pp 357-385.
c 2. R.B. Lehoucq, "Analysis and Implementation of an Implicitly
c Restarted Arnoldi Iteration", Rice University Technical Report
c TR95-13, Department of Computational and Applied Mathematics.
c
c\Routines called:
c ivout ARPACK utility routine that prints integers.
c second ARPACK utility routine for timing.
c dvout ARPACK utility routine that prints vectors.
c dlamch LAPACK routine that determines machine constants.
c dlartg LAPACK Givens rotation construction routine.
c dlacpy LAPACK matrix copy routine.
c dlaset LAPACK matrix initialization routine.
c dgemv Level 2 BLAS routine for matrix vector multiplication.
c daxpy Level 1 BLAS that computes a vector triad.
c dcopy Level 1 BLAS that copies one vector to another.
c dscal Level 1 BLAS that scales a vector.
c
c\Author
c Danny Sorensen Phuong Vu
c Richard Lehoucq CRPC / Rice University
c Dept. of Computational & Houston, Texas
c Applied Mathematics
c Rice University
c Houston, Texas
c
c\Revision history:
c 12/16/93: Version ' 2.4'
c
c\SCCS Information: @(#)
c FILE: sapps.F SID: 2.6 DATE OF SID: 3/28/97 RELEASE: 2
c
c\Remarks
c 1. In this version, each shift is applied to all the subblocks of
c the tridiagonal matrix H and not just to the submatrix that it
c comes from. This routine assumes that the subdiagonal elements
c of H that are stored in h(1:kev+np,1) are nonegative upon input
c and enforce this condition upon output. This version incorporates
c deflation. See code for documentation.
c
c\EndLib
c
c-----------------------------------------------------------------------
c
subroutine dsapps
& ( n, kev, np, shift, v, ldv, h, ldh, resid, q, ldq, workd )
c
c %----------------------------------------------------%
c | Include files for debugging and timing information |
c %----------------------------------------------------%
c
include 'debug.h'
include 'stat.h'
c
c %------------------%
c | Scalar Arguments |
c %------------------%
c
integer kev, ldh, ldq, ldv, n, np
c
c %-----------------%
c | Array Arguments |
c %-----------------%
c
Double precision
& h(ldh,2), q(ldq,kev+np), resid(n), shift(np),
& v(ldv,kev+np), workd(2*n)
c
c %------------%
c | Parameters |
c %------------%
c
Double precision
& one, zero
parameter (one = 1.0D+0, zero = 0.0D+0)
c
c %---------------%
c | Local Scalars |
c %---------------%
c
integer i, iend, istart, itop, j, jj, kplusp, msglvl
logical first
Double precision
& a1, a2, a3, a4, big, c, epsmch, f, g, r, s
save epsmch, first
c
c
c %----------------------%
c | External Subroutines |
c %----------------------%
c
external daxpy, dcopy, dscal, dlacpy, dlartg, dlaset, dvout,
& ivout, second, dgemv
c
c %--------------------%
c | External Functions |
c %--------------------%
c
Double precision
& dlamch
external dlamch
c
c %----------------------%
c | Intrinsics Functions |
c %----------------------%
c
intrinsic abs
c
c %----------------%
c | Data statments |
c %----------------%
c
data first / .true. /
c
c %-----------------------%
c | Executable Statements |
c %-----------------------%
c
if (first) then
epsmch = dlamch('Epsilon-Machine')
first = .false.
end if
itop = 1
c
c %-------------------------------%
c | Initialize timing statistics |
c | & message level for debugging |
c %-------------------------------%
c
call second (t0)
msglvl = msapps
c
kplusp = kev + np
c
c %----------------------------------------------%
c | Initialize Q to the identity matrix of order |
c | kplusp used to accumulate the rotations. |
c %----------------------------------------------%
c
call dlaset ('All', kplusp, kplusp, zero, one, q, ldq)
c
c %----------------------------------------------%
c | Quick return if there are no shifts to apply |
c %----------------------------------------------%
c
if (np .eq. 0) go to 9000
c
c %----------------------------------------------------------%
c | Apply the np shifts implicitly. Apply each shift to the |
c | whole matrix and not just to the submatrix from which it |
c | comes. |
c %----------------------------------------------------------%
c
do 90 jj = 1, np
c
istart = itop
c
c %----------------------------------------------------------%
c | Check for splitting and deflation. Currently we consider |
c | an off-diagonal element h(i+1,1) negligible if |
c | h(i+1,1) .le. epsmch*( |h(i,2)| + |h(i+1,2)| ) |
c | for i=1:KEV+NP-1. |
c | If above condition tests true then we set h(i+1,1) = 0. |
c | Note that h(1:KEV+NP,1) are assumed to be non negative. |
c %----------------------------------------------------------%
c
20 continue
c
c %------------------------------------------------%
c | The following loop exits early if we encounter |
c | a negligible off diagonal element. |
c %------------------------------------------------%
c
do 30 i = istart, kplusp-1
big = abs(h(i,2)) + abs(h(i+1,2))
if (h(i+1,1) .le. epsmch*big) then
if (msglvl .gt. 0) then
call ivout (logfil, 1, i, ndigit,
& '_sapps: deflation at row/column no.')
call ivout (logfil, 1, jj, ndigit,
& '_sapps: occured before shift number.')
call dvout (logfil, 1, h(i+1,1), ndigit,
& '_sapps: the corresponding off diagonal element')
end if
h(i+1,1) = zero
iend = i
go to 40
end if
30 continue
iend = kplusp
40 continue
c
if (istart .lt. iend) then
c
c %--------------------------------------------------------%
c | Construct the plane rotation G'(istart,istart+1,theta) |
c | that attempts to drive h(istart+1,1) to zero. |
c %--------------------------------------------------------%
c
f = h(istart,2) - shift(jj)
g = h(istart+1,1)
call dlartg (f, g, c, s, r)
c
c %-------------------------------------------------------%
c | Apply rotation to the left and right of H; |
c | H <- G' * H * G, where G = G(istart,istart+1,theta). |
c | This will create a "bulge". |
c %-------------------------------------------------------%
c
a1 = c*h(istart,2) + s*h(istart+1,1)
a2 = c*h(istart+1,1) + s*h(istart+1,2)
a4 = c*h(istart+1,2) - s*h(istart+1,1)
a3 = c*h(istart+1,1) - s*h(istart,2)
h(istart,2) = c*a1 + s*a2
h(istart+1,2) = c*a4 - s*a3
h(istart+1,1) = c*a3 + s*a4
c
c %----------------------------------------------------%
c | Accumulate the rotation in the matrix Q; Q <- Q*G |
c %----------------------------------------------------%
c
do 60 j = 1, min(istart+jj,kplusp)
a1 = c*q(j,istart) + s*q(j,istart+1)
q(j,istart+1) = - s*q(j,istart) + c*q(j,istart+1)
q(j,istart) = a1
60 continue
c
c
c %----------------------------------------------%
c | The following loop chases the bulge created. |
c | Note that the previous rotation may also be |
c | done within the following loop. But it is |
c | kept separate to make the distinction among |
c | the bulge chasing sweeps and the first plane |
c | rotation designed to drive h(istart+1,1) to |
c | zero. |
c %----------------------------------------------%
c
do 70 i = istart+1, iend-1
c
c %----------------------------------------------%
c | Construct the plane rotation G'(i,i+1,theta) |
c | that zeros the i-th bulge that was created |
c | by G(i-1,i,theta). g represents the bulge. |
c %----------------------------------------------%
c
f = h(i,1)
g = s*h(i+1,1)
c
c %----------------------------------%
c | Final update with G(i-1,i,theta) |
c %----------------------------------%
c
h(i+1,1) = c*h(i+1,1)
call dlartg (f, g, c, s, r)
c
c %-------------------------------------------%
c | The following ensures that h(1:iend-1,1), |
c | the first iend-2 off diagonal of elements |
c | H, remain non negative. |
c %-------------------------------------------%
c
if (r .lt. zero) then
r = -r
c = -c
s = -s
end if
c
c %--------------------------------------------%
c | Apply rotation to the left and right of H; |
c | H <- G * H * G', where G = G(i,i+1,theta) |
c %--------------------------------------------%
c
h(i,1) = r
c
a1 = c*h(i,2) + s*h(i+1,1)
a2 = c*h(i+1,1) + s*h(i+1,2)
a3 = c*h(i+1,1) - s*h(i,2)
a4 = c*h(i+1,2) - s*h(i+1,1)
c
h(i,2) = c*a1 + s*a2
h(i+1,2) = c*a4 - s*a3
h(i+1,1) = c*a3 + s*a4
c
c %----------------------------------------------------%
c | Accumulate the rotation in the matrix Q; Q <- Q*G |
c %----------------------------------------------------%
c
do 50 j = 1, min( i+jj, kplusp )
a1 = c*q(j,i) + s*q(j,i+1)
q(j,i+1) = - s*q(j,i) + c*q(j,i+1)
q(j,i) = a1
50 continue
c
70 continue
c
end if
c
c %--------------------------%
c | Update the block pointer |
c %--------------------------%
c
istart = iend + 1
c
c %------------------------------------------%
c | Make sure that h(iend,1) is non-negative |
c | If not then set h(iend,1) <-- -h(iend,1) |
c | and negate the last column of Q. |
c | We have effectively carried out a |
c | similarity on transformation H |
c %------------------------------------------%
c
if (h(iend,1) .lt. zero) then
h(iend,1) = -h(iend,1)
call dscal(kplusp, -one, q(1,iend), 1)
end if
c
c %--------------------------------------------------------%
c | Apply the same shift to the next block if there is any |
c %--------------------------------------------------------%
c
if (iend .lt. kplusp) go to 20
c
c %-----------------------------------------------------%
c | Check if we can increase the the start of the block |
c %-----------------------------------------------------%
c
do 80 i = itop, kplusp-1
if (h(i+1,1) .gt. zero) go to 90
itop = itop + 1
80 continue
c
c %-----------------------------------%
c | Finished applying the jj-th shift |
c %-----------------------------------%
c
90 continue
c
c %------------------------------------------%
c | All shifts have been applied. Check for |
c | more possible deflation that might occur |
c | after the last shift is applied. |
c %------------------------------------------%
c
do 100 i = itop, kplusp-1
big = abs(h(i,2)) + abs(h(i+1,2))
if (h(i+1,1) .le. epsmch*big) then
if (msglvl .gt. 0) then
call ivout (logfil, 1, i, ndigit,
& '_sapps: deflation at row/column no.')
call dvout (logfil, 1, h(i+1,1), ndigit,
& '_sapps: the corresponding off diagonal element')
end if
h(i+1,1) = zero
end if
100 continue
c
c %-------------------------------------------------%
c | Compute the (kev+1)-st column of (V*Q) and |
c | temporarily store the result in WORKD(N+1:2*N). |
c | This is not necessary if h(kev+1,1) = 0. |
c %-------------------------------------------------%
c
if ( h(kev+1,1) .gt. zero )
& call dgemv ('N', n, kplusp, one, v, ldv,
& q(1,kev+1), 1, zero, workd(n+1), 1)
c
c %-------------------------------------------------------%
c | Compute column 1 to kev of (V*Q) in backward order |
c | taking advantage that Q is an upper triangular matrix |
c | with lower bandwidth np. |
c | Place results in v(:,kplusp-kev:kplusp) temporarily. |
c %-------------------------------------------------------%
c
do 130 i = 1, kev
call dgemv ('N', n, kplusp-i+1, one, v, ldv,
& q(1,kev-i+1), 1, zero, workd, 1)
call dcopy (n, workd, 1, v(1,kplusp-i+1), 1)
130 continue
c
c %-------------------------------------------------%
c | Move v(:,kplusp-kev+1:kplusp) into v(:,1:kev). |
c %-------------------------------------------------%
c
call dlacpy ('All', n, kev, v(1,np+1), ldv, v, ldv)
c
c %--------------------------------------------%
c | Copy the (kev+1)-st column of (V*Q) in the |
c | appropriate place if h(kev+1,1) .ne. zero. |
c %--------------------------------------------%
c
if ( h(kev+1,1) .gt. zero )
& call dcopy (n, workd(n+1), 1, v(1,kev+1), 1)
c
c %-------------------------------------%
c | Update the residual vector: |
c | r <- sigmak*r + betak*v(:,kev+1) |
c | where |
c | sigmak = (e_{kev+p}'*Q)*e_{kev} |
c | betak = e_{kev+1}'*H*e_{kev} |
c %-------------------------------------%
c
call dscal (n, q(kplusp,kev), resid, 1)
if (h(kev+1,1) .gt. zero)
& call daxpy (n, h(kev+1,1), v(1,kev+1), 1, resid, 1)
c
if (msglvl .gt. 1) then
call dvout (logfil, 1, q(kplusp,kev), ndigit,
& '_sapps: sigmak of the updated residual vector')
call dvout (logfil, 1, h(kev+1,1), ndigit,
& '_sapps: betak of the updated residual vector')
call dvout (logfil, kev, h(1,2), ndigit,
& '_sapps: updated main diagonal of H for next iteration')
if (kev .gt. 1) then
call dvout (logfil, kev-1, h(2,1), ndigit,
& '_sapps: updated sub diagonal of H for next iteration')
end if
end if
c
call second (t1)
tsapps = tsapps + (t1 - t0)
c
9000 continue
return
c
c %---------------%
c | End of dsapps |
c %---------------%
c
end

850
arpack/ARPACK/SRC/dsaup2.f Normal file
View File

@@ -0,0 +1,850 @@
c-----------------------------------------------------------------------
c\BeginDoc
c
c\Name: dsaup2
c
c\Description:
c Intermediate level interface called by dsaupd.
c
c\Usage:
c call dsaup2
c ( IDO, BMAT, N, WHICH, NEV, NP, TOL, RESID, MODE, IUPD,
c ISHIFT, MXITER, V, LDV, H, LDH, RITZ, BOUNDS, Q, LDQ, WORKL,
c IPNTR, WORKD, INFO )
c
c\Arguments
c
c IDO, BMAT, N, WHICH, NEV, TOL, RESID: same as defined in dsaupd.
c MODE, ISHIFT, MXITER: see the definition of IPARAM in dsaupd.
c
c NP Integer. (INPUT/OUTPUT)
c Contains the number of implicit shifts to apply during
c each Arnoldi/Lanczos iteration.
c If ISHIFT=1, NP is adjusted dynamically at each iteration
c to accelerate convergence and prevent stagnation.
c This is also roughly equal to the number of matrix-vector
c products (involving the operator OP) per Arnoldi iteration.
c The logic for adjusting is contained within the current
c subroutine.
c If ISHIFT=0, NP is the number of shifts the user needs
c to provide via reverse comunication. 0 < NP < NCV-NEV.
c NP may be less than NCV-NEV since a leading block of the current
c upper Tridiagonal matrix has split off and contains "unwanted"
c Ritz values.
c Upon termination of the IRA iteration, NP contains the number
c of "converged" wanted Ritz values.
c
c IUPD Integer. (INPUT)
c IUPD .EQ. 0: use explicit restart instead implicit update.
c IUPD .NE. 0: use implicit update.
c
c V Double precision N by (NEV+NP) array. (INPUT/OUTPUT)
c The Lanczos basis vectors.
c
c LDV Integer. (INPUT)
c Leading dimension of V exactly as declared in the calling
c program.
c
c H Double precision (NEV+NP) by 2 array. (OUTPUT)
c H is used to store the generated symmetric tridiagonal matrix
c The subdiagonal is stored in the first column of H starting
c at H(2,1). The main diagonal is stored in the second column
c of H starting at H(1,2). If dsaup2 converges store the
c B-norm of the final residual vector in H(1,1).
c
c LDH Integer. (INPUT)
c Leading dimension of H exactly as declared in the calling
c program.
c
c RITZ Double precision array of length NEV+NP. (OUTPUT)
c RITZ(1:NEV) contains the computed Ritz values of OP.
c
c BOUNDS Double precision array of length NEV+NP. (OUTPUT)
c BOUNDS(1:NEV) contain the error bounds corresponding to RITZ.
c
c Q Double precision (NEV+NP) by (NEV+NP) array. (WORKSPACE)
c Private (replicated) work array used to accumulate the
c rotation in the shift application step.
c
c LDQ Integer. (INPUT)
c Leading dimension of Q exactly as declared in the calling
c program.
c
c WORKL Double precision array of length at least 3*(NEV+NP). (INPUT/WORKSPACE)
c Private (replicated) array on each PE or array allocated on
c the front end. It is used in the computation of the
c tridiagonal eigenvalue problem, the calculation and
c application of the shifts and convergence checking.
c If ISHIFT .EQ. O and IDO .EQ. 3, the first NP locations
c of WORKL are used in reverse communication to hold the user
c supplied shifts.
c
c IPNTR Integer array of length 3. (OUTPUT)
c Pointer to mark the starting locations in the WORKD for
c vectors used by the Lanczos iteration.
c -------------------------------------------------------------
c IPNTR(1): pointer to the current operand vector X.
c IPNTR(2): pointer to the current result vector Y.
c IPNTR(3): pointer to the vector B * X when used in one of
c the spectral transformation modes. X is the current
c operand.
c -------------------------------------------------------------
c
c WORKD Double precision work array of length 3*N. (REVERSE COMMUNICATION)
c Distributed array to be used in the basic Lanczos iteration
c for reverse communication. The user should not use WORKD
c as temporary workspace during the iteration !!!!!!!!!!
c See Data Distribution Note in dsaupd.
c
c INFO Integer. (INPUT/OUTPUT)
c If INFO .EQ. 0, a randomly initial residual vector is used.
c If INFO .NE. 0, RESID contains the initial residual vector,
c possibly from a previous run.
c Error flag on output.
c = 0: Normal return.
c = 1: All possible eigenvalues of OP has been found.
c NP returns the size of the invariant subspace
c spanning the operator OP.
c = 2: No shifts could be applied.
c = -8: Error return from trid. eigenvalue calculation;
c This should never happen.
c = -9: Starting vector is zero.
c = -9999: Could not build an Lanczos factorization.
c Size that was built in returned in NP.
c
c\EndDoc
c
c-----------------------------------------------------------------------
c
c\BeginLib
c
c\References:
c 1. D.C. Sorensen, "Implicit Application of Polynomial Filters in
c a k-Step Arnoldi Method", SIAM J. Matr. Anal. Apps., 13 (1992),
c pp 357-385.
c 2. R.B. Lehoucq, "Analysis and Implementation of an Implicitly
c Restarted Arnoldi Iteration", Rice University Technical Report
c TR95-13, Department of Computational and Applied Mathematics.
c 3. B.N. Parlett, "The Symmetric Eigenvalue Problem". Prentice-Hall,
c 1980.
c 4. B.N. Parlett, B. Nour-Omid, "Towards a Black Box Lanczos Program",
c Computer Physics Communications, 53 (1989), pp 169-179.
c 5. B. Nour-Omid, B.N. Parlett, T. Ericson, P.S. Jensen, "How to
c Implement the Spectral Transformation", Math. Comp., 48 (1987),
c pp 663-673.
c 6. R.G. Grimes, J.G. Lewis and H.D. Simon, "A Shifted Block Lanczos
c Algorithm for Solving Sparse Symmetric Generalized Eigenproblems",
c SIAM J. Matr. Anal. Apps., January (1993).
c 7. L. Reichel, W.B. Gragg, "Algorithm 686: FORTRAN Subroutines
c for Updating the QR decomposition", ACM TOMS, December 1990,
c Volume 16 Number 4, pp 369-377.
c
c\Routines called:
c dgetv0 ARPACK initial vector generation routine.
c dsaitr ARPACK Lanczos factorization routine.
c dsapps ARPACK application of implicit shifts routine.
c dsconv ARPACK convergence of Ritz values routine.
c dseigt ARPACK compute Ritz values and error bounds routine.
c dsgets ARPACK reorder Ritz values and error bounds routine.
c dsortr ARPACK sorting routine.
c ivout ARPACK utility routine that prints integers.
c second ARPACK utility routine for timing.
c dvout ARPACK utility routine that prints vectors.
c dlamch LAPACK routine that determines machine constants.
c dcopy Level 1 BLAS that copies one vector to another.
c ddot Level 1 BLAS that computes the scalar product of two vectors.
c dnrm2 Level 1 BLAS that computes the norm of a vector.
c dscal Level 1 BLAS that scales a vector.
c dswap Level 1 BLAS that swaps two vectors.
c
c\Author
c Danny Sorensen Phuong Vu
c Richard Lehoucq CRPC / Rice University
c Dept. of Computational & Houston, Texas
c Applied Mathematics
c Rice University
c Houston, Texas
c
c\Revision history:
c 12/15/93: Version ' 2.4'
c xx/xx/95: Version ' 2.4'. (R.B. Lehoucq)
c
c\SCCS Information: @(#)
c FILE: saup2.F SID: 2.7 DATE OF SID: 5/19/98 RELEASE: 2
c
c\EndLib
c
c-----------------------------------------------------------------------
c
subroutine dsaup2
& ( ido, bmat, n, which, nev, np, tol, resid, mode, iupd,
& ishift, mxiter, v, ldv, h, ldh, ritz, bounds,
& q, ldq, workl, ipntr, workd, info )
c
c %----------------------------------------------------%
c | Include files for debugging and timing information |
c %----------------------------------------------------%
c
include 'debug.h'
include 'stat.h'
c
c %------------------%
c | Scalar Arguments |
c %------------------%
c
character bmat*1, which*2
integer ido, info, ishift, iupd, ldh, ldq, ldv, mxiter,
& n, mode, nev, np
Double precision
& tol
c
c %-----------------%
c | Array Arguments |
c %-----------------%
c
integer ipntr(3)
Double precision
& bounds(nev+np), h(ldh,2), q(ldq,nev+np), resid(n),
& ritz(nev+np), v(ldv,nev+np), workd(3*n),
& workl(3*(nev+np))
c
c %------------%
c | Parameters |
c %------------%
c
Double precision
& one, zero
parameter (one = 1.0D+0, zero = 0.0D+0)
c
c %---------------%
c | Local Scalars |
c %---------------%
c
character wprime*2
logical cnorm, getv0, initv, update, ushift
integer ierr, iter, j, kplusp, msglvl, nconv, nevbef, nev0,
& np0, nptemp, nevd2, nevm2, kp(3)
Double precision
& rnorm, temp, eps23
save cnorm, getv0, initv, update, ushift,
& iter, kplusp, msglvl, nconv, nev0, np0,
& rnorm, eps23
c
c %----------------------%
c | External Subroutines |
c %----------------------%
c
external dcopy, dgetv0, dsaitr, dscal, dsconv, dseigt, dsgets,
& dsapps, dsortr, dvout, ivout, second, dswap
c
c %--------------------%
c | External Functions |
c %--------------------%
c
Double precision
& ddot, dnrm2, dlamch
external ddot, dnrm2, dlamch
c
c %---------------------%
c | Intrinsic Functions |
c %---------------------%
c
intrinsic min
c
c %-----------------------%
c | Executable Statements |
c %-----------------------%
c
if (ido .eq. 0) then
c
c %-------------------------------%
c | Initialize timing statistics |
c | & message level for debugging |
c %-------------------------------%
c
call second (t0)
msglvl = msaup2
c
c %---------------------------------%
c | Set machine dependent constant. |
c %---------------------------------%
c
eps23 = dlamch('Epsilon-Machine')
eps23 = eps23**(2.0D+0/3.0D+0)
c
c %-------------------------------------%
c | nev0 and np0 are integer variables |
c | hold the initial values of NEV & NP |
c %-------------------------------------%
c
nev0 = nev
np0 = np
c
c %-------------------------------------%
c | kplusp is the bound on the largest |
c | Lanczos factorization built. |
c | nconv is the current number of |
c | "converged" eigenvlues. |
c | iter is the counter on the current |
c | iteration step. |
c %-------------------------------------%
c
kplusp = nev0 + np0
nconv = 0
iter = 0
c
c %--------------------------------------------%
c | Set flags for computing the first NEV steps |
c | of the Lanczos factorization. |
c %--------------------------------------------%
c
getv0 = .true.
update = .false.
ushift = .false.
cnorm = .false.
c
if (info .ne. 0) then
c
c %--------------------------------------------%
c | User provides the initial residual vector. |
c %--------------------------------------------%
c
initv = .true.
info = 0
else
initv = .false.
end if
end if
c
c %---------------------------------------------%
c | Get a possibly random starting vector and |
c | force it into the range of the operator OP. |
c %---------------------------------------------%
c
10 continue
c
if (getv0) then
call dgetv0 (ido, bmat, 1, initv, n, 1, v, ldv, resid, rnorm,
& ipntr, workd, info)
c
if (ido .ne. 99) go to 9000
c
if (rnorm .eq. zero) then
c
c %-----------------------------------------%
c | The initial vector is zero. Error exit. |
c %-----------------------------------------%
c
info = -9
go to 1200
end if
getv0 = .false.
ido = 0
end if
c
c %------------------------------------------------------------%
c | Back from reverse communication: continue with update step |
c %------------------------------------------------------------%
c
if (update) go to 20
c
c %-------------------------------------------%
c | Back from computing user specified shifts |
c %-------------------------------------------%
c
if (ushift) go to 50
c
c %-------------------------------------%
c | Back from computing residual norm |
c | at the end of the current iteration |
c %-------------------------------------%
c
if (cnorm) go to 100
c
c %----------------------------------------------------------%
c | Compute the first NEV steps of the Lanczos factorization |
c %----------------------------------------------------------%
c
call dsaitr (ido, bmat, n, 0, nev0, mode, resid, rnorm, v, ldv,
& h, ldh, ipntr, workd, info)
c
c %---------------------------------------------------%
c | ido .ne. 99 implies use of reverse communication |
c | to compute operations involving OP and possibly B |
c %---------------------------------------------------%
c
if (ido .ne. 99) go to 9000
c
if (info .gt. 0) then
c
c %-----------------------------------------------------%
c | dsaitr was unable to build an Lanczos factorization |
c | of length NEV0. INFO is returned with the size of |
c | the factorization built. Exit main loop. |
c %-----------------------------------------------------%
c
np = info
mxiter = iter
info = -9999
go to 1200
end if
c
c %--------------------------------------------------------------%
c | |
c | M A I N LANCZOS I T E R A T I O N L O O P |
c | Each iteration implicitly restarts the Lanczos |
c | factorization in place. |
c | |
c %--------------------------------------------------------------%
c
1000 continue
c
iter = iter + 1
c
if (msglvl .gt. 0) then
call ivout (logfil, 1, iter, ndigit,
& '_saup2: **** Start of major iteration number ****')
end if
if (msglvl .gt. 1) then
call ivout (logfil, 1, nev, ndigit,
& '_saup2: The length of the current Lanczos factorization')
call ivout (logfil, 1, np, ndigit,
& '_saup2: Extend the Lanczos factorization by')
end if
c
c %------------------------------------------------------------%
c | Compute NP additional steps of the Lanczos factorization. |
c %------------------------------------------------------------%
c
ido = 0
20 continue
update = .true.
c
call dsaitr (ido, bmat, n, nev, np, mode, resid, rnorm, v,
& ldv, h, ldh, ipntr, workd, info)
c
c %---------------------------------------------------%
c | ido .ne. 99 implies use of reverse communication |
c | to compute operations involving OP and possibly B |
c %---------------------------------------------------%
c
if (ido .ne. 99) go to 9000
c
if (info .gt. 0) then
c
c %-----------------------------------------------------%
c | dsaitr was unable to build an Lanczos factorization |
c | of length NEV0+NP0. INFO is returned with the size |
c | of the factorization built. Exit main loop. |
c %-----------------------------------------------------%
c
np = info
mxiter = iter
info = -9999
go to 1200
end if
update = .false.
c
if (msglvl .gt. 1) then
call dvout (logfil, 1, rnorm, ndigit,
& '_saup2: Current B-norm of residual for factorization')
end if
c
c %--------------------------------------------------------%
c | Compute the eigenvalues and corresponding error bounds |
c | of the current symmetric tridiagonal matrix. |
c %--------------------------------------------------------%
c
call dseigt (rnorm, kplusp, h, ldh, ritz, bounds, workl, ierr)
c
if (ierr .ne. 0) then
info = -8
go to 1200
end if
c
c %----------------------------------------------------%
c | Make a copy of eigenvalues and corresponding error |
c | bounds obtained from _seigt. |
c %----------------------------------------------------%
c
call dcopy(kplusp, ritz, 1, workl(kplusp+1), 1)
call dcopy(kplusp, bounds, 1, workl(2*kplusp+1), 1)
c
c %---------------------------------------------------%
c | Select the wanted Ritz values and their bounds |
c | to be used in the convergence test. |
c | The selection is based on the requested number of |
c | eigenvalues instead of the current NEV and NP to |
c | prevent possible misconvergence. |
c | * Wanted Ritz values := RITZ(NP+1:NEV+NP) |
c | * Shifts := RITZ(1:NP) := WORKL(1:NP) |
c %---------------------------------------------------%
c
nev = nev0
np = np0
call dsgets (ishift, which, nev, np, ritz, bounds, workl)
c
c %-------------------%
c | Convergence test. |
c %-------------------%
c
call dcopy (nev, bounds(np+1), 1, workl(np+1), 1)
call dsconv (nev, ritz(np+1), workl(np+1), tol, nconv)
c
if (msglvl .gt. 2) then
kp(1) = nev
kp(2) = np
kp(3) = nconv
call ivout (logfil, 3, kp, ndigit,
& '_saup2: NEV, NP, NCONV are')
call dvout (logfil, kplusp, ritz, ndigit,
& '_saup2: The eigenvalues of H')
call dvout (logfil, kplusp, bounds, ndigit,
& '_saup2: Ritz estimates of the current NCV Ritz values')
end if
c
c %---------------------------------------------------------%
c | Count the number of unwanted Ritz values that have zero |
c | Ritz estimates. If any Ritz estimates are equal to zero |
c | then a leading block of H of order equal to at least |
c | the number of Ritz values with zero Ritz estimates has |
c | split off. None of these Ritz values may be removed by |
c | shifting. Decrease NP the number of shifts to apply. If |
c | no shifts may be applied, then prepare to exit |
c %---------------------------------------------------------%
c
nptemp = np
do 30 j=1, nptemp
if (bounds(j) .eq. zero) then
np = np - 1
nev = nev + 1
end if
30 continue
c
if ( (nconv .ge. nev0) .or.
& (iter .gt. mxiter) .or.
& (np .eq. 0) ) then
c
c %------------------------------------------------%
c | Prepare to exit. Put the converged Ritz values |
c | and corresponding bounds in RITZ(1:NCONV) and |
c | BOUNDS(1:NCONV) respectively. Then sort. Be |
c | careful when NCONV > NP since we don't want to |
c | swap overlapping locations. |
c %------------------------------------------------%
c
if (which .eq. 'BE') then
c
c %-----------------------------------------------------%
c | Both ends of the spectrum are requested. |
c | Sort the eigenvalues into algebraically decreasing |
c | order first then swap low end of the spectrum next |
c | to high end in appropriate locations. |
c | NOTE: when np < floor(nev/2) be careful not to swap |
c | overlapping locations. |
c %-----------------------------------------------------%
c
wprime = 'SA'
call dsortr (wprime, .true., kplusp, ritz, bounds)
nevd2 = nev0 / 2
nevm2 = nev0 - nevd2
if ( nev .gt. 1 ) then
call dswap ( min(nevd2,np), ritz(nevm2+1), 1,
& ritz( max(kplusp-nevd2+1,kplusp-np+1) ), 1)
call dswap ( min(nevd2,np), bounds(nevm2+1), 1,
& bounds( max(kplusp-nevd2+1,kplusp-np+1)), 1)
end if
c
else
c
c %--------------------------------------------------%
c | LM, SM, LA, SA case. |
c | Sort the eigenvalues of H into the an order that |
c | is opposite to WHICH, and apply the resulting |
c | order to BOUNDS. The eigenvalues are sorted so |
c | that the wanted part are always within the first |
c | NEV locations. |
c %--------------------------------------------------%
c
if (which .eq. 'LM') wprime = 'SM'
if (which .eq. 'SM') wprime = 'LM'
if (which .eq. 'LA') wprime = 'SA'
if (which .eq. 'SA') wprime = 'LA'
c
call dsortr (wprime, .true., kplusp, ritz, bounds)
c
end if
c
c %--------------------------------------------------%
c | Scale the Ritz estimate of each Ritz value |
c | by 1 / max(eps23,magnitude of the Ritz value). |
c %--------------------------------------------------%
c
do 35 j = 1, nev0
temp = max( eps23, abs(ritz(j)) )
bounds(j) = bounds(j)/temp
35 continue
c
c %----------------------------------------------------%
c | Sort the Ritz values according to the scaled Ritz |
c | esitmates. This will push all the converged ones |
c | towards the front of ritzr, ritzi, bounds |
c | (in the case when NCONV < NEV.) |
c %----------------------------------------------------%
c
wprime = 'LA'
call dsortr(wprime, .true., nev0, bounds, ritz)
c
c %----------------------------------------------%
c | Scale the Ritz estimate back to its original |
c | value. |
c %----------------------------------------------%
c
do 40 j = 1, nev0
temp = max( eps23, abs(ritz(j)) )
bounds(j) = bounds(j)*temp
40 continue
c
c %--------------------------------------------------%
c | Sort the "converged" Ritz values again so that |
c | the "threshold" values and their associated Ritz |
c | estimates appear at the appropriate position in |
c | ritz and bound. |
c %--------------------------------------------------%
c
if (which .eq. 'BE') then
c
c %------------------------------------------------%
c | Sort the "converged" Ritz values in increasing |
c | order. The "threshold" values are in the |
c | middle. |
c %------------------------------------------------%
c
wprime = 'LA'
call dsortr(wprime, .true., nconv, ritz, bounds)
c
else
c
c %----------------------------------------------%
c | In LM, SM, LA, SA case, sort the "converged" |
c | Ritz values according to WHICH so that the |
c | "threshold" value appears at the front of |
c | ritz. |
c %----------------------------------------------%
call dsortr(which, .true., nconv, ritz, bounds)
c
end if
c
c %------------------------------------------%
c | Use h( 1,1 ) as storage to communicate |
c | rnorm to _seupd if needed |
c %------------------------------------------%
c
h(1,1) = rnorm
c
if (msglvl .gt. 1) then
call dvout (logfil, kplusp, ritz, ndigit,
& '_saup2: Sorted Ritz values.')
call dvout (logfil, kplusp, bounds, ndigit,
& '_saup2: Sorted ritz estimates.')
end if
c
c %------------------------------------%
c | Max iterations have been exceeded. |
c %------------------------------------%
c
if (iter .gt. mxiter .and. nconv .lt. nev) info = 1
c
c %---------------------%
c | No shifts to apply. |
c %---------------------%
c
if (np .eq. 0 .and. nconv .lt. nev0) info = 2
c
np = nconv
go to 1100
c
else if (nconv .lt. nev .and. ishift .eq. 1) then
c
c %---------------------------------------------------%
c | Do not have all the requested eigenvalues yet. |
c | To prevent possible stagnation, adjust the number |
c | of Ritz values and the shifts. |
c %---------------------------------------------------%
c
nevbef = nev
nev = nev + min (nconv, np/2)
if (nev .eq. 1 .and. kplusp .ge. 6) then
nev = kplusp / 2
else if (nev .eq. 1 .and. kplusp .gt. 2) then
nev = 2
end if
np = kplusp - nev
c
c %---------------------------------------%
c | If the size of NEV was just increased |
c | resort the eigenvalues. |
c %---------------------------------------%
c
if (nevbef .lt. nev)
& call dsgets (ishift, which, nev, np, ritz, bounds,
& workl)
c
end if
c
if (msglvl .gt. 0) then
call ivout (logfil, 1, nconv, ndigit,
& '_saup2: no. of "converged" Ritz values at this iter.')
if (msglvl .gt. 1) then
kp(1) = nev
kp(2) = np
call ivout (logfil, 2, kp, ndigit,
& '_saup2: NEV and NP are')
call dvout (logfil, nev, ritz(np+1), ndigit,
& '_saup2: "wanted" Ritz values.')
call dvout (logfil, nev, bounds(np+1), ndigit,
& '_saup2: Ritz estimates of the "wanted" values ')
end if
end if
c
if (ishift .eq. 0) then
c
c %-----------------------------------------------------%
c | User specified shifts: reverse communication to |
c | compute the shifts. They are returned in the first |
c | NP locations of WORKL. |
c %-----------------------------------------------------%
c
ushift = .true.
ido = 3
go to 9000
end if
c
50 continue
c
c %------------------------------------%
c | Back from reverse communication; |
c | User specified shifts are returned |
c | in WORKL(1:*NP) |
c %------------------------------------%
c
ushift = .false.
c
c
c %---------------------------------------------------------%
c | Move the NP shifts to the first NP locations of RITZ to |
c | free up WORKL. This is for the non-exact shift case; |
c | in the exact shift case, dsgets already handles this. |
c %---------------------------------------------------------%
c
if (ishift .eq. 0) call dcopy (np, workl, 1, ritz, 1)
c
if (msglvl .gt. 2) then
call ivout (logfil, 1, np, ndigit,
& '_saup2: The number of shifts to apply ')
call dvout (logfil, np, workl, ndigit,
& '_saup2: shifts selected')
if (ishift .eq. 1) then
call dvout (logfil, np, bounds, ndigit,
& '_saup2: corresponding Ritz estimates')
end if
end if
c
c %---------------------------------------------------------%
c | Apply the NP0 implicit shifts by QR bulge chasing. |
c | Each shift is applied to the entire tridiagonal matrix. |
c | The first 2*N locations of WORKD are used as workspace. |
c | After dsapps is done, we have a Lanczos |
c | factorization of length NEV. |
c %---------------------------------------------------------%
c
call dsapps (n, nev, np, ritz, v, ldv, h, ldh, resid, q, ldq,
& workd)
c
c %---------------------------------------------%
c | Compute the B-norm of the updated residual. |
c | Keep B*RESID in WORKD(1:N) to be used in |
c | the first step of the next call to dsaitr. |
c %---------------------------------------------%
c
cnorm = .true.
call second (t2)
if (bmat .eq. 'G') then
nbx = nbx + 1
call dcopy (n, resid, 1, workd(n+1), 1)
ipntr(1) = n + 1
ipntr(2) = 1
ido = 2
c
c %----------------------------------%
c | Exit in order to compute B*RESID |
c %----------------------------------%
c
go to 9000
else if (bmat .eq. 'I') then
call dcopy (n, resid, 1, workd, 1)
end if
c
100 continue
c
c %----------------------------------%
c | Back from reverse communication; |
c | WORKD(1:N) := B*RESID |
c %----------------------------------%
c
if (bmat .eq. 'G') then
call second (t3)
tmvbx = tmvbx + (t3 - t2)
end if
c
if (bmat .eq. 'G') then
rnorm = ddot (n, resid, 1, workd, 1)
rnorm = sqrt(abs(rnorm))
else if (bmat .eq. 'I') then
rnorm = dnrm2(n, resid, 1)
end if
cnorm = .false.
130 continue
c
if (msglvl .gt. 2) then
call dvout (logfil, 1, rnorm, ndigit,
& '_saup2: B-norm of residual for NEV factorization')
call dvout (logfil, nev, h(1,2), ndigit,
& '_saup2: main diagonal of compressed H matrix')
call dvout (logfil, nev-1, h(2,1), ndigit,
& '_saup2: subdiagonal of compressed H matrix')
end if
c
go to 1000
c
c %---------------------------------------------------------------%
c | |
c | E N D O F M A I N I T E R A T I O N L O O P |
c | |
c %---------------------------------------------------------------%
c
1100 continue
c
mxiter = iter
nev = nconv
c
1200 continue
ido = 99
c
c %------------%
c | Error exit |
c %------------%
c
call second (t1)
tsaup2 = t1 - t0
c
9000 continue
return
c
c %---------------%
c | End of dsaup2 |
c %---------------%
c
end

690
arpack/ARPACK/SRC/dsaupd.f Normal file
View File

@@ -0,0 +1,690 @@
c-----------------------------------------------------------------------
c\BeginDoc
c
c\Name: dsaupd
c
c\Description:
c
c Reverse communication interface for the Implicitly Restarted Arnoldi
c Iteration. For symmetric problems this reduces to a variant of the Lanczos
c method. This method has been designed to compute approximations to a
c few eigenpairs of a linear operator OP that is real and symmetric
c with respect to a real positive semi-definite symmetric matrix B,
c i.e.
c
c B*OP = (OP`)*B.
c
c Another way to express this condition is
c
c < x,OPy > = < OPx,y > where < z,w > = z`Bw .
c
c In the standard eigenproblem B is the identity matrix.
c ( A` denotes transpose of A)
c
c The computed approximate eigenvalues are called Ritz values and
c the corresponding approximate eigenvectors are called Ritz vectors.
c
c dsaupd is usually called iteratively to solve one of the
c following problems:
c
c Mode 1: A*x = lambda*x, A symmetric
c ===> OP = A and B = I.
c
c Mode 2: A*x = lambda*M*x, A symmetric, M symmetric positive definite
c ===> OP = inv[M]*A and B = M.
c ===> (If M can be factored see remark 3 below)
c
c Mode 3: K*x = lambda*M*x, K symmetric, M symmetric positive semi-definite
c ===> OP = (inv[K - sigma*M])*M and B = M.
c ===> Shift-and-Invert mode
c
c Mode 4: K*x = lambda*KG*x, K symmetric positive semi-definite,
c KG symmetric indefinite
c ===> OP = (inv[K - sigma*KG])*K and B = K.
c ===> Buckling mode
c
c Mode 5: A*x = lambda*M*x, A symmetric, M symmetric positive semi-definite
c ===> OP = inv[A - sigma*M]*[A + sigma*M] and B = M.
c ===> Cayley transformed mode
c
c NOTE: The action of w <- inv[A - sigma*M]*v or w <- inv[M]*v
c should be accomplished either by a direct method
c using a sparse matrix factorization and solving
c
c [A - sigma*M]*w = v or M*w = v,
c
c or through an iterative method for solving these
c systems. If an iterative method is used, the
c convergence test must be more stringent than
c the accuracy requirements for the eigenvalue
c approximations.
c
c\Usage:
c call dsaupd
c ( IDO, BMAT, N, WHICH, NEV, TOL, RESID, NCV, V, LDV, IPARAM,
c IPNTR, WORKD, WORKL, LWORKL, INFO )
c
c\Arguments
c IDO Integer. (INPUT/OUTPUT)
c Reverse communication flag. IDO must be zero on the first
c call to dsaupd . IDO will be set internally to
c indicate the type of operation to be performed. Control is
c then given back to the calling routine which has the
c responsibility to carry out the requested operation and call
c dsaupd with the result. The operand is given in
c WORKD(IPNTR(1)), the result must be put in WORKD(IPNTR(2)).
c (If Mode = 2 see remark 5 below)
c -------------------------------------------------------------
c IDO = 0: first call to the reverse communication interface
c IDO = -1: compute Y = OP * X where
c IPNTR(1) is the pointer into WORKD for X,
c IPNTR(2) is the pointer into WORKD for Y.
c This is for the initialization phase to force the
c starting vector into the range of OP.
c IDO = 1: compute Y = OP * X where
c IPNTR(1) is the pointer into WORKD for X,
c IPNTR(2) is the pointer into WORKD for Y.
c In mode 3,4 and 5, the vector B * X is already
c available in WORKD(ipntr(3)). It does not
c need to be recomputed in forming OP * X.
c IDO = 2: compute Y = B * X where
c IPNTR(1) is the pointer into WORKD for X,
c IPNTR(2) is the pointer into WORKD for Y.
c IDO = 3: compute the IPARAM(8) shifts where
c IPNTR(11) is the pointer into WORKL for
c placing the shifts. See remark 6 below.
c IDO = 99: done
c -------------------------------------------------------------
c
c BMAT Character*1. (INPUT)
c BMAT specifies the type of the matrix B that defines the
c semi-inner product for the operator OP.
c B = 'I' -> standard eigenvalue problem A*x = lambda*x
c B = 'G' -> generalized eigenvalue problem A*x = lambda*B*x
c
c N Integer. (INPUT)
c Dimension of the eigenproblem.
c
c WHICH Character*2. (INPUT)
c Specify which of the Ritz values of OP to compute.
c
c 'LA' - compute the NEV largest (algebraic) eigenvalues.
c 'SA' - compute the NEV smallest (algebraic) eigenvalues.
c 'LM' - compute the NEV largest (in magnitude) eigenvalues.
c 'SM' - compute the NEV smallest (in magnitude) eigenvalues.
c 'BE' - compute NEV eigenvalues, half from each end of the
c spectrum. When NEV is odd, compute one more from the
c high end than from the low end.
c (see remark 1 below)
c
c NEV Integer. (INPUT)
c Number of eigenvalues of OP to be computed. 0 < NEV < N.
c
c TOL Double precision scalar. (INPUT)
c Stopping criterion: the relative accuracy of the Ritz value
c is considered acceptable if BOUNDS(I) .LE. TOL*ABS(RITZ(I)).
c If TOL .LE. 0. is passed a default is set:
c DEFAULT = DLAMCH ('EPS') (machine precision as computed
c by the LAPACK auxiliary subroutine DLAMCH ).
c
c RESID Double precision array of length N. (INPUT/OUTPUT)
c On INPUT:
c If INFO .EQ. 0, a random initial residual vector is used.
c If INFO .NE. 0, RESID contains the initial residual vector,
c possibly from a previous run.
c On OUTPUT:
c RESID contains the final residual vector.
c
c NCV Integer. (INPUT)
c Number of columns of the matrix V (less than or equal to N).
c This will indicate how many Lanczos vectors are generated
c at each iteration. After the startup phase in which NEV
c Lanczos vectors are generated, the algorithm generates
c NCV-NEV Lanczos vectors at each subsequent update iteration.
c Most of the cost in generating each Lanczos vector is in the
c matrix-vector product OP*x. (See remark 4 below).
c
c V Double precision N by NCV array. (OUTPUT)
c The NCV columns of V contain the Lanczos basis vectors.
c
c LDV Integer. (INPUT)
c Leading dimension of V exactly as declared in the calling
c program.
c
c IPARAM Integer array of length 11. (INPUT/OUTPUT)
c IPARAM(1) = ISHIFT: method for selecting the implicit shifts.
c The shifts selected at each iteration are used to restart
c the Arnoldi iteration in an implicit fashion.
c -------------------------------------------------------------
c ISHIFT = 0: the shifts are provided by the user via
c reverse communication. The NCV eigenvalues of
c the current tridiagonal matrix T are returned in
c the part of WORKL array corresponding to RITZ.
c See remark 6 below.
c ISHIFT = 1: exact shifts with respect to the reduced
c tridiagonal matrix T. This is equivalent to
c restarting the iteration with a starting vector
c that is a linear combination of Ritz vectors
c associated with the "wanted" Ritz values.
c -------------------------------------------------------------
c
c IPARAM(2) = LEVEC
c No longer referenced. See remark 2 below.
c
c IPARAM(3) = MXITER
c On INPUT: maximum number of Arnoldi update iterations allowed.
c On OUTPUT: actual number of Arnoldi update iterations taken.
c
c IPARAM(4) = NB: blocksize to be used in the recurrence.
c The code currently works only for NB = 1.
c
c IPARAM(5) = NCONV: number of "converged" Ritz values.
c This represents the number of Ritz values that satisfy
c the convergence criterion.
c
c IPARAM(6) = IUPD
c No longer referenced. Implicit restarting is ALWAYS used.
c
c IPARAM(7) = MODE
c On INPUT determines what type of eigenproblem is being solved.
c Must be 1,2,3,4,5; See under \Description of dsaupd for the
c five modes available.
c
c IPARAM(8) = NP
c When ido = 3 and the user provides shifts through reverse
c communication (IPARAM(1)=0), dsaupd returns NP, the number
c of shifts the user is to provide. 0 < NP <=NCV-NEV. See Remark
c 6 below.
c
c IPARAM(9) = NUMOP, IPARAM(10) = NUMOPB, IPARAM(11) = NUMREO,
c OUTPUT: NUMOP = total number of OP*x operations,
c NUMOPB = total number of B*x operations if BMAT='G',
c NUMREO = total number of steps of re-orthogonalization.
c
c IPNTR Integer array of length 11. (OUTPUT)
c Pointer to mark the starting locations in the WORKD and WORKL
c arrays for matrices/vectors used by the Lanczos iteration.
c -------------------------------------------------------------
c IPNTR(1): pointer to the current operand vector X in WORKD.
c IPNTR(2): pointer to the current result vector Y in WORKD.
c IPNTR(3): pointer to the vector B * X in WORKD when used in
c the shift-and-invert mode.
c IPNTR(4): pointer to the next available location in WORKL
c that is untouched by the program.
c IPNTR(5): pointer to the NCV by 2 tridiagonal matrix T in WORKL.
c IPNTR(6): pointer to the NCV RITZ values array in WORKL.
c IPNTR(7): pointer to the Ritz estimates in array WORKL associated
c with the Ritz values located in RITZ in WORKL.
c IPNTR(11): pointer to the NP shifts in WORKL. See Remark 6 below.
c
c Note: IPNTR(8:10) is only referenced by dseupd . See Remark 2.
c IPNTR(8): pointer to the NCV RITZ values of the original system.
c IPNTR(9): pointer to the NCV corresponding error bounds.
c IPNTR(10): pointer to the NCV by NCV matrix of eigenvectors
c of the tridiagonal matrix T. Only referenced by
c dseupd if RVEC = .TRUE. See Remarks.
c -------------------------------------------------------------
c
c WORKD Double precision work array of length 3*N. (REVERSE COMMUNICATION)
c Distributed array to be used in the basic Arnoldi iteration
c for reverse communication. The user should not use WORKD
c as temporary workspace during the iteration. Upon termination
c WORKD(1:N) contains B*RESID(1:N). If the Ritz vectors are desired
c subroutine dseupd uses this output.
c See Data Distribution Note below.
c
c WORKL Double precision work array of length LWORKL. (OUTPUT/WORKSPACE)
c Private (replicated) array on each PE or array allocated on
c the front end. See Data Distribution Note below.
c
c LWORKL Integer. (INPUT)
c LWORKL must be at least NCV**2 + 8*NCV .
c
c INFO Integer. (INPUT/OUTPUT)
c If INFO .EQ. 0, a randomly initial residual vector is used.
c If INFO .NE. 0, RESID contains the initial residual vector,
c possibly from a previous run.
c Error flag on output.
c = 0: Normal exit.
c = 1: Maximum number of iterations taken.
c All possible eigenvalues of OP has been found. IPARAM(5)
c returns the number of wanted converged Ritz values.
c = 2: No longer an informational error. Deprecated starting
c with release 2 of ARPACK.
c = 3: No shifts could be applied during a cycle of the
c Implicitly restarted Arnoldi iteration. One possibility
c is to increase the size of NCV relative to NEV.
c See remark 4 below.
c = -1: N must be positive.
c = -2: NEV must be positive.
c = -3: NCV must be greater than NEV and less than or equal to N.
c = -4: The maximum number of Arnoldi update iterations allowed
c must be greater than zero.
c = -5: WHICH must be one of 'LM', 'SM', 'LA', 'SA' or 'BE'.
c = -6: BMAT must be one of 'I' or 'G'.
c = -7: Length of private work array WORKL is not sufficient.
c = -8: Error return from trid. eigenvalue calculation;
c Informatinal error from LAPACK routine dsteqr .
c = -9: Starting vector is zero.
c = -10: IPARAM(7) must be 1,2,3,4,5.
c = -11: IPARAM(7) = 1 and BMAT = 'G' are incompatable.
c = -12: IPARAM(1) must be equal to 0 or 1.
c = -13: NEV and WHICH = 'BE' are incompatable.
c = -9999: Could not build an Arnoldi factorization.
c IPARAM(5) returns the size of the current Arnoldi
c factorization. The user is advised to check that
c enough workspace and array storage has been allocated.
c
c
c\Remarks
c 1. The converged Ritz values are always returned in ascending
c algebraic order. The computed Ritz values are approximate
c eigenvalues of OP. The selection of WHICH should be made
c with this in mind when Mode = 3,4,5. After convergence,
c approximate eigenvalues of the original problem may be obtained
c with the ARPACK subroutine dseupd .
c
c 2. If the Ritz vectors corresponding to the converged Ritz values
c are needed, the user must call dseupd immediately following completion
c of dsaupd . This is new starting with version 2.1 of ARPACK.
c
c 3. If M can be factored into a Cholesky factorization M = LL`
c then Mode = 2 should not be selected. Instead one should use
c Mode = 1 with OP = inv(L)*A*inv(L`). Appropriate triangular
c linear systems should be solved with L and L` rather
c than computing inverses. After convergence, an approximate
c eigenvector z of the original problem is recovered by solving
c L`z = x where x is a Ritz vector of OP.
c
c 4. At present there is no a-priori analysis to guide the selection
c of NCV relative to NEV. The only formal requrement is that NCV > NEV.
c However, it is recommended that NCV .ge. 2*NEV. If many problems of
c the same type are to be solved, one should experiment with increasing
c NCV while keeping NEV fixed for a given test problem. This will
c usually decrease the required number of OP*x operations but it
c also increases the work and storage required to maintain the orthogonal
c basis vectors. The optimal "cross-over" with respect to CPU time
c is problem dependent and must be determined empirically.
c
c 5. If IPARAM(7) = 2 then in the Reverse commuication interface the user
c must do the following. When IDO = 1, Y = OP * X is to be computed.
c When IPARAM(7) = 2 OP = inv(B)*A. After computing A*X the user
c must overwrite X with A*X. Y is then the solution to the linear set
c of equations B*Y = A*X.
c
c 6. When IPARAM(1) = 0, and IDO = 3, the user needs to provide the
c NP = IPARAM(8) shifts in locations:
c 1 WORKL(IPNTR(11))
c 2 WORKL(IPNTR(11)+1)
c .
c .
c .
c NP WORKL(IPNTR(11)+NP-1).
c
c The eigenvalues of the current tridiagonal matrix are located in
c WORKL(IPNTR(6)) through WORKL(IPNTR(6)+NCV-1). They are in the
c order defined by WHICH. The associated Ritz estimates are located in
c WORKL(IPNTR(8)), WORKL(IPNTR(8)+1), ... , WORKL(IPNTR(8)+NCV-1).
c
c-----------------------------------------------------------------------
c
c\Data Distribution Note:
c
c Fortran-D syntax:
c ================
c REAL RESID(N), V(LDV,NCV), WORKD(3*N), WORKL(LWORKL)
c DECOMPOSE D1(N), D2(N,NCV)
c ALIGN RESID(I) with D1(I)
c ALIGN V(I,J) with D2(I,J)
c ALIGN WORKD(I) with D1(I) range (1:N)
c ALIGN WORKD(I) with D1(I-N) range (N+1:2*N)
c ALIGN WORKD(I) with D1(I-2*N) range (2*N+1:3*N)
c DISTRIBUTE D1(BLOCK), D2(BLOCK,:)
c REPLICATED WORKL(LWORKL)
c
c Cray MPP syntax:
c ===============
c REAL RESID(N), V(LDV,NCV), WORKD(N,3), WORKL(LWORKL)
c SHARED RESID(BLOCK), V(BLOCK,:), WORKD(BLOCK,:)
c REPLICATED WORKL(LWORKL)
c
c
c\BeginLib
c
c\References:
c 1. D.C. Sorensen, "Implicit Application of Polynomial Filters in
c a k-Step Arnoldi Method", SIAM J. Matr. Anal. Apps., 13 (1992),
c pp 357-385.
c 2. R.B. Lehoucq, "Analysis and Implementation of an Implicitly
c Restarted Arnoldi Iteration", Rice University Technical Report
c TR95-13, Department of Computational and Applied Mathematics.
c 3. B.N. Parlett, "The Symmetric Eigenvalue Problem". Prentice-Hall,
c 1980.
c 4. B.N. Parlett, B. Nour-Omid, "Towards a Black Box Lanczos Program",
c Computer Physics Communications, 53 (1989), pp 169-179.
c 5. B. Nour-Omid, B.N. Parlett, T. Ericson, P.S. Jensen, "How to
c Implement the Spectral Transformation", Math. Comp., 48 (1987),
c pp 663-673.
c 6. R.G. Grimes, J.G. Lewis and H.D. Simon, "A Shifted Block Lanczos
c Algorithm for Solving Sparse Symmetric Generalized Eigenproblems",
c SIAM J. Matr. Anal. Apps., January (1993).
c 7. L. Reichel, W.B. Gragg, "Algorithm 686: FORTRAN Subroutines
c for Updating the QR decomposition", ACM TOMS, December 1990,
c Volume 16 Number 4, pp 369-377.
c 8. R.B. Lehoucq, D.C. Sorensen, "Implementation of Some Spectral
c Transformations in a k-Step Arnoldi Method". In Preparation.
c
c\Routines called:
c dsaup2 ARPACK routine that implements the Implicitly Restarted
c Arnoldi Iteration.
c dstats ARPACK routine that initialize timing and other statistics
c variables.
c ivout ARPACK utility routine that prints integers.
c second ARPACK utility routine for timing.
c dvout ARPACK utility routine that prints vectors.
c dlamch LAPACK routine that determines machine constants.
c
c\Authors
c Danny Sorensen Phuong Vu
c Richard Lehoucq CRPC / Rice University
c Dept. of Computational & Houston, Texas
c Applied Mathematics
c Rice University
c Houston, Texas
c
c\Revision history:
c 12/15/93: Version ' 2.4'
c
c\SCCS Information: @(#)
c FILE: saupd.F SID: 2.8 DATE OF SID: 04/10/01 RELEASE: 2
c
c\Remarks
c 1. None
c
c\EndLib
c
c-----------------------------------------------------------------------
c
subroutine dsaupd
& ( ido, bmat, n, which, nev, tol, resid, ncv, v, ldv, iparam,
& ipntr, workd, workl, lworkl, info )
c
c %----------------------------------------------------%
c | Include files for debugging and timing information |
c %----------------------------------------------------%
c
include 'debug.h'
include 'stat.h'
c
c %------------------%
c | Scalar Arguments |
c %------------------%
c
character bmat*1, which*2
integer ido, info, ldv, lworkl, n, ncv, nev
Double precision
& tol
c
c %-----------------%
c | Array Arguments |
c %-----------------%
c
integer iparam(11), ipntr(11)
Double precision
& resid(n), v(ldv,ncv), workd(3*n), workl(lworkl)
c
c %------------%
c | Parameters |
c %------------%
c
Double precision
& one, zero
parameter (one = 1.0D+0 , zero = 0.0D+0 )
c
c %---------------%
c | Local Scalars |
c %---------------%
c
integer bounds, ierr, ih, iq, ishift, iupd, iw,
& ldh, ldq, msglvl, mxiter, mode, nb,
& nev0, next, np, ritz, j
save bounds, ierr, ih, iq, ishift, iupd, iw,
& ldh, ldq, msglvl, mxiter, mode, nb,
& nev0, next, np, ritz
c
c %----------------------%
c | External Subroutines |
c %----------------------%
c
external dsaup2 , dvout , ivout, second, dstats
c
c %--------------------%
c | External Functions |
c %--------------------%
c
Double precision
& dlamch
external dlamch
c
c %-----------------------%
c | Executable Statements |
c %-----------------------%
c
if (ido .eq. 0) then
c
c %-------------------------------%
c | Initialize timing statistics |
c | & message level for debugging |
c %-------------------------------%
c
call dstats
call second (t0)
msglvl = msaupd
c
ierr = 0
ishift = iparam(1)
mxiter = iparam(3)
c nb = iparam(4)
nb = 1
c
c %--------------------------------------------%
c | Revision 2 performs only implicit restart. |
c %--------------------------------------------%
c
iupd = 1
mode = iparam(7)
c
c %----------------%
c | Error checking |
c %----------------%
c
if (n .le. 0) then
ierr = -1
else if (nev .le. 0) then
ierr = -2
else if (ncv .le. nev .or. ncv .gt. n) then
ierr = -3
end if
c
c %----------------------------------------------%
c | NP is the number of additional steps to |
c | extend the length NEV Lanczos factorization. |
c %----------------------------------------------%
c
np = ncv - nev
c
if (mxiter .le. 0) ierr = -4
if (which .ne. 'LM' .and.
& which .ne. 'SM' .and.
& which .ne. 'LA' .and.
& which .ne. 'SA' .and.
& which .ne. 'BE') ierr = -5
if (bmat .ne. 'I' .and. bmat .ne. 'G') ierr = -6
c
if (lworkl .lt. ncv**2 + 8*ncv) ierr = -7
if (mode .lt. 1 .or. mode .gt. 5) then
ierr = -10
else if (mode .eq. 1 .and. bmat .eq. 'G') then
ierr = -11
else if (ishift .lt. 0 .or. ishift .gt. 1) then
ierr = -12
else if (nev .eq. 1 .and. which .eq. 'BE') then
ierr = -13
end if
c
c %------------%
c | Error Exit |
c %------------%
c
if (ierr .ne. 0) then
info = ierr
ido = 99
go to 9000
end if
c
c %------------------------%
c | Set default parameters |
c %------------------------%
c
if (nb .le. 0) nb = 1
if (tol .le. zero) tol = dlamch ('EpsMach')
c
c %----------------------------------------------%
c | NP is the number of additional steps to |
c | extend the length NEV Lanczos factorization. |
c | NEV0 is the local variable designating the |
c | size of the invariant subspace desired. |
c %----------------------------------------------%
c
np = ncv - nev
nev0 = nev
c
c %-----------------------------%
c | Zero out internal workspace |
c %-----------------------------%
c
do 10 j = 1, ncv**2 + 8*ncv
workl(j) = zero
10 continue
c
c %-------------------------------------------------------%
c | Pointer into WORKL for address of H, RITZ, BOUNDS, Q |
c | etc... and the remaining workspace. |
c | Also update pointer to be used on output. |
c | Memory is laid out as follows: |
c | workl(1:2*ncv) := generated tridiagonal matrix |
c | workl(2*ncv+1:2*ncv+ncv) := ritz values |
c | workl(3*ncv+1:3*ncv+ncv) := computed error bounds |
c | workl(4*ncv+1:4*ncv+ncv*ncv) := rotation matrix Q |
c | workl(4*ncv+ncv*ncv+1:7*ncv+ncv*ncv) := workspace |
c %-------------------------------------------------------%
c
ldh = ncv
ldq = ncv
ih = 1
ritz = ih + 2*ldh
bounds = ritz + ncv
iq = bounds + ncv
iw = iq + ncv**2
next = iw + 3*ncv
c
ipntr(4) = next
ipntr(5) = ih
ipntr(6) = ritz
ipntr(7) = bounds
ipntr(11) = iw
end if
c
c %-------------------------------------------------------%
c | Carry out the Implicitly restarted Lanczos Iteration. |
c %-------------------------------------------------------%
c
call dsaup2
& ( ido, bmat, n, which, nev0, np, tol, resid, mode, iupd,
& ishift, mxiter, v, ldv, workl(ih), ldh, workl(ritz),
& workl(bounds), workl(iq), ldq, workl(iw), ipntr, workd,
& info )
c
c %--------------------------------------------------%
c | ido .ne. 99 implies use of reverse communication |
c | to compute operations involving OP or shifts. |
c %--------------------------------------------------%
c
if (ido .eq. 3) iparam(8) = np
if (ido .ne. 99) go to 9000
c
iparam(3) = mxiter
iparam(5) = np
iparam(9) = nopx
iparam(10) = nbx
iparam(11) = nrorth
c
c %------------------------------------%
c | Exit if there was an informational |
c | error within dsaup2 . |
c %------------------------------------%
c
if (info .lt. 0) go to 9000
if (info .eq. 2) info = 3
c
if (msglvl .gt. 0) then
call ivout (logfil, 1, mxiter, ndigit,
& '_saupd: number of update iterations taken')
call ivout (logfil, 1, np, ndigit,
& '_saupd: number of "converged" Ritz values')
call dvout (logfil, np, workl(Ritz), ndigit,
& '_saupd: final Ritz values')
call dvout (logfil, np, workl(Bounds), ndigit,
& '_saupd: corresponding error bounds')
end if
c
call second (t1)
tsaupd = t1 - t0
c
if (msglvl .gt. 0) then
c
c %--------------------------------------------------------%
c | Version Number & Version Date are defined in version.h |
c %--------------------------------------------------------%
c
write (6,1000)
write (6,1100) mxiter, nopx, nbx, nrorth, nitref, nrstrt,
& tmvopx, tmvbx, tsaupd, tsaup2, tsaitr, titref,
& tgetv0, tseigt, tsgets, tsapps, tsconv
1000 format (//,
& 5x, '==========================================',/
& 5x, '= Symmetric implicit Arnoldi update code =',/
& 5x, '= Version Number:', ' 2.4' , 19x, ' =',/
& 5x, '= Version Date: ', ' 07/31/96' , 14x, ' =',/
& 5x, '==========================================',/
& 5x, '= Summary of timing statistics =',/
& 5x, '==========================================',//)
1100 format (
& 5x, 'Total number update iterations = ', i5,/
& 5x, 'Total number of OP*x operations = ', i5,/
& 5x, 'Total number of B*x operations = ', i5,/
& 5x, 'Total number of reorthogonalization steps = ', i5,/
& 5x, 'Total number of iterative refinement steps = ', i5,/
& 5x, 'Total number of restart steps = ', i5,/
& 5x, 'Total time in user OP*x operation = ', f12.6,/
& 5x, 'Total time in user B*x operation = ', f12.6,/
& 5x, 'Total time in Arnoldi update routine = ', f12.6,/
& 5x, 'Total time in saup2 routine = ', f12.6,/
& 5x, 'Total time in basic Arnoldi iteration loop = ', f12.6,/
& 5x, 'Total time in reorthogonalization phase = ', f12.6,/
& 5x, 'Total time in (re)start vector generation = ', f12.6,/
& 5x, 'Total time in trid eigenvalue subproblem = ', f12.6,/
& 5x, 'Total time in getting the shifts = ', f12.6,/
& 5x, 'Total time in applying the shifts = ', f12.6,/
& 5x, 'Total time in convergence testing = ', f12.6)
end if
c
9000 continue
c
return
c
c %---------------%
c | End of dsaupd |
c %---------------%
c
end

138
arpack/ARPACK/SRC/dsconv.f Normal file
View File

@@ -0,0 +1,138 @@
c-----------------------------------------------------------------------
c\BeginDoc
c
c\Name: dsconv
c
c\Description:
c Convergence testing for the symmetric Arnoldi eigenvalue routine.
c
c\Usage:
c call dsconv
c ( N, RITZ, BOUNDS, TOL, NCONV )
c
c\Arguments
c N Integer. (INPUT)
c Number of Ritz values to check for convergence.
c
c RITZ Double precision array of length N. (INPUT)
c The Ritz values to be checked for convergence.
c
c BOUNDS Double precision array of length N. (INPUT)
c Ritz estimates associated with the Ritz values in RITZ.
c
c TOL Double precision scalar. (INPUT)
c Desired relative accuracy for a Ritz value to be considered
c "converged".
c
c NCONV Integer scalar. (OUTPUT)
c Number of "converged" Ritz values.
c
c\EndDoc
c
c-----------------------------------------------------------------------
c
c\BeginLib
c
c\Routines called:
c second ARPACK utility routine for timing.
c dlamch LAPACK routine that determines machine constants.
c
c\Author
c Danny Sorensen Phuong Vu
c Richard Lehoucq CRPC / Rice University
c Dept. of Computational & Houston, Texas
c Applied Mathematics
c Rice University
c Houston, Texas
c
c\SCCS Information: @(#)
c FILE: sconv.F SID: 2.4 DATE OF SID: 4/19/96 RELEASE: 2
c
c\Remarks
c 1. Starting with version 2.4, this routine no longer uses the
c Parlett strategy using the gap conditions.
c
c\EndLib
c
c-----------------------------------------------------------------------
c
subroutine dsconv (n, ritz, bounds, tol, nconv)
c
c %----------------------------------------------------%
c | Include files for debugging and timing information |
c %----------------------------------------------------%
c
include 'debug.h'
include 'stat.h'
c
c %------------------%
c | Scalar Arguments |
c %------------------%
c
integer n, nconv
Double precision
& tol
c
c %-----------------%
c | Array Arguments |
c %-----------------%
c
Double precision
& ritz(n), bounds(n)
c
c %---------------%
c | Local Scalars |
c %---------------%
c
integer i
Double precision
& temp, eps23
c
c %-------------------%
c | External routines |
c %-------------------%
c
Double precision
& dlamch
external dlamch
c %---------------------%
c | Intrinsic Functions |
c %---------------------%
c
intrinsic abs
c
c %-----------------------%
c | Executable Statements |
c %-----------------------%
c
call second (t0)
c
eps23 = dlamch('Epsilon-Machine')
eps23 = eps23**(2.0D+0 / 3.0D+0)
c
nconv = 0
do 10 i = 1, n
c
c %-----------------------------------------------------%
c | The i-th Ritz value is considered "converged" |
c | when: bounds(i) .le. TOL*max(eps23, abs(ritz(i))) |
c %-----------------------------------------------------%
c
temp = max( eps23, abs(ritz(i)) )
if ( bounds(i) .le. tol*temp ) then
nconv = nconv + 1
end if
c
10 continue
c
call second (t1)
tsconv = tsconv + (t1 - t0)
c
return
c
c %---------------%
c | End of dsconv |
c %---------------%
c
end

181
arpack/ARPACK/SRC/dseigt.f Normal file
View File

@@ -0,0 +1,181 @@
c-----------------------------------------------------------------------
c\BeginDoc
c
c\Name: dseigt
c
c\Description:
c Compute the eigenvalues of the current symmetric tridiagonal matrix
c and the corresponding error bounds given the current residual norm.
c
c\Usage:
c call dseigt
c ( RNORM, N, H, LDH, EIG, BOUNDS, WORKL, IERR )
c
c\Arguments
c RNORM Double precision scalar. (INPUT)
c RNORM contains the residual norm corresponding to the current
c symmetric tridiagonal matrix H.
c
c N Integer. (INPUT)
c Size of the symmetric tridiagonal matrix H.
c
c H Double precision N by 2 array. (INPUT)
c H contains the symmetric tridiagonal matrix with the
c subdiagonal in the first column starting at H(2,1) and the
c main diagonal in second column.
c
c LDH Integer. (INPUT)
c Leading dimension of H exactly as declared in the calling
c program.
c
c EIG Double precision array of length N. (OUTPUT)
c On output, EIG contains the N eigenvalues of H possibly
c unsorted. The BOUNDS arrays are returned in the
c same sorted order as EIG.
c
c BOUNDS Double precision array of length N. (OUTPUT)
c On output, BOUNDS contains the error estimates corresponding
c to the eigenvalues EIG. This is equal to RNORM times the
c last components of the eigenvectors corresponding to the
c eigenvalues in EIG.
c
c WORKL Double precision work array of length 3*N. (WORKSPACE)
c Private (replicated) array on each PE or array allocated on
c the front end.
c
c IERR Integer. (OUTPUT)
c Error exit flag from dstqrb.
c
c\EndDoc
c
c-----------------------------------------------------------------------
c
c\BeginLib
c
c\Local variables:
c xxxxxx real
c
c\Routines called:
c dstqrb ARPACK routine that computes the eigenvalues and the
c last components of the eigenvectors of a symmetric
c and tridiagonal matrix.
c second ARPACK utility routine for timing.
c dvout ARPACK utility routine that prints vectors.
c dcopy Level 1 BLAS that copies one vector to another.
c
c\Author
c Danny Sorensen Phuong Vu
c Richard Lehoucq CRPC / Rice University
c Dept. of Computational & Houston, Texas
c Applied Mathematics
c Rice University
c Houston, Texas
c
c\Revision history:
c xx/xx/92: Version ' 2.4'
c
c\SCCS Information: @(#)
c FILE: seigt.F SID: 2.4 DATE OF SID: 8/27/96 RELEASE: 2
c
c\Remarks
c None
c
c\EndLib
c
c-----------------------------------------------------------------------
c
subroutine dseigt
& ( rnorm, n, h, ldh, eig, bounds, workl, ierr )
c
c %----------------------------------------------------%
c | Include files for debugging and timing information |
c %----------------------------------------------------%
c
include 'debug.h'
include 'stat.h'
c
c %------------------%
c | Scalar Arguments |
c %------------------%
c
integer ierr, ldh, n
Double precision
& rnorm
c
c %-----------------%
c | Array Arguments |
c %-----------------%
c
Double precision
& eig(n), bounds(n), h(ldh,2), workl(3*n)
c
c %------------%
c | Parameters |
c %------------%
c
Double precision
& zero
parameter (zero = 0.0D+0)
c
c %---------------%
c | Local Scalars |
c %---------------%
c
integer i, k, msglvl
c
c %----------------------%
c | External Subroutines |
c %----------------------%
c
external dcopy, dstqrb, dvout, second
c
c %-----------------------%
c | Executable Statements |
c %-----------------------%
c
c %-------------------------------%
c | Initialize timing statistics |
c | & message level for debugging |
c %-------------------------------%
c
call second (t0)
msglvl = mseigt
c
if (msglvl .gt. 0) then
call dvout (logfil, n, h(1,2), ndigit,
& '_seigt: main diagonal of matrix H')
if (n .gt. 1) then
call dvout (logfil, n-1, h(2,1), ndigit,
& '_seigt: sub diagonal of matrix H')
end if
end if
c
call dcopy (n, h(1,2), 1, eig, 1)
call dcopy (n-1, h(2,1), 1, workl, 1)
call dstqrb (n, eig, workl, bounds, workl(n+1), ierr)
if (ierr .ne. 0) go to 9000
if (msglvl .gt. 1) then
call dvout (logfil, n, bounds, ndigit,
& '_seigt: last row of the eigenvector matrix for H')
end if
c
c %-----------------------------------------------%
c | Finally determine the error bounds associated |
c | with the n Ritz values of H. |
c %-----------------------------------------------%
c
do 30 k = 1, n
bounds(k) = rnorm*abs(bounds(k))
30 continue
c
call second (t1)
tseigt = tseigt + (t1 - t0)
c
9000 continue
return
c
c %---------------%
c | End of dseigt |
c %---------------%
c
end

217
arpack/ARPACK/SRC/dsesrt.f Normal file
View File

@@ -0,0 +1,217 @@
c-----------------------------------------------------------------------
c\BeginDoc
c
c\Name: dsesrt
c
c\Description:
c Sort the array X in the order specified by WHICH and optionally
c apply the permutation to the columns of the matrix A.
c
c\Usage:
c call dsesrt
c ( WHICH, APPLY, N, X, NA, A, LDA)
c
c\Arguments
c WHICH Character*2. (Input)
c 'LM' -> X is sorted into increasing order of magnitude.
c 'SM' -> X is sorted into decreasing order of magnitude.
c 'LA' -> X is sorted into increasing order of algebraic.
c 'SA' -> X is sorted into decreasing order of algebraic.
c
c APPLY Logical. (Input)
c APPLY = .TRUE. -> apply the sorted order to A.
c APPLY = .FALSE. -> do not apply the sorted order to A.
c
c N Integer. (INPUT)
c Dimension of the array X.
c
c X Double precision array of length N. (INPUT/OUTPUT)
c The array to be sorted.
c
c NA Integer. (INPUT)
c Number of rows of the matrix A.
c
c A Double precision array of length NA by N. (INPUT/OUTPUT)
c
c LDA Integer. (INPUT)
c Leading dimension of A.
c
c\EndDoc
c
c-----------------------------------------------------------------------
c
c\BeginLib
c
c\Routines
c dswap Level 1 BLAS that swaps the contents of two vectors.
c
c\Authors
c Danny Sorensen Phuong Vu
c Richard Lehoucq CRPC / Rice University
c Dept. of Computational & Houston, Texas
c Applied Mathematics
c Rice University
c Houston, Texas
c
c\Revision history:
c 12/15/93: Version ' 2.1'.
c Adapted from the sort routine in LANSO and
c the ARPACK code dsortr
c
c\SCCS Information: @(#)
c FILE: sesrt.F SID: 2.3 DATE OF SID: 4/19/96 RELEASE: 2
c
c\EndLib
c
c-----------------------------------------------------------------------
c
subroutine dsesrt (which, apply, n, x, na, a, lda)
c
c %------------------%
c | Scalar Arguments |
c %------------------%
c
character*2 which
logical apply
integer lda, n, na
c
c %-----------------%
c | Array Arguments |
c %-----------------%
c
Double precision
& x(0:n-1), a(lda, 0:n-1)
c
c %---------------%
c | Local Scalars |
c %---------------%
c
integer i, igap, j
Double precision
& temp
c
c %----------------------%
c | External Subroutines |
c %----------------------%
c
external dswap
c
c %-----------------------%
c | Executable Statements |
c %-----------------------%
c
igap = n / 2
c
if (which .eq. 'SA') then
c
c X is sorted into decreasing order of algebraic.
c
10 continue
if (igap .eq. 0) go to 9000
do 30 i = igap, n-1
j = i-igap
20 continue
c
if (j.lt.0) go to 30
c
if (x(j).lt.x(j+igap)) then
temp = x(j)
x(j) = x(j+igap)
x(j+igap) = temp
if (apply) call dswap( na, a(1, j), 1, a(1,j+igap), 1)
else
go to 30
endif
j = j-igap
go to 20
30 continue
igap = igap / 2
go to 10
c
else if (which .eq. 'SM') then
c
c X is sorted into decreasing order of magnitude.
c
40 continue
if (igap .eq. 0) go to 9000
do 60 i = igap, n-1
j = i-igap
50 continue
c
if (j.lt.0) go to 60
c
if (abs(x(j)).lt.abs(x(j+igap))) then
temp = x(j)
x(j) = x(j+igap)
x(j+igap) = temp
if (apply) call dswap( na, a(1, j), 1, a(1,j+igap), 1)
else
go to 60
endif
j = j-igap
go to 50
60 continue
igap = igap / 2
go to 40
c
else if (which .eq. 'LA') then
c
c X is sorted into increasing order of algebraic.
c
70 continue
if (igap .eq. 0) go to 9000
do 90 i = igap, n-1
j = i-igap
80 continue
c
if (j.lt.0) go to 90
c
if (x(j).gt.x(j+igap)) then
temp = x(j)
x(j) = x(j+igap)
x(j+igap) = temp
if (apply) call dswap( na, a(1, j), 1, a(1,j+igap), 1)
else
go to 90
endif
j = j-igap
go to 80
90 continue
igap = igap / 2
go to 70
c
else if (which .eq. 'LM') then
c
c X is sorted into increasing order of magnitude.
c
100 continue
if (igap .eq. 0) go to 9000
do 120 i = igap, n-1
j = i-igap
110 continue
c
if (j.lt.0) go to 120
c
if (abs(x(j)).gt.abs(x(j+igap))) then
temp = x(j)
x(j) = x(j+igap)
x(j+igap) = temp
if (apply) call dswap( na, a(1, j), 1, a(1,j+igap), 1)
else
go to 120
endif
j = j-igap
go to 110
120 continue
igap = igap / 2
go to 100
end if
c
9000 continue
return
c
c %---------------%
c | End of dsesrt |
c %---------------%
c
end

857
arpack/ARPACK/SRC/dseupd.f Normal file
View File

@@ -0,0 +1,857 @@
c\BeginDoc
c
c\Name: dseupd
c
c\Description:
c
c This subroutine returns the converged approximations to eigenvalues
c of A*z = lambda*B*z and (optionally):
c
c (1) the corresponding approximate eigenvectors,
c
c (2) an orthonormal (Lanczos) basis for the associated approximate
c invariant subspace,
c
c (3) Both.
c
c There is negligible additional cost to obtain eigenvectors. An orthonormal
c (Lanczos) basis is always computed. There is an additional storage cost
c of n*nev if both are requested (in this case a separate array Z must be
c supplied).
c
c These quantities are obtained from the Lanczos factorization computed
c by DSAUPD for the linear operator OP prescribed by the MODE selection
c (see IPARAM(7) in DSAUPD documentation.) DSAUPD must be called before
c this routine is called. These approximate eigenvalues and vectors are
c commonly called Ritz values and Ritz vectors respectively. They are
c referred to as such in the comments that follow. The computed orthonormal
c basis for the invariant subspace corresponding to these Ritz values is
c referred to as a Lanczos basis.
c
c See documentation in the header of the subroutine DSAUPD for a definition
c of OP as well as other terms and the relation of computed Ritz values
c and vectors of OP with respect to the given problem A*z = lambda*B*z.
c
c The approximate eigenvalues of the original problem are returned in
c ascending algebraic order. The user may elect to call this routine
c once for each desired Ritz vector and store it peripherally if desired.
c There is also the option of computing a selected set of these vectors
c with a single call.
c
c\Usage:
c call dseupd
c ( RVEC, HOWMNY, SELECT, D, Z, LDZ, SIGMA, BMAT, N, WHICH, NEV, TOL,
c RESID, NCV, V, LDV, IPARAM, IPNTR, WORKD, WORKL, LWORKL, INFO )
c
c RVEC LOGICAL (INPUT)
c Specifies whether Ritz vectors corresponding to the Ritz value
c approximations to the eigenproblem A*z = lambda*B*z are computed.
c
c RVEC = .FALSE. Compute Ritz values only.
c
c RVEC = .TRUE. Compute Ritz vectors.
c
c HOWMNY Character*1 (INPUT)
c Specifies how many Ritz vectors are wanted and the form of Z
c the matrix of Ritz vectors. See remark 1 below.
c = 'A': compute NEV Ritz vectors;
c = 'S': compute some of the Ritz vectors, specified
c by the logical array SELECT.
c
c SELECT Logical array of dimension NCV. (INPUT/WORKSPACE)
c If HOWMNY = 'S', SELECT specifies the Ritz vectors to be
c computed. To select the Ritz vector corresponding to a
c Ritz value D(j), SELECT(j) must be set to .TRUE..
c If HOWMNY = 'A' , SELECT is used as a workspace for
c reordering the Ritz values.
c
c D Double precision array of dimension NEV. (OUTPUT)
c On exit, D contains the Ritz value approximations to the
c eigenvalues of A*z = lambda*B*z. The values are returned
c in ascending order. If IPARAM(7) = 3,4,5 then D represents
c the Ritz values of OP computed by dsaupd transformed to
c those of the original eigensystem A*z = lambda*B*z. If
c IPARAM(7) = 1,2 then the Ritz values of OP are the same
c as the those of A*z = lambda*B*z.
c
c Z Double precision N by NEV array if HOWMNY = 'A'. (OUTPUT)
c On exit, Z contains the B-orthonormal Ritz vectors of the
c eigensystem A*z = lambda*B*z corresponding to the Ritz
c value approximations.
c If RVEC = .FALSE. then Z is not referenced.
c NOTE: The array Z may be set equal to first NEV columns of the
c Arnoldi/Lanczos basis array V computed by DSAUPD .
c
c LDZ Integer. (INPUT)
c The leading dimension of the array Z. If Ritz vectors are
c desired, then LDZ .ge. max( 1, N ). In any case, LDZ .ge. 1.
c
c SIGMA Double precision (INPUT)
c If IPARAM(7) = 3,4,5 represents the shift. Not referenced if
c IPARAM(7) = 1 or 2.
c
c
c **** The remaining arguments MUST be the same as for the ****
c **** call to DSAUPD that was just completed. ****
c
c NOTE: The remaining arguments
c
c BMAT, N, WHICH, NEV, TOL, RESID, NCV, V, LDV, IPARAM, IPNTR,
c WORKD, WORKL, LWORKL, INFO
c
c must be passed directly to DSEUPD following the last call
c to DSAUPD . These arguments MUST NOT BE MODIFIED between
c the the last call to DSAUPD and the call to DSEUPD .
c
c Two of these parameters (WORKL, INFO) are also output parameters:
c
c WORKL Double precision work array of length LWORKL. (OUTPUT/WORKSPACE)
c WORKL(1:4*ncv) contains information obtained in
c dsaupd . They are not changed by dseupd .
c WORKL(4*ncv+1:ncv*ncv+8*ncv) holds the
c untransformed Ritz values, the computed error estimates,
c and the associated eigenvector matrix of H.
c
c Note: IPNTR(8:10) contains the pointer into WORKL for addresses
c of the above information computed by dseupd .
c -------------------------------------------------------------
c IPNTR(8): pointer to the NCV RITZ values of the original system.
c IPNTR(9): pointer to the NCV corresponding error bounds.
c IPNTR(10): pointer to the NCV by NCV matrix of eigenvectors
c of the tridiagonal matrix T. Only referenced by
c dseupd if RVEC = .TRUE. See Remarks.
c -------------------------------------------------------------
c
c INFO Integer. (OUTPUT)
c Error flag on output.
c = 0: Normal exit.
c = -1: N must be positive.
c = -2: NEV must be positive.
c = -3: NCV must be greater than NEV and less than or equal to N.
c = -5: WHICH must be one of 'LM', 'SM', 'LA', 'SA' or 'BE'.
c = -6: BMAT must be one of 'I' or 'G'.
c = -7: Length of private work WORKL array is not sufficient.
c = -8: Error return from trid. eigenvalue calculation;
c Information error from LAPACK routine dsteqr .
c = -9: Starting vector is zero.
c = -10: IPARAM(7) must be 1,2,3,4,5.
c = -11: IPARAM(7) = 1 and BMAT = 'G' are incompatible.
c = -12: NEV and WHICH = 'BE' are incompatible.
c = -14: DSAUPD did not find any eigenvalues to sufficient
c accuracy.
c = -15: HOWMNY must be one of 'A' or 'S' if RVEC = .true.
c = -16: HOWMNY = 'S' not yet implemented
c = -17: DSEUPD got a different count of the number of converged
c Ritz values than DSAUPD got. This indicates the user
c probably made an error in passing data from DSAUPD to
c DSEUPD or that the data was modified before entering
c DSEUPD .
c
c\BeginLib
c
c\References:
c 1. D.C. Sorensen, "Implicit Application of Polynomial Filters in
c a k-Step Arnoldi Method", SIAM J. Matr. Anal. Apps., 13 (1992),
c pp 357-385.
c 2. R.B. Lehoucq, "Analysis and Implementation of an Implicitly
c Restarted Arnoldi Iteration", Rice University Technical Report
c TR95-13, Department of Computational and Applied Mathematics.
c 3. B.N. Parlett, "The Symmetric Eigenvalue Problem". Prentice-Hall,
c 1980.
c 4. B.N. Parlett, B. Nour-Omid, "Towards a Black Box Lanczos Program",
c Computer Physics Communications, 53 (1989), pp 169-179.
c 5. B. Nour-Omid, B.N. Parlett, T. Ericson, P.S. Jensen, "How to
c Implement the Spectral Transformation", Math. Comp., 48 (1987),
c pp 663-673.
c 6. R.G. Grimes, J.G. Lewis and H.D. Simon, "A Shifted Block Lanczos
c Algorithm for Solving Sparse Symmetric Generalized Eigenproblems",
c SIAM J. Matr. Anal. Apps., January (1993).
c 7. L. Reichel, W.B. Gragg, "Algorithm 686: FORTRAN Subroutines
c for Updating the QR decomposition", ACM TOMS, December 1990,
c Volume 16 Number 4, pp 369-377.
c
c\Remarks
c 1. The converged Ritz values are always returned in increasing
c (algebraic) order.
c
c 2. Currently only HOWMNY = 'A' is implemented. It is included at this
c stage for the user who wants to incorporate it.
c
c\Routines called:
c dsesrt ARPACK routine that sorts an array X, and applies the
c corresponding permutation to a matrix A.
c dsortr dsortr ARPACK sorting routine.
c ivout ARPACK utility routine that prints integers.
c dvout ARPACK utility routine that prints vectors.
c dgeqr2 LAPACK routine that computes the QR factorization of
c a matrix.
c dlacpy LAPACK matrix copy routine.
c dlamch LAPACK routine that determines machine constants.
c dorm2r LAPACK routine that applies an orthogonal matrix in
c factored form.
c dsteqr LAPACK routine that computes eigenvalues and eigenvectors
c of a tridiagonal matrix.
c dger Level 2 BLAS rank one update to a matrix.
c dcopy Level 1 BLAS that copies one vector to another .
c dnrm2 Level 1 BLAS that computes the norm of a vector.
c dscal Level 1 BLAS that scales a vector.
c dswap Level 1 BLAS that swaps the contents of two vectors.
c\Authors
c Danny Sorensen Phuong Vu
c Richard Lehoucq CRPC / Rice University
c Chao Yang Houston, Texas
c Dept. of Computational &
c Applied Mathematics
c Rice University
c Houston, Texas
c
c\Revision history:
c 12/15/93: Version ' 2.1'
c
c\SCCS Information: @(#)
c FILE: seupd.F SID: 2.11 DATE OF SID: 04/10/01 RELEASE: 2
c
c\EndLib
c
c-----------------------------------------------------------------------
subroutine dseupd (rvec , howmny, select, d ,
& z , ldz , sigma , bmat ,
& n , which , nev , tol ,
& resid , ncv , v , ldv ,
& iparam, ipntr , workd , workl,
& lworkl, info )
c
c %----------------------------------------------------%
c | Include files for debugging and timing information |
c %----------------------------------------------------%
c
include 'debug.h'
include 'stat.h'
c
c %------------------%
c | Scalar Arguments |
c %------------------%
c
character bmat, howmny, which*2
logical rvec
integer info, ldz, ldv, lworkl, n, ncv, nev
Double precision
& sigma, tol
c
c %-----------------%
c | Array Arguments |
c %-----------------%
c
integer iparam(7), ipntr(11)
logical select(ncv)
Double precision
& d(nev) , resid(n) , v(ldv,ncv),
& z(ldz, nev), workd(2*n), workl(lworkl)
c
c %------------%
c | Parameters |
c %------------%
c
Double precision
& one, zero
parameter (one = 1.0D+0 , zero = 0.0D+0 )
c
c %---------------%
c | Local Scalars |
c %---------------%
c
character type*6
integer bounds , ierr , ih , ihb , ihd ,
& iq , iw , j , k , ldh ,
& ldq , mode , msglvl, nconv , next ,
& ritz , irz , ibd , np , ishift,
& leftptr, rghtptr, numcnv, jj
Double precision
& bnorm2 , rnorm, temp, temp1, eps23
logical reord
c
c %----------------------%
c | External Subroutines |
c %----------------------%
c
external dcopy , dger , dgeqr2 , dlacpy , dorm2r , dscal ,
& dsesrt , dsteqr , dswap , dvout , ivout , dsortr
c
c %--------------------%
c | External Functions |
c %--------------------%
c
Double precision
& dnrm2 , dlamch
external dnrm2 , dlamch
c
c %---------------------%
c | Intrinsic Functions |
c %---------------------%
c
intrinsic min
c
c %-----------------------%
c | Executable Statements |
c %-----------------------%
c
c %------------------------%
c | Set default parameters |
c %------------------------%
c
msglvl = mseupd
mode = iparam(7)
nconv = iparam(5)
info = 0
c
c %--------------%
c | Quick return |
c %--------------%
c
if (nconv .eq. 0) go to 9000
ierr = 0
c
if (nconv .le. 0) ierr = -14
if (n .le. 0) ierr = -1
if (nev .le. 0) ierr = -2
if (ncv .le. nev .or. ncv .gt. n) ierr = -3
if (which .ne. 'LM' .and.
& which .ne. 'SM' .and.
& which .ne. 'LA' .and.
& which .ne. 'SA' .and.
& which .ne. 'BE') ierr = -5
if (bmat .ne. 'I' .and. bmat .ne. 'G') ierr = -6
if ( (howmny .ne. 'A' .and.
& howmny .ne. 'P' .and.
& howmny .ne. 'S') .and. rvec )
& ierr = -15
if (rvec .and. howmny .eq. 'S') ierr = -16
c
if (rvec .and. lworkl .lt. ncv**2+8*ncv) ierr = -7
c
if (mode .eq. 1 .or. mode .eq. 2) then
type = 'REGULR'
else if (mode .eq. 3 ) then
type = 'SHIFTI'
else if (mode .eq. 4 ) then
type = 'BUCKLE'
else if (mode .eq. 5 ) then
type = 'CAYLEY'
else
ierr = -10
end if
if (mode .eq. 1 .and. bmat .eq. 'G') ierr = -11
if (nev .eq. 1 .and. which .eq. 'BE') ierr = -12
c
c %------------%
c | Error Exit |
c %------------%
c
if (ierr .ne. 0) then
info = ierr
go to 9000
end if
c
c %-------------------------------------------------------%
c | Pointer into WORKL for address of H, RITZ, BOUNDS, Q |
c | etc... and the remaining workspace. |
c | Also update pointer to be used on output. |
c | Memory is laid out as follows: |
c | workl(1:2*ncv) := generated tridiagonal matrix H |
c | The subdiagonal is stored in workl(2:ncv). |
c | The dead spot is workl(1) but upon exiting |
c | dsaupd stores the B-norm of the last residual |
c | vector in workl(1). We use this !!! |
c | workl(2*ncv+1:2*ncv+ncv) := ritz values |
c | The wanted values are in the first NCONV spots. |
c | workl(3*ncv+1:3*ncv+ncv) := computed Ritz estimates |
c | The wanted values are in the first NCONV spots. |
c | NOTE: workl(1:4*ncv) is set by dsaupd and is not |
c | modified by dseupd . |
c %-------------------------------------------------------%
c
c %-------------------------------------------------------%
c | The following is used and set by dseupd . |
c | workl(4*ncv+1:4*ncv+ncv) := used as workspace during |
c | computation of the eigenvectors of H. Stores |
c | the diagonal of H. Upon EXIT contains the NCV |
c | Ritz values of the original system. The first |
c | NCONV spots have the wanted values. If MODE = |
c | 1 or 2 then will equal workl(2*ncv+1:3*ncv). |
c | workl(5*ncv+1:5*ncv+ncv) := used as workspace during |
c | computation of the eigenvectors of H. Stores |
c | the subdiagonal of H. Upon EXIT contains the |
c | NCV corresponding Ritz estimates of the |
c | original system. The first NCONV spots have the |
c | wanted values. If MODE = 1,2 then will equal |
c | workl(3*ncv+1:4*ncv). |
c | workl(6*ncv+1:6*ncv+ncv*ncv) := orthogonal Q that is |
c | the eigenvector matrix for H as returned by |
c | dsteqr . Not referenced if RVEC = .False. |
c | Ordering follows that of workl(4*ncv+1:5*ncv) |
c | workl(6*ncv+ncv*ncv+1:6*ncv+ncv*ncv+2*ncv) := |
c | Workspace. Needed by dsteqr and by dseupd . |
c | GRAND total of NCV*(NCV+8) locations. |
c %-------------------------------------------------------%
c
c
ih = ipntr(5)
ritz = ipntr(6)
bounds = ipntr(7)
ldh = ncv
ldq = ncv
ihd = bounds + ldh
ihb = ihd + ldh
iq = ihb + ldh
iw = iq + ldh*ncv
next = iw + 2*ncv
ipntr(4) = next
ipntr(8) = ihd
ipntr(9) = ihb
ipntr(10) = iq
c
c %----------------------------------------%
c | irz points to the Ritz values computed |
c | by _seigt before exiting _saup2. |
c | ibd points to the Ritz estimates |
c | computed by _seigt before exiting |
c | _saup2. |
c %----------------------------------------%
c
irz = ipntr(11)+ncv
ibd = irz+ncv
c
c
c %---------------------------------%
c | Set machine dependent constant. |
c %---------------------------------%
c
eps23 = dlamch ('Epsilon-Machine')
eps23 = eps23**(2.0D+0 / 3.0D+0 )
c
c %---------------------------------------%
c | RNORM is B-norm of the RESID(1:N). |
c | BNORM2 is the 2 norm of B*RESID(1:N). |
c | Upon exit of dsaupd WORKD(1:N) has |
c | B*RESID(1:N). |
c %---------------------------------------%
c
rnorm = workl(ih)
if (bmat .eq. 'I') then
bnorm2 = rnorm
else if (bmat .eq. 'G') then
bnorm2 = dnrm2 (n, workd, 1)
end if
c
if (msglvl .gt. 2) then
call dvout (logfil, ncv, workl(irz), ndigit,
& '_seupd: Ritz values passed in from _SAUPD.')
call dvout (logfil, ncv, workl(ibd), ndigit,
& '_seupd: Ritz estimates passed in from _SAUPD.')
end if
c
if (rvec) then
c
reord = .false.
c
c %---------------------------------------------------%
c | Use the temporary bounds array to store indices |
c | These will be used to mark the select array later |
c %---------------------------------------------------%
c
do 10 j = 1,ncv
workl(bounds+j-1) = j
select(j) = .false.
10 continue
c
c %-------------------------------------%
c | Select the wanted Ritz values. |
c | Sort the Ritz values so that the |
c | wanted ones appear at the tailing |
c | NEV positions of workl(irr) and |
c | workl(iri). Move the corresponding |
c | error estimates in workl(bound) |
c | accordingly. |
c %-------------------------------------%
c
np = ncv - nev
ishift = 0
call dsgets (ishift, which , nev ,
& np , workl(irz) , workl(bounds),
& workl)
c
if (msglvl .gt. 2) then
call dvout (logfil, ncv, workl(irz), ndigit,
& '_seupd: Ritz values after calling _SGETS.')
call dvout (logfil, ncv, workl(bounds), ndigit,
& '_seupd: Ritz value indices after calling _SGETS.')
end if
c
c %-----------------------------------------------------%
c | Record indices of the converged wanted Ritz values |
c | Mark the select array for possible reordering |
c %-----------------------------------------------------%
c
numcnv = 0
do 11 j = 1,ncv
temp1 = max(eps23, abs(workl(irz+ncv-j)) )
jj = workl(bounds + ncv - j)
if (numcnv .lt. nconv .and.
& workl(ibd+jj-1) .le. tol*temp1) then
select(jj) = .true.
numcnv = numcnv + 1
if (jj .gt. nev) reord = .true.
endif
11 continue
c
c %-----------------------------------------------------------%
c | Check the count (numcnv) of converged Ritz values with |
c | the number (nconv) reported by _saupd. If these two |
c | are different then there has probably been an error |
c | caused by incorrect passing of the _saupd data. |
c %-----------------------------------------------------------%
c
if (msglvl .gt. 2) then
call ivout(logfil, 1, numcnv, ndigit,
& '_seupd: Number of specified eigenvalues')
call ivout(logfil, 1, nconv, ndigit,
& '_seupd: Number of "converged" eigenvalues')
end if
c
if (numcnv .ne. nconv) then
info = -17
go to 9000
end if
c
c %-----------------------------------------------------------%
c | Call LAPACK routine _steqr to compute the eigenvalues and |
c | eigenvectors of the final symmetric tridiagonal matrix H. |
c | Initialize the eigenvector matrix Q to the identity. |
c %-----------------------------------------------------------%
c
call dcopy (ncv-1, workl(ih+1), 1, workl(ihb), 1)
call dcopy (ncv, workl(ih+ldh), 1, workl(ihd), 1)
c
call dsteqr ('Identity', ncv, workl(ihd), workl(ihb),
& workl(iq) , ldq, workl(iw), ierr)
c
if (ierr .ne. 0) then
info = -8
go to 9000
end if
c
if (msglvl .gt. 1) then
call dcopy (ncv, workl(iq+ncv-1), ldq, workl(iw), 1)
call dvout (logfil, ncv, workl(ihd), ndigit,
& '_seupd: NCV Ritz values of the final H matrix')
call dvout (logfil, ncv, workl(iw), ndigit,
& '_seupd: last row of the eigenvector matrix for H')
end if
c
if (reord) then
c
c %---------------------------------------------%
c | Reordered the eigenvalues and eigenvectors |
c | computed by _steqr so that the "converged" |
c | eigenvalues appear in the first NCONV |
c | positions of workl(ihd), and the associated |
c | eigenvectors appear in the first NCONV |
c | columns. |
c %---------------------------------------------%
c
leftptr = 1
rghtptr = ncv
c
if (ncv .eq. 1) go to 30
c
20 if (select(leftptr)) then
c
c %-------------------------------------------%
c | Search, from the left, for the first Ritz |
c | value that has not converged. |
c %-------------------------------------------%
c
leftptr = leftptr + 1
c
else if ( .not. select(rghtptr)) then
c
c %----------------------------------------------%
c | Search, from the right, the first Ritz value |
c | that has converged. |
c %----------------------------------------------%
c
rghtptr = rghtptr - 1
c
else
c
c %----------------------------------------------%
c | Swap the Ritz value on the left that has not |
c | converged with the Ritz value on the right |
c | that has converged. Swap the associated |
c | eigenvector of the tridiagonal matrix H as |
c | well. |
c %----------------------------------------------%
c
temp = workl(ihd+leftptr-1)
workl(ihd+leftptr-1) = workl(ihd+rghtptr-1)
workl(ihd+rghtptr-1) = temp
call dcopy (ncv, workl(iq+ncv*(leftptr-1)), 1,
& workl(iw), 1)
call dcopy (ncv, workl(iq+ncv*(rghtptr-1)), 1,
& workl(iq+ncv*(leftptr-1)), 1)
call dcopy (ncv, workl(iw), 1,
& workl(iq+ncv*(rghtptr-1)), 1)
leftptr = leftptr + 1
rghtptr = rghtptr - 1
c
end if
c
if (leftptr .lt. rghtptr) go to 20
c
30 end if
c
if (msglvl .gt. 2) then
call dvout (logfil, ncv, workl(ihd), ndigit,
& '_seupd: The eigenvalues of H--reordered')
end if
c
c %----------------------------------------%
c | Load the converged Ritz values into D. |
c %----------------------------------------%
c
call dcopy (nconv, workl(ihd), 1, d, 1)
c
else
c
c %-----------------------------------------------------%
c | Ritz vectors not required. Load Ritz values into D. |
c %-----------------------------------------------------%
c
call dcopy (nconv, workl(ritz), 1, d, 1)
call dcopy (ncv, workl(ritz), 1, workl(ihd), 1)
c
end if
c
c %------------------------------------------------------------------%
c | Transform the Ritz values and possibly vectors and corresponding |
c | Ritz estimates of OP to those of A*x=lambda*B*x. The Ritz values |
c | (and corresponding data) are returned in ascending order. |
c %------------------------------------------------------------------%
c
if (type .eq. 'REGULR') then
c
c %---------------------------------------------------------%
c | Ascending sort of wanted Ritz values, vectors and error |
c | bounds. Not necessary if only Ritz values are desired. |
c %---------------------------------------------------------%
c
if (rvec) then
call dsesrt ('LA', rvec , nconv, d, ncv, workl(iq), ldq)
else
call dcopy (ncv, workl(bounds), 1, workl(ihb), 1)
end if
c
else
c
c %-------------------------------------------------------------%
c | * Make a copy of all the Ritz values. |
c | * Transform the Ritz values back to the original system. |
c | For TYPE = 'SHIFTI' the transformation is |
c | lambda = 1/theta + sigma |
c | For TYPE = 'BUCKLE' the transformation is |
c | lambda = sigma * theta / ( theta - 1 ) |
c | For TYPE = 'CAYLEY' the transformation is |
c | lambda = sigma * (theta + 1) / (theta - 1 ) |
c | where the theta are the Ritz values returned by dsaupd . |
c | NOTES: |
c | *The Ritz vectors are not affected by the transformation. |
c | They are only reordered. |
c %-------------------------------------------------------------%
c
call dcopy (ncv, workl(ihd), 1, workl(iw), 1)
if (type .eq. 'SHIFTI') then
do 40 k=1, ncv
workl(ihd+k-1) = one / workl(ihd+k-1) + sigma
40 continue
else if (type .eq. 'BUCKLE') then
do 50 k=1, ncv
workl(ihd+k-1) = sigma * workl(ihd+k-1) /
& (workl(ihd+k-1) - one)
50 continue
else if (type .eq. 'CAYLEY') then
do 60 k=1, ncv
workl(ihd+k-1) = sigma * (workl(ihd+k-1) + one) /
& (workl(ihd+k-1) - one)
60 continue
end if
c
c %-------------------------------------------------------------%
c | * Store the wanted NCONV lambda values into D. |
c | * Sort the NCONV wanted lambda in WORKL(IHD:IHD+NCONV-1) |
c | into ascending order and apply sort to the NCONV theta |
c | values in the transformed system. We will need this to |
c | compute Ritz estimates in the original system. |
c | * Finally sort the lambda`s into ascending order and apply |
c | to Ritz vectors if wanted. Else just sort lambda`s into |
c | ascending order. |
c | NOTES: |
c | *workl(iw:iw+ncv-1) contain the theta ordered so that they |
c | match the ordering of the lambda. We`ll use them again for |
c | Ritz vector purification. |
c %-------------------------------------------------------------%
c
call dcopy (nconv, workl(ihd), 1, d, 1)
call dsortr ('LA', .true., nconv, workl(ihd), workl(iw))
if (rvec) then
call dsesrt ('LA', rvec , nconv, d, ncv, workl(iq), ldq)
else
call dcopy (ncv, workl(bounds), 1, workl(ihb), 1)
call dscal (ncv, bnorm2/rnorm, workl(ihb), 1)
call dsortr ('LA', .true., nconv, d, workl(ihb))
end if
c
end if
c
c %------------------------------------------------%
c | Compute the Ritz vectors. Transform the wanted |
c | eigenvectors of the symmetric tridiagonal H by |
c | the Lanczos basis matrix V. |
c %------------------------------------------------%
c
if (rvec .and. howmny .eq. 'A') then
c
c %----------------------------------------------------------%
c | Compute the QR factorization of the matrix representing |
c | the wanted invariant subspace located in the first NCONV |
c | columns of workl(iq,ldq). |
c %----------------------------------------------------------%
c
call dgeqr2 (ncv, nconv , workl(iq) ,
& ldq, workl(iw+ncv), workl(ihb),
& ierr)
c
c %--------------------------------------------------------%
c | * Postmultiply V by Q. |
c | * Copy the first NCONV columns of VQ into Z. |
c | The N by NCONV matrix Z is now a matrix representation |
c | of the approximate invariant subspace associated with |
c | the Ritz values in workl(ihd). |
c %--------------------------------------------------------%
c
call dorm2r ('Right', 'Notranspose', n ,
& ncv , nconv , workl(iq),
& ldq , workl(iw+ncv), v ,
& ldv , workd(n+1) , ierr)
call dlacpy ('All', n, nconv, v, ldv, z, ldz)
c
c %-----------------------------------------------------%
c | In order to compute the Ritz estimates for the Ritz |
c | values in both systems, need the last row of the |
c | eigenvector matrix. Remember, it`s in factored form |
c %-----------------------------------------------------%
c
do 65 j = 1, ncv-1
workl(ihb+j-1) = zero
65 continue
workl(ihb+ncv-1) = one
call dorm2r ('Left', 'Transpose' , ncv ,
& 1 , nconv , workl(iq) ,
& ldq , workl(iw+ncv), workl(ihb),
& ncv , temp , ierr)
c
else if (rvec .and. howmny .eq. 'S') then
c
c Not yet implemented. See remark 2 above.
c
end if
c
if (type .eq. 'REGULR' .and. rvec) then
c
do 70 j=1, ncv
workl(ihb+j-1) = rnorm * abs( workl(ihb+j-1) )
70 continue
c
else if (type .ne. 'REGULR' .and. rvec) then
c
c %-------------------------------------------------%
c | * Determine Ritz estimates of the theta. |
c | If RVEC = .true. then compute Ritz estimates |
c | of the theta. |
c | If RVEC = .false. then copy Ritz estimates |
c | as computed by dsaupd . |
c | * Determine Ritz estimates of the lambda. |
c %-------------------------------------------------%
c
call dscal (ncv, bnorm2, workl(ihb), 1)
if (type .eq. 'SHIFTI') then
c
do 80 k=1, ncv
workl(ihb+k-1) = abs( workl(ihb+k-1) )
& / workl(iw+k-1)**2
80 continue
c
else if (type .eq. 'BUCKLE') then
c
do 90 k=1, ncv
workl(ihb+k-1) = sigma * abs( workl(ihb+k-1) )
& / (workl(iw+k-1)-one )**2
90 continue
c
else if (type .eq. 'CAYLEY') then
c
do 100 k=1, ncv
workl(ihb+k-1) = abs( workl(ihb+k-1)
& / workl(iw+k-1)*(workl(iw+k-1)-one) )
100 continue
c
end if
c
end if
c
if (type .ne. 'REGULR' .and. msglvl .gt. 1) then
call dvout (logfil, nconv, d, ndigit,
& '_seupd: Untransformed converged Ritz values')
call dvout (logfil, nconv, workl(ihb), ndigit,
& '_seupd: Ritz estimates of the untransformed Ritz values')
else if (msglvl .gt. 1) then
call dvout (logfil, nconv, d, ndigit,
& '_seupd: Converged Ritz values')
call dvout (logfil, nconv, workl(ihb), ndigit,
& '_seupd: Associated Ritz estimates')
end if
c
c %-------------------------------------------------%
c | Ritz vector purification step. Formally perform |
c | one of inverse subspace iteration. Only used |
c | for MODE = 3,4,5. See reference 7 |
c %-------------------------------------------------%
c
if (rvec .and. (type .eq. 'SHIFTI' .or. type .eq. 'CAYLEY')) then
c
do 110 k=0, nconv-1
workl(iw+k) = workl(iq+k*ldq+ncv-1)
& / workl(iw+k)
110 continue
c
else if (rvec .and. type .eq. 'BUCKLE') then
c
do 120 k=0, nconv-1
workl(iw+k) = workl(iq+k*ldq+ncv-1)
& / (workl(iw+k)-one)
120 continue
c
end if
c
if (type .ne. 'REGULR')
& call dger (n, nconv, one, resid, 1, workl(iw), 1, z, ldz)
c
9000 continue
c
return
c
c %---------------%
c | End of dseupd |
c %---------------%
c
end

219
arpack/ARPACK/SRC/dsgets.f Normal file
View File

@@ -0,0 +1,219 @@
c-----------------------------------------------------------------------
c\BeginDoc
c
c\Name: dsgets
c
c\Description:
c Given the eigenvalues of the symmetric tridiagonal matrix H,
c computes the NP shifts AMU that are zeros of the polynomial of
c degree NP which filters out components of the unwanted eigenvectors
c corresponding to the AMU's based on some given criteria.
c
c NOTE: This is called even in the case of user specified shifts in
c order to sort the eigenvalues, and error bounds of H for later use.
c
c\Usage:
c call dsgets
c ( ISHIFT, WHICH, KEV, NP, RITZ, BOUNDS, SHIFTS )
c
c\Arguments
c ISHIFT Integer. (INPUT)
c Method for selecting the implicit shifts at each iteration.
c ISHIFT = 0: user specified shifts
c ISHIFT = 1: exact shift with respect to the matrix H.
c
c WHICH Character*2. (INPUT)
c Shift selection criteria.
c 'LM' -> KEV eigenvalues of largest magnitude are retained.
c 'SM' -> KEV eigenvalues of smallest magnitude are retained.
c 'LA' -> KEV eigenvalues of largest value are retained.
c 'SA' -> KEV eigenvalues of smallest value are retained.
c 'BE' -> KEV eigenvalues, half from each end of the spectrum.
c If KEV is odd, compute one more from the high end.
c
c KEV Integer. (INPUT)
c KEV+NP is the size of the matrix H.
c
c NP Integer. (INPUT)
c Number of implicit shifts to be computed.
c
c RITZ Double precision array of length KEV+NP. (INPUT/OUTPUT)
c On INPUT, RITZ contains the eigenvalues of H.
c On OUTPUT, RITZ are sorted so that the unwanted eigenvalues
c are in the first NP locations and the wanted part is in
c the last KEV locations. When exact shifts are selected, the
c unwanted part corresponds to the shifts to be applied.
c
c BOUNDS Double precision array of length KEV+NP. (INPUT/OUTPUT)
c Error bounds corresponding to the ordering in RITZ.
c
c SHIFTS Double precision array of length NP. (INPUT/OUTPUT)
c On INPUT: contains the user specified shifts if ISHIFT = 0.
c On OUTPUT: contains the shifts sorted into decreasing order
c of magnitude with respect to the Ritz estimates contained in
c BOUNDS. If ISHIFT = 0, SHIFTS is not modified on exit.
c
c\EndDoc
c
c-----------------------------------------------------------------------
c
c\BeginLib
c
c\Local variables:
c xxxxxx real
c
c\Routines called:
c dsortr ARPACK utility sorting routine.
c ivout ARPACK utility routine that prints integers.
c second ARPACK utility routine for timing.
c dvout ARPACK utility routine that prints vectors.
c dcopy Level 1 BLAS that copies one vector to another.
c dswap Level 1 BLAS that swaps the contents of two vectors.
c
c\Author
c Danny Sorensen Phuong Vu
c Richard Lehoucq CRPC / Rice University
c Dept. of Computational & Houston, Texas
c Applied Mathematics
c Rice University
c Houston, Texas
c
c\Revision history:
c xx/xx/93: Version ' 2.1'
c
c\SCCS Information: @(#)
c FILE: sgets.F SID: 2.4 DATE OF SID: 4/19/96 RELEASE: 2
c
c\Remarks
c
c\EndLib
c
c-----------------------------------------------------------------------
c
subroutine dsgets ( ishift, which, kev, np, ritz, bounds, shifts )
c
c %----------------------------------------------------%
c | Include files for debugging and timing information |
c %----------------------------------------------------%
c
include 'debug.h'
include 'stat.h'
c
c %------------------%
c | Scalar Arguments |
c %------------------%
c
character*2 which
integer ishift, kev, np
c
c %-----------------%
c | Array Arguments |
c %-----------------%
c
Double precision
& bounds(kev+np), ritz(kev+np), shifts(np)
c
c %------------%
c | Parameters |
c %------------%
c
Double precision
& one, zero
parameter (one = 1.0D+0, zero = 0.0D+0)
c
c %---------------%
c | Local Scalars |
c %---------------%
c
integer kevd2, msglvl
c
c %----------------------%
c | External Subroutines |
c %----------------------%
c
external dswap, dcopy, dsortr, second
c
c %---------------------%
c | Intrinsic Functions |
c %---------------------%
c
intrinsic max, min
c
c %-----------------------%
c | Executable Statements |
c %-----------------------%
c
c %-------------------------------%
c | Initialize timing statistics |
c | & message level for debugging |
c %-------------------------------%
c
call second (t0)
msglvl = msgets
c
if (which .eq. 'BE') then
c
c %-----------------------------------------------------%
c | Both ends of the spectrum are requested. |
c | Sort the eigenvalues into algebraically increasing |
c | order first then swap high end of the spectrum next |
c | to low end in appropriate locations. |
c | NOTE: when np < floor(kev/2) be careful not to swap |
c | overlapping locations. |
c %-----------------------------------------------------%
c
call dsortr ('LA', .true., kev+np, ritz, bounds)
kevd2 = kev / 2
if ( kev .gt. 1 ) then
call dswap ( min(kevd2,np), ritz, 1,
& ritz( max(kevd2,np)+1 ), 1)
call dswap ( min(kevd2,np), bounds, 1,
& bounds( max(kevd2,np)+1 ), 1)
end if
c
else
c
c %----------------------------------------------------%
c | LM, SM, LA, SA case. |
c | Sort the eigenvalues of H into the desired order |
c | and apply the resulting order to BOUNDS. |
c | The eigenvalues are sorted so that the wanted part |
c | are always in the last KEV locations. |
c %----------------------------------------------------%
c
call dsortr (which, .true., kev+np, ritz, bounds)
end if
c
if (ishift .eq. 1 .and. np .gt. 0) then
c
c %-------------------------------------------------------%
c | Sort the unwanted Ritz values used as shifts so that |
c | the ones with largest Ritz estimates are first. |
c | This will tend to minimize the effects of the |
c | forward instability of the iteration when the shifts |
c | are applied in subroutine dsapps. |
c %-------------------------------------------------------%
c
call dsortr ('SM', .true., np, bounds, ritz)
call dcopy (np, ritz, 1, shifts, 1)
end if
c
call second (t1)
tsgets = tsgets + (t1 - t0)
c
if (msglvl .gt. 0) then
call ivout (logfil, 1, kev, ndigit, '_sgets: KEV is')
call ivout (logfil, 1, np, ndigit, '_sgets: NP is')
call dvout (logfil, kev+np, ritz, ndigit,
& '_sgets: Eigenvalues of current H matrix')
call dvout (logfil, kev+np, bounds, ndigit,
& '_sgets: Associated Ritz estimates')
end if
c
return
c
c %---------------%
c | End of dsgets |
c %---------------%
c
end

344
arpack/ARPACK/SRC/dsortc.f Normal file
View File

@@ -0,0 +1,344 @@
c-----------------------------------------------------------------------
c\BeginDoc
c
c\Name: dsortc
c
c\Description:
c Sorts the complex array in XREAL and XIMAG into the order
c specified by WHICH and optionally applies the permutation to the
c real array Y. It is assumed that if an element of XIMAG is
c nonzero, then its negative is also an element. In other words,
c both members of a complex conjugate pair are to be sorted and the
c pairs are kept adjacent to each other.
c
c\Usage:
c call dsortc
c ( WHICH, APPLY, N, XREAL, XIMAG, Y )
c
c\Arguments
c WHICH Character*2. (Input)
c 'LM' -> sort XREAL,XIMAG into increasing order of magnitude.
c 'SM' -> sort XREAL,XIMAG into decreasing order of magnitude.
c 'LR' -> sort XREAL into increasing order of algebraic.
c 'SR' -> sort XREAL into decreasing order of algebraic.
c 'LI' -> sort XIMAG into increasing order of magnitude.
c 'SI' -> sort XIMAG into decreasing order of magnitude.
c NOTE: If an element of XIMAG is non-zero, then its negative
c is also an element.
c
c APPLY Logical. (Input)
c APPLY = .TRUE. -> apply the sorted order to array Y.
c APPLY = .FALSE. -> do not apply the sorted order to array Y.
c
c N Integer. (INPUT)
c Size of the arrays.
c
c XREAL, Double precision array of length N. (INPUT/OUTPUT)
c XIMAG Real and imaginary part of the array to be sorted.
c
c Y Double precision array of length N. (INPUT/OUTPUT)
c
c\EndDoc
c
c-----------------------------------------------------------------------
c
c\BeginLib
c
c\Author
c Danny Sorensen Phuong Vu
c Richard Lehoucq CRPC / Rice University
c Dept. of Computational & Houston, Texas
c Applied Mathematics
c Rice University
c Houston, Texas
c
c\Revision history:
c xx/xx/92: Version ' 2.1'
c Adapted from the sort routine in LANSO.
c
c\SCCS Information: @(#)
c FILE: sortc.F SID: 2.3 DATE OF SID: 4/20/96 RELEASE: 2
c
c\EndLib
c
c-----------------------------------------------------------------------
c
subroutine dsortc (which, apply, n, xreal, ximag, y)
c
c %------------------%
c | Scalar Arguments |
c %------------------%
c
character*2 which
logical apply
integer n
c
c %-----------------%
c | Array Arguments |
c %-----------------%
c
Double precision
& xreal(0:n-1), ximag(0:n-1), y(0:n-1)
c
c %---------------%
c | Local Scalars |
c %---------------%
c
integer i, igap, j
Double precision
& temp, temp1, temp2
c
c %--------------------%
c | External Functions |
c %--------------------%
c
Double precision
& dlapy2
external dlapy2
c
c %-----------------------%
c | Executable Statements |
c %-----------------------%
c
igap = n / 2
c
if (which .eq. 'LM') then
c
c %------------------------------------------------------%
c | Sort XREAL,XIMAG into increasing order of magnitude. |
c %------------------------------------------------------%
c
10 continue
if (igap .eq. 0) go to 9000
c
do 30 i = igap, n-1
j = i-igap
20 continue
c
if (j.lt.0) go to 30
c
temp1 = dlapy2(xreal(j),ximag(j))
temp2 = dlapy2(xreal(j+igap),ximag(j+igap))
c
if (temp1.gt.temp2) then
temp = xreal(j)
xreal(j) = xreal(j+igap)
xreal(j+igap) = temp
c
temp = ximag(j)
ximag(j) = ximag(j+igap)
ximag(j+igap) = temp
c
if (apply) then
temp = y(j)
y(j) = y(j+igap)
y(j+igap) = temp
end if
else
go to 30
end if
j = j-igap
go to 20
30 continue
igap = igap / 2
go to 10
c
else if (which .eq. 'SM') then
c
c %------------------------------------------------------%
c | Sort XREAL,XIMAG into decreasing order of magnitude. |
c %------------------------------------------------------%
c
40 continue
if (igap .eq. 0) go to 9000
c
do 60 i = igap, n-1
j = i-igap
50 continue
c
if (j .lt. 0) go to 60
c
temp1 = dlapy2(xreal(j),ximag(j))
temp2 = dlapy2(xreal(j+igap),ximag(j+igap))
c
if (temp1.lt.temp2) then
temp = xreal(j)
xreal(j) = xreal(j+igap)
xreal(j+igap) = temp
c
temp = ximag(j)
ximag(j) = ximag(j+igap)
ximag(j+igap) = temp
c
if (apply) then
temp = y(j)
y(j) = y(j+igap)
y(j+igap) = temp
end if
else
go to 60
endif
j = j-igap
go to 50
60 continue
igap = igap / 2
go to 40
c
else if (which .eq. 'LR') then
c
c %------------------------------------------------%
c | Sort XREAL into increasing order of algebraic. |
c %------------------------------------------------%
c
70 continue
if (igap .eq. 0) go to 9000
c
do 90 i = igap, n-1
j = i-igap
80 continue
c
if (j.lt.0) go to 90
c
if (xreal(j).gt.xreal(j+igap)) then
temp = xreal(j)
xreal(j) = xreal(j+igap)
xreal(j+igap) = temp
c
temp = ximag(j)
ximag(j) = ximag(j+igap)
ximag(j+igap) = temp
c
if (apply) then
temp = y(j)
y(j) = y(j+igap)
y(j+igap) = temp
end if
else
go to 90
endif
j = j-igap
go to 80
90 continue
igap = igap / 2
go to 70
c
else if (which .eq. 'SR') then
c
c %------------------------------------------------%
c | Sort XREAL into decreasing order of algebraic. |
c %------------------------------------------------%
c
100 continue
if (igap .eq. 0) go to 9000
do 120 i = igap, n-1
j = i-igap
110 continue
c
if (j.lt.0) go to 120
c
if (xreal(j).lt.xreal(j+igap)) then
temp = xreal(j)
xreal(j) = xreal(j+igap)
xreal(j+igap) = temp
c
temp = ximag(j)
ximag(j) = ximag(j+igap)
ximag(j+igap) = temp
c
if (apply) then
temp = y(j)
y(j) = y(j+igap)
y(j+igap) = temp
end if
else
go to 120
endif
j = j-igap
go to 110
120 continue
igap = igap / 2
go to 100
c
else if (which .eq. 'LI') then
c
c %------------------------------------------------%
c | Sort XIMAG into increasing order of magnitude. |
c %------------------------------------------------%
c
130 continue
if (igap .eq. 0) go to 9000
do 150 i = igap, n-1
j = i-igap
140 continue
c
if (j.lt.0) go to 150
c
if (abs(ximag(j)).gt.abs(ximag(j+igap))) then
temp = xreal(j)
xreal(j) = xreal(j+igap)
xreal(j+igap) = temp
c
temp = ximag(j)
ximag(j) = ximag(j+igap)
ximag(j+igap) = temp
c
if (apply) then
temp = y(j)
y(j) = y(j+igap)
y(j+igap) = temp
end if
else
go to 150
endif
j = j-igap
go to 140
150 continue
igap = igap / 2
go to 130
c
else if (which .eq. 'SI') then
c
c %------------------------------------------------%
c | Sort XIMAG into decreasing order of magnitude. |
c %------------------------------------------------%
c
160 continue
if (igap .eq. 0) go to 9000
do 180 i = igap, n-1
j = i-igap
170 continue
c
if (j.lt.0) go to 180
c
if (abs(ximag(j)).lt.abs(ximag(j+igap))) then
temp = xreal(j)
xreal(j) = xreal(j+igap)
xreal(j+igap) = temp
c
temp = ximag(j)
ximag(j) = ximag(j+igap)
ximag(j+igap) = temp
c
if (apply) then
temp = y(j)
y(j) = y(j+igap)
y(j+igap) = temp
end if
else
go to 180
endif
j = j-igap
go to 170
180 continue
igap = igap / 2
go to 160
end if
c
9000 continue
return
c
c %---------------%
c | End of dsortc |
c %---------------%
c
end

218
arpack/ARPACK/SRC/dsortr.f Normal file
View File

@@ -0,0 +1,218 @@
c-----------------------------------------------------------------------
c\BeginDoc
c
c\Name: dsortr
c
c\Description:
c Sort the array X1 in the order specified by WHICH and optionally
c applies the permutation to the array X2.
c
c\Usage:
c call dsortr
c ( WHICH, APPLY, N, X1, X2 )
c
c\Arguments
c WHICH Character*2. (Input)
c 'LM' -> X1 is sorted into increasing order of magnitude.
c 'SM' -> X1 is sorted into decreasing order of magnitude.
c 'LA' -> X1 is sorted into increasing order of algebraic.
c 'SA' -> X1 is sorted into decreasing order of algebraic.
c
c APPLY Logical. (Input)
c APPLY = .TRUE. -> apply the sorted order to X2.
c APPLY = .FALSE. -> do not apply the sorted order to X2.
c
c N Integer. (INPUT)
c Size of the arrays.
c
c X1 Double precision array of length N. (INPUT/OUTPUT)
c The array to be sorted.
c
c X2 Double precision array of length N. (INPUT/OUTPUT)
c Only referenced if APPLY = .TRUE.
c
c\EndDoc
c
c-----------------------------------------------------------------------
c
c\BeginLib
c
c\Author
c Danny Sorensen Phuong Vu
c Richard Lehoucq CRPC / Rice University
c Dept. of Computational & Houston, Texas
c Applied Mathematics
c Rice University
c Houston, Texas
c
c\Revision history:
c 12/16/93: Version ' 2.1'.
c Adapted from the sort routine in LANSO.
c
c\SCCS Information: @(#)
c FILE: sortr.F SID: 2.3 DATE OF SID: 4/19/96 RELEASE: 2
c
c\EndLib
c
c-----------------------------------------------------------------------
c
subroutine dsortr (which, apply, n, x1, x2)
c
c %------------------%
c | Scalar Arguments |
c %------------------%
c
character*2 which
logical apply
integer n
c
c %-----------------%
c | Array Arguments |
c %-----------------%
c
Double precision
& x1(0:n-1), x2(0:n-1)
c
c %---------------%
c | Local Scalars |
c %---------------%
c
integer i, igap, j
Double precision
& temp
c
c %-----------------------%
c | Executable Statements |
c %-----------------------%
c
igap = n / 2
c
if (which .eq. 'SA') then
c
c X1 is sorted into decreasing order of algebraic.
c
10 continue
if (igap .eq. 0) go to 9000
do 30 i = igap, n-1
j = i-igap
20 continue
c
if (j.lt.0) go to 30
c
if (x1(j).lt.x1(j+igap)) then
temp = x1(j)
x1(j) = x1(j+igap)
x1(j+igap) = temp
if (apply) then
temp = x2(j)
x2(j) = x2(j+igap)
x2(j+igap) = temp
end if
else
go to 30
endif
j = j-igap
go to 20
30 continue
igap = igap / 2
go to 10
c
else if (which .eq. 'SM') then
c
c X1 is sorted into decreasing order of magnitude.
c
40 continue
if (igap .eq. 0) go to 9000
do 60 i = igap, n-1
j = i-igap
50 continue
c
if (j.lt.0) go to 60
c
if (abs(x1(j)).lt.abs(x1(j+igap))) then
temp = x1(j)
x1(j) = x1(j+igap)
x1(j+igap) = temp
if (apply) then
temp = x2(j)
x2(j) = x2(j+igap)
x2(j+igap) = temp
end if
else
go to 60
endif
j = j-igap
go to 50
60 continue
igap = igap / 2
go to 40
c
else if (which .eq. 'LA') then
c
c X1 is sorted into increasing order of algebraic.
c
70 continue
if (igap .eq. 0) go to 9000
do 90 i = igap, n-1
j = i-igap
80 continue
c
if (j.lt.0) go to 90
c
if (x1(j).gt.x1(j+igap)) then
temp = x1(j)
x1(j) = x1(j+igap)
x1(j+igap) = temp
if (apply) then
temp = x2(j)
x2(j) = x2(j+igap)
x2(j+igap) = temp
end if
else
go to 90
endif
j = j-igap
go to 80
90 continue
igap = igap / 2
go to 70
c
else if (which .eq. 'LM') then
c
c X1 is sorted into increasing order of magnitude.
c
100 continue
if (igap .eq. 0) go to 9000
do 120 i = igap, n-1
j = i-igap
110 continue
c
if (j.lt.0) go to 120
c
if (abs(x1(j)).gt.abs(x1(j+igap))) then
temp = x1(j)
x1(j) = x1(j+igap)
x1(j+igap) = temp
if (apply) then
temp = x2(j)
x2(j) = x2(j+igap)
x2(j+igap) = temp
end if
else
go to 120
endif
j = j-igap
go to 110
120 continue
igap = igap / 2
go to 100
end if
c
9000 continue
return
c
c %---------------%
c | End of dsortr |
c %---------------%
c
end

61
arpack/ARPACK/SRC/dstatn.f Normal file
View File

@@ -0,0 +1,61 @@
c
c %---------------------------------------------%
c | Initialize statistic and timing information |
c | for nonsymmetric Arnoldi code. |
c %---------------------------------------------%
c
c\Author
c Danny Sorensen Phuong Vu
c Richard Lehoucq CRPC / Rice University
c Dept. of Computational & Houston, Texas
c Applied Mathematics
c Rice University
c Houston, Texas
c
c\SCCS Information: @(#)
c FILE: statn.F SID: 2.4 DATE OF SID: 4/20/96 RELEASE: 2
c
subroutine dstatn
c
c %--------------------------------%
c | See stat.doc for documentation |
c %--------------------------------%
c
include 'stat.h'
c
c %-----------------------%
c | Executable Statements |
c %-----------------------%
c
nopx = 0
nbx = 0
nrorth = 0
nitref = 0
nrstrt = 0
c
tnaupd = 0.0D+0
tnaup2 = 0.0D+0
tnaitr = 0.0D+0
tneigh = 0.0D+0
tngets = 0.0D+0
tnapps = 0.0D+0
tnconv = 0.0D+0
titref = 0.0D+0
tgetv0 = 0.0D+0
trvec = 0.0D+0
c
c %----------------------------------------------------%
c | User time including reverse communication overhead |
c %----------------------------------------------------%
c
tmvopx = 0.0D+0
tmvbx = 0.0D+0
c
return
c
c
c %---------------%
c | End of dstatn |
c %---------------%
c
end

47
arpack/ARPACK/SRC/dstats.f Normal file
View File

@@ -0,0 +1,47 @@
c
c\SCCS Information: @(#)
c FILE: stats.F SID: 2.1 DATE OF SID: 4/19/96 RELEASE: 2
c %---------------------------------------------%
c | Initialize statistic and timing information |
c | for symmetric Arnoldi code. |
c %---------------------------------------------%
subroutine dstats
c %--------------------------------%
c | See stat.doc for documentation |
c %--------------------------------%
include 'stat.h'
c %-----------------------%
c | Executable Statements |
c %-----------------------%
nopx = 0
nbx = 0
nrorth = 0
nitref = 0
nrstrt = 0
tsaupd = 0.0D+0
tsaup2 = 0.0D+0
tsaitr = 0.0D+0
tseigt = 0.0D+0
tsgets = 0.0D+0
tsapps = 0.0D+0
tsconv = 0.0D+0
titref = 0.0D+0
tgetv0 = 0.0D+0
trvec = 0.0D+0
c %----------------------------------------------------%
c | User time including reverse communication overhead |
c %----------------------------------------------------%
tmvopx = 0.0D+0
tmvbx = 0.0D+0
return
c
c End of dstats
c
end

594
arpack/ARPACK/SRC/dstqrb.f Normal file
View File

@@ -0,0 +1,594 @@
c-----------------------------------------------------------------------
c\BeginDoc
c
c\Name: dstqrb
c
c\Description:
c Computes all eigenvalues and the last component of the eigenvectors
c of a symmetric tridiagonal matrix using the implicit QL or QR method.
c
c This is mostly a modification of the LAPACK routine dsteqr.
c See Remarks.
c
c\Usage:
c call dstqrb
c ( N, D, E, Z, WORK, INFO )
c
c\Arguments
c N Integer. (INPUT)
c The number of rows and columns in the matrix. N >= 0.
c
c D Double precision array, dimension (N). (INPUT/OUTPUT)
c On entry, D contains the diagonal elements of the
c tridiagonal matrix.
c On exit, D contains the eigenvalues, in ascending order.
c If an error exit is made, the eigenvalues are correct
c for indices 1,2,...,INFO-1, but they are unordered and
c may not be the smallest eigenvalues of the matrix.
c
c E Double precision array, dimension (N-1). (INPUT/OUTPUT)
c On entry, E contains the subdiagonal elements of the
c tridiagonal matrix in positions 1 through N-1.
c On exit, E has been destroyed.
c
c Z Double precision array, dimension (N). (OUTPUT)
c On exit, Z contains the last row of the orthonormal
c eigenvector matrix of the symmetric tridiagonal matrix.
c If an error exit is made, Z contains the last row of the
c eigenvector matrix associated with the stored eigenvalues.
c
c WORK Double precision array, dimension (max(1,2*N-2)). (WORKSPACE)
c Workspace used in accumulating the transformation for
c computing the last components of the eigenvectors.
c
c INFO Integer. (OUTPUT)
c = 0: normal return.
c < 0: if INFO = -i, the i-th argument had an illegal value.
c > 0: if INFO = +i, the i-th eigenvalue has not converged
c after a total of 30*N iterations.
c
c\Remarks
c 1. None.
c
c-----------------------------------------------------------------------
c
c\BeginLib
c
c\Local variables:
c xxxxxx real
c
c\Routines called:
c daxpy Level 1 BLAS that computes a vector triad.
c dcopy Level 1 BLAS that copies one vector to another.
c dswap Level 1 BLAS that swaps the contents of two vectors.
c lsame LAPACK character comparison routine.
c dlae2 LAPACK routine that computes the eigenvalues of a 2-by-2
c symmetric matrix.
c dlaev2 LAPACK routine that eigendecomposition of a 2-by-2 symmetric
c matrix.
c dlamch LAPACK routine that determines machine constants.
c dlanst LAPACK routine that computes the norm of a matrix.
c dlapy2 LAPACK routine to compute sqrt(x**2+y**2) carefully.
c dlartg LAPACK Givens rotation construction routine.
c dlascl LAPACK routine for careful scaling of a matrix.
c dlaset LAPACK matrix initialization routine.
c dlasr LAPACK routine that applies an orthogonal transformation to
c a matrix.
c dlasrt LAPACK sorting routine.
c dsteqr LAPACK routine that computes eigenvalues and eigenvectors
c of a symmetric tridiagonal matrix.
c xerbla LAPACK error handler routine.
c
c\Authors
c Danny Sorensen Phuong Vu
c Richard Lehoucq CRPC / Rice University
c Dept. of Computational & Houston, Texas
c Applied Mathematics
c Rice University
c Houston, Texas
c
c\SCCS Information: @(#)
c FILE: stqrb.F SID: 2.5 DATE OF SID: 8/27/96 RELEASE: 2
c
c\Remarks
c 1. Starting with version 2.5, this routine is a modified version
c of LAPACK version 2.0 subroutine SSTEQR. No lines are deleted,
c only commeted out and new lines inserted.
c All lines commented out have "c$$$" at the beginning.
c Note that the LAPACK version 1.0 subroutine SSTEQR contained
c bugs.
c
c\EndLib
c
c-----------------------------------------------------------------------
c
subroutine dstqrb ( n, d, e, z, work, info )
c
c %------------------%
c | Scalar Arguments |
c %------------------%
c
integer info, n
c
c %-----------------%
c | Array Arguments |
c %-----------------%
c
Double precision
& d( n ), e( n-1 ), z( n ), work( 2*n-2 )
c
c .. parameters ..
Double precision
& zero, one, two, three
parameter ( zero = 0.0D+0, one = 1.0D+0,
& two = 2.0D+0, three = 3.0D+0 )
integer maxit
parameter ( maxit = 30 )
c ..
c .. local scalars ..
integer i, icompz, ii, iscale, j, jtot, k, l, l1, lend,
& lendm1, lendp1, lendsv, lm1, lsv, m, mm, mm1,
& nm1, nmaxit
Double precision
& anorm, b, c, eps, eps2, f, g, p, r, rt1, rt2,
& s, safmax, safmin, ssfmax, ssfmin, tst
c ..
c .. external functions ..
logical lsame
Double precision
& dlamch, dlanst, dlapy2
external lsame, dlamch, dlanst, dlapy2
c ..
c .. external subroutines ..
external dlae2, dlaev2, dlartg, dlascl, dlaset, dlasr,
& dlasrt, dswap, xerbla
c ..
c .. intrinsic functions ..
intrinsic abs, max, sign, sqrt
c ..
c .. executable statements ..
c
c test the input parameters.
c
info = 0
c
c$$$ IF( LSAME( COMPZ, 'N' ) ) THEN
c$$$ ICOMPZ = 0
c$$$ ELSE IF( LSAME( COMPZ, 'V' ) ) THEN
c$$$ ICOMPZ = 1
c$$$ ELSE IF( LSAME( COMPZ, 'I' ) ) THEN
c$$$ ICOMPZ = 2
c$$$ ELSE
c$$$ ICOMPZ = -1
c$$$ END IF
c$$$ IF( ICOMPZ.LT.0 ) THEN
c$$$ INFO = -1
c$$$ ELSE IF( N.LT.0 ) THEN
c$$$ INFO = -2
c$$$ ELSE IF( ( LDZ.LT.1 ) .OR. ( ICOMPZ.GT.0 .AND. LDZ.LT.MAX( 1,
c$$$ $ N ) ) ) THEN
c$$$ INFO = -6
c$$$ END IF
c$$$ IF( INFO.NE.0 ) THEN
c$$$ CALL XERBLA( 'SSTEQR', -INFO )
c$$$ RETURN
c$$$ END IF
c
c *** New starting with version 2.5 ***
c
icompz = 2
c *************************************
c
c quick return if possible
c
if( n.eq.0 )
$ return
c
if( n.eq.1 ) then
if( icompz.eq.2 ) z( 1 ) = one
return
end if
c
c determine the unit roundoff and over/underflow thresholds.
c
eps = dlamch( 'e' )
eps2 = eps**2
safmin = dlamch( 's' )
safmax = one / safmin
ssfmax = sqrt( safmax ) / three
ssfmin = sqrt( safmin ) / eps2
c
c compute the eigenvalues and eigenvectors of the tridiagonal
c matrix.
c
c$$ if( icompz.eq.2 )
c$$$ $ call dlaset( 'full', n, n, zero, one, z, ldz )
c
c *** New starting with version 2.5 ***
c
if ( icompz .eq. 2 ) then
do 5 j = 1, n-1
z(j) = zero
5 continue
z( n ) = one
end if
c *************************************
c
nmaxit = n*maxit
jtot = 0
c
c determine where the matrix splits and choose ql or qr iteration
c for each block, according to whether top or bottom diagonal
c element is smaller.
c
l1 = 1
nm1 = n - 1
c
10 continue
if( l1.gt.n )
$ go to 160
if( l1.gt.1 )
$ e( l1-1 ) = zero
if( l1.le.nm1 ) then
do 20 m = l1, nm1
tst = abs( e( m ) )
if( tst.eq.zero )
$ go to 30
if( tst.le.( sqrt( abs( d( m ) ) )*sqrt( abs( d( m+
$ 1 ) ) ) )*eps ) then
e( m ) = zero
go to 30
end if
20 continue
end if
m = n
c
30 continue
l = l1
lsv = l
lend = m
lendsv = lend
l1 = m + 1
if( lend.eq.l )
$ go to 10
c
c scale submatrix in rows and columns l to lend
c
anorm = dlanst( 'i', lend-l+1, d( l ), e( l ) )
iscale = 0
if( anorm.eq.zero )
$ go to 10
if( anorm.gt.ssfmax ) then
iscale = 1
call dlascl( 'g', 0, 0, anorm, ssfmax, lend-l+1, 1, d( l ), n,
$ info )
call dlascl( 'g', 0, 0, anorm, ssfmax, lend-l, 1, e( l ), n,
$ info )
else if( anorm.lt.ssfmin ) then
iscale = 2
call dlascl( 'g', 0, 0, anorm, ssfmin, lend-l+1, 1, d( l ), n,
$ info )
call dlascl( 'g', 0, 0, anorm, ssfmin, lend-l, 1, e( l ), n,
$ info )
end if
c
c choose between ql and qr iteration
c
if( abs( d( lend ) ).lt.abs( d( l ) ) ) then
lend = lsv
l = lendsv
end if
c
if( lend.gt.l ) then
c
c ql iteration
c
c look for small subdiagonal element.
c
40 continue
if( l.ne.lend ) then
lendm1 = lend - 1
do 50 m = l, lendm1
tst = abs( e( m ) )**2
if( tst.le.( eps2*abs( d( m ) ) )*abs( d( m+1 ) )+
$ safmin )go to 60
50 continue
end if
c
m = lend
c
60 continue
if( m.lt.lend )
$ e( m ) = zero
p = d( l )
if( m.eq.l )
$ go to 80
c
c if remaining matrix is 2-by-2, use dlae2 or dlaev2
c to compute its eigensystem.
c
if( m.eq.l+1 ) then
if( icompz.gt.0 ) then
call dlaev2( d( l ), e( l ), d( l+1 ), rt1, rt2, c, s )
work( l ) = c
work( n-1+l ) = s
c$$$ call dlasr( 'r', 'v', 'b', n, 2, work( l ),
c$$$ $ work( n-1+l ), z( 1, l ), ldz )
c
c *** New starting with version 2.5 ***
c
tst = z(l+1)
z(l+1) = c*tst - s*z(l)
z(l) = s*tst + c*z(l)
c *************************************
else
call dlae2( d( l ), e( l ), d( l+1 ), rt1, rt2 )
end if
d( l ) = rt1
d( l+1 ) = rt2
e( l ) = zero
l = l + 2
if( l.le.lend )
$ go to 40
go to 140
end if
c
if( jtot.eq.nmaxit )
$ go to 140
jtot = jtot + 1
c
c form shift.
c
g = ( d( l+1 )-p ) / ( two*e( l ) )
r = dlapy2( g, one )
g = d( m ) - p + ( e( l ) / ( g+sign( r, g ) ) )
c
s = one
c = one
p = zero
c
c inner loop
c
mm1 = m - 1
do 70 i = mm1, l, -1
f = s*e( i )
b = c*e( i )
call dlartg( g, f, c, s, r )
if( i.ne.m-1 )
$ e( i+1 ) = r
g = d( i+1 ) - p
r = ( d( i )-g )*s + two*c*b
p = s*r
d( i+1 ) = g + p
g = c*r - b
c
c if eigenvectors are desired, then save rotations.
c
if( icompz.gt.0 ) then
work( i ) = c
work( n-1+i ) = -s
end if
c
70 continue
c
c if eigenvectors are desired, then apply saved rotations.
c
if( icompz.gt.0 ) then
mm = m - l + 1
c$$$ call dlasr( 'r', 'v', 'b', n, mm, work( l ), work( n-1+l ),
c$$$ $ z( 1, l ), ldz )
c
c *** New starting with version 2.5 ***
c
call dlasr( 'r', 'v', 'b', 1, mm, work( l ),
& work( n-1+l ), z( l ), 1 )
c *************************************
end if
c
d( l ) = d( l ) - p
e( l ) = g
go to 40
c
c eigenvalue found.
c
80 continue
d( l ) = p
c
l = l + 1
if( l.le.lend )
$ go to 40
go to 140
c
else
c
c qr iteration
c
c look for small superdiagonal element.
c
90 continue
if( l.ne.lend ) then
lendp1 = lend + 1
do 100 m = l, lendp1, -1
tst = abs( e( m-1 ) )**2
if( tst.le.( eps2*abs( d( m ) ) )*abs( d( m-1 ) )+
$ safmin )go to 110
100 continue
end if
c
m = lend
c
110 continue
if( m.gt.lend )
$ e( m-1 ) = zero
p = d( l )
if( m.eq.l )
$ go to 130
c
c if remaining matrix is 2-by-2, use dlae2 or dlaev2
c to compute its eigensystem.
c
if( m.eq.l-1 ) then
if( icompz.gt.0 ) then
call dlaev2( d( l-1 ), e( l-1 ), d( l ), rt1, rt2, c, s )
c$$$ work( m ) = c
c$$$ work( n-1+m ) = s
c$$$ call dlasr( 'r', 'v', 'f', n, 2, work( m ),
c$$$ $ work( n-1+m ), z( 1, l-1 ), ldz )
c
c *** New starting with version 2.5 ***
c
tst = z(l)
z(l) = c*tst - s*z(l-1)
z(l-1) = s*tst + c*z(l-1)
c *************************************
else
call dlae2( d( l-1 ), e( l-1 ), d( l ), rt1, rt2 )
end if
d( l-1 ) = rt1
d( l ) = rt2
e( l-1 ) = zero
l = l - 2
if( l.ge.lend )
$ go to 90
go to 140
end if
c
if( jtot.eq.nmaxit )
$ go to 140
jtot = jtot + 1
c
c form shift.
c
g = ( d( l-1 )-p ) / ( two*e( l-1 ) )
r = dlapy2( g, one )
g = d( m ) - p + ( e( l-1 ) / ( g+sign( r, g ) ) )
c
s = one
c = one
p = zero
c
c inner loop
c
lm1 = l - 1
do 120 i = m, lm1
f = s*e( i )
b = c*e( i )
call dlartg( g, f, c, s, r )
if( i.ne.m )
$ e( i-1 ) = r
g = d( i ) - p
r = ( d( i+1 )-g )*s + two*c*b
p = s*r
d( i ) = g + p
g = c*r - b
c
c if eigenvectors are desired, then save rotations.
c
if( icompz.gt.0 ) then
work( i ) = c
work( n-1+i ) = s
end if
c
120 continue
c
c if eigenvectors are desired, then apply saved rotations.
c
if( icompz.gt.0 ) then
mm = l - m + 1
c$$$ call dlasr( 'r', 'v', 'f', n, mm, work( m ), work( n-1+m ),
c$$$ $ z( 1, m ), ldz )
c
c *** New starting with version 2.5 ***
c
call dlasr( 'r', 'v', 'f', 1, mm, work( m ), work( n-1+m ),
& z( m ), 1 )
c *************************************
end if
c
d( l ) = d( l ) - p
e( lm1 ) = g
go to 90
c
c eigenvalue found.
c
130 continue
d( l ) = p
c
l = l - 1
if( l.ge.lend )
$ go to 90
go to 140
c
end if
c
c undo scaling if necessary
c
140 continue
if( iscale.eq.1 ) then
call dlascl( 'g', 0, 0, ssfmax, anorm, lendsv-lsv+1, 1,
$ d( lsv ), n, info )
call dlascl( 'g', 0, 0, ssfmax, anorm, lendsv-lsv, 1, e( lsv ),
$ n, info )
else if( iscale.eq.2 ) then
call dlascl( 'g', 0, 0, ssfmin, anorm, lendsv-lsv+1, 1,
$ d( lsv ), n, info )
call dlascl( 'g', 0, 0, ssfmin, anorm, lendsv-lsv, 1, e( lsv ),
$ n, info )
end if
c
c check for no convergence to an eigenvalue after a total
c of n*maxit iterations.
c
if( jtot.lt.nmaxit )
$ go to 10
do 150 i = 1, n - 1
if( e( i ).ne.zero )
$ info = info + 1
150 continue
go to 190
c
c order eigenvalues and eigenvectors.
c
160 continue
if( icompz.eq.0 ) then
c
c use quick sort
c
call dlasrt( 'i', n, d, info )
c
else
c
c use selection sort to minimize swaps of eigenvectors
c
do 180 ii = 2, n
i = ii - 1
k = i
p = d( i )
do 170 j = ii, n
if( d( j ).lt.p ) then
k = j
p = d( j )
end if
170 continue
if( k.ne.i ) then
d( k ) = d( i )
d( i ) = p
c$$$ call dswap( n, z( 1, i ), 1, z( 1, k ), 1 )
c *** New starting with version 2.5 ***
c
p = z(k)
z(k) = z(i)
z(i) = p
c *************************************
end if
180 continue
end if
c
190 continue
return
c
c %---------------%
c | End of dstqrb |
c %---------------%
c
end

419
arpack/ARPACK/SRC/sgetv0.f Normal file
View File

@@ -0,0 +1,419 @@
c-----------------------------------------------------------------------
c\BeginDoc
c
c\Name: sgetv0
c
c\Description:
c Generate a random initial residual vector for the Arnoldi process.
c Force the residual vector to be in the range of the operator OP.
c
c\Usage:
c call sgetv0
c ( IDO, BMAT, ITRY, INITV, N, J, V, LDV, RESID, RNORM,
c IPNTR, WORKD, IERR )
c
c\Arguments
c IDO Integer. (INPUT/OUTPUT)
c Reverse communication flag. IDO must be zero on the first
c call to sgetv0.
c -------------------------------------------------------------
c IDO = 0: first call to the reverse communication interface
c IDO = -1: compute Y = OP * X where
c IPNTR(1) is the pointer into WORKD for X,
c IPNTR(2) is the pointer into WORKD for Y.
c This is for the initialization phase to force the
c starting vector into the range of OP.
c IDO = 2: compute Y = B * X where
c IPNTR(1) is the pointer into WORKD for X,
c IPNTR(2) is the pointer into WORKD for Y.
c IDO = 99: done
c -------------------------------------------------------------
c
c BMAT Character*1. (INPUT)
c BMAT specifies the type of the matrix B in the (generalized)
c eigenvalue problem A*x = lambda*B*x.
c B = 'I' -> standard eigenvalue problem A*x = lambda*x
c B = 'G' -> generalized eigenvalue problem A*x = lambda*B*x
c
c ITRY Integer. (INPUT)
c ITRY counts the number of times that sgetv0 is called.
c It should be set to 1 on the initial call to sgetv0.
c
c INITV Logical variable. (INPUT)
c .TRUE. => the initial residual vector is given in RESID.
c .FALSE. => generate a random initial residual vector.
c
c N Integer. (INPUT)
c Dimension of the problem.
c
c J Integer. (INPUT)
c Index of the residual vector to be generated, with respect to
c the Arnoldi process. J > 1 in case of a "restart".
c
c V Real N by J array. (INPUT)
c The first J-1 columns of V contain the current Arnoldi basis
c if this is a "restart".
c
c LDV Integer. (INPUT)
c Leading dimension of V exactly as declared in the calling
c program.
c
c RESID Real array of length N. (INPUT/OUTPUT)
c Initial residual vector to be generated. If RESID is
c provided, force RESID into the range of the operator OP.
c
c RNORM Real scalar. (OUTPUT)
c B-norm of the generated residual.
c
c IPNTR Integer array of length 3. (OUTPUT)
c
c WORKD Real work array of length 2*N. (REVERSE COMMUNICATION).
c On exit, WORK(1:N) = B*RESID to be used in SSAITR.
c
c IERR Integer. (OUTPUT)
c = 0: Normal exit.
c = -1: Cannot generate a nontrivial restarted residual vector
c in the range of the operator OP.
c
c\EndDoc
c
c-----------------------------------------------------------------------
c
c\BeginLib
c
c\Local variables:
c xxxxxx real
c
c\References:
c 1. D.C. Sorensen, "Implicit Application of Polynomial Filters in
c a k-Step Arnoldi Method", SIAM J. Matr. Anal. Apps., 13 (1992),
c pp 357-385.
c 2. R.B. Lehoucq, "Analysis and Implementation of an Implicitly
c Restarted Arnoldi Iteration", Rice University Technical Report
c TR95-13, Department of Computational and Applied Mathematics.
c
c\Routines called:
c second ARPACK utility routine for timing.
c svout ARPACK utility routine for vector output.
c slarnv LAPACK routine for generating a random vector.
c sgemv Level 2 BLAS routine for matrix vector multiplication.
c scopy Level 1 BLAS that copies one vector to another.
c sdot Level 1 BLAS that computes the scalar product of two vectors.
c snrm2 Level 1 BLAS that computes the norm of a vector.
c
c\Author
c Danny Sorensen Phuong Vu
c Richard Lehoucq CRPC / Rice University
c Dept. of Computational & Houston, Texas
c Applied Mathematics
c Rice University
c Houston, Texas
c
c\SCCS Information: @(#)
c FILE: getv0.F SID: 2.7 DATE OF SID: 04/07/99 RELEASE: 2
c
c\EndLib
c
c-----------------------------------------------------------------------
c
subroutine sgetv0
& ( ido, bmat, itry, initv, n, j, v, ldv, resid, rnorm,
& ipntr, workd, ierr )
c
c %----------------------------------------------------%
c | Include files for debugging and timing information |
c %----------------------------------------------------%
c
include 'debug.h'
include 'stat.h'
c
c %------------------%
c | Scalar Arguments |
c %------------------%
c
character bmat*1
logical initv
integer ido, ierr, itry, j, ldv, n
Real
& rnorm
c
c %-----------------%
c | Array Arguments |
c %-----------------%
c
integer ipntr(3)
Real
& resid(n), v(ldv,j), workd(2*n)
c
c %------------%
c | Parameters |
c %------------%
c
Real
& one, zero
parameter (one = 1.0E+0, zero = 0.0E+0)
c
c %------------------------%
c | Local Scalars & Arrays |
c %------------------------%
c
logical first, inits, orth
integer idist, iseed(4), iter, msglvl, jj
Real
& rnorm0
save first, iseed, inits, iter, msglvl, orth, rnorm0
c
c %----------------------%
c | External Subroutines |
c %----------------------%
c
external slarnv, svout, scopy, sgemv, second
c
c %--------------------%
c | External Functions |
c %--------------------%
c
Real
& sdot, snrm2
external sdot, snrm2
c
c %---------------------%
c | Intrinsic Functions |
c %---------------------%
c
intrinsic abs, sqrt
c
c %-----------------%
c | Data Statements |
c %-----------------%
c
data inits /.true./
c
c %-----------------------%
c | Executable Statements |
c %-----------------------%
c
c
c %-----------------------------------%
c | Initialize the seed of the LAPACK |
c | random number generator |
c %-----------------------------------%
c
if (inits) then
iseed(1) = 1
iseed(2) = 3
iseed(3) = 5
iseed(4) = 7
inits = .false.
end if
c
if (ido .eq. 0) then
c
c %-------------------------------%
c | Initialize timing statistics |
c | & message level for debugging |
c %-------------------------------%
c
call second (t0)
msglvl = mgetv0
c
ierr = 0
iter = 0
first = .FALSE.
orth = .FALSE.
c
c %-----------------------------------------------------%
c | Possibly generate a random starting vector in RESID |
c | Use a LAPACK random number generator used by the |
c | matrix generation routines. |
c | idist = 1: uniform (0,1) distribution; |
c | idist = 2: uniform (-1,1) distribution; |
c | idist = 3: normal (0,1) distribution; |
c %-----------------------------------------------------%
c
if (.not.initv) then
idist = 2
call slarnv (idist, iseed, n, resid)
end if
c
c %----------------------------------------------------------%
c | Force the starting vector into the range of OP to handle |
c | the generalized problem when B is possibly (singular). |
c %----------------------------------------------------------%
c
call second (t2)
if (bmat .eq. 'G') then
nopx = nopx + 1
ipntr(1) = 1
ipntr(2) = n + 1
call scopy (n, resid, 1, workd, 1)
ido = -1
go to 9000
end if
end if
c
c %-----------------------------------------%
c | Back from computing OP*(initial-vector) |
c %-----------------------------------------%
c
if (first) go to 20
c
c %-----------------------------------------------%
c | Back from computing B*(orthogonalized-vector) |
c %-----------------------------------------------%
c
if (orth) go to 40
c
if (bmat .eq. 'G') then
call second (t3)
tmvopx = tmvopx + (t3 - t2)
end if
c
c %------------------------------------------------------%
c | Starting vector is now in the range of OP; r = OP*r; |
c | Compute B-norm of starting vector. |
c %------------------------------------------------------%
c
call second (t2)
first = .TRUE.
if (bmat .eq. 'G') then
nbx = nbx + 1
call scopy (n, workd(n+1), 1, resid, 1)
ipntr(1) = n + 1
ipntr(2) = 1
ido = 2
go to 9000
else if (bmat .eq. 'I') then
call scopy (n, resid, 1, workd, 1)
end if
c
20 continue
c
if (bmat .eq. 'G') then
call second (t3)
tmvbx = tmvbx + (t3 - t2)
end if
c
first = .FALSE.
if (bmat .eq. 'G') then
rnorm0 = sdot (n, resid, 1, workd, 1)
rnorm0 = sqrt(abs(rnorm0))
else if (bmat .eq. 'I') then
rnorm0 = snrm2(n, resid, 1)
end if
rnorm = rnorm0
c
c %---------------------------------------------%
c | Exit if this is the very first Arnoldi step |
c %---------------------------------------------%
c
if (j .eq. 1) go to 50
c
c %----------------------------------------------------------------
c | Otherwise need to B-orthogonalize the starting vector against |
c | the current Arnoldi basis using Gram-Schmidt with iter. ref. |
c | This is the case where an invariant subspace is encountered |
c | in the middle of the Arnoldi factorization. |
c | |
c | s = V^{T}*B*r; r = r - V*s; |
c | |
c | Stopping criteria used for iter. ref. is discussed in |
c | Parlett's book, page 107 and in Gragg & Reichel TOMS paper. |
c %---------------------------------------------------------------%
c
orth = .TRUE.
30 continue
c
call sgemv ('T', n, j-1, one, v, ldv, workd, 1,
& zero, workd(n+1), 1)
call sgemv ('N', n, j-1, -one, v, ldv, workd(n+1), 1,
& one, resid, 1)
c
c %----------------------------------------------------------%
c | Compute the B-norm of the orthogonalized starting vector |
c %----------------------------------------------------------%
c
call second (t2)
if (bmat .eq. 'G') then
nbx = nbx + 1
call scopy (n, resid, 1, workd(n+1), 1)
ipntr(1) = n + 1
ipntr(2) = 1
ido = 2
go to 9000
else if (bmat .eq. 'I') then
call scopy (n, resid, 1, workd, 1)
end if
c
40 continue
c
if (bmat .eq. 'G') then
call second (t3)
tmvbx = tmvbx + (t3 - t2)
end if
c
if (bmat .eq. 'G') then
rnorm = sdot (n, resid, 1, workd, 1)
rnorm = sqrt(abs(rnorm))
else if (bmat .eq. 'I') then
rnorm = snrm2(n, resid, 1)
end if
c
c %--------------------------------------%
c | Check for further orthogonalization. |
c %--------------------------------------%
c
if (msglvl .gt. 2) then
call svout (logfil, 1, rnorm0, ndigit,
& '_getv0: re-orthonalization ; rnorm0 is')
call svout (logfil, 1, rnorm, ndigit,
& '_getv0: re-orthonalization ; rnorm is')
end if
c
if (rnorm .gt. 0.717*rnorm0) go to 50
c
iter = iter + 1
if (iter .le. 5) then
c
c %-----------------------------------%
c | Perform iterative refinement step |
c %-----------------------------------%
c
rnorm0 = rnorm
go to 30
else
c
c %------------------------------------%
c | Iterative refinement step "failed" |
c %------------------------------------%
c
do 45 jj = 1, n
resid(jj) = zero
45 continue
rnorm = zero
ierr = -1
end if
c
50 continue
c
if (msglvl .gt. 0) then
call svout (logfil, 1, rnorm, ndigit,
& '_getv0: B-norm of initial / restarted starting vector')
end if
if (msglvl .gt. 3) then
call svout (logfil, n, resid, ndigit,
& '_getv0: initial / restarted starting vector')
end if
ido = 99
c
call second (t1)
tgetv0 = tgetv0 + (t1 - t0)
c
9000 continue
return
c
c %---------------%
c | End of sgetv0 |
c %---------------%
c
end

521
arpack/ARPACK/SRC/slaqrb.f Normal file
View File

@@ -0,0 +1,521 @@
c-----------------------------------------------------------------------
c\BeginDoc
c
c\Name: slaqrb
c
c\Description:
c Compute the eigenvalues and the Schur decomposition of an upper
c Hessenberg submatrix in rows and columns ILO to IHI. Only the
c last component of the Schur vectors are computed.
c
c This is mostly a modification of the LAPACK routine slahqr.
c
c\Usage:
c call slaqrb
c ( WANTT, N, ILO, IHI, H, LDH, WR, WI, Z, INFO )
c
c\Arguments
c WANTT Logical variable. (INPUT)
c = .TRUE. : the full Schur form T is required;
c = .FALSE.: only eigenvalues are required.
c
c N Integer. (INPUT)
c The order of the matrix H. N >= 0.
c
c ILO Integer. (INPUT)
c IHI Integer. (INPUT)
c It is assumed that H is already upper quasi-triangular in
c rows and columns IHI+1:N, and that H(ILO,ILO-1) = 0 (unless
c ILO = 1). SLAQRB works primarily with the Hessenberg
c submatrix in rows and columns ILO to IHI, but applies
c transformations to all of H if WANTT is .TRUE..
c 1 <= ILO <= max(1,IHI); IHI <= N.
c
c H Real array, dimension (LDH,N). (INPUT/OUTPUT)
c On entry, the upper Hessenberg matrix H.
c On exit, if WANTT is .TRUE., H is upper quasi-triangular in
c rows and columns ILO:IHI, with any 2-by-2 diagonal blocks in
c standard form. If WANTT is .FALSE., the contents of H are
c unspecified on exit.
c
c LDH Integer. (INPUT)
c The leading dimension of the array H. LDH >= max(1,N).
c
c WR Real array, dimension (N). (OUTPUT)
c WI Real array, dimension (N). (OUTPUT)
c The real and imaginary parts, respectively, of the computed
c eigenvalues ILO to IHI are stored in the corresponding
c elements of WR and WI. If two eigenvalues are computed as a
c complex conjugate pair, they are stored in consecutive
c elements of WR and WI, say the i-th and (i+1)th, with
c WI(i) > 0 and WI(i+1) < 0. If WANTT is .TRUE., the
c eigenvalues are stored in the same order as on the diagonal
c of the Schur form returned in H, with WR(i) = H(i,i), and, if
c H(i:i+1,i:i+1) is a 2-by-2 diagonal block,
c WI(i) = sqrt(H(i+1,i)*H(i,i+1)) and WI(i+1) = -WI(i).
c
c Z Real array, dimension (N). (OUTPUT)
c On exit Z contains the last components of the Schur vectors.
c
c INFO Integer. (OUPUT)
c = 0: successful exit
c > 0: SLAQRB failed to compute all the eigenvalues ILO to IHI
c in a total of 30*(IHI-ILO+1) iterations; if INFO = i,
c elements i+1:ihi of WR and WI contain those eigenvalues
c which have been successfully computed.
c
c\Remarks
c 1. None.
c
c-----------------------------------------------------------------------
c
c\BeginLib
c
c\Local variables:
c xxxxxx real
c
c\Routines called:
c slabad LAPACK routine that computes machine constants.
c slamch LAPACK routine that determines machine constants.
c slanhs LAPACK routine that computes various norms of a matrix.
c slanv2 LAPACK routine that computes the Schur factorization of
c 2 by 2 nonsymmetric matrix in standard form.
c slarfg LAPACK Householder reflection construction routine.
c scopy Level 1 BLAS that copies one vector to another.
c srot Level 1 BLAS that applies a rotation to a 2 by 2 matrix.
c
c\Author
c Danny Sorensen Phuong Vu
c Richard Lehoucq CRPC / Rice University
c Dept. of Computational & Houston, Texas
c Applied Mathematics
c Rice University
c Houston, Texas
c
c\Revision history:
c xx/xx/92: Version ' 2.4'
c Modified from the LAPACK routine slahqr so that only the
c last component of the Schur vectors are computed.
c
c\SCCS Information: @(#)
c FILE: laqrb.F SID: 2.2 DATE OF SID: 8/27/96 RELEASE: 2
c
c\Remarks
c 1. None
c
c\EndLib
c
c-----------------------------------------------------------------------
c
subroutine slaqrb ( wantt, n, ilo, ihi, h, ldh, wr, wi,
& z, info )
c
c %------------------%
c | Scalar Arguments |
c %------------------%
c
logical wantt
integer ihi, ilo, info, ldh, n
c
c %-----------------%
c | Array Arguments |
c %-----------------%
c
Real
& h( ldh, * ), wi( * ), wr( * ), z( * )
c
c %------------%
c | Parameters |
c %------------%
c
Real
& zero, one, dat1, dat2
parameter (zero = 0.0E+0, one = 1.0E+0, dat1 = 7.5E-1,
& dat2 = -4.375E-1)
c
c %------------------------%
c | Local Scalars & Arrays |
c %------------------------%
c
integer i, i1, i2, itn, its, j, k, l, m, nh, nr
Real
& cs, h00, h10, h11, h12, h21, h22, h33, h33s,
& h43h34, h44, h44s, ovfl, s, smlnum, sn, sum,
& t1, t2, t3, tst1, ulp, unfl, v1, v2, v3
Real
& v( 3 ), work( 1 )
c
c %--------------------%
c | External Functions |
c %--------------------%
c
Real
& slamch, slanhs
external slamch, slanhs
c
c %----------------------%
c | External Subroutines |
c %----------------------%
c
external scopy, slabad, slanv2, slarfg, srot
c
c %-----------------------%
c | Executable Statements |
c %-----------------------%
c
info = 0
c
c %--------------------------%
c | Quick return if possible |
c %--------------------------%
c
if( n.eq.0 )
& return
if( ilo.eq.ihi ) then
wr( ilo ) = h( ilo, ilo )
wi( ilo ) = zero
return
end if
c
c %---------------------------------------------%
c | Initialize the vector of last components of |
c | the Schur vectors for accumulation. |
c %---------------------------------------------%
c
do 5 j = 1, n-1
z(j) = zero
5 continue
z(n) = one
c
nh = ihi - ilo + 1
c
c %-------------------------------------------------------------%
c | Set machine-dependent constants for the stopping criterion. |
c | If norm(H) <= sqrt(OVFL), overflow should not occur. |
c %-------------------------------------------------------------%
c
unfl = slamch( 'safe minimum' )
ovfl = one / unfl
call slabad( unfl, ovfl )
ulp = slamch( 'precision' )
smlnum = unfl*( nh / ulp )
c
c %---------------------------------------------------------------%
c | I1 and I2 are the indices of the first row and last column |
c | of H to which transformations must be applied. If eigenvalues |
c | only are computed, I1 and I2 are set inside the main loop. |
c | Zero out H(J+2,J) = ZERO for J=1:N if WANTT = .TRUE. |
c | else H(J+2,J) for J=ILO:IHI-ILO-1 if WANTT = .FALSE. |
c %---------------------------------------------------------------%
c
if( wantt ) then
i1 = 1
i2 = n
do 8 i=1,i2-2
h(i1+i+1,i) = zero
8 continue
else
do 9 i=1, ihi-ilo-1
h(ilo+i+1,ilo+i-1) = zero
9 continue
end if
c
c %---------------------------------------------------%
c | ITN is the total number of QR iterations allowed. |
c %---------------------------------------------------%
c
itn = 30*nh
c
c ------------------------------------------------------------------
c The main loop begins here. I is the loop index and decreases from
c IHI to ILO in steps of 1 or 2. Each iteration of the loop works
c with the active submatrix in rows and columns L to I.
c Eigenvalues I+1 to IHI have already converged. Either L = ILO or
c H(L,L-1) is negligible so that the matrix splits.
c ------------------------------------------------------------------
c
i = ihi
10 continue
l = ilo
if( i.lt.ilo )
& go to 150
c %--------------------------------------------------------------%
c | Perform QR iterations on rows and columns ILO to I until a |
c | submatrix of order 1 or 2 splits off at the bottom because a |
c | subdiagonal element has become negligible. |
c %--------------------------------------------------------------%
do 130 its = 0, itn
c
c %----------------------------------------------%
c | Look for a single small subdiagonal element. |
c %----------------------------------------------%
c
do 20 k = i, l + 1, -1
tst1 = abs( h( k-1, k-1 ) ) + abs( h( k, k ) )
if( tst1.eq.zero )
& tst1 = slanhs( '1', i-l+1, h( l, l ), ldh, work )
if( abs( h( k, k-1 ) ).le.max( ulp*tst1, smlnum ) )
& go to 30
20 continue
30 continue
l = k
if( l.gt.ilo ) then
c
c %------------------------%
c | H(L,L-1) is negligible |
c %------------------------%
c
h( l, l-1 ) = zero
end if
c
c %-------------------------------------------------------------%
c | Exit from loop if a submatrix of order 1 or 2 has split off |
c %-------------------------------------------------------------%
c
if( l.ge.i-1 )
& go to 140
c
c %---------------------------------------------------------%
c | Now the active submatrix is in rows and columns L to I. |
c | If eigenvalues only are being computed, only the active |
c | submatrix need be transformed. |
c %---------------------------------------------------------%
c
if( .not.wantt ) then
i1 = l
i2 = i
end if
c
if( its.eq.10 .or. its.eq.20 ) then
c
c %-------------------%
c | Exceptional shift |
c %-------------------%
c
s = abs( h( i, i-1 ) ) + abs( h( i-1, i-2 ) )
h44 = dat1*s
h33 = h44
h43h34 = dat2*s*s
c
else
c
c %-----------------------------------------%
c | Prepare to use Wilkinson's double shift |
c %-----------------------------------------%
c
h44 = h( i, i )
h33 = h( i-1, i-1 )
h43h34 = h( i, i-1 )*h( i-1, i )
end if
c
c %-----------------------------------------------------%
c | Look for two consecutive small subdiagonal elements |
c %-----------------------------------------------------%
c
do 40 m = i - 2, l, -1
c
c %---------------------------------------------------------%
c | Determine the effect of starting the double-shift QR |
c | iteration at row M, and see if this would make H(M,M-1) |
c | negligible. |
c %---------------------------------------------------------%
c
h11 = h( m, m )
h22 = h( m+1, m+1 )
h21 = h( m+1, m )
h12 = h( m, m+1 )
h44s = h44 - h11
h33s = h33 - h11
v1 = ( h33s*h44s-h43h34 ) / h21 + h12
v2 = h22 - h11 - h33s - h44s
v3 = h( m+2, m+1 )
s = abs( v1 ) + abs( v2 ) + abs( v3 )
v1 = v1 / s
v2 = v2 / s
v3 = v3 / s
v( 1 ) = v1
v( 2 ) = v2
v( 3 ) = v3
if( m.eq.l )
& go to 50
h00 = h( m-1, m-1 )
h10 = h( m, m-1 )
tst1 = abs( v1 )*( abs( h00 )+abs( h11 )+abs( h22 ) )
if( abs( h10 )*( abs( v2 )+abs( v3 ) ).le.ulp*tst1 )
& go to 50
40 continue
50 continue
c
c %----------------------%
c | Double-shift QR step |
c %----------------------%
c
do 120 k = m, i - 1
c
c ------------------------------------------------------------
c The first iteration of this loop determines a reflection G
c from the vector V and applies it from left and right to H,
c thus creating a nonzero bulge below the subdiagonal.
c
c Each subsequent iteration determines a reflection G to
c restore the Hessenberg form in the (K-1)th column, and thus
c chases the bulge one step toward the bottom of the active
c submatrix. NR is the order of G.
c ------------------------------------------------------------
c
nr = min( 3, i-k+1 )
if( k.gt.m )
& call scopy( nr, h( k, k-1 ), 1, v, 1 )
call slarfg( nr, v( 1 ), v( 2 ), 1, t1 )
if( k.gt.m ) then
h( k, k-1 ) = v( 1 )
h( k+1, k-1 ) = zero
if( k.lt.i-1 )
& h( k+2, k-1 ) = zero
else if( m.gt.l ) then
h( k, k-1 ) = -h( k, k-1 )
end if
v2 = v( 2 )
t2 = t1*v2
if( nr.eq.3 ) then
v3 = v( 3 )
t3 = t1*v3
c
c %------------------------------------------------%
c | Apply G from the left to transform the rows of |
c | the matrix in columns K to I2. |
c %------------------------------------------------%
c
do 60 j = k, i2
sum = h( k, j ) + v2*h( k+1, j ) + v3*h( k+2, j )
h( k, j ) = h( k, j ) - sum*t1
h( k+1, j ) = h( k+1, j ) - sum*t2
h( k+2, j ) = h( k+2, j ) - sum*t3
60 continue
c
c %----------------------------------------------------%
c | Apply G from the right to transform the columns of |
c | the matrix in rows I1 to min(K+3,I). |
c %----------------------------------------------------%
c
do 70 j = i1, min( k+3, i )
sum = h( j, k ) + v2*h( j, k+1 ) + v3*h( j, k+2 )
h( j, k ) = h( j, k ) - sum*t1
h( j, k+1 ) = h( j, k+1 ) - sum*t2
h( j, k+2 ) = h( j, k+2 ) - sum*t3
70 continue
c
c %----------------------------------%
c | Accumulate transformations for Z |
c %----------------------------------%
c
sum = z( k ) + v2*z( k+1 ) + v3*z( k+2 )
z( k ) = z( k ) - sum*t1
z( k+1 ) = z( k+1 ) - sum*t2
z( k+2 ) = z( k+2 ) - sum*t3
else if( nr.eq.2 ) then
c
c %------------------------------------------------%
c | Apply G from the left to transform the rows of |
c | the matrix in columns K to I2. |
c %------------------------------------------------%
c
do 90 j = k, i2
sum = h( k, j ) + v2*h( k+1, j )
h( k, j ) = h( k, j ) - sum*t1
h( k+1, j ) = h( k+1, j ) - sum*t2
90 continue
c
c %----------------------------------------------------%
c | Apply G from the right to transform the columns of |
c | the matrix in rows I1 to min(K+3,I). |
c %----------------------------------------------------%
c
do 100 j = i1, i
sum = h( j, k ) + v2*h( j, k+1 )
h( j, k ) = h( j, k ) - sum*t1
h( j, k+1 ) = h( j, k+1 ) - sum*t2
100 continue
c
c %----------------------------------%
c | Accumulate transformations for Z |
c %----------------------------------%
c
sum = z( k ) + v2*z( k+1 )
z( k ) = z( k ) - sum*t1
z( k+1 ) = z( k+1 ) - sum*t2
end if
120 continue
130 continue
c
c %-------------------------------------------------------%
c | Failure to converge in remaining number of iterations |
c %-------------------------------------------------------%
c
info = i
return
140 continue
if( l.eq.i ) then
c
c %------------------------------------------------------%
c | H(I,I-1) is negligible: one eigenvalue has converged |
c %------------------------------------------------------%
c
wr( i ) = h( i, i )
wi( i ) = zero
else if( l.eq.i-1 ) then
c
c %--------------------------------------------------------%
c | H(I-1,I-2) is negligible; |
c | a pair of eigenvalues have converged. |
c | |
c | Transform the 2-by-2 submatrix to standard Schur form, |
c | and compute and store the eigenvalues. |
c %--------------------------------------------------------%
c
call slanv2( h( i-1, i-1 ), h( i-1, i ), h( i, i-1 ),
& h( i, i ), wr( i-1 ), wi( i-1 ), wr( i ), wi( i ),
& cs, sn )
if( wantt ) then
c
c %-----------------------------------------------------%
c | Apply the transformation to the rest of H and to Z, |
c | as required. |
c %-----------------------------------------------------%
c
if( i2.gt.i )
& call srot( i2-i, h( i-1, i+1 ), ldh, h( i, i+1 ), ldh,
& cs, sn )
call srot( i-i1-1, h( i1, i-1 ), 1, h( i1, i ), 1, cs, sn )
sum = cs*z( i-1 ) + sn*z( i )
z( i ) = cs*z( i ) - sn*z( i-1 )
z( i-1 ) = sum
end if
end if
c
c %---------------------------------------------------------%
c | Decrement number of remaining iterations, and return to |
c | start of the main loop with new value of I. |
c %---------------------------------------------------------%
c
itn = itn - its
i = l - 1
go to 10
150 continue
return
c
c %---------------%
c | End of slaqrb |
c %---------------%
c
end

840
arpack/ARPACK/SRC/snaitr.f Normal file
View File

@@ -0,0 +1,840 @@
c-----------------------------------------------------------------------
c\BeginDoc
c
c\Name: snaitr
c
c\Description:
c Reverse communication interface for applying NP additional steps to
c a K step nonsymmetric Arnoldi factorization.
c
c Input: OP*V_{k} - V_{k}*H = r_{k}*e_{k}^T
c
c with (V_{k}^T)*B*V_{k} = I, (V_{k}^T)*B*r_{k} = 0.
c
c Output: OP*V_{k+p} - V_{k+p}*H = r_{k+p}*e_{k+p}^T
c
c with (V_{k+p}^T)*B*V_{k+p} = I, (V_{k+p}^T)*B*r_{k+p} = 0.
c
c where OP and B are as in snaupd. The B-norm of r_{k+p} is also
c computed and returned.
c
c\Usage:
c call snaitr
c ( IDO, BMAT, N, K, NP, NB, RESID, RNORM, V, LDV, H, LDH,
c IPNTR, WORKD, INFO )
c
c\Arguments
c IDO Integer. (INPUT/OUTPUT)
c Reverse communication flag.
c -------------------------------------------------------------
c IDO = 0: first call to the reverse communication interface
c IDO = -1: compute Y = OP * X where
c IPNTR(1) is the pointer into WORK for X,
c IPNTR(2) is the pointer into WORK for Y.
c This is for the restart phase to force the new
c starting vector into the range of OP.
c IDO = 1: compute Y = OP * X where
c IPNTR(1) is the pointer into WORK for X,
c IPNTR(2) is the pointer into WORK for Y,
c IPNTR(3) is the pointer into WORK for B * X.
c IDO = 2: compute Y = B * X where
c IPNTR(1) is the pointer into WORK for X,
c IPNTR(2) is the pointer into WORK for Y.
c IDO = 99: done
c -------------------------------------------------------------
c When the routine is used in the "shift-and-invert" mode, the
c vector B * Q is already available and do not need to be
c recompute in forming OP * Q.
c
c BMAT Character*1. (INPUT)
c BMAT specifies the type of the matrix B that defines the
c semi-inner product for the operator OP. See snaupd.
c B = 'I' -> standard eigenvalue problem A*x = lambda*x
c B = 'G' -> generalized eigenvalue problem A*x = lambda*M**x
c
c N Integer. (INPUT)
c Dimension of the eigenproblem.
c
c K Integer. (INPUT)
c Current size of V and H.
c
c NP Integer. (INPUT)
c Number of additional Arnoldi steps to take.
c
c NB Integer. (INPUT)
c Blocksize to be used in the recurrence.
c Only work for NB = 1 right now. The goal is to have a
c program that implement both the block and non-block method.
c
c RESID Real array of length N. (INPUT/OUTPUT)
c On INPUT: RESID contains the residual vector r_{k}.
c On OUTPUT: RESID contains the residual vector r_{k+p}.
c
c RNORM Real scalar. (INPUT/OUTPUT)
c B-norm of the starting residual on input.
c B-norm of the updated residual r_{k+p} on output.
c
c V Real N by K+NP array. (INPUT/OUTPUT)
c On INPUT: V contains the Arnoldi vectors in the first K
c columns.
c On OUTPUT: V contains the new NP Arnoldi vectors in the next
c NP columns. The first K columns are unchanged.
c
c LDV Integer. (INPUT)
c Leading dimension of V exactly as declared in the calling
c program.
c
c H Real (K+NP) by (K+NP) array. (INPUT/OUTPUT)
c H is used to store the generated upper Hessenberg matrix.
c
c LDH Integer. (INPUT)
c Leading dimension of H exactly as declared in the calling
c program.
c
c IPNTR Integer array of length 3. (OUTPUT)
c Pointer to mark the starting locations in the WORK for
c vectors used by the Arnoldi iteration.
c -------------------------------------------------------------
c IPNTR(1): pointer to the current operand vector X.
c IPNTR(2): pointer to the current result vector Y.
c IPNTR(3): pointer to the vector B * X when used in the
c shift-and-invert mode. X is the current operand.
c -------------------------------------------------------------
c
c WORKD Real work array of length 3*N. (REVERSE COMMUNICATION)
c Distributed array to be used in the basic Arnoldi iteration
c for reverse communication. The calling program should not
c use WORKD as temporary workspace during the iteration !!!!!!
c On input, WORKD(1:N) = B*RESID and is used to save some
c computation at the first step.
c
c INFO Integer. (OUTPUT)
c = 0: Normal exit.
c > 0: Size of the spanning invariant subspace of OP found.
c
c\EndDoc
c
c-----------------------------------------------------------------------
c
c\BeginLib
c
c\Local variables:
c xxxxxx real
c
c\References:
c 1. D.C. Sorensen, "Implicit Application of Polynomial Filters in
c a k-Step Arnoldi Method", SIAM J. Matr. Anal. Apps., 13 (1992),
c pp 357-385.
c 2. R.B. Lehoucq, "Analysis and Implementation of an Implicitly
c Restarted Arnoldi Iteration", Rice University Technical Report
c TR95-13, Department of Computational and Applied Mathematics.
c
c\Routines called:
c sgetv0 ARPACK routine to generate the initial vector.
c ivout ARPACK utility routine that prints integers.
c second ARPACK utility routine for timing.
c smout ARPACK utility routine that prints matrices
c svout ARPACK utility routine that prints vectors.
c slabad LAPACK routine that computes machine constants.
c slamch LAPACK routine that determines machine constants.
c slascl LAPACK routine for careful scaling of a matrix.
c slanhs LAPACK routine that computes various norms of a matrix.
c sgemv Level 2 BLAS routine for matrix vector multiplication.
c saxpy Level 1 BLAS that computes a vector triad.
c sscal Level 1 BLAS that scales a vector.
c scopy Level 1 BLAS that copies one vector to another .
c sdot Level 1 BLAS that computes the scalar product of two vectors.
c snrm2 Level 1 BLAS that computes the norm of a vector.
c
c\Author
c Danny Sorensen Phuong Vu
c Richard Lehoucq CRPC / Rice University
c Dept. of Computational & Houston, Texas
c Applied Mathematics
c Rice University
c Houston, Texas
c
c\Revision history:
c xx/xx/92: Version ' 2.4'
c
c\SCCS Information: @(#)
c FILE: naitr.F SID: 2.4 DATE OF SID: 8/27/96 RELEASE: 2
c
c\Remarks
c The algorithm implemented is:
c
c restart = .false.
c Given V_{k} = [v_{1}, ..., v_{k}], r_{k};
c r_{k} contains the initial residual vector even for k = 0;
c Also assume that rnorm = || B*r_{k} || and B*r_{k} are already
c computed by the calling program.
c
c betaj = rnorm ; p_{k+1} = B*r_{k} ;
c For j = k+1, ..., k+np Do
c 1) if ( betaj < tol ) stop or restart depending on j.
c ( At present tol is zero )
c if ( restart ) generate a new starting vector.
c 2) v_{j} = r(j-1)/betaj; V_{j} = [V_{j-1}, v_{j}];
c p_{j} = p_{j}/betaj
c 3) r_{j} = OP*v_{j} where OP is defined as in snaupd
c For shift-invert mode p_{j} = B*v_{j} is already available.
c wnorm = || OP*v_{j} ||
c 4) Compute the j-th step residual vector.
c w_{j} = V_{j}^T * B * OP * v_{j}
c r_{j} = OP*v_{j} - V_{j} * w_{j}
c H(:,j) = w_{j};
c H(j,j-1) = rnorm
c rnorm = || r_(j) ||
c If (rnorm > 0.717*wnorm) accept step and go back to 1)
c 5) Re-orthogonalization step:
c s = V_{j}'*B*r_{j}
c r_{j} = r_{j} - V_{j}*s; rnorm1 = || r_{j} ||
c alphaj = alphaj + s_{j};
c 6) Iterative refinement step:
c If (rnorm1 > 0.717*rnorm) then
c rnorm = rnorm1
c accept step and go back to 1)
c Else
c rnorm = rnorm1
c If this is the first time in step 6), go to 5)
c Else r_{j} lies in the span of V_{j} numerically.
c Set r_{j} = 0 and rnorm = 0; go to 1)
c EndIf
c End Do
c
c\EndLib
c
c-----------------------------------------------------------------------
c
subroutine snaitr
& (ido, bmat, n, k, np, nb, resid, rnorm, v, ldv, h, ldh,
& ipntr, workd, info)
c
c %----------------------------------------------------%
c | Include files for debugging and timing information |
c %----------------------------------------------------%
c
include 'debug.h'
include 'stat.h'
c
c %------------------%
c | Scalar Arguments |
c %------------------%
c
character bmat*1
integer ido, info, k, ldh, ldv, n, nb, np
Real
& rnorm
c
c %-----------------%
c | Array Arguments |
c %-----------------%
c
integer ipntr(3)
Real
& h(ldh,k+np), resid(n), v(ldv,k+np), workd(3*n)
c
c %------------%
c | Parameters |
c %------------%
c
Real
& one, zero
parameter (one = 1.0E+0, zero = 0.0E+0)
c
c %---------------%
c | Local Scalars |
c %---------------%
c
logical first, orth1, orth2, rstart, step3, step4
integer ierr, i, infol, ipj, irj, ivj, iter, itry, j, msglvl,
& jj
Real
& betaj, ovfl, temp1, rnorm1, smlnum, tst1, ulp, unfl,
& wnorm
save first, orth1, orth2, rstart, step3, step4,
& ierr, ipj, irj, ivj, iter, itry, j, msglvl, ovfl,
& betaj, rnorm1, smlnum, ulp, unfl, wnorm
c
c %-----------------------%
c | Local Array Arguments |
c %-----------------------%
c
Real
& xtemp(2)
c
c %----------------------%
c | External Subroutines |
c %----------------------%
c
external saxpy, scopy, sscal, sgemv, sgetv0, slabad,
& svout, smout, ivout, second
c
c %--------------------%
c | External Functions |
c %--------------------%
c
Real
& sdot, snrm2, slanhs, slamch
external sdot, snrm2, slanhs, slamch
c
c %---------------------%
c | Intrinsic Functions |
c %---------------------%
c
intrinsic abs, sqrt
c
c %-----------------%
c | Data statements |
c %-----------------%
c
data first / .true. /
c
c %-----------------------%
c | Executable Statements |
c %-----------------------%
c
if (first) then
c
c %-----------------------------------------%
c | Set machine-dependent constants for the |
c | the splitting and deflation criterion. |
c | If norm(H) <= sqrt(OVFL), |
c | overflow should not occur. |
c | REFERENCE: LAPACK subroutine slahqr |
c %-----------------------------------------%
c
unfl = slamch( 'safe minimum' )
ovfl = one / unfl
call slabad( unfl, ovfl )
ulp = slamch( 'precision' )
smlnum = unfl*( n / ulp )
first = .false.
end if
c
if (ido .eq. 0) then
c
c %-------------------------------%
c | Initialize timing statistics |
c | & message level for debugging |
c %-------------------------------%
c
call second (t0)
msglvl = mnaitr
c
c %------------------------------%
c | Initial call to this routine |
c %------------------------------%
c
info = 0
step3 = .false.
step4 = .false.
rstart = .false.
orth1 = .false.
orth2 = .false.
j = k + 1
ipj = 1
irj = ipj + n
ivj = irj + n
end if
c
c %-------------------------------------------------%
c | When in reverse communication mode one of: |
c | STEP3, STEP4, ORTH1, ORTH2, RSTART |
c | will be .true. when .... |
c | STEP3: return from computing OP*v_{j}. |
c | STEP4: return from computing B-norm of OP*v_{j} |
c | ORTH1: return from computing B-norm of r_{j+1} |
c | ORTH2: return from computing B-norm of |
c | correction to the residual vector. |
c | RSTART: return from OP computations needed by |
c | sgetv0. |
c %-------------------------------------------------%
c
if (step3) go to 50
if (step4) go to 60
if (orth1) go to 70
if (orth2) go to 90
if (rstart) go to 30
c
c %-----------------------------%
c | Else this is the first step |
c %-----------------------------%
c
c %--------------------------------------------------------------%
c | |
c | A R N O L D I I T E R A T I O N L O O P |
c | |
c | Note: B*r_{j-1} is already in WORKD(1:N)=WORKD(IPJ:IPJ+N-1) |
c %--------------------------------------------------------------%
1000 continue
c
if (msglvl .gt. 1) then
call ivout (logfil, 1, j, ndigit,
& '_naitr: generating Arnoldi vector number')
call svout (logfil, 1, rnorm, ndigit,
& '_naitr: B-norm of the current residual is')
end if
c
c %---------------------------------------------------%
c | STEP 1: Check if the B norm of j-th residual |
c | vector is zero. Equivalent to determing whether |
c | an exact j-step Arnoldi factorization is present. |
c %---------------------------------------------------%
c
betaj = rnorm
if (rnorm .gt. zero) go to 40
c
c %---------------------------------------------------%
c | Invariant subspace found, generate a new starting |
c | vector which is orthogonal to the current Arnoldi |
c | basis and continue the iteration. |
c %---------------------------------------------------%
c
if (msglvl .gt. 0) then
call ivout (logfil, 1, j, ndigit,
& '_naitr: ****** RESTART AT STEP ******')
end if
c
c %---------------------------------------------%
c | ITRY is the loop variable that controls the |
c | maximum amount of times that a restart is |
c | attempted. NRSTRT is used by stat.h |
c %---------------------------------------------%
c
betaj = zero
nrstrt = nrstrt + 1
itry = 1
20 continue
rstart = .true.
ido = 0
30 continue
c
c %--------------------------------------%
c | If in reverse communication mode and |
c | RSTART = .true. flow returns here. |
c %--------------------------------------%
c
call sgetv0 (ido, bmat, itry, .false., n, j, v, ldv,
& resid, rnorm, ipntr, workd, ierr)
if (ido .ne. 99) go to 9000
if (ierr .lt. 0) then
itry = itry + 1
if (itry .le. 3) go to 20
c
c %------------------------------------------------%
c | Give up after several restart attempts. |
c | Set INFO to the size of the invariant subspace |
c | which spans OP and exit. |
c %------------------------------------------------%
c
info = j - 1
call second (t1)
tnaitr = tnaitr + (t1 - t0)
ido = 99
go to 9000
end if
c
40 continue
c
c %---------------------------------------------------------%
c | STEP 2: v_{j} = r_{j-1}/rnorm and p_{j} = p_{j}/rnorm |
c | Note that p_{j} = B*r_{j-1}. In order to avoid overflow |
c | when reciprocating a small RNORM, test against lower |
c | machine bound. |
c %---------------------------------------------------------%
c
call scopy (n, resid, 1, v(1,j), 1)
if (rnorm .ge. unfl) then
temp1 = one / rnorm
call sscal (n, temp1, v(1,j), 1)
call sscal (n, temp1, workd(ipj), 1)
else
c
c %-----------------------------------------%
c | To scale both v_{j} and p_{j} carefully |
c | use LAPACK routine SLASCL |
c %-----------------------------------------%
c
call slascl ('General', i, i, rnorm, one, n, 1,
& v(1,j), n, infol)
call slascl ('General', i, i, rnorm, one, n, 1,
& workd(ipj), n, infol)
end if
c
c %------------------------------------------------------%
c | STEP 3: r_{j} = OP*v_{j}; Note that p_{j} = B*v_{j} |
c | Note that this is not quite yet r_{j}. See STEP 4 |
c %------------------------------------------------------%
c
step3 = .true.
nopx = nopx + 1
call second (t2)
call scopy (n, v(1,j), 1, workd(ivj), 1)
ipntr(1) = ivj
ipntr(2) = irj
ipntr(3) = ipj
ido = 1
c
c %-----------------------------------%
c | Exit in order to compute OP*v_{j} |
c %-----------------------------------%
c
go to 9000
50 continue
c
c %----------------------------------%
c | Back from reverse communication; |
c | WORKD(IRJ:IRJ+N-1) := OP*v_{j} |
c | if step3 = .true. |
c %----------------------------------%
c
call second (t3)
tmvopx = tmvopx + (t3 - t2)
step3 = .false.
c
c %------------------------------------------%
c | Put another copy of OP*v_{j} into RESID. |
c %------------------------------------------%
c
call scopy (n, workd(irj), 1, resid, 1)
c
c %---------------------------------------%
c | STEP 4: Finish extending the Arnoldi |
c | factorization to length j. |
c %---------------------------------------%
c
call second (t2)
if (bmat .eq. 'G') then
nbx = nbx + 1
step4 = .true.
ipntr(1) = irj
ipntr(2) = ipj
ido = 2
c
c %-------------------------------------%
c | Exit in order to compute B*OP*v_{j} |
c %-------------------------------------%
c
go to 9000
else if (bmat .eq. 'I') then
call scopy (n, resid, 1, workd(ipj), 1)
end if
60 continue
c
c %----------------------------------%
c | Back from reverse communication; |
c | WORKD(IPJ:IPJ+N-1) := B*OP*v_{j} |
c | if step4 = .true. |
c %----------------------------------%
c
if (bmat .eq. 'G') then
call second (t3)
tmvbx = tmvbx + (t3 - t2)
end if
c
step4 = .false.
c
c %-------------------------------------%
c | The following is needed for STEP 5. |
c | Compute the B-norm of OP*v_{j}. |
c %-------------------------------------%
c
if (bmat .eq. 'G') then
wnorm = sdot (n, resid, 1, workd(ipj), 1)
wnorm = sqrt(abs(wnorm))
else if (bmat .eq. 'I') then
wnorm = snrm2(n, resid, 1)
end if
c
c %-----------------------------------------%
c | Compute the j-th residual corresponding |
c | to the j step factorization. |
c | Use Classical Gram Schmidt and compute: |
c | w_{j} <- V_{j}^T * B * OP * v_{j} |
c | r_{j} <- OP*v_{j} - V_{j} * w_{j} |
c %-----------------------------------------%
c
c
c %------------------------------------------%
c | Compute the j Fourier coefficients w_{j} |
c | WORKD(IPJ:IPJ+N-1) contains B*OP*v_{j}. |
c %------------------------------------------%
c
call sgemv ('T', n, j, one, v, ldv, workd(ipj), 1,
& zero, h(1,j), 1)
c
c %--------------------------------------%
c | Orthogonalize r_{j} against V_{j}. |
c | RESID contains OP*v_{j}. See STEP 3. |
c %--------------------------------------%
c
call sgemv ('N', n, j, -one, v, ldv, h(1,j), 1,
& one, resid, 1)
c
if (j .gt. 1) h(j,j-1) = betaj
c
call second (t4)
c
orth1 = .true.
c
call second (t2)
if (bmat .eq. 'G') then
nbx = nbx + 1
call scopy (n, resid, 1, workd(irj), 1)
ipntr(1) = irj
ipntr(2) = ipj
ido = 2
c
c %----------------------------------%
c | Exit in order to compute B*r_{j} |
c %----------------------------------%
c
go to 9000
else if (bmat .eq. 'I') then
call scopy (n, resid, 1, workd(ipj), 1)
end if
70 continue
c
c %---------------------------------------------------%
c | Back from reverse communication if ORTH1 = .true. |
c | WORKD(IPJ:IPJ+N-1) := B*r_{j}. |
c %---------------------------------------------------%
c
if (bmat .eq. 'G') then
call second (t3)
tmvbx = tmvbx + (t3 - t2)
end if
c
orth1 = .false.
c
c %------------------------------%
c | Compute the B-norm of r_{j}. |
c %------------------------------%
c
if (bmat .eq. 'G') then
rnorm = sdot (n, resid, 1, workd(ipj), 1)
rnorm = sqrt(abs(rnorm))
else if (bmat .eq. 'I') then
rnorm = snrm2(n, resid, 1)
end if
c
c %-----------------------------------------------------------%
c | STEP 5: Re-orthogonalization / Iterative refinement phase |
c | Maximum NITER_ITREF tries. |
c | |
c | s = V_{j}^T * B * r_{j} |
c | r_{j} = r_{j} - V_{j}*s |
c | alphaj = alphaj + s_{j} |
c | |
c | The stopping criteria used for iterative refinement is |
c | discussed in Parlett's book SEP, page 107 and in Gragg & |
c | Reichel ACM TOMS paper; Algorithm 686, Dec. 1990. |
c | Determine if we need to correct the residual. The goal is |
c | to enforce ||v(:,1:j)^T * r_{j}|| .le. eps * || r_{j} || |
c | The following test determines whether the sine of the |
c | angle between OP*x and the computed residual is less |
c | than or equal to 0.717. |
c %-----------------------------------------------------------%
c
if (rnorm .gt. 0.717*wnorm) go to 100
iter = 0
nrorth = nrorth + 1
c
c %---------------------------------------------------%
c | Enter the Iterative refinement phase. If further |
c | refinement is necessary, loop back here. The loop |
c | variable is ITER. Perform a step of Classical |
c | Gram-Schmidt using all the Arnoldi vectors V_{j} |
c %---------------------------------------------------%
c
80 continue
c
if (msglvl .gt. 2) then
xtemp(1) = wnorm
xtemp(2) = rnorm
call svout (logfil, 2, xtemp, ndigit,
& '_naitr: re-orthonalization; wnorm and rnorm are')
call svout (logfil, j, h(1,j), ndigit,
& '_naitr: j-th column of H')
end if
c
c %----------------------------------------------------%
c | Compute V_{j}^T * B * r_{j}. |
c | WORKD(IRJ:IRJ+J-1) = v(:,1:J)'*WORKD(IPJ:IPJ+N-1). |
c %----------------------------------------------------%
c
call sgemv ('T', n, j, one, v, ldv, workd(ipj), 1,
& zero, workd(irj), 1)
c
c %---------------------------------------------%
c | Compute the correction to the residual: |
c | r_{j} = r_{j} - V_{j} * WORKD(IRJ:IRJ+J-1). |
c | The correction to H is v(:,1:J)*H(1:J,1:J) |
c | + v(:,1:J)*WORKD(IRJ:IRJ+J-1)*e'_j. |
c %---------------------------------------------%
c
call sgemv ('N', n, j, -one, v, ldv, workd(irj), 1,
& one, resid, 1)
call saxpy (j, one, workd(irj), 1, h(1,j), 1)
c
orth2 = .true.
call second (t2)
if (bmat .eq. 'G') then
nbx = nbx + 1
call scopy (n, resid, 1, workd(irj), 1)
ipntr(1) = irj
ipntr(2) = ipj
ido = 2
c
c %-----------------------------------%
c | Exit in order to compute B*r_{j}. |
c | r_{j} is the corrected residual. |
c %-----------------------------------%
c
go to 9000
else if (bmat .eq. 'I') then
call scopy (n, resid, 1, workd(ipj), 1)
end if
90 continue
c
c %---------------------------------------------------%
c | Back from reverse communication if ORTH2 = .true. |
c %---------------------------------------------------%
c
if (bmat .eq. 'G') then
call second (t3)
tmvbx = tmvbx + (t3 - t2)
end if
c
c %-----------------------------------------------------%
c | Compute the B-norm of the corrected residual r_{j}. |
c %-----------------------------------------------------%
c
if (bmat .eq. 'G') then
rnorm1 = sdot (n, resid, 1, workd(ipj), 1)
rnorm1 = sqrt(abs(rnorm1))
else if (bmat .eq. 'I') then
rnorm1 = snrm2(n, resid, 1)
end if
c
if (msglvl .gt. 0 .and. iter .gt. 0) then
call ivout (logfil, 1, j, ndigit,
& '_naitr: Iterative refinement for Arnoldi residual')
if (msglvl .gt. 2) then
xtemp(1) = rnorm
xtemp(2) = rnorm1
call svout (logfil, 2, xtemp, ndigit,
& '_naitr: iterative refinement ; rnorm and rnorm1 are')
end if
end if
c
c %-----------------------------------------%
c | Determine if we need to perform another |
c | step of re-orthogonalization. |
c %-----------------------------------------%
c
if (rnorm1 .gt. 0.717*rnorm) then
c
c %---------------------------------------%
c | No need for further refinement. |
c | The cosine of the angle between the |
c | corrected residual vector and the old |
c | residual vector is greater than 0.717 |
c | In other words the corrected residual |
c | and the old residual vector share an |
c | angle of less than arcCOS(0.717) |
c %---------------------------------------%
c
rnorm = rnorm1
c
else
c
c %-------------------------------------------%
c | Another step of iterative refinement step |
c | is required. NITREF is used by stat.h |
c %-------------------------------------------%
c
nitref = nitref + 1
rnorm = rnorm1
iter = iter + 1
if (iter .le. 1) go to 80
c
c %-------------------------------------------------%
c | Otherwise RESID is numerically in the span of V |
c %-------------------------------------------------%
c
do 95 jj = 1, n
resid(jj) = zero
95 continue
rnorm = zero
end if
c
c %----------------------------------------------%
c | Branch here directly if iterative refinement |
c | wasn't necessary or after at most NITER_REF |
c | steps of iterative refinement. |
c %----------------------------------------------%
c
100 continue
c
rstart = .false.
orth2 = .false.
c
call second (t5)
titref = titref + (t5 - t4)
c
c %------------------------------------%
c | STEP 6: Update j = j+1; Continue |
c %------------------------------------%
c
j = j + 1
if (j .gt. k+np) then
call second (t1)
tnaitr = tnaitr + (t1 - t0)
ido = 99
do 110 i = max(1,k), k+np-1
c
c %--------------------------------------------%
c | Check for splitting and deflation. |
c | Use a standard test as in the QR algorithm |
c | REFERENCE: LAPACK subroutine slahqr |
c %--------------------------------------------%
c
tst1 = abs( h( i, i ) ) + abs( h( i+1, i+1 ) )
if( tst1.eq.zero )
& tst1 = slanhs( '1', k+np, h, ldh, workd(n+1) )
if( abs( h( i+1,i ) ).le.max( ulp*tst1, smlnum ) )
& h(i+1,i) = zero
110 continue
c
if (msglvl .gt. 2) then
call smout (logfil, k+np, k+np, h, ldh, ndigit,
& '_naitr: Final upper Hessenberg matrix H of order K+NP')
end if
c
go to 9000
end if
c
c %--------------------------------------------------------%
c | Loop back to extend the factorization by another step. |
c %--------------------------------------------------------%
c
go to 1000
c
c %---------------------------------------------------------------%
c | |
c | E N D O F M A I N I T E R A T I O N L O O P |
c | |
c %---------------------------------------------------------------%
c
9000 continue
return
c
c %---------------%
c | End of snaitr |
c %---------------%
c
end

647
arpack/ARPACK/SRC/snapps.f Normal file
View File

@@ -0,0 +1,647 @@
c-----------------------------------------------------------------------
c\BeginDoc
c
c\Name: snapps
c
c\Description:
c Given the Arnoldi factorization
c
c A*V_{k} - V_{k}*H_{k} = r_{k+p}*e_{k+p}^T,
c
c apply NP implicit shifts resulting in
c
c A*(V_{k}*Q) - (V_{k}*Q)*(Q^T* H_{k}*Q) = r_{k+p}*e_{k+p}^T * Q
c
c where Q is an orthogonal matrix which is the product of rotations
c and reflections resulting from the NP bulge chage sweeps.
c The updated Arnoldi factorization becomes:
c
c A*VNEW_{k} - VNEW_{k}*HNEW_{k} = rnew_{k}*e_{k}^T.
c
c\Usage:
c call snapps
c ( N, KEV, NP, SHIFTR, SHIFTI, V, LDV, H, LDH, RESID, Q, LDQ,
c WORKL, WORKD )
c
c\Arguments
c N Integer. (INPUT)
c Problem size, i.e. size of matrix A.
c
c KEV Integer. (INPUT/OUTPUT)
c KEV+NP is the size of the input matrix H.
c KEV is the size of the updated matrix HNEW. KEV is only
c updated on ouput when fewer than NP shifts are applied in
c order to keep the conjugate pair together.
c
c NP Integer. (INPUT)
c Number of implicit shifts to be applied.
c
c SHIFTR, Real array of length NP. (INPUT)
c SHIFTI Real and imaginary part of the shifts to be applied.
c Upon, entry to snapps, the shifts must be sorted so that the
c conjugate pairs are in consecutive locations.
c
c V Real N by (KEV+NP) array. (INPUT/OUTPUT)
c On INPUT, V contains the current KEV+NP Arnoldi vectors.
c On OUTPUT, V contains the updated KEV Arnoldi vectors
c in the first KEV columns of V.
c
c LDV Integer. (INPUT)
c Leading dimension of V exactly as declared in the calling
c program.
c
c H Real (KEV+NP) by (KEV+NP) array. (INPUT/OUTPUT)
c On INPUT, H contains the current KEV+NP by KEV+NP upper
c Hessenber matrix of the Arnoldi factorization.
c On OUTPUT, H contains the updated KEV by KEV upper Hessenberg
c matrix in the KEV leading submatrix.
c
c LDH Integer. (INPUT)
c Leading dimension of H exactly as declared in the calling
c program.
c
c RESID Real array of length N. (INPUT/OUTPUT)
c On INPUT, RESID contains the the residual vector r_{k+p}.
c On OUTPUT, RESID is the update residual vector rnew_{k}
c in the first KEV locations.
c
c Q Real KEV+NP by KEV+NP work array. (WORKSPACE)
c Work array used to accumulate the rotations and reflections
c during the bulge chase sweep.
c
c LDQ Integer. (INPUT)
c Leading dimension of Q exactly as declared in the calling
c program.
c
c WORKL Real work array of length (KEV+NP). (WORKSPACE)
c Private (replicated) array on each PE or array allocated on
c the front end.
c
c WORKD Real work array of length 2*N. (WORKSPACE)
c Distributed array used in the application of the accumulated
c orthogonal matrix Q.
c
c\EndDoc
c
c-----------------------------------------------------------------------
c
c\BeginLib
c
c\Local variables:
c xxxxxx real
c
c\References:
c 1. D.C. Sorensen, "Implicit Application of Polynomial Filters in
c a k-Step Arnoldi Method", SIAM J. Matr. Anal. Apps., 13 (1992),
c pp 357-385.
c
c\Routines called:
c ivout ARPACK utility routine that prints integers.
c second ARPACK utility routine for timing.
c smout ARPACK utility routine that prints matrices.
c svout ARPACK utility routine that prints vectors.
c slabad LAPACK routine that computes machine constants.
c slacpy LAPACK matrix copy routine.
c slamch LAPACK routine that determines machine constants.
c slanhs LAPACK routine that computes various norms of a matrix.
c slapy2 LAPACK routine to compute sqrt(x**2+y**2) carefully.
c slarf LAPACK routine that applies Householder reflection to
c a matrix.
c slarfg LAPACK Householder reflection construction routine.
c slartg LAPACK Givens rotation construction routine.
c slaset LAPACK matrix initialization routine.
c sgemv Level 2 BLAS routine for matrix vector multiplication.
c saxpy Level 1 BLAS that computes a vector triad.
c scopy Level 1 BLAS that copies one vector to another .
c sscal Level 1 BLAS that scales a vector.
c
c\Author
c Danny Sorensen Phuong Vu
c Richard Lehoucq CRPC / Rice University
c Dept. of Computational & Houston, Texas
c Applied Mathematics
c Rice University
c Houston, Texas
c
c\Revision history:
c xx/xx/92: Version ' 2.4'
c
c\SCCS Information: @(#)
c FILE: napps.F SID: 2.4 DATE OF SID: 3/28/97 RELEASE: 2
c
c\Remarks
c 1. In this version, each shift is applied to all the sublocks of
c the Hessenberg matrix H and not just to the submatrix that it
c comes from. Deflation as in LAPACK routine slahqr (QR algorithm
c for upper Hessenberg matrices ) is used.
c The subdiagonals of H are enforced to be non-negative.
c
c\EndLib
c
c-----------------------------------------------------------------------
c
subroutine snapps
& ( n, kev, np, shiftr, shifti, v, ldv, h, ldh, resid, q, ldq,
& workl, workd )
c
c %----------------------------------------------------%
c | Include files for debugging and timing information |
c %----------------------------------------------------%
c
include 'debug.h'
include 'stat.h'
c
c %------------------%
c | Scalar Arguments |
c %------------------%
c
integer kev, ldh, ldq, ldv, n, np
c
c %-----------------%
c | Array Arguments |
c %-----------------%
c
Real
& h(ldh,kev+np), resid(n), shifti(np), shiftr(np),
& v(ldv,kev+np), q(ldq,kev+np), workd(2*n), workl(kev+np)
c
c %------------%
c | Parameters |
c %------------%
c
Real
& one, zero
parameter (one = 1.0E+0, zero = 0.0E+0)
c
c %------------------------%
c | Local Scalars & Arrays |
c %------------------------%
c
integer i, iend, ir, istart, j, jj, kplusp, msglvl, nr
logical cconj, first
Real
& c, f, g, h11, h12, h21, h22, h32, ovfl, r, s, sigmai,
& sigmar, smlnum, ulp, unfl, u(3), t, tau, tst1
save first, ovfl, smlnum, ulp, unfl
c
c %----------------------%
c | External Subroutines |
c %----------------------%
c
external saxpy, scopy, sscal, slacpy, slarfg, slarf,
& slaset, slabad, second, slartg
c
c %--------------------%
c | External Functions |
c %--------------------%
c
Real
& slamch, slanhs, slapy2
external slamch, slanhs, slapy2
c
c %----------------------%
c | Intrinsics Functions |
c %----------------------%
c
intrinsic abs, max, min
c
c %----------------%
c | Data statments |
c %----------------%
c
data first / .true. /
c
c %-----------------------%
c | Executable Statements |
c %-----------------------%
c
if (first) then
c
c %-----------------------------------------------%
c | Set machine-dependent constants for the |
c | stopping criterion. If norm(H) <= sqrt(OVFL), |
c | overflow should not occur. |
c | REFERENCE: LAPACK subroutine slahqr |
c %-----------------------------------------------%
c
unfl = slamch( 'safe minimum' )
ovfl = one / unfl
call slabad( unfl, ovfl )
ulp = slamch( 'precision' )
smlnum = unfl*( n / ulp )
first = .false.
end if
c
c %-------------------------------%
c | Initialize timing statistics |
c | & message level for debugging |
c %-------------------------------%
c
call second (t0)
msglvl = mnapps
kplusp = kev + np
c
c %--------------------------------------------%
c | Initialize Q to the identity to accumulate |
c | the rotations and reflections |
c %--------------------------------------------%
c
call slaset ('All', kplusp, kplusp, zero, one, q, ldq)
c
c %----------------------------------------------%
c | Quick return if there are no shifts to apply |
c %----------------------------------------------%
c
if (np .eq. 0) go to 9000
c
c %----------------------------------------------%
c | Chase the bulge with the application of each |
c | implicit shift. Each shift is applied to the |
c | whole matrix including each block. |
c %----------------------------------------------%
c
cconj = .false.
do 110 jj = 1, np
sigmar = shiftr(jj)
sigmai = shifti(jj)
c
if (msglvl .gt. 2 ) then
call ivout (logfil, 1, jj, ndigit,
& '_napps: shift number.')
call svout (logfil, 1, sigmar, ndigit,
& '_napps: The real part of the shift ')
call svout (logfil, 1, sigmai, ndigit,
& '_napps: The imaginary part of the shift ')
end if
c
c %-------------------------------------------------%
c | The following set of conditionals is necessary |
c | in order that complex conjugate pairs of shifts |
c | are applied together or not at all. |
c %-------------------------------------------------%
c
if ( cconj ) then
c
c %-----------------------------------------%
c | cconj = .true. means the previous shift |
c | had non-zero imaginary part. |
c %-----------------------------------------%
c
cconj = .false.
go to 110
else if ( jj .lt. np .and. abs( sigmai ) .gt. zero ) then
c
c %------------------------------------%
c | Start of a complex conjugate pair. |
c %------------------------------------%
c
cconj = .true.
else if ( jj .eq. np .and. abs( sigmai ) .gt. zero ) then
c
c %----------------------------------------------%
c | The last shift has a nonzero imaginary part. |
c | Don't apply it; thus the order of the |
c | compressed H is order KEV+1 since only np-1 |
c | were applied. |
c %----------------------------------------------%
c
kev = kev + 1
go to 110
end if
istart = 1
20 continue
c
c %--------------------------------------------------%
c | if sigmai = 0 then |
c | Apply the jj-th shift ... |
c | else |
c | Apply the jj-th and (jj+1)-th together ... |
c | (Note that jj < np at this point in the code) |
c | end |
c | to the current block of H. The next do loop |
c | determines the current block ; |
c %--------------------------------------------------%
c
do 30 i = istart, kplusp-1
c
c %----------------------------------------%
c | Check for splitting and deflation. Use |
c | a standard test as in the QR algorithm |
c | REFERENCE: LAPACK subroutine slahqr |
c %----------------------------------------%
c
tst1 = abs( h( i, i ) ) + abs( h( i+1, i+1 ) )
if( tst1.eq.zero )
& tst1 = slanhs( '1', kplusp-jj+1, h, ldh, workl )
if( abs( h( i+1,i ) ).le.max( ulp*tst1, smlnum ) ) then
if (msglvl .gt. 0) then
call ivout (logfil, 1, i, ndigit,
& '_napps: matrix splitting at row/column no.')
call ivout (logfil, 1, jj, ndigit,
& '_napps: matrix splitting with shift number.')
call svout (logfil, 1, h(i+1,i), ndigit,
& '_napps: off diagonal element.')
end if
iend = i
h(i+1,i) = zero
go to 40
end if
30 continue
iend = kplusp
40 continue
c
if (msglvl .gt. 2) then
call ivout (logfil, 1, istart, ndigit,
& '_napps: Start of current block ')
call ivout (logfil, 1, iend, ndigit,
& '_napps: End of current block ')
end if
c
c %------------------------------------------------%
c | No reason to apply a shift to block of order 1 |
c %------------------------------------------------%
c
if ( istart .eq. iend ) go to 100
c
c %------------------------------------------------------%
c | If istart + 1 = iend then no reason to apply a |
c | complex conjugate pair of shifts on a 2 by 2 matrix. |
c %------------------------------------------------------%
c
if ( istart + 1 .eq. iend .and. abs( sigmai ) .gt. zero )
& go to 100
c
h11 = h(istart,istart)
h21 = h(istart+1,istart)
if ( abs( sigmai ) .le. zero ) then
c
c %---------------------------------------------%
c | Real-valued shift ==> apply single shift QR |
c %---------------------------------------------%
c
f = h11 - sigmar
g = h21
c
do 80 i = istart, iend-1
c
c %-----------------------------------------------------%
c | Contruct the plane rotation G to zero out the bulge |
c %-----------------------------------------------------%
c
call slartg (f, g, c, s, r)
if (i .gt. istart) then
c
c %-------------------------------------------%
c | The following ensures that h(1:iend-1,1), |
c | the first iend-2 off diagonal of elements |
c | H, remain non negative. |
c %-------------------------------------------%
c
if (r .lt. zero) then
r = -r
c = -c
s = -s
end if
h(i,i-1) = r
h(i+1,i-1) = zero
end if
c
c %---------------------------------------------%
c | Apply rotation to the left of H; H <- G'*H |
c %---------------------------------------------%
c
do 50 j = i, kplusp
t = c*h(i,j) + s*h(i+1,j)
h(i+1,j) = -s*h(i,j) + c*h(i+1,j)
h(i,j) = t
50 continue
c
c %---------------------------------------------%
c | Apply rotation to the right of H; H <- H*G |
c %---------------------------------------------%
c
do 60 j = 1, min(i+2,iend)
t = c*h(j,i) + s*h(j,i+1)
h(j,i+1) = -s*h(j,i) + c*h(j,i+1)
h(j,i) = t
60 continue
c
c %----------------------------------------------------%
c | Accumulate the rotation in the matrix Q; Q <- Q*G |
c %----------------------------------------------------%
c
do 70 j = 1, min( i+jj, kplusp )
t = c*q(j,i) + s*q(j,i+1)
q(j,i+1) = - s*q(j,i) + c*q(j,i+1)
q(j,i) = t
70 continue
c
c %---------------------------%
c | Prepare for next rotation |
c %---------------------------%
c
if (i .lt. iend-1) then
f = h(i+1,i)
g = h(i+2,i)
end if
80 continue
c
c %-----------------------------------%
c | Finished applying the real shift. |
c %-----------------------------------%
c
else
c
c %----------------------------------------------------%
c | Complex conjugate shifts ==> apply double shift QR |
c %----------------------------------------------------%
c
h12 = h(istart,istart+1)
h22 = h(istart+1,istart+1)
h32 = h(istart+2,istart+1)
c
c %---------------------------------------------------------%
c | Compute 1st column of (H - shift*I)*(H - conj(shift)*I) |
c %---------------------------------------------------------%
c
s = 2.0*sigmar
t = slapy2 ( sigmar, sigmai )
u(1) = ( h11 * (h11 - s) + t * t ) / h21 + h12
u(2) = h11 + h22 - s
u(3) = h32
c
do 90 i = istart, iend-1
c
nr = min ( 3, iend-i+1 )
c
c %-----------------------------------------------------%
c | Construct Householder reflector G to zero out u(1). |
c | G is of the form I - tau*( 1 u )' * ( 1 u' ). |
c %-----------------------------------------------------%
c
call slarfg ( nr, u(1), u(2), 1, tau )
c
if (i .gt. istart) then
h(i,i-1) = u(1)
h(i+1,i-1) = zero
if (i .lt. iend-1) h(i+2,i-1) = zero
end if
u(1) = one
c
c %--------------------------------------%
c | Apply the reflector to the left of H |
c %--------------------------------------%
c
call slarf ('Left', nr, kplusp-i+1, u, 1, tau,
& h(i,i), ldh, workl)
c
c %---------------------------------------%
c | Apply the reflector to the right of H |
c %---------------------------------------%
c
ir = min ( i+3, iend )
call slarf ('Right', ir, nr, u, 1, tau,
& h(1,i), ldh, workl)
c
c %-----------------------------------------------------%
c | Accumulate the reflector in the matrix Q; Q <- Q*G |
c %-----------------------------------------------------%
c
call slarf ('Right', kplusp, nr, u, 1, tau,
& q(1,i), ldq, workl)
c
c %----------------------------%
c | Prepare for next reflector |
c %----------------------------%
c
if (i .lt. iend-1) then
u(1) = h(i+1,i)
u(2) = h(i+2,i)
if (i .lt. iend-2) u(3) = h(i+3,i)
end if
c
90 continue
c
c %--------------------------------------------%
c | Finished applying a complex pair of shifts |
c | to the current block |
c %--------------------------------------------%
c
end if
c
100 continue
c
c %---------------------------------------------------------%
c | Apply the same shift to the next block if there is any. |
c %---------------------------------------------------------%
c
istart = iend + 1
if (iend .lt. kplusp) go to 20
c
c %---------------------------------------------%
c | Loop back to the top to get the next shift. |
c %---------------------------------------------%
c
110 continue
c
c %--------------------------------------------------%
c | Perform a similarity transformation that makes |
c | sure that H will have non negative sub diagonals |
c %--------------------------------------------------%
c
do 120 j=1,kev
if ( h(j+1,j) .lt. zero ) then
call sscal( kplusp-j+1, -one, h(j+1,j), ldh )
call sscal( min(j+2, kplusp), -one, h(1,j+1), 1 )
call sscal( min(j+np+1,kplusp), -one, q(1,j+1), 1 )
end if
120 continue
c
do 130 i = 1, kev
c
c %--------------------------------------------%
c | Final check for splitting and deflation. |
c | Use a standard test as in the QR algorithm |
c | REFERENCE: LAPACK subroutine slahqr |
c %--------------------------------------------%
c
tst1 = abs( h( i, i ) ) + abs( h( i+1, i+1 ) )
if( tst1.eq.zero )
& tst1 = slanhs( '1', kev, h, ldh, workl )
if( h( i+1,i ) .le. max( ulp*tst1, smlnum ) )
& h(i+1,i) = zero
130 continue
c
c %-------------------------------------------------%
c | Compute the (kev+1)-st column of (V*Q) and |
c | temporarily store the result in WORKD(N+1:2*N). |
c | This is needed in the residual update since we |
c | cannot GUARANTEE that the corresponding entry |
c | of H would be zero as in exact arithmetic. |
c %-------------------------------------------------%
c
if (h(kev+1,kev) .gt. zero)
& call sgemv ('N', n, kplusp, one, v, ldv, q(1,kev+1), 1, zero,
& workd(n+1), 1)
c
c %----------------------------------------------------------%
c | Compute column 1 to kev of (V*Q) in backward order |
c | taking advantage of the upper Hessenberg structure of Q. |
c %----------------------------------------------------------%
c
do 140 i = 1, kev
call sgemv ('N', n, kplusp-i+1, one, v, ldv,
& q(1,kev-i+1), 1, zero, workd, 1)
call scopy (n, workd, 1, v(1,kplusp-i+1), 1)
140 continue
c
c %-------------------------------------------------%
c | Move v(:,kplusp-kev+1:kplusp) into v(:,1:kev). |
c %-------------------------------------------------%
c
call slacpy ('A', n, kev, v(1,kplusp-kev+1), ldv, v, ldv)
c
c %--------------------------------------------------------------%
c | Copy the (kev+1)-st column of (V*Q) in the appropriate place |
c %--------------------------------------------------------------%
c
if (h(kev+1,kev) .gt. zero)
& call scopy (n, workd(n+1), 1, v(1,kev+1), 1)
c
c %-------------------------------------%
c | Update the residual vector: |
c | r <- sigmak*r + betak*v(:,kev+1) |
c | where |
c | sigmak = (e_{kplusp}'*Q)*e_{kev} |
c | betak = e_{kev+1}'*H*e_{kev} |
c %-------------------------------------%
c
call sscal (n, q(kplusp,kev), resid, 1)
if (h(kev+1,kev) .gt. zero)
& call saxpy (n, h(kev+1,kev), v(1,kev+1), 1, resid, 1)
c
if (msglvl .gt. 1) then
call svout (logfil, 1, q(kplusp,kev), ndigit,
& '_napps: sigmak = (e_{kev+p}^T*Q)*e_{kev}')
call svout (logfil, 1, h(kev+1,kev), ndigit,
& '_napps: betak = e_{kev+1}^T*H*e_{kev}')
call ivout (logfil, 1, kev, ndigit,
& '_napps: Order of the final Hessenberg matrix ')
if (msglvl .gt. 2) then
call smout (logfil, kev, kev, h, ldh, ndigit,
& '_napps: updated Hessenberg matrix H for next iteration')
end if
c
end if
c
9000 continue
call second (t1)
tnapps = tnapps + (t1 - t0)
c
return
c
c %---------------%
c | End of snapps |
c %---------------%
c
end

835
arpack/ARPACK/SRC/snaup2.f Normal file
View File

@@ -0,0 +1,835 @@
c\BeginDoc
c
c\Name: snaup2
c
c\Description:
c Intermediate level interface called by snaupd.
c
c\Usage:
c call snaup2
c ( IDO, BMAT, N, WHICH, NEV, NP, TOL, RESID, MODE, IUPD,
c ISHIFT, MXITER, V, LDV, H, LDH, RITZR, RITZI, BOUNDS,
c Q, LDQ, WORKL, IPNTR, WORKD, INFO )
c
c\Arguments
c
c IDO, BMAT, N, WHICH, NEV, TOL, RESID: same as defined in snaupd.
c MODE, ISHIFT, MXITER: see the definition of IPARAM in snaupd.
c
c NP Integer. (INPUT/OUTPUT)
c Contains the number of implicit shifts to apply during
c each Arnoldi iteration.
c If ISHIFT=1, NP is adjusted dynamically at each iteration
c to accelerate convergence and prevent stagnation.
c This is also roughly equal to the number of matrix-vector
c products (involving the operator OP) per Arnoldi iteration.
c The logic for adjusting is contained within the current
c subroutine.
c If ISHIFT=0, NP is the number of shifts the user needs
c to provide via reverse comunication. 0 < NP < NCV-NEV.
c NP may be less than NCV-NEV for two reasons. The first, is
c to keep complex conjugate pairs of "wanted" Ritz values
c together. The second, is that a leading block of the current
c upper Hessenberg matrix has split off and contains "unwanted"
c Ritz values.
c Upon termination of the IRA iteration, NP contains the number
c of "converged" wanted Ritz values.
c
c IUPD Integer. (INPUT)
c IUPD .EQ. 0: use explicit restart instead implicit update.
c IUPD .NE. 0: use implicit update.
c
c V Real N by (NEV+NP) array. (INPUT/OUTPUT)
c The Arnoldi basis vectors are returned in the first NEV
c columns of V.
c
c LDV Integer. (INPUT)
c Leading dimension of V exactly as declared in the calling
c program.
c
c H Real (NEV+NP) by (NEV+NP) array. (OUTPUT)
c H is used to store the generated upper Hessenberg matrix
c
c LDH Integer. (INPUT)
c Leading dimension of H exactly as declared in the calling
c program.
c
c RITZR, Real arrays of length NEV+NP. (OUTPUT)
c RITZI RITZR(1:NEV) (resp. RITZI(1:NEV)) contains the real (resp.
c imaginary) part of the computed Ritz values of OP.
c
c BOUNDS Real array of length NEV+NP. (OUTPUT)
c BOUNDS(1:NEV) contain the error bounds corresponding to
c the computed Ritz values.
c
c Q Real (NEV+NP) by (NEV+NP) array. (WORKSPACE)
c Private (replicated) work array used to accumulate the
c rotation in the shift application step.
c
c LDQ Integer. (INPUT)
c Leading dimension of Q exactly as declared in the calling
c program.
c
c WORKL Real work array of length at least
c (NEV+NP)**2 + 3*(NEV+NP). (INPUT/WORKSPACE)
c Private (replicated) array on each PE or array allocated on
c the front end. It is used in shifts calculation, shifts
c application and convergence checking.
c
c On exit, the last 3*(NEV+NP) locations of WORKL contain
c the Ritz values (real,imaginary) and associated Ritz
c estimates of the current Hessenberg matrix. They are
c listed in the same order as returned from sneigh.
c
c If ISHIFT .EQ. O and IDO .EQ. 3, the first 2*NP locations
c of WORKL are used in reverse communication to hold the user
c supplied shifts.
c
c IPNTR Integer array of length 3. (OUTPUT)
c Pointer to mark the starting locations in the WORKD for
c vectors used by the Arnoldi iteration.
c -------------------------------------------------------------
c IPNTR(1): pointer to the current operand vector X.
c IPNTR(2): pointer to the current result vector Y.
c IPNTR(3): pointer to the vector B * X when used in the
c shift-and-invert mode. X is the current operand.
c -------------------------------------------------------------
c
c WORKD Real work array of length 3*N. (WORKSPACE)
c Distributed array to be used in the basic Arnoldi iteration
c for reverse communication. The user should not use WORKD
c as temporary workspace during the iteration !!!!!!!!!!
c See Data Distribution Note in DNAUPD.
c
c INFO Integer. (INPUT/OUTPUT)
c If INFO .EQ. 0, a randomly initial residual vector is used.
c If INFO .NE. 0, RESID contains the initial residual vector,
c possibly from a previous run.
c Error flag on output.
c = 0: Normal return.
c = 1: Maximum number of iterations taken.
c All possible eigenvalues of OP has been found.
c NP returns the number of converged Ritz values.
c = 2: No shifts could be applied.
c = -8: Error return from LAPACK eigenvalue calculation;
c This should never happen.
c = -9: Starting vector is zero.
c = -9999: Could not build an Arnoldi factorization.
c Size that was built in returned in NP.
c
c\EndDoc
c
c-----------------------------------------------------------------------
c
c\BeginLib
c
c\Local variables:
c xxxxxx real
c
c\References:
c 1. D.C. Sorensen, "Implicit Application of Polynomial Filters in
c a k-Step Arnoldi Method", SIAM J. Matr. Anal. Apps., 13 (1992),
c pp 357-385.
c 2. R.B. Lehoucq, "Analysis and Implementation of an Implicitly
c Restarted Arnoldi Iteration", Rice University Technical Report
c TR95-13, Department of Computational and Applied Mathematics.
c
c\Routines called:
c sgetv0 ARPACK initial vector generation routine.
c snaitr ARPACK Arnoldi factorization routine.
c snapps ARPACK application of implicit shifts routine.
c snconv ARPACK convergence of Ritz values routine.
c sneigh ARPACK compute Ritz values and error bounds routine.
c sngets ARPACK reorder Ritz values and error bounds routine.
c ssortc ARPACK sorting routine.
c ivout ARPACK utility routine that prints integers.
c second ARPACK utility routine for timing.
c smout ARPACK utility routine that prints matrices
c svout ARPACK utility routine that prints vectors.
c slamch LAPACK routine that determines machine constants.
c slapy2 LAPACK routine to compute sqrt(x**2+y**2) carefully.
c scopy Level 1 BLAS that copies one vector to another .
c sdot Level 1 BLAS that computes the scalar product of two vectors.
c snrm2 Level 1 BLAS that computes the norm of a vector.
c sswap Level 1 BLAS that swaps two vectors.
c
c\Author
c Danny Sorensen Phuong Vu
c Richard Lehoucq CRPC / Rice University
c Dept. of Computational & Houston, Texas
c Applied Mathematics
c Rice University
c Houston, Texas
c
c\SCCS Information: @(#)
c FILE: naup2.F SID: 2.8 DATE OF SID: 10/17/00 RELEASE: 2
c
c\Remarks
c 1. None
c
c\EndLib
c
c-----------------------------------------------------------------------
c
subroutine snaup2
& ( ido, bmat, n, which, nev, np, tol, resid, mode, iupd,
& ishift, mxiter, v, ldv, h, ldh, ritzr, ritzi, bounds,
& q, ldq, workl, ipntr, workd, info )
c
c %----------------------------------------------------%
c | Include files for debugging and timing information |
c %----------------------------------------------------%
c
include 'debug.h'
include 'stat.h'
c
c %------------------%
c | Scalar Arguments |
c %------------------%
c
character bmat*1, which*2
integer ido, info, ishift, iupd, mode, ldh, ldq, ldv, mxiter,
& n, nev, np
Real
& tol
c
c %-----------------%
c | Array Arguments |
c %-----------------%
c
integer ipntr(13)
Real
& bounds(nev+np), h(ldh,nev+np), q(ldq,nev+np), resid(n),
& ritzi(nev+np), ritzr(nev+np), v(ldv,nev+np),
& workd(3*n), workl( (nev+np)*(nev+np+3) )
c
c %------------%
c | Parameters |
c %------------%
c
Real
& one, zero
parameter (one = 1.0E+0, zero = 0.0E+0)
c
c %---------------%
c | Local Scalars |
c %---------------%
c
character wprime*2
logical cnorm , getv0, initv, update, ushift
integer ierr , iter , j , kplusp, msglvl, nconv,
& nevbef, nev0 , np0 , nptemp, numcnv
Real
& rnorm , temp , eps23
save cnorm , getv0, initv, update, ushift,
& rnorm , iter , eps23, kplusp, msglvl, nconv ,
& nevbef, nev0 , np0 , numcnv
c
c %-----------------------%
c | Local array arguments |
c %-----------------------%
c
integer kp(4)
c
c %----------------------%
c | External Subroutines |
c %----------------------%
c
external scopy , sgetv0, snaitr, snconv, sneigh,
& sngets, snapps, svout , ivout , second
c
c %--------------------%
c | External Functions |
c %--------------------%
c
Real
& sdot, snrm2, slapy2, slamch
external sdot, snrm2, slapy2, slamch
c
c %---------------------%
c | Intrinsic Functions |
c %---------------------%
c
intrinsic min, max, abs, sqrt
c
c %-----------------------%
c | Executable Statements |
c %-----------------------%
c
if (ido .eq. 0) then
c
call second (t0)
c
msglvl = mnaup2
c
c %-------------------------------------%
c | Get the machine dependent constant. |
c %-------------------------------------%
c
eps23 = slamch('Epsilon-Machine')
eps23 = eps23**(2.0E+0 / 3.0E+0)
c
nev0 = nev
np0 = np
c
c %-------------------------------------%
c | kplusp is the bound on the largest |
c | Lanczos factorization built. |
c | nconv is the current number of |
c | "converged" eigenvlues. |
c | iter is the counter on the current |
c | iteration step. |
c %-------------------------------------%
c
kplusp = nev + np
nconv = 0
iter = 0
c
c %---------------------------------------%
c | Set flags for computing the first NEV |
c | steps of the Arnoldi factorization. |
c %---------------------------------------%
c
getv0 = .true.
update = .false.
ushift = .false.
cnorm = .false.
c
if (info .ne. 0) then
c
c %--------------------------------------------%
c | User provides the initial residual vector. |
c %--------------------------------------------%
c
initv = .true.
info = 0
else
initv = .false.
end if
end if
c
c %---------------------------------------------%
c | Get a possibly random starting vector and |
c | force it into the range of the operator OP. |
c %---------------------------------------------%
c
10 continue
c
if (getv0) then
call sgetv0 (ido, bmat, 1, initv, n, 1, v, ldv, resid, rnorm,
& ipntr, workd, info)
c
if (ido .ne. 99) go to 9000
c
if (rnorm .eq. zero) then
c
c %-----------------------------------------%
c | The initial vector is zero. Error exit. |
c %-----------------------------------------%
c
info = -9
go to 1100
end if
getv0 = .false.
ido = 0
end if
c
c %-----------------------------------%
c | Back from reverse communication : |
c | continue with update step |
c %-----------------------------------%
c
if (update) go to 20
c
c %-------------------------------------------%
c | Back from computing user specified shifts |
c %-------------------------------------------%
c
if (ushift) go to 50
c
c %-------------------------------------%
c | Back from computing residual norm |
c | at the end of the current iteration |
c %-------------------------------------%
c
if (cnorm) go to 100
c
c %----------------------------------------------------------%
c | Compute the first NEV steps of the Arnoldi factorization |
c %----------------------------------------------------------%
c
call snaitr (ido, bmat, n, 0, nev, mode, resid, rnorm, v, ldv,
& h, ldh, ipntr, workd, info)
c
c %---------------------------------------------------%
c | ido .ne. 99 implies use of reverse communication |
c | to compute operations involving OP and possibly B |
c %---------------------------------------------------%
c
if (ido .ne. 99) go to 9000
c
if (info .gt. 0) then
np = info
mxiter = iter
info = -9999
go to 1200
end if
c
c %--------------------------------------------------------------%
c | |
c | M A I N ARNOLDI I T E R A T I O N L O O P |
c | Each iteration implicitly restarts the Arnoldi |
c | factorization in place. |
c | |
c %--------------------------------------------------------------%
c
1000 continue
c
iter = iter + 1
c
if (msglvl .gt. 0) then
call ivout (logfil, 1, iter, ndigit,
& '_naup2: **** Start of major iteration number ****')
end if
c
c %-----------------------------------------------------------%
c | Compute NP additional steps of the Arnoldi factorization. |
c | Adjust NP since NEV might have been updated by last call |
c | to the shift application routine snapps. |
c %-----------------------------------------------------------%
c
np = kplusp - nev
c
if (msglvl .gt. 1) then
call ivout (logfil, 1, nev, ndigit,
& '_naup2: The length of the current Arnoldi factorization')
call ivout (logfil, 1, np, ndigit,
& '_naup2: Extend the Arnoldi factorization by')
end if
c
c %-----------------------------------------------------------%
c | Compute NP additional steps of the Arnoldi factorization. |
c %-----------------------------------------------------------%
c
ido = 0
20 continue
update = .true.
c
call snaitr (ido , bmat, n , nev, np , mode , resid,
& rnorm, v , ldv, h , ldh, ipntr, workd,
& info)
c
c %---------------------------------------------------%
c | ido .ne. 99 implies use of reverse communication |
c | to compute operations involving OP and possibly B |
c %---------------------------------------------------%
c
if (ido .ne. 99) go to 9000
c
if (info .gt. 0) then
np = info
mxiter = iter
info = -9999
go to 1200
end if
update = .false.
c
if (msglvl .gt. 1) then
call svout (logfil, 1, rnorm, ndigit,
& '_naup2: Corresponding B-norm of the residual')
end if
c
c %--------------------------------------------------------%
c | Compute the eigenvalues and corresponding error bounds |
c | of the current upper Hessenberg matrix. |
c %--------------------------------------------------------%
c
call sneigh (rnorm, kplusp, h, ldh, ritzr, ritzi, bounds,
& q, ldq, workl, ierr)
c
if (ierr .ne. 0) then
info = -8
go to 1200
end if
c
c %----------------------------------------------------%
c | Make a copy of eigenvalues and corresponding error |
c | bounds obtained from sneigh. |
c %----------------------------------------------------%
c
call scopy(kplusp, ritzr, 1, workl(kplusp**2+1), 1)
call scopy(kplusp, ritzi, 1, workl(kplusp**2+kplusp+1), 1)
call scopy(kplusp, bounds, 1, workl(kplusp**2+2*kplusp+1), 1)
c
c %---------------------------------------------------%
c | Select the wanted Ritz values and their bounds |
c | to be used in the convergence test. |
c | The wanted part of the spectrum and corresponding |
c | error bounds are in the last NEV loc. of RITZR, |
c | RITZI and BOUNDS respectively. The variables NEV |
c | and NP may be updated if the NEV-th wanted Ritz |
c | value has a non zero imaginary part. In this case |
c | NEV is increased by one and NP decreased by one. |
c | NOTE: The last two arguments of sngets are no |
c | longer used as of version 2.1. |
c %---------------------------------------------------%
c
nev = nev0
np = np0
numcnv = nev
call sngets (ishift, which, nev, np, ritzr, ritzi,
& bounds, workl, workl(np+1))
if (nev .eq. nev0+1) numcnv = nev0+1
c
c %-------------------%
c | Convergence test. |
c %-------------------%
c
call scopy (nev, bounds(np+1), 1, workl(2*np+1), 1)
call snconv (nev, ritzr(np+1), ritzi(np+1), workl(2*np+1),
& tol, nconv)
c
if (msglvl .gt. 2) then
kp(1) = nev
kp(2) = np
kp(3) = numcnv
kp(4) = nconv
call ivout (logfil, 4, kp, ndigit,
& '_naup2: NEV, NP, NUMCNV, NCONV are')
call svout (logfil, kplusp, ritzr, ndigit,
& '_naup2: Real part of the eigenvalues of H')
call svout (logfil, kplusp, ritzi, ndigit,
& '_naup2: Imaginary part of the eigenvalues of H')
call svout (logfil, kplusp, bounds, ndigit,
& '_naup2: Ritz estimates of the current NCV Ritz values')
end if
c
c %---------------------------------------------------------%
c | Count the number of unwanted Ritz values that have zero |
c | Ritz estimates. If any Ritz estimates are equal to zero |
c | then a leading block of H of order equal to at least |
c | the number of Ritz values with zero Ritz estimates has |
c | split off. None of these Ritz values may be removed by |
c | shifting. Decrease NP the number of shifts to apply. If |
c | no shifts may be applied, then prepare to exit |
c %---------------------------------------------------------%
c
nptemp = np
do 30 j=1, nptemp
if (bounds(j) .eq. zero) then
np = np - 1
nev = nev + 1
end if
30 continue
c
if ( (nconv .ge. numcnv) .or.
& (iter .gt. mxiter) .or.
& (np .eq. 0) ) then
c
if (msglvl .gt. 4) then
call svout(logfil, kplusp, workl(kplusp**2+1), ndigit,
& '_naup2: Real part of the eig computed by _neigh:')
call svout(logfil, kplusp, workl(kplusp**2+kplusp+1),
& ndigit,
& '_naup2: Imag part of the eig computed by _neigh:')
call svout(logfil, kplusp, workl(kplusp**2+kplusp*2+1),
& ndigit,
& '_naup2: Ritz eistmates computed by _neigh:')
end if
c
c %------------------------------------------------%
c | Prepare to exit. Put the converged Ritz values |
c | and corresponding bounds in RITZ(1:NCONV) and |
c | BOUNDS(1:NCONV) respectively. Then sort. Be |
c | careful when NCONV > NP |
c %------------------------------------------------%
c
c %------------------------------------------%
c | Use h( 3,1 ) as storage to communicate |
c | rnorm to _neupd if needed |
c %------------------------------------------%
h(3,1) = rnorm
c
c %----------------------------------------------%
c | To be consistent with sngets, we first do a |
c | pre-processing sort in order to keep complex |
c | conjugate pairs together. This is similar |
c | to the pre-processing sort used in sngets |
c | except that the sort is done in the opposite |
c | order. |
c %----------------------------------------------%
c
if (which .eq. 'LM') wprime = 'SR'
if (which .eq. 'SM') wprime = 'LR'
if (which .eq. 'LR') wprime = 'SM'
if (which .eq. 'SR') wprime = 'LM'
if (which .eq. 'LI') wprime = 'SM'
if (which .eq. 'SI') wprime = 'LM'
c
call ssortc (wprime, .true., kplusp, ritzr, ritzi, bounds)
c
c %----------------------------------------------%
c | Now sort Ritz values so that converged Ritz |
c | values appear within the first NEV locations |
c | of ritzr, ritzi and bounds, and the most |
c | desired one appears at the front. |
c %----------------------------------------------%
c
if (which .eq. 'LM') wprime = 'SM'
if (which .eq. 'SM') wprime = 'LM'
if (which .eq. 'LR') wprime = 'SR'
if (which .eq. 'SR') wprime = 'LR'
if (which .eq. 'LI') wprime = 'SI'
if (which .eq. 'SI') wprime = 'LI'
c
call ssortc(wprime, .true., kplusp, ritzr, ritzi, bounds)
c
c %--------------------------------------------------%
c | Scale the Ritz estimate of each Ritz value |
c | by 1 / max(eps23,magnitude of the Ritz value). |
c %--------------------------------------------------%
c
do 35 j = 1, numcnv
temp = max(eps23,slapy2(ritzr(j),
& ritzi(j)))
bounds(j) = bounds(j)/temp
35 continue
c
c %----------------------------------------------------%
c | Sort the Ritz values according to the scaled Ritz |
c | esitmates. This will push all the converged ones |
c | towards the front of ritzr, ritzi, bounds |
c | (in the case when NCONV < NEV.) |
c %----------------------------------------------------%
c
wprime = 'LR'
call ssortc(wprime, .true., numcnv, bounds, ritzr, ritzi)
c
c %----------------------------------------------%
c | Scale the Ritz estimate back to its original |
c | value. |
c %----------------------------------------------%
c
do 40 j = 1, numcnv
temp = max(eps23, slapy2(ritzr(j),
& ritzi(j)))
bounds(j) = bounds(j)*temp
40 continue
c
c %------------------------------------------------%
c | Sort the converged Ritz values again so that |
c | the "threshold" value appears at the front of |
c | ritzr, ritzi and bound. |
c %------------------------------------------------%
c
call ssortc(which, .true., nconv, ritzr, ritzi, bounds)
c
if (msglvl .gt. 1) then
call svout (logfil, kplusp, ritzr, ndigit,
& '_naup2: Sorted real part of the eigenvalues')
call svout (logfil, kplusp, ritzi, ndigit,
& '_naup2: Sorted imaginary part of the eigenvalues')
call svout (logfil, kplusp, bounds, ndigit,
& '_naup2: Sorted ritz estimates.')
end if
c
c %------------------------------------%
c | Max iterations have been exceeded. |
c %------------------------------------%
c
if (iter .gt. mxiter .and. nconv .lt. numcnv) info = 1
c
c %---------------------%
c | No shifts to apply. |
c %---------------------%
c
if (np .eq. 0 .and. nconv .lt. numcnv) info = 2
c
np = nconv
go to 1100
c
else if ( (nconv .lt. numcnv) .and. (ishift .eq. 1) ) then
c
c %-------------------------------------------------%
c | Do not have all the requested eigenvalues yet. |
c | To prevent possible stagnation, adjust the size |
c | of NEV. |
c %-------------------------------------------------%
c
nevbef = nev
nev = nev + min(nconv, np/2)
if (nev .eq. 1 .and. kplusp .ge. 6) then
nev = kplusp / 2
else if (nev .eq. 1 .and. kplusp .gt. 3) then
nev = 2
end if
np = kplusp - nev
c
c %---------------------------------------%
c | If the size of NEV was just increased |
c | resort the eigenvalues. |
c %---------------------------------------%
c
if (nevbef .lt. nev)
& call sngets (ishift, which, nev, np, ritzr, ritzi,
& bounds, workl, workl(np+1))
c
end if
c
if (msglvl .gt. 0) then
call ivout (logfil, 1, nconv, ndigit,
& '_naup2: no. of "converged" Ritz values at this iter.')
if (msglvl .gt. 1) then
kp(1) = nev
kp(2) = np
call ivout (logfil, 2, kp, ndigit,
& '_naup2: NEV and NP are')
call svout (logfil, nev, ritzr(np+1), ndigit,
& '_naup2: "wanted" Ritz values -- real part')
call svout (logfil, nev, ritzi(np+1), ndigit,
& '_naup2: "wanted" Ritz values -- imag part')
call svout (logfil, nev, bounds(np+1), ndigit,
& '_naup2: Ritz estimates of the "wanted" values ')
end if
end if
c
if (ishift .eq. 0) then
c
c %-------------------------------------------------------%
c | User specified shifts: reverse comminucation to |
c | compute the shifts. They are returned in the first |
c | 2*NP locations of WORKL. |
c %-------------------------------------------------------%
c
ushift = .true.
ido = 3
go to 9000
end if
c
50 continue
c
c %------------------------------------%
c | Back from reverse communication; |
c | User specified shifts are returned |
c | in WORKL(1:2*NP) |
c %------------------------------------%
c
ushift = .false.
c
if ( ishift .eq. 0 ) then
c
c %----------------------------------%
c | Move the NP shifts from WORKL to |
c | RITZR, RITZI to free up WORKL |
c | for non-exact shift case. |
c %----------------------------------%
c
call scopy (np, workl, 1, ritzr, 1)
call scopy (np, workl(np+1), 1, ritzi, 1)
end if
c
if (msglvl .gt. 2) then
call ivout (logfil, 1, np, ndigit,
& '_naup2: The number of shifts to apply ')
call svout (logfil, np, ritzr, ndigit,
& '_naup2: Real part of the shifts')
call svout (logfil, np, ritzi, ndigit,
& '_naup2: Imaginary part of the shifts')
if ( ishift .eq. 1 )
& call svout (logfil, np, bounds, ndigit,
& '_naup2: Ritz estimates of the shifts')
end if
c
c %---------------------------------------------------------%
c | Apply the NP implicit shifts by QR bulge chasing. |
c | Each shift is applied to the whole upper Hessenberg |
c | matrix H. |
c | The first 2*N locations of WORKD are used as workspace. |
c %---------------------------------------------------------%
c
call snapps (n, nev, np, ritzr, ritzi, v, ldv,
& h, ldh, resid, q, ldq, workl, workd)
c
c %---------------------------------------------%
c | Compute the B-norm of the updated residual. |
c | Keep B*RESID in WORKD(1:N) to be used in |
c | the first step of the next call to snaitr. |
c %---------------------------------------------%
c
cnorm = .true.
call second (t2)
if (bmat .eq. 'G') then
nbx = nbx + 1
call scopy (n, resid, 1, workd(n+1), 1)
ipntr(1) = n + 1
ipntr(2) = 1
ido = 2
c
c %----------------------------------%
c | Exit in order to compute B*RESID |
c %----------------------------------%
c
go to 9000
else if (bmat .eq. 'I') then
call scopy (n, resid, 1, workd, 1)
end if
c
100 continue
c
c %----------------------------------%
c | Back from reverse communication; |
c | WORKD(1:N) := B*RESID |
c %----------------------------------%
c
if (bmat .eq. 'G') then
call second (t3)
tmvbx = tmvbx + (t3 - t2)
end if
c
if (bmat .eq. 'G') then
rnorm = sdot (n, resid, 1, workd, 1)
rnorm = sqrt(abs(rnorm))
else if (bmat .eq. 'I') then
rnorm = snrm2(n, resid, 1)
end if
cnorm = .false.
c
if (msglvl .gt. 2) then
call svout (logfil, 1, rnorm, ndigit,
& '_naup2: B-norm of residual for compressed factorization')
call smout (logfil, nev, nev, h, ldh, ndigit,
& '_naup2: Compressed upper Hessenberg matrix H')
end if
c
go to 1000
c
c %---------------------------------------------------------------%
c | |
c | E N D O F M A I N I T E R A T I O N L O O P |
c | |
c %---------------------------------------------------------------%
c
1100 continue
c
mxiter = iter
nev = numcnv
c
1200 continue
ido = 99
c
c %------------%
c | Error Exit |
c %------------%
c
call second (t1)
tnaup2 = t1 - t0
c
9000 continue
c
c %---------------%
c | End of snaup2 |
c %---------------%
c
return
end

693
arpack/ARPACK/SRC/snaupd.f Normal file
View File

@@ -0,0 +1,693 @@
c\BeginDoc
c
c\Name: snaupd
c
c\Description:
c Reverse communication interface for the Implicitly Restarted Arnoldi
c iteration. This subroutine computes approximations to a few eigenpairs
c of a linear operator "OP" with respect to a semi-inner product defined by
c a symmetric positive semi-definite real matrix B. B may be the identity
c matrix. NOTE: If the linear operator "OP" is real and symmetric
c with respect to the real positive semi-definite symmetric matrix B,
c i.e. B*OP = (OP`)*B, then subroutine ssaupd should be used instead.
c
c The computed approximate eigenvalues are called Ritz values and
c the corresponding approximate eigenvectors are called Ritz vectors.
c
c snaupd is usually called iteratively to solve one of the
c following problems:
c
c Mode 1: A*x = lambda*x.
c ===> OP = A and B = I.
c
c Mode 2: A*x = lambda*M*x, M symmetric positive definite
c ===> OP = inv[M]*A and B = M.
c ===> (If M can be factored see remark 3 below)
c
c Mode 3: A*x = lambda*M*x, M symmetric semi-definite
c ===> OP = Real_Part{ inv[A - sigma*M]*M } and B = M.
c ===> shift-and-invert mode (in real arithmetic)
c If OP*x = amu*x, then
c amu = 1/2 * [ 1/(lambda-sigma) + 1/(lambda-conjg(sigma)) ].
c Note: If sigma is real, i.e. imaginary part of sigma is zero;
c Real_Part{ inv[A - sigma*M]*M } == inv[A - sigma*M]*M
c amu == 1/(lambda-sigma).
c
c Mode 4: A*x = lambda*M*x, M symmetric semi-definite
c ===> OP = Imaginary_Part{ inv[A - sigma*M]*M } and B = M.
c ===> shift-and-invert mode (in real arithmetic)
c If OP*x = amu*x, then
c amu = 1/2i * [ 1/(lambda-sigma) - 1/(lambda-conjg(sigma)) ].
c
c Both mode 3 and 4 give the same enhancement to eigenvalues close to
c the (complex) shift sigma. However, as lambda goes to infinity,
c the operator OP in mode 4 dampens the eigenvalues more strongly than
c does OP defined in mode 3.
c
c NOTE: The action of w <- inv[A - sigma*M]*v or w <- inv[M]*v
c should be accomplished either by a direct method
c using a sparse matrix factorization and solving
c
c [A - sigma*M]*w = v or M*w = v,
c
c or through an iterative method for solving these
c systems. If an iterative method is used, the
c convergence test must be more stringent than
c the accuracy requirements for the eigenvalue
c approximations.
c
c\Usage:
c call snaupd
c ( IDO, BMAT, N, WHICH, NEV, TOL, RESID, NCV, V, LDV, IPARAM,
c IPNTR, WORKD, WORKL, LWORKL, INFO )
c
c\Arguments
c IDO Integer. (INPUT/OUTPUT)
c Reverse communication flag. IDO must be zero on the first
c call to snaupd. IDO will be set internally to
c indicate the type of operation to be performed. Control is
c then given back to the calling routine which has the
c responsibility to carry out the requested operation and call
c snaupd with the result. The operand is given in
c WORKD(IPNTR(1)), the result must be put in WORKD(IPNTR(2)).
c -------------------------------------------------------------
c IDO = 0: first call to the reverse communication interface
c IDO = -1: compute Y = OP * X where
c IPNTR(1) is the pointer into WORKD for X,
c IPNTR(2) is the pointer into WORKD for Y.
c This is for the initialization phase to force the
c starting vector into the range of OP.
c IDO = 1: compute Y = OP * X where
c IPNTR(1) is the pointer into WORKD for X,
c IPNTR(2) is the pointer into WORKD for Y.
c In mode 3 and 4, the vector B * X is already
c available in WORKD(ipntr(3)). It does not
c need to be recomputed in forming OP * X.
c IDO = 2: compute Y = B * X where
c IPNTR(1) is the pointer into WORKD for X,
c IPNTR(2) is the pointer into WORKD for Y.
c IDO = 3: compute the IPARAM(8) real and imaginary parts
c of the shifts where INPTR(14) is the pointer
c into WORKL for placing the shifts. See Remark
c 5 below.
c IDO = 99: done
c -------------------------------------------------------------
c
c BMAT Character*1. (INPUT)
c BMAT specifies the type of the matrix B that defines the
c semi-inner product for the operator OP.
c BMAT = 'I' -> standard eigenvalue problem A*x = lambda*x
c BMAT = 'G' -> generalized eigenvalue problem A*x = lambda*B*x
c
c N Integer. (INPUT)
c Dimension of the eigenproblem.
c
c WHICH Character*2. (INPUT)
c 'LM' -> want the NEV eigenvalues of largest magnitude.
c 'SM' -> want the NEV eigenvalues of smallest magnitude.
c 'LR' -> want the NEV eigenvalues of largest real part.
c 'SR' -> want the NEV eigenvalues of smallest real part.
c 'LI' -> want the NEV eigenvalues of largest imaginary part.
c 'SI' -> want the NEV eigenvalues of smallest imaginary part.
c
c NEV Integer. (INPUT/OUTPUT)
c Number of eigenvalues of OP to be computed. 0 < NEV < N-1.
c
c TOL Real scalar. (INPUT)
c Stopping criterion: the relative accuracy of the Ritz value
c is considered acceptable if BOUNDS(I) .LE. TOL*ABS(RITZ(I))
c where ABS(RITZ(I)) is the magnitude when RITZ(I) is complex.
c DEFAULT = SLAMCH('EPS') (machine precision as computed
c by the LAPACK auxiliary subroutine SLAMCH).
c
c RESID Real array of length N. (INPUT/OUTPUT)
c On INPUT:
c If INFO .EQ. 0, a random initial residual vector is used.
c If INFO .NE. 0, RESID contains the initial residual vector,
c possibly from a previous run.
c On OUTPUT:
c RESID contains the final residual vector.
c
c NCV Integer. (INPUT)
c Number of columns of the matrix V. NCV must satisfy the two
c inequalities 2 <= NCV-NEV and NCV <= N.
c This will indicate how many Arnoldi vectors are generated
c at each iteration. After the startup phase in which NEV
c Arnoldi vectors are generated, the algorithm generates
c approximately NCV-NEV Arnoldi vectors at each subsequent update
c iteration. Most of the cost in generating each Arnoldi vector is
c in the matrix-vector operation OP*x.
c NOTE: 2 <= NCV-NEV in order that complex conjugate pairs of Ritz
c values are kept together. (See remark 4 below)
c
c V Real array N by NCV. (OUTPUT)
c Contains the final set of Arnoldi basis vectors.
c
c LDV Integer. (INPUT)
c Leading dimension of V exactly as declared in the calling program.
c
c IPARAM Integer array of length 11. (INPUT/OUTPUT)
c IPARAM(1) = ISHIFT: method for selecting the implicit shifts.
c The shifts selected at each iteration are used to restart
c the Arnoldi iteration in an implicit fashion.
c -------------------------------------------------------------
c ISHIFT = 0: the shifts are provided by the user via
c reverse communication. The real and imaginary
c parts of the NCV eigenvalues of the Hessenberg
c matrix H are returned in the part of the WORKL
c array corresponding to RITZR and RITZI. See remark
c 5 below.
c ISHIFT = 1: exact shifts with respect to the current
c Hessenberg matrix H. This is equivalent to
c restarting the iteration with a starting vector
c that is a linear combination of approximate Schur
c vectors associated with the "wanted" Ritz values.
c -------------------------------------------------------------
c
c IPARAM(2) = No longer referenced.
c
c IPARAM(3) = MXITER
c On INPUT: maximum number of Arnoldi update iterations allowed.
c On OUTPUT: actual number of Arnoldi update iterations taken.
c
c IPARAM(4) = NB: blocksize to be used in the recurrence.
c The code currently works only for NB = 1.
c
c IPARAM(5) = NCONV: number of "converged" Ritz values.
c This represents the number of Ritz values that satisfy
c the convergence criterion.
c
c IPARAM(6) = IUPD
c No longer referenced. Implicit restarting is ALWAYS used.
c
c IPARAM(7) = MODE
c On INPUT determines what type of eigenproblem is being solved.
c Must be 1,2,3,4; See under \Description of snaupd for the
c four modes available.
c
c IPARAM(8) = NP
c When ido = 3 and the user provides shifts through reverse
c communication (IPARAM(1)=0), snaupd returns NP, the number
c of shifts the user is to provide. 0 < NP <=NCV-NEV. See Remark
c 5 below.
c
c IPARAM(9) = NUMOP, IPARAM(10) = NUMOPB, IPARAM(11) = NUMREO,
c OUTPUT: NUMOP = total number of OP*x operations,
c NUMOPB = total number of B*x operations if BMAT='G',
c NUMREO = total number of steps of re-orthogonalization.
c
c IPNTR Integer array of length 14. (OUTPUT)
c Pointer to mark the starting locations in the WORKD and WORKL
c arrays for matrices/vectors used by the Arnoldi iteration.
c -------------------------------------------------------------
c IPNTR(1): pointer to the current operand vector X in WORKD.
c IPNTR(2): pointer to the current result vector Y in WORKD.
c IPNTR(3): pointer to the vector B * X in WORKD when used in
c the shift-and-invert mode.
c IPNTR(4): pointer to the next available location in WORKL
c that is untouched by the program.
c IPNTR(5): pointer to the NCV by NCV upper Hessenberg matrix
c H in WORKL.
c IPNTR(6): pointer to the real part of the ritz value array
c RITZR in WORKL.
c IPNTR(7): pointer to the imaginary part of the ritz value array
c RITZI in WORKL.
c IPNTR(8): pointer to the Ritz estimates in array WORKL associated
c with the Ritz values located in RITZR and RITZI in WORKL.
c
c IPNTR(14): pointer to the NP shifts in WORKL. See Remark 5 below.
c
c Note: IPNTR(9:13) is only referenced by sneupd. See Remark 2 below.
c
c IPNTR(9): pointer to the real part of the NCV RITZ values of the
c original system.
c IPNTR(10): pointer to the imaginary part of the NCV RITZ values of
c the original system.
c IPNTR(11): pointer to the NCV corresponding error bounds.
c IPNTR(12): pointer to the NCV by NCV upper quasi-triangular
c Schur matrix for H.
c IPNTR(13): pointer to the NCV by NCV matrix of eigenvectors
c of the upper Hessenberg matrix H. Only referenced by
c sneupd if RVEC = .TRUE. See Remark 2 below.
c -------------------------------------------------------------
c
c WORKD Real work array of length 3*N. (REVERSE COMMUNICATION)
c Distributed array to be used in the basic Arnoldi iteration
c for reverse communication. The user should not use WORKD
c as temporary workspace during the iteration. Upon termination
c WORKD(1:N) contains B*RESID(1:N). If an invariant subspace
c associated with the converged Ritz values is desired, see remark
c 2 below, subroutine sneupd uses this output.
c See Data Distribution Note below.
c
c WORKL Real work array of length LWORKL. (OUTPUT/WORKSPACE)
c Private (replicated) array on each PE or array allocated on
c the front end. See Data Distribution Note below.
c
c LWORKL Integer. (INPUT)
c LWORKL must be at least 3*NCV**2 + 6*NCV.
c
c INFO Integer. (INPUT/OUTPUT)
c If INFO .EQ. 0, a randomly initial residual vector is used.
c If INFO .NE. 0, RESID contains the initial residual vector,
c possibly from a previous run.
c Error flag on output.
c = 0: Normal exit.
c = 1: Maximum number of iterations taken.
c All possible eigenvalues of OP has been found. IPARAM(5)
c returns the number of wanted converged Ritz values.
c = 2: No longer an informational error. Deprecated starting
c with release 2 of ARPACK.
c = 3: No shifts could be applied during a cycle of the
c Implicitly restarted Arnoldi iteration. One possibility
c is to increase the size of NCV relative to NEV.
c See remark 4 below.
c = -1: N must be positive.
c = -2: NEV must be positive.
c = -3: NCV-NEV >= 2 and less than or equal to N.
c = -4: The maximum number of Arnoldi update iteration
c must be greater than zero.
c = -5: WHICH must be one of 'LM', 'SM', 'LR', 'SR', 'LI', 'SI'
c = -6: BMAT must be one of 'I' or 'G'.
c = -7: Length of private work array is not sufficient.
c = -8: Error return from LAPACK eigenvalue calculation;
c = -9: Starting vector is zero.
c = -10: IPARAM(7) must be 1,2,3,4.
c = -11: IPARAM(7) = 1 and BMAT = 'G' are incompatable.
c = -12: IPARAM(1) must be equal to 0 or 1.
c = -9999: Could not build an Arnoldi factorization.
c IPARAM(5) returns the size of the current Arnoldi
c factorization.
c
c\Remarks
c 1. The computed Ritz values are approximate eigenvalues of OP. The
c selection of WHICH should be made with this in mind when
c Mode = 3 and 4. After convergence, approximate eigenvalues of the
c original problem may be obtained with the ARPACK subroutine sneupd.
c
c 2. If a basis for the invariant subspace corresponding to the converged Ritz
c values is needed, the user must call sneupd immediately following
c completion of snaupd. This is new starting with release 2 of ARPACK.
c
c 3. If M can be factored into a Cholesky factorization M = LL`
c then Mode = 2 should not be selected. Instead one should use
c Mode = 1 with OP = inv(L)*A*inv(L`). Appropriate triangular
c linear systems should be solved with L and L` rather
c than computing inverses. After convergence, an approximate
c eigenvector z of the original problem is recovered by solving
c L`z = x where x is a Ritz vector of OP.
c
c 4. At present there is no a-priori analysis to guide the selection
c of NCV relative to NEV. The only formal requrement is that NCV > NEV + 2.
c However, it is recommended that NCV .ge. 2*NEV+1. If many problems of
c the same type are to be solved, one should experiment with increasing
c NCV while keeping NEV fixed for a given test problem. This will
c usually decrease the required number of OP*x operations but it
c also increases the work and storage required to maintain the orthogonal
c basis vectors. The optimal "cross-over" with respect to CPU time
c is problem dependent and must be determined empirically.
c See Chapter 8 of Reference 2 for further information.
c
c 5. When IPARAM(1) = 0, and IDO = 3, the user needs to provide the
c NP = IPARAM(8) real and imaginary parts of the shifts in locations
c real part imaginary part
c ----------------------- --------------
c 1 WORKL(IPNTR(14)) WORKL(IPNTR(14)+NP)
c 2 WORKL(IPNTR(14)+1) WORKL(IPNTR(14)+NP+1)
c . .
c . .
c . .
c NP WORKL(IPNTR(14)+NP-1) WORKL(IPNTR(14)+2*NP-1).
c
c Only complex conjugate pairs of shifts may be applied and the pairs
c must be placed in consecutive locations. The real part of the
c eigenvalues of the current upper Hessenberg matrix are located in
c WORKL(IPNTR(6)) through WORKL(IPNTR(6)+NCV-1) and the imaginary part
c in WORKL(IPNTR(7)) through WORKL(IPNTR(7)+NCV-1). They are ordered
c according to the order defined by WHICH. The complex conjugate
c pairs are kept together and the associated Ritz estimates are located in
c WORKL(IPNTR(8)), WORKL(IPNTR(8)+1), ... , WORKL(IPNTR(8)+NCV-1).
c
c-----------------------------------------------------------------------
c
c\Data Distribution Note:
c
c Fortran-D syntax:
c ================
c Real resid(n), v(ldv,ncv), workd(3*n), workl(lworkl)
c decompose d1(n), d2(n,ncv)
c align resid(i) with d1(i)
c align v(i,j) with d2(i,j)
c align workd(i) with d1(i) range (1:n)
c align workd(i) with d1(i-n) range (n+1:2*n)
c align workd(i) with d1(i-2*n) range (2*n+1:3*n)
c distribute d1(block), d2(block,:)
c replicated workl(lworkl)
c
c Cray MPP syntax:
c ===============
c Real resid(n), v(ldv,ncv), workd(n,3), workl(lworkl)
c shared resid(block), v(block,:), workd(block,:)
c replicated workl(lworkl)
c
c CM2/CM5 syntax:
c ==============
c
c-----------------------------------------------------------------------
c
c include 'ex-nonsym.doc'
c
c-----------------------------------------------------------------------
c
c\BeginLib
c
c\Local variables:
c xxxxxx real
c
c\References:
c 1. D.C. Sorensen, "Implicit Application of Polynomial Filters in
c a k-Step Arnoldi Method", SIAM J. Matr. Anal. Apps., 13 (1992),
c pp 357-385.
c 2. R.B. Lehoucq, "Analysis and Implementation of an Implicitly
c Restarted Arnoldi Iteration", Rice University Technical Report
c TR95-13, Department of Computational and Applied Mathematics.
c 3. B.N. Parlett & Y. Saad, "Complex Shift and Invert Strategies for
c Real Matrices", Linear Algebra and its Applications, vol 88/89,
c pp 575-595, (1987).
c
c\Routines called:
c snaup2 ARPACK routine that implements the Implicitly Restarted
c Arnoldi Iteration.
c ivout ARPACK utility routine that prints integers.
c second ARPACK utility routine for timing.
c svout ARPACK utility routine that prints vectors.
c slamch LAPACK routine that determines machine constants.
c
c\Author
c Danny Sorensen Phuong Vu
c Richard Lehoucq CRPC / Rice University
c Dept. of Computational & Houston, Texas
c Applied Mathematics
c Rice University
c Houston, Texas
c
c\Revision history:
c 12/16/93: Version '1.1'
c
c\SCCS Information: @(#)
c FILE: naupd.F SID: 2.10 DATE OF SID: 08/23/02 RELEASE: 2
c
c\Remarks
c
c\EndLib
c
c-----------------------------------------------------------------------
c
subroutine snaupd
& ( ido, bmat, n, which, nev, tol, resid, ncv, v, ldv, iparam,
& ipntr, workd, workl, lworkl, info )
c
c %----------------------------------------------------%
c | Include files for debugging and timing information |
c %----------------------------------------------------%
c
include 'debug.h'
include 'stat.h'
c
c %------------------%
c | Scalar Arguments |
c %------------------%
c
character bmat*1, which*2
integer ido, info, ldv, lworkl, n, ncv, nev
Real
& tol
c
c %-----------------%
c | Array Arguments |
c %-----------------%
c
integer iparam(11), ipntr(14)
Real
& resid(n), v(ldv,ncv), workd(3*n), workl(lworkl)
c
c %------------%
c | Parameters |
c %------------%
c
Real
& one, zero
parameter (one = 1.0E+0, zero = 0.0E+0)
c
c %---------------%
c | Local Scalars |
c %---------------%
c
integer bounds, ierr, ih, iq, ishift, iupd, iw,
& ldh, ldq, levec, mode, msglvl, mxiter, nb,
& nev0, next, np, ritzi, ritzr, j
save bounds, ih, iq, ishift, iupd, iw, ldh, ldq,
& levec, mode, msglvl, mxiter, nb, nev0, next,
& np, ritzi, ritzr
c
c %----------------------%
c | External Subroutines |
c %----------------------%
c
external snaup2, svout, ivout, second, sstatn
c
c %--------------------%
c | External Functions |
c %--------------------%
c
Real
& slamch
external slamch
c
c %-----------------------%
c | Executable Statements |
c %-----------------------%
c
if (ido .eq. 0) then
c
c %-------------------------------%
c | Initialize timing statistics |
c | & message level for debugging |
c %-------------------------------%
c
call sstatn
call second (t0)
msglvl = mnaupd
c
c %----------------%
c | Error checking |
c %----------------%
c
ierr = 0
ishift = iparam(1)
c levec = iparam(2)
mxiter = iparam(3)
c nb = iparam(4)
nb = 1
c
c %--------------------------------------------%
c | Revision 2 performs only implicit restart. |
c %--------------------------------------------%
c
iupd = 1
mode = iparam(7)
c
if (n .le. 0) then
ierr = -1
else if (nev .le. 0) then
ierr = -2
else if (ncv .le. nev+1 .or. ncv .gt. n) then
ierr = -3
else if (mxiter .le. 0) then
ierr = 4
else if (which .ne. 'LM' .and.
& which .ne. 'SM' .and.
& which .ne. 'LR' .and.
& which .ne. 'SR' .and.
& which .ne. 'LI' .and.
& which .ne. 'SI') then
ierr = -5
else if (bmat .ne. 'I' .and. bmat .ne. 'G') then
ierr = -6
else if (lworkl .lt. 3*ncv**2 + 6*ncv) then
ierr = -7
else if (mode .lt. 1 .or. mode .gt. 4) then
ierr = -10
else if (mode .eq. 1 .and. bmat .eq. 'G') then
ierr = -11
else if (ishift .lt. 0 .or. ishift .gt. 1) then
ierr = -12
end if
c
c %------------%
c | Error Exit |
c %------------%
c
if (ierr .ne. 0) then
info = ierr
ido = 99
go to 9000
end if
c
c %------------------------%
c | Set default parameters |
c %------------------------%
c
if (nb .le. 0) nb = 1
if (tol .le. zero) tol = slamch('EpsMach')
c
c %----------------------------------------------%
c | NP is the number of additional steps to |
c | extend the length NEV Lanczos factorization. |
c | NEV0 is the local variable designating the |
c | size of the invariant subspace desired. |
c %----------------------------------------------%
c
np = ncv - nev
nev0 = nev
c
c %-----------------------------%
c | Zero out internal workspace |
c %-----------------------------%
c
do 10 j = 1, 3*ncv**2 + 6*ncv
workl(j) = zero
10 continue
c
c %-------------------------------------------------------------%
c | Pointer into WORKL for address of H, RITZ, BOUNDS, Q |
c | etc... and the remaining workspace. |
c | Also update pointer to be used on output. |
c | Memory is laid out as follows: |
c | workl(1:ncv*ncv) := generated Hessenberg matrix |
c | workl(ncv*ncv+1:ncv*ncv+2*ncv) := real and imaginary |
c | parts of ritz values |
c | workl(ncv*ncv+2*ncv+1:ncv*ncv+3*ncv) := error bounds |
c | workl(ncv*ncv+3*ncv+1:2*ncv*ncv+3*ncv) := rotation matrix Q |
c | workl(2*ncv*ncv+3*ncv+1:3*ncv*ncv+6*ncv) := workspace |
c | The final workspace is needed by subroutine sneigh called |
c | by snaup2. Subroutine sneigh calls LAPACK routines for |
c | calculating eigenvalues and the last row of the eigenvector |
c | matrix. |
c %-------------------------------------------------------------%
c
ldh = ncv
ldq = ncv
ih = 1
ritzr = ih + ldh*ncv
ritzi = ritzr + ncv
bounds = ritzi + ncv
iq = bounds + ncv
iw = iq + ldq*ncv
next = iw + ncv**2 + 3*ncv
c
ipntr(4) = next
ipntr(5) = ih
ipntr(6) = ritzr
ipntr(7) = ritzi
ipntr(8) = bounds
ipntr(14) = iw
c
end if
c
c %-------------------------------------------------------%
c | Carry out the Implicitly restarted Arnoldi Iteration. |
c %-------------------------------------------------------%
c
call snaup2
& ( ido, bmat, n, which, nev0, np, tol, resid, mode, iupd,
& ishift, mxiter, v, ldv, workl(ih), ldh, workl(ritzr),
& workl(ritzi), workl(bounds), workl(iq), ldq, workl(iw),
& ipntr, workd, info )
c
c %--------------------------------------------------%
c | ido .ne. 99 implies use of reverse communication |
c | to compute operations involving OP or shifts. |
c %--------------------------------------------------%
c
if (ido .eq. 3) iparam(8) = np
if (ido .ne. 99) go to 9000
c
iparam(3) = mxiter
iparam(5) = np
iparam(9) = nopx
iparam(10) = nbx
iparam(11) = nrorth
c
c %------------------------------------%
c | Exit if there was an informational |
c | error within snaup2. |
c %------------------------------------%
c
if (info .lt. 0) go to 9000
if (info .eq. 2) info = 3
c
if (msglvl .gt. 0) then
call ivout (logfil, 1, mxiter, ndigit,
& '_naupd: Number of update iterations taken')
call ivout (logfil, 1, np, ndigit,
& '_naupd: Number of wanted "converged" Ritz values')
call svout (logfil, np, workl(ritzr), ndigit,
& '_naupd: Real part of the final Ritz values')
call svout (logfil, np, workl(ritzi), ndigit,
& '_naupd: Imaginary part of the final Ritz values')
call svout (logfil, np, workl(bounds), ndigit,
& '_naupd: Associated Ritz estimates')
end if
c
call second (t1)
tnaupd = t1 - t0
c
if (msglvl .gt. 0) then
c
c %--------------------------------------------------------%
c | Version Number & Version Date are defined in version.h |
c %--------------------------------------------------------%
c
write (6,1000)
write (6,1100) mxiter, nopx, nbx, nrorth, nitref, nrstrt,
& tmvopx, tmvbx, tnaupd, tnaup2, tnaitr, titref,
& tgetv0, tneigh, tngets, tnapps, tnconv, trvec
1000 format (//,
& 5x, '=============================================',/
& 5x, '= Nonsymmetric implicit Arnoldi update code =',/
& 5x, '= Version Number: ', ' 2.4', 21x, ' =',/
& 5x, '= Version Date: ', ' 07/31/96', 16x, ' =',/
& 5x, '=============================================',/
& 5x, '= Summary of timing statistics =',/
& 5x, '=============================================',//)
1100 format (
& 5x, 'Total number update iterations = ', i5,/
& 5x, 'Total number of OP*x operations = ', i5,/
& 5x, 'Total number of B*x operations = ', i5,/
& 5x, 'Total number of reorthogonalization steps = ', i5,/
& 5x, 'Total number of iterative refinement steps = ', i5,/
& 5x, 'Total number of restart steps = ', i5,/
& 5x, 'Total time in user OP*x operation = ', f12.6,/
& 5x, 'Total time in user B*x operation = ', f12.6,/
& 5x, 'Total time in Arnoldi update routine = ', f12.6,/
& 5x, 'Total time in naup2 routine = ', f12.6,/
& 5x, 'Total time in basic Arnoldi iteration loop = ', f12.6,/
& 5x, 'Total time in reorthogonalization phase = ', f12.6,/
& 5x, 'Total time in (re)start vector generation = ', f12.6,/
& 5x, 'Total time in Hessenberg eig. subproblem = ', f12.6,/
& 5x, 'Total time in getting the shifts = ', f12.6,/
& 5x, 'Total time in applying the shifts = ', f12.6,/
& 5x, 'Total time in convergence testing = ', f12.6,/
& 5x, 'Total time in computing final Ritz vectors = ', f12.6/)
end if
c
9000 continue
c
return
c
c %---------------%
c | End of snaupd |
c %---------------%
c
end

0
arpack/ARPACK/SRC/snaupe.f Normal file
View File

146
arpack/ARPACK/SRC/snconv.f Normal file
View File

@@ -0,0 +1,146 @@
c-----------------------------------------------------------------------
c\BeginDoc
c
c\Name: snconv
c
c\Description:
c Convergence testing for the nonsymmetric Arnoldi eigenvalue routine.
c
c\Usage:
c call snconv
c ( N, RITZR, RITZI, BOUNDS, TOL, NCONV )
c
c\Arguments
c N Integer. (INPUT)
c Number of Ritz values to check for convergence.
c
c RITZR, Real arrays of length N. (INPUT)
c RITZI Real and imaginary parts of the Ritz values to be checked
c for convergence.
c BOUNDS Real array of length N. (INPUT)
c Ritz estimates for the Ritz values in RITZR and RITZI.
c
c TOL Real scalar. (INPUT)
c Desired backward error for a Ritz value to be considered
c "converged".
c
c NCONV Integer scalar. (OUTPUT)
c Number of "converged" Ritz values.
c
c\EndDoc
c
c-----------------------------------------------------------------------
c
c\BeginLib
c
c\Local variables:
c xxxxxx real
c
c\Routines called:
c second ARPACK utility routine for timing.
c slamch LAPACK routine that determines machine constants.
c slapy2 LAPACK routine to compute sqrt(x**2+y**2) carefully.
c
c\Author
c Danny Sorensen Phuong Vu
c Richard Lehoucq CRPC / Rice University
c Dept. of Computational & Houston, Texas
c Applied Mathematics
c Rice University
c Houston, Texas
c
c\Revision history:
c xx/xx/92: Version ' 2.1'
c
c\SCCS Information: @(#)
c FILE: nconv.F SID: 2.3 DATE OF SID: 4/20/96 RELEASE: 2
c
c\Remarks
c 1. xxxx
c
c\EndLib
c
c-----------------------------------------------------------------------
c
subroutine snconv (n, ritzr, ritzi, bounds, tol, nconv)
c
c %----------------------------------------------------%
c | Include files for debugging and timing information |
c %----------------------------------------------------%
c
include 'debug.h'
include 'stat.h'
c
c %------------------%
c | Scalar Arguments |
c %------------------%
c
integer n, nconv
Real
& tol
c
c %-----------------%
c | Array Arguments |
c %-----------------%
Real
& ritzr(n), ritzi(n), bounds(n)
c
c %---------------%
c | Local Scalars |
c %---------------%
c
integer i
Real
& temp, eps23
c
c %--------------------%
c | External Functions |
c %--------------------%
c
Real
& slapy2, slamch
external slapy2, slamch
c %-----------------------%
c | Executable Statements |
c %-----------------------%
c
c %-------------------------------------------------------------%
c | Convergence test: unlike in the symmetric code, I am not |
c | using things like refined error bounds and gap condition |
c | because I don't know the exact equivalent concept. |
c | |
c | Instead the i-th Ritz value is considered "converged" when: |
c | |
c | bounds(i) .le. ( TOL * | ritz | ) |
c | |
c | for some appropriate choice of norm. |
c %-------------------------------------------------------------%
c
call second (t0)
c
c %---------------------------------%
c | Get machine dependent constant. |
c %---------------------------------%
c
eps23 = slamch('Epsilon-Machine')
eps23 = eps23**(2.0E+0 / 3.0E+0)
c
nconv = 0
do 20 i = 1, n
temp = max( eps23, slapy2( ritzr(i), ritzi(i) ) )
if (bounds(i) .le. tol*temp) nconv = nconv + 1
20 continue
c
call second (t1)
tnconv = tnconv + (t1 - t0)
c
return
c
c %---------------%
c | End of snconv |
c %---------------%
c
end

314
arpack/ARPACK/SRC/sneigh.f Normal file
View File

@@ -0,0 +1,314 @@
c-----------------------------------------------------------------------
c\BeginDoc
c
c\Name: sneigh
c
c\Description:
c Compute the eigenvalues of the current upper Hessenberg matrix
c and the corresponding Ritz estimates given the current residual norm.
c
c\Usage:
c call sneigh
c ( RNORM, N, H, LDH, RITZR, RITZI, BOUNDS, Q, LDQ, WORKL, IERR )
c
c\Arguments
c RNORM Real scalar. (INPUT)
c Residual norm corresponding to the current upper Hessenberg
c matrix H.
c
c N Integer. (INPUT)
c Size of the matrix H.
c
c H Real N by N array. (INPUT)
c H contains the current upper Hessenberg matrix.
c
c LDH Integer. (INPUT)
c Leading dimension of H exactly as declared in the calling
c program.
c
c RITZR, Real arrays of length N. (OUTPUT)
c RITZI On output, RITZR(1:N) (resp. RITZI(1:N)) contains the real
c (respectively imaginary) parts of the eigenvalues of H.
c
c BOUNDS Real array of length N. (OUTPUT)
c On output, BOUNDS contains the Ritz estimates associated with
c the eigenvalues RITZR and RITZI. This is equal to RNORM
c times the last components of the eigenvectors corresponding
c to the eigenvalues in RITZR and RITZI.
c
c Q Real N by N array. (WORKSPACE)
c Workspace needed to store the eigenvectors of H.
c
c LDQ Integer. (INPUT)
c Leading dimension of Q exactly as declared in the calling
c program.
c
c WORKL Real work array of length N**2 + 3*N. (WORKSPACE)
c Private (replicated) array on each PE or array allocated on
c the front end. This is needed to keep the full Schur form
c of H and also in the calculation of the eigenvectors of H.
c
c IERR Integer. (OUTPUT)
c Error exit flag from slaqrb or strevc.
c
c\EndDoc
c
c-----------------------------------------------------------------------
c
c\BeginLib
c
c\Local variables:
c xxxxxx real
c
c\Routines called:
c slaqrb ARPACK routine to compute the real Schur form of an
c upper Hessenberg matrix and last row of the Schur vectors.
c second ARPACK utility routine for timing.
c smout ARPACK utility routine that prints matrices
c svout ARPACK utility routine that prints vectors.
c slacpy LAPACK matrix copy routine.
c slapy2 LAPACK routine to compute sqrt(x**2+y**2) carefully.
c strevc LAPACK routine to compute the eigenvectors of a matrix
c in upper quasi-triangular form
c sgemv Level 2 BLAS routine for matrix vector multiplication.
c scopy Level 1 BLAS that copies one vector to another .
c snrm2 Level 1 BLAS that computes the norm of a vector.
c sscal Level 1 BLAS that scales a vector.
c
c
c\Author
c Danny Sorensen Phuong Vu
c Richard Lehoucq CRPC / Rice University
c Dept. of Computational & Houston, Texas
c Applied Mathematics
c Rice University
c Houston, Texas
c
c\Revision history:
c xx/xx/92: Version ' 2.1'
c
c\SCCS Information: @(#)
c FILE: neigh.F SID: 2.3 DATE OF SID: 4/20/96 RELEASE: 2
c
c\Remarks
c None
c
c\EndLib
c
c-----------------------------------------------------------------------
c
subroutine sneigh (rnorm, n, h, ldh, ritzr, ritzi, bounds,
& q, ldq, workl, ierr)
c
c %----------------------------------------------------%
c | Include files for debugging and timing information |
c %----------------------------------------------------%
c
include 'debug.h'
include 'stat.h'
c
c %------------------%
c | Scalar Arguments |
c %------------------%
c
integer ierr, n, ldh, ldq
Real
& rnorm
c
c %-----------------%
c | Array Arguments |
c %-----------------%
c
Real
& bounds(n), h(ldh,n), q(ldq,n), ritzi(n), ritzr(n),
& workl(n*(n+3))
c
c %------------%
c | Parameters |
c %------------%
c
Real
& one, zero
parameter (one = 1.0E+0, zero = 0.0E+0)
c
c %------------------------%
c | Local Scalars & Arrays |
c %------------------------%
c
logical select(1)
integer i, iconj, msglvl
Real
& temp, vl(1)
c
c %----------------------%
c | External Subroutines |
c %----------------------%
c
external scopy, slacpy, slaqrb, strevc, svout, second
c
c %--------------------%
c | External Functions |
c %--------------------%
c
Real
& slapy2, snrm2
external slapy2, snrm2
c
c %---------------------%
c | Intrinsic Functions |
c %---------------------%
c
intrinsic abs
c
c %-----------------------%
c | Executable Statements |
c %-----------------------%
c
c
c %-------------------------------%
c | Initialize timing statistics |
c | & message level for debugging |
c %-------------------------------%
c
call second (t0)
msglvl = mneigh
c
if (msglvl .gt. 2) then
call smout (logfil, n, n, h, ldh, ndigit,
& '_neigh: Entering upper Hessenberg matrix H ')
end if
c
c %-----------------------------------------------------------%
c | 1. Compute the eigenvalues, the last components of the |
c | corresponding Schur vectors and the full Schur form T |
c | of the current upper Hessenberg matrix H. |
c | slaqrb returns the full Schur form of H in WORKL(1:N**2) |
c | and the last components of the Schur vectors in BOUNDS. |
c %-----------------------------------------------------------%
c
call slacpy ('All', n, n, h, ldh, workl, n)
call slaqrb (.true., n, 1, n, workl, n, ritzr, ritzi, bounds,
& ierr)
if (ierr .ne. 0) go to 9000
c
if (msglvl .gt. 1) then
call svout (logfil, n, bounds, ndigit,
& '_neigh: last row of the Schur matrix for H')
end if
c
c %-----------------------------------------------------------%
c | 2. Compute the eigenvectors of the full Schur form T and |
c | apply the last components of the Schur vectors to get |
c | the last components of the corresponding eigenvectors. |
c | Remember that if the i-th and (i+1)-st eigenvalues are |
c | complex conjugate pairs, then the real & imaginary part |
c | of the eigenvector components are split across adjacent |
c | columns of Q. |
c %-----------------------------------------------------------%
c
call strevc ('R', 'A', select, n, workl, n, vl, n, q, ldq,
& n, n, workl(n*n+1), ierr)
c
if (ierr .ne. 0) go to 9000
c
c %------------------------------------------------%
c | Scale the returning eigenvectors so that their |
c | euclidean norms are all one. LAPACK subroutine |
c | strevc returns each eigenvector normalized so |
c | that the element of largest magnitude has |
c | magnitude 1; here the magnitude of a complex |
c | number (x,y) is taken to be |x| + |y|. |
c %------------------------------------------------%
c
iconj = 0
do 10 i=1, n
if ( abs( ritzi(i) ) .le. zero ) then
c
c %----------------------%
c | Real eigenvalue case |
c %----------------------%
c
temp = snrm2( n, q(1,i), 1 )
call sscal ( n, one / temp, q(1,i), 1 )
else
c
c %-------------------------------------------%
c | Complex conjugate pair case. Note that |
c | since the real and imaginary part of |
c | the eigenvector are stored in consecutive |
c | columns, we further normalize by the |
c | square root of two. |
c %-------------------------------------------%
c
if (iconj .eq. 0) then
temp = slapy2( snrm2( n, q(1,i), 1 ),
& snrm2( n, q(1,i+1), 1 ) )
call sscal ( n, one / temp, q(1,i), 1 )
call sscal ( n, one / temp, q(1,i+1), 1 )
iconj = 1
else
iconj = 0
end if
end if
10 continue
c
call sgemv ('T', n, n, one, q, ldq, bounds, 1, zero, workl, 1)
c
if (msglvl .gt. 1) then
call svout (logfil, n, workl, ndigit,
& '_neigh: Last row of the eigenvector matrix for H')
end if
c
c %----------------------------%
c | Compute the Ritz estimates |
c %----------------------------%
c
iconj = 0
do 20 i = 1, n
if ( abs( ritzi(i) ) .le. zero ) then
c
c %----------------------%
c | Real eigenvalue case |
c %----------------------%
c
bounds(i) = rnorm * abs( workl(i) )
else
c
c %-------------------------------------------%
c | Complex conjugate pair case. Note that |
c | since the real and imaginary part of |
c | the eigenvector are stored in consecutive |
c | columns, we need to take the magnitude |
c | of the last components of the two vectors |
c %-------------------------------------------%
c
if (iconj .eq. 0) then
bounds(i) = rnorm * slapy2( workl(i), workl(i+1) )
bounds(i+1) = bounds(i)
iconj = 1
else
iconj = 0
end if
end if
20 continue
c
if (msglvl .gt. 2) then
call svout (logfil, n, ritzr, ndigit,
& '_neigh: Real part of the eigenvalues of H')
call svout (logfil, n, ritzi, ndigit,
& '_neigh: Imaginary part of the eigenvalues of H')
call svout (logfil, n, bounds, ndigit,
& '_neigh: Ritz estimates for the eigenvalues of H')
end if
c
call second (t1)
tneigh = tneigh + (t1 - t0)
c
9000 continue
return
c
c %---------------%
c | End of sneigh |
c %---------------%
c
end

1063
arpack/ARPACK/SRC/sneupd.f Normal file
View File

File diff suppressed because it is too large Load Diff

231
arpack/ARPACK/SRC/sngets.f Normal file
View File

@@ -0,0 +1,231 @@
c-----------------------------------------------------------------------
c\BeginDoc
c
c\Name: sngets
c
c\Description:
c Given the eigenvalues of the upper Hessenberg matrix H,
c computes the NP shifts AMU that are zeros of the polynomial of
c degree NP which filters out components of the unwanted eigenvectors
c corresponding to the AMU's based on some given criteria.
c
c NOTE: call this even in the case of user specified shifts in order
c to sort the eigenvalues, and error bounds of H for later use.
c
c\Usage:
c call sngets
c ( ISHIFT, WHICH, KEV, NP, RITZR, RITZI, BOUNDS, SHIFTR, SHIFTI )
c
c\Arguments
c ISHIFT Integer. (INPUT)
c Method for selecting the implicit shifts at each iteration.
c ISHIFT = 0: user specified shifts
c ISHIFT = 1: exact shift with respect to the matrix H.
c
c WHICH Character*2. (INPUT)
c Shift selection criteria.
c 'LM' -> want the KEV eigenvalues of largest magnitude.
c 'SM' -> want the KEV eigenvalues of smallest magnitude.
c 'LR' -> want the KEV eigenvalues of largest real part.
c 'SR' -> want the KEV eigenvalues of smallest real part.
c 'LI' -> want the KEV eigenvalues of largest imaginary part.
c 'SI' -> want the KEV eigenvalues of smallest imaginary part.
c
c KEV Integer. (INPUT/OUTPUT)
c INPUT: KEV+NP is the size of the matrix H.
c OUTPUT: Possibly increases KEV by one to keep complex conjugate
c pairs together.
c
c NP Integer. (INPUT/OUTPUT)
c Number of implicit shifts to be computed.
c OUTPUT: Possibly decreases NP by one to keep complex conjugate
c pairs together.
c
c RITZR, Real array of length KEV+NP. (INPUT/OUTPUT)
c RITZI On INPUT, RITZR and RITZI contain the real and imaginary
c parts of the eigenvalues of H.
c On OUTPUT, RITZR and RITZI are sorted so that the unwanted
c eigenvalues are in the first NP locations and the wanted
c portion is in the last KEV locations. When exact shifts are
c selected, the unwanted part corresponds to the shifts to
c be applied. Also, if ISHIFT .eq. 1, the unwanted eigenvalues
c are further sorted so that the ones with largest Ritz values
c are first.
c
c BOUNDS Real array of length KEV+NP. (INPUT/OUTPUT)
c Error bounds corresponding to the ordering in RITZ.
c
c SHIFTR, SHIFTI *** USE deprecated as of version 2.1. ***
c
c
c\EndDoc
c
c-----------------------------------------------------------------------
c
c\BeginLib
c
c\Local variables:
c xxxxxx real
c
c\Routines called:
c ssortc ARPACK sorting routine.
c scopy Level 1 BLAS that copies one vector to another .
c
c\Author
c Danny Sorensen Phuong Vu
c Richard Lehoucq CRPC / Rice University
c Dept. of Computational & Houston, Texas
c Applied Mathematics
c Rice University
c Houston, Texas
c
c\Revision history:
c xx/xx/92: Version ' 2.1'
c
c\SCCS Information: @(#)
c FILE: ngets.F SID: 2.3 DATE OF SID: 4/20/96 RELEASE: 2
c
c\Remarks
c 1. xxxx
c
c\EndLib
c
c-----------------------------------------------------------------------
c
subroutine sngets ( ishift, which, kev, np, ritzr, ritzi, bounds,
& shiftr, shifti )
c
c %----------------------------------------------------%
c | Include files for debugging and timing information |
c %----------------------------------------------------%
c
include 'debug.h'
include 'stat.h'
c
c %------------------%
c | Scalar Arguments |
c %------------------%
c
character*2 which
integer ishift, kev, np
c
c %-----------------%
c | Array Arguments |
c %-----------------%
c
Real
& bounds(kev+np), ritzr(kev+np), ritzi(kev+np),
& shiftr(1), shifti(1)
c
c %------------%
c | Parameters |
c %------------%
c
Real
& one, zero
parameter (one = 1.0, zero = 0.0)
c
c %---------------%
c | Local Scalars |
c %---------------%
c
integer msglvl
c
c %----------------------%
c | External Subroutines |
c %----------------------%
c
external scopy, ssortc, second
c
c %----------------------%
c | Intrinsics Functions |
c %----------------------%
c
intrinsic abs
c
c %-----------------------%
c | Executable Statements |
c %-----------------------%
c
c %-------------------------------%
c | Initialize timing statistics |
c | & message level for debugging |
c %-------------------------------%
c
call second (t0)
msglvl = mngets
c
c %----------------------------------------------------%
c | LM, SM, LR, SR, LI, SI case. |
c | Sort the eigenvalues of H into the desired order |
c | and apply the resulting order to BOUNDS. |
c | The eigenvalues are sorted so that the wanted part |
c | are always in the last KEV locations. |
c | We first do a pre-processing sort in order to keep |
c | complex conjugate pairs together |
c %----------------------------------------------------%
c
if (which .eq. 'LM') then
call ssortc ('LR', .true., kev+np, ritzr, ritzi, bounds)
else if (which .eq. 'SM') then
call ssortc ('SR', .true., kev+np, ritzr, ritzi, bounds)
else if (which .eq. 'LR') then
call ssortc ('LM', .true., kev+np, ritzr, ritzi, bounds)
else if (which .eq. 'SR') then
call ssortc ('SM', .true., kev+np, ritzr, ritzi, bounds)
else if (which .eq. 'LI') then
call ssortc ('LM', .true., kev+np, ritzr, ritzi, bounds)
else if (which .eq. 'SI') then
call ssortc ('SM', .true., kev+np, ritzr, ritzi, bounds)
end if
c
call ssortc (which, .true., kev+np, ritzr, ritzi, bounds)
c
c %-------------------------------------------------------%
c | Increase KEV by one if the ( ritzr(np),ritzi(np) ) |
c | = ( ritzr(np+1),-ritzi(np+1) ) and ritz(np) .ne. zero |
c | Accordingly decrease NP by one. In other words keep |
c | complex conjugate pairs together. |
c %-------------------------------------------------------%
c
if ( ( ritzr(np+1) - ritzr(np) ) .eq. zero
& .and. ( ritzi(np+1) + ritzi(np) ) .eq. zero ) then
np = np - 1
kev = kev + 1
end if
c
if ( ishift .eq. 1 ) then
c
c %-------------------------------------------------------%
c | Sort the unwanted Ritz values used as shifts so that |
c | the ones with largest Ritz estimates are first |
c | This will tend to minimize the effects of the |
c | forward instability of the iteration when they shifts |
c | are applied in subroutine snapps. |
c | Be careful and use 'SR' since we want to sort BOUNDS! |
c %-------------------------------------------------------%
c
call ssortc ( 'SR', .true., np, bounds, ritzr, ritzi )
end if
c
call second (t1)
tngets = tngets + (t1 - t0)
c
if (msglvl .gt. 0) then
call ivout (logfil, 1, kev, ndigit, '_ngets: KEV is')
call ivout (logfil, 1, np, ndigit, '_ngets: NP is')
call svout (logfil, kev+np, ritzr, ndigit,
& '_ngets: Eigenvalues of current H matrix -- real part')
call svout (logfil, kev+np, ritzi, ndigit,
& '_ngets: Eigenvalues of current H matrix -- imag part')
call svout (logfil, kev+np, bounds, ndigit,
& '_ngets: Ritz estimates of the current KEV+NP Ritz values')
end if
c
return
c
c %---------------%
c | End of sngets |
c %---------------%
c
end

853
arpack/ARPACK/SRC/ssaitr.f Normal file
View File

@@ -0,0 +1,853 @@
c-----------------------------------------------------------------------
c\BeginDoc
c
c\Name: ssaitr
c
c\Description:
c Reverse communication interface for applying NP additional steps to
c a K step symmetric Arnoldi factorization.
c
c Input: OP*V_{k} - V_{k}*H = r_{k}*e_{k}^T
c
c with (V_{k}^T)*B*V_{k} = I, (V_{k}^T)*B*r_{k} = 0.
c
c Output: OP*V_{k+p} - V_{k+p}*H = r_{k+p}*e_{k+p}^T
c
c with (V_{k+p}^T)*B*V_{k+p} = I, (V_{k+p}^T)*B*r_{k+p} = 0.
c
c where OP and B are as in ssaupd. The B-norm of r_{k+p} is also
c computed and returned.
c
c\Usage:
c call ssaitr
c ( IDO, BMAT, N, K, NP, MODE, RESID, RNORM, V, LDV, H, LDH,
c IPNTR, WORKD, INFO )
c
c\Arguments
c IDO Integer. (INPUT/OUTPUT)
c Reverse communication flag.
c -------------------------------------------------------------
c IDO = 0: first call to the reverse communication interface
c IDO = -1: compute Y = OP * X where
c IPNTR(1) is the pointer into WORK for X,
c IPNTR(2) is the pointer into WORK for Y.
c This is for the restart phase to force the new
c starting vector into the range of OP.
c IDO = 1: compute Y = OP * X where
c IPNTR(1) is the pointer into WORK for X,
c IPNTR(2) is the pointer into WORK for Y,
c IPNTR(3) is the pointer into WORK for B * X.
c IDO = 2: compute Y = B * X where
c IPNTR(1) is the pointer into WORK for X,
c IPNTR(2) is the pointer into WORK for Y.
c IDO = 99: done
c -------------------------------------------------------------
c When the routine is used in the "shift-and-invert" mode, the
c vector B * Q is already available and does not need to be
c recomputed in forming OP * Q.
c
c BMAT Character*1. (INPUT)
c BMAT specifies the type of matrix B that defines the
c semi-inner product for the operator OP. See ssaupd.
c B = 'I' -> standard eigenvalue problem A*x = lambda*x
c B = 'G' -> generalized eigenvalue problem A*x = lambda*M*x
c
c N Integer. (INPUT)
c Dimension of the eigenproblem.
c
c K Integer. (INPUT)
c Current order of H and the number of columns of V.
c
c NP Integer. (INPUT)
c Number of additional Arnoldi steps to take.
c
c MODE Integer. (INPUT)
c Signifies which form for "OP". If MODE=2 then
c a reduction in the number of B matrix vector multiplies
c is possible since the B-norm of OP*x is equivalent to
c the inv(B)-norm of A*x.
c
c RESID Real array of length N. (INPUT/OUTPUT)
c On INPUT: RESID contains the residual vector r_{k}.
c On OUTPUT: RESID contains the residual vector r_{k+p}.
c
c RNORM Real scalar. (INPUT/OUTPUT)
c On INPUT the B-norm of r_{k}.
c On OUTPUT the B-norm of the updated residual r_{k+p}.
c
c V Real N by K+NP array. (INPUT/OUTPUT)
c On INPUT: V contains the Arnoldi vectors in the first K
c columns.
c On OUTPUT: V contains the new NP Arnoldi vectors in the next
c NP columns. The first K columns are unchanged.
c
c LDV Integer. (INPUT)
c Leading dimension of V exactly as declared in the calling
c program.
c
c H Real (K+NP) by 2 array. (INPUT/OUTPUT)
c H is used to store the generated symmetric tridiagonal matrix
c with the subdiagonal in the first column starting at H(2,1)
c and the main diagonal in the second column.
c
c LDH Integer. (INPUT)
c Leading dimension of H exactly as declared in the calling
c program.
c
c IPNTR Integer array of length 3. (OUTPUT)
c Pointer to mark the starting locations in the WORK for
c vectors used by the Arnoldi iteration.
c -------------------------------------------------------------
c IPNTR(1): pointer to the current operand vector X.
c IPNTR(2): pointer to the current result vector Y.
c IPNTR(3): pointer to the vector B * X when used in the
c shift-and-invert mode. X is the current operand.
c -------------------------------------------------------------
c
c WORKD Real work array of length 3*N. (REVERSE COMMUNICATION)
c Distributed array to be used in the basic Arnoldi iteration
c for reverse communication. The calling program should not
c use WORKD as temporary workspace during the iteration !!!!!!
c On INPUT, WORKD(1:N) = B*RESID where RESID is associated
c with the K step Arnoldi factorization. Used to save some
c computation at the first step.
c On OUTPUT, WORKD(1:N) = B*RESID where RESID is associated
c with the K+NP step Arnoldi factorization.
c
c INFO Integer. (OUTPUT)
c = 0: Normal exit.
c > 0: Size of an invariant subspace of OP is found that is
c less than K + NP.
c
c\EndDoc
c
c-----------------------------------------------------------------------
c
c\BeginLib
c
c\Local variables:
c xxxxxx real
c
c\Routines called:
c sgetv0 ARPACK routine to generate the initial vector.
c ivout ARPACK utility routine that prints integers.
c smout ARPACK utility routine that prints matrices.
c svout ARPACK utility routine that prints vectors.
c slamch LAPACK routine that determines machine constants.
c slascl LAPACK routine for careful scaling of a matrix.
c sgemv Level 2 BLAS routine for matrix vector multiplication.
c saxpy Level 1 BLAS that computes a vector triad.
c sscal Level 1 BLAS that scales a vector.
c scopy Level 1 BLAS that copies one vector to another .
c sdot Level 1 BLAS that computes the scalar product of two vectors.
c snrm2 Level 1 BLAS that computes the norm of a vector.
c
c\Author
c Danny Sorensen Phuong Vu
c Richard Lehoucq CRPC / Rice University
c Dept. of Computational & Houston, Texas
c Applied Mathematics
c Rice University
c Houston, Texas
c
c\Revision history:
c xx/xx/93: Version ' 2.4'
c
c\SCCS Information: @(#)
c FILE: saitr.F SID: 2.6 DATE OF SID: 8/28/96 RELEASE: 2
c
c\Remarks
c The algorithm implemented is:
c
c restart = .false.
c Given V_{k} = [v_{1}, ..., v_{k}], r_{k};
c r_{k} contains the initial residual vector even for k = 0;
c Also assume that rnorm = || B*r_{k} || and B*r_{k} are already
c computed by the calling program.
c
c betaj = rnorm ; p_{k+1} = B*r_{k} ;
c For j = k+1, ..., k+np Do
c 1) if ( betaj < tol ) stop or restart depending on j.
c if ( restart ) generate a new starting vector.
c 2) v_{j} = r(j-1)/betaj; V_{j} = [V_{j-1}, v_{j}];
c p_{j} = p_{j}/betaj
c 3) r_{j} = OP*v_{j} where OP is defined as in ssaupd
c For shift-invert mode p_{j} = B*v_{j} is already available.
c wnorm = || OP*v_{j} ||
c 4) Compute the j-th step residual vector.
c w_{j} = V_{j}^T * B * OP * v_{j}
c r_{j} = OP*v_{j} - V_{j} * w_{j}
c alphaj <- j-th component of w_{j}
c rnorm = || r_{j} ||
c betaj+1 = rnorm
c If (rnorm > 0.717*wnorm) accept step and go back to 1)
c 5) Re-orthogonalization step:
c s = V_{j}'*B*r_{j}
c r_{j} = r_{j} - V_{j}*s; rnorm1 = || r_{j} ||
c alphaj = alphaj + s_{j};
c 6) Iterative refinement step:
c If (rnorm1 > 0.717*rnorm) then
c rnorm = rnorm1
c accept step and go back to 1)
c Else
c rnorm = rnorm1
c If this is the first time in step 6), go to 5)
c Else r_{j} lies in the span of V_{j} numerically.
c Set r_{j} = 0 and rnorm = 0; go to 1)
c EndIf
c End Do
c
c\EndLib
c
c-----------------------------------------------------------------------
c
subroutine ssaitr
& (ido, bmat, n, k, np, mode, resid, rnorm, v, ldv, h, ldh,
& ipntr, workd, info)
c
c %----------------------------------------------------%
c | Include files for debugging and timing information |
c %----------------------------------------------------%
c
include 'debug.h'
include 'stat.h'
c
c %------------------%
c | Scalar Arguments |
c %------------------%
c
character bmat*1
integer ido, info, k, ldh, ldv, n, mode, np
Real
& rnorm
c
c %-----------------%
c | Array Arguments |
c %-----------------%
c
integer ipntr(3)
Real
& h(ldh,2), resid(n), v(ldv,k+np), workd(3*n)
c
c %------------%
c | Parameters |
c %------------%
c
Real
& one, zero
parameter (one = 1.0E+0, zero = 0.0E+0)
c
c %---------------%
c | Local Scalars |
c %---------------%
c
logical first, orth1, orth2, rstart, step3, step4
integer i, ierr, ipj, irj, ivj, iter, itry, j, msglvl,
& infol, jj
Real
& rnorm1, wnorm, safmin, temp1
save orth1, orth2, rstart, step3, step4,
& ierr, ipj, irj, ivj, iter, itry, j, msglvl,
& rnorm1, safmin, wnorm
c
c %-----------------------%
c | Local Array Arguments |
c %-----------------------%
c
Real
& xtemp(2)
c
c %----------------------%
c | External Subroutines |
c %----------------------%
c
external saxpy, scopy, sscal, sgemv, sgetv0, svout, smout,
& slascl, ivout, second
c
c %--------------------%
c | External Functions |
c %--------------------%
c
Real
& sdot, snrm2, slamch
external sdot, snrm2, slamch
c
c %-----------------%
c | Data statements |
c %-----------------%
c
data first / .true. /
c
c %-----------------------%
c | Executable Statements |
c %-----------------------%
c
if (first) then
first = .false.
c
c %--------------------------------%
c | safmin = safe minimum is such |
c | that 1/sfmin does not overflow |
c %--------------------------------%
c
safmin = slamch('safmin')
end if
c
if (ido .eq. 0) then
c
c %-------------------------------%
c | Initialize timing statistics |
c | & message level for debugging |
c %-------------------------------%
c
call second (t0)
msglvl = msaitr
c
c %------------------------------%
c | Initial call to this routine |
c %------------------------------%
c
info = 0
step3 = .false.
step4 = .false.
rstart = .false.
orth1 = .false.
orth2 = .false.
c
c %--------------------------------%
c | Pointer to the current step of |
c | the factorization to build |
c %--------------------------------%
c
j = k + 1
c
c %------------------------------------------%
c | Pointers used for reverse communication |
c | when using WORKD. |
c %------------------------------------------%
c
ipj = 1
irj = ipj + n
ivj = irj + n
end if
c
c %-------------------------------------------------%
c | When in reverse communication mode one of: |
c | STEP3, STEP4, ORTH1, ORTH2, RSTART |
c | will be .true. |
c | STEP3: return from computing OP*v_{j}. |
c | STEP4: return from computing B-norm of OP*v_{j} |
c | ORTH1: return from computing B-norm of r_{j+1} |
c | ORTH2: return from computing B-norm of |
c | correction to the residual vector. |
c | RSTART: return from OP computations needed by |
c | sgetv0. |
c %-------------------------------------------------%
c
if (step3) go to 50
if (step4) go to 60
if (orth1) go to 70
if (orth2) go to 90
if (rstart) go to 30
c
c %------------------------------%
c | Else this is the first step. |
c %------------------------------%
c
c %--------------------------------------------------------------%
c | |
c | A R N O L D I I T E R A T I O N L O O P |
c | |
c | Note: B*r_{j-1} is already in WORKD(1:N)=WORKD(IPJ:IPJ+N-1) |
c %--------------------------------------------------------------%
c
1000 continue
c
if (msglvl .gt. 2) then
call ivout (logfil, 1, j, ndigit,
& '_saitr: generating Arnoldi vector no.')
call svout (logfil, 1, rnorm, ndigit,
& '_saitr: B-norm of the current residual =')
end if
c
c %---------------------------------------------------------%
c | Check for exact zero. Equivalent to determing whether a |
c | j-step Arnoldi factorization is present. |
c %---------------------------------------------------------%
c
if (rnorm .gt. zero) go to 40
c
c %---------------------------------------------------%
c | Invariant subspace found, generate a new starting |
c | vector which is orthogonal to the current Arnoldi |
c | basis and continue the iteration. |
c %---------------------------------------------------%
c
if (msglvl .gt. 0) then
call ivout (logfil, 1, j, ndigit,
& '_saitr: ****** restart at step ******')
end if
c
c %---------------------------------------------%
c | ITRY is the loop variable that controls the |
c | maximum amount of times that a restart is |
c | attempted. NRSTRT is used by stat.h |
c %---------------------------------------------%
c
nrstrt = nrstrt + 1
itry = 1
20 continue
rstart = .true.
ido = 0
30 continue
c
c %--------------------------------------%
c | If in reverse communication mode and |
c | RSTART = .true. flow returns here. |
c %--------------------------------------%
c
call sgetv0 (ido, bmat, itry, .false., n, j, v, ldv,
& resid, rnorm, ipntr, workd, ierr)
if (ido .ne. 99) go to 9000
if (ierr .lt. 0) then
itry = itry + 1
if (itry .le. 3) go to 20
c
c %------------------------------------------------%
c | Give up after several restart attempts. |
c | Set INFO to the size of the invariant subspace |
c | which spans OP and exit. |
c %------------------------------------------------%
c
info = j - 1
call second (t1)
tsaitr = tsaitr + (t1 - t0)
ido = 99
go to 9000
end if
c
40 continue
c
c %---------------------------------------------------------%
c | STEP 2: v_{j} = r_{j-1}/rnorm and p_{j} = p_{j}/rnorm |
c | Note that p_{j} = B*r_{j-1}. In order to avoid overflow |
c | when reciprocating a small RNORM, test against lower |
c | machine bound. |
c %---------------------------------------------------------%
c
call scopy (n, resid, 1, v(1,j), 1)
if (rnorm .ge. safmin) then
temp1 = one / rnorm
call sscal (n, temp1, v(1,j), 1)
call sscal (n, temp1, workd(ipj), 1)
else
c
c %-----------------------------------------%
c | To scale both v_{j} and p_{j} carefully |
c | use LAPACK routine SLASCL |
c %-----------------------------------------%
c
call slascl ('General', i, i, rnorm, one, n, 1,
& v(1,j), n, infol)
call slascl ('General', i, i, rnorm, one, n, 1,
& workd(ipj), n, infol)
end if
c
c %------------------------------------------------------%
c | STEP 3: r_{j} = OP*v_{j}; Note that p_{j} = B*v_{j} |
c | Note that this is not quite yet r_{j}. See STEP 4 |
c %------------------------------------------------------%
c
step3 = .true.
nopx = nopx + 1
call second (t2)
call scopy (n, v(1,j), 1, workd(ivj), 1)
ipntr(1) = ivj
ipntr(2) = irj
ipntr(3) = ipj
ido = 1
c
c %-----------------------------------%
c | Exit in order to compute OP*v_{j} |
c %-----------------------------------%
c
go to 9000
50 continue
c
c %-----------------------------------%
c | Back from reverse communication; |
c | WORKD(IRJ:IRJ+N-1) := OP*v_{j}. |
c %-----------------------------------%
c
call second (t3)
tmvopx = tmvopx + (t3 - t2)
c
step3 = .false.
c
c %------------------------------------------%
c | Put another copy of OP*v_{j} into RESID. |
c %------------------------------------------%
c
call scopy (n, workd(irj), 1, resid, 1)
c
c %-------------------------------------------%
c | STEP 4: Finish extending the symmetric |
c | Arnoldi to length j. If MODE = 2 |
c | then B*OP = B*inv(B)*A = A and |
c | we don't need to compute B*OP. |
c | NOTE: If MODE = 2 WORKD(IVJ:IVJ+N-1) is |
c | assumed to have A*v_{j}. |
c %-------------------------------------------%
c
if (mode .eq. 2) go to 65
call second (t2)
if (bmat .eq. 'G') then
nbx = nbx + 1
step4 = .true.
ipntr(1) = irj
ipntr(2) = ipj
ido = 2
c
c %-------------------------------------%
c | Exit in order to compute B*OP*v_{j} |
c %-------------------------------------%
c
go to 9000
else if (bmat .eq. 'I') then
call scopy(n, resid, 1 , workd(ipj), 1)
end if
60 continue
c
c %-----------------------------------%
c | Back from reverse communication; |
c | WORKD(IPJ:IPJ+N-1) := B*OP*v_{j}. |
c %-----------------------------------%
c
if (bmat .eq. 'G') then
call second (t3)
tmvbx = tmvbx + (t3 - t2)
end if
c
step4 = .false.
c
c %-------------------------------------%
c | The following is needed for STEP 5. |
c | Compute the B-norm of OP*v_{j}. |
c %-------------------------------------%
c
65 continue
if (mode .eq. 2) then
c
c %----------------------------------%
c | Note that the B-norm of OP*v_{j} |
c | is the inv(B)-norm of A*v_{j}. |
c %----------------------------------%
c
wnorm = sdot (n, resid, 1, workd(ivj), 1)
wnorm = sqrt(abs(wnorm))
else if (bmat .eq. 'G') then
wnorm = sdot (n, resid, 1, workd(ipj), 1)
wnorm = sqrt(abs(wnorm))
else if (bmat .eq. 'I') then
wnorm = snrm2(n, resid, 1)
end if
c
c %-----------------------------------------%
c | Compute the j-th residual corresponding |
c | to the j step factorization. |
c | Use Classical Gram Schmidt and compute: |
c | w_{j} <- V_{j}^T * B * OP * v_{j} |
c | r_{j} <- OP*v_{j} - V_{j} * w_{j} |
c %-----------------------------------------%
c
c
c %------------------------------------------%
c | Compute the j Fourier coefficients w_{j} |
c | WORKD(IPJ:IPJ+N-1) contains B*OP*v_{j}. |
c %------------------------------------------%
c
if (mode .ne. 2 ) then
call sgemv('T', n, j, one, v, ldv, workd(ipj), 1, zero,
& workd(irj), 1)
else if (mode .eq. 2) then
call sgemv('T', n, j, one, v, ldv, workd(ivj), 1, zero,
& workd(irj), 1)
end if
c
c %--------------------------------------%
c | Orthgonalize r_{j} against V_{j}. |
c | RESID contains OP*v_{j}. See STEP 3. |
c %--------------------------------------%
c
call sgemv('N', n, j, -one, v, ldv, workd(irj), 1, one,
& resid, 1)
c
c %--------------------------------------%
c | Extend H to have j rows and columns. |
c %--------------------------------------%
c
h(j,2) = workd(irj + j - 1)
if (j .eq. 1 .or. rstart) then
h(j,1) = zero
else
h(j,1) = rnorm
end if
call second (t4)
c
orth1 = .true.
iter = 0
c
call second (t2)
if (bmat .eq. 'G') then
nbx = nbx + 1
call scopy (n, resid, 1, workd(irj), 1)
ipntr(1) = irj
ipntr(2) = ipj
ido = 2
c
c %----------------------------------%
c | Exit in order to compute B*r_{j} |
c %----------------------------------%
c
go to 9000
else if (bmat .eq. 'I') then
call scopy (n, resid, 1, workd(ipj), 1)
end if
70 continue
c
c %---------------------------------------------------%
c | Back from reverse communication if ORTH1 = .true. |
c | WORKD(IPJ:IPJ+N-1) := B*r_{j}. |
c %---------------------------------------------------%
c
if (bmat .eq. 'G') then
call second (t3)
tmvbx = tmvbx + (t3 - t2)
end if
c
orth1 = .false.
c
c %------------------------------%
c | Compute the B-norm of r_{j}. |
c %------------------------------%
c
if (bmat .eq. 'G') then
rnorm = sdot (n, resid, 1, workd(ipj), 1)
rnorm = sqrt(abs(rnorm))
else if (bmat .eq. 'I') then
rnorm = snrm2(n, resid, 1)
end if
c
c %-----------------------------------------------------------%
c | STEP 5: Re-orthogonalization / Iterative refinement phase |
c | Maximum NITER_ITREF tries. |
c | |
c | s = V_{j}^T * B * r_{j} |
c | r_{j} = r_{j} - V_{j}*s |
c | alphaj = alphaj + s_{j} |
c | |
c | The stopping criteria used for iterative refinement is |
c | discussed in Parlett's book SEP, page 107 and in Gragg & |
c | Reichel ACM TOMS paper; Algorithm 686, Dec. 1990. |
c | Determine if we need to correct the residual. The goal is |
c | to enforce ||v(:,1:j)^T * r_{j}|| .le. eps * || r_{j} || |
c %-----------------------------------------------------------%
c
if (rnorm .gt. 0.717*wnorm) go to 100
nrorth = nrorth + 1
c
c %---------------------------------------------------%
c | Enter the Iterative refinement phase. If further |
c | refinement is necessary, loop back here. The loop |
c | variable is ITER. Perform a step of Classical |
c | Gram-Schmidt using all the Arnoldi vectors V_{j} |
c %---------------------------------------------------%
c
80 continue
c
if (msglvl .gt. 2) then
xtemp(1) = wnorm
xtemp(2) = rnorm
call svout (logfil, 2, xtemp, ndigit,
& '_saitr: re-orthonalization ; wnorm and rnorm are')
end if
c
c %----------------------------------------------------%
c | Compute V_{j}^T * B * r_{j}. |
c | WORKD(IRJ:IRJ+J-1) = v(:,1:J)'*WORKD(IPJ:IPJ+N-1). |
c %----------------------------------------------------%
c
call sgemv ('T', n, j, one, v, ldv, workd(ipj), 1,
& zero, workd(irj), 1)
c
c %----------------------------------------------%
c | Compute the correction to the residual: |
c | r_{j} = r_{j} - V_{j} * WORKD(IRJ:IRJ+J-1). |
c | The correction to H is v(:,1:J)*H(1:J,1:J) + |
c | v(:,1:J)*WORKD(IRJ:IRJ+J-1)*e'_j, but only |
c | H(j,j) is updated. |
c %----------------------------------------------%
c
call sgemv ('N', n, j, -one, v, ldv, workd(irj), 1,
& one, resid, 1)
c
if (j .eq. 1 .or. rstart) h(j,1) = zero
h(j,2) = h(j,2) + workd(irj + j - 1)
c
orth2 = .true.
call second (t2)
if (bmat .eq. 'G') then
nbx = nbx + 1
call scopy (n, resid, 1, workd(irj), 1)
ipntr(1) = irj
ipntr(2) = ipj
ido = 2
c
c %-----------------------------------%
c | Exit in order to compute B*r_{j}. |
c | r_{j} is the corrected residual. |
c %-----------------------------------%
c
go to 9000
else if (bmat .eq. 'I') then
call scopy (n, resid, 1, workd(ipj), 1)
end if
90 continue
c
c %---------------------------------------------------%
c | Back from reverse communication if ORTH2 = .true. |
c %---------------------------------------------------%
c
if (bmat .eq. 'G') then
call second (t3)
tmvbx = tmvbx + (t3 - t2)
end if
c
c %-----------------------------------------------------%
c | Compute the B-norm of the corrected residual r_{j}. |
c %-----------------------------------------------------%
c
if (bmat .eq. 'G') then
rnorm1 = sdot (n, resid, 1, workd(ipj), 1)
rnorm1 = sqrt(abs(rnorm1))
else if (bmat .eq. 'I') then
rnorm1 = snrm2(n, resid, 1)
end if
c
if (msglvl .gt. 0 .and. iter .gt. 0) then
call ivout (logfil, 1, j, ndigit,
& '_saitr: Iterative refinement for Arnoldi residual')
if (msglvl .gt. 2) then
xtemp(1) = rnorm
xtemp(2) = rnorm1
call svout (logfil, 2, xtemp, ndigit,
& '_saitr: iterative refinement ; rnorm and rnorm1 are')
end if
end if
c
c %-----------------------------------------%
c | Determine if we need to perform another |
c | step of re-orthogonalization. |
c %-----------------------------------------%
c
if (rnorm1 .gt. 0.717*rnorm) then
c
c %--------------------------------%
c | No need for further refinement |
c %--------------------------------%
c
rnorm = rnorm1
c
else
c
c %-------------------------------------------%
c | Another step of iterative refinement step |
c | is required. NITREF is used by stat.h |
c %-------------------------------------------%
c
nitref = nitref + 1
rnorm = rnorm1
iter = iter + 1
if (iter .le. 1) go to 80
c
c %-------------------------------------------------%
c | Otherwise RESID is numerically in the span of V |
c %-------------------------------------------------%
c
do 95 jj = 1, n
resid(jj) = zero
95 continue
rnorm = zero
end if
c
c %----------------------------------------------%
c | Branch here directly if iterative refinement |
c | wasn't necessary or after at most NITER_REF |
c | steps of iterative refinement. |
c %----------------------------------------------%
c
100 continue
c
rstart = .false.
orth2 = .false.
c
call second (t5)
titref = titref + (t5 - t4)
c
c %----------------------------------------------------------%
c | Make sure the last off-diagonal element is non negative |
c | If not perform a similarity transformation on H(1:j,1:j) |
c | and scale v(:,j) by -1. |
c %----------------------------------------------------------%
c
if (h(j,1) .lt. zero) then
h(j,1) = -h(j,1)
if ( j .lt. k+np) then
call sscal(n, -one, v(1,j+1), 1)
else
call sscal(n, -one, resid, 1)
end if
end if
c
c %------------------------------------%
c | STEP 6: Update j = j+1; Continue |
c %------------------------------------%
c
j = j + 1
if (j .gt. k+np) then
call second (t1)
tsaitr = tsaitr + (t1 - t0)
ido = 99
c
if (msglvl .gt. 1) then
call svout (logfil, k+np, h(1,2), ndigit,
& '_saitr: main diagonal of matrix H of step K+NP.')
if (k+np .gt. 1) then
call svout (logfil, k+np-1, h(2,1), ndigit,
& '_saitr: sub diagonal of matrix H of step K+NP.')
end if
end if
c
go to 9000
end if
c
c %--------------------------------------------------------%
c | Loop back to extend the factorization by another step. |
c %--------------------------------------------------------%
c
go to 1000
c
c %---------------------------------------------------------------%
c | |
c | E N D O F M A I N I T E R A T I O N L O O P |
c | |
c %---------------------------------------------------------------%
c
9000 continue
return
c
c %---------------%
c | End of ssaitr |
c %---------------%
c
end

516
arpack/ARPACK/SRC/ssapps.f Normal file
View File

@@ -0,0 +1,516 @@
c-----------------------------------------------------------------------
c\BeginDoc
c
c\Name: ssapps
c
c\Description:
c Given the Arnoldi factorization
c
c A*V_{k} - V_{k}*H_{k} = r_{k+p}*e_{k+p}^T,
c
c apply NP shifts implicitly resulting in
c
c A*(V_{k}*Q) - (V_{k}*Q)*(Q^T* H_{k}*Q) = r_{k+p}*e_{k+p}^T * Q
c
c where Q is an orthogonal matrix of order KEV+NP. Q is the product of
c rotations resulting from the NP bulge chasing sweeps. The updated Arnoldi
c factorization becomes:
c
c A*VNEW_{k} - VNEW_{k}*HNEW_{k} = rnew_{k}*e_{k}^T.
c
c\Usage:
c call ssapps
c ( N, KEV, NP, SHIFT, V, LDV, H, LDH, RESID, Q, LDQ, WORKD )
c
c\Arguments
c N Integer. (INPUT)
c Problem size, i.e. dimension of matrix A.
c
c KEV Integer. (INPUT)
c INPUT: KEV+NP is the size of the input matrix H.
c OUTPUT: KEV is the size of the updated matrix HNEW.
c
c NP Integer. (INPUT)
c Number of implicit shifts to be applied.
c
c SHIFT Real array of length NP. (INPUT)
c The shifts to be applied.
c
c V Real N by (KEV+NP) array. (INPUT/OUTPUT)
c INPUT: V contains the current KEV+NP Arnoldi vectors.
c OUTPUT: VNEW = V(1:n,1:KEV); the updated Arnoldi vectors
c are in the first KEV columns of V.
c
c LDV Integer. (INPUT)
c Leading dimension of V exactly as declared in the calling
c program.
c
c H Real (KEV+NP) by 2 array. (INPUT/OUTPUT)
c INPUT: H contains the symmetric tridiagonal matrix of the
c Arnoldi factorization with the subdiagonal in the 1st column
c starting at H(2,1) and the main diagonal in the 2nd column.
c OUTPUT: H contains the updated tridiagonal matrix in the
c KEV leading submatrix.
c
c LDH Integer. (INPUT)
c Leading dimension of H exactly as declared in the calling
c program.
c
c RESID Real array of length (N). (INPUT/OUTPUT)
c INPUT: RESID contains the the residual vector r_{k+p}.
c OUTPUT: RESID is the updated residual vector rnew_{k}.
c
c Q Real KEV+NP by KEV+NP work array. (WORKSPACE)
c Work array used to accumulate the rotations during the bulge
c chase sweep.
c
c LDQ Integer. (INPUT)
c Leading dimension of Q exactly as declared in the calling
c program.
c
c WORKD Real work array of length 2*N. (WORKSPACE)
c Distributed array used in the application of the accumulated
c orthogonal matrix Q.
c
c\EndDoc
c
c-----------------------------------------------------------------------
c
c\BeginLib
c
c\Local variables:
c xxxxxx real
c
c\References:
c 1. D.C. Sorensen, "Implicit Application of Polynomial Filters in
c a k-Step Arnoldi Method", SIAM J. Matr. Anal. Apps., 13 (1992),
c pp 357-385.
c 2. R.B. Lehoucq, "Analysis and Implementation of an Implicitly
c Restarted Arnoldi Iteration", Rice University Technical Report
c TR95-13, Department of Computational and Applied Mathematics.
c
c\Routines called:
c ivout ARPACK utility routine that prints integers.
c second ARPACK utility routine for timing.
c svout ARPACK utility routine that prints vectors.
c slamch LAPACK routine that determines machine constants.
c slartg LAPACK Givens rotation construction routine.
c slacpy LAPACK matrix copy routine.
c slaset LAPACK matrix initialization routine.
c sgemv Level 2 BLAS routine for matrix vector multiplication.
c saxpy Level 1 BLAS that computes a vector triad.
c scopy Level 1 BLAS that copies one vector to another.
c sscal Level 1 BLAS that scales a vector.
c
c\Author
c Danny Sorensen Phuong Vu
c Richard Lehoucq CRPC / Rice University
c Dept. of Computational & Houston, Texas
c Applied Mathematics
c Rice University
c Houston, Texas
c
c\Revision history:
c 12/16/93: Version ' 2.4'
c
c\SCCS Information: @(#)
c FILE: sapps.F SID: 2.6 DATE OF SID: 3/28/97 RELEASE: 2
c
c\Remarks
c 1. In this version, each shift is applied to all the subblocks of
c the tridiagonal matrix H and not just to the submatrix that it
c comes from. This routine assumes that the subdiagonal elements
c of H that are stored in h(1:kev+np,1) are nonegative upon input
c and enforce this condition upon output. This version incorporates
c deflation. See code for documentation.
c
c\EndLib
c
c-----------------------------------------------------------------------
c
subroutine ssapps
& ( n, kev, np, shift, v, ldv, h, ldh, resid, q, ldq, workd )
c
c %----------------------------------------------------%
c | Include files for debugging and timing information |
c %----------------------------------------------------%
c
include 'debug.h'
include 'stat.h'
c
c %------------------%
c | Scalar Arguments |
c %------------------%
c
integer kev, ldh, ldq, ldv, n, np
c
c %-----------------%
c | Array Arguments |
c %-----------------%
c
Real
& h(ldh,2), q(ldq,kev+np), resid(n), shift(np),
& v(ldv,kev+np), workd(2*n)
c
c %------------%
c | Parameters |
c %------------%
c
Real
& one, zero
parameter (one = 1.0E+0, zero = 0.0E+0)
c
c %---------------%
c | Local Scalars |
c %---------------%
c
integer i, iend, istart, itop, j, jj, kplusp, msglvl
logical first
Real
& a1, a2, a3, a4, big, c, epsmch, f, g, r, s
save epsmch, first
c
c
c %----------------------%
c | External Subroutines |
c %----------------------%
c
external saxpy, scopy, sscal, slacpy, slartg, slaset, svout,
& ivout, second, sgemv
c
c %--------------------%
c | External Functions |
c %--------------------%
c
Real
& slamch
external slamch
c
c %----------------------%
c | Intrinsics Functions |
c %----------------------%
c
intrinsic abs
c
c %----------------%
c | Data statments |
c %----------------%
c
data first / .true. /
c
c %-----------------------%
c | Executable Statements |
c %-----------------------%
c
if (first) then
epsmch = slamch('Epsilon-Machine')
first = .false.
end if
itop = 1
c
c %-------------------------------%
c | Initialize timing statistics |
c | & message level for debugging |
c %-------------------------------%
c
call second (t0)
msglvl = msapps
c
kplusp = kev + np
c
c %----------------------------------------------%
c | Initialize Q to the identity matrix of order |
c | kplusp used to accumulate the rotations. |
c %----------------------------------------------%
c
call slaset ('All', kplusp, kplusp, zero, one, q, ldq)
c
c %----------------------------------------------%
c | Quick return if there are no shifts to apply |
c %----------------------------------------------%
c
if (np .eq. 0) go to 9000
c
c %----------------------------------------------------------%
c | Apply the np shifts implicitly. Apply each shift to the |
c | whole matrix and not just to the submatrix from which it |
c | comes. |
c %----------------------------------------------------------%
c
do 90 jj = 1, np
c
istart = itop
c
c %----------------------------------------------------------%
c | Check for splitting and deflation. Currently we consider |
c | an off-diagonal element h(i+1,1) negligible if |
c | h(i+1,1) .le. epsmch*( |h(i,2)| + |h(i+1,2)| ) |
c | for i=1:KEV+NP-1. |
c | If above condition tests true then we set h(i+1,1) = 0. |
c | Note that h(1:KEV+NP,1) are assumed to be non negative. |
c %----------------------------------------------------------%
c
20 continue
c
c %------------------------------------------------%
c | The following loop exits early if we encounter |
c | a negligible off diagonal element. |
c %------------------------------------------------%
c
do 30 i = istart, kplusp-1
big = abs(h(i,2)) + abs(h(i+1,2))
if (h(i+1,1) .le. epsmch*big) then
if (msglvl .gt. 0) then
call ivout (logfil, 1, i, ndigit,
& '_sapps: deflation at row/column no.')
call ivout (logfil, 1, jj, ndigit,
& '_sapps: occured before shift number.')
call svout (logfil, 1, h(i+1,1), ndigit,
& '_sapps: the corresponding off diagonal element')
end if
h(i+1,1) = zero
iend = i
go to 40
end if
30 continue
iend = kplusp
40 continue
c
if (istart .lt. iend) then
c
c %--------------------------------------------------------%
c | Construct the plane rotation G'(istart,istart+1,theta) |
c | that attempts to drive h(istart+1,1) to zero. |
c %--------------------------------------------------------%
c
f = h(istart,2) - shift(jj)
g = h(istart+1,1)
call slartg (f, g, c, s, r)
c
c %-------------------------------------------------------%
c | Apply rotation to the left and right of H; |
c | H <- G' * H * G, where G = G(istart,istart+1,theta). |
c | This will create a "bulge". |
c %-------------------------------------------------------%
c
a1 = c*h(istart,2) + s*h(istart+1,1)
a2 = c*h(istart+1,1) + s*h(istart+1,2)
a4 = c*h(istart+1,2) - s*h(istart+1,1)
a3 = c*h(istart+1,1) - s*h(istart,2)
h(istart,2) = c*a1 + s*a2
h(istart+1,2) = c*a4 - s*a3
h(istart+1,1) = c*a3 + s*a4
c
c %----------------------------------------------------%
c | Accumulate the rotation in the matrix Q; Q <- Q*G |
c %----------------------------------------------------%
c
do 60 j = 1, min(istart+jj,kplusp)
a1 = c*q(j,istart) + s*q(j,istart+1)
q(j,istart+1) = - s*q(j,istart) + c*q(j,istart+1)
q(j,istart) = a1
60 continue
c
c
c %----------------------------------------------%
c | The following loop chases the bulge created. |
c | Note that the previous rotation may also be |
c | done within the following loop. But it is |
c | kept separate to make the distinction among |
c | the bulge chasing sweeps and the first plane |
c | rotation designed to drive h(istart+1,1) to |
c | zero. |
c %----------------------------------------------%
c
do 70 i = istart+1, iend-1
c
c %----------------------------------------------%
c | Construct the plane rotation G'(i,i+1,theta) |
c | that zeros the i-th bulge that was created |
c | by G(i-1,i,theta). g represents the bulge. |
c %----------------------------------------------%
c
f = h(i,1)
g = s*h(i+1,1)
c
c %----------------------------------%
c | Final update with G(i-1,i,theta) |
c %----------------------------------%
c
h(i+1,1) = c*h(i+1,1)
call slartg (f, g, c, s, r)
c
c %-------------------------------------------%
c | The following ensures that h(1:iend-1,1), |
c | the first iend-2 off diagonal of elements |
c | H, remain non negative. |
c %-------------------------------------------%
c
if (r .lt. zero) then
r = -r
c = -c
s = -s
end if
c
c %--------------------------------------------%
c | Apply rotation to the left and right of H; |
c | H <- G * H * G', where G = G(i,i+1,theta) |
c %--------------------------------------------%
c
h(i,1) = r
c
a1 = c*h(i,2) + s*h(i+1,1)
a2 = c*h(i+1,1) + s*h(i+1,2)
a3 = c*h(i+1,1) - s*h(i,2)
a4 = c*h(i+1,2) - s*h(i+1,1)
c
h(i,2) = c*a1 + s*a2
h(i+1,2) = c*a4 - s*a3
h(i+1,1) = c*a3 + s*a4
c
c %----------------------------------------------------%
c | Accumulate the rotation in the matrix Q; Q <- Q*G |
c %----------------------------------------------------%
c
do 50 j = 1, min( i+jj, kplusp )
a1 = c*q(j,i) + s*q(j,i+1)
q(j,i+1) = - s*q(j,i) + c*q(j,i+1)
q(j,i) = a1
50 continue
c
70 continue
c
end if
c
c %--------------------------%
c | Update the block pointer |
c %--------------------------%
c
istart = iend + 1
c
c %------------------------------------------%
c | Make sure that h(iend,1) is non-negative |
c | If not then set h(iend,1) <-- -h(iend,1) |
c | and negate the last column of Q. |
c | We have effectively carried out a |
c | similarity on transformation H |
c %------------------------------------------%
c
if (h(iend,1) .lt. zero) then
h(iend,1) = -h(iend,1)
call sscal(kplusp, -one, q(1,iend), 1)
end if
c
c %--------------------------------------------------------%
c | Apply the same shift to the next block if there is any |
c %--------------------------------------------------------%
c
if (iend .lt. kplusp) go to 20
c
c %-----------------------------------------------------%
c | Check if we can increase the the start of the block |
c %-----------------------------------------------------%
c
do 80 i = itop, kplusp-1
if (h(i+1,1) .gt. zero) go to 90
itop = itop + 1
80 continue
c
c %-----------------------------------%
c | Finished applying the jj-th shift |
c %-----------------------------------%
c
90 continue
c
c %------------------------------------------%
c | All shifts have been applied. Check for |
c | more possible deflation that might occur |
c | after the last shift is applied. |
c %------------------------------------------%
c
do 100 i = itop, kplusp-1
big = abs(h(i,2)) + abs(h(i+1,2))
if (h(i+1,1) .le. epsmch*big) then
if (msglvl .gt. 0) then
call ivout (logfil, 1, i, ndigit,
& '_sapps: deflation at row/column no.')
call svout (logfil, 1, h(i+1,1), ndigit,
& '_sapps: the corresponding off diagonal element')
end if
h(i+1,1) = zero
end if
100 continue
c
c %-------------------------------------------------%
c | Compute the (kev+1)-st column of (V*Q) and |
c | temporarily store the result in WORKD(N+1:2*N). |
c | This is not necessary if h(kev+1,1) = 0. |
c %-------------------------------------------------%
c
if ( h(kev+1,1) .gt. zero )
& call sgemv ('N', n, kplusp, one, v, ldv,
& q(1,kev+1), 1, zero, workd(n+1), 1)
c
c %-------------------------------------------------------%
c | Compute column 1 to kev of (V*Q) in backward order |
c | taking advantage that Q is an upper triangular matrix |
c | with lower bandwidth np. |
c | Place results in v(:,kplusp-kev:kplusp) temporarily. |
c %-------------------------------------------------------%
c
do 130 i = 1, kev
call sgemv ('N', n, kplusp-i+1, one, v, ldv,
& q(1,kev-i+1), 1, zero, workd, 1)
call scopy (n, workd, 1, v(1,kplusp-i+1), 1)
130 continue
c
c %-------------------------------------------------%
c | Move v(:,kplusp-kev+1:kplusp) into v(:,1:kev). |
c %-------------------------------------------------%
c
call slacpy ('All', n, kev, v(1,np+1), ldv, v, ldv)
c
c %--------------------------------------------%
c | Copy the (kev+1)-st column of (V*Q) in the |
c | appropriate place if h(kev+1,1) .ne. zero. |
c %--------------------------------------------%
c
if ( h(kev+1,1) .gt. zero )
& call scopy (n, workd(n+1), 1, v(1,kev+1), 1)
c
c %-------------------------------------%
c | Update the residual vector: |
c | r <- sigmak*r + betak*v(:,kev+1) |
c | where |
c | sigmak = (e_{kev+p}'*Q)*e_{kev} |
c | betak = e_{kev+1}'*H*e_{kev} |
c %-------------------------------------%
c
call sscal (n, q(kplusp,kev), resid, 1)
if (h(kev+1,1) .gt. zero)
& call saxpy (n, h(kev+1,1), v(1,kev+1), 1, resid, 1)
c
if (msglvl .gt. 1) then
call svout (logfil, 1, q(kplusp,kev), ndigit,
& '_sapps: sigmak of the updated residual vector')
call svout (logfil, 1, h(kev+1,1), ndigit,
& '_sapps: betak of the updated residual vector')
call svout (logfil, kev, h(1,2), ndigit,
& '_sapps: updated main diagonal of H for next iteration')
if (kev .gt. 1) then
call svout (logfil, kev-1, h(2,1), ndigit,
& '_sapps: updated sub diagonal of H for next iteration')
end if
end if
c
call second (t1)
tsapps = tsapps + (t1 - t0)
c
9000 continue
return
c
c %---------------%
c | End of ssapps |
c %---------------%
c
end

850
arpack/ARPACK/SRC/ssaup2.f Normal file
View File

@@ -0,0 +1,850 @@
c-----------------------------------------------------------------------
c\BeginDoc
c
c\Name: ssaup2
c
c\Description:
c Intermediate level interface called by ssaupd.
c
c\Usage:
c call ssaup2
c ( IDO, BMAT, N, WHICH, NEV, NP, TOL, RESID, MODE, IUPD,
c ISHIFT, MXITER, V, LDV, H, LDH, RITZ, BOUNDS, Q, LDQ, WORKL,
c IPNTR, WORKD, INFO )
c
c\Arguments
c
c IDO, BMAT, N, WHICH, NEV, TOL, RESID: same as defined in ssaupd.
c MODE, ISHIFT, MXITER: see the definition of IPARAM in ssaupd.
c
c NP Integer. (INPUT/OUTPUT)
c Contains the number of implicit shifts to apply during
c each Arnoldi/Lanczos iteration.
c If ISHIFT=1, NP is adjusted dynamically at each iteration
c to accelerate convergence and prevent stagnation.
c This is also roughly equal to the number of matrix-vector
c products (involving the operator OP) per Arnoldi iteration.
c The logic for adjusting is contained within the current
c subroutine.
c If ISHIFT=0, NP is the number of shifts the user needs
c to provide via reverse comunication. 0 < NP < NCV-NEV.
c NP may be less than NCV-NEV since a leading block of the current
c upper Tridiagonal matrix has split off and contains "unwanted"
c Ritz values.
c Upon termination of the IRA iteration, NP contains the number
c of "converged" wanted Ritz values.
c
c IUPD Integer. (INPUT)
c IUPD .EQ. 0: use explicit restart instead implicit update.
c IUPD .NE. 0: use implicit update.
c
c V Real N by (NEV+NP) array. (INPUT/OUTPUT)
c The Lanczos basis vectors.
c
c LDV Integer. (INPUT)
c Leading dimension of V exactly as declared in the calling
c program.
c
c H Real (NEV+NP) by 2 array. (OUTPUT)
c H is used to store the generated symmetric tridiagonal matrix
c The subdiagonal is stored in the first column of H starting
c at H(2,1). The main diagonal is stored in the second column
c of H starting at H(1,2). If ssaup2 converges store the
c B-norm of the final residual vector in H(1,1).
c
c LDH Integer. (INPUT)
c Leading dimension of H exactly as declared in the calling
c program.
c
c RITZ Real array of length NEV+NP. (OUTPUT)
c RITZ(1:NEV) contains the computed Ritz values of OP.
c
c BOUNDS Real array of length NEV+NP. (OUTPUT)
c BOUNDS(1:NEV) contain the error bounds corresponding to RITZ.
c
c Q Real (NEV+NP) by (NEV+NP) array. (WORKSPACE)
c Private (replicated) work array used to accumulate the
c rotation in the shift application step.
c
c LDQ Integer. (INPUT)
c Leading dimension of Q exactly as declared in the calling
c program.
c
c WORKL Real array of length at least 3*(NEV+NP). (INPUT/WORKSPACE)
c Private (replicated) array on each PE or array allocated on
c the front end. It is used in the computation of the
c tridiagonal eigenvalue problem, the calculation and
c application of the shifts and convergence checking.
c If ISHIFT .EQ. O and IDO .EQ. 3, the first NP locations
c of WORKL are used in reverse communication to hold the user
c supplied shifts.
c
c IPNTR Integer array of length 3. (OUTPUT)
c Pointer to mark the starting locations in the WORKD for
c vectors used by the Lanczos iteration.
c -------------------------------------------------------------
c IPNTR(1): pointer to the current operand vector X.
c IPNTR(2): pointer to the current result vector Y.
c IPNTR(3): pointer to the vector B * X when used in one of
c the spectral transformation modes. X is the current
c operand.
c -------------------------------------------------------------
c
c WORKD Real work array of length 3*N. (REVERSE COMMUNICATION)
c Distributed array to be used in the basic Lanczos iteration
c for reverse communication. The user should not use WORKD
c as temporary workspace during the iteration !!!!!!!!!!
c See Data Distribution Note in ssaupd.
c
c INFO Integer. (INPUT/OUTPUT)
c If INFO .EQ. 0, a randomly initial residual vector is used.
c If INFO .NE. 0, RESID contains the initial residual vector,
c possibly from a previous run.
c Error flag on output.
c = 0: Normal return.
c = 1: All possible eigenvalues of OP has been found.
c NP returns the size of the invariant subspace
c spanning the operator OP.
c = 2: No shifts could be applied.
c = -8: Error return from trid. eigenvalue calculation;
c This should never happen.
c = -9: Starting vector is zero.
c = -9999: Could not build an Lanczos factorization.
c Size that was built in returned in NP.
c
c\EndDoc
c
c-----------------------------------------------------------------------
c
c\BeginLib
c
c\References:
c 1. D.C. Sorensen, "Implicit Application of Polynomial Filters in
c a k-Step Arnoldi Method", SIAM J. Matr. Anal. Apps., 13 (1992),
c pp 357-385.
c 2. R.B. Lehoucq, "Analysis and Implementation of an Implicitly
c Restarted Arnoldi Iteration", Rice University Technical Report
c TR95-13, Department of Computational and Applied Mathematics.
c 3. B.N. Parlett, "The Symmetric Eigenvalue Problem". Prentice-Hall,
c 1980.
c 4. B.N. Parlett, B. Nour-Omid, "Towards a Black Box Lanczos Program",
c Computer Physics Communications, 53 (1989), pp 169-179.
c 5. B. Nour-Omid, B.N. Parlett, T. Ericson, P.S. Jensen, "How to
c Implement the Spectral Transformation", Math. Comp., 48 (1987),
c pp 663-673.
c 6. R.G. Grimes, J.G. Lewis and H.D. Simon, "A Shifted Block Lanczos
c Algorithm for Solving Sparse Symmetric Generalized Eigenproblems",
c SIAM J. Matr. Anal. Apps., January (1993).
c 7. L. Reichel, W.B. Gragg, "Algorithm 686: FORTRAN Subroutines
c for Updating the QR decomposition", ACM TOMS, December 1990,
c Volume 16 Number 4, pp 369-377.
c
c\Routines called:
c sgetv0 ARPACK initial vector generation routine.
c ssaitr ARPACK Lanczos factorization routine.
c ssapps ARPACK application of implicit shifts routine.
c ssconv ARPACK convergence of Ritz values routine.
c sseigt ARPACK compute Ritz values and error bounds routine.
c ssgets ARPACK reorder Ritz values and error bounds routine.
c ssortr ARPACK sorting routine.
c ivout ARPACK utility routine that prints integers.
c second ARPACK utility routine for timing.
c svout ARPACK utility routine that prints vectors.
c slamch LAPACK routine that determines machine constants.
c scopy Level 1 BLAS that copies one vector to another.
c sdot Level 1 BLAS that computes the scalar product of two vectors.
c snrm2 Level 1 BLAS that computes the norm of a vector.
c sscal Level 1 BLAS that scales a vector.
c sswap Level 1 BLAS that swaps two vectors.
c
c\Author
c Danny Sorensen Phuong Vu
c Richard Lehoucq CRPC / Rice University
c Dept. of Computational & Houston, Texas
c Applied Mathematics
c Rice University
c Houston, Texas
c
c\Revision history:
c 12/15/93: Version ' 2.4'
c xx/xx/95: Version ' 2.4'. (R.B. Lehoucq)
c
c\SCCS Information: @(#)
c FILE: saup2.F SID: 2.7 DATE OF SID: 5/19/98 RELEASE: 2
c
c\EndLib
c
c-----------------------------------------------------------------------
c
subroutine ssaup2
& ( ido, bmat, n, which, nev, np, tol, resid, mode, iupd,
& ishift, mxiter, v, ldv, h, ldh, ritz, bounds,
& q, ldq, workl, ipntr, workd, info )
c
c %----------------------------------------------------%
c | Include files for debugging and timing information |
c %----------------------------------------------------%
c
include 'debug.h'
include 'stat.h'
c
c %------------------%
c | Scalar Arguments |
c %------------------%
c
character bmat*1, which*2
integer ido, info, ishift, iupd, ldh, ldq, ldv, mxiter,
& n, mode, nev, np
Real
& tol
c
c %-----------------%
c | Array Arguments |
c %-----------------%
c
integer ipntr(3)
Real
& bounds(nev+np), h(ldh,2), q(ldq,nev+np), resid(n),
& ritz(nev+np), v(ldv,nev+np), workd(3*n),
& workl(3*(nev+np))
c
c %------------%
c | Parameters |
c %------------%
c
Real
& one, zero
parameter (one = 1.0E+0, zero = 0.0E+0)
c
c %---------------%
c | Local Scalars |
c %---------------%
c
character wprime*2
logical cnorm, getv0, initv, update, ushift
integer ierr, iter, j, kplusp, msglvl, nconv, nevbef, nev0,
& np0, nptemp, nevd2, nevm2, kp(3)
Real
& rnorm, temp, eps23
save cnorm, getv0, initv, update, ushift,
& iter, kplusp, msglvl, nconv, nev0, np0,
& rnorm, eps23
c
c %----------------------%
c | External Subroutines |
c %----------------------%
c
external scopy, sgetv0, ssaitr, sscal, ssconv, sseigt, ssgets,
& ssapps, ssortr, svout, ivout, second, sswap
c
c %--------------------%
c | External Functions |
c %--------------------%
c
Real
& sdot, snrm2, slamch
external sdot, snrm2, slamch
c
c %---------------------%
c | Intrinsic Functions |
c %---------------------%
c
intrinsic min
c
c %-----------------------%
c | Executable Statements |
c %-----------------------%
c
if (ido .eq. 0) then
c
c %-------------------------------%
c | Initialize timing statistics |
c | & message level for debugging |
c %-------------------------------%
c
call second (t0)
msglvl = msaup2
c
c %---------------------------------%
c | Set machine dependent constant. |
c %---------------------------------%
c
eps23 = slamch('Epsilon-Machine')
eps23 = eps23**(2.0E+0/3.0E+0)
c
c %-------------------------------------%
c | nev0 and np0 are integer variables |
c | hold the initial values of NEV & NP |
c %-------------------------------------%
c
nev0 = nev
np0 = np
c
c %-------------------------------------%
c | kplusp is the bound on the largest |
c | Lanczos factorization built. |
c | nconv is the current number of |
c | "converged" eigenvlues. |
c | iter is the counter on the current |
c | iteration step. |
c %-------------------------------------%
c
kplusp = nev0 + np0
nconv = 0
iter = 0
c
c %--------------------------------------------%
c | Set flags for computing the first NEV steps |
c | of the Lanczos factorization. |
c %--------------------------------------------%
c
getv0 = .true.
update = .false.
ushift = .false.
cnorm = .false.
c
if (info .ne. 0) then
c
c %--------------------------------------------%
c | User provides the initial residual vector. |
c %--------------------------------------------%
c
initv = .true.
info = 0
else
initv = .false.
end if
end if
c
c %---------------------------------------------%
c | Get a possibly random starting vector and |
c | force it into the range of the operator OP. |
c %---------------------------------------------%
c
10 continue
c
if (getv0) then
call sgetv0 (ido, bmat, 1, initv, n, 1, v, ldv, resid, rnorm,
& ipntr, workd, info)
c
if (ido .ne. 99) go to 9000
c
if (rnorm .eq. zero) then
c
c %-----------------------------------------%
c | The initial vector is zero. Error exit. |
c %-----------------------------------------%
c
info = -9
go to 1200
end if
getv0 = .false.
ido = 0
end if
c
c %------------------------------------------------------------%
c | Back from reverse communication: continue with update step |
c %------------------------------------------------------------%
c
if (update) go to 20
c
c %-------------------------------------------%
c | Back from computing user specified shifts |
c %-------------------------------------------%
c
if (ushift) go to 50
c
c %-------------------------------------%
c | Back from computing residual norm |
c | at the end of the current iteration |
c %-------------------------------------%
c
if (cnorm) go to 100
c
c %----------------------------------------------------------%
c | Compute the first NEV steps of the Lanczos factorization |
c %----------------------------------------------------------%
c
call ssaitr (ido, bmat, n, 0, nev0, mode, resid, rnorm, v, ldv,
& h, ldh, ipntr, workd, info)
c
c %---------------------------------------------------%
c | ido .ne. 99 implies use of reverse communication |
c | to compute operations involving OP and possibly B |
c %---------------------------------------------------%
c
if (ido .ne. 99) go to 9000
c
if (info .gt. 0) then
c
c %-----------------------------------------------------%
c | ssaitr was unable to build an Lanczos factorization |
c | of length NEV0. INFO is returned with the size of |
c | the factorization built. Exit main loop. |
c %-----------------------------------------------------%
c
np = info
mxiter = iter
info = -9999
go to 1200
end if
c
c %--------------------------------------------------------------%
c | |
c | M A I N LANCZOS I T E R A T I O N L O O P |
c | Each iteration implicitly restarts the Lanczos |
c | factorization in place. |
c | |
c %--------------------------------------------------------------%
c
1000 continue
c
iter = iter + 1
c
if (msglvl .gt. 0) then
call ivout (logfil, 1, iter, ndigit,
& '_saup2: **** Start of major iteration number ****')
end if
if (msglvl .gt. 1) then
call ivout (logfil, 1, nev, ndigit,
& '_saup2: The length of the current Lanczos factorization')
call ivout (logfil, 1, np, ndigit,
& '_saup2: Extend the Lanczos factorization by')
end if
c
c %------------------------------------------------------------%
c | Compute NP additional steps of the Lanczos factorization. |
c %------------------------------------------------------------%
c
ido = 0
20 continue
update = .true.
c
call ssaitr (ido, bmat, n, nev, np, mode, resid, rnorm, v,
& ldv, h, ldh, ipntr, workd, info)
c
c %---------------------------------------------------%
c | ido .ne. 99 implies use of reverse communication |
c | to compute operations involving OP and possibly B |
c %---------------------------------------------------%
c
if (ido .ne. 99) go to 9000
c
if (info .gt. 0) then
c
c %-----------------------------------------------------%
c | ssaitr was unable to build an Lanczos factorization |
c | of length NEV0+NP0. INFO is returned with the size |
c | of the factorization built. Exit main loop. |
c %-----------------------------------------------------%
c
np = info
mxiter = iter
info = -9999
go to 1200
end if
update = .false.
c
if (msglvl .gt. 1) then
call svout (logfil, 1, rnorm, ndigit,
& '_saup2: Current B-norm of residual for factorization')
end if
c
c %--------------------------------------------------------%
c | Compute the eigenvalues and corresponding error bounds |
c | of the current symmetric tridiagonal matrix. |
c %--------------------------------------------------------%
c
call sseigt (rnorm, kplusp, h, ldh, ritz, bounds, workl, ierr)
c
if (ierr .ne. 0) then
info = -8
go to 1200
end if
c
c %----------------------------------------------------%
c | Make a copy of eigenvalues and corresponding error |
c | bounds obtained from _seigt. |
c %----------------------------------------------------%
c
call scopy(kplusp, ritz, 1, workl(kplusp+1), 1)
call scopy(kplusp, bounds, 1, workl(2*kplusp+1), 1)
c
c %---------------------------------------------------%
c | Select the wanted Ritz values and their bounds |
c | to be used in the convergence test. |
c | The selection is based on the requested number of |
c | eigenvalues instead of the current NEV and NP to |
c | prevent possible misconvergence. |
c | * Wanted Ritz values := RITZ(NP+1:NEV+NP) |
c | * Shifts := RITZ(1:NP) := WORKL(1:NP) |
c %---------------------------------------------------%
c
nev = nev0
np = np0
call ssgets (ishift, which, nev, np, ritz, bounds, workl)
c
c %-------------------%
c | Convergence test. |
c %-------------------%
c
call scopy (nev, bounds(np+1), 1, workl(np+1), 1)
call ssconv (nev, ritz(np+1), workl(np+1), tol, nconv)
c
if (msglvl .gt. 2) then
kp(1) = nev
kp(2) = np
kp(3) = nconv
call ivout (logfil, 3, kp, ndigit,
& '_saup2: NEV, NP, NCONV are')
call svout (logfil, kplusp, ritz, ndigit,
& '_saup2: The eigenvalues of H')
call svout (logfil, kplusp, bounds, ndigit,
& '_saup2: Ritz estimates of the current NCV Ritz values')
end if
c
c %---------------------------------------------------------%
c | Count the number of unwanted Ritz values that have zero |
c | Ritz estimates. If any Ritz estimates are equal to zero |
c | then a leading block of H of order equal to at least |
c | the number of Ritz values with zero Ritz estimates has |
c | split off. None of these Ritz values may be removed by |
c | shifting. Decrease NP the number of shifts to apply. If |
c | no shifts may be applied, then prepare to exit |
c %---------------------------------------------------------%
c
nptemp = np
do 30 j=1, nptemp
if (bounds(j) .eq. zero) then
np = np - 1
nev = nev + 1
end if
30 continue
c
if ( (nconv .ge. nev0) .or.
& (iter .gt. mxiter) .or.
& (np .eq. 0) ) then
c
c %------------------------------------------------%
c | Prepare to exit. Put the converged Ritz values |
c | and corresponding bounds in RITZ(1:NCONV) and |
c | BOUNDS(1:NCONV) respectively. Then sort. Be |
c | careful when NCONV > NP since we don't want to |
c | swap overlapping locations. |
c %------------------------------------------------%
c
if (which .eq. 'BE') then
c
c %-----------------------------------------------------%
c | Both ends of the spectrum are requested. |
c | Sort the eigenvalues into algebraically decreasing |
c | order first then swap low end of the spectrum next |
c | to high end in appropriate locations. |
c | NOTE: when np < floor(nev/2) be careful not to swap |
c | overlapping locations. |
c %-----------------------------------------------------%
c
wprime = 'SA'
call ssortr (wprime, .true., kplusp, ritz, bounds)
nevd2 = nev0 / 2
nevm2 = nev0 - nevd2
if ( nev .gt. 1 ) then
call sswap ( min(nevd2,np), ritz(nevm2+1), 1,
& ritz( max(kplusp-nevd2+1,kplusp-np+1) ), 1)
call sswap ( min(nevd2,np), bounds(nevm2+1), 1,
& bounds( max(kplusp-nevd2+1,kplusp-np+1)), 1)
end if
c
else
c
c %--------------------------------------------------%
c | LM, SM, LA, SA case. |
c | Sort the eigenvalues of H into the an order that |
c | is opposite to WHICH, and apply the resulting |
c | order to BOUNDS. The eigenvalues are sorted so |
c | that the wanted part are always within the first |
c | NEV locations. |
c %--------------------------------------------------%
c
if (which .eq. 'LM') wprime = 'SM'
if (which .eq. 'SM') wprime = 'LM'
if (which .eq. 'LA') wprime = 'SA'
if (which .eq. 'SA') wprime = 'LA'
c
call ssortr (wprime, .true., kplusp, ritz, bounds)
c
end if
c
c %--------------------------------------------------%
c | Scale the Ritz estimate of each Ritz value |
c | by 1 / max(eps23,magnitude of the Ritz value). |
c %--------------------------------------------------%
c
do 35 j = 1, nev0
temp = max( eps23, abs(ritz(j)) )
bounds(j) = bounds(j)/temp
35 continue
c
c %----------------------------------------------------%
c | Sort the Ritz values according to the scaled Ritz |
c | esitmates. This will push all the converged ones |
c | towards the front of ritzr, ritzi, bounds |
c | (in the case when NCONV < NEV.) |
c %----------------------------------------------------%
c
wprime = 'LA'
call ssortr(wprime, .true., nev0, bounds, ritz)
c
c %----------------------------------------------%
c | Scale the Ritz estimate back to its original |
c | value. |
c %----------------------------------------------%
c
do 40 j = 1, nev0
temp = max( eps23, abs(ritz(j)) )
bounds(j) = bounds(j)*temp
40 continue
c
c %--------------------------------------------------%
c | Sort the "converged" Ritz values again so that |
c | the "threshold" values and their associated Ritz |
c | estimates appear at the appropriate position in |
c | ritz and bound. |
c %--------------------------------------------------%
c
if (which .eq. 'BE') then
c
c %------------------------------------------------%
c | Sort the "converged" Ritz values in increasing |
c | order. The "threshold" values are in the |
c | middle. |
c %------------------------------------------------%
c
wprime = 'LA'
call ssortr(wprime, .true., nconv, ritz, bounds)
c
else
c
c %----------------------------------------------%
c | In LM, SM, LA, SA case, sort the "converged" |
c | Ritz values according to WHICH so that the |
c | "threshold" value appears at the front of |
c | ritz. |
c %----------------------------------------------%
call ssortr(which, .true., nconv, ritz, bounds)
c
end if
c
c %------------------------------------------%
c | Use h( 1,1 ) as storage to communicate |
c | rnorm to _seupd if needed |
c %------------------------------------------%
c
h(1,1) = rnorm
c
if (msglvl .gt. 1) then
call svout (logfil, kplusp, ritz, ndigit,
& '_saup2: Sorted Ritz values.')
call svout (logfil, kplusp, bounds, ndigit,
& '_saup2: Sorted ritz estimates.')
end if
c
c %------------------------------------%
c | Max iterations have been exceeded. |
c %------------------------------------%
c
if (iter .gt. mxiter .and. nconv .lt. nev) info = 1
c
c %---------------------%
c | No shifts to apply. |
c %---------------------%
c
if (np .eq. 0 .and. nconv .lt. nev0) info = 2
c
np = nconv
go to 1100
c
else if (nconv .lt. nev .and. ishift .eq. 1) then
c
c %---------------------------------------------------%
c | Do not have all the requested eigenvalues yet. |
c | To prevent possible stagnation, adjust the number |
c | of Ritz values and the shifts. |
c %---------------------------------------------------%
c
nevbef = nev
nev = nev + min (nconv, np/2)
if (nev .eq. 1 .and. kplusp .ge. 6) then
nev = kplusp / 2
else if (nev .eq. 1 .and. kplusp .gt. 2) then
nev = 2
end if
np = kplusp - nev
c
c %---------------------------------------%
c | If the size of NEV was just increased |
c | resort the eigenvalues. |
c %---------------------------------------%
c
if (nevbef .lt. nev)
& call ssgets (ishift, which, nev, np, ritz, bounds,
& workl)
c
end if
c
if (msglvl .gt. 0) then
call ivout (logfil, 1, nconv, ndigit,
& '_saup2: no. of "converged" Ritz values at this iter.')
if (msglvl .gt. 1) then
kp(1) = nev
kp(2) = np
call ivout (logfil, 2, kp, ndigit,
& '_saup2: NEV and NP are')
call svout (logfil, nev, ritz(np+1), ndigit,
& '_saup2: "wanted" Ritz values.')
call svout (logfil, nev, bounds(np+1), ndigit,
& '_saup2: Ritz estimates of the "wanted" values ')
end if
end if
c
if (ishift .eq. 0) then
c
c %-----------------------------------------------------%
c | User specified shifts: reverse communication to |
c | compute the shifts. They are returned in the first |
c | NP locations of WORKL. |
c %-----------------------------------------------------%
c
ushift = .true.
ido = 3
go to 9000
end if
c
50 continue
c
c %------------------------------------%
c | Back from reverse communication; |
c | User specified shifts are returned |
c | in WORKL(1:*NP) |
c %------------------------------------%
c
ushift = .false.
c
c
c %---------------------------------------------------------%
c | Move the NP shifts to the first NP locations of RITZ to |
c | free up WORKL. This is for the non-exact shift case; |
c | in the exact shift case, ssgets already handles this. |
c %---------------------------------------------------------%
c
if (ishift .eq. 0) call scopy (np, workl, 1, ritz, 1)
c
if (msglvl .gt. 2) then
call ivout (logfil, 1, np, ndigit,
& '_saup2: The number of shifts to apply ')
call svout (logfil, np, workl, ndigit,
& '_saup2: shifts selected')
if (ishift .eq. 1) then
call svout (logfil, np, bounds, ndigit,
& '_saup2: corresponding Ritz estimates')
end if
end if
c
c %---------------------------------------------------------%
c | Apply the NP0 implicit shifts by QR bulge chasing. |
c | Each shift is applied to the entire tridiagonal matrix. |
c | The first 2*N locations of WORKD are used as workspace. |
c | After ssapps is done, we have a Lanczos |
c | factorization of length NEV. |
c %---------------------------------------------------------%
c
call ssapps (n, nev, np, ritz, v, ldv, h, ldh, resid, q, ldq,
& workd)
c
c %---------------------------------------------%
c | Compute the B-norm of the updated residual. |
c | Keep B*RESID in WORKD(1:N) to be used in |
c | the first step of the next call to ssaitr. |
c %---------------------------------------------%
c
cnorm = .true.
call second (t2)
if (bmat .eq. 'G') then
nbx = nbx + 1
call scopy (n, resid, 1, workd(n+1), 1)
ipntr(1) = n + 1
ipntr(2) = 1
ido = 2
c
c %----------------------------------%
c | Exit in order to compute B*RESID |
c %----------------------------------%
c
go to 9000
else if (bmat .eq. 'I') then
call scopy (n, resid, 1, workd, 1)
end if
c
100 continue
c
c %----------------------------------%
c | Back from reverse communication; |
c | WORKD(1:N) := B*RESID |
c %----------------------------------%
c
if (bmat .eq. 'G') then
call second (t3)
tmvbx = tmvbx + (t3 - t2)
end if
c
if (bmat .eq. 'G') then
rnorm = sdot (n, resid, 1, workd, 1)
rnorm = sqrt(abs(rnorm))
else if (bmat .eq. 'I') then
rnorm = snrm2(n, resid, 1)
end if
cnorm = .false.
130 continue
c
if (msglvl .gt. 2) then
call svout (logfil, 1, rnorm, ndigit,
& '_saup2: B-norm of residual for NEV factorization')
call svout (logfil, nev, h(1,2), ndigit,
& '_saup2: main diagonal of compressed H matrix')
call svout (logfil, nev-1, h(2,1), ndigit,
& '_saup2: subdiagonal of compressed H matrix')
end if
c
go to 1000
c
c %---------------------------------------------------------------%
c | |
c | E N D O F M A I N I T E R A T I O N L O O P |
c | |
c %---------------------------------------------------------------%
c
1100 continue
c
mxiter = iter
nev = nconv
c
1200 continue
ido = 99
c
c %------------%
c | Error exit |
c %------------%
c
call second (t1)
tsaup2 = t1 - t0
c
9000 continue
return
c
c %---------------%
c | End of ssaup2 |
c %---------------%
c
end

690
arpack/ARPACK/SRC/ssaupd.f Normal file
View File

@@ -0,0 +1,690 @@
c-----------------------------------------------------------------------
c\BeginDoc
c
c\Name: ssaupd
c
c\Description:
c
c Reverse communication interface for the Implicitly Restarted Arnoldi
c Iteration. For symmetric problems this reduces to a variant of the Lanczos
c method. This method has been designed to compute approximations to a
c few eigenpairs of a linear operator OP that is real and symmetric
c with respect to a real positive semi-definite symmetric matrix B,
c i.e.
c
c B*OP = (OP`)*B.
c
c Another way to express this condition is
c
c < x,OPy > = < OPx,y > where < z,w > = z`Bw .
c
c In the standard eigenproblem B is the identity matrix.
c ( A` denotes transpose of A)
c
c The computed approximate eigenvalues are called Ritz values and
c the corresponding approximate eigenvectors are called Ritz vectors.
c
c ssaupd is usually called iteratively to solve one of the
c following problems:
c
c Mode 1: A*x = lambda*x, A symmetric
c ===> OP = A and B = I.
c
c Mode 2: A*x = lambda*M*x, A symmetric, M symmetric positive definite
c ===> OP = inv[M]*A and B = M.
c ===> (If M can be factored see remark 3 below)
c
c Mode 3: K*x = lambda*M*x, K symmetric, M symmetric positive semi-definite
c ===> OP = (inv[K - sigma*M])*M and B = M.
c ===> Shift-and-Invert mode
c
c Mode 4: K*x = lambda*KG*x, K symmetric positive semi-definite,
c KG symmetric indefinite
c ===> OP = (inv[K - sigma*KG])*K and B = K.
c ===> Buckling mode
c
c Mode 5: A*x = lambda*M*x, A symmetric, M symmetric positive semi-definite
c ===> OP = inv[A - sigma*M]*[A + sigma*M] and B = M.
c ===> Cayley transformed mode
c
c NOTE: The action of w <- inv[A - sigma*M]*v or w <- inv[M]*v
c should be accomplished either by a direct method
c using a sparse matrix factorization and solving
c
c [A - sigma*M]*w = v or M*w = v,
c
c or through an iterative method for solving these
c systems. If an iterative method is used, the
c convergence test must be more stringent than
c the accuracy requirements for the eigenvalue
c approximations.
c
c\Usage:
c call ssaupd
c ( IDO, BMAT, N, WHICH, NEV, TOL, RESID, NCV, V, LDV, IPARAM,
c IPNTR, WORKD, WORKL, LWORKL, INFO )
c
c\Arguments
c IDO Integer. (INPUT/OUTPUT)
c Reverse communication flag. IDO must be zero on the first
c call to ssaupd. IDO will be set internally to
c indicate the type of operation to be performed. Control is
c then given back to the calling routine which has the
c responsibility to carry out the requested operation and call
c ssaupd with the result. The operand is given in
c WORKD(IPNTR(1)), the result must be put in WORKD(IPNTR(2)).
c (If Mode = 2 see remark 5 below)
c -------------------------------------------------------------
c IDO = 0: first call to the reverse communication interface
c IDO = -1: compute Y = OP * X where
c IPNTR(1) is the pointer into WORKD for X,
c IPNTR(2) is the pointer into WORKD for Y.
c This is for the initialization phase to force the
c starting vector into the range of OP.
c IDO = 1: compute Y = OP * X where
c IPNTR(1) is the pointer into WORKD for X,
c IPNTR(2) is the pointer into WORKD for Y.
c In mode 3,4 and 5, the vector B * X is already
c available in WORKD(ipntr(3)). It does not
c need to be recomputed in forming OP * X.
c IDO = 2: compute Y = B * X where
c IPNTR(1) is the pointer into WORKD for X,
c IPNTR(2) is the pointer into WORKD for Y.
c IDO = 3: compute the IPARAM(8) shifts where
c IPNTR(11) is the pointer into WORKL for
c placing the shifts. See remark 6 below.
c IDO = 99: done
c -------------------------------------------------------------
c
c BMAT Character*1. (INPUT)
c BMAT specifies the type of the matrix B that defines the
c semi-inner product for the operator OP.
c B = 'I' -> standard eigenvalue problem A*x = lambda*x
c B = 'G' -> generalized eigenvalue problem A*x = lambda*B*x
c
c N Integer. (INPUT)
c Dimension of the eigenproblem.
c
c WHICH Character*2. (INPUT)
c Specify which of the Ritz values of OP to compute.
c
c 'LA' - compute the NEV largest (algebraic) eigenvalues.
c 'SA' - compute the NEV smallest (algebraic) eigenvalues.
c 'LM' - compute the NEV largest (in magnitude) eigenvalues.
c 'SM' - compute the NEV smallest (in magnitude) eigenvalues.
c 'BE' - compute NEV eigenvalues, half from each end of the
c spectrum. When NEV is odd, compute one more from the
c high end than from the low end.
c (see remark 1 below)
c
c NEV Integer. (INPUT)
c Number of eigenvalues of OP to be computed. 0 < NEV < N.
c
c TOL Real scalar. (INPUT)
c Stopping criterion: the relative accuracy of the Ritz value
c is considered acceptable if BOUNDS(I) .LE. TOL*ABS(RITZ(I)).
c If TOL .LE. 0. is passed a default is set:
c DEFAULT = SLAMCH('EPS') (machine precision as computed
c by the LAPACK auxiliary subroutine SLAMCH).
c
c RESID Real array of length N. (INPUT/OUTPUT)
c On INPUT:
c If INFO .EQ. 0, a random initial residual vector is used.
c If INFO .NE. 0, RESID contains the initial residual vector,
c possibly from a previous run.
c On OUTPUT:
c RESID contains the final residual vector.
c
c NCV Integer. (INPUT)
c Number of columns of the matrix V (less than or equal to N).
c This will indicate how many Lanczos vectors are generated
c at each iteration. After the startup phase in which NEV
c Lanczos vectors are generated, the algorithm generates
c NCV-NEV Lanczos vectors at each subsequent update iteration.
c Most of the cost in generating each Lanczos vector is in the
c matrix-vector product OP*x. (See remark 4 below).
c
c V Real N by NCV array. (OUTPUT)
c The NCV columns of V contain the Lanczos basis vectors.
c
c LDV Integer. (INPUT)
c Leading dimension of V exactly as declared in the calling
c program.
c
c IPARAM Integer array of length 11. (INPUT/OUTPUT)
c IPARAM(1) = ISHIFT: method for selecting the implicit shifts.
c The shifts selected at each iteration are used to restart
c the Arnoldi iteration in an implicit fashion.
c -------------------------------------------------------------
c ISHIFT = 0: the shifts are provided by the user via
c reverse communication. The NCV eigenvalues of
c the current tridiagonal matrix T are returned in
c the part of WORKL array corresponding to RITZ.
c See remark 6 below.
c ISHIFT = 1: exact shifts with respect to the reduced
c tridiagonal matrix T. This is equivalent to
c restarting the iteration with a starting vector
c that is a linear combination of Ritz vectors
c associated with the "wanted" Ritz values.
c -------------------------------------------------------------
c
c IPARAM(2) = LEVEC
c No longer referenced. See remark 2 below.
c
c IPARAM(3) = MXITER
c On INPUT: maximum number of Arnoldi update iterations allowed.
c On OUTPUT: actual number of Arnoldi update iterations taken.
c
c IPARAM(4) = NB: blocksize to be used in the recurrence.
c The code currently works only for NB = 1.
c
c IPARAM(5) = NCONV: number of "converged" Ritz values.
c This represents the number of Ritz values that satisfy
c the convergence criterion.
c
c IPARAM(6) = IUPD
c No longer referenced. Implicit restarting is ALWAYS used.
c
c IPARAM(7) = MODE
c On INPUT determines what type of eigenproblem is being solved.
c Must be 1,2,3,4,5; See under \Description of ssaupd for the
c five modes available.
c
c IPARAM(8) = NP
c When ido = 3 and the user provides shifts through reverse
c communication (IPARAM(1)=0), ssaupd returns NP, the number
c of shifts the user is to provide. 0 < NP <=NCV-NEV. See Remark
c 6 below.
c
c IPARAM(9) = NUMOP, IPARAM(10) = NUMOPB, IPARAM(11) = NUMREO,
c OUTPUT: NUMOP = total number of OP*x operations,
c NUMOPB = total number of B*x operations if BMAT='G',
c NUMREO = total number of steps of re-orthogonalization.
c
c IPNTR Integer array of length 11. (OUTPUT)
c Pointer to mark the starting locations in the WORKD and WORKL
c arrays for matrices/vectors used by the Lanczos iteration.
c -------------------------------------------------------------
c IPNTR(1): pointer to the current operand vector X in WORKD.
c IPNTR(2): pointer to the current result vector Y in WORKD.
c IPNTR(3): pointer to the vector B * X in WORKD when used in
c the shift-and-invert mode.
c IPNTR(4): pointer to the next available location in WORKL
c that is untouched by the program.
c IPNTR(5): pointer to the NCV by 2 tridiagonal matrix T in WORKL.
c IPNTR(6): pointer to the NCV RITZ values array in WORKL.
c IPNTR(7): pointer to the Ritz estimates in array WORKL associated
c with the Ritz values located in RITZ in WORKL.
c IPNTR(11): pointer to the NP shifts in WORKL. See Remark 6 below.
c
c Note: IPNTR(8:10) is only referenced by sseupd. See Remark 2.
c IPNTR(8): pointer to the NCV RITZ values of the original system.
c IPNTR(9): pointer to the NCV corresponding error bounds.
c IPNTR(10): pointer to the NCV by NCV matrix of eigenvectors
c of the tridiagonal matrix T. Only referenced by
c sseupd if RVEC = .TRUE. See Remarks.
c -------------------------------------------------------------
c
c WORKD Real work array of length 3*N. (REVERSE COMMUNICATION)
c Distributed array to be used in the basic Arnoldi iteration
c for reverse communication. The user should not use WORKD
c as temporary workspace during the iteration. Upon termination
c WORKD(1:N) contains B*RESID(1:N). If the Ritz vectors are desired
c subroutine sseupd uses this output.
c See Data Distribution Note below.
c
c WORKL Real work array of length LWORKL. (OUTPUT/WORKSPACE)
c Private (replicated) array on each PE or array allocated on
c the front end. See Data Distribution Note below.
c
c LWORKL Integer. (INPUT)
c LWORKL must be at least NCV**2 + 8*NCV .
c
c INFO Integer. (INPUT/OUTPUT)
c If INFO .EQ. 0, a randomly initial residual vector is used.
c If INFO .NE. 0, RESID contains the initial residual vector,
c possibly from a previous run.
c Error flag on output.
c = 0: Normal exit.
c = 1: Maximum number of iterations taken.
c All possible eigenvalues of OP has been found. IPARAM(5)
c returns the number of wanted converged Ritz values.
c = 2: No longer an informational error. Deprecated starting
c with release 2 of ARPACK.
c = 3: No shifts could be applied during a cycle of the
c Implicitly restarted Arnoldi iteration. One possibility
c is to increase the size of NCV relative to NEV.
c See remark 4 below.
c = -1: N must be positive.
c = -2: NEV must be positive.
c = -3: NCV must be greater than NEV and less than or equal to N.
c = -4: The maximum number of Arnoldi update iterations allowed
c must be greater than zero.
c = -5: WHICH must be one of 'LM', 'SM', 'LA', 'SA' or 'BE'.
c = -6: BMAT must be one of 'I' or 'G'.
c = -7: Length of private work array WORKL is not sufficient.
c = -8: Error return from trid. eigenvalue calculation;
c Informatinal error from LAPACK routine ssteqr.
c = -9: Starting vector is zero.
c = -10: IPARAM(7) must be 1,2,3,4,5.
c = -11: IPARAM(7) = 1 and BMAT = 'G' are incompatable.
c = -12: IPARAM(1) must be equal to 0 or 1.
c = -13: NEV and WHICH = 'BE' are incompatable.
c = -9999: Could not build an Arnoldi factorization.
c IPARAM(5) returns the size of the current Arnoldi
c factorization. The user is advised to check that
c enough workspace and array storage has been allocated.
c
c
c\Remarks
c 1. The converged Ritz values are always returned in ascending
c algebraic order. The computed Ritz values are approximate
c eigenvalues of OP. The selection of WHICH should be made
c with this in mind when Mode = 3,4,5. After convergence,
c approximate eigenvalues of the original problem may be obtained
c with the ARPACK subroutine sseupd.
c
c 2. If the Ritz vectors corresponding to the converged Ritz values
c are needed, the user must call sseupd immediately following completion
c of ssaupd. This is new starting with version 2.1 of ARPACK.
c
c 3. If M can be factored into a Cholesky factorization M = LL`
c then Mode = 2 should not be selected. Instead one should use
c Mode = 1 with OP = inv(L)*A*inv(L`). Appropriate triangular
c linear systems should be solved with L and L` rather
c than computing inverses. After convergence, an approximate
c eigenvector z of the original problem is recovered by solving
c L`z = x where x is a Ritz vector of OP.
c
c 4. At present there is no a-priori analysis to guide the selection
c of NCV relative to NEV. The only formal requrement is that NCV > NEV.
c However, it is recommended that NCV .ge. 2*NEV. If many problems of
c the same type are to be solved, one should experiment with increasing
c NCV while keeping NEV fixed for a given test problem. This will
c usually decrease the required number of OP*x operations but it
c also increases the work and storage required to maintain the orthogonal
c basis vectors. The optimal "cross-over" with respect to CPU time
c is problem dependent and must be determined empirically.
c
c 5. If IPARAM(7) = 2 then in the Reverse commuication interface the user
c must do the following. When IDO = 1, Y = OP * X is to be computed.
c When IPARAM(7) = 2 OP = inv(B)*A. After computing A*X the user
c must overwrite X with A*X. Y is then the solution to the linear set
c of equations B*Y = A*X.
c
c 6. When IPARAM(1) = 0, and IDO = 3, the user needs to provide the
c NP = IPARAM(8) shifts in locations:
c 1 WORKL(IPNTR(11))
c 2 WORKL(IPNTR(11)+1)
c .
c .
c .
c NP WORKL(IPNTR(11)+NP-1).
c
c The eigenvalues of the current tridiagonal matrix are located in
c WORKL(IPNTR(6)) through WORKL(IPNTR(6)+NCV-1). They are in the
c order defined by WHICH. The associated Ritz estimates are located in
c WORKL(IPNTR(8)), WORKL(IPNTR(8)+1), ... , WORKL(IPNTR(8)+NCV-1).
c
c-----------------------------------------------------------------------
c
c\Data Distribution Note:
c
c Fortran-D syntax:
c ================
c REAL RESID(N), V(LDV,NCV), WORKD(3*N), WORKL(LWORKL)
c DECOMPOSE D1(N), D2(N,NCV)
c ALIGN RESID(I) with D1(I)
c ALIGN V(I,J) with D2(I,J)
c ALIGN WORKD(I) with D1(I) range (1:N)
c ALIGN WORKD(I) with D1(I-N) range (N+1:2*N)
c ALIGN WORKD(I) with D1(I-2*N) range (2*N+1:3*N)
c DISTRIBUTE D1(BLOCK), D2(BLOCK,:)
c REPLICATED WORKL(LWORKL)
c
c Cray MPP syntax:
c ===============
c REAL RESID(N), V(LDV,NCV), WORKD(N,3), WORKL(LWORKL)
c SHARED RESID(BLOCK), V(BLOCK,:), WORKD(BLOCK,:)
c REPLICATED WORKL(LWORKL)
c
c
c\BeginLib
c
c\References:
c 1. D.C. Sorensen, "Implicit Application of Polynomial Filters in
c a k-Step Arnoldi Method", SIAM J. Matr. Anal. Apps., 13 (1992),
c pp 357-385.
c 2. R.B. Lehoucq, "Analysis and Implementation of an Implicitly
c Restarted Arnoldi Iteration", Rice University Technical Report
c TR95-13, Department of Computational and Applied Mathematics.
c 3. B.N. Parlett, "The Symmetric Eigenvalue Problem". Prentice-Hall,
c 1980.
c 4. B.N. Parlett, B. Nour-Omid, "Towards a Black Box Lanczos Program",
c Computer Physics Communications, 53 (1989), pp 169-179.
c 5. B. Nour-Omid, B.N. Parlett, T. Ericson, P.S. Jensen, "How to
c Implement the Spectral Transformation", Math. Comp., 48 (1987),
c pp 663-673.
c 6. R.G. Grimes, J.G. Lewis and H.D. Simon, "A Shifted Block Lanczos
c Algorithm for Solving Sparse Symmetric Generalized Eigenproblems",
c SIAM J. Matr. Anal. Apps., January (1993).
c 7. L. Reichel, W.B. Gragg, "Algorithm 686: FORTRAN Subroutines
c for Updating the QR decomposition", ACM TOMS, December 1990,
c Volume 16 Number 4, pp 369-377.
c 8. R.B. Lehoucq, D.C. Sorensen, "Implementation of Some Spectral
c Transformations in a k-Step Arnoldi Method". In Preparation.
c
c\Routines called:
c ssaup2 ARPACK routine that implements the Implicitly Restarted
c Arnoldi Iteration.
c sstats ARPACK routine that initialize timing and other statistics
c variables.
c ivout ARPACK utility routine that prints integers.
c second ARPACK utility routine for timing.
c svout ARPACK utility routine that prints vectors.
c slamch LAPACK routine that determines machine constants.
c
c\Authors
c Danny Sorensen Phuong Vu
c Richard Lehoucq CRPC / Rice University
c Dept. of Computational & Houston, Texas
c Applied Mathematics
c Rice University
c Houston, Texas
c
c\Revision history:
c 12/15/93: Version ' 2.4'
c
c\SCCS Information: @(#)
c FILE: saupd.F SID: 2.8 DATE OF SID: 04/10/01 RELEASE: 2
c
c\Remarks
c 1. None
c
c\EndLib
c
c-----------------------------------------------------------------------
c
subroutine ssaupd
& ( ido, bmat, n, which, nev, tol, resid, ncv, v, ldv, iparam,
& ipntr, workd, workl, lworkl, info )
c
c %----------------------------------------------------%
c | Include files for debugging and timing information |
c %----------------------------------------------------%
c
include 'debug.h'
include 'stat.h'
c
c %------------------%
c | Scalar Arguments |
c %------------------%
c
character bmat*1, which*2
integer ido, info, ldv, lworkl, n, ncv, nev
Real
& tol
c
c %-----------------%
c | Array Arguments |
c %-----------------%
c
integer iparam(11), ipntr(11)
Real
& resid(n), v(ldv,ncv), workd(3*n), workl(lworkl)
c
c %------------%
c | Parameters |
c %------------%
c
Real
& one, zero
parameter (one = 1.0E+0 , zero = 0.0E+0 )
c
c %---------------%
c | Local Scalars |
c %---------------%
c
integer bounds, ierr, ih, iq, ishift, iupd, iw,
& ldh, ldq, msglvl, mxiter, mode, nb,
& nev0, next, np, ritz, j
save bounds, ierr, ih, iq, ishift, iupd, iw,
& ldh, ldq, msglvl, mxiter, mode, nb,
& nev0, next, np, ritz
c
c %----------------------%
c | External Subroutines |
c %----------------------%
c
external ssaup2, svout, ivout, second, sstats
c
c %--------------------%
c | External Functions |
c %--------------------%
c
Real
& slamch
external slamch
c
c %-----------------------%
c | Executable Statements |
c %-----------------------%
c
if (ido .eq. 0) then
c
c %-------------------------------%
c | Initialize timing statistics |
c | & message level for debugging |
c %-------------------------------%
c
call sstats
call second (t0)
msglvl = msaupd
c
ierr = 0
ishift = iparam(1)
mxiter = iparam(3)
c nb = iparam(4)
nb = 1
c
c %--------------------------------------------%
c | Revision 2 performs only implicit restart. |
c %--------------------------------------------%
c
iupd = 1
mode = iparam(7)
c
c %----------------%
c | Error checking |
c %----------------%
c
if (n .le. 0) then
ierr = -1
else if (nev .le. 0) then
ierr = -2
else if (ncv .le. nev .or. ncv .gt. n) then
ierr = -3
end if
c
c %----------------------------------------------%
c | NP is the number of additional steps to |
c | extend the length NEV Lanczos factorization. |
c %----------------------------------------------%
c
np = ncv - nev
c
if (mxiter .le. 0) ierr = -4
if (which .ne. 'LM' .and.
& which .ne. 'SM' .and.
& which .ne. 'LA' .and.
& which .ne. 'SA' .and.
& which .ne. 'BE') ierr = -5
if (bmat .ne. 'I' .and. bmat .ne. 'G') ierr = -6
c
if (lworkl .lt. ncv**2 + 8*ncv) ierr = -7
if (mode .lt. 1 .or. mode .gt. 5) then
ierr = -10
else if (mode .eq. 1 .and. bmat .eq. 'G') then
ierr = -11
else if (ishift .lt. 0 .or. ishift .gt. 1) then
ierr = -12
else if (nev .eq. 1 .and. which .eq. 'BE') then
ierr = -13
end if
c
c %------------%
c | Error Exit |
c %------------%
c
if (ierr .ne. 0) then
info = ierr
ido = 99
go to 9000
end if
c
c %------------------------%
c | Set default parameters |
c %------------------------%
c
if (nb .le. 0) nb = 1
if (tol .le. zero) tol = slamch('EpsMach')
c
c %----------------------------------------------%
c | NP is the number of additional steps to |
c | extend the length NEV Lanczos factorization. |
c | NEV0 is the local variable designating the |
c | size of the invariant subspace desired. |
c %----------------------------------------------%
c
np = ncv - nev
nev0 = nev
c
c %-----------------------------%
c | Zero out internal workspace |
c %-----------------------------%
c
do 10 j = 1, ncv**2 + 8*ncv
workl(j) = zero
10 continue
c
c %-------------------------------------------------------%
c | Pointer into WORKL for address of H, RITZ, BOUNDS, Q |
c | etc... and the remaining workspace. |
c | Also update pointer to be used on output. |
c | Memory is laid out as follows: |
c | workl(1:2*ncv) := generated tridiagonal matrix |
c | workl(2*ncv+1:2*ncv+ncv) := ritz values |
c | workl(3*ncv+1:3*ncv+ncv) := computed error bounds |
c | workl(4*ncv+1:4*ncv+ncv*ncv) := rotation matrix Q |
c | workl(4*ncv+ncv*ncv+1:7*ncv+ncv*ncv) := workspace |
c %-------------------------------------------------------%
c
ldh = ncv
ldq = ncv
ih = 1
ritz = ih + 2*ldh
bounds = ritz + ncv
iq = bounds + ncv
iw = iq + ncv**2
next = iw + 3*ncv
c
ipntr(4) = next
ipntr(5) = ih
ipntr(6) = ritz
ipntr(7) = bounds
ipntr(11) = iw
end if
c
c %-------------------------------------------------------%
c | Carry out the Implicitly restarted Lanczos Iteration. |
c %-------------------------------------------------------%
c
call ssaup2
& ( ido, bmat, n, which, nev0, np, tol, resid, mode, iupd,
& ishift, mxiter, v, ldv, workl(ih), ldh, workl(ritz),
& workl(bounds), workl(iq), ldq, workl(iw), ipntr, workd,
& info )
c
c %--------------------------------------------------%
c | ido .ne. 99 implies use of reverse communication |
c | to compute operations involving OP or shifts. |
c %--------------------------------------------------%
c
if (ido .eq. 3) iparam(8) = np
if (ido .ne. 99) go to 9000
c
iparam(3) = mxiter
iparam(5) = np
iparam(9) = nopx
iparam(10) = nbx
iparam(11) = nrorth
c
c %------------------------------------%
c | Exit if there was an informational |
c | error within ssaup2. |
c %------------------------------------%
c
if (info .lt. 0) go to 9000
if (info .eq. 2) info = 3
c
if (msglvl .gt. 0) then
call ivout (logfil, 1, mxiter, ndigit,
& '_saupd: number of update iterations taken')
call ivout (logfil, 1, np, ndigit,
& '_saupd: number of "converged" Ritz values')
call svout (logfil, np, workl(Ritz), ndigit,
& '_saupd: final Ritz values')
call svout (logfil, np, workl(Bounds), ndigit,
& '_saupd: corresponding error bounds')
end if
c
call second (t1)
tsaupd = t1 - t0
c
if (msglvl .gt. 0) then
c
c %--------------------------------------------------------%
c | Version Number & Version Date are defined in version.h |
c %--------------------------------------------------------%
c
write (6,1000)
write (6,1100) mxiter, nopx, nbx, nrorth, nitref, nrstrt,
& tmvopx, tmvbx, tsaupd, tsaup2, tsaitr, titref,
& tgetv0, tseigt, tsgets, tsapps, tsconv
1000 format (//,
& 5x, '==========================================',/
& 5x, '= Symmetric implicit Arnoldi update code =',/
& 5x, '= Version Number:', ' 2.4' , 19x, ' =',/
& 5x, '= Version Date: ', ' 07/31/96' , 14x, ' =',/
& 5x, '==========================================',/
& 5x, '= Summary of timing statistics =',/
& 5x, '==========================================',//)
1100 format (
& 5x, 'Total number update iterations = ', i5,/
& 5x, 'Total number of OP*x operations = ', i5,/
& 5x, 'Total number of B*x operations = ', i5,/
& 5x, 'Total number of reorthogonalization steps = ', i5,/
& 5x, 'Total number of iterative refinement steps = ', i5,/
& 5x, 'Total number of restart steps = ', i5,/
& 5x, 'Total time in user OP*x operation = ', f12.6,/
& 5x, 'Total time in user B*x operation = ', f12.6,/
& 5x, 'Total time in Arnoldi update routine = ', f12.6,/
& 5x, 'Total time in saup2 routine = ', f12.6,/
& 5x, 'Total time in basic Arnoldi iteration loop = ', f12.6,/
& 5x, 'Total time in reorthogonalization phase = ', f12.6,/
& 5x, 'Total time in (re)start vector generation = ', f12.6,/
& 5x, 'Total time in trid eigenvalue subproblem = ', f12.6,/
& 5x, 'Total time in getting the shifts = ', f12.6,/
& 5x, 'Total time in applying the shifts = ', f12.6,/
& 5x, 'Total time in convergence testing = ', f12.6)
end if
c
9000 continue
c
return
c
c %---------------%
c | End of ssaupd |
c %---------------%
c
end

138
arpack/ARPACK/SRC/ssconv.f Normal file
View File

@@ -0,0 +1,138 @@
c-----------------------------------------------------------------------
c\BeginDoc
c
c\Name: ssconv
c
c\Description:
c Convergence testing for the symmetric Arnoldi eigenvalue routine.
c
c\Usage:
c call ssconv
c ( N, RITZ, BOUNDS, TOL, NCONV )
c
c\Arguments
c N Integer. (INPUT)
c Number of Ritz values to check for convergence.
c
c RITZ Real array of length N. (INPUT)
c The Ritz values to be checked for convergence.
c
c BOUNDS Real array of length N. (INPUT)
c Ritz estimates associated with the Ritz values in RITZ.
c
c TOL Real scalar. (INPUT)
c Desired relative accuracy for a Ritz value to be considered
c "converged".
c
c NCONV Integer scalar. (OUTPUT)
c Number of "converged" Ritz values.
c
c\EndDoc
c
c-----------------------------------------------------------------------
c
c\BeginLib
c
c\Routines called:
c second ARPACK utility routine for timing.
c slamch LAPACK routine that determines machine constants.
c
c\Author
c Danny Sorensen Phuong Vu
c Richard Lehoucq CRPC / Rice University
c Dept. of Computational & Houston, Texas
c Applied Mathematics
c Rice University
c Houston, Texas
c
c\SCCS Information: @(#)
c FILE: sconv.F SID: 2.4 DATE OF SID: 4/19/96 RELEASE: 2
c
c\Remarks
c 1. Starting with version 2.4, this routine no longer uses the
c Parlett strategy using the gap conditions.
c
c\EndLib
c
c-----------------------------------------------------------------------
c
subroutine ssconv (n, ritz, bounds, tol, nconv)
c
c %----------------------------------------------------%
c | Include files for debugging and timing information |
c %----------------------------------------------------%
c
include 'debug.h'
include 'stat.h'
c
c %------------------%
c | Scalar Arguments |
c %------------------%
c
integer n, nconv
Real
& tol
c
c %-----------------%
c | Array Arguments |
c %-----------------%
c
Real
& ritz(n), bounds(n)
c
c %---------------%
c | Local Scalars |
c %---------------%
c
integer i
Real
& temp, eps23
c
c %-------------------%
c | External routines |
c %-------------------%
c
Real
& slamch
external slamch
c %---------------------%
c | Intrinsic Functions |
c %---------------------%
c
intrinsic abs
c
c %-----------------------%
c | Executable Statements |
c %-----------------------%
c
call second (t0)
c
eps23 = slamch('Epsilon-Machine')
eps23 = eps23**(2.0E+0 / 3.0E+0)
c
nconv = 0
do 10 i = 1, n
c
c %-----------------------------------------------------%
c | The i-th Ritz value is considered "converged" |
c | when: bounds(i) .le. TOL*max(eps23, abs(ritz(i))) |
c %-----------------------------------------------------%
c
temp = max( eps23, abs(ritz(i)) )
if ( bounds(i) .le. tol*temp ) then
nconv = nconv + 1
end if
c
10 continue
c
call second (t1)
tsconv = tsconv + (t1 - t0)
c
return
c
c %---------------%
c | End of ssconv |
c %---------------%
c
end

181
arpack/ARPACK/SRC/sseigt.f Normal file
View File

@@ -0,0 +1,181 @@
c-----------------------------------------------------------------------
c\BeginDoc
c
c\Name: sseigt
c
c\Description:
c Compute the eigenvalues of the current symmetric tridiagonal matrix
c and the corresponding error bounds given the current residual norm.
c
c\Usage:
c call sseigt
c ( RNORM, N, H, LDH, EIG, BOUNDS, WORKL, IERR )
c
c\Arguments
c RNORM Real scalar. (INPUT)
c RNORM contains the residual norm corresponding to the current
c symmetric tridiagonal matrix H.
c
c N Integer. (INPUT)
c Size of the symmetric tridiagonal matrix H.
c
c H Real N by 2 array. (INPUT)
c H contains the symmetric tridiagonal matrix with the
c subdiagonal in the first column starting at H(2,1) and the
c main diagonal in second column.
c
c LDH Integer. (INPUT)
c Leading dimension of H exactly as declared in the calling
c program.
c
c EIG Real array of length N. (OUTPUT)
c On output, EIG contains the N eigenvalues of H possibly
c unsorted. The BOUNDS arrays are returned in the
c same sorted order as EIG.
c
c BOUNDS Real array of length N. (OUTPUT)
c On output, BOUNDS contains the error estimates corresponding
c to the eigenvalues EIG. This is equal to RNORM times the
c last components of the eigenvectors corresponding to the
c eigenvalues in EIG.
c
c WORKL Real work array of length 3*N. (WORKSPACE)
c Private (replicated) array on each PE or array allocated on
c the front end.
c
c IERR Integer. (OUTPUT)
c Error exit flag from sstqrb.
c
c\EndDoc
c
c-----------------------------------------------------------------------
c
c\BeginLib
c
c\Local variables:
c xxxxxx real
c
c\Routines called:
c sstqrb ARPACK routine that computes the eigenvalues and the
c last components of the eigenvectors of a symmetric
c and tridiagonal matrix.
c second ARPACK utility routine for timing.
c svout ARPACK utility routine that prints vectors.
c scopy Level 1 BLAS that copies one vector to another.
c
c\Author
c Danny Sorensen Phuong Vu
c Richard Lehoucq CRPC / Rice University
c Dept. of Computational & Houston, Texas
c Applied Mathematics
c Rice University
c Houston, Texas
c
c\Revision history:
c xx/xx/92: Version ' 2.4'
c
c\SCCS Information: @(#)
c FILE: seigt.F SID: 2.4 DATE OF SID: 8/27/96 RELEASE: 2
c
c\Remarks
c None
c
c\EndLib
c
c-----------------------------------------------------------------------
c
subroutine sseigt
& ( rnorm, n, h, ldh, eig, bounds, workl, ierr )
c
c %----------------------------------------------------%
c | Include files for debugging and timing information |
c %----------------------------------------------------%
c
include 'debug.h'
include 'stat.h'
c
c %------------------%
c | Scalar Arguments |
c %------------------%
c
integer ierr, ldh, n
Real
& rnorm
c
c %-----------------%
c | Array Arguments |
c %-----------------%
c
Real
& eig(n), bounds(n), h(ldh,2), workl(3*n)
c
c %------------%
c | Parameters |
c %------------%
c
Real
& zero
parameter (zero = 0.0E+0)
c
c %---------------%
c | Local Scalars |
c %---------------%
c
integer i, k, msglvl
c
c %----------------------%
c | External Subroutines |
c %----------------------%
c
external scopy, sstqrb, svout, second
c
c %-----------------------%
c | Executable Statements |
c %-----------------------%
c
c %-------------------------------%
c | Initialize timing statistics |
c | & message level for debugging |
c %-------------------------------%
c
call second (t0)
msglvl = mseigt
c
if (msglvl .gt. 0) then
call svout (logfil, n, h(1,2), ndigit,
& '_seigt: main diagonal of matrix H')
if (n .gt. 1) then
call svout (logfil, n-1, h(2,1), ndigit,
& '_seigt: sub diagonal of matrix H')
end if
end if
c
call scopy (n, h(1,2), 1, eig, 1)
call scopy (n-1, h(2,1), 1, workl, 1)
call sstqrb (n, eig, workl, bounds, workl(n+1), ierr)
if (ierr .ne. 0) go to 9000
if (msglvl .gt. 1) then
call svout (logfil, n, bounds, ndigit,
& '_seigt: last row of the eigenvector matrix for H')
end if
c
c %-----------------------------------------------%
c | Finally determine the error bounds associated |
c | with the n Ritz values of H. |
c %-----------------------------------------------%
c
do 30 k = 1, n
bounds(k) = rnorm*abs(bounds(k))
30 continue
c
call second (t1)
tseigt = tseigt + (t1 - t0)
c
9000 continue
return
c
c %---------------%
c | End of sseigt |
c %---------------%
c
end

217
arpack/ARPACK/SRC/ssesrt.f Normal file
View File

@@ -0,0 +1,217 @@
c-----------------------------------------------------------------------
c\BeginDoc
c
c\Name: ssesrt
c
c\Description:
c Sort the array X in the order specified by WHICH and optionally
c apply the permutation to the columns of the matrix A.
c
c\Usage:
c call ssesrt
c ( WHICH, APPLY, N, X, NA, A, LDA)
c
c\Arguments
c WHICH Character*2. (Input)
c 'LM' -> X is sorted into increasing order of magnitude.
c 'SM' -> X is sorted into decreasing order of magnitude.
c 'LA' -> X is sorted into increasing order of algebraic.
c 'SA' -> X is sorted into decreasing order of algebraic.
c
c APPLY Logical. (Input)
c APPLY = .TRUE. -> apply the sorted order to A.
c APPLY = .FALSE. -> do not apply the sorted order to A.
c
c N Integer. (INPUT)
c Dimension of the array X.
c
c X Real array of length N. (INPUT/OUTPUT)
c The array to be sorted.
c
c NA Integer. (INPUT)
c Number of rows of the matrix A.
c
c A Real array of length NA by N. (INPUT/OUTPUT)
c
c LDA Integer. (INPUT)
c Leading dimension of A.
c
c\EndDoc
c
c-----------------------------------------------------------------------
c
c\BeginLib
c
c\Routines
c sswap Level 1 BLAS that swaps the contents of two vectors.
c
c\Authors
c Danny Sorensen Phuong Vu
c Richard Lehoucq CRPC / Rice University
c Dept. of Computational & Houston, Texas
c Applied Mathematics
c Rice University
c Houston, Texas
c
c\Revision history:
c 12/15/93: Version ' 2.1'.
c Adapted from the sort routine in LANSO and
c the ARPACK code ssortr
c
c\SCCS Information: @(#)
c FILE: sesrt.F SID: 2.3 DATE OF SID: 4/19/96 RELEASE: 2
c
c\EndLib
c
c-----------------------------------------------------------------------
c
subroutine ssesrt (which, apply, n, x, na, a, lda)
c
c %------------------%
c | Scalar Arguments |
c %------------------%
c
character*2 which
logical apply
integer lda, n, na
c
c %-----------------%
c | Array Arguments |
c %-----------------%
c
Real
& x(0:n-1), a(lda, 0:n-1)
c
c %---------------%
c | Local Scalars |
c %---------------%
c
integer i, igap, j
Real
& temp
c
c %----------------------%
c | External Subroutines |
c %----------------------%
c
external sswap
c
c %-----------------------%
c | Executable Statements |
c %-----------------------%
c
igap = n / 2
c
if (which .eq. 'SA') then
c
c X is sorted into decreasing order of algebraic.
c
10 continue
if (igap .eq. 0) go to 9000
do 30 i = igap, n-1
j = i-igap
20 continue
c
if (j.lt.0) go to 30
c
if (x(j).lt.x(j+igap)) then
temp = x(j)
x(j) = x(j+igap)
x(j+igap) = temp
if (apply) call sswap( na, a(1, j), 1, a(1,j+igap), 1)
else
go to 30
endif
j = j-igap
go to 20
30 continue
igap = igap / 2
go to 10
c
else if (which .eq. 'SM') then
c
c X is sorted into decreasing order of magnitude.
c
40 continue
if (igap .eq. 0) go to 9000
do 60 i = igap, n-1
j = i-igap
50 continue
c
if (j.lt.0) go to 60
c
if (abs(x(j)).lt.abs(x(j+igap))) then
temp = x(j)
x(j) = x(j+igap)
x(j+igap) = temp
if (apply) call sswap( na, a(1, j), 1, a(1,j+igap), 1)
else
go to 60
endif
j = j-igap
go to 50
60 continue
igap = igap / 2
go to 40
c
else if (which .eq. 'LA') then
c
c X is sorted into increasing order of algebraic.
c
70 continue
if (igap .eq. 0) go to 9000
do 90 i = igap, n-1
j = i-igap
80 continue
c
if (j.lt.0) go to 90
c
if (x(j).gt.x(j+igap)) then
temp = x(j)
x(j) = x(j+igap)
x(j+igap) = temp
if (apply) call sswap( na, a(1, j), 1, a(1,j+igap), 1)
else
go to 90
endif
j = j-igap
go to 80
90 continue
igap = igap / 2
go to 70
c
else if (which .eq. 'LM') then
c
c X is sorted into increasing order of magnitude.
c
100 continue
if (igap .eq. 0) go to 9000
do 120 i = igap, n-1
j = i-igap
110 continue
c
if (j.lt.0) go to 120
c
if (abs(x(j)).gt.abs(x(j+igap))) then
temp = x(j)
x(j) = x(j+igap)
x(j+igap) = temp
if (apply) call sswap( na, a(1, j), 1, a(1,j+igap), 1)
else
go to 120
endif
j = j-igap
go to 110
120 continue
igap = igap / 2
go to 100
end if
c
9000 continue
return
c
c %---------------%
c | End of ssesrt |
c %---------------%
c
end

857
arpack/ARPACK/SRC/sseupd.f Normal file
View File

@@ -0,0 +1,857 @@
c\BeginDoc
c
c\Name: sseupd
c
c\Description:
c
c This subroutine returns the converged approximations to eigenvalues
c of A*z = lambda*B*z and (optionally):
c
c (1) the corresponding approximate eigenvectors,
c
c (2) an orthonormal (Lanczos) basis for the associated approximate
c invariant subspace,
c
c (3) Both.
c
c There is negligible additional cost to obtain eigenvectors. An orthonormal
c (Lanczos) basis is always computed. There is an additional storage cost
c of n*nev if both are requested (in this case a separate array Z must be
c supplied).
c
c These quantities are obtained from the Lanczos factorization computed
c by SSAUPD for the linear operator OP prescribed by the MODE selection
c (see IPARAM(7) in SSAUPD documentation.) SSAUPD must be called before
c this routine is called. These approximate eigenvalues and vectors are
c commonly called Ritz values and Ritz vectors respectively. They are
c referred to as such in the comments that follow. The computed orthonormal
c basis for the invariant subspace corresponding to these Ritz values is
c referred to as a Lanczos basis.
c
c See documentation in the header of the subroutine SSAUPD for a definition
c of OP as well as other terms and the relation of computed Ritz values
c and vectors of OP with respect to the given problem A*z = lambda*B*z.
c
c The approximate eigenvalues of the original problem are returned in
c ascending algebraic order. The user may elect to call this routine
c once for each desired Ritz vector and store it peripherally if desired.
c There is also the option of computing a selected set of these vectors
c with a single call.
c
c\Usage:
c call sseupd
c ( RVEC, HOWMNY, SELECT, D, Z, LDZ, SIGMA, BMAT, N, WHICH, NEV, TOL,
c RESID, NCV, V, LDV, IPARAM, IPNTR, WORKD, WORKL, LWORKL, INFO )
c
c RVEC LOGICAL (INPUT)
c Specifies whether Ritz vectors corresponding to the Ritz value
c approximations to the eigenproblem A*z = lambda*B*z are computed.
c
c RVEC = .FALSE. Compute Ritz values only.
c
c RVEC = .TRUE. Compute Ritz vectors.
c
c HOWMNY Character*1 (INPUT)
c Specifies how many Ritz vectors are wanted and the form of Z
c the matrix of Ritz vectors. See remark 1 below.
c = 'A': compute NEV Ritz vectors;
c = 'S': compute some of the Ritz vectors, specified
c by the logical array SELECT.
c
c SELECT Logical array of dimension NCV. (INPUT/WORKSPACE)
c If HOWMNY = 'S', SELECT specifies the Ritz vectors to be
c computed. To select the Ritz vector corresponding to a
c Ritz value D(j), SELECT(j) must be set to .TRUE..
c If HOWMNY = 'A' , SELECT is used as a workspace for
c reordering the Ritz values.
c
c D Real array of dimension NEV. (OUTPUT)
c On exit, D contains the Ritz value approximations to the
c eigenvalues of A*z = lambda*B*z. The values are returned
c in ascending order. If IPARAM(7) = 3,4,5 then D represents
c the Ritz values of OP computed by ssaupd transformed to
c those of the original eigensystem A*z = lambda*B*z. If
c IPARAM(7) = 1,2 then the Ritz values of OP are the same
c as the those of A*z = lambda*B*z.
c
c Z Real N by NEV array if HOWMNY = 'A'. (OUTPUT)
c On exit, Z contains the B-orthonormal Ritz vectors of the
c eigensystem A*z = lambda*B*z corresponding to the Ritz
c value approximations.
c If RVEC = .FALSE. then Z is not referenced.
c NOTE: The array Z may be set equal to first NEV columns of the
c Arnoldi/Lanczos basis array V computed by SSAUPD.
c
c LDZ Integer. (INPUT)
c The leading dimension of the array Z. If Ritz vectors are
c desired, then LDZ .ge. max( 1, N ). In any case, LDZ .ge. 1.
c
c SIGMA Real (INPUT)
c If IPARAM(7) = 3,4,5 represents the shift. Not referenced if
c IPARAM(7) = 1 or 2.
c
c
c **** The remaining arguments MUST be the same as for the ****
c **** call to SSAUPD that was just completed. ****
c
c NOTE: The remaining arguments
c
c BMAT, N, WHICH, NEV, TOL, RESID, NCV, V, LDV, IPARAM, IPNTR,
c WORKD, WORKL, LWORKL, INFO
c
c must be passed directly to SSEUPD following the last call
c to SSAUPD. These arguments MUST NOT BE MODIFIED between
c the the last call to SSAUPD and the call to SSEUPD.
c
c Two of these parameters (WORKL, INFO) are also output parameters:
c
c WORKL Real work array of length LWORKL. (OUTPUT/WORKSPACE)
c WORKL(1:4*ncv) contains information obtained in
c ssaupd. They are not changed by sseupd.
c WORKL(4*ncv+1:ncv*ncv+8*ncv) holds the
c untransformed Ritz values, the computed error estimates,
c and the associated eigenvector matrix of H.
c
c Note: IPNTR(8:10) contains the pointer into WORKL for addresses
c of the above information computed by sseupd.
c -------------------------------------------------------------
c IPNTR(8): pointer to the NCV RITZ values of the original system.
c IPNTR(9): pointer to the NCV corresponding error bounds.
c IPNTR(10): pointer to the NCV by NCV matrix of eigenvectors
c of the tridiagonal matrix T. Only referenced by
c sseupd if RVEC = .TRUE. See Remarks.
c -------------------------------------------------------------
c
c INFO Integer. (OUTPUT)
c Error flag on output.
c = 0: Normal exit.
c = -1: N must be positive.
c = -2: NEV must be positive.
c = -3: NCV must be greater than NEV and less than or equal to N.
c = -5: WHICH must be one of 'LM', 'SM', 'LA', 'SA' or 'BE'.
c = -6: BMAT must be one of 'I' or 'G'.
c = -7: Length of private work WORKL array is not sufficient.
c = -8: Error return from trid. eigenvalue calculation;
c Information error from LAPACK routine ssteqr.
c = -9: Starting vector is zero.
c = -10: IPARAM(7) must be 1,2,3,4,5.
c = -11: IPARAM(7) = 1 and BMAT = 'G' are incompatible.
c = -12: NEV and WHICH = 'BE' are incompatible.
c = -14: SSAUPD did not find any eigenvalues to sufficient
c accuracy.
c = -15: HOWMNY must be one of 'A' or 'S' if RVEC = .true.
c = -16: HOWMNY = 'S' not yet implemented
c = -17: SSEUPD got a different count of the number of converged
c Ritz values than SSAUPD got. This indicates the user
c probably made an error in passing data from SSAUPD to
c SSEUPD or that the data was modified before entering
c SSEUPD.
c
c\BeginLib
c
c\References:
c 1. D.C. Sorensen, "Implicit Application of Polynomial Filters in
c a k-Step Arnoldi Method", SIAM J. Matr. Anal. Apps., 13 (1992),
c pp 357-385.
c 2. R.B. Lehoucq, "Analysis and Implementation of an Implicitly
c Restarted Arnoldi Iteration", Rice University Technical Report
c TR95-13, Department of Computational and Applied Mathematics.
c 3. B.N. Parlett, "The Symmetric Eigenvalue Problem". Prentice-Hall,
c 1980.
c 4. B.N. Parlett, B. Nour-Omid, "Towards a Black Box Lanczos Program",
c Computer Physics Communications, 53 (1989), pp 169-179.
c 5. B. Nour-Omid, B.N. Parlett, T. Ericson, P.S. Jensen, "How to
c Implement the Spectral Transformation", Math. Comp., 48 (1987),
c pp 663-673.
c 6. R.G. Grimes, J.G. Lewis and H.D. Simon, "A Shifted Block Lanczos
c Algorithm for Solving Sparse Symmetric Generalized Eigenproblems",
c SIAM J. Matr. Anal. Apps., January (1993).
c 7. L. Reichel, W.B. Gragg, "Algorithm 686: FORTRAN Subroutines
c for Updating the QR decomposition", ACM TOMS, December 1990,
c Volume 16 Number 4, pp 369-377.
c
c\Remarks
c 1. The converged Ritz values are always returned in increasing
c (algebraic) order.
c
c 2. Currently only HOWMNY = 'A' is implemented. It is included at this
c stage for the user who wants to incorporate it.
c
c\Routines called:
c ssesrt ARPACK routine that sorts an array X, and applies the
c corresponding permutation to a matrix A.
c ssortr ssortr ARPACK sorting routine.
c ivout ARPACK utility routine that prints integers.
c svout ARPACK utility routine that prints vectors.
c sgeqr2 LAPACK routine that computes the QR factorization of
c a matrix.
c slacpy LAPACK matrix copy routine.
c slamch LAPACK routine that determines machine constants.
c sorm2r LAPACK routine that applies an orthogonal matrix in
c factored form.
c ssteqr LAPACK routine that computes eigenvalues and eigenvectors
c of a tridiagonal matrix.
c sger Level 2 BLAS rank one update to a matrix.
c scopy Level 1 BLAS that copies one vector to another .
c snrm2 Level 1 BLAS that computes the norm of a vector.
c sscal Level 1 BLAS that scales a vector.
c sswap Level 1 BLAS that swaps the contents of two vectors.
c\Authors
c Danny Sorensen Phuong Vu
c Richard Lehoucq CRPC / Rice University
c Chao Yang Houston, Texas
c Dept. of Computational &
c Applied Mathematics
c Rice University
c Houston, Texas
c
c\Revision history:
c 12/15/93: Version ' 2.1'
c
c\SCCS Information: @(#)
c FILE: seupd.F SID: 2.11 DATE OF SID: 04/10/01 RELEASE: 2
c
c\EndLib
c
c-----------------------------------------------------------------------
subroutine sseupd(rvec , howmny, select, d ,
& z , ldz , sigma , bmat ,
& n , which , nev , tol ,
& resid , ncv , v , ldv ,
& iparam, ipntr , workd , workl,
& lworkl, info )
c
c %----------------------------------------------------%
c | Include files for debugging and timing information |
c %----------------------------------------------------%
c
include 'debug.h'
include 'stat.h'
c
c %------------------%
c | Scalar Arguments |
c %------------------%
c
character bmat, howmny, which*2
logical rvec
integer info, ldz, ldv, lworkl, n, ncv, nev
Real
& sigma, tol
c
c %-----------------%
c | Array Arguments |
c %-----------------%
c
integer iparam(7), ipntr(11)
logical select(ncv)
Real
& d(nev) , resid(n) , v(ldv,ncv),
& z(ldz, nev), workd(2*n), workl(lworkl)
c
c %------------%
c | Parameters |
c %------------%
c
Real
& one, zero
parameter (one = 1.0E+0 , zero = 0.0E+0 )
c
c %---------------%
c | Local Scalars |
c %---------------%
c
character type*6
integer bounds , ierr , ih , ihb , ihd ,
& iq , iw , j , k , ldh ,
& ldq , mode , msglvl, nconv , next ,
& ritz , irz , ibd , np , ishift,
& leftptr, rghtptr, numcnv, jj
Real
& bnorm2 , rnorm, temp, temp1, eps23
logical reord
c
c %----------------------%
c | External Subroutines |
c %----------------------%
c
external scopy , sger , sgeqr2, slacpy, sorm2r, sscal,
& ssesrt, ssteqr, sswap , svout , ivout , ssortr
c
c %--------------------%
c | External Functions |
c %--------------------%
c
Real
& snrm2, slamch
external snrm2, slamch
c
c %---------------------%
c | Intrinsic Functions |
c %---------------------%
c
intrinsic min
c
c %-----------------------%
c | Executable Statements |
c %-----------------------%
c
c %------------------------%
c | Set default parameters |
c %------------------------%
c
msglvl = mseupd
mode = iparam(7)
nconv = iparam(5)
info = 0
c
c %--------------%
c | Quick return |
c %--------------%
c
if (nconv .eq. 0) go to 9000
ierr = 0
c
if (nconv .le. 0) ierr = -14
if (n .le. 0) ierr = -1
if (nev .le. 0) ierr = -2
if (ncv .le. nev .or. ncv .gt. n) ierr = -3
if (which .ne. 'LM' .and.
& which .ne. 'SM' .and.
& which .ne. 'LA' .and.
& which .ne. 'SA' .and.
& which .ne. 'BE') ierr = -5
if (bmat .ne. 'I' .and. bmat .ne. 'G') ierr = -6
if ( (howmny .ne. 'A' .and.
& howmny .ne. 'P' .and.
& howmny .ne. 'S') .and. rvec )
& ierr = -15
if (rvec .and. howmny .eq. 'S') ierr = -16
c
if (rvec .and. lworkl .lt. ncv**2+8*ncv) ierr = -7
c
if (mode .eq. 1 .or. mode .eq. 2) then
type = 'REGULR'
else if (mode .eq. 3 ) then
type = 'SHIFTI'
else if (mode .eq. 4 ) then
type = 'BUCKLE'
else if (mode .eq. 5 ) then
type = 'CAYLEY'
else
ierr = -10
end if
if (mode .eq. 1 .and. bmat .eq. 'G') ierr = -11
if (nev .eq. 1 .and. which .eq. 'BE') ierr = -12
c
c %------------%
c | Error Exit |
c %------------%
c
if (ierr .ne. 0) then
info = ierr
go to 9000
end if
c
c %-------------------------------------------------------%
c | Pointer into WORKL for address of H, RITZ, BOUNDS, Q |
c | etc... and the remaining workspace. |
c | Also update pointer to be used on output. |
c | Memory is laid out as follows: |
c | workl(1:2*ncv) := generated tridiagonal matrix H |
c | The subdiagonal is stored in workl(2:ncv). |
c | The dead spot is workl(1) but upon exiting |
c | ssaupd stores the B-norm of the last residual |
c | vector in workl(1). We use this !!! |
c | workl(2*ncv+1:2*ncv+ncv) := ritz values |
c | The wanted values are in the first NCONV spots. |
c | workl(3*ncv+1:3*ncv+ncv) := computed Ritz estimates |
c | The wanted values are in the first NCONV spots. |
c | NOTE: workl(1:4*ncv) is set by ssaupd and is not |
c | modified by sseupd. |
c %-------------------------------------------------------%
c
c %-------------------------------------------------------%
c | The following is used and set by sseupd. |
c | workl(4*ncv+1:4*ncv+ncv) := used as workspace during |
c | computation of the eigenvectors of H. Stores |
c | the diagonal of H. Upon EXIT contains the NCV |
c | Ritz values of the original system. The first |
c | NCONV spots have the wanted values. If MODE = |
c | 1 or 2 then will equal workl(2*ncv+1:3*ncv). |
c | workl(5*ncv+1:5*ncv+ncv) := used as workspace during |
c | computation of the eigenvectors of H. Stores |
c | the subdiagonal of H. Upon EXIT contains the |
c | NCV corresponding Ritz estimates of the |
c | original system. The first NCONV spots have the |
c | wanted values. If MODE = 1,2 then will equal |
c | workl(3*ncv+1:4*ncv). |
c | workl(6*ncv+1:6*ncv+ncv*ncv) := orthogonal Q that is |
c | the eigenvector matrix for H as returned by |
c | ssteqr. Not referenced if RVEC = .False. |
c | Ordering follows that of workl(4*ncv+1:5*ncv) |
c | workl(6*ncv+ncv*ncv+1:6*ncv+ncv*ncv+2*ncv) := |
c | Workspace. Needed by ssteqr and by sseupd. |
c | GRAND total of NCV*(NCV+8) locations. |
c %-------------------------------------------------------%
c
c
ih = ipntr(5)
ritz = ipntr(6)
bounds = ipntr(7)
ldh = ncv
ldq = ncv
ihd = bounds + ldh
ihb = ihd + ldh
iq = ihb + ldh
iw = iq + ldh*ncv
next = iw + 2*ncv
ipntr(4) = next
ipntr(8) = ihd
ipntr(9) = ihb
ipntr(10) = iq
c
c %----------------------------------------%
c | irz points to the Ritz values computed |
c | by _seigt before exiting _saup2. |
c | ibd points to the Ritz estimates |
c | computed by _seigt before exiting |
c | _saup2. |
c %----------------------------------------%
c
irz = ipntr(11)+ncv
ibd = irz+ncv
c
c
c %---------------------------------%
c | Set machine dependent constant. |
c %---------------------------------%
c
eps23 = slamch('Epsilon-Machine')
eps23 = eps23**(2.0E+0 / 3.0E+0 )
c
c %---------------------------------------%
c | RNORM is B-norm of the RESID(1:N). |
c | BNORM2 is the 2 norm of B*RESID(1:N). |
c | Upon exit of ssaupd WORKD(1:N) has |
c | B*RESID(1:N). |
c %---------------------------------------%
c
rnorm = workl(ih)
if (bmat .eq. 'I') then
bnorm2 = rnorm
else if (bmat .eq. 'G') then
bnorm2 = snrm2(n, workd, 1)
end if
c
if (msglvl .gt. 2) then
call svout(logfil, ncv, workl(irz), ndigit,
& '_seupd: Ritz values passed in from _SAUPD.')
call svout(logfil, ncv, workl(ibd), ndigit,
& '_seupd: Ritz estimates passed in from _SAUPD.')
end if
c
if (rvec) then
c
reord = .false.
c
c %---------------------------------------------------%
c | Use the temporary bounds array to store indices |
c | These will be used to mark the select array later |
c %---------------------------------------------------%
c
do 10 j = 1,ncv
workl(bounds+j-1) = j
select(j) = .false.
10 continue
c
c %-------------------------------------%
c | Select the wanted Ritz values. |
c | Sort the Ritz values so that the |
c | wanted ones appear at the tailing |
c | NEV positions of workl(irr) and |
c | workl(iri). Move the corresponding |
c | error estimates in workl(bound) |
c | accordingly. |
c %-------------------------------------%
c
np = ncv - nev
ishift = 0
call ssgets(ishift, which , nev ,
& np , workl(irz) , workl(bounds),
& workl)
c
if (msglvl .gt. 2) then
call svout(logfil, ncv, workl(irz), ndigit,
& '_seupd: Ritz values after calling _SGETS.')
call svout(logfil, ncv, workl(bounds), ndigit,
& '_seupd: Ritz value indices after calling _SGETS.')
end if
c
c %-----------------------------------------------------%
c | Record indices of the converged wanted Ritz values |
c | Mark the select array for possible reordering |
c %-----------------------------------------------------%
c
numcnv = 0
do 11 j = 1,ncv
temp1 = max(eps23, abs(workl(irz+ncv-j)) )
jj = workl(bounds + ncv - j)
if (numcnv .lt. nconv .and.
& workl(ibd+jj-1) .le. tol*temp1) then
select(jj) = .true.
numcnv = numcnv + 1
if (jj .gt. nev) reord = .true.
endif
11 continue
c
c %-----------------------------------------------------------%
c | Check the count (numcnv) of converged Ritz values with |
c | the number (nconv) reported by _saupd. If these two |
c | are different then there has probably been an error |
c | caused by incorrect passing of the _saupd data. |
c %-----------------------------------------------------------%
c
if (msglvl .gt. 2) then
call ivout(logfil, 1, numcnv, ndigit,
& '_seupd: Number of specified eigenvalues')
call ivout(logfil, 1, nconv, ndigit,
& '_seupd: Number of "converged" eigenvalues')
end if
c
if (numcnv .ne. nconv) then
info = -17
go to 9000
end if
c
c %-----------------------------------------------------------%
c | Call LAPACK routine _steqr to compute the eigenvalues and |
c | eigenvectors of the final symmetric tridiagonal matrix H. |
c | Initialize the eigenvector matrix Q to the identity. |
c %-----------------------------------------------------------%
c
call scopy(ncv-1, workl(ih+1), 1, workl(ihb), 1)
call scopy(ncv, workl(ih+ldh), 1, workl(ihd), 1)
c
call ssteqr('Identity', ncv, workl(ihd), workl(ihb),
& workl(iq) , ldq, workl(iw), ierr)
c
if (ierr .ne. 0) then
info = -8
go to 9000
end if
c
if (msglvl .gt. 1) then
call scopy(ncv, workl(iq+ncv-1), ldq, workl(iw), 1)
call svout(logfil, ncv, workl(ihd), ndigit,
& '_seupd: NCV Ritz values of the final H matrix')
call svout(logfil, ncv, workl(iw), ndigit,
& '_seupd: last row of the eigenvector matrix for H')
end if
c
if (reord) then
c
c %---------------------------------------------%
c | Reordered the eigenvalues and eigenvectors |
c | computed by _steqr so that the "converged" |
c | eigenvalues appear in the first NCONV |
c | positions of workl(ihd), and the associated |
c | eigenvectors appear in the first NCONV |
c | columns. |
c %---------------------------------------------%
c
leftptr = 1
rghtptr = ncv
c
if (ncv .eq. 1) go to 30
c
20 if (select(leftptr)) then
c
c %-------------------------------------------%
c | Search, from the left, for the first Ritz |
c | value that has not converged. |
c %-------------------------------------------%
c
leftptr = leftptr + 1
c
else if ( .not. select(rghtptr)) then
c
c %----------------------------------------------%
c | Search, from the right, the first Ritz value |
c | that has converged. |
c %----------------------------------------------%
c
rghtptr = rghtptr - 1
c
else
c
c %----------------------------------------------%
c | Swap the Ritz value on the left that has not |
c | converged with the Ritz value on the right |
c | that has converged. Swap the associated |
c | eigenvector of the tridiagonal matrix H as |
c | well. |
c %----------------------------------------------%
c
temp = workl(ihd+leftptr-1)
workl(ihd+leftptr-1) = workl(ihd+rghtptr-1)
workl(ihd+rghtptr-1) = temp
call scopy(ncv, workl(iq+ncv*(leftptr-1)), 1,
& workl(iw), 1)
call scopy(ncv, workl(iq+ncv*(rghtptr-1)), 1,
& workl(iq+ncv*(leftptr-1)), 1)
call scopy(ncv, workl(iw), 1,
& workl(iq+ncv*(rghtptr-1)), 1)
leftptr = leftptr + 1
rghtptr = rghtptr - 1
c
end if
c
if (leftptr .lt. rghtptr) go to 20
c
30 end if
c
if (msglvl .gt. 2) then
call svout (logfil, ncv, workl(ihd), ndigit,
& '_seupd: The eigenvalues of H--reordered')
end if
c
c %----------------------------------------%
c | Load the converged Ritz values into D. |
c %----------------------------------------%
c
call scopy(nconv, workl(ihd), 1, d, 1)
c
else
c
c %-----------------------------------------------------%
c | Ritz vectors not required. Load Ritz values into D. |
c %-----------------------------------------------------%
c
call scopy(nconv, workl(ritz), 1, d, 1)
call scopy(ncv, workl(ritz), 1, workl(ihd), 1)
c
end if
c
c %------------------------------------------------------------------%
c | Transform the Ritz values and possibly vectors and corresponding |
c | Ritz estimates of OP to those of A*x=lambda*B*x. The Ritz values |
c | (and corresponding data) are returned in ascending order. |
c %------------------------------------------------------------------%
c
if (type .eq. 'REGULR') then
c
c %---------------------------------------------------------%
c | Ascending sort of wanted Ritz values, vectors and error |
c | bounds. Not necessary if only Ritz values are desired. |
c %---------------------------------------------------------%
c
if (rvec) then
call ssesrt('LA', rvec , nconv, d, ncv, workl(iq), ldq)
else
call scopy(ncv, workl(bounds), 1, workl(ihb), 1)
end if
c
else
c
c %-------------------------------------------------------------%
c | * Make a copy of all the Ritz values. |
c | * Transform the Ritz values back to the original system. |
c | For TYPE = 'SHIFTI' the transformation is |
c | lambda = 1/theta + sigma |
c | For TYPE = 'BUCKLE' the transformation is |
c | lambda = sigma * theta / ( theta - 1 ) |
c | For TYPE = 'CAYLEY' the transformation is |
c | lambda = sigma * (theta + 1) / (theta - 1 ) |
c | where the theta are the Ritz values returned by ssaupd. |
c | NOTES: |
c | *The Ritz vectors are not affected by the transformation. |
c | They are only reordered. |
c %-------------------------------------------------------------%
c
call scopy (ncv, workl(ihd), 1, workl(iw), 1)
if (type .eq. 'SHIFTI') then
do 40 k=1, ncv
workl(ihd+k-1) = one / workl(ihd+k-1) + sigma
40 continue
else if (type .eq. 'BUCKLE') then
do 50 k=1, ncv
workl(ihd+k-1) = sigma * workl(ihd+k-1) /
& (workl(ihd+k-1) - one)
50 continue
else if (type .eq. 'CAYLEY') then
do 60 k=1, ncv
workl(ihd+k-1) = sigma * (workl(ihd+k-1) + one) /
& (workl(ihd+k-1) - one)
60 continue
end if
c
c %-------------------------------------------------------------%
c | * Store the wanted NCONV lambda values into D. |
c | * Sort the NCONV wanted lambda in WORKL(IHD:IHD+NCONV-1) |
c | into ascending order and apply sort to the NCONV theta |
c | values in the transformed system. We will need this to |
c | compute Ritz estimates in the original system. |
c | * Finally sort the lambda`s into ascending order and apply |
c | to Ritz vectors if wanted. Else just sort lambda`s into |
c | ascending order. |
c | NOTES: |
c | *workl(iw:iw+ncv-1) contain the theta ordered so that they |
c | match the ordering of the lambda. We`ll use them again for |
c | Ritz vector purification. |
c %-------------------------------------------------------------%
c
call scopy(nconv, workl(ihd), 1, d, 1)
call ssortr('LA', .true., nconv, workl(ihd), workl(iw))
if (rvec) then
call ssesrt('LA', rvec , nconv, d, ncv, workl(iq), ldq)
else
call scopy(ncv, workl(bounds), 1, workl(ihb), 1)
call sscal(ncv, bnorm2/rnorm, workl(ihb), 1)
call ssortr('LA', .true., nconv, d, workl(ihb))
end if
c
end if
c
c %------------------------------------------------%
c | Compute the Ritz vectors. Transform the wanted |
c | eigenvectors of the symmetric tridiagonal H by |
c | the Lanczos basis matrix V. |
c %------------------------------------------------%
c
if (rvec .and. howmny .eq. 'A') then
c
c %----------------------------------------------------------%
c | Compute the QR factorization of the matrix representing |
c | the wanted invariant subspace located in the first NCONV |
c | columns of workl(iq,ldq). |
c %----------------------------------------------------------%
c
call sgeqr2(ncv, nconv , workl(iq) ,
& ldq, workl(iw+ncv), workl(ihb),
& ierr)
c
c %--------------------------------------------------------%
c | * Postmultiply V by Q. |
c | * Copy the first NCONV columns of VQ into Z. |
c | The N by NCONV matrix Z is now a matrix representation |
c | of the approximate invariant subspace associated with |
c | the Ritz values in workl(ihd). |
c %--------------------------------------------------------%
c
call sorm2r('Right', 'Notranspose', n ,
& ncv , nconv , workl(iq),
& ldq , workl(iw+ncv), v ,
& ldv , workd(n+1) , ierr)
call slacpy('All', n, nconv, v, ldv, z, ldz)
c
c %-----------------------------------------------------%
c | In order to compute the Ritz estimates for the Ritz |
c | values in both systems, need the last row of the |
c | eigenvector matrix. Remember, it`s in factored form |
c %-----------------------------------------------------%
c
do 65 j = 1, ncv-1
workl(ihb+j-1) = zero
65 continue
workl(ihb+ncv-1) = one
call sorm2r('Left', 'Transpose' , ncv ,
& 1 , nconv , workl(iq) ,
& ldq , workl(iw+ncv), workl(ihb),
& ncv , temp , ierr)
c
else if (rvec .and. howmny .eq. 'S') then
c
c Not yet implemented. See remark 2 above.
c
end if
c
if (type .eq. 'REGULR' .and. rvec) then
c
do 70 j=1, ncv
workl(ihb+j-1) = rnorm * abs( workl(ihb+j-1) )
70 continue
c
else if (type .ne. 'REGULR' .and. rvec) then
c
c %-------------------------------------------------%
c | * Determine Ritz estimates of the theta. |
c | If RVEC = .true. then compute Ritz estimates |
c | of the theta. |
c | If RVEC = .false. then copy Ritz estimates |
c | as computed by ssaupd. |
c | * Determine Ritz estimates of the lambda. |
c %-------------------------------------------------%
c
call sscal (ncv, bnorm2, workl(ihb), 1)
if (type .eq. 'SHIFTI') then
c
do 80 k=1, ncv
workl(ihb+k-1) = abs( workl(ihb+k-1) )
& / workl(iw+k-1)**2
80 continue
c
else if (type .eq. 'BUCKLE') then
c
do 90 k=1, ncv
workl(ihb+k-1) = sigma * abs( workl(ihb+k-1) )
& / (workl(iw+k-1)-one )**2
90 continue
c
else if (type .eq. 'CAYLEY') then
c
do 100 k=1, ncv
workl(ihb+k-1) = abs( workl(ihb+k-1)
& / workl(iw+k-1)*(workl(iw+k-1)-one) )
100 continue
c
end if
c
end if
c
if (type .ne. 'REGULR' .and. msglvl .gt. 1) then
call svout(logfil, nconv, d, ndigit,
& '_seupd: Untransformed converged Ritz values')
call svout(logfil, nconv, workl(ihb), ndigit,
& '_seupd: Ritz estimates of the untransformed Ritz values')
else if (msglvl .gt. 1) then
call svout(logfil, nconv, d, ndigit,
& '_seupd: Converged Ritz values')
call svout(logfil, nconv, workl(ihb), ndigit,
& '_seupd: Associated Ritz estimates')
end if
c
c %-------------------------------------------------%
c | Ritz vector purification step. Formally perform |
c | one of inverse subspace iteration. Only used |
c | for MODE = 3,4,5. See reference 7 |
c %-------------------------------------------------%
c
if (rvec .and. (type .eq. 'SHIFTI' .or. type .eq. 'CAYLEY')) then
c
do 110 k=0, nconv-1
workl(iw+k) = workl(iq+k*ldq+ncv-1)
& / workl(iw+k)
110 continue
c
else if (rvec .and. type .eq. 'BUCKLE') then
c
do 120 k=0, nconv-1
workl(iw+k) = workl(iq+k*ldq+ncv-1)
& / (workl(iw+k)-one)
120 continue
c
end if
c
if (type .ne. 'REGULR')
& call sger (n, nconv, one, resid, 1, workl(iw), 1, z, ldz)
c
9000 continue
c
return
c
c %---------------%
c | End of sseupd|
c %---------------%
c
end

219
arpack/ARPACK/SRC/ssgets.f Normal file
View File

@@ -0,0 +1,219 @@
c-----------------------------------------------------------------------
c\BeginDoc
c
c\Name: ssgets
c
c\Description:
c Given the eigenvalues of the symmetric tridiagonal matrix H,
c computes the NP shifts AMU that are zeros of the polynomial of
c degree NP which filters out components of the unwanted eigenvectors
c corresponding to the AMU's based on some given criteria.
c
c NOTE: This is called even in the case of user specified shifts in
c order to sort the eigenvalues, and error bounds of H for later use.
c
c\Usage:
c call ssgets
c ( ISHIFT, WHICH, KEV, NP, RITZ, BOUNDS, SHIFTS )
c
c\Arguments
c ISHIFT Integer. (INPUT)
c Method for selecting the implicit shifts at each iteration.
c ISHIFT = 0: user specified shifts
c ISHIFT = 1: exact shift with respect to the matrix H.
c
c WHICH Character*2. (INPUT)
c Shift selection criteria.
c 'LM' -> KEV eigenvalues of largest magnitude are retained.
c 'SM' -> KEV eigenvalues of smallest magnitude are retained.
c 'LA' -> KEV eigenvalues of largest value are retained.
c 'SA' -> KEV eigenvalues of smallest value are retained.
c 'BE' -> KEV eigenvalues, half from each end of the spectrum.
c If KEV is odd, compute one more from the high end.
c
c KEV Integer. (INPUT)
c KEV+NP is the size of the matrix H.
c
c NP Integer. (INPUT)
c Number of implicit shifts to be computed.
c
c RITZ Real array of length KEV+NP. (INPUT/OUTPUT)
c On INPUT, RITZ contains the eigenvalues of H.
c On OUTPUT, RITZ are sorted so that the unwanted eigenvalues
c are in the first NP locations and the wanted part is in
c the last KEV locations. When exact shifts are selected, the
c unwanted part corresponds to the shifts to be applied.
c
c BOUNDS Real array of length KEV+NP. (INPUT/OUTPUT)
c Error bounds corresponding to the ordering in RITZ.
c
c SHIFTS Real array of length NP. (INPUT/OUTPUT)
c On INPUT: contains the user specified shifts if ISHIFT = 0.
c On OUTPUT: contains the shifts sorted into decreasing order
c of magnitude with respect to the Ritz estimates contained in
c BOUNDS. If ISHIFT = 0, SHIFTS is not modified on exit.
c
c\EndDoc
c
c-----------------------------------------------------------------------
c
c\BeginLib
c
c\Local variables:
c xxxxxx real
c
c\Routines called:
c ssortr ARPACK utility sorting routine.
c ivout ARPACK utility routine that prints integers.
c second ARPACK utility routine for timing.
c svout ARPACK utility routine that prints vectors.
c scopy Level 1 BLAS that copies one vector to another.
c sswap Level 1 BLAS that swaps the contents of two vectors.
c
c\Author
c Danny Sorensen Phuong Vu
c Richard Lehoucq CRPC / Rice University
c Dept. of Computational & Houston, Texas
c Applied Mathematics
c Rice University
c Houston, Texas
c
c\Revision history:
c xx/xx/93: Version ' 2.1'
c
c\SCCS Information: @(#)
c FILE: sgets.F SID: 2.4 DATE OF SID: 4/19/96 RELEASE: 2
c
c\Remarks
c
c\EndLib
c
c-----------------------------------------------------------------------
c
subroutine ssgets ( ishift, which, kev, np, ritz, bounds, shifts )
c
c %----------------------------------------------------%
c | Include files for debugging and timing information |
c %----------------------------------------------------%
c
include 'debug.h'
include 'stat.h'
c
c %------------------%
c | Scalar Arguments |
c %------------------%
c
character*2 which
integer ishift, kev, np
c
c %-----------------%
c | Array Arguments |
c %-----------------%
c
Real
& bounds(kev+np), ritz(kev+np), shifts(np)
c
c %------------%
c | Parameters |
c %------------%
c
Real
& one, zero
parameter (one = 1.0E+0, zero = 0.0E+0)
c
c %---------------%
c | Local Scalars |
c %---------------%
c
integer kevd2, msglvl
c
c %----------------------%
c | External Subroutines |
c %----------------------%
c
external sswap, scopy, ssortr, second
c
c %---------------------%
c | Intrinsic Functions |
c %---------------------%
c
intrinsic max, min
c
c %-----------------------%
c | Executable Statements |
c %-----------------------%
c
c %-------------------------------%
c | Initialize timing statistics |
c | & message level for debugging |
c %-------------------------------%
c
call second (t0)
msglvl = msgets
c
if (which .eq. 'BE') then
c
c %-----------------------------------------------------%
c | Both ends of the spectrum are requested. |
c | Sort the eigenvalues into algebraically increasing |
c | order first then swap high end of the spectrum next |
c | to low end in appropriate locations. |
c | NOTE: when np < floor(kev/2) be careful not to swap |
c | overlapping locations. |
c %-----------------------------------------------------%
c
call ssortr ('LA', .true., kev+np, ritz, bounds)
kevd2 = kev / 2
if ( kev .gt. 1 ) then
call sswap ( min(kevd2,np), ritz, 1,
& ritz( max(kevd2,np)+1 ), 1)
call sswap ( min(kevd2,np), bounds, 1,
& bounds( max(kevd2,np)+1 ), 1)
end if
c
else
c
c %----------------------------------------------------%
c | LM, SM, LA, SA case. |
c | Sort the eigenvalues of H into the desired order |
c | and apply the resulting order to BOUNDS. |
c | The eigenvalues are sorted so that the wanted part |
c | are always in the last KEV locations. |
c %----------------------------------------------------%
c
call ssortr (which, .true., kev+np, ritz, bounds)
end if
c
if (ishift .eq. 1 .and. np .gt. 0) then
c
c %-------------------------------------------------------%
c | Sort the unwanted Ritz values used as shifts so that |
c | the ones with largest Ritz estimates are first. |
c | This will tend to minimize the effects of the |
c | forward instability of the iteration when the shifts |
c | are applied in subroutine ssapps. |
c %-------------------------------------------------------%
c
call ssortr ('SM', .true., np, bounds, ritz)
call scopy (np, ritz, 1, shifts, 1)
end if
c
call second (t1)
tsgets = tsgets + (t1 - t0)
c
if (msglvl .gt. 0) then
call ivout (logfil, 1, kev, ndigit, '_sgets: KEV is')
call ivout (logfil, 1, np, ndigit, '_sgets: NP is')
call svout (logfil, kev+np, ritz, ndigit,
& '_sgets: Eigenvalues of current H matrix')
call svout (logfil, kev+np, bounds, ndigit,
& '_sgets: Associated Ritz estimates')
end if
c
return
c
c %---------------%
c | End of ssgets |
c %---------------%
c
end

344
arpack/ARPACK/SRC/ssortc.f Normal file
View File

@@ -0,0 +1,344 @@
c-----------------------------------------------------------------------
c\BeginDoc
c
c\Name: ssortc
c
c\Description:
c Sorts the complex array in XREAL and XIMAG into the order
c specified by WHICH and optionally applies the permutation to the
c real array Y. It is assumed that if an element of XIMAG is
c nonzero, then its negative is also an element. In other words,
c both members of a complex conjugate pair are to be sorted and the
c pairs are kept adjacent to each other.
c
c\Usage:
c call ssortc
c ( WHICH, APPLY, N, XREAL, XIMAG, Y )
c
c\Arguments
c WHICH Character*2. (Input)
c 'LM' -> sort XREAL,XIMAG into increasing order of magnitude.
c 'SM' -> sort XREAL,XIMAG into decreasing order of magnitude.
c 'LR' -> sort XREAL into increasing order of algebraic.
c 'SR' -> sort XREAL into decreasing order of algebraic.
c 'LI' -> sort XIMAG into increasing order of magnitude.
c 'SI' -> sort XIMAG into decreasing order of magnitude.
c NOTE: If an element of XIMAG is non-zero, then its negative
c is also an element.
c
c APPLY Logical. (Input)
c APPLY = .TRUE. -> apply the sorted order to array Y.
c APPLY = .FALSE. -> do not apply the sorted order to array Y.
c
c N Integer. (INPUT)
c Size of the arrays.
c
c XREAL, Real array of length N. (INPUT/OUTPUT)
c XIMAG Real and imaginary part of the array to be sorted.
c
c Y Real array of length N. (INPUT/OUTPUT)
c
c\EndDoc
c
c-----------------------------------------------------------------------
c
c\BeginLib
c
c\Author
c Danny Sorensen Phuong Vu
c Richard Lehoucq CRPC / Rice University
c Dept. of Computational & Houston, Texas
c Applied Mathematics
c Rice University
c Houston, Texas
c
c\Revision history:
c xx/xx/92: Version ' 2.1'
c Adapted from the sort routine in LANSO.
c
c\SCCS Information: @(#)
c FILE: sortc.F SID: 2.3 DATE OF SID: 4/20/96 RELEASE: 2
c
c\EndLib
c
c-----------------------------------------------------------------------
c
subroutine ssortc (which, apply, n, xreal, ximag, y)
c
c %------------------%
c | Scalar Arguments |
c %------------------%
c
character*2 which
logical apply
integer n
c
c %-----------------%
c | Array Arguments |
c %-----------------%
c
Real
& xreal(0:n-1), ximag(0:n-1), y(0:n-1)
c
c %---------------%
c | Local Scalars |
c %---------------%
c
integer i, igap, j
Real
& temp, temp1, temp2
c
c %--------------------%
c | External Functions |
c %--------------------%
c
Real
& slapy2
external slapy2
c
c %-----------------------%
c | Executable Statements |
c %-----------------------%
c
igap = n / 2
c
if (which .eq. 'LM') then
c
c %------------------------------------------------------%
c | Sort XREAL,XIMAG into increasing order of magnitude. |
c %------------------------------------------------------%
c
10 continue
if (igap .eq. 0) go to 9000
c
do 30 i = igap, n-1
j = i-igap
20 continue
c
if (j.lt.0) go to 30
c
temp1 = slapy2(xreal(j),ximag(j))
temp2 = slapy2(xreal(j+igap),ximag(j+igap))
c
if (temp1.gt.temp2) then
temp = xreal(j)
xreal(j) = xreal(j+igap)
xreal(j+igap) = temp
c
temp = ximag(j)
ximag(j) = ximag(j+igap)
ximag(j+igap) = temp
c
if (apply) then
temp = y(j)
y(j) = y(j+igap)
y(j+igap) = temp
end if
else
go to 30
end if
j = j-igap
go to 20
30 continue
igap = igap / 2
go to 10
c
else if (which .eq. 'SM') then
c
c %------------------------------------------------------%
c | Sort XREAL,XIMAG into decreasing order of magnitude. |
c %------------------------------------------------------%
c
40 continue
if (igap .eq. 0) go to 9000
c
do 60 i = igap, n-1
j = i-igap
50 continue
c
if (j .lt. 0) go to 60
c
temp1 = slapy2(xreal(j),ximag(j))
temp2 = slapy2(xreal(j+igap),ximag(j+igap))
c
if (temp1.lt.temp2) then
temp = xreal(j)
xreal(j) = xreal(j+igap)
xreal(j+igap) = temp
c
temp = ximag(j)
ximag(j) = ximag(j+igap)
ximag(j+igap) = temp
c
if (apply) then
temp = y(j)
y(j) = y(j+igap)
y(j+igap) = temp
end if
else
go to 60
endif
j = j-igap
go to 50
60 continue
igap = igap / 2
go to 40
c
else if (which .eq. 'LR') then
c
c %------------------------------------------------%
c | Sort XREAL into increasing order of algebraic. |
c %------------------------------------------------%
c
70 continue
if (igap .eq. 0) go to 9000
c
do 90 i = igap, n-1
j = i-igap
80 continue
c
if (j.lt.0) go to 90
c
if (xreal(j).gt.xreal(j+igap)) then
temp = xreal(j)
xreal(j) = xreal(j+igap)
xreal(j+igap) = temp
c
temp = ximag(j)
ximag(j) = ximag(j+igap)
ximag(j+igap) = temp
c
if (apply) then
temp = y(j)
y(j) = y(j+igap)
y(j+igap) = temp
end if
else
go to 90
endif
j = j-igap
go to 80
90 continue
igap = igap / 2
go to 70
c
else if (which .eq. 'SR') then
c
c %------------------------------------------------%
c | Sort XREAL into decreasing order of algebraic. |
c %------------------------------------------------%
c
100 continue
if (igap .eq. 0) go to 9000
do 120 i = igap, n-1
j = i-igap
110 continue
c
if (j.lt.0) go to 120
c
if (xreal(j).lt.xreal(j+igap)) then
temp = xreal(j)
xreal(j) = xreal(j+igap)
xreal(j+igap) = temp
c
temp = ximag(j)
ximag(j) = ximag(j+igap)
ximag(j+igap) = temp
c
if (apply) then
temp = y(j)
y(j) = y(j+igap)
y(j+igap) = temp
end if
else
go to 120
endif
j = j-igap
go to 110
120 continue
igap = igap / 2
go to 100
c
else if (which .eq. 'LI') then
c
c %------------------------------------------------%
c | Sort XIMAG into increasing order of magnitude. |
c %------------------------------------------------%
c
130 continue
if (igap .eq. 0) go to 9000
do 150 i = igap, n-1
j = i-igap
140 continue
c
if (j.lt.0) go to 150
c
if (abs(ximag(j)).gt.abs(ximag(j+igap))) then
temp = xreal(j)
xreal(j) = xreal(j+igap)
xreal(j+igap) = temp
c
temp = ximag(j)
ximag(j) = ximag(j+igap)
ximag(j+igap) = temp
c
if (apply) then
temp = y(j)
y(j) = y(j+igap)
y(j+igap) = temp
end if
else
go to 150
endif
j = j-igap
go to 140
150 continue
igap = igap / 2
go to 130
c
else if (which .eq. 'SI') then
c
c %------------------------------------------------%
c | Sort XIMAG into decreasing order of magnitude. |
c %------------------------------------------------%
c
160 continue
if (igap .eq. 0) go to 9000
do 180 i = igap, n-1
j = i-igap
170 continue
c
if (j.lt.0) go to 180
c
if (abs(ximag(j)).lt.abs(ximag(j+igap))) then
temp = xreal(j)
xreal(j) = xreal(j+igap)
xreal(j+igap) = temp
c
temp = ximag(j)
ximag(j) = ximag(j+igap)
ximag(j+igap) = temp
c
if (apply) then
temp = y(j)
y(j) = y(j+igap)
y(j+igap) = temp
end if
else
go to 180
endif
j = j-igap
go to 170
180 continue
igap = igap / 2
go to 160
end if
c
9000 continue
return
c
c %---------------%
c | End of ssortc |
c %---------------%
c
end

218
arpack/ARPACK/SRC/ssortr.f Normal file
View File

@@ -0,0 +1,218 @@
c-----------------------------------------------------------------------
c\BeginDoc
c
c\Name: ssortr
c
c\Description:
c Sort the array X1 in the order specified by WHICH and optionally
c applies the permutation to the array X2.
c
c\Usage:
c call ssortr
c ( WHICH, APPLY, N, X1, X2 )
c
c\Arguments
c WHICH Character*2. (Input)
c 'LM' -> X1 is sorted into increasing order of magnitude.
c 'SM' -> X1 is sorted into decreasing order of magnitude.
c 'LA' -> X1 is sorted into increasing order of algebraic.
c 'SA' -> X1 is sorted into decreasing order of algebraic.
c
c APPLY Logical. (Input)
c APPLY = .TRUE. -> apply the sorted order to X2.
c APPLY = .FALSE. -> do not apply the sorted order to X2.
c
c N Integer. (INPUT)
c Size of the arrays.
c
c X1 Real array of length N. (INPUT/OUTPUT)
c The array to be sorted.
c
c X2 Real array of length N. (INPUT/OUTPUT)
c Only referenced if APPLY = .TRUE.
c
c\EndDoc
c
c-----------------------------------------------------------------------
c
c\BeginLib
c
c\Author
c Danny Sorensen Phuong Vu
c Richard Lehoucq CRPC / Rice University
c Dept. of Computational & Houston, Texas
c Applied Mathematics
c Rice University
c Houston, Texas
c
c\Revision history:
c 12/16/93: Version ' 2.1'.
c Adapted from the sort routine in LANSO.
c
c\SCCS Information: @(#)
c FILE: sortr.F SID: 2.3 DATE OF SID: 4/19/96 RELEASE: 2
c
c\EndLib
c
c-----------------------------------------------------------------------
c
subroutine ssortr (which, apply, n, x1, x2)
c
c %------------------%
c | Scalar Arguments |
c %------------------%
c
character*2 which
logical apply
integer n
c
c %-----------------%
c | Array Arguments |
c %-----------------%
c
Real
& x1(0:n-1), x2(0:n-1)
c
c %---------------%
c | Local Scalars |
c %---------------%
c
integer i, igap, j
Real
& temp
c
c %-----------------------%
c | Executable Statements |
c %-----------------------%
c
igap = n / 2
c
if (which .eq. 'SA') then
c
c X1 is sorted into decreasing order of algebraic.
c
10 continue
if (igap .eq. 0) go to 9000
do 30 i = igap, n-1
j = i-igap
20 continue
c
if (j.lt.0) go to 30
c
if (x1(j).lt.x1(j+igap)) then
temp = x1(j)
x1(j) = x1(j+igap)
x1(j+igap) = temp
if (apply) then
temp = x2(j)
x2(j) = x2(j+igap)
x2(j+igap) = temp
end if
else
go to 30
endif
j = j-igap
go to 20
30 continue
igap = igap / 2
go to 10
c
else if (which .eq. 'SM') then
c
c X1 is sorted into decreasing order of magnitude.
c
40 continue
if (igap .eq. 0) go to 9000
do 60 i = igap, n-1
j = i-igap
50 continue
c
if (j.lt.0) go to 60
c
if (abs(x1(j)).lt.abs(x1(j+igap))) then
temp = x1(j)
x1(j) = x1(j+igap)
x1(j+igap) = temp
if (apply) then
temp = x2(j)
x2(j) = x2(j+igap)
x2(j+igap) = temp
end if
else
go to 60
endif
j = j-igap
go to 50
60 continue
igap = igap / 2
go to 40
c
else if (which .eq. 'LA') then
c
c X1 is sorted into increasing order of algebraic.
c
70 continue
if (igap .eq. 0) go to 9000
do 90 i = igap, n-1
j = i-igap
80 continue
c
if (j.lt.0) go to 90
c
if (x1(j).gt.x1(j+igap)) then
temp = x1(j)
x1(j) = x1(j+igap)
x1(j+igap) = temp
if (apply) then
temp = x2(j)
x2(j) = x2(j+igap)
x2(j+igap) = temp
end if
else
go to 90
endif
j = j-igap
go to 80
90 continue
igap = igap / 2
go to 70
c
else if (which .eq. 'LM') then
c
c X1 is sorted into increasing order of magnitude.
c
100 continue
if (igap .eq. 0) go to 9000
do 120 i = igap, n-1
j = i-igap
110 continue
c
if (j.lt.0) go to 120
c
if (abs(x1(j)).gt.abs(x1(j+igap))) then
temp = x1(j)
x1(j) = x1(j+igap)
x1(j+igap) = temp
if (apply) then
temp = x2(j)
x2(j) = x2(j+igap)
x2(j+igap) = temp
end if
else
go to 120
endif
j = j-igap
go to 110
120 continue
igap = igap / 2
go to 100
end if
c
9000 continue
return
c
c %---------------%
c | End of ssortr |
c %---------------%
c
end

61
arpack/ARPACK/SRC/sstatn.f Normal file
View File

@@ -0,0 +1,61 @@
c
c %---------------------------------------------%
c | Initialize statistic and timing information |
c | for nonsymmetric Arnoldi code. |
c %---------------------------------------------%
c
c\Author
c Danny Sorensen Phuong Vu
c Richard Lehoucq CRPC / Rice University
c Dept. of Computational & Houston, Texas
c Applied Mathematics
c Rice University
c Houston, Texas
c
c\SCCS Information: @(#)
c FILE: statn.F SID: 2.4 DATE OF SID: 4/20/96 RELEASE: 2
c
subroutine sstatn
c
c %--------------------------------%
c | See stat.doc for documentation |
c %--------------------------------%
c
include 'stat.h'
c
c %-----------------------%
c | Executable Statements |
c %-----------------------%
c
nopx = 0
nbx = 0
nrorth = 0
nitref = 0
nrstrt = 0
c
tnaupd = 0.0E+0
tnaup2 = 0.0E+0
tnaitr = 0.0E+0
tneigh = 0.0E+0
tngets = 0.0E+0
tnapps = 0.0E+0
tnconv = 0.0E+0
titref = 0.0E+0
tgetv0 = 0.0E+0
trvec = 0.0E+0
c
c %----------------------------------------------------%
c | User time including reverse communication overhead |
c %----------------------------------------------------%
c
tmvopx = 0.0E+0
tmvbx = 0.0E+0
c
return
c
c
c %---------------%
c | End of sstatn |
c %---------------%
c
end

47
arpack/ARPACK/SRC/sstats.f Normal file
View File

@@ -0,0 +1,47 @@
c
c\SCCS Information: @(#)
c FILE: stats.F SID: 2.1 DATE OF SID: 4/19/96 RELEASE: 2
c %---------------------------------------------%
c | Initialize statistic and timing information |
c | for symmetric Arnoldi code. |
c %---------------------------------------------%
subroutine sstats
c %--------------------------------%
c | See stat.doc for documentation |
c %--------------------------------%
include 'stat.h'
c %-----------------------%
c | Executable Statements |
c %-----------------------%
nopx = 0
nbx = 0
nrorth = 0
nitref = 0
nrstrt = 0
tsaupd = 0.0E+0
tsaup2 = 0.0E+0
tsaitr = 0.0E+0
tseigt = 0.0E+0
tsgets = 0.0E+0
tsapps = 0.0E+0
tsconv = 0.0E+0
titref = 0.0E+0
tgetv0 = 0.0E+0
trvec = 0.0E+0
c %----------------------------------------------------%
c | User time including reverse communication overhead |
c %----------------------------------------------------%
tmvopx = 0.0E+0
tmvbx = 0.0E+0
return
c
c End of sstats
c
end

594
arpack/ARPACK/SRC/sstqrb.f Normal file
View File

@@ -0,0 +1,594 @@
c-----------------------------------------------------------------------
c\BeginDoc
c
c\Name: sstqrb
c
c\Description:
c Computes all eigenvalues and the last component of the eigenvectors
c of a symmetric tridiagonal matrix using the implicit QL or QR method.
c
c This is mostly a modification of the LAPACK routine ssteqr.
c See Remarks.
c
c\Usage:
c call sstqrb
c ( N, D, E, Z, WORK, INFO )
c
c\Arguments
c N Integer. (INPUT)
c The number of rows and columns in the matrix. N >= 0.
c
c D Real array, dimension (N). (INPUT/OUTPUT)
c On entry, D contains the diagonal elements of the
c tridiagonal matrix.
c On exit, D contains the eigenvalues, in ascending order.
c If an error exit is made, the eigenvalues are correct
c for indices 1,2,...,INFO-1, but they are unordered and
c may not be the smallest eigenvalues of the matrix.
c
c E Real array, dimension (N-1). (INPUT/OUTPUT)
c On entry, E contains the subdiagonal elements of the
c tridiagonal matrix in positions 1 through N-1.
c On exit, E has been destroyed.
c
c Z Real array, dimension (N). (OUTPUT)
c On exit, Z contains the last row of the orthonormal
c eigenvector matrix of the symmetric tridiagonal matrix.
c If an error exit is made, Z contains the last row of the
c eigenvector matrix associated with the stored eigenvalues.
c
c WORK Real array, dimension (max(1,2*N-2)). (WORKSPACE)
c Workspace used in accumulating the transformation for
c computing the last components of the eigenvectors.
c
c INFO Integer. (OUTPUT)
c = 0: normal return.
c < 0: if INFO = -i, the i-th argument had an illegal value.
c > 0: if INFO = +i, the i-th eigenvalue has not converged
c after a total of 30*N iterations.
c
c\Remarks
c 1. None.
c
c-----------------------------------------------------------------------
c
c\BeginLib
c
c\Local variables:
c xxxxxx real
c
c\Routines called:
c saxpy Level 1 BLAS that computes a vector triad.
c scopy Level 1 BLAS that copies one vector to another.
c sswap Level 1 BLAS that swaps the contents of two vectors.
c lsame LAPACK character comparison routine.
c slae2 LAPACK routine that computes the eigenvalues of a 2-by-2
c symmetric matrix.
c slaev2 LAPACK routine that eigendecomposition of a 2-by-2 symmetric
c matrix.
c slamch LAPACK routine that determines machine constants.
c slanst LAPACK routine that computes the norm of a matrix.
c slapy2 LAPACK routine to compute sqrt(x**2+y**2) carefully.
c slartg LAPACK Givens rotation construction routine.
c slascl LAPACK routine for careful scaling of a matrix.
c slaset LAPACK matrix initialization routine.
c slasr LAPACK routine that applies an orthogonal transformation to
c a matrix.
c slasrt LAPACK sorting routine.
c ssteqr LAPACK routine that computes eigenvalues and eigenvectors
c of a symmetric tridiagonal matrix.
c xerbla LAPACK error handler routine.
c
c\Authors
c Danny Sorensen Phuong Vu
c Richard Lehoucq CRPC / Rice University
c Dept. of Computational & Houston, Texas
c Applied Mathematics
c Rice University
c Houston, Texas
c
c\SCCS Information: @(#)
c FILE: stqrb.F SID: 2.5 DATE OF SID: 8/27/96 RELEASE: 2
c
c\Remarks
c 1. Starting with version 2.5, this routine is a modified version
c of LAPACK version 2.0 subroutine SSTEQR. No lines are deleted,
c only commeted out and new lines inserted.
c All lines commented out have "c$$$" at the beginning.
c Note that the LAPACK version 1.0 subroutine SSTEQR contained
c bugs.
c
c\EndLib
c
c-----------------------------------------------------------------------
c
subroutine sstqrb ( n, d, e, z, work, info )
c
c %------------------%
c | Scalar Arguments |
c %------------------%
c
integer info, n
c
c %-----------------%
c | Array Arguments |
c %-----------------%
c
Real
& d( n ), e( n-1 ), z( n ), work( 2*n-2 )
c
c .. parameters ..
Real
& zero, one, two, three
parameter ( zero = 0.0E+0, one = 1.0E+0,
& two = 2.0E+0, three = 3.0E+0 )
integer maxit
parameter ( maxit = 30 )
c ..
c .. local scalars ..
integer i, icompz, ii, iscale, j, jtot, k, l, l1, lend,
& lendm1, lendp1, lendsv, lm1, lsv, m, mm, mm1,
& nm1, nmaxit
Real
& anorm, b, c, eps, eps2, f, g, p, r, rt1, rt2,
& s, safmax, safmin, ssfmax, ssfmin, tst
c ..
c .. external functions ..
logical lsame
Real
& slamch, slanst, slapy2
external lsame, slamch, slanst, slapy2
c ..
c .. external subroutines ..
external slae2, slaev2, slartg, slascl, slaset, slasr,
& slasrt, sswap, xerbla
c ..
c .. intrinsic functions ..
intrinsic abs, max, sign, sqrt
c ..
c .. executable statements ..
c
c test the input parameters.
c
info = 0
c
c$$$ IF( LSAME( COMPZ, 'N' ) ) THEN
c$$$ ICOMPZ = 0
c$$$ ELSE IF( LSAME( COMPZ, 'V' ) ) THEN
c$$$ ICOMPZ = 1
c$$$ ELSE IF( LSAME( COMPZ, 'I' ) ) THEN
c$$$ ICOMPZ = 2
c$$$ ELSE
c$$$ ICOMPZ = -1
c$$$ END IF
c$$$ IF( ICOMPZ.LT.0 ) THEN
c$$$ INFO = -1
c$$$ ELSE IF( N.LT.0 ) THEN
c$$$ INFO = -2
c$$$ ELSE IF( ( LDZ.LT.1 ) .OR. ( ICOMPZ.GT.0 .AND. LDZ.LT.MAX( 1,
c$$$ $ N ) ) ) THEN
c$$$ INFO = -6
c$$$ END IF
c$$$ IF( INFO.NE.0 ) THEN
c$$$ CALL XERBLA( 'SSTEQR', -INFO )
c$$$ RETURN
c$$$ END IF
c
c *** New starting with version 2.5 ***
c
icompz = 2
c *************************************
c
c quick return if possible
c
if( n.eq.0 )
$ return
c
if( n.eq.1 ) then
if( icompz.eq.2 ) z( 1 ) = one
return
end if
c
c determine the unit roundoff and over/underflow thresholds.
c
eps = slamch( 'e' )
eps2 = eps**2
safmin = slamch( 's' )
safmax = one / safmin
ssfmax = sqrt( safmax ) / three
ssfmin = sqrt( safmin ) / eps2
c
c compute the eigenvalues and eigenvectors of the tridiagonal
c matrix.
c
c$$ if( icompz.eq.2 )
c$$$ $ call slaset( 'full', n, n, zero, one, z, ldz )
c
c *** New starting with version 2.5 ***
c
if ( icompz .eq. 2 ) then
do 5 j = 1, n-1
z(j) = zero
5 continue
z( n ) = one
end if
c *************************************
c
nmaxit = n*maxit
jtot = 0
c
c determine where the matrix splits and choose ql or qr iteration
c for each block, according to whether top or bottom diagonal
c element is smaller.
c
l1 = 1
nm1 = n - 1
c
10 continue
if( l1.gt.n )
$ go to 160
if( l1.gt.1 )
$ e( l1-1 ) = zero
if( l1.le.nm1 ) then
do 20 m = l1, nm1
tst = abs( e( m ) )
if( tst.eq.zero )
$ go to 30
if( tst.le.( sqrt( abs( d( m ) ) )*sqrt( abs( d( m+
$ 1 ) ) ) )*eps ) then
e( m ) = zero
go to 30
end if
20 continue
end if
m = n
c
30 continue
l = l1
lsv = l
lend = m
lendsv = lend
l1 = m + 1
if( lend.eq.l )
$ go to 10
c
c scale submatrix in rows and columns l to lend
c
anorm = slanst( 'i', lend-l+1, d( l ), e( l ) )
iscale = 0
if( anorm.eq.zero )
$ go to 10
if( anorm.gt.ssfmax ) then
iscale = 1
call slascl( 'g', 0, 0, anorm, ssfmax, lend-l+1, 1, d( l ), n,
$ info )
call slascl( 'g', 0, 0, anorm, ssfmax, lend-l, 1, e( l ), n,
$ info )
else if( anorm.lt.ssfmin ) then
iscale = 2
call slascl( 'g', 0, 0, anorm, ssfmin, lend-l+1, 1, d( l ), n,
$ info )
call slascl( 'g', 0, 0, anorm, ssfmin, lend-l, 1, e( l ), n,
$ info )
end if
c
c choose between ql and qr iteration
c
if( abs( d( lend ) ).lt.abs( d( l ) ) ) then
lend = lsv
l = lendsv
end if
c
if( lend.gt.l ) then
c
c ql iteration
c
c look for small subdiagonal element.
c
40 continue
if( l.ne.lend ) then
lendm1 = lend - 1
do 50 m = l, lendm1
tst = abs( e( m ) )**2
if( tst.le.( eps2*abs( d( m ) ) )*abs( d( m+1 ) )+
$ safmin )go to 60
50 continue
end if
c
m = lend
c
60 continue
if( m.lt.lend )
$ e( m ) = zero
p = d( l )
if( m.eq.l )
$ go to 80
c
c if remaining matrix is 2-by-2, use slae2 or slaev2
c to compute its eigensystem.
c
if( m.eq.l+1 ) then
if( icompz.gt.0 ) then
call slaev2( d( l ), e( l ), d( l+1 ), rt1, rt2, c, s )
work( l ) = c
work( n-1+l ) = s
c$$$ call slasr( 'r', 'v', 'b', n, 2, work( l ),
c$$$ $ work( n-1+l ), z( 1, l ), ldz )
c
c *** New starting with version 2.5 ***
c
tst = z(l+1)
z(l+1) = c*tst - s*z(l)
z(l) = s*tst + c*z(l)
c *************************************
else
call slae2( d( l ), e( l ), d( l+1 ), rt1, rt2 )
end if
d( l ) = rt1
d( l+1 ) = rt2
e( l ) = zero
l = l + 2
if( l.le.lend )
$ go to 40
go to 140
end if
c
if( jtot.eq.nmaxit )
$ go to 140
jtot = jtot + 1
c
c form shift.
c
g = ( d( l+1 )-p ) / ( two*e( l ) )
r = slapy2( g, one )
g = d( m ) - p + ( e( l ) / ( g+sign( r, g ) ) )
c
s = one
c = one
p = zero
c
c inner loop
c
mm1 = m - 1
do 70 i = mm1, l, -1
f = s*e( i )
b = c*e( i )
call slartg( g, f, c, s, r )
if( i.ne.m-1 )
$ e( i+1 ) = r
g = d( i+1 ) - p
r = ( d( i )-g )*s + two*c*b
p = s*r
d( i+1 ) = g + p
g = c*r - b
c
c if eigenvectors are desired, then save rotations.
c
if( icompz.gt.0 ) then
work( i ) = c
work( n-1+i ) = -s
end if
c
70 continue
c
c if eigenvectors are desired, then apply saved rotations.
c
if( icompz.gt.0 ) then
mm = m - l + 1
c$$$ call slasr( 'r', 'v', 'b', n, mm, work( l ), work( n-1+l ),
c$$$ $ z( 1, l ), ldz )
c
c *** New starting with version 2.5 ***
c
call slasr( 'r', 'v', 'b', 1, mm, work( l ),
& work( n-1+l ), z( l ), 1 )
c *************************************
end if
c
d( l ) = d( l ) - p
e( l ) = g
go to 40
c
c eigenvalue found.
c
80 continue
d( l ) = p
c
l = l + 1
if( l.le.lend )
$ go to 40
go to 140
c
else
c
c qr iteration
c
c look for small superdiagonal element.
c
90 continue
if( l.ne.lend ) then
lendp1 = lend + 1
do 100 m = l, lendp1, -1
tst = abs( e( m-1 ) )**2
if( tst.le.( eps2*abs( d( m ) ) )*abs( d( m-1 ) )+
$ safmin )go to 110
100 continue
end if
c
m = lend
c
110 continue
if( m.gt.lend )
$ e( m-1 ) = zero
p = d( l )
if( m.eq.l )
$ go to 130
c
c if remaining matrix is 2-by-2, use slae2 or slaev2
c to compute its eigensystem.
c
if( m.eq.l-1 ) then
if( icompz.gt.0 ) then
call slaev2( d( l-1 ), e( l-1 ), d( l ), rt1, rt2, c, s )
c$$$ work( m ) = c
c$$$ work( n-1+m ) = s
c$$$ call slasr( 'r', 'v', 'f', n, 2, work( m ),
c$$$ $ work( n-1+m ), z( 1, l-1 ), ldz )
c
c *** New starting with version 2.5 ***
c
tst = z(l)
z(l) = c*tst - s*z(l-1)
z(l-1) = s*tst + c*z(l-1)
c *************************************
else
call slae2( d( l-1 ), e( l-1 ), d( l ), rt1, rt2 )
end if
d( l-1 ) = rt1
d( l ) = rt2
e( l-1 ) = zero
l = l - 2
if( l.ge.lend )
$ go to 90
go to 140
end if
c
if( jtot.eq.nmaxit )
$ go to 140
jtot = jtot + 1
c
c form shift.
c
g = ( d( l-1 )-p ) / ( two*e( l-1 ) )
r = slapy2( g, one )
g = d( m ) - p + ( e( l-1 ) / ( g+sign( r, g ) ) )
c
s = one
c = one
p = zero
c
c inner loop
c
lm1 = l - 1
do 120 i = m, lm1
f = s*e( i )
b = c*e( i )
call slartg( g, f, c, s, r )
if( i.ne.m )
$ e( i-1 ) = r
g = d( i ) - p
r = ( d( i+1 )-g )*s + two*c*b
p = s*r
d( i ) = g + p
g = c*r - b
c
c if eigenvectors are desired, then save rotations.
c
if( icompz.gt.0 ) then
work( i ) = c
work( n-1+i ) = s
end if
c
120 continue
c
c if eigenvectors are desired, then apply saved rotations.
c
if( icompz.gt.0 ) then
mm = l - m + 1
c$$$ call slasr( 'r', 'v', 'f', n, mm, work( m ), work( n-1+m ),
c$$$ $ z( 1, m ), ldz )
c
c *** New starting with version 2.5 ***
c
call slasr( 'r', 'v', 'f', 1, mm, work( m ), work( n-1+m ),
& z( m ), 1 )
c *************************************
end if
c
d( l ) = d( l ) - p
e( lm1 ) = g
go to 90
c
c eigenvalue found.
c
130 continue
d( l ) = p
c
l = l - 1
if( l.ge.lend )
$ go to 90
go to 140
c
end if
c
c undo scaling if necessary
c
140 continue
if( iscale.eq.1 ) then
call slascl( 'g', 0, 0, ssfmax, anorm, lendsv-lsv+1, 1,
$ d( lsv ), n, info )
call slascl( 'g', 0, 0, ssfmax, anorm, lendsv-lsv, 1, e( lsv ),
$ n, info )
else if( iscale.eq.2 ) then
call slascl( 'g', 0, 0, ssfmin, anorm, lendsv-lsv+1, 1,
$ d( lsv ), n, info )
call slascl( 'g', 0, 0, ssfmin, anorm, lendsv-lsv, 1, e( lsv ),
$ n, info )
end if
c
c check for no convergence to an eigenvalue after a total
c of n*maxit iterations.
c
if( jtot.lt.nmaxit )
$ go to 10
do 150 i = 1, n - 1
if( e( i ).ne.zero )
$ info = info + 1
150 continue
go to 190
c
c order eigenvalues and eigenvectors.
c
160 continue
if( icompz.eq.0 ) then
c
c use quick sort
c
call slasrt( 'i', n, d, info )
c
else
c
c use selection sort to minimize swaps of eigenvectors
c
do 180 ii = 2, n
i = ii - 1
k = i
p = d( i )
do 170 j = ii, n
if( d( j ).lt.p ) then
k = j
p = d( j )
end if
170 continue
if( k.ne.i ) then
d( k ) = d( i )
d( i ) = p
c$$$ call sswap( n, z( 1, i ), 1, z( 1, k ), 1 )
c *** New starting with version 2.5 ***
c
p = z(k)
z(k) = z(i)
z(i) = p
c *************************************
end if
180 continue
end if
c
190 continue
return
c
c %---------------%
c | End of sstqrb |
c %---------------%
c
end

21
arpack/ARPACK/SRC/stat.h Normal file
View File

@@ -0,0 +1,21 @@
c %--------------------------------%
c | See stat.doc for documentation |
c %--------------------------------%
c
c\SCCS Information: @(#)
c FILE: stat.h SID: 2.2 DATE OF SID: 11/16/95 RELEASE: 2
c
real t0, t1, t2, t3, t4, t5
save t0, t1, t2, t3, t4, t5
c
integer nopx, nbx, nrorth, nitref, nrstrt
real tsaupd, tsaup2, tsaitr, tseigt, tsgets, tsapps, tsconv,
& tnaupd, tnaup2, tnaitr, tneigh, tngets, tnapps, tnconv,
& tcaupd, tcaup2, tcaitr, tceigh, tcgets, tcapps, tcconv,
& tmvopx, tmvbx, tgetv0, titref, trvec
common /timing/
& nopx, nbx, nrorth, nitref, nrstrt,
& tsaupd, tsaup2, tsaitr, tseigt, tsgets, tsapps, tsconv,
& tnaupd, tnaup2, tnaitr, tneigh, tngets, tnapps, tnconv,
& tcaupd, tcaup2, tcaitr, tceigh, tcgets, tcapps, tcconv,
& tmvopx, tmvbx, tgetv0, titref, trvec

30
arpack/ARPACK/SRC/version.h Normal file
View File

@@ -0,0 +1,30 @@
/*
In the current version, the parameter KAPPA in the Kahan's test
for orthogonality is set to 0.717, the same as used by Gragg & Reichel.
However computational experience indicates that this is a little too
strict and will frequently force reorthogonalization when it is not
necessary to do so.
Also the "moving boundary" idea is not currently activated in the nonsymmetric
code since it is not conclusive that it's the right thing to do all the time.
Requires further investigation.
As of 02/01/93 Richard Lehoucq assumes software control of the codes from
Phuong Vu. On 03/01/93 all the *.F files were migrated SCCS. The 1.1 version
of codes are those received from Phuong Vu. The frozen version of 07/08/92
is now considered version 1.1.
Version 2.1 contains two new symmetric routines, sesrt and seupd.
Changes as well as bug fixes for version 1.1 codes that were only corrected
for programming bugs are version 1.2. These 1.2 versions will also be in version 2.1.
Subroutine [d,s]saupd now requires slightly more workspace. See [d,s]saupd for the
details.
\SCCS Information: @(#)
FILE: version.h SID: 2.3 DATE OF SID: 11/16/95 RELEASE: 2
*/
#define VERSION_NUMBER ' 2.1'
#define VERSION_DATE ' 11/15/95'

414
arpack/ARPACK/SRC/zgetv0.f Normal file
View File

@@ -0,0 +1,414 @@
c\BeginDoc
c
c\Name: zgetv0
c
c\Description:
c Generate a random initial residual vector for the Arnoldi process.
c Force the residual vector to be in the range of the operator OP.
c
c\Usage:
c call zgetv0
c ( IDO, BMAT, ITRY, INITV, N, J, V, LDV, RESID, RNORM,
c IPNTR, WORKD, IERR )
c
c\Arguments
c IDO Integer. (INPUT/OUTPUT)
c Reverse communication flag. IDO must be zero on the first
c call to zgetv0.
c -------------------------------------------------------------
c IDO = 0: first call to the reverse communication interface
c IDO = -1: compute Y = OP * X where
c IPNTR(1) is the pointer into WORKD for X,
c IPNTR(2) is the pointer into WORKD for Y.
c This is for the initialization phase to force the
c starting vector into the range of OP.
c IDO = 2: compute Y = B * X where
c IPNTR(1) is the pointer into WORKD for X,
c IPNTR(2) is the pointer into WORKD for Y.
c IDO = 99: done
c -------------------------------------------------------------
c
c BMAT Character*1. (INPUT)
c BMAT specifies the type of the matrix B in the (generalized)
c eigenvalue problem A*x = lambda*B*x.
c B = 'I' -> standard eigenvalue problem A*x = lambda*x
c B = 'G' -> generalized eigenvalue problem A*x = lambda*B*x
c
c ITRY Integer. (INPUT)
c ITRY counts the number of times that zgetv0 is called.
c It should be set to 1 on the initial call to zgetv0.
c
c INITV Logical variable. (INPUT)
c .TRUE. => the initial residual vector is given in RESID.
c .FALSE. => generate a random initial residual vector.
c
c N Integer. (INPUT)
c Dimension of the problem.
c
c J Integer. (INPUT)
c Index of the residual vector to be generated, with respect to
c the Arnoldi process. J > 1 in case of a "restart".
c
c V Complex*16 N by J array. (INPUT)
c The first J-1 columns of V contain the current Arnoldi basis
c if this is a "restart".
c
c LDV Integer. (INPUT)
c Leading dimension of V exactly as declared in the calling
c program.
c
c RESID Complex*16 array of length N. (INPUT/OUTPUT)
c Initial residual vector to be generated. If RESID is
c provided, force RESID into the range of the operator OP.
c
c RNORM Double precision scalar. (OUTPUT)
c B-norm of the generated residual.
c
c IPNTR Integer array of length 3. (OUTPUT)
c
c WORKD Complex*16 work array of length 2*N. (REVERSE COMMUNICATION).
c On exit, WORK(1:N) = B*RESID to be used in SSAITR.
c
c IERR Integer. (OUTPUT)
c = 0: Normal exit.
c = -1: Cannot generate a nontrivial restarted residual vector
c in the range of the operator OP.
c
c\EndDoc
c
c-----------------------------------------------------------------------
c
c\BeginLib
c
c\Local variables:
c xxxxxx Complex*16
c
c\References:
c 1. D.C. Sorensen, "Implicit Application of Polynomial Filters in
c a k-Step Arnoldi Method", SIAM J. Matr. Anal. Apps., 13 (1992),
c pp 357-385.
c
c\Routines called:
c second ARPACK utility routine for timing.
c zvout ARPACK utility routine that prints vectors.
c zlarnv LAPACK routine for generating a random vector.
c zgemv Level 2 BLAS routine for matrix vector multiplication.
c zcopy Level 1 BLAS that copies one vector to another.
c zdotc Level 1 BLAS that computes the scalar product of two vectors.
c dznrm2 Level 1 BLAS that computes the norm of a vector.
c
c\Author
c Danny Sorensen Phuong Vu
c Richard Lehoucq CRPC / Rice University
c Dept. of Computational & Houston, Texas
c Applied Mathematics
c Rice University
c Houston, Texas
c
c\SCCS Information: @(#)
c FILE: getv0.F SID: 2.3 DATE OF SID: 08/27/96 RELEASE: 2
c
c\EndLib
c
c-----------------------------------------------------------------------
c
subroutine zgetv0
& ( ido, bmat, itry, initv, n, j, v, ldv, resid, rnorm,
& ipntr, workd, ierr )
c
c %----------------------------------------------------%
c | Include files for debugging and timing information |
c %----------------------------------------------------%
c
include 'debug.h'
include 'stat.h'
c
c %------------------%
c | Scalar Arguments |
c %------------------%
c
character bmat*1
logical initv
integer ido, ierr, itry, j, ldv, n
Double precision
& rnorm
c
c %-----------------%
c | Array Arguments |
c %-----------------%
c
integer ipntr(3)
Complex*16
& resid(n), v(ldv,j), workd(2*n)
c
c %------------%
c | Parameters |
c %------------%
c
Complex*16
& one, zero
Double precision
& rzero
parameter (one = (1.0D+0, 0.0D+0), zero = (0.0D+0, 0.0D+0),
& rzero = 0.0D+0)
c
c %------------------------%
c | Local Scalars & Arrays |
c %------------------------%
c
logical first, inits, orth
integer idist, iseed(4), iter, msglvl, jj
Double precision
& rnorm0
Complex*16
& cnorm
save first, iseed, inits, iter, msglvl, orth, rnorm0
c
c %----------------------%
c | External Subroutines |
c %----------------------%
c
external zcopy, zgemv, zlarnv, zvout, second
c
c %--------------------%
c | External Functions |
c %--------------------%
c
Double precision
& dznrm2, dlapy2
Complex*16
& zdotc
external zdotc, dznrm2, dlapy2
c
c %-----------------%
c | Data Statements |
c %-----------------%
c
data inits /.true./
c
c %-----------------------%
c | Executable Statements |
c %-----------------------%
c
c
c %-----------------------------------%
c | Initialize the seed of the LAPACK |
c | random number generator |
c %-----------------------------------%
c
if (inits) then
iseed(1) = 1
iseed(2) = 3
iseed(3) = 5
iseed(4) = 7
inits = .false.
end if
c
if (ido .eq. 0) then
c
c %-------------------------------%
c | Initialize timing statistics |
c | & message level for debugging |
c %-------------------------------%
c
call second (t0)
msglvl = mgetv0
c
ierr = 0
iter = 0
first = .FALSE.
orth = .FALSE.
c
c %-----------------------------------------------------%
c | Possibly generate a random starting vector in RESID |
c | Use a LAPACK random number generator used by the |
c | matrix generation routines. |
c | idist = 1: uniform (0,1) distribution; |
c | idist = 2: uniform (-1,1) distribution; |
c | idist = 3: normal (0,1) distribution; |
c %-----------------------------------------------------%
c
if (.not.initv) then
idist = 2
call zlarnv (idist, iseed, n, resid)
end if
c
c %----------------------------------------------------------%
c | Force the starting vector into the range of OP to handle |
c | the generalized problem when B is possibly (singular). |
c %----------------------------------------------------------%
c
call second (t2)
if (bmat .eq. 'G') then
nopx = nopx + 1
ipntr(1) = 1
ipntr(2) = n + 1
call zcopy (n, resid, 1, workd, 1)
ido = -1
go to 9000
end if
end if
c
c %----------------------------------------%
c | Back from computing B*(initial-vector) |
c %----------------------------------------%
c
if (first) go to 20
c
c %-----------------------------------------------%
c | Back from computing B*(orthogonalized-vector) |
c %-----------------------------------------------%
c
if (orth) go to 40
c
call second (t3)
tmvopx = tmvopx + (t3 - t2)
c
c %------------------------------------------------------%
c | Starting vector is now in the range of OP; r = OP*r; |
c | Compute B-norm of starting vector. |
c %------------------------------------------------------%
c
call second (t2)
first = .TRUE.
if (bmat .eq. 'G') then
nbx = nbx + 1
call zcopy (n, workd(n+1), 1, resid, 1)
ipntr(1) = n + 1
ipntr(2) = 1
ido = 2
go to 9000
else if (bmat .eq. 'I') then
call zcopy (n, resid, 1, workd, 1)
end if
c
20 continue
c
if (bmat .eq. 'G') then
call second (t3)
tmvbx = tmvbx + (t3 - t2)
end if
c
first = .FALSE.
if (bmat .eq. 'G') then
cnorm = zdotc (n, resid, 1, workd, 1)
rnorm0 = sqrt(dlapy2(dble(cnorm),dimag(cnorm)))
else if (bmat .eq. 'I') then
rnorm0 = dznrm2(n, resid, 1)
end if
rnorm = rnorm0
c
c %---------------------------------------------%
c | Exit if this is the very first Arnoldi step |
c %---------------------------------------------%
c
if (j .eq. 1) go to 50
c
c %----------------------------------------------------------------
c | Otherwise need to B-orthogonalize the starting vector against |
c | the current Arnoldi basis using Gram-Schmidt with iter. ref. |
c | This is the case where an invariant subspace is encountered |
c | in the middle of the Arnoldi factorization. |
c | |
c | s = V^{T}*B*r; r = r - V*s; |
c | |
c | Stopping criteria used for iter. ref. is discussed in |
c | Parlett's book, page 107 and in Gragg & Reichel TOMS paper. |
c %---------------------------------------------------------------%
c
orth = .TRUE.
30 continue
c
call zgemv ('C', n, j-1, one, v, ldv, workd, 1,
& zero, workd(n+1), 1)
call zgemv ('N', n, j-1, -one, v, ldv, workd(n+1), 1,
& one, resid, 1)
c
c %----------------------------------------------------------%
c | Compute the B-norm of the orthogonalized starting vector |
c %----------------------------------------------------------%
c
call second (t2)
if (bmat .eq. 'G') then
nbx = nbx + 1
call zcopy (n, resid, 1, workd(n+1), 1)
ipntr(1) = n + 1
ipntr(2) = 1
ido = 2
go to 9000
else if (bmat .eq. 'I') then
call zcopy (n, resid, 1, workd, 1)
end if
c
40 continue
c
if (bmat .eq. 'G') then
call second (t3)
tmvbx = tmvbx + (t3 - t2)
end if
c
if (bmat .eq. 'G') then
cnorm = zdotc (n, resid, 1, workd, 1)
rnorm = sqrt(dlapy2(dble(cnorm),dimag(cnorm)))
else if (bmat .eq. 'I') then
rnorm = dznrm2(n, resid, 1)
end if
c
c %--------------------------------------%
c | Check for further orthogonalization. |
c %--------------------------------------%
c
if (msglvl .gt. 2) then
call dvout (logfil, 1, rnorm0, ndigit,
& '_getv0: re-orthonalization ; rnorm0 is')
call dvout (logfil, 1, rnorm, ndigit,
& '_getv0: re-orthonalization ; rnorm is')
end if
c
if (rnorm .gt. 0.717*rnorm0) go to 50
c
iter = iter + 1
if (iter .le. 1) then
c
c %-----------------------------------%
c | Perform iterative refinement step |
c %-----------------------------------%
c
rnorm0 = rnorm
go to 30
else
c
c %------------------------------------%
c | Iterative refinement step "failed" |
c %------------------------------------%
c
do 45 jj = 1, n
resid(jj) = zero
45 continue
rnorm = rzero
ierr = -1
end if
c
50 continue
c
if (msglvl .gt. 0) then
call dvout (logfil, 1, rnorm, ndigit,
& '_getv0: B-norm of initial / restarted starting vector')
end if
if (msglvl .gt. 2) then
call zvout (logfil, n, resid, ndigit,
& '_getv0: initial / restarted starting vector')
end if
ido = 99
c
call second (t1)
tgetv0 = tgetv0 + (t1 - t0)
c
9000 continue
return
c
c %---------------%
c | End of zgetv0 |
c %---------------%
c
end

850
arpack/ARPACK/SRC/znaitr.f Normal file
View File

@@ -0,0 +1,850 @@
c\BeginDoc
c
c\Name: znaitr
c
c\Description:
c Reverse communication interface for applying NP additional steps to
c a K step nonsymmetric Arnoldi factorization.
c
c Input: OP*V_{k} - V_{k}*H = r_{k}*e_{k}^T
c
c with (V_{k}^T)*B*V_{k} = I, (V_{k}^T)*B*r_{k} = 0.
c
c Output: OP*V_{k+p} - V_{k+p}*H = r_{k+p}*e_{k+p}^T
c
c with (V_{k+p}^T)*B*V_{k+p} = I, (V_{k+p}^T)*B*r_{k+p} = 0.
c
c where OP and B are as in znaupd. The B-norm of r_{k+p} is also
c computed and returned.
c
c\Usage:
c call znaitr
c ( IDO, BMAT, N, K, NP, NB, RESID, RNORM, V, LDV, H, LDH,
c IPNTR, WORKD, INFO )
c
c\Arguments
c IDO Integer. (INPUT/OUTPUT)
c Reverse communication flag.
c -------------------------------------------------------------
c IDO = 0: first call to the reverse communication interface
c IDO = -1: compute Y = OP * X where
c IPNTR(1) is the pointer into WORK for X,
c IPNTR(2) is the pointer into WORK for Y.
c This is for the restart phase to force the new
c starting vector into the range of OP.
c IDO = 1: compute Y = OP * X where
c IPNTR(1) is the pointer into WORK for X,
c IPNTR(2) is the pointer into WORK for Y,
c IPNTR(3) is the pointer into WORK for B * X.
c IDO = 2: compute Y = B * X where
c IPNTR(1) is the pointer into WORK for X,
c IPNTR(2) is the pointer into WORK for Y.
c IDO = 99: done
c -------------------------------------------------------------
c When the routine is used in the "shift-and-invert" mode, the
c vector B * Q is already available and do not need to be
c recomputed in forming OP * Q.
c
c BMAT Character*1. (INPUT)
c BMAT specifies the type of the matrix B that defines the
c semi-inner product for the operator OP. See znaupd.
c B = 'I' -> standard eigenvalue problem A*x = lambda*x
c B = 'G' -> generalized eigenvalue problem A*x = lambda*M**x
c
c N Integer. (INPUT)
c Dimension of the eigenproblem.
c
c K Integer. (INPUT)
c Current size of V and H.
c
c NP Integer. (INPUT)
c Number of additional Arnoldi steps to take.
c
c NB Integer. (INPUT)
c Blocksize to be used in the recurrence.
c Only work for NB = 1 right now. The goal is to have a
c program that implement both the block and non-block method.
c
c RESID Complex*16 array of length N. (INPUT/OUTPUT)
c On INPUT: RESID contains the residual vector r_{k}.
c On OUTPUT: RESID contains the residual vector r_{k+p}.
c
c RNORM Double precision scalar. (INPUT/OUTPUT)
c B-norm of the starting residual on input.
c B-norm of the updated residual r_{k+p} on output.
c
c V Complex*16 N by K+NP array. (INPUT/OUTPUT)
c On INPUT: V contains the Arnoldi vectors in the first K
c columns.
c On OUTPUT: V contains the new NP Arnoldi vectors in the next
c NP columns. The first K columns are unchanged.
c
c LDV Integer. (INPUT)
c Leading dimension of V exactly as declared in the calling
c program.
c
c H Complex*16 (K+NP) by (K+NP) array. (INPUT/OUTPUT)
c H is used to store the generated upper Hessenberg matrix.
c
c LDH Integer. (INPUT)
c Leading dimension of H exactly as declared in the calling
c program.
c
c IPNTR Integer array of length 3. (OUTPUT)
c Pointer to mark the starting locations in the WORK for
c vectors used by the Arnoldi iteration.
c -------------------------------------------------------------
c IPNTR(1): pointer to the current operand vector X.
c IPNTR(2): pointer to the current result vector Y.
c IPNTR(3): pointer to the vector B * X when used in the
c shift-and-invert mode. X is the current operand.
c -------------------------------------------------------------
c
c WORKD Complex*16 work array of length 3*N. (REVERSE COMMUNICATION)
c Distributed array to be used in the basic Arnoldi iteration
c for reverse communication. The calling program should not
c use WORKD as temporary workspace during the iteration !!!!!!
c On input, WORKD(1:N) = B*RESID and is used to save some
c computation at the first step.
c
c INFO Integer. (OUTPUT)
c = 0: Normal exit.
c > 0: Size of the spanning invariant subspace of OP found.
c
c\EndDoc
c
c-----------------------------------------------------------------------
c
c\BeginLib
c
c\Local variables:
c xxxxxx Complex*16
c
c\References:
c 1. D.C. Sorensen, "Implicit Application of Polynomial Filters in
c a k-Step Arnoldi Method", SIAM J. Matr. Anal. Apps., 13 (1992),
c pp 357-385.
c 2. R.B. Lehoucq, "Analysis and Implementation of an Implicitly
c Restarted Arnoldi Iteration", Rice University Technical Report
c TR95-13, Department of Computational and Applied Mathematics.
c
c\Routines called:
c zgetv0 ARPACK routine to generate the initial vector.
c ivout ARPACK utility routine that prints integers.
c second ARPACK utility routine for timing.
c zmout ARPACK utility routine that prints matrices
c zvout ARPACK utility routine that prints vectors.
c zlanhs LAPACK routine that computes various norms of a matrix.
c zlascl LAPACK routine for careful scaling of a matrix.
c dlabad LAPACK routine for defining the underflow and overflow
c limits.
c dlamch LAPACK routine that determines machine constants.
c dlapy2 LAPACK routine to compute sqrt(x**2+y**2) carefully.
c zgemv Level 2 BLAS routine for matrix vector multiplication.
c zaxpy Level 1 BLAS that computes a vector triad.
c zcopy Level 1 BLAS that copies one vector to another .
c zdotc Level 1 BLAS that computes the scalar product of two vectors.
c zscal Level 1 BLAS that scales a vector.
c zdscal Level 1 BLAS that scales a complex vector by a real number.
c dznrm2 Level 1 BLAS that computes the norm of a vector.
c
c\Author
c Danny Sorensen Phuong Vu
c Richard Lehoucq CRPC / Rice University
c Dept. of Computational & Houston, Texas
c Applied Mathematics
c Rice University
c Houston, Texas
c
c\SCCS Information: @(#)
c FILE: naitr.F SID: 2.3 DATE OF SID: 8/27/96 RELEASE: 2
c
c\Remarks
c The algorithm implemented is:
c
c restart = .false.
c Given V_{k} = [v_{1}, ..., v_{k}], r_{k};
c r_{k} contains the initial residual vector even for k = 0;
c Also assume that rnorm = || B*r_{k} || and B*r_{k} are already
c computed by the calling program.
c
c betaj = rnorm ; p_{k+1} = B*r_{k} ;
c For j = k+1, ..., k+np Do
c 1) if ( betaj < tol ) stop or restart depending on j.
c ( At present tol is zero )
c if ( restart ) generate a new starting vector.
c 2) v_{j} = r(j-1)/betaj; V_{j} = [V_{j-1}, v_{j}];
c p_{j} = p_{j}/betaj
c 3) r_{j} = OP*v_{j} where OP is defined as in znaupd
c For shift-invert mode p_{j} = B*v_{j} is already available.
c wnorm = || OP*v_{j} ||
c 4) Compute the j-th step residual vector.
c w_{j} = V_{j}^T * B * OP * v_{j}
c r_{j} = OP*v_{j} - V_{j} * w_{j}
c H(:,j) = w_{j};
c H(j,j-1) = rnorm
c rnorm = || r_(j) ||
c If (rnorm > 0.717*wnorm) accept step and go back to 1)
c 5) Re-orthogonalization step:
c s = V_{j}'*B*r_{j}
c r_{j} = r_{j} - V_{j}*s; rnorm1 = || r_{j} ||
c alphaj = alphaj + s_{j};
c 6) Iterative refinement step:
c If (rnorm1 > 0.717*rnorm) then
c rnorm = rnorm1
c accept step and go back to 1)
c Else
c rnorm = rnorm1
c If this is the first time in step 6), go to 5)
c Else r_{j} lies in the span of V_{j} numerically.
c Set r_{j} = 0 and rnorm = 0; go to 1)
c EndIf
c End Do
c
c\EndLib
c
c-----------------------------------------------------------------------
c
subroutine znaitr
& (ido, bmat, n, k, np, nb, resid, rnorm, v, ldv, h, ldh,
& ipntr, workd, info)
c
c %----------------------------------------------------%
c | Include files for debugging and timing information |
c %----------------------------------------------------%
c
include 'debug.h'
include 'stat.h'
c
c %------------------%
c | Scalar Arguments |
c %------------------%
c
character bmat*1
integer ido, info, k, ldh, ldv, n, nb, np
Double precision
& rnorm
c
c %-----------------%
c | Array Arguments |
c %-----------------%
c
integer ipntr(3)
Complex*16
& h(ldh,k+np), resid(n), v(ldv,k+np), workd(3*n)
c
c %------------%
c | Parameters |
c %------------%
c
Complex*16
& one, zero
Double precision
& rone, rzero
parameter (one = (1.0D+0, 0.0D+0), zero = (0.0D+0, 0.0D+0),
& rone = 1.0D+0, rzero = 0.0D+0)
c
c %--------------%
c | Local Arrays |
c %--------------%
c
Double precision
& rtemp(2)
c
c %---------------%
c | Local Scalars |
c %---------------%
c
logical first, orth1, orth2, rstart, step3, step4
integer ierr, i, infol, ipj, irj, ivj, iter, itry, j, msglvl,
& jj
Double precision
& ovfl, smlnum, tst1, ulp, unfl, betaj,
& temp1, rnorm1, wnorm
Complex*16
& cnorm
c
save first, orth1, orth2, rstart, step3, step4,
& ierr, ipj, irj, ivj, iter, itry, j, msglvl, ovfl,
& betaj, rnorm1, smlnum, ulp, unfl, wnorm
c
c %----------------------%
c | External Subroutines |
c %----------------------%
c
external zaxpy, zcopy, zscal, zdscal, zgemv, zgetv0,
& dlabad, zvout, zmout, ivout, second
c
c %--------------------%
c | External Functions |
c %--------------------%
c
Complex*16
& zdotc
Double precision
& dlamch, dznrm2, zlanhs, dlapy2
external zdotc, dznrm2, zlanhs, dlamch, dlapy2
c
c %---------------------%
c | Intrinsic Functions |
c %---------------------%
c
intrinsic dimag, dble, max, sqrt
c
c %-----------------%
c | Data statements |
c %-----------------%
c
data first / .true. /
c
c %-----------------------%
c | Executable Statements |
c %-----------------------%
c
if (first) then
c
c %-----------------------------------------%
c | Set machine-dependent constants for the |
c | the splitting and deflation criterion. |
c | If norm(H) <= sqrt(OVFL), |
c | overflow should not occur. |
c | REFERENCE: LAPACK subroutine zlahqr |
c %-----------------------------------------%
c
unfl = dlamch( 'safe minimum' )
ovfl = dble(one / unfl)
call dlabad( unfl, ovfl )
ulp = dlamch( 'precision' )
smlnum = unfl*( n / ulp )
first = .false.
end if
c
if (ido .eq. 0) then
c
c %-------------------------------%
c | Initialize timing statistics |
c | & message level for debugging |
c %-------------------------------%
c
call second (t0)
msglvl = mcaitr
c
c %------------------------------%
c | Initial call to this routine |
c %------------------------------%
c
info = 0
step3 = .false.
step4 = .false.
rstart = .false.
orth1 = .false.
orth2 = .false.
j = k + 1
ipj = 1
irj = ipj + n
ivj = irj + n
end if
c
c %-------------------------------------------------%
c | When in reverse communication mode one of: |
c | STEP3, STEP4, ORTH1, ORTH2, RSTART |
c | will be .true. when .... |
c | STEP3: return from computing OP*v_{j}. |
c | STEP4: return from computing B-norm of OP*v_{j} |
c | ORTH1: return from computing B-norm of r_{j+1} |
c | ORTH2: return from computing B-norm of |
c | correction to the residual vector. |
c | RSTART: return from OP computations needed by |
c | zgetv0. |
c %-------------------------------------------------%
c
if (step3) go to 50
if (step4) go to 60
if (orth1) go to 70
if (orth2) go to 90
if (rstart) go to 30
c
c %-----------------------------%
c | Else this is the first step |
c %-----------------------------%
c
c %--------------------------------------------------------------%
c | |
c | A R N O L D I I T E R A T I O N L O O P |
c | |
c | Note: B*r_{j-1} is already in WORKD(1:N)=WORKD(IPJ:IPJ+N-1) |
c %--------------------------------------------------------------%
1000 continue
c
if (msglvl .gt. 1) then
call ivout (logfil, 1, j, ndigit,
& '_naitr: generating Arnoldi vector number')
call dvout (logfil, 1, rnorm, ndigit,
& '_naitr: B-norm of the current residual is')
end if
c
c %---------------------------------------------------%
c | STEP 1: Check if the B norm of j-th residual |
c | vector is zero. Equivalent to determine whether |
c | an exact j-step Arnoldi factorization is present. |
c %---------------------------------------------------%
c
betaj = rnorm
if (rnorm .gt. rzero) go to 40
c
c %---------------------------------------------------%
c | Invariant subspace found, generate a new starting |
c | vector which is orthogonal to the current Arnoldi |
c | basis and continue the iteration. |
c %---------------------------------------------------%
c
if (msglvl .gt. 0) then
call ivout (logfil, 1, j, ndigit,
& '_naitr: ****** RESTART AT STEP ******')
end if
c
c %---------------------------------------------%
c | ITRY is the loop variable that controls the |
c | maximum amount of times that a restart is |
c | attempted. NRSTRT is used by stat.h |
c %---------------------------------------------%
c
betaj = rzero
nrstrt = nrstrt + 1
itry = 1
20 continue
rstart = .true.
ido = 0
30 continue
c
c %--------------------------------------%
c | If in reverse communication mode and |
c | RSTART = .true. flow returns here. |
c %--------------------------------------%
c
call zgetv0 (ido, bmat, itry, .false., n, j, v, ldv,
& resid, rnorm, ipntr, workd, ierr)
if (ido .ne. 99) go to 9000
if (ierr .lt. 0) then
itry = itry + 1
if (itry .le. 3) go to 20
c
c %------------------------------------------------%
c | Give up after several restart attempts. |
c | Set INFO to the size of the invariant subspace |
c | which spans OP and exit. |
c %------------------------------------------------%
c
info = j - 1
call second (t1)
tcaitr = tcaitr + (t1 - t0)
ido = 99
go to 9000
end if
c
40 continue
c
c %---------------------------------------------------------%
c | STEP 2: v_{j} = r_{j-1}/rnorm and p_{j} = p_{j}/rnorm |
c | Note that p_{j} = B*r_{j-1}. In order to avoid overflow |
c | when reciprocating a small RNORM, test against lower |
c | machine bound. |
c %---------------------------------------------------------%
c
call zcopy (n, resid, 1, v(1,j), 1)
if ( rnorm .ge. unfl) then
temp1 = rone / rnorm
call zdscal (n, temp1, v(1,j), 1)
call zdscal (n, temp1, workd(ipj), 1)
else
c
c %-----------------------------------------%
c | To scale both v_{j} and p_{j} carefully |
c | use LAPACK routine zlascl |
c %-----------------------------------------%
c
call zlascl ('General', i, i, rnorm, rone,
& n, 1, v(1,j), n, infol)
call zlascl ('General', i, i, rnorm, rone,
& n, 1, workd(ipj), n, infol)
end if
c
c %------------------------------------------------------%
c | STEP 3: r_{j} = OP*v_{j}; Note that p_{j} = B*v_{j} |
c | Note that this is not quite yet r_{j}. See STEP 4 |
c %------------------------------------------------------%
c
step3 = .true.
nopx = nopx + 1
call second (t2)
call zcopy (n, v(1,j), 1, workd(ivj), 1)
ipntr(1) = ivj
ipntr(2) = irj
ipntr(3) = ipj
ido = 1
c
c %-----------------------------------%
c | Exit in order to compute OP*v_{j} |
c %-----------------------------------%
c
go to 9000
50 continue
c
c %----------------------------------%
c | Back from reverse communication; |
c | WORKD(IRJ:IRJ+N-1) := OP*v_{j} |
c | if step3 = .true. |
c %----------------------------------%
c
call second (t3)
tmvopx = tmvopx + (t3 - t2)
step3 = .false.
c
c %------------------------------------------%
c | Put another copy of OP*v_{j} into RESID. |
c %------------------------------------------%
c
call zcopy (n, workd(irj), 1, resid, 1)
c
c %---------------------------------------%
c | STEP 4: Finish extending the Arnoldi |
c | factorization to length j. |
c %---------------------------------------%
c
call second (t2)
if (bmat .eq. 'G') then
nbx = nbx + 1
step4 = .true.
ipntr(1) = irj
ipntr(2) = ipj
ido = 2
c
c %-------------------------------------%
c | Exit in order to compute B*OP*v_{j} |
c %-------------------------------------%
c
go to 9000
else if (bmat .eq. 'I') then
call zcopy (n, resid, 1, workd(ipj), 1)
end if
60 continue
c
c %----------------------------------%
c | Back from reverse communication; |
c | WORKD(IPJ:IPJ+N-1) := B*OP*v_{j} |
c | if step4 = .true. |
c %----------------------------------%
c
if (bmat .eq. 'G') then
call second (t3)
tmvbx = tmvbx + (t3 - t2)
end if
c
step4 = .false.
c
c %-------------------------------------%
c | The following is needed for STEP 5. |
c | Compute the B-norm of OP*v_{j}. |
c %-------------------------------------%
c
if (bmat .eq. 'G') then
cnorm = zdotc (n, resid, 1, workd(ipj), 1)
wnorm = sqrt( dlapy2(dble(cnorm),dimag(cnorm)) )
else if (bmat .eq. 'I') then
wnorm = dznrm2(n, resid, 1)
end if
c
c %-----------------------------------------%
c | Compute the j-th residual corresponding |
c | to the j step factorization. |
c | Use Classical Gram Schmidt and compute: |
c | w_{j} <- V_{j}^T * B * OP * v_{j} |
c | r_{j} <- OP*v_{j} - V_{j} * w_{j} |
c %-----------------------------------------%
c
c
c %------------------------------------------%
c | Compute the j Fourier coefficients w_{j} |
c | WORKD(IPJ:IPJ+N-1) contains B*OP*v_{j}. |
c %------------------------------------------%
c
call zgemv ('C', n, j, one, v, ldv, workd(ipj), 1,
& zero, h(1,j), 1)
c
c %--------------------------------------%
c | Orthogonalize r_{j} against V_{j}. |
c | RESID contains OP*v_{j}. See STEP 3. |
c %--------------------------------------%
c
call zgemv ('N', n, j, -one, v, ldv, h(1,j), 1,
& one, resid, 1)
c
if (j .gt. 1) h(j,j-1) = dcmplx(betaj, rzero)
c
call second (t4)
c
orth1 = .true.
c
call second (t2)
if (bmat .eq. 'G') then
nbx = nbx + 1
call zcopy (n, resid, 1, workd(irj), 1)
ipntr(1) = irj
ipntr(2) = ipj
ido = 2
c
c %----------------------------------%
c | Exit in order to compute B*r_{j} |
c %----------------------------------%
c
go to 9000
else if (bmat .eq. 'I') then
call zcopy (n, resid, 1, workd(ipj), 1)
end if
70 continue
c
c %---------------------------------------------------%
c | Back from reverse communication if ORTH1 = .true. |
c | WORKD(IPJ:IPJ+N-1) := B*r_{j}. |
c %---------------------------------------------------%
c
if (bmat .eq. 'G') then
call second (t3)
tmvbx = tmvbx + (t3 - t2)
end if
c
orth1 = .false.
c
c %------------------------------%
c | Compute the B-norm of r_{j}. |
c %------------------------------%
c
if (bmat .eq. 'G') then
cnorm = zdotc (n, resid, 1, workd(ipj), 1)
rnorm = sqrt( dlapy2(dble(cnorm),dimag(cnorm)) )
else if (bmat .eq. 'I') then
rnorm = dznrm2(n, resid, 1)
end if
c
c %-----------------------------------------------------------%
c | STEP 5: Re-orthogonalization / Iterative refinement phase |
c | Maximum NITER_ITREF tries. |
c | |
c | s = V_{j}^T * B * r_{j} |
c | r_{j} = r_{j} - V_{j}*s |
c | alphaj = alphaj + s_{j} |
c | |
c | The stopping criteria used for iterative refinement is |
c | discussed in Parlett's book SEP, page 107 and in Gragg & |
c | Reichel ACM TOMS paper; Algorithm 686, Dec. 1990. |
c | Determine if we need to correct the residual. The goal is |
c | to enforce ||v(:,1:j)^T * r_{j}|| .le. eps * || r_{j} || |
c | The following test determines whether the sine of the |
c | angle between OP*x and the computed residual is less |
c | than or equal to 0.717. |
c %-----------------------------------------------------------%
c
if ( rnorm .gt. 0.717*wnorm ) go to 100
c
iter = 0
nrorth = nrorth + 1
c
c %---------------------------------------------------%
c | Enter the Iterative refinement phase. If further |
c | refinement is necessary, loop back here. The loop |
c | variable is ITER. Perform a step of Classical |
c | Gram-Schmidt using all the Arnoldi vectors V_{j} |
c %---------------------------------------------------%
c
80 continue
c
if (msglvl .gt. 2) then
rtemp(1) = wnorm
rtemp(2) = rnorm
call dvout (logfil, 2, rtemp, ndigit,
& '_naitr: re-orthogonalization; wnorm and rnorm are')
call zvout (logfil, j, h(1,j), ndigit,
& '_naitr: j-th column of H')
end if
c
c %----------------------------------------------------%
c | Compute V_{j}^T * B * r_{j}. |
c | WORKD(IRJ:IRJ+J-1) = v(:,1:J)'*WORKD(IPJ:IPJ+N-1). |
c %----------------------------------------------------%
c
call zgemv ('C', n, j, one, v, ldv, workd(ipj), 1,
& zero, workd(irj), 1)
c
c %---------------------------------------------%
c | Compute the correction to the residual: |
c | r_{j} = r_{j} - V_{j} * WORKD(IRJ:IRJ+J-1). |
c | The correction to H is v(:,1:J)*H(1:J,1:J) |
c | + v(:,1:J)*WORKD(IRJ:IRJ+J-1)*e'_j. |
c %---------------------------------------------%
c
call zgemv ('N', n, j, -one, v, ldv, workd(irj), 1,
& one, resid, 1)
call zaxpy (j, one, workd(irj), 1, h(1,j), 1)
c
orth2 = .true.
call second (t2)
if (bmat .eq. 'G') then
nbx = nbx + 1
call zcopy (n, resid, 1, workd(irj), 1)
ipntr(1) = irj
ipntr(2) = ipj
ido = 2
c
c %-----------------------------------%
c | Exit in order to compute B*r_{j}. |
c | r_{j} is the corrected residual. |
c %-----------------------------------%
c
go to 9000
else if (bmat .eq. 'I') then
call zcopy (n, resid, 1, workd(ipj), 1)
end if
90 continue
c
c %---------------------------------------------------%
c | Back from reverse communication if ORTH2 = .true. |
c %---------------------------------------------------%
c
if (bmat .eq. 'G') then
call second (t3)
tmvbx = tmvbx + (t3 - t2)
end if
c
c %-----------------------------------------------------%
c | Compute the B-norm of the corrected residual r_{j}. |
c %-----------------------------------------------------%
c
if (bmat .eq. 'G') then
cnorm = zdotc (n, resid, 1, workd(ipj), 1)
rnorm1 = sqrt( dlapy2(dble(cnorm),dimag(cnorm)) )
else if (bmat .eq. 'I') then
rnorm1 = dznrm2(n, resid, 1)
end if
c
if (msglvl .gt. 0 .and. iter .gt. 0 ) then
call ivout (logfil, 1, j, ndigit,
& '_naitr: Iterative refinement for Arnoldi residual')
if (msglvl .gt. 2) then
rtemp(1) = rnorm
rtemp(2) = rnorm1
call dvout (logfil, 2, rtemp, ndigit,
& '_naitr: iterative refinement ; rnorm and rnorm1 are')
end if
end if
c
c %-----------------------------------------%
c | Determine if we need to perform another |
c | step of re-orthogonalization. |
c %-----------------------------------------%
c
if ( rnorm1 .gt. 0.717*rnorm ) then
c
c %---------------------------------------%
c | No need for further refinement. |
c | The cosine of the angle between the |
c | corrected residual vector and the old |
c | residual vector is greater than 0.717 |
c | In other words the corrected residual |
c | and the old residual vector share an |
c | angle of less than arcCOS(0.717) |
c %---------------------------------------%
c
rnorm = rnorm1
c
else
c
c %-------------------------------------------%
c | Another step of iterative refinement step |
c | is required. NITREF is used by stat.h |
c %-------------------------------------------%
c
nitref = nitref + 1
rnorm = rnorm1
iter = iter + 1
if (iter .le. 1) go to 80
c
c %-------------------------------------------------%
c | Otherwise RESID is numerically in the span of V |
c %-------------------------------------------------%
c
do 95 jj = 1, n
resid(jj) = zero
95 continue
rnorm = rzero
end if
c
c %----------------------------------------------%
c | Branch here directly if iterative refinement |
c | wasn't necessary or after at most NITER_REF |
c | steps of iterative refinement. |
c %----------------------------------------------%
c
100 continue
c
rstart = .false.
orth2 = .false.
c
call second (t5)
titref = titref + (t5 - t4)
c
c %------------------------------------%
c | STEP 6: Update j = j+1; Continue |
c %------------------------------------%
c
j = j + 1
if (j .gt. k+np) then
call second (t1)
tcaitr = tcaitr + (t1 - t0)
ido = 99
do 110 i = max(1,k), k+np-1
c
c %--------------------------------------------%
c | Check for splitting and deflation. |
c | Use a standard test as in the QR algorithm |
c | REFERENCE: LAPACK subroutine zlahqr |
c %--------------------------------------------%
c
tst1 = dlapy2(dble(h(i,i)),dimag(h(i,i)))
& + dlapy2(dble(h(i+1,i+1)), dimag(h(i+1,i+1)))
if( tst1.eq.dble(zero) )
& tst1 = zlanhs( '1', k+np, h, ldh, workd(n+1) )
if( dlapy2(dble(h(i+1,i)),dimag(h(i+1,i))) .le.
& max( ulp*tst1, smlnum ) )
& h(i+1,i) = zero
110 continue
c
if (msglvl .gt. 2) then
call zmout (logfil, k+np, k+np, h, ldh, ndigit,
& '_naitr: Final upper Hessenberg matrix H of order K+NP')
end if
c
go to 9000
end if
c
c %--------------------------------------------------------%
c | Loop back to extend the factorization by another step. |
c %--------------------------------------------------------%
c
go to 1000
c
c %---------------------------------------------------------------%
c | |
c | E N D O F M A I N I T E R A T I O N L O O P |
c | |
c %---------------------------------------------------------------%
c
9000 continue
return
c
c %---------------%
c | End of znaitr |
c %---------------%
c
end

507
arpack/ARPACK/SRC/znapps.f Normal file
View File

@@ -0,0 +1,507 @@
c\BeginDoc
c
c\Name: znapps
c
c\Description:
c Given the Arnoldi factorization
c
c A*V_{k} - V_{k}*H_{k} = r_{k+p}*e_{k+p}^T,
c
c apply NP implicit shifts resulting in
c
c A*(V_{k}*Q) - (V_{k}*Q)*(Q^T* H_{k}*Q) = r_{k+p}*e_{k+p}^T * Q
c
c where Q is an orthogonal matrix which is the product of rotations
c and reflections resulting from the NP bulge change sweeps.
c The updated Arnoldi factorization becomes:
c
c A*VNEW_{k} - VNEW_{k}*HNEW_{k} = rnew_{k}*e_{k}^T.
c
c\Usage:
c call znapps
c ( N, KEV, NP, SHIFT, V, LDV, H, LDH, RESID, Q, LDQ,
c WORKL, WORKD )
c
c\Arguments
c N Integer. (INPUT)
c Problem size, i.e. size of matrix A.
c
c KEV Integer. (INPUT/OUTPUT)
c KEV+NP is the size of the input matrix H.
c KEV is the size of the updated matrix HNEW.
c
c NP Integer. (INPUT)
c Number of implicit shifts to be applied.
c
c SHIFT Complex*16 array of length NP. (INPUT)
c The shifts to be applied.
c
c V Complex*16 N by (KEV+NP) array. (INPUT/OUTPUT)
c On INPUT, V contains the current KEV+NP Arnoldi vectors.
c On OUTPUT, V contains the updated KEV Arnoldi vectors
c in the first KEV columns of V.
c
c LDV Integer. (INPUT)
c Leading dimension of V exactly as declared in the calling
c program.
c
c H Complex*16 (KEV+NP) by (KEV+NP) array. (INPUT/OUTPUT)
c On INPUT, H contains the current KEV+NP by KEV+NP upper
c Hessenberg matrix of the Arnoldi factorization.
c On OUTPUT, H contains the updated KEV by KEV upper Hessenberg
c matrix in the KEV leading submatrix.
c
c LDH Integer. (INPUT)
c Leading dimension of H exactly as declared in the calling
c program.
c
c RESID Complex*16 array of length N. (INPUT/OUTPUT)
c On INPUT, RESID contains the the residual vector r_{k+p}.
c On OUTPUT, RESID is the update residual vector rnew_{k}
c in the first KEV locations.
c
c Q Complex*16 KEV+NP by KEV+NP work array. (WORKSPACE)
c Work array used to accumulate the rotations and reflections
c during the bulge chase sweep.
c
c LDQ Integer. (INPUT)
c Leading dimension of Q exactly as declared in the calling
c program.
c
c WORKL Complex*16 work array of length (KEV+NP). (WORKSPACE)
c Private (replicated) array on each PE or array allocated on
c the front end.
c
c WORKD Complex*16 work array of length 2*N. (WORKSPACE)
c Distributed array used in the application of the accumulated
c orthogonal matrix Q.
c
c\EndDoc
c
c-----------------------------------------------------------------------
c
c\BeginLib
c
c\Local variables:
c xxxxxx Complex*16
c
c\References:
c 1. D.C. Sorensen, "Implicit Application of Polynomial Filters in
c a k-Step Arnoldi Method", SIAM J. Matr. Anal. Apps., 13 (1992),
c pp 357-385.
c
c\Routines called:
c ivout ARPACK utility routine that prints integers.
c second ARPACK utility routine for timing.
c zmout ARPACK utility routine that prints matrices
c zvout ARPACK utility routine that prints vectors.
c zlacpy LAPACK matrix copy routine.
c zlanhs LAPACK routine that computes various norms of a matrix.
c zlartg LAPACK Givens rotation construction routine.
c zlaset LAPACK matrix initialization routine.
c dlabad LAPACK routine for defining the underflow and overflow
c limits.
c dlamch LAPACK routine that determines machine constants.
c dlapy2 LAPACK routine to compute sqrt(x**2+y**2) carefully.
c zgemv Level 2 BLAS routine for matrix vector multiplication.
c zaxpy Level 1 BLAS that computes a vector triad.
c zcopy Level 1 BLAS that copies one vector to another.
c zscal Level 1 BLAS that scales a vector.
c
c\Author
c Danny Sorensen Phuong Vu
c Richard Lehoucq CRPC / Rice University
c Dept. of Computational & Houston, Texas
c Applied Mathematics
c Rice University
c Houston, Texas
c
c\SCCS Information: @(#)
c FILE: napps.F SID: 2.3 DATE OF SID: 3/28/97 RELEASE: 2
c
c\Remarks
c 1. In this version, each shift is applied to all the sublocks of
c the Hessenberg matrix H and not just to the submatrix that it
c comes from. Deflation as in LAPACK routine zlahqr (QR algorithm
c for upper Hessenberg matrices ) is used.
c Upon output, the subdiagonals of H are enforced to be non-negative
c real numbers.
c
c\EndLib
c
c-----------------------------------------------------------------------
c
subroutine znapps
& ( n, kev, np, shift, v, ldv, h, ldh, resid, q, ldq,
& workl, workd )
c
c %----------------------------------------------------%
c | Include files for debugging and timing information |
c %----------------------------------------------------%
c
include 'debug.h'
include 'stat.h'
c
c %------------------%
c | Scalar Arguments |
c %------------------%
c
integer kev, ldh, ldq, ldv, n, np
c
c %-----------------%
c | Array Arguments |
c %-----------------%
c
Complex*16
& h(ldh,kev+np), resid(n), shift(np),
& v(ldv,kev+np), q(ldq,kev+np), workd(2*n), workl(kev+np)
c
c %------------%
c | Parameters |
c %------------%
c
Complex*16
& one, zero
Double precision
& rzero
parameter (one = (1.0D+0, 0.0D+0), zero = (0.0D+0, 0.0D+0),
& rzero = 0.0D+0)
c
c %------------------------%
c | Local Scalars & Arrays |
c %------------------------%
c
integer i, iend, istart, j, jj, kplusp, msglvl
logical first
Complex*16
& cdum, f, g, h11, h21, r, s, sigma, t
Double precision
& c, ovfl, smlnum, ulp, unfl, tst1
save first, ovfl, smlnum, ulp, unfl
c
c %----------------------%
c | External Subroutines |
c %----------------------%
c
external zaxpy, zcopy, zgemv, zscal, zlacpy, zlartg,
& zvout, zlaset, dlabad, zmout, second, ivout
c
c %--------------------%
c | External Functions |
c %--------------------%
c
Double precision
& zlanhs, dlamch, dlapy2
external zlanhs, dlamch, dlapy2
c
c %----------------------%
c | Intrinsics Functions |
c %----------------------%
c
intrinsic abs, dimag, conjg, dcmplx, max, min, dble
c
c %---------------------%
c | Statement Functions |
c %---------------------%
c
Double precision
& zabs1
zabs1( cdum ) = abs( dble( cdum ) ) + abs( dimag( cdum ) )
c
c %----------------%
c | Data statments |
c %----------------%
c
data first / .true. /
c
c %-----------------------%
c | Executable Statements |
c %-----------------------%
c
if (first) then
c
c %-----------------------------------------------%
c | Set machine-dependent constants for the |
c | stopping criterion. If norm(H) <= sqrt(OVFL), |
c | overflow should not occur. |
c | REFERENCE: LAPACK subroutine zlahqr |
c %-----------------------------------------------%
c
unfl = dlamch( 'safe minimum' )
ovfl = dble(one / unfl)
call dlabad( unfl, ovfl )
ulp = dlamch( 'precision' )
smlnum = unfl*( n / ulp )
first = .false.
end if
c
c %-------------------------------%
c | Initialize timing statistics |
c | & message level for debugging |
c %-------------------------------%
c
call second (t0)
msglvl = mcapps
c
kplusp = kev + np
c
c %--------------------------------------------%
c | Initialize Q to the identity to accumulate |
c | the rotations and reflections |
c %--------------------------------------------%
c
call zlaset ('All', kplusp, kplusp, zero, one, q, ldq)
c
c %----------------------------------------------%
c | Quick return if there are no shifts to apply |
c %----------------------------------------------%
c
if (np .eq. 0) go to 9000
c
c %----------------------------------------------%
c | Chase the bulge with the application of each |
c | implicit shift. Each shift is applied to the |
c | whole matrix including each block. |
c %----------------------------------------------%
c
do 110 jj = 1, np
sigma = shift(jj)
c
if (msglvl .gt. 2 ) then
call ivout (logfil, 1, jj, ndigit,
& '_napps: shift number.')
call zvout (logfil, 1, sigma, ndigit,
& '_napps: Value of the shift ')
end if
c
istart = 1
20 continue
c
do 30 i = istart, kplusp-1
c
c %----------------------------------------%
c | Check for splitting and deflation. Use |
c | a standard test as in the QR algorithm |
c | REFERENCE: LAPACK subroutine zlahqr |
c %----------------------------------------%
c
tst1 = zabs1( h( i, i ) ) + zabs1( h( i+1, i+1 ) )
if( tst1.eq.rzero )
& tst1 = zlanhs( '1', kplusp-jj+1, h, ldh, workl )
if ( abs(dble(h(i+1,i)))
& .le. max(ulp*tst1, smlnum) ) then
if (msglvl .gt. 0) then
call ivout (logfil, 1, i, ndigit,
& '_napps: matrix splitting at row/column no.')
call ivout (logfil, 1, jj, ndigit,
& '_napps: matrix splitting with shift number.')
call zvout (logfil, 1, h(i+1,i), ndigit,
& '_napps: off diagonal element.')
end if
iend = i
h(i+1,i) = zero
go to 40
end if
30 continue
iend = kplusp
40 continue
c
if (msglvl .gt. 2) then
call ivout (logfil, 1, istart, ndigit,
& '_napps: Start of current block ')
call ivout (logfil, 1, iend, ndigit,
& '_napps: End of current block ')
end if
c
c %------------------------------------------------%
c | No reason to apply a shift to block of order 1 |
c | or if the current block starts after the point |
c | of compression since we'll discard this stuff |
c %------------------------------------------------%
c
if ( istart .eq. iend .or. istart .gt. kev) go to 100
c
h11 = h(istart,istart)
h21 = h(istart+1,istart)
f = h11 - sigma
g = h21
c
do 80 i = istart, iend-1
c
c %------------------------------------------------------%
c | Construct the plane rotation G to zero out the bulge |
c %------------------------------------------------------%
c
call zlartg (f, g, c, s, r)
if (i .gt. istart) then
h(i,i-1) = r
h(i+1,i-1) = zero
end if
c
c %---------------------------------------------%
c | Apply rotation to the left of H; H <- G'*H |
c %---------------------------------------------%
c
do 50 j = i, kplusp
t = c*h(i,j) + s*h(i+1,j)
h(i+1,j) = -conjg(s)*h(i,j) + c*h(i+1,j)
h(i,j) = t
50 continue
c
c %---------------------------------------------%
c | Apply rotation to the right of H; H <- H*G |
c %---------------------------------------------%
c
do 60 j = 1, min(i+2,iend)
t = c*h(j,i) + conjg(s)*h(j,i+1)
h(j,i+1) = -s*h(j,i) + c*h(j,i+1)
h(j,i) = t
60 continue
c
c %-----------------------------------------------------%
c | Accumulate the rotation in the matrix Q; Q <- Q*G' |
c %-----------------------------------------------------%
c
do 70 j = 1, min(i+jj, kplusp)
t = c*q(j,i) + conjg(s)*q(j,i+1)
q(j,i+1) = - s*q(j,i) + c*q(j,i+1)
q(j,i) = t
70 continue
c
c %---------------------------%
c | Prepare for next rotation |
c %---------------------------%
c
if (i .lt. iend-1) then
f = h(i+1,i)
g = h(i+2,i)
end if
80 continue
c
c %-------------------------------%
c | Finished applying the shift. |
c %-------------------------------%
c
100 continue
c
c %---------------------------------------------------------%
c | Apply the same shift to the next block if there is any. |
c %---------------------------------------------------------%
c
istart = iend + 1
if (iend .lt. kplusp) go to 20
c
c %---------------------------------------------%
c | Loop back to the top to get the next shift. |
c %---------------------------------------------%
c
110 continue
c
c %---------------------------------------------------%
c | Perform a similarity transformation that makes |
c | sure that the compressed H will have non-negative |
c | real subdiagonal elements. |
c %---------------------------------------------------%
c
do 120 j=1,kev
if ( dble( h(j+1,j) ) .lt. rzero .or.
& dimag( h(j+1,j) ) .ne. rzero ) then
t = h(j+1,j) / dlapy2(dble(h(j+1,j)),dimag(h(j+1,j)))
call zscal( kplusp-j+1, conjg(t), h(j+1,j), ldh )
call zscal( min(j+2, kplusp), t, h(1,j+1), 1 )
call zscal( min(j+np+1,kplusp), t, q(1,j+1), 1 )
h(j+1,j) = dcmplx( dble( h(j+1,j) ), rzero )
end if
120 continue
c
do 130 i = 1, kev
c
c %--------------------------------------------%
c | Final check for splitting and deflation. |
c | Use a standard test as in the QR algorithm |
c | REFERENCE: LAPACK subroutine zlahqr. |
c | Note: Since the subdiagonals of the |
c | compressed H are nonnegative real numbers, |
c | we take advantage of this. |
c %--------------------------------------------%
c
tst1 = zabs1( h( i, i ) ) + zabs1( h( i+1, i+1 ) )
if( tst1 .eq. rzero )
& tst1 = zlanhs( '1', kev, h, ldh, workl )
if( dble( h( i+1,i ) ) .le. max( ulp*tst1, smlnum ) )
& h(i+1,i) = zero
130 continue
c
c %-------------------------------------------------%
c | Compute the (kev+1)-st column of (V*Q) and |
c | temporarily store the result in WORKD(N+1:2*N). |
c | This is needed in the residual update since we |
c | cannot GUARANTEE that the corresponding entry |
c | of H would be zero as in exact arithmetic. |
c %-------------------------------------------------%
c
if ( dble( h(kev+1,kev) ) .gt. rzero )
& call zgemv ('N', n, kplusp, one, v, ldv, q(1,kev+1), 1, zero,
& workd(n+1), 1)
c
c %----------------------------------------------------------%
c | Compute column 1 to kev of (V*Q) in backward order |
c | taking advantage of the upper Hessenberg structure of Q. |
c %----------------------------------------------------------%
c
do 140 i = 1, kev
call zgemv ('N', n, kplusp-i+1, one, v, ldv,
& q(1,kev-i+1), 1, zero, workd, 1)
call zcopy (n, workd, 1, v(1,kplusp-i+1), 1)
140 continue
c
c %-------------------------------------------------%
c | Move v(:,kplusp-kev+1:kplusp) into v(:,1:kev). |
c %-------------------------------------------------%
c
call zlacpy ('A', n, kev, v(1,kplusp-kev+1), ldv, v, ldv)
c
c %--------------------------------------------------------------%
c | Copy the (kev+1)-st column of (V*Q) in the appropriate place |
c %--------------------------------------------------------------%
c
if ( dble( h(kev+1,kev) ) .gt. rzero )
& call zcopy (n, workd(n+1), 1, v(1,kev+1), 1)
c
c %-------------------------------------%
c | Update the residual vector: |
c | r <- sigmak*r + betak*v(:,kev+1) |
c | where |
c | sigmak = (e_{kev+p}'*Q)*e_{kev} |
c | betak = e_{kev+1}'*H*e_{kev} |
c %-------------------------------------%
c
call zscal (n, q(kplusp,kev), resid, 1)
if ( dble( h(kev+1,kev) ) .gt. rzero )
& call zaxpy (n, h(kev+1,kev), v(1,kev+1), 1, resid, 1)
c
if (msglvl .gt. 1) then
call zvout (logfil, 1, q(kplusp,kev), ndigit,
& '_napps: sigmak = (e_{kev+p}^T*Q)*e_{kev}')
call zvout (logfil, 1, h(kev+1,kev), ndigit,
& '_napps: betak = e_{kev+1}^T*H*e_{kev}')
call ivout (logfil, 1, kev, ndigit,
& '_napps: Order of the final Hessenberg matrix ')
if (msglvl .gt. 2) then
call zmout (logfil, kev, kev, h, ldh, ndigit,
& '_napps: updated Hessenberg matrix H for next iteration')
end if
c
end if
c
9000 continue
call second (t1)
tcapps = tcapps + (t1 - t0)
c
return
c
c %---------------%
c | End of znapps |
c %---------------%
c
end

801
arpack/ARPACK/SRC/znaup2.f Normal file
View File

@@ -0,0 +1,801 @@
c\BeginDoc
c
c\Name: znaup2
c
c\Description:
c Intermediate level interface called by znaupd .
c
c\Usage:
c call znaup2
c ( IDO, BMAT, N, WHICH, NEV, NP, TOL, RESID, MODE, IUPD,
c ISHIFT, MXITER, V, LDV, H, LDH, RITZ, BOUNDS,
c Q, LDQ, WORKL, IPNTR, WORKD, RWORK, INFO )
c
c\Arguments
c
c IDO, BMAT, N, WHICH, NEV, TOL, RESID: same as defined in znaupd .
c MODE, ISHIFT, MXITER: see the definition of IPARAM in znaupd .
c
c NP Integer. (INPUT/OUTPUT)
c Contains the number of implicit shifts to apply during
c each Arnoldi iteration.
c If ISHIFT=1, NP is adjusted dynamically at each iteration
c to accelerate convergence and prevent stagnation.
c This is also roughly equal to the number of matrix-vector
c products (involving the operator OP) per Arnoldi iteration.
c The logic for adjusting is contained within the current
c subroutine.
c If ISHIFT=0, NP is the number of shifts the user needs
c to provide via reverse comunication. 0 < NP < NCV-NEV.
c NP may be less than NCV-NEV since a leading block of the current
c upper Hessenberg matrix has split off and contains "unwanted"
c Ritz values.
c Upon termination of the IRA iteration, NP contains the number
c of "converged" wanted Ritz values.
c
c IUPD Integer. (INPUT)
c IUPD .EQ. 0: use explicit restart instead implicit update.
c IUPD .NE. 0: use implicit update.
c
c V Complex*16 N by (NEV+NP) array. (INPUT/OUTPUT)
c The Arnoldi basis vectors are returned in the first NEV
c columns of V.
c
c LDV Integer. (INPUT)
c Leading dimension of V exactly as declared in the calling
c program.
c
c H Complex*16 (NEV+NP) by (NEV+NP) array. (OUTPUT)
c H is used to store the generated upper Hessenberg matrix
c
c LDH Integer. (INPUT)
c Leading dimension of H exactly as declared in the calling
c program.
c
c RITZ Complex*16 array of length NEV+NP. (OUTPUT)
c RITZ(1:NEV) contains the computed Ritz values of OP.
c
c BOUNDS Complex*16 array of length NEV+NP. (OUTPUT)
c BOUNDS(1:NEV) contain the error bounds corresponding to
c the computed Ritz values.
c
c Q Complex*16 (NEV+NP) by (NEV+NP) array. (WORKSPACE)
c Private (replicated) work array used to accumulate the
c rotation in the shift application step.
c
c LDQ Integer. (INPUT)
c Leading dimension of Q exactly as declared in the calling
c program.
c
c WORKL Complex*16 work array of length at least
c (NEV+NP)**2 + 3*(NEV+NP). (WORKSPACE)
c Private (replicated) array on each PE or array allocated on
c the front end. It is used in shifts calculation, shifts
c application and convergence checking.
c
c
c IPNTR Integer array of length 3. (OUTPUT)
c Pointer to mark the starting locations in the WORKD for
c vectors used by the Arnoldi iteration.
c -------------------------------------------------------------
c IPNTR(1): pointer to the current operand vector X.
c IPNTR(2): pointer to the current result vector Y.
c IPNTR(3): pointer to the vector B * X when used in the
c shift-and-invert mode. X is the current operand.
c -------------------------------------------------------------
c
c WORKD Complex*16 work array of length 3*N. (WORKSPACE)
c Distributed array to be used in the basic Arnoldi iteration
c for reverse communication. The user should not use WORKD
c as temporary workspace during the iteration !!!!!!!!!!
c See Data Distribution Note in ZNAUPD .
c
c RWORK Double precision work array of length NEV+NP ( WORKSPACE)
c Private (replicated) array on each PE or array allocated on
c the front end.
c
c INFO Integer. (INPUT/OUTPUT)
c If INFO .EQ. 0, a randomly initial residual vector is used.
c If INFO .NE. 0, RESID contains the initial residual vector,
c possibly from a previous run.
c Error flag on output.
c = 0: Normal return.
c = 1: Maximum number of iterations taken.
c All possible eigenvalues of OP has been found.
c NP returns the number of converged Ritz values.
c = 2: No shifts could be applied.
c = -8: Error return from LAPACK eigenvalue calculation;
c This should never happen.
c = -9: Starting vector is zero.
c = -9999: Could not build an Arnoldi factorization.
c Size that was built in returned in NP.
c
c\EndDoc
c
c-----------------------------------------------------------------------
c
c\BeginLib
c
c\Local variables:
c xxxxxx Complex*16
c
c\References:
c 1. D.C. Sorensen, "Implicit Application of Polynomial Filters in
c a k-Step Arnoldi Method", SIAM J. Matr. Anal. Apps., 13 (1992),
c pp 357-385.
c 2. R.B. Lehoucq, "Analysis and Implementation of an Implicitly
c Restarted Arnoldi Iteration", Rice University Technical Report
c TR95-13, Department of Computational and Applied Mathematics.
c
c\Routines called:
c zgetv0 ARPACK initial vector generation routine.
c znaitr ARPACK Arnoldi factorization routine.
c znapps ARPACK application of implicit shifts routine.
c zneigh ARPACK compute Ritz values and error bounds routine.
c zngets ARPACK reorder Ritz values and error bounds routine.
c zsortc ARPACK sorting routine.
c ivout ARPACK utility routine that prints integers.
c second ARPACK utility routine for timing.
c zmout ARPACK utility routine that prints matrices
c zvout ARPACK utility routine that prints vectors.
c dvout ARPACK utility routine that prints vectors.
c dlamch LAPACK routine that determines machine constants.
c dlapy2 LAPACK routine to compute sqrt(x**2+y**2) carefully.
c zcopy Level 1 BLAS that copies one vector to another .
c zdotc Level 1 BLAS that computes the scalar product of two vectors.
c zswap Level 1 BLAS that swaps two vectors.
c dznrm2 Level 1 BLAS that computes the norm of a vector.
c
c\Author
c Danny Sorensen Phuong Vu
c Richard Lehoucq CRPC / Rice Universitya
c Chao Yang Houston, Texas
c Dept. of Computational &
c Applied Mathematics
c Rice University
c Houston, Texas
c
c\SCCS Information: @(#)
c FILE: naup2.F SID: 2.6 DATE OF SID: 06/01/00 RELEASE: 2
c
c\Remarks
c 1. None
c
c\EndLib
c
c-----------------------------------------------------------------------
c
subroutine znaup2
& ( ido, bmat, n, which, nev, np, tol, resid, mode, iupd,
& ishift, mxiter, v, ldv, h, ldh, ritz, bounds,
& q, ldq, workl, ipntr, workd, rwork, info )
c
c %----------------------------------------------------%
c | Include files for debugging and timing information |
c %----------------------------------------------------%
c
include 'debug.h'
include 'stat.h'
c
c %------------------%
c | Scalar Arguments |
c %------------------%
c
character bmat*1, which*2
integer ido, info, ishift, iupd, mode, ldh, ldq, ldv, mxiter,
& n, nev, np
Double precision
& tol
c
c %-----------------%
c | Array Arguments |
c %-----------------%
c
integer ipntr(13)
Complex*16
& bounds(nev+np), h(ldh,nev+np), q(ldq,nev+np),
& resid(n), ritz(nev+np), v(ldv,nev+np),
& workd(3*n), workl( (nev+np)*(nev+np+3) )
Double precision
& rwork(nev+np)
c
c %------------%
c | Parameters |
c %------------%
c
Complex*16
& one, zero
Double precision
& rzero
parameter (one = (1.0D+0, 0.0D+0) , zero = (0.0D+0, 0.0D+0) ,
& rzero = 0.0D+0 )
c
c %---------------%
c | Local Scalars |
c %---------------%
c
logical cnorm , getv0, initv , update, ushift
integer ierr , iter , kplusp, msglvl, nconv,
& nevbef, nev0 , np0 , nptemp, i ,
& j
Complex*16
& cmpnorm
Double precision
& rnorm , eps23, rtemp
character wprime*2
c
save cnorm, getv0, initv , update, ushift,
& rnorm, iter , kplusp, msglvl, nconv ,
& nevbef, nev0 , np0 , eps23
c
c
c %-----------------------%
c | Local array arguments |
c %-----------------------%
c
integer kp(3)
c
c %----------------------%
c | External Subroutines |
c %----------------------%
c
external zcopy , zgetv0 , znaitr , zneigh , zngets , znapps ,
& zsortc , zswap , zmout , zvout , ivout, second
c
c %--------------------%
c | External functions |
c %--------------------%
c
Complex*16
& zdotc
Double precision
& dznrm2 , dlamch , dlapy2
external zdotc , dznrm2 , dlamch , dlapy2
c
c %---------------------%
c | Intrinsic Functions |
c %---------------------%
c
intrinsic dimag , dble , min, max
c
c %-----------------------%
c | Executable Statements |
c %-----------------------%
c
if (ido .eq. 0) then
c
call second (t0)
c
msglvl = mcaup2
c
nev0 = nev
np0 = np
c
c %-------------------------------------%
c | kplusp is the bound on the largest |
c | Lanczos factorization built. |
c | nconv is the current number of |
c | "converged" eigenvalues. |
c | iter is the counter on the current |
c | iteration step. |
c %-------------------------------------%
c
kplusp = nev + np
nconv = 0
iter = 0
c
c %---------------------------------%
c | Get machine dependent constant. |
c %---------------------------------%
c
eps23 = dlamch ('Epsilon-Machine')
eps23 = eps23**(2.0D+0 / 3.0D+0 )
c
c %---------------------------------------%
c | Set flags for computing the first NEV |
c | steps of the Arnoldi factorization. |
c %---------------------------------------%
c
getv0 = .true.
update = .false.
ushift = .false.
cnorm = .false.
c
if (info .ne. 0) then
c
c %--------------------------------------------%
c | User provides the initial residual vector. |
c %--------------------------------------------%
c
initv = .true.
info = 0
else
initv = .false.
end if
end if
c
c %---------------------------------------------%
c | Get a possibly random starting vector and |
c | force it into the range of the operator OP. |
c %---------------------------------------------%
c
10 continue
c
if (getv0) then
call zgetv0 (ido, bmat, 1, initv, n, 1, v, ldv, resid, rnorm,
& ipntr, workd, info)
c
if (ido .ne. 99) go to 9000
c
if (rnorm .eq. rzero) then
c
c %-----------------------------------------%
c | The initial vector is zero. Error exit. |
c %-----------------------------------------%
c
info = -9
go to 1100
end if
getv0 = .false.
ido = 0
end if
c
c %-----------------------------------%
c | Back from reverse communication : |
c | continue with update step |
c %-----------------------------------%
c
if (update) go to 20
c
c %-------------------------------------------%
c | Back from computing user specified shifts |
c %-------------------------------------------%
c
if (ushift) go to 50
c
c %-------------------------------------%
c | Back from computing residual norm |
c | at the end of the current iteration |
c %-------------------------------------%
c
if (cnorm) go to 100
c
c %----------------------------------------------------------%
c | Compute the first NEV steps of the Arnoldi factorization |
c %----------------------------------------------------------%
c
call znaitr (ido, bmat, n, 0, nev, mode, resid, rnorm, v, ldv,
& h, ldh, ipntr, workd, info)
c
if (ido .ne. 99) go to 9000
c
if (info .gt. 0) then
np = info
mxiter = iter
info = -9999
go to 1200
end if
c
c %--------------------------------------------------------------%
c | |
c | M A I N ARNOLDI I T E R A T I O N L O O P |
c | Each iteration implicitly restarts the Arnoldi |
c | factorization in place. |
c | |
c %--------------------------------------------------------------%
c
1000 continue
c
iter = iter + 1
c
if (msglvl .gt. 0) then
call ivout (logfil, 1, iter, ndigit,
& '_naup2: **** Start of major iteration number ****')
end if
c
c %-----------------------------------------------------------%
c | Compute NP additional steps of the Arnoldi factorization. |
c | Adjust NP since NEV might have been updated by last call |
c | to the shift application routine znapps . |
c %-----------------------------------------------------------%
c
np = kplusp - nev
c
if (msglvl .gt. 1) then
call ivout (logfil, 1, nev, ndigit,
& '_naup2: The length of the current Arnoldi factorization')
call ivout (logfil, 1, np, ndigit,
& '_naup2: Extend the Arnoldi factorization by')
end if
c
c %-----------------------------------------------------------%
c | Compute NP additional steps of the Arnoldi factorization. |
c %-----------------------------------------------------------%
c
ido = 0
20 continue
update = .true.
c
call znaitr (ido, bmat, n, nev, np, mode, resid, rnorm,
& v , ldv , h, ldh, ipntr, workd, info)
c
if (ido .ne. 99) go to 9000
c
if (info .gt. 0) then
np = info
mxiter = iter
info = -9999
go to 1200
end if
update = .false.
c
if (msglvl .gt. 1) then
call dvout (logfil, 1, rnorm, ndigit,
& '_naup2: Corresponding B-norm of the residual')
end if
c
c %--------------------------------------------------------%
c | Compute the eigenvalues and corresponding error bounds |
c | of the current upper Hessenberg matrix. |
c %--------------------------------------------------------%
c
call zneigh (rnorm, kplusp, h, ldh, ritz, bounds,
& q, ldq, workl, rwork, ierr)
c
if (ierr .ne. 0) then
info = -8
go to 1200
end if
c
c %---------------------------------------------------%
c | Select the wanted Ritz values and their bounds |
c | to be used in the convergence test. |
c | The wanted part of the spectrum and corresponding |
c | error bounds are in the last NEV loc. of RITZ, |
c | and BOUNDS respectively. |
c %---------------------------------------------------%
c
nev = nev0
np = np0
c
c %--------------------------------------------------%
c | Make a copy of Ritz values and the corresponding |
c | Ritz estimates obtained from zneigh . |
c %--------------------------------------------------%
c
call zcopy (kplusp,ritz,1,workl(kplusp**2+1),1)
call zcopy (kplusp,bounds,1,workl(kplusp**2+kplusp+1),1)
c
c %---------------------------------------------------%
c | Select the wanted Ritz values and their bounds |
c | to be used in the convergence test. |
c | The wanted part of the spectrum and corresponding |
c | bounds are in the last NEV loc. of RITZ |
c | BOUNDS respectively. |
c %---------------------------------------------------%
c
call zngets (ishift, which, nev, np, ritz, bounds)
c
c %------------------------------------------------------------%
c | Convergence test: currently we use the following criteria. |
c | The relative accuracy of a Ritz value is considered |
c | acceptable if: |
c | |
c | error_bounds(i) .le. tol*max(eps23, magnitude_of_ritz(i)). |
c | |
c %------------------------------------------------------------%
c
nconv = 0
c
do 25 i = 1, nev
rtemp = max( eps23, dlapy2 ( dble (ritz(np+i)),
& dimag (ritz(np+i)) ) )
if ( dlapy2 (dble (bounds(np+i)),dimag (bounds(np+i)))
& .le. tol*rtemp ) then
nconv = nconv + 1
end if
25 continue
c
if (msglvl .gt. 2) then
kp(1) = nev
kp(2) = np
kp(3) = nconv
call ivout (logfil, 3, kp, ndigit,
& '_naup2: NEV, NP, NCONV are')
call zvout (logfil, kplusp, ritz, ndigit,
& '_naup2: The eigenvalues of H')
call zvout (logfil, kplusp, bounds, ndigit,
& '_naup2: Ritz estimates of the current NCV Ritz values')
end if
c
c %---------------------------------------------------------%
c | Count the number of unwanted Ritz values that have zero |
c | Ritz estimates. If any Ritz estimates are equal to zero |
c | then a leading block of H of order equal to at least |
c | the number of Ritz values with zero Ritz estimates has |
c | split off. None of these Ritz values may be removed by |
c | shifting. Decrease NP the number of shifts to apply. If |
c | no shifts may be applied, then prepare to exit |
c %---------------------------------------------------------%
c
nptemp = np
do 30 j=1, nptemp
if (bounds(j) .eq. zero) then
np = np - 1
nev = nev + 1
end if
30 continue
c
if ( (nconv .ge. nev0) .or.
& (iter .gt. mxiter) .or.
& (np .eq. 0) ) then
c
if (msglvl .gt. 4) then
call zvout (logfil, kplusp, workl(kplusp**2+1), ndigit,
& '_naup2: Eigenvalues computed by _neigh:')
call zvout (logfil, kplusp, workl(kplusp**2+kplusp+1),
& ndigit,
& '_naup2: Ritz estimates computed by _neigh:')
end if
c
c %------------------------------------------------%
c | Prepare to exit. Put the converged Ritz values |
c | and corresponding bounds in RITZ(1:NCONV) and |
c | BOUNDS(1:NCONV) respectively. Then sort. Be |
c | careful when NCONV > NP |
c %------------------------------------------------%
c
c %------------------------------------------%
c | Use h( 3,1 ) as storage to communicate |
c | rnorm to zneupd if needed |
c %------------------------------------------%
h(3,1) = dcmplx (rnorm,rzero)
c
c %----------------------------------------------%
c | Sort Ritz values so that converged Ritz |
c | values appear within the first NEV locations |
c | of ritz and bounds, and the most desired one |
c | appears at the front. |
c %----------------------------------------------%
c
if (which .eq. 'LM') wprime = 'SM'
if (which .eq. 'SM') wprime = 'LM'
if (which .eq. 'LR') wprime = 'SR'
if (which .eq. 'SR') wprime = 'LR'
if (which .eq. 'LI') wprime = 'SI'
if (which .eq. 'SI') wprime = 'LI'
c
call zsortc (wprime, .true., kplusp, ritz, bounds)
c
c %--------------------------------------------------%
c | Scale the Ritz estimate of each Ritz value |
c | by 1 / max(eps23, magnitude of the Ritz value). |
c %--------------------------------------------------%
c
do 35 j = 1, nev0
rtemp = max( eps23, dlapy2 ( dble (ritz(j)),
& dimag (ritz(j)) ) )
bounds(j) = bounds(j)/rtemp
35 continue
c
c %---------------------------------------------------%
c | Sort the Ritz values according to the scaled Ritz |
c | estimates. This will push all the converged ones |
c | towards the front of ritz, bounds (in the case |
c | when NCONV < NEV.) |
c %---------------------------------------------------%
c
wprime = 'LM'
call zsortc (wprime, .true., nev0, bounds, ritz)
c
c %----------------------------------------------%
c | Scale the Ritz estimate back to its original |
c | value. |
c %----------------------------------------------%
c
do 40 j = 1, nev0
rtemp = max( eps23, dlapy2 ( dble (ritz(j)),
& dimag (ritz(j)) ) )
bounds(j) = bounds(j)*rtemp
40 continue
c
c %-----------------------------------------------%
c | Sort the converged Ritz values again so that |
c | the "threshold" value appears at the front of |
c | ritz and bound. |
c %-----------------------------------------------%
c
call zsortc (which, .true., nconv, ritz, bounds)
c
if (msglvl .gt. 1) then
call zvout (logfil, kplusp, ritz, ndigit,
& '_naup2: Sorted eigenvalues')
call zvout (logfil, kplusp, bounds, ndigit,
& '_naup2: Sorted ritz estimates.')
end if
c
c %------------------------------------%
c | Max iterations have been exceeded. |
c %------------------------------------%
c
if (iter .gt. mxiter .and. nconv .lt. nev0) info = 1
c
c %---------------------%
c | No shifts to apply. |
c %---------------------%
c
if (np .eq. 0 .and. nconv .lt. nev0) info = 2
c
np = nconv
go to 1100
c
else if ( (nconv .lt. nev0) .and. (ishift .eq. 1) ) then
c
c %-------------------------------------------------%
c | Do not have all the requested eigenvalues yet. |
c | To prevent possible stagnation, adjust the size |
c | of NEV. |
c %-------------------------------------------------%
c
nevbef = nev
nev = nev + min(nconv, np/2)
if (nev .eq. 1 .and. kplusp .ge. 6) then
nev = kplusp / 2
else if (nev .eq. 1 .and. kplusp .gt. 3) then
nev = 2
end if
np = kplusp - nev
c
c %---------------------------------------%
c | If the size of NEV was just increased |
c | resort the eigenvalues. |
c %---------------------------------------%
c
if (nevbef .lt. nev)
& call zngets (ishift, which, nev, np, ritz, bounds)
c
end if
c
if (msglvl .gt. 0) then
call ivout (logfil, 1, nconv, ndigit,
& '_naup2: no. of "converged" Ritz values at this iter.')
if (msglvl .gt. 1) then
kp(1) = nev
kp(2) = np
call ivout (logfil, 2, kp, ndigit,
& '_naup2: NEV and NP are')
call zvout (logfil, nev, ritz(np+1), ndigit,
& '_naup2: "wanted" Ritz values ')
call zvout (logfil, nev, bounds(np+1), ndigit,
& '_naup2: Ritz estimates of the "wanted" values ')
end if
end if
c
if (ishift .eq. 0) then
c
c %-------------------------------------------------------%
c | User specified shifts: pop back out to get the shifts |
c | and return them in the first 2*NP locations of WORKL. |
c %-------------------------------------------------------%
c
ushift = .true.
ido = 3
go to 9000
end if
50 continue
ushift = .false.
c
if ( ishift .ne. 1 ) then
c
c %----------------------------------%
c | Move the NP shifts from WORKL to |
c | RITZ, to free up WORKL |
c | for non-exact shift case. |
c %----------------------------------%
c
call zcopy (np, workl, 1, ritz, 1)
end if
c
if (msglvl .gt. 2) then
call ivout (logfil, 1, np, ndigit,
& '_naup2: The number of shifts to apply ')
call zvout (logfil, np, ritz, ndigit,
& '_naup2: values of the shifts')
if ( ishift .eq. 1 )
& call zvout (logfil, np, bounds, ndigit,
& '_naup2: Ritz estimates of the shifts')
end if
c
c %---------------------------------------------------------%
c | Apply the NP implicit shifts by QR bulge chasing. |
c | Each shift is applied to the whole upper Hessenberg |
c | matrix H. |
c | The first 2*N locations of WORKD are used as workspace. |
c %---------------------------------------------------------%
c
call znapps (n, nev, np, ritz, v, ldv,
& h, ldh, resid, q, ldq, workl, workd)
c
c %---------------------------------------------%
c | Compute the B-norm of the updated residual. |
c | Keep B*RESID in WORKD(1:N) to be used in |
c | the first step of the next call to znaitr . |
c %---------------------------------------------%
c
cnorm = .true.
call second (t2)
if (bmat .eq. 'G') then
nbx = nbx + 1
call zcopy (n, resid, 1, workd(n+1), 1)
ipntr(1) = n + 1
ipntr(2) = 1
ido = 2
c
c %----------------------------------%
c | Exit in order to compute B*RESID |
c %----------------------------------%
c
go to 9000
else if (bmat .eq. 'I') then
call zcopy (n, resid, 1, workd, 1)
end if
c
100 continue
c
c %----------------------------------%
c | Back from reverse communication; |
c | WORKD(1:N) := B*RESID |
c %----------------------------------%
c
if (bmat .eq. 'G') then
call second (t3)
tmvbx = tmvbx + (t3 - t2)
end if
c
if (bmat .eq. 'G') then
cmpnorm = zdotc (n, resid, 1, workd, 1)
rnorm = sqrt(dlapy2 (dble (cmpnorm),dimag (cmpnorm)))
else if (bmat .eq. 'I') then
rnorm = dznrm2 (n, resid, 1)
end if
cnorm = .false.
c
if (msglvl .gt. 2) then
call dvout (logfil, 1, rnorm, ndigit,
& '_naup2: B-norm of residual for compressed factorization')
call zmout (logfil, nev, nev, h, ldh, ndigit,
& '_naup2: Compressed upper Hessenberg matrix H')
end if
c
go to 1000
c
c %---------------------------------------------------------------%
c | |
c | E N D O F M A I N I T E R A T I O N L O O P |
c | |
c %---------------------------------------------------------------%
c
1100 continue
c
mxiter = iter
nev = nconv
c
1200 continue
ido = 99
c
c %------------%
c | Error Exit |
c %------------%
c
call second (t1)
tcaup2 = t1 - t0
c
9000 continue
c
c %---------------%
c | End of znaup2 |
c %---------------%
c
return
end

664
arpack/ARPACK/SRC/znaupd.f Normal file
View File

@@ -0,0 +1,664 @@
c\BeginDoc
c
c\Name: znaupd
c
c\Description:
c Reverse communication interface for the Implicitly Restarted Arnoldi
c iteration. This is intended to be used to find a few eigenpairs of a
c complex linear operator OP with respect to a semi-inner product defined
c by a hermitian positive semi-definite real matrix B. B may be the identity
c matrix. NOTE: if both OP and B are real, then dsaupd or dnaupd should
c be used.
c
c
c The computed approximate eigenvalues are called Ritz values and
c the corresponding approximate eigenvectors are called Ritz vectors.
c
c znaupd is usually called iteratively to solve one of the
c following problems:
c
c Mode 1: A*x = lambda*x.
c ===> OP = A and B = I.
c
c Mode 2: A*x = lambda*M*x, M hermitian positive definite
c ===> OP = inv[M]*A and B = M.
c ===> (If M can be factored see remark 3 below)
c
c Mode 3: A*x = lambda*M*x, M hermitian semi-definite
c ===> OP = inv[A - sigma*M]*M and B = M.
c ===> shift-and-invert mode
c If OP*x = amu*x, then lambda = sigma + 1/amu.
c
c
c NOTE: The action of w <- inv[A - sigma*M]*v or w <- inv[M]*v
c should be accomplished either by a direct method
c using a sparse matrix factorization and solving
c
c [A - sigma*M]*w = v or M*w = v,
c
c or through an iterative method for solving these
c systems. If an iterative method is used, the
c convergence test must be more stringent than
c the accuracy requirements for the eigenvalue
c approximations.
c
c\Usage:
c call znaupd
c ( IDO, BMAT, N, WHICH, NEV, TOL, RESID, NCV, V, LDV, IPARAM,
c IPNTR, WORKD, WORKL, LWORKL, RWORK, INFO )
c
c\Arguments
c IDO Integer. (INPUT/OUTPUT)
c Reverse communication flag. IDO must be zero on the first
c call to znaupd. IDO will be set internally to
c indicate the type of operation to be performed. Control is
c then given back to the calling routine which has the
c responsibility to carry out the requested operation and call
c znaupd with the result. The operand is given in
c WORKD(IPNTR(1)), the result must be put in WORKD(IPNTR(2)).
c -------------------------------------------------------------
c IDO = 0: first call to the reverse communication interface
c IDO = -1: compute Y = OP * X where
c IPNTR(1) is the pointer into WORKD for X,
c IPNTR(2) is the pointer into WORKD for Y.
c This is for the initialization phase to force the
c starting vector into the range of OP.
c IDO = 1: compute Y = OP * X where
c IPNTR(1) is the pointer into WORKD for X,
c IPNTR(2) is the pointer into WORKD for Y.
c In mode 3, the vector B * X is already
c available in WORKD(ipntr(3)). It does not
c need to be recomputed in forming OP * X.
c IDO = 2: compute Y = M * X where
c IPNTR(1) is the pointer into WORKD for X,
c IPNTR(2) is the pointer into WORKD for Y.
c IDO = 3: compute and return the shifts in the first
c NP locations of WORKL.
c IDO = 99: done
c -------------------------------------------------------------
c After the initialization phase, when the routine is used in
c the "shift-and-invert" mode, the vector M * X is already
c available and does not need to be recomputed in forming OP*X.
c
c BMAT Character*1. (INPUT)
c BMAT specifies the type of the matrix B that defines the
c semi-inner product for the operator OP.
c BMAT = 'I' -> standard eigenvalue problem A*x = lambda*x
c BMAT = 'G' -> generalized eigenvalue problem A*x = lambda*M*x
c
c N Integer. (INPUT)
c Dimension of the eigenproblem.
c
c WHICH Character*2. (INPUT)
c 'LM' -> want the NEV eigenvalues of largest magnitude.
c 'SM' -> want the NEV eigenvalues of smallest magnitude.
c 'LR' -> want the NEV eigenvalues of largest real part.
c 'SR' -> want the NEV eigenvalues of smallest real part.
c 'LI' -> want the NEV eigenvalues of largest imaginary part.
c 'SI' -> want the NEV eigenvalues of smallest imaginary part.
c
c NEV Integer. (INPUT)
c Number of eigenvalues of OP to be computed. 0 < NEV < N-1.
c
c TOL Double precision scalar. (INPUT)
c Stopping criteria: the relative accuracy of the Ritz value
c is considered acceptable if BOUNDS(I) .LE. TOL*ABS(RITZ(I))
c where ABS(RITZ(I)) is the magnitude when RITZ(I) is complex.
c DEFAULT = dlamch('EPS') (machine precision as computed
c by the LAPACK auxiliary subroutine dlamch).
c
c RESID Complex*16 array of length N. (INPUT/OUTPUT)
c On INPUT:
c If INFO .EQ. 0, a random initial residual vector is used.
c If INFO .NE. 0, RESID contains the initial residual vector,
c possibly from a previous run.
c On OUTPUT:
c RESID contains the final residual vector.
c
c NCV Integer. (INPUT)
c Number of columns of the matrix V. NCV must satisfy the two
c inequalities 1 <= NCV-NEV and NCV <= N.
c This will indicate how many Arnoldi vectors are generated
c at each iteration. After the startup phase in which NEV
c Arnoldi vectors are generated, the algorithm generates
c approximately NCV-NEV Arnoldi vectors at each subsequent update
c iteration. Most of the cost in generating each Arnoldi vector is
c in the matrix-vector operation OP*x. (See remark 4 below.)
c
c V Complex*16 array N by NCV. (OUTPUT)
c Contains the final set of Arnoldi basis vectors.
c
c LDV Integer. (INPUT)
c Leading dimension of V exactly as declared in the calling program.
c
c IPARAM Integer array of length 11. (INPUT/OUTPUT)
c IPARAM(1) = ISHIFT: method for selecting the implicit shifts.
c The shifts selected at each iteration are used to filter out
c the components of the unwanted eigenvector.
c -------------------------------------------------------------
c ISHIFT = 0: the shifts are to be provided by the user via
c reverse communication. The NCV eigenvalues of
c the Hessenberg matrix H are returned in the part
c of WORKL array corresponding to RITZ.
c ISHIFT = 1: exact shifts with respect to the current
c Hessenberg matrix H. This is equivalent to
c restarting the iteration from the beginning
c after updating the starting vector with a linear
c combination of Ritz vectors associated with the
c "wanted" eigenvalues.
c ISHIFT = 2: other choice of internal shift to be defined.
c -------------------------------------------------------------
c
c IPARAM(2) = No longer referenced
c
c IPARAM(3) = MXITER
c On INPUT: maximum number of Arnoldi update iterations allowed.
c On OUTPUT: actual number of Arnoldi update iterations taken.
c
c IPARAM(4) = NB: blocksize to be used in the recurrence.
c The code currently works only for NB = 1.
c
c IPARAM(5) = NCONV: number of "converged" Ritz values.
c This represents the number of Ritz values that satisfy
c the convergence criterion.
c
c IPARAM(6) = IUPD
c No longer referenced. Implicit restarting is ALWAYS used.
c
c IPARAM(7) = MODE
c On INPUT determines what type of eigenproblem is being solved.
c Must be 1,2,3; See under \Description of znaupd for the
c four modes available.
c
c IPARAM(8) = NP
c When ido = 3 and the user provides shifts through reverse
c communication (IPARAM(1)=0), _naupd returns NP, the number
c of shifts the user is to provide. 0 < NP < NCV-NEV.
c
c IPARAM(9) = NUMOP, IPARAM(10) = NUMOPB, IPARAM(11) = NUMREO,
c OUTPUT: NUMOP = total number of OP*x operations,
c NUMOPB = total number of B*x operations if BMAT='G',
c NUMREO = total number of steps of re-orthogonalization.
c
c IPNTR Integer array of length 14. (OUTPUT)
c Pointer to mark the starting locations in the WORKD and WORKL
c arrays for matrices/vectors used by the Arnoldi iteration.
c -------------------------------------------------------------
c IPNTR(1): pointer to the current operand vector X in WORKD.
c IPNTR(2): pointer to the current result vector Y in WORKD.
c IPNTR(3): pointer to the vector B * X in WORKD when used in
c the shift-and-invert mode.
c IPNTR(4): pointer to the next available location in WORKL
c that is untouched by the program.
c IPNTR(5): pointer to the NCV by NCV upper Hessenberg
c matrix H in WORKL.
c IPNTR(6): pointer to the ritz value array RITZ
c IPNTR(7): pointer to the (projected) ritz vector array Q
c IPNTR(8): pointer to the error BOUNDS array in WORKL.
c IPNTR(14): pointer to the NP shifts in WORKL. See Remark 5 below.
c
c Note: IPNTR(9:13) is only referenced by zneupd. See Remark 2 below.
c
c IPNTR(9): pointer to the NCV RITZ values of the
c original system.
c IPNTR(10): Not Used
c IPNTR(11): pointer to the NCV corresponding error bounds.
c IPNTR(12): pointer to the NCV by NCV upper triangular
c Schur matrix for H.
c IPNTR(13): pointer to the NCV by NCV matrix of eigenvectors
c of the upper Hessenberg matrix H. Only referenced by
c zneupd if RVEC = .TRUE. See Remark 2 below.
c
c -------------------------------------------------------------
c
c WORKD Complex*16 work array of length 3*N. (REVERSE COMMUNICATION)
c Distributed array to be used in the basic Arnoldi iteration
c for reverse communication. The user should not use WORKD
c as temporary workspace during the iteration !!!!!!!!!!
c See Data Distribution Note below.
c
c WORKL Complex*16 work array of length LWORKL. (OUTPUT/WORKSPACE)
c Private (replicated) array on each PE or array allocated on
c the front end. See Data Distribution Note below.
c
c LWORKL Integer. (INPUT)
c LWORKL must be at least 3*NCV**2 + 5*NCV.
c
c RWORK Double precision work array of length NCV (WORKSPACE)
c Private (replicated) array on each PE or array allocated on
c the front end.
c
c
c INFO Integer. (INPUT/OUTPUT)
c If INFO .EQ. 0, a randomly initial residual vector is used.
c If INFO .NE. 0, RESID contains the initial residual vector,
c possibly from a previous run.
c Error flag on output.
c = 0: Normal exit.
c = 1: Maximum number of iterations taken.
c All possible eigenvalues of OP has been found. IPARAM(5)
c returns the number of wanted converged Ritz values.
c = 2: No longer an informational error. Deprecated starting
c with release 2 of ARPACK.
c = 3: No shifts could be applied during a cycle of the
c Implicitly restarted Arnoldi iteration. One possibility
c is to increase the size of NCV relative to NEV.
c See remark 4 below.
c = -1: N must be positive.
c = -2: NEV must be positive.
c = -3: NCV-NEV >= 1 and less than or equal to N.
c = -4: The maximum number of Arnoldi update iteration
c must be greater than zero.
c = -5: WHICH must be one of 'LM', 'SM', 'LR', 'SR', 'LI', 'SI'
c = -6: BMAT must be one of 'I' or 'G'.
c = -7: Length of private work array is not sufficient.
c = -8: Error return from LAPACK eigenvalue calculation;
c = -9: Starting vector is zero.
c = -10: IPARAM(7) must be 1,2,3.
c = -11: IPARAM(7) = 1 and BMAT = 'G' are incompatible.
c = -12: IPARAM(1) must be equal to 0 or 1.
c = -9999: Could not build an Arnoldi factorization.
c User input error highly likely. Please
c check actual array dimensions and layout.
c IPARAM(5) returns the size of the current Arnoldi
c factorization.
c
c\Remarks
c 1. The computed Ritz values are approximate eigenvalues of OP. The
c selection of WHICH should be made with this in mind when using
c Mode = 3. When operating in Mode = 3 setting WHICH = 'LM' will
c compute the NEV eigenvalues of the original problem that are
c closest to the shift SIGMA . After convergence, approximate eigenvalues
c of the original problem may be obtained with the ARPACK subroutine zneupd.
c
c 2. If a basis for the invariant subspace corresponding to the converged Ritz
c values is needed, the user must call zneupd immediately following
c completion of znaupd. This is new starting with release 2 of ARPACK.
c
c 3. If M can be factored into a Cholesky factorization M = LL`
c then Mode = 2 should not be selected. Instead one should use
c Mode = 1 with OP = inv(L)*A*inv(L`). Appropriate triangular
c linear systems should be solved with L and L` rather
c than computing inverses. After convergence, an approximate
c eigenvector z of the original problem is recovered by solving
c L`z = x where x is a Ritz vector of OP.
c
c 4. At present there is no a-priori analysis to guide the selection
c of NCV relative to NEV. The only formal requirement is that NCV > NEV + 1.
c However, it is recommended that NCV .ge. 2*NEV. If many problems of
c the same type are to be solved, one should experiment with increasing
c NCV while keeping NEV fixed for a given test problem. This will
c usually decrease the required number of OP*x operations but it
c also increases the work and storage required to maintain the orthogonal
c basis vectors. The optimal "cross-over" with respect to CPU time
c is problem dependent and must be determined empirically.
c See Chapter 8 of Reference 2 for further information.
c
c 5. When IPARAM(1) = 0, and IDO = 3, the user needs to provide the
c NP = IPARAM(8) complex shifts in locations
c WORKL(IPNTR(14)), WORKL(IPNTR(14)+1), ... , WORKL(IPNTR(14)+NP).
c Eigenvalues of the current upper Hessenberg matrix are located in
c WORKL(IPNTR(6)) through WORKL(IPNTR(6)+NCV-1). They are ordered
c according to the order defined by WHICH. The associated Ritz estimates
c are located in WORKL(IPNTR(8)), WORKL(IPNTR(8)+1), ... ,
c WORKL(IPNTR(8)+NCV-1).
c
c-----------------------------------------------------------------------
c
c\Data Distribution Note:
c
c Fortran-D syntax:
c ================
c Complex*16 resid(n), v(ldv,ncv), workd(3*n), workl(lworkl)
c decompose d1(n), d2(n,ncv)
c align resid(i) with d1(i)
c align v(i,j) with d2(i,j)
c align workd(i) with d1(i) range (1:n)
c align workd(i) with d1(i-n) range (n+1:2*n)
c align workd(i) with d1(i-2*n) range (2*n+1:3*n)
c distribute d1(block), d2(block,:)
c replicated workl(lworkl)
c
c Cray MPP syntax:
c ===============
c Complex*16 resid(n), v(ldv,ncv), workd(n,3), workl(lworkl)
c shared resid(block), v(block,:), workd(block,:)
c replicated workl(lworkl)
c
c CM2/CM5 syntax:
c ==============
c
c-----------------------------------------------------------------------
c
c include 'ex-nonsym.doc'
c
c-----------------------------------------------------------------------
c
c\BeginLib
c
c\Local variables:
c xxxxxx Complex*16
c
c\References:
c 1. D.C. Sorensen, "Implicit Application of Polynomial Filters in
c a k-Step Arnoldi Method", SIAM J. Matr. Anal. Apps., 13 (1992),
c pp 357-385.
c 2. R.B. Lehoucq, "Analysis and Implementation of an Implicitly
c Restarted Arnoldi Iteration", Rice University Technical Report
c TR95-13, Department of Computational and Applied Mathematics.
c 3. B.N. Parlett & Y. Saad, "_Complex_ Shift and Invert Strategies for
c Double precision Matrices", Linear Algebra and its Applications, vol 88/89,
c pp 575-595, (1987).
c
c\Routines called:
c znaup2 ARPACK routine that implements the Implicitly Restarted
c Arnoldi Iteration.
c zstatn ARPACK routine that initializes the timing variables.
c ivout ARPACK utility routine that prints integers.
c zvout ARPACK utility routine that prints vectors.
c second ARPACK utility routine for timing.
c dlamch LAPACK routine that determines machine constants.
c
c\Author
c Danny Sorensen Phuong Vu
c Richard Lehoucq CRPC / Rice University
c Dept. of Computational & Houston, Texas
c Applied Mathematics
c Rice University
c Houston, Texas
c
c\SCCS Information: @(#)
c FILE: naupd.F SID: 2.9 DATE OF SID: 07/21/02 RELEASE: 2
c
c\Remarks
c
c\EndLib
c
c-----------------------------------------------------------------------
c
subroutine znaupd
& ( ido, bmat, n, which, nev, tol, resid, ncv, v, ldv, iparam,
& ipntr, workd, workl, lworkl, rwork, info )
c
c %----------------------------------------------------%
c | Include files for debugging and timing information |
c %----------------------------------------------------%
c
include 'debug.h'
include 'stat.h'
c
c %------------------%
c | Scalar Arguments |
c %------------------%
c
character bmat*1, which*2
integer ido, info, ldv, lworkl, n, ncv, nev
Double precision
& tol
c
c %-----------------%
c | Array Arguments |
c %-----------------%
c
integer iparam(11), ipntr(14)
Complex*16
& resid(n), v(ldv,ncv), workd(3*n), workl(lworkl)
Double precision
& rwork(ncv)
c
c %------------%
c | Parameters |
c %------------%
c
Complex*16
& one, zero
parameter (one = (1.0D+0, 0.0D+0), zero = (0.0D+0, 0.0D+0))
c
c %---------------%
c | Local Scalars |
c %---------------%
c
integer bounds, ierr, ih, iq, ishift, iupd, iw,
& ldh, ldq, levec, mode, msglvl, mxiter, nb,
& nev0, next, np, ritz, j
save bounds, ih, iq, ishift, iupd, iw,
& ldh, ldq, levec, mode, msglvl, mxiter, nb,
& nev0, next, np, ritz
c
c %----------------------%
c | External Subroutines |
c %----------------------%
c
external znaup2, zvout, ivout, second, zstatn
c
c %--------------------%
c | External Functions |
c %--------------------%
c
Double precision
& dlamch
external dlamch
c
c %-----------------------%
c | Executable Statements |
c %-----------------------%
c
if (ido .eq. 0) then
c
c %-------------------------------%
c | Initialize timing statistics |
c | & message level for debugging |
c %-------------------------------%
c
call zstatn
call second (t0)
msglvl = mcaupd
c
c %----------------%
c | Error checking |
c %----------------%
c
ierr = 0
ishift = iparam(1)
c levec = iparam(2)
mxiter = iparam(3)
c nb = iparam(4)
nb = 1
c
c %--------------------------------------------%
c | Revision 2 performs only implicit restart. |
c %--------------------------------------------%
c
iupd = 1
mode = iparam(7)
c
if (n .le. 0) then
ierr = -1
else if (nev .le. 0) then
ierr = -2
else if (ncv .le. nev .or. ncv .gt. n) then
ierr = -3
else if (mxiter .le. 0) then
ierr = -4
else if (which .ne. 'LM' .and.
& which .ne. 'SM' .and.
& which .ne. 'LR' .and.
& which .ne. 'SR' .and.
& which .ne. 'LI' .and.
& which .ne. 'SI') then
ierr = -5
else if (bmat .ne. 'I' .and. bmat .ne. 'G') then
ierr = -6
else if (lworkl .lt. 3*ncv**2 + 5*ncv) then
ierr = -7
else if (mode .lt. 1 .or. mode .gt. 3) then
ierr = -10
else if (mode .eq. 1 .and. bmat .eq. 'G') then
ierr = -11
end if
c
c %------------%
c | Error Exit |
c %------------%
c
if (ierr .ne. 0) then
info = ierr
ido = 99
go to 9000
end if
c
c %------------------------%
c | Set default parameters |
c %------------------------%
c
if (nb .le. 0) nb = 1
if (tol .le. 0.0D+0 ) tol = dlamch('EpsMach')
if (ishift .ne. 0 .and.
& ishift .ne. 1 .and.
& ishift .ne. 2) ishift = 1
c
c %----------------------------------------------%
c | NP is the number of additional steps to |
c | extend the length NEV Lanczos factorization. |
c | NEV0 is the local variable designating the |
c | size of the invariant subspace desired. |
c %----------------------------------------------%
c
np = ncv - nev
nev0 = nev
c
c %-----------------------------%
c | Zero out internal workspace |
c %-----------------------------%
c
do 10 j = 1, 3*ncv**2 + 5*ncv
workl(j) = zero
10 continue
c
c %-------------------------------------------------------------%
c | Pointer into WORKL for address of H, RITZ, BOUNDS, Q |
c | etc... and the remaining workspace. |
c | Also update pointer to be used on output. |
c | Memory is laid out as follows: |
c | workl(1:ncv*ncv) := generated Hessenberg matrix |
c | workl(ncv*ncv+1:ncv*ncv+ncv) := the ritz values |
c | workl(ncv*ncv+ncv+1:ncv*ncv+2*ncv) := error bounds |
c | workl(ncv*ncv+2*ncv+1:2*ncv*ncv+2*ncv) := rotation matrix Q |
c | workl(2*ncv*ncv+2*ncv+1:3*ncv*ncv+5*ncv) := workspace |
c | The final workspace is needed by subroutine zneigh called |
c | by znaup2. Subroutine zneigh calls LAPACK routines for |
c | calculating eigenvalues and the last row of the eigenvector |
c | matrix. |
c %-------------------------------------------------------------%
c
ldh = ncv
ldq = ncv
ih = 1
ritz = ih + ldh*ncv
bounds = ritz + ncv
iq = bounds + ncv
iw = iq + ldq*ncv
next = iw + ncv**2 + 3*ncv
c
ipntr(4) = next
ipntr(5) = ih
ipntr(6) = ritz
ipntr(7) = iq
ipntr(8) = bounds
ipntr(14) = iw
end if
c
c %-------------------------------------------------------%
c | Carry out the Implicitly restarted Arnoldi Iteration. |
c %-------------------------------------------------------%
c
call znaup2
& ( ido, bmat, n, which, nev0, np, tol, resid, mode, iupd,
& ishift, mxiter, v, ldv, workl(ih), ldh, workl(ritz),
& workl(bounds), workl(iq), ldq, workl(iw),
& ipntr, workd, rwork, info )
c
c %--------------------------------------------------%
c | ido .ne. 99 implies use of reverse communication |
c | to compute operations involving OP. |
c %--------------------------------------------------%
c
if (ido .eq. 3) iparam(8) = np
if (ido .ne. 99) go to 9000
c
iparam(3) = mxiter
iparam(5) = np
iparam(9) = nopx
iparam(10) = nbx
iparam(11) = nrorth
c
c %------------------------------------%
c | Exit if there was an informational |
c | error within znaup2. |
c %------------------------------------%
c
if (info .lt. 0) go to 9000
if (info .eq. 2) info = 3
c
if (msglvl .gt. 0) then
call ivout (logfil, 1, mxiter, ndigit,
& '_naupd: Number of update iterations taken')
call ivout (logfil, 1, np, ndigit,
& '_naupd: Number of wanted "converged" Ritz values')
call zvout (logfil, np, workl(ritz), ndigit,
& '_naupd: The final Ritz values')
call zvout (logfil, np, workl(bounds), ndigit,
& '_naupd: Associated Ritz estimates')
end if
c
call second (t1)
tcaupd = t1 - t0
c
if (msglvl .gt. 0) then
c
c %--------------------------------------------------------%
c | Version Number & Version Date are defined in version.h |
c %--------------------------------------------------------%
c
write (6,1000)
write (6,1100) mxiter, nopx, nbx, nrorth, nitref, nrstrt,
& tmvopx, tmvbx, tcaupd, tcaup2, tcaitr, titref,
& tgetv0, tceigh, tcgets, tcapps, tcconv, trvec
1000 format (//,
& 5x, '=============================================',/
& 5x, '= Complex implicit Arnoldi update code =',/
& 5x, '= Version Number: ', ' 2.3', 21x, ' =',/
& 5x, '= Version Date: ', ' 07/31/96', 16x, ' =',/
& 5x, '=============================================',/
& 5x, '= Summary of timing statistics =',/
& 5x, '=============================================',//)
1100 format (
& 5x, 'Total number update iterations = ', i5,/
& 5x, 'Total number of OP*x operations = ', i5,/
& 5x, 'Total number of B*x operations = ', i5,/
& 5x, 'Total number of reorthogonalization steps = ', i5,/
& 5x, 'Total number of iterative refinement steps = ', i5,/
& 5x, 'Total number of restart steps = ', i5,/
& 5x, 'Total time in user OP*x operation = ', f12.6,/
& 5x, 'Total time in user B*x operation = ', f12.6,/
& 5x, 'Total time in Arnoldi update routine = ', f12.6,/
& 5x, 'Total time in naup2 routine = ', f12.6,/
& 5x, 'Total time in basic Arnoldi iteration loop = ', f12.6,/
& 5x, 'Total time in reorthogonalization phase = ', f12.6,/
& 5x, 'Total time in (re)start vector generation = ', f12.6,/
& 5x, 'Total time in Hessenberg eig. subproblem = ', f12.6,/
& 5x, 'Total time in getting the shifts = ', f12.6,/
& 5x, 'Total time in applying the shifts = ', f12.6,/
& 5x, 'Total time in convergence testing = ', f12.6,/
& 5x, 'Total time in computing final Ritz vectors = ', f12.6/)
end if
c
9000 continue
c
return
c
c %---------------%
c | End of znaupd |
c %---------------%
c
end

257
arpack/ARPACK/SRC/zneigh.f Normal file
View File

@@ -0,0 +1,257 @@
c\BeginDoc
c
c\Name: zneigh
c
c\Description:
c Compute the eigenvalues of the current upper Hessenberg matrix
c and the corresponding Ritz estimates given the current residual norm.
c
c\Usage:
c call zneigh
c ( RNORM, N, H, LDH, RITZ, BOUNDS, Q, LDQ, WORKL, RWORK, IERR )
c
c\Arguments
c RNORM Double precision scalar. (INPUT)
c Residual norm corresponding to the current upper Hessenberg
c matrix H.
c
c N Integer. (INPUT)
c Size of the matrix H.
c
c H Complex*16 N by N array. (INPUT)
c H contains the current upper Hessenberg matrix.
c
c LDH Integer. (INPUT)
c Leading dimension of H exactly as declared in the calling
c program.
c
c RITZ Complex*16 array of length N. (OUTPUT)
c On output, RITZ(1:N) contains the eigenvalues of H.
c
c BOUNDS Complex*16 array of length N. (OUTPUT)
c On output, BOUNDS contains the Ritz estimates associated with
c the eigenvalues held in RITZ. This is equal to RNORM
c times the last components of the eigenvectors corresponding
c to the eigenvalues in RITZ.
c
c Q Complex*16 N by N array. (WORKSPACE)
c Workspace needed to store the eigenvectors of H.
c
c LDQ Integer. (INPUT)
c Leading dimension of Q exactly as declared in the calling
c program.
c
c WORKL Complex*16 work array of length N**2 + 3*N. (WORKSPACE)
c Private (replicated) array on each PE or array allocated on
c the front end. This is needed to keep the full Schur form
c of H and also in the calculation of the eigenvectors of H.
c
c RWORK Double precision work array of length N (WORKSPACE)
c Private (replicated) array on each PE or array allocated on
c the front end.
c
c IERR Integer. (OUTPUT)
c Error exit flag from zlahqr or ztrevc.
c
c\EndDoc
c
c-----------------------------------------------------------------------
c
c\BeginLib
c
c\Local variables:
c xxxxxx Complex*16
c
c\Routines called:
c ivout ARPACK utility routine that prints integers.
c second ARPACK utility routine for timing.
c zmout ARPACK utility routine that prints matrices
c zvout ARPACK utility routine that prints vectors.
c dvout ARPACK utility routine that prints vectors.
c zlacpy LAPACK matrix copy routine.
c zlahqr LAPACK routine to compute the Schur form of an
c upper Hessenberg matrix.
c zlaset LAPACK matrix initialization routine.
c ztrevc LAPACK routine to compute the eigenvectors of a matrix
c in upper triangular form
c zcopy Level 1 BLAS that copies one vector to another.
c zdscal Level 1 BLAS that scales a complex vector by a real number.
c dznrm2 Level 1 BLAS that computes the norm of a vector.
c
c
c\Author
c Danny Sorensen Phuong Vu
c Richard Lehoucq CRPC / Rice University
c Dept. of Computational & Houston, Texas
c Applied Mathematics
c Rice University
c Houston, Texas
c
c\SCCS Information: @(#)
c FILE: neigh.F SID: 2.2 DATE OF SID: 4/20/96 RELEASE: 2
c
c\Remarks
c None
c
c\EndLib
c
c-----------------------------------------------------------------------
c
subroutine zneigh (rnorm, n, h, ldh, ritz, bounds,
& q, ldq, workl, rwork, ierr)
c
c %----------------------------------------------------%
c | Include files for debugging and timing information |
c %----------------------------------------------------%
c
include 'debug.h'
include 'stat.h'
c
c %------------------%
c | Scalar Arguments |
c %------------------%
c
integer ierr, n, ldh, ldq
Double precision
& rnorm
c
c %-----------------%
c | Array Arguments |
c %-----------------%
c
Complex*16
& bounds(n), h(ldh,n), q(ldq,n), ritz(n),
& workl(n*(n+3))
Double precision
& rwork(n)
c
c %------------%
c | Parameters |
c %------------%
c
Complex*16
& one, zero
Double precision
& rone
parameter (one = (1.0D+0, 0.0D+0), zero = (0.0D+0, 0.0D+0),
& rone = 1.0D+0)
c
c %------------------------%
c | Local Scalars & Arrays |
c %------------------------%
c
logical select(1)
integer j, msglvl
Complex*16
& vl(1)
Double precision
& temp
c
c %----------------------%
c | External Subroutines |
c %----------------------%
c
external zlacpy, zlahqr, ztrevc, zcopy,
& zdscal, zmout, zvout, second
c
c %--------------------%
c | External Functions |
c %--------------------%
c
Double precision
& dznrm2
external dznrm2
c
c %-----------------------%
c | Executable Statements |
c %-----------------------%
c
c %-------------------------------%
c | Initialize timing statistics |
c | & message level for debugging |
c %-------------------------------%
c
call second (t0)
msglvl = mceigh
c
if (msglvl .gt. 2) then
call zmout (logfil, n, n, h, ldh, ndigit,
& '_neigh: Entering upper Hessenberg matrix H ')
end if
c
c %----------------------------------------------------------%
c | 1. Compute the eigenvalues, the last components of the |
c | corresponding Schur vectors and the full Schur form T |
c | of the current upper Hessenberg matrix H. |
c | zlahqr returns the full Schur form of H |
c | in WORKL(1:N**2), and the Schur vectors in q. |
c %----------------------------------------------------------%
c
call zlacpy ('All', n, n, h, ldh, workl, n)
call zlaset ('All', n, n, zero, one, q, ldq)
call zlahqr (.true., .true., n, 1, n, workl, ldh, ritz,
& 1, n, q, ldq, ierr)
if (ierr .ne. 0) go to 9000
c
call zcopy (n, q(n-1,1), ldq, bounds, 1)
if (msglvl .gt. 1) then
call zvout (logfil, n, bounds, ndigit,
& '_neigh: last row of the Schur matrix for H')
end if
c
c %----------------------------------------------------------%
c | 2. Compute the eigenvectors of the full Schur form T and |
c | apply the Schur vectors to get the corresponding |
c | eigenvectors. |
c %----------------------------------------------------------%
c
call ztrevc ('Right', 'Back', select, n, workl, n, vl, n, q,
& ldq, n, n, workl(n*n+1), rwork, ierr)
c
if (ierr .ne. 0) go to 9000
c
c %------------------------------------------------%
c | Scale the returning eigenvectors so that their |
c | Euclidean norms are all one. LAPACK subroutine |
c | ztrevc returns each eigenvector normalized so |
c | that the element of largest magnitude has |
c | magnitude 1; here the magnitude of a complex |
c | number (x,y) is taken to be |x| + |y|. |
c %------------------------------------------------%
c
do 10 j=1, n
temp = dznrm2( n, q(1,j), 1 )
call zdscal ( n, rone / temp, q(1,j), 1 )
10 continue
c
if (msglvl .gt. 1) then
call zcopy(n, q(n,1), ldq, workl, 1)
call zvout (logfil, n, workl, ndigit,
& '_neigh: Last row of the eigenvector matrix for H')
end if
c
c %----------------------------%
c | Compute the Ritz estimates |
c %----------------------------%
c
call zcopy(n, q(n,1), n, bounds, 1)
call zdscal(n, rnorm, bounds, 1)
c
if (msglvl .gt. 2) then
call zvout (logfil, n, ritz, ndigit,
& '_neigh: The eigenvalues of H')
call zvout (logfil, n, bounds, ndigit,
& '_neigh: Ritz estimates for the eigenvalues of H')
end if
c
call second(t1)
tceigh = tceigh + (t1 - t0)
c
9000 continue
return
c
c %---------------%
c | End of zneigh |
c %---------------%
c
end

872
arpack/ARPACK/SRC/zneupd.f Normal file
View File

@@ -0,0 +1,872 @@
c\BeginDoc
c
c\Name: zneupd
c
c\Description:
c This subroutine returns the converged approximations to eigenvalues
c of A*z = lambda*B*z and (optionally):
c
c (1) The corresponding approximate eigenvectors;
c
c (2) An orthonormal basis for the associated approximate
c invariant subspace;
c
c (3) Both.
c
c There is negligible additional cost to obtain eigenvectors. An orthonormal
c basis is always computed. There is an additional storage cost of n*nev
c if both are requested (in this case a separate array Z must be supplied).
c
c The approximate eigenvalues and eigenvectors of A*z = lambda*B*z
c are derived from approximate eigenvalues and eigenvectors of
c of the linear operator OP prescribed by the MODE selection in the
c call to ZNAUPD. ZNAUPD must be called before this routine is called.
c These approximate eigenvalues and vectors are commonly called Ritz
c values and Ritz vectors respectively. They are referred to as such
c in the comments that follow. The computed orthonormal basis for the
c invariant subspace corresponding to these Ritz values is referred to as a
c Schur basis.
c
c The definition of OP as well as other terms and the relation of computed
c Ritz values and vectors of OP with respect to the given problem
c A*z = lambda*B*z may be found in the header of ZNAUPD. For a brief
c description, see definitions of IPARAM(7), MODE and WHICH in the
c documentation of ZNAUPD.
c
c\Usage:
c call zneupd
c ( RVEC, HOWMNY, SELECT, D, Z, LDZ, SIGMA, WORKEV, BMAT,
c N, WHICH, NEV, TOL, RESID, NCV, V, LDV, IPARAM, IPNTR, WORKD,
c WORKL, LWORKL, RWORK, INFO )
c
c\Arguments:
c RVEC LOGICAL (INPUT)
c Specifies whether a basis for the invariant subspace corresponding
c to the converged Ritz value approximations for the eigenproblem
c A*z = lambda*B*z is computed.
c
c RVEC = .FALSE. Compute Ritz values only.
c
c RVEC = .TRUE. Compute Ritz vectors or Schur vectors.
c See Remarks below.
c
c HOWMNY Character*1 (INPUT)
c Specifies the form of the basis for the invariant subspace
c corresponding to the converged Ritz values that is to be computed.
c
c = 'A': Compute NEV Ritz vectors;
c = 'P': Compute NEV Schur vectors;
c = 'S': compute some of the Ritz vectors, specified
c by the logical array SELECT.
c
c SELECT Logical array of dimension NCV. (INPUT)
c If HOWMNY = 'S', SELECT specifies the Ritz vectors to be
c computed. To select the Ritz vector corresponding to a
c Ritz value D(j), SELECT(j) must be set to .TRUE..
c If HOWMNY = 'A' or 'P', SELECT need not be initialized
c but it is used as internal workspace.
c
c D Complex*16 array of dimension NEV+1. (OUTPUT)
c On exit, D contains the Ritz approximations
c to the eigenvalues lambda for A*z = lambda*B*z.
c
c Z Complex*16 N by NEV array (OUTPUT)
c On exit, if RVEC = .TRUE. and HOWMNY = 'A', then the columns of
c Z represents approximate eigenvectors (Ritz vectors) corresponding
c to the NCONV=IPARAM(5) Ritz values for eigensystem
c A*z = lambda*B*z.
c
c If RVEC = .FALSE. or HOWMNY = 'P', then Z is NOT REFERENCED.
c
c NOTE: If if RVEC = .TRUE. and a Schur basis is not required,
c the array Z may be set equal to first NEV+1 columns of the Arnoldi
c basis array V computed by ZNAUPD. In this case the Arnoldi basis
c will be destroyed and overwritten with the eigenvector basis.
c
c LDZ Integer. (INPUT)
c The leading dimension of the array Z. If Ritz vectors are
c desired, then LDZ .ge. max( 1, N ) is required.
c In any case, LDZ .ge. 1 is required.
c
c SIGMA Complex*16 (INPUT)
c If IPARAM(7) = 3 then SIGMA represents the shift.
c Not referenced if IPARAM(7) = 1 or 2.
c
c WORKEV Complex*16 work array of dimension 2*NCV. (WORKSPACE)
c
c **** The remaining arguments MUST be the same as for the ****
c **** call to ZNAUPD that was just completed. ****
c
c NOTE: The remaining arguments
c
c BMAT, N, WHICH, NEV, TOL, RESID, NCV, V, LDV, IPARAM, IPNTR,
c WORKD, WORKL, LWORKL, RWORK, INFO
c
c must be passed directly to ZNEUPD following the last call
c to ZNAUPD. These arguments MUST NOT BE MODIFIED between
c the the last call to ZNAUPD and the call to ZNEUPD.
c
c Three of these parameters (V, WORKL and INFO) are also output parameters:
c
c V Complex*16 N by NCV array. (INPUT/OUTPUT)
c
c Upon INPUT: the NCV columns of V contain the Arnoldi basis
c vectors for OP as constructed by ZNAUPD .
c
c Upon OUTPUT: If RVEC = .TRUE. the first NCONV=IPARAM(5) columns
c contain approximate Schur vectors that span the
c desired invariant subspace.
c
c NOTE: If the array Z has been set equal to first NEV+1 columns
c of the array V and RVEC=.TRUE. and HOWMNY= 'A', then the
c Arnoldi basis held by V has been overwritten by the desired
c Ritz vectors. If a separate array Z has been passed then
c the first NCONV=IPARAM(5) columns of V will contain approximate
c Schur vectors that span the desired invariant subspace.
c
c WORKL Double precision work array of length LWORKL. (OUTPUT/WORKSPACE)
c WORKL(1:ncv*ncv+2*ncv) contains information obtained in
c znaupd. They are not changed by zneupd.
c WORKL(ncv*ncv+2*ncv+1:3*ncv*ncv+4*ncv) holds the
c untransformed Ritz values, the untransformed error estimates of
c the Ritz values, the upper triangular matrix for H, and the
c associated matrix representation of the invariant subspace for H.
c
c Note: IPNTR(9:13) contains the pointer into WORKL for addresses
c of the above information computed by zneupd.
c -------------------------------------------------------------
c IPNTR(9): pointer to the NCV RITZ values of the
c original system.
c IPNTR(10): Not used
c IPNTR(11): pointer to the NCV corresponding error estimates.
c IPNTR(12): pointer to the NCV by NCV upper triangular
c Schur matrix for H.
c IPNTR(13): pointer to the NCV by NCV matrix of eigenvectors
c of the upper Hessenberg matrix H. Only referenced by
c zneupd if RVEC = .TRUE. See Remark 2 below.
c -------------------------------------------------------------
c
c INFO Integer. (OUTPUT)
c Error flag on output.
c = 0: Normal exit.
c
c = 1: The Schur form computed by LAPACK routine csheqr
c could not be reordered by LAPACK routine ztrsen.
c Re-enter subroutine zneupd with IPARAM(5)=NCV and
c increase the size of the array D to have
c dimension at least dimension NCV and allocate at least NCV
c columns for Z. NOTE: Not necessary if Z and V share
c the same space. Please notify the authors if this error
c occurs.
c
c = -1: N must be positive.
c = -2: NEV must be positive.
c = -3: NCV-NEV >= 1 and less than or equal to N.
c = -5: WHICH must be one of 'LM', 'SM', 'LR', 'SR', 'LI', 'SI'
c = -6: BMAT must be one of 'I' or 'G'.
c = -7: Length of private work WORKL array is not sufficient.
c = -8: Error return from LAPACK eigenvalue calculation.
c This should never happened.
c = -9: Error return from calculation of eigenvectors.
c Informational error from LAPACK routine ztrevc.
c = -10: IPARAM(7) must be 1,2,3
c = -11: IPARAM(7) = 1 and BMAT = 'G' are incompatible.
c = -12: HOWMNY = 'S' not yet implemented
c = -13: HOWMNY must be one of 'A' or 'P' if RVEC = .true.
c = -14: ZNAUPD did not find any eigenvalues to sufficient
c accuracy.
c = -15: ZNEUPD got a different count of the number of converged
c Ritz values than ZNAUPD got. This indicates the user
c probably made an error in passing data from ZNAUPD to
c ZNEUPD or that the data was modified before entering
c ZNEUPD
c
c\BeginLib
c
c\References:
c 1. D.C. Sorensen, "Implicit Application of Polynomial Filters in
c a k-Step Arnoldi Method", SIAM J. Matr. Anal. Apps., 13 (1992),
c pp 357-385.
c 2. R.B. Lehoucq, "Analysis and Implementation of an Implicitly
c Restarted Arnoldi Iteration", Rice University Technical Report
c TR95-13, Department of Computational and Applied Mathematics.
c 3. B. Nour-Omid, B. N. Parlett, T. Ericsson and P. S. Jensen,
c "How to Implement the Spectral Transformation", Math Comp.,
c Vol. 48, No. 178, April, 1987 pp. 664-673.
c
c\Routines called:
c ivout ARPACK utility routine that prints integers.
c zmout ARPACK utility routine that prints matrices
c zvout ARPACK utility routine that prints vectors.
c zgeqr2 LAPACK routine that computes the QR factorization of
c a matrix.
c zlacpy LAPACK matrix copy routine.
c zlahqr LAPACK routine that computes the Schur form of a
c upper Hessenberg matrix.
c zlaset LAPACK matrix initialization routine.
c ztrevc LAPACK routine to compute the eigenvectors of a matrix
c in upper triangular form.
c ztrsen LAPACK routine that re-orders the Schur form.
c zunm2r LAPACK routine that applies an orthogonal matrix in
c factored form.
c dlamch LAPACK routine that determines machine constants.
c ztrmm Level 3 BLAS matrix times an upper triangular matrix.
c zgeru Level 2 BLAS rank one update to a matrix.
c zcopy Level 1 BLAS that copies one vector to another .
c zscal Level 1 BLAS that scales a vector.
c zdscal Level 1 BLAS that scales a complex vector by a real number.
c dznrm2 Level 1 BLAS that computes the norm of a complex vector.
c
c\Remarks
c
c 1. Currently only HOWMNY = 'A' and 'P' are implemented.
c
c 2. Schur vectors are an orthogonal representation for the basis of
c Ritz vectors. Thus, their numerical properties are often superior.
c If RVEC = .true. then the relationship
c A * V(:,1:IPARAM(5)) = V(:,1:IPARAM(5)) * T, and
c transpose( V(:,1:IPARAM(5)) ) * V(:,1:IPARAM(5)) = I
c are approximately satisfied.
c Here T is the leading submatrix of order IPARAM(5) of the
c upper triangular matrix stored workl(ipntr(12)).
c
c\Authors
c Danny Sorensen Phuong Vu
c Richard Lehoucq CRPC / Rice University
c Chao Yang Houston, Texas
c Dept. of Computational &
c Applied Mathematics
c Rice University
c Houston, Texas
c
c\SCCS Information: @(#)
c FILE: neupd.F SID: 2.8 DATE OF SID: 07/21/02 RELEASE: 2
c
c\EndLib
c
c-----------------------------------------------------------------------
subroutine zneupd(rvec , howmny, select, d ,
& z , ldz , sigma , workev,
& bmat , n , which , nev ,
& tol , resid , ncv , v ,
& ldv , iparam, ipntr , workd ,
& workl, lworkl, rwork , info )
c
c %----------------------------------------------------%
c | Include files for debugging and timing information |
c %----------------------------------------------------%
c
include 'debug.h'
include 'stat.h'
c
c %------------------%
c | Scalar Arguments |
c %------------------%
c
character bmat, howmny, which*2
logical rvec
integer info, ldz, ldv, lworkl, n, ncv, nev
Complex*16
& sigma
Double precision
& tol
c
c %-----------------%
c | Array Arguments |
c %-----------------%
c
integer iparam(11), ipntr(14)
logical select(ncv)
Double precision
& rwork(ncv)
Complex*16
& d(nev) , resid(n) , v(ldv,ncv),
& z(ldz, nev),
& workd(3*n) , workl(lworkl), workev(2*ncv)
c
c %------------%
c | Parameters |
c %------------%
c
Complex*16
& one, zero
parameter (one = (1.0D+0, 0.0D+0), zero = (0.0D+0, 0.0D+0))
c
c %---------------%
c | Local Scalars |
c %---------------%
c
character type*6
integer bounds, ierr , ih , ihbds, iheig , nconv ,
& invsub, iuptri, iwev , j , ldh , ldq ,
& mode , msglvl, ritz , wr , k , irz ,
& ibd , outncv, iq , np , numcnv, jj ,
& ishift
Complex*16
& rnorm, temp, vl(1)
Double precision
& conds, sep, rtemp, eps23
logical reord
c
c %----------------------%
c | External Subroutines |
c %----------------------%
c
external zcopy , zgeru, zgeqr2, zlacpy, zmout,
& zunm2r, ztrmm, zvout, ivout,
& zlahqr
c
c %--------------------%
c | External Functions |
c %--------------------%
c
Double precision
& dznrm2, dlamch, dlapy2
external dznrm2, dlamch, dlapy2
c
Complex*16
& zdotc
external zdotc
c
c %-----------------------%
c | Executable Statements |
c %-----------------------%
c
c %------------------------%
c | Set default parameters |
c %------------------------%
c
msglvl = mceupd
mode = iparam(7)
nconv = iparam(5)
info = 0
c
c
c %---------------------------------%
c | Get machine dependent constant. |
c %---------------------------------%
c
eps23 = dlamch('Epsilon-Machine')
eps23 = eps23**(2.0D+0 / 3.0D+0)
c
c %-------------------------------%
c | Quick return |
c | Check for incompatible input |
c %-------------------------------%
c
ierr = 0
c
if (nconv .le. 0) then
ierr = -14
else if (n .le. 0) then
ierr = -1
else if (nev .le. 0) then
ierr = -2
else if (ncv .le. nev .or. ncv .gt. n) then
ierr = -3
else if (which .ne. 'LM' .and.
& which .ne. 'SM' .and.
& which .ne. 'LR' .and.
& which .ne. 'SR' .and.
& which .ne. 'LI' .and.
& which .ne. 'SI') then
ierr = -5
else if (bmat .ne. 'I' .and. bmat .ne. 'G') then
ierr = -6
else if (lworkl .lt. 3*ncv**2 + 4*ncv) then
ierr = -7
else if ( (howmny .ne. 'A' .and.
& howmny .ne. 'P' .and.
& howmny .ne. 'S') .and. rvec ) then
ierr = -13
else if (howmny .eq. 'S' ) then
ierr = -12
end if
c
if (mode .eq. 1 .or. mode .eq. 2) then
type = 'REGULR'
else if (mode .eq. 3 ) then
type = 'SHIFTI'
else
ierr = -10
end if
if (mode .eq. 1 .and. bmat .eq. 'G') ierr = -11
c
c %------------%
c | Error Exit |
c %------------%
c
if (ierr .ne. 0) then
info = ierr
go to 9000
end if
c
c %--------------------------------------------------------%
c | Pointer into WORKL for address of H, RITZ, WORKEV, Q |
c | etc... and the remaining workspace. |
c | Also update pointer to be used on output. |
c | Memory is laid out as follows: |
c | workl(1:ncv*ncv) := generated Hessenberg matrix |
c | workl(ncv*ncv+1:ncv*ncv+ncv) := ritz values |
c | workl(ncv*ncv+ncv+1:ncv*ncv+2*ncv) := error bounds |
c %--------------------------------------------------------%
c
c %-----------------------------------------------------------%
c | The following is used and set by ZNEUPD. |
c | workl(ncv*ncv+2*ncv+1:ncv*ncv+3*ncv) := The untransformed |
c | Ritz values. |
c | workl(ncv*ncv+3*ncv+1:ncv*ncv+4*ncv) := The untransformed |
c | error bounds of |
c | the Ritz values |
c | workl(ncv*ncv+4*ncv+1:2*ncv*ncv+4*ncv) := Holds the upper |
c | triangular matrix |
c | for H. |
c | workl(2*ncv*ncv+4*ncv+1: 3*ncv*ncv+4*ncv) := Holds the |
c | associated matrix |
c | representation of |
c | the invariant |
c | subspace for H. |
c | GRAND total of NCV * ( 3 * NCV + 4 ) locations. |
c %-----------------------------------------------------------%
c
ih = ipntr(5)
ritz = ipntr(6)
iq = ipntr(7)
bounds = ipntr(8)
ldh = ncv
ldq = ncv
iheig = bounds + ldh
ihbds = iheig + ldh
iuptri = ihbds + ldh
invsub = iuptri + ldh*ncv
ipntr(9) = iheig
ipntr(11) = ihbds
ipntr(12) = iuptri
ipntr(13) = invsub
wr = 1
iwev = wr + ncv
c
c %-----------------------------------------%
c | irz points to the Ritz values computed |
c | by _neigh before exiting _naup2. |
c | ibd points to the Ritz estimates |
c | computed by _neigh before exiting |
c | _naup2. |
c %-----------------------------------------%
c
irz = ipntr(14) + ncv*ncv
ibd = irz + ncv
c
c %------------------------------------%
c | RNORM is B-norm of the RESID(1:N). |
c %------------------------------------%
c
rnorm = workl(ih+2)
workl(ih+2) = zero
c
if (msglvl .gt. 2) then
call zvout(logfil, ncv, workl(irz), ndigit,
& '_neupd: Ritz values passed in from _NAUPD.')
call zvout(logfil, ncv, workl(ibd), ndigit,
& '_neupd: Ritz estimates passed in from _NAUPD.')
end if
c
if (rvec) then
c
reord = .false.
c
c %---------------------------------------------------%
c | Use the temporary bounds array to store indices |
c | These will be used to mark the select array later |
c %---------------------------------------------------%
c
do 10 j = 1,ncv
workl(bounds+j-1) = j
select(j) = .false.
10 continue
c
c %-------------------------------------%
c | Select the wanted Ritz values. |
c | Sort the Ritz values so that the |
c | wanted ones appear at the tailing |
c | NEV positions of workl(irr) and |
c | workl(iri). Move the corresponding |
c | error estimates in workl(ibd) |
c | accordingly. |
c %-------------------------------------%
c
np = ncv - nev
ishift = 0
call zngets(ishift, which , nev ,
& np , workl(irz), workl(bounds))
c
if (msglvl .gt. 2) then
call zvout (logfil, ncv, workl(irz), ndigit,
& '_neupd: Ritz values after calling _NGETS.')
call zvout (logfil, ncv, workl(bounds), ndigit,
& '_neupd: Ritz value indices after calling _NGETS.')
end if
c
c %-----------------------------------------------------%
c | Record indices of the converged wanted Ritz values |
c | Mark the select array for possible reordering |
c %-----------------------------------------------------%
c
numcnv = 0
do 11 j = 1,ncv
rtemp = max(eps23,
& dlapy2 ( dble(workl(irz+ncv-j)),
& dimag(workl(irz+ncv-j)) ))
jj = workl(bounds + ncv - j)
if (numcnv .lt. nconv .and.
& dlapy2( dble(workl(ibd+jj-1)),
& dimag(workl(ibd+jj-1)) )
& .le. tol*rtemp) then
select(jj) = .true.
numcnv = numcnv + 1
if (jj .gt. nev) reord = .true.
endif
11 continue
c
c %-----------------------------------------------------------%
c | Check the count (numcnv) of converged Ritz values with |
c | the number (nconv) reported by dnaupd. If these two |
c | are different then there has probably been an error |
c | caused by incorrect passing of the dnaupd data. |
c %-----------------------------------------------------------%
c
if (msglvl .gt. 2) then
call ivout(logfil, 1, numcnv, ndigit,
& '_neupd: Number of specified eigenvalues')
call ivout(logfil, 1, nconv, ndigit,
& '_neupd: Number of "converged" eigenvalues')
end if
c
if (numcnv .ne. nconv) then
info = -15
go to 9000
end if
c
c %-------------------------------------------------------%
c | Call LAPACK routine zlahqr to compute the Schur form |
c | of the upper Hessenberg matrix returned by ZNAUPD. |
c | Make a copy of the upper Hessenberg matrix. |
c | Initialize the Schur vector matrix Q to the identity. |
c %-------------------------------------------------------%
c
call zcopy(ldh*ncv, workl(ih), 1, workl(iuptri), 1)
call zlaset('All', ncv, ncv ,
& zero , one, workl(invsub),
& ldq)
call zlahqr(.true., .true. , ncv ,
& 1 , ncv , workl(iuptri),
& ldh , workl(iheig) , 1 ,
& ncv , workl(invsub), ldq ,
& ierr)
call zcopy(ncv , workl(invsub+ncv-1), ldq,
& workl(ihbds), 1)
c
if (ierr .ne. 0) then
info = -8
go to 9000
end if
c
if (msglvl .gt. 1) then
call zvout (logfil, ncv, workl(iheig), ndigit,
& '_neupd: Eigenvalues of H')
call zvout (logfil, ncv, workl(ihbds), ndigit,
& '_neupd: Last row of the Schur vector matrix')
if (msglvl .gt. 3) then
call zmout (logfil , ncv, ncv ,
& workl(iuptri), ldh, ndigit,
& '_neupd: The upper triangular matrix ')
end if
end if
c
if (reord) then
c
c %-----------------------------------------------%
c | Reorder the computed upper triangular matrix. |
c %-----------------------------------------------%
c
call ztrsen('None' , 'V' , select ,
& ncv , workl(iuptri), ldh ,
& workl(invsub), ldq , workl(iheig),
& nconv , conds , sep ,
& workev , ncv , ierr)
c
if (ierr .eq. 1) then
info = 1
go to 9000
end if
c
if (msglvl .gt. 2) then
call zvout (logfil, ncv, workl(iheig), ndigit,
& '_neupd: Eigenvalues of H--reordered')
if (msglvl .gt. 3) then
call zmout(logfil , ncv, ncv ,
& workl(iuptri), ldq, ndigit,
& '_neupd: Triangular matrix after re-ordering')
end if
end if
c
end if
c
c %---------------------------------------------%
c | Copy the last row of the Schur basis matrix |
c | to workl(ihbds). This vector will be used |
c | to compute the Ritz estimates of converged |
c | Ritz values. |
c %---------------------------------------------%
c
call zcopy(ncv , workl(invsub+ncv-1), ldq,
& workl(ihbds), 1)
c
c %--------------------------------------------%
c | Place the computed eigenvalues of H into D |
c | if a spectral transformation was not used. |
c %--------------------------------------------%
c
if (type .eq. 'REGULR') then
call zcopy(nconv, workl(iheig), 1, d, 1)
end if
c
c %----------------------------------------------------------%
c | Compute the QR factorization of the matrix representing |
c | the wanted invariant subspace located in the first NCONV |
c | columns of workl(invsub,ldq). |
c %----------------------------------------------------------%
c
call zgeqr2(ncv , nconv , workl(invsub),
& ldq , workev, workev(ncv+1),
& ierr)
c
c %--------------------------------------------------------%
c | * Postmultiply V by Q using zunm2r. |
c | * Copy the first NCONV columns of VQ into Z. |
c | * Postmultiply Z by R. |
c | The N by NCONV matrix Z is now a matrix representation |
c | of the approximate invariant subspace associated with |
c | the Ritz values in workl(iheig). The first NCONV |
c | columns of V are now approximate Schur vectors |
c | associated with the upper triangular matrix of order |
c | NCONV in workl(iuptri). |
c %--------------------------------------------------------%
c
call zunm2r('Right', 'Notranspose', n ,
& ncv , nconv , workl(invsub),
& ldq , workev , v ,
& ldv , workd(n+1) , ierr)
call zlacpy('All', n, nconv, v, ldv, z, ldz)
c
do 20 j=1, nconv
c
c %---------------------------------------------------%
c | Perform both a column and row scaling if the |
c | diagonal element of workl(invsub,ldq) is negative |
c | I'm lazy and don't take advantage of the upper |
c | triangular form of workl(iuptri,ldq). |
c | Note that since Q is orthogonal, R is a diagonal |
c | matrix consisting of plus or minus ones. |
c %---------------------------------------------------%
c
if ( dble( workl(invsub+(j-1)*ldq+j-1) ) .lt.
& dble(zero) ) then
call zscal(nconv, -one, workl(iuptri+j-1), ldq)
call zscal(nconv, -one, workl(iuptri+(j-1)*ldq), 1)
end if
c
20 continue
c
if (howmny .eq. 'A') then
c
c %--------------------------------------------%
c | Compute the NCONV wanted eigenvectors of T |
c | located in workl(iuptri,ldq). |
c %--------------------------------------------%
c
do 30 j=1, ncv
if (j .le. nconv) then
select(j) = .true.
else
select(j) = .false.
end if
30 continue
c
call ztrevc('Right', 'Select' , select ,
& ncv , workl(iuptri), ldq ,
& vl , 1 , workl(invsub),
& ldq , ncv , outncv ,
& workev , rwork , ierr)
c
if (ierr .ne. 0) then
info = -9
go to 9000
end if
c
c %------------------------------------------------%
c | Scale the returning eigenvectors so that their |
c | Euclidean norms are all one. LAPACK subroutine |
c | ztrevc returns each eigenvector normalized so |
c | that the element of largest magnitude has |
c | magnitude 1. |
c %------------------------------------------------%
c
do 40 j=1, nconv
rtemp = dznrm2(ncv, workl(invsub+(j-1)*ldq), 1)
rtemp = dble(one) / rtemp
call zdscal ( ncv, rtemp,
& workl(invsub+(j-1)*ldq), 1 )
c
c %------------------------------------------%
c | Ritz estimates can be obtained by taking |
c | the inner product of the last row of the |
c | Schur basis of H with eigenvectors of T. |
c | Note that the eigenvector matrix of T is |
c | upper triangular, thus the length of the |
c | inner product can be set to j. |
c %------------------------------------------%
c
workev(j) = zdotc(j, workl(ihbds), 1,
& workl(invsub+(j-1)*ldq), 1)
40 continue
c
if (msglvl .gt. 2) then
call zcopy(nconv, workl(invsub+ncv-1), ldq,
& workl(ihbds), 1)
call zvout (logfil, nconv, workl(ihbds), ndigit,
& '_neupd: Last row of the eigenvector matrix for T')
if (msglvl .gt. 3) then
call zmout(logfil , ncv, ncv ,
& workl(invsub), ldq, ndigit,
& '_neupd: The eigenvector matrix for T')
end if
end if
c
c %---------------------------------------%
c | Copy Ritz estimates into workl(ihbds) |
c %---------------------------------------%
c
call zcopy(nconv, workev, 1, workl(ihbds), 1)
c
c %----------------------------------------------%
c | The eigenvector matrix Q of T is triangular. |
c | Form Z*Q. |
c %----------------------------------------------%
c
call ztrmm('Right' , 'Upper' , 'No transpose',
& 'Non-unit', n , nconv ,
& one , workl(invsub), ldq ,
& z , ldz)
end if
c
else
c
c %--------------------------------------------------%
c | An approximate invariant subspace is not needed. |
c | Place the Ritz values computed ZNAUPD into D. |
c %--------------------------------------------------%
c
call zcopy(nconv, workl(ritz), 1, d, 1)
call zcopy(nconv, workl(ritz), 1, workl(iheig), 1)
call zcopy(nconv, workl(bounds), 1, workl(ihbds), 1)
c
end if
c
c %------------------------------------------------%
c | Transform the Ritz values and possibly vectors |
c | and corresponding error bounds of OP to those |
c | of A*x = lambda*B*x. |
c %------------------------------------------------%
c
if (type .eq. 'REGULR') then
c
if (rvec)
& call zscal(ncv, rnorm, workl(ihbds), 1)
c
else
c
c %---------------------------------------%
c | A spectral transformation was used. |
c | * Determine the Ritz estimates of the |
c | Ritz values in the original system. |
c %---------------------------------------%
c
if (rvec)
& call zscal(ncv, rnorm, workl(ihbds), 1)
c
do 50 k=1, ncv
temp = workl(iheig+k-1)
workl(ihbds+k-1) = workl(ihbds+k-1) / temp / temp
50 continue
c
end if
c
c %-----------------------------------------------------------%
c | * Transform the Ritz values back to the original system. |
c | For TYPE = 'SHIFTI' the transformation is |
c | lambda = 1/theta + sigma |
c | NOTES: |
c | *The Ritz vectors are not affected by the transformation. |
c %-----------------------------------------------------------%
c
if (type .eq. 'SHIFTI') then
do 60 k=1, nconv
d(k) = one / workl(iheig+k-1) + sigma
60 continue
end if
c
if (type .ne. 'REGULR' .and. msglvl .gt. 1) then
call zvout (logfil, nconv, d, ndigit,
& '_neupd: Untransformed Ritz values.')
call zvout (logfil, nconv, workl(ihbds), ndigit,
& '_neupd: Ritz estimates of the untransformed Ritz values.')
else if ( msglvl .gt. 1) then
call zvout (logfil, nconv, d, ndigit,
& '_neupd: Converged Ritz values.')
call zvout (logfil, nconv, workl(ihbds), ndigit,
& '_neupd: Associated Ritz estimates.')
end if
c
c %-------------------------------------------------%
c | Eigenvector Purification step. Formally perform |
c | one of inverse subspace iteration. Only used |
c | for MODE = 3. See reference 3. |
c %-------------------------------------------------%
c
if (rvec .and. howmny .eq. 'A' .and. type .eq. 'SHIFTI') then
c
c %------------------------------------------------%
c | Purify the computed Ritz vectors by adding a |
c | little bit of the residual vector: |
c | T |
c | resid(:)*( e s ) / theta |
c | NCV |
c | where H s = s theta. |
c %------------------------------------------------%
c
do 100 j=1, nconv
if (workl(iheig+j-1) .ne. zero) then
workev(j) = workl(invsub+(j-1)*ldq+ncv-1) /
& workl(iheig+j-1)
endif
100 continue
c %---------------------------------------%
c | Perform a rank one update to Z and |
c | purify all the Ritz vectors together. |
c %---------------------------------------%
c
call zgeru (n, nconv, one, resid, 1, workev, 1, z, ldz)
c
end if
c
9000 continue
c
return
c
c %---------------%
c | End of zneupd|
c %---------------%
c
end

178
arpack/ARPACK/SRC/zngets.f Normal file
View File

@@ -0,0 +1,178 @@
c\BeginDoc
c
c\Name: zngets
c
c\Description:
c Given the eigenvalues of the upper Hessenberg matrix H,
c computes the NP shifts AMU that are zeros of the polynomial of
c degree NP which filters out components of the unwanted eigenvectors
c corresponding to the AMU's based on some given criteria.
c
c NOTE: call this even in the case of user specified shifts in order
c to sort the eigenvalues, and error bounds of H for later use.
c
c\Usage:
c call zngets
c ( ISHIFT, WHICH, KEV, NP, RITZ, BOUNDS )
c
c\Arguments
c ISHIFT Integer. (INPUT)
c Method for selecting the implicit shifts at each iteration.
c ISHIFT = 0: user specified shifts
c ISHIFT = 1: exact shift with respect to the matrix H.
c
c WHICH Character*2. (INPUT)
c Shift selection criteria.
c 'LM' -> want the KEV eigenvalues of largest magnitude.
c 'SM' -> want the KEV eigenvalues of smallest magnitude.
c 'LR' -> want the KEV eigenvalues of largest REAL part.
c 'SR' -> want the KEV eigenvalues of smallest REAL part.
c 'LI' -> want the KEV eigenvalues of largest imaginary part.
c 'SI' -> want the KEV eigenvalues of smallest imaginary part.
c
c KEV Integer. (INPUT)
c The number of desired eigenvalues.
c
c NP Integer. (INPUT)
c The number of shifts to compute.
c
c RITZ Complex*16 array of length KEV+NP. (INPUT/OUTPUT)
c On INPUT, RITZ contains the the eigenvalues of H.
c On OUTPUT, RITZ are sorted so that the unwanted
c eigenvalues are in the first NP locations and the wanted
c portion is in the last KEV locations. When exact shifts are
c selected, the unwanted part corresponds to the shifts to
c be applied. Also, if ISHIFT .eq. 1, the unwanted eigenvalues
c are further sorted so that the ones with largest Ritz values
c are first.
c
c BOUNDS Complex*16 array of length KEV+NP. (INPUT/OUTPUT)
c Error bounds corresponding to the ordering in RITZ.
c
c
c
c\EndDoc
c
c-----------------------------------------------------------------------
c
c\BeginLib
c
c\Local variables:
c xxxxxx Complex*16
c
c\Routines called:
c zsortc ARPACK sorting routine.
c ivout ARPACK utility routine that prints integers.
c second ARPACK utility routine for timing.
c zvout ARPACK utility routine that prints vectors.
c
c\Author
c Danny Sorensen Phuong Vu
c Richard Lehoucq CRPC / Rice University
c Dept. of Computational & Houston, Texas
c Applied Mathematics
c Rice University
c Houston, Texas
c
c\SCCS Information: @(#)
c FILE: ngets.F SID: 2.2 DATE OF SID: 4/20/96 RELEASE: 2
c
c\Remarks
c 1. This routine does not keep complex conjugate pairs of
c eigenvalues together.
c
c\EndLib
c
c-----------------------------------------------------------------------
c
subroutine zngets ( ishift, which, kev, np, ritz, bounds)
c
c %----------------------------------------------------%
c | Include files for debugging and timing information |
c %----------------------------------------------------%
c
include 'debug.h'
include 'stat.h'
c
c %------------------%
c | Scalar Arguments |
c %------------------%
c
character*2 which
integer ishift, kev, np
c
c %-----------------%
c | Array Arguments |
c %-----------------%
c
Complex*16
& bounds(kev+np), ritz(kev+np)
c
c %------------%
c | Parameters |
c %------------%
c
Complex*16
& one, zero
parameter (one = (1.0D+0, 0.0D+0), zero = (0.0D+0, 0.0D+0))
c
c %---------------%
c | Local Scalars |
c %---------------%
c
integer msglvl
c
c %----------------------%
c | External Subroutines |
c %----------------------%
c
external zvout, zsortc, second
c
c %-----------------------%
c | Executable Statements |
c %-----------------------%
c
c %-------------------------------%
c | Initialize timing statistics |
c | & message level for debugging |
c %-------------------------------%
c
call second (t0)
msglvl = mcgets
c
call zsortc (which, .true., kev+np, ritz, bounds)
c
if ( ishift .eq. 1 ) then
c
c %-------------------------------------------------------%
c | Sort the unwanted Ritz values used as shifts so that |
c | the ones with largest Ritz estimates are first |
c | This will tend to minimize the effects of the |
c | forward instability of the iteration when the shifts |
c | are applied in subroutine znapps. |
c | Be careful and use 'SM' since we want to sort BOUNDS! |
c %-------------------------------------------------------%
c
call zsortc ( 'SM', .true., np, bounds, ritz )
c
end if
c
call second (t1)
tcgets = tcgets + (t1 - t0)
c
if (msglvl .gt. 0) then
call ivout (logfil, 1, kev, ndigit, '_ngets: KEV is')
call ivout (logfil, 1, np, ndigit, '_ngets: NP is')
call zvout (logfil, kev+np, ritz, ndigit,
& '_ngets: Eigenvalues of current H matrix ')
call zvout (logfil, kev+np, bounds, ndigit,
& '_ngets: Ritz estimates of the current KEV+NP Ritz values')
end if
c
return
c
c %---------------%
c | End of zngets |
c %---------------%
c
end

322
arpack/ARPACK/SRC/zsortc.f Normal file
View File

@@ -0,0 +1,322 @@
c\BeginDoc
c
c\Name: zsortc
c
c\Description:
c Sorts the Complex*16 array in X into the order
c specified by WHICH and optionally applies the permutation to the
c Double precision array Y.
c
c\Usage:
c call zsortc
c ( WHICH, APPLY, N, X, Y )
c
c\Arguments
c WHICH Character*2. (Input)
c 'LM' -> sort X into increasing order of magnitude.
c 'SM' -> sort X into decreasing order of magnitude.
c 'LR' -> sort X with real(X) in increasing algebraic order
c 'SR' -> sort X with real(X) in decreasing algebraic order
c 'LI' -> sort X with imag(X) in increasing algebraic order
c 'SI' -> sort X with imag(X) in decreasing algebraic order
c
c APPLY Logical. (Input)
c APPLY = .TRUE. -> apply the sorted order to array Y.
c APPLY = .FALSE. -> do not apply the sorted order to array Y.
c
c N Integer. (INPUT)
c Size of the arrays.
c
c X Complex*16 array of length N. (INPUT/OUTPUT)
c This is the array to be sorted.
c
c Y Complex*16 array of length N. (INPUT/OUTPUT)
c
c\EndDoc
c
c-----------------------------------------------------------------------
c
c\BeginLib
c
c\Routines called:
c dlapy2 LAPACK routine to compute sqrt(x**2+y**2) carefully.
c
c\Author
c Danny Sorensen Phuong Vu
c Richard Lehoucq CRPC / Rice University
c Dept. of Computational & Houston, Texas
c Applied Mathematics
c Rice University
c Houston, Texas
c
c Adapted from the sort routine in LANSO.
c
c\SCCS Information: @(#)
c FILE: sortc.F SID: 2.2 DATE OF SID: 4/20/96 RELEASE: 2
c
c\EndLib
c
c-----------------------------------------------------------------------
c
subroutine zsortc (which, apply, n, x, y)
c
c %------------------%
c | Scalar Arguments |
c %------------------%
c
character*2 which
logical apply
integer n
c
c %-----------------%
c | Array Arguments |
c %-----------------%
c
Complex*16
& x(0:n-1), y(0:n-1)
c
c %---------------%
c | Local Scalars |
c %---------------%
c
integer i, igap, j
Complex*16
& temp
Double precision
& temp1, temp2
c
c %--------------------%
c | External functions |
c %--------------------%
c
Double precision
& dlapy2
c
c %--------------------%
c | Intrinsic Functions |
c %--------------------%
Intrinsic
& dble, dimag
c
c %-----------------------%
c | Executable Statements |
c %-----------------------%
c
igap = n / 2
c
if (which .eq. 'LM') then
c
c %--------------------------------------------%
c | Sort X into increasing order of magnitude. |
c %--------------------------------------------%
c
10 continue
if (igap .eq. 0) go to 9000
c
do 30 i = igap, n-1
j = i-igap
20 continue
c
if (j.lt.0) go to 30
c
temp1 = dlapy2(dble(x(j)),dimag(x(j)))
temp2 = dlapy2(dble(x(j+igap)),dimag(x(j+igap)))
c
if (temp1.gt.temp2) then
temp = x(j)
x(j) = x(j+igap)
x(j+igap) = temp
c
if (apply) then
temp = y(j)
y(j) = y(j+igap)
y(j+igap) = temp
end if
else
go to 30
end if
j = j-igap
go to 20
30 continue
igap = igap / 2
go to 10
c
else if (which .eq. 'SM') then
c
c %--------------------------------------------%
c | Sort X into decreasing order of magnitude. |
c %--------------------------------------------%
c
40 continue
if (igap .eq. 0) go to 9000
c
do 60 i = igap, n-1
j = i-igap
50 continue
c
if (j .lt. 0) go to 60
c
temp1 = dlapy2(dble(x(j)),dimag(x(j)))
temp2 = dlapy2(dble(x(j+igap)),dimag(x(j+igap)))
c
if (temp1.lt.temp2) then
temp = x(j)
x(j) = x(j+igap)
x(j+igap) = temp
c
if (apply) then
temp = y(j)
y(j) = y(j+igap)
y(j+igap) = temp
end if
else
go to 60
endif
j = j-igap
go to 50
60 continue
igap = igap / 2
go to 40
c
else if (which .eq. 'LR') then
c
c %------------------------------------------------%
c | Sort XREAL into increasing order of algebraic. |
c %------------------------------------------------%
c
70 continue
if (igap .eq. 0) go to 9000
c
do 90 i = igap, n-1
j = i-igap
80 continue
c
if (j.lt.0) go to 90
c
if (dble(x(j)).gt.dble(x(j+igap))) then
temp = x(j)
x(j) = x(j+igap)
x(j+igap) = temp
c
if (apply) then
temp = y(j)
y(j) = y(j+igap)
y(j+igap) = temp
end if
else
go to 90
endif
j = j-igap
go to 80
90 continue
igap = igap / 2
go to 70
c
else if (which .eq. 'SR') then
c
c %------------------------------------------------%
c | Sort XREAL into decreasing order of algebraic. |
c %------------------------------------------------%
c
100 continue
if (igap .eq. 0) go to 9000
do 120 i = igap, n-1
j = i-igap
110 continue
c
if (j.lt.0) go to 120
c
if (dble(x(j)).lt.dble(x(j+igap))) then
temp = x(j)
x(j) = x(j+igap)
x(j+igap) = temp
c
if (apply) then
temp = y(j)
y(j) = y(j+igap)
y(j+igap) = temp
end if
else
go to 120
endif
j = j-igap
go to 110
120 continue
igap = igap / 2
go to 100
c
else if (which .eq. 'LI') then
c
c %--------------------------------------------%
c | Sort XIMAG into increasing algebraic order |
c %--------------------------------------------%
c
130 continue
if (igap .eq. 0) go to 9000
do 150 i = igap, n-1
j = i-igap
140 continue
c
if (j.lt.0) go to 150
c
if (dimag(x(j)).gt.dimag(x(j+igap))) then
temp = x(j)
x(j) = x(j+igap)
x(j+igap) = temp
c
if (apply) then
temp = y(j)
y(j) = y(j+igap)
y(j+igap) = temp
end if
else
go to 150
endif
j = j-igap
go to 140
150 continue
igap = igap / 2
go to 130
c
else if (which .eq. 'SI') then
c
c %---------------------------------------------%
c | Sort XIMAG into decreasing algebraic order |
c %---------------------------------------------%
c
160 continue
if (igap .eq. 0) go to 9000
do 180 i = igap, n-1
j = i-igap
170 continue
c
if (j.lt.0) go to 180
c
if (dimag(x(j)).lt.dimag(x(j+igap))) then
temp = x(j)
x(j) = x(j+igap)
x(j+igap) = temp
c
if (apply) then
temp = y(j)
y(j) = y(j+igap)
y(j+igap) = temp
end if
else
go to 180
endif
j = j-igap
go to 170
180 continue
igap = igap / 2
go to 160
end if
c
9000 continue
return
c
c %---------------%
c | End of zsortc |
c %---------------%
c
end

51
arpack/ARPACK/SRC/zstatn.f Normal file
View File

@@ -0,0 +1,51 @@
c
c\SCCS Information: @(#)
c FILE: statn.F SID: 2.2 DATE OF SID: 4/20/96 RELEASE: 2
c
c %---------------------------------------------%
c | Initialize statistic and timing information |
c | for complex nonsymmetric Arnoldi code. |
c %---------------------------------------------%
subroutine zstatn
c
c %--------------------------------%
c | See stat.doc for documentation |
c %--------------------------------%
c
include 'stat.h'
c %-----------------------%
c | Executable Statements |
c %-----------------------%
nopx = 0
nbx = 0
nrorth = 0
nitref = 0
nrstrt = 0
tcaupd = 0.0D+0
tcaup2 = 0.0D+0
tcaitr = 0.0D+0
tceigh = 0.0D+0
tcgets = 0.0D+0
tcapps = 0.0D+0
tcconv = 0.0D+0
titref = 0.0D+0
tgetv0 = 0.0D+0
trvec = 0.0D+0
c %----------------------------------------------------%
c | User time including reverse communication overhead |
c %----------------------------------------------------%
tmvopx = 0.0D+0
tmvbx = 0.0D+0
return
c
c %---------------%
c | End of zstatn |
c %---------------%
c
end

82
arpack/ARPACK/UTIL/Makefile Normal file
View File

@@ -0,0 +1,82 @@
############################################################################
#
# Program: ARPACK
#
# Module: Makefile
#
# Purpose: Sources Makefile
#
# Creation date: February 22, 1996
#
# Modified: September 6, 1996
#
# Send bug reports, comments or suggestions to arpack.caam.rice.edu
#
############################################################################
#\SCCS Information: @(#)
# FILE: Makefile SID: 2.1 DATE OF SID: 9/9/96 RELEASE: 2
include ../ARmake.inc
############################################################################
# To create or add to the library, enter make followed by one or
# more of the precisions desired. Some examples:
# make single
# make single complex
# make single double complex complex16
# Alternatively, the command
# make
# without any arguments creates a library of all four precisions.
# The name of the library is defined by $(ARPACKLIB) in
# ../ARmake.inc and is created at the next higher directory level.
#
OBJS = icnteq.o icopy.o iset.o iswap.o ivout.o second.o
SOBJ = svout.o smout.o
DOBJ = dvout.o dmout.o
COBJ = cvout.o cmout.o
ZOBJ = zvout.o zmout.o
.SUFFIXES: .o .F .f
.f.o:
$(FC) $(FFLAGS) -c $<
#
# make the library containing both single and double precision
#
all: single double complex complex16
single: $(SOBJ) $(OBJS)
$(AR) $(ARFLAGS) $(ARPACKLIB) $(SOBJ) $(OBJS)
$(RANLIB) $(ARPACKLIB)
double: $(DOBJ) $(OBJS) $(ZOBJ)
$(AR) $(ARFLAGS) $(ARPACKLIB) $(DOBJ) $(OBJS)
$(RANLIB) $(ARPACKLIB)
complex: $(SOBJ) $(OBJS) $(COBJ)
$(AR) $(ARFLAGS) $(ARPACKLIB) $(SOBJ) $(COBJ) $(OBJS)
$(RANLIB) $(ARPACKLIB)
complex16: $(DOBJ) $(OBJS) $(ZOBJ)
$(AR) $(ARFLAGS) $(ARPACKLIB) $(DOBJ) $(ZOBJ) $(OBJS)
$(RANLIB) $(ARPACKLIB)
#
sdrv:
ddrv:
cdrv:
zdrv:
#
# clean - remove all object files
#
clean:
rm -f *.o a.out core

250
arpack/ARPACK/UTIL/cmout.f Normal file
View File

@@ -0,0 +1,250 @@
*
* Routine: CMOUT
*
* Purpose: Complex matrix output routine.
*
* Usage: CALL CMOUT (LOUT, M, N, A, LDA, IDIGIT, IFMT)
*
* Arguments
* M - Number of rows of A. (Input)
* N - Number of columns of A. (Input)
* A - Complex M by N matrix to be printed. (Input)
* LDA - Leading dimension of A exactly as specified in the
* dimension statement of the calling program. (Input)
* IFMT - Format to be used in printing matrix A. (Input)
* IDIGIT - Print up to IABS(IDIGIT) decimal digits per number. (In)
* If IDIGIT .LT. 0, printing is done with 72 columns.
* If IDIGIT .GT. 0, printing is done with 132 columns.
*
*\SCCS Information: @(#)
* FILE: cmout.f SID: 2.1 DATE OF SID: 11/16/95 RELEASE: 2
*
*-----------------------------------------------------------------------
*
SUBROUTINE CMOUT( LOUT, M, N, A, LDA, IDIGIT, IFMT )
* ...
* ... SPECIFICATIONS FOR ARGUMENTS
INTEGER M, N, IDIGIT, LDA, LOUT
Complex
& A( LDA, * )
CHARACTER IFMT*( * )
* ...
* ... SPECIFICATIONS FOR LOCAL VARIABLES
INTEGER I, J, NDIGIT, K1, K2, LLL
CHARACTER*1 ICOL( 3 )
CHARACTER*80 LINE
* ...
* ... SPECIFICATIONS INTRINSICS
INTRINSIC MIN
*
DATA ICOL( 1 ), ICOL( 2 ), ICOL( 3 ) / 'C', 'o',
$ 'l' /
* ...
* ... FIRST EXECUTABLE STATEMENT
*
LLL = MIN( LEN( IFMT ), 80 )
DO 10 I = 1, LLL
LINE( I: I ) = '-'
10 CONTINUE
*
DO 20 I = LLL + 1, 80
LINE( I: I ) = ' '
20 CONTINUE
*
WRITE( LOUT, 9999 )IFMT, LINE( 1: LLL )
9999 FORMAT( / 1X, A / 1X, A )
*
IF( M.LE.0 .OR. N.LE.0 .OR. LDA.LE.0 )
$ RETURN
NDIGIT = IDIGIT
IF( IDIGIT.EQ.0 )
$ NDIGIT = 4
*
*=======================================================================
* CODE FOR OUTPUT USING 72 COLUMNS FORMAT
*=======================================================================
*
IF( IDIGIT.LT.0 ) THEN
NDIGIT = -IDIGIT
IF( NDIGIT.LE.4 ) THEN
DO 40 K1 = 1, N, 2
K2 = MIN0( N, K1+1 )
WRITE( LOUT, 9998 )( ICOL, I, I = K1, K2 )
DO 30 I = 1, M
IF (K1.NE.N) THEN
WRITE( LOUT, 9994 )I, ( A( I, J ), J = K1, K2 )
ELSE
WRITE( LOUT, 9984 )I, ( A( I, J ), J = K1, K2 )
END IF
30 CONTINUE
40 CONTINUE
*
ELSE IF( NDIGIT.LE.6 ) THEN
DO 60 K1 = 1, N, 2
K2 = MIN0( N, K1+1 )
WRITE( LOUT, 9997 )( ICOL, I, I = K1, K2 )
DO 50 I = 1, M
IF (K1.NE.N) THEN
WRITE( LOUT, 9993 )I, ( A( I, J ), J = K1, K2 )
ELSE
WRITE( LOUT, 9983 )I, ( A( I, J ), J = K1, K2 )
END IF
50 CONTINUE
60 CONTINUE
*
ELSE IF( NDIGIT.LE.8 ) THEN
DO 80 K1 = 1, N, 2
K2 = MIN0( N, K1+1 )
WRITE( LOUT, 9996 )( ICOL, I, I = K1, K2 )
DO 70 I = 1, M
IF (K1.NE.N) THEN
WRITE( LOUT, 9992 )I, ( A( I, J ), J = K1, K2 )
ELSE
WRITE( LOUT, 9982 )I, ( A( I, J ), J = K1, K2 )
END IF
70 CONTINUE
80 CONTINUE
*
ELSE
DO 100 K1 = 1, N
WRITE( LOUT, 9995 ) ICOL, K1
DO 90 I = 1, M
WRITE( LOUT, 9991 )I, A( I, K1 )
90 CONTINUE
100 CONTINUE
END IF
*
*=======================================================================
* CODE FOR OUTPUT USING 132 COLUMNS FORMAT
*=======================================================================
*
ELSE
IF( NDIGIT.LE.4 ) THEN
DO 120 K1 = 1, N, 4
K2 = MIN0( N, K1+3 )
WRITE( LOUT, 9998 )( ICOL, I, I = K1, K2 )
DO 110 I = 1, M
IF ((K1+3).LE.N) THEN
WRITE( LOUT, 9974 )I, ( A( I, J ), J = K1, K2 )
ELSE IF ((K1+3-N).EQ.1) THEN
WRITE( LOUT, 9964 )I, ( A( I, J ), J = k1, K2 )
ELSE IF ((K1+3-N).EQ.2) THEN
WRITE( LOUT, 9954 )I, ( A( I, J ), J = K1, K2 )
ELSE IF ((K1+3-N).EQ.3) THEN
WRITE( LOUT, 9944 )I, ( A( I, J ), J = K1, K2 )
END IF
110 CONTINUE
120 CONTINUE
*
ELSE IF( NDIGIT.LE.6 ) THEN
DO 140 K1 = 1, N, 3
K2 = MIN0( N, K1+ 2)
WRITE( LOUT, 9997 )( ICOL, I, I = K1, K2 )
DO 130 I = 1, M
IF ((K1+2).LE.N) THEN
WRITE( LOUT, 9973 )I, ( A( I, J ), J = K1, K2 )
ELSE IF ((K1+2-N).EQ.1) THEN
WRITE( LOUT, 9963 )I, ( A( I, J ), J = K1, K2 )
ELSE IF ((K1+2-N).EQ.2) THEN
WRITE( LOUT, 9953 )I, ( A( I, J ), J = K1, K2 )
END IF
130 CONTINUE
140 CONTINUE
*
ELSE IF( NDIGIT.LE.8 ) THEN
DO 160 K1 = 1, N, 3
K2 = MIN0( N, K1+2 )
WRITE( LOUT, 9996 )( ICOL, I, I = K1, K2 )
DO 150 I = 1, M
IF ((K1+2).LE.N) THEN
WRITE( LOUT, 9972 )I, ( A( I, J ), J = K1, K2 )
ELSE IF ((K1+2-N).EQ.1) THEN
WRITE( LOUT, 9962 )I, ( A( I, J ), J = K1, K2 )
ELSE IF ((K1+2-N).EQ.2) THEN
WRITE( LOUT, 9952 )I, ( A( I, J ), J = K1, K2 )
END IF
150 CONTINUE
160 CONTINUE
*
ELSE
DO 180 K1 = 1, N, 2
K2 = MIN0( N, K1+1 )
WRITE( LOUT, 9995 )( ICOL, I, I = K1, K2 )
DO 170 I = 1, M
IF ((K1+1).LE.N) THEN
WRITE( LOUT, 9971 )I, ( A( I, J ), J = K1, K2 )
ELSE
WRITE( LOUT, 9961 )I, ( A( I, J ), J = K1, K2 )
END IF
170 CONTINUE
180 CONTINUE
END IF
END IF
WRITE( LOUT, 9990 )
*
9998 FORMAT( 11X, 4( 9X, 3A1, I4, 9X ) )
9997 FORMAT( 10X, 4( 11X, 3A1, I4, 11X ) )
9996 FORMAT( 10X, 3( 13X, 3A1, I4, 13X ) )
9995 FORMAT( 12X, 2( 18x, 3A1, I4, 18X ) )
*
*========================================================
* FORMAT FOR 72 COLUMN
*========================================================
*
* DISPLAY 4 SIGNIFICANT DIGITS
*
9994 FORMAT( 1X, ' Row', I4, ':', 1X, 1P,2('(',E10.3,',',E10.3,') ') )
9984 FORMAT( 1X, ' Row', I4, ':', 1X, 1P,1('(',E10.3,',',E10.3,') ') )
*
* DISPLAY 6 SIGNIFICANT DIGITS
*
9993 FORMAT( 1X, ' Row', I4, ':', 1X, 1P,2('(',E12.5,',',E12.5,') ') )
9983 FORMAT( 1X, ' Row', I4, ':', 1X, 1P,1('(',E12.5,',',E12.5,') ') )
*
* DISPLAY 8 SIGNIFICANT DIGITS
*
9992 FORMAT( 1X, ' Row', I4, ':', 1X, 1P,2('(',E14.7,',',E14.7,') ') )
9982 FORMAT( 1X, ' Row', I4, ':', 1X, 1P,1('(',E14.7,',',E14.7,') ') )
*
* DISPLAY 13 SIGNIFICANT DIGITS
*
9991 FORMAT( 1X, ' Row', I4, ':', 1X, 1P,1('(',E20.13,',',E20.13,')') )
9990 FORMAT( 1X, ' ' )
*
*
*========================================================
* FORMAT FOR 132 COLUMN
*========================================================
*
* DISPLAY 4 SIGNIFICANT DIGIT
*
9974 FORMAT( 1X, ' Row', I4, ':', 1X, 1P,4('(',E10.3,',',E10.3,') ') )
9964 FORMAT( 1X, ' Row', I4, ':', 1X, 1P,3('(',E10.3,',',E10.3,') ') )
9954 FORMAT( 1X, ' Row', I4, ':', 1X, 1P,2('(',E10.3,',',E10.3,') ') )
9944 FORMAT( 1X, ' Row', I4, ':', 1X, 1P,1('(',E10.3,',',E10.3,') ') )
*
* DISPLAY 6 SIGNIFICANT DIGIT
*
9973 FORMAT( 1X, ' Row', I4, ':', 1X, 1P,3('(',E12.5,',',E12.5,') ') )
9963 FORMAT( 1X, ' Row', I4, ':', 1X, 1P,2('(',E12.5,',',E12.5,') ') )
9953 FORMAT( 1X, ' Row', I4, ':', 1X, 1P,1('(',E12.5,',',E12.5,') ') )
*
* DISPLAY 8 SIGNIFICANT DIGIT
*
9972 FORMAT( 1X, ' Row', I4, ':', 1X, 1P,3('(',E14.7,',',E14.7,') ') )
9962 FORMAT( 1X, ' Row', I4, ':', 1X, 1P,2('(',E14.7,',',E14.7,') ') )
9952 FORMAT( 1X, ' Row', I4, ':', 1X, 1P,1('(',E14.7,',',E14.7,') ') )
*
* DISPLAY 13 SIGNIFICANT DIGIT
*
9971 FORMAT( 1X, ' Row', I4, ':', 1X, 1P,2('(',E20.13,',',E20.13,
& ') '))
9961 FORMAT( 1X, ' Row', I4, ':', 1X, 1P,1('(',E20.13,',',E20.13,
& ') '))
*
*
*
*
RETURN
END

240
arpack/ARPACK/UTIL/cvout.f Normal file
View File

@@ -0,0 +1,240 @@
c-----------------------------------------------------------------------
c
c\SCCS Information: @(#)
c FILE: cvout.f SID: 2.1 DATE OF SID: 11/16/95 RELEASE: 2
c
*-----------------------------------------------------------------------
* Routine: CVOUT
*
* Purpose: Complex vector output routine.
*
* Usage: CALL CVOUT (LOUT, N, CX, IDIGIT, IFMT)
*
* Arguments
* N - Length of array CX. (Input)
* CX - Complex array to be printed. (Input)
* IFMT - Format to be used in printing array CX. (Input)
* IDIGIT - Print up to IABS(IDIGIT) decimal digits per number. (In)
* If IDIGIT .LT. 0, printing is done with 72 columns.
* If IDIGIT .GT. 0, printing is done with 132 columns.
*
*-----------------------------------------------------------------------
*
SUBROUTINE CVOUT( LOUT, N, CX, IDIGIT, IFMT )
* ...
* ... SPECIFICATIONS FOR ARGUMENTS
INTEGER N, IDIGIT, LOUT
Complex
& CX( * )
CHARACTER IFMT*( * )
* ...
* ... SPECIFICATIONS FOR LOCAL VARIABLES
INTEGER I, NDIGIT, K1, K2, LLL
CHARACTER*80 LINE
* ...
* ... FIRST EXECUTABLE STATEMENT
*
*
LLL = MIN( LEN( IFMT ), 80 )
DO 10 I = 1, LLL
LINE( I: I ) = '-'
10 CONTINUE
*
DO 20 I = LLL + 1, 80
LINE( I: I ) = ' '
20 CONTINUE
*
WRITE( LOUT, 9999 )IFMT, LINE( 1: LLL )
9999 FORMAT( / 1X, A / 1X, A )
*
IF( N.LE.0 )
$ RETURN
NDIGIT = IDIGIT
IF( IDIGIT.EQ.0 )
$ NDIGIT = 4
*
*=======================================================================
* CODE FOR OUTPUT USING 72 COLUMNS FORMAT
*=======================================================================
*
IF( IDIGIT.LT.0 ) THEN
NDIGIT = -IDIGIT
IF( NDIGIT.LE.4 ) THEN
DO 30 K1 = 1, N, 2
K2 = MIN0( N, K1+1 )
IF (K1.NE.N) THEN
WRITE( LOUT, 9998 )K1, K2, ( CX( I ),
$ I = K1, K2 )
ELSE
WRITE( LOUT, 9997 )K1, K2, ( CX( I ),
$ I = K1, K2 )
END IF
30 CONTINUE
ELSE IF( NDIGIT.LE.6 ) THEN
DO 40 K1 = 1, N, 2
K2 = MIN0( N, K1+1 )
IF (K1.NE.N) THEN
WRITE( LOUT, 9988 )K1, K2, ( CX( I ),
$ I = K1, K2 )
ELSE
WRITE( LOUT, 9987 )K1, K2, ( CX( I ),
$ I = K1, K2 )
END IF
40 CONTINUE
ELSE IF( NDIGIT.LE.8 ) THEN
DO 50 K1 = 1, N, 2
K2 = MIN0( N, K1+1 )
IF (K1.NE.N) THEN
WRITE( LOUT, 9978 )K1, K2, ( CX( I ),
$ I = K1, K2 )
ELSE
WRITE( LOUT, 9977 )K1, K2, ( CX( I ),
$ I = K1, K2 )
END IF
50 CONTINUE
ELSE
DO 60 K1 = 1, N
WRITE( LOUT, 9968 )K1, K1, CX( I )
60 CONTINUE
END IF
*
*=======================================================================
* CODE FOR OUTPUT USING 132 COLUMNS FORMAT
*=======================================================================
*
ELSE
IF( NDIGIT.LE.4 ) THEN
DO 70 K1 = 1, N, 4
K2 = MIN0( N, K1+3 )
IF ((K1+3).LE.N) THEN
WRITE( LOUT, 9958 )K1, K2, ( CX( I ),
$ I = K1, K2 )
ELSE IF ((K1+3-N) .EQ. 1) THEN
WRITE( LOUT, 9957 )K1, K2, ( CX( I ),
$ I = K1, K2 )
ELSE IF ((K1+3-N) .EQ. 2) THEN
WRITE( LOUT, 9956 )K1, K2, ( CX( I ),
$ I = K1, K2 )
ELSE IF ((K1+3-N) .EQ. 1) THEN
WRITE( LOUT, 9955 )K1, K2, ( CX( I ),
$ I = K1, K2 )
END IF
70 CONTINUE
ELSE IF( NDIGIT.LE.6 ) THEN
DO 80 K1 = 1, N, 3
K2 = MIN0( N, K1+2 )
IF ((K1+2).LE.N) THEN
WRITE( LOUT, 9948 )K1, K2, ( CX( I ),
$ I = K1, K2 )
ELSE IF ((K1+2-N) .EQ. 1) THEN
WRITE( LOUT, 9947 )K1, K2, ( CX( I ),
$ I = K1, K2 )
ELSE IF ((K1+2-N) .EQ. 2) THEN
WRITE( LOUT, 9946 )K1, K2, ( CX( I ),
$ I = K1, K2 )
END IF
80 CONTINUE
ELSE IF( NDIGIT.LE.8 ) THEN
DO 90 K1 = 1, N, 3
K2 = MIN0( N, K1+2 )
IF ((K1+2).LE.N) THEN
WRITE( LOUT, 9938 )K1, K2, ( CX( I ),
$ I = K1, K2 )
ELSE IF ((K1+2-N) .EQ. 1) THEN
WRITE( LOUT, 9937 )K1, K2, ( CX( I ),
$ I = K1, K2 )
ELSE IF ((K1+2-N) .EQ. 2) THEN
WRITE( LOUT, 9936 )K1, K2, ( CX( I ),
$ I = K1, K2 )
END IF
90 CONTINUE
ELSE
DO 100 K1 = 1, N, 2
K2 = MIN0( N, K1+1 )
IF ((K1+2).LE.N) THEN
WRITE( LOUT, 9928 )K1, K2, ( CX( I ),
$ I = K1, K2 )
ELSE IF ((K1+2-N) .EQ. 1) THEN
WRITE( LOUT, 9927 )K1, K2, ( CX( I ),
$ I = K1, K2 )
END IF
100 CONTINUE
END IF
END IF
WRITE( LOUT, 9994 )
RETURN
*
*=======================================================================
* FORMAT FOR 72 COLUMNS
*=======================================================================
*
* DISPLAY 4 SIGNIFICANT DIGITS
*
9998 FORMAT( 1X, I4, ' - ', I4, ':', 1X,
$ 1P,2('(',E10.3,',',E10.3,') ') )
9997 FORMAT( 1X, I4, ' - ', I4, ':', 1X,
$ 1P,1('(',E10.3,',',E10.3,') ') )
*
* DISPLAY 6 SIGNIFICANT DIGITS
*
9988 FORMAT( 1X, I4, ' - ', I4, ':', 1X,
$ 1P,2('(',E12.5,',',E12.5,') ') )
9987 FORMAT( 1X, I4, ' - ', I4, ':', 1X,
$ 1P,1('(',E12.5,',',E12.5,') ') )
*
* DISPLAY 8 SIGNIFICANT DIGITS
*
9978 FORMAT( 1X, I4, ' - ', I4, ':', 1X,
$ 1P,2('(',E14.7,',',E14.7,') ') )
9977 FORMAT( 1X, I4, ' - ', I4, ':', 1X,
$ 1P,1('(',E14.7,',',E14.7,') ') )
*
* DISPLAY 13 SIGNIFICANT DIGITS
*
9968 FORMAT( 1X, I4, ' - ', I4, ':', 1X,
$ 1P,1('(',E20.13,',',E20.13,') ') )
*
*=========================================================================
* FORMAT FOR 132 COLUMNS
*=========================================================================
*
* DISPLAY 4 SIGNIFICANT DIGITS
*
9958 FORMAT( 1X, I4, ' - ', I4, ':', 1X,
$ 1P,4('(',E10.3,',',E10.3,') ') )
9957 FORMAT( 1X, I4, ' - ', I4, ':', 1X,
$ 1P,3('(',E10.3,',',E10.3,') ') )
9956 FORMAT( 1X, I4, ' - ', I4, ':', 1X,
$ 1P,2('(',E10.3,',',E10.3,') ') )
9955 FORMAT( 1X, I4, ' - ', I4, ':', 1X,
$ 1P,1('(',E10.3,',',E10.3,') ') )
*
* DISPLAY 6 SIGNIFICANT DIGITS
*
9948 FORMAT( 1X, I4, ' - ', I4, ':', 1X,
$ 1P,3('(',E12.5,',',E12.5,') ') )
9947 FORMAT( 1X, I4, ' - ', I4, ':', 1X,
$ 1P,2('(',E12.5,',',E12.5,') ') )
9946 FORMAT( 1X, I4, ' - ', I4, ':', 1X,
$ 1P,1('(',E12.5,',',E12.5,') ') )
*
* DISPLAY 8 SIGNIFICANT DIGITS
*
9938 FORMAT( 1X, I4, ' - ', I4, ':', 1X,
$ 1P,3('(',E14.7,',',E14.7,') ') )
9937 FORMAT( 1X, I4, ' - ', I4, ':', 1X,
$ 1P,2('(',E14.7,',',E14.7,') ') )
9936 FORMAT( 1X, I4, ' - ', I4, ':', 1X,
$ 1P,1('(',E14.7,',',E14.7,') ') )
*
* DISPLAY 13 SIGNIFICANT DIGITS
*
9928 FORMAT( 1X, I4, ' - ', I4, ':', 1X,
$ 1P,2('(',E20.13,',',E20.13,') ') )
9927 FORMAT( 1X, I4, ' - ', I4, ':', 1X,
$ 1P,1('(',E20.13,',',E20.13,') ') )
*
*
*
9994 FORMAT( 1X, ' ' )
END

167
arpack/ARPACK/UTIL/dmout.f Normal file
View File

@@ -0,0 +1,167 @@
*-----------------------------------------------------------------------
* Routine: DMOUT
*
* Purpose: Real matrix output routine.
*
* Usage: CALL DMOUT (LOUT, M, N, A, LDA, IDIGIT, IFMT)
*
* Arguments
* M - Number of rows of A. (Input)
* N - Number of columns of A. (Input)
* A - Real M by N matrix to be printed. (Input)
* LDA - Leading dimension of A exactly as specified in the
* dimension statement of the calling program. (Input)
* IFMT - Format to be used in printing matrix A. (Input)
* IDIGIT - Print up to IABS(IDIGIT) decimal digits per number. (In)
* If IDIGIT .LT. 0, printing is done with 72 columns.
* If IDIGIT .GT. 0, printing is done with 132 columns.
*
*-----------------------------------------------------------------------
*
SUBROUTINE DMOUT( LOUT, M, N, A, LDA, IDIGIT, IFMT )
* ...
* ... SPECIFICATIONS FOR ARGUMENTS
* ...
* ... SPECIFICATIONS FOR LOCAL VARIABLES
* .. Scalar Arguments ..
CHARACTER*( * ) IFMT
INTEGER IDIGIT, LDA, LOUT, M, N
* ..
* .. Array Arguments ..
DOUBLE PRECISION A( LDA, * )
* ..
* .. Local Scalars ..
CHARACTER*80 LINE
INTEGER I, J, K1, K2, LLL, NDIGIT
* ..
* .. Local Arrays ..
CHARACTER ICOL( 3 )
* ..
* .. Intrinsic Functions ..
INTRINSIC LEN, MIN, MIN0
* ..
* .. Data statements ..
DATA ICOL( 1 ), ICOL( 2 ), ICOL( 3 ) / 'C', 'o',
$ 'l' /
* ..
* .. Executable Statements ..
* ...
* ... FIRST EXECUTABLE STATEMENT
*
LLL = MIN( LEN( IFMT ), 80 )
DO 10 I = 1, LLL
LINE( I: I ) = '-'
10 CONTINUE
*
DO 20 I = LLL + 1, 80
LINE( I: I ) = ' '
20 CONTINUE
*
WRITE( LOUT, FMT = 9999 )IFMT, LINE( 1: LLL )
9999 FORMAT( / 1X, A, / 1X, A )
*
IF( M.LE.0 .OR. N.LE.0 .OR. LDA.LE.0 )
$ RETURN
NDIGIT = IDIGIT
IF( IDIGIT.EQ.0 )
$ NDIGIT = 4
*
*=======================================================================
* CODE FOR OUTPUT USING 72 COLUMNS FORMAT
*=======================================================================
*
IF( IDIGIT.LT.0 ) THEN
NDIGIT = -IDIGIT
IF( NDIGIT.LE.4 ) THEN
DO 40 K1 = 1, N, 5
K2 = MIN0( N, K1+4 )
WRITE( LOUT, FMT = 9998 )( ICOL, I, I = K1, K2 )
DO 30 I = 1, M
WRITE( LOUT, FMT = 9994 )I, ( A( I, J ), J = K1, K2 )
30 CONTINUE
40 CONTINUE
*
ELSE IF( NDIGIT.LE.6 ) THEN
DO 60 K1 = 1, N, 4
K2 = MIN0( N, K1+3 )
WRITE( LOUT, FMT = 9997 )( ICOL, I, I = K1, K2 )
DO 50 I = 1, M
WRITE( LOUT, FMT = 9993 )I, ( A( I, J ), J = K1, K2 )
50 CONTINUE
60 CONTINUE
*
ELSE IF( NDIGIT.LE.10 ) THEN
DO 80 K1 = 1, N, 3
K2 = MIN0( N, K1+2 )
WRITE( LOUT, FMT = 9996 )( ICOL, I, I = K1, K2 )
DO 70 I = 1, M
WRITE( LOUT, FMT = 9992 )I, ( A( I, J ), J = K1, K2 )
70 CONTINUE
80 CONTINUE
*
ELSE
DO 100 K1 = 1, N, 2
K2 = MIN0( N, K1+1 )
WRITE( LOUT, FMT = 9995 )( ICOL, I, I = K1, K2 )
DO 90 I = 1, M
WRITE( LOUT, FMT = 9991 )I, ( A( I, J ), J = K1, K2 )
90 CONTINUE
100 CONTINUE
END IF
*
*=======================================================================
* CODE FOR OUTPUT USING 132 COLUMNS FORMAT
*=======================================================================
*
ELSE
IF( NDIGIT.LE.4 ) THEN
DO 120 K1 = 1, N, 10
K2 = MIN0( N, K1+9 )
WRITE( LOUT, FMT = 9998 )( ICOL, I, I = K1, K2 )
DO 110 I = 1, M
WRITE( LOUT, FMT = 9994 )I, ( A( I, J ), J = K1, K2 )
110 CONTINUE
120 CONTINUE
*
ELSE IF( NDIGIT.LE.6 ) THEN
DO 140 K1 = 1, N, 8
K2 = MIN0( N, K1+7 )
WRITE( LOUT, FMT = 9997 )( ICOL, I, I = K1, K2 )
DO 130 I = 1, M
WRITE( LOUT, FMT = 9993 )I, ( A( I, J ), J = K1, K2 )
130 CONTINUE
140 CONTINUE
*
ELSE IF( NDIGIT.LE.10 ) THEN
DO 160 K1 = 1, N, 6
K2 = MIN0( N, K1+5 )
WRITE( LOUT, FMT = 9996 )( ICOL, I, I = K1, K2 )
DO 150 I = 1, M
WRITE( LOUT, FMT = 9992 )I, ( A( I, J ), J = K1, K2 )
150 CONTINUE
160 CONTINUE
*
ELSE
DO 180 K1 = 1, N, 5
K2 = MIN0( N, K1+4 )
WRITE( LOUT, FMT = 9995 )( ICOL, I, I = K1, K2 )
DO 170 I = 1, M
WRITE( LOUT, FMT = 9991 )I, ( A( I, J ), J = K1, K2 )
170 CONTINUE
180 CONTINUE
END IF
END IF
WRITE( LOUT, FMT = 9990 )
*
9998 FORMAT( 10X, 10( 4X, 3A1, I4, 1X ) )
9997 FORMAT( 10X, 8( 5X, 3A1, I4, 2X ) )
9996 FORMAT( 10X, 6( 7X, 3A1, I4, 4X ) )
9995 FORMAT( 10X, 5( 9X, 3A1, I4, 6X ) )
9994 FORMAT( 1X, ' Row', I4, ':', 1X, 1P, 10D12.3 )
9993 FORMAT( 1X, ' Row', I4, ':', 1X, 1P, 8D14.5 )
9992 FORMAT( 1X, ' Row', I4, ':', 1X, 1P, 6D18.9 )
9991 FORMAT( 1X, ' Row', I4, ':', 1X, 1P, 5D22.13 )
9990 FORMAT( 1X, ' ' )
*
RETURN
END

122
arpack/ARPACK/UTIL/dvout.f Normal file
View File

@@ -0,0 +1,122 @@
*-----------------------------------------------------------------------
* Routine: DVOUT
*
* Purpose: Real vector output routine.
*
* Usage: CALL DVOUT (LOUT, N, SX, IDIGIT, IFMT)
*
* Arguments
* N - Length of array SX. (Input)
* SX - Real array to be printed. (Input)
* IFMT - Format to be used in printing array SX. (Input)
* IDIGIT - Print up to IABS(IDIGIT) decimal digits per number. (In)
* If IDIGIT .LT. 0, printing is done with 72 columns.
* If IDIGIT .GT. 0, printing is done with 132 columns.
*
*-----------------------------------------------------------------------
*
SUBROUTINE DVOUT( LOUT, N, SX, IDIGIT, IFMT )
* ...
* ... SPECIFICATIONS FOR ARGUMENTS
* ...
* ... SPECIFICATIONS FOR LOCAL VARIABLES
* .. Scalar Arguments ..
CHARACTER*( * ) IFMT
INTEGER IDIGIT, LOUT, N
* ..
* .. Array Arguments ..
DOUBLE PRECISION SX( * )
* ..
* .. Local Scalars ..
CHARACTER*80 LINE
INTEGER I, K1, K2, LLL, NDIGIT
* ..
* .. Intrinsic Functions ..
INTRINSIC LEN, MIN, MIN0
* ..
* .. Executable Statements ..
* ...
* ... FIRST EXECUTABLE STATEMENT
*
*
LLL = MIN( LEN( IFMT ), 80 )
DO 10 I = 1, LLL
LINE( I: I ) = '-'
10 CONTINUE
*
DO 20 I = LLL + 1, 80
LINE( I: I ) = ' '
20 CONTINUE
*
WRITE( LOUT, FMT = 9999 )IFMT, LINE( 1: LLL )
9999 FORMAT( / 1X, A, / 1X, A )
*
IF( N.LE.0 )
$ RETURN
NDIGIT = IDIGIT
IF( IDIGIT.EQ.0 )
$ NDIGIT = 4
*
*=======================================================================
* CODE FOR OUTPUT USING 72 COLUMNS FORMAT
*=======================================================================
*
IF( IDIGIT.LT.0 ) THEN
NDIGIT = -IDIGIT
IF( NDIGIT.LE.4 ) THEN
DO 30 K1 = 1, N, 5
K2 = MIN0( N, K1+4 )
WRITE( LOUT, FMT = 9998 )K1, K2, ( SX( I ), I = K1, K2 )
30 CONTINUE
ELSE IF( NDIGIT.LE.6 ) THEN
DO 40 K1 = 1, N, 4
K2 = MIN0( N, K1+3 )
WRITE( LOUT, FMT = 9997 )K1, K2, ( SX( I ), I = K1, K2 )
40 CONTINUE
ELSE IF( NDIGIT.LE.10 ) THEN
DO 50 K1 = 1, N, 3
K2 = MIN0( N, K1+2 )
WRITE( LOUT, FMT = 9996 )K1, K2, ( SX( I ), I = K1, K2 )
50 CONTINUE
ELSE
DO 60 K1 = 1, N, 2
K2 = MIN0( N, K1+1 )
WRITE( LOUT, FMT = 9995 )K1, K2, ( SX( I ), I = K1, K2 )
60 CONTINUE
END IF
*
*=======================================================================
* CODE FOR OUTPUT USING 132 COLUMNS FORMAT
*=======================================================================
*
ELSE
IF( NDIGIT.LE.4 ) THEN
DO 70 K1 = 1, N, 10
K2 = MIN0( N, K1+9 )
WRITE( LOUT, FMT = 9998 )K1, K2, ( SX( I ), I = K1, K2 )
70 CONTINUE
ELSE IF( NDIGIT.LE.6 ) THEN
DO 80 K1 = 1, N, 8
K2 = MIN0( N, K1+7 )
WRITE( LOUT, FMT = 9997 )K1, K2, ( SX( I ), I = K1, K2 )
80 CONTINUE
ELSE IF( NDIGIT.LE.10 ) THEN
DO 90 K1 = 1, N, 6
K2 = MIN0( N, K1+5 )
WRITE( LOUT, FMT = 9996 )K1, K2, ( SX( I ), I = K1, K2 )
90 CONTINUE
ELSE
DO 100 K1 = 1, N, 5
K2 = MIN0( N, K1+4 )
WRITE( LOUT, FMT = 9995 )K1, K2, ( SX( I ), I = K1, K2 )
100 CONTINUE
END IF
END IF
WRITE( LOUT, FMT = 9994 )
RETURN
9998 FORMAT( 1X, I4, ' - ', I4, ':', 1P, 10D12.3 )
9997 FORMAT( 1X, I4, ' - ', I4, ':', 1X, 1P, 8D14.5 )
9996 FORMAT( 1X, I4, ' - ', I4, ':', 1X, 1P, 6D18.9 )
9995 FORMAT( 1X, I4, ' - ', I4, ':', 1X, 1P, 5D24.13 )
9994 FORMAT( 1X, ' ' )
END

18
arpack/ARPACK/UTIL/icnteq.f Normal file
View File

@@ -0,0 +1,18 @@
c
c-----------------------------------------------------------------------
c
c Count the number of elements equal to a specified integer value.
c
integer function icnteq (n, array, value)
c
integer n, value
integer array(*)
c
k = 0
do 10 i = 1, n
if (array(i) .eq. value) k = k + 1
10 continue
icnteq = k
c
return
end

77
arpack/ARPACK/UTIL/icopy.f Normal file
View File

@@ -0,0 +1,77 @@
*--------------------------------------------------------------------
*\Documentation
*
*\Name: ICOPY
*
*\Description:
* ICOPY copies an integer vector lx to an integer vector ly.
*
*\Usage:
* call icopy ( n, lx, inc, ly, incy )
*
*\Arguments:
* n integer (input)
* On entry, n is the number of elements of lx to be
c copied to ly.
*
* lx integer array (input)
* On entry, lx is the integer vector to be copied.
*
* incx integer (input)
* On entry, incx is the increment between elements of lx.
*
* ly integer array (input)
* On exit, ly is the integer vector that contains the
* copy of lx.
*
* incy integer (input)
* On entry, incy is the increment between elements of ly.
*
*\Enddoc
*
*--------------------------------------------------------------------
*
subroutine icopy( n, lx, incx, ly, incy )
*
* ----------------------------
* Specifications for arguments
* ----------------------------
integer incx, incy, n
integer lx( 1 ), ly( 1 )
*
* ----------------------------------
* Specifications for local variables
* ----------------------------------
integer i, ix, iy
*
* --------------------------
* First executable statement
* --------------------------
if( n.le.0 )
$ return
if( incx.eq.1 .and. incy.eq.1 )
$ go to 20
c
c.....code for unequal increments or equal increments
c not equal to 1
ix = 1
iy = 1
if( incx.lt.0 )
$ ix = ( -n+1 )*incx + 1
if( incy.lt.0 )
$ iy = ( -n+1 )*incy + 1
do 10 i = 1, n
ly( iy ) = lx( ix )
ix = ix + incx
iy = iy + incy
10 continue
return
c
c.....code for both increments equal to 1
c
20 continue
do 30 i = 1, n
ly( i ) = lx( i )
30 continue
return
end

16
arpack/ARPACK/UTIL/iset.f Normal file
View File

@@ -0,0 +1,16 @@
c
c-----------------------------------------------------------------------
c
c Only work with increment equal to 1 right now.
c
subroutine iset (n, value, array, inc)
c
integer n, value, inc
integer array(*)
c
do 10 i = 1, n
array(i) = value
10 continue
c
return
end

55
arpack/ARPACK/UTIL/iswap.f Normal file
View File

@@ -0,0 +1,55 @@
subroutine iswap (n,sx,incx,sy,incy)
c
c interchanges two vectors.
c uses unrolled loops for increments equal to 1.
c jack dongarra, linpack, 3/11/78.
c
integer sx(1),sy(1),stemp
integer i,incx,incy,ix,iy,m,mp1,n
c
if(n.le.0)return
if(incx.eq.1.and.incy.eq.1)go to 20
c
c code for unequal increments or equal increments not equal
c to 1
c
ix = 1
iy = 1
if(incx.lt.0)ix = (-n+1)*incx + 1
if(incy.lt.0)iy = (-n+1)*incy + 1
do 10 i = 1,n
stemp = sx(ix)
sx(ix) = sy(iy)
sy(iy) = stemp
ix = ix + incx
iy = iy + incy
10 continue
return
c
c code for both increments equal to 1
c
c
c clean-up loop
c
20 m = mod(n,3)
if( m .eq. 0 ) go to 40
do 30 i = 1,m
stemp = sx(i)
sx(i) = sy(i)
sy(i) = stemp
30 continue
if( n .lt. 3 ) return
40 mp1 = m + 1
do 50 i = mp1,n,3
stemp = sx(i)
sx(i) = sy(i)
sy(i) = stemp
stemp = sx(i + 1)
sx(i + 1) = sy(i + 1)
sy(i + 1) = stemp
stemp = sx(i + 2)
sx(i + 2) = sy(i + 2)
sy(i + 2) = stemp
50 continue
return
end

120
arpack/ARPACK/UTIL/ivout.f Normal file
View File

@@ -0,0 +1,120 @@
C-----------------------------------------------------------------------
C Routine: IVOUT
C
C Purpose: Integer vector output routine.
C
C Usage: CALL IVOUT (LOUT, N, IX, IDIGIT, IFMT)
C
C Arguments
C N - Length of array IX. (Input)
C IX - Integer array to be printed. (Input)
C IFMT - Format to be used in printing array IX. (Input)
C IDIGIT - Print up to ABS(IDIGIT) decimal digits / number. (Input)
C If IDIGIT .LT. 0, printing is done with 72 columns.
C If IDIGIT .GT. 0, printing is done with 132 columns.
C
C-----------------------------------------------------------------------
C
SUBROUTINE IVOUT (LOUT, N, IX, IDIGIT, IFMT)
C ...
C ... SPECIFICATIONS FOR ARGUMENTS
INTEGER IX(*), N, IDIGIT, LOUT
CHARACTER IFMT*(*)
C ...
C ... SPECIFICATIONS FOR LOCAL VARIABLES
INTEGER I, NDIGIT, K1, K2, LLL
CHARACTER*80 LINE
* ...
* ... SPECIFICATIONS INTRINSICS
INTRINSIC MIN
*
C
LLL = MIN ( LEN ( IFMT ), 80 )
DO 1 I = 1, LLL
LINE(I:I) = '-'
1 CONTINUE
C
DO 2 I = LLL+1, 80
LINE(I:I) = ' '
2 CONTINUE
C
WRITE ( LOUT, 2000 ) IFMT, LINE(1:LLL)
2000 FORMAT ( /1X, A /1X, A )
C
IF (N .LE. 0) RETURN
NDIGIT = IDIGIT
IF (IDIGIT .EQ. 0) NDIGIT = 4
C
C=======================================================================
C CODE FOR OUTPUT USING 72 COLUMNS FORMAT
C=======================================================================
C
IF (IDIGIT .LT. 0) THEN
C
NDIGIT = -IDIGIT
IF (NDIGIT .LE. 4) THEN
DO 10 K1 = 1, N, 10
K2 = MIN0(N,K1+9)
WRITE(LOUT,1000) K1,K2,(IX(I),I=K1,K2)
10 CONTINUE
C
ELSE IF (NDIGIT .LE. 6) THEN
DO 30 K1 = 1, N, 7
K2 = MIN0(N,K1+6)
WRITE(LOUT,1001) K1,K2,(IX(I),I=K1,K2)
30 CONTINUE
C
ELSE IF (NDIGIT .LE. 10) THEN
DO 50 K1 = 1, N, 5
K2 = MIN0(N,K1+4)
WRITE(LOUT,1002) K1,K2,(IX(I),I=K1,K2)
50 CONTINUE
C
ELSE
DO 70 K1 = 1, N, 3
K2 = MIN0(N,K1+2)
WRITE(LOUT,1003) K1,K2,(IX(I),I=K1,K2)
70 CONTINUE
END IF
C
C=======================================================================
C CODE FOR OUTPUT USING 132 COLUMNS FORMAT
C=======================================================================
C
ELSE
C
IF (NDIGIT .LE. 4) THEN
DO 90 K1 = 1, N, 20
K2 = MIN0(N,K1+19)
WRITE(LOUT,1000) K1,K2,(IX(I),I=K1,K2)
90 CONTINUE
C
ELSE IF (NDIGIT .LE. 6) THEN
DO 110 K1 = 1, N, 15
K2 = MIN0(N,K1+14)
WRITE(LOUT,1001) K1,K2,(IX(I),I=K1,K2)
110 CONTINUE
C
ELSE IF (NDIGIT .LE. 10) THEN
DO 130 K1 = 1, N, 10
K2 = MIN0(N,K1+9)
WRITE(LOUT,1002) K1,K2,(IX(I),I=K1,K2)
130 CONTINUE
C
ELSE
DO 150 K1 = 1, N, 7
K2 = MIN0(N,K1+6)
WRITE(LOUT,1003) K1,K2,(IX(I),I=K1,K2)
150 CONTINUE
END IF
END IF
WRITE (LOUT,1004)
C
1000 FORMAT(1X,I4,' - ',I4,':',20(1X,I5))
1001 FORMAT(1X,I4,' - ',I4,':',15(1X,I7))
1002 FORMAT(1X,I4,' - ',I4,':',10(1X,I11))
1003 FORMAT(1X,I4,' - ',I4,':',7(1X,I15))
1004 FORMAT(1X,' ')
C
RETURN
END

36
arpack/ARPACK/UTIL/second.f Normal file
View File

@@ -0,0 +1,36 @@
SUBROUTINE SECOND( T )
*
REAL T
*
* -- LAPACK auxiliary routine (preliminary version) --
* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
* Courant Institute, Argonne National Lab, and Rice University
* July 26, 1991
*
* Purpose
* =======
*
* SECOND returns the user time for a process in seconds.
* This version gets the time from the system function ETIME.
*
* .. Local Scalars ..
REAL T1
* ..
* .. Local Arrays ..
REAL TARRAY( 2 )
* ..
* .. External Functions ..
REAL ETIME
* EXTERNAL ETIME
* ..
* .. Executable Statements ..
*
T1 = ETIME( TARRAY )
T = TARRAY( 1 )
RETURN
*
* End of SECOND
*
END

157
arpack/ARPACK/UTIL/smout.f Normal file
View File

@@ -0,0 +1,157 @@
*-----------------------------------------------------------------------
* Routine: SMOUT
*
* Purpose: Real matrix output routine.
*
* Usage: CALL SMOUT (LOUT, M, N, A, LDA, IDIGIT, IFMT)
*
* Arguments
* M - Number of rows of A. (Input)
* N - Number of columns of A. (Input)
* A - Real M by N matrix to be printed. (Input)
* LDA - Leading dimension of A exactly as specified in the
* dimension statement of the calling program. (Input)
* IFMT - Format to be used in printing matrix A. (Input)
* IDIGIT - Print up to IABS(IDIGIT) decimal digits per number. (In)
* If IDIGIT .LT. 0, printing is done with 72 columns.
* If IDIGIT .GT. 0, printing is done with 132 columns.
*
*-----------------------------------------------------------------------
*
SUBROUTINE SMOUT( LOUT, M, N, A, LDA, IDIGIT, IFMT )
* ...
* ... SPECIFICATIONS FOR ARGUMENTS
INTEGER M, N, IDIGIT, LDA, LOUT
REAL A( LDA, * )
CHARACTER IFMT*( * )
* ...
* ... SPECIFICATIONS FOR LOCAL VARIABLES
INTEGER I, J, NDIGIT, K1, K2, LLL
CHARACTER*1 ICOL( 3 )
CHARACTER*80 LINE
* ...
* ... SPECIFICATIONS INTRINSICS
INTRINSIC MIN
*
DATA ICOL( 1 ), ICOL( 2 ), ICOL( 3 ) / 'C', 'o',
$ 'l' /
* ...
* ... FIRST EXECUTABLE STATEMENT
*
LLL = MIN( LEN( IFMT ), 80 )
DO 10 I = 1, LLL
LINE( I: I ) = '-'
10 CONTINUE
*
DO 20 I = LLL + 1, 80
LINE( I: I ) = ' '
20 CONTINUE
*
WRITE( LOUT, 9999 )IFMT, LINE( 1: LLL )
9999 FORMAT( / 1X, A / 1X, A )
*
IF( M.LE.0 .OR. N.LE.0 .OR. LDA.LE.0 )
$ RETURN
NDIGIT = IDIGIT
IF( IDIGIT.EQ.0 )
$ NDIGIT = 4
*
*=======================================================================
* CODE FOR OUTPUT USING 72 COLUMNS FORMAT
*=======================================================================
*
IF( IDIGIT.LT.0 ) THEN
NDIGIT = -IDIGIT
IF( NDIGIT.LE.4 ) THEN
DO 40 K1 = 1, N, 5
K2 = MIN0( N, K1+4 )
WRITE( LOUT, 9998 )( ICOL, I, I = K1, K2 )
DO 30 I = 1, M
WRITE( LOUT, 9994 )I, ( A( I, J ), J = K1, K2 )
30 CONTINUE
40 CONTINUE
*
ELSE IF( NDIGIT.LE.6 ) THEN
DO 60 K1 = 1, N, 4
K2 = MIN0( N, K1+3 )
WRITE( LOUT, 9997 )( ICOL, I, I = K1, K2 )
DO 50 I = 1, M
WRITE( LOUT, 9993 )I, ( A( I, J ), J = K1, K2 )
50 CONTINUE
60 CONTINUE
*
ELSE IF( NDIGIT.LE.10 ) THEN
DO 80 K1 = 1, N, 3
K2 = MIN0( N, K1+2 )
WRITE( LOUT, 9996 )( ICOL, I, I = K1, K2 )
DO 70 I = 1, M
WRITE( LOUT, 9992 )I, ( A( I, J ), J = K1, K2 )
70 CONTINUE
80 CONTINUE
*
ELSE
DO 100 K1 = 1, N, 2
K2 = MIN0( N, K1+1 )
WRITE( LOUT, 9995 )( ICOL, I, I = K1, K2 )
DO 90 I = 1, M
WRITE( LOUT, 9991 )I, ( A( I, J ), J = K1, K2 )
90 CONTINUE
100 CONTINUE
END IF
*
*=======================================================================
* CODE FOR OUTPUT USING 132 COLUMNS FORMAT
*=======================================================================
*
ELSE
IF( NDIGIT.LE.4 ) THEN
DO 120 K1 = 1, N, 10
K2 = MIN0( N, K1+9 )
WRITE( LOUT, 9998 )( ICOL, I, I = K1, K2 )
DO 110 I = 1, M
WRITE( LOUT, 9994 )I, ( A( I, J ), J = K1, K2 )
110 CONTINUE
120 CONTINUE
*
ELSE IF( NDIGIT.LE.6 ) THEN
DO 140 K1 = 1, N, 8
K2 = MIN0( N, K1+7 )
WRITE( LOUT, 9997 )( ICOL, I, I = K1, K2 )
DO 130 I = 1, M
WRITE( LOUT, 9993 )I, ( A( I, J ), J = K1, K2 )
130 CONTINUE
140 CONTINUE
*
ELSE IF( NDIGIT.LE.10 ) THEN
DO 160 K1 = 1, N, 6
K2 = MIN0( N, K1+5 )
WRITE( LOUT, 9996 )( ICOL, I, I = K1, K2 )
DO 150 I = 1, M
WRITE( LOUT, 9992 )I, ( A( I, J ), J = K1, K2 )
150 CONTINUE
160 CONTINUE
*
ELSE
DO 180 K1 = 1, N, 5
K2 = MIN0( N, K1+4 )
WRITE( LOUT, 9995 )( ICOL, I, I = K1, K2 )
DO 170 I = 1, M
WRITE( LOUT, 9991 )I, ( A( I, J ), J = K1, K2 )
170 CONTINUE
180 CONTINUE
END IF
END IF
WRITE( LOUT, 9990 )
*
9998 FORMAT( 10X, 10( 4X, 3A1, I4, 1X ) )
9997 FORMAT( 10X, 8( 5X, 3A1, I4, 2X ) )
9996 FORMAT( 10X, 6( 7X, 3A1, I4, 4X ) )
9995 FORMAT( 10X, 5( 9X, 3A1, I4, 6X ) )
9994 FORMAT( 1X, ' Row', I4, ':', 1X, 1P10E12.3 )
9993 FORMAT( 1X, ' Row', I4, ':', 1X, 1P8E14.5 )
9992 FORMAT( 1X, ' Row', I4, ':', 1X, 1P6E18.9 )
9991 FORMAT( 1X, ' Row', I4, ':', 1X, 1P5E22.13 )
9990 FORMAT( 1X, ' ' )
*
RETURN
END

112
arpack/ARPACK/UTIL/svout.f Normal file
View File

@@ -0,0 +1,112 @@
*-----------------------------------------------------------------------
* Routine: SVOUT
*
* Purpose: Real vector output routine.
*
* Usage: CALL SVOUT (LOUT, N, SX, IDIGIT, IFMT)
*
* Arguments
* N - Length of array SX. (Input)
* SX - Real array to be printed. (Input)
* IFMT - Format to be used in printing array SX. (Input)
* IDIGIT - Print up to IABS(IDIGIT) decimal digits per number. (In)
* If IDIGIT .LT. 0, printing is done with 72 columns.
* If IDIGIT .GT. 0, printing is done with 132 columns.
*
*-----------------------------------------------------------------------
*
SUBROUTINE SVOUT( LOUT, N, SX, IDIGIT, IFMT )
* ...
* ... SPECIFICATIONS FOR ARGUMENTS
INTEGER N, IDIGIT, LOUT
REAL SX( * )
CHARACTER IFMT*( * )
* ...
* ... SPECIFICATIONS FOR LOCAL VARIABLES
INTEGER I, NDIGIT, K1, K2, LLL
CHARACTER*80 LINE
* ...
* ... FIRST EXECUTABLE STATEMENT
*
*
LLL = MIN( LEN( IFMT ), 80 )
DO 10 I = 1, LLL
LINE( I: I ) = '-'
10 CONTINUE
*
DO 20 I = LLL + 1, 80
LINE( I: I ) = ' '
20 CONTINUE
*
WRITE( LOUT, 9999 )IFMT, LINE( 1: LLL )
9999 FORMAT( / 1X, A / 1X, A )
*
IF( N.LE.0 )
$ RETURN
NDIGIT = IDIGIT
IF( IDIGIT.EQ.0 )
$ NDIGIT = 4
*
*=======================================================================
* CODE FOR OUTPUT USING 72 COLUMNS FORMAT
*=======================================================================
*
IF( IDIGIT.LT.0 ) THEN
NDIGIT = -IDIGIT
IF( NDIGIT.LE.4 ) THEN
DO 30 K1 = 1, N, 5
K2 = MIN0( N, K1+4 )
WRITE( LOUT, 9998 )K1, K2, ( SX( I ), I = K1, K2 )
30 CONTINUE
ELSE IF( NDIGIT.LE.6 ) THEN
DO 40 K1 = 1, N, 4
K2 = MIN0( N, K1+3 )
WRITE( LOUT, 9997 )K1, K2, ( SX( I ), I = K1, K2 )
40 CONTINUE
ELSE IF( NDIGIT.LE.10 ) THEN
DO 50 K1 = 1, N, 3
K2 = MIN0( N, K1+2 )
WRITE( LOUT, 9996 )K1, K2, ( SX( I ), I = K1, K2 )
50 CONTINUE
ELSE
DO 60 K1 = 1, N, 2
K2 = MIN0( N, K1+1 )
WRITE( LOUT, 9995 )K1, K2, ( SX( I ), I = K1, K2 )
60 CONTINUE
END IF
*
*=======================================================================
* CODE FOR OUTPUT USING 132 COLUMNS FORMAT
*=======================================================================
*
ELSE
IF( NDIGIT.LE.4 ) THEN
DO 70 K1 = 1, N, 10
K2 = MIN0( N, K1+9 )
WRITE( LOUT, 9998 )K1, K2, ( SX( I ), I = K1, K2 )
70 CONTINUE
ELSE IF( NDIGIT.LE.6 ) THEN
DO 80 K1 = 1, N, 8
K2 = MIN0( N, K1+7 )
WRITE( LOUT, 9997 )K1, K2, ( SX( I ), I = K1, K2 )
80 CONTINUE
ELSE IF( NDIGIT.LE.10 ) THEN
DO 90 K1 = 1, N, 6
K2 = MIN0( N, K1+5 )
WRITE( LOUT, 9996 )K1, K2, ( SX( I ), I = K1, K2 )
90 CONTINUE
ELSE
DO 100 K1 = 1, N, 5
K2 = MIN0( N, K1+4 )
WRITE( LOUT, 9995 )K1, K2, ( SX( I ), I = K1, K2 )
100 CONTINUE
END IF
END IF
WRITE( LOUT, 9994 )
RETURN
9998 FORMAT( 1X, I4, ' - ', I4, ':', 1P10E12.3 )
9997 FORMAT( 1X, I4, ' - ', I4, ':', 1X, 1P8E14.5 )
9996 FORMAT( 1X, I4, ' - ', I4, ':', 1X, 1P6E18.9 )
9995 FORMAT( 1X, I4, ' - ', I4, ':', 1X, 1P5E24.13 )
9994 FORMAT( 1X, ' ' )
END

250
arpack/ARPACK/UTIL/zmout.f Normal file
View File

@@ -0,0 +1,250 @@
*
* Routine: ZMOUT
*
* Purpose: Complex*16 matrix output routine.
*
* Usage: CALL ZMOUT (LOUT, M, N, A, LDA, IDIGIT, IFMT)
*
* Arguments
* M - Number of rows of A. (Input)
* N - Number of columns of A. (Input)
* A - Complex*16 M by N matrix to be printed. (Input)
* LDA - Leading dimension of A exactly as specified in the
* dimension statement of the calling program. (Input)
* IFMT - Format to be used in printing matrix A. (Input)
* IDIGIT - Print up to IABS(IDIGIT) decimal digits per number. (In)
* If IDIGIT .LT. 0, printing is done with 72 columns.
* If IDIGIT .GT. 0, printing is done with 132 columns.
*
*\SCCS Information: @(#)
* FILE: zmout.f SID: 2.1 DATE OF SID: 11/16/95 RELEASE: 2
*
*-----------------------------------------------------------------------
*
SUBROUTINE ZMOUT( LOUT, M, N, A, LDA, IDIGIT, IFMT )
* ...
* ... SPECIFICATIONS FOR ARGUMENTS
INTEGER M, N, IDIGIT, LDA, LOUT
Complex*16
& A( LDA, * )
CHARACTER IFMT*( * )
* ...
* ... SPECIFICATIONS FOR LOCAL VARIABLES
INTEGER I, J, NDIGIT, K1, K2, LLL
CHARACTER*1 ICOL( 3 )
CHARACTER*80 LINE
* ...
* ... SPECIFICATIONS INTRINSICS
INTRINSIC MIN
*
DATA ICOL( 1 ), ICOL( 2 ), ICOL( 3 ) / 'C', 'o',
$ 'l' /
* ...
* ... FIRST EXECUTABLE STATEMENT
*
LLL = MIN( LEN( IFMT ), 80 )
DO 10 I = 1, LLL
LINE( I: I ) = '-'
10 CONTINUE
*
DO 20 I = LLL + 1, 80
LINE( I: I ) = ' '
20 CONTINUE
*
WRITE( LOUT, 9999 )IFMT, LINE( 1: LLL )
9999 FORMAT( / 1X, A / 1X, A )
*
IF( M.LE.0 .OR. N.LE.0 .OR. LDA.LE.0 )
$ RETURN
NDIGIT = IDIGIT
IF( IDIGIT.EQ.0 )
$ NDIGIT = 4
*
*=======================================================================
* CODE FOR OUTPUT USING 72 COLUMNS FORMAT
*=======================================================================
*
IF( IDIGIT.LT.0 ) THEN
NDIGIT = -IDIGIT
IF( NDIGIT.LE.4 ) THEN
DO 40 K1 = 1, N, 2
K2 = MIN0( N, K1+1 )
WRITE( LOUT, 9998 )( ICOL, I, I = K1, K2 )
DO 30 I = 1, M
IF (K1.NE.N) THEN
WRITE( LOUT, 9994 )I, ( A( I, J ), J = K1, K2 )
ELSE
WRITE( LOUT, 9984 )I, ( A( I, J ), J = K1, K2 )
END IF
30 CONTINUE
40 CONTINUE
*
ELSE IF( NDIGIT.LE.6 ) THEN
DO 60 K1 = 1, N, 2
K2 = MIN0( N, K1+1 )
WRITE( LOUT, 9997 )( ICOL, I, I = K1, K2 )
DO 50 I = 1, M
IF (K1.NE.N) THEN
WRITE( LOUT, 9993 )I, ( A( I, J ), J = K1, K2 )
ELSE
WRITE( LOUT, 9983 )I, ( A( I, J ), J = K1, K2 )
END IF
50 CONTINUE
60 CONTINUE
*
ELSE IF( NDIGIT.LE.8 ) THEN
DO 80 K1 = 1, N, 2
K2 = MIN0( N, K1+1 )
WRITE( LOUT, 9996 )( ICOL, I, I = K1, K2 )
DO 70 I = 1, M
IF (K1.NE.N) THEN
WRITE( LOUT, 9992 )I, ( A( I, J ), J = K1, K2 )
ELSE
WRITE( LOUT, 9982 )I, ( A( I, J ), J = K1, K2 )
END IF
70 CONTINUE
80 CONTINUE
*
ELSE
DO 100 K1 = 1, N
WRITE( LOUT, 9995 ) ICOL, K1
DO 90 I = 1, M
WRITE( LOUT, 9991 )I, A( I, K1 )
90 CONTINUE
100 CONTINUE
END IF
*
*=======================================================================
* CODE FOR OUTPUT USING 132 COLUMNS FORMAT
*=======================================================================
*
ELSE
IF( NDIGIT.LE.4 ) THEN
DO 120 K1 = 1, N, 4
K2 = MIN0( N, K1+3 )
WRITE( LOUT, 9998 )( ICOL, I, I = K1, K2 )
DO 110 I = 1, M
IF ((K1+3).LE.N) THEN
WRITE( LOUT, 9974 )I, ( A( I, J ), J = K1, K2 )
ELSE IF ((K1+3-N).EQ.1) THEN
WRITE( LOUT, 9964 )I, ( A( I, J ), J = k1, K2 )
ELSE IF ((K1+3-N).EQ.2) THEN
WRITE( LOUT, 9954 )I, ( A( I, J ), J = K1, K2 )
ELSE IF ((K1+3-N).EQ.3) THEN
WRITE( LOUT, 9944 )I, ( A( I, J ), J = K1, K2 )
END IF
110 CONTINUE
120 CONTINUE
*
ELSE IF( NDIGIT.LE.6 ) THEN
DO 140 K1 = 1, N, 3
K2 = MIN0( N, K1+ 2)
WRITE( LOUT, 9997 )( ICOL, I, I = K1, K2 )
DO 130 I = 1, M
IF ((K1+2).LE.N) THEN
WRITE( LOUT, 9973 )I, ( A( I, J ), J = K1, K2 )
ELSE IF ((K1+2-N).EQ.1) THEN
WRITE( LOUT, 9963 )I, ( A( I, J ), J = K1, K2 )
ELSE IF ((K1+2-N).EQ.2) THEN
WRITE( LOUT, 9953 )I, ( A( I, J ), J = K1, K2 )
END IF
130 CONTINUE
140 CONTINUE
*
ELSE IF( NDIGIT.LE.8 ) THEN
DO 160 K1 = 1, N, 3
K2 = MIN0( N, K1+2 )
WRITE( LOUT, 9996 )( ICOL, I, I = K1, K2 )
DO 150 I = 1, M
IF ((K1+2).LE.N) THEN
WRITE( LOUT, 9972 )I, ( A( I, J ), J = K1, K2 )
ELSE IF ((K1+2-N).EQ.1) THEN
WRITE( LOUT, 9962 )I, ( A( I, J ), J = K1, K2 )
ELSE IF ((K1+2-N).EQ.2) THEN
WRITE( LOUT, 9952 )I, ( A( I, J ), J = K1, K2 )
END IF
150 CONTINUE
160 CONTINUE
*
ELSE
DO 180 K1 = 1, N, 2
K2 = MIN0( N, K1+1 )
WRITE( LOUT, 9995 )( ICOL, I, I = K1, K2 )
DO 170 I = 1, M
IF ((K1+1).LE.N) THEN
WRITE( LOUT, 9971 )I, ( A( I, J ), J = K1, K2 )
ELSE
WRITE( LOUT, 9961 )I, ( A( I, J ), J = K1, K2 )
END IF
170 CONTINUE
180 CONTINUE
END IF
END IF
WRITE( LOUT, 9990 )
*
9998 FORMAT( 11X, 4( 9X, 3A1, I4, 9X ) )
9997 FORMAT( 10X, 4( 11X, 3A1, I4, 11X ) )
9996 FORMAT( 10X, 3( 13X, 3A1, I4, 13X ) )
9995 FORMAT( 12X, 2( 18x, 3A1, I4, 18X ) )
*
*========================================================
* FORMAT FOR 72 COLUMN
*========================================================
*
* DISPLAY 4 SIGNIFICANT DIGITS
*
9994 FORMAT( 1X, ' Row', I4, ':', 1X, 1P,2('(',D10.3,',',D10.3,') ') )
9984 FORMAT( 1X, ' Row', I4, ':', 1X, 1P,1('(',D10.3,',',D10.3,') ') )
*
* DISPLAY 6 SIGNIFICANT DIGITS
*
9993 FORMAT( 1X, ' Row', I4, ':', 1X, 1P,2('(',D12.5,',',D12.5,') ') )
9983 FORMAT( 1X, ' Row', I4, ':', 1X, 1P,1('(',D12.5,',',D12.5,') ') )
*
* DISPLAY 8 SIGNIFICANT DIGITS
*
9992 FORMAT( 1X, ' Row', I4, ':', 1X, 1P,2('(',D14.7,',',D14.7,') ') )
9982 FORMAT( 1X, ' Row', I4, ':', 1X, 1P,1('(',D14.7,',',D14.7,') ') )
*
* DISPLAY 13 SIGNIFICANT DIGITS
*
9991 FORMAT( 1X, ' Row', I4, ':', 1X, 1P,1('(',D20.13,',',D20.13,')') )
9990 FORMAT( 1X, ' ' )
*
*
*========================================================
* FORMAT FOR 132 COLUMN
*========================================================
*
* DISPLAY 4 SIGNIFICANT DIGIT
*
9974 FORMAT( 1X, ' Row', I4, ':', 1X, 1P,4('(',D10.3,',',D10.3,') ') )
9964 FORMAT( 1X, ' Row', I4, ':', 1X, 1P,3('(',D10.3,',',D10.3,') ') )
9954 FORMAT( 1X, ' Row', I4, ':', 1X, 1P,2('(',D10.3,',',D10.3,') ') )
9944 FORMAT( 1X, ' Row', I4, ':', 1X, 1P,1('(',D10.3,',',D10.3,') ') )
*
* DISPLAY 6 SIGNIFICANT DIGIT
*
9973 FORMAT( 1X, ' Row', I4, ':', 1X, 1P,3('(',D12.5,',',D12.5,') ') )
9963 FORMAT( 1X, ' Row', I4, ':', 1X, 1P,2('(',D12.5,',',D12.5,') ') )
9953 FORMAT( 1X, ' Row', I4, ':', 1X, 1P,1('(',D12.5,',',D12.5,') ') )
*
* DISPLAY 8 SIGNIFICANT DIGIT
*
9972 FORMAT( 1X, ' Row', I4, ':', 1X, 1P,3('(',D14.7,',',D14.7,') ') )
9962 FORMAT( 1X, ' Row', I4, ':', 1X, 1P,2('(',D14.7,',',D14.7,') ') )
9952 FORMAT( 1X, ' Row', I4, ':', 1X, 1P,1('(',D14.7,',',D14.7,') ') )
*
* DISPLAY 13 SIGNIFICANT DIGIT
*
9971 FORMAT( 1X, ' Row', I4, ':', 1X, 1P,2('(',D20.13,',',D20.13,
& ') '))
9961 FORMAT( 1X, ' Row', I4, ':', 1X, 1P,1('(',D20.13,',',D20.13,
& ') '))
*
*
*
*
RETURN
END

240
arpack/ARPACK/UTIL/zvout.f Normal file
View File

@@ -0,0 +1,240 @@
c-----------------------------------------------------------------------
c
c\SCCS Information: @(#)
c FILE: zvout.f SID: 2.1 DATE OF SID: 11/16/95 RELEASE: 2
c
*-----------------------------------------------------------------------
* Routine: ZVOUT
*
* Purpose: Complex*16 vector output routine.
*
* Usage: CALL ZVOUT (LOUT, N, CX, IDIGIT, IFMT)
*
* Arguments
* N - Length of array CX. (Input)
* CX - Complex*16 array to be printed. (Input)
* IFMT - Format to be used in printing array CX. (Input)
* IDIGIT - Print up to IABS(IDIGIT) decimal digits per number. (In)
* If IDIGIT .LT. 0, printing is done with 72 columns.
* If IDIGIT .GT. 0, printing is done with 132 columns.
*
*-----------------------------------------------------------------------
*
SUBROUTINE ZVOUT( LOUT, N, CX, IDIGIT, IFMT )
* ...
* ... SPECIFICATIONS FOR ARGUMENTS
INTEGER N, IDIGIT, LOUT
Complex*16
& CX( * )
CHARACTER IFMT*( * )
* ...
* ... SPECIFICATIONS FOR LOCAL VARIABLES
INTEGER I, NDIGIT, K1, K2, LLL
CHARACTER*80 LINE
* ...
* ... FIRST EXECUTABLE STATEMENT
*
*
LLL = MIN( LEN( IFMT ), 80 )
DO 10 I = 1, LLL
LINE( I: I ) = '-'
10 CONTINUE
*
DO 20 I = LLL + 1, 80
LINE( I: I ) = ' '
20 CONTINUE
*
WRITE( LOUT, 9999 )IFMT, LINE( 1: LLL )
9999 FORMAT( / 1X, A / 1X, A )
*
IF( N.LE.0 )
$ RETURN
NDIGIT = IDIGIT
IF( IDIGIT.EQ.0 )
$ NDIGIT = 4
*
*=======================================================================
* CODE FOR OUTPUT USING 72 COLUMNS FORMAT
*=======================================================================
*
IF( IDIGIT.LT.0 ) THEN
NDIGIT = -IDIGIT
IF( NDIGIT.LE.4 ) THEN
DO 30 K1 = 1, N, 2
K2 = MIN0( N, K1+1 )
IF (K1.NE.N) THEN
WRITE( LOUT, 9998 )K1, K2, ( CX( I ),
$ I = K1, K2 )
ELSE
WRITE( LOUT, 9997 )K1, K2, ( CX( I ),
$ I = K1, K2 )
END IF
30 CONTINUE
ELSE IF( NDIGIT.LE.6 ) THEN
DO 40 K1 = 1, N, 2
K2 = MIN0( N, K1+1 )
IF (K1.NE.N) THEN
WRITE( LOUT, 9988 )K1, K2, ( CX( I ),
$ I = K1, K2 )
ELSE
WRITE( LOUT, 9987 )K1, K2, ( CX( I ),
$ I = K1, K2 )
END IF
40 CONTINUE
ELSE IF( NDIGIT.LE.8 ) THEN
DO 50 K1 = 1, N, 2
K2 = MIN0( N, K1+1 )
IF (K1.NE.N) THEN
WRITE( LOUT, 9978 )K1, K2, ( CX( I ),
$ I = K1, K2 )
ELSE
WRITE( LOUT, 9977 )K1, K2, ( CX( I ),
$ I = K1, K2 )
END IF
50 CONTINUE
ELSE
DO 60 K1 = 1, N
WRITE( LOUT, 9968 )K1, K1, CX( I )
60 CONTINUE
END IF
*
*=======================================================================
* CODE FOR OUTPUT USING 132 COLUMNS FORMAT
*=======================================================================
*
ELSE
IF( NDIGIT.LE.4 ) THEN
DO 70 K1 = 1, N, 4
K2 = MIN0( N, K1+3 )
IF ((K1+3).LE.N) THEN
WRITE( LOUT, 9958 )K1, K2, ( CX( I ),
$ I = K1, K2 )
ELSE IF ((K1+3-N) .EQ. 1) THEN
WRITE( LOUT, 9957 )K1, K2, ( CX( I ),
$ I = K1, K2 )
ELSE IF ((K1+3-N) .EQ. 2) THEN
WRITE( LOUT, 9956 )K1, K2, ( CX( I ),
$ I = K1, K2 )
ELSE IF ((K1+3-N) .EQ. 1) THEN
WRITE( LOUT, 9955 )K1, K2, ( CX( I ),
$ I = K1, K2 )
END IF
70 CONTINUE
ELSE IF( NDIGIT.LE.6 ) THEN
DO 80 K1 = 1, N, 3
K2 = MIN0( N, K1+2 )
IF ((K1+2).LE.N) THEN
WRITE( LOUT, 9948 )K1, K2, ( CX( I ),
$ I = K1, K2 )
ELSE IF ((K1+2-N) .EQ. 1) THEN
WRITE( LOUT, 9947 )K1, K2, ( CX( I ),
$ I = K1, K2 )
ELSE IF ((K1+2-N) .EQ. 2) THEN
WRITE( LOUT, 9946 )K1, K2, ( CX( I ),
$ I = K1, K2 )
END IF
80 CONTINUE
ELSE IF( NDIGIT.LE.8 ) THEN
DO 90 K1 = 1, N, 3
K2 = MIN0( N, K1+2 )
IF ((K1+2).LE.N) THEN
WRITE( LOUT, 9938 )K1, K2, ( CX( I ),
$ I = K1, K2 )
ELSE IF ((K1+2-N) .EQ. 1) THEN
WRITE( LOUT, 9937 )K1, K2, ( CX( I ),
$ I = K1, K2 )
ELSE IF ((K1+2-N) .EQ. 2) THEN
WRITE( LOUT, 9936 )K1, K2, ( CX( I ),
$ I = K1, K2 )
END IF
90 CONTINUE
ELSE
DO 100 K1 = 1, N, 2
K2 = MIN0( N, K1+1 )
IF ((K1+2).LE.N) THEN
WRITE( LOUT, 9928 )K1, K2, ( CX( I ),
$ I = K1, K2 )
ELSE IF ((K1+2-N) .EQ. 1) THEN
WRITE( LOUT, 9927 )K1, K2, ( CX( I ),
$ I = K1, K2 )
END IF
100 CONTINUE
END IF
END IF
WRITE( LOUT, 9994 )
RETURN
*
*=======================================================================
* FORMAT FOR 72 COLUMNS
*=======================================================================
*
* DISPLAY 4 SIGNIFICANT DIGITS
*
9998 FORMAT( 1X, I4, ' - ', I4, ':', 1X,
$ 1P,2('(',D10.3,',',D10.3,') ') )
9997 FORMAT( 1X, I4, ' - ', I4, ':', 1X,
$ 1P,1('(',D10.3,',',D10.3,') ') )
*
* DISPLAY 6 SIGNIFICANT DIGITS
*
9988 FORMAT( 1X, I4, ' - ', I4, ':', 1X,
$ 1P,2('(',D12.5,',',D12.5,') ') )
9987 FORMAT( 1X, I4, ' - ', I4, ':', 1X,
$ 1P,1('(',D12.5,',',D12.5,') ') )
*
* DISPLAY 8 SIGNIFICANT DIGITS
*
9978 FORMAT( 1X, I4, ' - ', I4, ':', 1X,
$ 1P,2('(',D14.7,',',D14.7,') ') )
9977 FORMAT( 1X, I4, ' - ', I4, ':', 1X,
$ 1P,1('(',D14.7,',',D14.7,') ') )
*
* DISPLAY 13 SIGNIFICANT DIGITS
*
9968 FORMAT( 1X, I4, ' - ', I4, ':', 1X,
$ 1P,1('(',D20.13,',',D20.13,') ') )
*
*=========================================================================
* FORMAT FOR 132 COLUMNS
*=========================================================================
*
* DISPLAY 4 SIGNIFICANT DIGITS
*
9958 FORMAT( 1X, I4, ' - ', I4, ':', 1X,
$ 1P,4('(',D10.3,',',D10.3,') ') )
9957 FORMAT( 1X, I4, ' - ', I4, ':', 1X,
$ 1P,3('(',D10.3,',',D10.3,') ') )
9956 FORMAT( 1X, I4, ' - ', I4, ':', 1X,
$ 1P,2('(',D10.3,',',D10.3,') ') )
9955 FORMAT( 1X, I4, ' - ', I4, ':', 1X,
$ 1P,1('(',D10.3,',',D10.3,') ') )
*
* DISPLAY 6 SIGNIFICANT DIGITS
*
9948 FORMAT( 1X, I4, ' - ', I4, ':', 1X,
$ 1P,3('(',D12.5,',',D12.5,') ') )
9947 FORMAT( 1X, I4, ' - ', I4, ':', 1X,
$ 1P,2('(',D12.5,',',D12.5,') ') )
9946 FORMAT( 1X, I4, ' - ', I4, ':', 1X,
$ 1P,1('(',D12.5,',',D12.5,') ') )
*
* DISPLAY 8 SIGNIFICANT DIGITS
*
9938 FORMAT( 1X, I4, ' - ', I4, ':', 1X,
$ 1P,3('(',D14.7,',',D14.7,') ') )
9937 FORMAT( 1X, I4, ' - ', I4, ':', 1X,
$ 1P,2('(',D14.7,',',D14.7,') ') )
9936 FORMAT( 1X, I4, ' - ', I4, ':', 1X,
$ 1P,1('(',D14.7,',',D14.7,') ') )
*
* DISPLAY 13 SIGNIFICANT DIGITS
*
9928 FORMAT( 1X, I4, ' - ', I4, ':', 1X,
$ 1P,2('(',D20.13,',',D20.13,') ') )
9927 FORMAT( 1X, I4, ' - ', I4, ':', 1X,
$ 1P,1('(',D20.13,',',D20.13,') ') )
*
*
*
9994 FORMAT( 1X, ' ' )
END

98
arpack/README Normal file
View File

@@ -0,0 +1,98 @@
This is the ARPACK package from
http://www.caam.rice.edu/software/ARPACK/
Specifically the files are from
http://www.caam.rice.edu/software/ARPACK/SRC/arpack96.tar.gz
with the patch
http://www.caam.rice.edu/software/ARPACK/SRC/patch.tar.gz
The ARPACK README is at
http://www.caam.rice.edu/software/ARPACK/SRC/readme.arpack
---
ARPACK is a collection of Fortran77 subroutines designed to solve large
scale eigenvalue problems.
The package is designed to compute a few eigenvalues and corresponding
eigenvectors of a general n by n matrix A. It is most appropriate for large
sparse or structured matrices A where structured means that a matrix-vector
product w <- Av requires order n rather than the usual order n**2 floating
point operations. This software is based upon an algorithmic variant of the
Arnoldi process called the Implicitly Restarted Arnoldi Method (IRAM). When
the matrix A is symmetric it reduces to a variant of the Lanczos process
called the Implicitly Restarted Lanczos Method (IRLM). These variants may be
viewed as a synthesis of the Arnoldi/Lanczos process with the Implicitly
Shifted QR technique that is suitable for large scale problems. For many
standard problems, a matrix factorization is not required. Only the action
of the matrix on a vector is needed. ARPACK software is capable of solving
large scale symmetric, nonsymmetric, and generalized eigenproblems from
significant application areas. The software is designed to compute a few (k)
eigenvalues with user specified features such as those of largest real part
or largest magnitude. Storage requirements are on the order of n*k locations.
No auxiliary storage is required. A set of Schur basis vectors for the desired
k-dimensional eigen-space is computed which is numerically orthogonal to working
precision. Numerically accurate eigenvectors are available on request.
Important Features:
o Reverse Communication Interface.
o Single and Double Precision Real Arithmetic Versions for Symmetric,
Non-symmetric, Standard or Generalized Problems.
o Single and Double Precision Complex Arithmetic Versions for Standard
or Generalized Problems.
o Routines for Banded Matrices - Standard or Generalized Problems.
o Routines for The Singular Value Decomposition.
o Example driver routines that may be used as templates to implement
numerous Shift-Invert strategies for all problem types, data types
and precision.
---
The ARPACK license is BSD-like.
http://www.caam.rice.edu/software/ARPACK/RiceBSD.doc
---
Rice BSD Software License
Permits source and binary redistribution of the software ARPACK and
P_ARPACK for both non-commercial and commercial use.
Copyright (©) 2001, Rice University
Developed by D.C. Sorensen, R.B. Lehoucq, C. Yang, and K. Maschhoff.
All rights reserved.
Redistribution and use in source and binary forms, with or without
modification, are permitted provided that the following conditions are
met:
. Redistributions of source code must retain the above copyright notice,
this list of conditions and the following disclaimer.
. Redistributions in binary form must reproduce the above copyright
notice, this list of conditions and the following disclaimer in the
documentation and/or other materials provided with the distribution.
. If you modify the source for these routines we ask that you change the
name of the routine and comment the changes made to the original.
. Written notification is provided to the developers of intent to use
this software. Also, we ask that use of ARPACK is properly cited in
any resulting publications or software documentation.
. Neither the name of Rice University (RICE) nor the names of its
contributors may be used to endorse or promote products derived from
this software without specific prior written permission.
THIS SOFTWARE IS PROVIDED BY RICE AND CONTRIBUTORS "AS IS" AND ANY EXPRESS
OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE
DISCLAIMED. IN NO EVENT SHALL RICE OR CONTRIBUTORS BE LIABLE FOR ANY
DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES
(INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR
SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER
CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT
LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY
OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH
DAMAGE.

4
arpack/__init__.py Normal file
View File

@@ -0,0 +1,4 @@
from info import __doc__
from arpack import *
import speigs

381
arpack/arpack.py Normal file
View File

@@ -0,0 +1,381 @@
"""
arpack - Scipy module to find a few eigenvectors and eigenvalues of a matrix
Uses ARPACK: http://www.caam.rice.edu/software/ARPACK/
"""
__all___=['eigen','eigen_symmetric']
import _arpack
import numpy as sb
import warnings
# inspired by iterative.py
# so inspired, in fact, that some of it was copied directly
try:
False, True
except NameError:
False, True = 0, 1
_type_conv = {'f':'s', 'd':'d', 'F':'c', 'D':'z'}
class get_matvec:
methname = 'matvec'
def __init__(self, obj, *args):
self.obj = obj
self.args = args
if isinstance(obj, sb.matrix):
self.callfunc = self.type1m
return
if isinstance(obj, sb.ndarray):
self.callfunc = self.type1
return
meth = getattr(obj,self.methname,None)
if not callable(meth):
raise ValueError, "Object must be an array "\
"or have a callable %s attribute." % (self.methname,)
self.obj = meth
self.callfunc = self.type2
def __call__(self, x):
return self.callfunc(x)
def type1(self, x):
return sb.dot(self.obj, x)
def type1m(self, x):
return sb.dot(self.obj.A, x)
def type2(self, x):
return self.obj(x,*self.args)
def eigen(A,k=6,M=None,ncv=None,which='LM',
maxiter=None,tol=0, return_eigenvectors=True):
""" Return k eigenvalues and eigenvectors of the matrix A.
Solves A * x[i] = w[i] * x[i], the standard eigenvalue problem for
w[i] eigenvalues with corresponding eigenvectors x[i].
Inputs:
A -- A matrix, array or an object with matvec(x) method to perform
the matrix vector product A * x. The sparse matrix formats
in scipy.sparse are appropriate for A.
k -- The number of eigenvalue/eigenvectors desired
M -- (Not implemented)
A symmetric positive-definite matrix for the generalized
eigenvalue problem A * x = w * M * x
Outputs:
w -- An array of k eigenvalues
v -- An array of k eigenvectors, k[i] is the eigenvector corresponding
to the eigenvector w[i]
Optional Inputs:
ncv -- Number of Lanczos vectors generated, ncv must be greater than k
and is recommended to be ncv > 2*k
which -- String specifying which eigenvectors to compute.
Compute the k eigenvalues of:
'LM' - largest magnitude.
'SM' - smallest magnitude.
'LR' - largest real part.
'SR' - smallest real part.
'LI' - largest imaginary part.
'SI' - smallest imaginary part.
maxiter -- Maximum number of Arnoldi update iterations allowed
tol -- Relative accuracy for eigenvalues (stopping criterion)
return_eigenvectors -- True|False, return eigenvectors
"""
try:
n,ny=A.shape
n==ny
except:
raise AttributeError("matrix is not square")
if M is not None:
raise NotImplementedError("generalized eigenproblem not supported yet")
# some defaults
if ncv is None:
ncv=2*k+1
ncv=min(ncv,n)
if maxiter==None:
maxiter=n*10
# guess type
resid = sb.zeros(n,'f')
try:
typ = A.dtype.char
except AttributeError:
typ = A.matvec(resid).dtype.char
if typ not in 'fdFD':
raise ValueError("matrix type must be 'f', 'd', 'F', or 'D'")
# some sanity checks
if k <= 0:
raise ValueError("k must be positive, k=%d"%k)
if k == n:
raise ValueError("k must be less than rank(A), k=%d"%k)
if maxiter <= 0:
raise ValueError("maxiter must be positive, maxiter=%d"%maxiter)
whiches=['LM','SM','LR','SR','LI','SI']
if which not in whiches:
raise ValueError("which must be one of %s"%' '.join(whiches))
if ncv > n or ncv < k:
raise ValueError("ncv must be k<=ncv<=n, ncv=%s"%ncv)
# assign solver and postprocessor
ltr = _type_conv[typ]
eigsolver = _arpack.__dict__[ltr+'naupd']
eigextract = _arpack.__dict__[ltr+'neupd']
matvec = get_matvec(A)
v = sb.zeros((n,ncv),typ) # holds Ritz vectors
resid = sb.zeros(n,typ) # residual
workd = sb.zeros(3*n,typ) # workspace
workl = sb.zeros(3*ncv*ncv+6*ncv,typ) # workspace
iparam = sb.zeros(11,'int') # problem parameters
ipntr = sb.zeros(14,'int') # pointers into workspaces
info = 0
ido = 0
if typ in 'FD':
rwork = sb.zeros(ncv,typ.lower())
# only supported mode is 1: Ax=lx
ishfts = 1
mode1 = 1
bmat = 'I'
iparam[0] = ishfts
iparam[2] = maxiter
iparam[6] = mode1
while True:
if typ in 'fd':
ido,resid,v,iparam,ipntr,info =\
eigsolver(ido,bmat,which,k,tol,resid,v,iparam,ipntr,
workd,workl,info)
else:
ido,resid,v,iparam,ipntr,info =\
eigsolver(ido,bmat,which,k,tol,resid,v,iparam,ipntr,
workd,workl,rwork,info)
if (ido == -1 or ido == 1):
# compute y = A * x
xslice = slice(ipntr[0]-1, ipntr[0]-1+n)
yslice = slice(ipntr[1]-1, ipntr[1]-1+n)
workd[yslice]=matvec(workd[xslice])
else: # done
break
if info < -1 :
raise RuntimeError("Error info=%d in arpack"%info)
return None
if info == -1:
warnings.warn("Maximum number of iterations taken: %s"%iparam[2])
# if iparam[3] != k:
# warnings.warn("Only %s eigenvalues converged"%iparam[3])
# now extract eigenvalues and (optionally) eigenvectors
rvec = return_eigenvectors
ierr = 0
howmny = 'A' # return all eigenvectors
sselect = sb.zeros(ncv,'int') # unused
sigmai = 0.0 # no shifts, not implemented
sigmar = 0.0 # no shifts, not implemented
workev = sb.zeros(3*ncv,typ)
if typ in 'fd':
dr=sb.zeros(k+1,typ)
di=sb.zeros(k+1,typ)
zr=sb.zeros((n,k+1),typ)
dr,di,z,info=\
eigextract(rvec,howmny,sselect,sigmar,sigmai,workev,
bmat,which,k,tol,resid,v,iparam,ipntr,
workd,workl,info)
# make eigenvalues complex
d=dr+1.0j*di
# futz with the eigenvectors:
# complex are stored as real,imaginary in consecutive columns
z=zr.astype(typ.upper())
for i in range(k): # fix c.c. pairs
if di[i] > 0 :
z[:,i]=zr[:,i]+1.0j*zr[:,i+1]
z[:,i+1]=z[:,i].conjugate()
else:
d,z,info =\
eigextract(rvec,howmny,sselect,sigmar,workev,
bmat,which,k,tol,resid,v,iparam,ipntr,
workd,workl,rwork,ierr)
if ierr != 0:
raise RuntimeError("Error info=%d in arpack"%info)
return None
if return_eigenvectors:
return d,z
return d
def eigen_symmetric(A,k=6,M=None,ncv=None,which='LM',
maxiter=None,tol=0, return_eigenvectors=True):
""" Return k eigenvalues and eigenvectors of the real symmetric matrix A.
Solves A * x[i] = w[i] * x[i], the standard eigenvalue problem for
w[i] eigenvalues with corresponding eigenvectors x[i].
A must be real and symmetric.
See eigen() for nonsymmetric or complex symmetric (Hermetian) matrices.
Inputs:
A -- A symmetric matrix, array or an object with matvec(x) method
to perform the matrix vector product A * x.
The sparse matrix formats in scipy.sparse are appropriate for A.
k -- The number of eigenvalue/eigenvectors desired
M -- (Not implemented)
A symmetric positive-definite matrix for the generalized
eigenvalue problem A * x = w * M * x
Outputs:
w -- An real array of k eigenvalues
v -- An array of k real eigenvectors, k[i] is the eigenvector corresponding
to the eigenvector w[i]
Optional Inputs:
ncv -- Number of Lanczos vectors generated, ncv must be greater than k
and is recommended to be ncv > 2*k
which -- String specifying which eigenvectors to compute.
Compute the k
'LA' - largest (algebraic) eigenvalues.
'SA' - smallest (algebraic) eigenvalues.
'LM' - largest (in magnitude) eigenvalues.
'SM' - smallest (in magnitude) eigenvalues.
'BE' - eigenvalues, half from each end of the
spectrum. When NEV is odd, compute one more from the
high end than from the low end.
maxiter -- Maximum number of Arnoldi update iterations allowed
tol -- Relative accuracy for eigenvalues (stopping criterion)
return_eigenvectors -- True|False, return eigenvectors
"""
try:
n,ny=A.shape
n==ny
except:
raise AttributeError("matrix is not square")
if M is not None:
raise NotImplementedError("generalized eigenproblem not supported yet")
if ncv is None:
ncv=2*k+1
ncv=min(ncv,n)
if maxiter==None:
maxiter=n*10
# guess type
resid = sb.zeros(n,'f')
try:
typ = A.dtype.char
except AttributeError:
typ = A.matvec(resid).dtype.char
if typ not in 'fd':
raise ValueError("matrix type must be 'f' or 'd'")
# some sanity checks
if k <= 0:
raise ValueError("k must be positive, k=%d"%k)
if k == n:
raise ValueError("k must be less than rank(A), k=%d"%k)
if maxiter <= 0:
raise ValueError("maxiter must be positive, maxiter=%d"%maxiter)
whiches=['LM','SM','LA','SA','BE']
if which not in whiches:
raise ValueError("which must be one of %s"%' '.join(whiches))
if ncv > n or ncv < k:
raise ValueError("ncv must be k<=ncv<=n, ncv=%s"%ncv)
# assign solver and postprocessor
ltr = _type_conv[typ]
eigsolver = _arpack.__dict__[ltr+'saupd']
eigextract = _arpack.__dict__[ltr+'seupd']
matvec = get_matvec(A)
v = sb.zeros((n,ncv),typ)
resid = sb.zeros(n,typ)
workd = sb.zeros(3*n,typ)
workl = sb.zeros(ncv*(ncv+8),typ)
iparam = sb.zeros(11,'int')
ipntr = sb.zeros(11,'int')
info = 0
ido = 0
# only supported mode is 1: Ax=lx
ishfts = 1
mode1 = 1
bmat='I'
iparam[0] = ishfts
iparam[2] = maxiter
iparam[6] = mode1
while True:
ido,resid,v,iparam,ipntr,info =\
eigsolver(ido,bmat,which,k,tol,resid,v,iparam,ipntr,
workd,workl,info)
if (ido == -1 or ido == 1):
xslice = slice(ipntr[0]-1, ipntr[0]-1+n)
yslice = slice(ipntr[1]-1, ipntr[1]-1+n)
workd[yslice]=matvec(workd[xslice])
else:
break
if info < -1 :
raise RuntimeError("Error info=%d in arpack"%info)
return None
if info == -1:
warnings.warn("Maximum number of iterations taken: %s"%iparam[2])
# now extract eigenvalues and (optionally) eigenvectors
rvec = return_eigenvectors
ierr = 0
howmny = 'A' # return all eigenvectors
sselect = sb.zeros(ncv,'int') # unused
sigma = 0.0 # no shifts, not implemented
d,z,info =\
eigextract(rvec,howmny,sselect,sigma,
bmat,which, k,tol,resid,v,iparam[0:7],ipntr,
workd[0:2*n],workl,ierr)
if ierr != 0:
raise RuntimeError("Error info=%d in arpack"%info)
return None
if return_eigenvectors:
return d,z
return d

207
arpack/arpack.pyf.src Normal file
View File

@@ -0,0 +1,207 @@
! -*- f90 -*-
! Note: the context of this file is case sensitive.
python module _arpack ! in
<_rd=real,double precision>
<_cd=complex,double complex>
interface ! in :_arpack
subroutine <s,d>saupd(ido,bmat,n,which,nev,tol,resid,ncv,v,ldv,iparam,ipntr,workd,workl,lworkl,info) ! in :_arpack:src/ssaupd.f
integer intent(in,out):: ido
character*1 :: bmat
integer optional,check(len(resid)>=n),depend(resid) :: n=len(resid)
character*2 :: which
integer :: nev
<_rd> :: tol
<_rd> dimension(n),intent(in,out) :: resid
integer optional,check(shape(v,1)==ncv),depend(v) :: ncv=shape(v,1)
<_rd> dimension(ldv,ncv),intent(in,out) :: v
integer optional,check(shape(v,0)==ldv),depend(v) :: ldv=shape(v,0)
integer dimension(11),intent(in,out) :: iparam
integer dimension(11),intent(in,out) :: ipntr
<_rd> dimension(3 * n),depend(n),intent(inout) :: workd
<_rd> dimension(lworkl),intent(inout) :: workl
integer optional,check(len(workl)>=lworkl),depend(workl) :: lworkl=len(workl)
integer intent(in,out):: info
end subroutine <s,d>saupd
subroutine <s,d>seupd(rvec,howmny,select,d,z,ldz,sigma,bmat,n,which,nev,tol,resid,ncv,v,ldv,iparam,ipntr,workd,workl,lworkl,info) ! in :_arpack:src/sseupd.f
logical :: rvec
character :: howmny
logical dimension(ncv) :: select
<_rd> dimension(nev),intent(out),depend(nev) :: d
<_rd> dimension(n,nev),intent(out),depend(nev) :: z
integer optional,check(shape(z,0)==ldz),depend(z) :: ldz=shape(z,0)
<_rd> :: sigma
character :: bmat
integer optional,check(len(resid)>=n),depend(resid) :: n=len(resid)
character*2 :: which
integer :: nev
<_rd> :: tol
<_rd> dimension(n) :: resid
integer optional,check(len(select)>=ncv),depend(select) :: ncv=len(select)
<_rd> dimension(ldv,ncv),depend(ncv) :: v
integer optional,check(shape(v,0)==ldv),depend(v) :: ldv=shape(v,0)
integer dimension(7) :: iparam
integer dimension(11) :: ipntr
<_rd> dimension(2 * n),depend(n) :: workd
<_rd> dimension(lworkl) :: workl
integer optional,check(len(workl)>=lworkl),depend(workl) :: lworkl=len(workl)
integer intent(in,out):: info
end subroutine <s,d>seupd
subroutine <s,d>naupd(ido,bmat,n,which,nev,tol,resid,ncv,v,ldv,iparam,ipntr,workd,workl,lworkl,info) ! in :_arpack:src/snaupd.f
integer intent(in,out):: ido
character*1 :: bmat
integer optional,check(len(resid)>=n),depend(resid) :: n=len(resid)
character*2 :: which
integer :: nev
<_rd> :: tol
<_rd> dimension(n),intent(in,out) :: resid
integer optional,check(shape(v,1)==ncv),depend(v) :: ncv=shape(v,1)
<_rd> dimension(ldv,ncv),intent(in,out) :: v
integer optional,check(shape(v,0)==ldv),depend(v) :: ldv=shape(v,0)
integer dimension(11),intent(in,out) :: iparam
integer dimension(14),intent(in,out) :: ipntr
<_rd> dimension(3 * n),depend(n),intent(inout) :: workd
<_rd> dimension(lworkl),intent(inout) :: workl
integer optional,check(len(workl)>=lworkl),depend(workl) :: lworkl=len(workl)
integer intent(in,out):: info
end subroutine <s,d>naupd
subroutine <s,d>neupd(rvec,howmny,select,dr,di,z,ldz,sigmar,sigmai,workev,bmat,n,which,nev,tol,resid,ncv,v,ldv,iparam,ipntr,workd,workl,lworkl,info) ! in ARPACK/SRC/sneupd.f
logical :: rvec
character :: howmny
logical dimension(ncv) :: select
<_rd> dimension(nev + 1),depend(nev),intent(out) :: dr
<_rd> dimension(nev + 1),depend(nev),intent(out) :: di
<_rd> dimension(n,nev+1),depend(n,nev),intent(out) :: z
integer optional,check(shape(z,0)==ldz),depend(z) :: ldz=shape(z,0)
<_rd> :: sigmar
<_rd> :: sigmai
<_rd> dimension(3 * ncv),depend(ncv) :: workev
character :: bmat
integer optional,check(len(resid)>=n),depend(resid) :: n=len(resid)
character*2 :: which
integer :: nev
<_rd> :: tol
<_rd> dimension(n) :: resid
integer optional,check(len(select)>=ncv),depend(select) :: ncv=len(select)
<_rd> dimension(n,ncv),depend(n,ncv) :: v
integer optional,check(shape(v,0)==ldv),depend(v) :: ldv=shape(v,0)
integer dimension(11) :: iparam
integer dimension(14) :: ipntr
<_rd> dimension(3 * n),depend(n):: workd
<_rd> dimension(lworkl) :: workl
integer optional,check(len(workl)>=lworkl),depend(workl) :: lworkl=len(workl)
integer intent(in,out):: info
end subroutine <s,d>neupd
subroutine <c,z>naupd(ido,bmat,n,which,nev,tol,resid,ncv,v,ldv,iparam,ipntr,workd,workl,lworkl,rwork,info) ! in :_arpack:src/snaupd.f
integer intent(in,out):: ido
character*1 :: bmat
integer optional,check(len(resid)>=n),depend(resid) :: n=len(resid)
character*2 :: which
integer :: nev
<_rd> :: tol
<_cd> dimension(n),intent(in,out) :: resid
integer optional,check(shape(v,1)==ncv),depend(v) :: ncv=shape(v,1)
<_cd> dimension(ldv,ncv),intent(in,out) :: v
integer optional,check(shape(v,0)==ldv),depend(v) :: ldv=shape(v,0)
integer dimension(11),intent(in,out) :: iparam
integer dimension(14),intent(in,out) :: ipntr
<_cd> dimension(3 * n),depend(n),intent(inout) :: workd
<_cd> dimension(lworkl),intent(inout) :: workl
integer optional,check(len(workl)>=lworkl),depend(workl) :: lworkl=len(workl)
<_rd> dimension(ncv),depend(ncv),intent(inout) :: rwork
integer intent(in,out):: info
end subroutine <c,z>naupd
subroutine <c,z>neupd(rvec,howmny,select,d,z,ldz,sigma,workev,bmat,n,which,nev,tol,resid,ncv,v,ldv,iparam,ipntr,workd,workl,lworkl,rwork,info) ! in :_arpack:src/sneupd.f
logical :: rvec
character :: howmny
logical dimension(ncv) :: select
<_cd> dimension(nev),depend(nev),intent(out) :: d
<_cd> dimension(n,nev), depend(nev),intent(out) :: z
integer optional,check(shape(z,0)==ldz),depend(z) :: ldz=shape(z,0)
<_cd> :: sigma
<_cd> dimension(3 * ncv),depend(ncv) :: workev
character :: bmat
integer optional,check(len(resid)>=n),depend(resid) :: n=len(resid)
character*2 :: which
integer :: nev
<_rd> :: tol
<_cd> dimension(n) :: resid
integer optional,check(len(select)>=ncv),depend(select) :: ncv=len(select)
<_cd> dimension(ldv,ncv),depend(ncv) :: v
integer optional,check(shape(v,0)==ldv),depend(v) :: ldv=shape(v,0)
integer dimension(11) :: iparam
integer dimension(14) :: ipntr
<_cd> dimension(3 * n),depend(n) :: workd
<_cd> dimension(lworkl) :: workl
integer optional,check(len(workl)>=lworkl),depend(workl) :: lworkl=len(workl)
<_rd> dimension(ncv),depend(ncv) :: rwork
integer intent(in,out):: info
end subroutine <c,z>neupd
integer :: logfil
integer :: ndigit
integer :: mgetv0
integer :: msaupd
integer :: msaup2
integer :: msaitr
integer :: mseigt
integer :: msapps
integer :: msgets
integer :: mseupd
integer :: mnaupd
integer :: mnaup2
integer :: mnaitr
integer :: mneigh
integer :: mnapps
integer :: mngets
integer :: mneupd
integer :: mcaupd
integer :: mcaup2
integer :: mcaitr
integer :: mceigh
integer :: mcapps
integer :: mcgets
integer :: mceupd
integer :: nopx
integer :: nbx
integer :: nrorth
integer :: nitref
integer :: nrstrt
real :: tsaupd
real :: tsaup2
real :: tsaitr
real :: tseigt
real :: tsgets
real :: tsapps
real :: tsconv
real :: tnaupd
real :: tnaup2
real :: tnaitr
real :: tneigh
real :: tngets
real :: tnapps
real :: tnconv
real :: tcaupd
real :: tcaup2
real :: tcaitr
real :: tceigh
real :: tcgets
real :: tcapps
real :: tcconv
real :: tmvopx
real :: tmvbx
real :: tgetv0
real :: titref
real :: trvec
common /debug/ logfil,ndigit,mgetv0,msaupd,msaup2,msaitr,mseigt,msapps,msgets,mseupd,mnaupd,mnaup2,mnaitr,mneigh,mnapps,mngets,mneupd,mcaupd,mcaup2,mcaitr,mceigh,mcapps,mcgets,mceupd
common /timing/ nopx,nbx,nrorth,nitref,nrstrt,tsaupd,tsaup2,tsaitr,tseigt,tsgets,tsapps,tsconv,tnaupd,tnaup2,tnaitr,tneigh,tngets,tnapps,tnconv,tcaupd,tcaup2,tcaitr,tceigh,tcgets,tcapps,tcconv,tmvopx,tmvbx,tgetv0,titref,trvec
end interface
end python module _arpack
! This file was auto-generated with f2py (version:2_3198).
! See http://cens.ioc.ee/projects/f2py2e/

14
arpack/info.py Normal file
View File

@@ -0,0 +1,14 @@
"""
Eigenvalue solver using iterative methods.
Find k eigenvectors and eigenvalues of a matrix A using the
Arnoldi/Lanczos iterative methods from ARPACK.
These methods are most useful for large sparse matrices.
- eigen(A,k)
- eigen_symmetric(A,k)
"""
global_symbols = []
postpone_import = 1

36
arpack/setup.py Executable file
View File

@@ -0,0 +1,36 @@
#!/usr/bin/env python
from os.path import join
def configuration(parent_package='',top_path=None):
from numpy.distutils.system_info import get_info, NotFoundError
from numpy.distutils.misc_util import Configuration
lapack_opt = get_info('lapack_opt')
if not lapack_opt:
raise NotFoundError,'no lapack/blas resources found'
config = Configuration('arpack', parent_package, top_path)
arpack_sources=[join('ARPACK','SRC', '*.f')]
arpack_sources.extend([join('ARPACK','UTIL', '*.f')])
# arpack_sources.extend([join('ARPACK','BLAS', '*.f')])
arpack_sources.extend([join('ARPACK','LAPACK', '*.f')])
config.add_library('arpack', sources=arpack_sources,
include_dirs=[join('ARPACK', 'SRC')])
config.add_extension('_arpack',
sources='arpack.pyf.src',
libraries=['arpack'],
extra_info = lapack_opt
)
config.add_data_dir('tests')
return config
if __name__ == '__main__':
from numpy.distutils.core import setup
setup(**configuration(top_path='').todict())

Some files were not shown because too many files have changed in this diff Show More