138 SUBROUTINE dlaexc( WANTQ, N, T, LDT, Q, LDQ, J1, N1, N2, WORK,
148 INTEGER info, j1, ldq, ldt, n, n1, n2
151 DOUBLE PRECISION q( ldq, * ), t( ldt, * ), work( * )
157 DOUBLE PRECISION zero, one
158 parameter( zero = 0.0d+0, one = 1.0d+0 )
160 parameter( ten = 1.0d+1 )
162 parameter( ldd = 4, ldx = 2 )
165 INTEGER ierr, j2, j3, j4, k, nd
166 DOUBLE PRECISION cs, dnorm, eps, scale, smlnum, sn, t11, t22,
167 $ t33, tau, tau1, tau2, temp, thresh, wi1, wi2,
171 DOUBLE PRECISION 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
dlartg( t( j1, j2 ), t22-t11, cs, sn, temp )
214 $ CALL
drot( n-j1-1, t( j1, j3 ), ldt, t( j2, j3 ), ldt, cs,
216 CALL
drot( j1-1, t( 1, j1 ), 1, t( 1, j2 ), 1, cs, sn )
225 CALL
drot( n, q( 1, j1 ), 1, q( 1, j2 ), 1, cs, sn )
236 CALL
dlacpy(
'Full', nd, nd, t( j1, j1 ), ldt, d, ldd )
237 dnorm =
dlange(
'Max', nd, nd, d, ldd, work )
243 smlnum =
dlamch(
'S' ) / eps
244 thresh = max( ten*eps*dnorm, smlnum )
248 CALL
dlasy2( .false., .false., -1, n1, n2, d, ldd,
249 $ d( n1+1, n1+1 ), ldd, d( 1, n1+1 ), ldd, scale,
x,
266 CALL
dlarfg( 3, u( 3 ), u, 1, tau )
272 CALL
dlarfx(
'L', 3, 3, u, tau, d, ldd, work )
273 CALL
dlarfx(
'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
dlarfx(
'L', 3, n-j1+1, u, tau, t( j1, j1 ), ldt, work )
283 CALL
dlarfx(
'R', j2, 3, u, tau, t( 1, j1 ), ldt, work )
293 CALL
dlarfx(
'R', n, 3, u, tau, q( 1, j1 ), ldq, work )
308 CALL
dlarfg( 3, u( 1 ), u( 2 ), 1, tau )
314 CALL
dlarfx(
'L', 3, 3, u, tau, d, ldd, work )
315 CALL
dlarfx(
'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
dlarfx(
'R', j3, 3, u, tau, t( 1, j1 ), ldt, work )
325 CALL
dlarfx(
'L', 3, n-j1, u, tau, t( j1, j2 ), ldt, work )
335 CALL
dlarfx(
'R', n, 3, u, tau, q( 1, j1 ), ldq, work )
352 CALL
dlarfg( 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
dlarfg( 3, u2( 1 ), u2( 2 ), 1, tau2 )
364 CALL
dlarfx(
'L', 3, 4, u1, tau1, d, ldd, work )
365 CALL
dlarfx(
'R', 4, 3, u1, tau1, d, ldd, work )
366 CALL
dlarfx(
'L', 3, 4, u2, tau2, d( 2, 1 ), ldd, work )
367 CALL
dlarfx(
'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
dlarfx(
'L', 3, n-j1+1, u1, tau1, t( j1, j1 ), ldt, work )
377 CALL
dlarfx(
'R', j4, 3, u1, tau1, t( 1, j1 ), ldt, work )
378 CALL
dlarfx(
'L', 3, n-j1+1, u2, tau2, t( j2, j1 ), ldt, work )
379 CALL
dlarfx(
'R', j4, 3, u2, tau2, t( 1, j2 ), ldt, work )
390 CALL
dlarfx(
'R', n, 3, u1, tau1, q( 1, j1 ), ldq, work )
391 CALL
dlarfx(
'R', n, 3, u2, tau2, q( 1, j2 ), ldq, work )
400 CALL
dlanv2( t( j1, j1 ), t( j1, j2 ), t( j2, j1 ),
401 $ t( j2, j2 ), wr1, wi1, wr2, wi2, cs, sn )
402 CALL
drot( n-j1-1, t( j1, j1+2 ), ldt, t( j2, j1+2 ), ldt,
404 CALL
drot( j1-1, t( 1, j1 ), 1, t( 1, j2 ), 1, cs, sn )
406 $ CALL
drot( n, q( 1, j1 ), 1, q( 1, j2 ), 1, cs, sn )
415 CALL
dlanv2( t( j3, j3 ), t( j3, j4 ), t( j4, j3 ),
416 $ t( j4, j4 ), wr1, wi1, wr2, wi2, cs, sn )
418 $ CALL
drot( n-j3-1, t( j3, j3+2 ), ldt, t( j4, j3+2 ),
420 CALL
drot( j3-1, t( 1, j3 ), 1, t( 1, j4 ), 1, cs, sn )
422 $ CALL
drot( n, q( 1, j3 ), 1, q( 1, j4 ), 1, cs, sn )
subroutine dlarfg(N, ALPHA, X, INCX, TAU)
DLARFG generates an elementary reflector (Householder matrix).
subroutine dlartg(F, G, CS, SN, R)
DLARTG generates a plane rotation with real cosine and real sine.
subroutine dlasy2(LTRANL, LTRANR, ISGN, N1, N2, TL, LDTL, TR, LDTR, B, LDB, SCALE, X, LDX, XNORM, INFO)
DLASY2 solves the Sylvester matrix equation where the matrices are of order 1 or 2.
subroutine dlanv2(A, B, C, D, RT1R, RT1I, RT2R, RT2I, CS, SN)
DLANV2 computes the Schur factorization of a real 2-by-2 nonsymmetric matrix in standard form...
subroutine dlarfx(SIDE, M, N, V, TAU, C, LDC, WORK)
DLARFX applies an elementary reflector to a general rectangular matrix, with loop unrolling when the ...
DOUBLE PRECISION function dlange(NORM, M, N, A, LDA, WORK)
DLANGE returns the value of the 1-norm, Frobenius norm, infinity-norm, or the largest absolute value ...
subroutine drot(N, DX, INCX, DY, INCY, C, S)
DROT
subroutine dlacpy(UPLO, M, N, A, LDA, B, LDB)
DLACPY copies all or part of one two-dimensional array to another.
DOUBLE PRECISION function dlamch(CMACH)
DLAMCH
subroutine dlaexc(WANTQ, N, T, LDT, Q, LDQ, J1, N1, N2, WORK, INFO)
DLAEXC swaps adjacent diagonal blocks of a real upper quasi-triangular matrix in Schur canonical form...