522 lines
18 KiB
Fortran
522 lines
18 KiB
Fortran
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
|