216 SUBROUTINE ctrevc( SIDE, HOWMNY, SELECT, N, T, LDT, VL, LDVL, VR,
217 $ LDVR, MM, M, WORK, RWORK, INFO )
224 CHARACTER HOWMNY, SIDE
225 INTEGER INFO, LDT, LDVL, LDVR, M, MM, N
230 COMPLEX T( LDT, * ), VL( LDVL, * ), VR( LDVR, * ),
238 parameter( zero = 0.0e+0, one = 1.0e+0 )
239 COMPLEX CMZERO, CMONE
240 parameter( cmzero = ( 0.0e+0, 0.0e+0 ),
241 $ cmone = ( 1.0e+0, 0.0e+0 ) )
244 LOGICAL ALLV, BOTHV, LEFTV, OVER, RIGHTV, SOMEV
245 INTEGER I, II, IS, J, K, KI
246 REAL OVFL, REMAX, SCALE, SMIN, SMLNUM, ULP, UNFL
253 EXTERNAL lsame, icamax, scasum, slamch
259 INTRINSIC abs, aimag, cmplx, conjg, max, real
265 cabs1( cdum ) = abs( real( cdum ) ) + abs( aimag( 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(
'CTREVC', -info )
320 unfl = slamch(
'Safe minimum' )
322 ulp = slamch(
'Precision' )
323 smlnum = unfl*( n / ulp )
328 work( i+n ) = t( i, i )
336 rwork( j ) = scasum( 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 clatrs(
'Upper',
'No transpose',
'Non-unit',
'Y',
371 $ ki-1, t, ldt, work( 1 ), scale, rwork,
379 CALL ccopy( ki, work( 1 ), 1, vr( 1, is ), 1 )
381 ii = icamax( ki, vr( 1, is ), 1 )
382 remax = one / cabs1( vr( ii, is ) )
383 CALL csscal( ki, remax, vr( 1, is ), 1 )
390 $
CALL cgemv(
'N', n, ki-1, cmone, vr, ldvr, work( 1 ),
391 $ 1, cmplx( scale ), vr( 1, ki ), 1 )
393 ii = icamax( n, vr( 1, ki ), 1 )
394 remax = one / cabs1( vr( ii, ki ) )
395 CALL csscal( n, remax, vr( 1, ki ), 1 )
401 t( k, k ) = work( k+n )
416 IF( .NOT.
SELECT( ki ) )
419 smin = max( ulp*( cabs1( t( ki, ki ) ) ), smlnum )
426 work( k ) = -conjg( t( ki, k ) )
433 t( k, k ) = t( k, k ) - t( ki, ki )
434 IF( cabs1( t( k, k ) ).LT.smin )
439 CALL clatrs(
'Upper',
'Conjugate transpose',
'Non-unit',
440 $
'Y', n-ki, t( ki+1, ki+1 ), ldt,
441 $ work( ki+1 ), scale, rwork, info )
448 CALL ccopy( n-ki+1, work( ki ), 1, vl( ki, is ), 1 )
450 ii = icamax( n-ki+1, vl( ki, is ), 1 ) + ki - 1
451 remax = one / cabs1( vl( ii, is ) )
452 CALL csscal( n-ki+1, remax, vl( ki, is ), 1 )
459 $
CALL cgemv(
'N', n, n-ki, cmone, vl( 1, ki+1 ), ldvl,
460 $ work( ki+1 ), 1, cmplx( scale ),
463 ii = icamax( n, vl( 1, ki ), 1 )
464 remax = one / cabs1( vl( ii, ki ) )
465 CALL csscal( n, remax, vl( 1, ki ), 1 )
471 t( k, k ) = work( k+n )
subroutine xerbla(srname, info)
subroutine ccopy(n, cx, incx, cy, incy)
CCOPY
subroutine cgemv(trans, m, n, alpha, a, lda, x, incx, beta, y, incy)
CGEMV
subroutine clatrs(uplo, trans, diag, normin, n, a, lda, x, scale, cnorm, info)
CLATRS solves a triangular system of equations with the scale factor set to prevent overflow.
subroutine csscal(n, sa, cx, incx)
CSSCAL
subroutine ctrevc(side, howmny, select, n, t, ldt, vl, ldvl, vr, ldvr, mm, m, work, rwork, info)
CTREVC