138 SUBROUTINE slaexc( WANTQ, N, T, LDT, Q, LDQ, J1, N1, N2, WORK,
148 INTEGER info, j1, ldq, ldt, n, n1, n2
151 REAL q( ldq, * ), t( ldt, * ), work( * )
158 parameter( zero = 0.0e+0, one = 1.0e+0 )
160 parameter( ten = 1.0e+1 )
162 parameter( ldd = 4, ldx = 2 )
165 INTEGER ierr, j2, j3, j4, k, nd
166 REAL cs, dnorm, eps, scale, smlnum, sn, t11, t22,
167 $ t33, tau, tau1, tau2, temp, thresh, wi1, wi2,
171 REAL d( ldd, 4 ), u( 3 ), u1( 3 ), u2( 3 ),
191 IF( n.EQ.0 .OR. n1.EQ.0 .OR. n2.EQ.0 )
200 IF( n1.EQ.1 .AND. n2.EQ.1 )
THEN
209 CALL
slartg( t( j1, j2 ), t22-t11, cs, sn, temp )
214 $ CALL
srot( n-j1-1, t( j1, j3 ), ldt, t( j2, j3 ), ldt, cs,
216 CALL
srot( j1-1, t( 1, j1 ), 1, t( 1, j2 ), 1, cs, sn )
225 CALL
srot( n, q( 1, j1 ), 1, q( 1, j2 ), 1, cs, sn )
236 CALL
slacpy(
'Full', nd, nd, t( j1, j1 ), ldt, d, ldd )
237 dnorm =
slange(
'Max', nd, nd, d, ldd, work )
243 smlnum =
slamch(
'S' ) / eps
244 thresh = max( ten*eps*dnorm, smlnum )
248 CALL
slasy2( .false., .false., -1, n1, n2, d, ldd,
249 $ d( n1+1, n1+1 ), ldd, d( 1, n1+1 ), ldd, scale,
x,
266 CALL
slarfg( 3, u( 3 ), u, 1, tau )
272 CALL
slarfx(
'L', 3, 3, u, tau, d, ldd, work )
273 CALL
slarfx(
'R', 3, 3, u, tau, d, ldd, work )
277 IF( max( abs( d( 3, 1 ) ), abs( d( 3, 2 ) ), abs( d( 3,
278 $ 3 )-t11 ) ).GT.thresh )go to 50
282 CALL
slarfx(
'L', 3, n-j1+1, u, tau, t( j1, j1 ), ldt, work )
283 CALL
slarfx(
'R', j2, 3, u, tau, t( 1, j1 ), ldt, work )
293 CALL
slarfx(
'R', n, 3, u, tau, q( 1, j1 ), ldq, work )
308 CALL
slarfg( 3, u( 1 ), u( 2 ), 1, tau )
314 CALL
slarfx(
'L', 3, 3, u, tau, d, ldd, work )
315 CALL
slarfx(
'R', 3, 3, u, tau, d, ldd, work )
319 IF( max( abs( d( 2, 1 ) ), abs( d( 3, 1 ) ), abs( d( 1,
320 $ 1 )-t33 ) ).GT.thresh )go to 50
324 CALL
slarfx(
'R', j3, 3, u, tau, t( 1, j1 ), ldt, work )
325 CALL
slarfx(
'L', 3, n-j1, u, tau, t( j1, j2 ), ldt, work )
335 CALL
slarfx(
'R', n, 3, u, tau, q( 1, j1 ), ldq, work )
352 CALL
slarfg( 3, u1( 1 ), u1( 2 ), 1, tau1 )
355 temp = -tau1*(
x( 1, 2 )+u1( 2 )*
x( 2, 2 ) )
356 u2( 1 ) = -temp*u1( 2 ) -
x( 2, 2 )
357 u2( 2 ) = -temp*u1( 3 )
359 CALL
slarfg( 3, u2( 1 ), u2( 2 ), 1, tau2 )
364 CALL
slarfx(
'L', 3, 4, u1, tau1, d, ldd, work )
365 CALL
slarfx(
'R', 4, 3, u1, tau1, d, ldd, work )
366 CALL
slarfx(
'L', 3, 4, u2, tau2, d( 2, 1 ), ldd, work )
367 CALL
slarfx(
'R', 4, 3, u2, tau2, d( 1, 2 ), ldd, work )
371 IF( max( abs( d( 3, 1 ) ), abs( d( 3, 2 ) ), abs( d( 4, 1 ) ),
372 $ abs( d( 4, 2 ) ) ).GT.thresh )go to 50
376 CALL
slarfx(
'L', 3, n-j1+1, u1, tau1, t( j1, j1 ), ldt, work )
377 CALL
slarfx(
'R', j4, 3, u1, tau1, t( 1, j1 ), ldt, work )
378 CALL
slarfx(
'L', 3, n-j1+1, u2, tau2, t( j2, j1 ), ldt, work )
379 CALL
slarfx(
'R', j4, 3, u2, tau2, t( 1, j2 ), ldt, work )
390 CALL
slarfx(
'R', n, 3, u1, tau1, q( 1, j1 ), ldq, work )
391 CALL
slarfx(
'R', n, 3, u2, tau2, q( 1, j2 ), ldq, work )
400 CALL
slanv2( t( j1, j1 ), t( j1, j2 ), t( j2, j1 ),
401 $ t( j2, j2 ), wr1, wi1, wr2, wi2, cs, sn )
402 CALL
srot( n-j1-1, t( j1, j1+2 ), ldt, t( j2, j1+2 ), ldt,
404 CALL
srot( j1-1, t( 1, j1 ), 1, t( 1, j2 ), 1, cs, sn )
406 $ CALL
srot( n, q( 1, j1 ), 1, q( 1, j2 ), 1, cs, sn )
415 CALL
slanv2( t( j3, j3 ), t( j3, j4 ), t( j4, j3 ),
416 $ t( j4, j4 ), wr1, wi1, wr2, wi2, cs, sn )
418 $ CALL
srot( n-j3-1, t( j3, j3+2 ), ldt, t( j4, j3+2 ),
420 CALL
srot( j3-1, t( 1, j3 ), 1, t( 1, j4 ), 1, cs, sn )
422 $ CALL
srot( n, q( 1, j3 ), 1, q( 1, j4 ), 1, cs, sn )
subroutine slarfx(SIDE, M, N, V, TAU, C, LDC, WORK)
SLARFX applies an elementary reflector to a general rectangular matrix, with loop unrolling when the ...
REAL function slamch(CMACH)
SLAMCH
subroutine slanv2(A, B, C, D, RT1R, RT1I, RT2R, RT2I, CS, SN)
SLANV2 computes the Schur factorization of a real 2-by-2 nonsymmetric matrix in standard form...
subroutine slasy2(LTRANL, LTRANR, ISGN, N1, N2, TL, LDTL, TR, LDTR, B, LDB, SCALE, X, LDX, XNORM, INFO)
SLASY2 solves the Sylvester matrix equation where the matrices are of order 1 or 2.
subroutine slacpy(UPLO, M, N, A, LDA, B, LDB)
SLACPY copies all or part of one two-dimensional array to another.
REAL function slange(NORM, M, N, A, LDA, WORK)
SLANGE returns the value of the 1-norm, Frobenius norm, infinity-norm, or the largest absolute value ...
subroutine slarfg(N, ALPHA, X, INCX, TAU)
SLARFG generates an elementary reflector (Householder matrix).
subroutine slaexc(WANTQ, N, T, LDT, Q, LDQ, J1, N1, N2, WORK, INFO)
SLAEXC swaps adjacent diagonal blocks of a real upper quasi-triangular matrix in Schur canonical form...
subroutine slartg(F, G, CS, SN, R)
SLARTG generates a plane rotation with real cosine and real sine.
subroutine srot(N, SX, INCX, SY, INCY, C, S)
SROT