205 SUBROUTINE slahqr( WANTT, WANTZ, N, ILO, IHI, H, LDH, WR, WI,
206 $ ILOZ, IHIZ, Z, LDZ, INFO )
214 INTEGER IHI, IHIZ, ILO, ILOZ, INFO, LDH, LDZ, N
218 REAL H( LDH, * ), WI( * ), WR( * ), Z( LDZ, * )
225 parameter( zero = 0.0e0, one = 1.0e0, two = 2.0e0 )
227 parameter( dat1 = 3.0e0 / 4.0e0, dat2 = -0.4375e0 )
229 parameter( kexsh = 10 )
232 REAL AA, AB, BA, BB, CS, DET, H11, H12, H21, H21S,
233 $ h22, rt1i, rt1r, rt2i, rt2r, rtdisc, s, safmax,
234 $ safmin, smlnum, sn, sum, t1, t2, t3, tr, tst,
236 INTEGER I, I1, I2, ITS, ITMAX, J, K, L, M, NH, NR, NZ,
250 INTRINSIC abs, max, min, real, sqrt
260 IF( ilo.EQ.ihi )
THEN
261 wr( ilo ) = h( ilo, ilo )
267 DO 10 j = ilo, ihi - 3
272 $ h( ihi, ihi-2 ) = zero
279 safmin = slamch(
'SAFE MINIMUM' )
280 safmax = one / safmin
281 CALL slabad( safmin, safmax )
282 ulp = slamch(
'PRECISION' )
283 smlnum = safmin*( real( nh ) / ulp )
296 itmax = 30 * max( 10, nh )
318 DO 140 its = 0, itmax
322 DO 30 k = i, l + 1, -1
323 IF( abs( h( k, k-1 ) ).LE.smlnum )
325 tst = abs( h( k-1, k-1 ) ) + abs( h( k, k ) )
326 IF( tst.EQ.zero )
THEN
328 $ tst = tst + abs( h( k-1, k-2 ) )
330 $ tst = tst + abs( h( k+1, k ) )
336 IF( abs( h( k, k-1 ) ).LE.ulp*tst )
THEN
337 ab = max( abs( h( k, k-1 ) ), abs( h( k-1, k ) ) )
338 ba = min( abs( h( k, k-1 ) ), abs( h( k-1, k ) ) )
339 aa = max( abs( h( k, k ) ),
340 $ abs( h( k-1, k-1 )-h( k, k ) ) )
341 bb = min( abs( h( k, k ) ),
342 $ abs( h( k-1, k-1 )-h( k, k ) ) )
344 IF( ba*( ab / s ).LE.max( smlnum,
345 $ ulp*( bb*( aa / s ) ) ) )
GO TO 40
367 IF( .NOT.wantt )
THEN
372 IF( mod(kdefl,2*kexsh).EQ.0 )
THEN
376 s = abs( h( i, i-1 ) ) + abs( h( i-1, i-2 ) )
377 h11 = dat1*s + h( i, i )
381 ELSE IF( mod(kdefl,kexsh).EQ.0 )
THEN
385 s = abs( h( l+1, l ) ) + abs( h( l+2, l+1 ) )
386 h11 = dat1*s + h( l, l )
400 s = abs( h11 ) + abs( h12 ) + abs( h21 ) + abs( h22 )
411 tr = ( h11+h22 ) / two
412 det = ( h11-tr )*( h22-tr ) - h12*h21
413 rtdisc = sqrt( abs( det ) )
414 IF( det.GE.zero )
THEN
428 IF( abs( rt1r-h22 ).LE.abs( rt2r-h22 ) )
THEN
442 DO 50 m = i - 2, l, -1
449 s = abs( h( m, m )-rt2r ) + abs( rt2i ) + abs( h21s )
450 h21s = h( m+1, m ) / s
451 v( 1 ) = h21s*h( m, m+1 ) + ( h( m, m )-rt1r )*
452 $ ( ( h( m, m )-rt2r ) / s ) - rt1i*( rt2i / s )
453 v( 2 ) = h21s*( h( m, m )+h( m+1, m+1 )-rt1r-rt2r )
454 v( 3 ) = h21s*h( m+2, m+1 )
455 s = abs( v( 1 ) ) + abs( v( 2 ) ) + abs( v( 3 ) )
461 IF( abs( h( m, m-1 ) )*( abs( v( 2 ) )+abs( v( 3 ) ) ).LE.
462 $ ulp*abs( v( 1 ) )*( abs( h( m-1, m-1 ) )+abs( h( m,
463 $ m ) )+abs( h( m+1, m+1 ) ) ) )
GO TO 60
482 $
CALL scopy( nr, h( k, k-1 ), 1, v, 1 )
483 CALL slarfg( nr, v( 1 ), v( 2 ), 1, t1 )
488 $ h( k+2, k-1 ) = zero
489 ELSE IF( m.GT.l )
THEN
494 h( k, k-1 ) = h( k, k-1 )*( one-t1 )
506 sum = h( k, j ) + v2*h( k+1, j ) + v3*h( k+2, j )
507 h( k, j ) = h( k, j ) - sum*t1
508 h( k+1, j ) = h( k+1, j ) - sum*t2
509 h( k+2, j ) = h( k+2, j ) - sum*t3
515 DO 80 j = i1, min( k+3, i )
516 sum = h( j, k ) + v2*h( j, k+1 ) + v3*h( j, k+2 )
517 h( j, k ) = h( j, k ) - sum*t1
518 h( j, k+1 ) = h( j, k+1 ) - sum*t2
519 h( j, k+2 ) = h( j, k+2 ) - sum*t3
527 sum = z( j, k ) + v2*z( j, k+1 ) + v3*z( j, k+2 )
528 z( j, k ) = z( j, k ) - sum*t1
529 z( j, k+1 ) = z( j, k+1 ) - sum*t2
530 z( j, k+2 ) = z( j, k+2 ) - sum*t3
533 ELSE IF( nr.EQ.2 )
THEN
539 sum = h( k, j ) + v2*h( k+1, j )
540 h( k, j ) = h( k, j ) - sum*t1
541 h( k+1, j ) = h( k+1, j ) - sum*t2
548 sum = h( j, k ) + v2*h( j, k+1 )
549 h( j, k ) = h( j, k ) - sum*t1
550 h( j, k+1 ) = h( j, k+1 ) - sum*t2
557 DO 120 j = iloz, ihiz
558 sum = z( j, k ) + v2*z( j, k+1 )
559 z( j, k ) = z( j, k ) - sum*t1
560 z( j, k+1 ) = z( j, k+1 ) - sum*t2
581 ELSE IF( l.EQ.i-1 )
THEN
588 CALL slanv2( h( i-1, i-1 ), h( i-1, i ), h( i, i-1 ),
589 $ h( i, i ), wr( i-1 ), wi( i-1 ), wr( i ), wi( i ),
597 $
CALL srot( i2-i, h( i-1, i+1 ), ldh, h( i, i+1 ), ldh,
599 CALL srot( i-i1-1, h( i1, i-1 ), 1, h( i1, i ), 1, cs, sn )
605 CALL srot( nz, z( iloz, i-1 ), 1, z( iloz, i ), 1, cs, sn )
subroutine slabad(SMALL, LARGE)
SLABAD
subroutine slarfg(N, ALPHA, X, INCX, TAU)
SLARFG generates an elementary reflector (Householder matrix).
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,...
subroutine srot(N, SX, INCX, SY, INCY, C, S)
SROT
subroutine scopy(N, SX, INCX, SY, INCY)
SCOPY