/* Subroutine */ int sqlt02_(integer *m, integer *n, integer *k, real *a,
real *af, real *q, real *l, integer *lda, real *tau, real *work,
integer *lwork, real *rwork, real *result)
{
/* System generated locals */
integer a_dim1, a_offset, af_dim1, af_offset, l_dim1, l_offset, q_dim1,
q_offset, i__1, i__2;
/* Builtin functions */
/* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);
/* Local variables */
real eps;
integer info;
real resid;
extern /* Subroutine */ int sgemm_(char *, char *, integer *, integer *,
integer *, real *, real *, integer *, real *, integer *, real *,
real *, integer *);
real anorm;
extern /* Subroutine */ int ssyrk_(char *, char *, integer *, integer *,
real *, real *, integer *, real *, real *, integer *);
extern doublereal slamch_(char *), slange_(char *, integer *,
integer *, real *, integer *, real *);
extern /* Subroutine */ int slacpy_(char *, integer *, integer *, real *,
integer *, real *, integer *), slaset_(char *, integer *,
integer *, real *, real *, real *, integer *), sorgql_(
integer *, integer *, integer *, real *, integer *, real *, real *
, integer *, integer *);
extern doublereal slansy_(char *, char *, integer *, real *, integer *,
real *);
/* -- LAPACK test routine (version 3.1) -- */
/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/* November 2006 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* SQLT02 tests SORGQL, which generates an m-by-n matrix Q with */
/* orthonornmal columns that is defined as the product of k elementary */
/* reflectors. */
/* Given the QL factorization of an m-by-n matrix A, SQLT02 generates */
/* the orthogonal matrix Q defined by the factorization of the last k */
/* columns of A; it compares L(m-n+1:m,n-k+1:n) with */
/* Q(1:m,m-n+1:m)'*A(1:m,n-k+1:n), and checks that the columns of Q are */
/* orthonormal. */
/* Arguments */
/* ========= */
/* M (input) INTEGER */
/* The number of rows of the matrix Q to be generated. M >= 0. */
/* N (input) INTEGER */
/* The number of columns of the matrix Q to be generated. */
/* M >= N >= 0. */
/* K (input) INTEGER */
/* The number of elementary reflectors whose product defines the */
/* matrix Q. N >= K >= 0. */
/* A (input) REAL array, dimension (LDA,N) */
/* The m-by-n matrix A which was factorized by SQLT01. */
/* AF (input) REAL array, dimension (LDA,N) */
/* Details of the QL factorization of A, as returned by SGEQLF. */
/* See SGEQLF for further details. */
/* Q (workspace) REAL array, dimension (LDA,N) */
/* L (workspace) REAL array, dimension (LDA,N) */
/* LDA (input) INTEGER */
/* The leading dimension of the arrays A, AF, Q and L. LDA >= M. */
/* TAU (input) REAL array, dimension (N) */
/* The scalar factors of the elementary reflectors corresponding */
/* to the QL factorization in AF. */
/* WORK (workspace) REAL array, dimension (LWORK) */
/* LWORK (input) INTEGER */
/* The dimension of the array WORK. */
/* RWORK (workspace) REAL array, dimension (M) */
/* RESULT (output) REAL array, dimension (2) */
/* The test ratios: */
/* RESULT(1) = norm( L - Q'*A ) / ( M * norm(A) * EPS ) */
/* RESULT(2) = norm( I - Q'*Q ) / ( M * EPS ) */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Scalars in Common .. */
/* .. */
/* .. Common blocks .. */
/* .. */
/* .. Executable Statements .. */
/* Quick return if possible */
/* Parameter adjustments */
l_dim1 = *lda;
l_offset = 1 + l_dim1;
l -= l_offset;
q_dim1 = *lda;
q_offset = 1 + q_dim1;
q -= q_offset;
af_dim1 = *lda;
af_offset = 1 + af_dim1;
af -= af_offset;
a_dim1 = *lda;
a_offset = 1 + a_dim1;
a -= a_offset;
--tau;
--work;
--rwork;
--result;
/* Function Body */
if (*m == 0 || *n == 0 || *k == 0) {
result[1] = 0.f;
result[2] = 0.f;
return 0;
}
eps = slamch_("Epsilon");
/* Copy the last k columns of the factorization to the array Q */
slaset_("Full", m, n, &c_b4, &c_b4, &q[q_offset], lda);
if (*k < *m) {
i__1 = *m - *k;
slacpy_("Full", &i__1, k, &af[(*n - *k + 1) * af_dim1 + 1], lda, &q[(*
n - *k + 1) * q_dim1 + 1], lda);
}
if (*k > 1) {
i__1 = *k - 1;
i__2 = *k - 1;
slacpy_("Upper", &i__1, &i__2, &af[*m - *k + 1 + (*n - *k + 2) *
af_dim1], lda, &q[*m - *k + 1 + (*n - *k + 2) * q_dim1], lda);
}
/* Generate the last n columns of the matrix Q */
s_copy(srnamc_1.srnamt, "SORGQL", (ftnlen)6, (ftnlen)6);
sorgql_(m, n, k, &q[q_offset], lda, &tau[*n - *k + 1], &work[1], lwork, &
info);
/* Copy L(m-n+1:m,n-k+1:n) */
slaset_("Full", n, k, &c_b10, &c_b10, &l[*m - *n + 1 + (*n - *k + 1) *
l_dim1], lda);
slacpy_("Lower", k, k, &af[*m - *k + 1 + (*n - *k + 1) * af_dim1], lda, &
l[*m - *k + 1 + (*n - *k + 1) * l_dim1], lda);
/* Compute L(m-n+1:m,n-k+1:n) - Q(1:m,m-n+1:m)' * A(1:m,n-k+1:n) */
sgemm_("Transpose", "No transpose", n, k, m, &c_b15, &q[q_offset], lda, &
a[(*n - *k + 1) * a_dim1 + 1], lda, &c_b16, &l[*m - *n + 1 + (*n
- *k + 1) * l_dim1], lda);
/* Compute norm( L - Q'*A ) / ( M * norm(A) * EPS ) . */
anorm = slange_("1", m, k, &a[(*n - *k + 1) * a_dim1 + 1], lda, &rwork[1]);
resid = slange_("1", n, k, &l[*m - *n + 1 + (*n - *k + 1) * l_dim1], lda,
&rwork[1]);
if (anorm > 0.f) {
result[1] = resid / (real) max(1,*m) / anorm / eps;
} else {
result[1] = 0.f;
}
/* Compute I - Q'*Q */
slaset_("Full", n, n, &c_b10, &c_b16, &l[l_offset], lda);
ssyrk_("Upper", "Transpose", n, m, &c_b15, &q[q_offset], lda, &c_b16, &l[
l_offset], lda);
/* Compute norm( I - Q'*Q ) / ( M * EPS ) . */
resid = slansy_("1", "Upper", n, &l[l_offset], lda, &rwork[1]);
result[2] = resid / (real) max(1,*m) / eps;
return 0;
/* End of SQLT02 */
} /* sqlt02_ */
/* Subroutine */ int slaed0_(integer *icompq, integer *qsiz, integer *n, real
*d__, real *e, real *q, integer *ldq, real *qstore, integer *ldqs,
real *work, integer *iwork, integer *info)
{
/* System generated locals */
integer q_dim1, q_offset, qstore_dim1, qstore_offset, i__1, i__2;
real r__1;
/* Builtin functions */
double log(doublereal);
integer pow_ii(integer *, integer *);
/* Local variables */
static real temp;
static integer curr, i__, j, k;
extern /* Subroutine */ int sgemm_(char *, char *, integer *, integer *,
integer *, real *, real *, integer *, real *, integer *, real *,
real *, integer *);
static integer iperm, indxq, iwrem;
extern /* Subroutine */ int scopy_(integer *, real *, integer *, real *,
integer *);
static integer iqptr, tlvls;
extern /* Subroutine */ int slaed1_(integer *, real *, real *, integer *,
integer *, real *, integer *, real *, integer *, integer *),
slaed7_(integer *, integer *, integer *, integer *, integer *,
integer *, real *, real *, integer *, integer *, real *, integer *
, real *, integer *, integer *, integer *, integer *, integer *,
real *, real *, integer *, integer *);
static integer iq, igivcl;
extern integer ilaenv_(integer *, char *, char *, integer *, integer *,
integer *, integer *, ftnlen, ftnlen);
extern /* Subroutine */ int xerbla_(char *, integer *);
static integer igivnm, submat;
extern /* Subroutine */ int slacpy_(char *, integer *, integer *, real *,
integer *, real *, integer *);
static integer curprb, subpbs, igivpt, curlvl, matsiz, iprmpt, smlsiz;
extern /* Subroutine */ int ssteqr_(char *, integer *, real *, real *,
real *, integer *, real *, integer *);
static integer lgn, msd2, smm1, spm1, spm2;
#define q_ref(a_1,a_2) q[(a_2)*q_dim1 + a_1]
#define qstore_ref(a_1,a_2) qstore[(a_2)*qstore_dim1 + a_1]
/* -- LAPACK routine (instrumented to count operations, version 3.0) --
Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
Courant Institute, Argonne National Lab, and Rice University
June 30, 1999
Common block to return operation count and iteration count
ITCNT is unchanged, OPS is only incremented
Purpose
=======
SLAED0 computes all eigenvalues and corresponding eigenvectors of a
symmetric tridiagonal matrix using the divide and conquer method.
Arguments
=========
ICOMPQ (input) INTEGER
= 0: Compute eigenvalues only.
= 1: Compute eigenvectors of original dense symmetric matrix
also. On entry, Q contains the orthogonal matrix used
to reduce the original matrix to tridiagonal form.
= 2: Compute eigenvalues and eigenvectors of tridiagonal
matrix.
QSIZ (input) INTEGER
The dimension of the orthogonal matrix used to reduce
the full matrix to tridiagonal form. QSIZ >= N if ICOMPQ = 1.
N (input) INTEGER
The dimension of the symmetric tridiagonal matrix. N >= 0.
D (input/output) REAL array, dimension (N)
On entry, the main diagonal of the tridiagonal matrix.
On exit, its eigenvalues.
E (input) REAL array, dimension (N-1)
The off-diagonal elements of the tridiagonal matrix.
On exit, E has been destroyed.
Q (input/output) REAL array, dimension (LDQ, N)
On entry, Q must contain an N-by-N orthogonal matrix.
If ICOMPQ = 0 Q is not referenced.
If ICOMPQ = 1 On entry, Q is a subset of the columns of the
orthogonal matrix used to reduce the full
matrix to tridiagonal form corresponding to
the subset of the full matrix which is being
decomposed at this time.
If ICOMPQ = 2 On entry, Q will be the identity matrix.
On exit, Q contains the eigenvectors of the
tridiagonal matrix.
LDQ (input) INTEGER
The leading dimension of the array Q. If eigenvectors are
desired, then LDQ >= max(1,N). In any case, LDQ >= 1.
QSTORE (workspace) REAL array, dimension (LDQS, N)
Referenced only when ICOMPQ = 1. Used to store parts of
the eigenvector matrix when the updating matrix multiplies
take place.
LDQS (input) INTEGER
The leading dimension of the array QSTORE. If ICOMPQ = 1,
then LDQS >= max(1,N). In any case, LDQS >= 1.
WORK (workspace) REAL array,
If ICOMPQ = 0 or 1, the dimension of WORK must be at least
1 + 3*N + 2*N*lg N + 2*N**2
( lg( N ) = smallest integer k
such that 2^k >= N )
If ICOMPQ = 2, the dimension of WORK must be at least
4*N + N**2.
IWORK (workspace) INTEGER array,
If ICOMPQ = 0 or 1, the dimension of IWORK must be at least
6 + 6*N + 5*N*lg N.
( lg( N ) = smallest integer k
such that 2^k >= N )
If ICOMPQ = 2, the dimension of IWORK must be at least
3 + 5*N.
INFO (output) INTEGER
= 0: successful exit.
< 0: if INFO = -i, the i-th argument had an illegal value.
> 0: The algorithm failed to compute an eigenvalue while
working on the submatrix lying in rows and columns
INFO/(N+1) through mod(INFO,N+1).
Further Details
===============
Based on contributions by
Jeff Rutter, Computer Science Division, University of California
at Berkeley, USA
=====================================================================
Test the input parameters.
Parameter adjustments */
--d__;
--e;
q_dim1 = *ldq;
q_offset = 1 + q_dim1 * 1;
q -= q_offset;
qstore_dim1 = *ldqs;
qstore_offset = 1 + qstore_dim1 * 1;
qstore -= qstore_offset;
--work;
--iwork;
/* Function Body */
*info = 0;
if (*icompq < 0 || *icompq > 2) {
*info = -1;
} else if (*icompq == 1 && *qsiz < max(0,*n)) {
*info = -2;
} else if (*n < 0) {
*info = -3;
} else if (*ldq < max(1,*n)) {
*info = -7;
} else if (*ldqs < max(1,*n)) {
*info = -9;
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("SLAED0", &i__1);
return 0;
}
/* Quick return if possible */
if (*n == 0) {
return 0;
}
smlsiz = ilaenv_(&c__9, "SLAED0", " ", &c__0, &c__0, &c__0, &c__0, (
ftnlen)6, (ftnlen)1);
/* Determine the size and placement of the submatrices, and save in
the leading elements of IWORK. */
iwork[1] = *n;
subpbs = 1;
tlvls = 0;
L10:
if (iwork[subpbs] > smlsiz) {
for (j = subpbs; j >= 1; --j) {
iwork[j * 2] = (iwork[j] + 1) / 2;
iwork[(j << 1) - 1] = iwork[j] / 2;
/* L20: */
}
++tlvls;
subpbs <<= 1;
goto L10;
}
i__1 = subpbs;
for (j = 2; j <= i__1; ++j) {
iwork[j] += iwork[j - 1];
/* L30: */
}
/* Divide the matrix into SUBPBS submatrices of size at most SMLSIZ+1
using rank-1 modifications (cuts). */
spm1 = subpbs - 1;
latime_1.ops += spm1 << 1;
i__1 = spm1;
for (i__ = 1; i__ <= i__1; ++i__) {
submat = iwork[i__] + 1;
smm1 = submat - 1;
d__[smm1] -= (r__1 = e[smm1], dabs(r__1));
d__[submat] -= (r__1 = e[smm1], dabs(r__1));
/* L40: */
}
indxq = (*n << 2) + 3;
if (*icompq != 2) {
/* Set up workspaces for eigenvalues only/accumulate new vectors
routine */
latime_1.ops += 3;
temp = log((real) (*n)) / log(2.f);
lgn = (integer) temp;
if (pow_ii(&c__2, &lgn) < *n) {
++lgn;
}
if (pow_ii(&c__2, &lgn) < *n) {
++lgn;
}
iprmpt = indxq + *n + 1;
iperm = iprmpt + *n * lgn;
iqptr = iperm + *n * lgn;
igivpt = iqptr + *n + 2;
igivcl = igivpt + *n * lgn;
igivnm = 1;
iq = igivnm + (*n << 1) * lgn;
/* Computing 2nd power */
i__1 = *n;
iwrem = iq + i__1 * i__1 + 1;
/* Initialize pointers */
i__1 = subpbs;
for (i__ = 0; i__ <= i__1; ++i__) {
iwork[iprmpt + i__] = 1;
iwork[igivpt + i__] = 1;
/* L50: */
}
iwork[iqptr] = 1;
}
/* Solve each submatrix eigenproblem at the bottom of the divide and
conquer tree. */
curr = 0;
i__1 = spm1;
for (i__ = 0; i__ <= i__1; ++i__) {
if (i__ == 0) {
submat = 1;
matsiz = iwork[1];
} else {
submat = iwork[i__] + 1;
matsiz = iwork[i__ + 1] - iwork[i__];
}
if (*icompq == 2) {
ssteqr_("I", &matsiz, &d__[submat], &e[submat], &q_ref(submat,
submat), ldq, &work[1], info);
if (*info != 0) {
goto L130;
}
} else {
ssteqr_("I", &matsiz, &d__[submat], &e[submat], &work[iq - 1 +
iwork[iqptr + curr]], &matsiz, &work[1], info);
if (*info != 0) {
goto L130;
}
if (*icompq == 1) {
latime_1.ops += (real) (*qsiz) * 2 * matsiz * matsiz;
sgemm_("N", "N", qsiz, &matsiz, &matsiz, &c_b23, &q_ref(1,
submat), ldq, &work[iq - 1 + iwork[iqptr + curr]], &
matsiz, &c_b24, &qstore_ref(1, submat), ldqs);
}
/* Computing 2nd power */
i__2 = matsiz;
iwork[iqptr + curr + 1] = iwork[iqptr + curr] + i__2 * i__2;
++curr;
}
k = 1;
i__2 = iwork[i__ + 1];
for (j = submat; j <= i__2; ++j) {
iwork[indxq + j] = k;
++k;
/* L60: */
}
/* L70: */
}
/* Successively merge eigensystems of adjacent submatrices
into eigensystem for the corresponding larger matrix.
while ( SUBPBS > 1 ) */
curlvl = 1;
L80:
if (subpbs > 1) {
spm2 = subpbs - 2;
i__1 = spm2;
for (i__ = 0; i__ <= i__1; i__ += 2) {
if (i__ == 0) {
submat = 1;
matsiz = iwork[2];
msd2 = iwork[1];
curprb = 0;
} else {
submat = iwork[i__] + 1;
matsiz = iwork[i__ + 2] - iwork[i__];
msd2 = matsiz / 2;
++curprb;
}
/* Merge lower order eigensystems (of size MSD2 and MATSIZ - MSD2)
into an eigensystem of size MATSIZ.
SLAED1 is used only for the full eigensystem of a tridiagonal
matrix.
SLAED7 handles the cases in which eigenvalues only or eigenvalues
and eigenvectors of a full symmetric matrix (which was reduced to
tridiagonal form) are desired. */
if (*icompq == 2) {
slaed1_(&matsiz, &d__[submat], &q_ref(submat, submat), ldq, &
iwork[indxq + submat], &e[submat + msd2 - 1], &msd2, &
work[1], &iwork[subpbs + 1], info);
} else {
slaed7_(icompq, &matsiz, qsiz, &tlvls, &curlvl, &curprb, &d__[
submat], &qstore_ref(1, submat), ldqs, &iwork[indxq +
submat], &e[submat + msd2 - 1], &msd2, &work[iq], &
iwork[iqptr], &iwork[iprmpt], &iwork[iperm], &iwork[
igivpt], &iwork[igivcl], &work[igivnm], &work[iwrem],
&iwork[subpbs + 1], info);
}
if (*info != 0) {
goto L130;
}
iwork[i__ / 2 + 1] = iwork[i__ + 2];
/* L90: */
}
subpbs /= 2;
++curlvl;
goto L80;
}
/* end while
Re-merge the eigenvalues/vectors which were deflated at the final
merge step. */
if (*icompq == 1) {
i__1 = *n;
for (i__ = 1; i__ <= i__1; ++i__) {
j = iwork[indxq + i__];
work[i__] = d__[j];
scopy_(qsiz, &qstore_ref(1, j), &c__1, &q_ref(1, i__), &c__1);
/* L100: */
}
scopy_(n, &work[1], &c__1, &d__[1], &c__1);
} else if (*icompq == 2) {
i__1 = *n;
for (i__ = 1; i__ <= i__1; ++i__) {
j = iwork[indxq + i__];
work[i__] = d__[j];
scopy_(n, &q_ref(1, j), &c__1, &work[*n * i__ + 1], &c__1);
/* L110: */
}
scopy_(n, &work[1], &c__1, &d__[1], &c__1);
slacpy_("A", n, n, &work[*n + 1], n, &q[q_offset], ldq);
} else {
i__1 = *n;
for (i__ = 1; i__ <= i__1; ++i__) {
j = iwork[indxq + i__];
work[i__] = d__[j];
/* L120: */
}
scopy_(n, &work[1], &c__1, &d__[1], &c__1);
}
goto L140;
L130:
*info = submat * (*n + 1) + submat + matsiz - 1;
L140:
return 0;
/* End of SLAED0 */
} /* slaed0_ */
/* Subroutine */ int sdrvgt_(logical *dotype, integer *nn, integer *nval,
integer *nrhs, real *thresh, logical *tsterr, real *a, real *af, real
*b, real *x, real *xact, real *work, real *rwork, integer *iwork,
integer *nout)
{
/* Initialized data */
static integer iseedy[4] = { 0,0,0,1 };
static char transs[1*3] = "N" "T" "C";
/* Format strings */
static char fmt_9999[] = "(1x,a,\002, N =\002,i5,\002, type \002,i2,\002"
", test \002,i2,\002, ratio = \002,g12.5)";
static char fmt_9998[] = "(1x,a,\002, FACT='\002,a1,\002', TRANS='\002,a"
"1,\002', N =\002,i5,\002, type \002,i2,\002, test \002,i2,\002, "
"ratio = \002,g12.5)";
/* System generated locals */
address a__1[2];
integer i__1, i__2, i__3, i__4, i__5[2];
real r__1, r__2;
char ch__1[2];
/* Builtin functions */
/* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);
integer s_wsfe(cilist *), do_fio(integer *, char *, ftnlen), e_wsfe(void);
/* Subroutine */ int s_cat(char *, char **, integer *, integer *, ftnlen);
/* Local variables */
integer i__, j, k, m, n;
real z__[3];
integer k1, in, kl, ku, ix, nt, lda;
char fact[1];
real cond;
integer mode, koff, imat, info;
char path[3], dist[1], type__[1];
integer nrun, ifact, nfail, iseed[4];
real rcond;
extern /* Subroutine */ int sget04_(integer *, integer *, real *, integer
*, real *, integer *, real *, real *), sscal_(integer *, real *,
real *, integer *);
integer nimat;
extern doublereal sget06_(real *, real *);
real anorm;
integer itran;
extern /* Subroutine */ int sgtt01_(integer *, real *, real *, real *,
real *, real *, real *, real *, integer *, real *, integer *,
real *, real *), sgtt02_(char *, integer *, integer *, real *,
real *, real *, real *, integer *, real *, integer *, real *,
real *), sgtt05_(char *, integer *, integer *, real *,
real *, real *, real *, integer *, real *, integer *, real *,
integer *, real *, real *, real *);
char trans[1];
integer izero, nerrs;
extern doublereal sasum_(integer *, real *, integer *);
extern /* Subroutine */ int scopy_(integer *, real *, integer *, real *,
integer *);
logical zerot;
extern /* Subroutine */ int sgtsv_(integer *, integer *, real *, real *,
real *, real *, integer *, integer *), slatb4_(char *, integer *,
integer *, integer *, char *, integer *, integer *, real *,
integer *, real *, char *), aladhd_(
integer *, char *), alaerh_(char *, char *, integer *,
integer *, char *, integer *, integer *, integer *, integer *,
integer *, integer *, integer *, integer *, integer *);
real rcondc, rcondi;
extern /* Subroutine */ int alasvm_(char *, integer *, integer *, integer
*, integer *);
real rcondo, anormi;
extern /* Subroutine */ int slagtm_(char *, integer *, integer *, real *,
real *, real *, real *, real *, integer *, real *, real *,
integer *);
real ainvnm;
extern doublereal slangt_(char *, integer *, real *, real *, real *);
logical trfcon;
real anormo;
extern /* Subroutine */ int slacpy_(char *, integer *, integer *, real *,
integer *, real *, integer *), slaset_(char *, integer *,
integer *, real *, real *, real *, integer *), slatms_(
integer *, integer *, char *, integer *, char *, real *, integer *
, real *, real *, integer *, integer *, char *, real *, integer *,
real *, integer *), slarnv_(integer *,
integer *, integer *, real *), sgttrf_(integer *, real *, real *,
real *, real *, integer *, integer *);
real result[6];
extern /* Subroutine */ int sgttrs_(char *, integer *, integer *, real *,
real *, real *, real *, integer *, real *, integer *, integer *), serrvx_(char *, integer *), sgtsvx_(char *, char
*, integer *, integer *, real *, real *, real *, real *, real *,
real *, real *, integer *, real *, integer *, real *, integer *,
real *, real *, real *, real *, integer *, integer *);
/* Fortran I/O blocks */
static cilist io___42 = { 0, 0, 0, fmt_9999, 0 };
static cilist io___46 = { 0, 0, 0, fmt_9998, 0 };
static cilist io___47 = { 0, 0, 0, fmt_9998, 0 };
/* -- LAPACK test routine (version 3.1) -- */
/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/* November 2006 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* SDRVGT tests SGTSV and -SVX. */
/* Arguments */
/* ========= */
/* DOTYPE (input) LOGICAL array, dimension (NTYPES) */
/* The matrix types to be used for testing. Matrices of type j */
/* (for 1 <= j <= NTYPES) are used for testing if DOTYPE(j) = */
/* .TRUE.; if DOTYPE(j) = .FALSE., then type j is not used. */
/* NN (input) INTEGER */
/* The number of values of N contained in the vector NVAL. */
/* NVAL (input) INTEGER array, dimension (NN) */
/* The values of the matrix dimension N. */
/* THRESH (input) REAL */
/* The threshold value for the test ratios. A result is */
/* included in the output file if RESULT >= THRESH. To have */
/* every test ratio printed, use THRESH = 0. */
/* TSTERR (input) LOGICAL */
/* Flag that indicates whether error exits are to be tested. */
/* A (workspace) REAL array, dimension (NMAX*4) */
/* AF (workspace) REAL array, dimension (NMAX*4) */
/* B (workspace) REAL array, dimension (NMAX*NRHS) */
/* X (workspace) REAL array, dimension (NMAX*NRHS) */
/* XACT (workspace) REAL array, dimension (NMAX*NRHS) */
/* WORK (workspace) REAL array, dimension */
/* (NMAX*max(3,NRHS)) */
/* RWORK (workspace) REAL array, dimension */
/* (max(NMAX,2*NRHS)) */
/* IWORK (workspace) INTEGER array, dimension (2*NMAX) */
/* NOUT (input) INTEGER */
/* The unit number for output. */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. Local Arrays .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Scalars in Common .. */
/* .. */
/* .. Common blocks .. */
/* .. */
/* .. Data statements .. */
/* Parameter adjustments */
--iwork;
--rwork;
--work;
--xact;
--x;
--b;
--af;
--a;
--nval;
--dotype;
/* Function Body */
/* .. */
/* .. Executable Statements .. */
s_copy(path, "Single precision", (ftnlen)1, (ftnlen)16);
s_copy(path + 1, "GT", (ftnlen)2, (ftnlen)2);
nrun = 0;
nfail = 0;
nerrs = 0;
for (i__ = 1; i__ <= 4; ++i__) {
iseed[i__ - 1] = iseedy[i__ - 1];
/* L10: */
}
/* Test the error exits */
if (*tsterr) {
serrvx_(path, nout);
}
infoc_1.infot = 0;
i__1 = *nn;
for (in = 1; in <= i__1; ++in) {
/* Do for each value of N in NVAL. */
n = nval[in];
/* Computing MAX */
i__2 = n - 1;
m = max(i__2,0);
lda = max(1,n);
nimat = 12;
if (n <= 0) {
nimat = 1;
}
i__2 = nimat;
for (imat = 1; imat <= i__2; ++imat) {
/* Do the tests only if DOTYPE( IMAT ) is true. */
if (! dotype[imat]) {
goto L130;
}
/* Set up parameters with SLATB4. */
slatb4_(path, &imat, &n, &n, type__, &kl, &ku, &anorm, &mode, &
cond, dist);
zerot = imat >= 8 && imat <= 10;
if (imat <= 6) {
/* Types 1-6: generate matrices of known condition number. */
/* Computing MAX */
i__3 = 2 - ku, i__4 = 3 - max(1,n);
koff = max(i__3,i__4);
s_copy(srnamc_1.srnamt, "SLATMS", (ftnlen)32, (ftnlen)6);
slatms_(&n, &n, dist, iseed, type__, &rwork[1], &mode, &cond,
&anorm, &kl, &ku, "Z", &af[koff], &c__3, &work[1], &
info);
/* Check the error code from SLATMS. */
if (info != 0) {
alaerh_(path, "SLATMS", &info, &c__0, " ", &n, &n, &kl, &
ku, &c_n1, &imat, &nfail, &nerrs, nout);
goto L130;
}
izero = 0;
if (n > 1) {
i__3 = n - 1;
scopy_(&i__3, &af[4], &c__3, &a[1], &c__1);
i__3 = n - 1;
scopy_(&i__3, &af[3], &c__3, &a[n + m + 1], &c__1);
}
scopy_(&n, &af[2], &c__3, &a[m + 1], &c__1);
} else {
/* Types 7-12: generate tridiagonal matrices with */
/* unknown condition numbers. */
if (! zerot || ! dotype[7]) {
/* Generate a matrix with elements from [-1,1]. */
i__3 = n + (m << 1);
slarnv_(&c__2, iseed, &i__3, &a[1]);
if (anorm != 1.f) {
i__3 = n + (m << 1);
sscal_(&i__3, &anorm, &a[1], &c__1);
}
} else if (izero > 0) {
/* Reuse the last matrix by copying back the zeroed out */
/* elements. */
if (izero == 1) {
a[n] = z__[1];
if (n > 1) {
a[1] = z__[2];
}
} else if (izero == n) {
a[n * 3 - 2] = z__[0];
a[(n << 1) - 1] = z__[1];
} else {
a[(n << 1) - 2 + izero] = z__[0];
a[n - 1 + izero] = z__[1];
a[izero] = z__[2];
}
}
/* If IMAT > 7, set one column of the matrix to 0. */
if (! zerot) {
izero = 0;
} else if (imat == 8) {
izero = 1;
z__[1] = a[n];
a[n] = 0.f;
if (n > 1) {
z__[2] = a[1];
a[1] = 0.f;
}
} else if (imat == 9) {
izero = n;
z__[0] = a[n * 3 - 2];
z__[1] = a[(n << 1) - 1];
a[n * 3 - 2] = 0.f;
a[(n << 1) - 1] = 0.f;
} else {
izero = (n + 1) / 2;
i__3 = n - 1;
for (i__ = izero; i__ <= i__3; ++i__) {
a[(n << 1) - 2 + i__] = 0.f;
a[n - 1 + i__] = 0.f;
a[i__] = 0.f;
/* L20: */
}
a[n * 3 - 2] = 0.f;
a[(n << 1) - 1] = 0.f;
}
}
for (ifact = 1; ifact <= 2; ++ifact) {
if (ifact == 1) {
*(unsigned char *)fact = 'F';
} else {
*(unsigned char *)fact = 'N';
}
/* Compute the condition number for comparison with */
/* the value returned by SGTSVX. */
if (zerot) {
if (ifact == 1) {
goto L120;
}
rcondo = 0.f;
rcondi = 0.f;
} else if (ifact == 1) {
i__3 = n + (m << 1);
scopy_(&i__3, &a[1], &c__1, &af[1], &c__1);
/* Compute the 1-norm and infinity-norm of A. */
anormo = slangt_("1", &n, &a[1], &a[m + 1], &a[n + m + 1]);
anormi = slangt_("I", &n, &a[1], &a[m + 1], &a[n + m + 1]);
/* Factor the matrix A. */
sgttrf_(&n, &af[1], &af[m + 1], &af[n + m + 1], &af[n + (
m << 1) + 1], &iwork[1], &info);
/* Use SGTTRS to solve for one column at a time of */
/* inv(A), computing the maximum column sum as we go. */
ainvnm = 0.f;
i__3 = n;
for (i__ = 1; i__ <= i__3; ++i__) {
i__4 = n;
for (j = 1; j <= i__4; ++j) {
x[j] = 0.f;
/* L30: */
}
x[i__] = 1.f;
sgttrs_("No transpose", &n, &c__1, &af[1], &af[m + 1],
&af[n + m + 1], &af[n + (m << 1) + 1], &
iwork[1], &x[1], &lda, &info);
/* Computing MAX */
r__1 = ainvnm, r__2 = sasum_(&n, &x[1], &c__1);
ainvnm = dmax(r__1,r__2);
/* L40: */
}
/* Compute the 1-norm condition number of A. */
if (anormo <= 0.f || ainvnm <= 0.f) {
rcondo = 1.f;
} else {
rcondo = 1.f / anormo / ainvnm;
}
/* Use SGTTRS to solve for one column at a time of */
/* inv(A'), computing the maximum column sum as we go. */
ainvnm = 0.f;
i__3 = n;
for (i__ = 1; i__ <= i__3; ++i__) {
i__4 = n;
for (j = 1; j <= i__4; ++j) {
x[j] = 0.f;
/* L50: */
}
x[i__] = 1.f;
sgttrs_("Transpose", &n, &c__1, &af[1], &af[m + 1], &
af[n + m + 1], &af[n + (m << 1) + 1], &iwork[
1], &x[1], &lda, &info);
/* Computing MAX */
r__1 = ainvnm, r__2 = sasum_(&n, &x[1], &c__1);
ainvnm = dmax(r__1,r__2);
/* L60: */
}
/* Compute the infinity-norm condition number of A. */
if (anormi <= 0.f || ainvnm <= 0.f) {
rcondi = 1.f;
} else {
rcondi = 1.f / anormi / ainvnm;
}
}
for (itran = 1; itran <= 3; ++itran) {
*(unsigned char *)trans = *(unsigned char *)&transs[itran
- 1];
if (itran == 1) {
rcondc = rcondo;
} else {
rcondc = rcondi;
}
/* Generate NRHS random solution vectors. */
ix = 1;
i__3 = *nrhs;
for (j = 1; j <= i__3; ++j) {
slarnv_(&c__2, iseed, &n, &xact[ix]);
ix += lda;
/* L70: */
}
/* Set the right hand side. */
slagtm_(trans, &n, nrhs, &c_b43, &a[1], &a[m + 1], &a[n +
m + 1], &xact[1], &lda, &c_b44, &b[1], &lda);
if (ifact == 2 && itran == 1) {
/* --- Test SGTSV --- */
/* Solve the system using Gaussian elimination with */
/* partial pivoting. */
i__3 = n + (m << 1);
scopy_(&i__3, &a[1], &c__1, &af[1], &c__1);
slacpy_("Full", &n, nrhs, &b[1], &lda, &x[1], &lda);
s_copy(srnamc_1.srnamt, "SGTSV ", (ftnlen)32, (ftnlen)
6);
sgtsv_(&n, nrhs, &af[1], &af[m + 1], &af[n + m + 1], &
x[1], &lda, &info);
/* Check error code from SGTSV . */
if (info != izero) {
alaerh_(path, "SGTSV ", &info, &izero, " ", &n, &
n, &c__1, &c__1, nrhs, &imat, &nfail, &
nerrs, nout);
}
nt = 1;
if (izero == 0) {
/* Check residual of computed solution. */
slacpy_("Full", &n, nrhs, &b[1], &lda, &work[1], &
lda);
sgtt02_(trans, &n, nrhs, &a[1], &a[m + 1], &a[n +
m + 1], &x[1], &lda, &work[1], &lda, &
rwork[1], &result[1]);
/* Check solution from generated exact solution. */
sget04_(&n, nrhs, &x[1], &lda, &xact[1], &lda, &
rcondc, &result[2]);
nt = 3;
}
/* Print information about the tests that did not pass */
/* the threshold. */
i__3 = nt;
for (k = 2; k <= i__3; ++k) {
if (result[k - 1] >= *thresh) {
if (nfail == 0 && nerrs == 0) {
aladhd_(nout, path);
}
io___42.ciunit = *nout;
s_wsfe(&io___42);
do_fio(&c__1, "SGTSV ", (ftnlen)6);
do_fio(&c__1, (char *)&n, (ftnlen)sizeof(
integer));
do_fio(&c__1, (char *)&imat, (ftnlen)sizeof(
integer));
do_fio(&c__1, (char *)&k, (ftnlen)sizeof(
integer));
do_fio(&c__1, (char *)&result[k - 1], (ftnlen)
sizeof(real));
e_wsfe();
++nfail;
}
/* L80: */
}
nrun = nrun + nt - 1;
}
/* --- Test SGTSVX --- */
if (ifact > 1) {
/* Initialize AF to zero. */
i__3 = n * 3 - 2;
for (i__ = 1; i__ <= i__3; ++i__) {
af[i__] = 0.f;
/* L90: */
}
}
slaset_("Full", &n, nrhs, &c_b44, &c_b44, &x[1], &lda);
/* Solve the system and compute the condition number and */
/* error bounds using SGTSVX. */
s_copy(srnamc_1.srnamt, "SGTSVX", (ftnlen)32, (ftnlen)6);
sgtsvx_(fact, trans, &n, nrhs, &a[1], &a[m + 1], &a[n + m
+ 1], &af[1], &af[m + 1], &af[n + m + 1], &af[n +
(m << 1) + 1], &iwork[1], &b[1], &lda, &x[1], &
lda, &rcond, &rwork[1], &rwork[*nrhs + 1], &work[
1], &iwork[n + 1], &info);
/* Check the error code from SGTSVX. */
if (info != izero) {
/* Writing concatenation */
i__5[0] = 1, a__1[0] = fact;
i__5[1] = 1, a__1[1] = trans;
s_cat(ch__1, a__1, i__5, &c__2, (ftnlen)2);
alaerh_(path, "SGTSVX", &info, &izero, ch__1, &n, &n,
&c__1, &c__1, nrhs, &imat, &nfail, &nerrs,
nout);
}
if (ifact >= 2) {
/* Reconstruct matrix from factors and compute */
/* residual. */
sgtt01_(&n, &a[1], &a[m + 1], &a[n + m + 1], &af[1], &
af[m + 1], &af[n + m + 1], &af[n + (m << 1) +
1], &iwork[1], &work[1], &lda, &rwork[1],
result);
k1 = 1;
} else {
k1 = 2;
}
if (info == 0) {
trfcon = FALSE_;
/* Check residual of computed solution. */
slacpy_("Full", &n, nrhs, &b[1], &lda, &work[1], &lda);
sgtt02_(trans, &n, nrhs, &a[1], &a[m + 1], &a[n + m +
1], &x[1], &lda, &work[1], &lda, &rwork[1], &
result[1]);
/* Check solution from generated exact solution. */
sget04_(&n, nrhs, &x[1], &lda, &xact[1], &lda, &
rcondc, &result[2]);
/* Check the error bounds from iterative refinement. */
sgtt05_(trans, &n, nrhs, &a[1], &a[m + 1], &a[n + m +
1], &b[1], &lda, &x[1], &lda, &xact[1], &lda,
&rwork[1], &rwork[*nrhs + 1], &result[3]);
nt = 5;
}
/* Print information about the tests that did not pass */
/* the threshold. */
i__3 = nt;
for (k = k1; k <= i__3; ++k) {
if (result[k - 1] >= *thresh) {
if (nfail == 0 && nerrs == 0) {
aladhd_(nout, path);
}
io___46.ciunit = *nout;
s_wsfe(&io___46);
do_fio(&c__1, "SGTSVX", (ftnlen)6);
do_fio(&c__1, fact, (ftnlen)1);
do_fio(&c__1, trans, (ftnlen)1);
do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer))
;
do_fio(&c__1, (char *)&imat, (ftnlen)sizeof(
integer));
do_fio(&c__1, (char *)&k, (ftnlen)sizeof(integer))
;
do_fio(&c__1, (char *)&result[k - 1], (ftnlen)
sizeof(real));
e_wsfe();
++nfail;
}
/* L100: */
}
/* Check the reciprocal of the condition number. */
result[5] = sget06_(&rcond, &rcondc);
if (result[5] >= *thresh) {
if (nfail == 0 && nerrs == 0) {
aladhd_(nout, path);
}
io___47.ciunit = *nout;
s_wsfe(&io___47);
do_fio(&c__1, "SGTSVX", (ftnlen)6);
do_fio(&c__1, fact, (ftnlen)1);
do_fio(&c__1, trans, (ftnlen)1);
do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&imat, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&k, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&result[k - 1], (ftnlen)sizeof(
real));
e_wsfe();
++nfail;
}
nrun = nrun + nt - k1 + 2;
/* L110: */
}
L120:
;
}
L130:
;
}
/* L140: */
}
/* Print a summary of the results. */
alasvm_(path, nout, &nfail, &nrun, &nerrs);
return 0;
/* End of SDRVGT */
} /* sdrvgt_ */
/* 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)
{
/* System generated locals */
address a__1[2];
integer h_dim1, h_offset, z_dim1, z_offset, i__1, i__2[2], i__3;
real r__1;
char ch__1[2];
/* Builtin functions */
/* Subroutine */ int s_cat(char *, char **, integer *, integer *, ftnlen);
/* Local variables */
integer i__;
#ifdef LAPACK_DISABLE_MEMORY_HOGS
real hl[1] /* was [49][49] */;
/** This function uses too much memory, so we stopped allocating the memory
* above and assert false here. */
assert(0 && "shseqr_ was called. This function allocates too much"
" memory and has been disabled.");
#else
real hl[2401] /* was [49][49] */;
#endif
integer kbot, nmin;
extern logical lsame_(char *, char *);
logical initz;
real workl[49];
logical wantt, wantz;
extern /* Subroutine */ int slaqr0_(logical *, logical *, integer *,
integer *, integer *, real *, integer *, real *, real *, integer *
, integer *, real *, integer *, real *, integer *, integer *),
xerbla_(char *, integer *);
extern integer ilaenv_(integer *, char *, char *, integer *, integer *,
integer *, integer *);
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 *), slaset_(char *, integer *, integer *, real *, real *,
real *, integer *);
logical lquery;
/* -- LAPACK driver routine (version 3.2) -- */
/* Univ. of Tennessee, Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd.. */
/* November 2006 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* SHSEQR computes the eigenvalues of a 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 .GE. 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. If N.GT.0, then 1.LE.ILO.LE.IHI.LE.N. */
/* If N = 0, then ILO = 1 and IHI = 0. */
/* H (input/output) REAL array, dimension (LDH,N) */
/* On entry, the upper Hessenberg matrix H. */
/* On exit, if INFO = 0 and JOB = 'S', then 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).LT.0. If INFO = 0 and JOB = 'E', the */
/* contents of H are unspecified on exit. (The output value of */
/* H when INFO.GT.0 is given under the description of INFO */
/* below.) */
/* Unlike earlier versions of SHSEQR, this subroutine may */
/* explicitly H(i,j) = 0 for i.GT.j and j = 1, 2, ... ILO-1 */
/* or j = IHI+1, IHI+2, ... N. */
/* LDH (input) INTEGER */
/* The leading dimension of the array H. LDH .GE. 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) .GT. 0 and */
/* WI(i+1) .LT. 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, */
/* if INFO = 0, 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, */
/* if INFO = 0, Z contains Q*Z. */
/* Normally Q is the orthogonal matrix generated by SORGHR */
/* after the call to SGEHRD which formed the Hessenberg matrix */
/* H. (The output value of Z when INFO.GT.0 is given under */
/* the description of INFO below.) */
/* LDZ (input) INTEGER */
/* The leading dimension of the array Z. if COMPZ = 'I' or */
/* COMPZ = 'V', then LDZ.GE.MAX(1,N). Otherwize, LDZ.GE.1. */
/* WORK (workspace/output) REAL array, dimension (LWORK) */
/* On exit, if INFO = 0, WORK(1) returns an estimate of */
/* the optimal value for LWORK. */
/* LWORK (input) INTEGER */
/* The dimension of the array WORK. LWORK .GE. max(1,N) */
/* is sufficient and delivers very good and sometimes */
/* optimal performance. However, LWORK as large as 11*N */
/* may be required for optimal performance. A workspace */
/* query is recommended to determine the optimal workspace */
/* size. */
/* If LWORK = -1, then SHSEQR does a workspace query. */
/* In this case, SHSEQR checks the input parameters and */
/* estimates the optimal workspace size for the given */
/* values of N, ILO and IHI. The estimate is returned */
/* in WORK(1). No error message related to LWORK is */
/* issued by XERBLA. Neither H nor Z are accessed. */
/* INFO (output) INTEGER */
/* = 0: successful exit */
/* .LT. 0: if INFO = -i, the i-th argument had an illegal */
/* value */
/* .GT. 0: if INFO = i, SHSEQR failed to compute all of */
/* the eigenvalues. Elements 1:ilo-1 and i+1:n of WR */
/* and WI contain those eigenvalues which have been */
/* successfully computed. (Failures are rare.) */
/* If INFO .GT. 0 and JOB = 'E', then on exit, the */
/* remaining unconverged eigenvalues are the eigen- */
/* values of the upper Hessenberg matrix rows and */
/* columns ILO through INFO of the final, output */
/* value of H. */
/* If INFO .GT. 0 and JOB = 'S', then on exit */
/* (*) (initial value of H)*U = U*(final value of H) */
/* where U is an orthogonal matrix. The final */
/* value of H is upper Hessenberg and quasi-triangular */
/* in rows and columns INFO+1 through IHI. */
/* If INFO .GT. 0 and COMPZ = 'V', then on exit */
/* (final value of Z) = (initial value of Z)*U */
/* where U is the orthogonal matrix in (*) (regard- */
/* less of the value of JOB.) */
/* If INFO .GT. 0 and COMPZ = 'I', then on exit */
/* (final value of Z) = U */
/* where U is the orthogonal matrix in (*) (regard- */
/* less of the value of JOB.) */
/* If INFO .GT. 0 and COMPZ = 'N', then Z is not */
/* accessed. */
/* ================================================================ */
/* Default values supplied by */
/* ILAENV(ISPEC,'SHSEQR',JOB(:1)//COMPZ(:1),N,ILO,IHI,LWORK). */
/* It is suggested that these defaults be adjusted in order */
/* to attain best performance in each particular */
/* computational environment. */
/* ISPEC=12: The SLAHQR vs SLAQR0 crossover point. */
/* Default: 75. (Must be at least 11.) */
/* ISPEC=13: Recommended deflation window size. */
/* This depends on ILO, IHI and NS. NS is the */
/* number of simultaneous shifts returned */
/* by ILAENV(ISPEC=15). (See ISPEC=15 below.) */
/* The default for (IHI-ILO+1).LE.500 is NS. */
/* The default for (IHI-ILO+1).GT.500 is 3*NS/2. */
/* ISPEC=14: Nibble crossover point. (See IPARMQ for */
/* details.) Default: 14% of deflation window */
/* size. */
/* ISPEC=15: Number of simultaneous shifts in a multishift */
/* QR iteration. */
/* If IHI-ILO+1 is ... */
/* greater than ...but less ... the */
/* or equal to ... than default is */
/* 1 30 NS = 2(+) */
/* 30 60 NS = 4(+) */
/* 60 150 NS = 10(+) */
/* 150 590 NS = ** */
/* 590 3000 NS = 64 */
/* 3000 6000 NS = 128 */
/* 6000 infinity NS = 256 */
/* (+) By default some or all matrices of this order */
/* are passed to the implicit double shift routine */
/* SLAHQR and this parameter is ignored. See */
/* ISPEC=12 above and comments in IPARMQ for */
/* details. */
/* (**) The asterisks (**) indicate an ad-hoc */
/* function of N increasing from 10 to 64. */
/* ISPEC=16: Select structured matrix multiply. */
/* If the number of simultaneous shifts (specified */
/* by ISPEC=15) is less than 14, then the default */
/* for ISPEC=16 is 0. Otherwise the default for */
/* ISPEC=16 is 2. */
/* ================================================================ */
/* Based on contributions by */
/* Karen Braman and Ralph Byers, Department of Mathematics, */
/* University of Kansas, USA */
/* ================================================================ */
/* References: */
/* K. Braman, R. Byers and R. Mathias, The Multi-Shift QR */
/* Algorithm Part I: Maintaining Well Focused Shifts, and Level 3 */
/* Performance, SIAM Journal of Matrix Analysis, volume 23, pages */
/* 929--947, 2002. */
/* K. Braman, R. Byers and R. Mathias, The Multi-Shift QR */
/* Algorithm Part II: Aggressive Early Deflation, SIAM Journal */
/* of Matrix Analysis, volume 23, pages 948--973, 2002. */
/* ================================================================ */
/* .. Parameters .. */
/* ==== Matrices of order NTINY or smaller must be processed by */
/* . SLAHQR because of insufficient subdiagonal scratch space. */
/* . (This is a hard limit.) ==== */
/* ==== NL allocates some local workspace to help small matrices */
/* . through a rare SLAHQR failure. NL .GT. NTINY = 11 is */
/* . required and NL .LE. NMIN = ILAENV(ISPEC=12,...) is recom- */
/* . mended. (The default value of NMIN is 75.) Using NL = 49 */
/* . allows up to six simultaneous shifts and a 16-by-16 */
/* . deflation window. ==== */
/* .. */
/* .. Local Arrays .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Executable Statements .. */
/* ==== Decode and check 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");
initz = lsame_(compz, "I");
wantz = initz || lsame_(compz, "V");
work[1] = (real) max(1,*n);
lquery = *lwork == -1;
*info = 0;
if (! lsame_(job, "E") && ! wantt) {
*info = -1;
} else if (! lsame_(compz, "N") && ! 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) {
/* ==== Quick return in case of invalid argument. ==== */
i__1 = -(*info);
xerbla_("SHSEQR", &i__1);
return 0;
} else if (*n == 0) {
/* ==== Quick return in case N = 0; nothing to do. ==== */
return 0;
} else if (lquery) {
/* ==== Quick return in case of a workspace query ==== */
slaqr0_(&wantt, &wantz, n, ilo, ihi, &h__[h_offset], ldh, &wr[1], &wi[
1], ilo, ihi, &z__[z_offset], ldz, &work[1], lwork, info);
/* ==== Ensure reported workspace size is backward-compatible with */
/* . previous LAPACK versions. ==== */
/* Computing MAX */
r__1 = (real) max(1,*n);
work[1] = dmax(r__1,work[1]);
return 0;
} else {
/* ==== copy 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: */
}
/* ==== Initialize Z, if requested ==== */
if (initz) {
slaset_("A", n, n, &c_b11, &c_b12, &z__[z_offset], ldz)
;
}
/* ==== Quick return if possible ==== */
if (*ilo == *ihi) {
wr[*ilo] = h__[*ilo + *ilo * h_dim1];
wi[*ilo] = 0.f;
return 0;
}
/* ==== SLAHQR/SLAQR0 crossover point ==== */
/* Writing concatenation */
i__2[0] = 1, a__1[0] = job;
i__2[1] = 1, a__1[1] = compz;
s_cat(ch__1, a__1, i__2, &c__2, (ftnlen)2);
nmin = ilaenv_(&c__12, "SHSEQR", ch__1, n, ilo, ihi, lwork);
nmin = max(11,nmin);
/* ==== SLAQR0 for big matrices; SLAHQR for small ones ==== */
if (*n > nmin) {
slaqr0_(&wantt, &wantz, n, ilo, ihi, &h__[h_offset], ldh, &wr[1],
&wi[1], ilo, ihi, &z__[z_offset], ldz, &work[1], lwork,
info);
} else {
/* ==== Small matrix ==== */
slahqr_(&wantt, &wantz, n, ilo, ihi, &h__[h_offset], ldh, &wr[1],
&wi[1], ilo, ihi, &z__[z_offset], ldz, info);
if (*info > 0) {
/* ==== A rare SLAHQR failure! SLAQR0 sometimes succeeds */
/* . when SLAHQR fails. ==== */
kbot = *info;
if (*n >= 49) {
/* ==== Larger matrices have enough subdiagonal scratch */
/* . space to call SLAQR0 directly. ==== */
slaqr0_(&wantt, &wantz, n, ilo, &kbot, &h__[h_offset],
ldh, &wr[1], &wi[1], ilo, ihi, &z__[z_offset],
ldz, &work[1], lwork, info);
} else {
/* ==== Tiny matrices don't have enough subdiagonal */
/* . scratch space to benefit from SLAQR0. Hence, */
/* . tiny matrices must be copied into a larger */
/* . array before calling SLAQR0. ==== */
slacpy_("A", n, n, &h__[h_offset], ldh, hl, &c__49);
hl[*n + 1 + *n * 49 - 50] = 0.f;
i__1 = 49 - *n;
slaset_("A", &c__49, &i__1, &c_b11, &c_b11, &hl[(*n + 1) *
49 - 49], &c__49);
slaqr0_(&wantt, &wantz, &c__49, ilo, &kbot, hl, &c__49, &
wr[1], &wi[1], ilo, ihi, &z__[z_offset], ldz,
workl, &c__49, info);
if (wantt || *info != 0) {
slacpy_("A", n, n, hl, &c__49, &h__[h_offset], ldh);
}
}
}
}
/* ==== Clear out the trash, if necessary. ==== */
if ((wantt || *info != 0) && *n > 2) {
i__1 = *n - 2;
i__3 = *n - 2;
slaset_("L", &i__1, &i__3, &c_b11, &c_b11, &h__[h_dim1 + 3], ldh);
}
/* ==== Ensure reported workspace size is backward-compatible with */
/* . previous LAPACK versions. ==== */
/* Computing MAX */
r__1 = (real) max(1,*n);
work[1] = dmax(r__1,work[1]);
}
/* ==== End of SHSEQR ==== */
return 0;
} /* shseqr_ */
/* Subroutine */
int sptsvx_(char *fact, integer *n, integer *nrhs, real *d__, real *e, real *df, real *ef, real *b, integer *ldb, real *x, integer *ldx, real *rcond, real *ferr, real *berr, real *work, integer *info)
{
/* System generated locals */
integer b_dim1, b_offset, x_dim1, x_offset, i__1;
/* Local variables */
extern logical lsame_(char *, char *);
real anorm;
extern /* Subroutine */
int scopy_(integer *, real *, integer *, real *, integer *);
extern real slamch_(char *);
logical nofact;
extern /* Subroutine */
int xerbla_(char *, integer *), slacpy_( char *, integer *, integer *, real *, integer *, real *, integer * );
extern real slanst_(char *, integer *, real *, real *);
extern /* Subroutine */
int sptcon_(integer *, real *, real *, real *, real *, real *, integer *), sptrfs_(integer *, integer *, real *, real *, real *, real *, real *, integer *, real *, integer *, real *, real *, real *, integer *), spttrf_(integer *, real *, real *, integer *), spttrs_(integer *, integer *, real *, real *, real *, integer *, integer *);
/* -- LAPACK driver routine (version 3.4.2) -- */
/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */
/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */
/* September 2012 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Executable Statements .. */
/* Test the input parameters. */
/* Parameter adjustments */
--d__;
--e;
--df;
--ef;
b_dim1 = *ldb;
b_offset = 1 + b_dim1;
b -= b_offset;
x_dim1 = *ldx;
x_offset = 1 + x_dim1;
x -= x_offset;
--ferr;
--berr;
--work;
/* Function Body */
*info = 0;
nofact = lsame_(fact, "N");
if (! nofact && ! lsame_(fact, "F"))
{
*info = -1;
}
else if (*n < 0)
{
*info = -2;
}
else if (*nrhs < 0)
{
*info = -3;
}
else if (*ldb < max(1,*n))
{
*info = -9;
}
else if (*ldx < max(1,*n))
{
*info = -11;
}
if (*info != 0)
{
i__1 = -(*info);
xerbla_("SPTSVX", &i__1);
return 0;
}
if (nofact)
{
/* Compute the L*D*L**T (or U**T*D*U) factorization of A. */
scopy_(n, &d__[1], &c__1, &df[1], &c__1);
if (*n > 1)
{
i__1 = *n - 1;
scopy_(&i__1, &e[1], &c__1, &ef[1], &c__1);
}
spttrf_(n, &df[1], &ef[1], info);
/* Return if INFO is non-zero. */
if (*info > 0)
{
*rcond = 0.f;
return 0;
}
}
/* Compute the norm of the matrix A. */
anorm = slanst_("1", n, &d__[1], &e[1]);
/* Compute the reciprocal of the condition number of A. */
sptcon_(n, &df[1], &ef[1], &anorm, rcond, &work[1], info);
/* Compute the solution vectors X. */
slacpy_("Full", n, nrhs, &b[b_offset], ldb, &x[x_offset], ldx);
spttrs_(n, nrhs, &df[1], &ef[1], &x[x_offset], ldx, info);
/* Use iterative refinement to improve the computed solutions and */
/* compute error bounds and backward error estimates for them. */
sptrfs_(n, nrhs, &d__[1], &e[1], &df[1], &ef[1], &b[b_offset], ldb, &x[ x_offset], ldx, &ferr[1], &berr[1], &work[1], info);
/* Set INFO = N+1 if the matrix is singular to working precision. */
if (*rcond < slamch_("Epsilon"))
{
*info = *n + 1;
}
return 0;
/* End of SPTSVX */
}
/* Subroutine */ int sggesx_(char *jobvsl, char *jobvsr, char *sort, L_fp
selctg, char *sense, integer *n, real *a, integer *lda, real *b,
integer *ldb, integer *sdim, real *alphar, real *alphai, real *beta,
real *vsl, integer *ldvsl, real *vsr, integer *ldvsr, real *rconde,
real *rcondv, real *work, integer *lwork, integer *iwork, integer *
liwork, logical *bwork, integer *info)
{
/* -- LAPACK driver 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
=======
SGGESX computes for a pair of N-by-N real nonsymmetric matrices
(A,B), the generalized eigenvalues, the real Schur form (S,T), and,
optionally, the left and/or right matrices of Schur vectors (VSL and
VSR). This gives the generalized Schur factorization
(A,B) = ( (VSL) S (VSR)**T, (VSL) T (VSR)**T )
Optionally, it also orders the eigenvalues so that a selected cluster
of eigenvalues appears in the leading diagonal blocks of the upper
quasi-triangular matrix S and the upper triangular matrix T; computes
a reciprocal condition number for the average of the selected
eigenvalues (RCONDE); and computes a reciprocal condition number for
the right and left deflating subspaces corresponding to the selected
eigenvalues (RCONDV). The leading columns of VSL and VSR then form
an orthonormal basis for the corresponding left and right eigenspaces
(deflating subspaces).
A generalized eigenvalue for a pair of matrices (A,B) is a scalar w
or a ratio alpha/beta = w, such that A - w*B is singular. It is
usually represented as the pair (alpha,beta), as there is a
reasonable interpretation for beta=0 or for both being zero.
A pair of matrices (S,T) is in generalized real Schur form if T is
upper triangular with non-negative diagonal and S is block upper
triangular with 1-by-1 and 2-by-2 blocks. 1-by-1 blocks correspond
to real generalized eigenvalues, while 2-by-2 blocks of S will be
"standardized" by making the corresponding elements of T have the
form:
[ a 0 ]
[ 0 b ]
and the pair of corresponding 2-by-2 blocks in S and T will have a
complex conjugate pair of generalized eigenvalues.
Arguments
=========
JOBVSL (input) CHARACTER*1
= 'N': do not compute the left Schur vectors;
= 'V': compute the left Schur vectors.
JOBVSR (input) CHARACTER*1
= 'N': do not compute the right Schur vectors;
= 'V': compute the right Schur vectors.
SORT (input) CHARACTER*1
Specifies whether or not to order the eigenvalues on the
diagonal of the generalized Schur form.
= 'N': Eigenvalues are not ordered;
= 'S': Eigenvalues are ordered (see SELCTG).
SELCTG (input) LOGICAL FUNCTION of three REAL arguments
SELCTG must be declared EXTERNAL in the calling subroutine.
If SORT = 'N', SELCTG is not referenced.
If SORT = 'S', SELCTG is used to select eigenvalues to sort
to the top left of the Schur form.
An eigenvalue (ALPHAR(j)+ALPHAI(j))/BETA(j) is selected if
SELCTG(ALPHAR(j),ALPHAI(j),BETA(j)) is true; i.e. if either
one of a complex conjugate pair of eigenvalues is selected,
then both complex eigenvalues are selected.
Note that a selected complex eigenvalue may no longer satisfy
SELCTG(ALPHAR(j),ALPHAI(j),BETA(j)) = .TRUE. after ordering,
since ordering may change the value of complex eigenvalues
(especially if the eigenvalue is ill-conditioned), in this
case INFO is set to N+3.
SENSE (input) CHARACTER
Determines which reciprocal condition numbers are computed.
= 'N' : None are computed;
= 'E' : Computed for average of selected eigenvalues only;
= 'V' : Computed for selected deflating subspaces only;
= 'B' : Computed for both.
If SENSE = 'E', 'V', or 'B', SORT must equal 'S'.
N (input) INTEGER
The order of the matrices A, B, VSL, and VSR. N >= 0.
A (input/output) REAL array, dimension (LDA, N)
On entry, the first of the pair of matrices.
On exit, A has been overwritten by its generalized Schur
form S.
LDA (input) INTEGER
The leading dimension of A. LDA >= max(1,N).
B (input/output) REAL array, dimension (LDB, N)
On entry, the second of the pair of matrices.
On exit, B has been overwritten by its generalized Schur
form T.
LDB (input) INTEGER
The leading dimension of B. LDB >= max(1,N).
SDIM (output) INTEGER
If SORT = 'N', SDIM = 0.
If SORT = 'S', SDIM = number of eigenvalues (after sorting)
for which SELCTG is true. (Complex conjugate pairs for which
SELCTG is true for either eigenvalue count as 2.)
ALPHAR (output) REAL array, dimension (N)
ALPHAI (output) REAL array, dimension (N)
BETA (output) REAL array, dimension (N)
On exit, (ALPHAR(j) + ALPHAI(j)*i)/BETA(j), j=1,...,N, will
be the generalized eigenvalues. ALPHAR(j) + ALPHAI(j)*i
and BETA(j),j=1,...,N are the diagonals of the complex Schur
form (S,T) that would result if the 2-by-2 diagonal blocks of
the real Schur form of (A,B) were further reduced to
triangular form using 2-by-2 complex unitary transformations.
If ALPHAI(j) is zero, then the j-th eigenvalue is real; if
positive, then the j-th and (j+1)-st eigenvalues are a
complex conjugate pair, with ALPHAI(j+1) negative.
Note: the quotients ALPHAR(j)/BETA(j) and ALPHAI(j)/BETA(j)
may easily over- or underflow, and BETA(j) may even be zero.
Thus, the user should avoid naively computing the ratio.
However, ALPHAR and ALPHAI will be always less than and
usually comparable with norm(A) in magnitude, and BETA always
less than and usually comparable with norm(B).
VSL (output) REAL array, dimension (LDVSL,N)
If JOBVSL = 'V', VSL will contain the left Schur vectors.
Not referenced if JOBVSL = 'N'.
LDVSL (input) INTEGER
The leading dimension of the matrix VSL. LDVSL >=1, and
if JOBVSL = 'V', LDVSL >= N.
VSR (output) REAL array, dimension (LDVSR,N)
If JOBVSR = 'V', VSR will contain the right Schur vectors.
Not referenced if JOBVSR = 'N'.
LDVSR (input) INTEGER
The leading dimension of the matrix VSR. LDVSR >= 1, and
if JOBVSR = 'V', LDVSR >= N.
RCONDE (output) REAL array, dimension ( 2 )
If SENSE = 'E' or 'B', RCONDE(1) and RCONDE(2) contain the
reciprocal condition numbers for the average of the selected
eigenvalues.
Not referenced if SENSE = 'N' or 'V'.
RCONDV (output) REAL array, dimension ( 2 )
If SENSE = 'V' or 'B', RCONDV(1) and RCONDV(2) contain the
reciprocal condition numbers for the selected deflating
subspaces.
Not referenced if SENSE = 'N' or 'E'.
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 >= 8*(N+1)+16.
If SENSE = 'E', 'V', or 'B',
LWORK >= MAX( 8*(N+1)+16, 2*SDIM*(N-SDIM) ).
IWORK (workspace) INTEGER array, dimension (LIWORK)
Not referenced if SENSE = 'N'.
LIWORK (input) INTEGER
The dimension of the array WORK. LIWORK >= N+6.
BWORK (workspace) LOGICAL array, dimension (N)
Not referenced if SORT = 'N'.
INFO (output) INTEGER
= 0: successful exit
< 0: if INFO = -i, the i-th argument had an illegal value.
= 1,...,N:
The QZ iteration failed. (A,B) are not in Schur
form, but ALPHAR(j), ALPHAI(j), and BETA(j) should
be correct for j=INFO+1,...,N.
> N: =N+1: other than QZ iteration failed in SHGEQZ
=N+2: after reordering, roundoff changed values of
some complex eigenvalues so that leading
eigenvalues in the Generalized Schur form no
longer satisfy SELCTG=.TRUE. This could also
be caused due to scaling.
=N+3: reordering failed in STGSEN.
Further details
===============
An approximate (asymptotic) bound on the average absolute error of
the selected eigenvalues is
EPS * norm((A, B)) / RCONDE( 1 ).
An approximate (asymptotic) bound on the maximum angular error in
the computed deflating subspaces is
EPS * norm((A, B)) / RCONDV( 2 ).
See LAPACK User's Guide, section 4.11 for more information.
=====================================================================
Decode the input arguments
Parameter adjustments */
/* Table of constant values */
static integer c__1 = 1;
static integer c__0 = 0;
static integer c_n1 = -1;
static real c_b37 = 0.f;
static real c_b38 = 1.f;
/* System generated locals */
integer a_dim1, a_offset, b_dim1, b_offset, vsl_dim1, vsl_offset,
vsr_dim1, vsr_offset, i__1, i__2;
real r__1;
/* Builtin functions */
double sqrt(doublereal);
/* Local variables */
static integer ijob;
static real anrm, bnrm;
static integer ierr, itau, iwrk, i__;
extern logical lsame_(char *, char *);
static integer ileft, icols;
static logical cursl, ilvsl, ilvsr;
static integer irows;
static logical lst2sl;
extern /* Subroutine */ int slabad_(real *, real *);
static integer ip;
static real pl;
extern /* Subroutine */ int sggbak_(char *, char *, integer *, integer *,
integer *, real *, real *, integer *, real *, integer *, integer *
), sggbal_(char *, integer *, real *, integer *,
real *, integer *, integer *, integer *, real *, real *, real *,
integer *);
static real pr;
static logical ilascl, ilbscl;
extern doublereal slamch_(char *), slange_(char *, integer *,
integer *, real *, integer *, real *);
static real safmin;
extern /* Subroutine */ int sgghrd_(char *, char *, integer *, integer *,
integer *, real *, integer *, real *, integer *, real *, integer *
, real *, integer *, integer *);
static real safmax;
extern /* Subroutine */ int xerbla_(char *, integer *);
static real bignum;
extern /* Subroutine */ int slascl_(char *, integer *, integer *, real *,
real *, integer *, integer *, real *, integer *, integer *);
extern integer ilaenv_(integer *, char *, char *, integer *, integer *,
integer *, integer *, ftnlen, ftnlen);
static integer ijobvl, iright;
extern /* Subroutine */ int sgeqrf_(integer *, integer *, real *, integer
*, real *, real *, integer *, integer *);
static integer ijobvr;
extern /* Subroutine */ int slacpy_(char *, integer *, integer *, real *,
integer *, real *, integer *);
static logical wantsb, wantse, lastsl;
static integer liwmin;
static real anrmto, bnrmto;
static integer minwrk, maxwrk;
static logical wantsn;
static real smlnum;
extern /* Subroutine */ int shgeqz_(char *, char *, char *, integer *,
integer *, integer *, real *, integer *, real *, integer *, real *
, real *, real *, real *, integer *, real *, integer *, real *,
integer *, integer *), slaset_(char *,
integer *, integer *, real *, real *, real *, integer *),
sorgqr_(integer *, integer *, integer *, real *, integer *, real *
, real *, integer *, integer *), stgsen_(integer *, logical *,
logical *, logical *, integer *, real *, integer *, real *,
integer *, real *, real *, real *, real *, integer *, real *,
integer *, integer *, real *, real *, real *, real *, integer *,
integer *, integer *, integer *);
static logical wantst, wantsv;
extern /* Subroutine */ int sormqr_(char *, char *, integer *, integer *,
integer *, real *, integer *, real *, real *, integer *, real *,
integer *, integer *);
static real dif[2];
static integer ihi, ilo;
static real eps;
#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 vsl_ref(a_1,a_2) vsl[(a_2)*vsl_dim1 + a_1]
a_dim1 = *lda;
a_offset = 1 + a_dim1 * 1;
a -= a_offset;
b_dim1 = *ldb;
b_offset = 1 + b_dim1 * 1;
b -= b_offset;
--alphar;
--alphai;
--beta;
vsl_dim1 = *ldvsl;
vsl_offset = 1 + vsl_dim1 * 1;
vsl -= vsl_offset;
vsr_dim1 = *ldvsr;
vsr_offset = 1 + vsr_dim1 * 1;
vsr -= vsr_offset;
--rconde;
--rcondv;
--work;
--iwork;
--bwork;
/* Function Body */
if (lsame_(jobvsl, "N")) {
ijobvl = 1;
ilvsl = FALSE_;
} else if (lsame_(jobvsl, "V")) {
ijobvl = 2;
ilvsl = TRUE_;
} else {
ijobvl = -1;
ilvsl = FALSE_;
}
if (lsame_(jobvsr, "N")) {
ijobvr = 1;
ilvsr = FALSE_;
} else if (lsame_(jobvsr, "V")) {
ijobvr = 2;
ilvsr = TRUE_;
} else {
ijobvr = -1;
ilvsr = FALSE_;
}
wantst = lsame_(sort, "S");
wantsn = lsame_(sense, "N");
wantse = lsame_(sense, "E");
wantsv = lsame_(sense, "V");
wantsb = lsame_(sense, "B");
if (wantsn) {
ijob = 0;
iwork[1] = 1;
} else if (wantse) {
ijob = 1;
} else if (wantsv) {
ijob = 2;
} else if (wantsb) {
ijob = 4;
}
/* Test the input arguments */
*info = 0;
if (ijobvl <= 0) {
*info = -1;
} else if (ijobvr <= 0) {
*info = -2;
} else if (! wantst && ! lsame_(sort, "N")) {
*info = -3;
} else if (! (wantsn || wantse || wantsv || wantsb) || ! wantst && !
wantsn) {
*info = -5;
} else if (*n < 0) {
*info = -6;
} else if (*lda < max(1,*n)) {
*info = -8;
} else if (*ldb < max(1,*n)) {
*info = -10;
} else if (*ldvsl < 1 || ilvsl && *ldvsl < *n) {
*info = -16;
} else if (*ldvsr < 1 || ilvsr && *ldvsr < *n) {
*info = -18;
}
/* Compute workspace
(Note: Comments in the code beginning "Workspace:" describe the
minimal amount of workspace needed at that point in the code,
as well as the preferred amount for good performance.
NB refers to the optimal block size for the immediately
following subroutine, as returned by ILAENV.) */
minwrk = 1;
if (*info == 0 && *lwork >= 1) {
minwrk = (*n + 1 << 3) + 16;
maxwrk = (*n + 1) * 7 + *n * ilaenv_(&c__1, "SGEQRF", " ", n, &c__1,
n, &c__0, (ftnlen)6, (ftnlen)1) + 16;
if (ilvsl) {
/* Computing MAX */
i__1 = maxwrk, i__2 = (*n + 1 << 3) + *n * ilaenv_(&c__1, "SORGQR"
, " ", n, &c__1, n, &c_n1, (ftnlen)6, (ftnlen)1) + 16;
maxwrk = max(i__1,i__2);
}
work[1] = (real) maxwrk;
}
if (! wantsn) {
liwmin = 1;
} else {
liwmin = *n + 6;
}
iwork[1] = liwmin;
if (*info == 0 && *lwork < minwrk) {
*info = -22;
} else if (*info == 0 && ijob >= 1) {
if (*liwork < liwmin) {
*info = -24;
}
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("SGGESX", &i__1);
return 0;
}
/* Quick return if possible */
if (*n == 0) {
*sdim = 0;
return 0;
}
/* Get machine constants */
eps = slamch_("P");
safmin = slamch_("S");
safmax = 1.f / safmin;
slabad_(&safmin, &safmax);
smlnum = sqrt(safmin) / eps;
bignum = 1.f / smlnum;
/* Scale A if max element outside range [SMLNUM,BIGNUM] */
anrm = slange_("M", n, n, &a[a_offset], lda, &work[1]);
ilascl = FALSE_;
if (anrm > 0.f && anrm < smlnum) {
anrmto = smlnum;
ilascl = TRUE_;
} else if (anrm > bignum) {
anrmto = bignum;
ilascl = TRUE_;
}
if (ilascl) {
slascl_("G", &c__0, &c__0, &anrm, &anrmto, n, n, &a[a_offset], lda, &
ierr);
}
/* Scale B if max element outside range [SMLNUM,BIGNUM] */
bnrm = slange_("M", n, n, &b[b_offset], ldb, &work[1]);
ilbscl = FALSE_;
if (bnrm > 0.f && bnrm < smlnum) {
bnrmto = smlnum;
ilbscl = TRUE_;
} else if (bnrm > bignum) {
bnrmto = bignum;
ilbscl = TRUE_;
}
if (ilbscl) {
slascl_("G", &c__0, &c__0, &bnrm, &bnrmto, n, n, &b[b_offset], ldb, &
ierr);
}
/* Permute the matrix to make it more nearly triangular
(Workspace: need 6*N + 2*N for permutation parameters) */
ileft = 1;
iright = *n + 1;
iwrk = iright + *n;
sggbal_("P", n, &a[a_offset], lda, &b[b_offset], ldb, &ilo, &ihi, &work[
ileft], &work[iright], &work[iwrk], &ierr);
/* Reduce B to triangular form (QR decomposition of B)
(Workspace: need N, prefer N*NB) */
irows = ihi + 1 - ilo;
icols = *n + 1 - ilo;
itau = iwrk;
iwrk = itau + irows;
i__1 = *lwork + 1 - iwrk;
sgeqrf_(&irows, &icols, &b_ref(ilo, ilo), ldb, &work[itau], &work[iwrk], &
i__1, &ierr);
/* Apply the orthogonal transformation to matrix A
(Workspace: need N, prefer N*NB) */
i__1 = *lwork + 1 - iwrk;
sormqr_("L", "T", &irows, &icols, &irows, &b_ref(ilo, ilo), ldb, &work[
itau], &a_ref(ilo, ilo), lda, &work[iwrk], &i__1, &ierr);
/* Initialize VSL
(Workspace: need N, prefer N*NB) */
if (ilvsl) {
slaset_("Full", n, n, &c_b37, &c_b38, &vsl[vsl_offset], ldvsl);
i__1 = irows - 1;
i__2 = irows - 1;
slacpy_("L", &i__1, &i__2, &b_ref(ilo + 1, ilo), ldb, &vsl_ref(ilo +
1, ilo), ldvsl);
i__1 = *lwork + 1 - iwrk;
sorgqr_(&irows, &irows, &irows, &vsl_ref(ilo, ilo), ldvsl, &work[itau]
, &work[iwrk], &i__1, &ierr);
}
/* Initialize VSR */
if (ilvsr) {
slaset_("Full", n, n, &c_b37, &c_b38, &vsr[vsr_offset], ldvsr);
}
/* Reduce to generalized Hessenberg form
(Workspace: none needed) */
sgghrd_(jobvsl, jobvsr, n, &ilo, &ihi, &a[a_offset], lda, &b[b_offset],
ldb, &vsl[vsl_offset], ldvsl, &vsr[vsr_offset], ldvsr, &ierr);
*sdim = 0;
/* Perform QZ algorithm, computing Schur vectors if desired
(Workspace: need N) */
iwrk = itau;
i__1 = *lwork + 1 - iwrk;
shgeqz_("S", jobvsl, jobvsr, n, &ilo, &ihi, &a[a_offset], lda, &b[
b_offset], ldb, &alphar[1], &alphai[1], &beta[1], &vsl[vsl_offset]
, ldvsl, &vsr[vsr_offset], ldvsr, &work[iwrk], &i__1, &ierr);
if (ierr != 0) {
if (ierr > 0 && ierr <= *n) {
*info = ierr;
} else if (ierr > *n && ierr <= *n << 1) {
*info = ierr - *n;
} else {
*info = *n + 1;
}
goto L50;
}
/* Sort eigenvalues ALPHA/BETA and compute the reciprocal of
condition number(s)
(Workspace: If IJOB >= 1, need MAX( 8*(N+1), 2*SDIM*(N-SDIM) )
otherwise, need 8*(N+1) ) */
if (wantst) {
/* Undo scaling on eigenvalues before SELCTGing */
if (ilascl) {
slascl_("G", &c__0, &c__0, &anrmto, &anrm, n, &c__1, &alphar[1],
n, &ierr);
slascl_("G", &c__0, &c__0, &anrmto, &anrm, n, &c__1, &alphai[1],
n, &ierr);
}
if (ilbscl) {
slascl_("G", &c__0, &c__0, &bnrmto, &bnrm, n, &c__1, &beta[1], n,
&ierr);
}
/* Select eigenvalues */
i__1 = *n;
for (i__ = 1; i__ <= i__1; ++i__) {
bwork[i__] = (*selctg)(&alphar[i__], &alphai[i__], &beta[i__]);
/* L10: */
}
/* Reorder eigenvalues, transform Generalized Schur vectors, and
compute reciprocal condition numbers */
i__1 = *lwork - iwrk + 1;
stgsen_(&ijob, &ilvsl, &ilvsr, &bwork[1], n, &a[a_offset], lda, &b[
b_offset], ldb, &alphar[1], &alphai[1], &beta[1], &vsl[
vsl_offset], ldvsl, &vsr[vsr_offset], ldvsr, sdim, &pl, &pr,
dif, &work[iwrk], &i__1, &iwork[1], liwork, &ierr);
if (ijob >= 1) {
/* Computing MAX */
i__1 = maxwrk, i__2 = (*sdim << 1) * (*n - *sdim);
maxwrk = max(i__1,i__2);
}
if (ierr == -22) {
/* not enough real workspace */
*info = -22;
} else {
rconde[1] = pl;
rconde[2] = pr;
rcondv[1] = dif[0];
rcondv[2] = dif[1];
if (ierr == 1) {
*info = *n + 3;
}
}
}
/* Apply permutation to VSL and VSR
(Workspace: none needed) */
if (ilvsl) {
sggbak_("P", "L", n, &ilo, &ihi, &work[ileft], &work[iright], n, &vsl[
vsl_offset], ldvsl, &ierr);
}
if (ilvsr) {
sggbak_("P", "R", n, &ilo, &ihi, &work[ileft], &work[iright], n, &vsr[
vsr_offset], ldvsr, &ierr);
}
/* Check if unscaling would cause over/underflow, if so, rescale
(ALPHAR(I),ALPHAI(I),BETA(I)) so BETA(I) is on the order of
B(I,I) and ALPHAR(I) and ALPHAI(I) are on the order of A(I,I) */
if (ilascl) {
i__1 = *n;
for (i__ = 1; i__ <= i__1; ++i__) {
if (alphai[i__] != 0.f) {
if (alphar[i__] / safmax > anrmto / anrm || safmin / alphar[
i__] > anrm / anrmto) {
work[1] = (r__1 = a_ref(i__, i__) / alphar[i__], dabs(
r__1));
beta[i__] *= work[1];
alphar[i__] *= work[1];
alphai[i__] *= work[1];
} else if (alphai[i__] / safmax > anrmto / anrm || safmin /
alphai[i__] > anrm / anrmto) {
work[1] = (r__1 = a_ref(i__, i__ + 1) / alphai[i__], dabs(
r__1));
beta[i__] *= work[1];
alphar[i__] *= work[1];
alphai[i__] *= work[1];
}
}
/* L20: */
}
}
if (ilbscl) {
i__1 = *n;
for (i__ = 1; i__ <= i__1; ++i__) {
if (alphai[i__] != 0.f) {
if (beta[i__] / safmax > bnrmto / bnrm || safmin / beta[i__]
> bnrm / bnrmto) {
work[1] = (r__1 = b_ref(i__, i__) / beta[i__], dabs(r__1))
;
beta[i__] *= work[1];
alphar[i__] *= work[1];
alphai[i__] *= work[1];
}
}
/* L25: */
}
}
/* Undo scaling */
if (ilascl) {
slascl_("H", &c__0, &c__0, &anrmto, &anrm, n, n, &a[a_offset], lda, &
ierr);
slascl_("G", &c__0, &c__0, &anrmto, &anrm, n, &c__1, &alphar[1], n, &
ierr);
slascl_("G", &c__0, &c__0, &anrmto, &anrm, n, &c__1, &alphai[1], n, &
ierr);
}
if (ilbscl) {
slascl_("U", &c__0, &c__0, &bnrmto, &bnrm, n, n, &b[b_offset], ldb, &
ierr);
slascl_("G", &c__0, &c__0, &bnrmto, &bnrm, n, &c__1, &beta[1], n, &
ierr);
}
/* L30: */
if (wantst) {
/* Check if reordering is correct */
lastsl = TRUE_;
lst2sl = TRUE_;
*sdim = 0;
ip = 0;
i__1 = *n;
for (i__ = 1; i__ <= i__1; ++i__) {
cursl = (*selctg)(&alphar[i__], &alphai[i__], &beta[i__]);
if (alphai[i__] == 0.f) {
if (cursl) {
++(*sdim);
}
ip = 0;
if (cursl && ! lastsl) {
*info = *n + 2;
}
} else {
if (ip == 1) {
/* Last eigenvalue of conjugate pair */
cursl = cursl || lastsl;
lastsl = cursl;
if (cursl) {
*sdim += 2;
}
ip = -1;
if (cursl && ! lst2sl) {
*info = *n + 2;
}
} else {
/* First eigenvalue of conjugate pair */
ip = 1;
}
}
lst2sl = lastsl;
lastsl = cursl;
/* L40: */
}
}
L50:
work[1] = (real) maxwrk;
iwork[1] = liwmin;
return 0;
/* End of SGGESX */
} /* sggesx_ */
int ssbgvd_(char *jobz, char *uplo, int *n, int *ka,
int *kb, float *ab, int *ldab, float *bb, int *ldbb, float *
w, float *z__, int *ldz, float *work, int *lwork, int *
iwork, int *liwork, int *info)
{
/* System generated locals */
int ab_dim1, ab_offset, bb_dim1, bb_offset, z_dim1, z_offset, i__1;
/* Local variables */
int inde;
char vect[1];
extern int lsame_(char *, char *);
int iinfo;
extern int sgemm_(char *, char *, int *, int *,
int *, float *, float *, int *, float *, int *, float *,
float *, int *);
int lwmin;
int upper, wantz;
int indwk2, llwrk2;
extern int xerbla_(char *, int *), sstedc_(
char *, int *, float *, float *, float *, int *, float *,
int *, int *, int *, int *), slacpy_(char
*, int *, int *, float *, int *, float *, int *);
int indwrk, liwmin;
extern int spbstf_(char *, int *, int *, float *,
int *, int *), ssbtrd_(char *, char *, int *,
int *, float *, int *, float *, float *, float *, int *,
float *, int *), ssbgst_(char *, char *,
int *, int *, int *, float *, int *, float *,
int *, float *, int *, float *, int *),
ssterf_(int *, float *, float *, int *);
int lquery;
/* -- LAPACK driver routine (version 3.2) -- */
/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/* November 2006 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* SSBGVD computes all the eigenvalues, and optionally, the eigenvectors */
/* of a float generalized symmetric-definite banded eigenproblem, of the */
/* form A*x=(lambda)*B*x. Here A and B are assumed to be symmetric and */
/* banded, and B is also positive definite. If eigenvectors are */
/* desired, it uses a divide and conquer algorithm. */
/* The divide and conquer algorithm makes very mild assumptions about */
/* floating point arithmetic. It will work on machines with a guard */
/* digit in add/subtract, or on those binary machines without guard */
/* digits which subtract like the Cray X-MP, Cray Y-MP, Cray C-90, or */
/* Cray-2. It could conceivably fail on hexadecimal or decimal machines */
/* without guard digits, but we know of none. */
/* Arguments */
/* ========= */
/* JOBZ (input) CHARACTER*1 */
/* = 'N': Compute eigenvalues only; */
/* = 'V': Compute eigenvalues and eigenvectors. */
/* UPLO (input) CHARACTER*1 */
/* = 'U': Upper triangles of A and B are stored; */
/* = 'L': Lower triangles of A and B are stored. */
/* N (input) INTEGER */
/* The order of the matrices A and B. N >= 0. */
/* KA (input) INTEGER */
/* The number of superdiagonals of the matrix A if UPLO = 'U', */
/* or the number of subdiagonals if UPLO = 'L'. KA >= 0. */
/* KB (input) INTEGER */
/* The number of superdiagonals of the matrix B if UPLO = 'U', */
/* or the number of subdiagonals if UPLO = 'L'. KB >= 0. */
/* AB (input/output) REAL array, dimension (LDAB, N) */
/* On entry, the upper or lower triangle of the symmetric band */
/* matrix A, stored in the first ka+1 rows of the array. The */
/* j-th column of A is stored in the j-th column of the array AB */
/* as follows: */
/* if UPLO = 'U', AB(ka+1+i-j,j) = A(i,j) for MAX(1,j-ka)<=i<=j; */
/* if UPLO = 'L', AB(1+i-j,j) = A(i,j) for j<=i<=MIN(n,j+ka). */
/* On exit, the contents of AB are destroyed. */
/* LDAB (input) INTEGER */
/* The leading dimension of the array AB. LDAB >= KA+1. */
/* BB (input/output) REAL array, dimension (LDBB, N) */
/* On entry, the upper or lower triangle of the symmetric band */
/* matrix B, stored in the first kb+1 rows of the array. The */
/* j-th column of B is stored in the j-th column of the array BB */
/* as follows: */
/* if UPLO = 'U', BB(ka+1+i-j,j) = B(i,j) for MAX(1,j-kb)<=i<=j; */
/* if UPLO = 'L', BB(1+i-j,j) = B(i,j) for j<=i<=MIN(n,j+kb). */
/* On exit, the factor S from the split Cholesky factorization */
/* B = S**T*S, as returned by SPBSTF. */
/* LDBB (input) INTEGER */
/* The leading dimension of the array BB. LDBB >= KB+1. */
/* W (output) REAL array, dimension (N) */
/* If INFO = 0, the eigenvalues in ascending order. */
/* Z (output) REAL array, dimension (LDZ, N) */
/* If JOBZ = 'V', then if INFO = 0, Z contains the matrix Z of */
/* eigenvectors, with the i-th column of Z holding the */
/* eigenvector associated with W(i). The eigenvectors are */
/* normalized so Z**T*B*Z = I. */
/* If JOBZ = 'N', then Z is not referenced. */
/* LDZ (input) INTEGER */
/* The leading dimension of the array Z. LDZ >= 1, and if */
/* JOBZ = 'V', LDZ >= MAX(1,N). */
/* 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. */
/* If N <= 1, LWORK >= 1. */
/* If JOBZ = 'N' and N > 1, LWORK >= 3*N. */
/* If JOBZ = 'V' and N > 1, LWORK >= 1 + 5*N + 2*N**2. */
/* If LWORK = -1, then a workspace query is assumed; the routine */
/* only calculates the optimal sizes of the WORK and IWORK */
/* arrays, returns these values as the first entries of the WORK */
/* and IWORK arrays, and no error message related to LWORK or */
/* LIWORK is issued by XERBLA. */
/* IWORK (workspace/output) INTEGER array, dimension (MAX(1,LIWORK)) */
/* On exit, if LIWORK > 0, IWORK(1) returns the optimal LIWORK. */
/* LIWORK (input) INTEGER */
/* The dimension of the array IWORK. */
/* If JOBZ = 'N' or N <= 1, LIWORK >= 1. */
/* If JOBZ = 'V' and N > 1, LIWORK >= 3 + 5*N. */
/* If LIWORK = -1, then a workspace query is assumed; the */
/* routine only calculates the optimal sizes of the WORK and */
/* IWORK arrays, returns these values as the first entries of */
/* the WORK and IWORK arrays, and no error message related to */
/* LWORK or LIWORK 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, and i is: */
/* <= N: the algorithm failed to converge: */
/* i off-diagonal elements of an intermediate */
/* tridiagonal form did not converge to zero; */
/* > N: if INFO = N + i, for 1 <= i <= N, then SPBSTF */
/* returned INFO = i: B is not positive definite. */
/* The factorization of B could not be completed and */
/* no eigenvalues or eigenvectors were computed. */
/* Further Details */
/* =============== */
/* Based on contributions by */
/* Mark Fahey, Department of Mathematics, Univ. of Kentucky, USA */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Executable Statements .. */
/* Test the input parameters. */
/* Parameter adjustments */
ab_dim1 = *ldab;
ab_offset = 1 + ab_dim1;
ab -= ab_offset;
bb_dim1 = *ldbb;
bb_offset = 1 + bb_dim1;
bb -= bb_offset;
--w;
z_dim1 = *ldz;
z_offset = 1 + z_dim1;
z__ -= z_offset;
--work;
--iwork;
/* Function Body */
wantz = lsame_(jobz, "V");
upper = lsame_(uplo, "U");
lquery = *lwork == -1 || *liwork == -1;
*info = 0;
if (*n <= 1) {
liwmin = 1;
lwmin = 1;
} else if (wantz) {
liwmin = *n * 5 + 3;
/* Computing 2nd power */
i__1 = *n;
lwmin = *n * 5 + 1 + (i__1 * i__1 << 1);
} else {
liwmin = 1;
lwmin = *n << 1;
}
if (! (wantz || lsame_(jobz, "N"))) {
*info = -1;
} else if (! (upper || lsame_(uplo, "L"))) {
*info = -2;
} else if (*n < 0) {
*info = -3;
} else if (*ka < 0) {
*info = -4;
} else if (*kb < 0 || *kb > *ka) {
*info = -5;
} else if (*ldab < *ka + 1) {
*info = -7;
} else if (*ldbb < *kb + 1) {
*info = -9;
} else if (*ldz < 1 || wantz && *ldz < *n) {
*info = -12;
}
if (*info == 0) {
work[1] = (float) lwmin;
iwork[1] = liwmin;
if (*lwork < lwmin && ! lquery) {
*info = -14;
} else if (*liwork < liwmin && ! lquery) {
*info = -16;
}
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("SSBGVD", &i__1);
return 0;
} else if (lquery) {
return 0;
}
/* Quick return if possible */
if (*n == 0) {
return 0;
}
/* Form a split Cholesky factorization of B. */
spbstf_(uplo, n, kb, &bb[bb_offset], ldbb, info);
if (*info != 0) {
*info = *n + *info;
return 0;
}
/* Transform problem to standard eigenvalue problem. */
inde = 1;
indwrk = inde + *n;
indwk2 = indwrk + *n * *n;
llwrk2 = *lwork - indwk2 + 1;
ssbgst_(jobz, uplo, n, ka, kb, &ab[ab_offset], ldab, &bb[bb_offset], ldbb,
&z__[z_offset], ldz, &work[indwrk], &iinfo)
;
/* Reduce to tridiagonal form. */
if (wantz) {
*(unsigned char *)vect = 'U';
} else {
*(unsigned char *)vect = 'N';
}
ssbtrd_(vect, uplo, n, ka, &ab[ab_offset], ldab, &w[1], &work[inde], &z__[
z_offset], ldz, &work[indwrk], &iinfo);
/* For eigenvalues only, call SSTERF. For eigenvectors, call SSTEDC. */
if (! wantz) {
ssterf_(n, &w[1], &work[inde], info);
} else {
sstedc_("I", n, &w[1], &work[inde], &work[indwrk], n, &work[indwk2], &
llwrk2, &iwork[1], liwork, info);
sgemm_("N", "N", n, n, n, &c_b12, &z__[z_offset], ldz, &work[indwrk],
n, &c_b13, &work[indwk2], n);
slacpy_("A", n, n, &work[indwk2], n, &z__[z_offset], ldz);
}
work[1] = (float) lwmin;
iwork[1] = liwmin;
return 0;
/* End of SSBGVD */
} /* ssbgvd_ */
/* Subroutine */ int sgtsvx_(char *fact, char *trans, integer *n, integer *
nrhs, real *dl, real *d__, real *du, real *dlf, real *df, real *duf,
real *du2, integer *ipiv, real *b, integer *ldb, real *x, integer *
ldx, real *rcond, real *ferr, real *berr, real *work, integer *iwork,
integer *info)
{
/* -- 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
Purpose
=======
SGTSVX uses the LU factorization to compute the solution to a real
system of linear equations A * X = B or A**T * X = B,
where A is a tridiagonal matrix of order N and X and B are N-by-NRHS
matrices.
Error bounds on the solution and a condition estimate are also
provided.
Description
===========
The following steps are performed:
1. If FACT = 'N', the LU decomposition is used to factor the matrix A
as A = L * U, where L is a product of permutation and unit lower
bidiagonal matrices and U is upper triangular with nonzeros in
only the main diagonal and first two superdiagonals.
2. If some U(i,i)=0, so that U is exactly singular, then the routine
returns with INFO = i. Otherwise, the factored form of A is used
to estimate the condition number of the matrix A. If the
reciprocal of the condition number is less than machine precision,
INFO = N+1 is returned as a warning, but the routine still goes on
to solve for X and compute error bounds as described below.
3. The system of equations is solved for X using the factored form
of A.
4. Iterative refinement is applied to improve the computed solution
matrix and calculate error bounds and backward error estimates
for it.
Arguments
=========
FACT (input) CHARACTER*1
Specifies whether or not the factored form of A has been
supplied on entry.
= 'F': DLF, DF, DUF, DU2, and IPIV contain the factored
form of A; DL, D, DU, DLF, DF, DUF, DU2 and IPIV
will not be modified.
= 'N': The matrix will be copied to DLF, DF, and DUF
and factored.
TRANS (input) CHARACTER*1
Specifies the form of the system of equations:
= 'N': A * X = B (No transpose)
= 'T': A**T * X = B (Transpose)
= 'C': A**H * X = B (Conjugate transpose = Transpose)
N (input) INTEGER
The order of the matrix A. N >= 0.
NRHS (input) INTEGER
The number of right hand sides, i.e., the number of columns
of the matrix B. NRHS >= 0.
DL (input) REAL array, dimension (N-1)
The (n-1) subdiagonal elements of A.
D (input) REAL array, dimension (N)
The n diagonal elements of A.
DU (input) REAL array, dimension (N-1)
The (n-1) superdiagonal elements of A.
DLF (input or output) REAL array, dimension (N-1)
If FACT = 'F', then DLF is an input argument and on entry
contains the (n-1) multipliers that define the matrix L from
the LU factorization of A as computed by SGTTRF.
If FACT = 'N', then DLF is an output argument and on exit
contains the (n-1) multipliers that define the matrix L from
the LU factorization of A.
DF (input or output) REAL array, dimension (N)
If FACT = 'F', then DF is an input argument and on entry
contains the n diagonal elements of the upper triangular
matrix U from the LU factorization of A.
If FACT = 'N', then DF is an output argument and on exit
contains the n diagonal elements of the upper triangular
matrix U from the LU factorization of A.
DUF (input or output) REAL array, dimension (N-1)
If FACT = 'F', then DUF is an input argument and on entry
contains the (n-1) elements of the first superdiagonal of U.
If FACT = 'N', then DUF is an output argument and on exit
contains the (n-1) elements of the first superdiagonal of U.
DU2 (input or output) REAL array, dimension (N-2)
If FACT = 'F', then DU2 is an input argument and on entry
contains the (n-2) elements of the second superdiagonal of
U.
If FACT = 'N', then DU2 is an output argument and on exit
contains the (n-2) elements of the second superdiagonal of
U.
IPIV (input or output) INTEGER array, dimension (N)
If FACT = 'F', then IPIV is an input argument and on entry
contains the pivot indices from the LU factorization of A as
computed by SGTTRF.
If FACT = 'N', then IPIV is an output argument and on exit
contains the pivot indices from the LU factorization of A;
row i of the matrix was interchanged with row IPIV(i).
IPIV(i) will always be either i or i+1; IPIV(i) = i indicates
a row interchange was not required.
B (input) REAL array, dimension (LDB,NRHS)
The N-by-NRHS right hand side matrix B.
LDB (input) INTEGER
The leading dimension of the array B. LDB >= max(1,N).
X (output) REAL array, dimension (LDX,NRHS)
If INFO = 0 or INFO = N+1, the N-by-NRHS solution matrix X.
LDX (input) INTEGER
The leading dimension of the array X. LDX >= max(1,N).
RCOND (output) REAL
The estimate of the reciprocal condition number of the matrix
A. If RCOND is less than the machine precision (in
particular, if RCOND = 0), the matrix is singular to working
precision. This condition is indicated by a return code of
INFO > 0.
FERR (output) REAL array, dimension (NRHS)
The estimated forward error bound for each solution vector
X(j) (the j-th column of the solution matrix X).
If XTRUE is the true solution corresponding to X(j), FERR(j)
is an estimated upper bound for the magnitude of the largest
element in (X(j) - XTRUE) divided by the magnitude of the
largest element in X(j). The estimate is as reliable as
the estimate for RCOND, and is almost always a slight
overestimate of the true error.
BERR (output) REAL array, dimension (NRHS)
The componentwise relative backward error of each solution
vector X(j) (i.e., the smallest relative change in
any element of A or B that makes X(j) an exact solution).
WORK (workspace) REAL array, dimension (3*N)
IWORK (workspace) INTEGER array, dimension (N)
INFO (output) INTEGER
= 0: successful exit
< 0: if INFO = -i, the i-th argument had an illegal value
> 0: if INFO = i, and i is
<= N: U(i,i) is exactly zero. The factorization
has not been completed unless i = N, but the
factor U is exactly singular, so the solution
and error bounds could not be computed.
RCOND = 0 is returned.
= N+1: U is nonsingular, but RCOND is less than machine
precision, meaning that the matrix is singular
to working precision. Nevertheless, the
solution and error bounds are computed because
there are a number of situations where the
computed solution can be more accurate than the
value of RCOND would suggest.
=====================================================================
Parameter adjustments */
/* Table of constant values */
static integer c__1 = 1;
/* System generated locals */
integer b_dim1, b_offset, x_dim1, x_offset, i__1;
/* Local variables */
static char norm[1];
extern logical lsame_(char *, char *);
static real anorm;
extern /* Subroutine */ int scopy_(integer *, real *, integer *, real *,
integer *);
extern doublereal slamch_(char *);
static logical nofact;
extern /* Subroutine */ int xerbla_(char *, integer *);
extern doublereal slangt_(char *, integer *, real *, real *, real *);
extern /* Subroutine */ int slacpy_(char *, integer *, integer *, real *,
integer *, real *, integer *), sgtcon_(char *, integer *,
real *, real *, real *, real *, integer *, real *, real *, real *,
integer *, integer *);
static logical notran;
extern /* Subroutine */ int sgtrfs_(char *, integer *, integer *, real *,
real *, real *, real *, real *, real *, real *, integer *, real *,
integer *, real *, integer *, real *, real *, real *, integer *,
integer *), sgttrf_(integer *, real *, real *, real *,
real *, integer *, integer *), sgttrs_(char *, integer *, integer
*, real *, real *, real *, real *, integer *, real *, integer *,
integer *);
--dl;
--d__;
--du;
--dlf;
--df;
--duf;
--du2;
--ipiv;
b_dim1 = *ldb;
b_offset = 1 + b_dim1 * 1;
b -= b_offset;
x_dim1 = *ldx;
x_offset = 1 + x_dim1 * 1;
x -= x_offset;
--ferr;
--berr;
--work;
--iwork;
/* Function Body */
*info = 0;
nofact = lsame_(fact, "N");
notran = lsame_(trans, "N");
if (! nofact && ! lsame_(fact, "F")) {
*info = -1;
} else if (! notran && ! lsame_(trans, "T") && !
lsame_(trans, "C")) {
*info = -2;
} else if (*n < 0) {
*info = -3;
} else if (*nrhs < 0) {
*info = -4;
} else if (*ldb < max(1,*n)) {
*info = -14;
} else if (*ldx < max(1,*n)) {
*info = -16;
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("SGTSVX", &i__1);
return 0;
}
if (nofact) {
/* Compute the LU factorization of A. */
scopy_(n, &d__[1], &c__1, &df[1], &c__1);
if (*n > 1) {
i__1 = *n - 1;
scopy_(&i__1, &dl[1], &c__1, &dlf[1], &c__1);
i__1 = *n - 1;
scopy_(&i__1, &du[1], &c__1, &duf[1], &c__1);
}
sgttrf_(n, &dlf[1], &df[1], &duf[1], &du2[1], &ipiv[1], info);
/* Return if INFO is non-zero. */
if (*info != 0) {
if (*info > 0) {
*rcond = 0.f;
}
return 0;
}
}
/* Compute the norm of the matrix A. */
if (notran) {
*(unsigned char *)norm = '1';
} else {
*(unsigned char *)norm = 'I';
}
anorm = slangt_(norm, n, &dl[1], &d__[1], &du[1]);
/* Compute the reciprocal of the condition number of A. */
sgtcon_(norm, n, &dlf[1], &df[1], &duf[1], &du2[1], &ipiv[1], &anorm,
rcond, &work[1], &iwork[1], info);
/* Set INFO = N+1 if the matrix is singular to working precision. */
if (*rcond < slamch_("Epsilon")) {
*info = *n + 1;
}
/* Compute the solution vectors X. */
slacpy_("Full", n, nrhs, &b[b_offset], ldb, &x[x_offset], ldx);
sgttrs_(trans, n, nrhs, &dlf[1], &df[1], &duf[1], &du2[1], &ipiv[1], &x[
x_offset], ldx, info);
/* Use iterative refinement to improve the computed solutions and
compute error bounds and backward error estimates for them. */
sgtrfs_(trans, n, nrhs, &dl[1], &d__[1], &du[1], &dlf[1], &df[1], &duf[1],
&du2[1], &ipiv[1], &b[b_offset], ldb, &x[x_offset], ldx, &ferr[1]
, &berr[1], &work[1], &iwork[1], info);
return 0;
/* End of SGTSVX */
} /* sgtsvx_ */
int slaqr5_(int *wantt, int *wantz, int *kacc22,
int *n, int *ktop, int *kbot, int *nshfts, float *sr,
float *si, float *h__, int *ldh, int *iloz, int *ihiz, float
*z__, int *ldz, float *v, int *ldv, float *u, int *ldu,
int *nv, float *wv, int *ldwv, int *nh, float *wh, int *
ldwh)
{
/* System generated locals */
int h_dim1, h_offset, u_dim1, u_offset, v_dim1, v_offset, wh_dim1,
wh_offset, wv_dim1, wv_offset, z_dim1, z_offset, i__1, i__2, i__3,
i__4, i__5, i__6, i__7;
float r__1, r__2, r__3, r__4, r__5;
/* Local variables */
int i__, j, k, m, i2, j2, i4, j4, k1;
float h11, h12, h21, h22;
int m22, ns, nu;
float vt[3], scl;
int kdu, kms;
float ulp;
int knz, kzs;
float tst1, tst2, beta;
int blk22, bmp22;
int mend, jcol, jlen, jbot, mbot;
float swap;
int jtop, jrow, mtop;
float alpha;
int accum;
int ndcol, incol;
extern int sgemm_(char *, char *, int *, int *,
int *, float *, float *, int *, float *, int *, float *,
float *, int *);
int krcol, nbmps;
extern int strmm_(char *, char *, char *, char *,
int *, int *, float *, float *, int *, float *, int *
), slaqr1_(int *, float *,
int *, float *, float *, float *, float *, float *), slabad_(float *
, float *);
extern double slamch_(char *);
float safmin;
extern int slarfg_(int *, float *, float *, int *,
float *);
float safmax;
extern int slacpy_(char *, int *, int *, float *,
int *, float *, int *), slaset_(char *, int *,
int *, float *, float *, float *, int *);
float refsum;
int mstart;
float smlnum;
/* -- LAPACK auxiliary routine (version 3.2) -- */
/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/* November 2006 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* This auxiliary subroutine called by SLAQR0 performs a */
/* single small-bulge multi-shift QR sweep. */
/* WANTT (input) int scalar */
/* WANTT = .true. if the quasi-triangular Schur factor */
/* is being computed. WANTT is set to .false. otherwise. */
/* WANTZ (input) int scalar */
/* WANTZ = .true. if the orthogonal Schur factor is being */
/* computed. WANTZ is set to .false. otherwise. */
/* KACC22 (input) int with value 0, 1, or 2. */
/* Specifies the computation mode of far-from-diagonal */
/* orthogonal updates. */
/* = 0: SLAQR5 does not accumulate reflections and does not */
/* use matrix-matrix multiply to update far-from-diagonal */
/* matrix entries. */
/* = 1: SLAQR5 accumulates reflections and uses matrix-matrix */
/* multiply to update the far-from-diagonal matrix entries. */
/* = 2: SLAQR5 accumulates reflections, uses matrix-matrix */
/* multiply to update the far-from-diagonal matrix entries, */
/* and takes advantage of 2-by-2 block structure during */
/* matrix multiplies. */
/* N (input) int scalar */
/* N is the order of the Hessenberg matrix H upon which this */
/* subroutine operates. */
/* KTOP (input) int scalar */
/* KBOT (input) int scalar */
/* These are the first and last rows and columns of an */
/* isolated diagonal block upon which the QR sweep is to be */
/* applied. It is assumed without a check that */
/* either KTOP = 1 or H(KTOP,KTOP-1) = 0 */
/* and */
/* either KBOT = N or H(KBOT+1,KBOT) = 0. */
/* NSHFTS (input) int scalar */
/* NSHFTS gives the number of simultaneous shifts. NSHFTS */
/* must be positive and even. */
/* SR (input/output) REAL array of size (NSHFTS) */
/* SI (input/output) REAL array of size (NSHFTS) */
/* SR contains the float parts and SI contains the imaginary */
/* parts of the NSHFTS shifts of origin that define the */
/* multi-shift QR sweep. On output SR and SI may be */
/* reordered. */
/* H (input/output) REAL array of size (LDH,N) */
/* On input H contains a Hessenberg matrix. On output a */
/* multi-shift QR sweep with shifts SR(J)+i*SI(J) is applied */
/* to the isolated diagonal block in rows and columns KTOP */
/* through KBOT. */
/* LDH (input) int scalar */
/* LDH is the leading dimension of H just as declared in the */
/* calling procedure. LDH.GE.MAX(1,N). */
/* ILOZ (input) INTEGER */
/* IHIZ (input) INTEGER */
/* Specify the rows of Z to which transformations must be */
/* applied if WANTZ is .TRUE.. 1 .LE. ILOZ .LE. IHIZ .LE. N */
/* Z (input/output) REAL array of size (LDZ,IHI) */
/* If WANTZ = .TRUE., then the QR Sweep orthogonal */
/* similarity transformation is accumulated into */
/* Z(ILOZ:IHIZ,ILO:IHI) from the right. */
/* If WANTZ = .FALSE., then Z is unreferenced. */
/* LDZ (input) int scalar */
/* LDA is the leading dimension of Z just as declared in */
/* the calling procedure. LDZ.GE.N. */
/* V (workspace) REAL array of size (LDV,NSHFTS/2) */
/* LDV (input) int scalar */
/* LDV is the leading dimension of V as declared in the */
/* calling procedure. LDV.GE.3. */
/* U (workspace) REAL array of size */
/* (LDU,3*NSHFTS-3) */
/* LDU (input) int scalar */
/* LDU is the leading dimension of U just as declared in the */
/* in the calling subroutine. LDU.GE.3*NSHFTS-3. */
/* NH (input) int scalar */
/* NH is the number of columns in array WH available for */
/* workspace. NH.GE.1. */
/* WH (workspace) REAL array of size (LDWH,NH) */
/* LDWH (input) int scalar */
/* Leading dimension of WH just as declared in the */
/* calling procedure. LDWH.GE.3*NSHFTS-3. */
/* NV (input) int scalar */
/* NV is the number of rows in WV agailable for workspace. */
/* NV.GE.1. */
/* WV (workspace) REAL array of size */
/* (LDWV,3*NSHFTS-3) */
/* LDWV (input) int scalar */
/* LDWV is the leading dimension of WV as declared in the */
/* in the calling subroutine. LDWV.GE.NV. */
/* ================================================================ */
/* Based on contributions by */
/* Karen Braman and Ralph Byers, Department of Mathematics, */
/* University of Kansas, USA */
/* ================================================================ */
/* Reference: */
/* K. Braman, R. Byers and R. Mathias, The Multi-Shift QR */
/* Algorithm Part I: Maintaining Well Focused Shifts, and */
/* Level 3 Performance, SIAM Journal of Matrix Analysis, */
/* volume 23, pages 929--947, 2002. */
/* ================================================================ */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Local Arrays .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Executable Statements .. */
/* ==== If there are no shifts, then there is nothing to do. ==== */
/* Parameter adjustments */
--sr;
--si;
h_dim1 = *ldh;
h_offset = 1 + h_dim1;
h__ -= h_offset;
z_dim1 = *ldz;
z_offset = 1 + z_dim1;
z__ -= z_offset;
v_dim1 = *ldv;
v_offset = 1 + v_dim1;
v -= v_offset;
u_dim1 = *ldu;
u_offset = 1 + u_dim1;
u -= u_offset;
wv_dim1 = *ldwv;
wv_offset = 1 + wv_dim1;
wv -= wv_offset;
wh_dim1 = *ldwh;
wh_offset = 1 + wh_dim1;
wh -= wh_offset;
/* Function Body */
if (*nshfts < 2) {
return 0;
}
/* ==== If the active block is empty or 1-by-1, then there */
/* . is nothing to do. ==== */
if (*ktop >= *kbot) {
return 0;
}
/* ==== Shuffle shifts into pairs of float shifts and pairs */
/* . of complex conjugate shifts assuming complex */
/* . conjugate shifts are already adjacent to one */
/* . another. ==== */
i__1 = *nshfts - 2;
for (i__ = 1; i__ <= i__1; i__ += 2) {
if (si[i__] != -si[i__ + 1]) {
swap = sr[i__];
sr[i__] = sr[i__ + 1];
sr[i__ + 1] = sr[i__ + 2];
sr[i__ + 2] = swap;
swap = si[i__];
si[i__] = si[i__ + 1];
si[i__ + 1] = si[i__ + 2];
si[i__ + 2] = swap;
}
/* L10: */
}
/* ==== NSHFTS is supposed to be even, but if it is odd, */
/* . then simply reduce it by one. The shuffle above */
/* . ensures that the dropped shift is float and that */
/* . the remaining shifts are paired. ==== */
ns = *nshfts - *nshfts % 2;
/* ==== Machine constants for deflation ==== */
safmin = slamch_("SAFE MINIMUM");
safmax = 1.f / safmin;
slabad_(&safmin, &safmax);
ulp = slamch_("PRECISION");
smlnum = safmin * ((float) (*n) / ulp);
/* ==== Use accumulated reflections to update far-from-diagonal */
/* . entries ? ==== */
accum = *kacc22 == 1 || *kacc22 == 2;
/* ==== If so, exploit the 2-by-2 block structure? ==== */
blk22 = ns > 2 && *kacc22 == 2;
/* ==== clear trash ==== */
if (*ktop + 2 <= *kbot) {
h__[*ktop + 2 + *ktop * h_dim1] = 0.f;
}
/* ==== NBMPS = number of 2-shift bulges in the chain ==== */
nbmps = ns / 2;
/* ==== KDU = width of slab ==== */
kdu = nbmps * 6 - 3;
/* ==== Create and chase chains of NBMPS bulges ==== */
i__1 = *kbot - 2;
i__2 = nbmps * 3 - 2;
for (incol = (1 - nbmps) * 3 + *ktop - 1; i__2 < 0 ? incol >= i__1 :
incol <= i__1; incol += i__2) {
ndcol = incol + kdu;
if (accum) {
slaset_("ALL", &kdu, &kdu, &c_b7, &c_b8, &u[u_offset], ldu);
}
/* ==== Near-the-diagonal bulge chase. The following loop */
/* . performs the near-the-diagonal part of a small bulge */
/* . multi-shift QR sweep. Each 6*NBMPS-2 column diagonal */
/* . chunk extends from column INCOL to column NDCOL */
/* . (including both column INCOL and column NDCOL). The */
/* . following loop chases a 3*NBMPS column long chain of */
/* . NBMPS bulges 3*NBMPS-2 columns to the right. (INCOL */
/* . may be less than KTOP and and NDCOL may be greater than */
/* . KBOT indicating phantom columns from which to chase */
/* . bulges before they are actually introduced or to which */
/* . to chase bulges beyond column KBOT.) ==== */
/* Computing MIN */
i__4 = incol + nbmps * 3 - 3, i__5 = *kbot - 2;
i__3 = MIN(i__4,i__5);
for (krcol = incol; krcol <= i__3; ++krcol) {
/* ==== Bulges number MTOP to MBOT are active double implicit */
/* . shift bulges. There may or may not also be small */
/* . 2-by-2 bulge, if there is room. The inactive bulges */
/* . (if any) must wait until the active bulges have moved */
/* . down the diagonal to make room. The phantom matrix */
/* . paradigm described above helps keep track. ==== */
/* Computing MAX */
i__4 = 1, i__5 = (*ktop - 1 - krcol + 2) / 3 + 1;
mtop = MAX(i__4,i__5);
/* Computing MIN */
i__4 = nbmps, i__5 = (*kbot - krcol) / 3;
mbot = MIN(i__4,i__5);
m22 = mbot + 1;
bmp22 = mbot < nbmps && krcol + (m22 - 1) * 3 == *kbot - 2;
/* ==== Generate reflections to chase the chain right */
/* . one column. (The minimum value of K is KTOP-1.) ==== */
i__4 = mbot;
for (m = mtop; m <= i__4; ++m) {
k = krcol + (m - 1) * 3;
if (k == *ktop - 1) {
slaqr1_(&c__3, &h__[*ktop + *ktop * h_dim1], ldh, &sr[(m
<< 1) - 1], &si[(m << 1) - 1], &sr[m * 2], &si[m *
2], &v[m * v_dim1 + 1]);
alpha = v[m * v_dim1 + 1];
slarfg_(&c__3, &alpha, &v[m * v_dim1 + 2], &c__1, &v[m *
v_dim1 + 1]);
} else {
beta = h__[k + 1 + k * h_dim1];
v[m * v_dim1 + 2] = h__[k + 2 + k * h_dim1];
v[m * v_dim1 + 3] = h__[k + 3 + k * h_dim1];
slarfg_(&c__3, &beta, &v[m * v_dim1 + 2], &c__1, &v[m *
v_dim1 + 1]);
/* ==== A Bulge may collapse because of vigilant */
/* . deflation or destructive underflow. In the */
/* . underflow case, try the two-small-subdiagonals */
/* . trick to try to reinflate the bulge. ==== */
if (h__[k + 3 + k * h_dim1] != 0.f || h__[k + 3 + (k + 1)
* h_dim1] != 0.f || h__[k + 3 + (k + 2) * h_dim1]
== 0.f) {
/* ==== Typical case: not collapsed (yet). ==== */
h__[k + 1 + k * h_dim1] = beta;
h__[k + 2 + k * h_dim1] = 0.f;
h__[k + 3 + k * h_dim1] = 0.f;
} else {
/* ==== Atypical case: collapsed. Attempt to */
/* . reintroduce ignoring H(K+1,K) and H(K+2,K). */
/* . If the fill resulting from the new */
/* . reflector is too large, then abandon it. */
/* . Otherwise, use the new one. ==== */
slaqr1_(&c__3, &h__[k + 1 + (k + 1) * h_dim1], ldh, &
sr[(m << 1) - 1], &si[(m << 1) - 1], &sr[m *
2], &si[m * 2], vt);
alpha = vt[0];
slarfg_(&c__3, &alpha, &vt[1], &c__1, vt);
refsum = vt[0] * (h__[k + 1 + k * h_dim1] + vt[1] *
h__[k + 2 + k * h_dim1]);
if ((r__1 = h__[k + 2 + k * h_dim1] - refsum * vt[1],
ABS(r__1)) + (r__2 = refsum * vt[2], ABS(
r__2)) > ulp * ((r__3 = h__[k + k * h_dim1],
ABS(r__3)) + (r__4 = h__[k + 1 + (k + 1) *
h_dim1], ABS(r__4)) + (r__5 = h__[k + 2 + (k
+ 2) * h_dim1], ABS(r__5)))) {
/* ==== Starting a new bulge here would */
/* . create non-negligible fill. Use */
/* . the old one with trepidation. ==== */
h__[k + 1 + k * h_dim1] = beta;
h__[k + 2 + k * h_dim1] = 0.f;
h__[k + 3 + k * h_dim1] = 0.f;
} else {
/* ==== Stating a new bulge here would */
/* . create only negligible fill. */
/* . Replace the old reflector with */
/* . the new one. ==== */
h__[k + 1 + k * h_dim1] -= refsum;
h__[k + 2 + k * h_dim1] = 0.f;
h__[k + 3 + k * h_dim1] = 0.f;
v[m * v_dim1 + 1] = vt[0];
v[m * v_dim1 + 2] = vt[1];
v[m * v_dim1 + 3] = vt[2];
}
}
}
/* L20: */
}
/* ==== Generate a 2-by-2 reflection, if needed. ==== */
k = krcol + (m22 - 1) * 3;
if (bmp22) {
if (k == *ktop - 1) {
slaqr1_(&c__2, &h__[k + 1 + (k + 1) * h_dim1], ldh, &sr[(
m22 << 1) - 1], &si[(m22 << 1) - 1], &sr[m22 * 2],
&si[m22 * 2], &v[m22 * v_dim1 + 1]);
beta = v[m22 * v_dim1 + 1];
slarfg_(&c__2, &beta, &v[m22 * v_dim1 + 2], &c__1, &v[m22
* v_dim1 + 1]);
} else {
beta = h__[k + 1 + k * h_dim1];
v[m22 * v_dim1 + 2] = h__[k + 2 + k * h_dim1];
slarfg_(&c__2, &beta, &v[m22 * v_dim1 + 2], &c__1, &v[m22
* v_dim1 + 1]);
h__[k + 1 + k * h_dim1] = beta;
h__[k + 2 + k * h_dim1] = 0.f;
}
}
/* ==== Multiply H by reflections from the left ==== */
if (accum) {
jbot = MIN(ndcol,*kbot);
} else if (*wantt) {
jbot = *n;
} else {
jbot = *kbot;
}
i__4 = jbot;
for (j = MAX(*ktop,krcol); j <= i__4; ++j) {
/* Computing MIN */
i__5 = mbot, i__6 = (j - krcol + 2) / 3;
mend = MIN(i__5,i__6);
i__5 = mend;
for (m = mtop; m <= i__5; ++m) {
k = krcol + (m - 1) * 3;
refsum = v[m * v_dim1 + 1] * (h__[k + 1 + j * h_dim1] + v[
m * v_dim1 + 2] * h__[k + 2 + j * h_dim1] + v[m *
v_dim1 + 3] * h__[k + 3 + j * h_dim1]);
h__[k + 1 + j * h_dim1] -= refsum;
h__[k + 2 + j * h_dim1] -= refsum * v[m * v_dim1 + 2];
h__[k + 3 + j * h_dim1] -= refsum * v[m * v_dim1 + 3];
/* L30: */
}
/* L40: */
}
if (bmp22) {
k = krcol + (m22 - 1) * 3;
/* Computing MAX */
i__4 = k + 1;
i__5 = jbot;
for (j = MAX(i__4,*ktop); j <= i__5; ++j) {
refsum = v[m22 * v_dim1 + 1] * (h__[k + 1 + j * h_dim1] +
v[m22 * v_dim1 + 2] * h__[k + 2 + j * h_dim1]);
h__[k + 1 + j * h_dim1] -= refsum;
h__[k + 2 + j * h_dim1] -= refsum * v[m22 * v_dim1 + 2];
/* L50: */
}
}
/* ==== Multiply H by reflections from the right. */
/* . Delay filling in the last row until the */
/* . vigilant deflation check is complete. ==== */
if (accum) {
jtop = MAX(*ktop,incol);
} else if (*wantt) {
jtop = 1;
} else {
jtop = *ktop;
}
i__5 = mbot;
for (m = mtop; m <= i__5; ++m) {
if (v[m * v_dim1 + 1] != 0.f) {
k = krcol + (m - 1) * 3;
/* Computing MIN */
i__6 = *kbot, i__7 = k + 3;
i__4 = MIN(i__6,i__7);
for (j = jtop; j <= i__4; ++j) {
refsum = v[m * v_dim1 + 1] * (h__[j + (k + 1) *
h_dim1] + v[m * v_dim1 + 2] * h__[j + (k + 2)
* h_dim1] + v[m * v_dim1 + 3] * h__[j + (k +
3) * h_dim1]);
h__[j + (k + 1) * h_dim1] -= refsum;
h__[j + (k + 2) * h_dim1] -= refsum * v[m * v_dim1 +
2];
h__[j + (k + 3) * h_dim1] -= refsum * v[m * v_dim1 +
3];
/* L60: */
}
if (accum) {
/* ==== Accumulate U. (If necessary, update Z later */
/* . with with an efficient matrix-matrix */
/* . multiply.) ==== */
kms = k - incol;
/* Computing MAX */
i__4 = 1, i__6 = *ktop - incol;
i__7 = kdu;
for (j = MAX(i__4,i__6); j <= i__7; ++j) {
refsum = v[m * v_dim1 + 1] * (u[j + (kms + 1) *
u_dim1] + v[m * v_dim1 + 2] * u[j + (kms
+ 2) * u_dim1] + v[m * v_dim1 + 3] * u[j
+ (kms + 3) * u_dim1]);
u[j + (kms + 1) * u_dim1] -= refsum;
u[j + (kms + 2) * u_dim1] -= refsum * v[m *
v_dim1 + 2];
u[j + (kms + 3) * u_dim1] -= refsum * v[m *
v_dim1 + 3];
/* L70: */
}
} else if (*wantz) {
/* ==== U is not accumulated, so update Z */
/* . now by multiplying by reflections */
/* . from the right. ==== */
i__7 = *ihiz;
for (j = *iloz; j <= i__7; ++j) {
refsum = v[m * v_dim1 + 1] * (z__[j + (k + 1) *
z_dim1] + v[m * v_dim1 + 2] * z__[j + (k
+ 2) * z_dim1] + v[m * v_dim1 + 3] * z__[
j + (k + 3) * z_dim1]);
z__[j + (k + 1) * z_dim1] -= refsum;
z__[j + (k + 2) * z_dim1] -= refsum * v[m *
v_dim1 + 2];
z__[j + (k + 3) * z_dim1] -= refsum * v[m *
v_dim1 + 3];
/* L80: */
}
}
}
/* L90: */
}
/* ==== Special case: 2-by-2 reflection (if needed) ==== */
k = krcol + (m22 - 1) * 3;
if (bmp22 && v[m22 * v_dim1 + 1] != 0.f) {
/* Computing MIN */
i__7 = *kbot, i__4 = k + 3;
i__5 = MIN(i__7,i__4);
for (j = jtop; j <= i__5; ++j) {
refsum = v[m22 * v_dim1 + 1] * (h__[j + (k + 1) * h_dim1]
+ v[m22 * v_dim1 + 2] * h__[j + (k + 2) * h_dim1])
;
h__[j + (k + 1) * h_dim1] -= refsum;
h__[j + (k + 2) * h_dim1] -= refsum * v[m22 * v_dim1 + 2];
/* L100: */
}
if (accum) {
kms = k - incol;
/* Computing MAX */
i__5 = 1, i__7 = *ktop - incol;
i__4 = kdu;
for (j = MAX(i__5,i__7); j <= i__4; ++j) {
refsum = v[m22 * v_dim1 + 1] * (u[j + (kms + 1) *
u_dim1] + v[m22 * v_dim1 + 2] * u[j + (kms +
2) * u_dim1]);
u[j + (kms + 1) * u_dim1] -= refsum;
u[j + (kms + 2) * u_dim1] -= refsum * v[m22 * v_dim1
+ 2];
/* L110: */
}
} else if (*wantz) {
i__4 = *ihiz;
for (j = *iloz; j <= i__4; ++j) {
refsum = v[m22 * v_dim1 + 1] * (z__[j + (k + 1) *
z_dim1] + v[m22 * v_dim1 + 2] * z__[j + (k +
2) * z_dim1]);
z__[j + (k + 1) * z_dim1] -= refsum;
z__[j + (k + 2) * z_dim1] -= refsum * v[m22 * v_dim1
+ 2];
/* L120: */
}
}
}
/* ==== Vigilant deflation check ==== */
mstart = mtop;
if (krcol + (mstart - 1) * 3 < *ktop) {
++mstart;
}
mend = mbot;
if (bmp22) {
++mend;
}
if (krcol == *kbot - 2) {
++mend;
}
i__4 = mend;
for (m = mstart; m <= i__4; ++m) {
/* Computing MIN */
i__5 = *kbot - 1, i__7 = krcol + (m - 1) * 3;
k = MIN(i__5,i__7);
/* ==== The following convergence test requires that */
/* . the tradition small-compared-to-nearby-diagonals */
/* . criterion and the Ahues & Tisseur (LAWN 122, 1997) */
/* . criteria both be satisfied. The latter improves */
/* . accuracy in some examples. Falling back on an */
/* . alternate convergence criterion when TST1 or TST2 */
/* . is zero (as done here) is traditional but probably */
/* . unnecessary. ==== */
if (h__[k + 1 + k * h_dim1] != 0.f) {
tst1 = (r__1 = h__[k + k * h_dim1], ABS(r__1)) + (r__2 =
h__[k + 1 + (k + 1) * h_dim1], ABS(r__2));
if (tst1 == 0.f) {
if (k >= *ktop + 1) {
tst1 += (r__1 = h__[k + (k - 1) * h_dim1], ABS(
r__1));
}
if (k >= *ktop + 2) {
tst1 += (r__1 = h__[k + (k - 2) * h_dim1], ABS(
r__1));
}
if (k >= *ktop + 3) {
tst1 += (r__1 = h__[k + (k - 3) * h_dim1], ABS(
r__1));
}
if (k <= *kbot - 2) {
tst1 += (r__1 = h__[k + 2 + (k + 1) * h_dim1],
ABS(r__1));
}
if (k <= *kbot - 3) {
tst1 += (r__1 = h__[k + 3 + (k + 1) * h_dim1],
ABS(r__1));
}
if (k <= *kbot - 4) {
tst1 += (r__1 = h__[k + 4 + (k + 1) * h_dim1],
ABS(r__1));
}
}
/* Computing MAX */
r__2 = smlnum, r__3 = ulp * tst1;
if ((r__1 = h__[k + 1 + k * h_dim1], ABS(r__1)) <= MAX(
r__2,r__3)) {
/* Computing MAX */
r__3 = (r__1 = h__[k + 1 + k * h_dim1], ABS(r__1)),
r__4 = (r__2 = h__[k + (k + 1) * h_dim1],
ABS(r__2));
h12 = MAX(r__3,r__4);
/* Computing MIN */
r__3 = (r__1 = h__[k + 1 + k * h_dim1], ABS(r__1)),
r__4 = (r__2 = h__[k + (k + 1) * h_dim1],
ABS(r__2));
h21 = MIN(r__3,r__4);
/* Computing MAX */
r__3 = (r__1 = h__[k + 1 + (k + 1) * h_dim1], ABS(
r__1)), r__4 = (r__2 = h__[k + k * h_dim1] -
h__[k + 1 + (k + 1) * h_dim1], ABS(r__2));
h11 = MAX(r__3,r__4);
/* Computing MIN */
r__3 = (r__1 = h__[k + 1 + (k + 1) * h_dim1], ABS(
r__1)), r__4 = (r__2 = h__[k + k * h_dim1] -
h__[k + 1 + (k + 1) * h_dim1], ABS(r__2));
h22 = MIN(r__3,r__4);
scl = h11 + h12;
tst2 = h22 * (h11 / scl);
/* Computing MAX */
r__1 = smlnum, r__2 = ulp * tst2;
if (tst2 == 0.f || h21 * (h12 / scl) <= MAX(r__1,
r__2)) {
h__[k + 1 + k * h_dim1] = 0.f;
}
}
}
/* L130: */
}
/* ==== Fill in the last row of each bulge. ==== */
/* Computing MIN */
i__4 = nbmps, i__5 = (*kbot - krcol - 1) / 3;
mend = MIN(i__4,i__5);
i__4 = mend;
for (m = mtop; m <= i__4; ++m) {
k = krcol + (m - 1) * 3;
refsum = v[m * v_dim1 + 1] * v[m * v_dim1 + 3] * h__[k + 4 + (
k + 3) * h_dim1];
h__[k + 4 + (k + 1) * h_dim1] = -refsum;
h__[k + 4 + (k + 2) * h_dim1] = -refsum * v[m * v_dim1 + 2];
h__[k + 4 + (k + 3) * h_dim1] -= refsum * v[m * v_dim1 + 3];
/* L140: */
}
/* ==== End of near-the-diagonal bulge chase. ==== */
/* L150: */
}
/* ==== Use U (if accumulated) to update far-from-diagonal */
/* . entries in H. If required, use U to update Z as */
/* . well. ==== */
if (accum) {
if (*wantt) {
jtop = 1;
jbot = *n;
} else {
jtop = *ktop;
jbot = *kbot;
}
if (! blk22 || incol < *ktop || ndcol > *kbot || ns <= 2) {
/* ==== Updates not exploiting the 2-by-2 block */
/* . structure of U. K1 and NU keep track of */
/* . the location and size of U in the special */
/* . cases of introducing bulges and chasing */
/* . bulges off the bottom. In these special */
/* . cases and in case the number of shifts */
/* . is NS = 2, there is no 2-by-2 block */
/* . structure to exploit. ==== */
/* Computing MAX */
i__3 = 1, i__4 = *ktop - incol;
k1 = MAX(i__3,i__4);
/* Computing MAX */
i__3 = 0, i__4 = ndcol - *kbot;
nu = kdu - MAX(i__3,i__4) - k1 + 1;
/* ==== Horizontal Multiply ==== */
i__3 = jbot;
i__4 = *nh;
for (jcol = MIN(ndcol,*kbot) + 1; i__4 < 0 ? jcol >= i__3 :
jcol <= i__3; jcol += i__4) {
/* Computing MIN */
i__5 = *nh, i__7 = jbot - jcol + 1;
jlen = MIN(i__5,i__7);
sgemm_("C", "N", &nu, &jlen, &nu, &c_b8, &u[k1 + k1 *
u_dim1], ldu, &h__[incol + k1 + jcol * h_dim1],
ldh, &c_b7, &wh[wh_offset], ldwh);
slacpy_("ALL", &nu, &jlen, &wh[wh_offset], ldwh, &h__[
incol + k1 + jcol * h_dim1], ldh);
/* L160: */
}
/* ==== Vertical multiply ==== */
i__4 = MAX(*ktop,incol) - 1;
i__3 = *nv;
for (jrow = jtop; i__3 < 0 ? jrow >= i__4 : jrow <= i__4;
jrow += i__3) {
/* Computing MIN */
i__5 = *nv, i__7 = MAX(*ktop,incol) - jrow;
jlen = MIN(i__5,i__7);
sgemm_("N", "N", &jlen, &nu, &nu, &c_b8, &h__[jrow + (
incol + k1) * h_dim1], ldh, &u[k1 + k1 * u_dim1],
ldu, &c_b7, &wv[wv_offset], ldwv);
slacpy_("ALL", &jlen, &nu, &wv[wv_offset], ldwv, &h__[
jrow + (incol + k1) * h_dim1], ldh);
/* L170: */
}
/* ==== Z multiply (also vertical) ==== */
if (*wantz) {
i__3 = *ihiz;
i__4 = *nv;
for (jrow = *iloz; i__4 < 0 ? jrow >= i__3 : jrow <= i__3;
jrow += i__4) {
/* Computing MIN */
i__5 = *nv, i__7 = *ihiz - jrow + 1;
jlen = MIN(i__5,i__7);
sgemm_("N", "N", &jlen, &nu, &nu, &c_b8, &z__[jrow + (
incol + k1) * z_dim1], ldz, &u[k1 + k1 *
u_dim1], ldu, &c_b7, &wv[wv_offset], ldwv);
slacpy_("ALL", &jlen, &nu, &wv[wv_offset], ldwv, &z__[
jrow + (incol + k1) * z_dim1], ldz)
;
/* L180: */
}
}
} else {
/* ==== Updates exploiting U's 2-by-2 block structure. */
/* . (I2, I4, J2, J4 are the last rows and columns */
/* . of the blocks.) ==== */
i2 = (kdu + 1) / 2;
i4 = kdu;
j2 = i4 - i2;
j4 = kdu;
/* ==== KZS and KNZ deal with the band of zeros */
/* . along the diagonal of one of the triangular */
/* . blocks. ==== */
kzs = j4 - j2 - (ns + 1);
knz = ns + 1;
/* ==== Horizontal multiply ==== */
i__4 = jbot;
i__3 = *nh;
for (jcol = MIN(ndcol,*kbot) + 1; i__3 < 0 ? jcol >= i__4 :
jcol <= i__4; jcol += i__3) {
/* Computing MIN */
i__5 = *nh, i__7 = jbot - jcol + 1;
jlen = MIN(i__5,i__7);
/* ==== Copy bottom of H to top+KZS of scratch ==== */
/* (The first KZS rows get multiplied by zero.) ==== */
slacpy_("ALL", &knz, &jlen, &h__[incol + 1 + j2 + jcol *
h_dim1], ldh, &wh[kzs + 1 + wh_dim1], ldwh);
/* ==== Multiply by U21' ==== */
slaset_("ALL", &kzs, &jlen, &c_b7, &c_b7, &wh[wh_offset],
ldwh);
strmm_("L", "U", "C", "N", &knz, &jlen, &c_b8, &u[j2 + 1
+ (kzs + 1) * u_dim1], ldu, &wh[kzs + 1 + wh_dim1]
, ldwh);
/* ==== Multiply top of H by U11' ==== */
sgemm_("C", "N", &i2, &jlen, &j2, &c_b8, &u[u_offset],
ldu, &h__[incol + 1 + jcol * h_dim1], ldh, &c_b8,
&wh[wh_offset], ldwh);
/* ==== Copy top of H to bottom of WH ==== */
slacpy_("ALL", &j2, &jlen, &h__[incol + 1 + jcol * h_dim1]
, ldh, &wh[i2 + 1 + wh_dim1], ldwh);
/* ==== Multiply by U21' ==== */
strmm_("L", "L", "C", "N", &j2, &jlen, &c_b8, &u[(i2 + 1)
* u_dim1 + 1], ldu, &wh[i2 + 1 + wh_dim1], ldwh);
/* ==== Multiply by U22 ==== */
i__5 = i4 - i2;
i__7 = j4 - j2;
sgemm_("C", "N", &i__5, &jlen, &i__7, &c_b8, &u[j2 + 1 + (
i2 + 1) * u_dim1], ldu, &h__[incol + 1 + j2 +
jcol * h_dim1], ldh, &c_b8, &wh[i2 + 1 + wh_dim1],
ldwh);
/* ==== Copy it back ==== */
slacpy_("ALL", &kdu, &jlen, &wh[wh_offset], ldwh, &h__[
incol + 1 + jcol * h_dim1], ldh);
/* L190: */
}
/* ==== Vertical multiply ==== */
i__3 = MAX(incol,*ktop) - 1;
i__4 = *nv;
for (jrow = jtop; i__4 < 0 ? jrow >= i__3 : jrow <= i__3;
jrow += i__4) {
/* Computing MIN */
i__5 = *nv, i__7 = MAX(incol,*ktop) - jrow;
jlen = MIN(i__5,i__7);
/* ==== Copy right of H to scratch (the first KZS */
/* . columns get multiplied by zero) ==== */
slacpy_("ALL", &jlen, &knz, &h__[jrow + (incol + 1 + j2) *
h_dim1], ldh, &wv[(kzs + 1) * wv_dim1 + 1], ldwv);
/* ==== Multiply by U21 ==== */
slaset_("ALL", &jlen, &kzs, &c_b7, &c_b7, &wv[wv_offset],
ldwv);
strmm_("R", "U", "N", "N", &jlen, &knz, &c_b8, &u[j2 + 1
+ (kzs + 1) * u_dim1], ldu, &wv[(kzs + 1) *
wv_dim1 + 1], ldwv);
/* ==== Multiply by U11 ==== */
sgemm_("N", "N", &jlen, &i2, &j2, &c_b8, &h__[jrow + (
incol + 1) * h_dim1], ldh, &u[u_offset], ldu, &
c_b8, &wv[wv_offset], ldwv);
/* ==== Copy left of H to right of scratch ==== */
slacpy_("ALL", &jlen, &j2, &h__[jrow + (incol + 1) *
h_dim1], ldh, &wv[(i2 + 1) * wv_dim1 + 1], ldwv);
/* ==== Multiply by U21 ==== */
i__5 = i4 - i2;
strmm_("R", "L", "N", "N", &jlen, &i__5, &c_b8, &u[(i2 +
1) * u_dim1 + 1], ldu, &wv[(i2 + 1) * wv_dim1 + 1]
, ldwv);
/* ==== Multiply by U22 ==== */
i__5 = i4 - i2;
i__7 = j4 - j2;
sgemm_("N", "N", &jlen, &i__5, &i__7, &c_b8, &h__[jrow + (
incol + 1 + j2) * h_dim1], ldh, &u[j2 + 1 + (i2 +
1) * u_dim1], ldu, &c_b8, &wv[(i2 + 1) * wv_dim1
+ 1], ldwv);
/* ==== Copy it back ==== */
slacpy_("ALL", &jlen, &kdu, &wv[wv_offset], ldwv, &h__[
jrow + (incol + 1) * h_dim1], ldh);
/* L200: */
}
/* ==== Multiply Z (also vertical) ==== */
if (*wantz) {
i__4 = *ihiz;
i__3 = *nv;
for (jrow = *iloz; i__3 < 0 ? jrow >= i__4 : jrow <= i__4;
jrow += i__3) {
/* Computing MIN */
i__5 = *nv, i__7 = *ihiz - jrow + 1;
jlen = MIN(i__5,i__7);
/* ==== Copy right of Z to left of scratch (first */
/* . KZS columns get multiplied by zero) ==== */
slacpy_("ALL", &jlen, &knz, &z__[jrow + (incol + 1 +
j2) * z_dim1], ldz, &wv[(kzs + 1) * wv_dim1 +
1], ldwv);
/* ==== Multiply by U12 ==== */
slaset_("ALL", &jlen, &kzs, &c_b7, &c_b7, &wv[
wv_offset], ldwv);
strmm_("R", "U", "N", "N", &jlen, &knz, &c_b8, &u[j2
+ 1 + (kzs + 1) * u_dim1], ldu, &wv[(kzs + 1)
* wv_dim1 + 1], ldwv);
/* ==== Multiply by U11 ==== */
sgemm_("N", "N", &jlen, &i2, &j2, &c_b8, &z__[jrow + (
incol + 1) * z_dim1], ldz, &u[u_offset], ldu,
&c_b8, &wv[wv_offset], ldwv);
/* ==== Copy left of Z to right of scratch ==== */
slacpy_("ALL", &jlen, &j2, &z__[jrow + (incol + 1) *
z_dim1], ldz, &wv[(i2 + 1) * wv_dim1 + 1],
ldwv);
/* ==== Multiply by U21 ==== */
i__5 = i4 - i2;
strmm_("R", "L", "N", "N", &jlen, &i__5, &c_b8, &u[(
i2 + 1) * u_dim1 + 1], ldu, &wv[(i2 + 1) *
wv_dim1 + 1], ldwv);
/* ==== Multiply by U22 ==== */
i__5 = i4 - i2;
i__7 = j4 - j2;
sgemm_("N", "N", &jlen, &i__5, &i__7, &c_b8, &z__[
jrow + (incol + 1 + j2) * z_dim1], ldz, &u[j2
+ 1 + (i2 + 1) * u_dim1], ldu, &c_b8, &wv[(i2
+ 1) * wv_dim1 + 1], ldwv);
/* ==== Copy the result back to Z ==== */
slacpy_("ALL", &jlen, &kdu, &wv[wv_offset], ldwv, &
z__[jrow + (incol + 1) * z_dim1], ldz);
/* L210: */
}
}
}
}
/* L220: */
}
/* ==== End of SLAQR5 ==== */
return 0;
} /* slaqr5_ */
/* Subroutine */
int sggevx_(char *balanc, char *jobvl, char *jobvr, char * sense, integer *n, real *a, integer *lda, real *b, integer *ldb, real *alphar, real *alphai, real *beta, real *vl, integer *ldvl, real *vr, integer *ldvr, integer *ilo, integer *ihi, real *lscale, real *rscale, real *abnrm, real *bbnrm, real *rconde, real *rcondv, real *work, integer *lwork, integer *iwork, logical *bwork, integer *info)
{
/* System generated locals */
integer a_dim1, a_offset, b_dim1, b_offset, vl_dim1, vl_offset, vr_dim1, vr_offset, i__1, i__2;
real r__1, r__2, r__3, r__4;
/* Builtin functions */
double sqrt(doublereal);
/* Local variables */
integer i__, j, m, jc, in, mm, jr;
real eps;
logical ilv, pair;
real anrm, bnrm;
integer ierr, itau;
real temp;
logical ilvl, ilvr;
integer iwrk, iwrk1;
extern logical lsame_(char *, char *);
integer icols;
logical noscl;
integer irows;
extern /* Subroutine */
int slabad_(real *, real *), sggbak_(char *, char *, integer *, integer *, integer *, real *, real *, integer *, real *, integer *, integer *), sggbal_(char *, integer *, real *, integer *, real *, integer *, integer *, integer *, real *, real *, real *, integer *);
logical ilascl, ilbscl;
extern real slamch_(char *);
extern /* Subroutine */
int xerbla_(char *, integer *), sgghrd_( char *, char *, integer *, integer *, integer *, real *, integer * , real *, integer *, real *, integer *, real *, integer *, integer *);
logical ldumma[1];
char chtemp[1];
real bignum;
extern /* Subroutine */
int slascl_(char *, integer *, integer *, real *, real *, integer *, integer *, real *, integer *, integer *);
extern integer ilaenv_(integer *, char *, char *, integer *, integer *, integer *, integer *);
extern real slange_(char *, integer *, integer *, real *, integer *, real *);
integer ijobvl;
extern /* Subroutine */
int sgeqrf_(integer *, integer *, real *, integer *, real *, real *, integer *, integer *);
integer ijobvr;
extern /* Subroutine */
int slacpy_(char *, integer *, integer *, real *, integer *, real *, integer *);
logical wantsb;
extern /* Subroutine */
int slaset_(char *, integer *, integer *, real *, real *, real *, integer *);
real anrmto;
logical wantse;
real bnrmto;
extern /* Subroutine */
int shgeqz_(char *, char *, char *, integer *, integer *, integer *, real *, integer *, real *, integer *, real * , real *, real *, real *, integer *, real *, integer *, real *, integer *, integer *), stgevc_(char *, char *, logical *, integer *, real *, integer *, real *, integer * , real *, integer *, real *, integer *, integer *, integer *, real *, integer *), stgsna_(char *, char *, logical *, integer *, real *, integer *, real *, integer *, real * , integer *, real *, integer *, real *, real *, integer *, integer *, real *, integer *, integer *, integer *);
integer minwrk, maxwrk;
logical wantsn;
real smlnum;
extern /* Subroutine */
int sorgqr_(integer *, integer *, integer *, real *, integer *, real *, real *, integer *, integer *);
logical lquery, wantsv;
extern /* Subroutine */
int sormqr_(char *, char *, integer *, integer *, integer *, real *, integer *, real *, real *, integer *, real *, integer *, integer *);
/* -- LAPACK driver routine (version 3.4.1) -- */
/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */
/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */
/* April 2012 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. Local Arrays .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Executable Statements .. */
/* Decode the input arguments */
/* Parameter adjustments */
a_dim1 = *lda;
a_offset = 1 + a_dim1;
a -= a_offset;
b_dim1 = *ldb;
b_offset = 1 + b_dim1;
b -= b_offset;
--alphar;
--alphai;
--beta;
vl_dim1 = *ldvl;
vl_offset = 1 + vl_dim1;
vl -= vl_offset;
vr_dim1 = *ldvr;
vr_offset = 1 + vr_dim1;
vr -= vr_offset;
--lscale;
--rscale;
--rconde;
--rcondv;
--work;
--iwork;
--bwork;
/* Function Body */
if (lsame_(jobvl, "N"))
{
ijobvl = 1;
ilvl = FALSE_;
}
else if (lsame_(jobvl, "V"))
{
ijobvl = 2;
ilvl = TRUE_;
}
else
{
ijobvl = -1;
ilvl = FALSE_;
}
if (lsame_(jobvr, "N"))
{
ijobvr = 1;
ilvr = FALSE_;
}
else if (lsame_(jobvr, "V"))
{
ijobvr = 2;
ilvr = TRUE_;
}
else
{
ijobvr = -1;
ilvr = FALSE_;
}
ilv = ilvl || ilvr;
noscl = lsame_(balanc, "N") || lsame_(balanc, "P");
wantsn = lsame_(sense, "N");
wantse = lsame_(sense, "E");
wantsv = lsame_(sense, "V");
wantsb = lsame_(sense, "B");
/* Test the input arguments */
*info = 0;
lquery = *lwork == -1;
if (! (noscl || lsame_(balanc, "S") || lsame_( balanc, "B")))
{
*info = -1;
}
else if (ijobvl <= 0)
{
*info = -2;
}
else if (ijobvr <= 0)
{
*info = -3;
}
else if (! (wantsn || wantse || wantsb || wantsv))
{
*info = -4;
}
else if (*n < 0)
{
*info = -5;
}
else if (*lda < max(1,*n))
{
*info = -7;
}
else if (*ldb < max(1,*n))
{
*info = -9;
}
else if (*ldvl < 1 || ilvl && *ldvl < *n)
{
*info = -14;
}
else if (*ldvr < 1 || ilvr && *ldvr < *n)
{
*info = -16;
}
/* Compute workspace */
/* (Note: Comments in the code beginning "Workspace:" describe the */
/* minimal amount of workspace needed at that point in the code, */
/* as well as the preferred amount for good performance. */
/* NB refers to the optimal block size for the immediately */
/* following subroutine, as returned by ILAENV. The workspace is */
/* computed assuming ILO = 1 and IHI = N, the worst case.) */
if (*info == 0)
{
if (*n == 0)
{
minwrk = 1;
maxwrk = 1;
}
else
{
if (noscl && ! ilv)
{
minwrk = *n << 1;
}
else
{
minwrk = *n * 6;
}
if (wantse)
{
minwrk = *n * 10;
}
else if (wantsv || wantsb)
{
minwrk = (*n << 1) * (*n + 4) + 16;
}
maxwrk = minwrk;
/* Computing MAX */
i__1 = maxwrk;
i__2 = *n + *n * ilaenv_(&c__1, "SGEQRF", " ", n, & c__1, n, &c__0); // , expr subst
maxwrk = max(i__1,i__2);
/* Computing MAX */
i__1 = maxwrk;
i__2 = *n + *n * ilaenv_(&c__1, "SORMQR", " ", n, & c__1, n, &c__0); // , expr subst
maxwrk = max(i__1,i__2);
if (ilvl)
{
/* Computing MAX */
i__1 = maxwrk;
i__2 = *n + *n * ilaenv_(&c__1, "SORGQR", " ", n, &c__1, n, &c__0); // , expr subst
maxwrk = max(i__1,i__2);
}
}
work[1] = (real) maxwrk;
if (*lwork < minwrk && ! lquery)
{
*info = -26;
}
}
if (*info != 0)
{
i__1 = -(*info);
xerbla_("SGGEVX", &i__1);
return 0;
}
else if (lquery)
{
return 0;
}
/* Quick return if possible */
if (*n == 0)
{
return 0;
}
/* Get machine constants */
eps = slamch_("P");
smlnum = slamch_("S");
bignum = 1.f / smlnum;
slabad_(&smlnum, &bignum);
smlnum = sqrt(smlnum) / eps;
bignum = 1.f / smlnum;
/* Scale A if max element outside range [SMLNUM,BIGNUM] */
anrm = slange_("M", n, n, &a[a_offset], lda, &work[1]);
ilascl = FALSE_;
if (anrm > 0.f && anrm < smlnum)
{
anrmto = smlnum;
ilascl = TRUE_;
}
else if (anrm > bignum)
{
anrmto = bignum;
ilascl = TRUE_;
}
if (ilascl)
{
slascl_("G", &c__0, &c__0, &anrm, &anrmto, n, n, &a[a_offset], lda, & ierr);
}
/* Scale B if max element outside range [SMLNUM,BIGNUM] */
bnrm = slange_("M", n, n, &b[b_offset], ldb, &work[1]);
ilbscl = FALSE_;
if (bnrm > 0.f && bnrm < smlnum)
{
bnrmto = smlnum;
ilbscl = TRUE_;
}
else if (bnrm > bignum)
{
bnrmto = bignum;
ilbscl = TRUE_;
}
if (ilbscl)
{
slascl_("G", &c__0, &c__0, &bnrm, &bnrmto, n, n, &b[b_offset], ldb, & ierr);
}
/* Permute and/or balance the matrix pair (A,B) */
/* (Workspace: need 6*N if BALANC = 'S' or 'B', 1 otherwise) */
sggbal_(balanc, n, &a[a_offset], lda, &b[b_offset], ldb, ilo, ihi, & lscale[1], &rscale[1], &work[1], &ierr);
/* Compute ABNRM and BBNRM */
*abnrm = slange_("1", n, n, &a[a_offset], lda, &work[1]);
if (ilascl)
{
work[1] = *abnrm;
slascl_("G", &c__0, &c__0, &anrmto, &anrm, &c__1, &c__1, &work[1], & c__1, &ierr);
*abnrm = work[1];
}
*bbnrm = slange_("1", n, n, &b[b_offset], ldb, &work[1]);
if (ilbscl)
{
work[1] = *bbnrm;
slascl_("G", &c__0, &c__0, &bnrmto, &bnrm, &c__1, &c__1, &work[1], & c__1, &ierr);
*bbnrm = work[1];
}
/* Reduce B to triangular form (QR decomposition of B) */
/* (Workspace: need N, prefer N*NB ) */
irows = *ihi + 1 - *ilo;
if (ilv || ! wantsn)
{
icols = *n + 1 - *ilo;
}
else
{
icols = irows;
}
itau = 1;
iwrk = itau + irows;
i__1 = *lwork + 1 - iwrk;
sgeqrf_(&irows, &icols, &b[*ilo + *ilo * b_dim1], ldb, &work[itau], &work[ iwrk], &i__1, &ierr);
/* Apply the orthogonal transformation to A */
/* (Workspace: need N, prefer N*NB) */
i__1 = *lwork + 1 - iwrk;
sormqr_("L", "T", &irows, &icols, &irows, &b[*ilo + *ilo * b_dim1], ldb, & work[itau], &a[*ilo + *ilo * a_dim1], lda, &work[iwrk], &i__1, & ierr);
/* Initialize VL and/or VR */
/* (Workspace: need N, prefer N*NB) */
if (ilvl)
{
slaset_("Full", n, n, &c_b57, &c_b58, &vl[vl_offset], ldvl) ;
if (irows > 1)
{
i__1 = irows - 1;
i__2 = irows - 1;
slacpy_("L", &i__1, &i__2, &b[*ilo + 1 + *ilo * b_dim1], ldb, &vl[ *ilo + 1 + *ilo * vl_dim1], ldvl);
}
i__1 = *lwork + 1 - iwrk;
sorgqr_(&irows, &irows, &irows, &vl[*ilo + *ilo * vl_dim1], ldvl, & work[itau], &work[iwrk], &i__1, &ierr);
}
if (ilvr)
{
slaset_("Full", n, n, &c_b57, &c_b58, &vr[vr_offset], ldvr) ;
}
/* Reduce to generalized Hessenberg form */
/* (Workspace: none needed) */
if (ilv || ! wantsn)
{
/* Eigenvectors requested -- work on whole matrix. */
sgghrd_(jobvl, jobvr, n, ilo, ihi, &a[a_offset], lda, &b[b_offset], ldb, &vl[vl_offset], ldvl, &vr[vr_offset], ldvr, &ierr);
}
else
{
sgghrd_("N", "N", &irows, &c__1, &irows, &a[*ilo + *ilo * a_dim1], lda, &b[*ilo + *ilo * b_dim1], ldb, &vl[vl_offset], ldvl, &vr[ vr_offset], ldvr, &ierr);
}
/* Perform QZ algorithm (Compute eigenvalues, and optionally, the */
/* Schur forms and Schur vectors) */
/* (Workspace: need N) */
if (ilv || ! wantsn)
{
*(unsigned char *)chtemp = 'S';
}
else
{
*(unsigned char *)chtemp = 'E';
}
shgeqz_(chtemp, jobvl, jobvr, n, ilo, ihi, &a[a_offset], lda, &b[b_offset] , ldb, &alphar[1], &alphai[1], &beta[1], &vl[vl_offset], ldvl, & vr[vr_offset], ldvr, &work[1], lwork, &ierr);
if (ierr != 0)
{
if (ierr > 0 && ierr <= *n)
{
*info = ierr;
}
else if (ierr > *n && ierr <= *n << 1)
{
*info = ierr - *n;
}
else
{
*info = *n + 1;
}
goto L130;
}
/* Compute Eigenvectors and estimate condition numbers if desired */
/* (Workspace: STGEVC: need 6*N */
/* STGSNA: need 2*N*(N+2)+16 if SENSE = 'V' or 'B', */
/* need N otherwise ) */
if (ilv || ! wantsn)
{
if (ilv)
{
if (ilvl)
{
if (ilvr)
{
*(unsigned char *)chtemp = 'B';
}
else
{
*(unsigned char *)chtemp = 'L';
}
}
else
{
*(unsigned char *)chtemp = 'R';
}
stgevc_(chtemp, "B", ldumma, n, &a[a_offset], lda, &b[b_offset], ldb, &vl[vl_offset], ldvl, &vr[vr_offset], ldvr, n, &in, & work[1], &ierr);
if (ierr != 0)
{
*info = *n + 2;
goto L130;
}
}
if (! wantsn)
{
/* compute eigenvectors (STGEVC) and estimate condition */
/* numbers (STGSNA). Note that the definition of the condition */
/* number is not invariant under transformation (u,v) to */
/* (Q*u, Z*v), where (u,v) are eigenvectors of the generalized */
/* Schur form (S,T), Q and Z are orthogonal matrices. In order */
/* to avoid using extra 2*N*N workspace, we have to recalculate */
/* eigenvectors and estimate one condition numbers at a time. */
pair = FALSE_;
i__1 = *n;
for (i__ = 1;
i__ <= i__1;
++i__)
{
if (pair)
{
pair = FALSE_;
goto L20;
}
mm = 1;
if (i__ < *n)
{
if (a[i__ + 1 + i__ * a_dim1] != 0.f)
{
pair = TRUE_;
mm = 2;
}
}
i__2 = *n;
for (j = 1;
j <= i__2;
++j)
{
bwork[j] = FALSE_;
/* L10: */
}
if (mm == 1)
{
bwork[i__] = TRUE_;
}
else if (mm == 2)
{
bwork[i__] = TRUE_;
bwork[i__ + 1] = TRUE_;
}
iwrk = mm * *n + 1;
iwrk1 = iwrk + mm * *n;
/* Compute a pair of left and right eigenvectors. */
/* (compute workspace: need up to 4*N + 6*N) */
if (wantse || wantsb)
{
stgevc_("B", "S", &bwork[1], n, &a[a_offset], lda, &b[ b_offset], ldb, &work[1], n, &work[iwrk], n, &mm, &m, &work[iwrk1], &ierr);
if (ierr != 0)
{
*info = *n + 2;
goto L130;
}
}
i__2 = *lwork - iwrk1 + 1;
stgsna_(sense, "S", &bwork[1], n, &a[a_offset], lda, &b[ b_offset], ldb, &work[1], n, &work[iwrk], n, &rconde[ i__], &rcondv[i__], &mm, &m, &work[iwrk1], &i__2, & iwork[1], &ierr);
L20:
;
}
}
}
/* Undo balancing on VL and VR and normalization */
/* (Workspace: none needed) */
if (ilvl)
{
sggbak_(balanc, "L", n, ilo, ihi, &lscale[1], &rscale[1], n, &vl[ vl_offset], ldvl, &ierr);
i__1 = *n;
for (jc = 1;
jc <= i__1;
++jc)
{
if (alphai[jc] < 0.f)
{
goto L70;
}
temp = 0.f;
if (alphai[jc] == 0.f)
{
i__2 = *n;
for (jr = 1;
jr <= i__2;
++jr)
{
/* Computing MAX */
r__2 = temp;
r__3 = (r__1 = vl[jr + jc * vl_dim1], abs( r__1)); // , expr subst
temp = max(r__2,r__3);
/* L30: */
}
}
else
{
i__2 = *n;
for (jr = 1;
jr <= i__2;
++jr)
{
/* Computing MAX */
r__3 = temp;
r__4 = (r__1 = vl[jr + jc * vl_dim1], abs( r__1)) + (r__2 = vl[jr + (jc + 1) * vl_dim1], abs( r__2)); // , expr subst
temp = max(r__3,r__4);
/* L40: */
}
}
if (temp < smlnum)
{
goto L70;
}
temp = 1.f / temp;
if (alphai[jc] == 0.f)
{
i__2 = *n;
for (jr = 1;
jr <= i__2;
++jr)
{
vl[jr + jc * vl_dim1] *= temp;
/* L50: */
}
}
else
{
i__2 = *n;
for (jr = 1;
jr <= i__2;
++jr)
{
vl[jr + jc * vl_dim1] *= temp;
vl[jr + (jc + 1) * vl_dim1] *= temp;
/* L60: */
}
}
L70:
;
}
}
if (ilvr)
{
sggbak_(balanc, "R", n, ilo, ihi, &lscale[1], &rscale[1], n, &vr[ vr_offset], ldvr, &ierr);
i__1 = *n;
for (jc = 1;
jc <= i__1;
++jc)
{
if (alphai[jc] < 0.f)
{
goto L120;
}
temp = 0.f;
if (alphai[jc] == 0.f)
{
i__2 = *n;
for (jr = 1;
jr <= i__2;
++jr)
{
/* Computing MAX */
r__2 = temp;
r__3 = (r__1 = vr[jr + jc * vr_dim1], abs( r__1)); // , expr subst
temp = max(r__2,r__3);
/* L80: */
}
}
else
{
i__2 = *n;
for (jr = 1;
jr <= i__2;
++jr)
{
/* Computing MAX */
r__3 = temp;
r__4 = (r__1 = vr[jr + jc * vr_dim1], abs( r__1)) + (r__2 = vr[jr + (jc + 1) * vr_dim1], abs( r__2)); // , expr subst
temp = max(r__3,r__4);
/* L90: */
}
}
if (temp < smlnum)
{
goto L120;
}
temp = 1.f / temp;
if (alphai[jc] == 0.f)
{
i__2 = *n;
for (jr = 1;
jr <= i__2;
++jr)
{
vr[jr + jc * vr_dim1] *= temp;
/* L100: */
}
}
else
{
i__2 = *n;
for (jr = 1;
jr <= i__2;
++jr)
{
vr[jr + jc * vr_dim1] *= temp;
vr[jr + (jc + 1) * vr_dim1] *= temp;
/* L110: */
}
}
L120:
;
}
}
/* Undo scaling if necessary */
L130:
if (ilascl)
{
slascl_("G", &c__0, &c__0, &anrmto, &anrm, n, &c__1, &alphar[1], n, & ierr);
slascl_("G", &c__0, &c__0, &anrmto, &anrm, n, &c__1, &alphai[1], n, & ierr);
}
if (ilbscl)
{
slascl_("G", &c__0, &c__0, &bnrmto, &bnrm, n, &c__1, &beta[1], n, & ierr);
}
work[1] = (real) maxwrk;
return 0;
/* End of SGGEVX */
}
/* Subroutine */ int sgeevx_(char *balanc, char *jobvl, char *jobvr, char *
sense, integer *n, real *a, integer *lda, real *wr, real *wi, real *
vl, integer *ldvl, real *vr, integer *ldvr, integer *ilo, integer *
ihi, real *scale, real *abnrm, real *rconde, real *rcondv, real *work,
integer *lwork, integer *iwork, integer *info)
{
/* System generated locals */
integer a_dim1, a_offset, vl_dim1, vl_offset, vr_dim1, vr_offset, i__1,
i__2, i__3;
real r__1, r__2;
/* Builtin functions */
double sqrt(doublereal);
/* Local variables */
integer i__, k;
real r__, cs, sn;
char job[1];
real scl, dum[1], eps;
char side[1];
real anrm;
integer ierr, itau, iwrk, nout;
extern /* Subroutine */ int srot_(integer *, real *, integer *, real *,
integer *, real *, real *);
extern doublereal snrm2_(integer *, real *, integer *);
integer icond;
extern logical lsame_(char *, char *);
extern /* Subroutine */ int sscal_(integer *, real *, real *, integer *);
extern doublereal slapy2_(real *, real *);
extern /* Subroutine */ int slabad_(real *, real *);
logical scalea;
real cscale;
extern /* Subroutine */ int sgebak_(char *, char *, integer *, integer *,
integer *, real *, integer *, real *, integer *, integer *), sgebal_(char *, integer *, real *, integer *,
integer *, integer *, real *, integer *);
extern doublereal slamch_(char *), slange_(char *, integer *,
integer *, real *, integer *, real *);
extern /* Subroutine */ int sgehrd_(integer *, integer *, integer *, real
*, integer *, real *, real *, integer *, integer *), xerbla_(char
*, integer *);
extern integer ilaenv_(integer *, char *, char *, integer *, integer *,
integer *, integer *);
logical select[1];
real bignum;
extern /* Subroutine */ int slascl_(char *, integer *, integer *, real *,
real *, integer *, integer *, real *, integer *, integer *);
extern integer isamax_(integer *, real *, integer *);
extern /* Subroutine */ int slacpy_(char *, integer *, integer *, real *,
integer *, real *, integer *), slartg_(real *, real *,
real *, real *, real *), sorghr_(integer *, integer *, integer *,
real *, integer *, real *, real *, integer *, integer *), shseqr_(
char *, char *, integer *, integer *, integer *, real *, integer *
, real *, real *, real *, integer *, real *, integer *, integer *), strevc_(char *, char *, logical *, integer *,
real *, integer *, real *, integer *, real *, integer *, integer *
, integer *, real *, integer *);
integer minwrk, maxwrk;
extern /* Subroutine */ int strsna_(char *, char *, logical *, integer *,
real *, integer *, real *, integer *, real *, integer *, real *,
real *, integer *, integer *, real *, integer *, integer *,
integer *);
logical wantvl, wntsnb;
integer hswork;
logical wntsne;
real smlnum;
logical lquery, wantvr, wntsnn, wntsnv;
/* -- LAPACK driver routine (version 3.2) -- */
/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/* November 2006 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* SGEEVX computes for an N-by-N real nonsymmetric matrix A, the */
/* eigenvalues and, optionally, the left and/or right eigenvectors. */
/* Optionally also, it computes a balancing transformation to improve */
/* the conditioning of the eigenvalues and eigenvectors (ILO, IHI, */
/* SCALE, and ABNRM), reciprocal condition numbers for the eigenvalues */
/* (RCONDE), and reciprocal condition numbers for the right */
/* eigenvectors (RCONDV). */
/* The right eigenvector v(j) of A satisfies */
/* A * v(j) = lambda(j) * v(j) */
/* where lambda(j) is its eigenvalue. */
/* The left eigenvector u(j) of A satisfies */
/* u(j)**H * A = lambda(j) * u(j)**H */
/* where u(j)**H denotes the conjugate transpose of u(j). */
/* The computed eigenvectors are normalized to have Euclidean norm */
/* equal to 1 and largest component real. */
/* Balancing a matrix means permuting the rows and columns to make it */
/* more nearly upper triangular, and applying a diagonal similarity */
/* transformation D * A * D**(-1), where D is a diagonal matrix, to */
/* make its rows and columns closer in norm and the condition numbers */
/* of its eigenvalues and eigenvectors smaller. The computed */
/* reciprocal condition numbers correspond to the balanced matrix. */
/* Permuting rows and columns will not change the condition numbers */
/* (in exact arithmetic) but diagonal scaling will. For further */
/* explanation of balancing, see section 4.10.2 of the LAPACK */
/* Users' Guide. */
/* Arguments */
/* ========= */
/* BALANC (input) CHARACTER*1 */
/* Indicates how the input matrix should be diagonally scaled */
/* and/or permuted to improve the conditioning of its */
/* eigenvalues. */
/* = 'N': Do not diagonally scale or permute; */
/* = 'P': Perform permutations to make the matrix more nearly */
/* upper triangular. Do not diagonally scale; */
/* = 'S': Diagonally scale the matrix, i.e. replace A by */
/* D*A*D**(-1), where D is a diagonal matrix chosen */
/* to make the rows and columns of A more equal in */
/* norm. Do not permute; */
/* = 'B': Both diagonally scale and permute A. */
/* Computed reciprocal condition numbers will be for the matrix */
/* after balancing and/or permuting. Permuting does not change */
/* condition numbers (in exact arithmetic), but balancing does. */
/* JOBVL (input) CHARACTER*1 */
/* = 'N': left eigenvectors of A are not computed; */
/* = 'V': left eigenvectors of A are computed. */
/* If SENSE = 'E' or 'B', JOBVL must = 'V'. */
/* JOBVR (input) CHARACTER*1 */
/* = 'N': right eigenvectors of A are not computed; */
/* = 'V': right eigenvectors of A are computed. */
/* If SENSE = 'E' or 'B', JOBVR must = 'V'. */
/* SENSE (input) CHARACTER*1 */
/* Determines which reciprocal condition numbers are computed. */
/* = 'N': None are computed; */
/* = 'E': Computed for eigenvalues only; */
/* = 'V': Computed for right eigenvectors only; */
/* = 'B': Computed for eigenvalues and right eigenvectors. */
/* If SENSE = 'E' or 'B', both left and right eigenvectors */
/* must also be computed (JOBVL = 'V' and JOBVR = 'V'). */
/* N (input) INTEGER */
/* The order of the matrix A. N >= 0. */
/* A (input/output) REAL array, dimension (LDA,N) */
/* On entry, the N-by-N matrix A. */
/* On exit, A has been overwritten. If JOBVL = 'V' or */
/* JOBVR = 'V', A contains the real Schur form of the balanced */
/* version of the input matrix A. */
/* LDA (input) INTEGER */
/* The leading dimension of the array A. LDA >= max(1,N). */
/* WR (output) REAL array, dimension (N) */
/* WI (output) REAL array, dimension (N) */
/* WR and WI contain the real and imaginary parts, */
/* respectively, of the computed eigenvalues. Complex */
/* conjugate pairs of eigenvalues will appear consecutively */
/* with the eigenvalue having the positive imaginary part */
/* first. */
/* VL (output) REAL array, dimension (LDVL,N) */
/* If JOBVL = 'V', the left eigenvectors u(j) are stored one */
/* after another in the columns of VL, in the same order */
/* as their eigenvalues. */
/* If JOBVL = 'N', VL is not referenced. */
/* If the j-th eigenvalue is real, then u(j) = VL(:,j), */
/* the j-th column of VL. */
/* If the j-th and (j+1)-st eigenvalues form a complex */
/* conjugate pair, then u(j) = VL(:,j) + i*VL(:,j+1) and */
/* u(j+1) = VL(:,j) - i*VL(:,j+1). */
/* LDVL (input) INTEGER */
/* The leading dimension of the array VL. LDVL >= 1; if */
/* JOBVL = 'V', LDVL >= N. */
/* VR (output) REAL array, dimension (LDVR,N) */
/* If JOBVR = 'V', the right eigenvectors v(j) are stored one */
/* after another in the columns of VR, in the same order */
/* as their eigenvalues. */
/* If JOBVR = 'N', VR is not referenced. */
/* If the j-th eigenvalue is real, then v(j) = VR(:,j), */
/* the j-th column of VR. */
/* If the j-th and (j+1)-st eigenvalues form a complex */
/* conjugate pair, then v(j) = VR(:,j) + i*VR(:,j+1) and */
/* v(j+1) = VR(:,j) - i*VR(:,j+1). */
/* LDVR (input) INTEGER */
/* The leading dimension of the array VR. LDVR >= 1, and if */
/* JOBVR = 'V', LDVR >= N. */
/* ILO (output) INTEGER */
/* IHI (output) INTEGER */
/* ILO and IHI are integer values determined when A was */
/* balanced. The balanced A(i,j) = 0 if I > J and */
/* J = 1,...,ILO-1 or I = IHI+1,...,N. */
/* SCALE (output) REAL array, dimension (N) */
/* Details of the permutations and scaling factors applied */
/* when balancing A. If P(j) is the index of the row and column */
/* interchanged with row and column j, and D(j) is the scaling */
/* factor applied to row and column j, then */
/* SCALE(J) = P(J), for J = 1,...,ILO-1 */
/* = D(J), for J = ILO,...,IHI */
/* = P(J) for J = IHI+1,...,N. */
/* The order in which the interchanges are made is N to IHI+1, */
/* then 1 to ILO-1. */
/* ABNRM (output) REAL */
/* The one-norm of the balanced matrix (the maximum */
/* of the sum of absolute values of elements of any column). */
/* RCONDE (output) REAL array, dimension (N) */
/* RCONDE(j) is the reciprocal condition number of the j-th */
/* eigenvalue. */
/* RCONDV (output) REAL array, dimension (N) */
/* RCONDV(j) is the reciprocal condition number of the j-th */
/* right eigenvector. */
/* 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. If SENSE = 'N' or 'E', */
/* LWORK >= max(1,2*N), and if JOBVL = 'V' or JOBVR = 'V', */
/* LWORK >= 3*N. If SENSE = 'V' or 'B', LWORK >= N*(N+6). */
/* For good performance, LWORK must generally be larger. */
/* 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 (2*N-2) */
/* If SENSE = 'N' or 'E', not referenced. */
/* INFO (output) INTEGER */
/* = 0: successful exit */
/* < 0: if INFO = -i, the i-th argument had an illegal value. */
/* > 0: if INFO = i, the QR algorithm failed to compute all the */
/* eigenvalues, and no eigenvectors or condition numbers */
/* have been computed; elements 1:ILO-1 and i+1:N of WR */
/* and WI contain eigenvalues which have converged. */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. Local Arrays .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Executable Statements .. */
/* Test the input arguments */
/* Parameter adjustments */
a_dim1 = *lda;
a_offset = 1 + a_dim1;
a -= a_offset;
--wr;
--wi;
vl_dim1 = *ldvl;
vl_offset = 1 + vl_dim1;
vl -= vl_offset;
vr_dim1 = *ldvr;
vr_offset = 1 + vr_dim1;
vr -= vr_offset;
--scale;
--rconde;
--rcondv;
--work;
--iwork;
/* Function Body */
*info = 0;
lquery = *lwork == -1;
wantvl = lsame_(jobvl, "V");
wantvr = lsame_(jobvr, "V");
wntsnn = lsame_(sense, "N");
wntsne = lsame_(sense, "E");
wntsnv = lsame_(sense, "V");
wntsnb = lsame_(sense, "B");
if (! (lsame_(balanc, "N") || lsame_(balanc, "S") || lsame_(balanc, "P")
|| lsame_(balanc, "B"))) {
*info = -1;
} else if (! wantvl && ! lsame_(jobvl, "N")) {
*info = -2;
} else if (! wantvr && ! lsame_(jobvr, "N")) {
*info = -3;
} else if (! (wntsnn || wntsne || wntsnb || wntsnv) || (wntsne || wntsnb)
&& ! (wantvl && wantvr)) {
*info = -4;
} else if (*n < 0) {
*info = -5;
} else if (*lda < max(1,*n)) {
*info = -7;
} else if (*ldvl < 1 || wantvl && *ldvl < *n) {
*info = -11;
} else if (*ldvr < 1 || wantvr && *ldvr < *n) {
*info = -13;
}
/* Compute workspace */
/* (Note: Comments in the code beginning "Workspace:" describe the */
/* minimal amount of workspace needed at that point in the code, */
/* as well as the preferred amount for good performance. */
/* NB refers to the optimal block size for the immediately */
/* following subroutine, as returned by ILAENV. */
/* HSWORK refers to the workspace preferred by SHSEQR, as */
/* calculated below. HSWORK is computed assuming ILO=1 and IHI=N, */
/* the worst case.) */
if (*info == 0) {
if (*n == 0) {
minwrk = 1;
maxwrk = 1;
} else {
maxwrk = *n + *n * ilaenv_(&c__1, "SGEHRD", " ", n, &c__1, n, &
c__0);
if (wantvl) {
shseqr_("S", "V", n, &c__1, n, &a[a_offset], lda, &wr[1], &wi[
1], &vl[vl_offset], ldvl, &work[1], &c_n1, info);
} else if (wantvr) {
shseqr_("S", "V", n, &c__1, n, &a[a_offset], lda, &wr[1], &wi[
1], &vr[vr_offset], ldvr, &work[1], &c_n1, info);
} else {
if (wntsnn) {
shseqr_("E", "N", n, &c__1, n, &a[a_offset], lda, &wr[1],
&wi[1], &vr[vr_offset], ldvr, &work[1], &c_n1,
info);
} else {
shseqr_("S", "N", n, &c__1, n, &a[a_offset], lda, &wr[1],
&wi[1], &vr[vr_offset], ldvr, &work[1], &c_n1,
info);
}
}
hswork = work[1];
if (! wantvl && ! wantvr) {
minwrk = *n << 1;
if (! wntsnn) {
/* Computing MAX */
i__1 = minwrk, i__2 = *n * *n + *n * 6;
minwrk = max(i__1,i__2);
}
maxwrk = max(maxwrk,hswork);
if (! wntsnn) {
/* Computing MAX */
i__1 = maxwrk, i__2 = *n * *n + *n * 6;
maxwrk = max(i__1,i__2);
}
} else {
minwrk = *n * 3;
if (! wntsnn && ! wntsne) {
/* Computing MAX */
i__1 = minwrk, i__2 = *n * *n + *n * 6;
minwrk = max(i__1,i__2);
}
maxwrk = max(maxwrk,hswork);
/* Computing MAX */
i__1 = maxwrk, i__2 = *n + (*n - 1) * ilaenv_(&c__1, "SORGHR",
" ", n, &c__1, n, &c_n1);
maxwrk = max(i__1,i__2);
if (! wntsnn && ! wntsne) {
/* Computing MAX */
i__1 = maxwrk, i__2 = *n * *n + *n * 6;
maxwrk = max(i__1,i__2);
}
/* Computing MAX */
i__1 = maxwrk, i__2 = *n * 3;
maxwrk = max(i__1,i__2);
}
maxwrk = max(maxwrk,minwrk);
}
work[1] = (real) maxwrk;
if (*lwork < minwrk && ! lquery) {
*info = -21;
}
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("SGEEVX", &i__1);
return 0;
} else if (lquery) {
return 0;
}
/* Quick return if possible */
if (*n == 0) {
return 0;
}
/* Get machine constants */
eps = slamch_("P");
smlnum = slamch_("S");
bignum = 1.f / smlnum;
slabad_(&smlnum, &bignum);
smlnum = sqrt(smlnum) / eps;
bignum = 1.f / smlnum;
/* Scale A if max element outside range [SMLNUM,BIGNUM] */
icond = 0;
anrm = slange_("M", n, n, &a[a_offset], lda, dum);
scalea = FALSE_;
if (anrm > 0.f && anrm < smlnum) {
scalea = TRUE_;
cscale = smlnum;
} else if (anrm > bignum) {
scalea = TRUE_;
cscale = bignum;
}
if (scalea) {
slascl_("G", &c__0, &c__0, &anrm, &cscale, n, n, &a[a_offset], lda, &
ierr);
}
/* Balance the matrix and compute ABNRM */
sgebal_(balanc, n, &a[a_offset], lda, ilo, ihi, &scale[1], &ierr);
*abnrm = slange_("1", n, n, &a[a_offset], lda, dum);
if (scalea) {
dum[0] = *abnrm;
slascl_("G", &c__0, &c__0, &cscale, &anrm, &c__1, &c__1, dum, &c__1, &
ierr);
*abnrm = dum[0];
}
/* Reduce to upper Hessenberg form */
/* (Workspace: need 2*N, prefer N+N*NB) */
itau = 1;
iwrk = itau + *n;
i__1 = *lwork - iwrk + 1;
sgehrd_(n, ilo, ihi, &a[a_offset], lda, &work[itau], &work[iwrk], &i__1, &
ierr);
if (wantvl) {
/* Want left eigenvectors */
/* Copy Householder vectors to VL */
*(unsigned char *)side = 'L';
slacpy_("L", n, n, &a[a_offset], lda, &vl[vl_offset], ldvl)
;
/* Generate orthogonal matrix in VL */
/* (Workspace: need 2*N-1, prefer N+(N-1)*NB) */
i__1 = *lwork - iwrk + 1;
sorghr_(n, ilo, ihi, &vl[vl_offset], ldvl, &work[itau], &work[iwrk], &
i__1, &ierr);
/* Perform QR iteration, accumulating Schur vectors in VL */
/* (Workspace: need 1, prefer HSWORK (see comments) ) */
iwrk = itau;
i__1 = *lwork - iwrk + 1;
shseqr_("S", "V", n, ilo, ihi, &a[a_offset], lda, &wr[1], &wi[1], &vl[
vl_offset], ldvl, &work[iwrk], &i__1, info);
if (wantvr) {
/* Want left and right eigenvectors */
/* Copy Schur vectors to VR */
*(unsigned char *)side = 'B';
slacpy_("F", n, n, &vl[vl_offset], ldvl, &vr[vr_offset], ldvr);
}
} else if (wantvr) {
/* Want right eigenvectors */
/* Copy Householder vectors to VR */
*(unsigned char *)side = 'R';
slacpy_("L", n, n, &a[a_offset], lda, &vr[vr_offset], ldvr)
;
/* Generate orthogonal matrix in VR */
/* (Workspace: need 2*N-1, prefer N+(N-1)*NB) */
i__1 = *lwork - iwrk + 1;
sorghr_(n, ilo, ihi, &vr[vr_offset], ldvr, &work[itau], &work[iwrk], &
i__1, &ierr);
/* Perform QR iteration, accumulating Schur vectors in VR */
/* (Workspace: need 1, prefer HSWORK (see comments) ) */
iwrk = itau;
i__1 = *lwork - iwrk + 1;
shseqr_("S", "V", n, ilo, ihi, &a[a_offset], lda, &wr[1], &wi[1], &vr[
vr_offset], ldvr, &work[iwrk], &i__1, info);
} else {
/* Compute eigenvalues only */
/* If condition numbers desired, compute Schur form */
if (wntsnn) {
*(unsigned char *)job = 'E';
} else {
*(unsigned char *)job = 'S';
}
/* (Workspace: need 1, prefer HSWORK (see comments) ) */
iwrk = itau;
i__1 = *lwork - iwrk + 1;
shseqr_(job, "N", n, ilo, ihi, &a[a_offset], lda, &wr[1], &wi[1], &vr[
vr_offset], ldvr, &work[iwrk], &i__1, info);
}
/* If INFO > 0 from SHSEQR, then quit */
if (*info > 0) {
goto L50;
}
if (wantvl || wantvr) {
/* Compute left and/or right eigenvectors */
/* (Workspace: need 3*N) */
strevc_(side, "B", select, n, &a[a_offset], lda, &vl[vl_offset], ldvl,
&vr[vr_offset], ldvr, n, &nout, &work[iwrk], &ierr);
}
/* Compute condition numbers if desired */
/* (Workspace: need N*N+6*N unless SENSE = 'E') */
if (! wntsnn) {
strsna_(sense, "A", select, n, &a[a_offset], lda, &vl[vl_offset],
ldvl, &vr[vr_offset], ldvr, &rconde[1], &rcondv[1], n, &nout,
&work[iwrk], n, &iwork[1], &icond);
}
if (wantvl) {
/* Undo balancing of left eigenvectors */
sgebak_(balanc, "L", n, ilo, ihi, &scale[1], n, &vl[vl_offset], ldvl,
&ierr);
/* Normalize left eigenvectors and make largest component real */
i__1 = *n;
for (i__ = 1; i__ <= i__1; ++i__) {
if (wi[i__] == 0.f) {
scl = 1.f / snrm2_(n, &vl[i__ * vl_dim1 + 1], &c__1);
sscal_(n, &scl, &vl[i__ * vl_dim1 + 1], &c__1);
} else if (wi[i__] > 0.f) {
r__1 = snrm2_(n, &vl[i__ * vl_dim1 + 1], &c__1);
r__2 = snrm2_(n, &vl[(i__ + 1) * vl_dim1 + 1], &c__1);
scl = 1.f / slapy2_(&r__1, &r__2);
sscal_(n, &scl, &vl[i__ * vl_dim1 + 1], &c__1);
sscal_(n, &scl, &vl[(i__ + 1) * vl_dim1 + 1], &c__1);
i__2 = *n;
for (k = 1; k <= i__2; ++k) {
/* Computing 2nd power */
r__1 = vl[k + i__ * vl_dim1];
/* Computing 2nd power */
r__2 = vl[k + (i__ + 1) * vl_dim1];
work[k] = r__1 * r__1 + r__2 * r__2;
/* L10: */
}
k = isamax_(n, &work[1], &c__1);
slartg_(&vl[k + i__ * vl_dim1], &vl[k + (i__ + 1) * vl_dim1],
&cs, &sn, &r__);
srot_(n, &vl[i__ * vl_dim1 + 1], &c__1, &vl[(i__ + 1) *
vl_dim1 + 1], &c__1, &cs, &sn);
vl[k + (i__ + 1) * vl_dim1] = 0.f;
}
/* L20: */
}
}
if (wantvr) {
/* Undo balancing of right eigenvectors */
sgebak_(balanc, "R", n, ilo, ihi, &scale[1], n, &vr[vr_offset], ldvr,
&ierr);
/* Normalize right eigenvectors and make largest component real */
i__1 = *n;
for (i__ = 1; i__ <= i__1; ++i__) {
if (wi[i__] == 0.f) {
scl = 1.f / snrm2_(n, &vr[i__ * vr_dim1 + 1], &c__1);
sscal_(n, &scl, &vr[i__ * vr_dim1 + 1], &c__1);
} else if (wi[i__] > 0.f) {
r__1 = snrm2_(n, &vr[i__ * vr_dim1 + 1], &c__1);
r__2 = snrm2_(n, &vr[(i__ + 1) * vr_dim1 + 1], &c__1);
scl = 1.f / slapy2_(&r__1, &r__2);
sscal_(n, &scl, &vr[i__ * vr_dim1 + 1], &c__1);
sscal_(n, &scl, &vr[(i__ + 1) * vr_dim1 + 1], &c__1);
i__2 = *n;
for (k = 1; k <= i__2; ++k) {
/* Computing 2nd power */
r__1 = vr[k + i__ * vr_dim1];
/* Computing 2nd power */
r__2 = vr[k + (i__ + 1) * vr_dim1];
work[k] = r__1 * r__1 + r__2 * r__2;
/* L30: */
}
k = isamax_(n, &work[1], &c__1);
slartg_(&vr[k + i__ * vr_dim1], &vr[k + (i__ + 1) * vr_dim1],
&cs, &sn, &r__);
srot_(n, &vr[i__ * vr_dim1 + 1], &c__1, &vr[(i__ + 1) *
vr_dim1 + 1], &c__1, &cs, &sn);
vr[k + (i__ + 1) * vr_dim1] = 0.f;
}
/* L40: */
}
}
/* Undo scaling if necessary */
L50:
if (scalea) {
i__1 = *n - *info;
/* Computing MAX */
i__3 = *n - *info;
i__2 = max(i__3,1);
slascl_("G", &c__0, &c__0, &cscale, &anrm, &i__1, &c__1, &wr[*info +
1], &i__2, &ierr);
i__1 = *n - *info;
/* Computing MAX */
i__3 = *n - *info;
i__2 = max(i__3,1);
slascl_("G", &c__0, &c__0, &cscale, &anrm, &i__1, &c__1, &wi[*info +
1], &i__2, &ierr);
if (*info == 0) {
if ((wntsnv || wntsnb) && icond == 0) {
slascl_("G", &c__0, &c__0, &cscale, &anrm, n, &c__1, &rcondv[
1], n, &ierr);
}
} else {
i__1 = *ilo - 1;
slascl_("G", &c__0, &c__0, &cscale, &anrm, &i__1, &c__1, &wr[1],
n, &ierr);
i__1 = *ilo - 1;
slascl_("G", &c__0, &c__0, &cscale, &anrm, &i__1, &c__1, &wi[1],
n, &ierr);
}
}
work[1] = (real) maxwrk;
return 0;
/* End of SGEEVX */
} /* sgeevx_ */
/* Subroutine */ int sget36_(real *rmax, integer *lmax, integer *ninfo,
integer *knt, integer *nin)
{
/* System generated locals */
integer i__1, i__2;
/* Builtin functions */
integer s_rsle(cilist *), do_lio(integer *, integer *, char *, ftnlen),
e_rsle(void);
double r_sign(real *, real *);
/* Local variables */
integer i__, j, n;
real q[100] /* was [10][10] */, t1[100] /* was [10][10] */, t2[100]
/* was [10][10] */;
integer loc;
real eps, res, tmp[100] /* was [10][10] */;
integer ifst, ilst;
real work[200];
integer info1, info2, ifst1, ifst2, ilst1, ilst2;
extern /* Subroutine */ int shst01_(integer *, integer *, integer *, real
*, integer *, real *, integer *, real *, integer *, real *,
integer *, real *);
extern doublereal slamch_(char *);
extern /* Subroutine */ int slacpy_(char *, integer *, integer *, real *,
integer *, real *, integer *), slaset_(char *, integer *,
integer *, real *, real *, real *, integer *), strexc_(
char *, integer *, real *, integer *, real *, integer *, integer *
, integer *, real *, integer *);
integer ifstsv;
real result[2];
integer ilstsv;
/* Fortran I/O blocks */
static cilist io___2 = { 0, 0, 0, 0, 0 };
static cilist io___7 = { 0, 0, 0, 0, 0 };
/* -- LAPACK test routine (version 3.1) -- */
/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/* November 2006 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* SGET36 tests STREXC, a routine for moving blocks (either 1 by 1 or */
/* 2 by 2) on the diagonal of a matrix in real Schur form. Thus, SLAEXC */
/* computes an orthogonal matrix Q such that */
/* Q' * T1 * Q = T2 */
/* and where one of the diagonal blocks of T1 (the one at row IFST) has */
/* been moved to position ILST. */
/* The test code verifies that the residual Q'*T1*Q-T2 is small, that T2 */
/* is in Schur form, and that the final position of the IFST block is */
/* ILST (within +-1). */
/* The test matrices are read from a file with logical unit number NIN. */
/* Arguments */
/* ========== */
/* RMAX (output) REAL */
/* Value of the largest test ratio. */
/* LMAX (output) INTEGER */
/* Example number where largest test ratio achieved. */
/* NINFO (output) INTEGER array, dimension (3) */
/* NINFO(J) is the number of examples where INFO=J. */
/* KNT (output) INTEGER */
/* Total number of examples tested. */
/* NIN (input) INTEGER */
/* Input logical unit number. */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. Local Arrays .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Executable Statements .. */
/* Parameter adjustments */
--ninfo;
/* Function Body */
eps = slamch_("P");
*rmax = 0.f;
*lmax = 0;
*knt = 0;
ninfo[1] = 0;
ninfo[2] = 0;
ninfo[3] = 0;
/* Read input data until N=0 */
L10:
io___2.ciunit = *nin;
s_rsle(&io___2);
do_lio(&c__3, &c__1, (char *)&n, (ftnlen)sizeof(integer));
do_lio(&c__3, &c__1, (char *)&ifst, (ftnlen)sizeof(integer));
do_lio(&c__3, &c__1, (char *)&ilst, (ftnlen)sizeof(integer));
e_rsle();
if (n == 0) {
return 0;
}
++(*knt);
i__1 = n;
for (i__ = 1; i__ <= i__1; ++i__) {
io___7.ciunit = *nin;
s_rsle(&io___7);
i__2 = n;
for (j = 1; j <= i__2; ++j) {
do_lio(&c__4, &c__1, (char *)&tmp[i__ + j * 10 - 11], (ftnlen)
sizeof(real));
}
e_rsle();
/* L20: */
}
slacpy_("F", &n, &n, tmp, &c__10, t1, &c__10);
slacpy_("F", &n, &n, tmp, &c__10, t2, &c__10);
ifstsv = ifst;
ilstsv = ilst;
ifst1 = ifst;
ilst1 = ilst;
ifst2 = ifst;
ilst2 = ilst;
res = 0.f;
/* Test without accumulating Q */
slaset_("Full", &n, &n, &c_b21, &c_b22, q, &c__10);
strexc_("N", &n, t1, &c__10, q, &c__10, &ifst1, &ilst1, work, &info1);
i__1 = n;
for (i__ = 1; i__ <= i__1; ++i__) {
i__2 = n;
for (j = 1; j <= i__2; ++j) {
if (i__ == j && q[i__ + j * 10 - 11] != 1.f) {
res += 1.f / eps;
}
if (i__ != j && q[i__ + j * 10 - 11] != 0.f) {
res += 1.f / eps;
}
/* L30: */
}
/* L40: */
}
/* Test with accumulating Q */
slaset_("Full", &n, &n, &c_b21, &c_b22, q, &c__10);
strexc_("V", &n, t2, &c__10, q, &c__10, &ifst2, &ilst2, work, &info2);
/* Compare T1 with T2 */
i__1 = n;
for (i__ = 1; i__ <= i__1; ++i__) {
i__2 = n;
for (j = 1; j <= i__2; ++j) {
if (t1[i__ + j * 10 - 11] != t2[i__ + j * 10 - 11]) {
res += 1.f / eps;
}
/* L50: */
}
/* L60: */
}
if (ifst1 != ifst2) {
res += 1.f / eps;
}
if (ilst1 != ilst2) {
res += 1.f / eps;
}
if (info1 != info2) {
res += 1.f / eps;
}
/* Test for successful reordering of T2 */
if (info2 != 0) {
++ninfo[info2];
} else {
if ((i__1 = ifst2 - ifstsv, abs(i__1)) > 1) {
res += 1.f / eps;
}
if ((i__1 = ilst2 - ilstsv, abs(i__1)) > 1) {
res += 1.f / eps;
}
}
/* Test for small residual, and orthogonality of Q */
shst01_(&n, &c__1, &n, tmp, &c__10, t2, &c__10, q, &c__10, work, &c__200,
result);
res = res + result[0] + result[1];
/* Test for T2 being in Schur form */
loc = 1;
L70:
if (t2[loc + 1 + loc * 10 - 11] != 0.f) {
/* 2 by 2 block */
if (t2[loc + (loc + 1) * 10 - 11] == 0.f || t2[loc + loc * 10 - 11] !=
t2[loc + 1 + (loc + 1) * 10 - 11] || r_sign(&c_b22, &t2[loc
+ (loc + 1) * 10 - 11]) == r_sign(&c_b22, &t2[loc + 1 + loc *
10 - 11])) {
res += 1.f / eps;
}
i__1 = n;
for (i__ = loc + 2; i__ <= i__1; ++i__) {
if (t2[i__ + loc * 10 - 11] != 0.f) {
res += 1.f / res;
}
if (t2[i__ + (loc + 1) * 10 - 11] != 0.f) {
res += 1.f / res;
}
/* L80: */
}
loc += 2;
} else {
/* 1 by 1 block */
i__1 = n;
for (i__ = loc + 1; i__ <= i__1; ++i__) {
if (t2[i__ + loc * 10 - 11] != 0.f) {
res += 1.f / res;
}
/* L90: */
}
++loc;
}
if (loc < n) {
goto L70;
}
if (res > *rmax) {
*rmax = res;
*lmax = *knt;
}
goto L10;
/* End of SGET36 */
} /* sget36_ */
/* Subroutine */ int sppsvx_(char *fact, char *uplo, integer *n, integer *
nrhs, real *ap, real *afp, char *equed, real *s, real *b, integer *
ldb, real *x, integer *ldx, real *rcond, real *ferr, real *berr, real
*work, integer *iwork, integer *info)
{
/* -- LAPACK driver 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
=======
SPPSVX uses the Cholesky factorization A = U**T*U or A = L*L**T to
compute the solution to a real system of linear equations
A * X = B,
where A is an N-by-N symmetric positive definite matrix stored in
packed format and X and B are N-by-NRHS matrices.
Error bounds on the solution and a condition estimate are also
provided.
Description
===========
The following steps are performed:
1. If FACT = 'E', real scaling factors are computed to equilibrate
the system:
diag(S) * A * diag(S) * inv(diag(S)) * X = diag(S) * B
Whether or not the system will be equilibrated depends on the
scaling of the matrix A, but if equilibration is used, A is
overwritten by diag(S)*A*diag(S) and B by diag(S)*B.
2. If FACT = 'N' or 'E', the Cholesky decomposition is used to
factor the matrix A (after equilibration if FACT = 'E') as
A = U**T* U, if UPLO = 'U', or
A = L * L**T, if UPLO = 'L',
where U is an upper triangular matrix and L is a lower triangular
matrix.
3. If the leading i-by-i principal minor is not positive definite,
then the routine returns with INFO = i. Otherwise, the factored
form of A is used to estimate the condition number of the matrix
A. If the reciprocal of the condition number is less than machine
precision, INFO = N+1 is returned as a warning, but the routine
still goes on to solve for X and compute error bounds as
described below.
4. The system of equations is solved for X using the factored form
of A.
5. Iterative refinement is applied to improve the computed solution
matrix and calculate error bounds and backward error estimates
for it.
6. If equilibration was used, the matrix X is premultiplied by
diag(S) so that it solves the original system before
equilibration.
Arguments
=========
FACT (input) CHARACTER*1
Specifies whether or not the factored form of the matrix A is
supplied on entry, and if not, whether the matrix A should be
equilibrated before it is factored.
= 'F': On entry, AFP contains the factored form of A.
If EQUED = 'Y', the matrix A has been equilibrated
with scaling factors given by S. AP and AFP will not
be modified.
= 'N': The matrix A will be copied to AFP and factored.
= 'E': The matrix A will be equilibrated if necessary, then
copied to AFP and factored.
UPLO (input) CHARACTER*1
= 'U': Upper triangle of A is stored;
= 'L': Lower triangle of A is stored.
N (input) INTEGER
The number of linear equations, i.e., the order of the
matrix A. N >= 0.
NRHS (input) INTEGER
The number of right hand sides, i.e., the number of columns
of the matrices B and X. NRHS >= 0.
AP (input/output) REAL array, dimension (N*(N+1)/2)
On entry, the upper or lower triangle of the symmetric matrix
A, packed columnwise in a linear array, except if FACT = 'F'
and EQUED = 'Y', then A must contain the equilibrated matrix
diag(S)*A*diag(S). The j-th column of A is stored in the
array AP as follows:
if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j;
if UPLO = 'L', AP(i + (j-1)*(2n-j)/2) = A(i,j) for j<=i<=n.
See below for further details. A is not modified if
FACT = 'F' or 'N', or if FACT = 'E' and EQUED = 'N' on exit.
On exit, if FACT = 'E' and EQUED = 'Y', A is overwritten by
diag(S)*A*diag(S).
AFP (input or output) REAL array, dimension
(N*(N+1)/2)
If FACT = 'F', then AFP is an input argument and on entry
contains the triangular factor U or L from the Cholesky
factorization A = U'*U or A = L*L', in the same storage
format as A. If EQUED .ne. 'N', then AFP is the factored
form of the equilibrated matrix A.
If FACT = 'N', then AFP is an output argument and on exit
returns the triangular factor U or L from the Cholesky
factorization A = U'*U or A = L*L' of the original matrix A.
If FACT = 'E', then AFP is an output argument and on exit
returns the triangular factor U or L from the Cholesky
factorization A = U'*U or A = L*L' of the equilibrated
matrix A (see the description of AP for the form of the
equilibrated matrix).
EQUED (input or output) CHARACTER*1
Specifies the form of equilibration that was done.
= 'N': No equilibration (always true if FACT = 'N').
= 'Y': Equilibration was done, i.e., A has been replaced by
diag(S) * A * diag(S).
EQUED is an input argument if FACT = 'F'; otherwise, it is an
output argument.
S (input or output) REAL array, dimension (N)
The scale factors for A; not accessed if EQUED = 'N'. S is
an input argument if FACT = 'F'; otherwise, S is an output
argument. If FACT = 'F' and EQUED = 'Y', each element of S
must be positive.
B (input/output) REAL array, dimension (LDB,NRHS)
On entry, the N-by-NRHS right hand side matrix B.
On exit, if EQUED = 'N', B is not modified; if EQUED = 'Y',
B is overwritten by diag(S) * B.
LDB (input) INTEGER
The leading dimension of the array B. LDB >= max(1,N).
X (output) REAL array, dimension (LDX,NRHS)
If INFO = 0 or INFO = N+1, the N-by-NRHS solution matrix X to
the original system of equations. Note that if EQUED = 'Y',
A and B are modified on exit, and the solution to the
equilibrated system is inv(diag(S))*X.
LDX (input) INTEGER
The leading dimension of the array X. LDX >= max(1,N).
RCOND (output) REAL
The estimate of the reciprocal condition number of the matrix
A after equilibration (if done). If RCOND is less than the
machine precision (in particular, if RCOND = 0), the matrix
is singular to working precision. This condition is
indicated by a return code of INFO > 0.
FERR (output) REAL array, dimension (NRHS)
The estimated forward error bound for each solution vector
X(j) (the j-th column of the solution matrix X).
If XTRUE is the true solution corresponding to X(j), FERR(j)
is an estimated upper bound for the magnitude of the largest
element in (X(j) - XTRUE) divided by the magnitude of the
largest element in X(j). The estimate is as reliable as
the estimate for RCOND, and is almost always a slight
overestimate of the true error.
BERR (output) REAL array, dimension (NRHS)
The componentwise relative backward error of each solution
vector X(j) (i.e., the smallest relative change in
any element of A or B that makes X(j) an exact solution).
WORK (workspace) REAL array, dimension (3*N)
IWORK (workspace) INTEGER array, dimension (N)
INFO (output) INTEGER
= 0: successful exit
< 0: if INFO = -i, the i-th argument had an illegal value
> 0: if INFO = i, and i is
<= N: the leading minor of order i of A is
not positive definite, so the factorization
could not be completed, and the solution has not
been computed. RCOND = 0 is returned.
= N+1: U is nonsingular, but RCOND is less than machine
precision, meaning that the matrix is singular
to working precision. Nevertheless, the
solution and error bounds are computed because
there are a number of situations where the
computed solution can be more accurate than the
value of RCOND would suggest.
Further Details
===============
The packed storage scheme is illustrated by the following example
when N = 4, UPLO = 'U':
Two-dimensional storage of the symmetric matrix A:
a11 a12 a13 a14
a22 a23 a24
a33 a34 (aij = conjg(aji))
a44
Packed storage of the upper triangle of A:
AP = [ a11, a12, a22, a13, a23, a33, a14, a24, a34, a44 ]
=====================================================================
Parameter adjustments */
/* Table of constant values */
static integer c__1 = 1;
/* System generated locals */
integer b_dim1, b_offset, x_dim1, x_offset, i__1, i__2;
real r__1, r__2;
/* Local variables */
static real amax, smin, smax;
static integer i__, j;
extern logical lsame_(char *, char *);
static real scond, anorm;
static logical equil, rcequ;
extern /* Subroutine */ int scopy_(integer *, real *, integer *, real *,
integer *);
extern doublereal slamch_(char *);
static logical nofact;
extern /* Subroutine */ int xerbla_(char *, integer *);
static real bignum;
static integer infequ;
extern /* Subroutine */ int slacpy_(char *, integer *, integer *, real *,
integer *, real *, integer *);
extern doublereal slansp_(char *, char *, integer *, real *, real *);
extern /* Subroutine */ int sppcon_(char *, integer *, real *, real *,
real *, real *, integer *, integer *), slaqsp_(char *,
integer *, real *, real *, real *, real *, char *)
;
static real smlnum;
extern /* Subroutine */ int sppequ_(char *, integer *, real *, real *,
real *, real *, integer *), spprfs_(char *, integer *,
integer *, real *, real *, real *, integer *, real *, integer *,
real *, real *, real *, integer *, integer *), spptrf_(
char *, integer *, real *, integer *), spptrs_(char *,
integer *, integer *, real *, real *, integer *, integer *);
#define b_ref(a_1,a_2) b[(a_2)*b_dim1 + a_1]
#define x_ref(a_1,a_2) x[(a_2)*x_dim1 + a_1]
--ap;
--afp;
--s;
b_dim1 = *ldb;
b_offset = 1 + b_dim1 * 1;
b -= b_offset;
x_dim1 = *ldx;
x_offset = 1 + x_dim1 * 1;
x -= x_offset;
--ferr;
--berr;
--work;
--iwork;
/* Function Body */
*info = 0;
nofact = lsame_(fact, "N");
equil = lsame_(fact, "E");
if (nofact || equil) {
*(unsigned char *)equed = 'N';
rcequ = FALSE_;
} else {
rcequ = lsame_(equed, "Y");
smlnum = slamch_("Safe minimum");
bignum = 1.f / smlnum;
}
/* Test the input parameters. */
if (! nofact && ! equil && ! lsame_(fact, "F")) {
*info = -1;
} else if (! lsame_(uplo, "U") && ! lsame_(uplo,
"L")) {
*info = -2;
} else if (*n < 0) {
*info = -3;
} else if (*nrhs < 0) {
*info = -4;
} else if (lsame_(fact, "F") && ! (rcequ || lsame_(
equed, "N"))) {
*info = -7;
} else {
if (rcequ) {
smin = bignum;
smax = 0.f;
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
/* Computing MIN */
r__1 = smin, r__2 = s[j];
smin = dmin(r__1,r__2);
/* Computing MAX */
r__1 = smax, r__2 = s[j];
smax = dmax(r__1,r__2);
/* L10: */
}
if (smin <= 0.f) {
*info = -8;
} else if (*n > 0) {
scond = dmax(smin,smlnum) / dmin(smax,bignum);
} else {
scond = 1.f;
}
}
if (*info == 0) {
if (*ldb < max(1,*n)) {
*info = -10;
} else if (*ldx < max(1,*n)) {
*info = -12;
}
}
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("SPPSVX", &i__1);
return 0;
}
if (equil) {
/* Compute row and column scalings to equilibrate the matrix A. */
sppequ_(uplo, n, &ap[1], &s[1], &scond, &amax, &infequ);
if (infequ == 0) {
/* Equilibrate the matrix. */
slaqsp_(uplo, n, &ap[1], &s[1], &scond, &amax, equed);
rcequ = lsame_(equed, "Y");
}
}
/* Scale the right-hand side. */
if (rcequ) {
i__1 = *nrhs;
for (j = 1; j <= i__1; ++j) {
i__2 = *n;
for (i__ = 1; i__ <= i__2; ++i__) {
b_ref(i__, j) = s[i__] * b_ref(i__, j);
/* L20: */
}
/* L30: */
}
}
if (nofact || equil) {
/* Compute the Cholesky factorization A = U'*U or A = L*L'. */
i__1 = *n * (*n + 1) / 2;
scopy_(&i__1, &ap[1], &c__1, &afp[1], &c__1);
spptrf_(uplo, n, &afp[1], info);
/* Return if INFO is non-zero. */
if (*info != 0) {
if (*info > 0) {
*rcond = 0.f;
}
return 0;
}
}
/* Compute the norm of the matrix A. */
anorm = slansp_("I", uplo, n, &ap[1], &work[1]);
/* Compute the reciprocal of the condition number of A. */
sppcon_(uplo, n, &afp[1], &anorm, rcond, &work[1], &iwork[1], info);
/* Set INFO = N+1 if the matrix is singular to working precision. */
if (*rcond < slamch_("Epsilon")) {
*info = *n + 1;
}
/* Compute the solution matrix X. */
slacpy_("Full", n, nrhs, &b[b_offset], ldb, &x[x_offset], ldx);
spptrs_(uplo, n, nrhs, &afp[1], &x[x_offset], ldx, info);
/* Use iterative refinement to improve the computed solution and
compute error bounds and backward error estimates for it. */
spprfs_(uplo, n, nrhs, &ap[1], &afp[1], &b[b_offset], ldb, &x[x_offset],
ldx, &ferr[1], &berr[1], &work[1], &iwork[1], info);
/* Transform the solution matrix X to a solution of the original
system. */
if (rcequ) {
i__1 = *nrhs;
for (j = 1; j <= i__1; ++j) {
i__2 = *n;
for (i__ = 1; i__ <= i__2; ++i__) {
x_ref(i__, j) = s[i__] * x_ref(i__, j);
/* L40: */
}
/* L50: */
}
i__1 = *nrhs;
for (j = 1; j <= i__1; ++j) {
ferr[j] /= scond;
/* L60: */
}
}
return 0;
/* End of SPPSVX */
} /* sppsvx_ */
/* Subroutine */ int sgesvx_(char *fact, char *trans, integer *n, integer *
nrhs, real *a, integer *lda, real *af, integer *ldaf, integer *ipiv,
char *equed, real *r__, real *c__, real *b, integer *ldb, real *x,
integer *ldx, real *rcond, real *ferr, real *berr, real *work,
integer *iwork, integer *info)
{
/* -- LAPACK driver 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
=======
SGESVX uses the LU factorization to compute the solution to a real
system of linear equations
A * X = B,
where A is an N-by-N matrix and X and B are N-by-NRHS matrices.
Error bounds on the solution and a condition estimate are also
provided.
Description
===========
The following steps are performed:
1. If FACT = 'E', real scaling factors are computed to equilibrate
the system:
TRANS = 'N': diag(R)*A*diag(C) *inv(diag(C))*X = diag(R)*B
TRANS = 'T': (diag(R)*A*diag(C))**T *inv(diag(R))*X = diag(C)*B
TRANS = 'C': (diag(R)*A*diag(C))**H *inv(diag(R))*X = diag(C)*B
Whether or not the system will be equilibrated depends on the
scaling of the matrix A, but if equilibration is used, A is
overwritten by diag(R)*A*diag(C) and B by diag(R)*B (if TRANS='N')
or diag(C)*B (if TRANS = 'T' or 'C').
2. If FACT = 'N' or 'E', the LU decomposition is used to factor the
matrix A (after equilibration if FACT = 'E') as
A = P * L * U,
where P is a permutation matrix, L is a unit lower triangular
matrix, and U is upper triangular.
3. If some U(i,i)=0, so that U is exactly singular, then the routine
returns with INFO = i. Otherwise, the factored form of A is used
to estimate the condition number of the matrix A. If the
reciprocal of the condition number is less than machine precision,
INFO = N+1 is returned as a warning, but the routine still goes on
to solve for X and compute error bounds as described below.
4. The system of equations is solved for X using the factored form
of A.
5. Iterative refinement is applied to improve the computed solution
matrix and calculate error bounds and backward error estimates
for it.
6. If equilibration was used, the matrix X is premultiplied by
diag(C) (if TRANS = 'N') or diag(R) (if TRANS = 'T' or 'C') so
that it solves the original system before equilibration.
Arguments
=========
FACT (input) CHARACTER*1
Specifies whether or not the factored form of the matrix A is
supplied on entry, and if not, whether the matrix A should be
equilibrated before it is factored.
= 'F': On entry, AF and IPIV contain the factored form of A.
If EQUED is not 'N', the matrix A has been
equilibrated with scaling factors given by R and C.
A, AF, and IPIV are not modified.
= 'N': The matrix A will be copied to AF and factored.
= 'E': The matrix A will be equilibrated if necessary, then
copied to AF and factored.
TRANS (input) CHARACTER*1
Specifies the form of the system of equations:
= 'N': A * X = B (No transpose)
= 'T': A**T * X = B (Transpose)
= 'C': A**H * X = B (Transpose)
N (input) INTEGER
The number of linear equations, i.e., the order of the
matrix A. N >= 0.
NRHS (input) INTEGER
The number of right hand sides, i.e., the number of columns
of the matrices B and X. NRHS >= 0.
A (input/output) REAL array, dimension (LDA,N)
On entry, the N-by-N matrix A. If FACT = 'F' and EQUED is
not 'N', then A must have been equilibrated by the scaling
factors in R and/or C. A is not modified if FACT = 'F' or
'N', or if FACT = 'E' and EQUED = 'N' on exit.
On exit, if EQUED .ne. 'N', A is scaled as follows:
EQUED = 'R': A := diag(R) * A
EQUED = 'C': A := A * diag(C)
EQUED = 'B': A := diag(R) * A * diag(C).
LDA (input) INTEGER
The leading dimension of the array A. LDA >= max(1,N).
AF (input or output) REAL array, dimension (LDAF,N)
If FACT = 'F', then AF is an input argument and on entry
contains the factors L and U from the factorization
A = P*L*U as computed by SGETRF. If EQUED .ne. 'N', then
AF is the factored form of the equilibrated matrix A.
If FACT = 'N', then AF is an output argument and on exit
returns the factors L and U from the factorization A = P*L*U
of the original matrix A.
If FACT = 'E', then AF is an output argument and on exit
returns the factors L and U from the factorization A = P*L*U
of the equilibrated matrix A (see the description of A for
the form of the equilibrated matrix).
LDAF (input) INTEGER
The leading dimension of the array AF. LDAF >= max(1,N).
IPIV (input or output) INTEGER array, dimension (N)
If FACT = 'F', then IPIV is an input argument and on entry
contains the pivot indices from the factorization A = P*L*U
as computed by SGETRF; row i of the matrix was interchanged
with row IPIV(i).
If FACT = 'N', then IPIV is an output argument and on exit
contains the pivot indices from the factorization A = P*L*U
of the original matrix A.
If FACT = 'E', then IPIV is an output argument and on exit
contains the pivot indices from the factorization A = P*L*U
of the equilibrated matrix A.
EQUED (input or output) CHARACTER*1
Specifies the form of equilibration that was done.
= 'N': No equilibration (always true if FACT = 'N').
= 'R': Row equilibration, i.e., A has been premultiplied by
diag(R).
= 'C': Column equilibration, i.e., A has been postmultiplied
by diag(C).
= 'B': Both row and column equilibration, i.e., A has been
replaced by diag(R) * A * diag(C).
EQUED is an input argument if FACT = 'F'; otherwise, it is an
output argument.
R (input or output) REAL array, dimension (N)
The row scale factors for A. If EQUED = 'R' or 'B', A is
multiplied on the left by diag(R); if EQUED = 'N' or 'C', R
is not accessed. R is an input argument if FACT = 'F';
otherwise, R is an output argument. If FACT = 'F' and
EQUED = 'R' or 'B', each element of R must be positive.
C (input or output) REAL array, dimension (N)
The column scale factors for A. If EQUED = 'C' or 'B', A is
multiplied on the right by diag(C); if EQUED = 'N' or 'R', C
is not accessed. C is an input argument if FACT = 'F';
otherwise, C is an output argument. If FACT = 'F' and
EQUED = 'C' or 'B', each element of C must be positive.
B (input/output) REAL array, dimension (LDB,NRHS)
On entry, the N-by-NRHS right hand side matrix B.
On exit,
if EQUED = 'N', B is not modified;
if TRANS = 'N' and EQUED = 'R' or 'B', B is overwritten by
diag(R)*B;
if TRANS = 'T' or 'C' and EQUED = 'C' or 'B', B is
overwritten by diag(C)*B.
LDB (input) INTEGER
The leading dimension of the array B. LDB >= max(1,N).
X (output) REAL array, dimension (LDX,NRHS)
If INFO = 0 or INFO = N+1, the N-by-NRHS solution matrix X
to the original system of equations. Note that A and B are
modified on exit if EQUED .ne. 'N', and the solution to the
equilibrated system is inv(diag(C))*X if TRANS = 'N' and
EQUED = 'C' or 'B', or inv(diag(R))*X if TRANS = 'T' or 'C'
and EQUED = 'R' or 'B'.
LDX (input) INTEGER
The leading dimension of the array X. LDX >= max(1,N).
RCOND (output) REAL
The estimate of the reciprocal condition number of the matrix
A after equilibration (if done). If RCOND is less than the
machine precision (in particular, if RCOND = 0), the matrix
is singular to working precision. This condition is
indicated by a return code of INFO > 0.
FERR (output) REAL array, dimension (NRHS)
The estimated forward error bound for each solution vector
X(j) (the j-th column of the solution matrix X).
If XTRUE is the true solution corresponding to X(j), FERR(j)
is an estimated upper bound for the magnitude of the largest
element in (X(j) - XTRUE) divided by the magnitude of the
largest element in X(j). The estimate is as reliable as
the estimate for RCOND, and is almost always a slight
overestimate of the true error.
BERR (output) REAL array, dimension (NRHS)
The componentwise relative backward error of each solution
vector X(j) (i.e., the smallest relative change in
any element of A or B that makes X(j) an exact solution).
WORK (workspace/output) REAL array, dimension (4*N)
On exit, WORK(1) contains the reciprocal pivot growth
factor norm(A)/norm(U). The "max absolute element" norm is
used. If WORK(1) is much less than 1, then the stability
of the LU factorization of the (equilibrated) matrix A
could be poor. This also means that the solution X, condition
estimator RCOND, and forward error bound FERR could be
unreliable. If factorization fails with 0<INFO<=N, then
WORK(1) contains the reciprocal pivot growth factor for the
leading INFO columns of A.
IWORK (workspace) INTEGER array, dimension (N)
INFO (output) INTEGER
= 0: successful exit
< 0: if INFO = -i, the i-th argument had an illegal value
> 0: if INFO = i, and i is
<= N: U(i,i) is exactly zero. The factorization has
been completed, but the factor U is exactly
singular, so the solution and error bounds
could not be computed. RCOND = 0 is returned.
= N+1: U is nonsingular, but RCOND is less than machine
precision, meaning that the matrix is singular
to working precision. Nevertheless, the
solution and error bounds are computed because
there are a number of situations where the
computed solution can be more accurate than the
value of RCOND would suggest.
=====================================================================
Parameter adjustments */
/* System generated locals */
integer a_dim1, a_offset, af_dim1, af_offset, b_dim1, b_offset, x_dim1,
x_offset, i__1, i__2;
real r__1, r__2;
/* Local variables */
static real amax;
static char norm[1];
static integer i__, j;
extern logical lsame_(char *, char *);
static real rcmin, rcmax, anorm;
static logical equil;
static real colcnd;
extern doublereal slamch_(char *), slange_(char *, integer *,
integer *, real *, integer *, real *);
static logical nofact;
extern /* Subroutine */ int slaqge_(integer *, integer *, real *, integer
*, real *, real *, real *, real *, real *, char *),
xerbla_(char *, integer *), sgecon_(char *, integer *,
real *, integer *, real *, real *, real *, integer *, integer *);
static real bignum;
static integer infequ;
static logical colequ;
extern /* Subroutine */ int sgeequ_(integer *, integer *, real *, integer
*, real *, real *, real *, real *, real *, integer *), sgerfs_(
char *, integer *, integer *, real *, integer *, real *, integer *
, integer *, real *, integer *, real *, integer *, real *, real *,
real *, integer *, integer *), sgetrf_(integer *,
integer *, real *, integer *, integer *, integer *);
static real rowcnd;
extern /* Subroutine */ int slacpy_(char *, integer *, integer *, real *,
integer *, real *, integer *);
static logical notran;
extern doublereal slantr_(char *, char *, char *, integer *, integer *,
real *, integer *, real *);
extern /* Subroutine */ int sgetrs_(char *, integer *, integer *, real *,
integer *, integer *, real *, integer *, integer *);
static real smlnum;
static logical rowequ;
static real rpvgrw;
#define b_ref(a_1,a_2) b[(a_2)*b_dim1 + a_1]
#define x_ref(a_1,a_2) x[(a_2)*x_dim1 + a_1]
a_dim1 = *lda;
a_offset = 1 + a_dim1 * 1;
a -= a_offset;
af_dim1 = *ldaf;
af_offset = 1 + af_dim1 * 1;
af -= af_offset;
--ipiv;
--r__;
--c__;
b_dim1 = *ldb;
b_offset = 1 + b_dim1 * 1;
b -= b_offset;
x_dim1 = *ldx;
x_offset = 1 + x_dim1 * 1;
x -= x_offset;
--ferr;
--berr;
--work;
--iwork;
/* Function Body */
*info = 0;
nofact = lsame_(fact, "N");
equil = lsame_(fact, "E");
notran = lsame_(trans, "N");
if (nofact || equil) {
*(unsigned char *)equed = 'N';
rowequ = FALSE_;
colequ = FALSE_;
} else {
rowequ = lsame_(equed, "R") || lsame_(equed,
"B");
colequ = lsame_(equed, "C") || lsame_(equed,
"B");
smlnum = slamch_("Safe minimum");
bignum = 1.f / smlnum;
}
/* Test the input parameters. */
if (! nofact && ! equil && ! lsame_(fact, "F")) {
*info = -1;
} else if (! notran && ! lsame_(trans, "T") && !
lsame_(trans, "C")) {
*info = -2;
} else if (*n < 0) {
*info = -3;
} else if (*nrhs < 0) {
*info = -4;
} else if (*lda < max(1,*n)) {
*info = -6;
} else if (*ldaf < max(1,*n)) {
*info = -8;
} else if (lsame_(fact, "F") && ! (rowequ || colequ
|| lsame_(equed, "N"))) {
*info = -10;
} else {
if (rowequ) {
rcmin = bignum;
rcmax = 0.f;
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
/* Computing MIN */
r__1 = rcmin, r__2 = r__[j];
rcmin = dmin(r__1,r__2);
/* Computing MAX */
r__1 = rcmax, r__2 = r__[j];
rcmax = dmax(r__1,r__2);
/* L10: */
}
if (rcmin <= 0.f) {
*info = -11;
} else if (*n > 0) {
rowcnd = dmax(rcmin,smlnum) / dmin(rcmax,bignum);
} else {
rowcnd = 1.f;
}
}
if (colequ && *info == 0) {
rcmin = bignum;
rcmax = 0.f;
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
/* Computing MIN */
r__1 = rcmin, r__2 = c__[j];
rcmin = dmin(r__1,r__2);
/* Computing MAX */
r__1 = rcmax, r__2 = c__[j];
rcmax = dmax(r__1,r__2);
/* L20: */
}
if (rcmin <= 0.f) {
*info = -12;
} else if (*n > 0) {
colcnd = dmax(rcmin,smlnum) / dmin(rcmax,bignum);
} else {
colcnd = 1.f;
}
}
if (*info == 0) {
if (*ldb < max(1,*n)) {
*info = -14;
} else if (*ldx < max(1,*n)) {
*info = -16;
}
}
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("SGESVX", &i__1);
return 0;
}
if (equil) {
/* Compute row and column scalings to equilibrate the matrix A. */
sgeequ_(n, n, &a[a_offset], lda, &r__[1], &c__[1], &rowcnd, &colcnd, &
amax, &infequ);
if (infequ == 0) {
/* Equilibrate the matrix. */
slaqge_(n, n, &a[a_offset], lda, &r__[1], &c__[1], &rowcnd, &
colcnd, &amax, equed);
rowequ = lsame_(equed, "R") || lsame_(equed,
"B");
colequ = lsame_(equed, "C") || lsame_(equed,
"B");
}
}
/* Scale the right hand side. */
if (notran) {
if (rowequ) {
i__1 = *nrhs;
for (j = 1; j <= i__1; ++j) {
i__2 = *n;
for (i__ = 1; i__ <= i__2; ++i__) {
b_ref(i__, j) = r__[i__] * b_ref(i__, j);
/* L30: */
}
/* L40: */
}
}
} else if (colequ) {
i__1 = *nrhs;
for (j = 1; j <= i__1; ++j) {
i__2 = *n;
for (i__ = 1; i__ <= i__2; ++i__) {
b_ref(i__, j) = c__[i__] * b_ref(i__, j);
/* L50: */
}
/* L60: */
}
}
if (nofact || equil) {
/* Compute the LU factorization of A. */
slacpy_("Full", n, n, &a[a_offset], lda, &af[af_offset], ldaf);
sgetrf_(n, n, &af[af_offset], ldaf, &ipiv[1], info);
/* Return if INFO is non-zero. */
if (*info != 0) {
if (*info > 0) {
/* Compute the reciprocal pivot growth factor of the
leading rank-deficient INFO columns of A. */
rpvgrw = slantr_("M", "U", "N", info, info, &af[af_offset],
ldaf, &work[1]);
if (rpvgrw == 0.f) {
rpvgrw = 1.f;
} else {
rpvgrw = slange_("M", n, info, &a[a_offset], lda, &work[1]
) / rpvgrw;
}
work[1] = rpvgrw;
*rcond = 0.f;
}
return 0;
}
}
/* Compute the norm of the matrix A and the
reciprocal pivot growth factor RPVGRW. */
if (notran) {
*(unsigned char *)norm = '1';
} else {
*(unsigned char *)norm = 'I';
}
anorm = slange_(norm, n, n, &a[a_offset], lda, &work[1]);
rpvgrw = slantr_("M", "U", "N", n, n, &af[af_offset], ldaf, &work[1]);
if (rpvgrw == 0.f) {
rpvgrw = 1.f;
} else {
rpvgrw = slange_("M", n, n, &a[a_offset], lda, &work[1]) /
rpvgrw;
}
/* Compute the reciprocal of the condition number of A. */
sgecon_(norm, n, &af[af_offset], ldaf, &anorm, rcond, &work[1], &iwork[1],
info);
/* Set INFO = N+1 if the matrix is singular to working precision. */
if (*rcond < slamch_("Epsilon")) {
*info = *n + 1;
}
/* Compute the solution matrix X. */
slacpy_("Full", n, nrhs, &b[b_offset], ldb, &x[x_offset], ldx);
sgetrs_(trans, n, nrhs, &af[af_offset], ldaf, &ipiv[1], &x[x_offset], ldx,
info);
/* Use iterative refinement to improve the computed solution and
compute error bounds and backward error estimates for it. */
sgerfs_(trans, n, nrhs, &a[a_offset], lda, &af[af_offset], ldaf, &ipiv[1],
&b[b_offset], ldb, &x[x_offset], ldx, &ferr[1], &berr[1], &work[
1], &iwork[1], info);
/* Transform the solution matrix X to a solution of the original
system. */
if (notran) {
if (colequ) {
i__1 = *nrhs;
for (j = 1; j <= i__1; ++j) {
i__2 = *n;
for (i__ = 1; i__ <= i__2; ++i__) {
x_ref(i__, j) = c__[i__] * x_ref(i__, j);
/* L70: */
}
/* L80: */
}
i__1 = *nrhs;
for (j = 1; j <= i__1; ++j) {
ferr[j] /= colcnd;
/* L90: */
}
}
} else if (rowequ) {
i__1 = *nrhs;
for (j = 1; j <= i__1; ++j) {
i__2 = *n;
for (i__ = 1; i__ <= i__2; ++i__) {
x_ref(i__, j) = r__[i__] * x_ref(i__, j);
/* L100: */
}
/* L110: */
}
i__1 = *nrhs;
for (j = 1; j <= i__1; ++j) {
ferr[j] /= rowcnd;
/* L120: */
}
}
work[1] = rpvgrw;
return 0;
/* End of SGESVX */
} /* sgesvx_ */
/* Subroutine */ int slals0_(integer *icompq, integer *nl, integer *nr,
integer *sqre, integer *nrhs, real *b, integer *ldb, real *bx,
integer *ldbx, integer *perm, integer *givptr, integer *givcol,
integer *ldgcol, real *givnum, integer *ldgnum, real *poles, real *
difl, real *difr, real *z__, integer *k, real *c__, real *s, real *
work, integer *info)
{
/* System generated locals */
integer givcol_dim1, givcol_offset, b_dim1, b_offset, bx_dim1, bx_offset,
difr_dim1, difr_offset, givnum_dim1, givnum_offset, poles_dim1,
poles_offset, i__1, i__2;
real r__1;
/* Local variables */
static integer i__, j, m, n;
static real dj;
static integer nlp1;
static real temp;
extern /* Subroutine */ int srot_(integer *, real *, integer *, real *,
integer *, real *, real *);
extern doublereal snrm2_(integer *, real *, integer *);
static real diflj, difrj, dsigj;
extern /* Subroutine */ int sscal_(integer *, real *, real *, integer *),
sgemv_(char *, integer *, integer *, real *, real *, integer *,
real *, integer *, real *, real *, integer *, ftnlen), scopy_(
integer *, real *, integer *, real *, integer *);
extern doublereal slamc3_(real *, real *);
extern /* Subroutine */ int xerbla_(char *, integer *, ftnlen);
static real dsigjp;
extern /* Subroutine */ int slascl_(char *, integer *, integer *, real *,
real *, integer *, integer *, real *, integer *, integer *,
ftnlen), slacpy_(char *, integer *, integer *, real *, integer *,
real *, integer *, ftnlen);
/* -- LAPACK routine (version 3.0) -- */
/* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., */
/* Courant Institute, Argonne National Lab, and Rice University */
/* December 1, 1999 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* SLALS0 applies back the multiplying factors of either the left or the */
/* right singular vector matrix of a diagonal matrix appended by a row */
/* to the right hand side matrix B in solving the least squares problem */
/* using the divide-and-conquer SVD approach. */
/* For the left singular vector matrix, three types of orthogonal */
/* matrices are involved: */
/* (1L) Givens rotations: the number of such rotations is GIVPTR; the */
/* pairs of columns/rows they were applied to are stored in GIVCOL; */
/* and the C- and S-values of these rotations are stored in GIVNUM. */
/* (2L) Permutation. The (NL+1)-st row of B is to be moved to the first */
/* row, and for J=2:N, PERM(J)-th row of B is to be moved to the */
/* J-th row. */
/* (3L) The left singular vector matrix of the remaining matrix. */
/* For the right singular vector matrix, four types of orthogonal */
/* matrices are involved: */
/* (1R) The right singular vector matrix of the remaining matrix. */
/* (2R) If SQRE = 1, one extra Givens rotation to generate the right */
/* null space. */
/* (3R) The inverse transformation of (2L). */
/* (4R) The inverse transformation of (1L). */
/* Arguments */
/* ========= */
/* ICOMPQ (input) INTEGER */
/* Specifies whether singular vectors are to be computed in */
/* factored form: */
/* = 0: Left singular vector matrix. */
/* = 1: Right singular vector matrix. */
/* NL (input) INTEGER */
/* The row dimension of the upper block. NL >= 1. */
/* NR (input) INTEGER */
/* The row dimension of the lower block. NR >= 1. */
/* SQRE (input) INTEGER */
/* = 0: the lower block is an NR-by-NR square matrix. */
/* = 1: the lower block is an NR-by-(NR+1) rectangular matrix. */
/* The bidiagonal matrix has row dimension N = NL + NR + 1, */
/* and column dimension M = N + SQRE. */
/* NRHS (input) INTEGER */
/* The number of columns of B and BX. NRHS must be at least 1. */
/* B (input/output) REAL array, dimension ( LDB, NRHS ) */
/* On input, B contains the right hand sides of the least */
/* squares problem in rows 1 through M. On output, B contains */
/* the solution X in rows 1 through N. */
/* LDB (input) INTEGER */
/* The leading dimension of B. LDB must be at least */
/* max(1,MAX( M, N ) ). */
/* BX (workspace) REAL array, dimension ( LDBX, NRHS ) */
/* LDBX (input) INTEGER */
/* The leading dimension of BX. */
/* PERM (input) INTEGER array, dimension ( N ) */
/* The permutations (from deflation and sorting) applied */
/* to the two blocks. */
/* GIVPTR (input) INTEGER */
/* The number of Givens rotations which took place in this */
/* subproblem. */
/* GIVCOL (input) INTEGER array, dimension ( LDGCOL, 2 ) */
/* Each pair of numbers indicates a pair of rows/columns */
/* involved in a Givens rotation. */
/* LDGCOL (input) INTEGER */
/* The leading dimension of GIVCOL, must be at least N. */
/* GIVNUM (input) REAL array, dimension ( LDGNUM, 2 ) */
/* Each number indicates the C or S value used in the */
/* corresponding Givens rotation. */
/* LDGNUM (input) INTEGER */
/* The leading dimension of arrays DIFR, POLES and */
/* GIVNUM, must be at least K. */
/* POLES (input) REAL array, dimension ( LDGNUM, 2 ) */
/* On entry, POLES(1:K, 1) contains the new singular */
/* values obtained from solving the secular equation, and */
/* POLES(1:K, 2) is an array containing the poles in the secular */
/* equation. */
/* DIFL (input) REAL array, dimension ( K ). */
/* On entry, DIFL(I) is the distance between I-th updated */
/* (undeflated) singular value and the I-th (undeflated) old */
/* singular value. */
/* DIFR (input) REAL array, dimension ( LDGNUM, 2 ). */
/* On entry, DIFR(I, 1) contains the distances between I-th */
/* updated (undeflated) singular value and the I+1-th */
/* (undeflated) old singular value. And DIFR(I, 2) is the */
/* normalizing factor for the I-th right singular vector. */
/* Z (input) REAL array, dimension ( K ) */
/* Contain the components of the deflation-adjusted updating row */
/* vector. */
/* K (input) INTEGER */
/* Contains the dimension of the non-deflated matrix, */
/* This is the order of the related secular equation. 1 <= K <=N. */
/* C (input) REAL */
/* C contains garbage if SQRE =0 and the C-value of a Givens */
/* rotation related to the right null space if SQRE = 1. */
/* S (input) REAL */
/* S contains garbage if SQRE =0 and the S-value of a Givens */
/* rotation related to the right null space if SQRE = 1. */
/* WORK (workspace) REAL array, dimension ( K ) */
/* INFO (output) INTEGER */
/* = 0: successful exit. */
/* < 0: if INFO = -i, the i-th argument had an illegal value. */
/* Further Details */
/* =============== */
/* Based on contributions by */
/* Ming Gu and Ren-Cang Li, Computer Science Division, University of */
/* California at Berkeley, USA */
/* Osni Marques, LBNL/NERSC, USA */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. Executable Statements .. */
/* Test the input parameters. */
/* Parameter adjustments */
b_dim1 = *ldb;
b_offset = 1 + b_dim1;
b -= b_offset;
bx_dim1 = *ldbx;
bx_offset = 1 + bx_dim1;
bx -= bx_offset;
--perm;
givcol_dim1 = *ldgcol;
givcol_offset = 1 + givcol_dim1;
givcol -= givcol_offset;
difr_dim1 = *ldgnum;
difr_offset = 1 + difr_dim1;
difr -= difr_offset;
poles_dim1 = *ldgnum;
poles_offset = 1 + poles_dim1;
poles -= poles_offset;
givnum_dim1 = *ldgnum;
givnum_offset = 1 + givnum_dim1;
givnum -= givnum_offset;
--difl;
--z__;
--work;
/* Function Body */
*info = 0;
if (*icompq < 0 || *icompq > 1) {
*info = -1;
} else if (*nl < 1) {
*info = -2;
} else if (*nr < 1) {
*info = -3;
} else if (*sqre < 0 || *sqre > 1) {
*info = -4;
}
n = *nl + *nr + 1;
if (*nrhs < 1) {
*info = -5;
} else if (*ldb < n) {
*info = -7;
} else if (*ldbx < n) {
*info = -9;
} else if (*givptr < 0) {
*info = -11;
} else if (*ldgcol < n) {
*info = -13;
} else if (*ldgnum < n) {
*info = -15;
} else if (*k < 1) {
*info = -20;
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("SLALS0", &i__1, (ftnlen)6);
return 0;
}
m = n + *sqre;
nlp1 = *nl + 1;
if (*icompq == 0) {
/* Apply back orthogonal transformations from the left. */
/* Step (1L): apply back the Givens rotations performed. */
i__1 = *givptr;
for (i__ = 1; i__ <= i__1; ++i__) {
srot_(nrhs, &b[givcol[i__ + (givcol_dim1 << 1)] + b_dim1], ldb, &
b[givcol[i__ + givcol_dim1] + b_dim1], ldb, &givnum[i__ +
(givnum_dim1 << 1)], &givnum[i__ + givnum_dim1]);
/* L10: */
}
/* Step (2L): permute rows of B. */
scopy_(nrhs, &b[nlp1 + b_dim1], ldb, &bx[bx_dim1 + 1], ldbx);
i__1 = n;
for (i__ = 2; i__ <= i__1; ++i__) {
scopy_(nrhs, &b[perm[i__] + b_dim1], ldb, &bx[i__ + bx_dim1],
ldbx);
/* L20: */
}
/* Step (3L): apply the inverse of the left singular vector */
/* matrix to BX. */
if (*k == 1) {
scopy_(nrhs, &bx[bx_offset], ldbx, &b[b_offset], ldb);
if (z__[1] < 0.f) {
sscal_(nrhs, &c_b5, &b[b_offset], ldb);
}
} else {
i__1 = *k;
for (j = 1; j <= i__1; ++j) {
diflj = difl[j];
dj = poles[j + poles_dim1];
dsigj = -poles[j + (poles_dim1 << 1)];
if (j < *k) {
difrj = -difr[j + difr_dim1];
dsigjp = -poles[j + 1 + (poles_dim1 << 1)];
}
if (z__[j] == 0.f || poles[j + (poles_dim1 << 1)] == 0.f) {
work[j] = 0.f;
} else {
work[j] = -poles[j + (poles_dim1 << 1)] * z__[j] / diflj /
(poles[j + (poles_dim1 << 1)] + dj);
}
i__2 = j - 1;
for (i__ = 1; i__ <= i__2; ++i__) {
if (z__[i__] == 0.f || poles[i__ + (poles_dim1 << 1)] ==
0.f) {
work[i__] = 0.f;
} else {
work[i__] = poles[i__ + (poles_dim1 << 1)] * z__[i__]
/ (slamc3_(&poles[i__ + (poles_dim1 << 1)], &
dsigj) - diflj) / (poles[i__ + (poles_dim1 <<
1)] + dj);
}
/* L30: */
}
i__2 = *k;
for (i__ = j + 1; i__ <= i__2; ++i__) {
if (z__[i__] == 0.f || poles[i__ + (poles_dim1 << 1)] ==
0.f) {
work[i__] = 0.f;
} else {
work[i__] = poles[i__ + (poles_dim1 << 1)] * z__[i__]
/ (slamc3_(&poles[i__ + (poles_dim1 << 1)], &
dsigjp) + difrj) / (poles[i__ + (poles_dim1 <<
1)] + dj);
}
/* L40: */
}
work[1] = -1.f;
temp = snrm2_(k, &work[1], &c__1);
sgemv_("T", k, nrhs, &c_b11, &bx[bx_offset], ldbx, &work[1], &
c__1, &c_b13, &b[j + b_dim1], ldb, (ftnlen)1);
slascl_("G", &c__0, &c__0, &temp, &c_b11, &c__1, nrhs, &b[j +
b_dim1], ldb, info, (ftnlen)1);
/* L50: */
}
}
/* Move the deflated rows of BX to B also. */
if (*k < max(m,n)) {
i__1 = n - *k;
slacpy_("A", &i__1, nrhs, &bx[*k + 1 + bx_dim1], ldbx, &b[*k + 1
+ b_dim1], ldb, (ftnlen)1);
}
} else {
/* Apply back the right orthogonal transformations. */
/* Step (1R): apply back the new right singular vector matrix */
/* to B. */
if (*k == 1) {
scopy_(nrhs, &b[b_offset], ldb, &bx[bx_offset], ldbx);
} else {
i__1 = *k;
for (j = 1; j <= i__1; ++j) {
dsigj = poles[j + (poles_dim1 << 1)];
if (z__[j] == 0.f) {
work[j] = 0.f;
} else {
work[j] = -z__[j] / difl[j] / (dsigj + poles[j +
poles_dim1]) / difr[j + (difr_dim1 << 1)];
}
i__2 = j - 1;
for (i__ = 1; i__ <= i__2; ++i__) {
if (z__[j] == 0.f) {
work[i__] = 0.f;
} else {
r__1 = -poles[i__ + 1 + (poles_dim1 << 1)];
work[i__] = z__[j] / (slamc3_(&dsigj, &r__1) - difr[
i__ + difr_dim1]) / (dsigj + poles[i__ +
poles_dim1]) / difr[i__ + (difr_dim1 << 1)];
}
/* L60: */
}
i__2 = *k;
for (i__ = j + 1; i__ <= i__2; ++i__) {
if (z__[j] == 0.f) {
work[i__] = 0.f;
} else {
r__1 = -poles[i__ + (poles_dim1 << 1)];
work[i__] = z__[j] / (slamc3_(&dsigj, &r__1) - difl[
i__]) / (dsigj + poles[i__ + poles_dim1]) /
difr[i__ + (difr_dim1 << 1)];
}
/* L70: */
}
sgemv_("T", k, nrhs, &c_b11, &b[b_offset], ldb, &work[1], &
c__1, &c_b13, &bx[j + bx_dim1], ldbx, (ftnlen)1);
/* L80: */
}
}
/* Step (2R): if SQRE = 1, apply back the rotation that is */
/* related to the right null space of the subproblem. */
if (*sqre == 1) {
scopy_(nrhs, &b[m + b_dim1], ldb, &bx[m + bx_dim1], ldbx);
srot_(nrhs, &bx[bx_dim1 + 1], ldbx, &bx[m + bx_dim1], ldbx, c__,
s);
}
if (*k < max(m,n)) {
i__1 = n - *k;
slacpy_("A", &i__1, nrhs, &b[*k + 1 + b_dim1], ldb, &bx[*k + 1 +
bx_dim1], ldbx, (ftnlen)1);
}
/* Step (3R): permute rows of B. */
scopy_(nrhs, &bx[bx_dim1 + 1], ldbx, &b[nlp1 + b_dim1], ldb);
if (*sqre == 1) {
scopy_(nrhs, &bx[m + bx_dim1], ldbx, &b[m + b_dim1], ldb);
}
i__1 = n;
for (i__ = 2; i__ <= i__1; ++i__) {
scopy_(nrhs, &bx[i__ + bx_dim1], ldbx, &b[perm[i__] + b_dim1],
ldb);
/* L90: */
}
/* Step (4R): apply back the Givens rotations performed. */
for (i__ = *givptr; i__ >= 1; --i__) {
r__1 = -givnum[i__ + givnum_dim1];
srot_(nrhs, &b[givcol[i__ + (givcol_dim1 << 1)] + b_dim1], ldb, &
b[givcol[i__ + givcol_dim1] + b_dim1], ldb, &givnum[i__ +
(givnum_dim1 << 1)], &r__1);
/* L100: */
}
}
return 0;
/* End of SLALS0 */
} /* slals0_ */
/* Subroutine */
int sggsvp_(char *jobu, char *jobv, char *jobq, integer *m, integer *p, integer *n, real *a, integer *lda, real *b, integer *ldb, real *tola, real *tolb, integer *k, integer *l, real *u, integer *ldu, real *v, integer *ldv, real *q, integer *ldq, integer *iwork, real * tau, real *work, integer *info)
{
/* System generated locals */
integer a_dim1, a_offset, b_dim1, b_offset, q_dim1, q_offset, u_dim1, u_offset, v_dim1, v_offset, i__1, i__2, i__3;
real r__1;
/* Local variables */
integer i__, j;
extern logical lsame_(char *, char *);
logical wantq, wantu, wantv;
extern /* Subroutine */
int 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 * ), 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 *), xerbla_(char *, integer *), sgeqpf_( integer *, integer *, real *, integer *, integer *, real *, real * , integer *), slacpy_(char *, integer *, integer *, real *, integer *, real *, integer *), slaset_(char *, integer *, integer *, real *, real *, real *, integer *), slapmt_( logical *, integer *, integer *, real *, integer *, integer *);
logical forwrd;
/* -- LAPACK computational routine (version 3.4.0) -- */
/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */
/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */
/* November 2011 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Executable Statements .. */
/* Test the 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;
u_dim1 = *ldu;
u_offset = 1 + u_dim1;
u -= u_offset;
v_dim1 = *ldv;
v_offset = 1 + v_dim1;
v -= v_offset;
q_dim1 = *ldq;
q_offset = 1 + q_dim1;
q -= q_offset;
--iwork;
--tau;
--work;
/* Function Body */
wantu = lsame_(jobu, "U");
wantv = lsame_(jobv, "V");
wantq = lsame_(jobq, "Q");
forwrd = TRUE_;
*info = 0;
if (! (wantu || lsame_(jobu, "N")))
{
*info = -1;
}
else if (! (wantv || lsame_(jobv, "N")))
{
*info = -2;
}
else if (! (wantq || lsame_(jobq, "N")))
{
*info = -3;
}
else if (*m < 0)
{
*info = -4;
}
else if (*p < 0)
{
*info = -5;
}
else if (*n < 0)
{
*info = -6;
}
else if (*lda < max(1,*m))
{
*info = -8;
}
else if (*ldb < max(1,*p))
{
*info = -10;
}
else if (*ldu < 1 || wantu && *ldu < *m)
{
*info = -16;
}
else if (*ldv < 1 || wantv && *ldv < *p)
{
*info = -18;
}
else if (*ldq < 1 || wantq && *ldq < *n)
{
*info = -20;
}
if (*info != 0)
{
i__1 = -(*info);
xerbla_("SGGSVP", &i__1);
return 0;
}
/* QR with column pivoting of B: B*P = V*( S11 S12 ) */
/* ( 0 0 ) */
i__1 = *n;
for (i__ = 1;
i__ <= i__1;
++i__)
{
iwork[i__] = 0;
/* L10: */
}
sgeqpf_(p, n, &b[b_offset], ldb, &iwork[1], &tau[1], &work[1], info);
/* Update A := A*P */
slapmt_(&forwrd, m, n, &a[a_offset], lda, &iwork[1]);
/* Determine the effective rank of matrix B. */
*l = 0;
i__1 = min(*p,*n);
for (i__ = 1;
i__ <= i__1;
++i__)
{
if ((r__1 = b[i__ + i__ * b_dim1], f2c_abs(r__1)) > *tolb)
{
++(*l);
}
/* L20: */
}
if (wantv)
{
/* Copy the details of V, and form V. */
slaset_("Full", p, p, &c_b12, &c_b12, &v[v_offset], ldv);
if (*p > 1)
{
i__1 = *p - 1;
slacpy_("Lower", &i__1, n, &b[b_dim1 + 2], ldb, &v[v_dim1 + 2], ldv);
}
i__1 = min(*p,*n);
sorg2r_(p, p, &i__1, &v[v_offset], ldv, &tau[1], &work[1], info);
}
/* Clean up B */
i__1 = *l - 1;
for (j = 1;
j <= i__1;
++j)
{
i__2 = *l;
for (i__ = j + 1;
i__ <= i__2;
++i__)
{
b[i__ + j * b_dim1] = 0.f;
/* L30: */
}
/* L40: */
}
if (*p > *l)
{
i__1 = *p - *l;
slaset_("Full", &i__1, n, &c_b12, &c_b12, &b[*l + 1 + b_dim1], ldb);
}
if (wantq)
{
/* Set Q = I and Update Q := Q*P */
slaset_("Full", n, n, &c_b12, &c_b22, &q[q_offset], ldq);
slapmt_(&forwrd, n, n, &q[q_offset], ldq, &iwork[1]);
}
if (*p >= *l && *n != *l)
{
/* RQ factorization of (S11 S12): ( S11 S12 ) = ( 0 S12 )*Z */
sgerq2_(l, n, &b[b_offset], ldb, &tau[1], &work[1], info);
/* Update A := A*Z**T */
sormr2_("Right", "Transpose", m, n, l, &b[b_offset], ldb, &tau[1], &a[ a_offset], lda, &work[1], info);
if (wantq)
{
/* Update Q := Q*Z**T */
sormr2_("Right", "Transpose", n, n, l, &b[b_offset], ldb, &tau[1], &q[q_offset], ldq, &work[1], info);
}
/* Clean up B */
i__1 = *n - *l;
slaset_("Full", l, &i__1, &c_b12, &c_b12, &b[b_offset], ldb);
i__1 = *n;
for (j = *n - *l + 1;
j <= i__1;
++j)
{
i__2 = *l;
for (i__ = j - *n + *l + 1;
i__ <= i__2;
++i__)
{
b[i__ + j * b_dim1] = 0.f;
/* L50: */
}
/* L60: */
}
}
/* Let N-L L */
/* A = ( A11 A12 ) M, */
/* then the following does the complete QR decomposition of A11: */
/* A11 = U*( 0 T12 )*P1**T */
/* ( 0 0 ) */
i__1 = *n - *l;
for (i__ = 1;
i__ <= i__1;
++i__)
{
iwork[i__] = 0;
/* L70: */
}
i__1 = *n - *l;
sgeqpf_(m, &i__1, &a[a_offset], lda, &iwork[1], &tau[1], &work[1], info);
/* Determine the effective rank of A11 */
*k = 0;
/* Computing MIN */
i__2 = *m;
i__3 = *n - *l; // , expr subst
i__1 = min(i__2,i__3);
for (i__ = 1;
i__ <= i__1;
++i__)
{
if ((r__1 = a[i__ + i__ * a_dim1], f2c_abs(r__1)) > *tola)
{
++(*k);
}
/* L80: */
}
/* Update A12 := U**T*A12, where A12 = A( 1:M, N-L+1:N ) */
/* Computing MIN */
i__2 = *m;
i__3 = *n - *l; // , expr subst
i__1 = min(i__2,i__3);
sorm2r_("Left", "Transpose", m, l, &i__1, &a[a_offset], lda, &tau[1], &a[( *n - *l + 1) * a_dim1 + 1], lda, &work[1], info);
if (wantu)
{
/* Copy the details of U, and form U */
slaset_("Full", m, m, &c_b12, &c_b12, &u[u_offset], ldu);
if (*m > 1)
{
i__1 = *m - 1;
i__2 = *n - *l;
slacpy_("Lower", &i__1, &i__2, &a[a_dim1 + 2], lda, &u[u_dim1 + 2] , ldu);
}
/* Computing MIN */
i__2 = *m;
i__3 = *n - *l; // , expr subst
i__1 = min(i__2,i__3);
sorg2r_(m, m, &i__1, &u[u_offset], ldu, &tau[1], &work[1], info);
}
if (wantq)
{
/* Update Q( 1:N, 1:N-L ) = Q( 1:N, 1:N-L )*P1 */
i__1 = *n - *l;
slapmt_(&forwrd, n, &i__1, &q[q_offset], ldq, &iwork[1]);
}
/* Clean up A: set the strictly lower triangular part of */
/* A(1:K, 1:K) = 0, and A( K+1:M, 1:N-L ) = 0. */
i__1 = *k - 1;
for (j = 1;
j <= i__1;
++j)
{
i__2 = *k;
for (i__ = j + 1;
i__ <= i__2;
++i__)
{
a[i__ + j * a_dim1] = 0.f;
/* L90: */
}
/* L100: */
}
if (*m > *k)
{
i__1 = *m - *k;
i__2 = *n - *l;
slaset_("Full", &i__1, &i__2, &c_b12, &c_b12, &a[*k + 1 + a_dim1], lda);
}
if (*n - *l > *k)
{
/* RQ factorization of ( T11 T12 ) = ( 0 T12 )*Z1 */
i__1 = *n - *l;
sgerq2_(k, &i__1, &a[a_offset], lda, &tau[1], &work[1], info);
if (wantq)
{
/* Update Q( 1:N,1:N-L ) = Q( 1:N,1:N-L )*Z1**T */
i__1 = *n - *l;
sormr2_("Right", "Transpose", n, &i__1, k, &a[a_offset], lda, & tau[1], &q[q_offset], ldq, &work[1], info);
}
/* Clean up A */
i__1 = *n - *l - *k;
slaset_("Full", k, &i__1, &c_b12, &c_b12, &a[a_offset], lda);
i__1 = *n - *l;
for (j = *n - *l - *k + 1;
j <= i__1;
++j)
{
i__2 = *k;
for (i__ = j - *n + *l + *k + 1;
i__ <= i__2;
++i__)
{
a[i__ + j * a_dim1] = 0.f;
/* L110: */
}
/* L120: */
}
}
if (*m > *k)
{
/* QR factorization of A( K+1:M,N-L+1:N ) */
i__1 = *m - *k;
sgeqr2_(&i__1, l, &a[*k + 1 + (*n - *l + 1) * a_dim1], lda, &tau[1], & work[1], info);
if (wantu)
{
/* Update U(:,K+1:M) := U(:,K+1:M)*U1 */
i__1 = *m - *k;
/* Computing MIN */
i__3 = *m - *k;
i__2 = min(i__3,*l);
sorm2r_("Right", "No transpose", m, &i__1, &i__2, &a[*k + 1 + (*n - *l + 1) * a_dim1], lda, &tau[1], &u[(*k + 1) * u_dim1 + 1], ldu, &work[1], info);
}
/* Clean up */
i__1 = *n;
for (j = *n - *l + 1;
j <= i__1;
++j)
{
i__2 = *m;
for (i__ = j - *n + *k + *l + 1;
i__ <= i__2;
++i__)
{
a[i__ + j * a_dim1] = 0.f;
/* L130: */
}
/* L140: */
}
}
return 0;
/* End of SGGSVP */
}
/* Subroutine */ int ssbevx_(char *jobz, char *range, char *uplo, integer *n,
integer *kd, real *ab, integer *ldab, real *q, integer *ldq, real *vl,
real *vu, integer *il, integer *iu, real *abstol, integer *m, real *
w, real *z, integer *ldz, real *work, integer *iwork, integer *ifail,
integer *info)
{
/* -- LAPACK driver routine (version 2.0) --
Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
Courant Institute, Argonne National Lab, and Rice University
September 30, 1994
Purpose
=======
SSBEVX computes selected eigenvalues and, optionally, eigenvectors
of a real symmetric band matrix A. Eigenvalues and eigenvectors can
be selected by specifying either a range of values or a range of
indices for the desired eigenvalues.
Arguments
=========
JOBZ (input) CHARACTER*1
= 'N': Compute eigenvalues only;
= 'V': Compute eigenvalues and eigenvectors.
RANGE (input) CHARACTER*1
= 'A': all eigenvalues will be found;
= 'V': all eigenvalues in the half-open interval (VL,VU]
will be found;
= 'I': the IL-th through IU-th eigenvalues will be found.
UPLO (input) CHARACTER*1
= 'U': Upper triangle of A is stored;
= 'L': Lower triangle of A is stored.
N (input) INTEGER
The order of the matrix A. N >= 0.
KD (input) INTEGER
The number of superdiagonals of the matrix A if UPLO = 'U',
or the number of subdiagonals if UPLO = 'L'. KD >= 0.
AB (input/output) REAL array, dimension (LDAB, N)
On entry, the upper or lower triangle of the symmetric band
matrix A, stored in the first KD+1 rows of the array. The
j-th column of A is stored in the j-th column of the array AB
as follows:
if UPLO = 'U', AB(kd+1+i-j,j) = A(i,j) for max(1,j-kd)<=i<=j;
if UPLO = 'L', AB(1+i-j,j) = A(i,j) for j<=i<=min(n,j+kd).
On exit, AB is overwritten by values generated during the
reduction to tridiagonal form. If UPLO = 'U', the first
superdiagonal and the diagonal of the tridiagonal matrix T
are returned in rows KD and KD+1 of AB, and if UPLO = 'L',
the diagonal and first subdiagonal of T are returned in the
first two rows of AB.
LDAB (input) INTEGER
The leading dimension of the array AB. LDAB >= KD + 1.
Q (output) REAL array, dimension (LDQ, N)
If JOBZ = 'V', the N-by-N orthogonal matrix used in the
reduction to tridiagonal form.
If JOBZ = 'N', the array Q is not referenced.
LDQ (input) INTEGER
The leading dimension of the array Q. If JOBZ = 'V', then
LDQ >= max(1,N).
VL (input) REAL
VU (input) REAL
If RANGE='V', the lower and upper bounds of the interval to
be searched for eigenvalues. VL < VU.
Not referenced if RANGE = 'A' or 'I'.
IL (input) INTEGER
IU (input) INTEGER
If RANGE='I', the indices (in ascending order) of the
smallest and largest eigenvalues to be returned.
1 <= IL <= IU <= N, if N > 0; IL = 1 and IU = 0 if N = 0.
Not referenced if RANGE = 'A' or 'V'.
ABSTOL (input) REAL
The absolute error tolerance for the eigenvalues.
An approximate eigenvalue is accepted as converged
when it is determined to lie in an interval [a,b]
of width less than or equal to
ABSTOL + EPS * max( |a|,|b| ) ,
where EPS is the machine precision. If ABSTOL is less than
or equal to zero, then EPS*|T| will be used in its place,
where |T| is the 1-norm of the tridiagonal matrix obtained
by reducing AB to tridiagonal form.
Eigenvalues will be computed most accurately when ABSTOL is
set to twice the underflow threshold 2*SLAMCH('S'), not zero.
If this routine returns with INFO>0, indicating that some
eigenvectors did not converge, try setting ABSTOL to
2*SLAMCH('S').
See "Computing Small Singular Values of Bidiagonal Matrices
with Guaranteed High Relative Accuracy," by Demmel and
Kahan, LAPACK Working Note #3.
M (output) INTEGER
The total number of eigenvalues found. 0 <= M <= N.
If RANGE = 'A', M = N, and if RANGE = 'I', M = IU-IL+1.
W (output) REAL array, dimension (N)
The first M elements contain the selected eigenvalues in
ascending order.
Z (output) REAL array, dimension (LDZ, max(1,M))
If JOBZ = 'V', then if INFO = 0, the first M columns of Z
contain the orthonormal eigenvectors of the matrix A
corresponding to the selected eigenvalues, with the i-th
column of Z holding the eigenvector associated with W(i).
If an eigenvector fails to converge, then that column of Z
contains the latest approximation to the eigenvector, and the
index of the eigenvector is returned in IFAIL.
If JOBZ = 'N', then Z is not referenced.
Note: the user must ensure that at least max(1,M) columns are
supplied in the array Z; if RANGE = 'V', the exact value of M
is not known in advance and an upper bound must be used.
LDZ (input) INTEGER
The leading dimension of the array Z. LDZ >= 1, and if
JOBZ = 'V', LDZ >= max(1,N).
WORK (workspace) REAL array, dimension (7*N)
IWORK (workspace) INTEGER array, dimension (5*N)
IFAIL (output) INTEGER array, dimension (N)
If JOBZ = 'V', then if INFO = 0, the first M elements of
IFAIL are zero. If INFO > 0, then IFAIL contains the
indices of the eigenvectors that failed to converge.
If JOBZ = 'N', then IFAIL is not referenced.
INFO (output) INTEGER
= 0: successful exit.
< 0: if INFO = -i, the i-th argument had an illegal value.
> 0: if INFO = i, then i eigenvectors failed to converge.
Their indices are stored in array IFAIL.
=====================================================================
Test the input parameters.
Parameter adjustments
Function Body */
/* Table of constant values */
static real c_b14 = 1.f;
static integer c__1 = 1;
static real c_b34 = 0.f;
/* System generated locals */
integer ab_dim1, ab_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 integer indd, inde;
static real anrm;
static integer imax;
static real rmin, rmax;
static integer itmp1, i, j, indee;
static real sigma;
extern logical lsame_(char *, char *);
static integer iinfo;
extern /* Subroutine */ int sscal_(integer *, real *, real *, integer *);
static char order[1];
extern /* Subroutine */ int sgemv_(char *, integer *, integer *, real *,
real *, integer *, real *, integer *, real *, real *, integer *);
static logical lower;
extern /* Subroutine */ int scopy_(integer *, real *, integer *, real *,
integer *), sswap_(integer *, real *, integer *, real *, integer *
);
static logical wantz;
static integer jj;
static logical alleig, indeig;
static integer iscale, indibl;
static logical valeig;
extern doublereal slamch_(char *);
static real safmin;
extern /* Subroutine */ int xerbla_(char *, integer *);
static real abstll, bignum;
extern doublereal slansb_(char *, char *, integer *, integer *, real *,
integer *, real *);
extern /* Subroutine */ int slascl_(char *, integer *, integer *, real *,
real *, integer *, integer *, real *, integer *, integer *);
static integer indisp, indiwo;
extern /* Subroutine */ int slacpy_(char *, integer *, integer *, real *,
integer *, real *, integer *);
static integer indwrk;
extern /* Subroutine */ int ssbtrd_(char *, char *, integer *, integer *,
real *, integer *, real *, real *, real *, integer *, real *,
integer *), sstein_(integer *, real *, real *,
integer *, real *, integer *, integer *, real *, integer *, real *
, integer *, integer *, integer *), ssterf_(integer *, real *,
real *, integer *);
static integer nsplit;
static real smlnum;
extern /* Subroutine */ int sstebz_(char *, char *, integer *, real *,
real *, integer *, integer *, real *, real *, real *, integer *,
integer *, real *, integer *, integer *, real *, integer *,
integer *), ssteqr_(char *, integer *, real *,
real *, real *, integer *, real *, integer *);
static real eps, vll, vuu, tmp1;
#define W(I) w[(I)-1]
#define WORK(I) work[(I)-1]
#define IWORK(I) iwork[(I)-1]
#define IFAIL(I) ifail[(I)-1]
#define AB(I,J) ab[(I)-1 + ((J)-1)* ( *ldab)]
#define Q(I,J) q[(I)-1 + ((J)-1)* ( *ldq)]
#define Z(I,J) z[(I)-1 + ((J)-1)* ( *ldz)]
wantz = lsame_(jobz, "V");
alleig = lsame_(range, "A");
valeig = lsame_(range, "V");
indeig = lsame_(range, "I");
lower = lsame_(uplo, "L");
*info = 0;
if (! (wantz || lsame_(jobz, "N"))) {
*info = -1;
} else if (! (alleig || valeig || indeig)) {
*info = -2;
} else if (! (lower || lsame_(uplo, "U"))) {
*info = -3;
} else if (*n < 0) {
*info = -4;
} else if (*kd < 0) {
*info = -5;
} else if (*ldab < *kd + 1) {
*info = -7;
} else if (*ldq < *n) {
*info = -9;
} else if (valeig && *n > 0 && *vu <= *vl) {
*info = -11;
} else if (indeig && *il < 1) {
*info = -12;
} else if (indeig && (*iu < min(*n,*il) || *iu > *n)) {
*info = -13;
} else if (*ldz < 1 || wantz && *ldz < *n) {
*info = -18;
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("SSBEVX", &i__1);
return 0;
}
/* Quick return if possible */
*m = 0;
if (*n == 0) {
return 0;
}
if (*n == 1) {
if (alleig || indeig) {
*m = 1;
W(1) = AB(1,1);
} else {
if (*vl < AB(1,1) && *vu >= AB(1,1)) {
*m = 1;
W(1) = AB(1,1);
}
}
if (wantz) {
Z(1,1) = 1.f;
}
return 0;
}
/* Get machine constants. */
safmin = slamch_("Safe minimum");
eps = slamch_("Precision");
smlnum = safmin / eps;
bignum = 1.f / smlnum;
rmin = sqrt(smlnum);
/* Computing MIN */
r__1 = sqrt(bignum), r__2 = 1.f / sqrt(sqrt(safmin));
rmax = dmin(r__1,r__2);
/* Scale matrix to allowable range, if necessary. */
iscale = 0;
abstll = *abstol;
if (valeig) {
vll = *vl;
vuu = *vu;
}
anrm = slansb_("M", uplo, n, kd, &AB(1,1), ldab, &WORK(1));
if (anrm > 0.f && anrm < rmin) {
iscale = 1;
sigma = rmin / anrm;
} else if (anrm > rmax) {
iscale = 1;
sigma = rmax / anrm;
}
if (iscale == 1) {
if (lower) {
slascl_("B", kd, kd, &c_b14, &sigma, n, n, &AB(1,1), ldab,
info);
} else {
slascl_("Q", kd, kd, &c_b14, &sigma, n, n, &AB(1,1), ldab,
info);
}
if (*abstol > 0.f) {
abstll = *abstol * sigma;
}
if (valeig) {
vll = *vl * sigma;
vuu = *vu * sigma;
}
}
/* Call SSBTRD to reduce symmetric band matrix to tridiagonal form. */
indd = 1;
inde = indd + *n;
indwrk = inde + *n;
ssbtrd_(jobz, uplo, n, kd, &AB(1,1), ldab, &WORK(indd), &WORK(inde),
&Q(1,1), ldq, &WORK(indwrk), &iinfo);
/* If all eigenvalues are desired and ABSTOL is less than or equal
to zero, then call SSTERF or SSTEQR. If this fails for some
eigenvalue, then try SSTEBZ. */
if ((alleig || indeig && *il == 1 && *iu == *n) && *abstol <= 0.f) {
scopy_(n, &WORK(indd), &c__1, &W(1), &c__1);
indee = indwrk + (*n << 1);
if (! wantz) {
i__1 = *n - 1;
scopy_(&i__1, &WORK(inde), &c__1, &WORK(indee), &c__1);
ssterf_(n, &W(1), &WORK(indee), info);
} else {
slacpy_("A", n, n, &Q(1,1), ldq, &Z(1,1), ldz);
i__1 = *n - 1;
scopy_(&i__1, &WORK(inde), &c__1, &WORK(indee), &c__1);
ssteqr_(jobz, n, &W(1), &WORK(indee), &Z(1,1), ldz, &WORK(
indwrk), info);
if (*info == 0) {
i__1 = *n;
for (i = 1; i <= *n; ++i) {
IFAIL(i) = 0;
/* L10: */
}
}
}
if (*info == 0) {
*m = *n;
goto L30;
}
*info = 0;
}
/* Otherwise, call SSTEBZ and, if eigenvectors are desired, SSTEIN. */
if (wantz) {
*(unsigned char *)order = 'B';
} else {
*(unsigned char *)order = 'E';
}
indibl = 1;
indisp = indibl + *n;
indiwo = indisp + *n;
sstebz_(range, order, n, &vll, &vuu, il, iu, &abstll, &WORK(indd), &WORK(
inde), m, &nsplit, &W(1), &IWORK(indibl), &IWORK(indisp), &WORK(
indwrk), &IWORK(indiwo), info);
if (wantz) {
sstein_(n, &WORK(indd), &WORK(inde), m, &W(1), &IWORK(indibl), &IWORK(
indisp), &Z(1,1), ldz, &WORK(indwrk), &IWORK(indiwo), &
IFAIL(1), info);
/* Apply orthogonal matrix used in reduction to tridiagonal
form to eigenvectors returned by SSTEIN. */
i__1 = *m;
for (j = 1; j <= *m; ++j) {
scopy_(n, &Z(1,j), &c__1, &WORK(1), &c__1);
sgemv_("N", n, n, &c_b14, &Q(1,1), ldq, &WORK(1), &c__1, &
c_b34, &Z(1,j), &c__1);
/* L20: */
}
}
/* If matrix was scaled, then rescale eigenvalues appropriately. */
L30:
if (iscale == 1) {
if (*info == 0) {
imax = *m;
} else {
imax = *info - 1;
}
r__1 = 1.f / sigma;
sscal_(&imax, &r__1, &W(1), &c__1);
}
/* If eigenvalues are not in order, then sort them, along with
eigenvectors. */
if (wantz) {
i__1 = *m - 1;
for (j = 1; j <= *m-1; ++j) {
i = 0;
tmp1 = W(j);
i__2 = *m;
for (jj = j + 1; jj <= *m; ++jj) {
if (W(jj) < tmp1) {
i = jj;
tmp1 = W(jj);
}
/* L40: */
}
if (i != 0) {
itmp1 = IWORK(indibl + i - 1);
W(i) = W(j);
IWORK(indibl + i - 1) = IWORK(indibl + j - 1);
W(j) = tmp1;
IWORK(indibl + j - 1) = itmp1;
sswap_(n, &Z(1,i), &c__1, &Z(1,j), &
c__1);
if (*info != 0) {
itmp1 = IFAIL(i);
IFAIL(i) = IFAIL(j);
IFAIL(j) = itmp1;
}
}
/* L50: */
}
}
return 0;
/* End of SSBEVX */
} /* ssbevx_ */
/* Subroutine */ int slalsd_(char *uplo, integer *smlsiz, integer *n, integer
*nrhs, real *d__, real *e, real *b, integer *ldb, real *rcond,
integer *rank, real *work, integer *iwork, integer *info)
{
/* System generated locals */
integer b_dim1, b_offset, i__1, i__2;
real r__1;
/* Builtin functions */
double log(doublereal), r_sign(real *, real *);
/* Local variables */
integer c__, i__, j, k;
real r__;
integer s, u, z__;
real cs;
integer bx;
real sn;
integer st, vt, nm1, st1;
real eps;
integer iwk;
real tol;
integer difl, difr;
real rcnd;
integer perm, nsub, nlvl, sqre, bxst;
extern /* Subroutine */ int srot_(integer *, real *, integer *, real *,
integer *, real *, real *), sgemm_(char *, char *, integer *,
integer *, integer *, real *, real *, integer *, real *, integer *
, real *, real *, integer *);
integer poles, sizei, nsize;
extern /* Subroutine */ int scopy_(integer *, real *, integer *, real *,
integer *);
integer nwork, icmpq1, icmpq2;
extern doublereal slamch_(char *);
extern /* Subroutine */ int slasda_(integer *, integer *, integer *,
integer *, real *, real *, real *, integer *, real *, integer *,
real *, real *, real *, real *, integer *, integer *, integer *,
integer *, real *, real *, real *, real *, integer *, integer *),
xerbla_(char *, integer *), slalsa_(integer *, integer *,
integer *, integer *, real *, integer *, real *, integer *, real *
, integer *, real *, integer *, real *, real *, real *, real *,
integer *, integer *, integer *, integer *, real *, real *, real *
, real *, integer *, integer *), slascl_(char *, integer *,
integer *, real *, real *, integer *, integer *, real *, integer *
, integer *);
integer givcol;
extern integer isamax_(integer *, real *, integer *);
extern /* Subroutine */ int slasdq_(char *, integer *, integer *, integer
*, integer *, integer *, real *, real *, real *, integer *, real *
, integer *, real *, integer *, real *, integer *),
slacpy_(char *, integer *, integer *, real *, integer *, real *,
integer *), slartg_(real *, real *, real *, real *, real *
), slaset_(char *, integer *, integer *, real *, real *, real *,
integer *);
real orgnrm;
integer givnum;
extern doublereal slanst_(char *, integer *, real *, real *);
extern /* Subroutine */ int slasrt_(char *, integer *, real *, integer *);
integer givptr, smlszp;
/* -- LAPACK routine (version 3.2) -- */
/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/* November 2006 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* SLALSD uses the singular value decomposition of A to solve the least */
/* squares problem of finding X to minimize the Euclidean norm of each */
/* column of A*X-B, where A is N-by-N upper bidiagonal, and X and B */
/* are N-by-NRHS. The solution X overwrites B. */
/* The singular values of A smaller than RCOND times the largest */
/* singular value are treated as zero in solving the least squares */
/* problem; in this case a minimum norm solution is returned. */
/* The actual singular values are returned in D in ascending order. */
/* This code makes very mild assumptions about floating point */
/* arithmetic. It will work on machines with a guard digit in */
/* add/subtract, or on those binary machines without guard digits */
/* which subtract like the Cray XMP, Cray YMP, Cray C 90, or Cray 2. */
/* It could conceivably fail on hexadecimal or decimal machines */
/* without guard digits, but we know of none. */
/* Arguments */
/* ========= */
/* UPLO (input) CHARACTER*1 */
/* = 'U': D and E define an upper bidiagonal matrix. */
/* = 'L': D and E define a lower bidiagonal matrix. */
/* SMLSIZ (input) INTEGER */
/* The maximum size of the subproblems at the bottom of the */
/* computation tree. */
/* N (input) INTEGER */
/* The dimension of the bidiagonal matrix. N >= 0. */
/* NRHS (input) INTEGER */
/* The number of columns of B. NRHS must be at least 1. */
/* D (input/output) REAL array, dimension (N) */
/* On entry D contains the main diagonal of the bidiagonal */
/* matrix. On exit, if INFO = 0, D contains its singular values. */
/* E (input/output) REAL array, dimension (N-1) */
/* Contains the super-diagonal entries of the bidiagonal matrix. */
/* On exit, E has been destroyed. */
/* B (input/output) REAL array, dimension (LDB,NRHS) */
/* On input, B contains the right hand sides of the least */
/* squares problem. On output, B contains the solution X. */
/* LDB (input) INTEGER */
/* The leading dimension of B in the calling subprogram. */
/* LDB must be at least max(1,N). */
/* RCOND (input) REAL */
/* The singular values of A less than or equal to RCOND times */
/* the largest singular value are treated as zero in solving */
/* the least squares problem. If RCOND is negative, */
/* machine precision is used instead. */
/* For example, if diag(S)*X=B were the least squares problem, */
/* where diag(S) is a diagonal matrix of singular values, the */
/* solution would be X(i) = B(i) / S(i) if S(i) is greater than */
/* RCOND*max(S), and X(i) = 0 if S(i) is less than or equal to */
/* RCOND*max(S). */
/* RANK (output) INTEGER */
/* The number of singular values of A greater than RCOND times */
/* the largest singular value. */
/* WORK (workspace) REAL array, dimension at least */
/* (9*N + 2*N*SMLSIZ + 8*N*NLVL + N*NRHS + (SMLSIZ+1)**2), */
/* where NLVL = max(0, INT(log_2 (N/(SMLSIZ+1))) + 1). */
/* IWORK (workspace) INTEGER array, dimension at least */
/* (3*N*NLVL + 11*N) */
/* INFO (output) INTEGER */
/* = 0: successful exit. */
/* < 0: if INFO = -i, the i-th argument had an illegal value. */
/* > 0: The algorithm failed to compute an singular value while */
/* working on the submatrix lying in rows and columns */
/* INFO/(N+1) through MOD(INFO,N+1). */
/* Further Details */
/* =============== */
/* Based on contributions by */
/* Ming Gu and Ren-Cang Li, Computer Science Division, University of */
/* California at Berkeley, USA */
/* Osni Marques, LBNL/NERSC, USA */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Executable Statements .. */
/* Test the input parameters. */
/* Parameter adjustments */
--d__;
--e;
b_dim1 = *ldb;
b_offset = 1 + b_dim1;
b -= b_offset;
--work;
--iwork;
/* Function Body */
*info = 0;
if (*n < 0) {
*info = -3;
} else if (*nrhs < 1) {
*info = -4;
} else if (*ldb < 1 || *ldb < *n) {
*info = -8;
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("SLALSD", &i__1);
return 0;
}
eps = slamch_("Epsilon");
/* Set up the tolerance. */
if (*rcond <= 0.f || *rcond >= 1.f) {
rcnd = eps;
} else {
rcnd = *rcond;
}
*rank = 0;
/* Quick return if possible. */
if (*n == 0) {
return 0;
} else if (*n == 1) {
if (d__[1] == 0.f) {
slaset_("A", &c__1, nrhs, &c_b6, &c_b6, &b[b_offset], ldb);
} else {
*rank = 1;
slascl_("G", &c__0, &c__0, &d__[1], &c_b11, &c__1, nrhs, &b[
b_offset], ldb, info);
d__[1] = dabs(d__[1]);
}
return 0;
}
/* Rotate the matrix if it is lower bidiagonal. */
if (*(unsigned char *)uplo == 'L') {
i__1 = *n - 1;
for (i__ = 1; i__ <= i__1; ++i__) {
slartg_(&d__[i__], &e[i__], &cs, &sn, &r__);
d__[i__] = r__;
e[i__] = sn * d__[i__ + 1];
d__[i__ + 1] = cs * d__[i__ + 1];
if (*nrhs == 1) {
srot_(&c__1, &b[i__ + b_dim1], &c__1, &b[i__ + 1 + b_dim1], &
c__1, &cs, &sn);
} else {
work[(i__ << 1) - 1] = cs;
work[i__ * 2] = sn;
}
/* L10: */
}
if (*nrhs > 1) {
i__1 = *nrhs;
for (i__ = 1; i__ <= i__1; ++i__) {
i__2 = *n - 1;
for (j = 1; j <= i__2; ++j) {
cs = work[(j << 1) - 1];
sn = work[j * 2];
srot_(&c__1, &b[j + i__ * b_dim1], &c__1, &b[j + 1 + i__ *
b_dim1], &c__1, &cs, &sn);
/* L20: */
}
/* L30: */
}
}
}
/* Scale. */
nm1 = *n - 1;
orgnrm = slanst_("M", n, &d__[1], &e[1]);
if (orgnrm == 0.f) {
slaset_("A", n, nrhs, &c_b6, &c_b6, &b[b_offset], ldb);
return 0;
}
slascl_("G", &c__0, &c__0, &orgnrm, &c_b11, n, &c__1, &d__[1], n, info);
slascl_("G", &c__0, &c__0, &orgnrm, &c_b11, &nm1, &c__1, &e[1], &nm1,
info);
/* If N is smaller than the minimum divide size SMLSIZ, then solve */
/* the problem with another solver. */
if (*n <= *smlsiz) {
nwork = *n * *n + 1;
slaset_("A", n, n, &c_b6, &c_b11, &work[1], n);
slasdq_("U", &c__0, n, n, &c__0, nrhs, &d__[1], &e[1], &work[1], n, &
work[1], n, &b[b_offset], ldb, &work[nwork], info);
if (*info != 0) {
return 0;
}
tol = rcnd * (r__1 = d__[isamax_(n, &d__[1], &c__1)], dabs(r__1));
i__1 = *n;
for (i__ = 1; i__ <= i__1; ++i__) {
if (d__[i__] <= tol) {
slaset_("A", &c__1, nrhs, &c_b6, &c_b6, &b[i__ + b_dim1], ldb);
} else {
slascl_("G", &c__0, &c__0, &d__[i__], &c_b11, &c__1, nrhs, &b[
i__ + b_dim1], ldb, info);
++(*rank);
}
/* L40: */
}
sgemm_("T", "N", n, nrhs, n, &c_b11, &work[1], n, &b[b_offset], ldb, &
c_b6, &work[nwork], n);
slacpy_("A", n, nrhs, &work[nwork], n, &b[b_offset], ldb);
/* Unscale. */
slascl_("G", &c__0, &c__0, &c_b11, &orgnrm, n, &c__1, &d__[1], n,
info);
slasrt_("D", n, &d__[1], info);
slascl_("G", &c__0, &c__0, &orgnrm, &c_b11, n, nrhs, &b[b_offset],
ldb, info);
return 0;
}
/* Book-keeping and setting up some constants. */
nlvl = (integer) (log((real) (*n) / (real) (*smlsiz + 1)) / log(2.f)) + 1;
smlszp = *smlsiz + 1;
u = 1;
vt = *smlsiz * *n + 1;
difl = vt + smlszp * *n;
difr = difl + nlvl * *n;
z__ = difr + (nlvl * *n << 1);
c__ = z__ + nlvl * *n;
s = c__ + *n;
poles = s + *n;
givnum = poles + (nlvl << 1) * *n;
bx = givnum + (nlvl << 1) * *n;
nwork = bx + *n * *nrhs;
sizei = *n + 1;
k = sizei + *n;
givptr = k + *n;
perm = givptr + *n;
givcol = perm + nlvl * *n;
iwk = givcol + (nlvl * *n << 1);
st = 1;
sqre = 0;
icmpq1 = 1;
icmpq2 = 0;
nsub = 0;
i__1 = *n;
for (i__ = 1; i__ <= i__1; ++i__) {
if ((r__1 = d__[i__], dabs(r__1)) < eps) {
d__[i__] = r_sign(&eps, &d__[i__]);
}
/* L50: */
}
i__1 = nm1;
for (i__ = 1; i__ <= i__1; ++i__) {
if ((r__1 = e[i__], dabs(r__1)) < eps || i__ == nm1) {
++nsub;
iwork[nsub] = st;
/* Subproblem found. First determine its size and then */
/* apply divide and conquer on it. */
if (i__ < nm1) {
/* A subproblem with E(I) small for I < NM1. */
nsize = i__ - st + 1;
iwork[sizei + nsub - 1] = nsize;
} else if ((r__1 = e[i__], dabs(r__1)) >= eps) {
/* A subproblem with E(NM1) not too small but I = NM1. */
nsize = *n - st + 1;
iwork[sizei + nsub - 1] = nsize;
} else {
/* A subproblem with E(NM1) small. This implies an */
/* 1-by-1 subproblem at D(N), which is not solved */
/* explicitly. */
nsize = i__ - st + 1;
iwork[sizei + nsub - 1] = nsize;
++nsub;
iwork[nsub] = *n;
iwork[sizei + nsub - 1] = 1;
scopy_(nrhs, &b[*n + b_dim1], ldb, &work[bx + nm1], n);
}
st1 = st - 1;
if (nsize == 1) {
/* This is a 1-by-1 subproblem and is not solved */
/* explicitly. */
scopy_(nrhs, &b[st + b_dim1], ldb, &work[bx + st1], n);
} else if (nsize <= *smlsiz) {
/* This is a small subproblem and is solved by SLASDQ. */
slaset_("A", &nsize, &nsize, &c_b6, &c_b11, &work[vt + st1],
n);
slasdq_("U", &c__0, &nsize, &nsize, &c__0, nrhs, &d__[st], &e[
st], &work[vt + st1], n, &work[nwork], n, &b[st +
b_dim1], ldb, &work[nwork], info);
if (*info != 0) {
return 0;
}
slacpy_("A", &nsize, nrhs, &b[st + b_dim1], ldb, &work[bx +
st1], n);
} else {
/* A large problem. Solve it using divide and conquer. */
slasda_(&icmpq1, smlsiz, &nsize, &sqre, &d__[st], &e[st], &
work[u + st1], n, &work[vt + st1], &iwork[k + st1], &
work[difl + st1], &work[difr + st1], &work[z__ + st1],
&work[poles + st1], &iwork[givptr + st1], &iwork[
givcol + st1], n, &iwork[perm + st1], &work[givnum +
st1], &work[c__ + st1], &work[s + st1], &work[nwork],
&iwork[iwk], info);
if (*info != 0) {
return 0;
}
bxst = bx + st1;
slalsa_(&icmpq2, smlsiz, &nsize, nrhs, &b[st + b_dim1], ldb, &
work[bxst], n, &work[u + st1], n, &work[vt + st1], &
iwork[k + st1], &work[difl + st1], &work[difr + st1],
&work[z__ + st1], &work[poles + st1], &iwork[givptr +
st1], &iwork[givcol + st1], n, &iwork[perm + st1], &
work[givnum + st1], &work[c__ + st1], &work[s + st1],
&work[nwork], &iwork[iwk], info);
if (*info != 0) {
return 0;
}
}
st = i__ + 1;
}
/* L60: */
}
/* Apply the singular values and treat the tiny ones as zero. */
tol = rcnd * (r__1 = d__[isamax_(n, &d__[1], &c__1)], dabs(r__1));
i__1 = *n;
for (i__ = 1; i__ <= i__1; ++i__) {
/* Some of the elements in D can be negative because 1-by-1 */
/* subproblems were not solved explicitly. */
if ((r__1 = d__[i__], dabs(r__1)) <= tol) {
slaset_("A", &c__1, nrhs, &c_b6, &c_b6, &work[bx + i__ - 1], n);
} else {
++(*rank);
slascl_("G", &c__0, &c__0, &d__[i__], &c_b11, &c__1, nrhs, &work[
bx + i__ - 1], n, info);
}
d__[i__] = (r__1 = d__[i__], dabs(r__1));
/* L70: */
}
/* Now apply back the right singular vectors. */
icmpq2 = 1;
i__1 = nsub;
for (i__ = 1; i__ <= i__1; ++i__) {
st = iwork[i__];
st1 = st - 1;
nsize = iwork[sizei + i__ - 1];
bxst = bx + st1;
if (nsize == 1) {
scopy_(nrhs, &work[bxst], n, &b[st + b_dim1], ldb);
} else if (nsize <= *smlsiz) {
sgemm_("T", "N", &nsize, nrhs, &nsize, &c_b11, &work[vt + st1], n,
&work[bxst], n, &c_b6, &b[st + b_dim1], ldb);
} else {
slalsa_(&icmpq2, smlsiz, &nsize, nrhs, &work[bxst], n, &b[st +
b_dim1], ldb, &work[u + st1], n, &work[vt + st1], &iwork[
k + st1], &work[difl + st1], &work[difr + st1], &work[z__
+ st1], &work[poles + st1], &iwork[givptr + st1], &iwork[
givcol + st1], n, &iwork[perm + st1], &work[givnum + st1],
&work[c__ + st1], &work[s + st1], &work[nwork], &iwork[
iwk], info);
if (*info != 0) {
return 0;
}
}
/* L80: */
}
/* Unscale and sort the singular values. */
slascl_("G", &c__0, &c__0, &c_b11, &orgnrm, n, &c__1, &d__[1], n, info);
slasrt_("D", n, &d__[1], info);
slascl_("G", &c__0, &c__0, &orgnrm, &c_b11, n, nrhs, &b[b_offset], ldb,
info);
return 0;
/* End of SLALSD */
} /* slalsd_ */
/* Subroutine */ int slahr2_(integer *n, integer *k, integer *nb, real *a,
integer *lda, real *tau, real *t, integer *ldt, real *y, integer *ldy)
{
/* System generated locals */
integer a_dim1, a_offset, t_dim1, t_offset, y_dim1, y_offset, i__1, i__2,
i__3;
real r__1;
/* Local variables */
integer i__;
real ei;
/* -- LAPACK auxiliary routine (version 3.2) -- */
/* November 2006 */
/* Purpose */
/* ======= */
/* SLAHR2 reduces the first NB columns of A real general n-BY-(n-k+1) */
/* matrix A so that elements below the k-th subdiagonal are zero. The */
/* reduction is performed by an orthogonal similarity transformation */
/* Q' * A * Q. The routine returns the matrices V and T which determine */
/* Q as a block reflector I - V*T*V', and also the matrix Y = A * V * T. */
/* This is an auxiliary routine called by SGEHRD. */
/* Arguments */
/* ========= */
/* N (input) INTEGER */
/* The order of the matrix A. */
/* K (input) INTEGER */
/* The offset for the reduction. Elements below the k-th */
/* subdiagonal in the first NB columns are reduced to zero. */
/* K < N. */
/* NB (input) INTEGER */
/* The number of columns to be reduced. */
/* A (input/output) REAL array, dimension (LDA,N-K+1) */
/* On entry, the n-by-(n-k+1) general matrix A. */
/* On exit, the elements on and above the k-th subdiagonal in */
/* the first NB columns are overwritten with the corresponding */
/* elements of the reduced matrix; the elements below the k-th */
/* subdiagonal, with the array TAU, represent the matrix Q as a */
/* product of elementary reflectors. The other columns of A are */
/* unchanged. See Further Details. */
/* LDA (input) INTEGER */
/* The leading dimension of the array A. LDA >= max(1,N). */
/* TAU (output) REAL array, dimension (NB) */
/* The scalar factors of the elementary reflectors. See Further */
/* Details. */
/* T (output) REAL array, dimension (LDT,NB) */
/* The upper triangular matrix T. */
/* LDT (input) INTEGER */
/* The leading dimension of the array T. LDT >= NB. */
/* Y (output) REAL array, dimension (LDY,NB) */
/* The n-by-nb matrix Y. */
/* LDY (input) INTEGER */
/* The leading dimension of the array Y. LDY >= N. */
/* Further Details */
/* =============== */
/* The matrix Q is represented as a product of nb elementary reflectors */
/* Q = H(1) H(2) . . . H(nb). */
/* Each H(i) has the form */
/* H(i) = I - tau * v * v' */
/* where tau is a real scalar, and v is a real vector with */
/* v(1:i+k-1) = 0, v(i+k) = 1; v(i+k+1:n) is stored on exit in */
/* A(i+k+1:n,i), and tau in TAU(i). */
/* The elements of the vectors v together form the (n-k+1)-by-nb matrix */
/* V which is needed, with T and Y, to apply the transformation to the */
/* unreduced part of the matrix, using an update of the form: */
/* A := (I - V*T*V') * (A - Y*V'). */
/* The contents of A on exit are illustrated by the following example */
/* with n = 7, k = 3 and nb = 2: */
/* ( a a a a a ) */
/* ( a a a a a ) */
/* ( a a a a a ) */
/* ( h h a a a ) */
/* ( v1 h a a a ) */
/* ( v1 v2 a a a ) */
/* ( v1 v2 a a a ) */
/* where a denotes an element of the original matrix A, h denotes a */
/* modified element of the upper Hessenberg matrix H, and vi denotes an */
/* element of the vector defining H(i). */
/* This file is a slight modification of LAPACK-3.0's SLAHRD */
/* incorporating improvements proposed by Quintana-Orti and Van de */
/* Gejin. Note that the entries of A(1:K,2:NB) differ from those */
/* returned by the original LAPACK routine. This function is */
/* not backward compatible with LAPACK3.0. */
/* ===================================================================== */
/* Quick return if possible */
/* Parameter adjustments */
--tau;
a_dim1 = *lda;
a_offset = 1 + a_dim1;
a -= a_offset;
t_dim1 = *ldt;
t_offset = 1 + t_dim1;
t -= t_offset;
y_dim1 = *ldy;
y_offset = 1 + y_dim1;
y -= y_offset;
/* Function Body */
if (*n <= 1) {
return 0;
}
i__1 = *nb;
for (i__ = 1; i__ <= i__1; ++i__) {
if (i__ > 1) {
/* Update A(K+1:N,I) */
/* Update I-th column of A - Y * V' */
i__2 = *n - *k;
i__3 = i__ - 1;
sgemv_("NO TRANSPOSE", &i__2, &i__3, &c_b4, &y[*k + 1 + y_dim1],
ldy, &a[*k + i__ - 1 + a_dim1], lda, &c_b5, &a[*k + 1 +
i__ * a_dim1], &c__1);
/* Apply I - V * T' * V' to this column (call it b) from the */
/* left, using the last column of T as workspace */
/* Let V = ( V1 ) and b = ( b1 ) (first I-1 rows) */
/* ( V2 ) ( b2 ) */
/* where V1 is unit lower triangular */
/* w := V1' * b1 */
i__2 = i__ - 1;
scopy_(&i__2, &a[*k + 1 + i__ * a_dim1], &c__1, &t[*nb * t_dim1 +
1], &c__1);
i__2 = i__ - 1;
strmv_("Lower", "Transpose", "UNIT", &i__2, &a[*k + 1 + a_dim1],
lda, &t[*nb * t_dim1 + 1], &c__1);
/* w := w + V2'*b2 */
i__2 = *n - *k - i__ + 1;
i__3 = i__ - 1;
sgemv_("Transpose", &i__2, &i__3, &c_b5, &a[*k + i__ + a_dim1],
lda, &a[*k + i__ + i__ * a_dim1], &c__1, &c_b5, &t[*nb *
t_dim1 + 1], &c__1);
/* w := T'*w */
i__2 = i__ - 1;
strmv_("Upper", "Transpose", "NON-UNIT", &i__2, &t[t_offset], ldt,
&t[*nb * t_dim1 + 1], &c__1);
/* b2 := b2 - V2*w */
i__2 = *n - *k - i__ + 1;
i__3 = i__ - 1;
sgemv_("NO TRANSPOSE", &i__2, &i__3, &c_b4, &a[*k + i__ + a_dim1],
lda, &t[*nb * t_dim1 + 1], &c__1, &c_b5, &a[*k + i__ +
i__ * a_dim1], &c__1);
/* b1 := b1 - V1*w */
i__2 = i__ - 1;
strmv_("Lower", "NO TRANSPOSE", "UNIT", &i__2, &a[*k + 1 + a_dim1]
, lda, &t[*nb * t_dim1 + 1], &c__1);
i__2 = i__ - 1;
saxpy_(&i__2, &c_b4, &t[*nb * t_dim1 + 1], &c__1, &a[*k + 1 + i__
* a_dim1], &c__1);
a[*k + i__ - 1 + (i__ - 1) * a_dim1] = ei;
}
/* Generate the elementary reflector H(I) to annihilate */
/* A(K+I+1:N,I) */
i__2 = *n - *k - i__ + 1;
/* Computing MIN */
i__3 = *k + i__ + 1;
slarfg_(&i__2, &a[*k + i__ + i__ * a_dim1], &a[min(i__3, *n)+ i__ *
a_dim1], &c__1, &tau[i__]);
ei = a[*k + i__ + i__ * a_dim1];
a[*k + i__ + i__ * a_dim1] = 1.f;
/* Compute Y(K+1:N,I) */
i__2 = *n - *k;
i__3 = *n - *k - i__ + 1;
sgemv_("NO TRANSPOSE", &i__2, &i__3, &c_b5, &a[*k + 1 + (i__ + 1) *
a_dim1], lda, &a[*k + i__ + i__ * a_dim1], &c__1, &c_b38, &y[*
k + 1 + i__ * y_dim1], &c__1);
i__2 = *n - *k - i__ + 1;
i__3 = i__ - 1;
sgemv_("Transpose", &i__2, &i__3, &c_b5, &a[*k + i__ + a_dim1], lda, &
a[*k + i__ + i__ * a_dim1], &c__1, &c_b38, &t[i__ * t_dim1 +
1], &c__1);
i__2 = *n - *k;
i__3 = i__ - 1;
sgemv_("NO TRANSPOSE", &i__2, &i__3, &c_b4, &y[*k + 1 + y_dim1], ldy,
&t[i__ * t_dim1 + 1], &c__1, &c_b5, &y[*k + 1 + i__ * y_dim1],
&c__1);
i__2 = *n - *k;
sscal_(&i__2, &tau[i__], &y[*k + 1 + i__ * y_dim1], &c__1);
/* Compute T(1:I,I) */
i__2 = i__ - 1;
r__1 = -tau[i__];
sscal_(&i__2, &r__1, &t[i__ * t_dim1 + 1], &c__1);
i__2 = i__ - 1;
strmv_("Upper", "No Transpose", "NON-UNIT", &i__2, &t[t_offset], ldt,
&t[i__ * t_dim1 + 1], &c__1)
;
t[i__ + i__ * t_dim1] = tau[i__];
}
a[*k + *nb + *nb * a_dim1] = ei;
/* Compute Y(1:K,1:NB) */
slacpy_("ALL", k, nb, &a[(a_dim1 << 1) + 1], lda, &y[y_offset], ldy);
strmm_("RIGHT", "Lower", "NO TRANSPOSE", "UNIT", k, nb, &c_b5, &a[*k + 1
+ a_dim1], lda, &y[y_offset], ldy);
if (*n > *k + *nb) {
i__1 = *n - *k - *nb;
sgemm_("NO TRANSPOSE", "NO TRANSPOSE", k, nb, &i__1, &c_b5, &a[(*nb +
2) * a_dim1 + 1], lda, &a[*k + 1 + *nb + a_dim1], lda, &c_b5,
&y[y_offset], ldy);
}
strmm_("RIGHT", "Upper", "NO TRANSPOSE", "NON-UNIT", k, nb, &c_b5, &t[
t_offset], ldt, &y[y_offset], ldy);
return 0;
/* End of SLAHR2 */
} /* slahr2_ */
/* Subroutine */ int sgegs_(char *jobvsl, char *jobvsr, integer *n, real *a,
integer *lda, real *b, integer *ldb, real *alphar, real *alphai, real
*beta, real *vsl, integer *ldvsl, real *vsr, integer *ldvsr, real *
work, integer *lwork, integer *info)
{
/* System generated locals */
integer a_dim1, a_offset, b_dim1, b_offset, vsl_dim1, vsl_offset,
vsr_dim1, vsr_offset, i__1, i__2;
/* Local variables */
integer nb, nb1, nb2, nb3, ihi, ilo;
real eps, anrm, bnrm;
integer itau, lopt;
extern logical lsame_(char *, char *);
integer ileft, iinfo, icols;
logical ilvsl;
integer iwork;
logical ilvsr;
integer irows;
extern /* Subroutine */ int sggbak_(char *, char *, integer *, integer *,
integer *, real *, real *, integer *, real *, integer *, integer *
), sggbal_(char *, integer *, real *, integer *,
real *, integer *, integer *, integer *, real *, real *, real *,
integer *);
logical ilascl, ilbscl;
extern doublereal slamch_(char *), slange_(char *, integer *,
integer *, real *, integer *, real *);
real safmin;
extern /* Subroutine */ int sgghrd_(char *, char *, integer *, integer *,
integer *, real *, integer *, real *, integer *, real *, integer *
, real *, integer *, integer *), xerbla_(char *,
integer *);
extern integer ilaenv_(integer *, char *, char *, integer *, integer *,
integer *, integer *);
real bignum;
extern /* Subroutine */ int slascl_(char *, integer *, integer *, real *,
real *, integer *, integer *, real *, integer *, integer *);
integer ijobvl, iright;
extern /* Subroutine */ int sgeqrf_(integer *, integer *, real *, integer
*, real *, real *, integer *, integer *);
integer ijobvr;
extern /* Subroutine */ int slacpy_(char *, integer *, integer *, real *,
integer *, real *, integer *), slaset_(char *, integer *,
integer *, real *, real *, real *, integer *);
real anrmto;
integer lwkmin;
real bnrmto;
extern /* Subroutine */ int shgeqz_(char *, char *, char *, integer *,
integer *, integer *, real *, integer *, real *, integer *, real *
, real *, real *, real *, integer *, real *, integer *, real *,
integer *, integer *);
real smlnum;
extern /* Subroutine */ int sorgqr_(integer *, integer *, integer *, real
*, integer *, real *, real *, integer *, integer *);
integer lwkopt;
logical lquery;
extern /* Subroutine */ int sormqr_(char *, char *, integer *, integer *,
integer *, real *, integer *, real *, real *, integer *, real *,
integer *, integer *);
/* -- LAPACK driver routine (version 3.2) -- */
/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/* November 2006 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* This routine is deprecated and has been replaced by routine SGGES. */
/* SGEGS computes the eigenvalues, real Schur form, and, optionally, */
/* left and or/right Schur vectors of a real matrix pair (A,B). */
/* Given two square matrices A and B, the generalized real Schur */
/* factorization has the form */
/* A = Q*S*Z**T, B = Q*T*Z**T */
/* where Q and Z are orthogonal matrices, T is upper triangular, and S */
/* is an upper quasi-triangular matrix with 1-by-1 and 2-by-2 diagonal */
/* blocks, the 2-by-2 blocks corresponding to complex conjugate pairs */
/* of eigenvalues of (A,B). The columns of Q are the left Schur vectors */
/* and the columns of Z are the right Schur vectors. */
/* If only the eigenvalues of (A,B) are needed, the driver routine */
/* SGEGV should be used instead. See SGEGV for a description of the */
/* eigenvalues of the generalized nonsymmetric eigenvalue problem */
/* (GNEP). */
/* Arguments */
/* ========= */
/* JOBVSL (input) CHARACTER*1 */
/* = 'N': do not compute the left Schur vectors; */
/* = 'V': compute the left Schur vectors (returned in VSL). */
/* JOBVSR (input) CHARACTER*1 */
/* = 'N': do not compute the right Schur vectors; */
/* = 'V': compute the right Schur vectors (returned in VSR). */
/* N (input) INTEGER */
/* The order of the matrices A, B, VSL, and VSR. N >= 0. */
/* A (input/output) REAL array, dimension (LDA, N) */
/* On entry, the matrix A. */
/* On exit, the upper quasi-triangular matrix S from the */
/* generalized real Schur factorization. */
/* LDA (input) INTEGER */
/* The leading dimension of A. LDA >= max(1,N). */
/* B (input/output) REAL array, dimension (LDB, N) */
/* On entry, the matrix B. */
/* On exit, the upper triangular matrix T from the generalized */
/* real Schur factorization. */
/* LDB (input) INTEGER */
/* The leading dimension of B. LDB >= max(1,N). */
/* ALPHAR (output) REAL array, dimension (N) */
/* The real parts of each scalar alpha defining an eigenvalue */
/* of GNEP. */
/* ALPHAI (output) REAL array, dimension (N) */
/* The imaginary parts of each scalar alpha defining an */
/* eigenvalue of GNEP. If ALPHAI(j) is zero, then the j-th */
/* eigenvalue is real; if positive, then the j-th and (j+1)-st */
/* eigenvalues are a complex conjugate pair, with */
/* ALPHAI(j+1) = -ALPHAI(j). */
/* BETA (output) REAL array, dimension (N) */
/* The scalars beta that define the eigenvalues of GNEP. */
/* Together, the quantities alpha = (ALPHAR(j),ALPHAI(j)) and */
/* beta = BETA(j) represent the j-th eigenvalue of the matrix */
/* pair (A,B), in one of the forms lambda = alpha/beta or */
/* mu = beta/alpha. Since either lambda or mu may overflow, */
/* they should not, in general, be computed. */
/* VSL (output) REAL array, dimension (LDVSL,N) */
/* If JOBVSL = 'V', the matrix of left Schur vectors Q. */
/* Not referenced if JOBVSL = 'N'. */
/* LDVSL (input) INTEGER */
/* The leading dimension of the matrix VSL. LDVSL >=1, and */
/* if JOBVSL = 'V', LDVSL >= N. */
/* VSR (output) REAL array, dimension (LDVSR,N) */
/* If JOBVSR = 'V', the matrix of right Schur vectors Z. */
/* Not referenced if JOBVSR = 'N'. */
/* LDVSR (input) INTEGER */
/* The leading dimension of the matrix VSR. LDVSR >= 1, and */
/* if JOBVSR = 'V', LDVSR >= N. */
/* 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 >= max(1,4*N). */
/* For good performance, LWORK must generally be larger. */
/* To compute the optimal value of LWORK, call ILAENV to get */
/* blocksizes (for SGEQRF, SORMQR, and SORGQR.) Then compute: */
/* NB -- MAX of the blocksizes for SGEQRF, SORMQR, and SORGQR */
/* The optimal LWORK is 2*N + N*(NB+1). */
/* 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. */
/* = 1,...,N: */
/* The QZ iteration failed. (A,B) are not in Schur */
/* form, but ALPHAR(j), ALPHAI(j), and BETA(j) should */
/* be correct for j=INFO+1,...,N. */
/* > N: errors that usually indicate LAPACK problems: */
/* =N+1: error return from SGGBAL */
/* =N+2: error return from SGEQRF */
/* =N+3: error return from SORMQR */
/* =N+4: error return from SORGQR */
/* =N+5: error return from SGGHRD */
/* =N+6: error return from SHGEQZ (other than failed */
/* iteration) */
/* =N+7: error return from SGGBAK (computing VSL) */
/* =N+8: error return from SGGBAK (computing VSR) */
/* =N+9: error return from SLASCL (various places) */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Executable Statements .. */
/* Decode the input arguments */
/* Parameter adjustments */
a_dim1 = *lda;
a_offset = 1 + a_dim1;
a -= a_offset;
b_dim1 = *ldb;
b_offset = 1 + b_dim1;
b -= b_offset;
--alphar;
--alphai;
--beta;
vsl_dim1 = *ldvsl;
vsl_offset = 1 + vsl_dim1;
vsl -= vsl_offset;
vsr_dim1 = *ldvsr;
vsr_offset = 1 + vsr_dim1;
vsr -= vsr_offset;
--work;
/* Function Body */
if (lsame_(jobvsl, "N")) {
ijobvl = 1;
ilvsl = FALSE_;
} else if (lsame_(jobvsl, "V")) {
ijobvl = 2;
ilvsl = TRUE_;
} else {
ijobvl = -1;
ilvsl = FALSE_;
}
if (lsame_(jobvsr, "N")) {
ijobvr = 1;
ilvsr = FALSE_;
} else if (lsame_(jobvsr, "V")) {
ijobvr = 2;
ilvsr = TRUE_;
} else {
ijobvr = -1;
ilvsr = FALSE_;
}
/* Test the input arguments */
/* Computing MAX */
i__1 = *n << 2;
lwkmin = max(i__1,1);
lwkopt = lwkmin;
work[1] = (real) lwkopt;
lquery = *lwork == -1;
*info = 0;
if (ijobvl <= 0) {
*info = -1;
} else if (ijobvr <= 0) {
*info = -2;
} else if (*n < 0) {
*info = -3;
} else if (*lda < max(1,*n)) {
*info = -5;
} else if (*ldb < max(1,*n)) {
*info = -7;
} else if (*ldvsl < 1 || ilvsl && *ldvsl < *n) {
*info = -12;
} else if (*ldvsr < 1 || ilvsr && *ldvsr < *n) {
*info = -14;
} else if (*lwork < lwkmin && ! lquery) {
*info = -16;
}
if (*info == 0) {
nb1 = ilaenv_(&c__1, "SGEQRF", " ", n, n, &c_n1, &c_n1);
nb2 = ilaenv_(&c__1, "SORMQR", " ", n, n, n, &c_n1);
nb3 = ilaenv_(&c__1, "SORGQR", " ", n, n, n, &c_n1);
/* Computing MAX */
i__1 = max(nb1,nb2);
nb = max(i__1,nb3);
lopt = (*n << 1) + *n * (nb + 1);
work[1] = (real) lopt;
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("SGEGS ", &i__1);
return 0;
} else if (lquery) {
return 0;
}
/* Quick return if possible */
if (*n == 0) {
return 0;
}
/* Get machine constants */
eps = slamch_("E") * slamch_("B");
safmin = slamch_("S");
smlnum = *n * safmin / eps;
bignum = 1.f / smlnum;
/* Scale A if max element outside range [SMLNUM,BIGNUM] */
anrm = slange_("M", n, n, &a[a_offset], lda, &work[1]);
ilascl = FALSE_;
if (anrm > 0.f && anrm < smlnum) {
anrmto = smlnum;
ilascl = TRUE_;
} else if (anrm > bignum) {
anrmto = bignum;
ilascl = TRUE_;
}
if (ilascl) {
slascl_("G", &c_n1, &c_n1, &anrm, &anrmto, n, n, &a[a_offset], lda, &
iinfo);
if (iinfo != 0) {
*info = *n + 9;
return 0;
}
}
/* Scale B if max element outside range [SMLNUM,BIGNUM] */
bnrm = slange_("M", n, n, &b[b_offset], ldb, &work[1]);
ilbscl = FALSE_;
if (bnrm > 0.f && bnrm < smlnum) {
bnrmto = smlnum;
ilbscl = TRUE_;
} else if (bnrm > bignum) {
bnrmto = bignum;
ilbscl = TRUE_;
}
if (ilbscl) {
slascl_("G", &c_n1, &c_n1, &bnrm, &bnrmto, n, n, &b[b_offset], ldb, &
iinfo);
if (iinfo != 0) {
*info = *n + 9;
return 0;
}
}
/* Permute the matrix to make it more nearly triangular */
/* Workspace layout: (2*N words -- "work..." not actually used) */
/* left_permutation, right_permutation, work... */
ileft = 1;
iright = *n + 1;
iwork = iright + *n;
sggbal_("P", n, &a[a_offset], lda, &b[b_offset], ldb, &ilo, &ihi, &work[
ileft], &work[iright], &work[iwork], &iinfo);
if (iinfo != 0) {
*info = *n + 1;
goto L10;
}
/* Reduce B to triangular form, and initialize VSL and/or VSR */
/* Workspace layout: ("work..." must have at least N words) */
/* left_permutation, right_permutation, tau, work... */
irows = ihi + 1 - ilo;
icols = *n + 1 - ilo;
itau = iwork;
iwork = itau + irows;
i__1 = *lwork + 1 - iwork;
sgeqrf_(&irows, &icols, &b[ilo + ilo * b_dim1], ldb, &work[itau], &work[
iwork], &i__1, &iinfo);
if (iinfo >= 0) {
/* Computing MAX */
i__1 = lwkopt, i__2 = (integer) work[iwork] + iwork - 1;
lwkopt = max(i__1,i__2);
}
if (iinfo != 0) {
*info = *n + 2;
goto L10;
}
i__1 = *lwork + 1 - iwork;
sormqr_("L", "T", &irows, &icols, &irows, &b[ilo + ilo * b_dim1], ldb, &
work[itau], &a[ilo + ilo * a_dim1], lda, &work[iwork], &i__1, &
iinfo);
if (iinfo >= 0) {
/* Computing MAX */
i__1 = lwkopt, i__2 = (integer) work[iwork] + iwork - 1;
lwkopt = max(i__1,i__2);
}
if (iinfo != 0) {
*info = *n + 3;
goto L10;
}
if (ilvsl) {
slaset_("Full", n, n, &c_b36, &c_b37, &vsl[vsl_offset], ldvsl);
i__1 = irows - 1;
i__2 = irows - 1;
slacpy_("L", &i__1, &i__2, &b[ilo + 1 + ilo * b_dim1], ldb, &vsl[ilo
+ 1 + ilo * vsl_dim1], ldvsl);
i__1 = *lwork + 1 - iwork;
sorgqr_(&irows, &irows, &irows, &vsl[ilo + ilo * vsl_dim1], ldvsl, &
work[itau], &work[iwork], &i__1, &iinfo);
if (iinfo >= 0) {
/* Computing MAX */
i__1 = lwkopt, i__2 = (integer) work[iwork] + iwork - 1;
lwkopt = max(i__1,i__2);
}
if (iinfo != 0) {
*info = *n + 4;
goto L10;
}
}
if (ilvsr) {
slaset_("Full", n, n, &c_b36, &c_b37, &vsr[vsr_offset], ldvsr);
}
/* Reduce to generalized Hessenberg form */
sgghrd_(jobvsl, jobvsr, n, &ilo, &ihi, &a[a_offset], lda, &b[b_offset],
ldb, &vsl[vsl_offset], ldvsl, &vsr[vsr_offset], ldvsr, &iinfo);
if (iinfo != 0) {
*info = *n + 5;
goto L10;
}
/* Perform QZ algorithm, computing Schur vectors if desired */
/* Workspace layout: ("work..." must have at least 1 word) */
/* left_permutation, right_permutation, work... */
iwork = itau;
i__1 = *lwork + 1 - iwork;
shgeqz_("S", jobvsl, jobvsr, n, &ilo, &ihi, &a[a_offset], lda, &b[
b_offset], ldb, &alphar[1], &alphai[1], &beta[1], &vsl[vsl_offset]
, ldvsl, &vsr[vsr_offset], ldvsr, &work[iwork], &i__1, &iinfo);
if (iinfo >= 0) {
/* Computing MAX */
i__1 = lwkopt, i__2 = (integer) work[iwork] + iwork - 1;
lwkopt = max(i__1,i__2);
}
if (iinfo != 0) {
if (iinfo > 0 && iinfo <= *n) {
*info = iinfo;
} else if (iinfo > *n && iinfo <= *n << 1) {
*info = iinfo - *n;
} else {
*info = *n + 6;
}
goto L10;
}
/* Apply permutation to VSL and VSR */
if (ilvsl) {
sggbak_("P", "L", n, &ilo, &ihi, &work[ileft], &work[iright], n, &vsl[
vsl_offset], ldvsl, &iinfo);
if (iinfo != 0) {
*info = *n + 7;
goto L10;
}
}
if (ilvsr) {
sggbak_("P", "R", n, &ilo, &ihi, &work[ileft], &work[iright], n, &vsr[
vsr_offset], ldvsr, &iinfo);
if (iinfo != 0) {
*info = *n + 8;
goto L10;
}
}
/* Undo scaling */
if (ilascl) {
slascl_("H", &c_n1, &c_n1, &anrmto, &anrm, n, n, &a[a_offset], lda, &
iinfo);
if (iinfo != 0) {
*info = *n + 9;
return 0;
}
slascl_("G", &c_n1, &c_n1, &anrmto, &anrm, n, &c__1, &alphar[1], n, &
iinfo);
if (iinfo != 0) {
*info = *n + 9;
return 0;
}
slascl_("G", &c_n1, &c_n1, &anrmto, &anrm, n, &c__1, &alphai[1], n, &
iinfo);
if (iinfo != 0) {
*info = *n + 9;
return 0;
}
}
if (ilbscl) {
slascl_("U", &c_n1, &c_n1, &bnrmto, &bnrm, n, n, &b[b_offset], ldb, &
iinfo);
if (iinfo != 0) {
*info = *n + 9;
return 0;
}
slascl_("G", &c_n1, &c_n1, &bnrmto, &bnrm, n, &c__1, &beta[1], n, &
iinfo);
if (iinfo != 0) {
*info = *n + 9;
return 0;
}
}
L10:
work[1] = (real) lwkopt;
return 0;
/* End of SGEGS */
} /* sgegs_ */
/* Subroutine */ int ssapps_(integer *n, integer *kev, integer *np, real *
shift, real *v, integer *ldv, real *h__, integer *ldh, real *resid,
real *q, integer *ldq, real *workd)
{
/* Initialized data */
static logical first = TRUE_;
/* System generated locals */
integer h_dim1, h_offset, q_dim1, q_offset, v_dim1, v_offset, i__1, i__2,
i__3, i__4;
real r__1, r__2;
/* Local variables */
static real c__, f, g;
static integer i__, j;
static real r__, s, a1, a2, a3, a4, t0, t1;
static integer jj;
static real big;
static integer iend, itop;
extern /* Subroutine */ int sscal_(integer *, real *, real *, integer *),
sgemv_(char *, integer *, integer *, real *, real *, integer *,
real *, integer *, real *, real *, integer *, ftnlen), scopy_(
integer *, real *, integer *, real *, integer *), saxpy_(integer *
, real *, real *, integer *, real *, integer *), ivout_(integer *,
integer *, integer *, integer *, char *, ftnlen), svout_(integer
*, integer *, real *, integer *, char *, ftnlen);
extern doublereal slamch_(char *, ftnlen);
extern /* Subroutine */ int second_(real *);
static real epsmch;
static integer istart, kplusp, msglvl;
extern /* Subroutine */ int slacpy_(char *, integer *, integer *, real *,
integer *, real *, integer *, ftnlen), slartg_(real *, real *,
real *, real *, real *), slaset_(char *, integer *, integer *,
real *, real *, real *, integer *, ftnlen);
/* %----------------------------------------------------% */
/* | Include files for debugging and timing information | */
/* %----------------------------------------------------% */
/* \SCCS Information: @(#) */
/* FILE: debug.h SID: 2.3 DATE OF SID: 11/16/95 RELEASE: 2 */
/* %---------------------------------% */
/* | See debug.doc for documentation | */
/* %---------------------------------% */
/* %------------------% */
/* | Scalar Arguments | */
/* %------------------% */
/* %--------------------------------% */
/* | See stat.doc for documentation | */
/* %--------------------------------% */
/* \SCCS Information: @(#) */
/* FILE: stat.h SID: 2.2 DATE OF SID: 11/16/95 RELEASE: 2 */
/* %-----------------% */
/* | Array Arguments | */
/* %-----------------% */
/* %------------% */
/* | Parameters | */
/* %------------% */
/* %---------------% */
/* | Local Scalars | */
/* %---------------% */
/* %----------------------% */
/* | External Subroutines | */
/* %----------------------% */
/* %--------------------% */
/* | External Functions | */
/* %--------------------% */
/* %----------------------% */
/* | Intrinsics Functions | */
/* %----------------------% */
/* %----------------% */
/* | Data statments | */
/* %----------------% */
/* Parameter adjustments */
--workd;
--resid;
--shift;
v_dim1 = *ldv;
v_offset = 1 + v_dim1;
v -= v_offset;
h_dim1 = *ldh;
h_offset = 1 + h_dim1;
h__ -= h_offset;
q_dim1 = *ldq;
q_offset = 1 + q_dim1;
q -= q_offset;
/* Function Body */
/* %-----------------------% */
/* | Executable Statements | */
/* %-----------------------% */
if (first) {
epsmch = slamch_("Epsilon-Machine", (ftnlen)15);
first = FALSE_;
}
itop = 1;
/* %-------------------------------% */
/* | Initialize timing statistics | */
/* | & message level for debugging | */
/* %-------------------------------% */
second_(&t0);
msglvl = debug_1.msapps;
kplusp = *kev + *np;
/* %----------------------------------------------% */
/* | Initialize Q to the identity matrix of order | */
/* | kplusp used to accumulate the rotations. | */
/* %----------------------------------------------% */
slaset_("All", &kplusp, &kplusp, &c_b4, &c_b5, &q[q_offset], ldq, (ftnlen)
3);
/* %----------------------------------------------% */
/* | Quick return if there are no shifts to apply | */
/* %----------------------------------------------% */
if (*np == 0) {
goto L9000;
}
/* %----------------------------------------------------------% */
/* | Apply the np shifts implicitly. Apply each shift to the | */
/* | whole matrix and not just to the submatrix from which it | */
/* | comes. | */
/* %----------------------------------------------------------% */
i__1 = *np;
for (jj = 1; jj <= i__1; ++jj) {
istart = itop;
/* %----------------------------------------------------------% */
/* | Check for splitting and deflation. Currently we consider | */
/* | an off-diagonal element h(i+1,1) negligible if | */
/* | h(i+1,1) .le. epsmch*( |h(i,2)| + |h(i+1,2)| ) | */
/* | for i=1:KEV+NP-1. | */
/* | If above condition tests true then we set h(i+1,1) = 0. | */
/* | Note that h(1:KEV+NP,1) are assumed to be non negative. | */
/* %----------------------------------------------------------% */
L20:
/* %------------------------------------------------% */
/* | The following loop exits early if we encounter | */
/* | a negligible off diagonal element. | */
/* %------------------------------------------------% */
i__2 = kplusp - 1;
for (i__ = istart; i__ <= i__2; ++i__) {
big = (r__1 = h__[i__ + (h_dim1 << 1)], dabs(r__1)) + (r__2 = h__[
i__ + 1 + (h_dim1 << 1)], dabs(r__2));
if (h__[i__ + 1 + h_dim1] <= epsmch * big) {
if (msglvl > 0) {
ivout_(&debug_1.logfil, &c__1, &i__, &debug_1.ndigit,
"_sapps: deflation at row/column no.", (ftnlen)35)
;
ivout_(&debug_1.logfil, &c__1, &jj, &debug_1.ndigit,
"_sapps: occured before shift number.", (ftnlen)
36);
svout_(&debug_1.logfil, &c__1, &h__[i__ + 1 + h_dim1], &
debug_1.ndigit, "_sapps: the corresponding off d"
"iagonal element", (ftnlen)46);
}
h__[i__ + 1 + h_dim1] = 0.f;
iend = i__;
goto L40;
}
/* L30: */
}
iend = kplusp;
L40:
if (istart < iend) {
/* %--------------------------------------------------------% */
/* | Construct the plane rotation G'(istart,istart+1,theta) | */
/* | that attempts to drive h(istart+1,1) to zero. | */
/* %--------------------------------------------------------% */
f = h__[istart + (h_dim1 << 1)] - shift[jj];
g = h__[istart + 1 + h_dim1];
slartg_(&f, &g, &c__, &s, &r__);
/* %-------------------------------------------------------% */
/* | Apply rotation to the left and right of H; | */
/* | H <- G' * H * G, where G = G(istart,istart+1,theta). | */
/* | This will create a "bulge". | */
/* %-------------------------------------------------------% */
a1 = c__ * h__[istart + (h_dim1 << 1)] + s * h__[istart + 1 +
h_dim1];
a2 = c__ * h__[istart + 1 + h_dim1] + s * h__[istart + 1 + (
h_dim1 << 1)];
a4 = c__ * h__[istart + 1 + (h_dim1 << 1)] - s * h__[istart + 1 +
h_dim1];
a3 = c__ * h__[istart + 1 + h_dim1] - s * h__[istart + (h_dim1 <<
1)];
h__[istart + (h_dim1 << 1)] = c__ * a1 + s * a2;
h__[istart + 1 + (h_dim1 << 1)] = c__ * a4 - s * a3;
h__[istart + 1 + h_dim1] = c__ * a3 + s * a4;
/* %----------------------------------------------------% */
/* | Accumulate the rotation in the matrix Q; Q <- Q*G | */
/* %----------------------------------------------------% */
/* Computing MIN */
i__3 = istart + jj;
i__2 = min(i__3,kplusp);
for (j = 1; j <= i__2; ++j) {
a1 = c__ * q[j + istart * q_dim1] + s * q[j + (istart + 1) *
q_dim1];
q[j + (istart + 1) * q_dim1] = -s * q[j + istart * q_dim1] +
c__ * q[j + (istart + 1) * q_dim1];
q[j + istart * q_dim1] = a1;
/* L60: */
}
/* %----------------------------------------------% */
/* | The following loop chases the bulge created. | */
/* | Note that the previous rotation may also be | */
/* | done within the following loop. But it is | */
/* | kept separate to make the distinction among | */
/* | the bulge chasing sweeps and the first plane | */
/* | rotation designed to drive h(istart+1,1) to | */
/* | zero. | */
/* %----------------------------------------------% */
i__2 = iend - 1;
for (i__ = istart + 1; i__ <= i__2; ++i__) {
/* %----------------------------------------------% */
/* | Construct the plane rotation G'(i,i+1,theta) | */
/* | that zeros the i-th bulge that was created | */
/* | by G(i-1,i,theta). g represents the bulge. | */
/* %----------------------------------------------% */
f = h__[i__ + h_dim1];
g = s * h__[i__ + 1 + h_dim1];
/* %----------------------------------% */
/* | Final update with G(i-1,i,theta) | */
/* %----------------------------------% */
h__[i__ + 1 + h_dim1] = c__ * h__[i__ + 1 + h_dim1];
slartg_(&f, &g, &c__, &s, &r__);
/* %-------------------------------------------% */
/* | The following ensures that h(1:iend-1,1), | */
/* | the first iend-2 off diagonal of elements | */
/* | H, remain non negative. | */
/* %-------------------------------------------% */
if (r__ < 0.f) {
r__ = -r__;
c__ = -c__;
s = -s;
}
/* %--------------------------------------------% */
/* | Apply rotation to the left and right of H; | */
/* | H <- G * H * G', where G = G(i,i+1,theta) | */
/* %--------------------------------------------% */
h__[i__ + h_dim1] = r__;
a1 = c__ * h__[i__ + (h_dim1 << 1)] + s * h__[i__ + 1 +
h_dim1];
a2 = c__ * h__[i__ + 1 + h_dim1] + s * h__[i__ + 1 + (h_dim1
<< 1)];
a3 = c__ * h__[i__ + 1 + h_dim1] - s * h__[i__ + (h_dim1 << 1)
];
a4 = c__ * h__[i__ + 1 + (h_dim1 << 1)] - s * h__[i__ + 1 +
h_dim1];
h__[i__ + (h_dim1 << 1)] = c__ * a1 + s * a2;
h__[i__ + 1 + (h_dim1 << 1)] = c__ * a4 - s * a3;
h__[i__ + 1 + h_dim1] = c__ * a3 + s * a4;
/* %----------------------------------------------------% */
/* | Accumulate the rotation in the matrix Q; Q <- Q*G | */
/* %----------------------------------------------------% */
/* Computing MIN */
i__4 = i__ + jj;
i__3 = min(i__4,kplusp);
for (j = 1; j <= i__3; ++j) {
a1 = c__ * q[j + i__ * q_dim1] + s * q[j + (i__ + 1) *
q_dim1];
q[j + (i__ + 1) * q_dim1] = -s * q[j + i__ * q_dim1] +
c__ * q[j + (i__ + 1) * q_dim1];
q[j + i__ * q_dim1] = a1;
/* L50: */
}
/* L70: */
}
}
/* %--------------------------% */
/* | Update the block pointer | */
/* %--------------------------% */
istart = iend + 1;
/* %------------------------------------------% */
/* | Make sure that h(iend,1) is non-negative | */
/* | If not then set h(iend,1) <-- -h(iend,1) | */
/* | and negate the last column of Q. | */
/* | We have effectively carried out a | */
/* | similarity on transformation H | */
/* %------------------------------------------% */
if (h__[iend + h_dim1] < 0.f) {
h__[iend + h_dim1] = -h__[iend + h_dim1];
sscal_(&kplusp, &c_b20, &q[iend * q_dim1 + 1], &c__1);
}
/* %--------------------------------------------------------% */
/* | Apply the same shift to the next block if there is any | */
/* %--------------------------------------------------------% */
if (iend < kplusp) {
goto L20;
}
/* %-----------------------------------------------------% */
/* | Check if we can increase the the start of the block | */
/* %-----------------------------------------------------% */
i__2 = kplusp - 1;
for (i__ = itop; i__ <= i__2; ++i__) {
if (h__[i__ + 1 + h_dim1] > 0.f) {
goto L90;
}
++itop;
/* L80: */
}
/* %-----------------------------------% */
/* | Finished applying the jj-th shift | */
/* %-----------------------------------% */
L90:
;
}
/* %------------------------------------------% */
/* | All shifts have been applied. Check for | */
/* | more possible deflation that might occur | */
/* | after the last shift is applied. | */
/* %------------------------------------------% */
i__1 = kplusp - 1;
for (i__ = itop; i__ <= i__1; ++i__) {
big = (r__1 = h__[i__ + (h_dim1 << 1)], dabs(r__1)) + (r__2 = h__[i__
+ 1 + (h_dim1 << 1)], dabs(r__2));
if (h__[i__ + 1 + h_dim1] <= epsmch * big) {
if (msglvl > 0) {
ivout_(&debug_1.logfil, &c__1, &i__, &debug_1.ndigit, "_sapp"
"s: deflation at row/column no.", (ftnlen)35);
svout_(&debug_1.logfil, &c__1, &h__[i__ + 1 + h_dim1], &
debug_1.ndigit, "_sapps: the corresponding off diago"
"nal element", (ftnlen)46);
}
h__[i__ + 1 + h_dim1] = 0.f;
}
/* L100: */
}
/* %-------------------------------------------------% */
/* | Compute the (kev+1)-st column of (V*Q) and | */
/* | temporarily store the result in WORKD(N+1:2*N). | */
/* | This is not necessary if h(kev+1,1) = 0. | */
/* %-------------------------------------------------% */
if (h__[*kev + 1 + h_dim1] > 0.f) {
sgemv_("N", n, &kplusp, &c_b5, &v[v_offset], ldv, &q[(*kev + 1) *
q_dim1 + 1], &c__1, &c_b4, &workd[*n + 1], &c__1, (ftnlen)1);
}
/* %-------------------------------------------------------% */
/* | Compute column 1 to kev of (V*Q) in backward order | */
/* | taking advantage that Q is an upper triangular matrix | */
/* | with lower bandwidth np. | */
/* | Place results in v(:,kplusp-kev:kplusp) temporarily. | */
/* %-------------------------------------------------------% */
i__1 = *kev;
for (i__ = 1; i__ <= i__1; ++i__) {
i__2 = kplusp - i__ + 1;
sgemv_("N", n, &i__2, &c_b5, &v[v_offset], ldv, &q[(*kev - i__ + 1) *
q_dim1 + 1], &c__1, &c_b4, &workd[1], &c__1, (ftnlen)1);
scopy_(n, &workd[1], &c__1, &v[(kplusp - i__ + 1) * v_dim1 + 1], &
c__1);
/* L130: */
}
/* %-------------------------------------------------% */
/* | Move v(:,kplusp-kev+1:kplusp) into v(:,1:kev). | */
/* %-------------------------------------------------% */
slacpy_("All", n, kev, &v[(*np + 1) * v_dim1 + 1], ldv, &v[v_offset], ldv,
(ftnlen)3);
/* %--------------------------------------------% */
/* | Copy the (kev+1)-st column of (V*Q) in the | */
/* | appropriate place if h(kev+1,1) .ne. zero. | */
/* %--------------------------------------------% */
if (h__[*kev + 1 + h_dim1] > 0.f) {
scopy_(n, &workd[*n + 1], &c__1, &v[(*kev + 1) * v_dim1 + 1], &c__1);
}
/* %-------------------------------------% */
/* | Update the residual vector: | */
/* | r <- sigmak*r + betak*v(:,kev+1) | */
/* | where | */
/* | sigmak = (e_{kev+p}'*Q)*e_{kev} | */
/* | betak = e_{kev+1}'*H*e_{kev} | */
/* %-------------------------------------% */
sscal_(n, &q[kplusp + *kev * q_dim1], &resid[1], &c__1);
if (h__[*kev + 1 + h_dim1] > 0.f) {
saxpy_(n, &h__[*kev + 1 + h_dim1], &v[(*kev + 1) * v_dim1 + 1], &c__1,
&resid[1], &c__1);
}
if (msglvl > 1) {
svout_(&debug_1.logfil, &c__1, &q[kplusp + *kev * q_dim1], &
debug_1.ndigit, "_sapps: sigmak of the updated residual vect"
"or", (ftnlen)45);
svout_(&debug_1.logfil, &c__1, &h__[*kev + 1 + h_dim1], &
debug_1.ndigit, "_sapps: betak of the updated residual vector"
, (ftnlen)44);
svout_(&debug_1.logfil, kev, &h__[(h_dim1 << 1) + 1], &debug_1.ndigit,
"_sapps: updated main diagonal of H for next iteration", (
ftnlen)53);
if (*kev > 1) {
i__1 = *kev - 1;
svout_(&debug_1.logfil, &i__1, &h__[h_dim1 + 2], &debug_1.ndigit,
"_sapps: updated sub diagonal of H for next iteration", (
ftnlen)52);
}
}
second_(&t1);
timing_1.tsapps += t1 - t0;
L9000:
return 0;
/* %---------------% */
/* | End of ssapps | */
/* %---------------% */
} /* ssapps_ */
int slaqr0_(int *wantt, int *wantz, int *n,
int *ilo, int *ihi, float *h__, int *ldh, float *wr, float *
wi, int *iloz, int *ihiz, float *z__, int *ldz, float *work,
int *lwork, int *info)
{
/* System generated locals */
int h_dim1, h_offset, z_dim1, z_offset, i__1, i__2, i__3, i__4, i__5;
float r__1, r__2, r__3, r__4;
/* Local variables */
int i__, k;
float aa, bb, cc, dd;
int ld;
float cs;
int nh, it, ks, kt;
float sn;
int ku, kv, ls, ns;
float ss;
int nw, inf, kdu, nho, nve, kwh, nsr, nwr, kwv, ndec, ndfl, kbot,
nmin;
float swap;
int ktop;
float zdum[1] /* was [1][1] */;
int kacc22, itmax, nsmax, nwmax, kwtop;
extern int slanv2_(float *, float *, float *, float *, float *
, float *, float *, float *, float *, float *), slaqr3_(int *,
int *, int *, int *, int *, int *, float *,
int *, int *, int *, float *, int *, int *,
int *, float *, float *, float *, int *, int *, float *,
int *, int *, float *, int *, float *, int *),
slaqr4_(int *, int *, int *, int *, int *,
float *, int *, float *, float *, int *, int *, float *,
int *, float *, int *, int *), slaqr5_(int *,
int *, int *, int *, int *, int *, int *,
float *, float *, float *, int *, int *, int *, float *,
int *, float *, int *, float *, int *, int *, float *
, int *, int *, float *, int *);
int nibble;
extern int ilaenv_(int *, char *, char *, int *, int *,
int *, int *);
char jbcmpz[1];
extern int slahqr_(int *, int *, int *,
int *, int *, float *, int *, float *, float *, int *
, int *, float *, int *, int *), slacpy_(char *,
int *, int *, float *, int *, float *, int *);
int nwupbd;
int sorted;
int lwkopt;
/* -- LAPACK auxiliary routine (version 3.2) -- */
/* Univ. of Tennessee, Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd.. */
/* November 2006 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* SLAQR0 computes the eigenvalues of a 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 */
/* ========= */
/* WANTT (input) LOGICAL */
/* = .TRUE. : the full Schur form T is required; */
/* = .FALSE.: only eigenvalues are required. */
/* WANTZ (input) LOGICAL */
/* = .TRUE. : the matrix of Schur vectors Z is required; */
/* = .FALSE.: Schur vectors are not required. */
/* N (input) INTEGER */
/* The order of the matrix H. N .GE. 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 and, if ILO.GT.1, */
/* H(ILO,ILO-1) is zero. 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. If N.GT.0, then 1.LE.ILO.LE.IHI.LE.N. */
/* If N = 0, then ILO = 1 and IHI = 0. */
/* H (input/output) REAL array, dimension (LDH,N) */
/* On entry, the upper Hessenberg matrix H. */
/* On exit, if INFO = 0 and WANTT is .TRUE., then 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).LT.0. If INFO = 0 and WANTT is */
/* .FALSE., then the contents of H are unspecified on exit. */
/* (The output value of H when INFO.GT.0 is given under the */
/* description of INFO below.) */
/* This subroutine may explicitly set H(i,j) = 0 for i.GT.j and */
/* j = 1, 2, ... ILO-1 or j = IHI+1, IHI+2, ... N. */
/* LDH (input) INTEGER */
/* The leading dimension of the array H. LDH .GE. MAX(1,N). */
/* WR (output) REAL array, dimension (IHI) */
/* WI (output) REAL array, dimension (IHI) */
/* The float and imaginary parts, respectively, of the computed */
/* eigenvalues of H(ILO:IHI,ILO:IHI) are stored in WR(ILO:IHI) */
/* and WI(ILO:IHI). 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) .GT. 0 and WI(i+1) .LT. 0. If WANTT is .TRUE., then */
/* 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). */
/* ILOZ (input) INTEGER */
/* IHIZ (input) INTEGER */
/* Specify the rows of Z to which transformations must be */
/* applied if WANTZ is .TRUE.. */
/* 1 .LE. ILOZ .LE. ILO; IHI .LE. IHIZ .LE. N. */
/* Z (input/output) REAL array, dimension (LDZ,IHI) */
/* If WANTZ is .FALSE., then Z is not referenced. */
/* If WANTZ is .TRUE., then Z(ILO:IHI,ILOZ:IHIZ) is */
/* replaced by Z(ILO:IHI,ILOZ:IHIZ)*U where U is the */
/* orthogonal Schur factor of H(ILO:IHI,ILO:IHI). */
/* (The output value of Z when INFO.GT.0 is given under */
/* the description of INFO below.) */
/* LDZ (input) INTEGER */
/* The leading dimension of the array Z. if WANTZ is .TRUE. */
/* then LDZ.GE.MAX(1,IHIZ). Otherwize, LDZ.GE.1. */
/* WORK (workspace/output) REAL array, dimension LWORK */
/* On exit, if LWORK = -1, WORK(1) returns an estimate of */
/* the optimal value for LWORK. */
/* LWORK (input) INTEGER */
/* The dimension of the array WORK. LWORK .GE. MAX(1,N) */
/* is sufficient, but LWORK typically as large as 6*N may */
/* be required for optimal performance. A workspace query */
/* to determine the optimal workspace size is recommended. */
/* If LWORK = -1, then SLAQR0 does a workspace query. */
/* In this case, SLAQR0 checks the input parameters and */
/* estimates the optimal workspace size for the given */
/* values of N, ILO and IHI. The estimate is returned */
/* in WORK(1). No error message related to LWORK is */
/* issued by XERBLA. Neither H nor Z are accessed. */
/* INFO (output) INTEGER */
/* = 0: successful exit */
/* .GT. 0: if INFO = i, SLAQR0 failed to compute all of */
/* the eigenvalues. Elements 1:ilo-1 and i+1:n of WR */
/* and WI contain those eigenvalues which have been */
/* successfully computed. (Failures are rare.) */
/* If INFO .GT. 0 and WANT is .FALSE., then on exit, */
/* the remaining unconverged eigenvalues are the eigen- */
/* values of the upper Hessenberg matrix rows and */
/* columns ILO through INFO of the final, output */
/* value of H. */
/* If INFO .GT. 0 and WANTT is .TRUE., then on exit */
/* (*) (initial value of H)*U = U*(final value of H) */
/* where U is an orthogonal matrix. The final */
/* value of H is upper Hessenberg and quasi-triangular */
/* in rows and columns INFO+1 through IHI. */
/* If INFO .GT. 0 and WANTZ is .TRUE., then on exit */
/* (final value of Z(ILO:IHI,ILOZ:IHIZ) */
/* = (initial value of Z(ILO:IHI,ILOZ:IHIZ)*U */
/* where U is the orthogonal matrix in (*) (regard- */
/* less of the value of WANTT.) */
/* If INFO .GT. 0 and WANTZ is .FALSE., then Z is not */
/* accessed. */
/* ================================================================ */
/* Based on contributions by */
/* Karen Braman and Ralph Byers, Department of Mathematics, */
/* University of Kansas, USA */
/* ================================================================ */
/* References: */
/* K. Braman, R. Byers and R. Mathias, The Multi-Shift QR */
/* Algorithm Part I: Maintaining Well Focused Shifts, and Level 3 */
/* Performance, SIAM Journal of Matrix Analysis, volume 23, pages */
/* 929--947, 2002. */
/* K. Braman, R. Byers and R. Mathias, The Multi-Shift QR */
/* Algorithm Part II: Aggressive Early Deflation, SIAM Journal */
/* of Matrix Analysis, volume 23, pages 948--973, 2002. */
/* ================================================================ */
/* .. Parameters .. */
/* ==== Matrices of order NTINY or smaller must be processed by */
/* . SLAHQR because of insufficient subdiagonal scratch space. */
/* . (This is a hard limit.) ==== */
/* ==== Exceptional deflation windows: try to cure rare */
/* . slow convergence by varying the size of the */
/* . deflation window after KEXNW iterations. ==== */
/* ==== Exceptional shifts: try to cure rare slow convergence */
/* . with ad-hoc exceptional shifts every KEXSH iterations. */
/* . ==== */
/* ==== The constants WILK1 and WILK2 are used to form the */
/* . exceptional shifts. ==== */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. Local Arrays .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Executable Statements .. */
/* 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 */
*info = 0;
/* ==== Quick return for N = 0: nothing to do. ==== */
if (*n == 0) {
work[1] = 1.f;
return 0;
}
if (*n <= 11) {
/* ==== Tiny matrices must use SLAHQR. ==== */
lwkopt = 1;
if (*lwork != -1) {
slahqr_(wantt, wantz, n, ilo, ihi, &h__[h_offset], ldh, &wr[1], &
wi[1], iloz, ihiz, &z__[z_offset], ldz, info);
}
} else {
/* ==== Use small bulge multi-shift QR with aggressive early */
/* . deflation on larger-than-tiny matrices. ==== */
/* ==== Hope for the best. ==== */
*info = 0;
/* ==== Set up job flags for ILAENV. ==== */
if (*wantt) {
*(unsigned char *)jbcmpz = 'S';
} else {
*(unsigned char *)jbcmpz = 'E';
}
if (*wantz) {
*(unsigned char *)&jbcmpz[1] = 'V';
} else {
*(unsigned char *)&jbcmpz[1] = 'N';
}
/* ==== NWR = recommended deflation window size. At this */
/* . point, N .GT. NTINY = 11, so there is enough */
/* . subdiagonal workspace for NWR.GE.2 as required. */
/* . (In fact, there is enough subdiagonal space for */
/* . NWR.GE.3.) ==== */
nwr = ilaenv_(&c__13, "SLAQR0", jbcmpz, n, ilo, ihi, lwork);
nwr = MAX(2,nwr);
/* Computing MIN */
i__1 = *ihi - *ilo + 1, i__2 = (*n - 1) / 3, i__1 = MIN(i__1,i__2);
nwr = MIN(i__1,nwr);
/* ==== NSR = recommended number of simultaneous shifts. */
/* . At this point N .GT. NTINY = 11, so there is at */
/* . enough subdiagonal workspace for NSR to be even */
/* . and greater than or equal to two as required. ==== */
nsr = ilaenv_(&c__15, "SLAQR0", jbcmpz, n, ilo, ihi, lwork);
/* Computing MIN */
i__1 = nsr, i__2 = (*n + 6) / 9, i__1 = MIN(i__1,i__2), i__2 = *ihi -
*ilo;
nsr = MIN(i__1,i__2);
/* Computing MAX */
i__1 = 2, i__2 = nsr - nsr % 2;
nsr = MAX(i__1,i__2);
/* ==== Estimate optimal workspace ==== */
/* ==== Workspace query call to SLAQR3 ==== */
i__1 = nwr + 1;
slaqr3_(wantt, wantz, n, ilo, ihi, &i__1, &h__[h_offset], ldh, iloz,
ihiz, &z__[z_offset], ldz, &ls, &ld, &wr[1], &wi[1], &h__[
h_offset], ldh, n, &h__[h_offset], ldh, n, &h__[h_offset],
ldh, &work[1], &c_n1);
/* ==== Optimal workspace = MAX(SLAQR5, SLAQR3) ==== */
/* Computing MAX */
i__1 = nsr * 3 / 2, i__2 = (int) work[1];
lwkopt = MAX(i__1,i__2);
/* ==== Quick return in case of workspace query. ==== */
if (*lwork == -1) {
work[1] = (float) lwkopt;
return 0;
}
/* ==== SLAHQR/SLAQR0 crossover point ==== */
nmin = ilaenv_(&c__12, "SLAQR0", jbcmpz, n, ilo, ihi, lwork);
nmin = MAX(11,nmin);
/* ==== Nibble crossover point ==== */
nibble = ilaenv_(&c__14, "SLAQR0", jbcmpz, n, ilo, ihi, lwork);
nibble = MAX(0,nibble);
/* ==== Accumulate reflections during ttswp? Use block */
/* . 2-by-2 structure during matrix-matrix multiply? ==== */
kacc22 = ilaenv_(&c__16, "SLAQR0", jbcmpz, n, ilo, ihi, lwork);
kacc22 = MAX(0,kacc22);
kacc22 = MIN(2,kacc22);
/* ==== NWMAX = the largest possible deflation window for */
/* . which there is sufficient workspace. ==== */
/* Computing MIN */
i__1 = (*n - 1) / 3, i__2 = *lwork / 2;
nwmax = MIN(i__1,i__2);
nw = nwmax;
/* ==== NSMAX = the Largest number of simultaneous shifts */
/* . for which there is sufficient workspace. ==== */
/* Computing MIN */
i__1 = (*n + 6) / 9, i__2 = (*lwork << 1) / 3;
nsmax = MIN(i__1,i__2);
nsmax -= nsmax % 2;
/* ==== NDFL: an iteration count restarted at deflation. ==== */
ndfl = 1;
/* ==== ITMAX = iteration limit ==== */
/* Computing MAX */
i__1 = 10, i__2 = *ihi - *ilo + 1;
itmax = MAX(i__1,i__2) * 30;
/* ==== Last row and column in the active block ==== */
kbot = *ihi;
/* ==== Main Loop ==== */
i__1 = itmax;
for (it = 1; it <= i__1; ++it) {
/* ==== Done when KBOT falls below ILO ==== */
if (kbot < *ilo) {
goto L90;
}
/* ==== Locate active block ==== */
i__2 = *ilo + 1;
for (k = kbot; k >= i__2; --k) {
if (h__[k + (k - 1) * h_dim1] == 0.f) {
goto L20;
}
/* L10: */
}
k = *ilo;
L20:
ktop = k;
/* ==== Select deflation window size: */
/* . Typical Case: */
/* . If possible and advisable, nibble the entire */
/* . active block. If not, use size MIN(NWR,NWMAX) */
/* . or MIN(NWR+1,NWMAX) depending upon which has */
/* . the smaller corresponding subdiagonal entry */
/* . (a heuristic). */
/* . */
/* . Exceptional Case: */
/* . If there have been no deflations in KEXNW or */
/* . more iterations, then vary the deflation window */
/* . size. At first, because, larger windows are, */
/* . in general, more powerful than smaller ones, */
/* . rapidly increase the window to the maximum possible. */
/* . Then, gradually reduce the window size. ==== */
nh = kbot - ktop + 1;
nwupbd = MIN(nh,nwmax);
if (ndfl < 5) {
nw = MIN(nwupbd,nwr);
} else {
/* Computing MIN */
i__2 = nwupbd, i__3 = nw << 1;
nw = MIN(i__2,i__3);
}
if (nw < nwmax) {
if (nw >= nh - 1) {
nw = nh;
} else {
kwtop = kbot - nw + 1;
if ((r__1 = h__[kwtop + (kwtop - 1) * h_dim1], ABS(r__1))
> (r__2 = h__[kwtop - 1 + (kwtop - 2) * h_dim1],
ABS(r__2))) {
++nw;
}
}
}
if (ndfl < 5) {
ndec = -1;
} else if (ndec >= 0 || nw >= nwupbd) {
++ndec;
if (nw - ndec < 2) {
ndec = 0;
}
nw -= ndec;
}
/* ==== Aggressive early deflation: */
/* . split workspace under the subdiagonal into */
/* . - an nw-by-nw work array V in the lower */
/* . left-hand-corner, */
/* . - an NW-by-at-least-NW-but-more-is-better */
/* . (NW-by-NHO) horizontal work array along */
/* . the bottom edge, */
/* . - an at-least-NW-but-more-is-better (NHV-by-NW) */
/* . vertical work array along the left-hand-edge. */
/* . ==== */
kv = *n - nw + 1;
kt = nw + 1;
nho = *n - nw - 1 - kt + 1;
kwv = nw + 2;
nve = *n - nw - kwv + 1;
/* ==== Aggressive early deflation ==== */
slaqr3_(wantt, wantz, n, &ktop, &kbot, &nw, &h__[h_offset], ldh,
iloz, ihiz, &z__[z_offset], ldz, &ls, &ld, &wr[1], &wi[1],
&h__[kv + h_dim1], ldh, &nho, &h__[kv + kt * h_dim1],
ldh, &nve, &h__[kwv + h_dim1], ldh, &work[1], lwork);
/* ==== Adjust KBOT accounting for new deflations. ==== */
kbot -= ld;
/* ==== KS points to the shifts. ==== */
ks = kbot - ls + 1;
/* ==== Skip an expensive QR sweep if there is a (partly */
/* . heuristic) reason to expect that many eigenvalues */
/* . will deflate without it. Here, the QR sweep is */
/* . skipped if many eigenvalues have just been deflated */
/* . or if the remaining active block is small. */
if (ld == 0 || ld * 100 <= nw * nibble && kbot - ktop + 1 > MIN(
nmin,nwmax)) {
/* ==== NS = nominal number of simultaneous shifts. */
/* . This may be lowered (slightly) if SLAQR3 */
/* . did not provide that many shifts. ==== */
/* Computing MIN */
/* Computing MAX */
i__4 = 2, i__5 = kbot - ktop;
i__2 = MIN(nsmax,nsr), i__3 = MAX(i__4,i__5);
ns = MIN(i__2,i__3);
ns -= ns % 2;
/* ==== If there have been no deflations */
/* . in a multiple of KEXSH iterations, */
/* . then try exceptional shifts. */
/* . Otherwise use shifts provided by */
/* . SLAQR3 above or from the eigenvalues */
/* . of a trailing principal submatrix. ==== */
if (ndfl % 6 == 0) {
ks = kbot - ns + 1;
/* Computing MAX */
i__3 = ks + 1, i__4 = ktop + 2;
i__2 = MAX(i__3,i__4);
for (i__ = kbot; i__ >= i__2; i__ += -2) {
ss = (r__1 = h__[i__ + (i__ - 1) * h_dim1], ABS(r__1)
) + (r__2 = h__[i__ - 1 + (i__ - 2) * h_dim1],
ABS(r__2));
aa = ss * .75f + h__[i__ + i__ * h_dim1];
bb = ss;
cc = ss * -.4375f;
dd = aa;
slanv2_(&aa, &bb, &cc, &dd, &wr[i__ - 1], &wi[i__ - 1]
, &wr[i__], &wi[i__], &cs, &sn);
/* L30: */
}
if (ks == ktop) {
wr[ks + 1] = h__[ks + 1 + (ks + 1) * h_dim1];
wi[ks + 1] = 0.f;
wr[ks] = wr[ks + 1];
wi[ks] = wi[ks + 1];
}
} else {
/* ==== Got NS/2 or fewer shifts? Use SLAQR4 or */
/* . SLAHQR on a trailing principal submatrix to */
/* . get more. (Since NS.LE.NSMAX.LE.(N+6)/9, */
/* . there is enough space below the subdiagonal */
/* . to fit an NS-by-NS scratch array.) ==== */
if (kbot - ks + 1 <= ns / 2) {
ks = kbot - ns + 1;
kt = *n - ns + 1;
slacpy_("A", &ns, &ns, &h__[ks + ks * h_dim1], ldh, &
h__[kt + h_dim1], ldh);
if (ns > nmin) {
slaqr4_(&c_false, &c_false, &ns, &c__1, &ns, &h__[
kt + h_dim1], ldh, &wr[ks], &wi[ks], &
c__1, &c__1, zdum, &c__1, &work[1], lwork,
&inf);
} else {
slahqr_(&c_false, &c_false, &ns, &c__1, &ns, &h__[
kt + h_dim1], ldh, &wr[ks], &wi[ks], &
c__1, &c__1, zdum, &c__1, &inf);
}
ks += inf;
/* ==== In case of a rare QR failure use */
/* . eigenvalues of the trailing 2-by-2 */
/* . principal submatrix. ==== */
if (ks >= kbot) {
aa = h__[kbot - 1 + (kbot - 1) * h_dim1];
cc = h__[kbot + (kbot - 1) * h_dim1];
bb = h__[kbot - 1 + kbot * h_dim1];
dd = h__[kbot + kbot * h_dim1];
slanv2_(&aa, &bb, &cc, &dd, &wr[kbot - 1], &wi[
kbot - 1], &wr[kbot], &wi[kbot], &cs, &sn)
;
ks = kbot - 1;
}
}
if (kbot - ks + 1 > ns) {
/* ==== Sort the shifts (Helps a little) */
/* . Bubble sort keeps complex conjugate */
/* . pairs together. ==== */
sorted = FALSE;
i__2 = ks + 1;
for (k = kbot; k >= i__2; --k) {
if (sorted) {
goto L60;
}
sorted = TRUE;
i__3 = k - 1;
for (i__ = ks; i__ <= i__3; ++i__) {
if ((r__1 = wr[i__], ABS(r__1)) + (r__2 = wi[
i__], ABS(r__2)) < (r__3 = wr[i__ +
1], ABS(r__3)) + (r__4 = wi[i__ + 1],
ABS(r__4))) {
sorted = FALSE;
swap = wr[i__];
wr[i__] = wr[i__ + 1];
wr[i__ + 1] = swap;
swap = wi[i__];
wi[i__] = wi[i__ + 1];
wi[i__ + 1] = swap;
}
/* L40: */
}
/* L50: */
}
L60:
;
}
/* ==== Shuffle shifts into pairs of float shifts */
/* . and pairs of complex conjugate shifts */
/* . assuming complex conjugate shifts are */
/* . already adjacent to one another. (Yes, */
/* . they are.) ==== */
i__2 = ks + 2;
for (i__ = kbot; i__ >= i__2; i__ += -2) {
if (wi[i__] != -wi[i__ - 1]) {
swap = wr[i__];
wr[i__] = wr[i__ - 1];
wr[i__ - 1] = wr[i__ - 2];
wr[i__ - 2] = swap;
swap = wi[i__];
wi[i__] = wi[i__ - 1];
wi[i__ - 1] = wi[i__ - 2];
wi[i__ - 2] = swap;
}
/* L70: */
}
}
/* ==== If there are only two shifts and both are */
/* . float, then use only one. ==== */
if (kbot - ks + 1 == 2) {
if (wi[kbot] == 0.f) {
if ((r__1 = wr[kbot] - h__[kbot + kbot * h_dim1],
ABS(r__1)) < (r__2 = wr[kbot - 1] - h__[kbot
+ kbot * h_dim1], ABS(r__2))) {
wr[kbot - 1] = wr[kbot];
} else {
wr[kbot] = wr[kbot - 1];
}
}
}
/* ==== Use up to NS of the the smallest magnatiude */
/* . shifts. If there aren't NS shifts available, */
/* . then use them all, possibly dropping one to */
/* . make the number of shifts even. ==== */
/* Computing MIN */
i__2 = ns, i__3 = kbot - ks + 1;
ns = MIN(i__2,i__3);
ns -= ns % 2;
ks = kbot - ns + 1;
/* ==== Small-bulge multi-shift QR sweep: */
/* . split workspace under the subdiagonal into */
/* . - a KDU-by-KDU work array U in the lower */
/* . left-hand-corner, */
/* . - a KDU-by-at-least-KDU-but-more-is-better */
/* . (KDU-by-NHo) horizontal work array WH along */
/* . the bottom edge, */
/* . - and an at-least-KDU-but-more-is-better-by-KDU */
/* . (NVE-by-KDU) vertical work WV arrow along */
/* . the left-hand-edge. ==== */
kdu = ns * 3 - 3;
ku = *n - kdu + 1;
kwh = kdu + 1;
nho = *n - kdu - 3 - (kdu + 1) + 1;
kwv = kdu + 4;
nve = *n - kdu - kwv + 1;
/* ==== Small-bulge multi-shift QR sweep ==== */
slaqr5_(wantt, wantz, &kacc22, n, &ktop, &kbot, &ns, &wr[ks],
&wi[ks], &h__[h_offset], ldh, iloz, ihiz, &z__[
z_offset], ldz, &work[1], &c__3, &h__[ku + h_dim1],
ldh, &nve, &h__[kwv + h_dim1], ldh, &nho, &h__[ku +
kwh * h_dim1], ldh);
}
/* ==== Note progress (or the lack of it). ==== */
if (ld > 0) {
ndfl = 1;
} else {
++ndfl;
}
/* ==== End of main loop ==== */
/* L80: */
}
/* ==== Iteration limit exceeded. Set INFO to show where */
/* . the problem occurred and exit. ==== */
*info = kbot;
L90:
;
}
/* ==== Return the optimal value of LWORK. ==== */
work[1] = (float) lwkopt;
/* ==== End of SLAQR0 ==== */
return 0;
} /* slaqr0_ */
/* ----------------------------------------------------------------------- */
/* Subroutine */ int sneupd_(logical *rvec, char *howmny, logical *select,
real *dr, real *di, real *z__, integer *ldz, real *sigmar, real *
sigmai, real *workev, char *bmat, integer *n, char *which, integer *
nev, real *tol, real *resid, integer *ncv, real *v, integer *ldv,
integer *iparam, integer *ipntr, real *workd, real *workl, integer *
lworkl, integer *info, ftnlen howmny_len, ftnlen bmat_len, ftnlen
which_len)
{
/* System generated locals */
integer v_dim1, v_offset, z_dim1, z_offset, i__1;
real r__1, r__2;
doublereal d__1;
/* Builtin functions */
double pow_dd(doublereal *, doublereal *);
integer s_cmp(char *, char *, ftnlen, ftnlen);
/* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);
/* Local variables */
static integer j, k, ih, jj, np;
static real vl[1] /* was [1][1] */;
static integer ibd, ldh, ldq, iri;
static real sep;
static integer irr, wri, wrr, mode;
static real eps23;
extern /* Subroutine */ int sger_(integer *, integer *, real *, real *,
integer *, real *, integer *, real *, integer *);
static integer ierr;
static real temp;
static integer iwev;
static char type__[6];
static real temp1;
extern doublereal snrm2_(integer *, real *, integer *);
static integer ihbds, iconj;
extern /* Subroutine */ int sscal_(integer *, real *, real *, integer *);
static real conds;
static logical reord;
extern /* Subroutine */ int sgemv_(char *, integer *, integer *, real *,
real *, integer *, real *, integer *, real *, real *, integer *,
ftnlen);
static integer nconv, iwork[1];
static real rnorm;
extern /* Subroutine */ int scopy_(integer *, real *, integer *, real *,
integer *);
static integer ritzi;
extern /* Subroutine */ int strmm_(char *, char *, char *, char *,
integer *, integer *, real *, real *, integer *, real *, integer *
, ftnlen, ftnlen, ftnlen, ftnlen), ivout_(integer *, integer *,
integer *, integer *, char *, ftnlen), smout_(integer *, integer *
, integer *, real *, integer *, integer *, char *, ftnlen);
static integer ritzr;
extern /* Subroutine */ int svout_(integer *, integer *, real *, integer *
, char *, ftnlen), sgeqr2_(integer *, integer *, real *, integer *
, real *, real *, integer *);
extern doublereal slapy2_(real *, real *);
extern /* Subroutine */ int sorm2r_(char *, char *, integer *, integer *,
integer *, real *, integer *, real *, real *, integer *, real *,
integer *, ftnlen, ftnlen);
static integer iheigi, iheigr, bounds, invsub, iuptri, msglvl, outncv,
ishift, numcnv;
extern /* Subroutine */ int slacpy_(char *, integer *, integer *, real *,
integer *, real *, integer *, ftnlen), slahqr_(logical *, logical
*, integer *, integer *, integer *, real *, integer *, real *,
real *, integer *, integer *, real *, integer *, integer *),
slaset_(char *, integer *, integer *, real *, real *, real *,
integer *, ftnlen), strevc_(char *, char *, logical *, integer *,
real *, integer *, real *, integer *, real *, integer *, integer *
, integer *, real *, integer *, ftnlen, ftnlen), strsen_(char *,
char *, logical *, integer *, real *, integer *, real *, integer *
, real *, real *, integer *, real *, real *, real *, integer *,
integer *, integer *, integer *, ftnlen, ftnlen);
extern doublereal slamch_(char *, ftnlen);
extern /* Subroutine */ int sngets_(integer *, char *, integer *, integer
*, real *, real *, real *, real *, real *, ftnlen);
/* %----------------------------------------------------% */
/* | Include files for debugging and timing information | */
/* %----------------------------------------------------% */
/* \SCCS Information: @(#) */
/* FILE: debug.h SID: 2.3 DATE OF SID: 11/16/95 RELEASE: 2 */
/* %---------------------------------% */
/* | See debug.doc for documentation | */
/* %---------------------------------% */
/* %------------------% */
/* | Scalar Arguments | */
/* %------------------% */
/* %--------------------------------% */
/* | See stat.doc for documentation | */
/* %--------------------------------% */
/* \SCCS Information: @(#) */
/* FILE: stat.h SID: 2.2 DATE OF SID: 11/16/95 RELEASE: 2 */
/* %-----------------% */
/* | Array Arguments | */
/* %-----------------% */
/* %------------% */
/* | Parameters | */
/* %------------% */
/* %---------------% */
/* | Local Scalars | */
/* %---------------% */
/* %----------------------% */
/* | External Subroutines | */
/* %----------------------% */
/* %--------------------% */
/* | External Functions | */
/* %--------------------% */
/* %---------------------% */
/* | Intrinsic Functions | */
/* %---------------------% */
/* %-----------------------% */
/* | Executable Statements | */
/* %-----------------------% */
/* %------------------------% */
/* | Set default parameters | */
/* %------------------------% */
/* Parameter adjustments */
z_dim1 = *ldz;
z_offset = 1 + z_dim1;
z__ -= z_offset;
--workd;
--resid;
--di;
--dr;
--workev;
--select;
v_dim1 = *ldv;
v_offset = 1 + v_dim1;
v -= v_offset;
--iparam;
--ipntr;
--workl;
/* Function Body */
msglvl = debug_1.mneupd;
mode = iparam[7];
nconv = iparam[5];
*info = 0;
/* %---------------------------------% */
/* | Get machine dependent constant. | */
/* %---------------------------------% */
eps23 = slamch_("Epsilon-Machine", (ftnlen)15);
d__1 = (doublereal) eps23;
eps23 = pow_dd(&d__1, &c_b3);
/* %--------------% */
/* | Quick return | */
/* %--------------% */
ierr = 0;
if (nconv <= 0) {
ierr = -14;
} else if (*n <= 0) {
ierr = -1;
} else if (*nev <= 0) {
ierr = -2;
} else if (*ncv <= *nev + 1 || *ncv > *n) {
ierr = -3;
} else if (s_cmp(which, "LM", (ftnlen)2, (ftnlen)2) != 0 && s_cmp(which,
"SM", (ftnlen)2, (ftnlen)2) != 0 && s_cmp(which, "LR", (ftnlen)2,
(ftnlen)2) != 0 && s_cmp(which, "SR", (ftnlen)2, (ftnlen)2) != 0
&& s_cmp(which, "LI", (ftnlen)2, (ftnlen)2) != 0 && s_cmp(which,
"SI", (ftnlen)2, (ftnlen)2) != 0) {
ierr = -5;
} else if (*(unsigned char *)bmat != 'I' && *(unsigned char *)bmat != 'G')
{
ierr = -6;
} else /* if(complicated condition) */ {
/* Computing 2nd power */
i__1 = *ncv;
if (*lworkl < i__1 * i__1 * 3 + *ncv * 6) {
ierr = -7;
} else if (*(unsigned char *)howmny != 'A' && *(unsigned char *)
howmny != 'P' && *(unsigned char *)howmny != 'S' && *rvec) {
ierr = -13;
} else if (*(unsigned char *)howmny == 'S') {
ierr = -12;
}
}
if (mode == 1 || mode == 2) {
s_copy(type__, "REGULR", (ftnlen)6, (ftnlen)6);
} else if (mode == 3 && *sigmai == 0.f) {
s_copy(type__, "SHIFTI", (ftnlen)6, (ftnlen)6);
} else if (mode == 3) {
s_copy(type__, "REALPT", (ftnlen)6, (ftnlen)6);
} else if (mode == 4) {
s_copy(type__, "IMAGPT", (ftnlen)6, (ftnlen)6);
} else {
ierr = -10;
}
if (mode == 1 && *(unsigned char *)bmat == 'G') {
ierr = -11;
}
/* %------------% */
/* | Error Exit | */
/* %------------% */
if (ierr != 0) {
*info = ierr;
goto L9000;
}
/* %--------------------------------------------------------% */
/* | Pointer into WORKL for address of H, RITZ, BOUNDS, Q | */
/* | etc... and the remaining workspace. | */
/* | Also update pointer to be used on output. | */
/* | Memory is laid out as follows: | */
/* | workl(1:ncv*ncv) := generated Hessenberg matrix | */
/* | workl(ncv*ncv+1:ncv*ncv+2*ncv) := real and imaginary | */
/* | parts of ritz values | */
/* | workl(ncv*ncv+2*ncv+1:ncv*ncv+3*ncv) := error bounds | */
/* %--------------------------------------------------------% */
/* %-----------------------------------------------------------% */
/* | The following is used and set by SNEUPD. | */
/* | workl(ncv*ncv+3*ncv+1:ncv*ncv+4*ncv) := The untransformed | */
/* | real part of the Ritz values. | */
/* | workl(ncv*ncv+4*ncv+1:ncv*ncv+5*ncv) := The untransformed | */
/* | imaginary part of the Ritz values. | */
/* | workl(ncv*ncv+5*ncv+1:ncv*ncv+6*ncv) := The untransformed | */
/* | error bounds of the Ritz values | */
/* | workl(ncv*ncv+6*ncv+1:2*ncv*ncv+6*ncv) := Holds the upper | */
/* | quasi-triangular matrix for H | */
/* | workl(2*ncv*ncv+6*ncv+1: 3*ncv*ncv+6*ncv) := Holds the | */
/* | associated matrix representation of the invariant | */
/* | subspace for H. | */
/* | GRAND total of NCV * ( 3 * NCV + 6 ) locations. | */
/* %-----------------------------------------------------------% */
ih = ipntr[5];
ritzr = ipntr[6];
ritzi = ipntr[7];
bounds = ipntr[8];
ldh = *ncv;
ldq = *ncv;
iheigr = bounds + ldh;
iheigi = iheigr + ldh;
ihbds = iheigi + ldh;
iuptri = ihbds + ldh;
invsub = iuptri + ldh * *ncv;
ipntr[9] = iheigr;
ipntr[10] = iheigi;
ipntr[11] = ihbds;
ipntr[12] = iuptri;
ipntr[13] = invsub;
wrr = 1;
wri = *ncv + 1;
iwev = wri + *ncv;
/* %-----------------------------------------% */
/* | irr points to the REAL part of the Ritz | */
/* | values computed by _neigh before | */
/* | exiting _naup2. | */
/* | iri points to the IMAGINARY part of the | */
/* | Ritz values computed by _neigh | */
/* | before exiting _naup2. | */
/* | ibd points to the Ritz estimates | */
/* | computed by _neigh before exiting | */
/* | _naup2. | */
/* %-----------------------------------------% */
irr = ipntr[14] + *ncv * *ncv;
iri = irr + *ncv;
ibd = iri + *ncv;
/* %------------------------------------% */
/* | RNORM is B-norm of the RESID(1:N). | */
/* %------------------------------------% */
rnorm = workl[ih + 2];
workl[ih + 2] = 0.f;
if (msglvl > 2) {
svout_(&debug_1.logfil, ncv, &workl[irr], &debug_1.ndigit, "_neupd: "
"Real part of Ritz values passed in from _NAUPD.", (ftnlen)55);
svout_(&debug_1.logfil, ncv, &workl[iri], &debug_1.ndigit, "_neupd: "
"Imag part of Ritz values passed in from _NAUPD.", (ftnlen)55);
svout_(&debug_1.logfil, ncv, &workl[ibd], &debug_1.ndigit, "_neupd: "
"Ritz estimates passed in from _NAUPD.", (ftnlen)45);
}
if (*rvec) {
reord = FALSE_;
/* %---------------------------------------------------% */
/* | Use the temporary bounds array to store indices | */
/* | These will be used to mark the select array later | */
/* %---------------------------------------------------% */
i__1 = *ncv;
for (j = 1; j <= i__1; ++j) {
workl[bounds + j - 1] = (real) j;
select[j] = FALSE_;
/* L10: */
}
/* %-------------------------------------% */
/* | Select the wanted Ritz values. | */
/* | Sort the Ritz values so that the | */
/* | wanted ones appear at the tailing | */
/* | NEV positions of workl(irr) and | */
/* | workl(iri). Move the corresponding | */
/* | error estimates in workl(bound) | */
/* | accordingly. | */
/* %-------------------------------------% */
np = *ncv - *nev;
ishift = 0;
sngets_(&ishift, which, nev, &np, &workl[irr], &workl[iri], &workl[
bounds], &workl[1], &workl[np + 1], (ftnlen)2);
if (msglvl > 2) {
svout_(&debug_1.logfil, ncv, &workl[irr], &debug_1.ndigit, "_neu"
"pd: Real part of Ritz values after calling _NGETS.", (
ftnlen)54);
svout_(&debug_1.logfil, ncv, &workl[iri], &debug_1.ndigit, "_neu"
"pd: Imag part of Ritz values after calling _NGETS.", (
ftnlen)54);
svout_(&debug_1.logfil, ncv, &workl[bounds], &debug_1.ndigit,
"_neupd: Ritz value indices after calling _NGETS.", (
ftnlen)48);
}
/* %-----------------------------------------------------% */
/* | Record indices of the converged wanted Ritz values | */
/* | Mark the select array for possible reordering | */
/* %-----------------------------------------------------% */
numcnv = 0;
i__1 = *ncv;
for (j = 1; j <= i__1; ++j) {
/* Computing MAX */
r__1 = eps23, r__2 = slapy2_(&workl[irr + *ncv - j], &workl[iri +
*ncv - j]);
temp1 = dmax(r__1,r__2);
jj = workl[bounds + *ncv - j];
if (numcnv < nconv && workl[ibd + jj - 1] <= *tol * temp1) {
select[jj] = TRUE_;
++numcnv;
if (jj > *nev) {
reord = TRUE_;
}
}
/* L11: */
}
/* %-----------------------------------------------------------% */
/* | Check the count (numcnv) of converged Ritz values with | */
/* | the number (nconv) reported by dnaupd. If these two | */
/* | are different then there has probably been an error | */
/* | caused by incorrect passing of the dnaupd data. | */
/* %-----------------------------------------------------------% */
if (msglvl > 2) {
ivout_(&debug_1.logfil, &c__1, &numcnv, &debug_1.ndigit, "_neupd"
": Number of specified eigenvalues", (ftnlen)39);
ivout_(&debug_1.logfil, &c__1, &nconv, &debug_1.ndigit, "_neupd:"
" Number of \"converged\" eigenvalues", (ftnlen)41);
}
if (numcnv != nconv) {
*info = -15;
goto L9000;
}
/* %-----------------------------------------------------------% */
/* | Call LAPACK routine slahqr to compute the real Schur form | */
/* | of the upper Hessenberg matrix returned by SNAUPD. | */
/* | Make a copy of the upper Hessenberg matrix. | */
/* | Initialize the Schur vector matrix Q to the identity. | */
/* %-----------------------------------------------------------% */
i__1 = ldh * *ncv;
scopy_(&i__1, &workl[ih], &c__1, &workl[iuptri], &c__1);
slaset_("All", ncv, ncv, &c_b37, &c_b38, &workl[invsub], &ldq, (
ftnlen)3);
slahqr_(&c_true, &c_true, ncv, &c__1, ncv, &workl[iuptri], &ldh, &
workl[iheigr], &workl[iheigi], &c__1, ncv, &workl[invsub], &
ldq, &ierr);
scopy_(ncv, &workl[invsub + *ncv - 1], &ldq, &workl[ihbds], &c__1);
if (ierr != 0) {
*info = -8;
goto L9000;
}
if (msglvl > 1) {
svout_(&debug_1.logfil, ncv, &workl[iheigr], &debug_1.ndigit,
"_neupd: Real part of the eigenvalues of H", (ftnlen)41);
svout_(&debug_1.logfil, ncv, &workl[iheigi], &debug_1.ndigit,
"_neupd: Imaginary part of the Eigenvalues of H", (ftnlen)
46);
svout_(&debug_1.logfil, ncv, &workl[ihbds], &debug_1.ndigit,
"_neupd: Last row of the Schur vector matrix", (ftnlen)43)
;
if (msglvl > 3) {
smout_(&debug_1.logfil, ncv, ncv, &workl[iuptri], &ldh, &
debug_1.ndigit, "_neupd: The upper quasi-triangular "
"matrix ", (ftnlen)42);
}
}
if (reord) {
/* %-----------------------------------------------------% */
/* | Reorder the computed upper quasi-triangular matrix. | */
/* %-----------------------------------------------------% */
strsen_("None", "V", &select[1], ncv, &workl[iuptri], &ldh, &
workl[invsub], &ldq, &workl[iheigr], &workl[iheigi], &
nconv, &conds, &sep, &workl[ihbds], ncv, iwork, &c__1, &
ierr, (ftnlen)4, (ftnlen)1);
if (ierr == 1) {
*info = 1;
goto L9000;
}
if (msglvl > 2) {
svout_(&debug_1.logfil, ncv, &workl[iheigr], &debug_1.ndigit,
"_neupd: Real part of the eigenvalues of H--reordered"
, (ftnlen)52);
svout_(&debug_1.logfil, ncv, &workl[iheigi], &debug_1.ndigit,
"_neupd: Imag part of the eigenvalues of H--reordered"
, (ftnlen)52);
if (msglvl > 3) {
smout_(&debug_1.logfil, ncv, ncv, &workl[iuptri], &ldq, &
debug_1.ndigit, "_neupd: Quasi-triangular matrix"
" after re-ordering", (ftnlen)49);
}
}
}
/* %---------------------------------------% */
/* | Copy the last row of the Schur vector | */
/* | into workl(ihbds). This will be used | */
/* | to compute the Ritz estimates of | */
/* | converged Ritz values. | */
/* %---------------------------------------% */
scopy_(ncv, &workl[invsub + *ncv - 1], &ldq, &workl[ihbds], &c__1);
/* %----------------------------------------------------% */
/* | Place the computed eigenvalues of H into DR and DI | */
/* | if a spectral transformation was not used. | */
/* %----------------------------------------------------% */
if (s_cmp(type__, "REGULR", (ftnlen)6, (ftnlen)6) == 0) {
scopy_(&nconv, &workl[iheigr], &c__1, &dr[1], &c__1);
scopy_(&nconv, &workl[iheigi], &c__1, &di[1], &c__1);
}
/* %----------------------------------------------------------% */
/* | Compute the QR factorization of the matrix representing | */
/* | the wanted invariant subspace located in the first NCONV | */
/* | columns of workl(invsub,ldq). | */
/* %----------------------------------------------------------% */
sgeqr2_(ncv, &nconv, &workl[invsub], &ldq, &workev[1], &workev[*ncv +
1], &ierr);
/* %---------------------------------------------------------% */
/* | * Postmultiply V by Q using sorm2r. | */
/* | * Copy the first NCONV columns of VQ into Z. | */
/* | * Postmultiply Z by R. | */
/* | The N by NCONV matrix Z is now a matrix representation | */
/* | of the approximate invariant subspace associated with | */
/* | the Ritz values in workl(iheigr) and workl(iheigi) | */
/* | The first NCONV columns of V are now approximate Schur | */
/* | vectors associated with the real upper quasi-triangular | */
/* | matrix of order NCONV in workl(iuptri) | */
/* %---------------------------------------------------------% */
sorm2r_("Right", "Notranspose", n, ncv, &nconv, &workl[invsub], &ldq,
&workev[1], &v[v_offset], ldv, &workd[*n + 1], &ierr, (ftnlen)
5, (ftnlen)11);
slacpy_("All", n, &nconv, &v[v_offset], ldv, &z__[z_offset], ldz, (
ftnlen)3);
i__1 = nconv;
for (j = 1; j <= i__1; ++j) {
/* %---------------------------------------------------% */
/* | Perform both a column and row scaling if the | */
/* | diagonal element of workl(invsub,ldq) is negative | */
/* | I'm lazy and don't take advantage of the upper | */
/* | quasi-triangular form of workl(iuptri,ldq) | */
/* | Note that since Q is orthogonal, R is a diagonal | */
/* | matrix consisting of plus or minus ones | */
/* %---------------------------------------------------% */
if (workl[invsub + (j - 1) * ldq + j - 1] < 0.f) {
sscal_(&nconv, &c_b64, &workl[iuptri + j - 1], &ldq);
sscal_(&nconv, &c_b64, &workl[iuptri + (j - 1) * ldq], &c__1);
}
/* L20: */
}
if (*(unsigned char *)howmny == 'A') {
/* %--------------------------------------------% */
/* | Compute the NCONV wanted eigenvectors of T | */
/* | located in workl(iuptri,ldq). | */
/* %--------------------------------------------% */
i__1 = *ncv;
for (j = 1; j <= i__1; ++j) {
if (j <= nconv) {
select[j] = TRUE_;
} else {
select[j] = FALSE_;
}
/* L30: */
}
strevc_("Right", "Select", &select[1], ncv, &workl[iuptri], &ldq,
vl, &c__1, &workl[invsub], &ldq, ncv, &outncv, &workev[1],
&ierr, (ftnlen)5, (ftnlen)6);
if (ierr != 0) {
*info = -9;
goto L9000;
}
/* %------------------------------------------------% */
/* | Scale the returning eigenvectors so that their | */
/* | Euclidean norms are all one. LAPACK subroutine | */
/* | strevc returns each eigenvector normalized so | */
/* | that the element of largest magnitude has | */
/* | magnitude 1; | */
/* %------------------------------------------------% */
iconj = 0;
i__1 = nconv;
for (j = 1; j <= i__1; ++j) {
if (workl[iheigi + j - 1] == 0.f) {
/* %----------------------% */
/* | real eigenvalue case | */
/* %----------------------% */
temp = snrm2_(ncv, &workl[invsub + (j - 1) * ldq], &c__1);
r__1 = 1.f / temp;
sscal_(ncv, &r__1, &workl[invsub + (j - 1) * ldq], &c__1);
} else {
/* %-------------------------------------------% */
/* | Complex conjugate pair case. Note that | */
/* | since the real and imaginary part of | */
/* | the eigenvector are stored in consecutive | */
/* | columns, we further normalize by the | */
/* | square root of two. | */
/* %-------------------------------------------% */
if (iconj == 0) {
r__1 = snrm2_(ncv, &workl[invsub + (j - 1) * ldq], &
c__1);
r__2 = snrm2_(ncv, &workl[invsub + j * ldq], &c__1);
temp = slapy2_(&r__1, &r__2);
r__1 = 1.f / temp;
sscal_(ncv, &r__1, &workl[invsub + (j - 1) * ldq], &
c__1);
r__1 = 1.f / temp;
sscal_(ncv, &r__1, &workl[invsub + j * ldq], &c__1);
iconj = 1;
} else {
iconj = 0;
}
}
/* L40: */
}
sgemv_("T", ncv, &nconv, &c_b38, &workl[invsub], &ldq, &workl[
ihbds], &c__1, &c_b37, &workev[1], &c__1, (ftnlen)1);
iconj = 0;
i__1 = nconv;
for (j = 1; j <= i__1; ++j) {
if (workl[iheigi + j - 1] != 0.f) {
/* %-------------------------------------------% */
/* | Complex conjugate pair case. Note that | */
/* | since the real and imaginary part of | */
/* | the eigenvector are stored in consecutive | */
/* %-------------------------------------------% */
if (iconj == 0) {
workev[j] = slapy2_(&workev[j], &workev[j + 1]);
workev[j + 1] = workev[j];
iconj = 1;
} else {
iconj = 0;
}
}
/* L45: */
}
if (msglvl > 2) {
scopy_(ncv, &workl[invsub + *ncv - 1], &ldq, &workl[ihbds], &
c__1);
svout_(&debug_1.logfil, ncv, &workl[ihbds], &debug_1.ndigit,
"_neupd: Last row of the eigenvector matrix for T", (
ftnlen)48);
if (msglvl > 3) {
smout_(&debug_1.logfil, ncv, ncv, &workl[invsub], &ldq, &
debug_1.ndigit, "_neupd: The eigenvector matrix "
"for T", (ftnlen)36);
}
}
/* %---------------------------------------% */
/* | Copy Ritz estimates into workl(ihbds) | */
/* %---------------------------------------% */
scopy_(&nconv, &workev[1], &c__1, &workl[ihbds], &c__1);
/* %---------------------------------------------------------% */
/* | Compute the QR factorization of the eigenvector matrix | */
/* | associated with leading portion of T in the first NCONV | */
/* | columns of workl(invsub,ldq). | */
/* %---------------------------------------------------------% */
sgeqr2_(ncv, &nconv, &workl[invsub], &ldq, &workev[1], &workev[*
ncv + 1], &ierr);
/* %----------------------------------------------% */
/* | * Postmultiply Z by Q. | */
/* | * Postmultiply Z by R. | */
/* | The N by NCONV matrix Z is now contains the | */
/* | Ritz vectors associated with the Ritz values | */
/* | in workl(iheigr) and workl(iheigi). | */
/* %----------------------------------------------% */
sorm2r_("Right", "Notranspose", n, ncv, &nconv, &workl[invsub], &
ldq, &workev[1], &z__[z_offset], ldz, &workd[*n + 1], &
ierr, (ftnlen)5, (ftnlen)11);
strmm_("Right", "Upper", "No transpose", "Non-unit", n, &nconv, &
c_b38, &workl[invsub], &ldq, &z__[z_offset], ldz, (ftnlen)
5, (ftnlen)5, (ftnlen)12, (ftnlen)8);
}
} else {
/* %------------------------------------------------------% */
/* | An approximate invariant subspace is not needed. | */
/* | Place the Ritz values computed SNAUPD into DR and DI | */
/* %------------------------------------------------------% */
scopy_(&nconv, &workl[ritzr], &c__1, &dr[1], &c__1);
scopy_(&nconv, &workl[ritzi], &c__1, &di[1], &c__1);
scopy_(&nconv, &workl[ritzr], &c__1, &workl[iheigr], &c__1);
scopy_(&nconv, &workl[ritzi], &c__1, &workl[iheigi], &c__1);
scopy_(&nconv, &workl[bounds], &c__1, &workl[ihbds], &c__1);
}
/* %------------------------------------------------% */
/* | Transform the Ritz values and possibly vectors | */
/* | and corresponding error bounds of OP to those | */
/* | of A*x = lambda*B*x. | */
/* %------------------------------------------------% */
if (s_cmp(type__, "REGULR", (ftnlen)6, (ftnlen)6) == 0) {
if (*rvec) {
sscal_(ncv, &rnorm, &workl[ihbds], &c__1);
}
} else {
/* %---------------------------------------% */
/* | A spectral transformation was used. | */
/* | * Determine the Ritz estimates of the | */
/* | Ritz values in the original system. | */
/* %---------------------------------------% */
if (s_cmp(type__, "SHIFTI", (ftnlen)6, (ftnlen)6) == 0) {
if (*rvec) {
sscal_(ncv, &rnorm, &workl[ihbds], &c__1);
}
i__1 = *ncv;
for (k = 1; k <= i__1; ++k) {
temp = slapy2_(&workl[iheigr + k - 1], &workl[iheigi + k - 1])
;
workl[ihbds + k - 1] = (r__1 = workl[ihbds + k - 1], dabs(
r__1)) / temp / temp;
/* L50: */
}
} else if (s_cmp(type__, "REALPT", (ftnlen)6, (ftnlen)6) == 0) {
i__1 = *ncv;
for (k = 1; k <= i__1; ++k) {
/* L60: */
}
} else if (s_cmp(type__, "IMAGPT", (ftnlen)6, (ftnlen)6) == 0) {
i__1 = *ncv;
for (k = 1; k <= i__1; ++k) {
/* L70: */
}
}
/* %-----------------------------------------------------------% */
/* | * Transform the Ritz values back to the original system. | */
/* | For TYPE = 'SHIFTI' the transformation is | */
/* | lambda = 1/theta + sigma | */
/* | For TYPE = 'REALPT' or 'IMAGPT' the user must from | */
/* | Rayleigh quotients or a projection. See remark 3 above.| */
/* | NOTES: | */
/* | *The Ritz vectors are not affected by the transformation. | */
/* %-----------------------------------------------------------% */
if (s_cmp(type__, "SHIFTI", (ftnlen)6, (ftnlen)6) == 0) {
i__1 = *ncv;
for (k = 1; k <= i__1; ++k) {
temp = slapy2_(&workl[iheigr + k - 1], &workl[iheigi + k - 1])
;
workl[iheigr + k - 1] = workl[iheigr + k - 1] / temp / temp +
*sigmar;
workl[iheigi + k - 1] = -workl[iheigi + k - 1] / temp / temp
+ *sigmai;
/* L80: */
}
scopy_(&nconv, &workl[iheigr], &c__1, &dr[1], &c__1);
scopy_(&nconv, &workl[iheigi], &c__1, &di[1], &c__1);
} else if (s_cmp(type__, "REALPT", (ftnlen)6, (ftnlen)6) == 0 ||
s_cmp(type__, "IMAGPT", (ftnlen)6, (ftnlen)6) == 0) {
scopy_(&nconv, &workl[iheigr], &c__1, &dr[1], &c__1);
scopy_(&nconv, &workl[iheigi], &c__1, &di[1], &c__1);
}
}
if (s_cmp(type__, "SHIFTI", (ftnlen)6, (ftnlen)6) == 0 && msglvl > 1) {
svout_(&debug_1.logfil, &nconv, &dr[1], &debug_1.ndigit, "_neupd: Un"
"transformed real part of the Ritz valuess.", (ftnlen)52);
svout_(&debug_1.logfil, &nconv, &di[1], &debug_1.ndigit, "_neupd: Un"
"transformed imag part of the Ritz valuess.", (ftnlen)52);
svout_(&debug_1.logfil, &nconv, &workl[ihbds], &debug_1.ndigit, "_ne"
"upd: Ritz estimates of untransformed Ritz values.", (ftnlen)
52);
} else if (s_cmp(type__, "REGULR", (ftnlen)6, (ftnlen)6) == 0 && msglvl >
1) {
svout_(&debug_1.logfil, &nconv, &dr[1], &debug_1.ndigit, "_neupd: Re"
"al parts of converged Ritz values.", (ftnlen)44);
svout_(&debug_1.logfil, &nconv, &di[1], &debug_1.ndigit, "_neupd: Im"
"ag parts of converged Ritz values.", (ftnlen)44);
svout_(&debug_1.logfil, &nconv, &workl[ihbds], &debug_1.ndigit, "_ne"
"upd: Associated Ritz estimates.", (ftnlen)34);
}
/* %-------------------------------------------------% */
/* | Eigenvector Purification step. Formally perform | */
/* | one of inverse subspace iteration. Only used | */
/* | for MODE = 2. | */
/* %-------------------------------------------------% */
if (*rvec && *(unsigned char *)howmny == 'A' && s_cmp(type__, "SHIFTI", (
ftnlen)6, (ftnlen)6) == 0) {
/* %------------------------------------------------% */
/* | Purify the computed Ritz vectors by adding a | */
/* | little bit of the residual vector: | */
/* | T | */
/* | resid(:)*( e s ) / theta | */
/* | NCV | */
/* | where H s = s theta. Remember that when theta | */
/* | has nonzero imaginary part, the corresponding | */
/* | Ritz vector is stored across two columns of Z. | */
/* %------------------------------------------------% */
iconj = 0;
i__1 = nconv;
for (j = 1; j <= i__1; ++j) {
if (workl[iheigi + j - 1] == 0.f) {
workev[j] = workl[invsub + (j - 1) * ldq + *ncv - 1] / workl[
iheigr + j - 1];
} else if (iconj == 0) {
temp = slapy2_(&workl[iheigr + j - 1], &workl[iheigi + j - 1])
;
workev[j] = (workl[invsub + (j - 1) * ldq + *ncv - 1] * workl[
iheigr + j - 1] + workl[invsub + j * ldq + *ncv - 1] *
workl[iheigi + j - 1]) / temp / temp;
workev[j + 1] = (workl[invsub + j * ldq + *ncv - 1] * workl[
iheigr + j - 1] - workl[invsub + (j - 1) * ldq + *ncv
- 1] * workl[iheigi + j - 1]) / temp / temp;
iconj = 1;
} else {
iconj = 0;
}
/* L110: */
}
/* %---------------------------------------% */
/* | Perform a rank one update to Z and | */
/* | purify all the Ritz vectors together. | */
/* %---------------------------------------% */
sger_(n, &nconv, &c_b38, &resid[1], &c__1, &workev[1], &c__1, &z__[
z_offset], ldz);
}
L9000:
return 0;
/* %---------------% */
/* | End of SNEUPD | */
/* %---------------% */
} /* sneupd_ */
/* Subroutine */ int sptsvx_(char *fact, integer *n, integer *nrhs, real *d__,
real *e, real *df, real *ef, real *b, integer *ldb, real *x, integer
*ldx, real *rcond, real *ferr, real *berr, real *work, integer *info,
ftnlen fact_len)
{
/* System generated locals */
integer b_dim1, b_offset, x_dim1, x_offset, i__1;
/* Local variables */
extern logical lsame_(char *, char *, ftnlen, ftnlen);
static real anorm;
extern /* Subroutine */ int scopy_(integer *, real *, integer *, real *,
integer *);
extern doublereal slamch_(char *, ftnlen);
static logical nofact;
extern /* Subroutine */ int xerbla_(char *, integer *, ftnlen), slacpy_(
char *, integer *, integer *, real *, integer *, real *, integer *
, ftnlen);
extern doublereal slanst_(char *, integer *, real *, real *, ftnlen);
extern /* Subroutine */ int sptcon_(integer *, real *, real *, real *,
real *, real *, integer *), sptrfs_(integer *, integer *, real *,
real *, real *, real *, real *, integer *, real *, integer *,
real *, real *, real *, integer *), spttrf_(integer *, real *,
real *, integer *), spttrs_(integer *, integer *, real *, real *,
real *, integer *, integer *);
/* -- 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 */
/* ======= */
/* SPTSVX uses the factorization A = L*D*L**T to compute the solution */
/* to a real system of linear equations A*X = B, where A is an N-by-N */
/* symmetric positive definite tridiagonal matrix and X and B are */
/* N-by-NRHS matrices. */
/* Error bounds on the solution and a condition estimate are also */
/* provided. */
/* Description */
/* =========== */
/* The following steps are performed: */
/* 1. If FACT = 'N', the matrix A is factored as A = L*D*L**T, where L */
/* is a unit lower bidiagonal matrix and D is diagonal. The */
/* factorization can also be regarded as having the form */
/* A = U**T*D*U. */
/* 2. If the leading i-by-i principal minor is not positive definite, */
/* then the routine returns with INFO = i. Otherwise, the factored */
/* form of A is used to estimate the condition number of the matrix */
/* A. If the reciprocal of the condition number is less than machine */
/* precision, INFO = N+1 is returned as a warning, but the routine */
/* still goes on to solve for X and compute error bounds as */
/* described below. */
/* 3. The system of equations is solved for X using the factored form */
/* of A. */
/* 4. Iterative refinement is applied to improve the computed solution */
/* matrix and calculate error bounds and backward error estimates */
/* for it. */
/* Arguments */
/* ========= */
/* FACT (input) CHARACTER*1 */
/* Specifies whether or not the factored form of A has been */
/* supplied on entry. */
/* = 'F': On entry, DF and EF contain the factored form of A. */
/* D, E, DF, and EF will not be modified. */
/* = 'N': The matrix A will be copied to DF and EF and */
/* factored. */
/* N (input) INTEGER */
/* The order of the matrix A. N >= 0. */
/* NRHS (input) INTEGER */
/* The number of right hand sides, i.e., the number of columns */
/* of the matrices B and X. NRHS >= 0. */
/* D (input) REAL array, dimension (N) */
/* The n diagonal elements of the tridiagonal matrix A. */
/* E (input) REAL array, dimension (N-1) */
/* The (n-1) subdiagonal elements of the tridiagonal matrix A. */
/* DF (input or output) REAL array, dimension (N) */
/* If FACT = 'F', then DF is an input argument and on entry */
/* contains the n diagonal elements of the diagonal matrix D */
/* from the L*D*L**T factorization of A. */
/* If FACT = 'N', then DF is an output argument and on exit */
/* contains the n diagonal elements of the diagonal matrix D */
/* from the L*D*L**T factorization of A. */
/* EF (input or output) REAL array, dimension (N-1) */
/* If FACT = 'F', then EF is an input argument and on entry */
/* contains the (n-1) subdiagonal elements of the unit */
/* bidiagonal factor L from the L*D*L**T factorization of A. */
/* If FACT = 'N', then EF is an output argument and on exit */
/* contains the (n-1) subdiagonal elements of the unit */
/* bidiagonal factor L from the L*D*L**T factorization of A. */
/* B (input) REAL array, dimension (LDB,NRHS) */
/* The N-by-NRHS right hand side matrix B. */
/* LDB (input) INTEGER */
/* The leading dimension of the array B. LDB >= max(1,N). */
/* X (output) REAL array, dimension (LDX,NRHS) */
/* If INFO = 0 of INFO = N+1, the N-by-NRHS solution matrix X. */
/* LDX (input) INTEGER */
/* The leading dimension of the array X. LDX >= max(1,N). */
/* RCOND (output) REAL */
/* The reciprocal condition number of the matrix A. If RCOND */
/* is less than the machine precision (in particular, if */
/* RCOND = 0), the matrix is singular to working precision. */
/* This condition is indicated by a return code of INFO > 0. */
/* FERR (output) REAL array, dimension (NRHS) */
/* The forward error bound for each solution vector */
/* X(j) (the j-th column of the solution matrix X). */
/* If XTRUE is the true solution corresponding to X(j), FERR(j) */
/* is an estimated upper bound for the magnitude of the largest */
/* element in (X(j) - XTRUE) divided by the magnitude of the */
/* largest element in X(j). */
/* BERR (output) REAL array, dimension (NRHS) */
/* The componentwise relative backward error of each solution */
/* vector X(j) (i.e., the smallest relative change in any */
/* element of A or B that makes X(j) an exact solution). */
/* WORK (workspace) REAL array, dimension (2*N) */
/* INFO (output) INTEGER */
/* = 0: successful exit */
/* < 0: if INFO = -i, the i-th argument had an illegal value */
/* > 0: if INFO = i, and i is */
/* <= N: the leading minor of order i of A is */
/* not positive definite, so the factorization */
/* could not be completed, and the solution has not */
/* been computed. RCOND = 0 is returned. */
/* = N+1: U is nonsingular, but RCOND is less than machine */
/* precision, meaning that the matrix is singular */
/* to working precision. Nevertheless, the */
/* solution and error bounds are computed because */
/* there are a number of situations where the */
/* computed solution can be more accurate than the */
/* value of RCOND would suggest. */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Executable Statements .. */
/* Test the input parameters. */
/* Parameter adjustments */
--d__;
--e;
--df;
--ef;
b_dim1 = *ldb;
b_offset = 1 + b_dim1;
b -= b_offset;
x_dim1 = *ldx;
x_offset = 1 + x_dim1;
x -= x_offset;
--ferr;
--berr;
--work;
/* Function Body */
*info = 0;
nofact = lsame_(fact, "N", (ftnlen)1, (ftnlen)1);
if (! nofact && ! lsame_(fact, "F", (ftnlen)1, (ftnlen)1)) {
*info = -1;
} else if (*n < 0) {
*info = -2;
} else if (*nrhs < 0) {
*info = -3;
} else if (*ldb < max(1,*n)) {
*info = -9;
} else if (*ldx < max(1,*n)) {
*info = -11;
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("SPTSVX", &i__1, (ftnlen)6);
return 0;
}
if (nofact) {
/* Compute the L*D*L' (or U'*D*U) factorization of A. */
scopy_(n, &d__[1], &c__1, &df[1], &c__1);
if (*n > 1) {
i__1 = *n - 1;
scopy_(&i__1, &e[1], &c__1, &ef[1], &c__1);
}
spttrf_(n, &df[1], &ef[1], info);
/* Return if INFO is non-zero. */
if (*info != 0) {
if (*info > 0) {
*rcond = 0.f;
}
return 0;
}
}
/* Compute the norm of the matrix A. */
anorm = slanst_("1", n, &d__[1], &e[1], (ftnlen)1);
/* Compute the reciprocal of the condition number of A. */
sptcon_(n, &df[1], &ef[1], &anorm, rcond, &work[1], info);
/* Set INFO = N+1 if the matrix is singular to working precision. */
if (*rcond < slamch_("Epsilon", (ftnlen)7)) {
*info = *n + 1;
}
/* Compute the solution vectors X. */
slacpy_("Full", n, nrhs, &b[b_offset], ldb, &x[x_offset], ldx, (ftnlen)4);
spttrs_(n, nrhs, &df[1], &ef[1], &x[x_offset], ldx, info);
/* Use iterative refinement to improve the computed solutions and */
/* compute error bounds and backward error estimates for them. */
sptrfs_(n, nrhs, &d__[1], &e[1], &df[1], &ef[1], &b[b_offset], ldb, &x[
x_offset], ldx, &ferr[1], &berr[1], &work[1], info);
return 0;
/* End of SPTSVX */
} /* sptsvx_ */
/* Subroutine */ int sgelsd_(integer *m, integer *n, integer *nrhs, real *a,
integer *lda, real *b, integer *ldb, real *s, real *rcond, integer *
rank, real *work, integer *lwork, integer *iwork, integer *info)
{
/* System generated locals */
integer a_dim1, a_offset, b_dim1, b_offset, i__1, i__2, i__3, i__4;
/* Builtin functions */
double log(doublereal);
/* Local variables */
integer ie, il, mm;
real eps, anrm, bnrm;
integer itau, nlvl, iascl, ibscl;
real sfmin;
integer minmn, maxmn, itaup, itauq, mnthr, nwork;
extern /* Subroutine */ int slabad_(real *, real *), sgebrd_(integer *,
integer *, real *, integer *, real *, real *, real *, real *,
real *, integer *, integer *);
extern doublereal slamch_(char *), slange_(char *, integer *,
integer *, real *, integer *, real *);
extern /* Subroutine */ int xerbla_(char *, integer *);
extern integer ilaenv_(integer *, char *, char *, integer *, integer *,
integer *, integer *);
real bignum;
extern /* Subroutine */ int sgelqf_(integer *, integer *, real *, integer
*, real *, real *, integer *, integer *), slalsd_(char *, integer
*, integer *, integer *, real *, real *, real *, integer *, real *
, integer *, real *, integer *, integer *), slascl_(char *
, integer *, integer *, real *, real *, integer *, integer *,
real *, integer *, integer *);
integer wlalsd;
extern /* Subroutine */ int sgeqrf_(integer *, integer *, real *, integer
*, real *, real *, integer *, integer *), slacpy_(char *, integer
*, integer *, real *, integer *, real *, integer *),
slaset_(char *, integer *, integer *, real *, real *, real *,
integer *);
integer ldwork;
extern /* Subroutine */ int sormbr_(char *, char *, char *, integer *,
integer *, integer *, real *, integer *, real *, real *, integer *
, real *, integer *, integer *);
integer liwork, minwrk, maxwrk;
real smlnum;
extern /* Subroutine */ int sormlq_(char *, char *, integer *, integer *,
integer *, real *, integer *, real *, real *, integer *, real *,
integer *, integer *);
logical lquery;
integer smlsiz;
extern /* Subroutine */ int sormqr_(char *, char *, integer *, integer *,
integer *, real *, integer *, real *, real *, integer *, real *,
integer *, integer *);
/* -- LAPACK driver routine (version 3.1) -- */
/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/* November 2006 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* SGELSD computes the minimum-norm solution to a real linear least */
/* squares problem: */
/* minimize 2-norm(| b - A*x |) */
/* using the singular value decomposition (SVD) of A. A is an M-by-N */
/* matrix which may be rank-deficient. */
/* Several right hand side vectors b and solution vectors x can be */
/* handled in a single call; they are stored as the columns of the */
/* M-by-NRHS right hand side matrix B and the N-by-NRHS solution */
/* matrix X. */
/* The problem is solved in three steps: */
/* (1) Reduce the coefficient matrix A to bidiagonal form with */
/* Householder transformations, reducing the original problem */
/* into a "bidiagonal least squares problem" (BLS) */
/* (2) Solve the BLS using a divide and conquer approach. */
/* (3) Apply back all the Householder tranformations to solve */
/* the original least squares problem. */
/* The effective rank of A is determined by treating as zero those */
/* singular values which are less than RCOND times the largest singular */
/* value. */
/* The divide and conquer algorithm makes very mild assumptions about */
/* floating point arithmetic. It will work on machines with a guard */
/* digit in add/subtract, or on those binary machines without guard */
/* digits which subtract like the Cray X-MP, Cray Y-MP, Cray C-90, or */
/* Cray-2. It could conceivably fail on hexadecimal or decimal machines */
/* without guard digits, but we know of none. */
/* Arguments */
/* ========= */
/* M (input) INTEGER */
/* The number of rows of A. M >= 0. */
/* N (input) INTEGER */
/* The number of columns of A. N >= 0. */
/* NRHS (input) INTEGER */
/* The number of right hand sides, i.e., the number of columns */
/* of the matrices B and X. NRHS >= 0. */
/* A (input) REAL array, dimension (LDA,N) */
/* On entry, the M-by-N matrix A. */
/* On exit, A has been destroyed. */
/* LDA (input) INTEGER */
/* The leading dimension of the array A. LDA >= max(1,M). */
/* B (input/output) REAL array, dimension (LDB,NRHS) */
/* On entry, the M-by-NRHS right hand side matrix B. */
/* On exit, B is overwritten by the N-by-NRHS solution */
/* matrix X. If m >= n and RANK = n, the residual */
/* sum-of-squares for the solution in the i-th column is given */
/* by the sum of squares of elements n+1:m in that column. */
/* LDB (input) INTEGER */
/* The leading dimension of the array B. LDB >= max(1,max(M,N)). */
/* S (output) REAL array, dimension (min(M,N)) */
/* The singular values of A in decreasing order. */
/* The condition number of A in the 2-norm = S(1)/S(min(m,n)). */
/* RCOND (input) REAL */
/* RCOND is used to determine the effective rank of A. */
/* Singular values S(i) <= RCOND*S(1) are treated as zero. */
/* If RCOND < 0, machine precision is used instead. */
/* RANK (output) INTEGER */
/* The effective rank of A, i.e., the number of singular values */
/* which are greater than RCOND*S(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 must be at least 1. */
/* The exact minimum amount of workspace needed depends on M, */
/* N and NRHS. As long as LWORK is at least */
/* 12*N + 2*N*SMLSIZ + 8*N*NLVL + N*NRHS + (SMLSIZ+1)**2, */
/* if M is greater than or equal to N or */
/* 12*M + 2*M*SMLSIZ + 8*M*NLVL + M*NRHS + (SMLSIZ+1)**2, */
/* if M is less than N, the code will execute correctly. */
/* SMLSIZ is returned by ILAENV and is equal to the maximum */
/* size of the subproblems at the bottom of the computation */
/* tree (usually about 25), and */
/* NLVL = MAX( 0, INT( LOG_2( MIN( M,N )/(SMLSIZ+1) ) ) + 1 ) */
/* For good performance, LWORK should generally be larger. */
/* If LWORK = -1, then a workspace query is assumed; the routine */
/* only calculates the optimal size of the array WORK and the */
/* minimum size of the array IWORK, and returns these values as */
/* the first entries of the WORK and IWORK arrays, and no error */
/* message related to LWORK is issued by XERBLA. */
/* IWORK (workspace) INTEGER array, dimension (MAX(1,LIWORK)) */
/* LIWORK >= max(1, 3*MINMN*NLVL + 11*MINMN), */
/* where MINMN = MIN( M,N ). */
/* On exit, if INFO = 0, IWORK(1) returns the minimum LIWORK. */
/* INFO (output) INTEGER */
/* = 0: successful exit */
/* < 0: if INFO = -i, the i-th argument had an illegal value. */
/* > 0: the algorithm for computing the SVD failed to converge; */
/* if INFO = i, i off-diagonal elements of an intermediate */
/* bidiagonal form did not converge to zero. */
/* Further Details */
/* =============== */
/* Based on contributions by */
/* Ming Gu and Ren-Cang Li, Computer Science Division, University of */
/* California at Berkeley, USA */
/* Osni Marques, LBNL/NERSC, USA */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Executable Statements .. */
/* Test the input arguments. */
/* Parameter adjustments */
a_dim1 = *lda;
a_offset = 1 + a_dim1;
a -= a_offset;
b_dim1 = *ldb;
b_offset = 1 + b_dim1;
b -= b_offset;
--s;
--work;
--iwork;
/* Function Body */
*info = 0;
minmn = min(*m,*n);
maxmn = max(*m,*n);
lquery = *lwork == -1;
if (*m < 0) {
*info = -1;
} else if (*n < 0) {
*info = -2;
} else if (*nrhs < 0) {
*info = -3;
} else if (*lda < max(1,*m)) {
*info = -5;
} else if (*ldb < max(1,maxmn)) {
*info = -7;
}
/* Compute workspace. */
/* (Note: Comments in the code beginning "Workspace:" describe the */
/* minimal amount of workspace needed at that point in the code, */
/* as well as the preferred amount for good performance. */
/* NB refers to the optimal block size for the immediately */
/* following subroutine, as returned by ILAENV.) */
if (*info == 0) {
minwrk = 1;
maxwrk = 1;
liwork = 1;
if (minmn > 0) {
smlsiz = ilaenv_(&c__9, "SGELSD", " ", &c__0, &c__0, &c__0, &c__0);
mnthr = ilaenv_(&c__6, "SGELSD", " ", m, n, nrhs, &c_n1);
/* Computing MAX */
i__1 = (integer) (log((real) minmn / (real) (smlsiz + 1)) / log(
2.f)) + 1;
nlvl = max(i__1,0);
liwork = minmn * 3 * nlvl + minmn * 11;
mm = *m;
if (*m >= *n && *m >= mnthr) {
/* Path 1a - overdetermined, with many more rows than */
/* columns. */
mm = *n;
/* Computing MAX */
i__1 = maxwrk, i__2 = *n + *n * ilaenv_(&c__1, "SGEQRF",
" ", m, n, &c_n1, &c_n1);
maxwrk = max(i__1,i__2);
/* Computing MAX */
i__1 = maxwrk, i__2 = *n + *nrhs * ilaenv_(&c__1, "SORMQR",
"LT", m, nrhs, n, &c_n1);
maxwrk = max(i__1,i__2);
}
if (*m >= *n) {
/* Path 1 - overdetermined or exactly determined. */
/* Computing MAX */
i__1 = maxwrk, i__2 = *n * 3 + (mm + *n) * ilaenv_(&c__1,
"SGEBRD", " ", &mm, n, &c_n1, &c_n1);
maxwrk = max(i__1,i__2);
/* Computing MAX */
i__1 = maxwrk, i__2 = *n * 3 + *nrhs * ilaenv_(&c__1, "SORMBR"
, "QLT", &mm, nrhs, n, &c_n1);
maxwrk = max(i__1,i__2);
/* Computing MAX */
i__1 = maxwrk, i__2 = *n * 3 + (*n - 1) * ilaenv_(&c__1,
"SORMBR", "PLN", n, nrhs, n, &c_n1);
maxwrk = max(i__1,i__2);
/* Computing 2nd power */
i__1 = smlsiz + 1;
wlalsd = *n * 9 + (*n << 1) * smlsiz + (*n << 3) * nlvl + *n *
*nrhs + i__1 * i__1;
/* Computing MAX */
i__1 = maxwrk, i__2 = *n * 3 + wlalsd;
maxwrk = max(i__1,i__2);
/* Computing MAX */
i__1 = *n * 3 + mm, i__2 = *n * 3 + *nrhs, i__1 = max(i__1,
i__2), i__2 = *n * 3 + wlalsd;
minwrk = max(i__1,i__2);
}
if (*n > *m) {
/* Computing 2nd power */
i__1 = smlsiz + 1;
wlalsd = *m * 9 + (*m << 1) * smlsiz + (*m << 3) * nlvl + *m *
*nrhs + i__1 * i__1;
if (*n >= mnthr) {
/* Path 2a - underdetermined, with many more columns */
/* than rows. */
maxwrk = *m + *m * ilaenv_(&c__1, "SGELQF", " ", m, n, &
c_n1, &c_n1);
/* Computing MAX */
i__1 = maxwrk, i__2 = *m * *m + (*m << 2) + (*m << 1) *
ilaenv_(&c__1, "SGEBRD", " ", m, m, &c_n1, &c_n1);
maxwrk = max(i__1,i__2);
/* Computing MAX */
i__1 = maxwrk, i__2 = *m * *m + (*m << 2) + *nrhs *
ilaenv_(&c__1, "SORMBR", "QLT", m, nrhs, m, &c_n1);
maxwrk = max(i__1,i__2);
/* Computing MAX */
i__1 = maxwrk, i__2 = *m * *m + (*m << 2) + (*m - 1) *
ilaenv_(&c__1, "SORMBR", "PLN", m, nrhs, m, &c_n1);
maxwrk = max(i__1,i__2);
if (*nrhs > 1) {
/* Computing MAX */
i__1 = maxwrk, i__2 = *m * *m + *m + *m * *nrhs;
maxwrk = max(i__1,i__2);
} else {
/* Computing MAX */
i__1 = maxwrk, i__2 = *m * *m + (*m << 1);
maxwrk = max(i__1,i__2);
}
/* Computing MAX */
i__1 = maxwrk, i__2 = *m + *nrhs * ilaenv_(&c__1, "SORMLQ"
, "LT", n, nrhs, m, &c_n1);
maxwrk = max(i__1,i__2);
/* Computing MAX */
i__1 = maxwrk, i__2 = *m * *m + (*m << 2) + wlalsd;
maxwrk = max(i__1,i__2);
} else {
/* Path 2 - remaining underdetermined cases. */
maxwrk = *m * 3 + (*n + *m) * ilaenv_(&c__1, "SGEBRD",
" ", m, n, &c_n1, &c_n1);
/* Computing MAX */
i__1 = maxwrk, i__2 = *m * 3 + *nrhs * ilaenv_(&c__1,
"SORMBR", "QLT", m, nrhs, n, &c_n1);
maxwrk = max(i__1,i__2);
/* Computing MAX */
i__1 = maxwrk, i__2 = *m * 3 + *m * ilaenv_(&c__1, "SORM"
"BR", "PLN", n, nrhs, m, &c_n1);
maxwrk = max(i__1,i__2);
/* Computing MAX */
i__1 = maxwrk, i__2 = *m * 3 + wlalsd;
maxwrk = max(i__1,i__2);
}
/* Computing MAX */
i__1 = *m * 3 + *nrhs, i__2 = *m * 3 + *m, i__1 = max(i__1,
i__2), i__2 = *m * 3 + wlalsd;
minwrk = max(i__1,i__2);
}
}
minwrk = min(minwrk,maxwrk);
work[1] = (real) maxwrk;
iwork[1] = liwork;
if (*lwork < minwrk && ! lquery) {
*info = -12;
}
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("SGELSD", &i__1);
return 0;
} else if (lquery) {
return 0;
}
/* Quick return if possible. */
if (*m == 0 || *n == 0) {
*rank = 0;
return 0;
}
/* Get machine parameters. */
eps = slamch_("P");
sfmin = slamch_("S");
smlnum = sfmin / eps;
bignum = 1.f / smlnum;
slabad_(&smlnum, &bignum);
/* Scale A if max entry outside range [SMLNUM,BIGNUM]. */
anrm = slange_("M", m, n, &a[a_offset], lda, &work[1]);
iascl = 0;
if (anrm > 0.f && anrm < smlnum) {
/* Scale matrix norm up to SMLNUM. */
slascl_("G", &c__0, &c__0, &anrm, &smlnum, m, n, &a[a_offset], lda,
info);
iascl = 1;
} else if (anrm > bignum) {
/* Scale matrix norm down to BIGNUM. */
slascl_("G", &c__0, &c__0, &anrm, &bignum, m, n, &a[a_offset], lda,
info);
iascl = 2;
} else if (anrm == 0.f) {
/* Matrix all zero. Return zero solution. */
i__1 = max(*m,*n);
slaset_("F", &i__1, nrhs, &c_b81, &c_b81, &b[b_offset], ldb);
slaset_("F", &minmn, &c__1, &c_b81, &c_b81, &s[1], &c__1);
*rank = 0;
goto L10;
}
/* Scale B if max entry outside range [SMLNUM,BIGNUM]. */
bnrm = slange_("M", m, nrhs, &b[b_offset], ldb, &work[1]);
ibscl = 0;
if (bnrm > 0.f && bnrm < smlnum) {
/* Scale matrix norm up to SMLNUM. */
slascl_("G", &c__0, &c__0, &bnrm, &smlnum, m, nrhs, &b[b_offset], ldb,
info);
ibscl = 1;
} else if (bnrm > bignum) {
/* Scale matrix norm down to BIGNUM. */
slascl_("G", &c__0, &c__0, &bnrm, &bignum, m, nrhs, &b[b_offset], ldb,
info);
ibscl = 2;
}
/* If M < N make sure certain entries of B are zero. */
if (*m < *n) {
i__1 = *n - *m;
slaset_("F", &i__1, nrhs, &c_b81, &c_b81, &b[*m + 1 + b_dim1], ldb);
}
/* Overdetermined case. */
if (*m >= *n) {
/* Path 1 - overdetermined or exactly determined. */
mm = *m;
if (*m >= mnthr) {
/* Path 1a - overdetermined, with many more rows than columns. */
mm = *n;
itau = 1;
nwork = itau + *n;
/* Compute A=Q*R. */
/* (Workspace: need 2*N, prefer N+N*NB) */
i__1 = *lwork - nwork + 1;
sgeqrf_(m, n, &a[a_offset], lda, &work[itau], &work[nwork], &i__1,
info);
/* Multiply B by transpose(Q). */
/* (Workspace: need N+NRHS, prefer N+NRHS*NB) */
i__1 = *lwork - nwork + 1;
sormqr_("L", "T", m, nrhs, n, &a[a_offset], lda, &work[itau], &b[
b_offset], ldb, &work[nwork], &i__1, info);
/* Zero out below R. */
if (*n > 1) {
i__1 = *n - 1;
i__2 = *n - 1;
slaset_("L", &i__1, &i__2, &c_b81, &c_b81, &a[a_dim1 + 2],
lda);
}
}
ie = 1;
itauq = ie + *n;
itaup = itauq + *n;
nwork = itaup + *n;
/* Bidiagonalize R in A. */
/* (Workspace: need 3*N+MM, prefer 3*N+(MM+N)*NB) */
i__1 = *lwork - nwork + 1;
sgebrd_(&mm, n, &a[a_offset], lda, &s[1], &work[ie], &work[itauq], &
work[itaup], &work[nwork], &i__1, info);
/* Multiply B by transpose of left bidiagonalizing vectors of R. */
/* (Workspace: need 3*N+NRHS, prefer 3*N+NRHS*NB) */
i__1 = *lwork - nwork + 1;
sormbr_("Q", "L", "T", &mm, nrhs, n, &a[a_offset], lda, &work[itauq],
&b[b_offset], ldb, &work[nwork], &i__1, info);
/* Solve the bidiagonal least squares problem. */
slalsd_("U", &smlsiz, n, nrhs, &s[1], &work[ie], &b[b_offset], ldb,
rcond, rank, &work[nwork], &iwork[1], info);
if (*info != 0) {
goto L10;
}
/* Multiply B by right bidiagonalizing vectors of R. */
i__1 = *lwork - nwork + 1;
sormbr_("P", "L", "N", n, nrhs, n, &a[a_offset], lda, &work[itaup], &
b[b_offset], ldb, &work[nwork], &i__1, info);
} else /* if(complicated condition) */ {
/* Computing MAX */
i__1 = *m, i__2 = (*m << 1) - 4, i__1 = max(i__1,i__2), i__1 = max(
i__1,*nrhs), i__2 = *n - *m * 3, i__1 = max(i__1,i__2);
if (*n >= mnthr && *lwork >= (*m << 2) + *m * *m + max(i__1,wlalsd)) {
/* Path 2a - underdetermined, with many more columns than rows */
/* and sufficient workspace for an efficient algorithm. */
ldwork = *m;
/* Computing MAX */
/* Computing MAX */
i__3 = *m, i__4 = (*m << 1) - 4, i__3 = max(i__3,i__4), i__3 =
max(i__3,*nrhs), i__4 = *n - *m * 3;
i__1 = (*m << 2) + *m * *lda + max(i__3,i__4), i__2 = *m * *lda +
*m + *m * *nrhs, i__1 = max(i__1,i__2), i__2 = (*m << 2)
+ *m * *lda + wlalsd;
if (*lwork >= max(i__1,i__2)) {
ldwork = *lda;
}
itau = 1;
nwork = *m + 1;
/* Compute A=L*Q. */
/* (Workspace: need 2*M, prefer M+M*NB) */
i__1 = *lwork - nwork + 1;
sgelqf_(m, n, &a[a_offset], lda, &work[itau], &work[nwork], &i__1,
info);
il = nwork;
/* Copy L to WORK(IL), zeroing out above its diagonal. */
slacpy_("L", m, m, &a[a_offset], lda, &work[il], &ldwork);
i__1 = *m - 1;
i__2 = *m - 1;
slaset_("U", &i__1, &i__2, &c_b81, &c_b81, &work[il + ldwork], &
ldwork);
ie = il + ldwork * *m;
itauq = ie + *m;
itaup = itauq + *m;
nwork = itaup + *m;
/* Bidiagonalize L in WORK(IL). */
/* (Workspace: need M*M+5*M, prefer M*M+4*M+2*M*NB) */
i__1 = *lwork - nwork + 1;
sgebrd_(m, m, &work[il], &ldwork, &s[1], &work[ie], &work[itauq],
&work[itaup], &work[nwork], &i__1, info);
/* Multiply B by transpose of left bidiagonalizing vectors of L. */
/* (Workspace: need M*M+4*M+NRHS, prefer M*M+4*M+NRHS*NB) */
i__1 = *lwork - nwork + 1;
sormbr_("Q", "L", "T", m, nrhs, m, &work[il], &ldwork, &work[
itauq], &b[b_offset], ldb, &work[nwork], &i__1, info);
/* Solve the bidiagonal least squares problem. */
slalsd_("U", &smlsiz, m, nrhs, &s[1], &work[ie], &b[b_offset],
ldb, rcond, rank, &work[nwork], &iwork[1], info);
if (*info != 0) {
goto L10;
}
/* Multiply B by right bidiagonalizing vectors of L. */
i__1 = *lwork - nwork + 1;
sormbr_("P", "L", "N", m, nrhs, m, &work[il], &ldwork, &work[
itaup], &b[b_offset], ldb, &work[nwork], &i__1, info);
/* Zero out below first M rows of B. */
i__1 = *n - *m;
slaset_("F", &i__1, nrhs, &c_b81, &c_b81, &b[*m + 1 + b_dim1],
ldb);
nwork = itau + *m;
/* Multiply transpose(Q) by B. */
/* (Workspace: need M+NRHS, prefer M+NRHS*NB) */
i__1 = *lwork - nwork + 1;
sormlq_("L", "T", n, nrhs, m, &a[a_offset], lda, &work[itau], &b[
b_offset], ldb, &work[nwork], &i__1, info);
} else {
/* Path 2 - remaining underdetermined cases. */
ie = 1;
itauq = ie + *m;
itaup = itauq + *m;
nwork = itaup + *m;
/* Bidiagonalize A. */
/* (Workspace: need 3*M+N, prefer 3*M+(M+N)*NB) */
i__1 = *lwork - nwork + 1;
sgebrd_(m, n, &a[a_offset], lda, &s[1], &work[ie], &work[itauq], &
work[itaup], &work[nwork], &i__1, info);
/* Multiply B by transpose of left bidiagonalizing vectors. */
/* (Workspace: need 3*M+NRHS, prefer 3*M+NRHS*NB) */
i__1 = *lwork - nwork + 1;
sormbr_("Q", "L", "T", m, nrhs, n, &a[a_offset], lda, &work[itauq]
, &b[b_offset], ldb, &work[nwork], &i__1, info);
/* Solve the bidiagonal least squares problem. */
slalsd_("L", &smlsiz, m, nrhs, &s[1], &work[ie], &b[b_offset],
ldb, rcond, rank, &work[nwork], &iwork[1], info);
if (*info != 0) {
goto L10;
}
/* Multiply B by right bidiagonalizing vectors of A. */
i__1 = *lwork - nwork + 1;
sormbr_("P", "L", "N", n, nrhs, m, &a[a_offset], lda, &work[itaup]
, &b[b_offset], ldb, &work[nwork], &i__1, info);
}
}
/* Undo scaling. */
if (iascl == 1) {
slascl_("G", &c__0, &c__0, &anrm, &smlnum, n, nrhs, &b[b_offset], ldb,
info);
slascl_("G", &c__0, &c__0, &smlnum, &anrm, &minmn, &c__1, &s[1], &
minmn, info);
} else if (iascl == 2) {
slascl_("G", &c__0, &c__0, &anrm, &bignum, n, nrhs, &b[b_offset], ldb,
info);
slascl_("G", &c__0, &c__0, &bignum, &anrm, &minmn, &c__1, &s[1], &
minmn, info);
}
if (ibscl == 1) {
slascl_("G", &c__0, &c__0, &smlnum, &bnrm, n, nrhs, &b[b_offset], ldb,
info);
} else if (ibscl == 2) {
slascl_("G", &c__0, &c__0, &bignum, &bnrm, n, nrhs, &b[b_offset], ldb,
info);
}
L10:
work[1] = (real) maxwrk;
iwork[1] = liwork;
return 0;
/* End of SGELSD */
} /* sgelsd_ */
