262 SUBROUTINE strsna( JOB, HOWMNY, SELECT, N, T, LDT, VL, LDVL, VR,
263 $ LDVR, S, SEP, MM, M, WORK, LDWORK, IWORK,
271 CHARACTER HOWMNY, JOB
272 INTEGER INFO, LDT, LDVL, LDVR, LDWORK, M, MM, N
277 REAL S( * ), SEP( * ), T( LDT, * ), VL( LDVL, * ),
278 $ vr( ldvr, * ), work( ldwork, * )
285 PARAMETER ( ZERO = 0.0e+0, one = 1.0e+0, two = 2.0e+0 )
288 LOGICAL PAIR, SOMCON, WANTBH, WANTS, WANTSP
289 INTEGER I, IERR, IFST, ILST, J, K, KASE, KS, N2, NN
290 REAL BIGNUM, COND, CS, DELTA, DUMM, EPS, EST, LNRM,
291 $ mu, prod, prod1, prod2, rnrm, scale, smlnum, sn
299 REAL SDOT, SLAMCH, SLAPY2, SNRM2
300 EXTERNAL lsame, sdot, slamch, slapy2, snrm2
306 INTRINSIC abs, max, sqrt
312 wantbh = lsame( job,
'B' )
313 wants = lsame( job,
'E' ) .OR. wantbh
314 wantsp = lsame( job,
'V' ) .OR. wantbh
316 somcon = lsame( howmny,
'S' )
319 IF( .NOT.wants .AND. .NOT.wantsp )
THEN
321 ELSE IF( .NOT.lsame( howmny,
'A' ) .AND. .NOT.somcon )
THEN
323 ELSE IF( n.LT.0 )
THEN
325 ELSE IF( ldt.LT.max( 1, n ) )
THEN
327 ELSE IF( ldvl.LT.1 .OR. ( wants .AND. ldvl.LT.n ) )
THEN
329 ELSE IF( ldvr.LT.1 .OR. ( wants .AND. ldvr.LT.n ) )
THEN
344 IF( t( k+1, k ).EQ.zero )
THEN
349 IF(
SELECT( k ) .OR.
SELECT( k+1 ) )
364 ELSE IF( ldwork.LT.1 .OR. ( wantsp .AND. ldwork.LT.n ) )
THEN
369 CALL xerbla(
'STRSNA', -info )
380 IF( .NOT.
SELECT( 1 ) )
386 $ sep( 1 ) = abs( t( 1, 1 ) )
393 smlnum = slamch(
'S' ) / eps
394 bignum = one / smlnum
407 $ pair = t( k+1, k ).NE.zero
415 IF( .NOT.
SELECT( k ) .AND. .NOT.
SELECT( k+1 ) )
418 IF( .NOT.
SELECT( k ) )
434 prod = sdot( n, vr( 1, ks ), 1, vl( 1, ks ), 1 )
435 rnrm = snrm2( n, vr( 1, ks ), 1 )
436 lnrm = snrm2( n, vl( 1, ks ), 1 )
437 s( ks ) = abs( prod ) / ( rnrm*lnrm )
442 prod1 = sdot( n, vr( 1, ks ), 1, vl( 1, ks ), 1 )
443 prod1 = prod1 + sdot( n, vr( 1, ks+1 ), 1, vl( 1, ks+1 ),
445 prod2 = sdot( n, vl( 1, ks ), 1, vr( 1, ks+1 ), 1 )
446 prod2 = prod2 - sdot( n, vl( 1, ks+1 ), 1, vr( 1, ks ),
448 rnrm = slapy2( snrm2( n, vr( 1, ks ), 1 ),
449 $ snrm2( n, vr( 1, ks+1 ), 1 ) )
450 lnrm = slapy2( snrm2( n, vl( 1, ks ), 1 ),
451 $ snrm2( n, vl( 1, ks+1 ), 1 ) )
452 cond = slapy2( prod1, prod2 ) / ( rnrm*lnrm )
466 CALL slacpy(
'Full', n, n, t, ldt, work, ldwork )
469 CALL strexc(
'No Q', n, work, ldwork, dummy, 1, ifst, ilst,
470 $ work( 1, n+1 ), ierr )
472 IF( ierr.EQ.1 .OR. ierr.EQ.2 )
THEN
482 IF( work( 2, 1 ).EQ.zero )
THEN
487 work( i, i ) = work( i, i ) - work( 1, 1 )
501 mu = sqrt( abs( work( 1, 2 ) ) )*
502 $ sqrt( abs( work( 2, 1 ) ) )
503 delta = slapy2( mu, work( 2, 1 ) )
505 sn = -work( 2, 1 ) / delta
519 work( 2, j ) = cs*work( 2, j )
520 work( j, j ) = work( j, j ) - work( 1, 1 )
524 work( 1, n+1 ) = two*mu
526 work( i, n+1 ) = sn*work( 1, i+1 )
537 CALL slacn2( nn, work( 1, n+2 ), work( 1, n+4 ), iwork,
545 CALL slaqtr( .true., .true., n-1, work( 2, 2 ),
546 $ ldwork, dummy, dumm, scale,
547 $ work( 1, n+4 ), work( 1, n+6 ),
554 CALL slaqtr( .true., .false., n-1, work( 2, 2 ),
555 $ ldwork, work( 1, n+1 ), mu, scale,
556 $ work( 1, n+4 ), work( 1, n+6 ),
564 CALL slaqtr( .false., .true., n-1, work( 2, 2 ),
565 $ ldwork, dummy, dumm, scale,
566 $ work( 1, n+4 ), work( 1, n+6 ),
573 CALL slaqtr( .false., .false., n-1,
574 $ work( 2, 2 ), ldwork,
575 $ work( 1, n+1 ), mu, scale,
576 $ work( 1, n+4 ), work( 1, n+6 ),
586 sep( ks ) = scale / max( est, smlnum )
588 $ sep( ks+1 ) = sep( ks )
subroutine xerbla(srname, info)
subroutine slacn2(n, v, x, isgn, est, kase, isave)
SLACN2 estimates the 1-norm of a square matrix, using reverse communication for evaluating matrix-vec...
subroutine slacpy(uplo, m, n, a, lda, b, ldb)
SLACPY copies all or part of one two-dimensional array to another.
subroutine slaqtr(ltran, lreal, n, t, ldt, b, w, scale, x, work, info)
SLAQTR solves a real quasi-triangular system of equations, or a complex quasi-triangular system of sp...
subroutine strexc(compq, n, t, ldt, q, ldq, ifst, ilst, work, info)
STREXC
subroutine strsna(job, howmny, select, n, t, ldt, vl, ldvl, vr, ldvr, s, sep, mm, m, work, ldwork, iwork, info)
STRSNA