/* Subroutine */ int shseqr_(char *job, char *compz, integer *n, integer *ilo,
integer *ihi, real *h__, integer *ldh, real *wr, real *wi, real *z__,
integer *ldz, real *work, integer *lwork, integer *info, ftnlen
job_len, ftnlen compz_len)
{
/* System generated locals */
address a__1[2];
integer h_dim1, h_offset, z_dim1, z_offset, i__1, i__2, i__3[2], i__4,
i__5;
real r__1, r__2;
char ch__1[2];
/* Builtin functions */
/* Subroutine */ int s_cat(char *, char **, integer *, integer *, ftnlen);
/* Local variables */
static integer i__, j, k, l;
static real s[225] /* was [15][15] */, v[16];
static integer i1, i2, ii, nh, nr, ns, nv;
static real vv[16];
static integer itn;
static real tau;
static integer its;
static real ulp, tst1;
static integer maxb;
static real absw;
static integer ierr;
static real unfl, temp, ovfl;
extern logical lsame_(char *, char *, ftnlen, ftnlen);
extern /* Subroutine */ int sscal_(integer *, real *, real *, integer *);
static integer itemp;
extern /* Subroutine */ int sgemv_(char *, integer *, integer *, real *,
real *, integer *, real *, integer *, real *, real *, integer *,
ftnlen);
static logical initz, wantt;
extern /* Subroutine */ int scopy_(integer *, real *, integer *, real *,
integer *);
static logical wantz;
extern doublereal slapy2_(real *, real *);
extern /* Subroutine */ int slabad_(real *, real *);
extern doublereal slamch_(char *, ftnlen);
extern /* Subroutine */ int xerbla_(char *, integer *, ftnlen);
extern integer ilaenv_(integer *, char *, char *, integer *, integer *,
integer *, integer *, ftnlen, ftnlen);
extern /* Subroutine */ int slarfg_(integer *, real *, real *, integer *,
real *);
extern integer isamax_(integer *, real *, integer *);
extern doublereal slanhs_(char *, integer *, real *, integer *, real *,
ftnlen);
extern /* Subroutine */ int slahqr_(logical *, logical *, integer *,
integer *, integer *, real *, integer *, real *, real *, integer *
, integer *, real *, integer *, integer *), slacpy_(char *,
integer *, integer *, real *, integer *, real *, integer *,
ftnlen), slaset_(char *, integer *, integer *, real *, real *,
real *, integer *, ftnlen), slarfx_(char *, integer *, integer *,
real *, real *, real *, integer *, real *, ftnlen);
static real smlnum;
static logical lquery;
/* -- LAPACK routine (version 3.0) -- */
/* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., */
/* Courant Institute, Argonne National Lab, and Rice University */
/* June 30, 1999 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* SHSEQR computes the eigenvalues of a real upper Hessenberg matrix H */
/* and, optionally, the matrices T and Z from the Schur decomposition */
/* H = Z T Z**T, where T is an upper quasi-triangular matrix (the Schur */
/* form), and Z is the orthogonal matrix of Schur vectors. */
/* Optionally Z may be postmultiplied into an input orthogonal matrix Q, */
/* so that this routine can give the Schur factorization of a matrix A */
/* which has been reduced to the Hessenberg form H by the orthogonal */
/* matrix Q: A = Q*H*Q**T = (QZ)*T*(QZ)**T. */
/* Arguments */
/* ========= */
/* JOB (input) CHARACTER*1 */
/* = 'E': compute eigenvalues only; */
/* = 'S': compute eigenvalues and the Schur form T. */
/* COMPZ (input) CHARACTER*1 */
/* = 'N': no Schur vectors are computed; */
/* = 'I': Z is initialized to the unit matrix and the matrix Z */
/* of Schur vectors of H is returned; */
/* = 'V': Z must contain an orthogonal matrix Q on entry, and */
/* the product Q*Z is returned. */
/* N (input) INTEGER */
/* The order of the matrix H. N >= 0. */
/* ILO (input) INTEGER */
/* IHI (input) INTEGER */
/* It is assumed that H is already upper triangular in rows */
/* and columns 1:ILO-1 and IHI+1:N. ILO and IHI are normally */
/* set by a previous call to SGEBAL, and then passed to SGEHRD */
/* when the matrix output by SGEBAL is reduced to Hessenberg */
/* form. Otherwise ILO and IHI should be set to 1 and N */
/* respectively. */
/* 1 <= ILO <= IHI <= N, if N > 0; ILO=1 and IHI=0, if N=0. */
/* H (input/output) REAL array, dimension (LDH,N) */
/* On entry, the upper Hessenberg matrix H. */
/* On exit, if JOB = 'S', H contains the upper quasi-triangular */
/* matrix T from the Schur decomposition (the Schur form); */
/* 2-by-2 diagonal blocks (corresponding to complex conjugate */
/* pairs of eigenvalues) are returned in standard form, with */
/* H(i,i) = H(i+1,i+1) and H(i+1,i)*H(i,i+1) < 0. If JOB = 'E', */
/* the contents of H are unspecified on exit. */
/* LDH (input) INTEGER */
/* The leading dimension of the array H. LDH >= max(1,N). */
/* WR (output) REAL array, dimension (N) */
/* WI (output) REAL array, dimension (N) */
/* The real and imaginary parts, respectively, of the computed */
/* eigenvalues. If two eigenvalues are computed as a complex */
/* conjugate pair, they are stored in consecutive elements of */
/* WR and WI, say the i-th and (i+1)th, with WI(i) > 0 and */
/* WI(i+1) < 0. If JOB = 'S', the eigenvalues are stored in the */
/* same order as on the diagonal of the Schur form returned in */
/* H, with WR(i) = H(i,i) and, if H(i:i+1,i:i+1) is a 2-by-2 */
/* diagonal block, WI(i) = sqrt(H(i+1,i)*H(i,i+1)) and */
/* WI(i+1) = -WI(i). */
/* Z (input/output) REAL array, dimension (LDZ,N) */
/* If COMPZ = 'N': Z is not referenced. */
/* If COMPZ = 'I': on entry, Z need not be set, and on exit, Z */
/* contains the orthogonal matrix Z of the Schur vectors of H. */
/* If COMPZ = 'V': on entry Z must contain an N-by-N matrix Q, */
/* which is assumed to be equal to the unit matrix except for */
/* the submatrix Z(ILO:IHI,ILO:IHI); on exit Z contains Q*Z. */
/* Normally Q is the orthogonal matrix generated by SORGHR after */
/* the call to SGEHRD which formed the Hessenberg matrix H. */
/* LDZ (input) INTEGER */
/* The leading dimension of the array Z. */
/* LDZ >= max(1,N) if COMPZ = 'I' or 'V'; LDZ >= 1 otherwise. */
/* WORK (workspace/output) REAL array, dimension (LWORK) */
/* On exit, if INFO = 0, WORK(1) returns the optimal LWORK. */
/* LWORK (input) INTEGER */
/* The dimension of the array WORK. LWORK >= max(1,N). */
/* If LWORK = -1, then a workspace query is assumed; the routine */
/* only calculates the optimal size of the WORK array, returns */
/* this value as the first entry of the WORK array, and no error */
/* message related to LWORK is issued by XERBLA. */
/* INFO (output) INTEGER */
/* = 0: successful exit */
/* < 0: if INFO = -i, the i-th argument had an illegal value */
/* > 0: if INFO = i, SHSEQR failed to compute all of the */
/* eigenvalues in a total of 30*(IHI-ILO+1) iterations; */
/* elements 1:ilo-1 and i+1:n of WR and WI contain those */
/* eigenvalues which have been successfully computed. */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. Local Arrays .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Executable Statements .. */
/* Decode and test the input parameters */
/* Parameter adjustments */
h_dim1 = *ldh;
h_offset = 1 + h_dim1;
h__ -= h_offset;
--wr;
--wi;
z_dim1 = *ldz;
z_offset = 1 + z_dim1;
z__ -= z_offset;
--work;
/* Function Body */
wantt = lsame_(job, "S", (ftnlen)1, (ftnlen)1);
initz = lsame_(compz, "I", (ftnlen)1, (ftnlen)1);
wantz = initz || lsame_(compz, "V", (ftnlen)1, (ftnlen)1);
*info = 0;
work[1] = (real) max(1,*n);
lquery = *lwork == -1;
if (! lsame_(job, "E", (ftnlen)1, (ftnlen)1) && ! wantt) {
*info = -1;
} else if (! lsame_(compz, "N", (ftnlen)1, (ftnlen)1) && ! wantz) {
*info = -2;
} else if (*n < 0) {
*info = -3;
} else if (*ilo < 1 || *ilo > max(1,*n)) {
*info = -4;
} else if (*ihi < min(*ilo,*n) || *ihi > *n) {
*info = -5;
} else if (*ldh < max(1,*n)) {
*info = -7;
} else if (*ldz < 1 || wantz && *ldz < max(1,*n)) {
*info = -11;
} else if (*lwork < max(1,*n) && ! lquery) {
*info = -13;
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("SHSEQR", &i__1, (ftnlen)6);
return 0;
} else if (lquery) {
return 0;
}
/* Initialize Z, if necessary */
if (initz) {
slaset_("Full", n, n, &c_b9, &c_b10, &z__[z_offset], ldz, (ftnlen)4);
}
/* Store the eigenvalues isolated by SGEBAL. */
i__1 = *ilo - 1;
for (i__ = 1; i__ <= i__1; ++i__) {
wr[i__] = h__[i__ + i__ * h_dim1];
wi[i__] = 0.f;
/* L10: */
}
i__1 = *n;
for (i__ = *ihi + 1; i__ <= i__1; ++i__) {
wr[i__] = h__[i__ + i__ * h_dim1];
wi[i__] = 0.f;
/* L20: */
}
/* Quick return if possible. */
if (*n == 0) {
return 0;
}
if (*ilo == *ihi) {
wr[*ilo] = h__[*ilo + *ilo * h_dim1];
wi[*ilo] = 0.f;
return 0;
}
/* Set rows and columns ILO to IHI to zero below the first */
/* subdiagonal. */
i__1 = *ihi - 2;
for (j = *ilo; j <= i__1; ++j) {
i__2 = *n;
for (i__ = j + 2; i__ <= i__2; ++i__) {
h__[i__ + j * h_dim1] = 0.f;
/* L30: */
}
/* L40: */
}
nh = *ihi - *ilo + 1;
/* Determine the order of the multi-shift QR algorithm to be used. */
/* Writing concatenation */
i__3[0] = 1, a__1[0] = job;
i__3[1] = 1, a__1[1] = compz;
s_cat(ch__1, a__1, i__3, &c__2, (ftnlen)2);
ns = ilaenv_(&c__4, "SHSEQR", ch__1, n, ilo, ihi, &c_n1, (ftnlen)6, (
ftnlen)2);
/* Writing concatenation */
i__3[0] = 1, a__1[0] = job;
i__3[1] = 1, a__1[1] = compz;
s_cat(ch__1, a__1, i__3, &c__2, (ftnlen)2);
maxb = ilaenv_(&c__8, "SHSEQR", ch__1, n, ilo, ihi, &c_n1, (ftnlen)6, (
ftnlen)2);
if (ns <= 2 || ns > nh || maxb >= nh) {
/* Use the standard double-shift algorithm */
slahqr_(&wantt, &wantz, n, ilo, ihi, &h__[h_offset], ldh, &wr[1], &wi[
1], ilo, ihi, &z__[z_offset], ldz, info);
return 0;
}
maxb = max(3,maxb);
/* Computing MIN */
i__1 = min(ns,maxb);
ns = min(i__1,15);
/* Now 2 < NS <= MAXB < NH. */
/* Set machine-dependent constants for the stopping criterion. */
/* If norm(H) <= sqrt(OVFL), overflow should not occur. */
unfl = slamch_("Safe minimum", (ftnlen)12);
ovfl = 1.f / unfl;
slabad_(&unfl, &ovfl);
ulp = slamch_("Precision", (ftnlen)9);
smlnum = unfl * (nh / ulp);
/* I1 and I2 are the indices of the first row and last column of H */
/* to which transformations must be applied. If eigenvalues only are */
/* being computed, I1 and I2 are set inside the main loop. */
if (wantt) {
i1 = 1;
i2 = *n;
}
/* ITN is the total number of multiple-shift QR iterations allowed. */
itn = nh * 30;
/* The main loop begins here. I is the loop index and decreases from */
/* IHI to ILO in steps of at most MAXB. Each iteration of the loop */
/* works with the active submatrix in rows and columns L to I. */
/* Eigenvalues I+1 to IHI have already converged. Either L = ILO or */
/* H(L,L-1) is negligible so that the matrix splits. */
i__ = *ihi;
L50:
l = *ilo;
if (i__ < *ilo) {
goto L170;
}
/* Perform multiple-shift QR iterations on rows and columns ILO to I */
/* until a submatrix of order at most MAXB splits off at the bottom */
/* because a subdiagonal element has become negligible. */
i__1 = itn;
for (its = 0; its <= i__1; ++its) {
/* Look for a single small subdiagonal element. */
i__2 = l + 1;
for (k = i__; k >= i__2; --k) {
tst1 = (r__1 = h__[k - 1 + (k - 1) * h_dim1], dabs(r__1)) + (r__2
= h__[k + k * h_dim1], dabs(r__2));
if (tst1 == 0.f) {
i__4 = i__ - l + 1;
tst1 = slanhs_("1", &i__4, &h__[l + l * h_dim1], ldh, &work[1]
, (ftnlen)1);
}
/* Computing MAX */
r__2 = ulp * tst1;
if ((r__1 = h__[k + (k - 1) * h_dim1], dabs(r__1)) <= dmax(r__2,
smlnum)) {
goto L70;
}
/* L60: */
}
L70:
l = k;
if (l > *ilo) {
/* H(L,L-1) is negligible. */
h__[l + (l - 1) * h_dim1] = 0.f;
}
/* Exit from loop if a submatrix of order <= MAXB has split off. */
if (l >= i__ - maxb + 1) {
goto L160;
}
/* Now the active submatrix is in rows and columns L to I. If */
/* eigenvalues only are being computed, only the active submatrix */
/* need be transformed. */
if (! wantt) {
i1 = l;
i2 = i__;
}
if (its == 20 || its == 30) {
/* Exceptional shifts. */
i__2 = i__;
for (ii = i__ - ns + 1; ii <= i__2; ++ii) {
wr[ii] = ((r__1 = h__[ii + (ii - 1) * h_dim1], dabs(r__1)) + (
r__2 = h__[ii + ii * h_dim1], dabs(r__2))) * 1.5f;
wi[ii] = 0.f;
/* L80: */
}
} else {
/* Use eigenvalues of trailing submatrix of order NS as shifts. */
slacpy_("Full", &ns, &ns, &h__[i__ - ns + 1 + (i__ - ns + 1) *
h_dim1], ldh, s, &c__15, (ftnlen)4);
slahqr_(&c_false, &c_false, &ns, &c__1, &ns, s, &c__15, &wr[i__ -
ns + 1], &wi[i__ - ns + 1], &c__1, &ns, &z__[z_offset],
ldz, &ierr);
if (ierr > 0) {
/* If SLAHQR failed to compute all NS eigenvalues, use the */
/* unconverged diagonal elements as the remaining shifts. */
i__2 = ierr;
for (ii = 1; ii <= i__2; ++ii) {
wr[i__ - ns + ii] = s[ii + ii * 15 - 16];
wi[i__ - ns + ii] = 0.f;
/* L90: */
}
}
}
/* Form the first column of (G-w(1)) (G-w(2)) . . . (G-w(ns)) */
/* where G is the Hessenberg submatrix H(L:I,L:I) and w is */
/* the vector of shifts (stored in WR and WI). The result is */
/* stored in the local array V. */
v[0] = 1.f;
i__2 = ns + 1;
for (ii = 2; ii <= i__2; ++ii) {
v[ii - 1] = 0.f;
/* L100: */
}
nv = 1;
i__2 = i__;
for (j = i__ - ns + 1; j <= i__2; ++j) {
if (wi[j] >= 0.f) {
if (wi[j] == 0.f) {
/* real shift */
i__4 = nv + 1;
scopy_(&i__4, v, &c__1, vv, &c__1);
i__4 = nv + 1;
r__1 = -wr[j];
sgemv_("No transpose", &i__4, &nv, &c_b10, &h__[l + l *
h_dim1], ldh, vv, &c__1, &r__1, v, &c__1, (ftnlen)
12);
++nv;
} else if (wi[j] > 0.f) {
/* complex conjugate pair of shifts */
i__4 = nv + 1;
scopy_(&i__4, v, &c__1, vv, &c__1);
i__4 = nv + 1;
r__1 = wr[j] * -2.f;
sgemv_("No transpose", &i__4, &nv, &c_b10, &h__[l + l *
h_dim1], ldh, v, &c__1, &r__1, vv, &c__1, (ftnlen)
12);
i__4 = nv + 1;
itemp = isamax_(&i__4, vv, &c__1);
/* Computing MAX */
r__2 = (r__1 = vv[itemp - 1], dabs(r__1));
temp = 1.f / dmax(r__2,smlnum);
i__4 = nv + 1;
sscal_(&i__4, &temp, vv, &c__1);
absw = slapy2_(&wr[j], &wi[j]);
temp = temp * absw * absw;
i__4 = nv + 2;
i__5 = nv + 1;
sgemv_("No transpose", &i__4, &i__5, &c_b10, &h__[l + l *
h_dim1], ldh, vv, &c__1, &temp, v, &c__1, (ftnlen)
12);
nv += 2;
}
/* Scale V(1:NV) so that max(abs(V(i))) = 1. If V is zero, */
/* reset it to the unit vector. */
itemp = isamax_(&nv, v, &c__1);
temp = (r__1 = v[itemp - 1], dabs(r__1));
if (temp == 0.f) {
v[0] = 1.f;
i__4 = nv;
for (ii = 2; ii <= i__4; ++ii) {
v[ii - 1] = 0.f;
/* L110: */
}
} else {
temp = dmax(temp,smlnum);
r__1 = 1.f / temp;
sscal_(&nv, &r__1, v, &c__1);
}
}
/* L120: */
}
/* Multiple-shift QR step */
i__2 = i__ - 1;
for (k = l; k <= i__2; ++k) {
/* The first iteration of this loop determines a reflection G */
/* from the vector V and applies it from left and right to H, */
/* thus creating a nonzero bulge below the subdiagonal. */
/* Each subsequent iteration determines a reflection G to */
/* restore the Hessenberg form in the (K-1)th column, and thus */
/* chases the bulge one step toward the bottom of the active */
/* submatrix. NR is the order of G. */
/* Computing MIN */
i__4 = ns + 1, i__5 = i__ - k + 1;
nr = min(i__4,i__5);
if (k > l) {
scopy_(&nr, &h__[k + (k - 1) * h_dim1], &c__1, v, &c__1);
}
slarfg_(&nr, v, &v[1], &c__1, &tau);
if (k > l) {
h__[k + (k - 1) * h_dim1] = v[0];
i__4 = i__;
for (ii = k + 1; ii <= i__4; ++ii) {
h__[ii + (k - 1) * h_dim1] = 0.f;
/* L130: */
}
}
v[0] = 1.f;
/* Apply G from the left to transform the rows of the matrix in */
/* columns K to I2. */
i__4 = i2 - k + 1;
slarfx_("Left", &nr, &i__4, v, &tau, &h__[k + k * h_dim1], ldh, &
work[1], (ftnlen)4);
/* Apply G from the right to transform the columns of the */
/* matrix in rows I1 to min(K+NR,I). */
/* Computing MIN */
i__5 = k + nr;
i__4 = min(i__5,i__) - i1 + 1;
slarfx_("Right", &i__4, &nr, v, &tau, &h__[i1 + k * h_dim1], ldh,
&work[1], (ftnlen)5);
if (wantz) {
/* Accumulate transformations in the matrix Z */
slarfx_("Right", &nh, &nr, v, &tau, &z__[*ilo + k * z_dim1],
ldz, &work[1], (ftnlen)5);
}
/* L140: */
}
/* L150: */
}
/* Failure to converge in remaining number of iterations */
*info = i__;
return 0;
L160:
/* A submatrix of order <= MAXB in rows and columns L to I has split */
/* off. Use the double-shift QR algorithm to handle it. */
slahqr_(&wantt, &wantz, n, &l, &i__, &h__[h_offset], ldh, &wr[1], &wi[1],
ilo, ihi, &z__[z_offset], ldz, info);
if (*info > 0) {
return 0;
}
/* Decrement number of remaining iterations, and return to start of */
/* the main loop with a new value of I. */
itn -= its;
i__ = l - 1;
goto L50;
L170:
work[1] = (real) max(1,*n);
return 0;
/* End of SHSEQR */
} /* shseqr_ */
/* Subroutine */ int slaexc_(logical *wantq, integer *n, real *t, integer *
ldt, real *q, integer *ldq, integer *j1, integer *n1, integer *n2,
real *work, integer *info)
{
/* -- LAPACK auxiliary routine (version 3.0) --
Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
Courant Institute, Argonne National Lab, and Rice University
February 29, 1992
Purpose
=======
SLAEXC swaps adjacent diagonal blocks T11 and T22 of order 1 or 2 in
an upper quasi-triangular matrix T by an orthogonal similarity
transformation.
T must be in Schur canonical form, that is, block upper triangular
with 1-by-1 and 2-by-2 diagonal blocks; each 2-by-2 diagonal block
has its diagonal elemnts equal and its off-diagonal elements of
opposite sign.
Arguments
=========
WANTQ (input) LOGICAL
= .TRUE. : accumulate the transformation in the matrix Q;
= .FALSE.: do not accumulate the transformation.
N (input) INTEGER
The order of the matrix T. N >= 0.
T (input/output) REAL array, dimension (LDT,N)
On entry, the upper quasi-triangular matrix T, in Schur
canonical form.
On exit, the updated matrix T, again in Schur canonical form.
LDT (input) INTEGER
The leading dimension of the array T. LDT >= max(1,N).
Q (input/output) REAL array, dimension (LDQ,N)
On entry, if WANTQ is .TRUE., the orthogonal matrix Q.
On exit, if WANTQ is .TRUE., the updated matrix Q.
If WANTQ is .FALSE., Q is not referenced.
LDQ (input) INTEGER
The leading dimension of the array Q.
LDQ >= 1; and if WANTQ is .TRUE., LDQ >= N.
J1 (input) INTEGER
The index of the first row of the first block T11.
N1 (input) INTEGER
The order of the first block T11. N1 = 0, 1 or 2.
N2 (input) INTEGER
The order of the second block T22. N2 = 0, 1 or 2.
WORK (workspace) REAL array, dimension (N)
INFO (output) INTEGER
= 0: successful exit
= 1: the transformed matrix T would be too far from Schur
form; the blocks are not swapped and T and Q are
unchanged.
=====================================================================
Parameter adjustments */
/* Table of constant values */
static integer c__1 = 1;
static integer c__4 = 4;
static logical c_false = FALSE_;
static integer c_n1 = -1;
static integer c__2 = 2;
static integer c__3 = 3;
/* System generated locals */
integer q_dim1, q_offset, t_dim1, t_offset, i__1;
real r__1, r__2, r__3, r__4, r__5, r__6;
/* Local variables */
static integer ierr;
static real temp;
extern /* Subroutine */ int srot_(integer *, real *, integer *, real *,
integer *, real *, real *);
static real d__[16] /* was [4][4] */;
static integer k;
static real u[3], scale, x[4] /* was [2][2] */, dnorm;
static integer j2, j3, j4;
static real xnorm, u1[3], u2[3];
extern /* Subroutine */ int slanv2_(real *, real *, real *, real *, real *
, real *, real *, real *, real *, real *), slasy2_(logical *,
logical *, integer *, integer *, integer *, real *, integer *,
real *, integer *, real *, integer *, real *, real *, integer *,
real *, integer *);
static integer nd;
static real cs, t11, t22, t33, sn;
extern doublereal slamch_(char *), slange_(char *, integer *,
integer *, real *, integer *, real *);
extern /* Subroutine */ int slarfg_(integer *, real *, real *, integer *,
real *), slacpy_(char *, integer *, integer *, real *, integer *,
real *, integer *), slartg_(real *, real *, real *, real *
, real *);
static real thresh;
extern /* Subroutine */ int slarfx_(char *, integer *, integer *, real *,
real *, real *, integer *, real *);
static real smlnum, wi1, wi2, wr1, wr2, eps, tau, tau1, tau2;
#define d___ref(a_1,a_2) d__[(a_2)*4 + a_1 - 5]
#define q_ref(a_1,a_2) q[(a_2)*q_dim1 + a_1]
#define t_ref(a_1,a_2) t[(a_2)*t_dim1 + a_1]
#define x_ref(a_1,a_2) x[(a_2)*2 + a_1 - 3]
t_dim1 = *ldt;
t_offset = 1 + t_dim1 * 1;
t -= t_offset;
q_dim1 = *ldq;
q_offset = 1 + q_dim1 * 1;
q -= q_offset;
--work;
/* Function Body */
*info = 0;
/* Quick return if possible */
if (*n == 0 || *n1 == 0 || *n2 == 0) {
return 0;
}
if (*j1 + *n1 > *n) {
return 0;
}
j2 = *j1 + 1;
j3 = *j1 + 2;
j4 = *j1 + 3;
if (*n1 == 1 && *n2 == 1) {
/* Swap two 1-by-1 blocks. */
t11 = t_ref(*j1, *j1);
t22 = t_ref(j2, j2);
/* Determine the transformation to perform the interchange. */
r__1 = t22 - t11;
slartg_(&t_ref(*j1, j2), &r__1, &cs, &sn, &temp);
/* Apply transformation to the matrix T. */
if (j3 <= *n) {
i__1 = *n - *j1 - 1;
srot_(&i__1, &t_ref(*j1, j3), ldt, &t_ref(j2, j3), ldt, &cs, &sn);
}
i__1 = *j1 - 1;
srot_(&i__1, &t_ref(1, *j1), &c__1, &t_ref(1, j2), &c__1, &cs, &sn);
t_ref(*j1, *j1) = t22;
t_ref(j2, j2) = t11;
if (*wantq) {
/* Accumulate transformation in the matrix Q. */
srot_(n, &q_ref(1, *j1), &c__1, &q_ref(1, j2), &c__1, &cs, &sn);
}
} else {
/* Swapping involves at least one 2-by-2 block.
Copy the diagonal block of order N1+N2 to the local array D
and compute its norm. */
nd = *n1 + *n2;
slacpy_("Full", &nd, &nd, &t_ref(*j1, *j1), ldt, d__, &c__4);
dnorm = slange_("Max", &nd, &nd, d__, &c__4, &work[1]);
/* Compute machine-dependent threshold for test for accepting
swap. */
eps = slamch_("P");
smlnum = slamch_("S") / eps;
/* Computing MAX */
r__1 = eps * 10.f * dnorm;
thresh = dmax(r__1,smlnum);
/* Solve T11*X - X*T22 = scale*T12 for X. */
slasy2_(&c_false, &c_false, &c_n1, n1, n2, d__, &c__4, &d___ref(*n1 +
1, *n1 + 1), &c__4, &d___ref(1, *n1 + 1), &c__4, &scale, x, &
c__2, &xnorm, &ierr);
/* Swap the adjacent diagonal blocks. */
k = *n1 + *n1 + *n2 - 3;
switch (k) {
case 1: goto L10;
case 2: goto L20;
case 3: goto L30;
}
L10:
/* N1 = 1, N2 = 2: generate elementary reflector H so that:
( scale, X11, X12 ) H = ( 0, 0, * ) */
u[0] = scale;
u[1] = x_ref(1, 1);
u[2] = x_ref(1, 2);
slarfg_(&c__3, &u[2], u, &c__1, &tau);
u[2] = 1.f;
t11 = t_ref(*j1, *j1);
/* Perform swap provisionally on diagonal block in D. */
slarfx_("L", &c__3, &c__3, u, &tau, d__, &c__4, &work[1]);
slarfx_("R", &c__3, &c__3, u, &tau, d__, &c__4, &work[1]);
/* Test whether to reject swap.
Computing MAX */
r__4 = (r__1 = d___ref(3, 1), dabs(r__1)), r__5 = (r__2 = d___ref(3,
2), dabs(r__2)), r__4 = max(r__4,r__5), r__5 = (r__3 =
d___ref(3, 3) - t11, dabs(r__3));
if (dmax(r__4,r__5) > thresh) {
goto L50;
}
/* Accept swap: apply transformation to the entire matrix T. */
i__1 = *n - *j1 + 1;
slarfx_("L", &c__3, &i__1, u, &tau, &t_ref(*j1, *j1), ldt, &work[1]);
slarfx_("R", &j2, &c__3, u, &tau, &t_ref(1, *j1), ldt, &work[1]);
t_ref(j3, *j1) = 0.f;
t_ref(j3, j2) = 0.f;
t_ref(j3, j3) = t11;
if (*wantq) {
/* Accumulate transformation in the matrix Q. */
slarfx_("R", n, &c__3, u, &tau, &q_ref(1, *j1), ldq, &work[1]);
}
goto L40;
L20:
/* N1 = 2, N2 = 1: generate elementary reflector H so that:
H ( -X11 ) = ( * )
( -X21 ) = ( 0 )
( scale ) = ( 0 ) */
u[0] = -x_ref(1, 1);
u[1] = -x_ref(2, 1);
u[2] = scale;
slarfg_(&c__3, u, &u[1], &c__1, &tau);
u[0] = 1.f;
t33 = t_ref(j3, j3);
/* Perform swap provisionally on diagonal block in D. */
slarfx_("L", &c__3, &c__3, u, &tau, d__, &c__4, &work[1]);
slarfx_("R", &c__3, &c__3, u, &tau, d__, &c__4, &work[1]);
/* Test whether to reject swap.
Computing MAX */
r__4 = (r__1 = d___ref(2, 1), dabs(r__1)), r__5 = (r__2 = d___ref(3,
1), dabs(r__2)), r__4 = max(r__4,r__5), r__5 = (r__3 =
d___ref(1, 1) - t33, dabs(r__3));
if (dmax(r__4,r__5) > thresh) {
goto L50;
}
/* Accept swap: apply transformation to the entire matrix T. */
slarfx_("R", &j3, &c__3, u, &tau, &t_ref(1, *j1), ldt, &work[1]);
i__1 = *n - *j1;
slarfx_("L", &c__3, &i__1, u, &tau, &t_ref(*j1, j2), ldt, &work[1]);
t_ref(*j1, *j1) = t33;
t_ref(j2, *j1) = 0.f;
t_ref(j3, *j1) = 0.f;
if (*wantq) {
/* Accumulate transformation in the matrix Q. */
slarfx_("R", n, &c__3, u, &tau, &q_ref(1, *j1), ldq, &work[1]);
}
goto L40;
L30:
/* N1 = 2, N2 = 2: generate elementary reflectors H(1) and H(2) so
that:
H(2) H(1) ( -X11 -X12 ) = ( * * )
( -X21 -X22 ) ( 0 * )
( scale 0 ) ( 0 0 )
( 0 scale ) ( 0 0 ) */
u1[0] = -x_ref(1, 1);
u1[1] = -x_ref(2, 1);
u1[2] = scale;
slarfg_(&c__3, u1, &u1[1], &c__1, &tau1);
u1[0] = 1.f;
temp = -tau1 * (x_ref(1, 2) + u1[1] * x_ref(2, 2));
u2[0] = -temp * u1[1] - x_ref(2, 2);
u2[1] = -temp * u1[2];
u2[2] = scale;
slarfg_(&c__3, u2, &u2[1], &c__1, &tau2);
u2[0] = 1.f;
/* Perform swap provisionally on diagonal block in D. */
slarfx_("L", &c__3, &c__4, u1, &tau1, d__, &c__4, &work[1])
;
slarfx_("R", &c__4, &c__3, u1, &tau1, d__, &c__4, &work[1])
;
slarfx_("L", &c__3, &c__4, u2, &tau2, &d___ref(2, 1), &c__4, &work[1]);
slarfx_("R", &c__4, &c__3, u2, &tau2, &d___ref(1, 2), &c__4, &work[1]);
/* Test whether to reject swap.
Computing MAX */
r__5 = (r__1 = d___ref(3, 1), dabs(r__1)), r__6 = (r__2 = d___ref(3,
2), dabs(r__2)), r__5 = max(r__5,r__6), r__6 = (r__3 =
d___ref(4, 1), dabs(r__3)), r__5 = max(r__5,r__6), r__6 = (
r__4 = d___ref(4, 2), dabs(r__4));
if (dmax(r__5,r__6) > thresh) {
goto L50;
}
/* Accept swap: apply transformation to the entire matrix T. */
i__1 = *n - *j1 + 1;
slarfx_("L", &c__3, &i__1, u1, &tau1, &t_ref(*j1, *j1), ldt, &work[1]);
slarfx_("R", &j4, &c__3, u1, &tau1, &t_ref(1, *j1), ldt, &work[1]);
i__1 = *n - *j1 + 1;
slarfx_("L", &c__3, &i__1, u2, &tau2, &t_ref(j2, *j1), ldt, &work[1]);
slarfx_("R", &j4, &c__3, u2, &tau2, &t_ref(1, j2), ldt, &work[1]);
t_ref(j3, *j1) = 0.f;
t_ref(j3, j2) = 0.f;
t_ref(j4, *j1) = 0.f;
t_ref(j4, j2) = 0.f;
if (*wantq) {
/* Accumulate transformation in the matrix Q. */
slarfx_("R", n, &c__3, u1, &tau1, &q_ref(1, *j1), ldq, &work[1]);
slarfx_("R", n, &c__3, u2, &tau2, &q_ref(1, j2), ldq, &work[1]);
}
L40:
if (*n2 == 2) {
/* Standardize new 2-by-2 block T11 */
slanv2_(&t_ref(*j1, *j1), &t_ref(*j1, j2), &t_ref(j2, *j1), &
t_ref(j2, j2), &wr1, &wi1, &wr2, &wi2, &cs, &sn);
i__1 = *n - *j1 - 1;
srot_(&i__1, &t_ref(*j1, *j1 + 2), ldt, &t_ref(j2, *j1 + 2), ldt,
&cs, &sn);
i__1 = *j1 - 1;
srot_(&i__1, &t_ref(1, *j1), &c__1, &t_ref(1, j2), &c__1, &cs, &
sn);
if (*wantq) {
srot_(n, &q_ref(1, *j1), &c__1, &q_ref(1, j2), &c__1, &cs, &
sn);
}
}
if (*n1 == 2) {
/* Standardize new 2-by-2 block T22 */
j3 = *j1 + *n2;
j4 = j3 + 1;
slanv2_(&t_ref(j3, j3), &t_ref(j3, j4), &t_ref(j4, j3), &t_ref(j4,
j4), &wr1, &wi1, &wr2, &wi2, &cs, &sn);
if (j3 + 2 <= *n) {
i__1 = *n - j3 - 1;
srot_(&i__1, &t_ref(j3, j3 + 2), ldt, &t_ref(j4, j3 + 2), ldt,
&cs, &sn);
}
i__1 = j3 - 1;
srot_(&i__1, &t_ref(1, j3), &c__1, &t_ref(1, j4), &c__1, &cs, &sn)
;
if (*wantq) {
srot_(n, &q_ref(1, j3), &c__1, &q_ref(1, j4), &c__1, &cs, &sn)
;
}
}
}
return 0;
/* Exit with INFO = 1 if swap was rejected. */
L50:
*info = 1;
return 0;
/* End of SLAEXC */
} /* slaexc_ */
