262 SUBROUTINE dtrsna( 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 DOUBLE PRECISION S( * ), SEP( * ), T( LDT, * ), VL( LDVL, * ),
278 $ vr( ldvr, * ), work( ldwork, * )
284 DOUBLE PRECISION ZERO, ONE, TWO
285 PARAMETER ( ZERO = 0.0d+0, one = 1.0d+0, two = 2.0d+0 )
288 LOGICAL PAIR, SOMCON, WANTBH, WANTS, WANTSP
289 INTEGER I, IERR, IFST, ILST, J, K, KASE, KS, N2, NN
290 DOUBLE PRECISION BIGNUM, COND, CS, DELTA, DUMM, EPS, EST, LNRM,
291 $ mu, prod, prod1, prod2, rnrm, scale, smlnum, sn
295 DOUBLE PRECISION DUMMY( 1 )
299 DOUBLE PRECISION DDOT, DLAMCH, DLAPY2, DNRM2
300 EXTERNAL lsame, ddot, dlamch, dlapy2, dnrm2
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(
'DTRSNA', -info )
380 IF( .NOT.
SELECT( 1 ) )
386 $ sep( 1 ) = abs( t( 1, 1 ) )
393 smlnum = dlamch(
'S' ) / eps
394 bignum = one / smlnum
395 CALL dlabad( smlnum, bignum )
408 $ pair = t( k+1, k ).NE.zero
416 IF( .NOT.
SELECT( k ) .AND. .NOT.
SELECT( k+1 ) )
419 IF( .NOT.
SELECT( k ) )
435 prod = ddot( n, vr( 1, ks ), 1, vl( 1, ks ), 1 )
436 rnrm = dnrm2( n, vr( 1, ks ), 1 )
437 lnrm = dnrm2( n, vl( 1, ks ), 1 )
438 s( ks ) = abs( prod ) / ( rnrm*lnrm )
443 prod1 = ddot( n, vr( 1, ks ), 1, vl( 1, ks ), 1 )
444 prod1 = prod1 + ddot( n, vr( 1, ks+1 ), 1, vl( 1, ks+1 ),
446 prod2 = ddot( n, vl( 1, ks ), 1, vr( 1, ks+1 ), 1 )
447 prod2 = prod2 - ddot( n, vl( 1, ks+1 ), 1, vr( 1, ks ),
449 rnrm = dlapy2( dnrm2( n, vr( 1, ks ), 1 ),
450 $ dnrm2( n, vr( 1, ks+1 ), 1 ) )
451 lnrm = dlapy2( dnrm2( n, vl( 1, ks ), 1 ),
452 $ dnrm2( n, vl( 1, ks+1 ), 1 ) )
453 cond = dlapy2( prod1, prod2 ) / ( rnrm*lnrm )
467 CALL dlacpy(
'Full', n, n, t, ldt, work, ldwork )
470 CALL dtrexc(
'No Q', n, work, ldwork, dummy, 1, ifst, ilst,
471 $ work( 1, n+1 ), ierr )
473 IF( ierr.EQ.1 .OR. ierr.EQ.2 )
THEN
483 IF( work( 2, 1 ).EQ.zero )
THEN
488 work( i, i ) = work( i, i ) - work( 1, 1 )
502 mu = sqrt( abs( work( 1, 2 ) ) )*
503 $ sqrt( abs( work( 2, 1 ) ) )
504 delta = dlapy2( mu, work( 2, 1 ) )
506 sn = -work( 2, 1 ) / delta
520 work( 2, j ) = cs*work( 2, j )
521 work( j, j ) = work( j, j ) - work( 1, 1 )
525 work( 1, n+1 ) = two*mu
527 work( i, n+1 ) = sn*work( 1, i+1 )
538 CALL dlacn2( nn, work( 1, n+2 ), work( 1, n+4 ), iwork,
546 CALL dlaqtr( .true., .true., n-1, work( 2, 2 ),
547 $ ldwork, dummy, dumm, scale,
548 $ work( 1, n+4 ), work( 1, n+6 ),
555 CALL dlaqtr( .true., .false., n-1, work( 2, 2 ),
556 $ ldwork, work( 1, n+1 ), mu, scale,
557 $ work( 1, n+4 ), work( 1, n+6 ),
565 CALL dlaqtr( .false., .true., n-1, work( 2, 2 ),
566 $ ldwork, dummy, dumm, scale,
567 $ work( 1, n+4 ), work( 1, n+6 ),
574 CALL dlaqtr( .false., .false., n-1,
575 $ work( 2, 2 ), ldwork,
576 $ work( 1, n+1 ), mu, scale,
577 $ work( 1, n+4 ), work( 1, n+6 ),
587 sep( ks ) = scale / max( est, smlnum )
589 $ sep( ks+1 ) = sep( ks )
subroutine dlabad(SMALL, LARGE)
DLABAD
subroutine dlacpy(UPLO, M, N, A, LDA, B, LDB)
DLACPY copies all or part of one two-dimensional array to another.
subroutine xerbla(SRNAME, INFO)
XERBLA
subroutine dlaqtr(LTRAN, LREAL, N, T, LDT, B, W, SCALE, X, WORK, INFO)
DLAQTR solves a real quasi-triangular system of equations, or a complex quasi-triangular system of sp...
subroutine dlacn2(N, V, X, ISGN, EST, KASE, ISAVE)
DLACN2 estimates the 1-norm of a square matrix, using reverse communication for evaluating matrix-vec...
subroutine dtrexc(COMPQ, N, T, LDT, Q, LDQ, IFST, ILST, WORK, INFO)
DTREXC
subroutine dtrsna(JOB, HOWMNY, SELECT, N, T, LDT, VL, LDVL, VR, LDVR, S, SEP, MM, M, WORK, LDWORK, IWORK, INFO)
DTRSNA