/* Subroutine */ int stgsyl_(char *trans, integer *ijob, integer *m, integer *
n, real *a, integer *lda, real *b, integer *ldb, real *c__, integer *
ldc, real *d__, integer *ldd, real *e, integer *lde, real *f, integer
*ldf, real *scale, real *dif, real *work, integer *lwork, integer *
iwork, integer *info)
{
/* System generated locals */
integer a_dim1, a_offset, b_dim1, b_offset, c_dim1, c_offset, d_dim1,
d_offset, e_dim1, e_offset, f_dim1, f_offset, i__1, i__2, i__3,
i__4;
/* Local variables */
integer i__, j, k, p, q, ie, je, mb, nb, is, js, pq;
real dsum;
integer ppqq;
integer ifunc;
integer linfo;
integer lwmin;
real scale2, dscale;
real scaloc;
integer iround;
logical notran;
integer isolve;
logical lquery;
/* -- LAPACK routine (version 3.2) -- */
/* November 2006 */
/* Purpose */
/* ======= */
/* STGSYL solves the generalized Sylvester equation: */
/* A * R - L * B = scale * C (1) */
/* D * R - L * E = scale * F */
/* where R and L are unknown m-by-n matrices, (A, D), (B, E) and */
/* (C, F) are given matrix pairs of size m-by-m, n-by-n and m-by-n, */
/* respectively, with real entries. (A, D) and (B, E) must be in */
/* generalized (real) Schur canonical form, i.e. A, B are upper quasi */
/* triangular and D, E are upper triangular. */
/* The solution (R, L) overwrites (C, F). 0 <= SCALE <= 1 is an output */
/* scaling factor chosen to avoid overflow. */
/* In matrix notation (1) is equivalent to solve Zx = scale b, where */
/* Z is defined as */
/* Z = [ kron(In, A) -kron(B', Im) ] (2) */
/* [ kron(In, D) -kron(E', Im) ]. */
/* Here Ik is the identity matrix of size k and X' is the transpose of */
/* X. kron(X, Y) is the Kronecker product between the matrices X and Y. */
/* If TRANS = 'T', STGSYL solves the transposed system Z'*y = scale*b, */
/* which is equivalent to solve for R and L in */
/* A' * R + D' * L = scale * C (3) */
/* R * B' + L * E' = scale * (-F) */
/* This case (TRANS = 'T') is used to compute an one-norm-based estimate */
/* of Dif[(A,D), (B,E)], the separation between the matrix pairs (A,D) */
/* and (B,E), using SLACON. */
/* If IJOB >= 1, STGSYL computes a Frobenius norm-based estimate */
/* of Dif[(A,D),(B,E)]. That is, the reciprocal of a lower bound on the */
/* reciprocal of the smallest singular value of Z. See [1-2] for more */
/* information. */
/* This is a level 3 BLAS algorithm. */
/* Arguments */
/* ========= */
/* TRANS (input) CHARACTER*1 */
/* = 'N', solve the generalized Sylvester equation (1). */
/* = 'T', solve the 'transposed' system (3). */
/* IJOB (input) INTEGER */
/* Specifies what kind of functionality to be performed. */
/* =0: solve (1) only. */
/* =1: The functionality of 0 and 3. */
/* =2: The functionality of 0 and 4. */
/* =3: Only an estimate of Dif[(A,D), (B,E)] is computed. */
/* (look ahead strategy IJOB = 1 is used). */
/* =4: Only an estimate of Dif[(A,D), (B,E)] is computed. */
/* ( SGECON on sub-systems is used ). */
/* Not referenced if TRANS = 'T'. */
/* M (input) INTEGER */
/* The order of the matrices A and D, and the row dimension of */
/* the matrices C, F, R and L. */
/* N (input) INTEGER */
/* The order of the matrices B and E, and the column dimension */
/* of the matrices C, F, R and L. */
/* A (input) REAL array, dimension (LDA, M) */
/* The upper quasi triangular matrix A. */
/* LDA (input) INTEGER */
/* The leading dimension of the array A. LDA >= max(1, M). */
/* B (input) REAL array, dimension (LDB, N) */
/* The upper quasi triangular matrix B. */
/* LDB (input) INTEGER */
/* The leading dimension of the array B. LDB >= max(1, N). */
/* C (input/output) REAL array, dimension (LDC, N) */
/* On entry, C contains the right-hand-side of the first matrix */
/* equation in (1) or (3). */
/* On exit, if IJOB = 0, 1 or 2, C has been overwritten by */
/* the solution R. If IJOB = 3 or 4 and TRANS = 'N', C holds R, */
/* the solution achieved during the computation of the */
/* Dif-estimate. */
/* LDC (input) INTEGER */
/* The leading dimension of the array C. LDC >= max(1, M). */
/* D (input) REAL array, dimension (LDD, M) */
/* The upper triangular matrix D. */
/* LDD (input) INTEGER */
/* The leading dimension of the array D. LDD >= max(1, M). */
/* E (input) REAL array, dimension (LDE, N) */
/* The upper triangular matrix E. */
/* LDE (input) INTEGER */
/* The leading dimension of the array E. LDE >= max(1, N). */
/* F (input/output) REAL array, dimension (LDF, N) */
/* On entry, F contains the right-hand-side of the second matrix */
/* equation in (1) or (3). */
/* On exit, if IJOB = 0, 1 or 2, F has been overwritten by */
/* the solution L. If IJOB = 3 or 4 and TRANS = 'N', F holds L, */
/* the solution achieved during the computation of the */
/* Dif-estimate. */
/* LDF (input) INTEGER */
/* The leading dimension of the array F. LDF >= max(1, M). */
/* DIF (output) REAL */
/* On exit DIF is the reciprocal of a lower bound of the */
/* reciprocal of the Dif-function, i.e. DIF is an upper bound of */
/* Dif[(A,D), (B,E)] = sigma_min(Z), where Z as in (2). */
/* IF IJOB = 0 or TRANS = 'T', DIF is not touched. */
/* SCALE (output) REAL */
/* On exit SCALE is the scaling factor in (1) or (3). */
/* If 0 < SCALE < 1, C and F hold the solutions R and L, resp., */
/* to a slightly perturbed system but the input matrices A, B, D */
/* and E have not been changed. If SCALE = 0, C and F hold the */
/* solutions R and L, respectively, to the homogeneous system */
/* with C = F = 0. Normally, SCALE = 1. */
/* WORK (workspace/output) REAL array, dimension (MAX(1,LWORK)) */
/* On exit, if INFO = 0, WORK(1) returns the optimal LWORK. */
/* LWORK (input) INTEGER */
/* The dimension of the array WORK. LWORK > = 1. */
/* If IJOB = 1 or 2 and TRANS = 'N', LWORK >= max(1,2*M*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. */
/* IWORK (workspace) INTEGER array, dimension (M+N+6) */
/* INFO (output) INTEGER */
/* =0: successful exit */
/* <0: If INFO = -i, the i-th argument had an illegal value. */
/* >0: (A, D) and (B, E) have common or close eigenvalues. */
/* Further Details */
/* =============== */
/* Based on contributions by */
/* Bo Kagstrom and Peter Poromaa, Department of Computing Science, */
/* Umea University, S-901 87 Umea, Sweden. */
/* [1] B. Kagstrom and P. Poromaa, LAPACK-Style Algorithms and Software */
/* for Solving the Generalized Sylvester Equation and Estimating the */
/* Separation between Regular Matrix Pairs, Report UMINF - 93.23, */
/* Department of Computing Science, Umea University, S-901 87 Umea, */
/* Sweden, December 1993, Revised April 1994, Also as LAPACK Working */
/* Note 75. To appear in ACM Trans. on Math. Software, Vol 22, */
/* No 1, 1996. */
/* [2] B. Kagstrom, A Perturbation Analysis of the Generalized Sylvester */
/* Equation (AR - LB, DR - LE ) = (C, F), SIAM J. Matrix Anal. */
/* Appl., 15(4):1045-1060, 1994 */
/* [3] B. Kagstrom and L. Westin, Generalized Schur Methods with */
/* Condition Estimators for Solving the Generalized Sylvester */
/* Equation, IEEE Transactions on Automatic Control, Vol. 34, No. 7, */
/* July 1989, pp 745-751. */
/* ===================================================================== */
/* Replaced various illegal calls to SCOPY by calls to SLASET. */
/* Sven Hammarling, 1/5/02. */
/* Decode and test input parameters */
/* Parameter adjustments */
a_dim1 = *lda;
a_offset = 1 + a_dim1;
a -= a_offset;
b_dim1 = *ldb;
b_offset = 1 + b_dim1;
b -= b_offset;
c_dim1 = *ldc;
c_offset = 1 + c_dim1;
c__ -= c_offset;
d_dim1 = *ldd;
d_offset = 1 + d_dim1;
d__ -= d_offset;
e_dim1 = *lde;
e_offset = 1 + e_dim1;
e -= e_offset;
f_dim1 = *ldf;
f_offset = 1 + f_dim1;
f -= f_offset;
--work;
--iwork;
/* Function Body */
*info = 0;
notran = lsame_(trans, "N");
lquery = *lwork == -1;
if (! notran && ! lsame_(trans, "T")) {
*info = -1;
} else if (notran) {
if (*ijob < 0 || *ijob > 4) {
*info = -2;
}
}
if (*info == 0) {
if (*m <= 0) {
*info = -3;
} else if (*n <= 0) {
*info = -4;
} else if (*lda < max(1,*m)) {
*info = -6;
} else if (*ldb < max(1,*n)) {
*info = -8;
} else if (*ldc < max(1,*m)) {
*info = -10;
} else if (*ldd < max(1,*m)) {
*info = -12;
} else if (*lde < max(1,*n)) {
*info = -14;
} else if (*ldf < max(1,*m)) {
*info = -16;
}
}
if (*info == 0) {
if (notran) {
if (*ijob == 1 || *ijob == 2) {
/* Computing MAX */
i__1 = 1, i__2 = (*m << 1) * *n;
lwmin = max(i__1,i__2);
} else {
lwmin = 1;
}
} else {
lwmin = 1;
}
work[1] = (real) lwmin;
if (*lwork < lwmin && ! lquery) {
*info = -20;
}
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("STGSYL", &i__1);
return 0;
} else if (lquery) {
return 0;
}
/* Quick return if possible */
if (*m == 0 || *n == 0) {
*scale = 1.f;
if (notran) {
if (*ijob != 0) {
*dif = 0.f;
}
}
return 0;
}
/* Determine optimal block sizes MB and NB */
mb = ilaenv_(&c__2, "STGSYL", trans, m, n, &c_n1, &c_n1);
nb = ilaenv_(&c__5, "STGSYL", trans, m, n, &c_n1, &c_n1);
isolve = 1;
ifunc = 0;
if (notran) {
if (*ijob >= 3) {
ifunc = *ijob - 2;
slaset_("F", m, n, &c_b14, &c_b14, &c__[c_offset], ldc)
;
slaset_("F", m, n, &c_b14, &c_b14, &f[f_offset], ldf);
} else if (*ijob >= 1 && notran) {
isolve = 2;
}
}
if (mb <= 1 && nb <= 1 || mb >= *m && nb >= *n) {
i__1 = isolve;
for (iround = 1; iround <= i__1; ++iround) {
/* Use unblocked Level 2 solver */
dscale = 0.f;
dsum = 1.f;
pq = 0;
stgsy2_(trans, &ifunc, m, n, &a[a_offset], lda, &b[b_offset], ldb,
&c__[c_offset], ldc, &d__[d_offset], ldd, &e[e_offset],
lde, &f[f_offset], ldf, scale, &dsum, &dscale, &iwork[1],
&pq, info);
if (dscale != 0.f) {
if (*ijob == 1 || *ijob == 3) {
*dif = sqrt((real) ((*m << 1) * *n)) / (dscale * sqrt(
dsum));
} else {
*dif = sqrt((real) pq) / (dscale * sqrt(dsum));
}
}
if (isolve == 2 && iround == 1) {
if (notran) {
ifunc = *ijob;
}
scale2 = *scale;
slacpy_("F", m, n, &c__[c_offset], ldc, &work[1], m);
slacpy_("F", m, n, &f[f_offset], ldf, &work[*m * *n + 1], m);
slaset_("F", m, n, &c_b14, &c_b14, &c__[c_offset], ldc);
slaset_("F", m, n, &c_b14, &c_b14, &f[f_offset], ldf);
} else if (isolve == 2 && iround == 2) {
slacpy_("F", m, n, &work[1], m, &c__[c_offset], ldc);
slacpy_("F", m, n, &work[*m * *n + 1], m, &f[f_offset], ldf);
*scale = scale2;
}
}
return 0;
}
/* Determine block structure of A */
p = 0;
i__ = 1;
L40:
if (i__ > *m) {
goto L50;
}
++p;
iwork[p] = i__;
i__ += mb;
if (i__ >= *m) {
goto L50;
}
if (a[i__ + (i__ - 1) * a_dim1] != 0.f) {
++i__;
}
goto L40;
L50:
iwork[p + 1] = *m + 1;
if (iwork[p] == iwork[p + 1]) {
--p;
}
/* Determine block structure of B */
q = p + 1;
j = 1;
L60:
if (j > *n) {
goto L70;
}
++q;
iwork[q] = j;
j += nb;
if (j >= *n) {
goto L70;
}
if (b[j + (j - 1) * b_dim1] != 0.f) {
++j;
}
goto L60;
L70:
iwork[q + 1] = *n + 1;
if (iwork[q] == iwork[q + 1]) {
--q;
}
if (notran) {
i__1 = isolve;
for (iround = 1; iround <= i__1; ++iround) {
/* Solve (I, J)-subsystem */
/* A(I, I) * R(I, J) - L(I, J) * B(J, J) = C(I, J) */
/* D(I, I) * R(I, J) - L(I, J) * E(J, J) = F(I, J) */
dscale = 0.f;
dsum = 1.f;
pq = 0;
*scale = 1.f;
i__2 = q;
for (j = p + 2; j <= i__2; ++j) {
js = iwork[j];
je = iwork[j + 1] - 1;
nb = je - js + 1;
for (i__ = p; i__ >= 1; --i__) {
is = iwork[i__];
ie = iwork[i__ + 1] - 1;
mb = ie - is + 1;
ppqq = 0;
stgsy2_(trans, &ifunc, &mb, &nb, &a[is + is * a_dim1],
lda, &b[js + js * b_dim1], ldb, &c__[is + js *
c_dim1], ldc, &d__[is + is * d_dim1], ldd, &e[js
+ js * e_dim1], lde, &f[is + js * f_dim1], ldf, &
scaloc, &dsum, &dscale, &iwork[q + 2], &ppqq, &
linfo);
if (linfo > 0) {
*info = linfo;
}
pq += ppqq;
if (scaloc != 1.f) {
i__3 = js - 1;
for (k = 1; k <= i__3; ++k) {
sscal_(m, &scaloc, &c__[k * c_dim1 + 1], &c__1);
sscal_(m, &scaloc, &f[k * f_dim1 + 1], &c__1);
}
i__3 = je;
for (k = js; k <= i__3; ++k) {
i__4 = is - 1;
sscal_(&i__4, &scaloc, &c__[k * c_dim1 + 1], &
c__1);
i__4 = is - 1;
sscal_(&i__4, &scaloc, &f[k * f_dim1 + 1], &c__1);
}
i__3 = je;
for (k = js; k <= i__3; ++k) {
i__4 = *m - ie;
sscal_(&i__4, &scaloc, &c__[ie + 1 + k * c_dim1],
&c__1);
i__4 = *m - ie;
sscal_(&i__4, &scaloc, &f[ie + 1 + k * f_dim1], &
c__1);
}
i__3 = *n;
for (k = je + 1; k <= i__3; ++k) {
sscal_(m, &scaloc, &c__[k * c_dim1 + 1], &c__1);
sscal_(m, &scaloc, &f[k * f_dim1 + 1], &c__1);
}
*scale *= scaloc;
}
/* Substitute R(I, J) and L(I, J) into remaining */
/* equation. */
if (i__ > 1) {
i__3 = is - 1;
sgemm_("N", "N", &i__3, &nb, &mb, &c_b51, &a[is *
a_dim1 + 1], lda, &c__[is + js * c_dim1], ldc,
&c_b52, &c__[js * c_dim1 + 1], ldc);
i__3 = is - 1;
sgemm_("N", "N", &i__3, &nb, &mb, &c_b51, &d__[is *
d_dim1 + 1], ldd, &c__[is + js * c_dim1], ldc,
&c_b52, &f[js * f_dim1 + 1], ldf);
}
if (j < q) {
i__3 = *n - je;
sgemm_("N", "N", &mb, &i__3, &nb, &c_b52, &f[is + js *
f_dim1], ldf, &b[js + (je + 1) * b_dim1],
ldb, &c_b52, &c__[is + (je + 1) * c_dim1],
ldc);
i__3 = *n - je;
sgemm_("N", "N", &mb, &i__3, &nb, &c_b52, &f[is + js *
f_dim1], ldf, &e[js + (je + 1) * e_dim1],
lde, &c_b52, &f[is + (je + 1) * f_dim1], ldf);
}
}
}
if (dscale != 0.f) {
if (*ijob == 1 || *ijob == 3) {
*dif = sqrt((real) ((*m << 1) * *n)) / (dscale * sqrt(
dsum));
} else {
*dif = sqrt((real) pq) / (dscale * sqrt(dsum));
}
}
if (isolve == 2 && iround == 1) {
if (notran) {
ifunc = *ijob;
}
scale2 = *scale;
slacpy_("F", m, n, &c__[c_offset], ldc, &work[1], m);
slacpy_("F", m, n, &f[f_offset], ldf, &work[*m * *n + 1], m);
slaset_("F", m, n, &c_b14, &c_b14, &c__[c_offset], ldc);
slaset_("F", m, n, &c_b14, &c_b14, &f[f_offset], ldf);
} else if (isolve == 2 && iround == 2) {
slacpy_("F", m, n, &work[1], m, &c__[c_offset], ldc);
slacpy_("F", m, n, &work[*m * *n + 1], m, &f[f_offset], ldf);
*scale = scale2;
}
}
} else {
/* Solve transposed (I, J)-subsystem */
/* A(I, I)' * R(I, J) + D(I, I)' * L(I, J) = C(I, J) */
/* R(I, J) * B(J, J)' + L(I, J) * E(J, J)' = -F(I, J) */
*scale = 1.f;
i__1 = p;
for (i__ = 1; i__ <= i__1; ++i__) {
is = iwork[i__];
ie = iwork[i__ + 1] - 1;
mb = ie - is + 1;
i__2 = p + 2;
for (j = q; j >= i__2; --j) {
js = iwork[j];
je = iwork[j + 1] - 1;
nb = je - js + 1;
stgsy2_(trans, &ifunc, &mb, &nb, &a[is + is * a_dim1], lda, &
b[js + js * b_dim1], ldb, &c__[is + js * c_dim1], ldc,
&d__[is + is * d_dim1], ldd, &e[js + js * e_dim1],
lde, &f[is + js * f_dim1], ldf, &scaloc, &dsum, &
dscale, &iwork[q + 2], &ppqq, &linfo);
if (linfo > 0) {
*info = linfo;
}
if (scaloc != 1.f) {
i__3 = js - 1;
for (k = 1; k <= i__3; ++k) {
sscal_(m, &scaloc, &c__[k * c_dim1 + 1], &c__1);
sscal_(m, &scaloc, &f[k * f_dim1 + 1], &c__1);
}
i__3 = je;
for (k = js; k <= i__3; ++k) {
i__4 = is - 1;
sscal_(&i__4, &scaloc, &c__[k * c_dim1 + 1], &c__1);
i__4 = is - 1;
sscal_(&i__4, &scaloc, &f[k * f_dim1 + 1], &c__1);
}
i__3 = je;
for (k = js; k <= i__3; ++k) {
i__4 = *m - ie;
sscal_(&i__4, &scaloc, &c__[ie + 1 + k * c_dim1], &
c__1);
i__4 = *m - ie;
sscal_(&i__4, &scaloc, &f[ie + 1 + k * f_dim1], &c__1)
;
}
i__3 = *n;
for (k = je + 1; k <= i__3; ++k) {
sscal_(m, &scaloc, &c__[k * c_dim1 + 1], &c__1);
sscal_(m, &scaloc, &f[k * f_dim1 + 1], &c__1);
}
*scale *= scaloc;
}
/* Substitute R(I, J) and L(I, J) into remaining equation. */
if (j > p + 2) {
i__3 = js - 1;
sgemm_("N", "T", &mb, &i__3, &nb, &c_b52, &c__[is + js *
c_dim1], ldc, &b[js * b_dim1 + 1], ldb, &c_b52, &
f[is + f_dim1], ldf);
i__3 = js - 1;
sgemm_("N", "T", &mb, &i__3, &nb, &c_b52, &f[is + js *
f_dim1], ldf, &e[js * e_dim1 + 1], lde, &c_b52, &
f[is + f_dim1], ldf);
}
if (i__ < p) {
i__3 = *m - ie;
sgemm_("T", "N", &i__3, &nb, &mb, &c_b51, &a[is + (ie + 1)
* a_dim1], lda, &c__[is + js * c_dim1], ldc, &
c_b52, &c__[ie + 1 + js * c_dim1], ldc);
i__3 = *m - ie;
sgemm_("T", "N", &i__3, &nb, &mb, &c_b51, &d__[is + (ie +
1) * d_dim1], ldd, &f[is + js * f_dim1], ldf, &
c_b52, &c__[ie + 1 + js * c_dim1], ldc);
}
}
}
}
work[1] = (real) lwmin;
return 0;
/* End of STGSYL */
} /* stgsyl_ */
/* Subroutine */ int stgex2_(logical *wantq, logical *wantz, integer *n, real
*a, integer *lda, real *b, integer *ldb, real *q, integer *ldq, real *
z__, integer *ldz, integer *j1, integer *n1, integer *n2, real *work,
integer *lwork, integer *info)
{
/* System generated locals */
integer a_dim1, a_offset, b_dim1, b_offset, q_dim1, q_offset, z_dim1,
z_offset, i__1, i__2;
real r__1;
/* Builtin functions */
double sqrt(doublereal);
/* Local variables */
real f, g;
integer i__, m;
real s[16] /* was [4][4] */, t[16] /* was [4][4] */, be[2], ai[2], ar[2],
sa, sb, li[16] /* was [4][4] */, ir[16] /* was [4][4]
*/, ss, ws, eps;
logical weak;
real ddum;
integer idum;
real taul[4], dsum, taur[4], scpy[16] /* was [4][4] */, tcpy[16]
/* was [4][4] */;
extern /* Subroutine */ int srot_(integer *, real *, integer *, real *,
integer *, real *, real *);
real scale, bqra21, brqa21;
extern /* Subroutine */ int sscal_(integer *, real *, real *, integer *);
real licop[16] /* was [4][4] */;
integer linfo;
extern /* Subroutine */ int sgemm_(char *, char *, integer *, integer *,
integer *, real *, real *, integer *, real *, integer *, real *,
real *, integer *);
real ircop[16] /* was [4][4] */, dnorm;
integer iwork[4];
extern /* Subroutine */ int slagv2_(real *, integer *, real *, integer *,
real *, real *, real *, real *, real *, real *, real *), sgeqr2_(
integer *, integer *, real *, integer *, real *, real *, integer *
), sgerq2_(integer *, integer *, real *, integer *, real *, real *
, integer *), sorg2r_(integer *, integer *, integer *, real *,
integer *, real *, real *, integer *), sorgr2_(integer *, integer
*, integer *, real *, integer *, real *, real *, integer *),
sorm2r_(char *, char *, integer *, integer *, integer *, real *,
integer *, real *, real *, integer *, real *, integer *), sormr2_(char *, char *, integer *, integer *, integer *,
real *, integer *, real *, real *, integer *, real *, integer *);
real dscale;
extern /* Subroutine */ int stgsy2_(char *, integer *, integer *, integer
*, real *, integer *, real *, integer *, real *, integer *, real *
, integer *, real *, integer *, real *, integer *, real *, real *,
real *, integer *, integer *, integer *);
extern doublereal slamch_(char *);
extern /* Subroutine */ int slacpy_(char *, integer *, integer *, real *,
integer *, real *, integer *), slartg_(real *, real *,
real *, real *, real *);
real thresh;
extern /* Subroutine */ int slaset_(char *, integer *, integer *, real *,
real *, real *, integer *), slassq_(integer *, real *,
integer *, real *, real *);
real smlnum;
logical strong;
/* -- LAPACK auxiliary routine (version 3.1) -- */
/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/* November 2006 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* STGEX2 swaps adjacent diagonal blocks (A11, B11) and (A22, B22) */
/* of size 1-by-1 or 2-by-2 in an upper (quasi) triangular matrix pair */
/* (A, B) by an orthogonal equivalence transformation. */
/* (A, B) must be in generalized real Schur canonical form (as returned */
/* by SGGES), i.e. A is block upper triangular with 1-by-1 and 2-by-2 */
/* diagonal blocks. B is upper triangular. */
/* Optionally, the matrices Q and Z of generalized Schur vectors are */
/* updated. */
/* Q(in) * A(in) * Z(in)' = Q(out) * A(out) * Z(out)' */
/* Q(in) * B(in) * Z(in)' = Q(out) * B(out) * Z(out)' */
/* Arguments */
/* ========= */
/* WANTQ (input) LOGICAL */
/* .TRUE. : update the left transformation matrix Q; */
/* .FALSE.: do not update Q. */
/* WANTZ (input) LOGICAL */
/* .TRUE. : update the right transformation matrix Z; */
/* .FALSE.: do not update Z. */
/* N (input) INTEGER */
/* The order of the matrices A and B. N >= 0. */
/* A (input/output) REAL arrays, dimensions (LDA,N) */
/* On entry, the matrix A in the pair (A, B). */
/* On exit, the updated matrix A. */
/* LDA (input) INTEGER */
/* The leading dimension of the array A. LDA >= max(1,N). */
/* B (input/output) REAL arrays, dimensions (LDB,N) */
/* On entry, the matrix B in the pair (A, B). */
/* On exit, the updated matrix B. */
/* LDB (input) INTEGER */
/* The leading dimension of the array B. LDB >= max(1,N). */
/* Q (input/output) REAL array, dimension (LDZ,N) */
/* On entry, if WANTQ = .TRUE., the orthogonal matrix Q. */
/* On exit, the updated matrix Q. */
/* Not referenced if WANTQ = .FALSE.. */
/* LDQ (input) INTEGER */
/* The leading dimension of the array Q. LDQ >= 1. */
/* If WANTQ = .TRUE., LDQ >= N. */
/* Z (input/output) REAL array, dimension (LDZ,N) */
/* On entry, if WANTZ =.TRUE., the orthogonal matrix Z. */
/* On exit, the updated matrix Z. */
/* Not referenced if WANTZ = .FALSE.. */
/* LDZ (input) INTEGER */
/* The leading dimension of the array Z. LDZ >= 1. */
/* If WANTZ = .TRUE., LDZ >= N. */
/* J1 (input) INTEGER */
/* The index to the first block (A11, B11). 1 <= J1 <= N. */
/* N1 (input) INTEGER */
/* The order of the first block (A11, B11). N1 = 0, 1 or 2. */
/* N2 (input) INTEGER */
/* The order of the second block (A22, B22). N2 = 0, 1 or 2. */
/* WORK (workspace) REAL array, dimension (MAX(1,LWORK)). */
/* LWORK (input) INTEGER */
/* The dimension of the array WORK. */
/* LWORK >= MAX( N*(N2+N1), (N2+N1)*(N2+N1)*2 ) */
/* INFO (output) INTEGER */
/* =0: Successful exit */
/* >0: If INFO = 1, the transformed matrix (A, B) would be */
/* too far from generalized Schur form; the blocks are */
/* not swapped and (A, B) and (Q, Z) are unchanged. */
/* The problem of swapping is too ill-conditioned. */
/* <0: If INFO = -16: LWORK is too small. Appropriate value */
/* for LWORK is returned in WORK(1). */
/* Further Details */
/* =============== */
/* Based on contributions by */
/* Bo Kagstrom and Peter Poromaa, Department of Computing Science, */
/* Umea University, S-901 87 Umea, Sweden. */
/* In the current code both weak and strong stability tests are */
/* performed. The user can omit the strong stability test by changing */
/* the internal logical parameter WANDS to .FALSE.. See ref. [2] for */
/* details. */
/* [1] B. Kagstrom; A Direct Method for Reordering Eigenvalues in the */
/* Generalized Real Schur Form of a Regular Matrix Pair (A, B), in */
/* M.S. Moonen et al (eds), Linear Algebra for Large Scale and */
/* Real-Time Applications, Kluwer Academic Publ. 1993, pp 195-218. */
/* [2] B. Kagstrom and P. Poromaa; Computing Eigenspaces with Specified */
/* Eigenvalues of a Regular Matrix Pair (A, B) and Condition */
/* Estimation: Theory, Algorithms and Software, */
/* Report UMINF - 94.04, Department of Computing Science, Umea */
/* University, S-901 87 Umea, Sweden, 1994. Also as LAPACK Working */
/* Note 87. To appear in Numerical Algorithms, 1996. */
/* ===================================================================== */
/* Replaced various illegal calls to SCOPY by calls to SLASET, or by DO */
/* loops. Sven Hammarling, 1/5/02. */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. Local Arrays .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Executable Statements .. */
/* Parameter adjustments */
a_dim1 = *lda;
a_offset = 1 + a_dim1;
a -= a_offset;
b_dim1 = *ldb;
b_offset = 1 + b_dim1;
b -= b_offset;
q_dim1 = *ldq;
q_offset = 1 + q_dim1;
q -= q_offset;
z_dim1 = *ldz;
z_offset = 1 + z_dim1;
z__ -= z_offset;
--work;
/* Function Body */
*info = 0;
/* Quick return if possible */
if (*n <= 1 || *n1 <= 0 || *n2 <= 0) {
return 0;
}
if (*n1 > *n || *j1 + *n1 > *n) {
return 0;
}
m = *n1 + *n2;
/* Computing MAX */
i__1 = *n * m, i__2 = m * m << 1;
if (*lwork < max(i__1,i__2)) {
*info = -16;
/* Computing MAX */
i__1 = *n * m, i__2 = m * m << 1;
work[1] = (real) max(i__1,i__2);
return 0;
}
weak = FALSE_;
strong = FALSE_;
/* Make a local copy of selected block */
slaset_("Full", &c__4, &c__4, &c_b5, &c_b5, li, &c__4);
slaset_("Full", &c__4, &c__4, &c_b5, &c_b5, ir, &c__4);
slacpy_("Full", &m, &m, &a[*j1 + *j1 * a_dim1], lda, s, &c__4);
slacpy_("Full", &m, &m, &b[*j1 + *j1 * b_dim1], ldb, t, &c__4);
/* Compute threshold for testing acceptance of swapping. */
eps = slamch_("P");
smlnum = slamch_("S") / eps;
dscale = 0.f;
dsum = 1.f;
slacpy_("Full", &m, &m, s, &c__4, &work[1], &m);
i__1 = m * m;
slassq_(&i__1, &work[1], &c__1, &dscale, &dsum);
slacpy_("Full", &m, &m, t, &c__4, &work[1], &m);
i__1 = m * m;
slassq_(&i__1, &work[1], &c__1, &dscale, &dsum);
dnorm = dscale * sqrt(dsum);
/* Computing MAX */
r__1 = eps * 10.f * dnorm;
thresh = dmax(r__1,smlnum);
if (m == 2) {
/* CASE 1: Swap 1-by-1 and 1-by-1 blocks. */
/* Compute orthogonal QL and RQ that swap 1-by-1 and 1-by-1 blocks */
/* using Givens rotations and perform the swap tentatively. */
f = s[5] * t[0] - t[5] * s[0];
g = s[5] * t[4] - t[5] * s[4];
sb = dabs(t[5]);
sa = dabs(s[5]);
slartg_(&f, &g, &ir[4], ir, &ddum);
ir[1] = -ir[4];
ir[5] = ir[0];
srot_(&c__2, s, &c__1, &s[4], &c__1, ir, &ir[1]);
srot_(&c__2, t, &c__1, &t[4], &c__1, ir, &ir[1]);
if (sa >= sb) {
slartg_(s, &s[1], li, &li[1], &ddum);
} else {
slartg_(t, &t[1], li, &li[1], &ddum);
}
srot_(&c__2, s, &c__4, &s[1], &c__4, li, &li[1]);
srot_(&c__2, t, &c__4, &t[1], &c__4, li, &li[1]);
li[5] = li[0];
li[4] = -li[1];
/* Weak stability test: */
/* |S21| + |T21| <= O(EPS * F-norm((S, T))) */
ws = dabs(s[1]) + dabs(t[1]);
weak = ws <= thresh;
if (! weak) {
goto L70;
}
if (TRUE_) {
/* Strong stability test: */
/* F-norm((A-QL'*S*QR, B-QL'*T*QR)) <= O(EPS*F-norm((A,B))) */
slacpy_("Full", &m, &m, &a[*j1 + *j1 * a_dim1], lda, &work[m * m
+ 1], &m);
sgemm_("N", "N", &m, &m, &m, &c_b42, li, &c__4, s, &c__4, &c_b5, &
work[1], &m);
sgemm_("N", "T", &m, &m, &m, &c_b48, &work[1], &m, ir, &c__4, &
c_b42, &work[m * m + 1], &m);
dscale = 0.f;
dsum = 1.f;
i__1 = m * m;
slassq_(&i__1, &work[m * m + 1], &c__1, &dscale, &dsum);
slacpy_("Full", &m, &m, &b[*j1 + *j1 * b_dim1], ldb, &work[m * m
+ 1], &m);
sgemm_("N", "N", &m, &m, &m, &c_b42, li, &c__4, t, &c__4, &c_b5, &
work[1], &m);
sgemm_("N", "T", &m, &m, &m, &c_b48, &work[1], &m, ir, &c__4, &
c_b42, &work[m * m + 1], &m);
i__1 = m * m;
slassq_(&i__1, &work[m * m + 1], &c__1, &dscale, &dsum);
ss = dscale * sqrt(dsum);
strong = ss <= thresh;
if (! strong) {
goto L70;
}
}
/* Update (A(J1:J1+M-1, M+J1:N), B(J1:J1+M-1, M+J1:N)) and */
/* (A(1:J1-1, J1:J1+M), B(1:J1-1, J1:J1+M)). */
i__1 = *j1 + 1;
srot_(&i__1, &a[*j1 * a_dim1 + 1], &c__1, &a[(*j1 + 1) * a_dim1 + 1],
&c__1, ir, &ir[1]);
i__1 = *j1 + 1;
srot_(&i__1, &b[*j1 * b_dim1 + 1], &c__1, &b[(*j1 + 1) * b_dim1 + 1],
&c__1, ir, &ir[1]);
i__1 = *n - *j1 + 1;
srot_(&i__1, &a[*j1 + *j1 * a_dim1], lda, &a[*j1 + 1 + *j1 * a_dim1],
lda, li, &li[1]);
i__1 = *n - *j1 + 1;
srot_(&i__1, &b[*j1 + *j1 * b_dim1], ldb, &b[*j1 + 1 + *j1 * b_dim1],
ldb, li, &li[1]);
/* Set N1-by-N2 (2,1) - blocks to ZERO. */
a[*j1 + 1 + *j1 * a_dim1] = 0.f;
b[*j1 + 1 + *j1 * b_dim1] = 0.f;
/* Accumulate transformations into Q and Z if requested. */
if (*wantz) {
srot_(n, &z__[*j1 * z_dim1 + 1], &c__1, &z__[(*j1 + 1) * z_dim1 +
1], &c__1, ir, &ir[1]);
}
if (*wantq) {
srot_(n, &q[*j1 * q_dim1 + 1], &c__1, &q[(*j1 + 1) * q_dim1 + 1],
&c__1, li, &li[1]);
}
/* Exit with INFO = 0 if swap was successfully performed. */
return 0;
} else {
/* CASE 2: Swap 1-by-1 and 2-by-2 blocks, or 2-by-2 */
/* and 2-by-2 blocks. */
/* Solve the generalized Sylvester equation */
/* S11 * R - L * S22 = SCALE * S12 */
/* T11 * R - L * T22 = SCALE * T12 */
/* for R and L. Solutions in LI and IR. */
slacpy_("Full", n1, n2, &t[(*n1 + 1 << 2) - 4], &c__4, li, &c__4);
slacpy_("Full", n1, n2, &s[(*n1 + 1 << 2) - 4], &c__4, &ir[*n2 + 1 + (
*n1 + 1 << 2) - 5], &c__4);
stgsy2_("N", &c__0, n1, n2, s, &c__4, &s[*n1 + 1 + (*n1 + 1 << 2) - 5]
, &c__4, &ir[*n2 + 1 + (*n1 + 1 << 2) - 5], &c__4, t, &c__4, &
t[*n1 + 1 + (*n1 + 1 << 2) - 5], &c__4, li, &c__4, &scale, &
dsum, &dscale, iwork, &idum, &linfo);
/* Compute orthogonal matrix QL: */
/* QL' * LI = [ TL ] */
/* [ 0 ] */
/* where */
/* LI = [ -L ] */
/* [ SCALE * identity(N2) ] */
i__1 = *n2;
for (i__ = 1; i__ <= i__1; ++i__) {
sscal_(n1, &c_b48, &li[(i__ << 2) - 4], &c__1);
li[*n1 + i__ + (i__ << 2) - 5] = scale;
/* L10: */
}
sgeqr2_(&m, n2, li, &c__4, taul, &work[1], &linfo);
if (linfo != 0) {
goto L70;
}
sorg2r_(&m, &m, n2, li, &c__4, taul, &work[1], &linfo);
if (linfo != 0) {
goto L70;
}
/* Compute orthogonal matrix RQ: */
/* IR * RQ' = [ 0 TR], */
/* where IR = [ SCALE * identity(N1), R ] */
i__1 = *n1;
for (i__ = 1; i__ <= i__1; ++i__) {
ir[*n2 + i__ + (i__ << 2) - 5] = scale;
/* L20: */
}
sgerq2_(n1, &m, &ir[*n2], &c__4, taur, &work[1], &linfo);
if (linfo != 0) {
goto L70;
}
sorgr2_(&m, &m, n1, ir, &c__4, taur, &work[1], &linfo);
if (linfo != 0) {
goto L70;
}
/* Perform the swapping tentatively: */
sgemm_("T", "N", &m, &m, &m, &c_b42, li, &c__4, s, &c__4, &c_b5, &
work[1], &m);
sgemm_("N", "T", &m, &m, &m, &c_b42, &work[1], &m, ir, &c__4, &c_b5,
s, &c__4);
sgemm_("T", "N", &m, &m, &m, &c_b42, li, &c__4, t, &c__4, &c_b5, &
work[1], &m);
sgemm_("N", "T", &m, &m, &m, &c_b42, &work[1], &m, ir, &c__4, &c_b5,
t, &c__4);
slacpy_("F", &m, &m, s, &c__4, scpy, &c__4);
slacpy_("F", &m, &m, t, &c__4, tcpy, &c__4);
slacpy_("F", &m, &m, ir, &c__4, ircop, &c__4);
slacpy_("F", &m, &m, li, &c__4, licop, &c__4);
/* Triangularize the B-part by an RQ factorization. */
/* Apply transformation (from left) to A-part, giving S. */
sgerq2_(&m, &m, t, &c__4, taur, &work[1], &linfo);
if (linfo != 0) {
goto L70;
}
sormr2_("R", "T", &m, &m, &m, t, &c__4, taur, s, &c__4, &work[1], &
linfo);
if (linfo != 0) {
goto L70;
}
sormr2_("L", "N", &m, &m, &m, t, &c__4, taur, ir, &c__4, &work[1], &
linfo);
if (linfo != 0) {
goto L70;
}
/* Compute F-norm(S21) in BRQA21. (T21 is 0.) */
dscale = 0.f;
dsum = 1.f;
i__1 = *n2;
for (i__ = 1; i__ <= i__1; ++i__) {
slassq_(n1, &s[*n2 + 1 + (i__ << 2) - 5], &c__1, &dscale, &dsum);
/* L30: */
}
brqa21 = dscale * sqrt(dsum);
/* Triangularize the B-part by a QR factorization. */
/* Apply transformation (from right) to A-part, giving S. */
sgeqr2_(&m, &m, tcpy, &c__4, taul, &work[1], &linfo);
if (linfo != 0) {
goto L70;
}
sorm2r_("L", "T", &m, &m, &m, tcpy, &c__4, taul, scpy, &c__4, &work[1]
, info);
sorm2r_("R", "N", &m, &m, &m, tcpy, &c__4, taul, licop, &c__4, &work[
1], info);
if (linfo != 0) {
goto L70;
}
/* Compute F-norm(S21) in BQRA21. (T21 is 0.) */
dscale = 0.f;
dsum = 1.f;
i__1 = *n2;
for (i__ = 1; i__ <= i__1; ++i__) {
slassq_(n1, &scpy[*n2 + 1 + (i__ << 2) - 5], &c__1, &dscale, &
dsum);
/* L40: */
}
bqra21 = dscale * sqrt(dsum);
/* Decide which method to use. */
/* Weak stability test: */
/* F-norm(S21) <= O(EPS * F-norm((S, T))) */
if (bqra21 <= brqa21 && bqra21 <= thresh) {
slacpy_("F", &m, &m, scpy, &c__4, s, &c__4);
slacpy_("F", &m, &m, tcpy, &c__4, t, &c__4);
slacpy_("F", &m, &m, ircop, &c__4, ir, &c__4);
slacpy_("F", &m, &m, licop, &c__4, li, &c__4);
} else if (brqa21 >= thresh) {
goto L70;
}
/* Set lower triangle of B-part to zero */
i__1 = m - 1;
i__2 = m - 1;
slaset_("Lower", &i__1, &i__2, &c_b5, &c_b5, &t[1], &c__4);
if (TRUE_) {
/* Strong stability test: */
/* F-norm((A-QL*S*QR', B-QL*T*QR')) <= O(EPS*F-norm((A,B))) */
slacpy_("Full", &m, &m, &a[*j1 + *j1 * a_dim1], lda, &work[m * m
+ 1], &m);
sgemm_("N", "N", &m, &m, &m, &c_b42, li, &c__4, s, &c__4, &c_b5, &
work[1], &m);
sgemm_("N", "N", &m, &m, &m, &c_b48, &work[1], &m, ir, &c__4, &
c_b42, &work[m * m + 1], &m);
dscale = 0.f;
dsum = 1.f;
i__1 = m * m;
slassq_(&i__1, &work[m * m + 1], &c__1, &dscale, &dsum);
slacpy_("Full", &m, &m, &b[*j1 + *j1 * b_dim1], ldb, &work[m * m
+ 1], &m);
sgemm_("N", "N", &m, &m, &m, &c_b42, li, &c__4, t, &c__4, &c_b5, &
work[1], &m);
sgemm_("N", "N", &m, &m, &m, &c_b48, &work[1], &m, ir, &c__4, &
c_b42, &work[m * m + 1], &m);
i__1 = m * m;
slassq_(&i__1, &work[m * m + 1], &c__1, &dscale, &dsum);
ss = dscale * sqrt(dsum);
strong = ss <= thresh;
if (! strong) {
goto L70;
}
}
/* If the swap is accepted ("weakly" and "strongly"), apply the */
/* transformations and set N1-by-N2 (2,1)-block to zero. */
slaset_("Full", n1, n2, &c_b5, &c_b5, &s[*n2], &c__4);
/* copy back M-by-M diagonal block starting at index J1 of (A, B) */
slacpy_("F", &m, &m, s, &c__4, &a[*j1 + *j1 * a_dim1], lda)
;
slacpy_("F", &m, &m, t, &c__4, &b[*j1 + *j1 * b_dim1], ldb)
;
slaset_("Full", &c__4, &c__4, &c_b5, &c_b5, t, &c__4);
/* Standardize existing 2-by-2 blocks. */
i__1 = m * m;
for (i__ = 1; i__ <= i__1; ++i__) {
work[i__] = 0.f;
/* L50: */
}
work[1] = 1.f;
t[0] = 1.f;
idum = *lwork - m * m - 2;
if (*n2 > 1) {
slagv2_(&a[*j1 + *j1 * a_dim1], lda, &b[*j1 + *j1 * b_dim1], ldb,
ar, ai, be, &work[1], &work[2], t, &t[1]);
work[m + 1] = -work[2];
work[m + 2] = work[1];
t[*n2 + (*n2 << 2) - 5] = t[0];
t[4] = -t[1];
}
work[m * m] = 1.f;
t[m + (m << 2) - 5] = 1.f;
if (*n1 > 1) {
slagv2_(&a[*j1 + *n2 + (*j1 + *n2) * a_dim1], lda, &b[*j1 + *n2 +
(*j1 + *n2) * b_dim1], ldb, taur, taul, &work[m * m + 1],
&work[*n2 * m + *n2 + 1], &work[*n2 * m + *n2 + 2], &t[*
n2 + 1 + (*n2 + 1 << 2) - 5], &t[m + (m - 1 << 2) - 5]);
work[m * m] = work[*n2 * m + *n2 + 1];
work[m * m - 1] = -work[*n2 * m + *n2 + 2];
t[m + (m << 2) - 5] = t[*n2 + 1 + (*n2 + 1 << 2) - 5];
t[m - 1 + (m << 2) - 5] = -t[m + (m - 1 << 2) - 5];
}
sgemm_("T", "N", n2, n1, n2, &c_b42, &work[1], &m, &a[*j1 + (*j1 + *
n2) * a_dim1], lda, &c_b5, &work[m * m + 1], n2);
slacpy_("Full", n2, n1, &work[m * m + 1], n2, &a[*j1 + (*j1 + *n2) *
a_dim1], lda);
sgemm_("T", "N", n2, n1, n2, &c_b42, &work[1], &m, &b[*j1 + (*j1 + *
n2) * b_dim1], ldb, &c_b5, &work[m * m + 1], n2);
slacpy_("Full", n2, n1, &work[m * m + 1], n2, &b[*j1 + (*j1 + *n2) *
b_dim1], ldb);
sgemm_("N", "N", &m, &m, &m, &c_b42, li, &c__4, &work[1], &m, &c_b5, &
work[m * m + 1], &m);
slacpy_("Full", &m, &m, &work[m * m + 1], &m, li, &c__4);
sgemm_("N", "N", n2, n1, n1, &c_b42, &a[*j1 + (*j1 + *n2) * a_dim1],
lda, &t[*n2 + 1 + (*n2 + 1 << 2) - 5], &c__4, &c_b5, &work[1],
n2);
slacpy_("Full", n2, n1, &work[1], n2, &a[*j1 + (*j1 + *n2) * a_dim1],
lda);
sgemm_("N", "N", n2, n1, n1, &c_b42, &b[*j1 + (*j1 + *n2) * b_dim1],
ldb, &t[*n2 + 1 + (*n2 + 1 << 2) - 5], &c__4, &c_b5, &work[1],
n2);
slacpy_("Full", n2, n1, &work[1], n2, &b[*j1 + (*j1 + *n2) * b_dim1],
ldb);
sgemm_("T", "N", &m, &m, &m, &c_b42, ir, &c__4, t, &c__4, &c_b5, &
work[1], &m);
slacpy_("Full", &m, &m, &work[1], &m, ir, &c__4);
/* Accumulate transformations into Q and Z if requested. */
if (*wantq) {
sgemm_("N", "N", n, &m, &m, &c_b42, &q[*j1 * q_dim1 + 1], ldq, li,
&c__4, &c_b5, &work[1], n);
slacpy_("Full", n, &m, &work[1], n, &q[*j1 * q_dim1 + 1], ldq);
}
if (*wantz) {
sgemm_("N", "N", n, &m, &m, &c_b42, &z__[*j1 * z_dim1 + 1], ldz,
ir, &c__4, &c_b5, &work[1], n);
slacpy_("Full", n, &m, &work[1], n, &z__[*j1 * z_dim1 + 1], ldz);
}
/* Update (A(J1:J1+M-1, M+J1:N), B(J1:J1+M-1, M+J1:N)) and */
/* (A(1:J1-1, J1:J1+M), B(1:J1-1, J1:J1+M)). */
i__ = *j1 + m;
if (i__ <= *n) {
i__1 = *n - i__ + 1;
sgemm_("T", "N", &m, &i__1, &m, &c_b42, li, &c__4, &a[*j1 + i__ *
a_dim1], lda, &c_b5, &work[1], &m);
i__1 = *n - i__ + 1;
slacpy_("Full", &m, &i__1, &work[1], &m, &a[*j1 + i__ * a_dim1],
lda);
i__1 = *n - i__ + 1;
sgemm_("T", "N", &m, &i__1, &m, &c_b42, li, &c__4, &b[*j1 + i__ *
b_dim1], ldb, &c_b5, &work[1], &m);
i__1 = *n - i__ + 1;
slacpy_("Full", &m, &i__1, &work[1], &m, &b[*j1 + i__ * b_dim1],
ldb);
}
i__ = *j1 - 1;
if (i__ > 0) {
sgemm_("N", "N", &i__, &m, &m, &c_b42, &a[*j1 * a_dim1 + 1], lda,
ir, &c__4, &c_b5, &work[1], &i__);
slacpy_("Full", &i__, &m, &work[1], &i__, &a[*j1 * a_dim1 + 1],
lda);
sgemm_("N", "N", &i__, &m, &m, &c_b42, &b[*j1 * b_dim1 + 1], ldb,
ir, &c__4, &c_b5, &work[1], &i__);
slacpy_("Full", &i__, &m, &work[1], &i__, &b[*j1 * b_dim1 + 1],
ldb);
}
/* Exit with INFO = 0 if swap was successfully performed. */
return 0;
}
/* Exit with INFO = 1 if swap was rejected. */
L70:
*info = 1;
return 0;
/* End of STGEX2 */
} /* stgex2_ */
/* Subroutine */ int stgex2_(logical *wantq, logical *wantz, integer *n, real
*a, integer *lda, real *b, integer *ldb, real *q, integer *ldq, real *
z__, integer *ldz, integer *j1, integer *n1, integer *n2, real *work,
integer *lwork, 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
June 30, 1999
Purpose
=======
STGEX2 swaps adjacent diagonal blocks (A11, B11) and (A22, B22)
of size 1-by-1 or 2-by-2 in an upper (quasi) triangular matrix pair
(A, B) by an orthogonal equivalence transformation.
(A, B) must be in generalized real Schur canonical form (as returned
by SGGES), i.e. A is block upper triangular with 1-by-1 and 2-by-2
diagonal blocks. B is upper triangular.
Optionally, the matrices Q and Z of generalized Schur vectors are
updated.
Q(in) * A(in) * Z(in)' = Q(out) * A(out) * Z(out)'
Q(in) * B(in) * Z(in)' = Q(out) * B(out) * Z(out)'
Arguments
=========
WANTQ (input) LOGICAL
.TRUE. : update the left transformation matrix Q;
.FALSE.: do not update Q.
WANTZ (input) LOGICAL
.TRUE. : update the right transformation matrix Z;
.FALSE.: do not update Z.
N (input) INTEGER
The order of the matrices A and B. N >= 0.
A (input/output) REAL arrays, dimensions (LDA,N)
On entry, the matrix A in the pair (A, B).
On exit, the updated matrix A.
LDA (input) INTEGER
The leading dimension of the array A. LDA >= max(1,N).
B (input/output) REAL arrays, dimensions (LDB,N)
On entry, the matrix B in the pair (A, B).
On exit, the updated matrix B.
LDB (input) INTEGER
The leading dimension of the array B. LDB >= max(1,N).
Q (input/output) REAL array, dimension (LDZ,N)
On entry, if WANTQ = .TRUE., the orthogonal matrix Q.
On exit, the updated matrix Q.
Not referenced if WANTQ = .FALSE..
LDQ (input) INTEGER
The leading dimension of the array Q. LDQ >= 1.
If WANTQ = .TRUE., LDQ >= N.
Z (input/output) REAL array, dimension (LDZ,N)
On entry, if WANTZ =.TRUE., the orthogonal matrix Z.
On exit, the updated matrix Z.
Not referenced if WANTZ = .FALSE..
LDZ (input) INTEGER
The leading dimension of the array Z. LDZ >= 1.
If WANTZ = .TRUE., LDZ >= N.
J1 (input) INTEGER
The index to the first block (A11, B11). 1 <= J1 <= N.
N1 (input) INTEGER
The order of the first block (A11, B11). N1 = 0, 1 or 2.
N2 (input) INTEGER
The order of the second block (A22, B22). N2 = 0, 1 or 2.
WORK (workspace) REAL array, dimension (LWORK).
LWORK (input) INTEGER
The dimension of the array WORK.
LWORK >= MAX( N*(N2+N1), (N2+N1)*(N2+N1)*2 )
INFO (output) INTEGER
=0: Successful exit
>0: If INFO = 1, the transformed matrix (A, B) would be
too far from generalized Schur form; the blocks are
not swapped and (A, B) and (Q, Z) are unchanged.
The problem of swapping is too ill-conditioned.
<0: If INFO = -16: LWORK is too small. Appropriate value
for LWORK is returned in WORK(1).
Further Details
===============
Based on contributions by
Bo Kagstrom and Peter Poromaa, Department of Computing Science,
Umea University, S-901 87 Umea, Sweden.
In the current code both weak and strong stability tests are
performed. The user can omit the strong stability test by changing
the internal logical parameter WANDS to .FALSE.. See ref. [2] for
details.
[1] B. Kagstrom; A Direct Method for Reordering Eigenvalues in the
Generalized Real Schur Form of a Regular Matrix Pair (A, B), in
M.S. Moonen et al (eds), Linear Algebra for Large Scale and
Real-Time Applications, Kluwer Academic Publ. 1993, pp 195-218.
[2] B. Kagstrom and P. Poromaa; Computing Eigenspaces with Specified
Eigenvalues of a Regular Matrix Pair (A, B) and Condition
Estimation: Theory, Algorithms and Software,
Report UMINF - 94.04, Department of Computing Science, Umea
University, S-901 87 Umea, Sweden, 1994. Also as LAPACK Working
Note 87. To appear in Numerical Algorithms, 1996.
=====================================================================
Parameter adjustments */
/* Table of constant values */
static integer c__16 = 16;
static real c_b3 = 0.f;
static integer c__0 = 0;
static integer c__1 = 1;
static integer c__4 = 4;
static integer c__2 = 2;
static real c_b38 = 1.f;
static real c_b44 = -1.f;
/* System generated locals */
integer a_dim1, a_offset, b_dim1, b_offset, q_dim1, q_offset, z_dim1,
z_offset, i__1, i__2;
real r__1, r__2;
/* Builtin functions */
double sqrt(doublereal);
/* Local variables */
static logical weak;
static real ddum;
static integer idum;
static real taul[4], dsum, taur[4], scpy[16] /* was [4][4] */,
tcpy[16] /* was [4][4] */;
extern /* Subroutine */ int srot_(integer *, real *, integer *, real *,
integer *, real *, real *);
static real f, g;
static integer i__, m;
static real s[16] /* was [4][4] */, t[16] /* was [4][4] */, scale,
bqra21, brqa21;
extern /* Subroutine */ int sscal_(integer *, real *, real *, integer *);
static real licop[16] /* was [4][4] */;
static integer linfo;
extern /* Subroutine */ int sgemm_(char *, char *, integer *, integer *,
integer *, real *, real *, integer *, real *, integer *, real *,
real *, integer *);
static real ircop[16] /* was [4][4] */, dnorm;
static integer iwork[4];
extern /* Subroutine */ int scopy_(integer *, real *, integer *, real *,
integer *), slagv2_(real *, integer *, real *, integer *, real *,
real *, real *, real *, real *, real *, real *), sgeqr2_(integer *
, integer *, real *, integer *, real *, real *, integer *),
sgerq2_(integer *, integer *, real *, integer *, real *, real *,
integer *);
static real be[2], ai[2];
extern /* Subroutine */ int sorg2r_(integer *, integer *, integer *, real
*, integer *, real *, real *, integer *), sorgr2_(integer *,
integer *, integer *, real *, integer *, real *, real *, integer *
);
static real ar[2], sa, sb, li[16] /* was [4][4] */;
extern /* Subroutine */ int sorm2r_(char *, char *, integer *, integer *,
integer *, real *, integer *, real *, real *, integer *, real *,
integer *), sormr2_(char *, char *, integer *,
integer *, integer *, real *, integer *, real *, real *, integer *
, real *, integer *);
static real dscale, ir[16] /* was [4][4] */;
extern /* Subroutine */ int stgsy2_(char *, integer *, integer *, integer
*, real *, integer *, real *, integer *, real *, integer *, real *
, integer *, real *, integer *, real *, integer *, real *, real *,
real *, integer *, integer *, integer *);
static real ss;
extern doublereal slamch_(char *);
static real ws;
extern /* Subroutine */ int slacpy_(char *, integer *, integer *, real *,
integer *, real *, integer *), slartg_(real *, real *,
real *, real *, real *);
static real thresh;
extern /* Subroutine */ int slassq_(integer *, real *, integer *, real *,
real *);
static real smlnum;
static logical strong;
static real eps;
#define scpy_ref(a_1,a_2) scpy[(a_2)*4 + a_1 - 5]
#define a_ref(a_1,a_2) a[(a_2)*a_dim1 + a_1]
#define b_ref(a_1,a_2) b[(a_2)*b_dim1 + a_1]
#define q_ref(a_1,a_2) q[(a_2)*q_dim1 + a_1]
#define s_ref(a_1,a_2) s[(a_2)*4 + a_1 - 5]
#define t_ref(a_1,a_2) t[(a_2)*4 + a_1 - 5]
#define z___ref(a_1,a_2) z__[(a_2)*z_dim1 + a_1]
#define li_ref(a_1,a_2) li[(a_2)*4 + a_1 - 5]
#define ir_ref(a_1,a_2) ir[(a_2)*4 + a_1 - 5]
a_dim1 = *lda;
a_offset = 1 + a_dim1 * 1;
a -= a_offset;
b_dim1 = *ldb;
b_offset = 1 + b_dim1 * 1;
b -= b_offset;
q_dim1 = *ldq;
q_offset = 1 + q_dim1 * 1;
q -= q_offset;
z_dim1 = *ldz;
z_offset = 1 + z_dim1 * 1;
z__ -= z_offset;
--work;
/* Function Body */
*info = 0;
/* Quick return if possible */
if (*n <= 1 || *n1 <= 0 || *n2 <= 0) {
return 0;
}
if (*n1 > *n || *j1 + *n1 > *n) {
return 0;
}
m = *n1 + *n2;
/* Computing MAX */
i__1 = *n * m, i__2 = m * m << 1;
if (*lwork < max(i__1,i__2)) {
*info = -16;
/* Computing MAX */
i__1 = *n * m, i__2 = m * m << 1;
work[1] = (real) max(i__1,i__2);
return 0;
}
weak = FALSE_;
strong = FALSE_;
/* Make a local copy of selected block */
scopy_(&c__16, &c_b3, &c__0, li, &c__1);
scopy_(&c__16, &c_b3, &c__0, ir, &c__1);
slacpy_("Full", &m, &m, &a_ref(*j1, *j1), lda, s, &c__4);
slacpy_("Full", &m, &m, &b_ref(*j1, *j1), ldb, t, &c__4);
/* Compute threshold for testing acceptance of swapping. */
eps = slamch_("P");
smlnum = slamch_("S") / eps;
dscale = 0.f;
dsum = 1.f;
slacpy_("Full", &m, &m, s, &c__4, &work[1], &m);
i__1 = m * m;
slassq_(&i__1, &work[1], &c__1, &dscale, &dsum);
slacpy_("Full", &m, &m, t, &c__4, &work[1], &m);
i__1 = m * m;
slassq_(&i__1, &work[1], &c__1, &dscale, &dsum);
dnorm = dscale * sqrt(dsum);
/* Computing MAX */
r__1 = eps * 10.f * dnorm;
thresh = dmax(r__1,smlnum);
if (m == 2) {
/* CASE 1: Swap 1-by-1 and 1-by-1 blocks.
Compute orthogonal QL and RQ that swap 1-by-1 and 1-by-1 blocks
using Givens rotations and perform the swap tentatively. */
f = s_ref(2, 2) * t_ref(1, 1) - t_ref(2, 2) * s_ref(1, 1);
g = s_ref(2, 2) * t_ref(1, 2) - t_ref(2, 2) * s_ref(1, 2);
sb = (r__1 = t_ref(2, 2), dabs(r__1));
sa = (r__1 = s_ref(2, 2), dabs(r__1));
slartg_(&f, &g, &ir_ref(1, 2), &ir_ref(1, 1), &ddum);
ir_ref(2, 1) = -ir_ref(1, 2);
ir_ref(2, 2) = ir_ref(1, 1);
srot_(&c__2, &s_ref(1, 1), &c__1, &s_ref(1, 2), &c__1, &ir_ref(1, 1),
&ir_ref(2, 1));
srot_(&c__2, &t_ref(1, 1), &c__1, &t_ref(1, 2), &c__1, &ir_ref(1, 1),
&ir_ref(2, 1));
if (sa >= sb) {
slartg_(&s_ref(1, 1), &s_ref(2, 1), &li_ref(1, 1), &li_ref(2, 1),
&ddum);
} else {
slartg_(&t_ref(1, 1), &t_ref(2, 1), &li_ref(1, 1), &li_ref(2, 1),
&ddum);
}
srot_(&c__2, &s_ref(1, 1), &c__4, &s_ref(2, 1), &c__4, &li_ref(1, 1),
&li_ref(2, 1));
srot_(&c__2, &t_ref(1, 1), &c__4, &t_ref(2, 1), &c__4, &li_ref(1, 1),
&li_ref(2, 1));
li_ref(2, 2) = li_ref(1, 1);
li_ref(1, 2) = -li_ref(2, 1);
/* Weak stability test:
|S21| + |T21| <= O(EPS * F-norm((S, T))) */
ws = (r__1 = s_ref(2, 1), dabs(r__1)) + (r__2 = t_ref(2, 1), dabs(
r__2));
weak = ws <= thresh;
if (! weak) {
goto L70;
}
if (TRUE_) {
/* Strong stability test:
F-norm((A-QL'*S*QR, B-QL'*T*QR)) <= O(EPS*F-norm((A,B))) */
slacpy_("Full", &m, &m, &a_ref(*j1, *j1), lda, &work[m * m + 1], &
m);
sgemm_("N", "N", &m, &m, &m, &c_b38, li, &c__4, s, &c__4, &c_b3, &
work[1], &m);
sgemm_("N", "T", &m, &m, &m, &c_b44, &work[1], &m, ir, &c__4, &
c_b38, &work[m * m + 1], &m);
dscale = 0.f;
dsum = 1.f;
i__1 = m * m;
slassq_(&i__1, &work[m * m + 1], &c__1, &dscale, &dsum);
slacpy_("Full", &m, &m, &b_ref(*j1, *j1), ldb, &work[m * m + 1], &
m);
sgemm_("N", "N", &m, &m, &m, &c_b38, li, &c__4, t, &c__4, &c_b3, &
work[1], &m);
sgemm_("N", "T", &m, &m, &m, &c_b44, &work[1], &m, ir, &c__4, &
c_b38, &work[m * m + 1], &m);
i__1 = m * m;
slassq_(&i__1, &work[m * m + 1], &c__1, &dscale, &dsum);
ss = dscale * sqrt(dsum);
strong = ss <= thresh;
if (! strong) {
goto L70;
}
}
/* Update (A(J1:J1+M-1, M+J1:N), B(J1:J1+M-1, M+J1:N)) and
(A(1:J1-1, J1:J1+M), B(1:J1-1, J1:J1+M)). */
i__1 = *j1 + 1;
srot_(&i__1, &a_ref(1, *j1), &c__1, &a_ref(1, *j1 + 1), &c__1, &
ir_ref(1, 1), &ir_ref(2, 1));
i__1 = *j1 + 1;
srot_(&i__1, &b_ref(1, *j1), &c__1, &b_ref(1, *j1 + 1), &c__1, &
ir_ref(1, 1), &ir_ref(2, 1));
i__1 = *n - *j1 + 1;
srot_(&i__1, &a_ref(*j1, *j1), lda, &a_ref(*j1 + 1, *j1), lda, &
li_ref(1, 1), &li_ref(2, 1));
i__1 = *n - *j1 + 1;
srot_(&i__1, &b_ref(*j1, *j1), ldb, &b_ref(*j1 + 1, *j1), ldb, &
li_ref(1, 1), &li_ref(2, 1));
/* Set N1-by-N2 (2,1) - blocks to ZERO. */
a_ref(*j1 + 1, *j1) = 0.f;
b_ref(*j1 + 1, *j1) = 0.f;
/* Accumulate transformations into Q and Z if requested. */
if (*wantz) {
srot_(n, &z___ref(1, *j1), &c__1, &z___ref(1, *j1 + 1), &c__1, &
ir_ref(1, 1), &ir_ref(2, 1));
}
if (*wantq) {
srot_(n, &q_ref(1, *j1), &c__1, &q_ref(1, *j1 + 1), &c__1, &
li_ref(1, 1), &li_ref(2, 1));
}
/* Exit with INFO = 0 if swap was successfully performed. */
return 0;
} else {
/* CASE 2: Swap 1-by-1 and 2-by-2 blocks, or 2-by-2
and 2-by-2 blocks.
Solve the generalized Sylvester equation
S11 * R - L * S22 = SCALE * S12
T11 * R - L * T22 = SCALE * T12
for R and L. Solutions in LI and IR. */
slacpy_("Full", n1, n2, &t_ref(1, *n1 + 1), &c__4, li, &c__4);
slacpy_("Full", n1, n2, &s_ref(1, *n1 + 1), &c__4, &ir_ref(*n2 + 1, *
n1 + 1), &c__4);
stgsy2_("N", &c__0, n1, n2, s, &c__4, &s_ref(*n1 + 1, *n1 + 1), &c__4,
&ir_ref(*n2 + 1, *n1 + 1), &c__4, t, &c__4, &t_ref(*n1 + 1, *
n1 + 1), &c__4, li, &c__4, &scale, &dsum, &dscale, iwork, &
idum, &linfo);
/* Compute orthogonal matrix QL:
QL' * LI = [ TL ]
[ 0 ]
where
LI = [ -L ]
[ SCALE * identity(N2) ] */
i__1 = *n2;
for (i__ = 1; i__ <= i__1; ++i__) {
sscal_(n1, &c_b44, &li_ref(1, i__), &c__1);
li_ref(*n1 + i__, i__) = scale;
/* L10: */
}
sgeqr2_(&m, n2, li, &c__4, taul, &work[1], &linfo);
if (linfo != 0) {
goto L70;
}
sorg2r_(&m, &m, n2, li, &c__4, taul, &work[1], &linfo);
if (linfo != 0) {
goto L70;
}
/* Compute orthogonal matrix RQ:
IR * RQ' = [ 0 TR],
where IR = [ SCALE * identity(N1), R ] */
i__1 = *n1;
for (i__ = 1; i__ <= i__1; ++i__) {
ir_ref(*n2 + i__, i__) = scale;
/* L20: */
}
sgerq2_(n1, &m, &ir_ref(*n2 + 1, 1), &c__4, taur, &work[1], &linfo);
if (linfo != 0) {
goto L70;
}
sorgr2_(&m, &m, n1, ir, &c__4, taur, &work[1], &linfo);
if (linfo != 0) {
goto L70;
}
/* Perform the swapping tentatively: */
sgemm_("T", "N", &m, &m, &m, &c_b38, li, &c__4, s, &c__4, &c_b3, &
work[1], &m);
sgemm_("N", "T", &m, &m, &m, &c_b38, &work[1], &m, ir, &c__4, &c_b3,
s, &c__4);
sgemm_("T", "N", &m, &m, &m, &c_b38, li, &c__4, t, &c__4, &c_b3, &
work[1], &m);
sgemm_("N", "T", &m, &m, &m, &c_b38, &work[1], &m, ir, &c__4, &c_b3,
t, &c__4);
slacpy_("F", &m, &m, s, &c__4, scpy, &c__4);
slacpy_("F", &m, &m, t, &c__4, tcpy, &c__4);
slacpy_("F", &m, &m, ir, &c__4, ircop, &c__4);
slacpy_("F", &m, &m, li, &c__4, licop, &c__4);
/* Triangularize the B-part by an RQ factorization.
Apply transformation (from left) to A-part, giving S. */
sgerq2_(&m, &m, t, &c__4, taur, &work[1], &linfo);
if (linfo != 0) {
goto L70;
}
sormr2_("R", "T", &m, &m, &m, t, &c__4, taur, s, &c__4, &work[1], &
linfo);
if (linfo != 0) {
goto L70;
}
sormr2_("L", "N", &m, &m, &m, t, &c__4, taur, ir, &c__4, &work[1], &
linfo);
if (linfo != 0) {
goto L70;
}
/* Compute F-norm(S21) in BRQA21. (T21 is 0.) */
dscale = 0.f;
dsum = 1.f;
i__1 = *n2;
for (i__ = 1; i__ <= i__1; ++i__) {
slassq_(n1, &s_ref(*n2 + 1, i__), &c__1, &dscale, &dsum);
/* L30: */
}
brqa21 = dscale * sqrt(dsum);
/* Triangularize the B-part by a QR factorization.
Apply transformation (from right) to A-part, giving S. */
sgeqr2_(&m, &m, tcpy, &c__4, taul, &work[1], &linfo);
if (linfo != 0) {
goto L70;
}
sorm2r_("L", "T", &m, &m, &m, tcpy, &c__4, taul, scpy, &c__4, &work[1]
, info);
sorm2r_("R", "N", &m, &m, &m, tcpy, &c__4, taul, licop, &c__4, &work[
1], info);
if (linfo != 0) {
goto L70;
}
/* Compute F-norm(S21) in BQRA21. (T21 is 0.) */
dscale = 0.f;
dsum = 1.f;
i__1 = *n2;
for (i__ = 1; i__ <= i__1; ++i__) {
slassq_(n1, &scpy_ref(*n2 + 1, i__), &c__1, &dscale, &dsum);
/* L40: */
}
bqra21 = dscale * sqrt(dsum);
/* Decide which method to use.
Weak stability test:
F-norm(S21) <= O(EPS * F-norm((S, T))) */
if (bqra21 <= brqa21 && bqra21 <= thresh) {
slacpy_("F", &m, &m, scpy, &c__4, s, &c__4);
slacpy_("F", &m, &m, tcpy, &c__4, t, &c__4);
slacpy_("F", &m, &m, ircop, &c__4, ir, &c__4);
slacpy_("F", &m, &m, licop, &c__4, li, &c__4);
} else if (brqa21 >= thresh) {
goto L70;
}
/* Set lower triangle of B-part to zero */
i__1 = m;
for (i__ = 2; i__ <= i__1; ++i__) {
i__2 = m - i__ + 1;
scopy_(&i__2, &c_b3, &c__0, &t_ref(i__, i__ - 1), &c__1);
/* L50: */
}
if (TRUE_) {
/* Strong stability test:
F-norm((A-QL*S*QR', B-QL*T*QR')) <= O(EPS*F-norm((A,B))) */
slacpy_("Full", &m, &m, &a_ref(*j1, *j1), lda, &work[m * m + 1], &
m);
sgemm_("N", "N", &m, &m, &m, &c_b38, li, &c__4, s, &c__4, &c_b3, &
work[1], &m);
sgemm_("N", "N", &m, &m, &m, &c_b44, &work[1], &m, ir, &c__4, &
c_b38, &work[m * m + 1], &m);
dscale = 0.f;
dsum = 1.f;
i__1 = m * m;
slassq_(&i__1, &work[m * m + 1], &c__1, &dscale, &dsum);
slacpy_("Full", &m, &m, &b_ref(*j1, *j1), ldb, &work[m * m + 1], &
m);
sgemm_("N", "N", &m, &m, &m, &c_b38, li, &c__4, t, &c__4, &c_b3, &
work[1], &m);
sgemm_("N", "N", &m, &m, &m, &c_b44, &work[1], &m, ir, &c__4, &
c_b38, &work[m * m + 1], &m);
i__1 = m * m;
slassq_(&i__1, &work[m * m + 1], &c__1, &dscale, &dsum);
ss = dscale * sqrt(dsum);
strong = ss <= thresh;
if (! strong) {
goto L70;
}
}
/* If the swap is accepted ("weakly" and "strongly"), apply the
transformations and set N1-by-N2 (2,1)-block to zero. */
i__1 = *n2;
for (i__ = 1; i__ <= i__1; ++i__) {
scopy_(n1, &c_b3, &c__0, &s_ref(*n2 + 1, i__), &c__1);
/* L60: */
}
/* copy back M-by-M diagonal block starting at index J1 of (A, B) */
slacpy_("F", &m, &m, s, &c__4, &a_ref(*j1, *j1), lda);
slacpy_("F", &m, &m, t, &c__4, &b_ref(*j1, *j1), ldb);
scopy_(&c__16, &c_b3, &c__0, t, &c__1);
/* Standardize existing 2-by-2 blocks. */
i__1 = m * m;
scopy_(&i__1, &c_b3, &c__0, &work[1], &c__1);
work[1] = 1.f;
t_ref(1, 1) = 1.f;
idum = *lwork - m * m - 2;
if (*n2 > 1) {
slagv2_(&a_ref(*j1, *j1), lda, &b_ref(*j1, *j1), ldb, ar, ai, be,
&work[1], &work[2], &t_ref(1, 1), &t_ref(2, 1));
work[m + 1] = -work[2];
work[m + 2] = work[1];
t_ref(*n2, *n2) = t_ref(1, 1);
t_ref(1, 2) = -t_ref(2, 1);
}
work[m * m] = 1.f;
t_ref(m, m) = 1.f;
if (*n1 > 1) {
slagv2_(&a_ref(*j1 + *n2, *j1 + *n2), lda, &b_ref(*j1 + *n2, *j1
+ *n2), ldb, taur, taul, &work[m * m + 1], &work[*n2 * m
+ *n2 + 1], &work[*n2 * m + *n2 + 2], &t_ref(*n2 + 1, *n2
+ 1), &t_ref(m, m - 1));
work[m * m] = work[*n2 * m + *n2 + 1];
work[m * m - 1] = -work[*n2 * m + *n2 + 2];
t_ref(m, m) = t_ref(*n2 + 1, *n2 + 1);
t_ref(m - 1, m) = -t_ref(m, m - 1);
}
sgemm_("T", "N", n2, n1, n2, &c_b38, &work[1], &m, &a_ref(*j1, *j1 + *
n2), lda, &c_b3, &work[m * m + 1], n2);
slacpy_("Full", n2, n1, &work[m * m + 1], n2, &a_ref(*j1, *j1 + *n2),
lda);
sgemm_("T", "N", n2, n1, n2, &c_b38, &work[1], &m, &b_ref(*j1, *j1 + *
n2), ldb, &c_b3, &work[m * m + 1], n2);
slacpy_("Full", n2, n1, &work[m * m + 1], n2, &b_ref(*j1, *j1 + *n2),
ldb);
sgemm_("N", "N", &m, &m, &m, &c_b38, li, &c__4, &work[1], &m, &c_b3, &
work[m * m + 1], &m);
slacpy_("Full", &m, &m, &work[m * m + 1], &m, li, &c__4);
sgemm_("N", "N", n2, n1, n1, &c_b38, &a_ref(*j1, *j1 + *n2), lda, &
t_ref(*n2 + 1, *n2 + 1), &c__4, &c_b3, &work[1], n2);
slacpy_("Full", n2, n1, &work[1], n2, &a_ref(*j1, *j1 + *n2), lda);
sgemm_("N", "N", n2, n1, n1, &c_b38, &b_ref(*j1, *j1 + *n2), lda, &
t_ref(*n2 + 1, *n2 + 1), &c__4, &c_b3, &work[1], n2);
slacpy_("Full", n2, n1, &work[1], n2, &b_ref(*j1, *j1 + *n2), ldb);
sgemm_("T", "N", &m, &m, &m, &c_b38, ir, &c__4, t, &c__4, &c_b3, &
work[1], &m);
slacpy_("Full", &m, &m, &work[1], &m, ir, &c__4);
/* Accumulate transformations into Q and Z if requested. */
if (*wantq) {
sgemm_("N", "N", n, &m, &m, &c_b38, &q_ref(1, *j1), ldq, li, &
c__4, &c_b3, &work[1], n);
slacpy_("Full", n, &m, &work[1], n, &q_ref(1, *j1), ldq);
}
if (*wantz) {
sgemm_("N", "N", n, &m, &m, &c_b38, &z___ref(1, *j1), ldz, ir, &
c__4, &c_b3, &work[1], n);
slacpy_("Full", n, &m, &work[1], n, &z___ref(1, *j1), ldz);
}
/* Update (A(J1:J1+M-1, M+J1:N), B(J1:J1+M-1, M+J1:N)) and
(A(1:J1-1, J1:J1+M), B(1:J1-1, J1:J1+M)). */
i__ = *j1 + m;
if (i__ <= *n) {
i__1 = *n - i__ + 1;
sgemm_("T", "N", &m, &i__1, &m, &c_b38, li, &c__4, &a_ref(*j1,
i__), lda, &c_b3, &work[1], &m);
i__1 = *n - i__ + 1;
slacpy_("Full", &m, &i__1, &work[1], &m, &a_ref(*j1, i__), lda);
i__1 = *n - i__ + 1;
sgemm_("T", "N", &m, &i__1, &m, &c_b38, li, &c__4, &b_ref(*j1,
i__), lda, &c_b3, &work[1], &m);
i__1 = *n - i__ + 1;
slacpy_("Full", &m, &i__1, &work[1], &m, &b_ref(*j1, i__), lda);
}
i__ = *j1 - 1;
if (i__ > 0) {
sgemm_("N", "N", &i__, &m, &m, &c_b38, &a_ref(1, *j1), lda, ir, &
c__4, &c_b3, &work[1], &i__);
slacpy_("Full", &i__, &m, &work[1], &i__, &a_ref(1, *j1), lda);
sgemm_("N", "N", &i__, &m, &m, &c_b38, &b_ref(1, *j1), ldb, ir, &
c__4, &c_b3, &work[1], &i__);
slacpy_("Full", &i__, &m, &work[1], &i__, &b_ref(1, *j1), ldb);
}
/* Exit with INFO = 0 if swap was successfully performed. */
return 0;
}
/* Exit with INFO = 1 if swap was rejected. */
L70:
*info = 1;
return 0;
/* End of STGEX2 */
} /* stgex2_ */
