218 SUBROUTINE ctrevc( SIDE, HOWMNY, SELECT, N, T, LDT, VL, LDVL, VR,
219 $ ldvr, mm, m, work, rwork, info )
227 CHARACTER howmny, side
228 INTEGER info, ldt, ldvl, ldvr, m, mm, n
233 COMPLEX t( ldt, * ), vl( ldvl, * ), vr( ldvr, * ),
241 parameter( zero = 0.0e+0, one = 1.0e+0 )
242 COMPLEX cmzero, cmone
243 parameter( cmzero = ( 0.0e+0, 0.0e+0 ),
244 $ cmone = ( 1.0e+0, 0.0e+0 ) )
247 LOGICAL allv, bothv, leftv, over, rightv, somev
248 INTEGER i, ii, is, j, k, ki
249 REAL ovfl, remax, scale, smin, smlnum, ulp, unfl
262 INTRINSIC abs, aimag, cmplx, conjg, max, real
268 cabs1( cdum ) = abs(
REAL( CDUM ) ) + abs( aimag( cdum ) )
274 bothv =
lsame( side,
'B' )
275 rightv =
lsame( side,
'R' ) .OR. bothv
276 leftv =
lsame( side,
'L' ) .OR. bothv
278 allv =
lsame( howmny,
'A' )
279 over =
lsame( howmny,
'B' )
280 somev =
lsame( howmny,
'S' )
296 IF( .NOT.rightv .AND. .NOT.leftv )
THEN
298 ELSE IF( .NOT.allv .AND. .NOT.over .AND. .NOT.somev )
THEN
300 ELSE IF( n.LT.0 )
THEN
302 ELSE IF( ldt.LT.max( 1, n ) )
THEN
304 ELSE IF( ldvl.LT.1 .OR. ( leftv .AND. ldvl.LT.n ) )
THEN
306 ELSE IF( ldvr.LT.1 .OR. ( rightv .AND. ldvr.LT.n ) )
THEN
308 ELSE IF( mm.LT.m )
THEN
312 CALL
xerbla(
'CTREVC', -info )
323 unfl =
slamch(
'Safe minimum' )
326 ulp =
slamch(
'Precision' )
327 smlnum = unfl*( n / ulp )
332 work( i+n ) = t( i, i )
340 rwork( j ) =
scasum( j-1, t( 1, j ), 1 )
351 IF( .NOT.
SELECT( ki ) )
354 smin = max( ulp*( cabs1( t( ki, ki ) ) ), smlnum )
361 work( k ) = -t( k, ki )
368 t( k, k ) = t( k, k ) - t( ki, ki )
369 IF( cabs1( t( k, k ) ).LT.smin )
374 CALL
clatrs(
'Upper',
'No transpose',
'Non-unit',
'Y',
375 $ ki-1, t, ldt, work( 1 ), scale, rwork,
383 CALL
ccopy( ki, work( 1 ), 1, vr( 1, is ), 1 )
385 ii =
icamax( ki, vr( 1, is ), 1 )
386 remax = one / cabs1( vr( ii, is ) )
387 CALL
csscal( ki, remax, vr( 1, is ), 1 )
394 $ CALL
cgemv(
'N', n, ki-1, cmone, vr, ldvr, work( 1 ),
395 $ 1, cmplx( scale ), vr( 1, ki ), 1 )
397 ii =
icamax( n, vr( 1, ki ), 1 )
398 remax = one / cabs1( vr( ii, ki ) )
399 CALL
csscal( n, remax, vr( 1, ki ), 1 )
405 t( k, k ) = work( k+n )
420 IF( .NOT.
SELECT( ki ) )
423 smin = max( ulp*( cabs1( t( ki, ki ) ) ), smlnum )
430 work( k ) = -conjg( t( ki, k ) )
437 t( k, k ) = t( k, k ) - t( ki, ki )
438 IF( cabs1( t( k, k ) ).LT.smin )
443 CALL
clatrs(
'Upper',
'Conjugate transpose',
'Non-unit',
444 $
'Y', n-ki, t( ki+1, ki+1 ), ldt,
445 $ work( ki+1 ), scale, rwork, info )
452 CALL
ccopy( n-ki+1, work( ki ), 1, vl( ki, is ), 1 )
454 ii =
icamax( n-ki+1, vl( ki, is ), 1 ) + ki - 1
455 remax = one / cabs1( vl( ii, is ) )
456 CALL
csscal( n-ki+1, remax, vl( ki, is ), 1 )
463 $ CALL
cgemv(
'N', n, n-ki, cmone, vl( 1, ki+1 ), ldvl,
464 $ work( ki+1 ), 1, cmplx( scale ),
467 ii =
icamax( n, vl( 1, ki ), 1 )
468 remax = one / cabs1( vl( ii, ki ) )
469 CALL
csscal( n, remax, vl( 1, ki ), 1 )
475 t( k, k ) = work( k+n )