214 SUBROUTINE ztrevc( SIDE, HOWMNY, SELECT, N, T, LDT, VL, LDVL,
216 $ LDVR, MM, M, WORK, RWORK, INFO )
223 CHARACTER HOWMNY, SIDE
224 INTEGER INFO, LDT, LDVL, LDVR, M, MM, N
228 DOUBLE PRECISION RWORK( * )
229 COMPLEX*16 T( LDT, * ), VL( LDVL, * ), VR( LDVR, * ),
236 DOUBLE PRECISION ZERO, ONE
237 PARAMETER ( ZERO = 0.0d+0, one = 1.0d+0 )
238 COMPLEX*16 CMZERO, CMONE
239 parameter( cmzero = ( 0.0d+0, 0.0d+0 ),
240 $ cmone = ( 1.0d+0, 0.0d+0 ) )
243 LOGICAL ALLV, BOTHV, LEFTV, OVER, RIGHTV, SOMEV
244 INTEGER I, II, IS, J, K, KI
245 DOUBLE PRECISION OVFL, REMAX, SCALE, SMIN, SMLNUM, ULP, UNFL
251 DOUBLE PRECISION DLAMCH, DZASUM
252 EXTERNAL lsame, izamax, dlamch, dzasum
259 INTRINSIC abs, dble, dcmplx, dconjg, dimag, max
262 DOUBLE PRECISION CABS1
265 cabs1( cdum ) = abs( dble( cdum ) ) + abs( dimag( cdum ) )
271 bothv = lsame( side,
'B' )
272 rightv = lsame( side,
'R' ) .OR. bothv
273 leftv = lsame( side,
'L' ) .OR. bothv
275 allv = lsame( howmny,
'A' )
276 over = lsame( howmny,
'B' )
277 somev = lsame( howmny,
'S' )
293 IF( .NOT.rightv .AND. .NOT.leftv )
THEN
295 ELSE IF( .NOT.allv .AND. .NOT.over .AND. .NOT.somev )
THEN
297 ELSE IF( n.LT.0 )
THEN
299 ELSE IF( ldt.LT.max( 1, n ) )
THEN
301 ELSE IF( ldvl.LT.1 .OR. ( leftv .AND. ldvl.LT.n ) )
THEN
303 ELSE IF( ldvr.LT.1 .OR. ( rightv .AND. ldvr.LT.n ) )
THEN
305 ELSE IF( mm.LT.m )
THEN
309 CALL xerbla(
'ZTREVC', -info )
320 unfl = dlamch(
'Safe minimum' )
322 ulp = dlamch(
'Precision' )
323 smlnum = unfl*( n / ulp )
328 work( i+n ) = t( i, i )
336 rwork( j ) = dzasum( j-1, t( 1, j ), 1 )
347 IF( .NOT.
SELECT( ki ) )
350 smin = max( ulp*( cabs1( t( ki, ki ) ) ), smlnum )
357 work( k ) = -t( k, ki )
364 t( k, k ) = t( k, k ) - t( ki, ki )
365 IF( cabs1( t( k, k ) ).LT.smin )
370 CALL zlatrs(
'Upper',
'No transpose',
'Non-unit',
'Y',
371 $ ki-1, t, ldt, work( 1 ), scale, rwork,
379 CALL zcopy( ki, work( 1 ), 1, vr( 1, is ), 1 )
381 ii = izamax( ki, vr( 1, is ), 1 )
382 remax = one / cabs1( vr( ii, is ) )
383 CALL zdscal( ki, remax, vr( 1, is ), 1 )
390 $
CALL zgemv(
'N', n, ki-1, cmone, vr, ldvr,
392 $ 1, dcmplx( scale ), vr( 1, ki ), 1 )
394 ii = izamax( n, vr( 1, ki ), 1 )
395 remax = one / cabs1( vr( ii, ki ) )
396 CALL zdscal( n, remax, vr( 1, ki ), 1 )
402 t( k, k ) = work( k+n )
417 IF( .NOT.
SELECT( ki ) )
420 smin = max( ulp*( cabs1( t( ki, ki ) ) ), smlnum )
427 work( k ) = -dconjg( t( ki, k ) )
434 t( k, k ) = t( k, k ) - t( ki, ki )
435 IF( cabs1( t( k, k ) ).LT.smin )
440 CALL zlatrs(
'Upper',
'Conjugate transpose',
442 $
'Y', n-ki, t( ki+1, ki+1 ), ldt,
443 $ work( ki+1 ), scale, rwork, info )
450 CALL zcopy( n-ki+1, work( ki ), 1, vl( ki, is ), 1 )
452 ii = izamax( n-ki+1, vl( ki, is ), 1 ) + ki - 1
453 remax = one / cabs1( vl( ii, is ) )
454 CALL zdscal( n-ki+1, remax, vl( ki, is ), 1 )
461 $
CALL zgemv(
'N', n, n-ki, cmone, vl( 1, ki+1 ),
463 $ work( ki+1 ), 1, dcmplx( scale ),
466 ii = izamax( n, vl( 1, ki ), 1 )
467 remax = one / cabs1( vl( ii, ki ) )
468 CALL zdscal( n, remax, vl( 1, ki ), 1 )
474 t( k, k ) = work( k+n )