/* Subroutine */ int dget32_(doublereal *rmax, integer *lmax, integer *ninfo,
integer *knt)
{
/* Initialized data */
static integer itval[32] /* was [2][2][8] */ = { 8,4,2,1,4,8,1,2,2,1,8,
4,1,2,4,8,9,4,2,1,4,9,1,2,2,1,9,4,1,2,4,9 };
/* System generated locals */
doublereal d__1, d__2;
/* Local variables */
doublereal b[4] /* was [2][2] */, x[4] /* was [2][2] */;
integer n1, n2, ib;
doublereal tl[4] /* was [2][2] */, tr[4] /* was [2][2] */;
integer ib1, ib2, ib3;
doublereal den, val[3], eps;
integer itl;
doublereal res, sgn;
integer itr;
doublereal tmp;
integer info, isgn;
doublereal tnrm, xnrm, scale, xnorm;
extern /* Subroutine */ int dlasy2_(logical *, logical *, integer *,
integer *, integer *, doublereal *, integer *, doublereal *,
integer *, doublereal *, integer *, doublereal *, doublereal *,
integer *, doublereal *, integer *), dlabad_(doublereal *,
doublereal *);
extern doublereal dlamch_(char *);
doublereal bignum;
integer itranl, itlscl;
logical ltranl;
integer itranr, itrscl;
logical ltranr;
doublereal smlnum;
/* -- LAPACK test routine (version 3.1) -- */
/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/* November 2006 */
/* .. Scalar Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* DGET32 tests DLASY2, a routine for solving */
/* op(TL)*X + ISGN*X*op(TR) = SCALE*B */
/* where TL is N1 by N1, TR is N2 by N2, and N1,N2 =1 or 2 only. */
/* X and B are N1 by N2, op() is an optional transpose, an */
/* ISGN = 1 or -1. SCALE is chosen less than or equal to 1 to */
/* avoid overflow in X. */
/* The test condition is that the scaled residual */
/* norm( op(TL)*X + ISGN*X*op(TR) = SCALE*B ) */
/* / ( max( ulp*norm(TL), ulp*norm(TR)) * norm(X), SMLNUM ) */
/* should be on the order of 1. Here, ulp is the machine precision. */
/* Also, it is verified that SCALE is less than or equal to 1, and */
/* that XNORM = infinity-norm(X). */
/* Arguments */
/* ========== */
/* RMAX (output) DOUBLE PRECISION */
/* Value of the largest test ratio. */
/* LMAX (output) INTEGER */
/* Example number where largest test ratio achieved. */
/* NINFO (output) INTEGER */
/* Number of examples returned with INFO.NE.0. */
/* KNT (output) INTEGER */
/* Total number of examples tested. */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. Local Arrays .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Data statements .. */
/* .. */
/* .. Executable Statements .. */
/* Get machine parameters */
eps = dlamch_("P");
smlnum = dlamch_("S") / eps;
bignum = 1. / smlnum;
dlabad_(&smlnum, &bignum);
/* Set up test case parameters */
val[0] = sqrt(smlnum);
val[1] = 1.;
val[2] = sqrt(bignum);
*knt = 0;
*ninfo = 0;
*lmax = 0;
*rmax = 0.;
/* Begin test loop */
for (itranl = 0; itranl <= 1; ++itranl) {
for (itranr = 0; itranr <= 1; ++itranr) {
for (isgn = -1; isgn <= 1; isgn += 2) {
sgn = (doublereal) isgn;
ltranl = itranl == 1;
ltranr = itranr == 1;
n1 = 1;
n2 = 1;
for (itl = 1; itl <= 3; ++itl) {
for (itr = 1; itr <= 3; ++itr) {
for (ib = 1; ib <= 3; ++ib) {
tl[0] = val[itl - 1];
tr[0] = val[itr - 1];
b[0] = val[ib - 1];
++(*knt);
dlasy2_(<ranl, <ranr, &isgn, &n1, &n2, tl, &
c__2, tr, &c__2, b, &c__2, &scale, x, &
c__2, &xnorm, &info);
if (info != 0) {
++(*ninfo);
}
res = (d__1 = (tl[0] + sgn * tr[0]) * x[0] -
scale * b[0], abs(d__1));
if (info == 0) {
/* Computing MAX */
d__1 = eps * ((abs(tr[0]) + abs(tl[0])) * abs(
x[0]));
den = max(d__1,smlnum);
} else {
/* Computing MAX */
d__1 = abs(x[0]);
den = smlnum * max(d__1,1.);
}
res /= den;
if (scale > 1.) {
res += 1. / eps;
}
res += (d__1 = xnorm - abs(x[0]), abs(d__1)) /
max(smlnum,xnorm) / eps;
if (info != 0 && info != 1) {
res += 1. / eps;
}
if (res > *rmax) {
*lmax = *knt;
*rmax = res;
}
/* L10: */
}
/* L20: */
}
/* L30: */
}
n1 = 2;
n2 = 1;
for (itl = 1; itl <= 8; ++itl) {
for (itlscl = 1; itlscl <= 3; ++itlscl) {
for (itr = 1; itr <= 3; ++itr) {
for (ib1 = 1; ib1 <= 3; ++ib1) {
for (ib2 = 1; ib2 <= 3; ++ib2) {
b[0] = val[ib1 - 1];
b[1] = val[ib2 - 1] * -4.;
tl[0] = itval[((itl << 1) + 1 << 1) - 6] *
val[itlscl - 1];
tl[1] = itval[((itl << 1) + 1 << 1) - 5] *
val[itlscl - 1];
tl[2] = itval[((itl << 1) + 2 << 1) - 6] *
val[itlscl - 1];
tl[3] = itval[((itl << 1) + 2 << 1) - 5] *
val[itlscl - 1];
tr[0] = val[itr - 1];
++(*knt);
dlasy2_(<ranl, <ranr, &isgn, &n1, &n2,
tl, &c__2, tr, &c__2, b, &c__2, &
scale, x, &c__2, &xnorm, &info);
if (info != 0) {
++(*ninfo);
}
if (ltranl) {
tmp = tl[2];
tl[2] = tl[1];
tl[1] = tmp;
}
res = (d__1 = (tl[0] + sgn * tr[0]) * x[0]
+ tl[2] * x[1] - scale * b[0],
abs(d__1));
res += (d__1 = (tl[3] + sgn * tr[0]) * x[
1] + tl[1] * x[0] - scale * b[1],
abs(d__1));
tnrm = abs(tr[0]) + abs(tl[0]) + abs(tl[2]
) + abs(tl[1]) + abs(tl[3]);
/* Computing MAX */
d__1 = abs(x[0]), d__2 = abs(x[1]);
xnrm = max(d__1,d__2);
/* Computing MAX */
d__1 = smlnum, d__2 = smlnum * xnrm, d__1
= max(d__1,d__2), d__2 = tnrm *
eps * xnrm;
den = max(d__1,d__2);
res /= den;
if (scale > 1.) {
res += 1. / eps;
}
res += (d__1 = xnorm - xnrm, abs(d__1)) /
max(smlnum,xnorm) / eps;
if (res > *rmax) {
*lmax = *knt;
*rmax = res;
}
/* L40: */
}
/* L50: */
}
/* L60: */
}
/* L70: */
}
/* L80: */
}
n1 = 1;
n2 = 2;
for (itr = 1; itr <= 8; ++itr) {
for (itrscl = 1; itrscl <= 3; ++itrscl) {
for (itl = 1; itl <= 3; ++itl) {
for (ib1 = 1; ib1 <= 3; ++ib1) {
for (ib2 = 1; ib2 <= 3; ++ib2) {
b[0] = val[ib1 - 1];
b[2] = val[ib2 - 1] * -2.;
tr[0] = itval[((itr << 1) + 1 << 1) - 6] *
val[itrscl - 1];
tr[1] = itval[((itr << 1) + 1 << 1) - 5] *
val[itrscl - 1];
tr[2] = itval[((itr << 1) + 2 << 1) - 6] *
val[itrscl - 1];
tr[3] = itval[((itr << 1) + 2 << 1) - 5] *
val[itrscl - 1];
tl[0] = val[itl - 1];
++(*knt);
dlasy2_(<ranl, <ranr, &isgn, &n1, &n2,
tl, &c__2, tr, &c__2, b, &c__2, &
scale, x, &c__2, &xnorm, &info);
if (info != 0) {
++(*ninfo);
}
if (ltranr) {
tmp = tr[2];
tr[2] = tr[1];
tr[1] = tmp;
}
tnrm = abs(tl[0]) + abs(tr[0]) + abs(tr[2]
) + abs(tr[3]) + abs(tr[1]);
xnrm = abs(x[0]) + abs(x[2]);
res = (d__1 = (tl[0] + sgn * tr[0]) * x[0]
+ sgn * tr[1] * x[2] - scale * b[
0], abs(d__1));
res += (d__1 = (tl[0] + sgn * tr[3]) * x[
2] + sgn * tr[2] * x[0] - scale *
b[2], abs(d__1));
/* Computing MAX */
d__1 = smlnum, d__2 = smlnum * xnrm, d__1
= max(d__1,d__2), d__2 = tnrm *
eps * xnrm;
den = max(d__1,d__2);
res /= den;
if (scale > 1.) {
res += 1. / eps;
}
res += (d__1 = xnorm - xnrm, abs(d__1)) /
max(smlnum,xnorm) / eps;
if (res > *rmax) {
*lmax = *knt;
*rmax = res;
}
/* L90: */
}
/* L100: */
}
/* L110: */
}
/* L120: */
}
/* L130: */
}
n1 = 2;
n2 = 2;
for (itr = 1; itr <= 8; ++itr) {
for (itrscl = 1; itrscl <= 3; ++itrscl) {
for (itl = 1; itl <= 8; ++itl) {
for (itlscl = 1; itlscl <= 3; ++itlscl) {
for (ib1 = 1; ib1 <= 3; ++ib1) {
for (ib2 = 1; ib2 <= 3; ++ib2) {
for (ib3 = 1; ib3 <= 3; ++ib3) {
b[0] = val[ib1 - 1];
b[1] = val[ib2 - 1] * -4.;
b[2] = val[ib3 - 1] * -2.;
/* Computing MIN */
d__1 = val[ib1 - 1], d__2 = val[
ib2 - 1], d__1 = min(d__1,
d__2), d__2 = val[ib3 - 1]
;
b[3] = min(d__1,d__2) * 8.;
tr[0] = itval[((itr << 1) + 1 <<
1) - 6] * val[itrscl - 1];
tr[1] = itval[((itr << 1) + 1 <<
1) - 5] * val[itrscl - 1];
tr[2] = itval[((itr << 1) + 2 <<
1) - 6] * val[itrscl - 1];
tr[3] = itval[((itr << 1) + 2 <<
1) - 5] * val[itrscl - 1];
tl[0] = itval[((itl << 1) + 1 <<
1) - 6] * val[itlscl - 1];
tl[1] = itval[((itl << 1) + 1 <<
1) - 5] * val[itlscl - 1];
tl[2] = itval[((itl << 1) + 2 <<
1) - 6] * val[itlscl - 1];
tl[3] = itval[((itl << 1) + 2 <<
1) - 5] * val[itlscl - 1];
++(*knt);
dlasy2_(<ranl, <ranr, &isgn, &
n1, &n2, tl, &c__2, tr, &
c__2, b, &c__2, &scale, x,
&c__2, &xnorm, &info);
if (info != 0) {
++(*ninfo);
}
if (ltranr) {
tmp = tr[2];
tr[2] = tr[1];
tr[1] = tmp;
}
if (ltranl) {
tmp = tl[2];
tl[2] = tl[1];
tl[1] = tmp;
}
tnrm = abs(tr[0]) + abs(tr[1]) +
abs(tr[2]) + abs(tr[3]) +
abs(tl[0]) + abs(tl[1]) +
abs(tl[2]) + abs(tl[3]);
/* Computing MAX */
d__1 = abs(x[0]) + abs(x[2]),
d__2 = abs(x[1]) + abs(x[
3]);
xnrm = max(d__1,d__2);
res = (d__1 = (tl[0] + sgn * tr[0]
) * x[0] + sgn * tr[1] *
x[2] + tl[2] * x[1] -
scale * b[0], abs(d__1));
res += (d__1 = tl[0] * x[2] + sgn
* tr[2] * x[0] + sgn * tr[
3] * x[2] + tl[2] * x[3]
- scale * b[2], abs(d__1))
;
res += (d__1 = tl[1] * x[0] + sgn
* tr[0] * x[1] + sgn * tr[
1] * x[3] + tl[3] * x[1]
- scale * b[1], abs(d__1))
;
res += (d__1 = (tl[3] + sgn * tr[
3]) * x[3] + sgn * tr[2] *
x[1] + tl[1] * x[2] -
scale * b[3], abs(d__1));
/* Computing MAX */
d__1 = smlnum, d__2 = smlnum *
xnrm, d__1 = max(d__1,
d__2), d__2 = tnrm * eps *
xnrm;
den = max(d__1,d__2);
res /= den;
if (scale > 1.) {
res += 1. / eps;
}
res += (d__1 = xnorm - xnrm, abs(
d__1)) / max(smlnum,xnorm)
/ eps;
if (res > *rmax) {
*lmax = *knt;
*rmax = res;
}
/* L140: */
}
/* L150: */
}
/* L160: */
}
/* L170: */
}
/* L180: */
}
/* L190: */
}
/* L200: */
}
/* L210: */
}
/* L220: */
}
/* L230: */
}
return 0;
/* End of DGET32 */
} /* dget32_ */
/* Subroutine */ int dlaexc_(logical *wantq, integer *n, doublereal *t,
integer *ldt, doublereal *q, integer *ldq, integer *j1, integer *n1,
integer *n2, doublereal *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
=======
DLAEXC 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) DOUBLE PRECISION 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) DOUBLE PRECISION 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) DOUBLE PRECISION 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;
doublereal d__1, d__2, d__3, d__4, d__5, d__6;
/* Local variables */
static integer ierr;
static doublereal temp;
extern /* Subroutine */ int drot_(integer *, doublereal *, integer *,
doublereal *, integer *, doublereal *, doublereal *);
static doublereal d__[16] /* was [4][4] */;
static integer k;
static doublereal u[3], scale, x[4] /* was [2][2] */, dnorm;
static integer j2, j3, j4;
static doublereal xnorm, u1[3], u2[3];
extern /* Subroutine */ int dlanv2_(doublereal *, doublereal *,
doublereal *, doublereal *, doublereal *, doublereal *,
doublereal *, doublereal *, doublereal *, doublereal *), dlasy2_(
logical *, logical *, integer *, integer *, integer *, doublereal
*, integer *, doublereal *, integer *, doublereal *, integer *,
doublereal *, doublereal *, integer *, doublereal *, integer *);
static integer nd;
static doublereal cs, t11, t22;
extern doublereal dlamch_(char *);
static doublereal t33;
extern doublereal dlange_(char *, integer *, integer *, doublereal *,
integer *, doublereal *);
extern /* Subroutine */ int dlarfg_(integer *, doublereal *, doublereal *,
integer *, doublereal *);
static doublereal sn;
extern /* Subroutine */ int dlacpy_(char *, integer *, integer *,
doublereal *, integer *, doublereal *, integer *),
dlartg_(doublereal *, doublereal *, doublereal *, doublereal *,
doublereal *), dlarfx_(char *, integer *, integer *, doublereal *,
doublereal *, doublereal *, integer *, doublereal *);
static doublereal thresh, 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. */
d__1 = t22 - t11;
dlartg_(&t_ref(*j1, j2), &d__1, &cs, &sn, &temp);
/* Apply transformation to the matrix T. */
if (j3 <= *n) {
i__1 = *n - *j1 - 1;
drot_(&i__1, &t_ref(*j1, j3), ldt, &t_ref(j2, j3), ldt, &cs, &sn);
}
i__1 = *j1 - 1;
drot_(&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. */
drot_(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;
dlacpy_("Full", &nd, &nd, &t_ref(*j1, *j1), ldt, d__, &c__4);
dnorm = dlange_("Max", &nd, &nd, d__, &c__4, &work[1]);
/* Compute machine-dependent threshold for test for accepting
swap. */
eps = dlamch_("P");
smlnum = dlamch_("S") / eps;
/* Computing MAX */
d__1 = eps * 10. * dnorm;
thresh = max(d__1,smlnum);
/* Solve T11*X - X*T22 = scale*T12 for X. */
dlasy2_(&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);
dlarfg_(&c__3, &u[2], u, &c__1, &tau);
u[2] = 1.;
t11 = t_ref(*j1, *j1);
/* Perform swap provisionally on diagonal block in D. */
dlarfx_("L", &c__3, &c__3, u, &tau, d__, &c__4, &work[1]);
dlarfx_("R", &c__3, &c__3, u, &tau, d__, &c__4, &work[1]);
/* Test whether to reject swap.
Computing MAX */
d__4 = (d__1 = d___ref(3, 1), abs(d__1)), d__5 = (d__2 = d___ref(3, 2)
, abs(d__2)), d__4 = max(d__4,d__5), d__5 = (d__3 = d___ref(3,
3) - t11, abs(d__3));
if (max(d__4,d__5) > thresh) {
goto L50;
}
/* Accept swap: apply transformation to the entire matrix T. */
i__1 = *n - *j1 + 1;
dlarfx_("L", &c__3, &i__1, u, &tau, &t_ref(*j1, *j1), ldt, &work[1]);
dlarfx_("R", &j2, &c__3, u, &tau, &t_ref(1, *j1), ldt, &work[1]);
t_ref(j3, *j1) = 0.;
t_ref(j3, j2) = 0.;
t_ref(j3, j3) = t11;
if (*wantq) {
/* Accumulate transformation in the matrix Q. */
dlarfx_("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;
dlarfg_(&c__3, u, &u[1], &c__1, &tau);
u[0] = 1.;
t33 = t_ref(j3, j3);
/* Perform swap provisionally on diagonal block in D. */
dlarfx_("L", &c__3, &c__3, u, &tau, d__, &c__4, &work[1]);
dlarfx_("R", &c__3, &c__3, u, &tau, d__, &c__4, &work[1]);
/* Test whether to reject swap.
Computing MAX */
d__4 = (d__1 = d___ref(2, 1), abs(d__1)), d__5 = (d__2 = d___ref(3, 1)
, abs(d__2)), d__4 = max(d__4,d__5), d__5 = (d__3 = d___ref(1,
1) - t33, abs(d__3));
if (max(d__4,d__5) > thresh) {
goto L50;
}
/* Accept swap: apply transformation to the entire matrix T. */
dlarfx_("R", &j3, &c__3, u, &tau, &t_ref(1, *j1), ldt, &work[1]);
i__1 = *n - *j1;
dlarfx_("L", &c__3, &i__1, u, &tau, &t_ref(*j1, j2), ldt, &work[1]);
t_ref(*j1, *j1) = t33;
t_ref(j2, *j1) = 0.;
t_ref(j3, *j1) = 0.;
if (*wantq) {
/* Accumulate transformation in the matrix Q. */
dlarfx_("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;
dlarfg_(&c__3, u1, &u1[1], &c__1, &tau1);
u1[0] = 1.;
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;
dlarfg_(&c__3, u2, &u2[1], &c__1, &tau2);
u2[0] = 1.;
/* Perform swap provisionally on diagonal block in D. */
dlarfx_("L", &c__3, &c__4, u1, &tau1, d__, &c__4, &work[1])
;
dlarfx_("R", &c__4, &c__3, u1, &tau1, d__, &c__4, &work[1])
;
dlarfx_("L", &c__3, &c__4, u2, &tau2, &d___ref(2, 1), &c__4, &work[1]);
dlarfx_("R", &c__4, &c__3, u2, &tau2, &d___ref(1, 2), &c__4, &work[1]);
/* Test whether to reject swap.
Computing MAX */
d__5 = (d__1 = d___ref(3, 1), abs(d__1)), d__6 = (d__2 = d___ref(3, 2)
, abs(d__2)), d__5 = max(d__5,d__6), d__6 = (d__3 = d___ref(4,
1), abs(d__3)), d__5 = max(d__5,d__6), d__6 = (d__4 =
d___ref(4, 2), abs(d__4));
if (max(d__5,d__6) > thresh) {
goto L50;
}
/* Accept swap: apply transformation to the entire matrix T. */
i__1 = *n - *j1 + 1;
dlarfx_("L", &c__3, &i__1, u1, &tau1, &t_ref(*j1, *j1), ldt, &work[1]);
dlarfx_("R", &j4, &c__3, u1, &tau1, &t_ref(1, *j1), ldt, &work[1]);
i__1 = *n - *j1 + 1;
dlarfx_("L", &c__3, &i__1, u2, &tau2, &t_ref(j2, *j1), ldt, &work[1]);
dlarfx_("R", &j4, &c__3, u2, &tau2, &t_ref(1, j2), ldt, &work[1]);
t_ref(j3, *j1) = 0.;
t_ref(j3, j2) = 0.;
t_ref(j4, *j1) = 0.;
t_ref(j4, j2) = 0.;
if (*wantq) {
/* Accumulate transformation in the matrix Q. */
dlarfx_("R", n, &c__3, u1, &tau1, &q_ref(1, *j1), ldq, &work[1]);
dlarfx_("R", n, &c__3, u2, &tau2, &q_ref(1, j2), ldq, &work[1]);
}
L40:
if (*n2 == 2) {
/* Standardize new 2-by-2 block T11 */
dlanv2_(&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;
drot_(&i__1, &t_ref(*j1, *j1 + 2), ldt, &t_ref(j2, *j1 + 2), ldt,
&cs, &sn);
i__1 = *j1 - 1;
drot_(&i__1, &t_ref(1, *j1), &c__1, &t_ref(1, j2), &c__1, &cs, &
sn);
if (*wantq) {
drot_(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;
dlanv2_(&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;
drot_(&i__1, &t_ref(j3, j3 + 2), ldt, &t_ref(j4, j3 + 2), ldt,
&cs, &sn);
}
i__1 = j3 - 1;
drot_(&i__1, &t_ref(1, j3), &c__1, &t_ref(1, j4), &c__1, &cs, &sn)
;
if (*wantq) {
drot_(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 DLAEXC */
} /* dlaexc_ */
/* Subroutine */ int dlaexc_(logical *wantq, integer *n, doublereal *t,
integer *ldt, doublereal *q, integer *ldq, integer *j1, integer *n1,
integer *n2, doublereal *work, integer *info)
{
/* System generated locals */
integer q_dim1, q_offset, t_dim1, t_offset, i__1;
doublereal d__1, d__2, d__3;
/* Local variables */
doublereal d__[16] /* was [4][4] */;
integer k;
doublereal u[3], x[4] /* was [2][2] */;
integer j2, j3, j4;
doublereal u1[3], u2[3];
integer nd;
doublereal cs, t11, t22, t33, sn, wi1, wi2, wr1, wr2, eps, tau, tau1,
tau2;
integer ierr;
doublereal temp;
extern /* Subroutine */ int drot_(integer *, doublereal *, integer *,
doublereal *, integer *, doublereal *, doublereal *);
doublereal scale, dnorm, xnorm;
extern /* Subroutine */ int dlanv2_(doublereal *, doublereal *,
doublereal *, doublereal *, doublereal *, doublereal *,
doublereal *, doublereal *, doublereal *, doublereal *), dlasy2_(
logical *, logical *, integer *, integer *, integer *, doublereal
*, integer *, doublereal *, integer *, doublereal *, integer *,
doublereal *, doublereal *, integer *, doublereal *, integer *);
extern doublereal dlamch_(char *), dlange_(char *, integer *,
integer *, doublereal *, integer *, doublereal *);
extern /* Subroutine */ int dlarfg_(integer *, doublereal *, doublereal *,
integer *, doublereal *), dlacpy_(char *, integer *, integer *,
doublereal *, integer *, doublereal *, integer *),
dlartg_(doublereal *, doublereal *, doublereal *, doublereal *,
doublereal *), dlarfx_(char *, integer *, integer *, doublereal *,
doublereal *, doublereal *, integer *, doublereal *);
doublereal thresh, smlnum;
/* -- LAPACK auxiliary routine (version 3.1) -- */
/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/* November 2006 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* DLAEXC 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) DOUBLE PRECISION 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) DOUBLE PRECISION 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) DOUBLE PRECISION 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. */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. Local Arrays .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Executable Statements .. */
/* Parameter adjustments */
t_dim1 = *ldt;
t_offset = 1 + t_dim1;
t -= t_offset;
q_dim1 = *ldq;
q_offset = 1 + q_dim1;
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[*j1 + *j1 * t_dim1];
t22 = t[j2 + j2 * t_dim1];
/* Determine the transformation to perform the interchange. */
d__1 = t22 - t11;
dlartg_(&t[*j1 + j2 * t_dim1], &d__1, &cs, &sn, &temp);
/* Apply transformation to the matrix T. */
if (j3 <= *n) {
i__1 = *n - *j1 - 1;
drot_(&i__1, &t[*j1 + j3 * t_dim1], ldt, &t[j2 + j3 * t_dim1],
ldt, &cs, &sn);
}
i__1 = *j1 - 1;
drot_(&i__1, &t[*j1 * t_dim1 + 1], &c__1, &t[j2 * t_dim1 + 1], &c__1,
&cs, &sn);
t[*j1 + *j1 * t_dim1] = t22;
t[j2 + j2 * t_dim1] = t11;
if (*wantq) {
/* Accumulate transformation in the matrix Q. */
drot_(n, &q[*j1 * q_dim1 + 1], &c__1, &q[j2 * q_dim1 + 1], &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;
dlacpy_("Full", &nd, &nd, &t[*j1 + *j1 * t_dim1], ldt, d__, &c__4);
dnorm = dlange_("Max", &nd, &nd, d__, &c__4, &work[1]);
/* Compute machine-dependent threshold for test for accepting */
/* swap. */
eps = dlamch_("P");
smlnum = dlamch_("S") / eps;
/* Computing MAX */
d__1 = eps * 10. * dnorm;
thresh = max(d__1,smlnum);
/* Solve T11*X - X*T22 = scale*T12 for X. */
dlasy2_(&c_false, &c_false, &c_n1, n1, n2, d__, &c__4, &d__[*n1 + 1 +
(*n1 + 1 << 2) - 5], &c__4, &d__[(*n1 + 1 << 2) - 4], &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[0];
u[2] = x[2];
dlarfg_(&c__3, &u[2], u, &c__1, &tau);
u[2] = 1.;
t11 = t[*j1 + *j1 * t_dim1];
/* Perform swap provisionally on diagonal block in D. */
dlarfx_("L", &c__3, &c__3, u, &tau, d__, &c__4, &work[1]);
dlarfx_("R", &c__3, &c__3, u, &tau, d__, &c__4, &work[1]);
/* Test whether to reject swap. */
/* Computing MAX */
d__2 = abs(d__[2]), d__3 = abs(d__[6]), d__2 = max(d__2,d__3), d__3 =
(d__1 = d__[10] - t11, abs(d__1));
if (max(d__2,d__3) > thresh) {
goto L50;
}
/* Accept swap: apply transformation to the entire matrix T. */
i__1 = *n - *j1 + 1;
dlarfx_("L", &c__3, &i__1, u, &tau, &t[*j1 + *j1 * t_dim1], ldt, &
work[1]);
dlarfx_("R", &j2, &c__3, u, &tau, &t[*j1 * t_dim1 + 1], ldt, &work[1]);
t[j3 + *j1 * t_dim1] = 0.;
t[j3 + j2 * t_dim1] = 0.;
t[j3 + j3 * t_dim1] = t11;
if (*wantq) {
/* Accumulate transformation in the matrix Q. */
dlarfx_("R", n, &c__3, u, &tau, &q[*j1 * q_dim1 + 1], 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[0];
u[1] = -x[1];
u[2] = scale;
dlarfg_(&c__3, u, &u[1], &c__1, &tau);
u[0] = 1.;
t33 = t[j3 + j3 * t_dim1];
/* Perform swap provisionally on diagonal block in D. */
dlarfx_("L", &c__3, &c__3, u, &tau, d__, &c__4, &work[1]);
dlarfx_("R", &c__3, &c__3, u, &tau, d__, &c__4, &work[1]);
/* Test whether to reject swap. */
/* Computing MAX */
d__2 = abs(d__[1]), d__3 = abs(d__[2]), d__2 = max(d__2,d__3), d__3 =
(d__1 = d__[0] - t33, abs(d__1));
if (max(d__2,d__3) > thresh) {
goto L50;
}
/* Accept swap: apply transformation to the entire matrix T. */
dlarfx_("R", &j3, &c__3, u, &tau, &t[*j1 * t_dim1 + 1], ldt, &work[1]);
i__1 = *n - *j1;
dlarfx_("L", &c__3, &i__1, u, &tau, &t[*j1 + j2 * t_dim1], ldt, &work[
1]);
t[*j1 + *j1 * t_dim1] = t33;
t[j2 + *j1 * t_dim1] = 0.;
t[j3 + *j1 * t_dim1] = 0.;
if (*wantq) {
/* Accumulate transformation in the matrix Q. */
dlarfx_("R", n, &c__3, u, &tau, &q[*j1 * q_dim1 + 1], 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[0];
u1[1] = -x[1];
u1[2] = scale;
dlarfg_(&c__3, u1, &u1[1], &c__1, &tau1);
u1[0] = 1.;
temp = -tau1 * (x[2] + u1[1] * x[3]);
u2[0] = -temp * u1[1] - x[3];
u2[1] = -temp * u1[2];
u2[2] = scale;
dlarfg_(&c__3, u2, &u2[1], &c__1, &tau2);
u2[0] = 1.;
/* Perform swap provisionally on diagonal block in D. */
dlarfx_("L", &c__3, &c__4, u1, &tau1, d__, &c__4, &work[1])
;
dlarfx_("R", &c__4, &c__3, u1, &tau1, d__, &c__4, &work[1])
;
dlarfx_("L", &c__3, &c__4, u2, &tau2, &d__[1], &c__4, &work[1]);
dlarfx_("R", &c__4, &c__3, u2, &tau2, &d__[4], &c__4, &work[1]);
/* Test whether to reject swap. */
/* Computing MAX */
d__1 = abs(d__[2]), d__2 = abs(d__[6]), d__1 = max(d__1,d__2), d__2 =
abs(d__[3]), d__1 = max(d__1,d__2), d__2 = abs(d__[7]);
if (max(d__1,d__2) > thresh) {
goto L50;
}
/* Accept swap: apply transformation to the entire matrix T. */
i__1 = *n - *j1 + 1;
dlarfx_("L", &c__3, &i__1, u1, &tau1, &t[*j1 + *j1 * t_dim1], ldt, &
work[1]);
dlarfx_("R", &j4, &c__3, u1, &tau1, &t[*j1 * t_dim1 + 1], ldt, &work[
1]);
i__1 = *n - *j1 + 1;
dlarfx_("L", &c__3, &i__1, u2, &tau2, &t[j2 + *j1 * t_dim1], ldt, &
work[1]);
dlarfx_("R", &j4, &c__3, u2, &tau2, &t[j2 * t_dim1 + 1], ldt, &work[1]
);
t[j3 + *j1 * t_dim1] = 0.;
t[j3 + j2 * t_dim1] = 0.;
t[j4 + *j1 * t_dim1] = 0.;
t[j4 + j2 * t_dim1] = 0.;
if (*wantq) {
/* Accumulate transformation in the matrix Q. */
dlarfx_("R", n, &c__3, u1, &tau1, &q[*j1 * q_dim1 + 1], ldq, &
work[1]);
dlarfx_("R", n, &c__3, u2, &tau2, &q[j2 * q_dim1 + 1], ldq, &work[
1]);
}
L40:
if (*n2 == 2) {
/* Standardize new 2-by-2 block T11 */
dlanv2_(&t[*j1 + *j1 * t_dim1], &t[*j1 + j2 * t_dim1], &t[j2 + *
j1 * t_dim1], &t[j2 + j2 * t_dim1], &wr1, &wi1, &wr2, &
wi2, &cs, &sn);
i__1 = *n - *j1 - 1;
drot_(&i__1, &t[*j1 + (*j1 + 2) * t_dim1], ldt, &t[j2 + (*j1 + 2)
* t_dim1], ldt, &cs, &sn);
i__1 = *j1 - 1;
drot_(&i__1, &t[*j1 * t_dim1 + 1], &c__1, &t[j2 * t_dim1 + 1], &
c__1, &cs, &sn);
if (*wantq) {
drot_(n, &q[*j1 * q_dim1 + 1], &c__1, &q[j2 * q_dim1 + 1], &
c__1, &cs, &sn);
}
}
if (*n1 == 2) {
/* Standardize new 2-by-2 block T22 */
j3 = *j1 + *n2;
j4 = j3 + 1;
dlanv2_(&t[j3 + j3 * t_dim1], &t[j3 + j4 * t_dim1], &t[j4 + j3 *
t_dim1], &t[j4 + j4 * t_dim1], &wr1, &wi1, &wr2, &wi2, &
cs, &sn);
if (j3 + 2 <= *n) {
i__1 = *n - j3 - 1;
drot_(&i__1, &t[j3 + (j3 + 2) * t_dim1], ldt, &t[j4 + (j3 + 2)
* t_dim1], ldt, &cs, &sn);
}
i__1 = j3 - 1;
drot_(&i__1, &t[j3 * t_dim1 + 1], &c__1, &t[j4 * t_dim1 + 1], &
c__1, &cs, &sn);
if (*wantq) {
drot_(n, &q[j3 * q_dim1 + 1], &c__1, &q[j4 * q_dim1 + 1], &
c__1, &cs, &sn);
}
}
}
return 0;
/* Exit with INFO = 1 if swap was rejected. */
L50:
*info = 1;
return 0;
/* End of DLAEXC */
} /* dlaexc_ */
