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,
255 GO TO ( 10, 20, 30 )k
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 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 slartg(F, G, CS, SN, R)
SLARTG generates a plane rotation with real cosine and real sine.
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 ...
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 srot(N, SX, INCX, SY, INCY, C, S)
SROT
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 ...
real function slamch(CMACH)
SLAMCH
subroutine slarfg(N, ALPHA, X, INCX, TAU)
SLARFG generates an elementary reflector (Householder matrix).
subroutine slacpy(UPLO, M, N, A, LDA, B, LDB)
SLACPY copies all or part of one two-dimensional array to another.