/* Subroutine */ int dsteqr_(char *compz, integer *n, doublereal *d__,
doublereal *e, doublereal *z__, integer *ldz, doublereal *work,
integer *info)
{
/* System generated locals */
integer z_dim1, z_offset, i__1, i__2;
doublereal d__1, d__2;
/* Builtin functions */
double sqrt(doublereal), d_sign(doublereal *, doublereal *);
/* Local variables */
doublereal b, c__, f, g;
integer i__, j, k, l, m;
doublereal p, r__, s;
integer l1, ii, mm, lm1, mm1, nm1;
doublereal rt1, rt2, eps;
integer lsv;
doublereal tst, eps2;
integer lend, jtot;
extern /* Subroutine */ int dlae2_(doublereal *, doublereal *, doublereal
*, doublereal *, doublereal *);
extern logical lsame_(char *, char *);
extern /* Subroutine */ int dlasr_(char *, char *, char *, integer *,
integer *, doublereal *, doublereal *, doublereal *, integer *);
doublereal anorm;
extern /* Subroutine */ int dswap_(integer *, doublereal *, integer *,
doublereal *, integer *), dlaev2_(doublereal *, doublereal *,
doublereal *, doublereal *, doublereal *, doublereal *,
doublereal *);
integer lendm1, lendp1;
extern doublereal dlapy2_(doublereal *, doublereal *), dlamch_(char *);
integer iscale;
extern /* Subroutine */ int dlascl_(char *, integer *, integer *,
doublereal *, doublereal *, integer *, integer *, doublereal *,
integer *, integer *), dlaset_(char *, integer *, integer
*, doublereal *, doublereal *, doublereal *, integer *);
doublereal safmin;
extern /* Subroutine */ int dlartg_(doublereal *, doublereal *,
doublereal *, doublereal *, doublereal *);
doublereal safmax;
extern /* Subroutine */ int xerbla_(char *, integer *);
extern doublereal dlanst_(char *, integer *, doublereal *, doublereal *);
extern /* Subroutine */ int dlasrt_(char *, integer *, doublereal *,
integer *);
integer lendsv;
doublereal ssfmin;
integer nmaxit, icompz;
doublereal ssfmax;
/* -- LAPACK routine (version 3.1) -- */
/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/* November 2006 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* DSTEQR computes all eigenvalues and, optionally, eigenvectors of a */
/* symmetric tridiagonal matrix using the implicit QL or QR method. */
/* The eigenvectors of a full or band symmetric matrix can also be found */
/* if DSYTRD or DSPTRD or DSBTRD has been used to reduce this matrix to */
/* tridiagonal form. */
/* Arguments */
/* ========= */
/* COMPZ (input) CHARACTER*1 */
/* = 'N': Compute eigenvalues only. */
/* = 'V': Compute eigenvalues and eigenvectors of the original */
/* symmetric matrix. On entry, Z must contain the */
/* orthogonal matrix used to reduce the original matrix */
/* to tridiagonal form. */
/* = 'I': Compute eigenvalues and eigenvectors of the */
/* tridiagonal matrix. Z is initialized to the identity */
/* matrix. */
/* N (input) INTEGER */
/* The order of the matrix. N >= 0. */
/* D (input/output) DOUBLE PRECISION array, dimension (N) */
/* On entry, the diagonal elements of the tridiagonal matrix. */
/* On exit, if INFO = 0, the eigenvalues in ascending order. */
/* E (input/output) DOUBLE PRECISION array, dimension (N-1) */
/* On entry, the (n-1) subdiagonal elements of the tridiagonal */
/* matrix. */
/* On exit, E has been destroyed. */
/* Z (input/output) DOUBLE PRECISION array, dimension (LDZ, N) */
/* On entry, if COMPZ = 'V', then Z contains the orthogonal */
/* matrix used in the reduction to tridiagonal form. */
/* On exit, if INFO = 0, then if COMPZ = 'V', Z contains the */
/* orthonormal eigenvectors of the original symmetric matrix, */
/* and if COMPZ = 'I', Z contains the orthonormal eigenvectors */
/* of the symmetric tridiagonal matrix. */
/* If COMPZ = 'N', then Z is not referenced. */
/* LDZ (input) INTEGER */
/* The leading dimension of the array Z. LDZ >= 1, and if */
/* eigenvectors are desired, then LDZ >= max(1,N). */
/* WORK (workspace) DOUBLE PRECISION array, dimension (max(1,2*N-2)) */
/* If COMPZ = 'N', then WORK is not referenced. */
/* INFO (output) INTEGER */
/* = 0: successful exit */
/* < 0: if INFO = -i, the i-th argument had an illegal value */
/* > 0: the algorithm has failed to find all the eigenvalues in */
/* a total of 30*N iterations; if INFO = i, then i */
/* elements of E have not converged to zero; on exit, D */
/* and E contain the elements of a symmetric tridiagonal */
/* matrix which is orthogonally similar to the original */
/* matrix. */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Executable Statements .. */
/* Test the input parameters. */
/* Parameter adjustments */
--d__;
--e;
z_dim1 = *ldz;
z_offset = 1 + z_dim1;
z__ -= z_offset;
--work;
/* Function Body */
*info = 0;
if (lsame_(compz, "N")) {
icompz = 0;
} else if (lsame_(compz, "V")) {
icompz = 1;
} else if (lsame_(compz, "I")) {
icompz = 2;
} else {
icompz = -1;
}
if (icompz < 0) {
*info = -1;
} else if (*n < 0) {
*info = -2;
} else if (*ldz < 1 || icompz > 0 && *ldz < max(1,*n)) {
*info = -6;
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("DSTEQR", &i__1);
return 0;
}
/* Quick return if possible */
if (*n == 0) {
return 0;
}
if (*n == 1) {
if (icompz == 2) {
z__[z_dim1 + 1] = 1.;
}
return 0;
}
/* Determine the unit roundoff and over/underflow thresholds. */
eps = dlamch_("E");
/* Computing 2nd power */
d__1 = eps;
eps2 = d__1 * d__1;
safmin = dlamch_("S");
safmax = 1. / safmin;
ssfmax = sqrt(safmax) / 3.;
ssfmin = sqrt(safmin) / eps2;
/* Compute the eigenvalues and eigenvectors of the tridiagonal */
/* matrix. */
if (icompz == 2) {
dlaset_("Full", n, n, &c_b9, &c_b10, &z__[z_offset], ldz);
}
nmaxit = *n * 30;
jtot = 0;
/* Determine where the matrix splits and choose QL or QR iteration */
/* for each block, according to whether top or bottom diagonal */
/* element is smaller. */
l1 = 1;
nm1 = *n - 1;
L10:
if (l1 > *n) {
goto L160;
}
if (l1 > 1) {
e[l1 - 1] = 0.;
}
if (l1 <= nm1) {
i__1 = nm1;
for (m = l1; m <= i__1; ++m) {
tst = (d__1 = e[m], abs(d__1));
if (tst == 0.) {
goto L30;
}
if (tst <= sqrt((d__1 = d__[m], abs(d__1))) * sqrt((d__2 = d__[m
+ 1], abs(d__2))) * eps) {
e[m] = 0.;
goto L30;
}
/* L20: */
}
}
m = *n;
L30:
l = l1;
lsv = l;
lend = m;
lendsv = lend;
l1 = m + 1;
if (lend == l) {
goto L10;
}
/* Scale submatrix in rows and columns L to LEND */
i__1 = lend - l + 1;
anorm = dlanst_("I", &i__1, &d__[l], &e[l]);
iscale = 0;
if (anorm == 0.) {
goto L10;
}
if (anorm > ssfmax) {
iscale = 1;
i__1 = lend - l + 1;
dlascl_("G", &c__0, &c__0, &anorm, &ssfmax, &i__1, &c__1, &d__[l], n,
info);
i__1 = lend - l;
dlascl_("G", &c__0, &c__0, &anorm, &ssfmax, &i__1, &c__1, &e[l], n,
info);
} else if (anorm < ssfmin) {
iscale = 2;
i__1 = lend - l + 1;
dlascl_("G", &c__0, &c__0, &anorm, &ssfmin, &i__1, &c__1, &d__[l], n,
info);
i__1 = lend - l;
dlascl_("G", &c__0, &c__0, &anorm, &ssfmin, &i__1, &c__1, &e[l], n,
info);
}
/* Choose between QL and QR iteration */
if ((d__1 = d__[lend], abs(d__1)) < (d__2 = d__[l], abs(d__2))) {
lend = lsv;
l = lendsv;
}
if (lend > l) {
/* QL Iteration */
/* Look for small subdiagonal element. */
L40:
if (l != lend) {
lendm1 = lend - 1;
i__1 = lendm1;
for (m = l; m <= i__1; ++m) {
/* Computing 2nd power */
d__2 = (d__1 = e[m], abs(d__1));
tst = d__2 * d__2;
if (tst <= eps2 * (d__1 = d__[m], abs(d__1)) * (d__2 = d__[m
+ 1], abs(d__2)) + safmin) {
goto L60;
}
/* L50: */
}
}
m = lend;
L60:
if (m < lend) {
e[m] = 0.;
}
p = d__[l];
if (m == l) {
goto L80;
}
/* If remaining matrix is 2-by-2, use DLAE2 or SLAEV2 */
/* to compute its eigensystem. */
if (m == l + 1) {
if (icompz > 0) {
dlaev2_(&d__[l], &e[l], &d__[l + 1], &rt1, &rt2, &c__, &s);
work[l] = c__;
work[*n - 1 + l] = s;
dlasr_("R", "V", "B", n, &c__2, &work[l], &work[*n - 1 + l], &
z__[l * z_dim1 + 1], ldz);
} else {
dlae2_(&d__[l], &e[l], &d__[l + 1], &rt1, &rt2);
}
d__[l] = rt1;
d__[l + 1] = rt2;
e[l] = 0.;
l += 2;
if (l <= lend) {
goto L40;
}
goto L140;
}
if (jtot == nmaxit) {
goto L140;
}
++jtot;
/* Form shift. */
g = (d__[l + 1] - p) / (e[l] * 2.);
r__ = dlapy2_(&g, &c_b10);
g = d__[m] - p + e[l] / (g + d_sign(&r__, &g));
s = 1.;
c__ = 1.;
p = 0.;
/* Inner loop */
mm1 = m - 1;
i__1 = l;
for (i__ = mm1; i__ >= i__1; --i__) {
f = s * e[i__];
b = c__ * e[i__];
dlartg_(&g, &f, &c__, &s, &r__);
if (i__ != m - 1) {
e[i__ + 1] = r__;
}
g = d__[i__ + 1] - p;
r__ = (d__[i__] - g) * s + c__ * 2. * b;
p = s * r__;
d__[i__ + 1] = g + p;
g = c__ * r__ - b;
/* If eigenvectors are desired, then save rotations. */
if (icompz > 0) {
work[i__] = c__;
work[*n - 1 + i__] = -s;
}
/* L70: */
}
/* If eigenvectors are desired, then apply saved rotations. */
if (icompz > 0) {
mm = m - l + 1;
dlasr_("R", "V", "B", n, &mm, &work[l], &work[*n - 1 + l], &z__[l
* z_dim1 + 1], ldz);
}
d__[l] -= p;
e[l] = g;
goto L40;
/* Eigenvalue found. */
L80:
d__[l] = p;
++l;
if (l <= lend) {
goto L40;
}
goto L140;
} else {
/* QR Iteration */
/* Look for small superdiagonal element. */
L90:
if (l != lend) {
lendp1 = lend + 1;
i__1 = lendp1;
for (m = l; m >= i__1; --m) {
/* Computing 2nd power */
d__2 = (d__1 = e[m - 1], abs(d__1));
tst = d__2 * d__2;
if (tst <= eps2 * (d__1 = d__[m], abs(d__1)) * (d__2 = d__[m
- 1], abs(d__2)) + safmin) {
goto L110;
}
/* L100: */
}
}
m = lend;
L110:
if (m > lend) {
e[m - 1] = 0.;
}
p = d__[l];
if (m == l) {
goto L130;
}
/* If remaining matrix is 2-by-2, use DLAE2 or SLAEV2 */
/* to compute its eigensystem. */
if (m == l - 1) {
if (icompz > 0) {
dlaev2_(&d__[l - 1], &e[l - 1], &d__[l], &rt1, &rt2, &c__, &s)
;
work[m] = c__;
work[*n - 1 + m] = s;
dlasr_("R", "V", "F", n, &c__2, &work[m], &work[*n - 1 + m], &
z__[(l - 1) * z_dim1 + 1], ldz);
} else {
dlae2_(&d__[l - 1], &e[l - 1], &d__[l], &rt1, &rt2);
}
d__[l - 1] = rt1;
d__[l] = rt2;
e[l - 1] = 0.;
l += -2;
if (l >= lend) {
goto L90;
}
goto L140;
}
if (jtot == nmaxit) {
goto L140;
}
++jtot;
/* Form shift. */
g = (d__[l - 1] - p) / (e[l - 1] * 2.);
r__ = dlapy2_(&g, &c_b10);
g = d__[m] - p + e[l - 1] / (g + d_sign(&r__, &g));
s = 1.;
c__ = 1.;
p = 0.;
/* Inner loop */
lm1 = l - 1;
i__1 = lm1;
for (i__ = m; i__ <= i__1; ++i__) {
f = s * e[i__];
b = c__ * e[i__];
dlartg_(&g, &f, &c__, &s, &r__);
if (i__ != m) {
e[i__ - 1] = r__;
}
g = d__[i__] - p;
r__ = (d__[i__ + 1] - g) * s + c__ * 2. * b;
p = s * r__;
d__[i__] = g + p;
g = c__ * r__ - b;
/* If eigenvectors are desired, then save rotations. */
if (icompz > 0) {
work[i__] = c__;
work[*n - 1 + i__] = s;
}
/* L120: */
}
/* If eigenvectors are desired, then apply saved rotations. */
if (icompz > 0) {
mm = l - m + 1;
dlasr_("R", "V", "F", n, &mm, &work[m], &work[*n - 1 + m], &z__[m
* z_dim1 + 1], ldz);
}
d__[l] -= p;
e[lm1] = g;
goto L90;
/* Eigenvalue found. */
L130:
d__[l] = p;
--l;
if (l >= lend) {
goto L90;
}
goto L140;
}
/* Undo scaling if necessary */
L140:
if (iscale == 1) {
i__1 = lendsv - lsv + 1;
dlascl_("G", &c__0, &c__0, &ssfmax, &anorm, &i__1, &c__1, &d__[lsv],
n, info);
i__1 = lendsv - lsv;
dlascl_("G", &c__0, &c__0, &ssfmax, &anorm, &i__1, &c__1, &e[lsv], n,
info);
} else if (iscale == 2) {
i__1 = lendsv - lsv + 1;
dlascl_("G", &c__0, &c__0, &ssfmin, &anorm, &i__1, &c__1, &d__[lsv],
n, info);
i__1 = lendsv - lsv;
dlascl_("G", &c__0, &c__0, &ssfmin, &anorm, &i__1, &c__1, &e[lsv], n,
info);
}
/* Check for no convergence to an eigenvalue after a total */
/* of N*MAXIT iterations. */
if (jtot < nmaxit) {
goto L10;
}
i__1 = *n - 1;
for (i__ = 1; i__ <= i__1; ++i__) {
if (e[i__] != 0.) {
++(*info);
}
/* L150: */
}
goto L190;
/* Order eigenvalues and eigenvectors. */
L160:
if (icompz == 0) {
/* Use Quick Sort */
dlasrt_("I", n, &d__[1], info);
} else {
/* Use Selection Sort to minimize swaps of eigenvectors */
i__1 = *n;
for (ii = 2; ii <= i__1; ++ii) {
i__ = ii - 1;
k = i__;
p = d__[i__];
i__2 = *n;
for (j = ii; j <= i__2; ++j) {
if (d__[j] < p) {
k = j;
p = d__[j];
}
/* L170: */
}
if (k != i__) {
d__[k] = d__[i__];
d__[i__] = p;
dswap_(n, &z__[i__ * z_dim1 + 1], &c__1, &z__[k * z_dim1 + 1],
&c__1);
}
/* L180: */
}
}
L190:
return 0;
/* End of DSTEQR */
} /* dsteqr_ */
/* Subroutine */
int dsyevx_(char *jobz, char *range, char *uplo, integer *n, doublereal *a, integer *lda, doublereal *vl, doublereal *vu, integer * il, integer *iu, doublereal *abstol, integer *m, doublereal *w, doublereal *z__, integer *ldz, doublereal *work, integer *lwork, integer *iwork, integer *ifail, integer *info)
{
/* System generated locals */
integer a_dim1, a_offset, z_dim1, z_offset, i__1, i__2;
doublereal d__1, d__2;
/* Builtin functions */
double sqrt(doublereal);
/* Local variables */
integer i__, j, nb, jj;
doublereal eps, vll, vuu, tmp1;
integer indd, inde;
doublereal anrm;
integer imax;
doublereal rmin, rmax;
logical test;
integer itmp1, indee;
extern /* Subroutine */
int dscal_(integer *, doublereal *, doublereal *, integer *);
doublereal sigma;
extern logical lsame_(char *, char *);
integer iinfo;
char order[1];
extern /* Subroutine */
int dcopy_(integer *, doublereal *, integer *, doublereal *, integer *), dswap_(integer *, doublereal *, integer *, doublereal *, integer *);
logical lower, wantz;
extern doublereal dlamch_(char *);
logical alleig, indeig;
integer iscale, indibl;
logical valeig;
extern /* Subroutine */
int dlacpy_(char *, integer *, integer *, doublereal *, integer *, doublereal *, integer *);
doublereal safmin;
extern integer ilaenv_(integer *, char *, char *, integer *, integer *, integer *, integer *);
extern /* Subroutine */
int xerbla_(char *, integer *);
doublereal abstll, bignum;
integer indtau, indisp;
extern /* Subroutine */
int dstein_(integer *, doublereal *, doublereal *, integer *, doublereal *, integer *, integer *, doublereal *, integer *, doublereal *, integer *, integer *, integer *), dsterf_(integer *, doublereal *, doublereal *, integer *);
integer indiwo, indwkn;
extern doublereal dlansy_(char *, char *, integer *, doublereal *, integer *, doublereal *);
extern /* Subroutine */
int dstebz_(char *, char *, integer *, doublereal *, doublereal *, integer *, integer *, doublereal *, doublereal *, doublereal *, integer *, integer *, doublereal *, integer *, integer *, doublereal *, integer *, integer *);
integer indwrk, lwkmin;
extern /* Subroutine */
int dorgtr_(char *, integer *, doublereal *, integer *, doublereal *, doublereal *, integer *, integer *), dsteqr_(char *, integer *, doublereal *, doublereal *, doublereal *, integer *, doublereal *, integer *), dormtr_(char *, char *, char *, integer *, integer *, doublereal * , integer *, doublereal *, doublereal *, integer *, doublereal *, integer *, integer *);
integer llwrkn, llwork, nsplit;
doublereal smlnum;
extern /* Subroutine */
int dsytrd_(char *, integer *, doublereal *, integer *, doublereal *, doublereal *, doublereal *, doublereal *, integer *, integer *);
integer lwkopt;
logical lquery;
/* -- LAPACK driver 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;
--w;
z_dim1 = *ldz;
z_offset = 1 + z_dim1;
z__ -= z_offset;
--work;
--iwork;
--ifail;
/* Function Body */
lower = lsame_(uplo, "L");
wantz = lsame_(jobz, "V");
alleig = lsame_(range, "A");
valeig = lsame_(range, "V");
indeig = lsame_(range, "I");
lquery = *lwork == -1;
*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 (*lda < max(1,*n))
{
*info = -6;
}
else
{
if (valeig)
{
if (*n > 0 && *vu <= *vl)
{
*info = -8;
}
}
else if (indeig)
{
if (*il < 1 || *il > max(1,*n))
{
*info = -9;
}
else if (*iu < min(*n,*il) || *iu > *n)
{
*info = -10;
}
}
}
if (*info == 0)
{
if (*ldz < 1 || wantz && *ldz < *n)
{
*info = -15;
}
}
if (*info == 0)
{
if (*n <= 1)
{
lwkmin = 1;
work[1] = (doublereal) lwkmin;
}
else
{
lwkmin = *n << 3;
nb = ilaenv_(&c__1, "DSYTRD", uplo, n, &c_n1, &c_n1, &c_n1);
/* Computing MAX */
i__1 = nb;
i__2 = ilaenv_(&c__1, "DORMTR", uplo, n, &c_n1, &c_n1, &c_n1); // , expr subst
nb = max(i__1,i__2);
/* Computing MAX */
i__1 = lwkmin;
i__2 = (nb + 3) * *n; // , expr subst
lwkopt = max(i__1,i__2);
work[1] = (doublereal) lwkopt;
}
if (*lwork < lwkmin && ! lquery)
{
*info = -17;
}
}
if (*info != 0)
{
i__1 = -(*info);
xerbla_("DSYEVX", &i__1);
return 0;
}
else if (lquery)
{
return 0;
}
/* Quick return if possible */
*m = 0;
if (*n == 0)
{
return 0;
}
if (*n == 1)
{
if (alleig || indeig)
{
*m = 1;
w[1] = a[a_dim1 + 1];
}
else
{
if (*vl < a[a_dim1 + 1] && *vu >= a[a_dim1 + 1])
{
*m = 1;
w[1] = a[a_dim1 + 1];
}
}
if (wantz)
{
z__[z_dim1 + 1] = 1.;
}
return 0;
}
/* Get machine constants. */
safmin = dlamch_("Safe minimum");
eps = dlamch_("Precision");
smlnum = safmin / eps;
bignum = 1. / smlnum;
rmin = sqrt(smlnum);
/* Computing MIN */
d__1 = sqrt(bignum);
d__2 = 1. / sqrt(sqrt(safmin)); // , expr subst
rmax = min(d__1,d__2);
/* Scale matrix to allowable range, if necessary. */
iscale = 0;
abstll = *abstol;
if (valeig)
{
vll = *vl;
vuu = *vu;
}
anrm = dlansy_("M", uplo, n, &a[a_offset], lda, &work[1]);
if (anrm > 0. && anrm < rmin)
{
iscale = 1;
sigma = rmin / anrm;
}
else if (anrm > rmax)
{
iscale = 1;
sigma = rmax / anrm;
}
if (iscale == 1)
{
if (lower)
{
i__1 = *n;
for (j = 1;
j <= i__1;
++j)
{
i__2 = *n - j + 1;
dscal_(&i__2, &sigma, &a[j + j * a_dim1], &c__1);
/* L10: */
}
}
else
{
i__1 = *n;
for (j = 1;
j <= i__1;
++j)
{
dscal_(&j, &sigma, &a[j * a_dim1 + 1], &c__1);
/* L20: */
}
}
if (*abstol > 0.)
{
abstll = *abstol * sigma;
}
if (valeig)
{
vll = *vl * sigma;
vuu = *vu * sigma;
}
}
/* Call DSYTRD to reduce symmetric matrix to tridiagonal form. */
indtau = 1;
inde = indtau + *n;
indd = inde + *n;
indwrk = indd + *n;
llwork = *lwork - indwrk + 1;
dsytrd_(uplo, n, &a[a_offset], lda, &work[indd], &work[inde], &work[ indtau], &work[indwrk], &llwork, &iinfo);
/* If all eigenvalues are desired and ABSTOL is less than or equal to */
/* zero, then call DSTERF or DORGTR and SSTEQR. If this fails for */
/* some eigenvalue, then try DSTEBZ. */
test = FALSE_;
if (indeig)
{
if (*il == 1 && *iu == *n)
{
test = TRUE_;
}
}
if ((alleig || test) && *abstol <= 0.)
{
dcopy_(n, &work[indd], &c__1, &w[1], &c__1);
indee = indwrk + (*n << 1);
if (! wantz)
{
i__1 = *n - 1;
dcopy_(&i__1, &work[inde], &c__1, &work[indee], &c__1);
dsterf_(n, &w[1], &work[indee], info);
}
else
{
dlacpy_("A", n, n, &a[a_offset], lda, &z__[z_offset], ldz);
dorgtr_(uplo, n, &z__[z_offset], ldz, &work[indtau], &work[indwrk] , &llwork, &iinfo);
i__1 = *n - 1;
dcopy_(&i__1, &work[inde], &c__1, &work[indee], &c__1);
dsteqr_(jobz, n, &w[1], &work[indee], &z__[z_offset], ldz, &work[ indwrk], info);
if (*info == 0)
{
i__1 = *n;
for (i__ = 1;
i__ <= i__1;
++i__)
{
ifail[i__] = 0;
/* L30: */
}
}
}
if (*info == 0)
{
*m = *n;
goto L40;
}
*info = 0;
}
/* Otherwise, call DSTEBZ 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;
dstebz_(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)
{
dstein_(n, &work[indd], &work[inde], m, &w[1], &iwork[indibl], &iwork[ indisp], &z__[z_offset], ldz, &work[indwrk], &iwork[indiwo], & ifail[1], info);
/* Apply orthogonal matrix used in reduction to tridiagonal */
/* form to eigenvectors returned by DSTEIN. */
indwkn = inde;
llwrkn = *lwork - indwkn + 1;
dormtr_("L", uplo, "N", n, m, &a[a_offset], lda, &work[indtau], &z__[ z_offset], ldz, &work[indwkn], &llwrkn, &iinfo);
}
/* If matrix was scaled, then rescale eigenvalues appropriately. */
L40:
if (iscale == 1)
{
if (*info == 0)
{
imax = *m;
}
else
{
imax = *info - 1;
}
d__1 = 1. / sigma;
dscal_(&imax, &d__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 <= i__1;
++j)
{
i__ = 0;
tmp1 = w[j];
i__2 = *m;
for (jj = j + 1;
jj <= i__2;
++jj)
{
if (w[jj] < tmp1)
{
i__ = jj;
tmp1 = w[jj];
}
/* L50: */
}
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;
dswap_(n, &z__[i__ * z_dim1 + 1], &c__1, &z__[j * z_dim1 + 1], &c__1);
if (*info != 0)
{
itmp1 = ifail[i__];
ifail[i__] = ifail[j];
ifail[j] = itmp1;
}
}
/* L60: */
}
}
/* Set WORK(1) to optimal workspace size. */
work[1] = (doublereal) lwkopt;
return 0;
/* End of DSYEVX */
}
/* Subroutine */ int dgebak_(char *job, char *side, integer *n, integer *ilo,
integer *ihi, doublereal *scale, integer *m, doublereal *v, integer *
ldv, integer *info)
{
/* System generated locals */
integer v_dim1, v_offset, i__1;
/* Local variables */
integer i__, k;
doublereal s;
integer ii;
extern /* Subroutine */ int dscal_(integer *, doublereal *, doublereal *,
integer *);
extern logical lsame_(char *, char *);
extern /* Subroutine */ int dswap_(integer *, doublereal *, integer *,
doublereal *, integer *);
logical leftv;
extern /* Subroutine */ int xerbla_(char *, integer *);
logical rightv;
/* -- LAPACK routine (version 3.1) -- */
/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/* November 2006 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* DGEBAK forms the right or left eigenvectors of a real general matrix */
/* by backward transformation on the computed eigenvectors of the */
/* balanced matrix output by DGEBAL. */
/* Arguments */
/* ========= */
/* JOB (input) CHARACTER*1 */
/* Specifies the type of backward transformation required: */
/* = 'N', do nothing, return immediately; */
/* = 'P', do backward transformation for permutation only; */
/* = 'S', do backward transformation for scaling only; */
/* = 'B', do backward transformations for both permutation and */
/* scaling. */
/* JOB must be the same as the argument JOB supplied to DGEBAL. */
/* SIDE (input) CHARACTER*1 */
/* = 'R': V contains right eigenvectors; */
/* = 'L': V contains left eigenvectors. */
/* N (input) INTEGER */
/* The number of rows of the matrix V. N >= 0. */
/* ILO (input) INTEGER */
/* IHI (input) INTEGER */
/* The integers ILO and IHI determined by DGEBAL. */
/* 1 <= ILO <= IHI <= N, if N > 0; ILO=1 and IHI=0, if N=0. */
/* SCALE (input) DOUBLE PRECISION array, dimension (N) */
/* Details of the permutation and scaling factors, as returned */
/* by DGEBAL. */
/* M (input) INTEGER */
/* The number of columns of the matrix V. M >= 0. */
/* V (input/output) DOUBLE PRECISION array, dimension (LDV,M) */
/* On entry, the matrix of right or left eigenvectors to be */
/* transformed, as returned by DHSEIN or DTREVC. */
/* On exit, V is overwritten by the transformed eigenvectors. */
/* LDV (input) INTEGER */
/* The leading dimension of the array V. LDV >= max(1,N). */
/* INFO (output) INTEGER */
/* = 0: successful exit */
/* < 0: if INFO = -i, the i-th argument had an illegal value. */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Executable Statements .. */
/* Decode and Test the input parameters */
/* Parameter adjustments */
--scale;
v_dim1 = *ldv;
v_offset = 1 + v_dim1;
v -= v_offset;
/* Function Body */
rightv = lsame_(side, "R");
leftv = lsame_(side, "L");
*info = 0;
if (! lsame_(job, "N") && ! lsame_(job, "P") && ! lsame_(job, "S")
&& ! lsame_(job, "B")) {
*info = -1;
} else if (! rightv && ! leftv) {
*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 (*m < 0) {
*info = -7;
} else if (*ldv < max(1,*n)) {
*info = -9;
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("DGEBAK", &i__1);
return 0;
}
/* Quick return if possible */
if (*n == 0) {
return 0;
}
if (*m == 0) {
return 0;
}
if (lsame_(job, "N")) {
return 0;
}
if (*ilo == *ihi) {
goto L30;
}
/* Backward balance */
if (lsame_(job, "S") || lsame_(job, "B")) {
if (rightv) {
i__1 = *ihi;
for (i__ = *ilo; i__ <= i__1; ++i__) {
s = scale[i__];
dscal_(m, &s, &v[i__ + v_dim1], ldv);
/* L10: */
}
}
if (leftv) {
i__1 = *ihi;
for (i__ = *ilo; i__ <= i__1; ++i__) {
s = 1. / scale[i__];
dscal_(m, &s, &v[i__ + v_dim1], ldv);
/* L20: */
}
}
}
/* Backward permutation */
/* For I = ILO-1 step -1 until 1, */
/* IHI+1 step 1 until N do -- */
L30:
if (lsame_(job, "P") || lsame_(job, "B")) {
if (rightv) {
i__1 = *n;
for (ii = 1; ii <= i__1; ++ii) {
i__ = ii;
if (i__ >= *ilo && i__ <= *ihi) {
goto L40;
}
if (i__ < *ilo) {
i__ = *ilo - ii;
}
k = (integer) scale[i__];
if (k == i__) {
goto L40;
}
dswap_(m, &v[i__ + v_dim1], ldv, &v[k + v_dim1], ldv);
L40:
;
}
}
if (leftv) {
i__1 = *n;
for (ii = 1; ii <= i__1; ++ii) {
i__ = ii;
if (i__ >= *ilo && i__ <= *ihi) {
goto L50;
}
if (i__ < *ilo) {
i__ = *ilo - ii;
}
k = (integer) scale[i__];
if (k == i__) {
goto L50;
}
dswap_(m, &v[i__ + v_dim1], ldv, &v[k + v_dim1], ldv);
L50:
;
}
}
}
return 0;
/* End of DGEBAK */
} /* dgebak_ */
/* Subroutine */ int dstemr_(char *jobz, char *range, integer *n, doublereal *
d__, doublereal *e, doublereal *vl, doublereal *vu, integer *il,
integer *iu, integer *m, doublereal *w, doublereal *z__, integer *ldz,
integer *nzc, integer *isuppz, logical *tryrac, doublereal *work,
integer *lwork, integer *iwork, integer *liwork, integer *info)
{
/* -- LAPACK computational routine (version 3.1) --
Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
November 2006
Purpose
=======
DSTEMR computes selected eigenvalues and, optionally, eigenvectors
of a real symmetric tridiagonal matrix T. Any such unreduced matrix has
a well defined set of pairwise different real eigenvalues, the corresponding
real eigenvectors are pairwise orthogonal.
The spectrum may be computed either completely or partially by specifying
either an interval (VL,VU] or a range of indices IL:IU for the desired
eigenvalues.
Depending on the number of desired eigenvalues, these are computed either
by bisection or the dqds algorithm. Numerically orthogonal eigenvectors are
computed by the use of various suitable L D L^T factorizations near clusters
of close eigenvalues (referred to as RRRs, Relatively Robust
Representations). An informal sketch of the algorithm follows.
For each unreduced block (submatrix) of T,
(a) Compute T - sigma I = L D L^T, so that L and D
define all the wanted eigenvalues to high relative accuracy.
This means that small relative changes in the entries of D and L
cause only small relative changes in the eigenvalues and
eigenvectors. The standard (unfactored) representation of the
tridiagonal matrix T does not have this property in general.
(b) Compute the eigenvalues to suitable accuracy.
If the eigenvectors are desired, the algorithm attains full
accuracy of the computed eigenvalues only right before
the corresponding vectors have to be computed, see steps c) and d).
(c) For each cluster of close eigenvalues, select a new
shift close to the cluster, find a new factorization, and refine
the shifted eigenvalues to suitable accuracy.
(d) For each eigenvalue with a large enough relative separation compute
the corresponding eigenvector by forming a rank revealing twisted
factorization. Go back to (c) for any clusters that remain.
For more details, see:
- Inderjit S. Dhillon and Beresford N. Parlett: "Multiple representations
to compute orthogonal eigenvectors of symmetric tridiagonal matrices,"
Linear Algebra and its Applications, 387(1), pp. 1-28, August 2004.
- Inderjit Dhillon and Beresford Parlett: "Orthogonal Eigenvectors and
Relative Gaps," SIAM Journal on Matrix Analysis and Applications, Vol. 25,
2004. Also LAPACK Working Note 154.
- Inderjit Dhillon: "A new O(n^2) algorithm for the symmetric
tridiagonal eigenvalue/eigenvector problem",
Computer Science Division Technical Report No. UCB/CSD-97-971,
UC Berkeley, May 1997.
Notes:
1.DSTEMR works only on machines which follow IEEE-754
floating-point standard in their handling of infinities and NaNs.
This permits the use of efficient inner loops avoiding a check for
zero divisors.
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.
N (input) INTEGER
The order of the matrix. N >= 0.
D (input/output) DOUBLE PRECISION array, dimension (N)
On entry, the N diagonal elements of the tridiagonal matrix
T. On exit, D is overwritten.
E (input/output) DOUBLE PRECISION array, dimension (N)
On entry, the (N-1) subdiagonal elements of the tridiagonal
matrix T in elements 1 to N-1 of E. E(N) need not be set on
input, but is used internally as workspace.
On exit, E is overwritten.
VL (input) DOUBLE PRECISION
VU (input) DOUBLE PRECISION
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.
Not referenced if RANGE = 'A' or 'V'.
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) DOUBLE PRECISION array, dimension (N)
The first M elements contain the selected eigenvalues in
ascending order.
Z (output) DOUBLE PRECISION array, dimension (LDZ, max(1,M) )
If JOBZ = 'V', and if INFO = 0, then the first M columns of Z
contain the orthonormal eigenvectors of the matrix T
corresponding to the selected eigenvalues, with the i-th
column of Z holding the eigenvector associated with W(i).
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 can be computed with a workspace
query by setting NZC = -1, see below.
LDZ (input) INTEGER
The leading dimension of the array Z. LDZ >= 1, and if
JOBZ = 'V', then LDZ >= max(1,N).
NZC (input) INTEGER
The number of eigenvectors to be held in the array Z.
If RANGE = 'A', then NZC >= max(1,N).
If RANGE = 'V', then NZC >= the number of eigenvalues in (VL,VU].
If RANGE = 'I', then NZC >= IU-IL+1.
If NZC = -1, then a workspace query is assumed; the
routine calculates the number of columns of the array Z that
are needed to hold the eigenvectors.
This value is returned as the first entry of the Z array, and
no error message related to NZC is issued by XERBLA.
ISUPPZ (output) INTEGER ARRAY, dimension ( 2*max(1,M) )
The support of the eigenvectors in Z, i.e., the indices
indicating the nonzero elements in Z. The i-th computed eigenvector
is nonzero only in elements ISUPPZ( 2*i-1 ) through
ISUPPZ( 2*i ). This is relevant in the case when the matrix
is split. ISUPPZ is only accessed when JOBZ is 'V' and N > 0.
TRYRAC (input/output) LOGICAL
If TRYRAC.EQ..TRUE., indicates that the code should check whether
the tridiagonal matrix defines its eigenvalues to high relative
accuracy. If so, the code uses relative-accuracy preserving
algorithms that might be (a bit) slower depending on the matrix.
If the matrix does not define its eigenvalues to high relative
accuracy, the code can uses possibly faster algorithms.
If TRYRAC.EQ..FALSE., the code is not required to guarantee
relatively accurate eigenvalues and can use the fastest possible
techniques.
On exit, a .TRUE. TRYRAC will be set to .FALSE. if the matrix
does not define its eigenvalues to high relative accuracy.
WORK (workspace/output) DOUBLE PRECISION array, dimension (LWORK)
On exit, if INFO = 0, WORK(1) returns the optimal
(and minimal) LWORK.
LWORK (input) INTEGER
The dimension of the array WORK. LWORK >= max(1,18*N)
if JOBZ = 'V', and LWORK >= max(1,12*N) if JOBZ = 'N'.
If LWORK = -1, then a workspace query is assumed; the routine
only calculates the optimal size of the WORK array, returns
this value as the first entry of the WORK array, and no error
message related to LWORK is issued by XERBLA.
IWORK (workspace/output) INTEGER array, dimension (LIWORK)
On exit, if INFO = 0, IWORK(1) returns the optimal LIWORK.
LIWORK (input) INTEGER
The dimension of the array IWORK. LIWORK >= max(1,10*N)
if the eigenvectors are desired, and LIWORK >= max(1,8*N)
if only the eigenvalues are to be computed.
If LIWORK = -1, then a workspace query is assumed; the
routine only calculates the optimal size of the IWORK array,
returns this value as the first entry of the IWORK array, and
no error message related to LIWORK is issued by XERBLA.
INFO (output) INTEGER
On exit, INFO
= 0: successful exit
< 0: if INFO = -i, the i-th argument had an illegal value
> 0: if INFO = 1X, internal error in DLARRE,
if INFO = 2X, internal error in DLARRV.
Here, the digit X = ABS( IINFO ) < 10, where IINFO is
the nonzero error code returned by DLARRE or
DLARRV, respectively.
Further Details
===============
Based on contributions by
Beresford Parlett, University of California, Berkeley, USA
Jim Demmel, University of California, Berkeley, USA
Inderjit Dhillon, University of Texas, Austin, USA
Osni Marques, LBNL/NERSC, USA
Christof Voemel, University of California, Berkeley, USA
=====================================================================
Test the input parameters.
Parameter adjustments */
/* Table of constant values */
static integer c__1 = 1;
static doublereal c_b18 = .001;
/* System generated locals */
integer z_dim1, z_offset, i__1, i__2;
doublereal d__1, d__2;
/* Builtin functions */
double sqrt(doublereal);
/* Local variables */
static integer i__, j;
static doublereal r1, r2;
static integer jj;
static doublereal cs;
static integer in;
static doublereal sn, wl, wu;
static integer iil, iiu;
static doublereal eps, tmp;
static integer indd, iend, jblk, wend;
static doublereal rmin, rmax;
static integer itmp;
static doublereal tnrm;
extern /* Subroutine */ int dlae2_(doublereal *, doublereal *, doublereal
*, doublereal *, doublereal *);
static integer inde2, itmp2;
static doublereal rtol1, rtol2;
extern /* Subroutine */ int dscal_(integer *, doublereal *, doublereal *,
integer *);
static doublereal scale;
static integer indgp;
extern logical lsame_(char *, char *);
static integer iinfo, iindw, ilast;
extern /* Subroutine */ int dcopy_(integer *, doublereal *, integer *,
doublereal *, integer *), dswap_(integer *, doublereal *, integer
*, doublereal *, integer *);
static integer lwmin;
static logical wantz;
extern /* Subroutine */ int dlaev2_(doublereal *, doublereal *,
doublereal *, doublereal *, doublereal *, doublereal *,
doublereal *);
extern doublereal dlamch_(char *);
static logical alleig;
static integer ibegin;
static logical indeig;
static integer iindbl;
static logical valeig;
extern /* Subroutine */ int dlarrc_(char *, integer *, doublereal *,
doublereal *, doublereal *, doublereal *, doublereal *, integer *,
integer *, integer *, integer *), dlarre_(char *,
integer *, doublereal *, doublereal *, integer *, integer *,
doublereal *, doublereal *, doublereal *, doublereal *,
doublereal *, doublereal *, integer *, integer *, integer *,
doublereal *, doublereal *, doublereal *, integer *, integer *,
doublereal *, doublereal *, doublereal *, integer *, integer *);
static integer wbegin;
static doublereal safmin;
extern /* Subroutine */ int dlarrj_(integer *, doublereal *, doublereal *,
integer *, integer *, doublereal *, integer *, doublereal *,
doublereal *, doublereal *, integer *, doublereal *, doublereal *,
integer *), xerbla_(char *, integer *);
static doublereal bignum;
static integer inderr, iindwk, indgrs, offset;
extern doublereal dlanst_(char *, integer *, doublereal *, doublereal *);
extern /* Subroutine */ int dlarrr_(integer *, doublereal *, doublereal *,
integer *), dlarrv_(integer *, doublereal *, doublereal *,
doublereal *, doublereal *, doublereal *, integer *, integer *,
integer *, integer *, doublereal *, doublereal *, doublereal *,
doublereal *, doublereal *, doublereal *, integer *, integer *,
doublereal *, doublereal *, integer *, integer *, doublereal *,
integer *, integer *), dlasrt_(char *, integer *, doublereal *,
integer *);
static doublereal thresh;
static integer iinspl, ifirst, indwrk, liwmin, nzcmin;
static doublereal pivmin;
static integer nsplit;
static doublereal smlnum;
static logical lquery, zquery;
--d__;
--e;
--w;
z_dim1 = *ldz;
z_offset = 1 + z_dim1;
z__ -= z_offset;
--isuppz;
--work;
--iwork;
/* Function Body */
wantz = lsame_(jobz, "V");
alleig = lsame_(range, "A");
valeig = lsame_(range, "V");
indeig = lsame_(range, "I");
lquery = *lwork == -1 || *liwork == -1;
zquery = *nzc == -1;
*tryrac = *info != 0;
/* DSTEMR needs WORK of size 6*N, IWORK of size 3*N.
In addition, DLARRE needs WORK of size 6*N, IWORK of size 5*N.
Furthermore, DLARRV needs WORK of size 12*N, IWORK of size 7*N. */
if (wantz) {
lwmin = *n * 18;
liwmin = *n * 10;
} else {
/* need less workspace if only the eigenvalues are wanted */
lwmin = *n * 12;
liwmin = *n << 3;
}
wl = 0.;
wu = 0.;
iil = 0;
iiu = 0;
if (valeig) {
/* We do not reference VL, VU in the cases RANGE = 'I','A'
The interval (WL, WU] contains all the wanted eigenvalues.
It is either given by the user or computed in DLARRE. */
wl = *vl;
wu = *vu;
} else if (indeig) {
/* We do not reference IL, IU in the cases RANGE = 'V','A' */
iil = *il;
iiu = *iu;
}
*info = 0;
if (! (wantz || lsame_(jobz, "N"))) {
*info = -1;
} else if (! (alleig || valeig || indeig)) {
*info = -2;
} else if (*n < 0) {
*info = -3;
} else if (valeig && *n > 0 && wu <= wl) {
*info = -7;
} else if (indeig && (iil < 1 || iil > *n)) {
*info = -8;
} else if (indeig && (iiu < iil || iiu > *n)) {
*info = -9;
} else if (*ldz < 1 || (wantz && *ldz < *n)) {
*info = -13;
} else if (*lwork < lwmin && ! lquery) {
*info = -17;
} else if (*liwork < liwmin && ! lquery) {
*info = -19;
}
/* Get machine constants. */
safmin = dlamch_("Safe minimum");
eps = dlamch_("Precision");
smlnum = safmin / eps;
bignum = 1. / smlnum;
rmin = sqrt(smlnum);
/* Computing MIN */
d__1 = sqrt(bignum), d__2 = 1. / sqrt(sqrt(safmin));
rmax = min(d__1,d__2);
if (*info == 0) {
work[1] = (doublereal) lwmin;
iwork[1] = liwmin;
if (wantz && alleig) {
nzcmin = *n;
} else if (wantz && valeig) {
dlarrc_("T", n, vl, vu, &d__[1], &e[1], &safmin, &nzcmin, &itmp, &
itmp2, info);
} else if (wantz && indeig) {
nzcmin = iiu - iil + 1;
} else {
/* WANTZ .EQ. FALSE. */
nzcmin = 0;
}
if (zquery && *info == 0) {
z__[z_dim1 + 1] = (doublereal) nzcmin;
} else if (*nzc < nzcmin && ! zquery) {
*info = -14;
}
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("DSTEMR", &i__1);
return 0;
} else if (lquery || zquery) {
return 0;
}
/* Handle N = 0, 1, and 2 cases immediately */
*m = 0;
if (*n == 0) {
return 0;
}
if (*n == 1) {
if (alleig || indeig) {
*m = 1;
w[1] = d__[1];
} else {
if (wl < d__[1] && wu >= d__[1]) {
*m = 1;
w[1] = d__[1];
}
}
if (wantz && ! zquery) {
z__[z_dim1 + 1] = 1.;
isuppz[1] = 1;
isuppz[2] = 1;
}
return 0;
}
if (*n == 2) {
if (! wantz) {
dlae2_(&d__[1], &e[1], &d__[2], &r1, &r2);
} else if (wantz && ! zquery) {
dlaev2_(&d__[1], &e[1], &d__[2], &r1, &r2, &cs, &sn);
}
if (alleig || (valeig && r2 > wl && r2 <= wu) || (indeig && iil == 1)) {
++(*m);
w[*m] = r2;
if (wantz && ! zquery) {
z__[*m * z_dim1 + 1] = -sn;
z__[*m * z_dim1 + 2] = cs;
/* Note: At most one of SN and CS can be zero. */
if (sn != 0.) {
if (cs != 0.) {
isuppz[(*m << 1) - 1] = 1;
isuppz[(*m << 1) - 1] = 2;
} else {
isuppz[(*m << 1) - 1] = 1;
isuppz[(*m << 1) - 1] = 1;
}
} else {
isuppz[(*m << 1) - 1] = 2;
isuppz[*m * 2] = 2;
}
}
}
if (alleig || (valeig && r1 > wl && r1 <= wu) || (indeig && iiu == 2)) {
++(*m);
w[*m] = r1;
if (wantz && ! zquery) {
z__[*m * z_dim1 + 1] = cs;
z__[*m * z_dim1 + 2] = sn;
/* Note: At most one of SN and CS can be zero. */
if (sn != 0.) {
if (cs != 0.) {
isuppz[(*m << 1) - 1] = 1;
isuppz[(*m << 1) - 1] = 2;
} else {
isuppz[(*m << 1) - 1] = 1;
isuppz[(*m << 1) - 1] = 1;
}
} else {
isuppz[(*m << 1) - 1] = 2;
isuppz[*m * 2] = 2;
}
}
}
return 0;
}
/* Continue with general N */
indgrs = 1;
inderr = (*n << 1) + 1;
indgp = *n * 3 + 1;
indd = (*n << 2) + 1;
inde2 = *n * 5 + 1;
indwrk = *n * 6 + 1;
iinspl = 1;
iindbl = *n + 1;
iindw = (*n << 1) + 1;
iindwk = *n * 3 + 1;
/* Scale matrix to allowable range, if necessary.
The allowable range is related to the PIVMIN parameter; see the
comments in DLARRD. The preference for scaling small values
up is heuristic; we expect users' matrices not to be close to the
RMAX threshold. */
scale = 1.;
tnrm = dlanst_("M", n, &d__[1], &e[1]);
if (tnrm > 0. && tnrm < rmin) {
scale = rmin / tnrm;
} else if (tnrm > rmax) {
scale = rmax / tnrm;
}
if (scale != 1.) {
dscal_(n, &scale, &d__[1], &c__1);
i__1 = *n - 1;
dscal_(&i__1, &scale, &e[1], &c__1);
tnrm *= scale;
if (valeig) {
/* If eigenvalues in interval have to be found,
scale (WL, WU] accordingly */
wl *= scale;
wu *= scale;
}
}
/* Compute the desired eigenvalues of the tridiagonal after splitting
into smaller subblocks if the corresponding off-diagonal elements
are small
THRESH is the splitting parameter for DLARRE
A negative THRESH forces the old splitting criterion based on the
size of the off-diagonal. A positive THRESH switches to splitting
which preserves relative accuracy. */
if (*tryrac) {
/* Test whether the matrix warrants the more expensive relative approach. */
dlarrr_(n, &d__[1], &e[1], &iinfo);
} else {
/* The user does not care about relative accurately eigenvalues */
iinfo = -1;
}
/* Set the splitting criterion */
if (iinfo == 0) {
thresh = eps;
} else {
thresh = -eps;
/* relative accuracy is desired but T does not guarantee it */
*tryrac = FALSE_;
}
if (*tryrac) {
/* Copy original diagonal, needed to guarantee relative accuracy */
dcopy_(n, &d__[1], &c__1, &work[indd], &c__1);
}
/* Store the squares of the offdiagonal values of T */
i__1 = *n - 1;
for (j = 1; j <= i__1; ++j) {
/* Computing 2nd power */
d__1 = e[j];
work[inde2 + j - 1] = d__1 * d__1;
/* L5: */
}
/* Set the tolerance parameters for bisection */
if (! wantz) {
/* DLARRE computes the eigenvalues to full precision. */
rtol1 = eps * 4.;
rtol2 = eps * 4.;
} else {
/* DLARRE computes the eigenvalues to less than full precision.
DLARRV will refine the eigenvalue approximations, and we can
need less accurate initial bisection in DLARRE.
Note: these settings do only affect the subset case and DLARRE */
rtol1 = sqrt(eps);
/* Computing MAX */
d__1 = sqrt(eps) * .005, d__2 = eps * 4.;
rtol2 = max(d__1,d__2);
}
dlarre_(range, n, &wl, &wu, &iil, &iiu, &d__[1], &e[1], &work[inde2], &
rtol1, &rtol2, &thresh, &nsplit, &iwork[iinspl], m, &w[1], &work[
inderr], &work[indgp], &iwork[iindbl], &iwork[iindw], &work[
indgrs], &pivmin, &work[indwrk], &iwork[iindwk], &iinfo);
if (iinfo != 0) {
*info = abs(iinfo) + 10;
return 0;
}
/* Note that if RANGE .NE. 'V', DLARRE computes bounds on the desired
part of the spectrum. All desired eigenvalues are contained in
(WL,WU] */
if (wantz) {
/* Compute the desired eigenvectors corresponding to the computed
eigenvalues */
dlarrv_(n, &wl, &wu, &d__[1], &e[1], &pivmin, &iwork[iinspl], m, &
c__1, m, &c_b18, &rtol1, &rtol2, &w[1], &work[inderr], &work[
indgp], &iwork[iindbl], &iwork[iindw], &work[indgrs], &z__[
z_offset], ldz, &isuppz[1], &work[indwrk], &iwork[iindwk], &
iinfo);
if (iinfo != 0) {
*info = abs(iinfo) + 20;
return 0;
}
} else {
/* DLARRE computes eigenvalues of the (shifted) root representation
DLARRV returns the eigenvalues of the unshifted matrix.
However, if the eigenvectors are not desired by the user, we need
to apply the corresponding shifts from DLARRE to obtain the
eigenvalues of the original matrix. */
i__1 = *m;
for (j = 1; j <= i__1; ++j) {
itmp = iwork[iindbl + j - 1];
w[j] += e[iwork[iinspl + itmp - 1]];
/* L20: */
}
}
if (*tryrac) {
/* Refine computed eigenvalues so that they are relatively accurate
with respect to the original matrix T. */
ibegin = 1;
wbegin = 1;
i__1 = iwork[iindbl + *m - 1];
for (jblk = 1; jblk <= i__1; ++jblk) {
iend = iwork[iinspl + jblk - 1];
in = iend - ibegin + 1;
wend = wbegin - 1;
/* check if any eigenvalues have to be refined in this block */
L36:
if (wend < *m) {
if (iwork[iindbl + wend] == jblk) {
++wend;
goto L36;
}
}
if (wend < wbegin) {
ibegin = iend + 1;
goto L39;
}
offset = iwork[iindw + wbegin - 1] - 1;
ifirst = iwork[iindw + wbegin - 1];
ilast = iwork[iindw + wend - 1];
rtol2 = eps * 4.;
dlarrj_(&in, &work[indd + ibegin - 1], &work[inde2 + ibegin - 1],
&ifirst, &ilast, &rtol2, &offset, &w[wbegin], &work[
inderr + wbegin - 1], &work[indwrk], &iwork[iindwk], &
pivmin, &tnrm, &iinfo);
ibegin = iend + 1;
wbegin = wend + 1;
L39:
;
}
}
/* If matrix was scaled, then rescale eigenvalues appropriately. */
if (scale != 1.) {
d__1 = 1. / scale;
dscal_(m, &d__1, &w[1], &c__1);
}
/* If eigenvalues are not in increasing order, then sort them,
possibly along with eigenvectors. */
if (nsplit > 1) {
if (! wantz) {
dlasrt_("I", m, &w[1], &iinfo);
if (iinfo != 0) {
*info = 3;
return 0;
}
} else {
i__1 = *m - 1;
for (j = 1; j <= i__1; ++j) {
i__ = 0;
tmp = w[j];
i__2 = *m;
for (jj = j + 1; jj <= i__2; ++jj) {
if (w[jj] < tmp) {
i__ = jj;
tmp = w[jj];
}
/* L50: */
}
if (i__ != 0) {
w[i__] = w[j];
w[j] = tmp;
if (wantz) {
dswap_(n, &z__[i__ * z_dim1 + 1], &c__1, &z__[j *
z_dim1 + 1], &c__1);
itmp = isuppz[(i__ << 1) - 1];
isuppz[(i__ << 1) - 1] = isuppz[(j << 1) - 1];
isuppz[(j << 1) - 1] = itmp;
itmp = isuppz[i__ * 2];
isuppz[i__ * 2] = isuppz[j * 2];
isuppz[j * 2] = itmp;
}
}
/* L60: */
}
}
}
work[1] = (doublereal) lwmin;
iwork[1] = liwmin;
return 0;
/* End of DSTEMR */
} /* dstemr_ */
/* Subroutine */ int dgbtrs_(char *trans, integer *n, integer *kl, integer *
ku, integer *nrhs, doublereal *ab, integer *ldab, integer *ipiv,
doublereal *b, integer *ldb, integer *info)
{
/* -- LAPACK routine (version 2.0) --
Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
Courant Institute, Argonne National Lab, and Rice University
March 31, 1993
Purpose
=======
DGBTRS solves a system of linear equations
A * X = B or A' * X = B
with a general band matrix A using the LU factorization computed
by DGBTRF.
Arguments
=========
TRANS (input) CHARACTER*1
Specifies the form of the system of equations.
= 'N': A * X = B (No transpose)
= 'T': A'* X = B (Transpose)
= 'C': A'* X = B (Conjugate transpose = Transpose)
N (input) INTEGER
The order of the matrix A. N >= 0.
KL (input) INTEGER
The number of subdiagonals within the band of A. KL >= 0.
KU (input) INTEGER
The number of superdiagonals within the band of A. KU >= 0.
NRHS (input) INTEGER
The number of right hand sides, i.e., the number of columns
of the matrix B. NRHS >= 0.
AB (input) DOUBLE PRECISION array, dimension (LDAB,N)
Details of the LU factorization of the band matrix A, as
computed by DGBTRF. U is stored as an upper triangular band
matrix with KL+KU superdiagonals in rows 1 to KL+KU+1, and
the multipliers used during the factorization are stored in
rows KL+KU+2 to 2*KL+KU+1.
LDAB (input) INTEGER
The leading dimension of the array AB. LDAB >= 2*KL+KU+1.
IPIV (input) INTEGER array, dimension (N)
The pivot indices; for 1 <= i <= N, row i of the matrix was
interchanged with row IPIV(i).
B (input/output) DOUBLE PRECISION array, dimension (LDB,NRHS)
On entry, the right hand side matrix B.
On exit, the solution matrix X.
LDB (input) INTEGER
The leading dimension of the array B. LDB >= max(1,N).
INFO (output) INTEGER
= 0: successful exit
< 0: if INFO = -i, the i-th argument had an illegal value
=====================================================================
Test the input parameters.
Parameter adjustments
Function Body */
/* Table of constant values */
static doublereal c_b7 = -1.;
static integer c__1 = 1;
static doublereal c_b23 = 1.;
/* System generated locals */
integer ab_dim1, ab_offset, b_dim1, b_offset, i__1, i__2, i__3;
/* Local variables */
extern /* Subroutine */ int dger_(integer *, integer *, doublereal *,
doublereal *, integer *, doublereal *, integer *, doublereal *,
integer *);
static integer i, j, l;
extern logical lsame_(char *, char *);
extern /* Subroutine */ int dgemv_(char *, integer *, integer *,
doublereal *, doublereal *, integer *, doublereal *, integer *,
doublereal *, doublereal *, integer *), dswap_(integer *,
doublereal *, integer *, doublereal *, integer *), dtbsv_(char *,
char *, char *, integer *, integer *, doublereal *, integer *,
doublereal *, integer *);
static logical lnoti;
static integer kd, lm;
extern /* Subroutine */ int xerbla_(char *, integer *);
static logical notran;
#define IPIV(I) ipiv[(I)-1]
#define AB(I,J) ab[(I)-1 + ((J)-1)* ( *ldab)]
#define B(I,J) b[(I)-1 + ((J)-1)* ( *ldb)]
*info = 0;
notran = lsame_(trans, "N");
if (! notran && ! lsame_(trans, "T") && ! lsame_(trans, "C")) {
*info = -1;
} else if (*n < 0) {
*info = -2;
} else if (*kl < 0) {
*info = -3;
} else if (*ku < 0) {
*info = -4;
} else if (*nrhs < 0) {
*info = -5;
} else if (*ldab < (*kl << 1) + *ku + 1) {
*info = -7;
} else if (*ldb < max(1,*n)) {
*info = -10;
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("DGBTRS", &i__1);
return 0;
}
/* Quick return if possible */
if (*n == 0 || *nrhs == 0) {
return 0;
}
kd = *ku + *kl + 1;
lnoti = *kl > 0;
if (notran) {
/* Solve A*X = B.
Solve L*X = B, overwriting B with X.
L is represented as a product of permutations and unit lower
triangular matrices L = P(1) * L(1) * ... * P(n-1) * L(n-1),
where each transformation L(i) is a rank-one modification of
the identity matrix. */
if (lnoti) {
i__1 = *n - 1;
for (j = 1; j <= *n-1; ++j) {
/* Computing MIN */
i__2 = *kl, i__3 = *n - j;
lm = min(i__2,i__3);
l = IPIV(j);
if (l != j) {
dswap_(nrhs, &B(l,1), ldb, &B(j,1), ldb);
}
dger_(&lm, nrhs, &c_b7, &AB(kd+1,j), &c__1, &B(j,1), ldb, &B(j+1,1), ldb);
/* L10: */
}
}
i__1 = *nrhs;
for (i = 1; i <= *nrhs; ++i) {
/* Solve U*X = B, overwriting B with X. */
i__2 = *kl + *ku;
dtbsv_("Upper", "No transpose", "Non-unit", n, &i__2, &AB(1,1), ldab, &B(1,i), &c__1);
/* L20: */
}
} else {
/* Solve A'*X = B. */
i__1 = *nrhs;
for (i = 1; i <= *nrhs; ++i) {
/* Solve U'*X = B, overwriting B with X. */
i__2 = *kl + *ku;
dtbsv_("Upper", "Transpose", "Non-unit", n, &i__2, &AB(1,1),
ldab, &B(1,i), &c__1);
/* L30: */
}
/* Solve L'*X = B, overwriting B with X. */
if (lnoti) {
for (j = *n - 1; j >= 1; --j) {
/* Computing MIN */
i__1 = *kl, i__2 = *n - j;
lm = min(i__1,i__2);
dgemv_("Transpose", &lm, nrhs, &c_b7, &B(j+1,1), ldb,
&AB(kd+1,j), &c__1, &c_b23, &B(j,1), ldb);
l = IPIV(j);
if (l != j) {
dswap_(nrhs, &B(l,1), ldb, &B(j,1), ldb);
}
/* L40: */
}
}
}
return 0;
/* End of DGBTRS */
} /* dgbtrs_ */
/* Subroutine */ int dgeesx_(char *jobvs, char *sort, L_fp select, char *
sense, integer *n, doublereal *a, integer *lda, integer *sdim,
doublereal *wr, doublereal *wi, doublereal *vs, integer *ldvs,
doublereal *rconde, doublereal *rcondv, doublereal *work, integer *
lwork, integer *iwork, integer *liwork, logical *bwork, integer *info)
{
/* System generated locals */
integer a_dim1, a_offset, vs_dim1, vs_offset, i__1, i__2, i__3;
/* Local variables */
integer i__, i1, i2, ip, ihi, ilo;
doublereal dum[1], eps;
integer ibal;
doublereal anrm;
integer ierr, itau, iwrk, lwrk, inxt, icond, ieval;
logical cursl;
integer liwrk;
logical lst2sl, scalea;
doublereal cscale;
doublereal bignum;
logical wantsb;
logical wantse, lastsl;
integer minwrk, maxwrk;
logical wantsn;
doublereal smlnum;
integer hswork;
logical wantst, lquery, wantsv, wantvs;
/* -- LAPACK driver routine (version 3.2) -- */
/* November 2006 */
/* Purpose */
/* ======= */
/* DGEESX computes for an N-by-N real nonsymmetric matrix A, the */
/* eigenvalues, the real Schur form T, and, optionally, the matrix of */
/* Schur vectors Z. This gives the Schur factorization A = Z*T*(Z**T). */
/* Optionally, it also orders the eigenvalues on the diagonal of the */
/* real Schur form so that selected eigenvalues are at the top left; */
/* computes a reciprocal condition number for the average of the */
/* selected eigenvalues (RCONDE); and computes a reciprocal condition */
/* number for the right invariant subspace corresponding to the */
/* selected eigenvalues (RCONDV). The leading columns of Z form an */
/* orthonormal basis for this invariant subspace. */
/* For further explanation of the reciprocal condition numbers RCONDE */
/* and RCONDV, see Section 4.10 of the LAPACK Users' Guide (where */
/* these quantities are called s and sep respectively). */
/* A real matrix is in real Schur form if it is upper quasi-triangular */
/* with 1-by-1 and 2-by-2 blocks. 2-by-2 blocks will be standardized in */
/* the form */
/* [ a b ] */
/* [ c a ] */
/* where b*c < 0. The eigenvalues of such a block are a +- sqrt(bc). */
/* Arguments */
/* ========= */
/* JOBVS (input) CHARACTER*1 */
/* = 'N': Schur vectors are not computed; */
/* = 'V': Schur vectors are computed. */
/* SORT (input) CHARACTER*1 */
/* Specifies whether or not to order the eigenvalues on the */
/* diagonal of the Schur form. */
/* = 'N': Eigenvalues are not ordered; */
/* = 'S': Eigenvalues are ordered (see SELECT). */
/* SELECT (external procedure) LOGICAL FUNCTION of two DOUBLE PRECISION arguments */
/* SELECT must be declared EXTERNAL in the calling subroutine. */
/* If SORT = 'S', SELECT is used to select eigenvalues to sort */
/* to the top left of the Schur form. */
/* If SORT = 'N', SELECT is not referenced. */
/* An eigenvalue WR(j)+sqrt(-1)*WI(j) is selected if */
/* SELECT(WR(j),WI(j)) is true; i.e., if either one of a */
/* complex conjugate pair of eigenvalues is selected, then both */
/* are. Note that a selected complex eigenvalue may no longer */
/* satisfy SELECT(WR(j),WI(j)) = .TRUE. after ordering, since */
/* ordering may change the value of complex eigenvalues */
/* (especially if the eigenvalue is ill-conditioned); in this */
/* case INFO may be set to N+3 (see INFO below). */
/* SENSE (input) CHARACTER*1 */
/* Determines which reciprocal condition numbers are computed. */
/* = 'N': None are computed; */
/* = 'E': Computed for average of selected eigenvalues only; */
/* = 'V': Computed for selected right invariant subspace only; */
/* = 'B': Computed for both. */
/* If SENSE = 'E', 'V' or 'B', SORT must equal 'S'. */
/* N (input) INTEGER */
/* The order of the matrix A. N >= 0. */
/* A (input/output) DOUBLE PRECISION array, dimension (LDA, N) */
/* On entry, the N-by-N matrix A. */
/* On exit, A is overwritten by its real Schur form T. */
/* LDA (input) INTEGER */
/* The leading dimension of the array A. LDA >= max(1,N). */
/* SDIM (output) INTEGER */
/* If SORT = 'N', SDIM = 0. */
/* If SORT = 'S', SDIM = number of eigenvalues (after sorting) */
/* for which SELECT is true. (Complex conjugate */
/* pairs for which SELECT is true for either */
/* eigenvalue count as 2.) */
/* WR (output) DOUBLE PRECISION array, dimension (N) */
/* WI (output) DOUBLE PRECISION array, dimension (N) */
/* WR and WI contain the real and imaginary parts, respectively, */
/* of the computed eigenvalues, in the same order that they */
/* appear on the diagonal of the output Schur form T. Complex */
/* conjugate pairs of eigenvalues appear consecutively with the */
/* eigenvalue having the positive imaginary part first. */
/* VS (output) DOUBLE PRECISION array, dimension (LDVS,N) */
/* If JOBVS = 'V', VS contains the orthogonal matrix Z of Schur */
/* vectors. */
/* If JOBVS = 'N', VS is not referenced. */
/* LDVS (input) INTEGER */
/* The leading dimension of the array VS. LDVS >= 1, and if */
/* JOBVS = 'V', LDVS >= N. */
/* RCONDE (output) DOUBLE PRECISION */
/* If SENSE = 'E' or 'B', RCONDE contains the reciprocal */
/* condition number for the average of the selected eigenvalues. */
/* Not referenced if SENSE = 'N' or 'V'. */
/* RCONDV (output) DOUBLE PRECISION */
/* If SENSE = 'V' or 'B', RCONDV contains the reciprocal */
/* condition number for the selected right invariant subspace. */
/* Not referenced if SENSE = 'N' or 'E'. */
/* WORK (workspace/output) DOUBLE PRECISION 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,3*N). */
/* Also, if SENSE = 'E' or 'V' or 'B', */
/* LWORK >= N+2*SDIM*(N-SDIM), where SDIM is the number of */
/* selected eigenvalues computed by this routine. Note that */
/* N+2*SDIM*(N-SDIM) <= N+N*N/2. Note also that an error is only */
/* returned if LWORK < max(1,3*N), but if SENSE = 'E' or 'V' or */
/* 'B' this may not be large enough. */
/* For good performance, LWORK must generally be larger. */
/* If LWORK = -1, then a workspace query is assumed; the routine */
/* only calculates upper bounds on the optimal sizes of the */
/* arrays WORK and IWORK, returns these values as the first */
/* entries of the WORK and IWORK arrays, and no error messages */
/* related to LWORK or LIWORK are issued by XERBLA. */
/* IWORK (workspace/output) INTEGER array, dimension (MAX(1,LIWORK)) */
/* On exit, if INFO = 0, IWORK(1) returns the optimal LIWORK. */
/* LIWORK (input) INTEGER */
/* The dimension of the array IWORK. */
/* LIWORK >= 1; if SENSE = 'V' or 'B', LIWORK >= SDIM*(N-SDIM). */
/* Note that SDIM*(N-SDIM) <= N*N/4. Note also that an error is */
/* only returned if LIWORK < 1, but if SENSE = 'V' or 'B' this */
/* may not be large enough. */
/* If LIWORK = -1, then a workspace query is assumed; the */
/* routine only calculates upper bounds on the optimal sizes of */
/* the arrays WORK and IWORK, returns these values as the first */
/* entries of the WORK and IWORK arrays, and no error messages */
/* related to LWORK or LIWORK are issued by XERBLA. */
/* 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. */
/* > 0: if INFO = i, and i is */
/* <= N: the QR algorithm failed to compute all the */
/* eigenvalues; elements 1:ILO-1 and i+1:N of WR and WI */
/* contain those eigenvalues which have converged; if */
/* JOBVS = 'V', VS contains the transformation which */
/* reduces A to its partially converged Schur form. */
/* = N+1: the eigenvalues could not be reordered because some */
/* eigenvalues were too close to separate (the problem */
/* is very ill-conditioned); */
/* = N+2: after reordering, roundoff changed values of some */
/* complex eigenvalues so that leading eigenvalues in */
/* the Schur form no longer satisfy SELECT=.TRUE. This */
/* could also be caused by underflow due to scaling. */
/* ===================================================================== */
/* Test the input arguments */
/* Parameter adjustments */
a_dim1 = *lda;
a_offset = 1 + a_dim1;
a -= a_offset;
--wr;
--wi;
vs_dim1 = *ldvs;
vs_offset = 1 + vs_dim1;
vs -= vs_offset;
--work;
--iwork;
--bwork;
/* Function Body */
*info = 0;
wantvs = lsame_(jobvs, "V");
wantst = lsame_(sort, "S");
wantsn = lsame_(sense, "N");
wantse = lsame_(sense, "E");
wantsv = lsame_(sense, "V");
wantsb = lsame_(sense, "B");
lquery = *lwork == -1 || *liwork == -1;
if (! wantvs && ! lsame_(jobvs, "N")) {
*info = -1;
} else if (! wantst && ! lsame_(sort, "N")) {
*info = -2;
} else if (! (wantsn || wantse || wantsv || wantsb) || ! wantst && !
wantsn) {
*info = -4;
} else if (*n < 0) {
*info = -5;
} else if (*lda < max(1,*n)) {
*info = -7;
} else if (*ldvs < 1 || wantvs && *ldvs < *n) {
*info = -12;
}
/* Compute workspace */
/* (Note: Comments in the code beginning "RWorkspace:" describe the */
/* minimal amount of real workspace needed at that point in the */
/* code, as well as the preferred amount for good performance. */
/* IWorkspace refers to integer workspace. */
/* NB refers to the optimal block size for the immediately */
/* following subroutine, as returned by ILAENV. */
/* HSWORK refers to the workspace preferred by DHSEQR, as */
/* calculated below. HSWORK is computed assuming ILO=1 and IHI=N, */
/* the worst case. */
/* If SENSE = 'E', 'V' or 'B', then the amount of workspace needed */
/* depends on SDIM, which is computed by the routine DTRSEN later */
/* in the code.) */
if (*info == 0) {
liwrk = 1;
if (*n == 0) {
minwrk = 1;
lwrk = 1;
} else {
maxwrk = (*n << 1) + *n * ilaenv_(&c__1, "DGEHRD", " ", n, &c__1,
n, &c__0);
minwrk = *n * 3;
dhseqr_("S", jobvs, n, &c__1, n, &a[a_offset], lda, &wr[1], &wi[1]
, &vs[vs_offset], ldvs, &work[1], &c_n1, &ieval);
hswork = (integer) work[1];
if (! wantvs) {
/* Computing MAX */
i__1 = maxwrk, i__2 = *n + hswork;
maxwrk = max(i__1,i__2);
} else {
/* Computing MAX */
i__1 = maxwrk, i__2 = (*n << 1) + (*n - 1) * ilaenv_(&c__1,
"DORGHR", " ", n, &c__1, n, &c_n1);
maxwrk = max(i__1,i__2);
/* Computing MAX */
i__1 = maxwrk, i__2 = *n + hswork;
maxwrk = max(i__1,i__2);
}
lwrk = maxwrk;
if (! wantsn) {
/* Computing MAX */
i__1 = lwrk, i__2 = *n + *n * *n / 2;
lwrk = max(i__1,i__2);
}
if (wantsv || wantsb) {
liwrk = *n * *n / 4;
}
}
iwork[1] = liwrk;
work[1] = (doublereal) lwrk;
if (*lwork < minwrk && ! lquery) {
*info = -16;
} else if (*liwork < 1 && ! lquery) {
*info = -18;
}
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("DGEESX", &i__1);
return 0;
}
/* Quick return if possible */
if (*n == 0) {
*sdim = 0;
return 0;
}
/* Get machine constants */
eps = dlamch_("P");
smlnum = dlamch_("S");
bignum = 1. / smlnum;
dlabad_(&smlnum, &bignum);
smlnum = sqrt(smlnum) / eps;
bignum = 1. / smlnum;
/* Scale A if max element outside range [SMLNUM,BIGNUM] */
anrm = dlange_("M", n, n, &a[a_offset], lda, dum);
scalea = FALSE_;
if (anrm > 0. && anrm < smlnum) {
scalea = TRUE_;
cscale = smlnum;
} else if (anrm > bignum) {
scalea = TRUE_;
cscale = bignum;
}
if (scalea) {
dlascl_("G", &c__0, &c__0, &anrm, &cscale, n, n, &a[a_offset], lda, &
ierr);
}
/* Permute the matrix to make it more nearly triangular */
/* (RWorkspace: need N) */
ibal = 1;
dgebal_("P", n, &a[a_offset], lda, &ilo, &ihi, &work[ibal], &ierr);
/* Reduce to upper Hessenberg form */
/* (RWorkspace: need 3*N, prefer 2*N+N*NB) */
itau = *n + ibal;
iwrk = *n + itau;
i__1 = *lwork - iwrk + 1;
dgehrd_(n, &ilo, &ihi, &a[a_offset], lda, &work[itau], &work[iwrk], &i__1,
&ierr);
if (wantvs) {
/* Copy Householder vectors to VS */
dlacpy_("L", n, n, &a[a_offset], lda, &vs[vs_offset], ldvs)
;
/* Generate orthogonal matrix in VS */
/* (RWorkspace: need 3*N-1, prefer 2*N+(N-1)*NB) */
i__1 = *lwork - iwrk + 1;
dorghr_(n, &ilo, &ihi, &vs[vs_offset], ldvs, &work[itau], &work[iwrk],
&i__1, &ierr);
}
*sdim = 0;
/* Perform QR iteration, accumulating Schur vectors in VS if desired */
/* (RWorkspace: need N+1, prefer N+HSWORK (see comments) ) */
iwrk = itau;
i__1 = *lwork - iwrk + 1;
dhseqr_("S", jobvs, n, &ilo, &ihi, &a[a_offset], lda, &wr[1], &wi[1], &vs[
vs_offset], ldvs, &work[iwrk], &i__1, &ieval);
if (ieval > 0) {
*info = ieval;
}
/* Sort eigenvalues if desired */
if (wantst && *info == 0) {
if (scalea) {
dlascl_("G", &c__0, &c__0, &cscale, &anrm, n, &c__1, &wr[1], n, &
ierr);
dlascl_("G", &c__0, &c__0, &cscale, &anrm, n, &c__1, &wi[1], n, &
ierr);
}
i__1 = *n;
for (i__ = 1; i__ <= i__1; ++i__) {
bwork[i__] = (*select)(&wr[i__], &wi[i__]);
}
/* Reorder eigenvalues, transform Schur vectors, and compute */
/* reciprocal condition numbers */
/* (RWorkspace: if SENSE is not 'N', need N+2*SDIM*(N-SDIM) */
/* otherwise, need N ) */
/* (IWorkspace: if SENSE is 'V' or 'B', need SDIM*(N-SDIM) */
/* otherwise, need 0 ) */
i__1 = *lwork - iwrk + 1;
dtrsen_(sense, jobvs, &bwork[1], n, &a[a_offset], lda, &vs[vs_offset],
ldvs, &wr[1], &wi[1], sdim, rconde, rcondv, &work[iwrk], &
i__1, &iwork[1], liwork, &icond);
if (! wantsn) {
/* Computing MAX */
i__1 = maxwrk, i__2 = *n + (*sdim << 1) * (*n - *sdim);
maxwrk = max(i__1,i__2);
}
if (icond == -15) {
/* Not enough real workspace */
*info = -16;
} else if (icond == -17) {
/* Not enough integer workspace */
*info = -18;
} else if (icond > 0) {
/* DTRSEN failed to reorder or to restore standard Schur form */
*info = icond + *n;
}
}
if (wantvs) {
/* Undo balancing */
/* (RWorkspace: need N) */
dgebak_("P", "R", n, &ilo, &ihi, &work[ibal], n, &vs[vs_offset], ldvs,
&ierr);
}
if (scalea) {
/* Undo scaling for the Schur form of A */
dlascl_("H", &c__0, &c__0, &cscale, &anrm, n, n, &a[a_offset], lda, &
ierr);
i__1 = *lda + 1;
dcopy_(n, &a[a_offset], &i__1, &wr[1], &c__1);
if ((wantsv || wantsb) && *info == 0) {
dum[0] = *rcondv;
dlascl_("G", &c__0, &c__0, &cscale, &anrm, &c__1, &c__1, dum, &
c__1, &ierr);
*rcondv = dum[0];
}
if (cscale == smlnum) {
/* If scaling back towards underflow, adjust WI if an */
/* offdiagonal element of a 2-by-2 block in the Schur form */
/* underflows. */
if (ieval > 0) {
i1 = ieval + 1;
i2 = ihi - 1;
i__1 = ilo - 1;
dlascl_("G", &c__0, &c__0, &cscale, &anrm, &i__1, &c__1, &wi[
1], n, &ierr);
} else if (wantst) {
i1 = 1;
i2 = *n - 1;
} else {
i1 = ilo;
i2 = ihi - 1;
}
inxt = i1 - 1;
i__1 = i2;
for (i__ = i1; i__ <= i__1; ++i__) {
if (i__ < inxt) {
goto L20;
}
if (wi[i__] == 0.) {
inxt = i__ + 1;
} else {
if (a[i__ + 1 + i__ * a_dim1] == 0.) {
wi[i__] = 0.;
wi[i__ + 1] = 0.;
} else if (a[i__ + 1 + i__ * a_dim1] != 0. && a[i__ + (
i__ + 1) * a_dim1] == 0.) {
wi[i__] = 0.;
wi[i__ + 1] = 0.;
if (i__ > 1) {
i__2 = i__ - 1;
dswap_(&i__2, &a[i__ * a_dim1 + 1], &c__1, &a[(
i__ + 1) * a_dim1 + 1], &c__1);
}
if (*n > i__ + 1) {
i__2 = *n - i__ - 1;
dswap_(&i__2, &a[i__ + (i__ + 2) * a_dim1], lda, &
a[i__ + 1 + (i__ + 2) * a_dim1], lda);
}
dswap_(n, &vs[i__ * vs_dim1 + 1], &c__1, &vs[(i__ + 1)
* vs_dim1 + 1], &c__1);
a[i__ + (i__ + 1) * a_dim1] = a[i__ + 1 + i__ *
a_dim1];
a[i__ + 1 + i__ * a_dim1] = 0.;
}
inxt = i__ + 2;
}
L20:
;
}
}
i__1 = *n - ieval;
/* Computing MAX */
i__3 = *n - ieval;
i__2 = max(i__3,1);
dlascl_("G", &c__0, &c__0, &cscale, &anrm, &i__1, &c__1, &wi[ieval +
1], &i__2, &ierr);
}
if (wantst && *info == 0) {
/* Check if reordering successful */
lastsl = TRUE_;
lst2sl = TRUE_;
*sdim = 0;
ip = 0;
i__1 = *n;
for (i__ = 1; i__ <= i__1; ++i__) {
cursl = (*select)(&wr[i__], &wi[i__]);
if (wi[i__] == 0.) {
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;
}
}
work[1] = (doublereal) maxwrk;
if (wantsv || wantsb) {
/* Computing MAX */
i__1 = 1, i__2 = *sdim * (*n - *sdim);
iwork[1] = max(i__1,i__2);
} else {
iwork[1] = 1;
}
return 0;
/* End of DGEESX */
} /* dgeesx_ */
/* Subroutine */
int dlaqp2_(integer *m, integer *n, integer *offset, doublereal *a, integer *lda, integer *jpvt, doublereal *tau, doublereal *vn1, doublereal *vn2, doublereal *work)
{
/* System generated locals */
integer a_dim1, a_offset, i__1, i__2, i__3;
doublereal d__1, d__2;
/* Builtin functions */
double sqrt(doublereal);
/* Local variables */
integer i__, j, mn;
doublereal aii;
integer pvt;
doublereal temp;
extern doublereal dnrm2_(integer *, doublereal *, integer *);
doublereal temp2, tol3z;
extern /* Subroutine */
int dlarf_(char *, integer *, integer *, doublereal *, integer *, doublereal *, doublereal *, integer *, doublereal *);
integer offpi, itemp;
extern /* Subroutine */
int dswap_(integer *, doublereal *, integer *, doublereal *, integer *);
extern doublereal dlamch_(char *);
extern /* Subroutine */
int dlarfg_(integer *, doublereal *, doublereal *, integer *, doublereal *);
extern integer idamax_(integer *, doublereal *, integer *);
/* -- LAPACK auxiliary routine (version 3.5.0) -- */
/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */
/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */
/* November 2013 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. Executable Statements .. */
/* Parameter adjustments */
a_dim1 = *lda;
a_offset = 1 + a_dim1;
a -= a_offset;
--jpvt;
--tau;
--vn1;
--vn2;
--work;
/* Function Body */
/* Computing MIN */
i__1 = *m - *offset;
mn = min(i__1,*n);
tol3z = sqrt(dlamch_("Epsilon"));
/* Compute factorization. */
i__1 = mn;
for (i__ = 1;
i__ <= i__1;
++i__)
{
offpi = *offset + i__;
/* Determine ith pivot column and swap if necessary. */
i__2 = *n - i__ + 1;
pvt = i__ - 1 + idamax_(&i__2, &vn1[i__], &c__1);
if (pvt != i__)
{
dswap_(m, &a[pvt * a_dim1 + 1], &c__1, &a[i__ * a_dim1 + 1], & c__1);
itemp = jpvt[pvt];
jpvt[pvt] = jpvt[i__];
jpvt[i__] = itemp;
vn1[pvt] = vn1[i__];
vn2[pvt] = vn2[i__];
}
/* Generate elementary reflector H(i). */
if (offpi < *m)
{
i__2 = *m - offpi + 1;
dlarfg_(&i__2, &a[offpi + i__ * a_dim1], &a[offpi + 1 + i__ * a_dim1], &c__1, &tau[i__]);
}
else
{
dlarfg_(&c__1, &a[*m + i__ * a_dim1], &a[*m + i__ * a_dim1], & c__1, &tau[i__]);
}
if (i__ < *n)
{
/* Apply H(i)**T to A(offset+i:m,i+1:n) from the left. */
aii = a[offpi + i__ * a_dim1];
a[offpi + i__ * a_dim1] = 1.;
i__2 = *m - offpi + 1;
i__3 = *n - i__;
dlarf_("Left", &i__2, &i__3, &a[offpi + i__ * a_dim1], &c__1, & tau[i__], &a[offpi + (i__ + 1) * a_dim1], lda, &work[1]);
a[offpi + i__ * a_dim1] = aii;
}
/* Update partial column norms. */
i__2 = *n;
for (j = i__ + 1;
j <= i__2;
++j)
{
if (vn1[j] != 0.)
{
/* NOTE: The following 4 lines follow from the analysis in */
/* Lapack Working Note 176. */
/* Computing 2nd power */
d__2 = (d__1 = a[offpi + j * a_dim1], abs(d__1)) / vn1[j];
temp = 1. - d__2 * d__2;
temp = max(temp,0.);
/* Computing 2nd power */
d__1 = vn1[j] / vn2[j];
temp2 = temp * (d__1 * d__1);
if (temp2 <= tol3z)
{
if (offpi < *m)
{
i__3 = *m - offpi;
vn1[j] = dnrm2_(&i__3, &a[offpi + 1 + j * a_dim1], & c__1);
vn2[j] = vn1[j];
}
else
{
vn1[j] = 0.;
vn2[j] = 0.;
}
}
else
{
vn1[j] *= sqrt(temp);
}
}
/* L10: */
}
/* L20: */
}
return 0;
/* End of DLAQP2 */
}
/* Subroutine */ int dsytri_(char *uplo, integer *n, doublereal *a, integer *
lda, integer *ipiv, doublereal *work, integer *info)
{
/* System generated locals */
integer a_dim1, a_offset, i__1;
doublereal d__1;
/* Local variables */
doublereal d__;
integer k;
doublereal t, ak;
integer kp;
doublereal akp1;
extern doublereal ddot_(integer *, doublereal *, integer *, doublereal *,
integer *);
doublereal temp, akkp1;
extern logical lsame_(char *, char *);
extern /* Subroutine */ int dcopy_(integer *, doublereal *, integer *,
doublereal *, integer *), dswap_(integer *, doublereal *, integer
*, doublereal *, integer *);
integer kstep;
logical upper;
extern /* Subroutine */ int dsymv_(char *, integer *, doublereal *,
doublereal *, integer *, doublereal *, integer *, doublereal *,
doublereal *, integer *), xerbla_(char *, integer *);
/* -- LAPACK routine (version 3.2) -- */
/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/* November 2006 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* DSYTRI computes the inverse of a real symmetric indefinite matrix */
/* A using the factorization A = U*D*U**T or A = L*D*L**T computed by */
/* DSYTRF. */
/* Arguments */
/* ========= */
/* UPLO (input) CHARACTER*1 */
/* Specifies whether the details of the factorization are stored */
/* as an upper or lower triangular matrix. */
/* = 'U': Upper triangular, form is A = U*D*U**T; */
/* = 'L': Lower triangular, form is A = L*D*L**T. */
/* N (input) INTEGER */
/* The order of the matrix A. N >= 0. */
/* A (input/output) DOUBLE PRECISION array, dimension (LDA,N) */
/* On entry, the block diagonal matrix D and the multipliers */
/* used to obtain the factor U or L as computed by DSYTRF. */
/* On exit, if INFO = 0, the (symmetric) inverse of the original */
/* matrix. If UPLO = 'U', the upper triangular part of the */
/* inverse is formed and the part of A below the diagonal is not */
/* referenced; if UPLO = 'L' the lower triangular part of the */
/* inverse is formed and the part of A above the diagonal is */
/* not referenced. */
/* LDA (input) INTEGER */
/* The leading dimension of the array A. LDA >= max(1,N). */
/* IPIV (input) INTEGER array, dimension (N) */
/* Details of the interchanges and the block structure of D */
/* as determined by DSYTRF. */
/* WORK (workspace) DOUBLE PRECISION 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, D(i,i) = 0; the matrix is singular and its */
/* inverse could not be computed. */
/* ===================================================================== */
/* .. 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;
--ipiv;
--work;
/* Function Body */
*info = 0;
upper = lsame_(uplo, "U");
if (! upper && ! lsame_(uplo, "L")) {
*info = -1;
} else if (*n < 0) {
*info = -2;
} else if (*lda < max(1,*n)) {
*info = -4;
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("DSYTRI", &i__1);
return 0;
}
/* Quick return if possible */
if (*n == 0) {
return 0;
}
/* Check that the diagonal matrix D is nonsingular. */
if (upper) {
/* Upper triangular storage: examine D from bottom to top */
for (*info = *n; *info >= 1; --(*info)) {
if (ipiv[*info] > 0 && a[*info + *info * a_dim1] == 0.) {
return 0;
}
/* L10: */
}
} else {
/* Lower triangular storage: examine D from top to bottom. */
i__1 = *n;
for (*info = 1; *info <= i__1; ++(*info)) {
if (ipiv[*info] > 0 && a[*info + *info * a_dim1] == 0.) {
return 0;
}
/* L20: */
}
}
*info = 0;
if (upper) {
/* Compute inv(A) from the factorization A = U*D*U'. */
/* K is the main loop index, increasing from 1 to N in steps of */
/* 1 or 2, depending on the size of the diagonal blocks. */
k = 1;
L30:
/* If K > N, exit from loop. */
if (k > *n) {
goto L40;
}
if (ipiv[k] > 0) {
/* 1 x 1 diagonal block */
/* Invert the diagonal block. */
a[k + k * a_dim1] = 1. / a[k + k * a_dim1];
/* Compute column K of the inverse. */
if (k > 1) {
i__1 = k - 1;
dcopy_(&i__1, &a[k * a_dim1 + 1], &c__1, &work[1], &c__1);
i__1 = k - 1;
dsymv_(uplo, &i__1, &c_b11, &a[a_offset], lda, &work[1], &
c__1, &c_b13, &a[k * a_dim1 + 1], &c__1);
i__1 = k - 1;
a[k + k * a_dim1] -= ddot_(&i__1, &work[1], &c__1, &a[k *
a_dim1 + 1], &c__1);
}
kstep = 1;
} else {
/* 2 x 2 diagonal block */
/* Invert the diagonal block. */
t = (d__1 = a[k + (k + 1) * a_dim1], abs(d__1));
ak = a[k + k * a_dim1] / t;
akp1 = a[k + 1 + (k + 1) * a_dim1] / t;
akkp1 = a[k + (k + 1) * a_dim1] / t;
d__ = t * (ak * akp1 - 1.);
a[k + k * a_dim1] = akp1 / d__;
a[k + 1 + (k + 1) * a_dim1] = ak / d__;
a[k + (k + 1) * a_dim1] = -akkp1 / d__;
/* Compute columns K and K+1 of the inverse. */
if (k > 1) {
i__1 = k - 1;
dcopy_(&i__1, &a[k * a_dim1 + 1], &c__1, &work[1], &c__1);
i__1 = k - 1;
dsymv_(uplo, &i__1, &c_b11, &a[a_offset], lda, &work[1], &
c__1, &c_b13, &a[k * a_dim1 + 1], &c__1);
i__1 = k - 1;
a[k + k * a_dim1] -= ddot_(&i__1, &work[1], &c__1, &a[k *
a_dim1 + 1], &c__1);
i__1 = k - 1;
a[k + (k + 1) * a_dim1] -= ddot_(&i__1, &a[k * a_dim1 + 1], &
c__1, &a[(k + 1) * a_dim1 + 1], &c__1);
i__1 = k - 1;
dcopy_(&i__1, &a[(k + 1) * a_dim1 + 1], &c__1, &work[1], &
c__1);
i__1 = k - 1;
dsymv_(uplo, &i__1, &c_b11, &a[a_offset], lda, &work[1], &
c__1, &c_b13, &a[(k + 1) * a_dim1 + 1], &c__1);
i__1 = k - 1;
a[k + 1 + (k + 1) * a_dim1] -= ddot_(&i__1, &work[1], &c__1, &
a[(k + 1) * a_dim1 + 1], &c__1);
}
kstep = 2;
}
kp = (i__1 = ipiv[k], abs(i__1));
if (kp != k) {
/* Interchange rows and columns K and KP in the leading */
/* submatrix A(1:k+1,1:k+1) */
i__1 = kp - 1;
dswap_(&i__1, &a[k * a_dim1 + 1], &c__1, &a[kp * a_dim1 + 1], &
c__1);
i__1 = k - kp - 1;
dswap_(&i__1, &a[kp + 1 + k * a_dim1], &c__1, &a[kp + (kp + 1) *
a_dim1], lda);
temp = a[k + k * a_dim1];
a[k + k * a_dim1] = a[kp + kp * a_dim1];
a[kp + kp * a_dim1] = temp;
if (kstep == 2) {
temp = a[k + (k + 1) * a_dim1];
a[k + (k + 1) * a_dim1] = a[kp + (k + 1) * a_dim1];
a[kp + (k + 1) * a_dim1] = temp;
}
}
k += kstep;
goto L30;
L40:
;
} else {
/* Compute inv(A) from the factorization A = L*D*L'. */
/* K is the main loop index, increasing from 1 to N in steps of */
/* 1 or 2, depending on the size of the diagonal blocks. */
k = *n;
L50:
/* If K < 1, exit from loop. */
if (k < 1) {
goto L60;
}
if (ipiv[k] > 0) {
/* 1 x 1 diagonal block */
/* Invert the diagonal block. */
a[k + k * a_dim1] = 1. / a[k + k * a_dim1];
/* Compute column K of the inverse. */
if (k < *n) {
i__1 = *n - k;
dcopy_(&i__1, &a[k + 1 + k * a_dim1], &c__1, &work[1], &c__1);
i__1 = *n - k;
dsymv_(uplo, &i__1, &c_b11, &a[k + 1 + (k + 1) * a_dim1], lda,
&work[1], &c__1, &c_b13, &a[k + 1 + k * a_dim1], &
c__1);
i__1 = *n - k;
a[k + k * a_dim1] -= ddot_(&i__1, &work[1], &c__1, &a[k + 1 +
k * a_dim1], &c__1);
}
kstep = 1;
} else {
/* 2 x 2 diagonal block */
/* Invert the diagonal block. */
t = (d__1 = a[k + (k - 1) * a_dim1], abs(d__1));
ak = a[k - 1 + (k - 1) * a_dim1] / t;
akp1 = a[k + k * a_dim1] / t;
akkp1 = a[k + (k - 1) * a_dim1] / t;
d__ = t * (ak * akp1 - 1.);
a[k - 1 + (k - 1) * a_dim1] = akp1 / d__;
a[k + k * a_dim1] = ak / d__;
a[k + (k - 1) * a_dim1] = -akkp1 / d__;
/* Compute columns K-1 and K of the inverse. */
if (k < *n) {
i__1 = *n - k;
dcopy_(&i__1, &a[k + 1 + k * a_dim1], &c__1, &work[1], &c__1);
i__1 = *n - k;
dsymv_(uplo, &i__1, &c_b11, &a[k + 1 + (k + 1) * a_dim1], lda,
&work[1], &c__1, &c_b13, &a[k + 1 + k * a_dim1], &
c__1);
i__1 = *n - k;
a[k + k * a_dim1] -= ddot_(&i__1, &work[1], &c__1, &a[k + 1 +
k * a_dim1], &c__1);
i__1 = *n - k;
a[k + (k - 1) * a_dim1] -= ddot_(&i__1, &a[k + 1 + k * a_dim1]
, &c__1, &a[k + 1 + (k - 1) * a_dim1], &c__1);
i__1 = *n - k;
dcopy_(&i__1, &a[k + 1 + (k - 1) * a_dim1], &c__1, &work[1], &
c__1);
i__1 = *n - k;
dsymv_(uplo, &i__1, &c_b11, &a[k + 1 + (k + 1) * a_dim1], lda,
&work[1], &c__1, &c_b13, &a[k + 1 + (k - 1) * a_dim1]
, &c__1);
i__1 = *n - k;
a[k - 1 + (k - 1) * a_dim1] -= ddot_(&i__1, &work[1], &c__1, &
a[k + 1 + (k - 1) * a_dim1], &c__1);
}
kstep = 2;
}
kp = (i__1 = ipiv[k], abs(i__1));
if (kp != k) {
/* Interchange rows and columns K and KP in the trailing */
/* submatrix A(k-1:n,k-1:n) */
if (kp < *n) {
i__1 = *n - kp;
dswap_(&i__1, &a[kp + 1 + k * a_dim1], &c__1, &a[kp + 1 + kp *
a_dim1], &c__1);
}
i__1 = kp - k - 1;
dswap_(&i__1, &a[k + 1 + k * a_dim1], &c__1, &a[kp + (k + 1) *
a_dim1], lda);
temp = a[k + k * a_dim1];
a[k + k * a_dim1] = a[kp + kp * a_dim1];
a[kp + kp * a_dim1] = temp;
if (kstep == 2) {
temp = a[k + (k - 1) * a_dim1];
a[k + (k - 1) * a_dim1] = a[kp + (k - 1) * a_dim1];
a[kp + (k - 1) * a_dim1] = temp;
}
}
k -= kstep;
goto L50;
L60:
;
}
return 0;
/* End of DSYTRI */
} /* dsytri_ */
/* Subroutine */ int dgebal_(char *job, integer *n, doublereal *a, integer *
lda, integer *ilo, integer *ihi, doublereal *scale, integer *info)
{
/* System generated locals */
integer a_dim1, a_offset, i__1, i__2;
doublereal d__1, d__2;
/* Local variables */
doublereal c__, f, g;
integer i__, j, k, l, m;
doublereal r__, s, ca, ra;
integer ica, ira, iexc;
extern /* Subroutine */ int dscal_(integer *, doublereal *, doublereal *,
integer *);
extern logical lsame_(char *, char *);
extern /* Subroutine */ int dswap_(integer *, doublereal *, integer *,
doublereal *, integer *);
doublereal sfmin1, sfmin2, sfmax1, sfmax2;
extern doublereal dlamch_(char *);
extern integer idamax_(integer *, doublereal *, integer *);
extern /* Subroutine */ int xerbla_(char *, integer *);
logical noconv;
/* -- LAPACK routine (version 3.1) -- */
/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/* November 2006 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* DGEBAL balances a general real matrix A. This involves, first, */
/* permuting A by a similarity transformation to isolate eigenvalues */
/* in the first 1 to ILO-1 and last IHI+1 to N elements on the */
/* diagonal; and second, applying a diagonal similarity transformation */
/* to rows and columns ILO to IHI to make the rows and columns as */
/* close in norm as possible. Both steps are optional. */
/* Balancing may reduce the 1-norm of the matrix, and improve the */
/* accuracy of the computed eigenvalues and/or eigenvectors. */
/* Arguments */
/* ========= */
/* JOB (input) CHARACTER*1 */
/* Specifies the operations to be performed on A: */
/* = 'N': none: simply set ILO = 1, IHI = N, SCALE(I) = 1.0 */
/* for i = 1,...,N; */
/* = 'P': permute only; */
/* = 'S': scale only; */
/* = 'B': both permute and scale. */
/* N (input) INTEGER */
/* The order of the matrix A. N >= 0. */
/* A (input/output) DOUBLE PRECISION array, dimension (LDA,N) */
/* On entry, the input matrix A. */
/* On exit, A is overwritten by the balanced matrix. */
/* If JOB = 'N', A is not referenced. */
/* See Further Details. */
/* LDA (input) INTEGER */
/* The leading dimension of the array A. LDA >= max(1,N). */
/* ILO (output) INTEGER */
/* IHI (output) INTEGER */
/* ILO and IHI are set to integers such that on exit */
/* A(i,j) = 0 if i > j and j = 1,...,ILO-1 or I = IHI+1,...,N. */
/* If JOB = 'N' or 'S', ILO = 1 and IHI = N. */
/* SCALE (output) DOUBLE PRECISION array, dimension (N) */
/* Details of the permutations and scaling factors applied to */
/* 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. */
/* INFO (output) INTEGER */
/* = 0: successful exit. */
/* < 0: if INFO = -i, the i-th argument had an illegal value. */
/* Further Details */
/* =============== */
/* The permutations consist of row and column interchanges which put */
/* the matrix in the form */
/* ( T1 X Y ) */
/* P A P = ( 0 B Z ) */
/* ( 0 0 T2 ) */
/* where T1 and T2 are upper triangular matrices whose eigenvalues lie */
/* along the diagonal. The column indices ILO and IHI mark the starting */
/* and ending columns of the submatrix B. Balancing consists of applying */
/* a diagonal similarity transformation inv(D) * B * D to make the */
/* 1-norms of each row of B and its corresponding column nearly equal. */
/* The output matrix is */
/* ( T1 X*D Y ) */
/* ( 0 inv(D)*B*D inv(D)*Z ). */
/* ( 0 0 T2 ) */
/* Information about the permutations P and the diagonal matrix D is */
/* returned in the vector SCALE. */
/* This subroutine is based on the EISPACK routine BALANC. */
/* Modified by Tzu-Yi Chen, Computer Science Division, University of */
/* California at Berkeley, USA */
/* ===================================================================== */
/* .. 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;
--scale;
/* Function Body */
*info = 0;
if (! lsame_(job, "N") && ! lsame_(job, "P") && ! lsame_(job, "S")
&& ! lsame_(job, "B")) {
*info = -1;
} else if (*n < 0) {
*info = -2;
} else if (*lda < max(1,*n)) {
*info = -4;
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("DGEBAL", &i__1);
return 0;
}
k = 1;
l = *n;
if (*n == 0) {
goto L210;
}
if (lsame_(job, "N")) {
i__1 = *n;
for (i__ = 1; i__ <= i__1; ++i__) {
scale[i__] = 1.;
/* L10: */
}
goto L210;
}
if (lsame_(job, "S")) {
goto L120;
}
/* Permutation to isolate eigenvalues if possible */
goto L50;
/* Row and column exchange. */
L20:
scale[m] = (doublereal) j;
if (j == m) {
goto L30;
}
dswap_(&l, &a[j * a_dim1 + 1], &c__1, &a[m * a_dim1 + 1], &c__1);
i__1 = *n - k + 1;
dswap_(&i__1, &a[j + k * a_dim1], lda, &a[m + k * a_dim1], lda);
L30:
switch (iexc) {
case 1: goto L40;
case 2: goto L80;
}
/* Search for rows isolating an eigenvalue and push them down. */
L40:
if (l == 1) {
goto L210;
}
--l;
L50:
for (j = l; j >= 1; --j) {
i__1 = l;
for (i__ = 1; i__ <= i__1; ++i__) {
if (i__ == j) {
goto L60;
}
if (a[j + i__ * a_dim1] != 0.) {
goto L70;
}
L60:
;
}
m = l;
iexc = 1;
goto L20;
L70:
;
}
goto L90;
/* Search for columns isolating an eigenvalue and push them left. */
L80:
++k;
L90:
i__1 = l;
for (j = k; j <= i__1; ++j) {
i__2 = l;
for (i__ = k; i__ <= i__2; ++i__) {
if (i__ == j) {
goto L100;
}
if (a[i__ + j * a_dim1] != 0.) {
goto L110;
}
L100:
;
}
m = k;
iexc = 2;
goto L20;
L110:
;
}
L120:
i__1 = l;
for (i__ = k; i__ <= i__1; ++i__) {
scale[i__] = 1.;
/* L130: */
}
if (lsame_(job, "P")) {
goto L210;
}
/* Balance the submatrix in rows K to L. */
/* Iterative loop for norm reduction */
sfmin1 = dlamch_("S") / dlamch_("P");
sfmax1 = 1. / sfmin1;
sfmin2 = sfmin1 * 2.;
sfmax2 = 1. / sfmin2;
L140:
noconv = FALSE_;
i__1 = l;
for (i__ = k; i__ <= i__1; ++i__) {
c__ = 0.;
r__ = 0.;
i__2 = l;
for (j = k; j <= i__2; ++j) {
if (j == i__) {
goto L150;
}
c__ += (d__1 = a[j + i__ * a_dim1], abs(d__1));
r__ += (d__1 = a[i__ + j * a_dim1], abs(d__1));
L150:
;
}
ica = idamax_(&l, &a[i__ * a_dim1 + 1], &c__1);
ca = (d__1 = a[ica + i__ * a_dim1], abs(d__1));
i__2 = *n - k + 1;
ira = idamax_(&i__2, &a[i__ + k * a_dim1], lda);
ra = (d__1 = a[i__ + (ira + k - 1) * a_dim1], abs(d__1));
/* Guard against zero C or R due to underflow. */
if (c__ == 0. || r__ == 0.) {
goto L200;
}
g = r__ / 2.;
f = 1.;
s = c__ + r__;
L160:
/* Computing MAX */
d__1 = max(f,c__);
/* Computing MIN */
d__2 = min(r__,g);
if (c__ >= g || max(d__1,ca) >= sfmax2 || min(d__2,ra) <= sfmin2) {
goto L170;
}
f *= 2.;
c__ *= 2.;
ca *= 2.;
r__ /= 2.;
g /= 2.;
ra /= 2.;
goto L160;
L170:
g = c__ / 2.;
L180:
/* Computing MIN */
d__1 = min(f,c__), d__1 = min(d__1,g);
if (g < r__ || max(r__,ra) >= sfmax2 || min(d__1,ca) <= sfmin2) {
goto L190;
}
f /= 2.;
c__ /= 2.;
g /= 2.;
ca /= 2.;
r__ *= 2.;
ra *= 2.;
goto L180;
/* Now balance. */
L190:
if (c__ + r__ >= s * .95) {
goto L200;
}
if (f < 1. && scale[i__] < 1.) {
if (f * scale[i__] <= sfmin1) {
goto L200;
}
}
if (f > 1. && scale[i__] > 1.) {
if (scale[i__] >= sfmax1 / f) {
goto L200;
}
}
g = 1. / f;
scale[i__] *= f;
noconv = TRUE_;
i__2 = *n - k + 1;
dscal_(&i__2, &g, &a[i__ + k * a_dim1], lda);
dscal_(&l, &f, &a[i__ * a_dim1 + 1], &c__1);
L200:
;
}
if (noconv) {
goto L140;
}
L210:
*ilo = k;
*ihi = l;
return 0;
/* End of DGEBAL */
} /* dgebal_ */
static int lpfnb_ (integer *n, integer *p, doublereal *a, doublereal *c__,
doublereal *b, doublereal *d__, doublereal *u, doublereal *beta,
doublereal *eps, doublereal *x, doublereal *s, doublereal *y,
doublereal *z__, doublereal *w, doublereal *dx, doublereal *ds,
doublereal *dy, doublereal *dz, doublereal *dw, doublereal *dr,
doublereal *rhs, doublereal *ada, integer *nit, integer *info,
void (*callback)(void))
{
integer a_dim1 = *p, ada_dim1 = *p;
integer a_offset = 1 + a_dim1, ada_offset = 1 + ada_dim1;
doublereal d1, d2;
static doublereal g;
static integer i;
static doublereal mu, gap;
static doublereal dsdw, dxdz;
static doublereal deltad, deltap;
int main_iters = 0;
int err = 0;
/* Parameter adjustments */
--dr;
--dw;
--dz;
--ds;
--dx;
--w;
--z__;
--s;
--x;
--u;
--d__;
--c__;
ada -= ada_offset;
--rhs;
--dy;
--y;
--b;
a -= a_offset;
--nit;
/* Function Body */
nit[1] = 0;
nit[2] = 0;
nit[3] = *n;
dgemv_("N", p, n, &c_b4, &a[a_offset], p, &c__[1], &one, &zero, &y[1],
&one);
for (i = 1; i <= *n; ++i) {
d__[i] = 1.;
}
err = stepy_(n, p, &a[a_offset], &d__[1], &y[1], &ada[ada_offset], info);
if (err) {
return err;
}
dcopy_(n, &c__[1], &one, &s[1], &one);
dgemv_("T", p, n, &c_b13, &a[a_offset], p, &y[1], &one, &c_b4, &s[1],
&one);
for (i = 1; i <= *n; ++i) {
if ((d1 = s[i], fabs(d1)) < *eps) {
d1 = s[i];
z__[i] = max(d1,0.) + *eps;
d1 = -s[i];
w[i] = max(d1,0.) + *eps;
} else {
d1 = s[i];
z__[i] = max(d1, 0.);
d1 = -s[i];
w[i] = max(d1, 0.);
}
s[i] = u[i] - x[i];
}
gap = ddot_(n, &z__[1], &one, &x[1], &one) +
ddot_(n, &w[1], &one, &s[1], &one);
looptop:
if (callback != NULL && (main_iters++ % ITERSTEP == 0)) {
callback();
}
if (gap > *eps && nit[1] < 50) {
++nit[1];
for (i = 1; i <= *n; ++i) {
d__[i] = 1. / (z__[i] / x[i] + w[i] / s[i]);
ds[i] = z__[i] - w[i];
dz[i] = d__[i] * ds[i];
}
dcopy_(p, &b[1], &one, &dy[1], &one);
dgemv_("N", p, n, &c_b13, &a[a_offset], p, &x[1], &one, &c_b4, &dy[1],
&one);
dgemv_("N", p, n, &c_b4, &a[a_offset], p, &dz[1], &one, &c_b4, &dy[1],
&one);
dcopy_(p, &dy[1], &one, &rhs[1], &one);
err = stepy_(n, p, &a[a_offset], &d__[1], &dy[1], &ada[ada_offset], info);
if (err) {
return err;
}
dgemv_("T", p, n, &c_b4, &a[a_offset], p, &dy[1], &one, &c_b13,
&ds[1], &one);
deltap = 1e20;
deltad = 1e20;
for (i = 1; i <= *n; ++i) {
dx[i] = d__[i] * ds[i];
ds[i] = -dx[i];
dz[i] = -z__[i] * (dx[i] / x[i] + 1.);
dw[i] = -w[i] * (ds[i] / s[i] + 1.);
if (dx[i] < 0.) {
d1 = deltap, d2 = -x[i] / dx[i];
deltap = min(d1,d2);
}
if (ds[i] < 0.) {
d1 = deltap, d2 = -s[i] / ds[i];
deltap = min(d1,d2);
}
if (dz[i] < 0.) {
d1 = deltad, d2 = -z__[i] / dz[i];
deltad = min(d1,d2);
}
if (dw[i] < 0.) {
d1 = deltad, d2 = -w[i] / dw[i];
deltad = min(d1,d2);
}
}
d1 = *beta * deltap;
deltap = min(d1,1.);
d1 = *beta * deltad;
deltad = min(d1,1.);
if (min(deltap,deltad) < 1.) {
++nit[2];
mu = ddot_(n, &x[1], &one, &z__[1], &one) +
ddot_(n, &s[1], &one, &w[1], &one);
g = mu + deltap * ddot_(n, &dx[1], &one, &z__[1], &one) +
deltad * ddot_(n, &dz[1], &one, &x[1], &one) +
deltap * deltad * ddot_(n, &dz[1], &one, &dx[1], &one) +
deltap * ddot_(n, &ds[1], &one, &w[1], &one) +
deltad * ddot_(n, &dw[1], &one, &s[1], &one) +
deltap * deltad * ddot_(n, &ds[1], &one, &dw[1], &one);
d1 = g / mu;
mu = mu * (d1 * (d1 * d1)) / (doublereal) (*n << 1);
for (i = 1; i <= *n; ++i) {
dr[i] = d__[i] * (mu * (1 / s[i] - 1 / x[i]) + dx[i]
* dz[i] / x[i] - ds[i] * dw[i] / s[i]);
}
dswap_(p, &rhs[1], &one, &dy[1], &one);
dgemv_("N", p, n, &c_b4, &a[a_offset], p, &dr[1], &one, &c_b4,
&dy[1], &one);
dpotrs_("U", p, &one, &ada[ada_offset], p, &dy[1], p, info);
if (*info != 0) {
fprintf(stderr, "lpfnb: dpotrs_ gave info = %d\n", *info);
}
dgemv_("T", p, n, &c_b4, &a[a_offset], p, &dy[1], &one, &zero,
&u[1], &one);
deltap = 1e20;
deltad = 1e20;
for (i = 1; i <= *n; ++i) {
dxdz = dx[i] * dz[i];
dsdw = ds[i] * dw[i];
dx[i] = d__[i] * (u[i] - z__[i] + w[i]) - dr[i];
ds[i] = -dx[i];
dz[i] = -z__[i] + (mu - z__[i] * dx[i] - dxdz) / x[i];
dw[i] = -w[i] + (mu - w[i] * ds[i] - dsdw) / s[i];
if (dx[i] < 0.) {
d1 = deltap, d2 = -x[i] / dx[i];
deltap = min(d1, d2);
}
if (ds[i] < 0.) {
d1 = deltap, d2 = -s[i] / ds[i];
deltap = min(d1, d2);
}
if (dz[i] < 0.) {
d1 = deltad, d2 = -z__[i] / dz[i];
deltad = min(d1, d2);
}
if (dw[i] < 0.) {
d1 = deltad, d2 = -w[i] / dw[i];
deltad = min(d1, d2);
}
}
d1 = *beta * deltap;
deltap = min(d1,1.);
d1 = *beta * deltad;
deltad = min(d1,1.);
}
daxpy_(n, &deltap, &dx[1], &one, &x[1], &one);
daxpy_(n, &deltap, &ds[1], &one, &s[1], &one);
daxpy_(p, &deltad, &dy[1], &one, &y[1], &one);
daxpy_(n, &deltad, &dz[1], &one, &z__[1], &one);
daxpy_(n, &deltad, &dw[1], &one, &w[1], &one);
gap = ddot_(n, &z__[1], &one, &x[1], &one) +
ddot_(n, &w[1], &one, &s[1], &one);
goto looptop;
}
daxpy_(n, &c_b13, &w[1], &one, &z__[1], &one);
dswap_(n, &z__[1], &one, &x[1], &one);
return err;
} /* end of lpfnb_ */
/*< >*/
/* Subroutine */ int dsaup2_(integer *ido, char *bmat, integer *n, char *
which, integer *nev, integer *np, doublereal *tol, doublereal *resid,
integer *mode, integer *iupd, integer *ishift, integer *mxiter,
doublereal *v, integer *ldv, doublereal *h__, integer *ldh,
doublereal *ritz, doublereal *bounds, doublereal *q, integer *ldq,
doublereal *workl, integer *ipntr, doublereal *workd, integer *info,
ftnlen bmat_len, ftnlen which_len)
{
/* System generated locals */
integer h_dim1, h_offset, q_dim1, q_offset, v_dim1, v_offset, i__1, i__2,
i__3;
doublereal d__1, d__2, d__3;
/* Builtin functions */
double pow_dd(doublereal *, doublereal *);
integer s_cmp(char *, char *, ftnlen, ftnlen);
/* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);
double sqrt(doublereal);
/* Local variables */
integer j;
/* static real t0, t1, t2, t3; */
/* integer kp[3]; */
static integer np0, nev0;
extern doublereal ddot_(integer *, doublereal *, integer *, doublereal *,
integer *);
static doublereal eps23;
integer ierr;
static integer iter;
doublereal temp;
integer nevd2;
extern doublereal dnrm2_(integer *, doublereal *, integer *);
static logical getv0;
integer nevm2;
static logical cnorm;
extern /* Subroutine */ int dcopy_(integer *, doublereal *, integer *,
doublereal *, integer *), dswap_(integer *, doublereal *, integer
*, doublereal *, integer *);
static integer nconv;
static logical initv;
static doublereal rnorm;
extern /* Subroutine */ int dgetv0_(integer *, char *, integer *, logical
*, integer *, integer *, doublereal *, integer *, doublereal *,
doublereal *, integer *, doublereal *, integer *, ftnlen);
extern doublereal dlamch_(char *, ftnlen);
integer nevbef;
extern /* Subroutine */ int second_(real *);
static logical update;
char wprime[2];
static logical ushift;
static integer kplusp /*, msglvl */;
integer nptemp;
extern /* Subroutine */ int dsaitr_(integer *, char *, integer *, integer
*, integer *, integer *, doublereal *, doublereal *, doublereal *,
integer *, doublereal *, integer *, integer *, doublereal *,
integer *, ftnlen), dsconv_(integer *, doublereal *, doublereal *,
doublereal *, integer *), dseigt_(doublereal *, integer *,
doublereal *, integer *, doublereal *, doublereal *, doublereal *,
integer *), dsgets_(integer *, char *, integer *, integer *,
doublereal *, doublereal *, doublereal *, ftnlen), dsapps_(
integer *, integer *, integer *, doublereal *, doublereal *,
integer *, doublereal *, integer *, doublereal *, doublereal *,
integer *, doublereal *), dsortr_(char *, logical *, integer *,
doublereal *, doublereal *, ftnlen);
/* %----------------------------------------------------% */
/* | Include files for debugging and timing information | */
/* %----------------------------------------------------% */
/*< include 'debug.h' >*/
/*< include 'stat.h' >*/
/* \SCCS Information: @(#) */
/* FILE: debug.h SID: 2.3 DATE OF SID: 11/16/95 RELEASE: 2 */
/* %---------------------------------% */
/* | See debug.doc for documentation | */
/* %---------------------------------% */
/*< >*/
/*< character bmat*1, which*2 >*/
/* %------------------% */
/* | Scalar Arguments | */
/* %------------------% */
/* %--------------------------------% */
/* | See stat.doc for documentation | */
/* %--------------------------------% */
/* \SCCS Information: @(#) */
/* FILE: stat.h SID: 2.2 DATE OF SID: 11/16/95 RELEASE: 2 */
/*< save t0, t1, t2, t3, t4, t5 >*/
/*< integer nopx, nbx, nrorth, nitref, nrstrt >*/
/*< >*/
/*< >*/
/*< >*/
/*< >*/
/* %-----------------% */
/* | Array Arguments | */
/* %-----------------% */
/*< integer ipntr(3) >*/
/*< >*/
/* %------------% */
/* | Parameters | */
/* %------------% */
/*< >*/
/*< parameter (one = 1.0D+0, zero = 0.0D+0) >*/
/* %---------------% */
/* | Local Scalars | */
/* %---------------% */
/*< character wprime*2 >*/
/*< logical cnorm, getv0, initv, update, ushift >*/
/*< >*/
/*< >*/
/*< >*/
/* %----------------------% */
/* | External Subroutines | */
/* %----------------------% */
/*< >*/
/* %--------------------% */
/* | External Functions | */
/* %--------------------% */
/*< >*/
/*< external ddot, dnrm2, dlamch >*/
/* %---------------------% */
/* | Intrinsic Functions | */
/* %---------------------% */
/*< intrinsic min >*/
/* %-----------------------% */
/* | Executable Statements | */
/* %-----------------------% */
/*< if (ido .eq. 0) then >*/
/* Parameter adjustments */
--workd;
--resid;
--workl;
--bounds;
--ritz;
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;
--ipntr;
/* Function Body */
if (*ido == 0) {
/* %-------------------------------% */
/* | Initialize timing statistics | */
/* | & message level for debugging | */
/* %-------------------------------% */
/*< call second (t0) >*/
/* second_(&t0); */
/*< msglvl = msaup2 >*/
/* msglvl = debug_1.msaup2; */
/* %---------------------------------% */
/* | Set machine dependent constant. | */
/* %---------------------------------% */
/*< eps23 = dlamch('Epsilon-Machine') >*/
eps23 = dlamch_("Epsilon-Machine", (ftnlen)15);
/*< eps23 = eps23**(2.0D+0/3.0D+0) >*/
eps23 = pow_dd(&eps23, &c_b3);
/* %-------------------------------------% */
/* | nev0 and np0 are integer variables | */
/* | hold the initial values of NEV & NP | */
/* %-------------------------------------% */
/*< nev0 = nev >*/
nev0 = *nev;
/*< np0 = np >*/
np0 = *np;
/* %-------------------------------------% */
/* | kplusp is the bound on the largest | */
/* | Lanczos factorization built. | */
/* | nconv is the current number of | */
/* | "converged" eigenvlues. | */
/* | iter is the counter on the current | */
/* | iteration step. | */
/* %-------------------------------------% */
/*< kplusp = nev0 + np0 >*/
kplusp = nev0 + np0;
/*< nconv = 0 >*/
nconv = 0;
/*< iter = 0 >*/
iter = 0;
/* %--------------------------------------------% */
/* | Set flags for computing the first NEV steps | */
/* | of the Lanczos factorization. | */
/* %--------------------------------------------% */
/*< getv0 = .true. >*/
getv0 = TRUE_;
/*< update = .false. >*/
update = FALSE_;
/*< ushift = .false. >*/
ushift = FALSE_;
/*< cnorm = .false. >*/
cnorm = FALSE_;
/*< if (info .ne. 0) then >*/
if (*info != 0) {
/* %--------------------------------------------% */
/* | User provides the initial residual vector. | */
/* %--------------------------------------------% */
/*< initv = .true. >*/
initv = TRUE_;
/*< info = 0 >*/
*info = 0;
/*< else >*/
} else {
/*< initv = .false. >*/
initv = FALSE_;
/*< end if >*/
}
/*< end if >*/
}
/* %---------------------------------------------% */
/* | Get a possibly random starting vector and | */
/* | force it into the range of the operator OP. | */
/* %---------------------------------------------% */
/*< 10 continue >*/
/* L10: */
/*< if (getv0) then >*/
if (getv0) {
/*< >*/
dgetv0_(ido, bmat, &c__1, &initv, n, &c__1, &v[v_offset], ldv, &resid[
1], &rnorm, &ipntr[1], &workd[1], info, (ftnlen)1);
/*< if (ido .ne. 99) go to 9000 >*/
if (*ido != 99) {
goto L9000;
}
/*< if (rnorm .eq. zero) then >*/
if (rnorm == 0.) {
/* %-----------------------------------------% */
/* | The initial vector is zero. Error exit. | */
/* %-----------------------------------------% */
/*< info = -9 >*/
*info = -9;
/*< go to 1200 >*/
goto L1200;
/*< end if >*/
}
/*< getv0 = .false. >*/
getv0 = FALSE_;
/*< ido = 0 >*/
*ido = 0;
/*< end if >*/
}
/* %------------------------------------------------------------% */
/* | Back from reverse communication: continue with update step | */
/* %------------------------------------------------------------% */
/*< if (update) go to 20 >*/
if (update) {
goto L20;
}
/* %-------------------------------------------% */
/* | Back from computing user specified shifts | */
/* %-------------------------------------------% */
/*< if (ushift) go to 50 >*/
if (ushift) {
goto L50;
}
/* %-------------------------------------% */
/* | Back from computing residual norm | */
/* | at the end of the current iteration | */
/* %-------------------------------------% */
/*< if (cnorm) go to 100 >*/
if (cnorm) {
goto L100;
}
/* %----------------------------------------------------------% */
/* | Compute the first NEV steps of the Lanczos factorization | */
/* %----------------------------------------------------------% */
/*< >*/
dsaitr_(ido, bmat, n, &c__0, &nev0, mode, &resid[1], &rnorm, &v[v_offset],
ldv, &h__[h_offset], ldh, &ipntr[1], &workd[1], info, (ftnlen)1);
/* %---------------------------------------------------% */
/* | ido .ne. 99 implies use of reverse communication | */
/* | to compute operations involving OP and possibly B | */
/* %---------------------------------------------------% */
/*< if (ido .ne. 99) go to 9000 >*/
if (*ido != 99) {
goto L9000;
}
/*< if (info .gt. 0) then >*/
if (*info > 0) {
/* %-----------------------------------------------------% */
/* | dsaitr was unable to build an Lanczos factorization | */
/* | of length NEV0. INFO is returned with the size of | */
/* | the factorization built. Exit main loop. | */
/* %-----------------------------------------------------% */
/*< np = info >*/
*np = *info;
/*< mxiter = iter >*/
*mxiter = iter;
/*< info = -9999 >*/
*info = -9999;
/*< go to 1200 >*/
goto L1200;
/*< end if >*/
}
/* %--------------------------------------------------------------% */
/* | | */
/* | M A I N LANCZOS I T E R A T I O N L O O P | */
/* | Each iteration implicitly restarts the Lanczos | */
/* | factorization in place. | */
/* | | */
/* %--------------------------------------------------------------% */
/*< 1000 continue >*/
L1000:
/*< iter = iter + 1 >*/
++iter;
/* if (msglvl .gt. 0) then */
/* call ivout (logfil, 1, iter, ndigit, */
/* & '_saup2: **** Start of major iteration number ****') */
/* end if */
/* if (msglvl .gt. 1) then */
/* call ivout (logfil, 1, nev, ndigit, */
/* & '_saup2: The length of the current Lanczos factorization') */
/* call ivout (logfil, 1, np, ndigit, */
/* & '_saup2: Extend the Lanczos factorization by') */
/* end if */
/* %------------------------------------------------------------% */
/* | Compute NP additional steps of the Lanczos factorization. | */
/* %------------------------------------------------------------% */
/*< ido = 0 >*/
*ido = 0;
/*< 20 continue >*/
L20:
/*< update = .true. >*/
update = TRUE_;
/*< >*/
dsaitr_(ido, bmat, n, nev, np, mode, &resid[1], &rnorm, &v[v_offset], ldv,
&h__[h_offset], ldh, &ipntr[1], &workd[1], info, (ftnlen)1);
/* %---------------------------------------------------% */
/* | ido .ne. 99 implies use of reverse communication | */
/* | to compute operations involving OP and possibly B | */
/* %---------------------------------------------------% */
/*< if (ido .ne. 99) go to 9000 >*/
if (*ido != 99) {
goto L9000;
}
/*< if (info .gt. 0) then >*/
if (*info > 0) {
/* %-----------------------------------------------------% */
/* | dsaitr was unable to build an Lanczos factorization | */
/* | of length NEV0+NP0. INFO is returned with the size | */
/* | of the factorization built. Exit main loop. | */
/* %-----------------------------------------------------% */
/*< np = info >*/
*np = *info;
/*< mxiter = iter >*/
*mxiter = iter;
/*< info = -9999 >*/
*info = -9999;
/*< go to 1200 >*/
goto L1200;
/*< end if >*/
}
/*< update = .false. >*/
update = FALSE_;
/* if (msglvl .gt. 1) then */
/* call dvout (logfil, 1, rnorm, ndigit, */
/* & '_saup2: Current B-norm of residual for factorization') */
/* end if */
/* %--------------------------------------------------------% */
/* | Compute the eigenvalues and corresponding error bounds | */
/* | of the current symmetric tridiagonal matrix. | */
/* %--------------------------------------------------------% */
/*< call dseigt (rnorm, kplusp, h, ldh, ritz, bounds, workl, ierr) >*/
dseigt_(&rnorm, &kplusp, &h__[h_offset], ldh, &ritz[1], &bounds[1], &
workl[1], &ierr);
/*< if (ierr .ne. 0) then >*/
if (ierr != 0) {
/*< info = -8 >*/
*info = -8;
/*< go to 1200 >*/
goto L1200;
/*< end if >*/
}
/* %----------------------------------------------------% */
/* | Make a copy of eigenvalues and corresponding error | */
/* | bounds obtained from _seigt. | */
/* %----------------------------------------------------% */
/*< call dcopy(kplusp, ritz, 1, workl(kplusp+1), 1) >*/
dcopy_(&kplusp, &ritz[1], &c__1, &workl[kplusp + 1], &c__1);
/*< call dcopy(kplusp, bounds, 1, workl(2*kplusp+1), 1) >*/
dcopy_(&kplusp, &bounds[1], &c__1, &workl[(kplusp << 1) + 1], &c__1);
/* %---------------------------------------------------% */
/* | Select the wanted Ritz values and their bounds | */
/* | to be used in the convergence test. | */
/* | The selection is based on the requested number of | */
/* | eigenvalues instead of the current NEV and NP to | */
/* | prevent possible misconvergence. | */
/* | * Wanted Ritz values := RITZ(NP+1:NEV+NP) | */
/* | * Shifts := RITZ(1:NP) := WORKL(1:NP) | */
/* %---------------------------------------------------% */
/*< nev = nev0 >*/
*nev = nev0;
/*< np = np0 >*/
*np = np0;
/*< call dsgets (ishift, which, nev, np, ritz, bounds, workl) >*/
dsgets_(ishift, which, nev, np, &ritz[1], &bounds[1], &workl[1], (ftnlen)
2);
/* %-------------------% */
/* | Convergence test. | */
/* %-------------------% */
/*< call dcopy (nev, bounds(np+1), 1, workl(np+1), 1) >*/
dcopy_(nev, &bounds[*np + 1], &c__1, &workl[*np + 1], &c__1);
/*< call dsconv (nev, ritz(np+1), workl(np+1), tol, nconv) >*/
dsconv_(nev, &ritz[*np + 1], &workl[*np + 1], tol, &nconv);
/*< if (msglvl .gt. 2) then >*/
/* if (msglvl > 2) { */
/*< kp(1) = nev >*/
/* kp[0] = *nev; */
/*< kp(2) = np >*/
/* kp[1] = *np; */
/*< kp(3) = nconv >*/
/* kp[2] = nconv; */
/* call ivout (logfil, 3, kp, ndigit, */
/* & '_saup2: NEV, NP, NCONV are') */
/* call dvout (logfil, kplusp, ritz, ndigit, */
/* & '_saup2: The eigenvalues of H') */
/* call dvout (logfil, kplusp, bounds, ndigit, */
/* & '_saup2: Ritz estimates of the current NCV Ritz values') */
/*< end if >*/
/* } */
/* %---------------------------------------------------------% */
/* | Count the number of unwanted Ritz values that have zero | */
/* | Ritz estimates. If any Ritz estimates are equal to zero | */
/* | then a leading block of H of order equal to at least | */
/* | the number of Ritz values with zero Ritz estimates has | */
/* | split off. None of these Ritz values may be removed by | */
/* | shifting. Decrease NP the number of shifts to apply. If | */
/* | no shifts may be applied, then prepare to exit | */
/* %---------------------------------------------------------% */
/*< nptemp = np >*/
nptemp = *np;
/*< do 30 j=1, nptemp >*/
i__1 = nptemp;
for (j = 1; j <= i__1; ++j) {
/*< if (bounds(j) .eq. zero) then >*/
if (bounds[j] == 0.) {
/*< np = np - 1 >*/
--(*np);
/*< nev = nev + 1 >*/
++(*nev);
/*< end if >*/
}
/*< 30 continue >*/
/* L30: */
}
/*< >*/
if (nconv >= nev0 || iter > *mxiter || *np == 0) {
/* %------------------------------------------------% */
/* | Prepare to exit. Put the converged Ritz values | */
/* | and corresponding bounds in RITZ(1:NCONV) and | */
/* | BOUNDS(1:NCONV) respectively. Then sort. Be | */
/* | careful when NCONV > NP since we don't want to | */
/* | swap overlapping locations. | */
/* %------------------------------------------------% */
/*< if (which .eq. 'BE') then >*/
if (s_cmp(which, "BE", (ftnlen)2, (ftnlen)2) == 0) {
/* %-----------------------------------------------------% */
/* | Both ends of the spectrum are requested. | */
/* | Sort the eigenvalues into algebraically decreasing | */
/* | order first then swap low end of the spectrum next | */
/* | to high end in appropriate locations. | */
/* | NOTE: when np < floor(nev/2) be careful not to swap | */
/* | overlapping locations. | */
/* %-----------------------------------------------------% */
/*< wprime = 'SA' >*/
s_copy(wprime, "SA", (ftnlen)2, (ftnlen)2);
/*< call dsortr (wprime, .true., kplusp, ritz, bounds) >*/
dsortr_(wprime, &c_true, &kplusp, &ritz[1], &bounds[1], (ftnlen)2)
;
/*< nevd2 = nev / 2 >*/
nevd2 = *nev / 2;
/*< nevm2 = nev - nevd2 >*/
nevm2 = *nev - nevd2;
/*< if ( nev .gt. 1 ) then >*/
if (*nev > 1) {
/*< >*/
i__1 = min(nevd2,*np);
/* Computing MAX */
i__2 = kplusp - nevd2 + 1, i__3 = kplusp - *np + 1;
dswap_(&i__1, &ritz[nevm2 + 1], &c__1, &ritz[max(i__2,i__3)],
&c__1);
/*< >*/
i__1 = min(nevd2,*np);
/* Computing MAX */
i__2 = kplusp - nevd2 + 1, i__3 = kplusp - *np;
dswap_(&i__1, &bounds[nevm2 + 1], &c__1, &bounds[max(i__2,
i__3) + 1], &c__1);
/*< end if >*/
}
/*< else >*/
} else {
/* %--------------------------------------------------% */
/* | LM, SM, LA, SA case. | */
/* | Sort the eigenvalues of H into the an order that | */
/* | is opposite to WHICH, and apply the resulting | */
/* | order to BOUNDS. The eigenvalues are sorted so | */
/* | that the wanted part are always within the first | */
/* | NEV locations. | */
/* %--------------------------------------------------% */
/*< if (which .eq. 'LM') wprime = 'SM' >*/
if (s_cmp(which, "LM", (ftnlen)2, (ftnlen)2) == 0) {
s_copy(wprime, "SM", (ftnlen)2, (ftnlen)2);
}
/*< if (which .eq. 'SM') wprime = 'LM' >*/
if (s_cmp(which, "SM", (ftnlen)2, (ftnlen)2) == 0) {
s_copy(wprime, "LM", (ftnlen)2, (ftnlen)2);
}
/*< if (which .eq. 'LA') wprime = 'SA' >*/
if (s_cmp(which, "LA", (ftnlen)2, (ftnlen)2) == 0) {
s_copy(wprime, "SA", (ftnlen)2, (ftnlen)2);
}
/*< if (which .eq. 'SA') wprime = 'LA' >*/
if (s_cmp(which, "SA", (ftnlen)2, (ftnlen)2) == 0) {
s_copy(wprime, "LA", (ftnlen)2, (ftnlen)2);
}
/*< call dsortr (wprime, .true., kplusp, ritz, bounds) >*/
dsortr_(wprime, &c_true, &kplusp, &ritz[1], &bounds[1], (ftnlen)2)
;
/*< end if >*/
}
/* %--------------------------------------------------% */
/* | Scale the Ritz estimate of each Ritz value | */
/* | by 1 / max(eps23,magnitude of the Ritz value). | */
/* %--------------------------------------------------% */
/*< do 35 j = 1, nev0 >*/
i__1 = nev0;
for (j = 1; j <= i__1; ++j) {
/*< temp = max( eps23, abs(ritz(j)) ) >*/
/* Computing MAX */
d__2 = eps23, d__3 = (d__1 = ritz[j], abs(d__1));
temp = max(d__2,d__3);
/*< bounds(j) = bounds(j)/temp >*/
bounds[j] /= temp;
/*< 35 continue >*/
/* L35: */
}
/* %----------------------------------------------------% */
/* | Sort the Ritz values according to the scaled Ritz | */
/* | esitmates. This will push all the converged ones | */
/* | towards the front of ritzr, ritzi, bounds | */
/* | (in the case when NCONV < NEV.) | */
/* %----------------------------------------------------% */
/*< wprime = 'LA' >*/
s_copy(wprime, "LA", (ftnlen)2, (ftnlen)2);
/*< call dsortr(wprime, .true., nev0, bounds, ritz) >*/
dsortr_(wprime, &c_true, &nev0, &bounds[1], &ritz[1], (ftnlen)2);
/* %----------------------------------------------% */
/* | Scale the Ritz estimate back to its original | */
/* | value. | */
/* %----------------------------------------------% */
/*< do 40 j = 1, nev0 >*/
i__1 = nev0;
for (j = 1; j <= i__1; ++j) {
/*< temp = max( eps23, abs(ritz(j)) ) >*/
/* Computing MAX */
d__2 = eps23, d__3 = (d__1 = ritz[j], abs(d__1));
temp = max(d__2,d__3);
/*< bounds(j) = bounds(j)*temp >*/
bounds[j] *= temp;
/*< 40 continue >*/
/* L40: */
}
/* %--------------------------------------------------% */
/* | Sort the "converged" Ritz values again so that | */
/* | the "threshold" values and their associated Ritz | */
/* | estimates appear at the appropriate position in | */
/* | ritz and bound. | */
/* %--------------------------------------------------% */
/*< if (which .eq. 'BE') then >*/
if (s_cmp(which, "BE", (ftnlen)2, (ftnlen)2) == 0) {
/* %------------------------------------------------% */
/* | Sort the "converged" Ritz values in increasing | */
/* | order. The "threshold" values are in the | */
/* | middle. | */
/* %------------------------------------------------% */
/*< wprime = 'LA' >*/
s_copy(wprime, "LA", (ftnlen)2, (ftnlen)2);
/*< call dsortr(wprime, .true., nconv, ritz, bounds) >*/
dsortr_(wprime, &c_true, &nconv, &ritz[1], &bounds[1], (ftnlen)2);
/*< else >*/
} else {
/* %----------------------------------------------% */
/* | In LM, SM, LA, SA case, sort the "converged" | */
/* | Ritz values according to WHICH so that the | */
/* | "threshold" value appears at the front of | */
/* | ritz. | */
/* %----------------------------------------------% */
/*< call dsortr(which, .true., nconv, ritz, bounds) >*/
dsortr_(which, &c_true, &nconv, &ritz[1], &bounds[1], (ftnlen)2);
/*< end if >*/
}
/* %------------------------------------------% */
/* | Use h( 1,1 ) as storage to communicate | */
/* | rnorm to _seupd if needed | */
/* %------------------------------------------% */
/*< h(1,1) = rnorm >*/
h__[h_dim1 + 1] = rnorm;
/* if (msglvl .gt. 1) then */
/* call dvout (logfil, kplusp, ritz, ndigit, */
/* & '_saup2: Sorted Ritz values.') */
/* call dvout (logfil, kplusp, bounds, ndigit, */
/* & '_saup2: Sorted ritz estimates.') */
/* end if */
/* %------------------------------------% */
/* | Max iterations have been exceeded. | */
/* %------------------------------------% */
/*< if (iter .gt. mxiter .and. nconv .lt. nev) info = 1 >*/
if (iter > *mxiter && nconv < *nev) {
*info = 1;
}
/* %---------------------% */
/* | No shifts to apply. | */
/* %---------------------% */
/*< if (np .eq. 0 .and. nconv .lt. nev0) info = 2 >*/
if (*np == 0 && nconv < nev0) {
*info = 2;
}
/*< np = nconv >*/
*np = nconv;
/*< go to 1100 >*/
goto L1100;
/*< else if (nconv .lt. nev .and. ishift .eq. 1) then >*/
} else if (nconv < *nev && *ishift == 1) {
/* %---------------------------------------------------% */
/* | Do not have all the requested eigenvalues yet. | */
/* | To prevent possible stagnation, adjust the number | */
/* | of Ritz values and the shifts. | */
/* %---------------------------------------------------% */
/*< nevbef = nev >*/
nevbef = *nev;
/*< nev = nev + min (nconv, np/2) >*/
/* Computing MIN */
i__1 = nconv, i__2 = *np / 2;
*nev += min(i__1,i__2);
/*< if (nev .eq. 1 .and. kplusp .ge. 6) then >*/
if (*nev == 1 && kplusp >= 6) {
/*< nev = kplusp / 2 >*/
*nev = kplusp / 2;
/*< else if (nev .eq. 1 .and. kplusp .gt. 2) then >*/
} else if (*nev == 1 && kplusp > 2) {
/*< nev = 2 >*/
*nev = 2;
/*< end if >*/
}
/*< np = kplusp - nev >*/
*np = kplusp - *nev;
/* %---------------------------------------% */
/* | If the size of NEV was just increased | */
/* | resort the eigenvalues. | */
/* %---------------------------------------% */
/*< >*/
if (nevbef < *nev) {
dsgets_(ishift, which, nev, np, &ritz[1], &bounds[1], &workl[1], (
ftnlen)2);
}
/*< end if >*/
}
/*< if (msglvl .gt. 0) then >*/
/* if (msglvl > 0) { */
/* call ivout (logfil, 1, nconv, ndigit, */
/* & '_saup2: no. of "converged" Ritz values at this iter.') */
/*< if (msglvl .gt. 1) then >*/
/* if (msglvl > 1) { */
/*< kp(1) = nev >*/
/* kp[0] = *nev; */
/*< kp(2) = np >*/
/* kp[1] = *np; */
/* call ivout (logfil, 2, kp, ndigit, */
/* & '_saup2: NEV and NP are') */
/* call dvout (logfil, nev, ritz(np+1), ndigit, */
/* & '_saup2: "wanted" Ritz values.') */
/* call dvout (logfil, nev, bounds(np+1), ndigit, */
/* & '_saup2: Ritz estimates of the "wanted" values ') */
/*< end if >*/
/* } */
/*< end if >*/
/* } */
/*< if (ishift .eq. 0) then >*/
if (*ishift == 0) {
/* %-----------------------------------------------------% */
/* | User specified shifts: reverse communication to | */
/* | compute the shifts. They are returned in the first | */
/* | NP locations of WORKL. | */
/* %-----------------------------------------------------% */
/*< ushift = .true. >*/
ushift = TRUE_;
/*< ido = 3 >*/
*ido = 3;
/*< go to 9000 >*/
goto L9000;
/*< end if >*/
}
/*< 50 continue >*/
L50:
/* %------------------------------------% */
/* | Back from reverse communication; | */
/* | User specified shifts are returned | */
/* | in WORKL(1:*NP) | */
/* %------------------------------------% */
/*< ushift = .false. >*/
ushift = FALSE_;
/* %---------------------------------------------------------% */
/* | Move the NP shifts to the first NP locations of RITZ to | */
/* | free up WORKL. This is for the non-exact shift case; | */
/* | in the exact shift case, dsgets already handles this. | */
/* %---------------------------------------------------------% */
/*< if (ishift .eq. 0) call dcopy (np, workl, 1, ritz, 1) >*/
if (*ishift == 0) {
dcopy_(np, &workl[1], &c__1, &ritz[1], &c__1);
}
/* if (msglvl .gt. 2) then */
/* call ivout (logfil, 1, np, ndigit, */
/* & '_saup2: The number of shifts to apply ') */
/* call dvout (logfil, np, workl, ndigit, */
/* & '_saup2: shifts selected') */
/* if (ishift .eq. 1) then */
/* call dvout (logfil, np, bounds, ndigit, */
/* & '_saup2: corresponding Ritz estimates') */
/* end if */
/* end if */
/* %---------------------------------------------------------% */
/* | Apply the NP0 implicit shifts by QR bulge chasing. | */
/* | Each shift is applied to the entire tridiagonal matrix. | */
/* | The first 2*N locations of WORKD are used as workspace. | */
/* | After dsapps is done, we have a Lanczos | */
/* | factorization of length NEV. | */
/* %---------------------------------------------------------% */
/*< >*/
dsapps_(n, nev, np, &ritz[1], &v[v_offset], ldv, &h__[h_offset], ldh, &
resid[1], &q[q_offset], ldq, &workd[1]);
/* %---------------------------------------------% */
/* | Compute the B-norm of the updated residual. | */
/* | Keep B*RESID in WORKD(1:N) to be used in | */
/* | the first step of the next call to dsaitr. | */
/* %---------------------------------------------% */
/*< cnorm = .true. >*/
cnorm = TRUE_;
/*< call second (t2) >*/
/* second_(&t2); */
/*< if (bmat .eq. 'G') then >*/
if (*(unsigned char *)bmat == 'G') {
/*< nbx = nbx + 1 >*/
/* ++timing_1.nbx; */
/*< call dcopy (n, resid, 1, workd(n+1), 1) >*/
dcopy_(n, &resid[1], &c__1, &workd[*n + 1], &c__1);
/*< ipntr(1) = n + 1 >*/
ipntr[1] = *n + 1;
/*< ipntr(2) = 1 >*/
ipntr[2] = 1;
/*< ido = 2 >*/
*ido = 2;
/* %----------------------------------% */
/* | Exit in order to compute B*RESID | */
/* %----------------------------------% */
/*< go to 9000 >*/
goto L9000;
/*< else if (bmat .eq. 'I') then >*/
} else if (*(unsigned char *)bmat == 'I') {
/*< call dcopy (n, resid, 1, workd, 1) >*/
dcopy_(n, &resid[1], &c__1, &workd[1], &c__1);
/*< end if >*/
}
/*< 100 continue >*/
L100:
/* %----------------------------------% */
/* | Back from reverse communication; | */
/* | WORKD(1:N) := B*RESID | */
/* %----------------------------------% */
/*< if (bmat .eq. 'G') then >*/
if (*(unsigned char *)bmat == 'G') {
/*< call second (t3) >*/
/* second_(&t3); */
/*< tmvbx = tmvbx + (t3 - t2) >*/
/* timing_1.tmvbx += t3 - t2; */
/*< end if >*/
}
/*< if (bmat .eq. 'G') then >*/
if (*(unsigned char *)bmat == 'G') {
/*< rnorm = ddot (n, resid, 1, workd, 1) >*/
rnorm = ddot_(n, &resid[1], &c__1, &workd[1], &c__1);
/*< rnorm = sqrt(abs(rnorm)) >*/
rnorm = sqrt((abs(rnorm)));
/*< else if (bmat .eq. 'I') then >*/
} else if (*(unsigned char *)bmat == 'I') {
/*< rnorm = dnrm2(n, resid, 1) >*/
rnorm = dnrm2_(n, &resid[1], &c__1);
/*< end if >*/
}
/*< cnorm = .false. >*/
cnorm = FALSE_;
/*< 130 continue >*/
/* L130: */
/* if (msglvl .gt. 2) then */
/* call dvout (logfil, 1, rnorm, ndigit, */
/* & '_saup2: B-norm of residual for NEV factorization') */
/* call dvout (logfil, nev, h(1,2), ndigit, */
/* & '_saup2: main diagonal of compressed H matrix') */
/* call dvout (logfil, nev-1, h(2,1), ndigit, */
/* & '_saup2: subdiagonal of compressed H matrix') */
/* end if */
/*< go to 1000 >*/
goto L1000;
/* %---------------------------------------------------------------% */
/* | | */
/* | E N D O F M A I N I T E R A T I O N L O O P | */
/* | | */
/* %---------------------------------------------------------------% */
/*< 1100 continue >*/
L1100:
/*< mxiter = iter >*/
*mxiter = iter;
/*< nev = nconv >*/
*nev = nconv;
/*< 1200 continue >*/
L1200:
/*< ido = 99 >*/
*ido = 99;
/* %------------% */
/* | Error exit | */
/* %------------% */
/*< call second (t1) >*/
/* second_(&t1); */
/*< tsaup2 = t1 - t0 >*/
/* timing_1.tsaup2 = t1 - t0; */
/*< 9000 continue >*/
L9000:
/*< return >*/
return 0;
/* %---------------% */
/* | End of dsaup2 | */
/* %---------------% */
/*< end >*/
} /* dsaup2_ */
void STARPU_DSWAP(const int n, double *X, const int incX, double *Y, const int incY)
{
dswap_(&n, X, &incX, Y, &incY);
}
/* Subroutine */ int dsvdc_(doublereal *x, integer *ldx, integer *n, integer *
p, doublereal *s, doublereal *e, doublereal *u, integer *ldu,
doublereal *v, integer *ldv, doublereal *work, integer *job, integer *
info)
{
/* System generated locals */
integer x_dim1, x_offset, u_dim1, u_offset, v_dim1, v_offset, i__1, i__2,
i__3;
doublereal d__1, d__2, d__3, d__4, d__5, d__6, d__7;
/* Builtin functions */
double d_sign(doublereal *, doublereal *), sqrt(doublereal);
/* Local variables */
static doublereal b, c__, f, g;
static integer i__, j, k, l, m;
static doublereal t, t1, el;
static integer kk;
static doublereal cs;
static integer ll, mm, ls;
static doublereal sl;
static integer lu;
static doublereal sm, sn;
static integer lm1, mm1, lp1, mp1, nct, ncu, lls, nrt;
static doublereal emm1, smm1;
static integer kase;
extern doublereal ddot_(integer *, doublereal *, integer *, doublereal *,
integer *);
static integer jobu, iter;
extern /* Subroutine */ int drot_(integer *, doublereal *, integer *,
doublereal *, integer *, doublereal *, doublereal *);
static doublereal test;
extern doublereal dnrm2_(integer *, doublereal *, integer *);
static integer nctp1, nrtp1;
extern /* Subroutine */ int dscal_(integer *, doublereal *, doublereal *,
integer *);
static doublereal scale, shift;
extern /* Subroutine */ int dswap_(integer *, doublereal *, integer *,
doublereal *, integer *), drotg_(doublereal *, doublereal *,
doublereal *, doublereal *);
static integer maxit;
extern /* Subroutine */ int daxpy_(integer *, doublereal *, doublereal *,
integer *, doublereal *, integer *);
static logical wantu, wantv;
static doublereal ztest;
/* dsvdc is a subroutine to reduce a double precision nxp matrix x */
/* by orthogonal transformations u and v to diagonal form. the */
/* diagonal elements s(i) are the singular values of x. the */
/* columns of u are the corresponding left singular vectors, */
/* and the columns of v the right singular vectors. */
/* on entry */
/* x double precision(ldx,p), where ldx.ge.n. */
/* x contains the matrix whose singular value */
/* decomposition is to be computed. x is */
/* destroyed by dsvdc. */
/* ldx integer. */
/* ldx is the leading dimension of the array x. */
/* n integer. */
/* n is the number of rows of the matrix x. */
/* p integer. */
/* p is the number of columns of the matrix x. */
/* ldu integer. */
/* ldu is the leading dimension of the array u. */
/* (see below). */
/* ldv integer. */
/* ldv is the leading dimension of the array v. */
/* (see below). */
/* work double precision(n). */
/* work is a scratch array. */
/* job integer. */
/* job controls the computation of the singular */
/* vectors. it has the decimal expansion ab */
/* with the following meaning */
/* a.eq.0 do not compute the left singular */
/* vectors. */
/* a.eq.1 return the n left singular vectors */
/* in u. */
/* a.ge.2 return the first min(n,p) singular */
/* vectors in u. */
/* b.eq.0 do not compute the right singular */
/* vectors. */
/* b.eq.1 return the right singular vectors */
/* in v. */
/* on return */
/* s double precision(mm), where mm=min(n+1,p). */
/* the first min(n,p) entries of s contain the */
/* singular values of x arranged in descending */
/* order of magnitude. */
/* e double precision(p), */
/* e ordinarily contains zeros. however see the */
/* discussion of info for exceptions. */
/* u double precision(ldu,k), where ldu.ge.n. if */
/* joba.eq.1 then k.eq.n, if joba.ge.2 */
/* then k.eq.min(n,p). */
/* u contains the matrix of left singular vectors. */
/* u is not referenced if joba.eq.0. if n.le.p */
/* or if joba.eq.2, then u may be identified with x */
/* in the subroutine call. */
/* v double precision(ldv,p), where ldv.ge.p. */
/* v contains the matrix of right singular vectors. */
/* v is not referenced if job.eq.0. if p.le.n, */
/* then v may be identified with x in the */
/* subroutine call. */
/* info integer. */
/* the singular values (and their corresponding */
/* singular vectors) s(info+1),s(info+2),...,s(m) */
/* are correct (here m=min(n,p)). thus if */
/* info.eq.0, all the singular values and their */
/* vectors are correct. in any event, the matrix */
/* b = trans(u)*x*v is the bidiagonal matrix */
/* with the elements of s on its diagonal and the */
/* elements of e on its super-diagonal (trans(u) */
/* is the transpose of u). thus the singular */
/* values of x and b are the same. */
/* linpack. this version dated 08/14/78 . */
/* correction made to shift 2/84. */
/* g.w. stewart, university of maryland, argonne national lab. */
/* dsvdc uses the following functions and subprograms. */
/* external drot */
/* blas daxpy,ddot,dscal,dswap,dnrm2,drotg */
/* fortran dabs,dmax1,max0,min0,mod,dsqrt */
/* internal variables */
/* set the maximum number of iterations. */
/* Parameter adjustments */
x_dim1 = *ldx;
x_offset = 1 + x_dim1;
x -= x_offset;
--s;
--e;
u_dim1 = *ldu;
u_offset = 1 + u_dim1;
u -= u_offset;
v_dim1 = *ldv;
v_offset = 1 + v_dim1;
v -= v_offset;
--work;
/* Function Body */
maxit = 30;
/* determine what is to be computed. */
wantu = FALSE_;
wantv = FALSE_;
jobu = *job % 100 / 10;
ncu = *n;
if (jobu > 1) {
ncu = min(*n,*p);
}
if (jobu != 0) {
wantu = TRUE_;
}
if (*job % 10 != 0) {
wantv = TRUE_;
}
/* reduce x to bidiagonal form, storing the diagonal elements */
/* in s and the super-diagonal elements in e. */
*info = 0;
/* Computing MIN */
i__1 = *n - 1;
nct = min(i__1,*p);
/* Computing MAX */
/* Computing MIN */
i__3 = *p - 2;
i__1 = 0, i__2 = min(i__3,*n);
nrt = max(i__1,i__2);
lu = max(nct,nrt);
if (lu < 1) {
goto L170;
}
i__1 = lu;
for (l = 1; l <= i__1; ++l) {
lp1 = l + 1;
if (l > nct) {
goto L20;
}
/* compute the transformation for the l-th column and */
/* place the l-th diagonal in s(l). */
i__2 = *n - l + 1;
s[l] = dnrm2_(&i__2, &x[l + l * x_dim1], &c__1);
if (s[l] == 0.) {
goto L10;
}
if (x[l + l * x_dim1] != 0.) {
s[l] = d_sign(&s[l], &x[l + l * x_dim1]);
}
i__2 = *n - l + 1;
d__1 = 1. / s[l];
dscal_(&i__2, &d__1, &x[l + l * x_dim1], &c__1);
x[l + l * x_dim1] += 1.;
L10:
s[l] = -s[l];
L20:
if (*p < lp1) {
goto L50;
}
i__2 = *p;
for (j = lp1; j <= i__2; ++j) {
if (l > nct) {
goto L30;
}
if (s[l] == 0.) {
goto L30;
}
/* apply the transformation. */
i__3 = *n - l + 1;
t = -ddot_(&i__3, &x[l + l * x_dim1], &c__1, &x[l + j * x_dim1], &
c__1) / x[l + l * x_dim1];
i__3 = *n - l + 1;
daxpy_(&i__3, &t, &x[l + l * x_dim1], &c__1, &x[l + j * x_dim1], &
c__1);
L30:
/* place the l-th row of x into e for the */
/* subsequent calculation of the row transformation. */
e[j] = x[l + j * x_dim1];
/* L40: */
}
L50:
if (! wantu || l > nct) {
goto L70;
}
/* place the transformation in u for subsequent back */
/* multiplication. */
i__2 = *n;
for (i__ = l; i__ <= i__2; ++i__) {
u[i__ + l * u_dim1] = x[i__ + l * x_dim1];
/* L60: */
}
L70:
if (l > nrt) {
goto L150;
}
/* compute the l-th row transformation and place the */
/* l-th super-diagonal in e(l). */
i__2 = *p - l;
e[l] = dnrm2_(&i__2, &e[lp1], &c__1);
if (e[l] == 0.) {
goto L80;
}
if (e[lp1] != 0.) {
e[l] = d_sign(&e[l], &e[lp1]);
}
i__2 = *p - l;
d__1 = 1. / e[l];
dscal_(&i__2, &d__1, &e[lp1], &c__1);
e[lp1] += 1.;
L80:
e[l] = -e[l];
if (lp1 > *n || e[l] == 0.) {
goto L120;
}
/* apply the transformation. */
i__2 = *n;
for (i__ = lp1; i__ <= i__2; ++i__) {
work[i__] = 0.;
/* L90: */
}
i__2 = *p;
for (j = lp1; j <= i__2; ++j) {
i__3 = *n - l;
daxpy_(&i__3, &e[j], &x[lp1 + j * x_dim1], &c__1, &work[lp1], &
c__1);
/* L100: */
}
i__2 = *p;
for (j = lp1; j <= i__2; ++j) {
i__3 = *n - l;
d__1 = -e[j] / e[lp1];
daxpy_(&i__3, &d__1, &work[lp1], &c__1, &x[lp1 + j * x_dim1], &
c__1);
/* L110: */
}
L120:
if (! wantv) {
goto L140;
}
/* place the transformation in v for subsequent */
/* back multiplication. */
i__2 = *p;
for (i__ = lp1; i__ <= i__2; ++i__) {
v[i__ + l * v_dim1] = e[i__];
/* L130: */
}
L140:
L150:
/* L160: */
;
}
L170:
/* set up the final bidiagonal matrix or order m. */
/* Computing MIN */
i__1 = *p, i__2 = *n + 1;
m = min(i__1,i__2);
nctp1 = nct + 1;
nrtp1 = nrt + 1;
if (nct < *p) {
s[nctp1] = x[nctp1 + nctp1 * x_dim1];
}
if (*n < m) {
s[m] = 0.;
}
if (nrtp1 < m) {
e[nrtp1] = x[nrtp1 + m * x_dim1];
}
e[m] = 0.;
/* if required, generate u. */
if (! wantu) {
goto L300;
}
if (ncu < nctp1) {
goto L200;
}
i__1 = ncu;
for (j = nctp1; j <= i__1; ++j) {
i__2 = *n;
for (i__ = 1; i__ <= i__2; ++i__) {
u[i__ + j * u_dim1] = 0.;
/* L180: */
}
u[j + j * u_dim1] = 1.;
/* L190: */
}
L200:
if (nct < 1) {
goto L290;
}
i__1 = nct;
for (ll = 1; ll <= i__1; ++ll) {
l = nct - ll + 1;
if (s[l] == 0.) {
goto L250;
}
lp1 = l + 1;
if (ncu < lp1) {
goto L220;
}
i__2 = ncu;
for (j = lp1; j <= i__2; ++j) {
i__3 = *n - l + 1;
t = -ddot_(&i__3, &u[l + l * u_dim1], &c__1, &u[l + j * u_dim1], &
c__1) / u[l + l * u_dim1];
i__3 = *n - l + 1;
daxpy_(&i__3, &t, &u[l + l * u_dim1], &c__1, &u[l + j * u_dim1], &
c__1);
/* L210: */
}
L220:
i__2 = *n - l + 1;
dscal_(&i__2, &c_b44, &u[l + l * u_dim1], &c__1);
u[l + l * u_dim1] += 1.;
lm1 = l - 1;
if (lm1 < 1) {
goto L240;
}
i__2 = lm1;
for (i__ = 1; i__ <= i__2; ++i__) {
u[i__ + l * u_dim1] = 0.;
/* L230: */
}
L240:
goto L270;
L250:
i__2 = *n;
for (i__ = 1; i__ <= i__2; ++i__) {
u[i__ + l * u_dim1] = 0.;
/* L260: */
}
u[l + l * u_dim1] = 1.;
L270:
/* L280: */
;
}
L290:
L300:
/* if it is required, generate v. */
if (! wantv) {
goto L350;
}
i__1 = *p;
for (ll = 1; ll <= i__1; ++ll) {
l = *p - ll + 1;
lp1 = l + 1;
if (l > nrt) {
goto L320;
}
if (e[l] == 0.) {
goto L320;
}
i__2 = *p;
for (j = lp1; j <= i__2; ++j) {
i__3 = *p - l;
t = -ddot_(&i__3, &v[lp1 + l * v_dim1], &c__1, &v[lp1 + j *
v_dim1], &c__1) / v[lp1 + l * v_dim1];
i__3 = *p - l;
daxpy_(&i__3, &t, &v[lp1 + l * v_dim1], &c__1, &v[lp1 + j *
v_dim1], &c__1);
/* L310: */
}
L320:
i__2 = *p;
for (i__ = 1; i__ <= i__2; ++i__) {
v[i__ + l * v_dim1] = 0.;
/* L330: */
}
v[l + l * v_dim1] = 1.;
/* L340: */
}
L350:
/* main iteration loop for the singular values. */
mm = m;
iter = 0;
L360:
/* quit if all the singular values have been found. */
/* ...exit */
if (m == 0) {
goto L620;
}
/* if too many iterations have been performed, set */
/* flag and return. */
if (iter < maxit) {
goto L370;
}
*info = m;
/* ......exit */
goto L620;
L370:
/* this section of the program inspects for */
/* negligible elements in the s and e arrays. on */
/* completion the variables kase and l are set as follows. */
/* kase = 1 if s(m) and e(l-1) are negligible and l.lt.m */
/* kase = 2 if s(l) is negligible and l.lt.m */
/* kase = 3 if e(l-1) is negligible, l.lt.m, and */
/* s(l), ..., s(m) are not negligible (qr step). */
/* kase = 4 if e(m-1) is negligible (convergence). */
i__1 = m;
for (ll = 1; ll <= i__1; ++ll) {
l = m - ll;
/* ...exit */
if (l == 0) {
goto L400;
}
test = (d__1 = s[l], abs(d__1)) + (d__2 = s[l + 1], abs(d__2));
ztest = test + (d__1 = e[l], abs(d__1));
if (ztest != test) {
goto L380;
}
e[l] = 0.;
/* ......exit */
goto L400;
L380:
/* L390: */
;
}
L400:
if (l != m - 1) {
goto L410;
}
kase = 4;
goto L480;
L410:
lp1 = l + 1;
mp1 = m + 1;
i__1 = mp1;
for (lls = lp1; lls <= i__1; ++lls) {
ls = m - lls + lp1;
/* ...exit */
if (ls == l) {
goto L440;
}
test = 0.;
if (ls != m) {
test += (d__1 = e[ls], abs(d__1));
}
if (ls != l + 1) {
test += (d__1 = e[ls - 1], abs(d__1));
}
ztest = test + (d__1 = s[ls], abs(d__1));
if (ztest != test) {
goto L420;
}
s[ls] = 0.;
/* ......exit */
goto L440;
L420:
/* L430: */
;
}
L440:
if (ls != l) {
goto L450;
}
kase = 3;
goto L470;
L450:
if (ls != m) {
goto L460;
}
kase = 1;
goto L470;
L460:
kase = 2;
l = ls;
L470:
L480:
++l;
/* perform the task indicated by kase. */
switch (kase) {
case 1: goto L490;
case 2: goto L520;
case 3: goto L540;
case 4: goto L570;
}
/* deflate negligible s(m). */
L490:
mm1 = m - 1;
f = e[m - 1];
e[m - 1] = 0.;
i__1 = mm1;
for (kk = l; kk <= i__1; ++kk) {
k = mm1 - kk + l;
t1 = s[k];
drotg_(&t1, &f, &cs, &sn);
s[k] = t1;
if (k == l) {
goto L500;
}
f = -sn * e[k - 1];
e[k - 1] = cs * e[k - 1];
L500:
if (wantv) {
drot_(p, &v[k * v_dim1 + 1], &c__1, &v[m * v_dim1 + 1], &c__1, &
cs, &sn);
}
/* L510: */
}
goto L610;
/* split at negligible s(l). */
L520:
f = e[l - 1];
e[l - 1] = 0.;
i__1 = m;
for (k = l; k <= i__1; ++k) {
t1 = s[k];
drotg_(&t1, &f, &cs, &sn);
s[k] = t1;
f = -sn * e[k];
e[k] = cs * e[k];
if (wantu) {
drot_(n, &u[k * u_dim1 + 1], &c__1, &u[(l - 1) * u_dim1 + 1], &
c__1, &cs, &sn);
}
/* L530: */
}
goto L610;
/* perform one qr step. */
L540:
/* calculate the shift. */
/* Computing MAX */
d__6 = (d__1 = s[m], abs(d__1)), d__7 = (d__2 = s[m - 1], abs(d__2)),
d__6 = max(d__6,d__7), d__7 = (d__3 = e[m - 1], abs(d__3)), d__6 =
max(d__6,d__7), d__7 = (d__4 = s[l], abs(d__4)), d__6 = max(d__6,
d__7), d__7 = (d__5 = e[l], abs(d__5));
scale = max(d__6,d__7);
sm = s[m] / scale;
smm1 = s[m - 1] / scale;
emm1 = e[m - 1] / scale;
sl = s[l] / scale;
el = e[l] / scale;
/* Computing 2nd power */
d__1 = emm1;
b = ((smm1 + sm) * (smm1 - sm) + d__1 * d__1) / 2.;
/* Computing 2nd power */
d__1 = sm * emm1;
c__ = d__1 * d__1;
shift = 0.;
if (b == 0. && c__ == 0.) {
goto L550;
}
/* Computing 2nd power */
d__1 = b;
shift = sqrt(d__1 * d__1 + c__);
if (b < 0.) {
shift = -shift;
}
shift = c__ / (b + shift);
L550:
f = (sl + sm) * (sl - sm) + shift;
g = sl * el;
/* chase zeros. */
mm1 = m - 1;
i__1 = mm1;
for (k = l; k <= i__1; ++k) {
drotg_(&f, &g, &cs, &sn);
if (k != l) {
e[k - 1] = f;
}
f = cs * s[k] + sn * e[k];
e[k] = cs * e[k] - sn * s[k];
g = sn * s[k + 1];
s[k + 1] = cs * s[k + 1];
if (wantv) {
drot_(p, &v[k * v_dim1 + 1], &c__1, &v[(k + 1) * v_dim1 + 1], &
c__1, &cs, &sn);
}
drotg_(&f, &g, &cs, &sn);
s[k] = f;
f = cs * e[k] + sn * s[k + 1];
s[k + 1] = -sn * e[k] + cs * s[k + 1];
g = sn * e[k + 1];
e[k + 1] = cs * e[k + 1];
if (wantu && k < *n) {
drot_(n, &u[k * u_dim1 + 1], &c__1, &u[(k + 1) * u_dim1 + 1], &
c__1, &cs, &sn);
}
/* L560: */
}
e[m - 1] = f;
++iter;
goto L610;
/* convergence. */
L570:
/* make the singular value positive. */
if (s[l] >= 0.) {
goto L580;
}
s[l] = -s[l];
if (wantv) {
dscal_(p, &c_b44, &v[l * v_dim1 + 1], &c__1);
}
L580:
/* order the singular value. */
L590:
if (l == mm) {
goto L600;
}
/* ...exit */
if (s[l] >= s[l + 1]) {
goto L600;
}
t = s[l];
s[l] = s[l + 1];
s[l + 1] = t;
if (wantv && l < *p) {
dswap_(p, &v[l * v_dim1 + 1], &c__1, &v[(l + 1) * v_dim1 + 1], &c__1);
}
if (wantu && l < *n) {
dswap_(n, &u[l * u_dim1 + 1], &c__1, &u[(l + 1) * u_dim1 + 1], &c__1);
}
++l;
goto L590;
L600:
iter = 0;
--m;
L610:
goto L360;
L620:
return 0;
} /* dsvdc_ */
/* Subroutine */ int dsbgvx_(char *jobz, char *range, char *uplo, integer *n,
integer *ka, integer *kb, doublereal *ab, integer *ldab, doublereal *
bb, integer *ldbb, doublereal *q, integer *ldq, doublereal *vl,
doublereal *vu, integer *il, integer *iu, doublereal *abstol, integer
*m, doublereal *w, doublereal *z__, integer *ldz, doublereal *work,
integer *iwork, integer *ifail, integer *info)
{
/* System generated locals */
integer ab_dim1, ab_offset, bb_dim1, bb_offset, q_dim1, q_offset, z_dim1,
z_offset, i__1, i__2;
/* Local variables */
integer i__, j, jj;
doublereal tmp1;
integer indd, inde;
char vect[1];
logical test;
integer itmp1, indee;
extern logical lsame_(char *, char *);
extern /* Subroutine */ int dgemv_(char *, integer *, integer *,
doublereal *, doublereal *, integer *, doublereal *, integer *,
doublereal *, doublereal *, integer *);
integer iinfo;
char order[1];
extern /* Subroutine */ int dcopy_(integer *, doublereal *, integer *,
doublereal *, integer *), dswap_(integer *, doublereal *, integer
*, doublereal *, integer *);
logical upper, wantz, alleig, indeig;
integer indibl;
logical valeig;
extern /* Subroutine */ int dlacpy_(char *, integer *, integer *,
doublereal *, integer *, doublereal *, integer *),
xerbla_(char *, integer *), dpbstf_(char *, integer *,
integer *, doublereal *, integer *, integer *), dsbtrd_(
char *, char *, integer *, integer *, doublereal *, integer *,
doublereal *, doublereal *, doublereal *, integer *, doublereal *,
integer *);
integer indisp;
extern /* Subroutine */ int dsbgst_(char *, char *, integer *, integer *,
integer *, doublereal *, integer *, doublereal *, integer *,
doublereal *, integer *, doublereal *, integer *),
dstein_(integer *, doublereal *, doublereal *, integer *,
doublereal *, integer *, integer *, doublereal *, integer *,
doublereal *, integer *, integer *, integer *);
integer indiwo;
extern /* Subroutine */ int dsterf_(integer *, doublereal *, doublereal *,
integer *), dstebz_(char *, char *, integer *, doublereal *,
doublereal *, integer *, integer *, doublereal *, doublereal *,
doublereal *, integer *, integer *, doublereal *, integer *,
integer *, doublereal *, integer *, integer *);
integer indwrk;
extern /* Subroutine */ int dsteqr_(char *, integer *, doublereal *,
doublereal *, doublereal *, integer *, doublereal *, integer *);
integer nsplit;
/* -- LAPACK driver routine (version 3.1) -- */
/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/* November 2006 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* DSBGVX computes selected eigenvalues, and optionally, eigenvectors */
/* of a real 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. Eigenvalues and */
/* eigenvectors can be selected by specifying either all eigenvalues, */
/* 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 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) DOUBLE PRECISION 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) DOUBLE PRECISION 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 DPBSTF. */
/* LDBB (input) INTEGER */
/* The leading dimension of the array BB. LDBB >= KB+1. */
/* Q (output) DOUBLE PRECISION array, dimension (LDQ, N) */
/* If JOBZ = 'V', the n-by-n matrix used in the reduction of */
/* A*x = (lambda)*B*x to standard form, i.e. C*x = (lambda)*x, */
/* and consequently C to tridiagonal form. */
/* If JOBZ = 'N', the array Q is not referenced. */
/* LDQ (input) INTEGER */
/* The leading dimension of the array Q. If JOBZ = 'N', */
/* LDQ >= 1. If JOBZ = 'V', LDQ >= max(1,N). */
/* VL (input) DOUBLE PRECISION */
/* VU (input) DOUBLE PRECISION */
/* 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) DOUBLE PRECISION */
/* 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 A to tridiagonal form. */
/* Eigenvalues will be computed most accurately when ABSTOL is */
/* set to twice the underflow threshold 2*DLAMCH('S'), not zero. */
/* If this routine returns with INFO>0, indicating that some */
/* eigenvectors did not converge, try setting ABSTOL to */
/* 2*DLAMCH('S'). */
/* 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) DOUBLE PRECISION array, dimension (N) */
/* If INFO = 0, the eigenvalues in ascending order. */
/* Z (output) DOUBLE PRECISION 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) DOUBLE PRECISION array, dimension (7*N) */
/* IWORK (workspace/output) INTEGER array, dimension (5*N) */
/* IFAIL (output) INTEGER array, dimension (M) */
/* 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 eigenvalues 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 */
/* <= N: if INFO = i, then i eigenvectors failed to converge. */
/* Their indices are stored in IFAIL. */
/* > N : DPBSTF returned an error code; i.e., */
/* if INFO = N + i, for 1 <= i <= N, then the leading */
/* minor of order i of 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 .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. 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;
q_dim1 = *ldq;
q_offset = 1 + q_dim1;
q -= q_offset;
--w;
z_dim1 = *ldz;
z_offset = 1 + z_dim1;
z__ -= z_offset;
--work;
--iwork;
--ifail;
/* Function Body */
wantz = lsame_(jobz, "V");
upper = lsame_(uplo, "U");
alleig = lsame_(range, "A");
valeig = lsame_(range, "V");
indeig = lsame_(range, "I");
*info = 0;
if (! (wantz || lsame_(jobz, "N"))) {
*info = -1;
} else if (! (alleig || valeig || indeig)) {
*info = -2;
} else if (! (upper || lsame_(uplo, "L"))) {
*info = -3;
} else if (*n < 0) {
*info = -4;
} else if (*ka < 0) {
*info = -5;
} else if (*kb < 0 || *kb > *ka) {
*info = -6;
} else if (*ldab < *ka + 1) {
*info = -8;
} else if (*ldbb < *kb + 1) {
*info = -10;
} else if (*ldq < 1 || wantz && *ldq < *n) {
*info = -12;
} else {
if (valeig) {
if (*n > 0 && *vu <= *vl) {
*info = -14;
}
} else if (indeig) {
if (*il < 1 || *il > max(1,*n)) {
*info = -15;
} else if (*iu < min(*n,*il) || *iu > *n) {
*info = -16;
}
}
}
if (*info == 0) {
if (*ldz < 1 || wantz && *ldz < *n) {
*info = -21;
}
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("DSBGVX", &i__1);
return 0;
}
/* Quick return if possible */
*m = 0;
if (*n == 0) {
return 0;
}
/* Form a split Cholesky factorization of B. */
dpbstf_(uplo, n, kb, &bb[bb_offset], ldbb, info);
if (*info != 0) {
*info = *n + *info;
return 0;
}
/* Transform problem to standard eigenvalue problem. */
dsbgst_(jobz, uplo, n, ka, kb, &ab[ab_offset], ldab, &bb[bb_offset], ldbb,
&q[q_offset], ldq, &work[1], &iinfo);
/* Reduce symmetric band matrix to tridiagonal form. */
indd = 1;
inde = indd + *n;
indwrk = inde + *n;
if (wantz) {
*(unsigned char *)vect = 'U';
} else {
*(unsigned char *)vect = 'N';
}
dsbtrd_(vect, uplo, n, ka, &ab[ab_offset], ldab, &work[indd], &work[inde],
&q[q_offset], ldq, &work[indwrk], &iinfo);
/* If all eigenvalues are desired and ABSTOL is less than or equal */
/* to zero, then call DSTERF or SSTEQR. If this fails for some */
/* eigenvalue, then try DSTEBZ. */
test = FALSE_;
if (indeig) {
if (*il == 1 && *iu == *n) {
test = TRUE_;
}
}
if ((alleig || test) && *abstol <= 0.) {
dcopy_(n, &work[indd], &c__1, &w[1], &c__1);
indee = indwrk + (*n << 1);
i__1 = *n - 1;
dcopy_(&i__1, &work[inde], &c__1, &work[indee], &c__1);
if (! wantz) {
dsterf_(n, &w[1], &work[indee], info);
} else {
dlacpy_("A", n, n, &q[q_offset], ldq, &z__[z_offset], ldz);
dsteqr_(jobz, n, &w[1], &work[indee], &z__[z_offset], ldz, &work[
indwrk], info);
if (*info == 0) {
i__1 = *n;
for (i__ = 1; i__ <= i__1; ++i__) {
ifail[i__] = 0;
/* L10: */
}
}
}
if (*info == 0) {
*m = *n;
goto L30;
}
*info = 0;
}
/* Otherwise, call DSTEBZ and, if eigenvectors are desired, */
/* call DSTEIN. */
if (wantz) {
*(unsigned char *)order = 'B';
} else {
*(unsigned char *)order = 'E';
}
indibl = 1;
indisp = indibl + *n;
indiwo = indisp + *n;
dstebz_(range, order, n, vl, vu, il, iu, abstol, &work[indd], &work[inde],
m, &nsplit, &w[1], &iwork[indibl], &iwork[indisp], &work[indwrk],
&iwork[indiwo], info);
if (wantz) {
dstein_(n, &work[indd], &work[inde], m, &w[1], &iwork[indibl], &iwork[
indisp], &z__[z_offset], ldz, &work[indwrk], &iwork[indiwo], &
ifail[1], info);
/* Apply transformation matrix used in reduction to tridiagonal */
/* form to eigenvectors returned by DSTEIN. */
i__1 = *m;
for (j = 1; j <= i__1; ++j) {
dcopy_(n, &z__[j * z_dim1 + 1], &c__1, &work[1], &c__1);
dgemv_("N", n, n, &c_b25, &q[q_offset], ldq, &work[1], &c__1, &
c_b27, &z__[j * z_dim1 + 1], &c__1);
/* L20: */
}
}
L30:
/* If eigenvalues are not in order, then sort them, along with */
/* eigenvectors. */
if (wantz) {
i__1 = *m - 1;
for (j = 1; j <= i__1; ++j) {
i__ = 0;
tmp1 = w[j];
i__2 = *m;
for (jj = j + 1; jj <= i__2; ++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;
dswap_(n, &z__[i__ * z_dim1 + 1], &c__1, &z__[j * z_dim1 + 1],
&c__1);
if (*info != 0) {
itmp1 = ifail[i__];
ifail[i__] = ifail[j];
ifail[j] = itmp1;
}
}
/* L50: */
}
}
return 0;
/* End of DSBGVX */
} /* dsbgvx_ */
/* Subroutine */ int dbdsdc_(char *uplo, char *compq, integer *n, doublereal *
d__, doublereal *e, doublereal *u, integer *ldu, doublereal *vt,
integer *ldvt, doublereal *q, integer *iq, doublereal *work, integer *
iwork, integer *info)
{
/* System generated locals */
integer u_dim1, u_offset, vt_dim1, vt_offset, i__1, i__2;
doublereal d__1;
/* Builtin functions */
double d_sign(doublereal *, doublereal *), log(doublereal);
/* Local variables */
static integer difl, difr, ierr, perm, mlvl, sqre, i__, j, k;
static doublereal p, r__;
static integer z__;
extern logical lsame_(char *, char *);
extern /* Subroutine */ int dlasr_(char *, char *, char *, integer *,
integer *, doublereal *, doublereal *, doublereal *, integer *), dcopy_(integer *, doublereal *, integer *
, doublereal *, integer *), dswap_(integer *, doublereal *,
integer *, doublereal *, integer *);
static integer poles, iuplo, nsize, start;
extern /* Subroutine */ int dlasd0_(integer *, integer *, doublereal *,
doublereal *, doublereal *, integer *, doublereal *, integer *,
integer *, integer *, doublereal *, integer *);
static integer ic, ii, kk;
static doublereal cs;
extern doublereal dlamch_(char *);
extern /* Subroutine */ int dlasda_(integer *, integer *, integer *,
integer *, doublereal *, doublereal *, doublereal *, integer *,
doublereal *, integer *, doublereal *, doublereal *, doublereal *,
doublereal *, integer *, integer *, integer *, integer *,
doublereal *, doublereal *, doublereal *, doublereal *, integer *,
integer *);
static integer is, iu;
static doublereal sn;
extern /* Subroutine */ int dlascl_(char *, integer *, integer *,
doublereal *, doublereal *, integer *, integer *, doublereal *,
integer *, integer *), dlasdq_(char *, integer *, integer
*, integer *, integer *, integer *, doublereal *, doublereal *,
doublereal *, integer *, doublereal *, integer *, doublereal *,
integer *, doublereal *, integer *), dlaset_(char *,
integer *, integer *, doublereal *, doublereal *, doublereal *,
integer *), dlartg_(doublereal *, doublereal *,
doublereal *, doublereal *, doublereal *);
extern integer ilaenv_(integer *, char *, char *, integer *, integer *,
integer *, integer *, ftnlen, ftnlen);
extern /* Subroutine */ int xerbla_(char *, integer *);
static integer givcol;
extern doublereal dlanst_(char *, integer *, doublereal *, doublereal *);
static integer icompq;
static doublereal orgnrm;
static integer givnum, givptr, nm1, qstart, smlsiz, wstart, smlszp;
static doublereal eps;
static integer ivt;
#define u_ref(a_1,a_2) u[(a_2)*u_dim1 + a_1]
#define vt_ref(a_1,a_2) vt[(a_2)*vt_dim1 + a_1]
/* -- LAPACK routine (instrumented to count ops, version 3.0) --
Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
Courant Institute, Argonne National Lab, and Rice University
October 31, 1999
Purpose
=======
DBDSDC computes the singular value decomposition (SVD) of a real
N-by-N (upper or lower) bidiagonal matrix B: B = U * S * VT,
using a divide and conquer method, where S is a diagonal matrix
with non-negative diagonal elements (the singular values of B), and
U and VT are orthogonal matrices of left and right singular vectors,
respectively. DBDSDC can be used to compute all singular values,
and optionally, singular vectors or singular vectors in compact form.
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 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. See DLASD3 for details.
The code currently call DLASDQ if singular values only are desired.
However, it can be slightly modified to compute singular values
using the divide and conquer method.
Arguments
=========
UPLO (input) CHARACTER*1
= 'U': B is upper bidiagonal.
= 'L': B is lower bidiagonal.
COMPQ (input) CHARACTER*1
Specifies whether singular vectors are to be computed
as follows:
= 'N': Compute singular values only;
= 'P': Compute singular values and compute singular
vectors in compact form;
= 'I': Compute singular values and singular vectors.
N (input) INTEGER
The order of the matrix B. N >= 0.
D (input/output) DOUBLE PRECISION array, dimension (N)
On entry, the n diagonal elements of the bidiagonal matrix B.
On exit, if INFO=0, the singular values of B.
E (input/output) DOUBLE PRECISION array, dimension (N)
On entry, the elements of E contain the offdiagonal
elements of the bidiagonal matrix whose SVD is desired.
On exit, E has been destroyed.
U (output) DOUBLE PRECISION array, dimension (LDU,N)
If COMPQ = 'I', then:
On exit, if INFO = 0, U contains the left singular vectors
of the bidiagonal matrix.
For other values of COMPQ, U is not referenced.
LDU (input) INTEGER
The leading dimension of the array U. LDU >= 1.
If singular vectors are desired, then LDU >= max( 1, N ).
VT (output) DOUBLE PRECISION array, dimension (LDVT,N)
If COMPQ = 'I', then:
On exit, if INFO = 0, VT' contains the right singular
vectors of the bidiagonal matrix.
For other values of COMPQ, VT is not referenced.
LDVT (input) INTEGER
The leading dimension of the array VT. LDVT >= 1.
If singular vectors are desired, then LDVT >= max( 1, N ).
Q (output) DOUBLE PRECISION array, dimension (LDQ)
If COMPQ = 'P', then:
On exit, if INFO = 0, Q and IQ contain the left
and right singular vectors in a compact form,
requiring O(N log N) space instead of 2*N**2.
In particular, Q contains all the DOUBLE PRECISION data in
LDQ >= N*(11 + 2*SMLSIZ + 8*INT(LOG_2(N/(SMLSIZ+1))))
words of memory, where 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).
For other values of COMPQ, Q is not referenced.
IQ (output) INTEGER array, dimension (LDIQ)
If COMPQ = 'P', then:
On exit, if INFO = 0, Q and IQ contain the left
and right singular vectors in a compact form,
requiring O(N log N) space instead of 2*N**2.
In particular, IQ contains all INTEGER data in
LDIQ >= N*(3 + 3*INT(LOG_2(N/(SMLSIZ+1))))
words of memory, where 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).
For other values of COMPQ, IQ is not referenced.
WORK (workspace) DOUBLE PRECISION array, dimension (LWORK)
If COMPQ = 'N' then LWORK >= (4 * N).
If COMPQ = 'P' then LWORK >= (6 * N).
If COMPQ = 'I' then LWORK >= (3 * N**2 + 4 * N).
IWORK (workspace) INTEGER array, dimension (7*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.
The update process of divide and conquer failed.
Further Details
===============
Based on contributions by
Ming Gu and Huan Ren, Computer Science Division, University of
California at Berkeley, USA
=====================================================================
Test the input parameters.
Parameter adjustments */
--d__;
--e;
u_dim1 = *ldu;
u_offset = 1 + u_dim1 * 1;
u -= u_offset;
vt_dim1 = *ldvt;
vt_offset = 1 + vt_dim1 * 1;
vt -= vt_offset;
--q;
--iq;
--work;
--iwork;
/* Function Body */
*info = 0;
iuplo = 0;
if (lsame_(uplo, "U")) {
iuplo = 1;
}
if (lsame_(uplo, "L")) {
iuplo = 2;
}
if (lsame_(compq, "N")) {
icompq = 0;
} else if (lsame_(compq, "P")) {
icompq = 1;
} else if (lsame_(compq, "I")) {
icompq = 2;
} else {
icompq = -1;
}
if (iuplo == 0) {
*info = -1;
} else if (icompq < 0) {
*info = -2;
} else if (*n < 0) {
*info = -3;
} else if (*ldu < 1 || icompq == 2 && *ldu < *n) {
*info = -7;
} else if (*ldvt < 1 || icompq == 2 && *ldvt < *n) {
*info = -9;
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("DBDSDC", &i__1);
return 0;
}
/* Quick return if possible */
if (*n == 0) {
return 0;
}
smlsiz = ilaenv_(&c__9, "DBDSDC", " ", &c__0, &c__0, &c__0, &c__0, (
ftnlen)6, (ftnlen)1);
if (*n == 1) {
if (icompq == 1) {
q[1] = d_sign(&c_b15, &d__[1]);
q[smlsiz * *n + 1] = 1.;
} else if (icompq == 2) {
u_ref(1, 1) = d_sign(&c_b15, &d__[1]);
vt_ref(1, 1) = 1.;
}
d__[1] = abs(d__[1]);
return 0;
}
nm1 = *n - 1;
/* If matrix lower bidiagonal, rotate to be upper bidiagonal
by applying Givens rotations on the left */
wstart = 1;
qstart = 3;
if (icompq == 1) {
dcopy_(n, &d__[1], &c__1, &q[1], &c__1);
i__1 = *n - 1;
dcopy_(&i__1, &e[1], &c__1, &q[*n + 1], &c__1);
}
if (iuplo == 2) {
qstart = 5;
wstart = (*n << 1) - 1;
latime_1.ops += (doublereal) (*n - 1 << 3);
i__1 = *n - 1;
for (i__ = 1; i__ <= i__1; ++i__) {
dlartg_(&d__[i__], &e[i__], &cs, &sn, &r__);
d__[i__] = r__;
e[i__] = sn * d__[i__ + 1];
d__[i__ + 1] = cs * d__[i__ + 1];
if (icompq == 1) {
q[i__ + (*n << 1)] = cs;
q[i__ + *n * 3] = sn;
} else if (icompq == 2) {
work[i__] = cs;
work[nm1 + i__] = -sn;
}
/* L10: */
}
}
/* If ICOMPQ = 0, use DLASDQ to compute the singular values. */
if (icompq == 0) {
dlasdq_("U", &c__0, n, &c__0, &c__0, &c__0, &d__[1], &e[1], &vt[
vt_offset], ldvt, &u[u_offset], ldu, &u[u_offset], ldu, &work[
wstart], info);
goto L40;
}
/* If N is smaller than the minimum divide size SMLSIZ, then solve
the problem with another solver. */
if (*n <= smlsiz) {
if (icompq == 2) {
dlaset_("A", n, n, &c_b29, &c_b15, &u[u_offset], ldu);
dlaset_("A", n, n, &c_b29, &c_b15, &vt[vt_offset], ldvt);
dlasdq_("U", &c__0, n, n, n, &c__0, &d__[1], &e[1], &vt[vt_offset]
, ldvt, &u[u_offset], ldu, &u[u_offset], ldu, &work[
wstart], info);
} else if (icompq == 1) {
iu = 1;
ivt = iu + *n;
dlaset_("A", n, n, &c_b29, &c_b15, &q[iu + (qstart - 1) * *n], n);
dlaset_("A", n, n, &c_b29, &c_b15, &q[ivt + (qstart - 1) * *n], n);
dlasdq_("U", &c__0, n, n, n, &c__0, &d__[1], &e[1], &q[ivt + (
qstart - 1) * *n], n, &q[iu + (qstart - 1) * *n], n, &q[
iu + (qstart - 1) * *n], n, &work[wstart], info);
}
goto L40;
}
if (icompq == 2) {
dlaset_("A", n, n, &c_b29, &c_b15, &u[u_offset], ldu);
dlaset_("A", n, n, &c_b29, &c_b15, &vt[vt_offset], ldvt);
}
/* Scale. */
orgnrm = dlanst_("M", n, &d__[1], &e[1]);
if (orgnrm == 0.) {
return 0;
}
latime_1.ops += (doublereal) (*n + nm1);
dlascl_("G", &c__0, &c__0, &orgnrm, &c_b15, n, &c__1, &d__[1], n, &ierr);
dlascl_("G", &c__0, &c__0, &orgnrm, &c_b15, &nm1, &c__1, &e[1], &nm1, &
ierr);
eps = dlamch_("Epsilon");
mlvl = (integer) (log((doublereal) (*n) / (doublereal) (smlsiz + 1)) /
log(2.)) + 1;
smlszp = smlsiz + 1;
if (icompq == 1) {
iu = 1;
ivt = smlsiz + 1;
difl = ivt + smlszp;
difr = difl + mlvl;
z__ = difr + (mlvl << 1);
ic = z__ + mlvl;
is = ic + 1;
poles = is + 1;
givnum = poles + (mlvl << 1);
k = 1;
givptr = 2;
perm = 3;
givcol = perm + mlvl;
}
i__1 = *n;
for (i__ = 1; i__ <= i__1; ++i__) {
if ((d__1 = d__[i__], abs(d__1)) < eps) {
d__[i__] = d_sign(&eps, &d__[i__]);
}
/* L20: */
}
start = 1;
sqre = 0;
i__1 = nm1;
for (i__ = 1; i__ <= i__1; ++i__) {
if ((d__1 = e[i__], abs(d__1)) < eps || i__ == nm1) {
/* 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__ - start + 1;
} else if ((d__1 = e[i__], abs(d__1)) >= eps) {
/* A subproblem with E(NM1) not too small but I = NM1. */
nsize = *n - start + 1;
} else {
/* A subproblem with E(NM1) small. This implies an
1-by-1 subproblem at D(N). Solve this 1-by-1 problem
first. */
nsize = i__ - start + 1;
if (icompq == 2) {
u_ref(*n, *n) = d_sign(&c_b15, &d__[*n]);
vt_ref(*n, *n) = 1.;
} else if (icompq == 1) {
q[*n + (qstart - 1) * *n] = d_sign(&c_b15, &d__[*n]);
q[*n + (smlsiz + qstart - 1) * *n] = 1.;
}
d__[*n] = (d__1 = d__[*n], abs(d__1));
}
if (icompq == 2) {
dlasd0_(&nsize, &sqre, &d__[start], &e[start], &u_ref(start,
start), ldu, &vt_ref(start, start), ldvt, &smlsiz, &
iwork[1], &work[wstart], info);
} else {
dlasda_(&icompq, &smlsiz, &nsize, &sqre, &d__[start], &e[
start], &q[start + (iu + qstart - 2) * *n], n, &q[
start + (ivt + qstart - 2) * *n], &iq[start + k * *n],
&q[start + (difl + qstart - 2) * *n], &q[start + (
difr + qstart - 2) * *n], &q[start + (z__ + qstart -
2) * *n], &q[start + (poles + qstart - 2) * *n], &iq[
start + givptr * *n], &iq[start + givcol * *n], n, &
iq[start + perm * *n], &q[start + (givnum + qstart -
2) * *n], &q[start + (ic + qstart - 2) * *n], &q[
start + (is + qstart - 2) * *n], &work[wstart], &
iwork[1], info);
if (*info != 0) {
return 0;
}
}
start = i__ + 1;
}
/* L30: */
}
/* Unscale */
latime_1.ops += (doublereal) (*n);
dlascl_("G", &c__0, &c__0, &c_b15, &orgnrm, n, &c__1, &d__[1], n, &ierr);
L40:
/* Use Selection Sort to minimize swaps of singular vectors */
i__1 = *n;
for (ii = 2; ii <= i__1; ++ii) {
i__ = ii - 1;
kk = i__;
p = d__[i__];
i__2 = *n;
for (j = ii; j <= i__2; ++j) {
if (d__[j] > p) {
kk = j;
p = d__[j];
}
/* L50: */
}
if (kk != i__) {
d__[kk] = d__[i__];
d__[i__] = p;
if (icompq == 1) {
iq[i__] = kk;
} else if (icompq == 2) {
dswap_(n, &u_ref(1, i__), &c__1, &u_ref(1, kk), &c__1);
dswap_(n, &vt_ref(i__, 1), ldvt, &vt_ref(kk, 1), ldvt);
}
} else if (icompq == 1) {
iq[i__] = i__;
}
/* L60: */
}
/* If ICOMPQ = 1, use IQ(N,1) as the indicator for UPLO */
if (icompq == 1) {
if (iuplo == 1) {
iq[*n] = 1;
} else {
iq[*n] = 0;
}
}
/* If B is lower bidiagonal, update U by those Givens rotations
which rotated B to be upper bidiagonal */
if (iuplo == 2 && icompq == 2) {
latime_1.ops += (doublereal) ((*n - 1) * 6 * *n);
dlasr_("L", "V", "B", n, n, &work[1], &work[*n], &u[u_offset], ldu);
}
return 0;
/* End of DBDSDC */
} /* dbdsdc_ */
/* Subroutine */
int dggbal_(char *job, integer *n, doublereal *a, integer * lda, doublereal *b, integer *ldb, integer *ilo, integer *ihi, doublereal *lscale, doublereal *rscale, doublereal *work, integer * info)
{
/* System generated locals */
integer a_dim1, a_offset, b_dim1, b_offset, i__1, i__2, i__3;
doublereal d__1, d__2, d__3;
/* Builtin functions */
double d_lg10(doublereal *), d_sign(doublereal *, doublereal *), pow_di( doublereal *, integer *);
/* Local variables */
integer i__, j, k, l, m;
doublereal t;
integer jc;
doublereal ta, tb, tc;
integer ir;
doublereal ew;
integer it, nr, ip1, jp1, lm1;
doublereal cab, rab, ewc, cor, sum;
integer nrp2, icab, lcab;
doublereal beta, coef;
integer irab, lrab;
doublereal basl, cmax;
extern doublereal ddot_(integer *, doublereal *, integer *, doublereal *, integer *);
doublereal coef2, coef5, gamma, alpha;
extern /* Subroutine */
int dscal_(integer *, doublereal *, doublereal *, integer *);
extern logical lsame_(char *, char *);
doublereal sfmin, sfmax;
extern /* Subroutine */
int dswap_(integer *, doublereal *, integer *, doublereal *, integer *);
integer iflow;
extern /* Subroutine */
int daxpy_(integer *, doublereal *, doublereal *, integer *, doublereal *, integer *);
integer kount;
extern doublereal dlamch_(char *);
doublereal pgamma;
extern integer idamax_(integer *, doublereal *, integer *);
extern /* Subroutine */
int xerbla_(char *, integer *);
integer lsfmin, lsfmax;
/* -- 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;
--lscale;
--rscale;
--work;
/* Function Body */
*info = 0;
if (! lsame_(job, "N") && ! lsame_(job, "P") && ! lsame_(job, "S") && ! lsame_(job, "B"))
{
*info = -1;
}
else if (*n < 0)
{
*info = -2;
}
else if (*lda < max(1,*n))
{
*info = -4;
}
else if (*ldb < max(1,*n))
{
*info = -6;
}
if (*info != 0)
{
i__1 = -(*info);
xerbla_("DGGBAL", &i__1);
return 0;
}
/* Quick return if possible */
if (*n == 0)
{
*ilo = 1;
*ihi = *n;
return 0;
}
if (*n == 1)
{
*ilo = 1;
*ihi = *n;
lscale[1] = 1.;
rscale[1] = 1.;
return 0;
}
if (lsame_(job, "N"))
{
*ilo = 1;
*ihi = *n;
i__1 = *n;
for (i__ = 1;
i__ <= i__1;
++i__)
{
lscale[i__] = 1.;
rscale[i__] = 1.;
/* L10: */
}
return 0;
}
k = 1;
l = *n;
if (lsame_(job, "S"))
{
goto L190;
}
goto L30;
/* Permute the matrices A and B to isolate the eigenvalues. */
/* Find row with one nonzero in columns 1 through L */
L20:
l = lm1;
if (l != 1)
{
goto L30;
}
rscale[1] = 1.;
lscale[1] = 1.;
goto L190;
L30:
lm1 = l - 1;
for (i__ = l;
i__ >= 1;
--i__)
{
i__1 = lm1;
for (j = 1;
j <= i__1;
++j)
{
jp1 = j + 1;
if (a[i__ + j * a_dim1] != 0. || b[i__ + j * b_dim1] != 0.)
{
goto L50;
}
/* L40: */
}
j = l;
goto L70;
L50:
i__1 = l;
for (j = jp1;
j <= i__1;
++j)
{
if (a[i__ + j * a_dim1] != 0. || b[i__ + j * b_dim1] != 0.)
{
goto L80;
}
/* L60: */
}
j = jp1 - 1;
L70:
m = l;
iflow = 1;
goto L160;
L80:
;
}
goto L100;
/* Find column with one nonzero in rows K through N */
L90:
++k;
L100:
i__1 = l;
for (j = k;
j <= i__1;
++j)
{
i__2 = lm1;
for (i__ = k;
i__ <= i__2;
++i__)
{
ip1 = i__ + 1;
if (a[i__ + j * a_dim1] != 0. || b[i__ + j * b_dim1] != 0.)
{
goto L120;
}
/* L110: */
}
i__ = l;
goto L140;
L120:
i__2 = l;
for (i__ = ip1;
i__ <= i__2;
++i__)
{
if (a[i__ + j * a_dim1] != 0. || b[i__ + j * b_dim1] != 0.)
{
goto L150;
}
/* L130: */
}
i__ = ip1 - 1;
L140:
m = k;
iflow = 2;
goto L160;
L150:
;
}
goto L190;
/* Permute rows M and I */
L160:
lscale[m] = (doublereal) i__;
if (i__ == m)
{
goto L170;
}
i__1 = *n - k + 1;
dswap_(&i__1, &a[i__ + k * a_dim1], lda, &a[m + k * a_dim1], lda);
i__1 = *n - k + 1;
dswap_(&i__1, &b[i__ + k * b_dim1], ldb, &b[m + k * b_dim1], ldb);
/* Permute columns M and J */
L170:
rscale[m] = (doublereal) j;
if (j == m)
{
goto L180;
}
dswap_(&l, &a[j * a_dim1 + 1], &c__1, &a[m * a_dim1 + 1], &c__1);
dswap_(&l, &b[j * b_dim1 + 1], &c__1, &b[m * b_dim1 + 1], &c__1);
L180:
switch (iflow)
{
case 1:
goto L20;
case 2:
goto L90;
}
L190:
*ilo = k;
*ihi = l;
if (lsame_(job, "P"))
{
i__1 = *ihi;
for (i__ = *ilo;
i__ <= i__1;
++i__)
{
lscale[i__] = 1.;
rscale[i__] = 1.;
/* L195: */
}
return 0;
}
if (*ilo == *ihi)
{
return 0;
}
/* Balance the submatrix in rows ILO to IHI. */
nr = *ihi - *ilo + 1;
i__1 = *ihi;
for (i__ = *ilo;
i__ <= i__1;
++i__)
{
rscale[i__] = 0.;
lscale[i__] = 0.;
work[i__] = 0.;
work[i__ + *n] = 0.;
work[i__ + (*n << 1)] = 0.;
work[i__ + *n * 3] = 0.;
work[i__ + (*n << 2)] = 0.;
work[i__ + *n * 5] = 0.;
/* L200: */
}
/* Compute right side vector in resulting linear equations */
basl = d_lg10(&c_b35);
i__1 = *ihi;
for (i__ = *ilo;
i__ <= i__1;
++i__)
{
i__2 = *ihi;
for (j = *ilo;
j <= i__2;
++j)
{
tb = b[i__ + j * b_dim1];
ta = a[i__ + j * a_dim1];
if (ta == 0.)
{
goto L210;
}
d__1 = f2c_abs(ta);
ta = d_lg10(&d__1) / basl;
L210:
if (tb == 0.)
{
goto L220;
}
d__1 = f2c_abs(tb);
tb = d_lg10(&d__1) / basl;
L220:
work[i__ + (*n << 2)] = work[i__ + (*n << 2)] - ta - tb;
work[j + *n * 5] = work[j + *n * 5] - ta - tb;
/* L230: */
}
/* L240: */
}
coef = 1. / (doublereal) (nr << 1);
coef2 = coef * coef;
coef5 = coef2 * .5;
nrp2 = nr + 2;
beta = 0.;
it = 1;
/* Start generalized conjugate gradient iteration */
L250:
gamma = ddot_(&nr, &work[*ilo + (*n << 2)], &c__1, &work[*ilo + (*n << 2)] , &c__1) + ddot_(&nr, &work[*ilo + *n * 5], &c__1, &work[*ilo + * n * 5], &c__1);
ew = 0.;
ewc = 0.;
i__1 = *ihi;
for (i__ = *ilo;
i__ <= i__1;
++i__)
{
ew += work[i__ + (*n << 2)];
ewc += work[i__ + *n * 5];
/* L260: */
}
/* Computing 2nd power */
d__1 = ew;
/* Computing 2nd power */
d__2 = ewc;
/* Computing 2nd power */
d__3 = ew - ewc;
gamma = coef * gamma - coef2 * (d__1 * d__1 + d__2 * d__2) - coef5 * ( d__3 * d__3);
if (gamma == 0.)
{
goto L350;
}
if (it != 1)
{
beta = gamma / pgamma;
}
t = coef5 * (ewc - ew * 3.);
tc = coef5 * (ew - ewc * 3.);
dscal_(&nr, &beta, &work[*ilo], &c__1);
dscal_(&nr, &beta, &work[*ilo + *n], &c__1);
daxpy_(&nr, &coef, &work[*ilo + (*n << 2)], &c__1, &work[*ilo + *n], & c__1);
daxpy_(&nr, &coef, &work[*ilo + *n * 5], &c__1, &work[*ilo], &c__1);
i__1 = *ihi;
for (i__ = *ilo;
i__ <= i__1;
++i__)
{
work[i__] += tc;
work[i__ + *n] += t;
/* L270: */
}
/* Apply matrix to vector */
i__1 = *ihi;
for (i__ = *ilo;
i__ <= i__1;
++i__)
{
kount = 0;
sum = 0.;
i__2 = *ihi;
for (j = *ilo;
j <= i__2;
++j)
{
if (a[i__ + j * a_dim1] == 0.)
{
goto L280;
}
++kount;
sum += work[j];
L280:
if (b[i__ + j * b_dim1] == 0.)
{
goto L290;
}
++kount;
sum += work[j];
L290:
;
}
work[i__ + (*n << 1)] = (doublereal) kount * work[i__ + *n] + sum;
/* L300: */
}
i__1 = *ihi;
for (j = *ilo;
j <= i__1;
++j)
{
kount = 0;
sum = 0.;
i__2 = *ihi;
for (i__ = *ilo;
i__ <= i__2;
++i__)
{
if (a[i__ + j * a_dim1] == 0.)
{
goto L310;
}
++kount;
sum += work[i__ + *n];
L310:
if (b[i__ + j * b_dim1] == 0.)
{
goto L320;
}
++kount;
sum += work[i__ + *n];
L320:
;
}
work[j + *n * 3] = (doublereal) kount * work[j] + sum;
/* L330: */
}
sum = ddot_(&nr, &work[*ilo + *n], &c__1, &work[*ilo + (*n << 1)], &c__1) + ddot_(&nr, &work[*ilo], &c__1, &work[*ilo + *n * 3], &c__1);
alpha = gamma / sum;
/* Determine correction to current iteration */
cmax = 0.;
i__1 = *ihi;
for (i__ = *ilo;
i__ <= i__1;
++i__)
{
cor = alpha * work[i__ + *n];
if (f2c_abs(cor) > cmax)
{
cmax = f2c_abs(cor);
}
lscale[i__] += cor;
cor = alpha * work[i__];
if (f2c_abs(cor) > cmax)
{
cmax = f2c_abs(cor);
}
rscale[i__] += cor;
/* L340: */
}
if (cmax < .5)
{
goto L350;
}
d__1 = -alpha;
daxpy_(&nr, &d__1, &work[*ilo + (*n << 1)], &c__1, &work[*ilo + (*n << 2)] , &c__1);
d__1 = -alpha;
daxpy_(&nr, &d__1, &work[*ilo + *n * 3], &c__1, &work[*ilo + *n * 5], & c__1);
pgamma = gamma;
++it;
if (it <= nrp2)
{
goto L250;
}
/* End generalized conjugate gradient iteration */
L350:
sfmin = dlamch_("S");
sfmax = 1. / sfmin;
lsfmin = (integer) (d_lg10(&sfmin) / basl + 1.);
lsfmax = (integer) (d_lg10(&sfmax) / basl);
i__1 = *ihi;
for (i__ = *ilo;
i__ <= i__1;
++i__)
{
i__2 = *n - *ilo + 1;
irab = idamax_(&i__2, &a[i__ + *ilo * a_dim1], lda);
rab = (d__1 = a[i__ + (irab + *ilo - 1) * a_dim1], f2c_abs(d__1));
i__2 = *n - *ilo + 1;
irab = idamax_(&i__2, &b[i__ + *ilo * b_dim1], ldb);
/* Computing MAX */
d__2 = rab;
d__3 = (d__1 = b[i__ + (irab + *ilo - 1) * b_dim1], f2c_abs( d__1)); // , expr subst
rab = max(d__2,d__3);
d__1 = rab + sfmin;
lrab = (integer) (d_lg10(&d__1) / basl + 1.);
ir = (integer) (lscale[i__] + d_sign(&c_b71, &lscale[i__]));
/* Computing MIN */
i__2 = max(ir,lsfmin);
i__2 = min(i__2,lsfmax);
i__3 = lsfmax - lrab; // ; expr subst
ir = min(i__2,i__3);
lscale[i__] = pow_di(&c_b35, &ir);
icab = idamax_(ihi, &a[i__ * a_dim1 + 1], &c__1);
cab = (d__1 = a[icab + i__ * a_dim1], f2c_abs(d__1));
icab = idamax_(ihi, &b[i__ * b_dim1 + 1], &c__1);
/* Computing MAX */
d__2 = cab;
d__3 = (d__1 = b[icab + i__ * b_dim1], f2c_abs(d__1)); // , expr subst
cab = max(d__2,d__3);
d__1 = cab + sfmin;
lcab = (integer) (d_lg10(&d__1) / basl + 1.);
jc = (integer) (rscale[i__] + d_sign(&c_b71, &rscale[i__]));
/* Computing MIN */
i__2 = max(jc,lsfmin);
i__2 = min(i__2,lsfmax);
i__3 = lsfmax - lcab; // ; expr subst
jc = min(i__2,i__3);
rscale[i__] = pow_di(&c_b35, &jc);
/* L360: */
}
/* Row scaling of matrices A and B */
i__1 = *ihi;
for (i__ = *ilo;
i__ <= i__1;
++i__)
{
i__2 = *n - *ilo + 1;
dscal_(&i__2, &lscale[i__], &a[i__ + *ilo * a_dim1], lda);
i__2 = *n - *ilo + 1;
dscal_(&i__2, &lscale[i__], &b[i__ + *ilo * b_dim1], ldb);
/* L370: */
}
/* Column scaling of matrices A and B */
i__1 = *ihi;
for (j = *ilo;
j <= i__1;
++j)
{
dscal_(ihi, &rscale[j], &a[j * a_dim1 + 1], &c__1);
dscal_(ihi, &rscale[j], &b[j * b_dim1 + 1], &c__1);
/* L380: */
}
return 0;
/* End of DGGBAL */
}
/* Subroutine */ int dsptrs_(char *uplo, integer *n, integer *nrhs,
doublereal *ap, integer *ipiv, doublereal *b, integer *ldb, integer *
info)
{
/* System generated locals */
integer b_dim1, b_offset, i__1;
doublereal d__1;
/* Local variables */
integer j, k;
doublereal ak, bk;
integer kc, kp;
doublereal akm1, bkm1;
extern /* Subroutine */ int dger_(integer *, integer *, doublereal *,
doublereal *, integer *, doublereal *, integer *, doublereal *,
integer *);
doublereal akm1k;
extern /* Subroutine */ int dscal_(integer *, doublereal *, doublereal *,
integer *);
extern logical lsame_(char *, char *);
doublereal denom;
extern /* Subroutine */ int dgemv_(char *, integer *, integer *,
doublereal *, doublereal *, integer *, doublereal *, integer *,
doublereal *, doublereal *, integer *), dswap_(integer *,
doublereal *, integer *, doublereal *, integer *);
logical upper;
extern /* Subroutine */ int xerbla_(char *, integer *);
/* -- LAPACK routine (version 3.1) -- */
/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/* November 2006 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* DSPTRS solves a system of linear equations A*X = B with a real */
/* symmetric matrix A stored in packed format using the factorization */
/* A = U*D*U**T or A = L*D*L**T computed by DSPTRF. */
/* Arguments */
/* ========= */
/* UPLO (input) CHARACTER*1 */
/* Specifies whether the details of the factorization are stored */
/* as an upper or lower triangular matrix. */
/* = 'U': Upper triangular, form is A = U*D*U**T; */
/* = 'L': Lower triangular, form is A = L*D*L**T. */
/* 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. */
/* AP (input) DOUBLE PRECISION array, dimension (N*(N+1)/2) */
/* The block diagonal matrix D and the multipliers used to */
/* obtain the factor U or L as computed by DSPTRF, stored as a */
/* packed triangular matrix. */
/* IPIV (input) INTEGER array, dimension (N) */
/* Details of the interchanges and the block structure of D */
/* as determined by DSPTRF. */
/* B (input/output) DOUBLE PRECISION array, dimension (LDB,NRHS) */
/* On entry, the right hand side matrix B. */
/* On exit, the solution matrix X. */
/* LDB (input) INTEGER */
/* The leading dimension of the array B. LDB >= max(1,N). */
/* INFO (output) INTEGER */
/* = 0: successful exit */
/* < 0: if INFO = -i, the i-th argument had an illegal value */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Executable Statements .. */
/* Parameter adjustments */
--ap;
--ipiv;
b_dim1 = *ldb;
b_offset = 1 + b_dim1;
b -= b_offset;
/* Function Body */
*info = 0;
upper = lsame_(uplo, "U");
if (! upper && ! lsame_(uplo, "L")) {
*info = -1;
} else if (*n < 0) {
*info = -2;
} else if (*nrhs < 0) {
*info = -3;
} else if (*ldb < max(1,*n)) {
*info = -7;
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("DSPTRS", &i__1);
return 0;
}
/* Quick return if possible */
if (*n == 0 || *nrhs == 0) {
return 0;
}
if (upper) {
/* Solve A*X = B, where A = U*D*U'. */
/* First solve U*D*X = B, overwriting B with X. */
/* K is the main loop index, decreasing from N to 1 in steps of */
/* 1 or 2, depending on the size of the diagonal blocks. */
k = *n;
kc = *n * (*n + 1) / 2 + 1;
L10:
/* If K < 1, exit from loop. */
if (k < 1) {
goto L30;
}
kc -= k;
if (ipiv[k] > 0) {
/* 1 x 1 diagonal block */
/* Interchange rows K and IPIV(K). */
kp = ipiv[k];
if (kp != k) {
dswap_(nrhs, &b[k + b_dim1], ldb, &b[kp + b_dim1], ldb);
}
/* Multiply by inv(U(K)), where U(K) is the transformation */
/* stored in column K of A. */
i__1 = k - 1;
dger_(&i__1, nrhs, &c_b7, &ap[kc], &c__1, &b[k + b_dim1], ldb, &b[
b_dim1 + 1], ldb);
/* Multiply by the inverse of the diagonal block. */
d__1 = 1. / ap[kc + k - 1];
dscal_(nrhs, &d__1, &b[k + b_dim1], ldb);
--k;
} else {
/* 2 x 2 diagonal block */
/* Interchange rows K-1 and -IPIV(K). */
kp = -ipiv[k];
if (kp != k - 1) {
dswap_(nrhs, &b[k - 1 + b_dim1], ldb, &b[kp + b_dim1], ldb);
}
/* Multiply by inv(U(K)), where U(K) is the transformation */
/* stored in columns K-1 and K of A. */
i__1 = k - 2;
dger_(&i__1, nrhs, &c_b7, &ap[kc], &c__1, &b[k + b_dim1], ldb, &b[
b_dim1 + 1], ldb);
i__1 = k - 2;
dger_(&i__1, nrhs, &c_b7, &ap[kc - (k - 1)], &c__1, &b[k - 1 +
b_dim1], ldb, &b[b_dim1 + 1], ldb);
/* Multiply by the inverse of the diagonal block. */
akm1k = ap[kc + k - 2];
akm1 = ap[kc - 1] / akm1k;
ak = ap[kc + k - 1] / akm1k;
denom = akm1 * ak - 1.;
i__1 = *nrhs;
for (j = 1; j <= i__1; ++j) {
bkm1 = b[k - 1 + j * b_dim1] / akm1k;
bk = b[k + j * b_dim1] / akm1k;
b[k - 1 + j * b_dim1] = (ak * bkm1 - bk) / denom;
b[k + j * b_dim1] = (akm1 * bk - bkm1) / denom;
/* L20: */
}
kc = kc - k + 1;
k += -2;
}
goto L10;
L30:
/* Next solve U'*X = B, overwriting B with X. */
/* K is the main loop index, increasing from 1 to N in steps of */
/* 1 or 2, depending on the size of the diagonal blocks. */
k = 1;
kc = 1;
L40:
/* If K > N, exit from loop. */
if (k > *n) {
goto L50;
}
if (ipiv[k] > 0) {
/* 1 x 1 diagonal block */
/* Multiply by inv(U'(K)), where U(K) is the transformation */
/* stored in column K of A. */
i__1 = k - 1;
dgemv_("Transpose", &i__1, nrhs, &c_b7, &b[b_offset], ldb, &ap[kc]
, &c__1, &c_b19, &b[k + b_dim1], ldb);
/* Interchange rows K and IPIV(K). */
kp = ipiv[k];
if (kp != k) {
dswap_(nrhs, &b[k + b_dim1], ldb, &b[kp + b_dim1], ldb);
}
kc += k;
++k;
} else {
/* 2 x 2 diagonal block */
/* Multiply by inv(U'(K+1)), where U(K+1) is the transformation */
/* stored in columns K and K+1 of A. */
i__1 = k - 1;
dgemv_("Transpose", &i__1, nrhs, &c_b7, &b[b_offset], ldb, &ap[kc]
, &c__1, &c_b19, &b[k + b_dim1], ldb);
i__1 = k - 1;
dgemv_("Transpose", &i__1, nrhs, &c_b7, &b[b_offset], ldb, &ap[kc
+ k], &c__1, &c_b19, &b[k + 1 + b_dim1], ldb);
/* Interchange rows K and -IPIV(K). */
kp = -ipiv[k];
if (kp != k) {
dswap_(nrhs, &b[k + b_dim1], ldb, &b[kp + b_dim1], ldb);
}
kc = kc + (k << 1) + 1;
k += 2;
}
goto L40;
L50:
;
} else {
/* Solve A*X = B, where A = L*D*L'. */
/* First solve L*D*X = B, overwriting B with X. */
/* K is the main loop index, increasing from 1 to N in steps of */
/* 1 or 2, depending on the size of the diagonal blocks. */
k = 1;
kc = 1;
L60:
/* If K > N, exit from loop. */
if (k > *n) {
goto L80;
}
if (ipiv[k] > 0) {
/* 1 x 1 diagonal block */
/* Interchange rows K and IPIV(K). */
kp = ipiv[k];
if (kp != k) {
dswap_(nrhs, &b[k + b_dim1], ldb, &b[kp + b_dim1], ldb);
}
/* Multiply by inv(L(K)), where L(K) is the transformation */
/* stored in column K of A. */
if (k < *n) {
i__1 = *n - k;
dger_(&i__1, nrhs, &c_b7, &ap[kc + 1], &c__1, &b[k + b_dim1],
ldb, &b[k + 1 + b_dim1], ldb);
}
/* Multiply by the inverse of the diagonal block. */
d__1 = 1. / ap[kc];
dscal_(nrhs, &d__1, &b[k + b_dim1], ldb);
kc = kc + *n - k + 1;
++k;
} else {
/* 2 x 2 diagonal block */
/* Interchange rows K+1 and -IPIV(K). */
kp = -ipiv[k];
if (kp != k + 1) {
dswap_(nrhs, &b[k + 1 + b_dim1], ldb, &b[kp + b_dim1], ldb);
}
/* Multiply by inv(L(K)), where L(K) is the transformation */
/* stored in columns K and K+1 of A. */
if (k < *n - 1) {
i__1 = *n - k - 1;
dger_(&i__1, nrhs, &c_b7, &ap[kc + 2], &c__1, &b[k + b_dim1],
ldb, &b[k + 2 + b_dim1], ldb);
i__1 = *n - k - 1;
dger_(&i__1, nrhs, &c_b7, &ap[kc + *n - k + 2], &c__1, &b[k +
1 + b_dim1], ldb, &b[k + 2 + b_dim1], ldb);
}
/* Multiply by the inverse of the diagonal block. */
akm1k = ap[kc + 1];
akm1 = ap[kc] / akm1k;
ak = ap[kc + *n - k + 1] / akm1k;
denom = akm1 * ak - 1.;
i__1 = *nrhs;
for (j = 1; j <= i__1; ++j) {
bkm1 = b[k + j * b_dim1] / akm1k;
bk = b[k + 1 + j * b_dim1] / akm1k;
b[k + j * b_dim1] = (ak * bkm1 - bk) / denom;
b[k + 1 + j * b_dim1] = (akm1 * bk - bkm1) / denom;
/* L70: */
}
kc = kc + (*n - k << 1) + 1;
k += 2;
}
goto L60;
L80:
/* Next solve L'*X = B, overwriting B with X. */
/* K is the main loop index, decreasing from N to 1 in steps of */
/* 1 or 2, depending on the size of the diagonal blocks. */
k = *n;
kc = *n * (*n + 1) / 2 + 1;
L90:
/* If K < 1, exit from loop. */
if (k < 1) {
goto L100;
}
kc -= *n - k + 1;
if (ipiv[k] > 0) {
/* 1 x 1 diagonal block */
/* Multiply by inv(L'(K)), where L(K) is the transformation */
/* stored in column K of A. */
if (k < *n) {
i__1 = *n - k;
dgemv_("Transpose", &i__1, nrhs, &c_b7, &b[k + 1 + b_dim1],
ldb, &ap[kc + 1], &c__1, &c_b19, &b[k + b_dim1], ldb);
}
/* Interchange rows K and IPIV(K). */
kp = ipiv[k];
if (kp != k) {
dswap_(nrhs, &b[k + b_dim1], ldb, &b[kp + b_dim1], ldb);
}
--k;
} else {
/* 2 x 2 diagonal block */
/* Multiply by inv(L'(K-1)), where L(K-1) is the transformation */
/* stored in columns K-1 and K of A. */
if (k < *n) {
i__1 = *n - k;
dgemv_("Transpose", &i__1, nrhs, &c_b7, &b[k + 1 + b_dim1],
ldb, &ap[kc + 1], &c__1, &c_b19, &b[k + b_dim1], ldb);
i__1 = *n - k;
dgemv_("Transpose", &i__1, nrhs, &c_b7, &b[k + 1 + b_dim1],
ldb, &ap[kc - (*n - k)], &c__1, &c_b19, &b[k - 1 +
b_dim1], ldb);
}
/* Interchange rows K and -IPIV(K). */
kp = -ipiv[k];
if (kp != k) {
dswap_(nrhs, &b[k + b_dim1], ldb, &b[kp + b_dim1], ldb);
}
kc -= *n - k + 2;
k += -2;
}
goto L90;
L100:
;
}
return 0;
/* End of DSPTRS */
} /* dsptrs_ */
/* Subroutine */ HYPRE_Int dgetf2_(integer *m, integer *n, doublereal *a, integer *
lda, integer *ipiv, 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, 1992
Purpose
=======
DGETF2 computes an LU factorization of a general m-by-n matrix A
using partial pivoting with row interchanges.
The factorization has the form
A = P * L * U
where P is a permutation matrix, L is lower triangular with unit
diagonal elements (lower trapezoidal if m > n), and U is upper
triangular (upper trapezoidal if m < n).
This is the right-looking Level 2 BLAS version of the algorithm.
Arguments
=========
M (input) INTEGER
The number of rows of the matrix A. M >= 0.
N (input) INTEGER
The number of columns of the matrix A. N >= 0.
A (input/output) DOUBLE PRECISION array, dimension (LDA,N)
On entry, the m by n matrix to be factored.
On exit, the factors L and U from the factorization
A = P*L*U; the unit diagonal elements of L are not stored.
LDA (input) INTEGER
The leading dimension of the array A. LDA >= max(1,M).
IPIV (output) INTEGER array, dimension (min(M,N))
The pivot indices; for 1 <= i <= min(M,N), row i of the
matrix was interchanged with row IPIV(i).
INFO (output) INTEGER
= 0: successful exit
< 0: if INFO = -k, the k-th argument had an illegal value
> 0: if INFO = k, U(k,k) is exactly zero. The factorization
has been completed, but the factor U is exactly
singular, and division by zero will occur if it is used
to solve a system of equations.
=====================================================================
Test the input parameters.
Parameter adjustments */
/* Table of constant values */
static integer c__1 = 1;
static doublereal c_b6 = -1.;
/* System generated locals */
integer a_dim1, a_offset, i__1, i__2, i__3;
doublereal d__1;
/* Local variables */
extern /* Subroutine */ HYPRE_Int dger_(integer *, integer *, doublereal *,
doublereal *, integer *, doublereal *, integer *, doublereal *,
integer *);
static integer j;
extern /* Subroutine */ HYPRE_Int dscal_(integer *, doublereal *, doublereal *,
integer *), dswap_(integer *, doublereal *, integer *, doublereal
*, integer *);
static integer jp;
extern integer idamax_(integer *, doublereal *, integer *);
extern /* Subroutine */ HYPRE_Int xerbla_(char *, integer *);
#define a_ref(a_1,a_2) a[(a_2)*a_dim1 + a_1]
a_dim1 = *lda;
a_offset = 1 + a_dim1 * 1;
a -= a_offset;
--ipiv;
/* Function Body */
*info = 0;
if (*m < 0) {
*info = -1;
} else if (*n < 0) {
*info = -2;
} else if (*lda < max(1,*m)) {
*info = -4;
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("DGETF2", &i__1);
return 0;
}
/* Quick return if possible */
if (*m == 0 || *n == 0) {
return 0;
}
i__1 = min(*m,*n);
for (j = 1; j <= i__1; ++j) {
/* Find pivot and test for singularity. */
i__2 = *m - j + 1;
jp = j - 1 + idamax_(&i__2, &a_ref(j, j), &c__1);
ipiv[j] = jp;
if (a_ref(jp, j) != 0.) {
/* Apply the interchange to columns 1:N. */
if (jp != j) {
dswap_(n, &a_ref(j, 1), lda, &a_ref(jp, 1), lda);
}
/* Compute elements J+1:M of J-th column. */
if (j < *m) {
i__2 = *m - j;
d__1 = 1. / a_ref(j, j);
dscal_(&i__2, &d__1, &a_ref(j + 1, j), &c__1);
}
} else if (*info == 0) {
*info = j;
}
if (j < min(*m,*n)) {
/* Update trailing submatrix. */
i__2 = *m - j;
i__3 = *n - j;
dger_(&i__2, &i__3, &c_b6, &a_ref(j + 1, j), &c__1, &a_ref(j, j +
1), lda, &a_ref(j + 1, j + 1), lda);
}
/* L10: */
}
return 0;
/* End of DGETF2 */
} /* dgetf2_ */
/* Subroutine */ int dsytri_(char *uplo, integer *n, doublereal *a, integer *
lda, integer *ipiv, doublereal *work, integer *info)
{
/* -- LAPACK routine (version 3.0) --
Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
Courant Institute, Argonne National Lab, and Rice University
March 31, 1993
Purpose
=======
DSYTRI computes the inverse of a real symmetric indefinite matrix
A using the factorization A = U*D*U**T or A = L*D*L**T computed by
DSYTRF.
Arguments
=========
UPLO (input) CHARACTER*1
Specifies whether the details of the factorization are stored
as an upper or lower triangular matrix.
= 'U': Upper triangular, form is A = U*D*U**T;
= 'L': Lower triangular, form is A = L*D*L**T.
N (input) INTEGER
The order of the matrix A. N >= 0.
A (input/output) DOUBLE PRECISION array, dimension (LDA,N)
On entry, the block diagonal matrix D and the multipliers
used to obtain the factor U or L as computed by DSYTRF.
On exit, if INFO = 0, the (symmetric) inverse of the original
matrix. If UPLO = 'U', the upper triangular part of the
inverse is formed and the part of A below the diagonal is not
referenced; if UPLO = 'L' the lower triangular part of the
inverse is formed and the part of A above the diagonal is
not referenced.
LDA (input) INTEGER
The leading dimension of the array A. LDA >= max(1,N).
IPIV (input) INTEGER array, dimension (N)
Details of the interchanges and the block structure of D
as determined by DSYTRF.
WORK (workspace) DOUBLE PRECISION 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, D(i,i) = 0; the matrix is singular and its
inverse could not be computed.
=====================================================================
Test the input parameters.
Parameter adjustments */
/* Table of constant values */
static integer c__1 = 1;
static doublereal c_b11 = -1.;
static doublereal c_b13 = 0.;
/* System generated locals */
integer a_dim1, a_offset, i__1;
doublereal d__1;
/* Local variables */
extern doublereal ddot_(integer *, doublereal *, integer *, doublereal *,
integer *);
static doublereal temp, akkp1, d__;
static integer k;
static doublereal t;
extern logical lsame_(char *, char *);
extern /* Subroutine */ int dcopy_(integer *, doublereal *, integer *,
doublereal *, integer *), dswap_(integer *, doublereal *, integer
*, doublereal *, integer *);
static integer kstep;
static logical upper;
extern /* Subroutine */ int dsymv_(char *, integer *, doublereal *,
doublereal *, integer *, doublereal *, integer *, doublereal *,
doublereal *, integer *);
static doublereal ak;
static integer kp;
extern /* Subroutine */ int xerbla_(char *, integer *);
static doublereal akp1;
#define a_ref(a_1,a_2) a[(a_2)*a_dim1 + a_1]
a_dim1 = *lda;
a_offset = 1 + a_dim1 * 1;
a -= a_offset;
--ipiv;
--work;
/* Function Body */
*info = 0;
upper = lsame_(uplo, "U");
if (! upper && ! lsame_(uplo, "L")) {
*info = -1;
} else if (*n < 0) {
*info = -2;
} else if (*lda < max(1,*n)) {
*info = -4;
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("DSYTRI", &i__1);
return 0;
}
/* Quick return if possible */
if (*n == 0) {
return 0;
}
/* Check that the diagonal matrix D is nonsingular. */
if (upper) {
/* Upper triangular storage: examine D from bottom to top */
for (*info = *n; *info >= 1; --(*info)) {
if (ipiv[*info] > 0 && a_ref(*info, *info) == 0.) {
return 0;
}
/* L10: */
}
} else {
/* Lower triangular storage: examine D from top to bottom. */
i__1 = *n;
for (*info = 1; *info <= i__1; ++(*info)) {
if (ipiv[*info] > 0 && a_ref(*info, *info) == 0.) {
return 0;
}
/* L20: */
}
}
*info = 0;
if (upper) {
/* Compute inv(A) from the factorization A = U*D*U'.
K is the main loop index, increasing from 1 to N in steps of
1 or 2, depending on the size of the diagonal blocks. */
k = 1;
L30:
/* If K > N, exit from loop. */
if (k > *n) {
goto L40;
}
if (ipiv[k] > 0) {
/* 1 x 1 diagonal block
Invert the diagonal block. */
a_ref(k, k) = 1. / a_ref(k, k);
/* Compute column K of the inverse. */
if (k > 1) {
i__1 = k - 1;
dcopy_(&i__1, &a_ref(1, k), &c__1, &work[1], &c__1);
i__1 = k - 1;
dsymv_(uplo, &i__1, &c_b11, &a[a_offset], lda, &work[1], &
c__1, &c_b13, &a_ref(1, k), &c__1);
i__1 = k - 1;
a_ref(k, k) = a_ref(k, k) - ddot_(&i__1, &work[1], &c__1, &
a_ref(1, k), &c__1);
}
kstep = 1;
} else {
/* 2 x 2 diagonal block
Invert the diagonal block. */
t = (d__1 = a_ref(k, k + 1), abs(d__1));
ak = a_ref(k, k) / t;
akp1 = a_ref(k + 1, k + 1) / t;
akkp1 = a_ref(k, k + 1) / t;
d__ = t * (ak * akp1 - 1.);
a_ref(k, k) = akp1 / d__;
a_ref(k + 1, k + 1) = ak / d__;
a_ref(k, k + 1) = -akkp1 / d__;
/* Compute columns K and K+1 of the inverse. */
if (k > 1) {
i__1 = k - 1;
dcopy_(&i__1, &a_ref(1, k), &c__1, &work[1], &c__1);
i__1 = k - 1;
dsymv_(uplo, &i__1, &c_b11, &a[a_offset], lda, &work[1], &
c__1, &c_b13, &a_ref(1, k), &c__1);
i__1 = k - 1;
a_ref(k, k) = a_ref(k, k) - ddot_(&i__1, &work[1], &c__1, &
a_ref(1, k), &c__1);
i__1 = k - 1;
a_ref(k, k + 1) = a_ref(k, k + 1) - ddot_(&i__1, &a_ref(1, k),
&c__1, &a_ref(1, k + 1), &c__1);
i__1 = k - 1;
dcopy_(&i__1, &a_ref(1, k + 1), &c__1, &work[1], &c__1);
i__1 = k - 1;
dsymv_(uplo, &i__1, &c_b11, &a[a_offset], lda, &work[1], &
c__1, &c_b13, &a_ref(1, k + 1), &c__1);
i__1 = k - 1;
a_ref(k + 1, k + 1) = a_ref(k + 1, k + 1) - ddot_(&i__1, &
work[1], &c__1, &a_ref(1, k + 1), &c__1);
}
kstep = 2;
}
kp = (i__1 = ipiv[k], abs(i__1));
if (kp != k) {
/* Interchange rows and columns K and KP in the leading
submatrix A(1:k+1,1:k+1) */
i__1 = kp - 1;
dswap_(&i__1, &a_ref(1, k), &c__1, &a_ref(1, kp), &c__1);
i__1 = k - kp - 1;
dswap_(&i__1, &a_ref(kp + 1, k), &c__1, &a_ref(kp, kp + 1), lda);
temp = a_ref(k, k);
a_ref(k, k) = a_ref(kp, kp);
a_ref(kp, kp) = temp;
if (kstep == 2) {
temp = a_ref(k, k + 1);
a_ref(k, k + 1) = a_ref(kp, k + 1);
a_ref(kp, k + 1) = temp;
}
}
k += kstep;
goto L30;
L40:
;
} else {
/* Compute inv(A) from the factorization A = L*D*L'.
K is the main loop index, increasing from 1 to N in steps of
1 or 2, depending on the size of the diagonal blocks. */
k = *n;
L50:
/* If K < 1, exit from loop. */
if (k < 1) {
goto L60;
}
if (ipiv[k] > 0) {
/* 1 x 1 diagonal block
Invert the diagonal block. */
a_ref(k, k) = 1. / a_ref(k, k);
/* Compute column K of the inverse. */
if (k < *n) {
i__1 = *n - k;
dcopy_(&i__1, &a_ref(k + 1, k), &c__1, &work[1], &c__1);
i__1 = *n - k;
dsymv_(uplo, &i__1, &c_b11, &a_ref(k + 1, k + 1), lda, &work[
1], &c__1, &c_b13, &a_ref(k + 1, k), &c__1)
;
i__1 = *n - k;
a_ref(k, k) = a_ref(k, k) - ddot_(&i__1, &work[1], &c__1, &
a_ref(k + 1, k), &c__1);
}
kstep = 1;
} else {
/* 2 x 2 diagonal block
Invert the diagonal block. */
t = (d__1 = a_ref(k, k - 1), abs(d__1));
ak = a_ref(k - 1, k - 1) / t;
akp1 = a_ref(k, k) / t;
akkp1 = a_ref(k, k - 1) / t;
d__ = t * (ak * akp1 - 1.);
a_ref(k - 1, k - 1) = akp1 / d__;
a_ref(k, k) = ak / d__;
a_ref(k, k - 1) = -akkp1 / d__;
/* Compute columns K-1 and K of the inverse. */
if (k < *n) {
i__1 = *n - k;
dcopy_(&i__1, &a_ref(k + 1, k), &c__1, &work[1], &c__1);
i__1 = *n - k;
dsymv_(uplo, &i__1, &c_b11, &a_ref(k + 1, k + 1), lda, &work[
1], &c__1, &c_b13, &a_ref(k + 1, k), &c__1)
;
i__1 = *n - k;
a_ref(k, k) = a_ref(k, k) - ddot_(&i__1, &work[1], &c__1, &
a_ref(k + 1, k), &c__1);
i__1 = *n - k;
a_ref(k, k - 1) = a_ref(k, k - 1) - ddot_(&i__1, &a_ref(k + 1,
k), &c__1, &a_ref(k + 1, k - 1), &c__1);
i__1 = *n - k;
dcopy_(&i__1, &a_ref(k + 1, k - 1), &c__1, &work[1], &c__1);
i__1 = *n - k;
dsymv_(uplo, &i__1, &c_b11, &a_ref(k + 1, k + 1), lda, &work[
1], &c__1, &c_b13, &a_ref(k + 1, k - 1), &c__1);
i__1 = *n - k;
a_ref(k - 1, k - 1) = a_ref(k - 1, k - 1) - ddot_(&i__1, &
work[1], &c__1, &a_ref(k + 1, k - 1), &c__1);
}
kstep = 2;
}
kp = (i__1 = ipiv[k], abs(i__1));
if (kp != k) {
/* Interchange rows and columns K and KP in the trailing
submatrix A(k-1:n,k-1:n) */
if (kp < *n) {
i__1 = *n - kp;
dswap_(&i__1, &a_ref(kp + 1, k), &c__1, &a_ref(kp + 1, kp), &
c__1);
}
i__1 = kp - k - 1;
dswap_(&i__1, &a_ref(k + 1, k), &c__1, &a_ref(kp, k + 1), lda);
temp = a_ref(k, k);
a_ref(k, k) = a_ref(kp, kp);
a_ref(kp, kp) = temp;
if (kstep == 2) {
temp = a_ref(k, k - 1);
a_ref(k, k - 1) = a_ref(kp, k - 1);
a_ref(kp, k - 1) = temp;
}
}
k -= kstep;
goto L50;
L60:
;
}
return 0;
/* End of DSYTRI */
} /* dsytri_ */
/* Subroutine */ int dlavsy_(char *uplo, char *trans, char *diag, integer *n,
integer *nrhs, doublereal *a, integer *lda, integer *ipiv, doublereal
*b, integer *ldb, integer *info)
{
/* System generated locals */
integer a_dim1, a_offset, b_dim1, b_offset, i__1;
/* Local variables */
integer j, k;
doublereal t1, t2, d11, d12, d21, d22;
integer kp;
extern /* Subroutine */ int dger_(integer *, integer *, doublereal *,
doublereal *, integer *, doublereal *, integer *, doublereal *,
integer *), dscal_(integer *, doublereal *, doublereal *, integer
*);
extern logical lsame_(char *, char *);
extern /* Subroutine */ int dgemv_(char *, integer *, integer *,
doublereal *, doublereal *, integer *, doublereal *, integer *,
doublereal *, doublereal *, integer *), dswap_(integer *,
doublereal *, integer *, doublereal *, integer *), xerbla_(char *,
integer *);
logical nounit;
/* -- LAPACK auxiliary routine (version 3.1) -- */
/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/* November 2006 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* DLAVSY performs one of the matrix-vector operations */
/* x := A*x or x := A'*x, */
/* where x is an N element vector and A is one of the factors */
/* from the block U*D*U' or L*D*L' factorization computed by DSYTRF. */
/* If TRANS = 'N', multiplies by U or U * D (or L or L * D) */
/* If TRANS = 'T', multiplies by U' or D * U' (or L' or D * L') */
/* If TRANS = 'C', multiplies by U' or D * U' (or L' or D * L') */
/* Arguments */
/* ========= */
/* UPLO (input) CHARACTER*1 */
/* Specifies whether the factor stored in A is upper or lower */
/* triangular. */
/* = 'U': Upper triangular */
/* = 'L': Lower triangular */
/* TRANS (input) CHARACTER*1 */
/* Specifies the operation to be performed: */
/* = 'N': x := A*x */
/* = 'T': x := A'*x */
/* = 'C': x := A'*x */
/* DIAG (input) CHARACTER*1 */
/* Specifies whether or not the diagonal blocks are unit */
/* matrices. If the diagonal blocks are assumed to be unit, */
/* then A = U or A = L, otherwise A = U*D or A = L*D. */
/* = 'U': Diagonal blocks are assumed to be unit matrices. */
/* = 'N': Diagonal blocks are assumed to be non-unit matrices. */
/* N (input) INTEGER */
/* The number of rows and columns of the matrix A. N >= 0. */
/* NRHS (input) INTEGER */
/* The number of right hand sides, i.e., the number of vectors */
/* x to be multiplied by A. NRHS >= 0. */
/* A (input) DOUBLE PRECISION array, dimension (LDA,N) */
/* The block diagonal matrix D and the multipliers used to */
/* obtain the factor U or L as computed by DSYTRF. */
/* LDA (input) INTEGER */
/* The leading dimension of the array A. LDA >= max(1,N). */
/* IPIV (input) INTEGER array, dimension (N) */
/* The pivot indices from DSYTRF. */
/* B (input/output) DOUBLE PRECISION array, dimension (LDB,NRHS) */
/* On entry, B contains NRHS vectors of length N. */
/* On exit, B is overwritten with the product A * B. */
/* LDB (input) INTEGER */
/* The leading dimension of the array B. LDB >= max(1,N). */
/* INFO (output) INTEGER */
/* = 0: successful exit */
/* < 0: if INFO = -k, the k-th argument had an illegal value */
/* ===================================================================== */
/* .. 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;
--ipiv;
b_dim1 = *ldb;
b_offset = 1 + b_dim1;
b -= b_offset;
/* Function Body */
*info = 0;
if (! lsame_(uplo, "U") && ! lsame_(uplo, "L")) {
*info = -1;
} else if (! lsame_(trans, "N") && ! lsame_(trans,
"T") && ! lsame_(trans, "C")) {
*info = -2;
} else if (! lsame_(diag, "U") && ! lsame_(diag,
"N")) {
*info = -3;
} else if (*n < 0) {
*info = -4;
} else if (*lda < max(1,*n)) {
*info = -6;
} else if (*ldb < max(1,*n)) {
*info = -9;
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("DLAVSY ", &i__1);
return 0;
}
/* Quick return if possible. */
if (*n == 0) {
return 0;
}
nounit = lsame_(diag, "N");
/* ------------------------------------------ */
/* Compute B := A * B (No transpose) */
/* ------------------------------------------ */
if (lsame_(trans, "N")) {
/* Compute B := U*B */
/* where U = P(m)*inv(U(m))* ... *P(1)*inv(U(1)) */
if (lsame_(uplo, "U")) {
/* Loop forward applying the transformations. */
k = 1;
L10:
if (k > *n) {
goto L30;
}
if (ipiv[k] > 0) {
/* 1 x 1 pivot block */
/* Multiply by the diagonal element if forming U * D. */
if (nounit) {
dscal_(nrhs, &a[k + k * a_dim1], &b[k + b_dim1], ldb);
}
/* Multiply by P(K) * inv(U(K)) if K > 1. */
if (k > 1) {
/* Apply the transformation. */
i__1 = k - 1;
dger_(&i__1, nrhs, &c_b15, &a[k * a_dim1 + 1], &c__1, &b[
k + b_dim1], ldb, &b[b_dim1 + 1], ldb);
/* Interchange if P(K) .ne. I. */
kp = ipiv[k];
if (kp != k) {
dswap_(nrhs, &b[k + b_dim1], ldb, &b[kp + b_dim1],
ldb);
}
}
++k;
} else {
/* 2 x 2 pivot block */
/* Multiply by the diagonal block if forming U * D. */
if (nounit) {
d11 = a[k + k * a_dim1];
d22 = a[k + 1 + (k + 1) * a_dim1];
d12 = a[k + (k + 1) * a_dim1];
d21 = d12;
i__1 = *nrhs;
for (j = 1; j <= i__1; ++j) {
t1 = b[k + j * b_dim1];
t2 = b[k + 1 + j * b_dim1];
b[k + j * b_dim1] = d11 * t1 + d12 * t2;
b[k + 1 + j * b_dim1] = d21 * t1 + d22 * t2;
/* L20: */
}
}
/* Multiply by P(K) * inv(U(K)) if K > 1. */
if (k > 1) {
/* Apply the transformations. */
i__1 = k - 1;
dger_(&i__1, nrhs, &c_b15, &a[k * a_dim1 + 1], &c__1, &b[
k + b_dim1], ldb, &b[b_dim1 + 1], ldb);
i__1 = k - 1;
dger_(&i__1, nrhs, &c_b15, &a[(k + 1) * a_dim1 + 1], &
c__1, &b[k + 1 + b_dim1], ldb, &b[b_dim1 + 1],
ldb);
/* Interchange if P(K) .ne. I. */
kp = (i__1 = ipiv[k], abs(i__1));
if (kp != k) {
dswap_(nrhs, &b[k + b_dim1], ldb, &b[kp + b_dim1],
ldb);
}
}
k += 2;
}
goto L10;
L30:
/* Compute B := L*B */
/* where L = P(1)*inv(L(1))* ... *P(m)*inv(L(m)) . */
;
} else {
/* Loop backward applying the transformations to B. */
k = *n;
L40:
if (k < 1) {
goto L60;
}
/* Test the pivot index. If greater than zero, a 1 x 1 */
/* pivot was used, otherwise a 2 x 2 pivot was used. */
if (ipiv[k] > 0) {
/* 1 x 1 pivot block: */
/* Multiply by the diagonal element if forming L * D. */
if (nounit) {
dscal_(nrhs, &a[k + k * a_dim1], &b[k + b_dim1], ldb);
}
/* Multiply by P(K) * inv(L(K)) if K < N. */
if (k != *n) {
kp = ipiv[k];
/* Apply the transformation. */
i__1 = *n - k;
dger_(&i__1, nrhs, &c_b15, &a[k + 1 + k * a_dim1], &c__1,
&b[k + b_dim1], ldb, &b[k + 1 + b_dim1], ldb);
/* Interchange if a permutation was applied at the */
/* K-th step of the factorization. */
if (kp != k) {
dswap_(nrhs, &b[k + b_dim1], ldb, &b[kp + b_dim1],
ldb);
}
}
--k;
} else {
/* 2 x 2 pivot block: */
/* Multiply by the diagonal block if forming L * D. */
if (nounit) {
d11 = a[k - 1 + (k - 1) * a_dim1];
d22 = a[k + k * a_dim1];
d21 = a[k + (k - 1) * a_dim1];
d12 = d21;
i__1 = *nrhs;
for (j = 1; j <= i__1; ++j) {
t1 = b[k - 1 + j * b_dim1];
t2 = b[k + j * b_dim1];
b[k - 1 + j * b_dim1] = d11 * t1 + d12 * t2;
b[k + j * b_dim1] = d21 * t1 + d22 * t2;
/* L50: */
}
}
/* Multiply by P(K) * inv(L(K)) if K < N. */
if (k != *n) {
/* Apply the transformation. */
i__1 = *n - k;
dger_(&i__1, nrhs, &c_b15, &a[k + 1 + k * a_dim1], &c__1,
&b[k + b_dim1], ldb, &b[k + 1 + b_dim1], ldb);
i__1 = *n - k;
dger_(&i__1, nrhs, &c_b15, &a[k + 1 + (k - 1) * a_dim1], &
c__1, &b[k - 1 + b_dim1], ldb, &b[k + 1 + b_dim1],
ldb);
/* Interchange if a permutation was applied at the */
/* K-th step of the factorization. */
kp = (i__1 = ipiv[k], abs(i__1));
if (kp != k) {
dswap_(nrhs, &b[k + b_dim1], ldb, &b[kp + b_dim1],
ldb);
}
}
k += -2;
}
goto L40;
L60:
;
}
/* ---------------------------------------- */
/* Compute B := A' * B (transpose) */
/* ---------------------------------------- */
} else {
/* Form B := U'*B */
/* where U = P(m)*inv(U(m))* ... *P(1)*inv(U(1)) */
/* and U' = inv(U'(1))*P(1)* ... *inv(U'(m))*P(m) */
if (lsame_(uplo, "U")) {
/* Loop backward applying the transformations. */
k = *n;
L70:
if (k < 1) {
goto L90;
}
/* 1 x 1 pivot block. */
if (ipiv[k] > 0) {
if (k > 1) {
/* Interchange if P(K) .ne. I. */
kp = ipiv[k];
if (kp != k) {
dswap_(nrhs, &b[k + b_dim1], ldb, &b[kp + b_dim1],
ldb);
}
/* Apply the transformation */
i__1 = k - 1;
dgemv_("Transpose", &i__1, nrhs, &c_b15, &b[b_offset],
ldb, &a[k * a_dim1 + 1], &c__1, &c_b15, &b[k +
b_dim1], ldb);
}
if (nounit) {
dscal_(nrhs, &a[k + k * a_dim1], &b[k + b_dim1], ldb);
}
--k;
/* 2 x 2 pivot block. */
} else {
if (k > 2) {
/* Interchange if P(K) .ne. I. */
kp = (i__1 = ipiv[k], abs(i__1));
if (kp != k - 1) {
dswap_(nrhs, &b[k - 1 + b_dim1], ldb, &b[kp + b_dim1],
ldb);
}
/* Apply the transformations */
i__1 = k - 2;
dgemv_("Transpose", &i__1, nrhs, &c_b15, &b[b_offset],
ldb, &a[k * a_dim1 + 1], &c__1, &c_b15, &b[k +
b_dim1], ldb);
i__1 = k - 2;
dgemv_("Transpose", &i__1, nrhs, &c_b15, &b[b_offset],
ldb, &a[(k - 1) * a_dim1 + 1], &c__1, &c_b15, &b[
k - 1 + b_dim1], ldb);
}
/* Multiply by the diagonal block if non-unit. */
if (nounit) {
d11 = a[k - 1 + (k - 1) * a_dim1];
d22 = a[k + k * a_dim1];
d12 = a[k - 1 + k * a_dim1];
d21 = d12;
i__1 = *nrhs;
for (j = 1; j <= i__1; ++j) {
t1 = b[k - 1 + j * b_dim1];
t2 = b[k + j * b_dim1];
b[k - 1 + j * b_dim1] = d11 * t1 + d12 * t2;
b[k + j * b_dim1] = d21 * t1 + d22 * t2;
/* L80: */
}
}
k += -2;
}
goto L70;
L90:
/* Form B := L'*B */
/* where L = P(1)*inv(L(1))* ... *P(m)*inv(L(m)) */
/* and L' = inv(L'(m))*P(m)* ... *inv(L'(1))*P(1) */
;
} else {
/* Loop forward applying the L-transformations. */
k = 1;
L100:
if (k > *n) {
goto L120;
}
/* 1 x 1 pivot block */
if (ipiv[k] > 0) {
if (k < *n) {
/* Interchange if P(K) .ne. I. */
kp = ipiv[k];
if (kp != k) {
dswap_(nrhs, &b[k + b_dim1], ldb, &b[kp + b_dim1],
ldb);
}
/* Apply the transformation */
i__1 = *n - k;
dgemv_("Transpose", &i__1, nrhs, &c_b15, &b[k + 1 +
b_dim1], ldb, &a[k + 1 + k * a_dim1], &c__1, &
c_b15, &b[k + b_dim1], ldb);
}
if (nounit) {
dscal_(nrhs, &a[k + k * a_dim1], &b[k + b_dim1], ldb);
}
++k;
/* 2 x 2 pivot block. */
} else {
if (k < *n - 1) {
/* Interchange if P(K) .ne. I. */
kp = (i__1 = ipiv[k], abs(i__1));
if (kp != k + 1) {
dswap_(nrhs, &b[k + 1 + b_dim1], ldb, &b[kp + b_dim1],
ldb);
}
/* Apply the transformation */
i__1 = *n - k - 1;
dgemv_("Transpose", &i__1, nrhs, &c_b15, &b[k + 2 +
b_dim1], ldb, &a[k + 2 + (k + 1) * a_dim1], &c__1,
&c_b15, &b[k + 1 + b_dim1], ldb);
i__1 = *n - k - 1;
dgemv_("Transpose", &i__1, nrhs, &c_b15, &b[k + 2 +
b_dim1], ldb, &a[k + 2 + k * a_dim1], &c__1, &
c_b15, &b[k + b_dim1], ldb);
}
/* Multiply by the diagonal block if non-unit. */
if (nounit) {
d11 = a[k + k * a_dim1];
d22 = a[k + 1 + (k + 1) * a_dim1];
d21 = a[k + 1 + k * a_dim1];
d12 = d21;
i__1 = *nrhs;
for (j = 1; j <= i__1; ++j) {
t1 = b[k + j * b_dim1];
t2 = b[k + 1 + j * b_dim1];
b[k + j * b_dim1] = d11 * t1 + d12 * t2;
b[k + 1 + j * b_dim1] = d21 * t1 + d22 * t2;
/* L110: */
}
}
k += 2;
}
goto L100;
L120:
;
}
}
return 0;
/* End of DLAVSY */
} /* dlavsy_ */
/* Subroutine */ int dbdsqr_(char *uplo, integer *n, integer *ncvt, integer *
nru, integer *ncc, doublereal *d__, doublereal *e, doublereal *vt,
integer *ldvt, doublereal *u, integer *ldu, doublereal *c__, integer *
ldc, doublereal *work, integer *info)
{
/* System generated locals */
integer c_dim1, c_offset, u_dim1, u_offset, vt_dim1, vt_offset, i__1,
i__2;
doublereal d__1, d__2, d__3, d__4;
/* Builtin functions */
double pow_dd(doublereal *, doublereal *), sqrt(doublereal), d_sign(
doublereal *, doublereal *);
/* Local variables */
static doublereal abse;
static integer idir;
static doublereal abss;
static integer oldm;
static doublereal cosl;
static integer isub, iter;
static doublereal unfl, sinl, cosr, smin, smax, sinr;
extern /* Subroutine */ int drot_(integer *, doublereal *, integer *,
doublereal *, integer *, doublereal *, doublereal *), dlas2_(
doublereal *, doublereal *, doublereal *, doublereal *,
doublereal *);
static doublereal f, g, h__;
static integer i__, j, m;
static doublereal r__;
extern /* Subroutine */ int dscal_(integer *, doublereal *, doublereal *,
integer *);
extern logical lsame_(char *, char *);
static doublereal oldcs;
extern /* Subroutine */ int dlasr_(char *, char *, char *, integer *,
integer *, doublereal *, doublereal *, doublereal *, integer *);
static integer oldll;
static doublereal shift, sigmn, oldsn;
extern /* Subroutine */ int dswap_(integer *, doublereal *, integer *,
doublereal *, integer *);
static integer maxit;
static doublereal sminl, sigmx;
static logical lower;
extern /* Subroutine */ int dlasq1_(integer *, doublereal *, doublereal *,
doublereal *, integer *), dlasv2_(doublereal *, doublereal *,
doublereal *, doublereal *, doublereal *, doublereal *,
doublereal *, doublereal *, doublereal *);
static doublereal cs;
static integer ll;
extern doublereal dlamch_(char *);
static doublereal sn, mu;
extern /* Subroutine */ int dlartg_(doublereal *, doublereal *,
doublereal *, doublereal *, doublereal *), xerbla_(char *,
integer *);
static doublereal sminoa, thresh;
static logical rotate;
static doublereal sminlo;
static integer nm1;
static doublereal tolmul;
static integer nm12, nm13, lll;
static doublereal eps, sll, tol;
#define c___ref(a_1,a_2) c__[(a_2)*c_dim1 + a_1]
#define u_ref(a_1,a_2) u[(a_2)*u_dim1 + a_1]
#define vt_ref(a_1,a_2) vt[(a_2)*vt_dim1 + a_1]
/* -- LAPACK routine (version 3.0) --
Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
Courant Institute, Argonne National Lab, and Rice University
October 31, 1999
Purpose
=======
DBDSQR computes the singular value decomposition (SVD) of a real
N-by-N (upper or lower) bidiagonal matrix B: B = Q * S * P' (P'
denotes the transpose of P), where S is a diagonal matrix with
non-negative diagonal elements (the singular values of B), and Q
and P are orthogonal matrices.
The routine computes S, and optionally computes U * Q, P' * VT,
or Q' * C, for given real input matrices U, VT, and C.
See "Computing Small Singular Values of Bidiagonal Matrices With
Guaranteed High Relative Accuracy," by J. Demmel and W. Kahan,
LAPACK Working Note #3 (or SIAM J. Sci. Statist. Comput. vol. 11,
no. 5, pp. 873-912, Sept 1990) and
"Accurate singular values and differential qd algorithms," by
B. Parlett and V. Fernando, Technical Report CPAM-554, Mathematics
Department, University of California at Berkeley, July 1992
for a detailed description of the algorithm.
Arguments
=========
UPLO (input) CHARACTER*1
= 'U': B is upper bidiagonal;
= 'L': B is lower bidiagonal.
N (input) INTEGER
The order of the matrix B. N >= 0.
NCVT (input) INTEGER
The number of columns of the matrix VT. NCVT >= 0.
NRU (input) INTEGER
The number of rows of the matrix U. NRU >= 0.
NCC (input) INTEGER
The number of columns of the matrix C. NCC >= 0.
D (input/output) DOUBLE PRECISION array, dimension (N)
On entry, the n diagonal elements of the bidiagonal matrix B.
On exit, if INFO=0, the singular values of B in decreasing
order.
E (input/output) DOUBLE PRECISION array, dimension (N)
On entry, the elements of E contain the
offdiagonal elements of the bidiagonal matrix whose SVD
is desired. On normal exit (INFO = 0), E is destroyed.
If the algorithm does not converge (INFO > 0), D and E
will contain the diagonal and superdiagonal elements of a
bidiagonal matrix orthogonally equivalent to the one given
as input. E(N) is used for workspace.
VT (input/output) DOUBLE PRECISION array, dimension (LDVT, NCVT)
On entry, an N-by-NCVT matrix VT.
On exit, VT is overwritten by P' * VT.
VT is not referenced if NCVT = 0.
LDVT (input) INTEGER
The leading dimension of the array VT.
LDVT >= max(1,N) if NCVT > 0; LDVT >= 1 if NCVT = 0.
U (input/output) DOUBLE PRECISION array, dimension (LDU, N)
On entry, an NRU-by-N matrix U.
On exit, U is overwritten by U * Q.
U is not referenced if NRU = 0.
LDU (input) INTEGER
The leading dimension of the array U. LDU >= max(1,NRU).
C (input/output) DOUBLE PRECISION array, dimension (LDC, NCC)
On entry, an N-by-NCC matrix C.
On exit, C is overwritten by Q' * C.
C is not referenced if NCC = 0.
LDC (input) INTEGER
The leading dimension of the array C.
LDC >= max(1,N) if NCC > 0; LDC >=1 if NCC = 0.
WORK (workspace) DOUBLE PRECISION array, dimension (4*N)
INFO (output) INTEGER
= 0: successful exit
< 0: If INFO = -i, the i-th argument had an illegal value
> 0: the algorithm did not converge; D and E contain the
elements of a bidiagonal matrix which is orthogonally
similar to the input matrix B; if INFO = i, i
elements of E have not converged to zero.
Internal Parameters
===================
TOLMUL DOUBLE PRECISION, default = max(10,min(100,EPS**(-1/8)))
TOLMUL controls the convergence criterion of the QR loop.
If it is positive, TOLMUL*EPS is the desired relative
precision in the computed singular values.
If it is negative, abs(TOLMUL*EPS*sigma_max) is the
desired absolute accuracy in the computed singular
values (corresponds to relative accuracy
abs(TOLMUL*EPS) in the largest singular value.
abs(TOLMUL) should be between 1 and 1/EPS, and preferably
between 10 (for fast convergence) and .1/EPS
(for there to be some accuracy in the results).
Default is to lose at either one eighth or 2 of the
available decimal digits in each computed singular value
(whichever is smaller).
MAXITR INTEGER, default = 6
MAXITR controls the maximum number of passes of the
algorithm through its inner loop. The algorithms stops
(and so fails to converge) if the number of passes
through the inner loop exceeds MAXITR*N**2.
=====================================================================
Test the input parameters.
Parameter adjustments */
--d__;
--e;
vt_dim1 = *ldvt;
vt_offset = 1 + vt_dim1 * 1;
vt -= vt_offset;
u_dim1 = *ldu;
u_offset = 1 + u_dim1 * 1;
u -= u_offset;
c_dim1 = *ldc;
c_offset = 1 + c_dim1 * 1;
c__ -= c_offset;
--work;
/* Function Body */
*info = 0;
lower = lsame_(uplo, "L");
if (! lsame_(uplo, "U") && ! lower) {
*info = -1;
} else if (*n < 0) {
*info = -2;
} else if (*ncvt < 0) {
*info = -3;
} else if (*nru < 0) {
*info = -4;
} else if (*ncc < 0) {
*info = -5;
} else if ((*ncvt == 0 && *ldvt < 1) ||
(*ncvt > 0 && *ldvt < max(1,*n))) {
*info = -9;
} else if (*ldu < max(1,*nru)) {
*info = -11;
} else if ((*ncc == 0 && *ldc < 1) ||
(*ncc > 0 && *ldc < max(1,*n))) {
*info = -13;
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("DBDSQR", &i__1);
return 0;
}
if (*n == 0) {
return 0;
}
if (*n == 1) {
goto L160;
}
/* ROTATE is true if any singular vectors desired, false otherwise */
rotate = *ncvt > 0 || *nru > 0 || *ncc > 0;
/* If no singular vectors desired, use qd algorithm */
if (! rotate) {
dlasq1_(n, &d__[1], &e[1], &work[1], info);
return 0;
}
nm1 = *n - 1;
nm12 = nm1 + nm1;
nm13 = nm12 + nm1;
idir = 0;
/* Get machine constants */
eps = dlamch_("Epsilon");
unfl = dlamch_("Safe minimum");
/* If matrix lower bidiagonal, rotate to be upper bidiagonal
by applying Givens rotations on the left */
if (lower) {
i__1 = *n - 1;
for (i__ = 1; i__ <= i__1; ++i__) {
dlartg_(&d__[i__], &e[i__], &cs, &sn, &r__);
d__[i__] = r__;
e[i__] = sn * d__[i__ + 1];
d__[i__ + 1] = cs * d__[i__ + 1];
work[i__] = cs;
work[nm1 + i__] = sn;
/* L10: */
}
/* Update singular vectors if desired */
if (*nru > 0) {
dlasr_("R", "V", "F", nru, n, &work[1], &work[*n], &u[u_offset],
ldu);
}
if (*ncc > 0) {
dlasr_("L", "V", "F", n, ncc, &work[1], &work[*n], &c__[c_offset],
ldc);
}
}
/* Compute singular values to relative accuracy TOL
(By setting TOL to be negative, algorithm will compute
singular values to absolute accuracy ABS(TOL)*norm(input matrix))
Computing MAX
Computing MIN */
d__3 = 100., d__4 = pow_dd(&eps, &c_b15);
d__1 = 10., d__2 = min(d__3,d__4);
tolmul = max(d__1,d__2);
tol = tolmul * eps;
/* Compute approximate maximum, minimum singular values */
smax = 0.;
i__1 = *n;
for (i__ = 1; i__ <= i__1; ++i__) {
/* Computing MAX */
d__2 = smax, d__3 = (d__1 = d__[i__], abs(d__1));
smax = max(d__2,d__3);
/* L20: */
}
i__1 = *n - 1;
for (i__ = 1; i__ <= i__1; ++i__) {
/* Computing MAX */
d__2 = smax, d__3 = (d__1 = e[i__], abs(d__1));
smax = max(d__2,d__3);
/* L30: */
}
sminl = 0.;
if (tol >= 0.) {
/* Relative accuracy desired */
sminoa = abs(d__[1]);
if (sminoa == 0.) {
goto L50;
}
mu = sminoa;
i__1 = *n;
for (i__ = 2; i__ <= i__1; ++i__) {
mu = (d__2 = d__[i__], abs(d__2)) * (mu / (mu + (d__1 = e[i__ - 1]
, abs(d__1))));
sminoa = min(sminoa,mu);
if (sminoa == 0.) {
goto L50;
}
/* L40: */
}
L50:
sminoa /= sqrt((doublereal) (*n));
/* Computing MAX */
d__1 = tol * sminoa, d__2 = *n * 6 * *n * unfl;
thresh = max(d__1,d__2);
} else {
/* Absolute accuracy desired
Computing MAX */
d__1 = abs(tol) * smax, d__2 = *n * 6 * *n * unfl;
thresh = max(d__1,d__2);
}
/* Prepare for main iteration loop for the singular values
(MAXIT is the maximum number of passes through the inner
loop permitted before nonconvergence signalled.) */
maxit = *n * 6 * *n;
iter = 0;
oldll = -1;
oldm = -1;
/* M points to last element of unconverged part of matrix */
m = *n;
/* Begin main iteration loop */
L60:
/* Check for convergence or exceeding iteration count */
if (m <= 1) {
goto L160;
}
if (iter > maxit) {
goto L200;
}
/* Find diagonal block of matrix to work on */
if (tol < 0. && (d__1 = d__[m], abs(d__1)) <= thresh) {
d__[m] = 0.;
}
smax = (d__1 = d__[m], abs(d__1));
smin = smax;
i__1 = m - 1;
for (lll = 1; lll <= i__1; ++lll) {
ll = m - lll;
abss = (d__1 = d__[ll], abs(d__1));
abse = (d__1 = e[ll], abs(d__1));
if (tol < 0. && abss <= thresh) {
d__[ll] = 0.;
}
if (abse <= thresh) {
goto L80;
}
smin = min(smin,abss);
/* Computing MAX */
d__1 = max(smax,abss);
smax = max(d__1,abse);
/* L70: */
}
ll = 0;
goto L90;
L80:
e[ll] = 0.;
/* Matrix splits since E(LL) = 0 */
if (ll == m - 1) {
/* Convergence of bottom singular value, return to top of loop */
--m;
goto L60;
}
L90:
++ll;
/* E(LL) through E(M-1) are nonzero, E(LL-1) is zero */
if (ll == m - 1) {
/* 2 by 2 block, handle separately */
dlasv2_(&d__[m - 1], &e[m - 1], &d__[m], &sigmn, &sigmx, &sinr, &cosr,
&sinl, &cosl);
d__[m - 1] = sigmx;
e[m - 1] = 0.;
d__[m] = sigmn;
/* Compute singular vectors, if desired */
if (*ncvt > 0) {
drot_(ncvt, &vt_ref(m - 1, 1), ldvt, &vt_ref(m, 1), ldvt, &cosr, &
sinr);
}
if (*nru > 0) {
drot_(nru, &u_ref(1, m - 1), &c__1, &u_ref(1, m), &c__1, &cosl, &
sinl);
}
if (*ncc > 0) {
drot_(ncc, &c___ref(m - 1, 1), ldc, &c___ref(m, 1), ldc, &cosl, &
sinl);
}
m += -2;
goto L60;
}
/* If working on new submatrix, choose shift direction
(from larger end diagonal element towards smaller) */
if (ll > oldm || m < oldll) {
if ((d__1 = d__[ll], abs(d__1)) >= (d__2 = d__[m], abs(d__2))) {
/* Chase bulge from top (big end) to bottom (small end) */
idir = 1;
} else {
/* Chase bulge from bottom (big end) to top (small end) */
idir = 2;
}
}
/* Apply convergence tests */
if (idir == 1) {
/* Run convergence test in forward direction
First apply standard test to bottom of matrix */
if (((d__2 = e[m - 1], abs(d__2)) <=
abs(tol) * (d__1 = d__[m], abs(d__1))) ||
(tol < 0. && (d__3 = e[m - 1], abs(d__3)) <= thresh))
{
e[m - 1] = 0.;
goto L60;
}
if (tol >= 0.) {
/* If relative accuracy desired,
apply convergence criterion forward */
mu = (d__1 = d__[ll], abs(d__1));
sminl = mu;
i__1 = m - 1;
for (lll = ll; lll <= i__1; ++lll) {
if ((d__1 = e[lll], abs(d__1)) <= tol * mu) {
e[lll] = 0.;
goto L60;
}
sminlo = sminl;
mu = (d__2 = d__[lll + 1], abs(d__2)) * (mu / (mu + (d__1 = e[
lll], abs(d__1))));
sminl = min(sminl,mu);
/* L100: */
}
}
} else {
/* Run convergence test in backward direction
First apply standard test to top of matrix */
if ((d__2 = e[ll], abs(d__2)) <= abs(tol) * (d__1 = d__[ll], abs(d__1)
) ||
(tol < 0. && (d__3 = e[ll], abs(d__3)) <= thresh)) {
e[ll] = 0.;
goto L60;
}
if (tol >= 0.) {
/* If relative accuracy desired,
apply convergence criterion backward */
mu = (d__1 = d__[m], abs(d__1));
sminl = mu;
i__1 = ll;
for (lll = m - 1; lll >= i__1; --lll) {
if ((d__1 = e[lll], abs(d__1)) <= tol * mu) {
e[lll] = 0.;
goto L60;
}
sminlo = sminl;
mu = (d__2 = d__[lll], abs(d__2)) * (mu / (mu + (d__1 = e[lll]
, abs(d__1))));
sminl = min(sminl,mu);
/* L110: */
}
}
}
oldll = ll;
oldm = m;
/* Compute shift. First, test if shifting would ruin relative
accuracy, and if so set the shift to zero.
Computing MAX */
d__1 = eps, d__2 = tol * .01;
if (tol >= 0. && *n * tol * (sminl / smax) <= max(d__1,d__2)) {
/* Use a zero shift to avoid loss of relative accuracy */
shift = 0.;
} else {
/* Compute the shift from 2-by-2 block at end of matrix */
if (idir == 1) {
sll = (d__1 = d__[ll], abs(d__1));
dlas2_(&d__[m - 1], &e[m - 1], &d__[m], &shift, &r__);
} else {
sll = (d__1 = d__[m], abs(d__1));
dlas2_(&d__[ll], &e[ll], &d__[ll + 1], &shift, &r__);
}
/* Test if shift negligible, and if so set to zero */
if (sll > 0.) {
/* Computing 2nd power */
d__1 = shift / sll;
if (d__1 * d__1 < eps) {
shift = 0.;
}
}
}
/* Increment iteration count */
iter = iter + m - ll;
/* If SHIFT = 0, do simplified QR iteration */
if (shift == 0.) {
if (idir == 1) {
/* Chase bulge from top to bottom
Save cosines and sines for later singular vector updates */
cs = 1.;
oldcs = 1.;
i__1 = m - 1;
for (i__ = ll; i__ <= i__1; ++i__) {
d__1 = d__[i__] * cs;
dlartg_(&d__1, &e[i__], &cs, &sn, &r__);
if (i__ > ll) {
e[i__ - 1] = oldsn * r__;
}
d__1 = oldcs * r__;
d__2 = d__[i__ + 1] * sn;
dlartg_(&d__1, &d__2, &oldcs, &oldsn, &d__[i__]);
work[i__ - ll + 1] = cs;
work[i__ - ll + 1 + nm1] = sn;
work[i__ - ll + 1 + nm12] = oldcs;
work[i__ - ll + 1 + nm13] = oldsn;
/* L120: */
}
h__ = d__[m] * cs;
d__[m] = h__ * oldcs;
e[m - 1] = h__ * oldsn;
/* Update singular vectors */
if (*ncvt > 0) {
i__1 = m - ll + 1;
dlasr_("L", "V", "F", &i__1, ncvt, &work[1], &work[*n], &
vt_ref(ll, 1), ldvt);
}
if (*nru > 0) {
i__1 = m - ll + 1;
dlasr_("R", "V", "F", nru, &i__1, &work[nm12 + 1], &work[nm13
+ 1], &u_ref(1, ll), ldu);
}
if (*ncc > 0) {
i__1 = m - ll + 1;
dlasr_("L", "V", "F", &i__1, ncc, &work[nm12 + 1], &work[nm13
+ 1], &c___ref(ll, 1), ldc);
}
/* Test convergence */
if ((d__1 = e[m - 1], abs(d__1)) <= thresh) {
e[m - 1] = 0.;
}
} else {
/* Chase bulge from bottom to top
Save cosines and sines for later singular vector updates */
cs = 1.;
oldcs = 1.;
i__1 = ll + 1;
for (i__ = m; i__ >= i__1; --i__) {
d__1 = d__[i__] * cs;
dlartg_(&d__1, &e[i__ - 1], &cs, &sn, &r__);
if (i__ < m) {
e[i__] = oldsn * r__;
}
d__1 = oldcs * r__;
d__2 = d__[i__ - 1] * sn;
dlartg_(&d__1, &d__2, &oldcs, &oldsn, &d__[i__]);
work[i__ - ll] = cs;
work[i__ - ll + nm1] = -sn;
work[i__ - ll + nm12] = oldcs;
work[i__ - ll + nm13] = -oldsn;
/* L130: */
}
h__ = d__[ll] * cs;
d__[ll] = h__ * oldcs;
e[ll] = h__ * oldsn;
/* Update singular vectors */
if (*ncvt > 0) {
i__1 = m - ll + 1;
dlasr_("L", "V", "B", &i__1, ncvt, &work[nm12 + 1], &work[
nm13 + 1], &vt_ref(ll, 1), ldvt);
}
if (*nru > 0) {
i__1 = m - ll + 1;
dlasr_("R", "V", "B", nru, &i__1, &work[1], &work[*n], &u_ref(
1, ll), ldu);
}
if (*ncc > 0) {
i__1 = m - ll + 1;
dlasr_("L", "V", "B", &i__1, ncc, &work[1], &work[*n], &
c___ref(ll, 1), ldc);
}
/* Test convergence */
if ((d__1 = e[ll], abs(d__1)) <= thresh) {
e[ll] = 0.;
}
}
} else {
/* Use nonzero shift */
if (idir == 1) {
/* Chase bulge from top to bottom
Save cosines and sines for later singular vector updates */
f = ((d__1 = d__[ll], abs(d__1)) - shift) * (d_sign(&c_b49, &d__[
ll]) + shift / d__[ll]);
g = e[ll];
i__1 = m - 1;
for (i__ = ll; i__ <= i__1; ++i__) {
dlartg_(&f, &g, &cosr, &sinr, &r__);
if (i__ > ll) {
e[i__ - 1] = r__;
}
f = cosr * d__[i__] + sinr * e[i__];
e[i__] = cosr * e[i__] - sinr * d__[i__];
g = sinr * d__[i__ + 1];
d__[i__ + 1] = cosr * d__[i__ + 1];
dlartg_(&f, &g, &cosl, &sinl, &r__);
d__[i__] = r__;
f = cosl * e[i__] + sinl * d__[i__ + 1];
d__[i__ + 1] = cosl * d__[i__ + 1] - sinl * e[i__];
if (i__ < m - 1) {
g = sinl * e[i__ + 1];
e[i__ + 1] = cosl * e[i__ + 1];
}
work[i__ - ll + 1] = cosr;
work[i__ - ll + 1 + nm1] = sinr;
work[i__ - ll + 1 + nm12] = cosl;
work[i__ - ll + 1 + nm13] = sinl;
/* L140: */
}
e[m - 1] = f;
/* Update singular vectors */
if (*ncvt > 0) {
i__1 = m - ll + 1;
dlasr_("L", "V", "F", &i__1, ncvt, &work[1], &work[*n], &
vt_ref(ll, 1), ldvt);
}
if (*nru > 0) {
i__1 = m - ll + 1;
dlasr_("R", "V", "F", nru, &i__1, &work[nm12 + 1], &work[nm13
+ 1], &u_ref(1, ll), ldu);
}
if (*ncc > 0) {
i__1 = m - ll + 1;
dlasr_("L", "V", "F", &i__1, ncc, &work[nm12 + 1], &work[nm13
+ 1], &c___ref(ll, 1), ldc);
}
/* Test convergence */
if ((d__1 = e[m - 1], abs(d__1)) <= thresh) {
e[m - 1] = 0.;
}
} else {
/* Chase bulge from bottom to top
Save cosines and sines for later singular vector updates */
f = ((d__1 = d__[m], abs(d__1)) - shift) * (d_sign(&c_b49, &d__[m]
) + shift / d__[m]);
g = e[m - 1];
i__1 = ll + 1;
for (i__ = m; i__ >= i__1; --i__) {
dlartg_(&f, &g, &cosr, &sinr, &r__);
if (i__ < m) {
e[i__] = r__;
}
f = cosr * d__[i__] + sinr * e[i__ - 1];
e[i__ - 1] = cosr * e[i__ - 1] - sinr * d__[i__];
g = sinr * d__[i__ - 1];
d__[i__ - 1] = cosr * d__[i__ - 1];
dlartg_(&f, &g, &cosl, &sinl, &r__);
d__[i__] = r__;
f = cosl * e[i__ - 1] + sinl * d__[i__ - 1];
d__[i__ - 1] = cosl * d__[i__ - 1] - sinl * e[i__ - 1];
if (i__ > ll + 1) {
g = sinl * e[i__ - 2];
e[i__ - 2] = cosl * e[i__ - 2];
}
work[i__ - ll] = cosr;
work[i__ - ll + nm1] = -sinr;
work[i__ - ll + nm12] = cosl;
work[i__ - ll + nm13] = -sinl;
/* L150: */
}
e[ll] = f;
/* Test convergence */
if ((d__1 = e[ll], abs(d__1)) <= thresh) {
e[ll] = 0.;
}
/* Update singular vectors if desired */
if (*ncvt > 0) {
i__1 = m - ll + 1;
dlasr_("L", "V", "B", &i__1, ncvt, &work[nm12 + 1], &work[
nm13 + 1], &vt_ref(ll, 1), ldvt);
}
if (*nru > 0) {
i__1 = m - ll + 1;
dlasr_("R", "V", "B", nru, &i__1, &work[1], &work[*n], &u_ref(
1, ll), ldu);
}
if (*ncc > 0) {
i__1 = m - ll + 1;
dlasr_("L", "V", "B", &i__1, ncc, &work[1], &work[*n], &
c___ref(ll, 1), ldc);
}
}
}
/* QR iteration finished, go back and check convergence */
goto L60;
/* All singular values converged, so make them positive */
L160:
i__1 = *n;
for (i__ = 1; i__ <= i__1; ++i__) {
if (d__[i__] < 0.) {
d__[i__] = -d__[i__];
/* Change sign of singular vectors, if desired */
if (*ncvt > 0) {
dscal_(ncvt, &c_b72, &vt_ref(i__, 1), ldvt);
}
}
/* L170: */
}
/* Sort the singular values into decreasing order (insertion sort on
singular values, but only one transposition per singular vector) */
i__1 = *n - 1;
for (i__ = 1; i__ <= i__1; ++i__) {
/* Scan for smallest D(I) */
isub = 1;
smin = d__[1];
i__2 = *n + 1 - i__;
for (j = 2; j <= i__2; ++j) {
if (d__[j] <= smin) {
isub = j;
smin = d__[j];
}
/* L180: */
}
if (isub != *n + 1 - i__) {
/* Swap singular values and vectors */
d__[isub] = d__[*n + 1 - i__];
d__[*n + 1 - i__] = smin;
if (*ncvt > 0) {
dswap_(ncvt, &vt_ref(isub, 1), ldvt, &vt_ref(*n + 1 - i__, 1),
ldvt);
}
if (*nru > 0) {
dswap_(nru, &u_ref(1, isub), &c__1, &u_ref(1, *n + 1 - i__), &
c__1);
}
if (*ncc > 0) {
dswap_(ncc, &c___ref(isub, 1), ldc, &c___ref(*n + 1 - i__, 1),
ldc);
}
}
/* L190: */
}
goto L220;
/* Maximum number of iterations exceeded, failure to converge */
L200:
*info = 0;
i__1 = *n - 1;
for (i__ = 1; i__ <= i__1; ++i__) {
if (e[i__] != 0.) {
++(*info);
}
/* L210: */
}
L220:
return 0;
/* End of DBDSQR */
} /* dbdsqr_ */
int dbdsdc_(char *uplo, char *compq, int *n, double *
d__, double *e, double *u, int *ldu, double *vt,
int *ldvt, double *q, int *iq, double *work, int *
iwork, int *info)
{
/* System generated locals */
int u_dim1, u_offset, vt_dim1, vt_offset, i__1, i__2;
double d__1;
/* Builtin functions */
double d_sign(double *, double *), log(double);
/* Local variables */
int i__, j, k;
double p, r__;
int z__, ic, ii, kk;
double cs;
int is, iu;
double sn;
int nm1;
double eps;
int ivt, difl, difr, ierr, perm, mlvl, sqre;
extern int lsame_(char *, char *);
extern int dlasr_(char *, char *, char *, int *,
int *, double *, double *, double *, int *), dcopy_(int *, double *, int *
, double *, int *), dswap_(int *, double *,
int *, double *, int *);
int poles, iuplo, nsize, start;
extern int dlasd0_(int *, int *, double *,
double *, double *, int *, double *, int *,
int *, int *, double *, int *);
extern double dlamch_(char *);
extern int dlasda_(int *, int *, int *,
int *, double *, double *, double *, int *,
double *, int *, double *, double *, double *,
double *, int *, int *, int *, int *,
double *, double *, double *, double *, int *,
int *), dlascl_(char *, int *, int *, double *,
double *, int *, int *, double *, int *,
int *), dlasdq_(char *, int *, int *, int
*, int *, int *, double *, double *, double *,
int *, double *, int *, double *, int *,
double *, int *), dlaset_(char *, int *,
int *, double *, double *, double *, int *), dlartg_(double *, double *, double *,
double *, double *);
extern int ilaenv_(int *, char *, char *, int *, int *,
int *, int *);
extern int xerbla_(char *, int *);
int givcol;
extern double dlanst_(char *, int *, double *, double *);
int icompq;
double orgnrm;
int givnum, givptr, qstart, smlsiz, wstart, smlszp;
/* -- LAPACK routine (version 3.2) -- */
/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/* November 2006 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* DBDSDC computes the singular value decomposition (SVD) of a float */
/* N-by-N (upper or lower) bidiagonal matrix B: B = U * S * VT, */
/* using a divide and conquer method, where S is a diagonal matrix */
/* with non-negative diagonal elements (the singular values of B), and */
/* U and VT are orthogonal matrices of left and right singular vectors, */
/* respectively. DBDSDC can be used to compute all singular values, */
/* and optionally, singular vectors or singular vectors in compact form. */
/* 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 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. See DLASD3 for details. */
/* The code currently calls DLASDQ if singular values only are desired. */
/* However, it can be slightly modified to compute singular values */
/* using the divide and conquer method. */
/* Arguments */
/* ========= */
/* UPLO (input) CHARACTER*1 */
/* = 'U': B is upper bidiagonal. */
/* = 'L': B is lower bidiagonal. */
/* COMPQ (input) CHARACTER*1 */
/* Specifies whether singular vectors are to be computed */
/* as follows: */
/* = 'N': Compute singular values only; */
/* = 'P': Compute singular values and compute singular */
/* vectors in compact form; */
/* = 'I': Compute singular values and singular vectors. */
/* N (input) INTEGER */
/* The order of the matrix B. N >= 0. */
/* D (input/output) DOUBLE PRECISION array, dimension (N) */
/* On entry, the n diagonal elements of the bidiagonal matrix B. */
/* On exit, if INFO=0, the singular values of B. */
/* E (input/output) DOUBLE PRECISION array, dimension (N-1) */
/* On entry, the elements of E contain the offdiagonal */
/* elements of the bidiagonal matrix whose SVD is desired. */
/* On exit, E has been destroyed. */
/* U (output) DOUBLE PRECISION array, dimension (LDU,N) */
/* If COMPQ = 'I', then: */
/* On exit, if INFO = 0, U contains the left singular vectors */
/* of the bidiagonal matrix. */
/* For other values of COMPQ, U is not referenced. */
/* LDU (input) INTEGER */
/* The leading dimension of the array U. LDU >= 1. */
/* If singular vectors are desired, then LDU >= MAX( 1, N ). */
/* VT (output) DOUBLE PRECISION array, dimension (LDVT,N) */
/* If COMPQ = 'I', then: */
/* On exit, if INFO = 0, VT' contains the right singular */
/* vectors of the bidiagonal matrix. */
/* For other values of COMPQ, VT is not referenced. */
/* LDVT (input) INTEGER */
/* The leading dimension of the array VT. LDVT >= 1. */
/* If singular vectors are desired, then LDVT >= MAX( 1, N ). */
/* Q (output) DOUBLE PRECISION array, dimension (LDQ) */
/* If COMPQ = 'P', then: */
/* On exit, if INFO = 0, Q and IQ contain the left */
/* and right singular vectors in a compact form, */
/* requiring O(N log N) space instead of 2*N**2. */
/* In particular, Q contains all the DOUBLE PRECISION data in */
/* LDQ >= N*(11 + 2*SMLSIZ + 8*INT(LOG_2(N/(SMLSIZ+1)))) */
/* words of memory, where 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). */
/* For other values of COMPQ, Q is not referenced. */
/* IQ (output) INTEGER array, dimension (LDIQ) */
/* If COMPQ = 'P', then: */
/* On exit, if INFO = 0, Q and IQ contain the left */
/* and right singular vectors in a compact form, */
/* requiring O(N log N) space instead of 2*N**2. */
/* In particular, IQ contains all INTEGER data in */
/* LDIQ >= N*(3 + 3*INT(LOG_2(N/(SMLSIZ+1)))) */
/* words of memory, where 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). */
/* For other values of COMPQ, IQ is not referenced. */
/* WORK (workspace) DOUBLE PRECISION array, dimension (MAX(1,LWORK)) */
/* If COMPQ = 'N' then LWORK >= (4 * N). */
/* If COMPQ = 'P' then LWORK >= (6 * N). */
/* If COMPQ = 'I' then LWORK >= (3 * N**2 + 4 * N). */
/* IWORK (workspace) INTEGER array, dimension (8*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. */
/* The update process of divide and conquer failed. */
/* Further Details */
/* =============== */
/* Based on contributions by */
/* Ming Gu and Huan Ren, Computer Science Division, University of */
/* California at Berkeley, USA */
/* ===================================================================== */
/* Changed dimension statement in comment describing E from (N) to */
/* (N-1). Sven, 17 Feb 05. */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Executable Statements .. */
/* Test the input parameters. */
/* Parameter adjustments */
--d__;
--e;
u_dim1 = *ldu;
u_offset = 1 + u_dim1;
u -= u_offset;
vt_dim1 = *ldvt;
vt_offset = 1 + vt_dim1;
vt -= vt_offset;
--q;
--iq;
--work;
--iwork;
/* Function Body */
*info = 0;
iuplo = 0;
if (lsame_(uplo, "U")) {
iuplo = 1;
}
if (lsame_(uplo, "L")) {
iuplo = 2;
}
if (lsame_(compq, "N")) {
icompq = 0;
} else if (lsame_(compq, "P")) {
icompq = 1;
} else if (lsame_(compq, "I")) {
icompq = 2;
} else {
icompq = -1;
}
if (iuplo == 0) {
*info = -1;
} else if (icompq < 0) {
*info = -2;
} else if (*n < 0) {
*info = -3;
} else if (*ldu < 1 || icompq == 2 && *ldu < *n) {
*info = -7;
} else if (*ldvt < 1 || icompq == 2 && *ldvt < *n) {
*info = -9;
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("DBDSDC", &i__1);
return 0;
}
/* Quick return if possible */
if (*n == 0) {
return 0;
}
smlsiz = ilaenv_(&c__9, "DBDSDC", " ", &c__0, &c__0, &c__0, &c__0);
if (*n == 1) {
if (icompq == 1) {
q[1] = d_sign(&c_b15, &d__[1]);
q[smlsiz * *n + 1] = 1.;
} else if (icompq == 2) {
u[u_dim1 + 1] = d_sign(&c_b15, &d__[1]);
vt[vt_dim1 + 1] = 1.;
}
d__[1] = ABS(d__[1]);
return 0;
}
nm1 = *n - 1;
/* If matrix lower bidiagonal, rotate to be upper bidiagonal */
/* by applying Givens rotations on the left */
wstart = 1;
qstart = 3;
if (icompq == 1) {
dcopy_(n, &d__[1], &c__1, &q[1], &c__1);
i__1 = *n - 1;
dcopy_(&i__1, &e[1], &c__1, &q[*n + 1], &c__1);
}
if (iuplo == 2) {
qstart = 5;
wstart = (*n << 1) - 1;
i__1 = *n - 1;
for (i__ = 1; i__ <= i__1; ++i__) {
dlartg_(&d__[i__], &e[i__], &cs, &sn, &r__);
d__[i__] = r__;
e[i__] = sn * d__[i__ + 1];
d__[i__ + 1] = cs * d__[i__ + 1];
if (icompq == 1) {
q[i__ + (*n << 1)] = cs;
q[i__ + *n * 3] = sn;
} else if (icompq == 2) {
work[i__] = cs;
work[nm1 + i__] = -sn;
}
/* L10: */
}
}
/* If ICOMPQ = 0, use DLASDQ to compute the singular values. */
if (icompq == 0) {
dlasdq_("U", &c__0, n, &c__0, &c__0, &c__0, &d__[1], &e[1], &vt[
vt_offset], ldvt, &u[u_offset], ldu, &u[u_offset], ldu, &work[
wstart], info);
goto L40;
}
/* If N is smaller than the minimum divide size SMLSIZ, then solve */
/* the problem with another solver. */
if (*n <= smlsiz) {
if (icompq == 2) {
dlaset_("A", n, n, &c_b29, &c_b15, &u[u_offset], ldu);
dlaset_("A", n, n, &c_b29, &c_b15, &vt[vt_offset], ldvt);
dlasdq_("U", &c__0, n, n, n, &c__0, &d__[1], &e[1], &vt[vt_offset]
, ldvt, &u[u_offset], ldu, &u[u_offset], ldu, &work[
wstart], info);
} else if (icompq == 1) {
iu = 1;
ivt = iu + *n;
dlaset_("A", n, n, &c_b29, &c_b15, &q[iu + (qstart - 1) * *n], n);
dlaset_("A", n, n, &c_b29, &c_b15, &q[ivt + (qstart - 1) * *n], n);
dlasdq_("U", &c__0, n, n, n, &c__0, &d__[1], &e[1], &q[ivt + (
qstart - 1) * *n], n, &q[iu + (qstart - 1) * *n], n, &q[
iu + (qstart - 1) * *n], n, &work[wstart], info);
}
goto L40;
}
if (icompq == 2) {
dlaset_("A", n, n, &c_b29, &c_b15, &u[u_offset], ldu);
dlaset_("A", n, n, &c_b29, &c_b15, &vt[vt_offset], ldvt);
}
/* Scale. */
orgnrm = dlanst_("M", n, &d__[1], &e[1]);
if (orgnrm == 0.) {
return 0;
}
dlascl_("G", &c__0, &c__0, &orgnrm, &c_b15, n, &c__1, &d__[1], n, &ierr);
dlascl_("G", &c__0, &c__0, &orgnrm, &c_b15, &nm1, &c__1, &e[1], &nm1, &
ierr);
eps = dlamch_("Epsilon");
mlvl = (int) (log((double) (*n) / (double) (smlsiz + 1)) /
log(2.)) + 1;
smlszp = smlsiz + 1;
if (icompq == 1) {
iu = 1;
ivt = smlsiz + 1;
difl = ivt + smlszp;
difr = difl + mlvl;
z__ = difr + (mlvl << 1);
ic = z__ + mlvl;
is = ic + 1;
poles = is + 1;
givnum = poles + (mlvl << 1);
k = 1;
givptr = 2;
perm = 3;
givcol = perm + mlvl;
}
i__1 = *n;
for (i__ = 1; i__ <= i__1; ++i__) {
if ((d__1 = d__[i__], ABS(d__1)) < eps) {
d__[i__] = d_sign(&eps, &d__[i__]);
}
/* L20: */
}
start = 1;
sqre = 0;
i__1 = nm1;
for (i__ = 1; i__ <= i__1; ++i__) {
if ((d__1 = e[i__], ABS(d__1)) < eps || i__ == nm1) {
/* 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__ - start + 1;
} else if ((d__1 = e[i__], ABS(d__1)) >= eps) {
/* A subproblem with E(NM1) not too small but I = NM1. */
nsize = *n - start + 1;
} else {
/* A subproblem with E(NM1) small. This implies an */
/* 1-by-1 subproblem at D(N). Solve this 1-by-1 problem */
/* first. */
nsize = i__ - start + 1;
if (icompq == 2) {
u[*n + *n * u_dim1] = d_sign(&c_b15, &d__[*n]);
vt[*n + *n * vt_dim1] = 1.;
} else if (icompq == 1) {
q[*n + (qstart - 1) * *n] = d_sign(&c_b15, &d__[*n]);
q[*n + (smlsiz + qstart - 1) * *n] = 1.;
}
d__[*n] = (d__1 = d__[*n], ABS(d__1));
}
if (icompq == 2) {
dlasd0_(&nsize, &sqre, &d__[start], &e[start], &u[start +
start * u_dim1], ldu, &vt[start + start * vt_dim1],
ldvt, &smlsiz, &iwork[1], &work[wstart], info);
} else {
dlasda_(&icompq, &smlsiz, &nsize, &sqre, &d__[start], &e[
start], &q[start + (iu + qstart - 2) * *n], n, &q[
start + (ivt + qstart - 2) * *n], &iq[start + k * *n],
&q[start + (difl + qstart - 2) * *n], &q[start + (
difr + qstart - 2) * *n], &q[start + (z__ + qstart -
2) * *n], &q[start + (poles + qstart - 2) * *n], &iq[
start + givptr * *n], &iq[start + givcol * *n], n, &
iq[start + perm * *n], &q[start + (givnum + qstart -
2) * *n], &q[start + (ic + qstart - 2) * *n], &q[
start + (is + qstart - 2) * *n], &work[wstart], &
iwork[1], info);
if (*info != 0) {
return 0;
}
}
start = i__ + 1;
}
/* L30: */
}
/* Unscale */
dlascl_("G", &c__0, &c__0, &c_b15, &orgnrm, n, &c__1, &d__[1], n, &ierr);
L40:
/* Use Selection Sort to minimize swaps of singular vectors */
i__1 = *n;
for (ii = 2; ii <= i__1; ++ii) {
i__ = ii - 1;
kk = i__;
p = d__[i__];
i__2 = *n;
for (j = ii; j <= i__2; ++j) {
if (d__[j] > p) {
kk = j;
p = d__[j];
}
/* L50: */
}
if (kk != i__) {
d__[kk] = d__[i__];
d__[i__] = p;
if (icompq == 1) {
iq[i__] = kk;
} else if (icompq == 2) {
dswap_(n, &u[i__ * u_dim1 + 1], &c__1, &u[kk * u_dim1 + 1], &
c__1);
dswap_(n, &vt[i__ + vt_dim1], ldvt, &vt[kk + vt_dim1], ldvt);
}
} else if (icompq == 1) {
iq[i__] = i__;
}
/* L60: */
}
/* If ICOMPQ = 1, use IQ(N,1) as the indicator for UPLO */
if (icompq == 1) {
if (iuplo == 1) {
iq[*n] = 1;
} else {
iq[*n] = 0;
}
}
/* If B is lower bidiagonal, update U by those Givens rotations */
/* which rotated B to be upper bidiagonal */
if (iuplo == 2 && icompq == 2) {
dlasr_("L", "V", "B", n, n, &work[1], &work[*n], &u[u_offset], ldu);
}
return 0;
/* End of DBDSDC */
} /* dbdsdc_ */
/* Subroutine */ int dsbevx_(char *jobz, char *range, char *uplo, integer *n,
integer *kd, doublereal *ab, integer *ldab, doublereal *q, integer *
ldq, doublereal *vl, doublereal *vu, integer *il, integer *iu,
doublereal *abstol, integer *m, doublereal *w, doublereal *z__,
integer *ldz, doublereal *work, integer *iwork, integer *ifail,
integer *info, ftnlen jobz_len, ftnlen range_len, ftnlen uplo_len)
{
/* System generated locals */
integer ab_dim1, ab_offset, q_dim1, q_offset, z_dim1, z_offset, i__1,
i__2;
doublereal d__1, d__2;
/* Builtin functions */
double sqrt(doublereal);
/* Local variables */
static integer i__, j, jj;
static doublereal eps, vll, vuu, tmp1;
static integer indd, inde;
static doublereal anrm;
static integer imax;
static doublereal rmin, rmax;
static integer itmp1, indee;
extern /* Subroutine */ int dscal_(integer *, doublereal *, doublereal *,
integer *);
static doublereal sigma;
extern logical lsame_(char *, char *, ftnlen, ftnlen);
extern /* Subroutine */ int dgemv_(char *, integer *, integer *,
doublereal *, doublereal *, integer *, doublereal *, integer *,
doublereal *, doublereal *, integer *, ftnlen);
static integer iinfo;
static char order[1];
extern /* Subroutine */ int dcopy_(integer *, doublereal *, integer *,
doublereal *, integer *), dswap_(integer *, doublereal *, integer
*, doublereal *, integer *);
static logical lower, wantz;
extern doublereal dlamch_(char *, ftnlen);
static logical alleig, indeig;
static integer iscale, indibl;
extern /* Subroutine */ int dlascl_(char *, integer *, integer *,
doublereal *, doublereal *, integer *, integer *, doublereal *,
integer *, integer *, ftnlen);
extern doublereal dlansb_(char *, char *, integer *, integer *,
doublereal *, integer *, doublereal *, ftnlen, ftnlen);
static logical valeig;
extern /* Subroutine */ int dlacpy_(char *, integer *, integer *,
doublereal *, integer *, doublereal *, integer *, ftnlen);
static doublereal safmin;
extern /* Subroutine */ int xerbla_(char *, integer *, ftnlen);
static doublereal abstll, bignum;
extern /* Subroutine */ int dsbtrd_(char *, char *, integer *, integer *,
doublereal *, integer *, doublereal *, doublereal *, doublereal *,
integer *, doublereal *, integer *, ftnlen, ftnlen);
static integer indisp;
extern /* Subroutine */ int dstein_(integer *, doublereal *, doublereal *,
integer *, doublereal *, integer *, integer *, doublereal *,
integer *, doublereal *, integer *, integer *, integer *),
dsterf_(integer *, doublereal *, doublereal *, integer *);
static integer indiwo;
extern /* Subroutine */ int dstebz_(char *, char *, integer *, doublereal
*, doublereal *, integer *, integer *, doublereal *, doublereal *,
doublereal *, integer *, integer *, doublereal *, integer *,
integer *, doublereal *, integer *, integer *, ftnlen, ftnlen);
static integer indwrk;
extern /* Subroutine */ int dsteqr_(char *, integer *, doublereal *,
doublereal *, doublereal *, integer *, doublereal *, integer *,
ftnlen);
static integer nsplit;
static doublereal smlnum;
/* -- 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 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* DSBEVX 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) DOUBLE PRECISION 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) DOUBLE PRECISION 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) DOUBLE PRECISION */
/* VU (input) DOUBLE PRECISION */
/* 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) DOUBLE PRECISION */
/* 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*DLAMCH('S'), not zero. */
/* If this routine returns with INFO>0, indicating that some */
/* eigenvectors did not converge, try setting ABSTOL to */
/* 2*DLAMCH('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) DOUBLE PRECISION array, dimension (N) */
/* The first M elements contain the selected eigenvalues in */
/* ascending order. */
/* Z (output) DOUBLE PRECISION 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) DOUBLE PRECISION 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. */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Executable Statements .. */
/* Test the input parameters. */
/* Parameter adjustments */
ab_dim1 = *ldab;
ab_offset = 1 + ab_dim1;
ab -= ab_offset;
q_dim1 = *ldq;
q_offset = 1 + q_dim1;
q -= q_offset;
--w;
z_dim1 = *ldz;
z_offset = 1 + z_dim1;
z__ -= z_offset;
--work;
--iwork;
--ifail;
/* Function Body */
wantz = lsame_(jobz, "V", (ftnlen)1, (ftnlen)1);
alleig = lsame_(range, "A", (ftnlen)1, (ftnlen)1);
valeig = lsame_(range, "V", (ftnlen)1, (ftnlen)1);
indeig = lsame_(range, "I", (ftnlen)1, (ftnlen)1);
lower = lsame_(uplo, "L", (ftnlen)1, (ftnlen)1);
*info = 0;
if (! (wantz || lsame_(jobz, "N", (ftnlen)1, (ftnlen)1))) {
*info = -1;
} else if (! (alleig || valeig || indeig)) {
*info = -2;
} else if (! (lower || lsame_(uplo, "U", (ftnlen)1, (ftnlen)1))) {
*info = -3;
} else if (*n < 0) {
*info = -4;
} else if (*kd < 0) {
*info = -5;
} else if (*ldab < *kd + 1) {
*info = -7;
} else if (wantz && *ldq < max(1,*n)) {
*info = -9;
} else {
if (valeig) {
if (*n > 0 && *vu <= *vl) {
*info = -11;
}
} else if (indeig) {
if (*il < 1 || *il > max(1,*n)) {
*info = -12;
} else if (*iu < min(*n,*il) || *iu > *n) {
*info = -13;
}
}
}
if (*info == 0) {
if (*ldz < 1 || wantz && *ldz < *n) {
*info = -18;
}
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("DSBEVX", &i__1, (ftnlen)6);
return 0;
}
/* Quick return if possible */
*m = 0;
if (*n == 0) {
return 0;
}
if (*n == 1) {
*m = 1;
if (lower) {
tmp1 = ab[ab_dim1 + 1];
} else {
tmp1 = ab[*kd + 1 + ab_dim1];
}
if (valeig) {
if (! (*vl < tmp1 && *vu >= tmp1)) {
*m = 0;
}
}
if (*m == 1) {
w[1] = tmp1;
if (wantz) {
z__[z_dim1 + 1] = 1.;
}
}
return 0;
}
/* Get machine constants. */
safmin = dlamch_("Safe minimum", (ftnlen)12);
eps = dlamch_("Precision", (ftnlen)9);
smlnum = safmin / eps;
bignum = 1. / smlnum;
rmin = sqrt(smlnum);
/* Computing MIN */
d__1 = sqrt(bignum), d__2 = 1. / sqrt(sqrt(safmin));
rmax = min(d__1,d__2);
/* Scale matrix to allowable range, if necessary. */
iscale = 0;
abstll = *abstol;
if (valeig) {
vll = *vl;
vuu = *vu;
} else {
vll = 0.;
vuu = 0.;
}
anrm = dlansb_("M", uplo, n, kd, &ab[ab_offset], ldab, &work[1], (ftnlen)
1, (ftnlen)1);
if (anrm > 0. && anrm < rmin) {
iscale = 1;
sigma = rmin / anrm;
} else if (anrm > rmax) {
iscale = 1;
sigma = rmax / anrm;
}
if (iscale == 1) {
if (lower) {
dlascl_("B", kd, kd, &c_b14, &sigma, n, n, &ab[ab_offset], ldab,
info, (ftnlen)1);
} else {
dlascl_("Q", kd, kd, &c_b14, &sigma, n, n, &ab[ab_offset], ldab,
info, (ftnlen)1);
}
if (*abstol > 0.) {
abstll = *abstol * sigma;
}
if (valeig) {
vll = *vl * sigma;
vuu = *vu * sigma;
}
}
/* Call DSBTRD to reduce symmetric band matrix to tridiagonal form. */
indd = 1;
inde = indd + *n;
indwrk = inde + *n;
dsbtrd_(jobz, uplo, n, kd, &ab[ab_offset], ldab, &work[indd], &work[inde],
&q[q_offset], ldq, &work[indwrk], &iinfo, (ftnlen)1, (ftnlen)1);
/* If all eigenvalues are desired and ABSTOL is less than or equal */
/* to zero, then call DSTERF or SSTEQR. If this fails for some */
/* eigenvalue, then try DSTEBZ. */
if ((alleig || indeig && *il == 1 && *iu == *n) && *abstol <= 0.) {
dcopy_(n, &work[indd], &c__1, &w[1], &c__1);
indee = indwrk + (*n << 1);
if (! wantz) {
i__1 = *n - 1;
dcopy_(&i__1, &work[inde], &c__1, &work[indee], &c__1);
dsterf_(n, &w[1], &work[indee], info);
} else {
dlacpy_("A", n, n, &q[q_offset], ldq, &z__[z_offset], ldz, (
ftnlen)1);
i__1 = *n - 1;
dcopy_(&i__1, &work[inde], &c__1, &work[indee], &c__1);
dsteqr_(jobz, n, &w[1], &work[indee], &z__[z_offset], ldz, &work[
indwrk], info, (ftnlen)1);
if (*info == 0) {
i__1 = *n;
for (i__ = 1; i__ <= i__1; ++i__) {
ifail[i__] = 0;
/* L10: */
}
}
}
if (*info == 0) {
*m = *n;
goto L30;
}
*info = 0;
}
/* Otherwise, call DSTEBZ 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;
dstebz_(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, (ftnlen)1, (ftnlen)1);
if (wantz) {
dstein_(n, &work[indd], &work[inde], m, &w[1], &iwork[indibl], &iwork[
indisp], &z__[z_offset], ldz, &work[indwrk], &iwork[indiwo], &
ifail[1], info);
/* Apply orthogonal matrix used in reduction to tridiagonal */
/* form to eigenvectors returned by DSTEIN. */
i__1 = *m;
for (j = 1; j <= i__1; ++j) {
dcopy_(n, &z__[j * z_dim1 + 1], &c__1, &work[1], &c__1);
dgemv_("N", n, n, &c_b14, &q[q_offset], ldq, &work[1], &c__1, &
c_b34, &z__[j * z_dim1 + 1], &c__1, (ftnlen)1);
/* L20: */
}
}
/* If matrix was scaled, then rescale eigenvalues appropriately. */
L30:
if (iscale == 1) {
if (*info == 0) {
imax = *m;
} else {
imax = *info - 1;
}
d__1 = 1. / sigma;
dscal_(&imax, &d__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 <= i__1; ++j) {
i__ = 0;
tmp1 = w[j];
i__2 = *m;
for (jj = j + 1; jj <= i__2; ++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;
dswap_(n, &z__[i__ * z_dim1 + 1], &c__1, &z__[j * z_dim1 + 1],
&c__1);
if (*info != 0) {
itmp1 = ifail[i__];
ifail[i__] = ifail[j];
ifail[j] = itmp1;
}
}
/* L50: */
}
}
return 0;
/* End of DSBEVX */
} /* dsbevx_ */
/* Subroutine */ int check2_(doublereal *sfac)
{
/* Initialized data */
static doublereal sa = .3;
static integer incxs[4] = { 1,2,-2,-1 };
static integer incys[4] = { 1,-2,1,-2 };
static integer lens[8] /* was [4][2] */ = { 1,1,2,4,1,1,3,7 };
static integer ns[4] = { 0,1,2,4 };
static doublereal dx1[7] = { .6,.1,-.5,.8,.9,-.3,-.4 };
static doublereal dy1[7] = { .5,-.9,.3,.7,-.6,.2,.8 };
static doublereal dt7[16] /* was [4][4] */ = { 0.,.3,.21,.62,0.,.3,-.07,
.85,0.,.3,-.79,-.74,0.,.3,.33,1.27 };
static doublereal dt8[112] /* was [7][4][4] */ = { .5,0.,0.,0.,0.,0.,0.,
.68,0.,0.,0.,0.,0.,0.,.68,-.87,0.,0.,0.,0.,0.,.68,-.87,.15,.94,0.,
0.,0.,.5,0.,0.,0.,0.,0.,0.,.68,0.,0.,0.,0.,0.,0.,.35,-.9,.48,0.,
0.,0.,0.,.38,-.9,.57,.7,-.75,.2,.98,.5,0.,0.,0.,0.,0.,0.,.68,0.,
0.,0.,0.,0.,0.,.35,-.72,0.,0.,0.,0.,0.,.38,-.63,.15,.88,0.,0.,0.,
.5,0.,0.,0.,0.,0.,0.,.68,0.,0.,0.,0.,0.,0.,.68,-.9,.33,0.,0.,0.,
0.,.68,-.9,.33,.7,-.75,.2,1.04 };
static doublereal dt10x[112] /* was [7][4][4] */ = { .6,0.,0.,0.,
0.,0.,0.,.5,0.,0.,0.,0.,0.,0.,.5,-.9,0.,0.,0.,0.,0.,.5,-.9,.3,.7,
0.,0.,0.,.6,0.,0.,0.,0.,0.,0.,.5,0.,0.,0.,0.,0.,0.,.3,.1,.5,0.,0.,
0.,0.,.8,.1,-.6,.8,.3,-.3,.5,.6,0.,0.,0.,0.,0.,0.,.5,0.,0.,0.,0.,
0.,0.,-.9,.1,.5,0.,0.,0.,0.,.7,.1,.3,.8,-.9,-.3,.5,.6,0.,0.,0.,0.,
0.,0.,.5,0.,0.,0.,0.,0.,0.,.5,.3,0.,0.,0.,0.,0.,.5,.3,-.6,.8,0.,
0.,0. };
static doublereal dt10y[112] /* was [7][4][4] */ = { .5,0.,0.,0.,
0.,0.,0.,.6,0.,0.,0.,0.,0.,0.,.6,.1,0.,0.,0.,0.,0.,.6,.1,-.5,.8,
0.,0.,0.,.5,0.,0.,0.,0.,0.,0.,.6,0.,0.,0.,0.,0.,0.,-.5,-.9,.6,0.,
0.,0.,0.,-.4,-.9,.9,.7,-.5,.2,.6,.5,0.,0.,0.,0.,0.,0.,.6,0.,0.,0.,
0.,0.,0.,-.5,.6,0.,0.,0.,0.,0.,-.4,.9,-.5,.6,0.,0.,0.,.5,0.,0.,0.,
0.,0.,0.,.6,0.,0.,0.,0.,0.,0.,.6,-.9,.1,0.,0.,0.,0.,.6,-.9,.1,.7,
-.5,.2,.8 };
static doublereal ssize1[4] = { 0.,.3,1.6,3.2 };
static doublereal ssize2[28] /* was [14][2] */ = { 0.,0.,0.,0.,0.,
0.,0.,0.,0.,0.,0.,0.,0.,0.,1.17,1.17,1.17,1.17,1.17,1.17,1.17,
1.17,1.17,1.17,1.17,1.17,1.17,1.17 };
/* System generated locals */
integer i__1;
doublereal d__1;
/* Builtin functions */
integer s_wsle(cilist *), do_lio(integer *, integer *, char *, ftnlen),
e_wsle(void);
/* Subroutine */ int s_stop(char *, ftnlen);
/* Local variables */
extern doublereal ddot_(integer *, doublereal *, integer *, doublereal *,
integer *);
static integer lenx, leny, i__, j;
extern /* Subroutine */ int dcopy_(integer *, doublereal *, integer *,
doublereal *, integer *), dswap_(integer *, doublereal *, integer
*, doublereal *, integer *);
static integer ksize;
extern /* Subroutine */ int daxpy_(integer *, doublereal *, doublereal *,
integer *, doublereal *, integer *), stest_(integer *, doublereal
*, doublereal *, doublereal *, doublereal *), stest1_(doublereal *
, doublereal *, doublereal *, doublereal *);
static integer ki, kn, mx, my;
static doublereal sx[7], sy[7], stx[7], sty[7];
/* Fortran I/O blocks */
static cilist io___63 = { 0, 6, 0, 0, 0 };
#define dt10x_ref(a_1,a_2,a_3) dt10x[((a_3)*4 + (a_2))*7 + a_1 - 36]
#define dt10y_ref(a_1,a_2,a_3) dt10y[((a_3)*4 + (a_2))*7 + a_1 - 36]
#define lens_ref(a_1,a_2) lens[(a_2)*4 + a_1 - 5]
#define ssize2_ref(a_1,a_2) ssize2[(a_2)*14 + a_1 - 15]
#define dt7_ref(a_1,a_2) dt7[(a_2)*4 + a_1 - 5]
#define dt8_ref(a_1,a_2,a_3) dt8[((a_3)*4 + (a_2))*7 + a_1 - 36]
for (ki = 1; ki <= 4; ++ki) {
combla_1.incx = incxs[ki - 1];
combla_1.incy = incys[ki - 1];
mx = abs(combla_1.incx);
my = abs(combla_1.incy);
for (kn = 1; kn <= 4; ++kn) {
combla_1.n = ns[kn - 1];
ksize = min(2,kn);
lenx = lens_ref(kn, mx);
leny = lens_ref(kn, my);
for (i__ = 1; i__ <= 7; ++i__) {
sx[i__ - 1] = dx1[i__ - 1];
sy[i__ - 1] = dy1[i__ - 1];
/* L20: */
}
if (combla_1.icase == 1) {
d__1 = ddot_(&combla_1.n, sx, &combla_1.incx, sy, &
combla_1.incy);
stest1_(&d__1, &dt7_ref(kn, ki), &ssize1[kn - 1], sfac);
} else if (combla_1.icase == 2) {
daxpy_(&combla_1.n, &sa, sx, &combla_1.incx, sy, &
combla_1.incy);
i__1 = leny;
for (j = 1; j <= i__1; ++j) {
sty[j - 1] = dt8_ref(j, kn, ki);
/* L40: */
}
stest_(&leny, sy, sty, &ssize2_ref(1, ksize), sfac);
} else if (combla_1.icase == 5) {
for (i__ = 1; i__ <= 7; ++i__) {
sty[i__ - 1] = dt10y_ref(i__, kn, ki);
/* L60: */
}
dcopy_(&combla_1.n, sx, &combla_1.incx, sy, &combla_1.incy);
stest_(&leny, sy, sty, &ssize2_ref(1, 1), &c_b34);
} else if (combla_1.icase == 6) {
dswap_(&combla_1.n, sx, &combla_1.incx, sy, &combla_1.incy);
for (i__ = 1; i__ <= 7; ++i__) {
stx[i__ - 1] = dt10x_ref(i__, kn, ki);
sty[i__ - 1] = dt10y_ref(i__, kn, ki);
/* L80: */
}
stest_(&lenx, sx, stx, &ssize2_ref(1, 1), &c_b34);
stest_(&leny, sy, sty, &ssize2_ref(1, 1), &c_b34);
} else {
s_wsle(&io___63);
do_lio(&c__9, &c__1, " Shouldn't be here in CHECK2", (ftnlen)
28);
e_wsle();
s_stop("", (ftnlen)0);
}
/* L100: */
}
/* L120: */
}
return 0;
} /* check2_ */
/* Subroutine */ int dlasyf_(char *uplo, integer *n, integer *nb, integer *kb,
doublereal *a, integer *lda, integer *ipiv, doublereal *w, integer *
ldw, integer *info)
{
/* -- LAPACK routine (version 2.0) --
Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
Courant Institute, Argonne National Lab, and Rice University
February 29, 1992
Purpose
=======
DLASYF computes a partial factorization of a real symmetric matrix A
using the Bunch-Kaufman diagonal pivoting method. The partial
factorization has the form:
A = ( I U12 ) ( A11 0 ) ( I 0 ) if UPLO = 'U', or:
( 0 U22 ) ( 0 D ) ( U12' U22' )
A = ( L11 0 ) ( D 0 ) ( L11' L21' ) if UPLO = 'L'
( L21 I ) ( 0 A22 ) ( 0 I )
where the order of D is at most NB. The actual order is returned in
the argument KB, and is either NB or NB-1, or N if N <= NB.
DLASYF is an auxiliary routine called by DSYTRF. It uses blocked code
(calling Level 3 BLAS) to update the submatrix A11 (if UPLO = 'U') or
A22 (if UPLO = 'L').
Arguments
=========
UPLO (input) CHARACTER*1
Specifies whether the upper or lower triangular part of the
symmetric matrix A is stored:
= 'U': Upper triangular
= 'L': Lower triangular
N (input) INTEGER
The order of the matrix A. N >= 0.
NB (input) INTEGER
The maximum number of columns of the matrix A that should be
factored. NB should be at least 2 to allow for 2-by-2 pivot
blocks.
KB (output) INTEGER
The number of columns of A that were actually factored.
KB is either NB-1 or NB, or N if N <= NB.
A (input/output) DOUBLE PRECISION array, dimension (LDA,N)
On entry, the symmetric matrix A. If UPLO = 'U', the leading
n-by-n upper triangular part of A contains the upper
triangular part of the matrix A, and the strictly lower
triangular part of A is not referenced. If UPLO = 'L', the
leading n-by-n lower triangular part of A contains the lower
triangular part of the matrix A, and the strictly upper
triangular part of A is not referenced.
On exit, A contains details of the partial factorization.
LDA (input) INTEGER
The leading dimension of the array A. LDA >= max(1,N).
IPIV (output) INTEGER array, dimension (N)
Details of the interchanges and the block structure of D.
If UPLO = 'U', only the last KB elements of IPIV are set;
if UPLO = 'L', only the first KB elements are set.
If IPIV(k) > 0, then rows and columns k and IPIV(k) were
interchanged and D(k,k) is a 1-by-1 diagonal block.
If UPLO = 'U' and IPIV(k) = IPIV(k-1) < 0, then rows and
columns k-1 and -IPIV(k) were interchanged and D(k-1:k,k-1:k)
is a 2-by-2 diagonal block. If UPLO = 'L' and IPIV(k) =
IPIV(k+1) < 0, then rows and columns k+1 and -IPIV(k) were
interchanged and D(k:k+1,k:k+1) is a 2-by-2 diagonal block.
W (workspace) DOUBLE PRECISION array, dimension (LDW,NB)
LDW (input) INTEGER
The leading dimension of the array W. LDW >= max(1,N).
INFO (output) INTEGER
= 0: successful exit
> 0: if INFO = k, D(k,k) is exactly zero. The factorization
has been completed, but the block diagonal matrix D is
exactly singular.
=====================================================================
Parameter adjustments
Function Body */
/* Table of constant values */
static integer c__1 = 1;
static doublereal c_b8 = -1.;
static doublereal c_b9 = 1.;
/* System generated locals */
integer a_dim1, a_offset, w_dim1, w_offset, i__1, i__2, i__3, i__4, i__5;
doublereal d__1, d__2, d__3;
/* Builtin functions */
double sqrt(doublereal);
/* Local variables */
static integer imax, jmax, j, k;
static doublereal t, alpha;
extern /* Subroutine */ int dscal_(integer *, doublereal *, doublereal *,
integer *), dgemm_(char *, char *, integer *, integer *, integer *
, doublereal *, doublereal *, integer *, doublereal *, integer *,
doublereal *, doublereal *, integer *);
extern logical lsame_(char *, char *);
extern /* Subroutine */ int dgemv_(char *, integer *, integer *,
doublereal *, doublereal *, integer *, doublereal *, integer *,
doublereal *, doublereal *, integer *), dcopy_(integer *,
doublereal *, integer *, doublereal *, integer *), dswap_(integer
*, doublereal *, integer *, doublereal *, integer *);
static integer kstep;
static doublereal r1, d11, d21, d22;
static integer jb, jj, kk, jp, kp;
static doublereal absakk;
static integer kw;
extern integer idamax_(integer *, doublereal *, integer *);
static doublereal colmax, rowmax;
static integer kkw;
#define IPIV(I) ipiv[(I)-1]
#define A(I,J) a[(I)-1 + ((J)-1)* ( *lda)]
#define W(I,J) w[(I)-1 + ((J)-1)* ( *ldw)]
*info = 0;
/* Initialize ALPHA for use in choosing pivot block size. */
alpha = (sqrt(17.) + 1.) / 8.;
if (lsame_(uplo, "U")) {
/* Factorize the trailing columns of A using the upper triangle
of A and working backwards, and compute the matrix W = U12*D
for use in updating A11
K is the main loop index, decreasing from N in steps of 1 or
2
KW is the column of W which corresponds to column K of A */
k = *n;
L10:
kw = *nb + k - *n;
/* Exit from loop */
if (k <= *n - *nb + 1 && *nb < *n || k < 1) {
goto L30;
}
/* Copy column K of A to column KW of W and update it */
dcopy_(&k, &A(1,k), &c__1, &W(1,kw), &c__1);
if (k < *n) {
i__1 = *n - k;
dgemv_("No transpose", &k, &i__1, &c_b8, &A(1,k+1),
lda, &W(k,kw+1), ldw, &c_b9, &W(1,kw), &c__1);
}
kstep = 1;
/* Determine rows and columns to be interchanged and whether
a 1-by-1 or 2-by-2 pivot block will be used */
absakk = (d__1 = W(k,kw), abs(d__1));
/* IMAX is the row-index of the largest off-diagonal element in
column K, and COLMAX is its absolute value */
if (k > 1) {
i__1 = k - 1;
imax = idamax_(&i__1, &W(1,kw), &c__1);
colmax = (d__1 = W(imax,kw), abs(d__1));
} else {
colmax = 0.;
}
if (max(absakk,colmax) == 0.) {
/* Column K is zero: set INFO and continue */
if (*info == 0) {
*info = k;
}
kp = k;
} else {
if (absakk >= alpha * colmax) {
/* no interchange, use 1-by-1 pivot block */
kp = k;
} else {
/* Copy column IMAX to column KW-1 of W and updat
e it */
dcopy_(&imax, &A(1,imax), &c__1, &W(1,kw-1), &c__1);
i__1 = k - imax;
dcopy_(&i__1, &A(imax,imax+1), lda, &W(imax+1,kw-1), &c__1);
if (k < *n) {
i__1 = *n - k;
dgemv_("No transpose", &k, &i__1, &c_b8, &A(1,k+1), lda, &W(imax,kw+1),
ldw, &c_b9, &W(1,kw-1), &c__1)
;
}
/* JMAX is the column-index of the largest off-di
agonal
element in row IMAX, and ROWMAX is its absolut
e value */
i__1 = k - imax;
jmax = imax + idamax_(&i__1, &W(imax+1,kw-1),
&c__1);
rowmax = (d__1 = W(jmax,kw-1), abs(d__1));
if (imax > 1) {
i__1 = imax - 1;
jmax = idamax_(&i__1, &W(1,kw-1), &c__1);
/* Computing MAX */
d__2 = rowmax, d__3 = (d__1 = W(jmax,kw-1),
abs(d__1));
rowmax = max(d__2,d__3);
}
if (absakk >= alpha * colmax * (colmax / rowmax)) {
/* no interchange, use 1-by-1 pivot block
*/
kp = k;
} else if ((d__1 = W(imax,kw-1), abs(d__1)) >=
alpha * rowmax) {
/* interchange rows and columns K and IMAX
, use 1-by-1
pivot block */
kp = imax;
/* copy column KW-1 of W to column KW */
dcopy_(&k, &W(1,kw-1), &c__1, &W(1,kw), &c__1);
} else {
/* interchange rows and columns K-1 and IM
AX, use 2-by-2
pivot block */
kp = imax;
kstep = 2;
}
}
kk = k - kstep + 1;
kkw = *nb + kk - *n;
/* Updated column KP is already stored in column KKW of
W */
if (kp != kk) {
/* Copy non-updated column KK to column KP */
A(kp,k) = A(kk,k);
i__1 = k - 1 - kp;
dcopy_(&i__1, &A(kp+1,kk), &c__1, &A(kp,kp+1), lda);
dcopy_(&kp, &A(1,kk), &c__1, &A(1,kp), &
c__1);
/* Interchange rows KK and KP in last KK columns
of A and W */
i__1 = *n - kk + 1;
dswap_(&i__1, &A(kk,kk), lda, &A(kp,kk),
lda);
i__1 = *n - kk + 1;
dswap_(&i__1, &W(kk,kkw), ldw, &W(kp,kkw), ldw);
}
if (kstep == 1) {
/* 1-by-1 pivot block D(k): column KW of W now ho
lds
W(k) = U(k)*D(k)
where U(k) is the k-th column of U
Store U(k) in column k of A */
dcopy_(&k, &W(1,kw), &c__1, &A(1,k), &
c__1);
r1 = 1. / A(k,k);
i__1 = k - 1;
dscal_(&i__1, &r1, &A(1,k), &c__1);
} else {
/* 2-by-2 pivot block D(k): columns KW and KW-1 o
f W now
hold
( W(k-1) W(k) ) = ( U(k-1) U(k) )*D(k)
where U(k) and U(k-1) are the k-th and (k-1)-t
h columns
of U */
if (k > 2) {
/* Store U(k) and U(k-1) in columns k and
k-1 of A */
d21 = W(k-1,kw);
d11 = W(k,kw) / d21;
d22 = W(k-1,kw-1) / d21;
t = 1. / (d11 * d22 - 1.);
d21 = t / d21;
i__1 = k - 2;
for (j = 1; j <= k-2; ++j) {
A(j,k-1) = d21 * (d11 * W(j,kw-1) - W(j,kw));
A(j,k) = d21 * (d22 * W(j,kw) -
W(j,kw-1));
/* L20: */
}
}
/* Copy D(k) to A */
A(k-1,k-1) = W(k-1,kw-1);
A(k-1,k) = W(k-1,kw);
A(k,k) = W(k,kw);
}
}
/* Store details of the interchanges in IPIV */
if (kstep == 1) {
IPIV(k) = kp;
} else {
IPIV(k) = -kp;
IPIV(k - 1) = -kp;
}
/* Decrease K and return to the start of the main loop */
k -= kstep;
goto L10;
L30:
/* Update the upper triangle of A11 (= A(1:k,1:k)) as
A11 := A11 - U12*D*U12' = A11 - U12*W'
computing blocks of NB columns at a time */
i__1 = -(*nb);
for (j = (k - 1) / *nb * *nb + 1; i__1 < 0 ? j >= 1 : j <= 1; j +=
i__1) {
/* Computing MIN */
i__2 = *nb, i__3 = k - j + 1;
jb = min(i__2,i__3);
/* Update the upper triangle of the diagonal block */
i__2 = j + jb - 1;
for (jj = j; jj <= j+jb-1; ++jj) {
i__3 = jj - j + 1;
i__4 = *n - k;
dgemv_("No transpose", &i__3, &i__4, &c_b8, &A(j,k+1), lda, &W(jj,kw+1), ldw, &c_b9,
&A(j,jj), &c__1);
/* L40: */
}
/* Update the rectangular superdiagonal block */
i__2 = j - 1;
i__3 = *n - k;
dgemm_("No transpose", "Transpose", &i__2, &jb, &i__3, &c_b8, &A(1,k+1), lda, &W(j,kw+1), ldw,
&c_b9, &A(1,j), lda);
/* L50: */
}
/* Put U12 in standard form by partially undoing the interchang
es
in columns k+1:n */
j = k + 1;
L60:
jj = j;
jp = IPIV(j);
if (jp < 0) {
jp = -jp;
++j;
}
++j;
if (jp != jj && j <= *n) {
i__1 = *n - j + 1;
dswap_(&i__1, &A(jp,j), lda, &A(jj,j), lda);
}
if (j <= *n) {
goto L60;
}
/* Set KB to the number of columns factorized */
*kb = *n - k;
} else {
/* Factorize the leading columns of A using the lower triangle
of A and working forwards, and compute the matrix W = L21*D
for use in updating A22
K is the main loop index, increasing from 1 in steps of 1 or
2 */
k = 1;
L70:
/* Exit from loop */
if (k >= *nb && *nb < *n || k > *n) {
goto L90;
}
/* Copy column K of A to column K of W and update it */
i__1 = *n - k + 1;
dcopy_(&i__1, &A(k,k), &c__1, &W(k,k), &c__1);
i__1 = *n - k + 1;
i__2 = k - 1;
dgemv_("No transpose", &i__1, &i__2, &c_b8, &A(k,1), lda, &W(k,1), ldw, &c_b9, &W(k,k), &c__1);
kstep = 1;
/* Determine rows and columns to be interchanged and whether
a 1-by-1 or 2-by-2 pivot block will be used */
absakk = (d__1 = W(k,k), abs(d__1));
/* IMAX is the row-index of the largest off-diagonal element in
column K, and COLMAX is its absolute value */
if (k < *n) {
i__1 = *n - k;
imax = k + idamax_(&i__1, &W(k+1,k), &c__1);
colmax = (d__1 = W(imax,k), abs(d__1));
} else {
colmax = 0.;
}
if (max(absakk,colmax) == 0.) {
/* Column K is zero: set INFO and continue */
if (*info == 0) {
*info = k;
}
kp = k;
} else {
if (absakk >= alpha * colmax) {
/* no interchange, use 1-by-1 pivot block */
kp = k;
} else {
/* Copy column IMAX to column K+1 of W and update
it */
i__1 = imax - k;
dcopy_(&i__1, &A(imax,k), lda, &W(k,k+1), &c__1);
i__1 = *n - imax + 1;
dcopy_(&i__1, &A(imax,imax), &c__1, &W(imax,k+1), &c__1);
i__1 = *n - k + 1;
i__2 = k - 1;
dgemv_("No transpose", &i__1, &i__2, &c_b8, &A(k,1),
lda, &W(imax,1), ldw, &c_b9, &W(k,k+1), &c__1);
/* JMAX is the column-index of the largest off-di
agonal
element in row IMAX, and ROWMAX is its absolut
e value */
i__1 = imax - k;
jmax = k - 1 + idamax_(&i__1, &W(k,k+1), &c__1)
;
rowmax = (d__1 = W(jmax,k+1), abs(d__1));
if (imax < *n) {
i__1 = *n - imax;
jmax = imax + idamax_(&i__1, &W(imax+1,k+1), &c__1);
/* Computing MAX */
d__2 = rowmax, d__3 = (d__1 = W(jmax,k+1),
abs(d__1));
rowmax = max(d__2,d__3);
}
if (absakk >= alpha * colmax * (colmax / rowmax)) {
/* no interchange, use 1-by-1 pivot block
*/
kp = k;
} else if ((d__1 = W(imax,k+1), abs(d__1)) >=
alpha * rowmax) {
/* interchange rows and columns K and IMAX
, use 1-by-1
pivot block */
kp = imax;
/* copy column K+1 of W to column K */
i__1 = *n - k + 1;
dcopy_(&i__1, &W(k,k+1), &c__1, &W(k,k), &c__1);
} else {
/* interchange rows and columns K+1 and IM
AX, use 2-by-2
pivot block */
kp = imax;
kstep = 2;
}
}
kk = k + kstep - 1;
/* Updated column KP is already stored in column KK of W
*/
if (kp != kk) {
/* Copy non-updated column KK to column KP */
A(kp,k) = A(kk,k);
i__1 = kp - k - 1;
dcopy_(&i__1, &A(k+1,kk), &c__1, &A(kp,k+1), lda);
i__1 = *n - kp + 1;
dcopy_(&i__1, &A(kp,kk), &c__1, &A(kp,kp), &c__1);
/* Interchange rows KK and KP in first KK columns
of A and W */
dswap_(&kk, &A(kk,1), lda, &A(kp,1), lda);
dswap_(&kk, &W(kk,1), ldw, &W(kp,1), ldw);
}
if (kstep == 1) {
/* 1-by-1 pivot block D(k): column k of W now hol
ds
W(k) = L(k)*D(k)
where L(k) is the k-th column of L
Store L(k) in column k of A */
i__1 = *n - k + 1;
dcopy_(&i__1, &W(k,k), &c__1, &A(k,k), &
c__1);
if (k < *n) {
r1 = 1. / A(k,k);
i__1 = *n - k;
dscal_(&i__1, &r1, &A(k+1,k), &c__1);
}
} else {
/* 2-by-2 pivot block D(k): columns k and k+1 of
W now hold
( W(k) W(k+1) ) = ( L(k) L(k+1) )*D(k)
where L(k) and L(k+1) are the k-th and (k+1)-t
h columns
of L */
if (k < *n - 1) {
/* Store L(k) and L(k+1) in columns k and
k+1 of A */
d21 = W(k+1,k);
d11 = W(k+1,k+1) / d21;
d22 = W(k,k) / d21;
t = 1. / (d11 * d22 - 1.);
d21 = t / d21;
i__1 = *n;
for (j = k + 2; j <= *n; ++j) {
A(j,k) = d21 * (d11 * W(j,k) -
W(j,k+1));
A(j,k+1) = d21 * (d22 * W(j,k+1) - W(j,k));
/* L80: */
}
}
/* Copy D(k) to A */
A(k,k) = W(k,k);
A(k+1,k) = W(k+1,k);
A(k+1,k+1) = W(k+1,k+1);
}
}
/* Store details of the interchanges in IPIV */
if (kstep == 1) {
IPIV(k) = kp;
} else {
IPIV(k) = -kp;
IPIV(k + 1) = -kp;
}
/* Increase K and return to the start of the main loop */
k += kstep;
goto L70;
L90:
/* Update the lower triangle of A22 (= A(k:n,k:n)) as
A22 := A22 - L21*D*L21' = A22 - L21*W'
computing blocks of NB columns at a time */
i__1 = *n;
i__2 = *nb;
for (j = k; *nb < 0 ? j >= *n : j <= *n; j += *nb) {
/* Computing MIN */
i__3 = *nb, i__4 = *n - j + 1;
jb = min(i__3,i__4);
/* Update the lower triangle of the diagonal block */
i__3 = j + jb - 1;
for (jj = j; jj <= j+jb-1; ++jj) {
i__4 = j + jb - jj;
i__5 = k - 1;
dgemv_("No transpose", &i__4, &i__5, &c_b8, &A(jj,1),
lda, &W(jj,1), ldw, &c_b9, &A(jj,jj)
, &c__1);
/* L100: */
}
/* Update the rectangular subdiagonal block */
if (j + jb <= *n) {
i__3 = *n - j - jb + 1;
i__4 = k - 1;
dgemm_("No transpose", "Transpose", &i__3, &jb, &i__4, &c_b8,
&A(j+jb,1), lda, &W(j,1), ldw, &c_b9,
&A(j+jb,j), lda);
}
/* L110: */
}
/* Put L21 in standard form by partially undoing the interchang
es
in columns 1:k-1 */
j = k - 1;
L120:
jj = j;
jp = IPIV(j);
if (jp < 0) {
jp = -jp;
--j;
}
--j;
if (jp != jj && j >= 1) {
dswap_(&j, &A(jp,1), lda, &A(jj,1), lda);
}
if (j >= 1) {
goto L120;
}
/* Set KB to the number of columns factorized */
*kb = k - 1;
}
return 0;
/* End of DLASYF */
} /* dlasyf_ */
/* Subroutine */ int dgees_(char *jobvs, char *sort, L_fp select, integer *n,
doublereal *a, integer *lda, integer *sdim, doublereal *wr,
doublereal *wi, doublereal *vs, integer *ldvs, doublereal *work,
integer *lwork, 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
=======
DGEES computes for an N-by-N real nonsymmetric matrix A, the
eigenvalues, the real Schur form T, and, optionally, the matrix of
Schur vectors Z. This gives the Schur factorization A = Z*T*(Z**T).
Optionally, it also orders the eigenvalues on the diagonal of the
real Schur form so that selected eigenvalues are at the top left.
The leading columns of Z then form an orthonormal basis for the
invariant subspace corresponding to the selected eigenvalues.
A matrix is in real Schur form if it is upper quasi-triangular with
1-by-1 and 2-by-2 blocks. 2-by-2 blocks will be standardized in the
form
[ a b ]
[ c a ]
where b*c < 0. The eigenvalues of such a block are a +- sqrt(bc).
Arguments
=========
JOBVS (input) CHARACTER*1
= 'N': Schur vectors are not computed;
= 'V': Schur vectors are computed.
SORT (input) CHARACTER*1
Specifies whether or not to order the eigenvalues on the
diagonal of the Schur form.
= 'N': Eigenvalues are not ordered;
= 'S': Eigenvalues are ordered (see SELECT).
SELECT (input) LOGICAL FUNCTION of two DOUBLE PRECISION arguments
SELECT must be declared EXTERNAL in the calling subroutine.
If SORT = 'S', SELECT is used to select eigenvalues to sort
to the top left of the Schur form.
If SORT = 'N', SELECT is not referenced.
An eigenvalue WR(j)+sqrt(-1)*WI(j) is selected if
SELECT(WR(j),WI(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 SELECT(WR(j),WI(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+2 (see INFO below).
N (input) INTEGER
The order of the matrix A. N >= 0.
A (input/output) DOUBLE PRECISION array, dimension (LDA,N)
On entry, the N-by-N matrix A.
On exit, A has been overwritten by its real Schur form T.
LDA (input) INTEGER
The leading dimension of the array A. LDA >= max(1,N).
SDIM (output) INTEGER
If SORT = 'N', SDIM = 0.
If SORT = 'S', SDIM = number of eigenvalues (after sorting)
for which SELECT is true. (Complex conjugate
pairs for which SELECT is true for either
eigenvalue count as 2.)
WR (output) DOUBLE PRECISION array, dimension (N)
WI (output) DOUBLE PRECISION array, dimension (N)
WR and WI contain the real and imaginary parts,
respectively, of the computed eigenvalues in the same order
that they appear on the diagonal of the output Schur form T.
Complex conjugate pairs of eigenvalues will appear
consecutively with the eigenvalue having the positive
imaginary part first.
VS (output) DOUBLE PRECISION array, dimension (LDVS,N)
If JOBVS = 'V', VS contains the orthogonal matrix Z of Schur
vectors.
If JOBVS = 'N', VS is not referenced.
LDVS (input) INTEGER
The leading dimension of the array VS. LDVS >= 1; if
JOBVS = 'V', LDVS >= N.
WORK (workspace/output) DOUBLE PRECISION array, dimension (LWORK)
On exit, if INFO = 0, WORK(1) contains the optimal LWORK.
LWORK (input) INTEGER
The dimension of the array WORK. LWORK >= max(1,3*N).
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.
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.
> 0: if INFO = i, and i is
<= N: the QR algorithm failed to compute all the
eigenvalues; elements 1:ILO-1 and i+1:N of WR and WI
contain those eigenvalues which have converged; if
JOBVS = 'V', VS contains the matrix which reduces A
to its partially converged Schur form.
= N+1: the eigenvalues could not be reordered because some
eigenvalues were too close to separate (the problem
is very ill-conditioned);
= N+2: after reordering, roundoff changed values of some
complex eigenvalues so that leading eigenvalues in
the Schur form no longer satisfy SELECT=.TRUE. This
could also be caused by underflow due to scaling.
=====================================================================
Test the input arguments
Parameter adjustments */
/* Table of constant values */
static integer c__1 = 1;
static integer c__0 = 0;
static integer c__8 = 8;
static integer c_n1 = -1;
static integer c__4 = 4;
/* System generated locals */
integer a_dim1, a_offset, vs_dim1, vs_offset, i__1, i__2, i__3, i__4;
/* Builtin functions */
double sqrt(doublereal);
/* Local variables */
static integer ibal, maxb;
static doublereal anrm;
static integer idum[1], ierr, itau, iwrk, inxt, i__, k;
static doublereal s;
static integer icond, ieval;
extern logical lsame_(char *, char *);
extern /* Subroutine */ int dcopy_(integer *, doublereal *, integer *,
doublereal *, integer *), dswap_(integer *, doublereal *, integer
*, doublereal *, integer *);
static logical cursl;
static integer i1, i2;
extern /* Subroutine */ int dlabad_(doublereal *, doublereal *), dgebak_(
char *, char *, integer *, integer *, integer *, doublereal *,
integer *, doublereal *, integer *, integer *),
dgebal_(char *, integer *, doublereal *, integer *, integer *,
integer *, doublereal *, integer *);
static logical lst2sl, scalea;
static integer ip;
static doublereal cscale;
extern doublereal dlamch_(char *), dlange_(char *, integer *,
integer *, doublereal *, integer *, doublereal *);
extern /* Subroutine */ int dgehrd_(integer *, integer *, integer *,
doublereal *, integer *, doublereal *, doublereal *, integer *,
integer *), dlascl_(char *, integer *, integer *, doublereal *,
doublereal *, integer *, integer *, doublereal *, integer *,
integer *), dlacpy_(char *, integer *, integer *,
doublereal *, integer *, doublereal *, integer *),
xerbla_(char *, integer *);
extern integer ilaenv_(integer *, char *, char *, integer *, integer *,
integer *, integer *, ftnlen, ftnlen);
static doublereal bignum;
extern /* Subroutine */ int dorghr_(integer *, integer *, integer *,
doublereal *, integer *, doublereal *, doublereal *, integer *,
integer *), dhseqr_(char *, char *, integer *, integer *, integer
*, doublereal *, integer *, doublereal *, doublereal *,
doublereal *, integer *, doublereal *, integer *, integer *), dtrsen_(char *, char *, logical *, integer *,
doublereal *, integer *, doublereal *, integer *, doublereal *,
doublereal *, integer *, doublereal *, doublereal *, doublereal *,
integer *, integer *, integer *, integer *);
static logical lastsl;
static integer minwrk, maxwrk;
static doublereal smlnum;
static integer hswork;
static logical wantst, lquery, wantvs;
static integer ihi, ilo;
static doublereal dum[1], eps, sep;
#define a_ref(a_1,a_2) a[(a_2)*a_dim1 + a_1]
#define vs_ref(a_1,a_2) vs[(a_2)*vs_dim1 + a_1]
a_dim1 = *lda;
a_offset = 1 + a_dim1 * 1;
a -= a_offset;
--wr;
--wi;
vs_dim1 = *ldvs;
vs_offset = 1 + vs_dim1 * 1;
vs -= vs_offset;
--work;
--bwork;
/* Function Body */
*info = 0;
lquery = *lwork == -1;
wantvs = lsame_(jobvs, "V");
wantst = lsame_(sort, "S");
if (! wantvs && ! lsame_(jobvs, "N")) {
*info = -1;
} else if (! wantst && ! lsame_(sort, "N")) {
*info = -2;
} else if (*n < 0) {
*info = -4;
} else if (*lda < max(1,*n)) {
*info = -6;
} else if (*ldvs < 1 || wantvs && *ldvs < *n) {
*info = -11;
}
/* 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 DHSEQR, as
calculated below. HSWORK is computed assuming ILO=1 and IHI=N,
the worst case.) */
minwrk = 1;
if (*info == 0 && (*lwork >= 1 || lquery)) {
maxwrk = (*n << 1) + *n * ilaenv_(&c__1, "DGEHRD", " ", n, &c__1, n, &
c__0, (ftnlen)6, (ftnlen)1);
/* Computing MAX */
i__1 = 1, i__2 = *n * 3;
minwrk = max(i__1,i__2);
if (! wantvs) {
/* Computing MAX */
i__1 = ilaenv_(&c__8, "DHSEQR", "SN", n, &c__1, n, &c_n1, (ftnlen)
6, (ftnlen)2);
maxb = max(i__1,2);
/* Computing MIN
Computing MAX */
i__3 = 2, i__4 = ilaenv_(&c__4, "DHSEQR", "SN", n, &c__1, n, &
c_n1, (ftnlen)6, (ftnlen)2);
i__1 = min(maxb,*n), i__2 = max(i__3,i__4);
k = min(i__1,i__2);
/* Computing MAX */
i__1 = k * (k + 2), i__2 = *n << 1;
hswork = max(i__1,i__2);
/* Computing MAX */
i__1 = maxwrk, i__2 = *n + hswork, i__1 = max(i__1,i__2);
maxwrk = max(i__1,1);
} else {
/* Computing MAX */
i__1 = maxwrk, i__2 = (*n << 1) + (*n - 1) * ilaenv_(&c__1, "DOR"
"GHR", " ", n, &c__1, n, &c_n1, (ftnlen)6, (ftnlen)1);
maxwrk = max(i__1,i__2);
/* Computing MAX */
i__1 = ilaenv_(&c__8, "DHSEQR", "EN", n, &c__1, n, &c_n1, (ftnlen)
6, (ftnlen)2);
maxb = max(i__1,2);
/* Computing MIN
Computing MAX */
i__3 = 2, i__4 = ilaenv_(&c__4, "DHSEQR", "EN", n, &c__1, n, &
c_n1, (ftnlen)6, (ftnlen)2);
i__1 = min(maxb,*n), i__2 = max(i__3,i__4);
k = min(i__1,i__2);
/* Computing MAX */
i__1 = k * (k + 2), i__2 = *n << 1;
hswork = max(i__1,i__2);
/* Computing MAX */
i__1 = maxwrk, i__2 = *n + hswork, i__1 = max(i__1,i__2);
maxwrk = max(i__1,1);
}
work[1] = (doublereal) maxwrk;
}
if (*lwork < minwrk && ! lquery) {
*info = -13;
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("DGEES ", &i__1);
return 0;
} else if (lquery) {
return 0;
}
/* Quick return if possible */
if (*n == 0) {
*sdim = 0;
return 0;
}
/* Get machine constants */
eps = dlamch_("P");
smlnum = dlamch_("S");
bignum = 1. / smlnum;
dlabad_(&smlnum, &bignum);
smlnum = sqrt(smlnum) / eps;
bignum = 1. / smlnum;
/* Scale A if max element outside range [SMLNUM,BIGNUM] */
anrm = dlange_("M", n, n, &a[a_offset], lda, dum);
scalea = FALSE_;
if (anrm > 0. && anrm < smlnum) {
scalea = TRUE_;
cscale = smlnum;
} else if (anrm > bignum) {
scalea = TRUE_;
cscale = bignum;
}
if (scalea) {
dlascl_("G", &c__0, &c__0, &anrm, &cscale, n, n, &a[a_offset], lda, &
ierr);
}
/* Permute the matrix to make it more nearly triangular
(Workspace: need N) */
ibal = 1;
dgebal_("P", n, &a[a_offset], lda, &ilo, &ihi, &work[ibal], &ierr);
/* Reduce to upper Hessenberg form
(Workspace: need 3*N, prefer 2*N+N*NB) */
itau = *n + ibal;
iwrk = *n + itau;
i__1 = *lwork - iwrk + 1;
dgehrd_(n, &ilo, &ihi, &a[a_offset], lda, &work[itau], &work[iwrk], &i__1,
&ierr);
if (wantvs) {
/* Copy Householder vectors to VS */
dlacpy_("L", n, n, &a[a_offset], lda, &vs[vs_offset], ldvs)
;
/* Generate orthogonal matrix in VS
(Workspace: need 3*N-1, prefer 2*N+(N-1)*NB) */
i__1 = *lwork - iwrk + 1;
dorghr_(n, &ilo, &ihi, &vs[vs_offset], ldvs, &work[itau], &work[iwrk],
&i__1, &ierr);
}
*sdim = 0;
/* Perform QR iteration, accumulating Schur vectors in VS if desired
(Workspace: need N+1, prefer N+HSWORK (see comments) ) */
iwrk = itau;
i__1 = *lwork - iwrk + 1;
dhseqr_("S", jobvs, n, &ilo, &ihi, &a[a_offset], lda, &wr[1], &wi[1], &vs[
vs_offset], ldvs, &work[iwrk], &i__1, &ieval);
if (ieval > 0) {
*info = ieval;
}
/* Sort eigenvalues if desired */
if (wantst && *info == 0) {
if (scalea) {
dlascl_("G", &c__0, &c__0, &cscale, &anrm, n, &c__1, &wr[1], n, &
ierr);
dlascl_("G", &c__0, &c__0, &cscale, &anrm, n, &c__1, &wi[1], n, &
ierr);
}
i__1 = *n;
for (i__ = 1; i__ <= i__1; ++i__) {
bwork[i__] = (*select)(&wr[i__], &wi[i__]);
/* L10: */
}
/* Reorder eigenvalues and transform Schur vectors
(Workspace: none needed) */
i__1 = *lwork - iwrk + 1;
dtrsen_("N", jobvs, &bwork[1], n, &a[a_offset], lda, &vs[vs_offset],
ldvs, &wr[1], &wi[1], sdim, &s, &sep, &work[iwrk], &i__1,
idum, &c__1, &icond);
if (icond > 0) {
*info = *n + icond;
}
}
if (wantvs) {
/* Undo balancing
(Workspace: need N) */
dgebak_("P", "R", n, &ilo, &ihi, &work[ibal], n, &vs[vs_offset], ldvs,
&ierr);
}
if (scalea) {
/* Undo scaling for the Schur form of A */
dlascl_("H", &c__0, &c__0, &cscale, &anrm, n, n, &a[a_offset], lda, &
ierr);
i__1 = *lda + 1;
dcopy_(n, &a[a_offset], &i__1, &wr[1], &c__1);
if (cscale == smlnum) {
/* If scaling back towards underflow, adjust WI if an
offdiagonal element of a 2-by-2 block in the Schur form
underflows. */
if (ieval > 0) {
i1 = ieval + 1;
i2 = ihi - 1;
i__1 = ilo - 1;
/* Computing MAX */
i__3 = ilo - 1;
i__2 = max(i__3,1);
dlascl_("G", &c__0, &c__0, &cscale, &anrm, &i__1, &c__1, &wi[
1], &i__2, &ierr);
} else if (wantst) {
i1 = 1;
i2 = *n - 1;
} else {
i1 = ilo;
i2 = ihi - 1;
}
inxt = i1 - 1;
i__1 = i2;
for (i__ = i1; i__ <= i__1; ++i__) {
if (i__ < inxt) {
goto L20;
}
if (wi[i__] == 0.) {
inxt = i__ + 1;
} else {
if (a_ref(i__ + 1, i__) == 0.) {
wi[i__] = 0.;
wi[i__ + 1] = 0.;
} else if (a_ref(i__ + 1, i__) != 0. && a_ref(i__, i__ +
1) == 0.) {
wi[i__] = 0.;
wi[i__ + 1] = 0.;
if (i__ > 1) {
i__2 = i__ - 1;
dswap_(&i__2, &a_ref(1, i__), &c__1, &a_ref(1,
i__ + 1), &c__1);
}
if (*n > i__ + 1) {
i__2 = *n - i__ - 1;
dswap_(&i__2, &a_ref(i__, i__ + 2), lda, &a_ref(
i__ + 1, i__ + 2), lda);
}
dswap_(n, &vs_ref(1, i__), &c__1, &vs_ref(1, i__ + 1),
&c__1);
a_ref(i__, i__ + 1) = a_ref(i__ + 1, i__);
a_ref(i__ + 1, i__) = 0.;
}
inxt = i__ + 2;
}
L20:
;
}
}
/* Undo scaling for the imaginary part of the eigenvalues */
i__1 = *n - ieval;
/* Computing MAX */
i__3 = *n - ieval;
i__2 = max(i__3,1);
dlascl_("G", &c__0, &c__0, &cscale, &anrm, &i__1, &c__1, &wi[ieval +
1], &i__2, &ierr);
}
if (wantst && *info == 0) {
/* Check if reordering successful */
lastsl = TRUE_;
lst2sl = TRUE_;
*sdim = 0;
ip = 0;
i__1 = *n;
for (i__ = 1; i__ <= i__1; ++i__) {
cursl = (*select)(&wr[i__], &wi[i__]);
if (wi[i__] == 0.) {
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;
/* L30: */
}
}
work[1] = (doublereal) maxwrk;
return 0;
/* End of DGEES */
} /* dgees_ */
/* Subroutine */ int dpstf2_(char *uplo, integer *n, doublereal *a, integer *
lda, integer *piv, integer *rank, doublereal *tol, doublereal *work,
integer *info)
{
/* System generated locals */
integer a_dim1, a_offset, i__1, i__2, i__3;
doublereal d__1;
/* Builtin functions */
double sqrt(doublereal);
/* Local variables */
integer i__, j, maxlocval;
doublereal ajj;
integer pvt;
extern /* Subroutine */ int dscal_(integer *, doublereal *, doublereal *,
integer *);
extern logical lsame_(char *, char *);
extern /* Subroutine */ int dgemv_(char *, integer *, integer *,
doublereal *, doublereal *, integer *, doublereal *, integer *,
doublereal *, doublereal *, integer *);
doublereal dtemp;
integer itemp;
extern /* Subroutine */ int dswap_(integer *, doublereal *, integer *,
doublereal *, integer *);
doublereal dstop;
logical upper;
extern doublereal dlamch_(char *);
extern logical disnan_(doublereal *);
extern /* Subroutine */ int xerbla_(char *, integer *);
extern integer dmaxloc_(doublereal *, integer *);
/* -- LAPACK PROTOTYPE routine (version 3.2) -- */
/* Craig Lucas, University of Manchester / NAG Ltd. */
/* October, 2008 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* DPSTF2 computes the Cholesky factorization with complete */
/* pivoting of a real symmetric positive semidefinite matrix A. */
/* The factorization has the form */
/* P' * A * P = U' * U , if UPLO = 'U', */
/* P' * A * P = L * L', if UPLO = 'L', */
/* where U is an upper triangular matrix and L is lower triangular, and */
/* P is stored as vector PIV. */
/* This algorithm does not attempt to check that A is positive */
/* semidefinite. This version of the algorithm calls level 2 BLAS. */
/* Arguments */
/* ========= */
/* UPLO (input) CHARACTER*1 */
/* Specifies whether the upper or lower triangular part of the */
/* symmetric matrix A is stored. */
/* = 'U': Upper triangular */
/* = 'L': Lower triangular */
/* N (input) INTEGER */
/* The order of the matrix A. N >= 0. */
/* A (input/output) DOUBLE PRECISION array, dimension (LDA,N) */
/* On entry, the symmetric matrix A. If UPLO = 'U', the leading */
/* n by n upper triangular part of A contains the upper */
/* triangular part of the matrix A, and the strictly lower */
/* triangular part of A is not referenced. If UPLO = 'L', the */
/* leading n by n lower triangular part of A contains the lower */
/* triangular part of the matrix A, and the strictly upper */
/* triangular part of A is not referenced. */
/* On exit, if INFO = 0, the factor U or L from the Cholesky */
/* factorization as above. */
/* PIV (output) INTEGER array, dimension (N) */
/* PIV is such that the nonzero entries are P( PIV(K), K ) = 1. */
/* RANK (output) INTEGER */
/* The rank of A given by the number of steps the algorithm */
/* completed. */
/* TOL (input) DOUBLE PRECISION */
/* User defined tolerance. If TOL < 0, then N*U*MAX( A( K,K ) ) */
/* will be used. The algorithm terminates at the (K-1)st step */
/* if the pivot <= TOL. */
/* LDA (input) INTEGER */
/* The leading dimension of the array A. LDA >= max(1,N). */
/* WORK DOUBLE PRECISION array, dimension (2*N) */
/* Work space. */
/* INFO (output) INTEGER */
/* < 0: If INFO = -K, the K-th argument had an illegal value, */
/* = 0: algorithm completed successfully, and */
/* > 0: the matrix A is either rank deficient with computed rank */
/* as returned in RANK, or is indefinite. See Section 7 of */
/* LAPACK Working Note #161 for further information. */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Executable Statements .. */
/* Test the input parameters */
/* Parameter adjustments */
--work;
--piv;
a_dim1 = *lda;
a_offset = 1 + a_dim1;
a -= a_offset;
/* Function Body */
*info = 0;
upper = lsame_(uplo, "U");
if (! upper && ! lsame_(uplo, "L")) {
*info = -1;
} else if (*n < 0) {
*info = -2;
} else if (*lda < max(1,*n)) {
*info = -4;
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("DPSTF2", &i__1);
return 0;
}
/* Quick return if possible */
if (*n == 0) {
return 0;
}
/* Initialize PIV */
i__1 = *n;
for (i__ = 1; i__ <= i__1; ++i__) {
piv[i__] = i__;
/* L100: */
}
/* Compute stopping value */
pvt = 1;
ajj = a[pvt + pvt * a_dim1];
i__1 = *n;
for (i__ = 2; i__ <= i__1; ++i__) {
if (a[i__ + i__ * a_dim1] > ajj) {
pvt = i__;
ajj = a[pvt + pvt * a_dim1];
}
}
if (ajj == 0. || disnan_(&ajj)) {
*rank = 0;
*info = 1;
goto L170;
}
/* Compute stopping value if not supplied */
if (*tol < 0.) {
dstop = *n * dlamch_("Epsilon") * ajj;
} else {
dstop = *tol;
}
/* Set first half of WORK to zero, holds dot products */
i__1 = *n;
for (i__ = 1; i__ <= i__1; ++i__) {
work[i__] = 0.;
/* L110: */
}
if (upper) {
/* Compute the Cholesky factorization P' * A * P = U' * U */
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
/* Find pivot, test for exit, else swap rows and columns */
/* Update dot products, compute possible pivots which are */
/* stored in the second half of WORK */
i__2 = *n;
for (i__ = j; i__ <= i__2; ++i__) {
if (j > 1) {
/* Computing 2nd power */
d__1 = a[j - 1 + i__ * a_dim1];
work[i__] += d__1 * d__1;
}
work[*n + i__] = a[i__ + i__ * a_dim1] - work[i__];
/* L120: */
}
if (j > 1) {
maxlocval = (*n << 1) - (*n + j) + 1;
itemp = dmaxloc_(&work[*n + j], &maxlocval);
pvt = itemp + j - 1;
ajj = work[*n + pvt];
if (ajj <= dstop || disnan_(&ajj)) {
a[j + j * a_dim1] = ajj;
goto L160;
}
}
if (j != pvt) {
/* Pivot OK, so can now swap pivot rows and columns */
a[pvt + pvt * a_dim1] = a[j + j * a_dim1];
i__2 = j - 1;
dswap_(&i__2, &a[j * a_dim1 + 1], &c__1, &a[pvt * a_dim1 + 1],
&c__1);
if (pvt < *n) {
i__2 = *n - pvt;
dswap_(&i__2, &a[j + (pvt + 1) * a_dim1], lda, &a[pvt + (
pvt + 1) * a_dim1], lda);
}
i__2 = pvt - j - 1;
dswap_(&i__2, &a[j + (j + 1) * a_dim1], lda, &a[j + 1 + pvt *
a_dim1], &c__1);
/* Swap dot products and PIV */
dtemp = work[j];
work[j] = work[pvt];
work[pvt] = dtemp;
itemp = piv[pvt];
piv[pvt] = piv[j];
piv[j] = itemp;
}
ajj = sqrt(ajj);
a[j + j * a_dim1] = ajj;
/* Compute elements J+1:N of row J */
if (j < *n) {
i__2 = j - 1;
i__3 = *n - j;
dgemv_("Trans", &i__2, &i__3, &c_b16, &a[(j + 1) * a_dim1 + 1]
, lda, &a[j * a_dim1 + 1], &c__1, &c_b18, &a[j + (j +
1) * a_dim1], lda);
i__2 = *n - j;
d__1 = 1. / ajj;
dscal_(&i__2, &d__1, &a[j + (j + 1) * a_dim1], lda);
}
/* L130: */
}
} else {
/* Compute the Cholesky factorization P' * A * P = L * L' */
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
/* Find pivot, test for exit, else swap rows and columns */
/* Update dot products, compute possible pivots which are */
/* stored in the second half of WORK */
i__2 = *n;
for (i__ = j; i__ <= i__2; ++i__) {
if (j > 1) {
/* Computing 2nd power */
d__1 = a[i__ + (j - 1) * a_dim1];
work[i__] += d__1 * d__1;
}
work[*n + i__] = a[i__ + i__ * a_dim1] - work[i__];
/* L140: */
}
if (j > 1) {
maxlocval = (*n << 1) - (*n + j) + 1;
itemp = dmaxloc_(&work[*n + j], &maxlocval);
pvt = itemp + j - 1;
ajj = work[*n + pvt];
if (ajj <= dstop || disnan_(&ajj)) {
a[j + j * a_dim1] = ajj;
goto L160;
}
}
if (j != pvt) {
/* Pivot OK, so can now swap pivot rows and columns */
a[pvt + pvt * a_dim1] = a[j + j * a_dim1];
i__2 = j - 1;
dswap_(&i__2, &a[j + a_dim1], lda, &a[pvt + a_dim1], lda);
if (pvt < *n) {
i__2 = *n - pvt;
dswap_(&i__2, &a[pvt + 1 + j * a_dim1], &c__1, &a[pvt + 1
+ pvt * a_dim1], &c__1);
}
i__2 = pvt - j - 1;
dswap_(&i__2, &a[j + 1 + j * a_dim1], &c__1, &a[pvt + (j + 1)
* a_dim1], lda);
/* Swap dot products and PIV */
dtemp = work[j];
work[j] = work[pvt];
work[pvt] = dtemp;
itemp = piv[pvt];
piv[pvt] = piv[j];
piv[j] = itemp;
}
ajj = sqrt(ajj);
a[j + j * a_dim1] = ajj;
/* Compute elements J+1:N of column J */
if (j < *n) {
i__2 = *n - j;
i__3 = j - 1;
dgemv_("No Trans", &i__2, &i__3, &c_b16, &a[j + 1 + a_dim1],
lda, &a[j + a_dim1], lda, &c_b18, &a[j + 1 + j *
a_dim1], &c__1);
i__2 = *n - j;
d__1 = 1. / ajj;
dscal_(&i__2, &d__1, &a[j + 1 + j * a_dim1], &c__1);
}
/* L150: */
}
}
/* Ran to completion, A has full rank */
*rank = *n;
goto L170;
L160:
/* Rank is number of steps completed. Set INFO = 1 to signal */
/* that the factorization cannot be used to solve a system. */
*rank = j - 1;
*info = 1;
L170:
return 0;
/* End of DPSTF2 */
} /* dpstf2_ */
/* Subroutine */ int dgbtf2_(integer *m, integer *n, integer *kl, integer *ku,
doublereal *ab, integer *ldab, integer *ipiv, integer *info)
{
/* -- LAPACK routine (version 3.0) --
Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
Courant Institute, Argonne National Lab, and Rice University
February 29, 1992
Purpose
=======
DGBTF2 computes an LU factorization of a real m-by-n band matrix A
using partial pivoting with row interchanges.
This is the unblocked version of the algorithm, calling Level 2 BLAS.
Arguments
=========
M (input) INTEGER
The number of rows of the matrix A. M >= 0.
N (input) INTEGER
The number of columns of the matrix A. N >= 0.
KL (input) INTEGER
The number of subdiagonals within the band of A. KL >= 0.
KU (input) INTEGER
The number of superdiagonals within the band of A. KU >= 0.
AB (input/output) DOUBLE PRECISION array, dimension (LDAB,N)
On entry, the matrix A in band storage, in rows KL+1 to
2*KL+KU+1; rows 1 to KL of the array need not be set.
The j-th column of A is stored in the j-th column of the
array AB as follows:
AB(kl+ku+1+i-j,j) = A(i,j) for max(1,j-ku)<=i<=min(m,j+kl)
On exit, details of the factorization: U is stored as an
upper triangular band matrix with KL+KU superdiagonals in
rows 1 to KL+KU+1, and the multipliers used during the
factorization are stored in rows KL+KU+2 to 2*KL+KU+1.
See below for further details.
LDAB (input) INTEGER
The leading dimension of the array AB. LDAB >= 2*KL+KU+1.
IPIV (output) INTEGER array, dimension (min(M,N))
The pivot indices; for 1 <= i <= min(M,N), row i of the
matrix was interchanged with row IPIV(i).
INFO (output) INTEGER
= 0: successful exit
< 0: if INFO = -i, the i-th argument had an illegal value
> 0: if INFO = +i, U(i,i) is exactly zero. The factorization
has been completed, but the factor U is exactly
singular, and division by zero will occur if it is used
to solve a system of equations.
Further Details
===============
The band storage scheme is illustrated by the following example, when
M = N = 6, KL = 2, KU = 1:
On entry: On exit:
* * * + + + * * * u14 u25 u36
* * + + + + * * u13 u24 u35 u46
* a12 a23 a34 a45 a56 * u12 u23 u34 u45 u56
a11 a22 a33 a44 a55 a66 u11 u22 u33 u44 u55 u66
a21 a32 a43 a54 a65 * m21 m32 m43 m54 m65 *
a31 a42 a53 a64 * * m31 m42 m53 m64 * *
Array elements marked * are not used by the routine; elements marked
+ need not be set on entry, but are required by the routine to store
elements of U, because of fill-in resulting from the row
interchanges.
=====================================================================
KV is the number of superdiagonals in the factor U, allowing for
fill-in.
Parameter adjustments */
/* Table of constant values */
static integer c__1 = 1;
static doublereal c_b9 = -1.;
/* System generated locals */
integer ab_dim1, ab_offset, i__1, i__2, i__3, i__4;
doublereal d__1;
/* Local variables */
extern /* Subroutine */ int dger_(integer *, integer *, doublereal *,
doublereal *, integer *, doublereal *, integer *, doublereal *,
integer *);
static integer i__, j;
extern /* Subroutine */ int dscal_(integer *, doublereal *, doublereal *,
integer *), dswap_(integer *, doublereal *, integer *, doublereal
*, integer *);
static integer km, jp, ju, kv;
extern integer idamax_(integer *, doublereal *, integer *);
extern /* Subroutine */ int xerbla_(char *, integer *);
#define ab_ref(a_1,a_2) ab[(a_2)*ab_dim1 + a_1]
ab_dim1 = *ldab;
ab_offset = 1 + ab_dim1 * 1;
ab -= ab_offset;
--ipiv;
/* Function Body */
kv = *ku + *kl;
/* Test the input parameters. */
*info = 0;
if (*m < 0) {
*info = -1;
} else if (*n < 0) {
*info = -2;
} else if (*kl < 0) {
*info = -3;
} else if (*ku < 0) {
*info = -4;
} else if (*ldab < *kl + kv + 1) {
*info = -6;
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("DGBTF2", &i__1);
return 0;
}
/* Quick return if possible */
if (*m == 0 || *n == 0) {
return 0;
}
/* Gaussian elimination with partial pivoting
Set fill-in elements in columns KU+2 to KV to zero. */
i__1 = min(kv,*n);
for (j = *ku + 2; j <= i__1; ++j) {
i__2 = *kl;
for (i__ = kv - j + 2; i__ <= i__2; ++i__) {
ab_ref(i__, j) = 0.;
/* L10: */
}
/* L20: */
}
/* JU is the index of the last column affected by the current stage
of the factorization. */
ju = 1;
i__1 = min(*m,*n);
for (j = 1; j <= i__1; ++j) {
/* Set fill-in elements in column J+KV to zero. */
if (j + kv <= *n) {
i__2 = *kl;
for (i__ = 1; i__ <= i__2; ++i__) {
ab_ref(i__, j + kv) = 0.;
/* L30: */
}
}
/* Find pivot and test for singularity. KM is the number of
subdiagonal elements in the current column.
Computing MIN */
i__2 = *kl, i__3 = *m - j;
km = min(i__2,i__3);
i__2 = km + 1;
jp = idamax_(&i__2, &ab_ref(kv + 1, j), &c__1);
ipiv[j] = jp + j - 1;
if (ab_ref(kv + jp, j) != 0.) {
/* Computing MAX
Computing MIN */
i__4 = j + *ku + jp - 1;
i__2 = ju, i__3 = min(i__4,*n);
ju = max(i__2,i__3);
/* Apply interchange to columns J to JU. */
if (jp != 1) {
i__2 = ju - j + 1;
i__3 = *ldab - 1;
i__4 = *ldab - 1;
dswap_(&i__2, &ab_ref(kv + jp, j), &i__3, &ab_ref(kv + 1, j),
&i__4);
}
if (km > 0) {
/* Compute multipliers. */
d__1 = 1. / ab_ref(kv + 1, j);
dscal_(&km, &d__1, &ab_ref(kv + 2, j), &c__1);
/* Update trailing submatrix within the band. */
if (ju > j) {
i__2 = ju - j;
i__3 = *ldab - 1;
i__4 = *ldab - 1;
dger_(&km, &i__2, &c_b9, &ab_ref(kv + 2, j), &c__1, &
ab_ref(kv, j + 1), &i__3, &ab_ref(kv + 1, j + 1),
&i__4);
}
}
} else {
/* If pivot is zero, set INFO to the index of the pivot
unless a zero pivot has already been found. */
if (*info == 0) {
*info = j;
}
}
/* L40: */
}
return 0;
/* End of DGBTF2 */
} /* dgbtf2_ */
int dgetri_(int *n, double *a, int *lda, int
*ipiv, double *work, int *lwork, int *info)
{
/* System generated locals */
int a_dim1, a_offset, i__1, i__2, i__3;
/* Local variables */
int i__, j, jb, nb, jj, jp, nn, iws;
extern int dgemm_(char *, char *, int *, int *,
int *, double *, double *, int *, double *,
int *, double *, double *, int *),
dgemv_(char *, int *, int *, double *, double *,
int *, double *, int *, double *, double *,
int *);
int nbmin;
extern int dswap_(int *, double *, int *,
double *, int *), dtrsm_(char *, char *, char *, char *,
int *, int *, double *, double *, int *,
double *, int *), xerbla_(
char *, int *);
extern int ilaenv_(int *, char *, char *, int *, int *,
int *, int *);
int ldwork;
extern int dtrtri_(char *, char *, int *, double
*, int *, int *);
int lwkopt;
int lquery;
/* -- LAPACK routine (version 3.2) -- */
/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/* November 2006 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* DGETRI computes the inverse of a matrix using the LU factorization */
/* computed by DGETRF. */
/* This method inverts U and then computes inv(A) by solving the system */
/* inv(A)*L = inv(U) for inv(A). */
/* Arguments */
/* ========= */
/* N (input) INTEGER */
/* The order of the matrix A. N >= 0. */
/* A (input/output) DOUBLE PRECISION array, dimension (LDA,N) */
/* On entry, the factors L and U from the factorization */
/* A = P*L*U as computed by DGETRF. */
/* On exit, if INFO = 0, the inverse of the original matrix A. */
/* LDA (input) INTEGER */
/* The leading dimension of the array A. LDA >= MAX(1,N). */
/* IPIV (input) INTEGER array, dimension (N) */
/* The pivot indices from DGETRF; for 1<=i<=N, row i of the */
/* matrix was interchanged with row IPIV(i). */
/* WORK (workspace/output) DOUBLE PRECISION array, dimension (MAX(1,LWORK)) */
/* On exit, if INFO=0, then WORK(1) returns the optimal LWORK. */
/* LWORK (input) INTEGER */
/* The dimension of the array WORK. LWORK >= MAX(1,N). */
/* For optimal performance LWORK >= N*NB, where NB is */
/* the optimal blocksize returned by ILAENV. */
/* If LWORK = -1, then a workspace query is assumed; the routine */
/* only calculates the optimal size of the WORK array, returns */
/* this value as the first entry of the WORK array, and no error */
/* message related to LWORK is issued by XERBLA. */
/* INFO (output) INTEGER */
/* = 0: successful exit */
/* < 0: if INFO = -i, the i-th argument had an illegal value */
/* > 0: if INFO = i, U(i,i) is exactly zero; the matrix is */
/* singular and its inverse could not be computed. */
/* ===================================================================== */
/* .. 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;
--ipiv;
--work;
/* Function Body */
*info = 0;
nb = ilaenv_(&c__1, "DGETRI", " ", n, &c_n1, &c_n1, &c_n1);
lwkopt = *n * nb;
work[1] = (double) lwkopt;
lquery = *lwork == -1;
if (*n < 0) {
*info = -1;
} else if (*lda < MAX(1,*n)) {
*info = -3;
} else if (*lwork < MAX(1,*n) && ! lquery) {
*info = -6;
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("DGETRI", &i__1);
return 0;
} else if (lquery) {
return 0;
}
/* Quick return if possible */
if (*n == 0) {
return 0;
}
/* Form inv(U). If INFO > 0 from DTRTRI, then U is singular, */
/* and the inverse is not computed. */
dtrtri_("Upper", "Non-unit", n, &a[a_offset], lda, info);
if (*info > 0) {
return 0;
}
nbmin = 2;
ldwork = *n;
if (nb > 1 && nb < *n) {
/* Computing MAX */
i__1 = ldwork * nb;
iws = MAX(i__1,1);
if (*lwork < iws) {
nb = *lwork / ldwork;
/* Computing MAX */
i__1 = 2, i__2 = ilaenv_(&c__2, "DGETRI", " ", n, &c_n1, &c_n1, &
c_n1);
nbmin = MAX(i__1,i__2);
}
} else {
iws = *n;
}
/* Solve the equation inv(A)*L = inv(U) for inv(A). */
if (nb < nbmin || nb >= *n) {
/* Use unblocked code. */
for (j = *n; j >= 1; --j) {
/* Copy current column of L to WORK and replace with zeros. */
i__1 = *n;
for (i__ = j + 1; i__ <= i__1; ++i__) {
work[i__] = a[i__ + j * a_dim1];
a[i__ + j * a_dim1] = 0.;
/* L10: */
}
/* Compute current column of inv(A). */
if (j < *n) {
i__1 = *n - j;
dgemv_("No transpose", n, &i__1, &c_b20, &a[(j + 1) * a_dim1
+ 1], lda, &work[j + 1], &c__1, &c_b22, &a[j * a_dim1
+ 1], &c__1);
}
/* L20: */
}
} else {
/* Use blocked code. */
nn = (*n - 1) / nb * nb + 1;
i__1 = -nb;
for (j = nn; i__1 < 0 ? j >= 1 : j <= 1; j += i__1) {
/* Computing MIN */
i__2 = nb, i__3 = *n - j + 1;
jb = MIN(i__2,i__3);
/* Copy current block column of L to WORK and replace with */
/* zeros. */
i__2 = j + jb - 1;
for (jj = j; jj <= i__2; ++jj) {
i__3 = *n;
for (i__ = jj + 1; i__ <= i__3; ++i__) {
work[i__ + (jj - j) * ldwork] = a[i__ + jj * a_dim1];
a[i__ + jj * a_dim1] = 0.;
/* L30: */
}
/* L40: */
}
/* Compute current block column of inv(A). */
if (j + jb <= *n) {
i__2 = *n - j - jb + 1;
dgemm_("No transpose", "No transpose", n, &jb, &i__2, &c_b20,
&a[(j + jb) * a_dim1 + 1], lda, &work[j + jb], &
ldwork, &c_b22, &a[j * a_dim1 + 1], lda);
}
dtrsm_("Right", "Lower", "No transpose", "Unit", n, &jb, &c_b22, &
work[j], &ldwork, &a[j * a_dim1 + 1], lda);
/* L50: */
}
}
/* Apply column interchanges. */
for (j = *n - 1; j >= 1; --j) {
jp = ipiv[j];
if (jp != j) {
dswap_(n, &a[j * a_dim1 + 1], &c__1, &a[jp * a_dim1 + 1], &c__1);
}
/* L60: */
}
work[1] = (double) iws;
return 0;
/* End of DGETRI */
} /* dgetri_ */
/* Subroutine */ int dchkpb_(logical *dotype, integer *nn, integer *nval,
integer *nnb, integer *nbval, integer *nns, integer *nsval,
doublereal *thresh, logical *tsterr, integer *nmax, doublereal *a,
doublereal *afac, doublereal *ainv, doublereal *b, doublereal *x,
doublereal *xact, doublereal *work, doublereal *rwork, integer *iwork,
integer *nout)
{
/* Initialized data */
static integer iseedy[4] = { 1988,1989,1990,1991 };
/* Format strings */
static char fmt_9999[] = "(\002 UPLO='\002,a1,\002', N=\002,i5,\002, KD"
"=\002,i5,\002, NB=\002,i4,\002, type \002,i2,\002, test \002,i2"
",\002, ratio= \002,g12.5)";
static char fmt_9998[] = "(\002 UPLO='\002,a1,\002', N=\002,i5,\002, KD"
"=\002,i5,\002, NRHS=\002,i3,\002, type \002,i2,\002, test(\002,i"
"2,\002) = \002,g12.5)";
static char fmt_9997[] = "(\002 UPLO='\002,a1,\002', N=\002,i5,\002, KD"
"=\002,i5,\002,\002,10x,\002 type \002,i2,\002, test(\002,i2,\002"
") = \002,g12.5)";
/* System generated locals */
integer i__1, i__2, i__3, i__4, i__5, i__6;
/* Local variables */
integer i__, k, n, i1, i2, kd, nb, in, kl, iw, ku, lda, ikd, inb, nkd,
ldab, ioff, mode, koff, imat, info;
char path[3], dist[1];
integer irhs, nrhs;
char uplo[1], type__[1];
integer nrun;
integer nfail, iseed[4];
integer kdval[4];
doublereal rcond;
integer nimat;
doublereal anorm;
integer iuplo, izero, nerrs;
logical zerot;
char xtype[1];
doublereal rcondc;
char packit[1];
doublereal cndnum;
doublereal ainvnm;
doublereal result[7];
/* Fortran I/O blocks */
static cilist io___40 = { 0, 0, 0, fmt_9999, 0 };
static cilist io___46 = { 0, 0, 0, fmt_9998, 0 };
static cilist io___48 = { 0, 0, 0, fmt_9997, 0 };
/* -- LAPACK test routine (version 3.1) -- */
/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/* November 2006 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* DCHKPB tests DPBTRF, -TRS, -RFS, and -CON. */
/* 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. */
/* NNB (input) INTEGER */
/* The number of values of NB contained in the vector NBVAL. */
/* NBVAL (input) INTEGER array, dimension (NBVAL) */
/* The values of the blocksize NB. */
/* NNS (input) INTEGER */
/* The number of values of NRHS contained in the vector NSVAL. */
/* NSVAL (input) INTEGER array, dimension (NNS) */
/* The values of the number of right hand sides NRHS. */
/* THRESH (input) DOUBLE PRECISION */
/* 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. */
/* NMAX (input) INTEGER */
/* The maximum value permitted for N, used in dimensioning the */
/* work arrays. */
/* A (workspace) DOUBLE PRECISION array, dimension (NMAX*NMAX) */
/* AFAC (workspace) DOUBLE PRECISION array, dimension (NMAX*NMAX) */
/* AINV (workspace) DOUBLE PRECISION array, dimension (NMAX*NMAX) */
/* B (workspace) DOUBLE PRECISION array, dimension (NMAX*NSMAX) */
/* where NSMAX is the largest entry in NSVAL. */
/* X (workspace) DOUBLE PRECISION array, dimension (NMAX*NSMAX) */
/* XACT (workspace) DOUBLE PRECISION array, dimension (NMAX*NSMAX) */
/* WORK (workspace) DOUBLE PRECISION array, dimension */
/* (NMAX*max(3,NSMAX)) */
/* RWORK (workspace) DOUBLE PRECISION array, dimension */
/* (max(NMAX,2*NSMAX)) */
/* IWORK (workspace) INTEGER array, dimension (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;
--ainv;
--afac;
--a;
--nsval;
--nbval;
--nval;
--dotype;
/* Function Body */
/* .. */
/* .. Executable Statements .. */
/* Initialize constants and the random number seed. */
s_copy(path, "Double precision", (ftnlen)1, (ftnlen)16);
s_copy(path + 1, "PB", (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) {
derrpo_(path, nout);
}
infoc_1.infot = 0;
xlaenv_(&c__2, &c__2);
kdval[0] = 0;
/* Do for each value of N in NVAL */
i__1 = *nn;
for (in = 1; in <= i__1; ++in) {
n = nval[in];
lda = max(n,1);
*(unsigned char *)xtype = 'N';
/* Set limits on the number of loop iterations. */
/* Computing MAX */
i__2 = 1, i__3 = min(n,4);
nkd = max(i__2,i__3);
nimat = 8;
if (n == 0) {
nimat = 1;
}
kdval[1] = n + (n + 1) / 4;
kdval[2] = (n * 3 - 1) / 4;
kdval[3] = (n + 1) / 4;
i__2 = nkd;
for (ikd = 1; ikd <= i__2; ++ikd) {
/* Do for KD = 0, (5*N+1)/4, (3N-1)/4, and (N+1)/4. This order */
/* makes it easier to skip redundant values for small values */
/* of N. */
kd = kdval[ikd - 1];
ldab = kd + 1;
/* Do first for UPLO = 'U', then for UPLO = 'L' */
for (iuplo = 1; iuplo <= 2; ++iuplo) {
koff = 1;
if (iuplo == 1) {
*(unsigned char *)uplo = 'U';
/* Computing MAX */
i__3 = 1, i__4 = kd + 2 - n;
koff = max(i__3,i__4);
*(unsigned char *)packit = 'Q';
} else {
*(unsigned char *)uplo = 'L';
*(unsigned char *)packit = 'B';
}
i__3 = nimat;
for (imat = 1; imat <= i__3; ++imat) {
/* Do the tests only if DOTYPE( IMAT ) is true. */
if (! dotype[imat]) {
goto L60;
}
/* Skip types 2, 3, or 4 if the matrix size is too small. */
zerot = imat >= 2 && imat <= 4;
if (zerot && n < imat - 1) {
goto L60;
}
if (! zerot || ! dotype[1]) {
/* Set up parameters with DLATB4 and generate a test */
/* matrix with DLATMS. */
dlatb4_(path, &imat, &n, &n, type__, &kl, &ku, &anorm,
&mode, &cndnum, dist);
s_copy(srnamc_1.srnamt, "DLATMS", (ftnlen)32, (ftnlen)
6);
dlatms_(&n, &n, dist, iseed, type__, &rwork[1], &mode,
&cndnum, &anorm, &kd, &kd, packit, &a[koff],
&ldab, &work[1], &info);
/* Check error code from DLATMS. */
if (info != 0) {
alaerh_(path, "DLATMS", &info, &c__0, uplo, &n, &
n, &kd, &kd, &c_n1, &imat, &nfail, &nerrs,
nout);
goto L60;
}
} else if (izero > 0) {
/* Use the same matrix for types 3 and 4 as for type */
/* 2 by copying back the zeroed out column, */
iw = (lda << 1) + 1;
if (iuplo == 1) {
ioff = (izero - 1) * ldab + kd + 1;
i__4 = izero - i1;
dcopy_(&i__4, &work[iw], &c__1, &a[ioff - izero +
i1], &c__1);
iw = iw + izero - i1;
i__4 = i2 - izero + 1;
/* Computing MAX */
i__6 = ldab - 1;
i__5 = max(i__6,1);
dcopy_(&i__4, &work[iw], &c__1, &a[ioff], &i__5);
} else {
ioff = (i1 - 1) * ldab + 1;
i__4 = izero - i1;
/* Computing MAX */
i__6 = ldab - 1;
i__5 = max(i__6,1);
dcopy_(&i__4, &work[iw], &c__1, &a[ioff + izero -
i1], &i__5);
ioff = (izero - 1) * ldab + 1;
iw = iw + izero - i1;
i__4 = i2 - izero + 1;
dcopy_(&i__4, &work[iw], &c__1, &a[ioff], &c__1);
}
}
/* For types 2-4, zero one row and column of the matrix */
/* to test that INFO is returned correctly. */
izero = 0;
if (zerot) {
if (imat == 2) {
izero = 1;
} else if (imat == 3) {
izero = n;
} else {
izero = n / 2 + 1;
}
/* Save the zeroed out row and column in WORK(*,3) */
iw = lda << 1;
/* Computing MIN */
i__5 = (kd << 1) + 1;
i__4 = min(i__5,n);
for (i__ = 1; i__ <= i__4; ++i__) {
work[iw + i__] = 0.;
/* L20: */
}
++iw;
/* Computing MAX */
i__4 = izero - kd;
i1 = max(i__4,1);
/* Computing MIN */
i__4 = izero + kd;
i2 = min(i__4,n);
if (iuplo == 1) {
ioff = (izero - 1) * ldab + kd + 1;
i__4 = izero - i1;
dswap_(&i__4, &a[ioff - izero + i1], &c__1, &work[
iw], &c__1);
iw = iw + izero - i1;
i__4 = i2 - izero + 1;
/* Computing MAX */
i__6 = ldab - 1;
i__5 = max(i__6,1);
dswap_(&i__4, &a[ioff], &i__5, &work[iw], &c__1);
} else {
ioff = (i1 - 1) * ldab + 1;
i__4 = izero - i1;
/* Computing MAX */
i__6 = ldab - 1;
i__5 = max(i__6,1);
dswap_(&i__4, &a[ioff + izero - i1], &i__5, &work[
iw], &c__1);
ioff = (izero - 1) * ldab + 1;
iw = iw + izero - i1;
i__4 = i2 - izero + 1;
dswap_(&i__4, &a[ioff], &c__1, &work[iw], &c__1);
}
}
/* Do for each value of NB in NBVAL */
i__4 = *nnb;
for (inb = 1; inb <= i__4; ++inb) {
nb = nbval[inb];
xlaenv_(&c__1, &nb);
/* Compute the L*L' or U'*U factorization of the band */
/* matrix. */
i__5 = kd + 1;
dlacpy_("Full", &i__5, &n, &a[1], &ldab, &afac[1], &
ldab);
s_copy(srnamc_1.srnamt, "DPBTRF", (ftnlen)32, (ftnlen)
6);
dpbtrf_(uplo, &n, &kd, &afac[1], &ldab, &info);
/* Check error code from DPBTRF. */
if (info != izero) {
alaerh_(path, "DPBTRF", &info, &izero, uplo, &n, &
n, &kd, &kd, &nb, &imat, &nfail, &nerrs,
nout);
goto L50;
}
/* Skip the tests if INFO is not 0. */
if (info != 0) {
goto L50;
}
/* + TEST 1 */
/* Reconstruct matrix from factors and compute */
/* residual. */
i__5 = kd + 1;
dlacpy_("Full", &i__5, &n, &afac[1], &ldab, &ainv[1],
&ldab);
dpbt01_(uplo, &n, &kd, &a[1], &ldab, &ainv[1], &ldab,
&rwork[1], result);
/* Print the test ratio if it is .GE. THRESH. */
if (result[0] >= *thresh) {
if (nfail == 0 && nerrs == 0) {
alahd_(nout, path);
}
io___40.ciunit = *nout;
s_wsfe(&io___40);
do_fio(&c__1, uplo, (ftnlen)1);
do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer))
;
do_fio(&c__1, (char *)&kd, (ftnlen)sizeof(integer)
);
do_fio(&c__1, (char *)&nb, (ftnlen)sizeof(integer)
);
do_fio(&c__1, (char *)&imat, (ftnlen)sizeof(
integer));
do_fio(&c__1, (char *)&c__1, (ftnlen)sizeof(
integer));
do_fio(&c__1, (char *)&result[0], (ftnlen)sizeof(
doublereal));
e_wsfe();
++nfail;
}
++nrun;
/* Only do other tests if this is the first blocksize. */
if (inb > 1) {
goto L50;
}
/* Form the inverse of A so we can get a good estimate */
/* of RCONDC = 1/(norm(A) * norm(inv(A))). */
dlaset_("Full", &n, &n, &c_b50, &c_b51, &ainv[1], &
lda);
s_copy(srnamc_1.srnamt, "DPBTRS", (ftnlen)32, (ftnlen)
6);
dpbtrs_(uplo, &n, &kd, &n, &afac[1], &ldab, &ainv[1],
&lda, &info);
/* Compute RCONDC = 1/(norm(A) * norm(inv(A))). */
anorm = dlansb_("1", uplo, &n, &kd, &a[1], &ldab, &
rwork[1]);
ainvnm = dlange_("1", &n, &n, &ainv[1], &lda, &rwork[
1]);
if (anorm <= 0. || ainvnm <= 0.) {
rcondc = 1.;
} else {
rcondc = 1. / anorm / ainvnm;
}
i__5 = *nns;
for (irhs = 1; irhs <= i__5; ++irhs) {
nrhs = nsval[irhs];
/* + TEST 2 */
/* Solve and compute residual for A * X = B. */
s_copy(srnamc_1.srnamt, "DLARHS", (ftnlen)32, (
ftnlen)6);
dlarhs_(path, xtype, uplo, " ", &n, &n, &kd, &kd,
&nrhs, &a[1], &ldab, &xact[1], &lda, &b[1]
, &lda, iseed, &info);
dlacpy_("Full", &n, &nrhs, &b[1], &lda, &x[1], &
lda);
s_copy(srnamc_1.srnamt, "DPBTRS", (ftnlen)32, (
ftnlen)6);
dpbtrs_(uplo, &n, &kd, &nrhs, &afac[1], &ldab, &x[
1], &lda, &info);
/* Check error code from DPBTRS. */
if (info != 0) {
alaerh_(path, "DPBTRS", &info, &c__0, uplo, &
n, &n, &kd, &kd, &nrhs, &imat, &nfail,
&nerrs, nout);
}
dlacpy_("Full", &n, &nrhs, &b[1], &lda, &work[1],
&lda);
dpbt02_(uplo, &n, &kd, &nrhs, &a[1], &ldab, &x[1],
&lda, &work[1], &lda, &rwork[1], &result[
1]);
/* + TEST 3 */
/* Check solution from generated exact solution. */
dget04_(&n, &nrhs, &x[1], &lda, &xact[1], &lda, &
rcondc, &result[2]);
/* + TESTS 4, 5, and 6 */
/* Use iterative refinement to improve the solution. */
s_copy(srnamc_1.srnamt, "DPBRFS", (ftnlen)32, (
ftnlen)6);
dpbrfs_(uplo, &n, &kd, &nrhs, &a[1], &ldab, &afac[
1], &ldab, &b[1], &lda, &x[1], &lda, &
rwork[1], &rwork[nrhs + 1], &work[1], &
iwork[1], &info);
/* Check error code from DPBRFS. */
if (info != 0) {
alaerh_(path, "DPBRFS", &info, &c__0, uplo, &
n, &n, &kd, &kd, &nrhs, &imat, &nfail,
&nerrs, nout);
}
dget04_(&n, &nrhs, &x[1], &lda, &xact[1], &lda, &
rcondc, &result[3]);
dpbt05_(uplo, &n, &kd, &nrhs, &a[1], &ldab, &b[1],
&lda, &x[1], &lda, &xact[1], &lda, &
rwork[1], &rwork[nrhs + 1], &result[4]);
/* Print information about the tests that did not */
/* pass the threshold. */
for (k = 2; k <= 6; ++k) {
if (result[k - 1] >= *thresh) {
if (nfail == 0 && nerrs == 0) {
alahd_(nout, path);
}
io___46.ciunit = *nout;
s_wsfe(&io___46);
do_fio(&c__1, uplo, (ftnlen)1);
do_fio(&c__1, (char *)&n, (ftnlen)sizeof(
integer));
do_fio(&c__1, (char *)&kd, (ftnlen)sizeof(
integer));
do_fio(&c__1, (char *)&nrhs, (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(doublereal));
e_wsfe();
++nfail;
}
/* L30: */
}
nrun += 5;
/* L40: */
}
/* + TEST 7 */
/* Get an estimate of RCOND = 1/CNDNUM. */
s_copy(srnamc_1.srnamt, "DPBCON", (ftnlen)32, (ftnlen)
6);
dpbcon_(uplo, &n, &kd, &afac[1], &ldab, &anorm, &
rcond, &work[1], &iwork[1], &info);
/* Check error code from DPBCON. */
if (info != 0) {
alaerh_(path, "DPBCON", &info, &c__0, uplo, &n, &
n, &kd, &kd, &c_n1, &imat, &nfail, &nerrs,
nout);
}
result[6] = dget06_(&rcond, &rcondc);
/* Print the test ratio if it is .GE. THRESH. */
if (result[6] >= *thresh) {
if (nfail == 0 && nerrs == 0) {
alahd_(nout, path);
}
io___48.ciunit = *nout;
s_wsfe(&io___48);
do_fio(&c__1, uplo, (ftnlen)1);
do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer))
;
do_fio(&c__1, (char *)&kd, (ftnlen)sizeof(integer)
);
do_fio(&c__1, (char *)&imat, (ftnlen)sizeof(
integer));
do_fio(&c__1, (char *)&c__7, (ftnlen)sizeof(
integer));
do_fio(&c__1, (char *)&result[6], (ftnlen)sizeof(
doublereal));
e_wsfe();
++nfail;
}
++nrun;
L50:
;
}
L60:
;
}
/* L70: */
}
/* L80: */
}
/* L90: */
}
/* Print a summary of the results. */
alasum_(path, nout, &nfail, &nrun, &nerrs);
return 0;
/* End of DCHKPB */
} /* dchkpb_ */