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 ),
175 DOUBLE PRECISION DLAMCH, DLANGE
176 EXTERNAL dlamch, dlange
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,
255 GO TO ( 10, 20, 30 )k
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 dlacpy(UPLO, M, N, A, LDA, B, LDB)
DLACPY copies all or part of one two-dimensional array to another.
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 drot(N, DX, INCX, DY, INCY, C, S)
DROT
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 dlartg(F, G, CS, SN, R)
DLARTG generates a plane rotation with real cosine and real sine.
subroutine dlarfg(N, ALPHA, X, INCX, TAU)
DLARFG generates an elementary reflector (Householder matrix).
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...
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 ...