248 SUBROUTINE ztrsna( JOB, HOWMNY, SELECT, N, T, LDT, VL, LDVL, VR,
249 $ ldvr, s, sep, mm, m, work, ldwork, rwork,
258 CHARACTER howmny, job
259 INTEGER info, ldt, ldvl, ldvr, ldwork, m, mm, n
263 DOUBLE PRECISION rwork( * ), s( * ), sep( * )
264 COMPLEX*16 t( ldt, * ), vl( ldvl, * ), vr( ldvr, * ),
271 DOUBLE PRECISION zero, one
272 parameter( zero = 0.0d+0, one = 1.0d0+0 )
275 LOGICAL somcon, wantbh, wants, wantsp
277 INTEGER i, ierr, ix, j, k, kase, ks
278 DOUBLE PRECISION bignum, eps, est, lnrm, rnrm, scale, smlnum,
280 COMPLEX*16 cdum, prod
284 COMPLEX*16 dummy( 1 )
297 INTRINSIC abs, dble, dimag, max
300 DOUBLE PRECISION cabs1
303 cabs1( cdum ) = abs( dble( cdum ) ) + abs( dimag( cdum ) )
309 wantbh =
lsame( job,
'B' )
310 wants =
lsame( job,
'E' ) .OR. wantbh
311 wantsp =
lsame( job,
'V' ) .OR. wantbh
313 somcon =
lsame( howmny,
'S' )
329 IF( .NOT.wants .AND. .NOT.wantsp )
THEN
331 ELSE IF( .NOT.
lsame( howmny,
'A' ) .AND. .NOT.somcon )
THEN
333 ELSE IF( n.LT.0 )
THEN
335 ELSE IF( ldt.LT.max( 1, n ) )
THEN
337 ELSE IF( ldvl.LT.1 .OR. ( wants .AND. ldvl.LT.n ) )
THEN
339 ELSE IF( ldvr.LT.1 .OR. ( wants .AND. ldvr.LT.n ) )
THEN
341 ELSE IF( mm.LT.m )
THEN
343 ELSE IF( ldwork.LT.1 .OR. ( wantsp .AND. ldwork.LT.n ) )
THEN
347 CALL
xerbla(
'ZTRSNA', -info )
358 IF( .NOT.
SELECT( 1 ) )
364 $ sep( 1 ) = abs( t( 1, 1 ) )
371 smlnum =
dlamch(
'S' ) / eps
372 bignum = one / smlnum
373 CALL
dlabad( smlnum, bignum )
379 IF( .NOT.
SELECT( k ) )
388 prod =
zdotc( n, vr( 1, ks ), 1, vl( 1, ks ), 1 )
389 rnrm =
dznrm2( n, vr( 1, ks ), 1 )
390 lnrm =
dznrm2( n, vl( 1, ks ), 1 )
391 s( ks ) = abs( prod ) / ( rnrm*lnrm )
403 CALL
zlacpy(
'Full', n, n, t, ldt, work, ldwork )
404 CALL
ztrexc(
'No Q', n, work, ldwork, dummy, 1, k, 1, ierr )
409 work( i, i ) = work( i, i ) - work( 1, 1 )
420 CALL
zlacn2( n-1, work( 1, n+1 ), work, est, kase, isave )
427 CALL
zlatrs(
'Upper',
'Conjugate transpose',
428 $
'Nonunit', normin, n-1, work( 2, 2 ),
429 $ ldwork, work, scale, rwork, ierr )
434 CALL
zlatrs(
'Upper',
'No transpose',
'Nonunit',
435 $ normin, n-1, work( 2, 2 ), ldwork, work,
436 $ scale, rwork, ierr )
439 IF( scale.NE.one )
THEN
444 ix =
izamax( n-1, work, 1 )
445 xnorm = cabs1( work( ix, 1 ) )
446 IF( scale.LT.xnorm*smlnum .OR. scale.EQ.zero )
448 CALL
zdrscl( n, scale, work, 1 )
453 sep( ks ) = one / max( est, smlnum )