207 SUBROUTINE slahqr( WANTT, WANTZ, N, ILO, IHI, H, LDH, WR, WI,
208 $ iloz, ihiz, z, ldz, info )
216 INTEGER ihi, ihiz, ilo, iloz, info, ldh, ldz, n
220 REAL h( ldh, * ), wi( * ), wr( * ), z( ldz, * )
227 parameter( itmax = 30 )
229 parameter( zero = 0.0e0, one = 1.0e0, two = 2.0e0 )
231 parameter( dat1 = 3.0e0 / 4.0e0, dat2 = -0.4375e0 )
234 REAL aa, ab, ba, bb, cs, det, h11, h12, h21, h21s,
235 $ h22, rt1i, rt1r, rt2i, rt2r, rtdisc, s, safmax,
236 $ safmin, smlnum, sn, sum, t1, t2, t3, tr, tst,
238 INTEGER i, i1, i2, its,
j, k, l, m, nh, nr, nz
251 INTRINSIC abs, max, min,
REAL, sqrt
261 IF( ilo.EQ.ihi )
THEN
262 wr( ilo ) = h( ilo, ilo )
268 DO 10
j = ilo, ihi - 3
273 $ h( ihi, ihi-2 ) = zero
280 safmin =
slamch(
'SAFE MINIMUM' )
281 safmax = one / safmin
282 CALL
slabad( safmin, safmax )
283 ulp =
slamch(
'PRECISION' )
284 smlnum = safmin*(
REAL( NH ) / ulp )
311 DO 140 its = 0, itmax
315 DO 30 k = i, l + 1, -1
316 IF( abs( h( k, k-1 ) ).LE.smlnum )
318 tst = abs( h( k-1, k-1 ) ) + abs( h( k, k ) )
319 IF( tst.EQ.zero )
THEN
321 $ tst = tst + abs( h( k-1, k-2 ) )
323 $ tst = tst + abs( h( k+1, k ) )
329 IF( abs( h( k, k-1 ) ).LE.ulp*tst )
THEN
330 ab = max( abs( h( k, k-1 ) ), abs( h( k-1, k ) ) )
331 ba = min( abs( h( k, k-1 ) ), abs( h( k-1, k ) ) )
332 aa = max( abs( h( k, k ) ),
333 $ abs( h( k-1, k-1 )-h( k, k ) ) )
334 bb = min( abs( h( k, k ) ),
335 $ abs( h( k-1, k-1 )-h( k, k ) ) )
337 IF( ba*( ab / s ).LE.max( smlnum,
338 $ ulp*( bb*( aa / s ) ) ) )go to 40
359 IF( .NOT.wantt )
THEN
368 s = abs( h( l+1, l ) ) + abs( h( l+2, l+1 ) )
369 h11 = dat1*s + h( l, l )
373 ELSE IF( its.EQ.20 )
THEN
377 s = abs( h( i, i-1 ) ) + abs( h( i-1, i-2 ) )
378 h11 = dat1*s + h( i, i )
392 s = abs( h11 ) + abs( h12 ) + abs( h21 ) + abs( h22 )
403 tr = ( h11+h22 ) / two
404 det = ( h11-tr )*( h22-tr ) - h12*h21
405 rtdisc = sqrt( abs( det ) )
406 IF( det.GE.zero )
THEN
420 IF( abs( rt1r-h22 ).LE.abs( rt2r-h22 ) )
THEN
434 DO 50 m = i - 2, l, -1
441 s = abs( h( m, m )-rt2r ) + abs( rt2i ) + abs( h21s )
442 h21s = h( m+1, m ) / s
443 v( 1 ) = h21s*h( m, m+1 ) + ( h( m, m )-rt1r )*
444 $ ( ( h( m, m )-rt2r ) / s ) - rt1i*( rt2i / s )
445 v( 2 ) = h21s*( h( m, m )+h( m+1, m+1 )-rt1r-rt2r )
446 v( 3 ) = h21s*h( m+2, m+1 )
447 s = abs( v( 1 ) ) + abs( v( 2 ) ) + abs( v( 3 ) )
453 IF( abs( h( m, m-1 ) )*( abs( v( 2 ) )+abs( v( 3 ) ) ).LE.
454 $ ulp*abs( v( 1 ) )*( abs( h( m-1, m-1 ) )+abs( h( m,
455 $ m ) )+abs( h( m+1, m+1 ) ) ) )go to 60
474 $ CALL
scopy( nr, h( k, k-1 ), 1, v, 1 )
475 CALL
slarfg( nr, v( 1 ), v( 2 ), 1, t1 )
480 $ h( k+2, k-1 ) = zero
481 ELSE IF( m.GT.l )
THEN
486 h( k, k-1 ) = h( k, k-1 )*( one-t1 )
498 sum = h( k,
j ) + v2*h( k+1,
j ) + v3*h( k+2,
j )
499 h( k,
j ) = h( k,
j ) - sum*t1
500 h( k+1,
j ) = h( k+1,
j ) - sum*t2
501 h( k+2,
j ) = h( k+2,
j ) - sum*t3
507 DO 80
j = i1, min( k+3, i )
508 sum = h(
j, k ) + v2*h(
j, k+1 ) + v3*h(
j, k+2 )
509 h(
j, k ) = h(
j, k ) - sum*t1
510 h(
j, k+1 ) = h(
j, k+1 ) - sum*t2
511 h(
j, k+2 ) = h(
j, k+2 ) - sum*t3
519 sum = z(
j, k ) + v2*z(
j, k+1 ) + v3*z(
j, k+2 )
520 z(
j, k ) = z(
j, k ) - sum*t1
521 z(
j, k+1 ) = z(
j, k+1 ) - sum*t2
522 z(
j, k+2 ) = z(
j, k+2 ) - sum*t3
525 ELSE IF( nr.EQ.2 )
THEN
531 sum = h( k,
j ) + v2*h( k+1,
j )
532 h( k,
j ) = h( k,
j ) - sum*t1
533 h( k+1,
j ) = h( k+1,
j ) - sum*t2
540 sum = h(
j, k ) + v2*h(
j, k+1 )
541 h(
j, k ) = h(
j, k ) - sum*t1
542 h(
j, k+1 ) = h(
j, k+1 ) - sum*t2
549 DO 120
j = iloz, ihiz
550 sum = z(
j, k ) + v2*z(
j, k+1 )
551 z(
j, k ) = z(
j, k ) - sum*t1
552 z(
j, k+1 ) = z(
j, k+1 ) - sum*t2
573 ELSE IF( l.EQ.i-1 )
THEN
580 CALL
slanv2( h( i-1, i-1 ), h( i-1, i ), h( i, i-1 ),
581 $ h( i, i ), wr( i-1 ), wi( i-1 ), wr( i ), wi( i ),
589 $ CALL
srot( i2-i, h( i-1, i+1 ), ldh, h( i, i+1 ), ldh,
591 CALL
srot( i-i1-1, h( i1, i-1 ), 1, h( i1, i ), 1, cs, sn )
597 CALL
srot( nz, z( iloz, i-1 ), 1, z( iloz, i ), 1, cs, sn )
REAL function slamch(CMACH)
SLAMCH
subroutine slanv2(A, B, C, D, RT1R, RT1I, RT2R, RT2I, CS, SN)
SLANV2 computes the Schur factorization of a real 2-by-2 nonsymmetric matrix in standard form...
subroutine slahqr(WANTT, WANTZ, N, ILO, IHI, H, LDH, WR, WI, ILOZ, IHIZ, Z, LDZ, INFO)
SLAHQR computes the eigenvalues and Schur factorization of an upper Hessenberg matrix, using the double-shift/single-shift QR algorithm.
subroutine scopy(N, SX, INCX, SY, INCY)
SCOPY
subroutine slarfg(N, ALPHA, X, INCX, TAU)
SLARFG generates an elementary reflector (Householder matrix).
set ue cd $ADTTMP cat<< EOF > tmp f Program LinearEquations Implicit none Real j
subroutine slabad(SMALL, LARGE)
SLABAD
subroutine srot(N, SX, INCX, SY, INCY, C, S)
SROT