/* 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)
{
/* System generated locals */
integer z_dim1, z_offset, i__1, i__2;
doublereal d__1, d__2;
/* Builtin functions */
double sqrt(doublereal);
/* Local variables */
integer i__, j;
doublereal r1, r2;
integer jj;
doublereal cs;
integer in;
doublereal sn, wl, wu;
integer iil, iiu;
doublereal eps, tmp;
integer indd, iend, jblk, wend;
doublereal rmin, rmax;
integer itmp;
doublereal tnrm;
extern /* Subroutine */ int dlae2_(doublereal *, doublereal *, doublereal
*, doublereal *, doublereal *);
integer inde2, itmp2;
doublereal rtol1, rtol2;
extern /* Subroutine */ int dscal_(integer *, doublereal *, doublereal *,
integer *);
doublereal scale;
integer indgp;
extern logical lsame_(char *, char *);
integer iinfo, iindw, ilast;
extern /* Subroutine */ int dcopy_(integer *, doublereal *, integer *,
doublereal *, integer *), dswap_(integer *, doublereal *, integer
*, doublereal *, integer *);
integer lwmin;
logical wantz;
extern /* Subroutine */ int dlaev2_(doublereal *, doublereal *,
doublereal *, doublereal *, doublereal *, doublereal *,
doublereal *);
extern doublereal dlamch_(char *);
logical alleig;
integer ibegin;
logical indeig;
integer iindbl;
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 *);
integer wbegin;
doublereal safmin;
extern /* Subroutine */ int dlarrj_(integer *, doublereal *, doublereal *,
integer *, integer *, doublereal *, integer *, doublereal *,
doublereal *, doublereal *, integer *, doublereal *, doublereal *,
integer *), xerbla_(char *, integer *);
doublereal bignum;
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 *);
doublereal thresh;
integer iinspl, ifirst, indwrk, liwmin, nzcmin;
doublereal pivmin;
integer nsplit;
doublereal smlnum;
logical lquery, zquery;
/* -- LAPACK computational routine (version 3.2) -- */
/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/* November 2006 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* 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 */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Executable Statements .. */
/* Test the input parameters. */
/* Parameter adjustments */
--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;
/* 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 dstevx_(char *jobz, char *range, integer *n, doublereal *
d__, doublereal *e, 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 z_dim1, z_offset, i__1, i__2;
doublereal d__1, d__2;
/* Builtin functions */
double sqrt(doublereal);
/* Local variables */
integer i__, j, jj;
doublereal eps, vll, vuu, tmp1;
integer imax;
doublereal rmin, rmax;
logical test;
doublereal tnrm;
integer itmp1;
extern /* Subroutine */ int dscal_(integer *, doublereal *, doublereal *,
integer *);
doublereal sigma;
extern logical lsame_(char *, char *);
char order[1];
extern /* Subroutine */ int dcopy_(integer *, doublereal *, integer *,
doublereal *, integer *), dswap_(integer *, doublereal *, integer
*, doublereal *, integer *);
logical wantz;
extern doublereal dlamch_(char *);
logical alleig, indeig;
integer iscale, indibl;
logical valeig;
doublereal safmin;
extern /* Subroutine */ int xerbla_(char *, integer *);
doublereal bignum;
extern doublereal dlanst_(char *, integer *, doublereal *, doublereal *);
integer 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;
extern /* Subroutine */ int 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;
doublereal smlnum;
/* -- LAPACK driver routine (version 3.2) -- */
/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/* November 2006 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* DSTEVX computes selected eigenvalues and, optionally, eigenvectors */
/* of a real symmetric tridiagonal 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. */
/* 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 */
/* A. */
/* On exit, D may be multiplied by a constant factor chosen */
/* to avoid over/underflow in computing the eigenvalues. */
/* E (input/output) DOUBLE PRECISION array, dimension (max(1,N-1)) */
/* On entry, the (n-1) subdiagonal elements of the tridiagonal */
/* matrix A in elements 1 to N-1 of E. */
/* On exit, E may be multiplied by a constant factor chosen */
/* to avoid over/underflow in computing the eigenvalues. */
/* 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. */
/* 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 (INFO > 0), 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 (5*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 */
--d__;
--e;
--w;
z_dim1 = *ldz;
z_offset = 1 + z_dim1;
z__ -= z_offset;
--work;
--iwork;
--ifail;
/* Function Body */
wantz = lsame_(jobz, "V");
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 (*n < 0) {
*info = -3;
} else {
if (valeig) {
if (*n > 0 && *vu <= *vl) {
*info = -7;
}
} else if (indeig) {
if (*il < 1 || *il > max(1,*n)) {
*info = -8;
} else if (*iu < min(*n,*il) || *iu > *n) {
*info = -9;
}
}
}
if (*info == 0) {
if (*ldz < 1 || wantz && *ldz < *n) {
*info = -14;
}
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("DSTEVX", &i__1);
return 0;
}
/* Quick return if possible */
*m = 0;
if (*n == 0) {
return 0;
}
if (*n == 1) {
if (alleig || indeig) {
*m = 1;
w[1] = d__[1];
} else {
if (*vl < d__[1] && *vu >= d__[1]) {
*m = 1;
w[1] = d__[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));
rmax = min(d__1,d__2);
/* Scale matrix to allowable range, if necessary. */
iscale = 0;
if (valeig) {
vll = *vl;
vuu = *vu;
} else {
vll = 0.;
vuu = 0.;
}
tnrm = dlanst_("M", n, &d__[1], &e[1]);
if (tnrm > 0. && tnrm < rmin) {
iscale = 1;
sigma = rmin / tnrm;
} else if (tnrm > rmax) {
iscale = 1;
sigma = rmax / tnrm;
}
if (iscale == 1) {
dscal_(n, &sigma, &d__[1], &c__1);
i__1 = *n - 1;
dscal_(&i__1, &sigma, &e[1], &c__1);
if (valeig) {
vll = *vl * sigma;
vuu = *vu * sigma;
}
}
/* If all eigenvalues are desired and ABSTOL is less than 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, &d__[1], &c__1, &w[1], &c__1);
i__1 = *n - 1;
dcopy_(&i__1, &e[1], &c__1, &work[1], &c__1);
indwrk = *n + 1;
if (! wantz) {
dsterf_(n, &w[1], &work[1], info);
} else {
dsteqr_("I", n, &w[1], &work[1], &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 L20;
}
*info = 0;
}
/* Otherwise, call DSTEBZ and, if eigenvectors are desired, SSTEIN. */
if (wantz) {
*(unsigned char *)order = 'B';
} else {
*(unsigned char *)order = 'E';
}
indwrk = 1;
indibl = 1;
indisp = indibl + *n;
indiwo = indisp + *n;
dstebz_(range, order, n, &vll, &vuu, il, iu, abstol, &d__[1], &e[1], m, &
nsplit, &w[1], &iwork[indibl], &iwork[indisp], &work[indwrk], &
iwork[indiwo], info);
if (wantz) {
dstein_(n, &d__[1], &e[1], m, &w[1], &iwork[indibl], &iwork[indisp], &
z__[z_offset], ldz, &work[indwrk], &iwork[indiwo], &ifail[1],
info);
}
/* If matrix was scaled, then rescale eigenvalues appropriately. */
L20:
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];
}
/* L30: */
}
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;
}
}
/* L40: */
}
}
return 0;
/* End of DSTEVX */
} /* dstevx_ */
/* Subroutine */ int zsteqr_(char *compz, integer *n, doublereal *d,
doublereal *e, doublecomplex *z, integer *ldz, doublereal *work,
integer *info)
{
/* -- LAPACK routine (version 2.0) --
Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
Courant Institute, Argonne National Lab, and Rice University
September 30, 1994
Purpose
=======
ZSTEQR 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 complex Hermitian matrix can also
be found if ZHETRD or ZHPTRD or ZHBTRD 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
Hermitian matrix. On entry, Z must contain the
unitary 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) COMPLEX*16 array, dimension (LDZ, N)
On entry, if COMPZ = 'V', then Z contains the unitary
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 Hermitian 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 unitarily similar to the original
matrix.
=====================================================================
Test the input parameters.
Parameter adjustments
Function Body */
/* Table of constant values */
static doublecomplex c_b1 = {0.,0.};
static doublecomplex c_b2 = {1.,0.};
static integer c__0 = 0;
static integer c__1 = 1;
static integer c__2 = 2;
static doublereal c_b41 = 1.;
/* 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 */
static integer lend, jtot;
extern /* Subroutine */ int dlae2_(doublereal *, doublereal *, doublereal
*, doublereal *, doublereal *);
static doublereal b, c, f, g;
static integer i, j, k, l, m;
static doublereal p, r, s;
extern logical lsame_(char *, char *);
static doublereal anorm;
extern /* Subroutine */ int zlasr_(char *, char *, char *, integer *,
integer *, doublereal *, doublereal *, doublecomplex *, integer *);
static integer l1;
extern /* Subroutine */ int zswap_(integer *, doublecomplex *, integer *,
doublecomplex *, integer *), dlaev2_(doublereal *, doublereal *,
doublereal *, doublereal *, doublereal *, doublereal *,
doublereal *);
static integer lendm1, lendp1;
extern doublereal dlapy2_(doublereal *, doublereal *);
static integer ii;
extern doublereal dlamch_(char *);
static integer mm, iscale;
extern /* Subroutine */ int dlascl_(char *, integer *, integer *,
doublereal *, doublereal *, integer *, integer *, doublereal *,
integer *, integer *);
static doublereal safmin;
extern /* Subroutine */ int dlartg_(doublereal *, doublereal *,
doublereal *, doublereal *, doublereal *);
static doublereal safmax;
extern /* Subroutine */ int xerbla_(char *, integer *);
extern doublereal dlanst_(char *, integer *, doublereal *, doublereal *);
extern /* Subroutine */ int dlasrt_(char *, integer *, doublereal *,
integer *);
static integer lendsv;
static doublereal ssfmin;
static integer nmaxit, icompz;
static doublereal ssfmax;
extern /* Subroutine */ int zlaset_(char *, integer *, integer *,
doublecomplex *, doublecomplex *, doublecomplex *, integer *);
static integer lm1, mm1, nm1;
static doublereal rt1, rt2, eps;
static integer lsv;
static doublereal tst, eps2;
#define D(I) d[(I)-1]
#define E(I) e[(I)-1]
#define WORK(I) work[(I)-1]
#define Z(I,J) z[(I)-1 + ((J)-1)* ( *ldz)]
*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_("ZSTEQR", &i__1);
return 0;
}
/* Quick return if possible */
if (*n == 0) {
return 0;
}
if (*n == 1) {
if (icompz == 2) {
i__1 = z_dim1 + 1;
Z(1,1).r = 1., Z(1,1).i = 0.;
}
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) {
zlaset_("Full", n, n, &c_b1, &c_b2, &Z(1,1), 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 <= nm1; ++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 <= lendm1; ++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;
zlasr_("R", "V", "B", n, &c__2, &WORK(l), &WORK(*n - 1 + l), &
Z(1,l), 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_b41);
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 >= l; --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;
zlasr_("R", "V", "B", n, &mm, &WORK(l), &WORK(*n - 1 + l), &Z(1,l), 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 >= lendp1; --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;
zlasr_("R", "V", "F", n, &c__2, &WORK(m), &WORK(*n - 1 + m), &
Z(1,l-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_b41);
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 <= lm1; ++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;
zlasr_("R", "V", "F", n, &mm, &WORK(m), &WORK(*n - 1 + m), &Z(1,m), 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) {
i__1 = *n - 1;
for (i = 1; i <= *n-1; ++i) {
if (E(i) != 0.) {
++(*info);
}
/* L150: */
}
return 0;
}
goto L10;
/* 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 <= *n; ++ii) {
i = ii - 1;
k = i;
p = D(i);
i__2 = *n;
for (j = ii; j <= *n; ++j) {
if (D(j) < p) {
k = j;
p = D(j);
}
/* L170: */
}
if (k != i) {
D(k) = D(i);
D(i) = p;
zswap_(n, &Z(1,i), &c__1, &Z(1,k), &
c__1);
}
/* L180: */
}
}
return 0;
/* End of ZSTEQR */
} /* zsteqr_ */
/* Subroutine */ int dsterf_(integer *n, doublereal *d__, doublereal *e,
integer *info)
{
/* System generated locals */
integer i__1;
doublereal d__1, d__2, d__3;
/* Builtin functions */
double sqrt(doublereal), d_sign(doublereal *, doublereal *);
/* Local variables */
static doublereal oldc;
static integer lend, jtot;
extern /* Subroutine */ int dlae2_(doublereal *, doublereal *, doublereal
*, doublereal *, doublereal *);
static doublereal c__;
static integer i__, l, m;
static doublereal p, gamma, r__, s, alpha, sigma, anorm;
static integer l1;
extern doublereal dlapy2_(doublereal *, doublereal *);
static doublereal bb;
extern doublereal dlamch_(char *);
static integer iscale;
extern /* Subroutine */ int dlascl_(char *, integer *, integer *,
doublereal *, doublereal *, integer *, integer *, doublereal *,
integer *, integer *);
static doublereal oldgam, safmin;
extern /* Subroutine */ int xerbla_(char *, integer *);
static doublereal safmax;
extern doublereal dlanst_(char *, integer *, doublereal *, doublereal *);
extern /* Subroutine */ int dlasrt_(char *, integer *, doublereal *,
integer *);
static integer lendsv;
static doublereal ssfmin;
static integer nmaxit;
static doublereal ssfmax, rt1, rt2, eps, rte;
static integer lsv;
static doublereal eps2;
/* -- LAPACK routine (instrumented to count operations, version 3.0) --
Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
Courant Institute, Argonne National Lab, and Rice University
June 30, 1999
Common block to return operation count and iteration count
ITCNT is initialized to 0, OPS is only incremented
Purpose
=======
DSTERF computes all eigenvalues of a symmetric tridiagonal matrix
using the Pal-Walker-Kahan variant of the QL or QR algorithm.
Arguments
=========
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.
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.
INFO (output) INTEGER
= 0: successful exit
< 0: if INFO = -i, the i-th argument had an illegal value
> 0: the algorithm failed to find all of the eigenvalues in
a total of 30*N iterations; if INFO = i, then i
elements of E have not converged to zero.
=====================================================================
Test the input parameters.
Parameter adjustments */
--e;
--d__;
/* Function Body */
*info = 0;
/* Quick return if possible */
latime_1.itcnt = 0.;
if (*n < 0) {
*info = -1;
i__1 = -(*info);
xerbla_("DSTERF", &i__1);
return 0;
}
if (*n <= 1) {
return 0;
}
/* Determine the unit roundoff for this environment. */
latime_1.ops += 6;
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 of the tridiagonal matrix. */
nmaxit = *n * 30;
sigma = 0.;
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;
L10:
if (l1 > *n) {
goto L170;
}
if (l1 > 1) {
e[l1 - 1] = 0.;
}
i__1 = *n - 1;
for (m = l1; m <= i__1; ++m) {
latime_1.ops += 4;
if ((d__3 = e[m], abs(d__3)) <= 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 */
latime_1.ops += lend - l + 1 << 1;
i__1 = lend - l + 1;
anorm = dlanst_("I", &i__1, &d__[l], &e[l]);
iscale = 0;
if (anorm > ssfmax) {
iscale = 1;
latime_1.ops = latime_1.ops + (lend - l << 1) + 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;
latime_1.ops = latime_1.ops + (lend - l << 1) + 1;
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);
}
latime_1.ops += lend - l << 1;
i__1 = lend - 1;
for (i__ = l; i__ <= i__1; ++i__) {
/* Computing 2nd power */
d__1 = e[i__];
e[i__] = d__1 * d__1;
/* L40: */
}
/* 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. */
L50:
if (l != lend) {
i__1 = lend - 1;
for (m = l; m <= i__1; ++m) {
latime_1.ops += 3;
if ((d__2 = e[m], abs(d__2)) <= eps2 * (d__1 = d__[m] * d__[m
+ 1], abs(d__1))) {
goto L70;
}
/* L60: */
}
}
m = lend;
L70:
if (m < lend) {
e[m] = 0.;
}
p = d__[l];
if (m == l) {
goto L90;
}
/* If remaining matrix is 2 by 2, use DLAE2 to compute its
eigenvalues. */
if (m == l + 1) {
latime_1.ops += 16;
rte = sqrt(e[l]);
dlae2_(&d__[l], &rte, &d__[l + 1], &rt1, &rt2);
d__[l] = rt1;
d__[l + 1] = rt2;
e[l] = 0.;
l += 2;
if (l <= lend) {
goto L50;
}
goto L150;
}
if (jtot == nmaxit) {
goto L150;
}
++jtot;
/* Form shift. */
latime_1.ops += 14;
rte = sqrt(e[l]);
sigma = (d__[l + 1] - p) / (rte * 2.);
r__ = dlapy2_(&sigma, &c_b32);
sigma = p - rte / (sigma + d_sign(&r__, &sigma));
c__ = 1.;
s = 0.;
gamma = d__[m] - sigma;
p = gamma * gamma;
/* Inner loop */
latime_1.ops += (m - l) * 12;
i__1 = l;
for (i__ = m - 1; i__ >= i__1; --i__) {
bb = e[i__];
r__ = p + bb;
if (i__ != m - 1) {
e[i__ + 1] = s * r__;
}
oldc = c__;
c__ = p / r__;
s = bb / r__;
oldgam = gamma;
alpha = d__[i__];
gamma = c__ * (alpha - sigma) - s * oldgam;
d__[i__ + 1] = oldgam + (alpha - gamma);
if (c__ != 0.) {
p = gamma * gamma / c__;
} else {
p = oldc * bb;
}
/* L80: */
}
latime_1.ops += 2;
e[l] = s * p;
d__[l] = sigma + gamma;
goto L50;
/* Eigenvalue found. */
L90:
d__[l] = p;
++l;
if (l <= lend) {
goto L50;
}
goto L150;
} else {
/* QR Iteration
Look for small superdiagonal element. */
L100:
i__1 = lend + 1;
for (m = l; m >= i__1; --m) {
latime_1.ops += 3;
if ((d__2 = e[m - 1], abs(d__2)) <= eps2 * (d__1 = d__[m] * d__[m
- 1], abs(d__1))) {
goto L120;
}
/* L110: */
}
m = lend;
L120:
if (m > lend) {
e[m - 1] = 0.;
}
p = d__[l];
if (m == l) {
goto L140;
}
/* If remaining matrix is 2 by 2, use DLAE2 to compute its
eigenvalues. */
if (m == l - 1) {
latime_1.ops += 16;
rte = sqrt(e[l - 1]);
dlae2_(&d__[l], &rte, &d__[l - 1], &rt1, &rt2);
d__[l] = rt1;
d__[l - 1] = rt2;
e[l - 1] = 0.;
l += -2;
if (l >= lend) {
goto L100;
}
goto L150;
}
if (jtot == nmaxit) {
goto L150;
}
++jtot;
/* Form shift. */
latime_1.ops += 14;
rte = sqrt(e[l - 1]);
sigma = (d__[l - 1] - p) / (rte * 2.);
r__ = dlapy2_(&sigma, &c_b32);
sigma = p - rte / (sigma + d_sign(&r__, &sigma));
c__ = 1.;
s = 0.;
gamma = d__[m] - sigma;
p = gamma * gamma;
/* Inner loop */
latime_1.ops += (l - m) * 12;
i__1 = l - 1;
for (i__ = m; i__ <= i__1; ++i__) {
bb = e[i__];
r__ = p + bb;
if (i__ != m) {
e[i__ - 1] = s * r__;
}
oldc = c__;
c__ = p / r__;
s = bb / r__;
oldgam = gamma;
alpha = d__[i__ + 1];
gamma = c__ * (alpha - sigma) - s * oldgam;
d__[i__] = oldgam + (alpha - gamma);
if (c__ != 0.) {
p = gamma * gamma / c__;
} else {
p = oldc * bb;
}
/* L130: */
}
latime_1.ops += 2;
e[l - 1] = s * p;
d__[l] = sigma + gamma;
goto L100;
/* Eigenvalue found. */
L140:
d__[l] = p;
--l;
if (l >= lend) {
goto L100;
}
goto L150;
}
/* Undo scaling if necessary */
L150:
if (iscale == 1) {
latime_1.ops = latime_1.ops + lendsv - lsv + 1;
i__1 = lendsv - lsv + 1;
dlascl_("G", &c__0, &c__0, &ssfmax, &anorm, &i__1, &c__1, &d__[lsv],
n, info);
}
if (iscale == 2) {
latime_1.ops = latime_1.ops + lendsv - lsv + 1;
i__1 = lendsv - lsv + 1;
dlascl_("G", &c__0, &c__0, &ssfmin, &anorm, &i__1, &c__1, &d__[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);
}
/* L160: */
}
goto L180;
/* Sort eigenvalues in increasing order. */
L170:
dlasrt_("I", n, &d__[1], info);
L180:
return 0;
/* End of DSTERF */
} /* dsterf_ */
/* Subroutine */ int zsteqr_(char *compz, integer *n, doublereal *d__,
doublereal *e, doublecomplex *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 *);
doublereal anorm;
extern /* Subroutine */ int zlasr_(char *, char *, char *, integer *,
integer *, doublereal *, doublereal *, doublecomplex *, integer *), zswap_(integer *, doublecomplex *,
integer *, doublecomplex *, 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 *);
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;
extern /* Subroutine */ int zlaset_(char *, integer *, integer *,
doublecomplex *, doublecomplex *, doublecomplex *, integer *);
/* -- LAPACK routine (version 3.2) -- */
/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/* November 2006 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* ZSTEQR 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 complex Hermitian matrix can also */
/* be found if ZHETRD or ZHPTRD or ZHBTRD 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 */
/* Hermitian matrix. On entry, Z must contain the */
/* unitary 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) COMPLEX*16 array, dimension (LDZ, N) */
/* On entry, if COMPZ = 'V', then Z contains the unitary */
/* 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 Hermitian 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 unitarily 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_("ZSTEQR", &i__1);
return 0;
}
/* Quick return if possible */
if (*n == 0) {
return 0;
}
if (*n == 1) {
if (icompz == 2) {
i__1 = z_dim1 + 1;
z__[i__1].r = 1., z__[i__1].i = 0.;
}
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) {
zlaset_("Full", n, n, &c_b1, &c_b2, &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;
zlasr_("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_b41);
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;
zlasr_("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;
zlasr_("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_b41);
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;
zlasr_("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) {
i__1 = *n - 1;
for (i__ = 1; i__ <= i__1; ++i__) {
if (e[i__] != 0.) {
++(*info);
}
/* L150: */
}
return 0;
}
goto L10;
/* 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;
zswap_(n, &z__[i__ * z_dim1 + 1], &c__1, &z__[k * z_dim1 + 1],
&c__1);
}
/* L180: */
}
}
return 0;
/* End of ZSTEQR */
} /* zsteqr_ */
/* Subroutine */ int dlalsd_(char *uplo, integer *smlsiz, integer *n, integer
*nrhs, doublereal *d__, doublereal *e, doublereal *b, integer *ldb,
doublereal *rcond, integer *rank, doublereal *work, integer *iwork,
integer *info)
{
/* System generated locals */
integer b_dim1, b_offset, i__1, i__2;
doublereal d__1;
/* Builtin functions */
double log(doublereal), d_sign(doublereal *, doublereal *);
/* Local variables */
integer c__, i__, j, k;
doublereal r__;
integer s, u, z__;
doublereal cs;
integer bx;
doublereal sn;
integer st, vt, nm1, st1;
doublereal eps;
integer iwk;
doublereal tol;
integer difl, difr;
doublereal rcnd;
integer perm, nsub;
extern /* Subroutine */ int drot_(integer *, doublereal *, integer *,
doublereal *, integer *, doublereal *, doublereal *);
integer nlvl, sqre, bxst;
extern /* Subroutine */ int dgemm_(char *, char *, integer *, integer *,
integer *, doublereal *, doublereal *, integer *, doublereal *,
integer *, doublereal *, doublereal *, integer *),
dcopy_(integer *, doublereal *, integer *, doublereal *, integer
*);
integer poles, sizei, nsize, nwork, icmpq1, icmpq2;
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 *), dlalsa_(integer *, integer *, integer *, integer *,
doublereal *, integer *, doublereal *, integer *, doublereal *,
integer *, doublereal *, integer *, doublereal *, doublereal *,
doublereal *, doublereal *, integer *, integer *, integer *,
integer *, doublereal *, doublereal *, doublereal *, doublereal *,
integer *, integer *), dlascl_(char *, integer *, integer *,
doublereal *, doublereal *, integer *, integer *, doublereal *,
integer *, integer *);
extern integer idamax_(integer *, doublereal *, integer *);
extern /* Subroutine */ int dlasdq_(char *, integer *, integer *, integer
*, integer *, integer *, doublereal *, doublereal *, doublereal *,
integer *, doublereal *, integer *, doublereal *, integer *,
doublereal *, integer *), dlacpy_(char *, integer *,
integer *, doublereal *, integer *, doublereal *, integer *), dlartg_(doublereal *, doublereal *, doublereal *,
doublereal *, doublereal *), dlaset_(char *, integer *, integer *,
doublereal *, doublereal *, doublereal *, integer *),
xerbla_(char *, integer *);
integer givcol;
extern doublereal dlanst_(char *, integer *, doublereal *, doublereal *);
extern /* Subroutine */ int dlasrt_(char *, integer *, doublereal *,
integer *);
doublereal orgnrm;
integer givnum, givptr, smlszp;
/* -- LAPACK routine (version 3.2) -- */
/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/* November 2006 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* DLALSD uses the singular value decomposition of A to solve the least */
/* squares problem of finding X to minimize the Euclidean norm of each */
/* column of A*X-B, where A is N-by-N upper bidiagonal, and X and B */
/* are N-by-NRHS. The solution X overwrites B. */
/* The singular values of A smaller than RCOND times the largest */
/* singular value are treated as zero in solving the least squares */
/* problem; in this case a minimum norm solution is returned. */
/* The actual singular values are returned in D in ascending order. */
/* This code makes very mild assumptions about floating point */
/* arithmetic. It will work on machines with a guard digit in */
/* add/subtract, or on those binary machines without guard digits */
/* which subtract like the Cray XMP, Cray YMP, Cray C 90, or Cray 2. */
/* It could conceivably fail on hexadecimal or decimal machines */
/* without guard digits, but we know of none. */
/* Arguments */
/* ========= */
/* UPLO (input) CHARACTER*1 */
/* = 'U': D and E define an upper bidiagonal matrix. */
/* = 'L': D and E define a lower bidiagonal matrix. */
/* SMLSIZ (input) INTEGER */
/* The maximum size of the subproblems at the bottom of the */
/* computation tree. */
/* N (input) INTEGER */
/* The dimension of the bidiagonal matrix. N >= 0. */
/* NRHS (input) INTEGER */
/* The number of columns of B. NRHS must be at least 1. */
/* D (input/output) DOUBLE PRECISION array, dimension (N) */
/* On entry D contains the main diagonal of the bidiagonal */
/* matrix. On exit, if INFO = 0, D contains its singular values. */
/* E (input/output) DOUBLE PRECISION array, dimension (N-1) */
/* Contains the super-diagonal entries of the bidiagonal matrix. */
/* On exit, E has been destroyed. */
/* B (input/output) DOUBLE PRECISION array, dimension (LDB,NRHS) */
/* On input, B contains the right hand sides of the least */
/* squares problem. On output, B contains the solution X. */
/* LDB (input) INTEGER */
/* The leading dimension of B in the calling subprogram. */
/* LDB must be at least max(1,N). */
/* RCOND (input) DOUBLE PRECISION */
/* The singular values of A less than or equal to RCOND times */
/* the largest singular value are treated as zero in solving */
/* the least squares problem. If RCOND is negative, */
/* machine precision is used instead. */
/* For example, if diag(S)*X=B were the least squares problem, */
/* where diag(S) is a diagonal matrix of singular values, the */
/* solution would be X(i) = B(i) / S(i) if S(i) is greater than */
/* RCOND*max(S), and X(i) = 0 if S(i) is less than or equal to */
/* RCOND*max(S). */
/* RANK (output) INTEGER */
/* The number of singular values of A greater than RCOND times */
/* the largest singular value. */
/* WORK (workspace) DOUBLE PRECISION array, dimension at least */
/* (9*N + 2*N*SMLSIZ + 8*N*NLVL + N*NRHS + (SMLSIZ+1)**2), */
/* where NLVL = max(0, INT(log_2 (N/(SMLSIZ+1))) + 1). */
/* IWORK (workspace) INTEGER array, dimension at least */
/* (3*N*NLVL + 11*N) */
/* INFO (output) INTEGER */
/* = 0: successful exit. */
/* < 0: if INFO = -i, the i-th argument had an illegal value. */
/* > 0: The algorithm failed to compute an singular value while */
/* working on the submatrix lying in rows and columns */
/* INFO/(N+1) through MOD(INFO,N+1). */
/* Further Details */
/* =============== */
/* Based on contributions by */
/* Ming Gu and Ren-Cang Li, Computer Science Division, University of */
/* California at Berkeley, USA */
/* Osni Marques, LBNL/NERSC, USA */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Executable Statements .. */
/* Test the input parameters. */
/* Parameter adjustments */
--d__;
--e;
b_dim1 = *ldb;
b_offset = 1 + b_dim1;
b -= b_offset;
--work;
--iwork;
/* Function Body */
*info = 0;
if (*n < 0) {
*info = -3;
} else if (*nrhs < 1) {
*info = -4;
} else if (*ldb < 1 || *ldb < *n) {
*info = -8;
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("DLALSD", &i__1);
return 0;
}
eps = dlamch_("Epsilon");
/* Set up the tolerance. */
if (*rcond <= 0. || *rcond >= 1.) {
rcnd = eps;
} else {
rcnd = *rcond;
}
*rank = 0;
/* Quick return if possible. */
if (*n == 0) {
return 0;
} else if (*n == 1) {
if (d__[1] == 0.) {
dlaset_("A", &c__1, nrhs, &c_b6, &c_b6, &b[b_offset], ldb);
} else {
*rank = 1;
dlascl_("G", &c__0, &c__0, &d__[1], &c_b11, &c__1, nrhs, &b[
b_offset], ldb, info);
d__[1] = abs(d__[1]);
}
return 0;
}
/* Rotate the matrix if it is lower bidiagonal. */
if (*(unsigned char *)uplo == 'L') {
i__1 = *n - 1;
for (i__ = 1; i__ <= i__1; ++i__) {
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 (*nrhs == 1) {
drot_(&c__1, &b[i__ + b_dim1], &c__1, &b[i__ + 1 + b_dim1], &
c__1, &cs, &sn);
} else {
work[(i__ << 1) - 1] = cs;
work[i__ * 2] = sn;
}
/* L10: */
}
if (*nrhs > 1) {
i__1 = *nrhs;
for (i__ = 1; i__ <= i__1; ++i__) {
i__2 = *n - 1;
for (j = 1; j <= i__2; ++j) {
cs = work[(j << 1) - 1];
sn = work[j * 2];
drot_(&c__1, &b[j + i__ * b_dim1], &c__1, &b[j + 1 + i__ *
b_dim1], &c__1, &cs, &sn);
/* L20: */
}
/* L30: */
}
}
}
/* Scale. */
nm1 = *n - 1;
orgnrm = dlanst_("M", n, &d__[1], &e[1]);
if (orgnrm == 0.) {
dlaset_("A", n, nrhs, &c_b6, &c_b6, &b[b_offset], ldb);
return 0;
}
dlascl_("G", &c__0, &c__0, &orgnrm, &c_b11, n, &c__1, &d__[1], n, info);
dlascl_("G", &c__0, &c__0, &orgnrm, &c_b11, &nm1, &c__1, &e[1], &nm1,
info);
/* If N is smaller than the minimum divide size SMLSIZ, then solve */
/* the problem with another solver. */
if (*n <= *smlsiz) {
nwork = *n * *n + 1;
dlaset_("A", n, n, &c_b6, &c_b11, &work[1], n);
dlasdq_("U", &c__0, n, n, &c__0, nrhs, &d__[1], &e[1], &work[1], n, &
work[1], n, &b[b_offset], ldb, &work[nwork], info);
if (*info != 0) {
return 0;
}
tol = rcnd * (d__1 = d__[idamax_(n, &d__[1], &c__1)], abs(d__1));
i__1 = *n;
for (i__ = 1; i__ <= i__1; ++i__) {
if (d__[i__] <= tol) {
dlaset_("A", &c__1, nrhs, &c_b6, &c_b6, &b[i__ + b_dim1], ldb);
} else {
dlascl_("G", &c__0, &c__0, &d__[i__], &c_b11, &c__1, nrhs, &b[
i__ + b_dim1], ldb, info);
++(*rank);
}
/* L40: */
}
dgemm_("T", "N", n, nrhs, n, &c_b11, &work[1], n, &b[b_offset], ldb, &
c_b6, &work[nwork], n);
dlacpy_("A", n, nrhs, &work[nwork], n, &b[b_offset], ldb);
/* Unscale. */
dlascl_("G", &c__0, &c__0, &c_b11, &orgnrm, n, &c__1, &d__[1], n,
info);
dlasrt_("D", n, &d__[1], info);
dlascl_("G", &c__0, &c__0, &orgnrm, &c_b11, n, nrhs, &b[b_offset],
ldb, info);
return 0;
}
/* Book-keeping and setting up some constants. */
nlvl = (integer) (log((doublereal) (*n) / (doublereal) (*smlsiz + 1)) /
log(2.)) + 1;
smlszp = *smlsiz + 1;
u = 1;
vt = *smlsiz * *n + 1;
difl = vt + smlszp * *n;
difr = difl + nlvl * *n;
z__ = difr + (nlvl * *n << 1);
c__ = z__ + nlvl * *n;
s = c__ + *n;
poles = s + *n;
givnum = poles + (nlvl << 1) * *n;
bx = givnum + (nlvl << 1) * *n;
nwork = bx + *n * *nrhs;
sizei = *n + 1;
k = sizei + *n;
givptr = k + *n;
perm = givptr + *n;
givcol = perm + nlvl * *n;
iwk = givcol + (nlvl * *n << 1);
st = 1;
sqre = 0;
icmpq1 = 1;
icmpq2 = 0;
nsub = 0;
i__1 = *n;
for (i__ = 1; i__ <= i__1; ++i__) {
if ((d__1 = d__[i__], abs(d__1)) < eps) {
d__[i__] = d_sign(&eps, &d__[i__]);
}
/* L50: */
}
i__1 = nm1;
for (i__ = 1; i__ <= i__1; ++i__) {
if ((d__1 = e[i__], abs(d__1)) < eps || i__ == nm1) {
++nsub;
iwork[nsub] = st;
/* Subproblem found. First determine its size and then */
/* apply divide and conquer on it. */
if (i__ < nm1) {
/* A subproblem with E(I) small for I < NM1. */
nsize = i__ - st + 1;
iwork[sizei + nsub - 1] = nsize;
} else if ((d__1 = e[i__], abs(d__1)) >= eps) {
/* A subproblem with E(NM1) not too small but I = NM1. */
nsize = *n - st + 1;
iwork[sizei + nsub - 1] = nsize;
} else {
/* A subproblem with E(NM1) small. This implies an */
/* 1-by-1 subproblem at D(N), which is not solved */
/* explicitly. */
nsize = i__ - st + 1;
iwork[sizei + nsub - 1] = nsize;
++nsub;
iwork[nsub] = *n;
iwork[sizei + nsub - 1] = 1;
dcopy_(nrhs, &b[*n + b_dim1], ldb, &work[bx + nm1], n);
}
st1 = st - 1;
if (nsize == 1) {
/* This is a 1-by-1 subproblem and is not solved */
/* explicitly. */
dcopy_(nrhs, &b[st + b_dim1], ldb, &work[bx + st1], n);
} else if (nsize <= *smlsiz) {
/* This is a small subproblem and is solved by DLASDQ. */
dlaset_("A", &nsize, &nsize, &c_b6, &c_b11, &work[vt + st1],
n);
dlasdq_("U", &c__0, &nsize, &nsize, &c__0, nrhs, &d__[st], &e[
st], &work[vt + st1], n, &work[nwork], n, &b[st +
b_dim1], ldb, &work[nwork], info);
if (*info != 0) {
return 0;
}
dlacpy_("A", &nsize, nrhs, &b[st + b_dim1], ldb, &work[bx +
st1], n);
} else {
/* A large problem. Solve it using divide and conquer. */
dlasda_(&icmpq1, smlsiz, &nsize, &sqre, &d__[st], &e[st], &
work[u + st1], n, &work[vt + st1], &iwork[k + st1], &
work[difl + st1], &work[difr + st1], &work[z__ + st1],
&work[poles + st1], &iwork[givptr + st1], &iwork[
givcol + st1], n, &iwork[perm + st1], &work[givnum +
st1], &work[c__ + st1], &work[s + st1], &work[nwork],
&iwork[iwk], info);
if (*info != 0) {
return 0;
}
bxst = bx + st1;
dlalsa_(&icmpq2, smlsiz, &nsize, nrhs, &b[st + b_dim1], ldb, &
work[bxst], n, &work[u + st1], n, &work[vt + st1], &
iwork[k + st1], &work[difl + st1], &work[difr + st1],
&work[z__ + st1], &work[poles + st1], &iwork[givptr +
st1], &iwork[givcol + st1], n, &iwork[perm + st1], &
work[givnum + st1], &work[c__ + st1], &work[s + st1],
&work[nwork], &iwork[iwk], info);
if (*info != 0) {
return 0;
}
}
st = i__ + 1;
}
/* L60: */
}
/* Apply the singular values and treat the tiny ones as zero. */
tol = rcnd * (d__1 = d__[idamax_(n, &d__[1], &c__1)], abs(d__1));
i__1 = *n;
for (i__ = 1; i__ <= i__1; ++i__) {
/* Some of the elements in D can be negative because 1-by-1 */
/* subproblems were not solved explicitly. */
if ((d__1 = d__[i__], abs(d__1)) <= tol) {
dlaset_("A", &c__1, nrhs, &c_b6, &c_b6, &work[bx + i__ - 1], n);
} else {
++(*rank);
dlascl_("G", &c__0, &c__0, &d__[i__], &c_b11, &c__1, nrhs, &work[
bx + i__ - 1], n, info);
}
d__[i__] = (d__1 = d__[i__], abs(d__1));
/* L70: */
}
/* Now apply back the right singular vectors. */
icmpq2 = 1;
i__1 = nsub;
for (i__ = 1; i__ <= i__1; ++i__) {
st = iwork[i__];
st1 = st - 1;
nsize = iwork[sizei + i__ - 1];
bxst = bx + st1;
if (nsize == 1) {
dcopy_(nrhs, &work[bxst], n, &b[st + b_dim1], ldb);
} else if (nsize <= *smlsiz) {
dgemm_("T", "N", &nsize, nrhs, &nsize, &c_b11, &work[vt + st1], n,
&work[bxst], n, &c_b6, &b[st + b_dim1], ldb);
} else {
dlalsa_(&icmpq2, smlsiz, &nsize, nrhs, &work[bxst], n, &b[st +
b_dim1], ldb, &work[u + st1], n, &work[vt + st1], &iwork[
k + st1], &work[difl + st1], &work[difr + st1], &work[z__
+ st1], &work[poles + st1], &iwork[givptr + st1], &iwork[
givcol + st1], n, &iwork[perm + st1], &work[givnum + st1],
&work[c__ + st1], &work[s + st1], &work[nwork], &iwork[
iwk], info);
if (*info != 0) {
return 0;
}
}
/* L80: */
}
/* Unscale and sort the singular values. */
dlascl_("G", &c__0, &c__0, &c_b11, &orgnrm, n, &c__1, &d__[1], n, info);
dlasrt_("D", n, &d__[1], info);
dlascl_("G", &c__0, &c__0, &orgnrm, &c_b11, n, nrhs, &b[b_offset], ldb,
info);
return 0;
/* End of DLALSD */
} /* dlalsd_ */
/* Subroutine */ int dstev_(char *jobz, integer *n, doublereal *d__,
doublereal *e, doublereal *z__, integer *ldz, doublereal *work,
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
September 30, 1994
Purpose
=======
DSTEV computes all eigenvalues and, optionally, eigenvectors of a
real symmetric tridiagonal matrix A.
Arguments
=========
JOBZ (input) CHARACTER*1
= 'N': Compute eigenvalues only;
= 'V': Compute eigenvalues and eigenvectors.
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
A.
On exit, if INFO = 0, the eigenvalues in ascending order.
E (input/output) DOUBLE PRECISION array, dimension (N)
On entry, the (n-1) subdiagonal elements of the tridiagonal
matrix A, stored in elements 1 to N-1 of E; E(N) need not
be set, but is used by the routine.
On exit, the contents of E are destroyed.
Z (output) DOUBLE PRECISION array, dimension (LDZ, N)
If JOBZ = 'V', then if INFO = 0, Z contains the orthonormal
eigenvectors of the matrix A, with the i-th column of Z
holding the eigenvector associated with D(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) DOUBLE PRECISION array, dimension (max(1,2*N-2))
If JOBZ = 'N', WORK 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, the algorithm failed to converge; i
off-diagonal elements of E did not converge to zero.
=====================================================================
Test the input parameters.
Parameter adjustments */
/* Table of constant values */
static integer c__1 = 1;
/* System generated locals */
integer z_dim1, z_offset, i__1;
doublereal d__1;
/* Builtin functions */
double sqrt(doublereal);
/* Local variables */
static integer imax;
static doublereal rmin, rmax, tnrm;
extern /* Subroutine */ int dscal_(integer *, doublereal *, doublereal *,
integer *);
static doublereal sigma;
extern logical lsame_(char *, char *);
static logical wantz;
extern doublereal dlamch_(char *);
static integer iscale;
static doublereal safmin;
extern /* Subroutine */ int xerbla_(char *, integer *);
static doublereal bignum;
extern doublereal dlanst_(char *, integer *, doublereal *, doublereal *);
extern /* Subroutine */ int dsterf_(integer *, doublereal *, doublereal *,
integer *), dsteqr_(char *, integer *, doublereal *, doublereal *
, doublereal *, integer *, doublereal *, integer *);
static doublereal smlnum, eps;
#define z___ref(a_1,a_2) z__[(a_2)*z_dim1 + a_1]
--d__;
--e;
z_dim1 = *ldz;
z_offset = 1 + z_dim1 * 1;
z__ -= z_offset;
--work;
/* Function Body */
wantz = lsame_(jobz, "V");
*info = 0;
if (! (wantz || lsame_(jobz, "N"))) {
*info = -1;
} else if (*n < 0) {
*info = -2;
} else if (*ldz < 1 || wantz && *ldz < *n) {
*info = -6;
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("DSTEV ", &i__1);
return 0;
}
/* Quick return if possible */
if (*n == 0) {
return 0;
}
if (*n == 1) {
if (wantz) {
z___ref(1, 1) = 1.;
}
return 0;
}
/* Get machine constants. */
safmin = dlamch_("Safe minimum");
eps = dlamch_("Precision");
smlnum = safmin / eps;
bignum = 1. / smlnum;
rmin = sqrt(smlnum);
rmax = sqrt(bignum);
/* Scale matrix to allowable range, if necessary. */
iscale = 0;
tnrm = dlanst_("M", n, &d__[1], &e[1]);
if (tnrm > 0. && tnrm < rmin) {
iscale = 1;
sigma = rmin / tnrm;
} else if (tnrm > rmax) {
iscale = 1;
sigma = rmax / tnrm;
}
if (iscale == 1) {
dscal_(n, &sigma, &d__[1], &c__1);
i__1 = *n - 1;
dscal_(&i__1, &sigma, &e[1], &c__1);
}
/* For eigenvalues only, call DSTERF. For eigenvalues and
eigenvectors, call DSTEQR. */
if (! wantz) {
dsterf_(n, &d__[1], &e[1], info);
} else {
dsteqr_("I", n, &d__[1], &e[1], &z__[z_offset], ldz, &work[1], info);
}
/* If matrix was scaled, then rescale eigenvalues appropriately. */
if (iscale == 1) {
if (*info == 0) {
imax = *n;
} else {
imax = *info - 1;
}
d__1 = 1. / sigma;
dscal_(&imax, &d__1, &d__[1], &c__1);
}
return 0;
/* End of DSTEV */
} /* dstev_ */
/* 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 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 */
--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_("M", &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 */
}
/* Subroutine */ int dstedc_(char *compz, integer *n, doublereal *d__,
doublereal *e, doublereal *z__, integer *ldz, doublereal *work,
integer *lwork, integer *iwork, integer *liwork, 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
=======
DSTEDC computes all eigenvalues and, optionally, eigenvectors of a
symmetric tridiagonal matrix using the divide and conquer method.
The eigenvectors of a full or band real symmetric matrix can also be
found if DSYTRD or DSPTRD or DSBTRD has been used to reduce this
matrix to tridiagonal 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 DLAED3 for details.
Arguments
=========
COMPZ (input) CHARACTER*1
= 'N': Compute eigenvalues only.
= 'I': Compute eigenvectors of tridiagonal matrix also.
= 'V': Compute eigenvectors of original dense symmetric
matrix also. On entry, Z contains the orthogonal
matrix used to reduce the original matrix to
tridiagonal form.
N (input) INTEGER
The dimension of the symmetric tridiagonal 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 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.
If eigenvectors are desired, then LDZ >= max(1,N).
WORK (workspace/output) DOUBLE PRECISION array,
dimension (LWORK)
On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
LWORK (input) INTEGER
The dimension of the array WORK.
If COMPZ = 'N' or N <= 1 then LWORK must be at least 1.
If COMPZ = 'V' and N > 1 then LWORK must be at least
( 1 + 3*N + 2*N*lg N + 3*N**2 ),
where lg( N ) = smallest integer k such
that 2**k >= N.
If COMPZ = 'I' and N > 1 then LWORK must be at least
( 1 + 4*N + N**2 ).
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.
If COMPZ = 'N' or N <= 1 then LIWORK must be at least 1.
If COMPZ = 'V' and N > 1 then LIWORK must be at least
( 6 + 6*N + 5*N*lg N ).
If COMPZ = 'I' and N > 1 then LIWORK must be at least
( 3 + 5*N ).
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
= 0: successful exit.
< 0: if INFO = -i, the i-th argument had an illegal value.
> 0: The algorithm failed to compute an eigenvalue while
working on the submatrix lying in rows and columns
INFO/(N+1) through mod(INFO,N+1).
Further Details
===============
Based on contributions by
Jeff Rutter, Computer Science Division, University of California
at Berkeley, USA
Modified by Francoise Tisseur, University of Tennessee.
=====================================================================
Test the input parameters.
Parameter adjustments */
/* Table of constant values */
static integer c__2 = 2;
static integer c__9 = 9;
static integer c__0 = 0;
static doublereal c_b18 = 0.;
static doublereal c_b19 = 1.;
static integer c__1 = 1;
/* System generated locals */
integer z_dim1, z_offset, i__1, i__2;
doublereal d__1, d__2;
/* Builtin functions */
double log(doublereal);
integer pow_ii(integer *, integer *);
double sqrt(doublereal);
/* Local variables */
static doublereal tiny;
static integer i__, j, k, m;
static doublereal p;
extern /* Subroutine */ int dgemm_(char *, char *, integer *, integer *,
integer *, doublereal *, doublereal *, integer *, doublereal *,
integer *, doublereal *, doublereal *, integer *);
extern logical lsame_(char *, char *);
extern /* Subroutine */ int dswap_(integer *, doublereal *, integer *,
doublereal *, integer *);
static integer lwmin;
extern /* Subroutine */ int dlaed0_(integer *, integer *, integer *,
doublereal *, doublereal *, doublereal *, integer *, doublereal *,
integer *, doublereal *, integer *, integer *);
static integer start, ii;
extern doublereal dlamch_(char *);
extern /* Subroutine */ int dlascl_(char *, integer *, integer *,
doublereal *, doublereal *, integer *, integer *, doublereal *,
integer *, integer *), dlacpy_(char *, integer *, integer
*, doublereal *, integer *, doublereal *, integer *),
dlaset_(char *, integer *, integer *, doublereal *, doublereal *,
doublereal *, integer *);
extern integer ilaenv_(integer *, char *, char *, integer *, integer *,
integer *, integer *, ftnlen, ftnlen);
extern /* Subroutine */ int xerbla_(char *, integer *);
extern doublereal dlanst_(char *, integer *, doublereal *, doublereal *);
extern /* Subroutine */ int dsterf_(integer *, doublereal *, doublereal *,
integer *), dlasrt_(char *, integer *, doublereal *, integer *);
static integer liwmin, icompz;
extern /* Subroutine */ int dsteqr_(char *, integer *, doublereal *,
doublereal *, doublereal *, integer *, doublereal *, integer *);
static doublereal orgnrm;
static logical lquery;
static integer smlsiz, dtrtrw, storez, end, lgn;
static doublereal eps;
#define z___ref(a_1,a_2) z__[(a_2)*z_dim1 + a_1]
--d__;
--e;
z_dim1 = *ldz;
z_offset = 1 + z_dim1 * 1;
z__ -= z_offset;
--work;
--iwork;
/* Function Body */
*info = 0;
lquery = *lwork == -1 || *liwork == -1;
if (lsame_(compz, "N")) {
icompz = 0;
} else if (lsame_(compz, "V")) {
icompz = 1;
} else if (lsame_(compz, "I")) {
icompz = 2;
} else {
icompz = -1;
}
if (*n <= 1 || icompz <= 0) {
liwmin = 1;
lwmin = 1;
} else {
lgn = (integer) (log((doublereal) (*n)) / log(2.));
if (pow_ii(&c__2, &lgn) < *n) {
++lgn;
}
if (pow_ii(&c__2, &lgn) < *n) {
++lgn;
}
if (icompz == 1) {
/* Computing 2nd power */
i__1 = *n;
lwmin = *n * 3 + 1 + (*n << 1) * lgn + i__1 * i__1 * 3;
liwmin = *n * 6 + 6 + *n * 5 * lgn;
} else if (icompz == 2) {
/* Computing 2nd power */
i__1 = *n;
lwmin = (*n << 2) + 1 + i__1 * i__1;
liwmin = *n * 5 + 3;
}
}
if (icompz < 0) {
*info = -1;
} else if (*n < 0) {
*info = -2;
} else if (*ldz < 1 || icompz > 0 && *ldz < max(1,*n)) {
*info = -6;
} else if (*lwork < lwmin && ! lquery) {
*info = -8;
} else if (*liwork < liwmin && ! lquery) {
*info = -10;
}
if (*info == 0) {
work[1] = (doublereal) lwmin;
iwork[1] = liwmin;
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("DSTEDC", &i__1);
return 0;
} else if (lquery) {
return 0;
}
/* Quick return if possible */
if (*n == 0) {
return 0;
}
if (*n == 1) {
if (icompz != 0) {
z___ref(1, 1) = 1.;
}
return 0;
}
smlsiz = ilaenv_(&c__9, "DSTEDC", " ", &c__0, &c__0, &c__0, &c__0, (
ftnlen)6, (ftnlen)1);
/* If the following conditional clause is removed, then the routine
will use the Divide and Conquer routine to compute only the
eigenvalues, which requires (3N + 3N**2) real workspace and
(2 + 5N + 2N lg(N)) integer workspace.
Since on many architectures DSTERF is much faster than any other
algorithm for finding eigenvalues only, it is used here
as the default.
If COMPZ = 'N', use DSTERF to compute the eigenvalues. */
if (icompz == 0) {
dsterf_(n, &d__[1], &e[1], info);
return 0;
}
/* If N is smaller than the minimum divide size (SMLSIZ+1), then
solve the problem with another solver. */
if (*n <= smlsiz) {
if (icompz == 0) {
dsterf_(n, &d__[1], &e[1], info);
return 0;
} else if (icompz == 2) {
dsteqr_("I", n, &d__[1], &e[1], &z__[z_offset], ldz, &work[1],
info);
return 0;
} else {
dsteqr_("V", n, &d__[1], &e[1], &z__[z_offset], ldz, &work[1],
info);
return 0;
}
}
/* If COMPZ = 'V', the Z matrix must be stored elsewhere for later
use. */
if (icompz == 1) {
storez = *n * *n + 1;
} else {
storez = 1;
}
if (icompz == 2) {
dlaset_("Full", n, n, &c_b18, &c_b19, &z__[z_offset], ldz);
}
/* Scale. */
orgnrm = dlanst_("M", n, &d__[1], &e[1]);
if (orgnrm == 0.) {
return 0;
}
eps = dlamch_("Epsilon");
start = 1;
/* while ( START <= N ) */
L10:
if (start <= *n) {
/* Let END be the position of the next subdiagonal entry such that
E( END ) <= TINY or END = N if no such subdiagonal exists. The
matrix identified by the elements between START and END
constitutes an independent sub-problem. */
end = start;
L20:
if (end < *n) {
tiny = eps * sqrt((d__1 = d__[end], abs(d__1))) * sqrt((d__2 =
d__[end + 1], abs(d__2)));
if ((d__1 = e[end], abs(d__1)) > tiny) {
++end;
goto L20;
}
}
/* (Sub) Problem determined. Compute its size and solve it. */
m = end - start + 1;
if (m == 1) {
start = end + 1;
goto L10;
}
if (m > smlsiz) {
*info = smlsiz;
/* Scale. */
orgnrm = dlanst_("M", &m, &d__[start], &e[start]);
dlascl_("G", &c__0, &c__0, &orgnrm, &c_b19, &m, &c__1, &d__[start]
, &m, info);
i__1 = m - 1;
i__2 = m - 1;
dlascl_("G", &c__0, &c__0, &orgnrm, &c_b19, &i__1, &c__1, &e[
start], &i__2, info);
if (icompz == 1) {
dtrtrw = 1;
} else {
dtrtrw = start;
}
dlaed0_(&icompz, n, &m, &d__[start], &e[start], &z___ref(dtrtrw,
start), ldz, &work[1], n, &work[storez], &iwork[1], info);
if (*info != 0) {
*info = (*info / (m + 1) + start - 1) * (*n + 1) + *info % (m
+ 1) + start - 1;
return 0;
}
/* Scale back. */
dlascl_("G", &c__0, &c__0, &c_b19, &orgnrm, &m, &c__1, &d__[start]
, &m, info);
} else {
if (icompz == 1) {
/* Since QR won't update a Z matrix which is larger than the
length of D, we must solve the sub-problem in a workspace and
then multiply back into Z. */
dsteqr_("I", &m, &d__[start], &e[start], &work[1], &m, &work[
m * m + 1], info);
dlacpy_("A", n, &m, &z___ref(1, start), ldz, &work[storez], n);
dgemm_("N", "N", n, &m, &m, &c_b19, &work[storez], ldz, &work[
1], &m, &c_b18, &z___ref(1, start), ldz);
} else if (icompz == 2) {
dsteqr_("I", &m, &d__[start], &e[start], &z___ref(start,
start), ldz, &work[1], info);
} else {
dsterf_(&m, &d__[start], &e[start], info);
}
if (*info != 0) {
*info = start * (*n + 1) + end;
return 0;
}
}
start = end + 1;
goto L10;
}
/* endwhile
If the problem split any number of times, then the eigenvalues
will not be properly ordered. Here we permute the eigenvalues
(and the associated eigenvectors) into ascending order. */
if (m != *n) {
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];
}
/* L30: */
}
if (k != i__) {
d__[k] = d__[i__];
d__[i__] = p;
dswap_(n, &z___ref(1, i__), &c__1, &z___ref(1, k), &c__1);
}
/* L40: */
}
}
}
work[1] = (doublereal) lwmin;
iwork[1] = liwmin;
return 0;
/* End of DSTEDC */
} /* dstedc_ */
/* Subroutine */
int zstemr_(char *jobz, char *range, integer *n, doublereal * d__, doublereal *e, doublereal *vl, doublereal *vu, integer *il, integer *iu, integer *m, doublereal *w, doublecomplex *z__, integer * ldz, integer *nzc, integer *isuppz, logical *tryrac, doublereal *work, integer *lwork, integer *iwork, integer *liwork, integer *info)
{
/* System generated locals */
integer z_dim1, z_offset, i__1, i__2;
doublereal d__1, d__2;
/* Builtin functions */
double sqrt(doublereal);
/* Local variables */
integer i__, j;
doublereal r1, r2;
integer jj;
doublereal cs;
integer in;
doublereal sn, wl, wu;
integer iil, iiu;
doublereal eps, tmp;
integer indd, iend, jblk, wend;
doublereal rmin, rmax;
integer itmp;
doublereal tnrm;
extern /* Subroutine */
int dlae2_(doublereal *, doublereal *, doublereal *, doublereal *, doublereal *);
integer inde2, itmp2;
doublereal rtol1, rtol2;
extern /* Subroutine */
int dscal_(integer *, doublereal *, doublereal *, integer *);
doublereal scale;
integer indgp;
extern logical lsame_(char *, char *);
integer iinfo, iindw, ilast;
extern /* Subroutine */
int dcopy_(integer *, doublereal *, integer *, doublereal *, integer *);
integer lwmin;
logical wantz;
extern /* Subroutine */
int zswap_(integer *, doublecomplex *, integer *, doublecomplex *, integer *), dlaev2_(doublereal *, doublereal *, doublereal *, doublereal *, doublereal *, doublereal *, doublereal *);
extern doublereal dlamch_(char *);
logical alleig;
integer ibegin;
logical indeig;
integer iindbl;
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 *);
integer wbegin;
doublereal safmin;
extern /* Subroutine */
int dlarrj_(integer *, doublereal *, doublereal *, integer *, integer *, doublereal *, integer *, doublereal *, doublereal *, doublereal *, integer *, doublereal *, doublereal *, integer *), xerbla_(char *, integer *);
doublereal bignum;
integer inderr, iindwk, indgrs, offset;
extern doublereal dlanst_(char *, integer *, doublereal *, doublereal *);
extern /* Subroutine */
int dlarrr_(integer *, doublereal *, doublereal *, integer *), dlasrt_(char *, integer *, doublereal *, integer *);
doublereal thresh;
integer iinspl, indwrk, ifirst, liwmin, nzcmin;
doublereal pivmin;
integer nsplit;
doublereal smlnum;
extern /* Subroutine */
int zlarrv_(integer *, doublereal *, doublereal *, doublereal *, doublereal *, doublereal *, integer *, integer *, integer *, integer *, doublereal *, doublereal *, doublereal *, doublereal *, doublereal *, doublereal *, integer *, integer *, doublereal *, doublecomplex *, integer *, integer *, doublereal *, integer *, integer *);
logical lquery, zquery;
/* -- LAPACK computational 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 Functions .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Executable Statements .. */
/* Test the input parameters. */
/* Parameter adjustments */
--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;
/* 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, ZLARRV 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;
nsplit = 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)); // , expr subst
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)
{
i__1 = z_dim1 + 1;
z__[i__1].r = (doublereal) nzcmin;
z__[i__1].i = 0.; // , expr subst
}
else if (*nzc < nzcmin && ! zquery)
{
*info = -14;
}
}
if (*info != 0)
{
i__1 = -(*info);
xerbla_("ZSTEMR", &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)
{
i__1 = z_dim1 + 1;
z__[i__1].r = 1.;
z__[i__1].i = 0.; // , expr subst
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)
{
i__1 = *m * z_dim1 + 1;
d__1 = -sn;
z__[i__1].r = d__1;
z__[i__1].i = 0.; // , expr subst
i__1 = *m * z_dim1 + 2;
z__[i__1].r = cs;
z__[i__1].i = 0.; // , expr subst
/* 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)
{
i__1 = *m * z_dim1 + 1;
z__[i__1].r = cs;
z__[i__1].i = 0.; // , expr subst
i__1 = *m * z_dim1 + 2;
z__[i__1].r = sn;
z__[i__1].i = 0.; // , expr subst
/* 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;
}
}
}
}
else
{
/* 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. */
/* ZLARRV will refine the eigenvalue approximations, and we only */
/* 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.; // , expr subst
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 = f2c_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 */
zlarrv_(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 = f2c_abs(iinfo) + 20;
return 0;
}
}
else
{
/* DLARRE computes eigenvalues of the (shifted) root representation */
/* ZLARRV 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 || *n == 2)
{
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)
{
zswap_(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 ZSTEMR */
}
/* Subroutine */
int dlalsd_(char *uplo, integer *smlsiz, integer *n, integer *nrhs, doublereal *d__, doublereal *e, doublereal *b, integer *ldb, doublereal *rcond, integer *rank, doublereal *work, integer *iwork, integer *info)
{
/* System generated locals */
integer b_dim1, b_offset, i__1, i__2;
doublereal d__1;
/* Builtin functions */
double log(doublereal), d_sign(doublereal *, doublereal *);
/* Local variables */
integer c__, i__, j, k;
doublereal r__;
integer s, u, z__;
doublereal cs;
integer bx;
doublereal sn;
integer st, vt, nm1, st1;
doublereal eps;
integer iwk;
doublereal tol;
integer difl, difr;
doublereal rcnd;
integer perm, nsub;
extern /* Subroutine */
int drot_(integer *, doublereal *, integer *, doublereal *, integer *, doublereal *, doublereal *);
integer nlvl, sqre, bxst;
extern /* Subroutine */
int dgemm_(char *, char *, integer *, integer *, integer *, doublereal *, doublereal *, integer *, doublereal *, integer *, doublereal *, doublereal *, integer *), dcopy_(integer *, doublereal *, integer *, doublereal *, integer *);
integer poles, sizei, nsize, nwork, icmpq1, icmpq2;
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 *), dlalsa_(integer *, integer *, integer *, integer *, doublereal *, integer *, doublereal *, integer *, doublereal *, integer *, doublereal *, integer *, doublereal *, doublereal *, doublereal *, doublereal *, integer *, integer *, integer *, integer *, doublereal *, doublereal *, doublereal *, doublereal *, integer *, integer *), dlascl_(char *, integer *, integer *, doublereal *, doublereal *, integer *, integer *, doublereal *, integer *, integer *);
extern integer idamax_(integer *, doublereal *, integer *);
extern /* Subroutine */
int dlasdq_(char *, integer *, integer *, integer *, integer *, integer *, doublereal *, doublereal *, doublereal *, integer *, doublereal *, integer *, doublereal *, integer *, doublereal *, integer *), dlacpy_(char *, integer *, integer *, doublereal *, integer *, doublereal *, integer *), dlartg_(doublereal *, doublereal *, doublereal *, doublereal *, doublereal *), dlaset_(char *, integer *, integer *, doublereal *, doublereal *, doublereal *, integer *), xerbla_(char *, integer *);
integer givcol;
extern doublereal dlanst_(char *, integer *, doublereal *, doublereal *);
extern /* Subroutine */
int dlasrt_(char *, integer *, doublereal *, integer *);
doublereal orgnrm;
integer givnum, givptr, smlszp;
/* -- LAPACK computational routine (version 3.4.2) -- */
/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */
/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */
/* September 2012 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Executable Statements .. */
/* Test the input parameters. */
/* Parameter adjustments */
--d__;
--e;
b_dim1 = *ldb;
b_offset = 1 + b_dim1;
b -= b_offset;
--work;
--iwork;
/* Function Body */
*info = 0;
if (*n < 0)
{
*info = -3;
}
else if (*nrhs < 1)
{
*info = -4;
}
else if (*ldb < 1 || *ldb < *n)
{
*info = -8;
}
if (*info != 0)
{
i__1 = -(*info);
xerbla_("DLALSD", &i__1);
return 0;
}
eps = dlamch_("Epsilon");
/* Set up the tolerance. */
if (*rcond <= 0. || *rcond >= 1.)
{
rcnd = eps;
}
else
{
rcnd = *rcond;
}
*rank = 0;
/* Quick return if possible. */
if (*n == 0)
{
return 0;
}
else if (*n == 1)
{
if (d__[1] == 0.)
{
dlaset_("A", &c__1, nrhs, &c_b6, &c_b6, &b[b_offset], ldb);
}
else
{
*rank = 1;
dlascl_("G", &c__0, &c__0, &d__[1], &c_b11, &c__1, nrhs, &b[ b_offset], ldb, info);
d__[1] = abs(d__[1]);
}
return 0;
}
/* Rotate the matrix if it is lower bidiagonal. */
if (*(unsigned char *)uplo == 'L')
{
i__1 = *n - 1;
for (i__ = 1;
i__ <= i__1;
++i__)
{
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 (*nrhs == 1)
{
drot_(&c__1, &b[i__ + b_dim1], &c__1, &b[i__ + 1 + b_dim1], & c__1, &cs, &sn);
}
else
{
work[(i__ << 1) - 1] = cs;
work[i__ * 2] = sn;
}
/* L10: */
}
if (*nrhs > 1)
{
i__1 = *nrhs;
for (i__ = 1;
i__ <= i__1;
++i__)
{
i__2 = *n - 1;
for (j = 1;
j <= i__2;
++j)
{
cs = work[(j << 1) - 1];
sn = work[j * 2];
drot_(&c__1, &b[j + i__ * b_dim1], &c__1, &b[j + 1 + i__ * b_dim1], &c__1, &cs, &sn);
/* L20: */
}
/* L30: */
}
}
}
/* Scale. */
nm1 = *n - 1;
orgnrm = dlanst_("M", n, &d__[1], &e[1]);
if (orgnrm == 0.)
{
dlaset_("A", n, nrhs, &c_b6, &c_b6, &b[b_offset], ldb);
return 0;
}
dlascl_("G", &c__0, &c__0, &orgnrm, &c_b11, n, &c__1, &d__[1], n, info);
dlascl_("G", &c__0, &c__0, &orgnrm, &c_b11, &nm1, &c__1, &e[1], &nm1, info);
/* If N is smaller than the minimum divide size SMLSIZ, then solve */
/* the problem with another solver. */
if (*n <= *smlsiz)
{
nwork = *n * *n + 1;
dlaset_("A", n, n, &c_b6, &c_b11, &work[1], n);
dlasdq_("U", &c__0, n, n, &c__0, nrhs, &d__[1], &e[1], &work[1], n, & work[1], n, &b[b_offset], ldb, &work[nwork], info);
if (*info != 0)
{
return 0;
}
tol = rcnd * (d__1 = d__[idamax_(n, &d__[1], &c__1)], abs(d__1));
i__1 = *n;
for (i__ = 1;
i__ <= i__1;
++i__)
{
if (d__[i__] <= tol)
{
dlaset_("A", &c__1, nrhs, &c_b6, &c_b6, &b[i__ + b_dim1], ldb);
}
else
{
dlascl_("G", &c__0, &c__0, &d__[i__], &c_b11, &c__1, nrhs, &b[ i__ + b_dim1], ldb, info);
++(*rank);
}
/* L40: */
}
dgemm_("T", "N", n, nrhs, n, &c_b11, &work[1], n, &b[b_offset], ldb, & c_b6, &work[nwork], n);
dlacpy_("A", n, nrhs, &work[nwork], n, &b[b_offset], ldb);
/* Unscale. */
dlascl_("G", &c__0, &c__0, &c_b11, &orgnrm, n, &c__1, &d__[1], n, info);
dlasrt_("D", n, &d__[1], info);
dlascl_("G", &c__0, &c__0, &orgnrm, &c_b11, n, nrhs, &b[b_offset], ldb, info);
return 0;
}
/* Book-keeping and setting up some constants. */
nlvl = (integer) (log((doublereal) (*n) / (doublereal) (*smlsiz + 1)) / log(2.)) + 1;
smlszp = *smlsiz + 1;
u = 1;
vt = *smlsiz * *n + 1;
difl = vt + smlszp * *n;
difr = difl + nlvl * *n;
z__ = difr + (nlvl * *n << 1);
c__ = z__ + nlvl * *n;
s = c__ + *n;
poles = s + *n;
givnum = poles + (nlvl << 1) * *n;
bx = givnum + (nlvl << 1) * *n;
nwork = bx + *n * *nrhs;
sizei = *n + 1;
k = sizei + *n;
givptr = k + *n;
perm = givptr + *n;
givcol = perm + nlvl * *n;
iwk = givcol + (nlvl * *n << 1);
st = 1;
sqre = 0;
icmpq1 = 1;
icmpq2 = 0;
nsub = 0;
i__1 = *n;
for (i__ = 1;
i__ <= i__1;
++i__)
{
if ((d__1 = d__[i__], abs(d__1)) < eps)
{
d__[i__] = d_sign(&eps, &d__[i__]);
}
/* L50: */
}
i__1 = nm1;
for (i__ = 1;
i__ <= i__1;
++i__)
{
if ((d__1 = e[i__], abs(d__1)) < eps || i__ == nm1)
{
++nsub;
iwork[nsub] = st;
/* Subproblem found. First determine its size and then */
/* apply divide and conquer on it. */
if (i__ < nm1)
{
/* A subproblem with E(I) small for I < NM1. */
nsize = i__ - st + 1;
iwork[sizei + nsub - 1] = nsize;
}
else if ((d__1 = e[i__], abs(d__1)) >= eps)
{
/* A subproblem with E(NM1) not too small but I = NM1. */
nsize = *n - st + 1;
iwork[sizei + nsub - 1] = nsize;
}
else
{
/* A subproblem with E(NM1) small. This implies an */
/* 1-by-1 subproblem at D(N), which is not solved */
/* explicitly. */
nsize = i__ - st + 1;
iwork[sizei + nsub - 1] = nsize;
++nsub;
iwork[nsub] = *n;
iwork[sizei + nsub - 1] = 1;
dcopy_(nrhs, &b[*n + b_dim1], ldb, &work[bx + nm1], n);
}
st1 = st - 1;
if (nsize == 1)
{
/* This is a 1-by-1 subproblem and is not solved */
/* explicitly. */
dcopy_(nrhs, &b[st + b_dim1], ldb, &work[bx + st1], n);
}
else if (nsize <= *smlsiz)
{
/* This is a small subproblem and is solved by DLASDQ. */
dlaset_("A", &nsize, &nsize, &c_b6, &c_b11, &work[vt + st1], n);
dlasdq_("U", &c__0, &nsize, &nsize, &c__0, nrhs, &d__[st], &e[ st], &work[vt + st1], n, &work[nwork], n, &b[st + b_dim1], ldb, &work[nwork], info);
if (*info != 0)
{
return 0;
}
dlacpy_("A", &nsize, nrhs, &b[st + b_dim1], ldb, &work[bx + st1], n);
}
else
{
/* A large problem. Solve it using divide and conquer. */
dlasda_(&icmpq1, smlsiz, &nsize, &sqre, &d__[st], &e[st], & work[u + st1], n, &work[vt + st1], &iwork[k + st1], & work[difl + st1], &work[difr + st1], &work[z__ + st1], &work[poles + st1], &iwork[givptr + st1], &iwork[ givcol + st1], n, &iwork[perm + st1], &work[givnum + st1], &work[c__ + st1], &work[s + st1], &work[nwork], &iwork[iwk], info);
if (*info != 0)
{
return 0;
}
bxst = bx + st1;
dlalsa_(&icmpq2, smlsiz, &nsize, nrhs, &b[st + b_dim1], ldb, & work[bxst], n, &work[u + st1], n, &work[vt + st1], & iwork[k + st1], &work[difl + st1], &work[difr + st1], &work[z__ + st1], &work[poles + st1], &iwork[givptr + st1], &iwork[givcol + st1], n, &iwork[perm + st1], & work[givnum + st1], &work[c__ + st1], &work[s + st1], &work[nwork], &iwork[iwk], info);
if (*info != 0)
{
return 0;
}
}
st = i__ + 1;
}
/* L60: */
}
/* Apply the singular values and treat the tiny ones as zero. */
tol = rcnd * (d__1 = d__[idamax_(n, &d__[1], &c__1)], abs(d__1));
i__1 = *n;
for (i__ = 1;
i__ <= i__1;
++i__)
{
/* Some of the elements in D can be negative because 1-by-1 */
/* subproblems were not solved explicitly. */
if ((d__1 = d__[i__], abs(d__1)) <= tol)
{
dlaset_("A", &c__1, nrhs, &c_b6, &c_b6, &work[bx + i__ - 1], n);
}
else
{
++(*rank);
dlascl_("G", &c__0, &c__0, &d__[i__], &c_b11, &c__1, nrhs, &work[ bx + i__ - 1], n, info);
}
d__[i__] = (d__1 = d__[i__], abs(d__1));
/* L70: */
}
/* Now apply back the right singular vectors. */
icmpq2 = 1;
i__1 = nsub;
for (i__ = 1;
i__ <= i__1;
++i__)
{
st = iwork[i__];
st1 = st - 1;
nsize = iwork[sizei + i__ - 1];
bxst = bx + st1;
if (nsize == 1)
{
dcopy_(nrhs, &work[bxst], n, &b[st + b_dim1], ldb);
}
else if (nsize <= *smlsiz)
{
dgemm_("T", "N", &nsize, nrhs, &nsize, &c_b11, &work[vt + st1], n, &work[bxst], n, &c_b6, &b[st + b_dim1], ldb);
}
else
{
dlalsa_(&icmpq2, smlsiz, &nsize, nrhs, &work[bxst], n, &b[st + b_dim1], ldb, &work[u + st1], n, &work[vt + st1], &iwork[ k + st1], &work[difl + st1], &work[difr + st1], &work[z__ + st1], &work[poles + st1], &iwork[givptr + st1], &iwork[ givcol + st1], n, &iwork[perm + st1], &work[givnum + st1], &work[c__ + st1], &work[s + st1], &work[nwork], &iwork[ iwk], info);
if (*info != 0)
{
return 0;
}
}
/* L80: */
}
/* Unscale and sort the singular values. */
dlascl_("G", &c__0, &c__0, &c_b11, &orgnrm, n, &c__1, &d__[1], n, info);
dlasrt_("D", n, &d__[1], info);
dlascl_("G", &c__0, &c__0, &orgnrm, &c_b11, n, nrhs, &b[b_offset], ldb, info);
return 0;
/* End of DLALSD */
}
/* Subroutine */ int dstev_(char *jobz, integer *n, doublereal *d__,
doublereal *e, doublereal *z__, integer *ldz, doublereal *work,
integer *info)
{
/* System generated locals */
integer z_dim1, z_offset, i__1;
doublereal d__1;
/* Builtin functions */
double sqrt(doublereal);
/* Local variables */
doublereal eps;
integer imax;
doublereal rmin, rmax, tnrm;
extern /* Subroutine */ int dscal_(integer *, doublereal *, doublereal *,
integer *);
doublereal sigma;
extern logical lsame_(char *, char *);
logical wantz;
extern doublereal dlamch_(char *);
integer iscale;
doublereal safmin;
extern /* Subroutine */ int xerbla_(char *, integer *);
doublereal bignum;
extern doublereal dlanst_(char *, integer *, doublereal *, doublereal *);
extern /* Subroutine */ int dsterf_(integer *, doublereal *, doublereal *,
integer *), dsteqr_(char *, integer *, doublereal *, doublereal *
, doublereal *, integer *, doublereal *, integer *);
doublereal smlnum;
/* -- LAPACK driver routine (version 3.2) -- */
/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/* November 2006 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* DSTEV computes all eigenvalues and, optionally, eigenvectors of a */
/* real symmetric tridiagonal matrix A. */
/* Arguments */
/* ========= */
/* JOBZ (input) CHARACTER*1 */
/* = 'N': Compute eigenvalues only; */
/* = 'V': Compute eigenvalues and eigenvectors. */
/* 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 */
/* A. */
/* 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 A, stored in elements 1 to N-1 of E. */
/* On exit, the contents of E are destroyed. */
/* Z (output) DOUBLE PRECISION array, dimension (LDZ, N) */
/* If JOBZ = 'V', then if INFO = 0, Z contains the orthonormal */
/* eigenvectors of the matrix A, with the i-th column of Z */
/* holding the eigenvector associated with D(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) DOUBLE PRECISION array, dimension (max(1,2*N-2)) */
/* If JOBZ = 'N', WORK 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, the algorithm failed to converge; i */
/* off-diagonal elements of E did not converge to zero. */
/* ===================================================================== */
/* .. 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 */
wantz = lsame_(jobz, "V");
*info = 0;
if (! (wantz || lsame_(jobz, "N"))) {
*info = -1;
} else if (*n < 0) {
*info = -2;
} else if (*ldz < 1 || wantz && *ldz < *n) {
*info = -6;
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("DSTEV ", &i__1);
return 0;
}
/* Quick return if possible */
if (*n == 0) {
return 0;
}
if (*n == 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);
rmax = sqrt(bignum);
/* Scale matrix to allowable range, if necessary. */
iscale = 0;
tnrm = dlanst_("M", n, &d__[1], &e[1]);
if (tnrm > 0. && tnrm < rmin) {
iscale = 1;
sigma = rmin / tnrm;
} else if (tnrm > rmax) {
iscale = 1;
sigma = rmax / tnrm;
}
if (iscale == 1) {
dscal_(n, &sigma, &d__[1], &c__1);
i__1 = *n - 1;
dscal_(&i__1, &sigma, &e[1], &c__1);
}
/* For eigenvalues only, call DSTERF. For eigenvalues and */
/* eigenvectors, call DSTEQR. */
if (! wantz) {
dsterf_(n, &d__[1], &e[1], info);
} else {
dsteqr_("I", n, &d__[1], &e[1], &z__[z_offset], ldz, &work[1], info);
}
/* If matrix was scaled, then rescale eigenvalues appropriately. */
if (iscale == 1) {
if (*info == 0) {
imax = *n;
} else {
imax = *info - 1;
}
d__1 = 1. / sigma;
dscal_(&imax, &d__1, &d__[1], &c__1);
}
return 0;
/* End of DSTEV */
} /* dstev_ */
/*< subroutine dstqrb ( n, d, e, z, work, info ) >*/
/* Subroutine */ int dstqrb_(integer *n, doublereal *d__, doublereal *e,
doublereal *z__, doublereal *work, integer *info)
{
/* System generated locals */
integer 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 *), dlasr_(char *, char *, char *,
integer *, integer *, doublereal *, doublereal *, doublereal *,
integer *, ftnlen, ftnlen, ftnlen);
doublereal anorm;
extern /* Subroutine */ int dlaev2_(doublereal *, doublereal *,
doublereal *, doublereal *, doublereal *, doublereal *,
doublereal *);
integer lendm1, lendp1;
extern doublereal dlapy2_(doublereal *, doublereal *), dlamch_(char *,
ftnlen);
integer iscale;
extern /* Subroutine */ int dlascl_(char *, integer *, integer *,
doublereal *, doublereal *, integer *, integer *, doublereal *,
integer *, integer *, ftnlen);
doublereal safmin;
extern /* Subroutine */ int dlartg_(doublereal *, doublereal *,
doublereal *, doublereal *, doublereal *);
doublereal safmax;
extern doublereal dlanst_(char *, integer *, doublereal *, doublereal *,
ftnlen);
extern /* Subroutine */ int dlasrt_(char *, integer *, doublereal *,
integer *, ftnlen);
integer lendsv, nmaxit, icompz;
doublereal ssfmax, ssfmin;
/* %------------------% */
/* | Scalar Arguments | */
/* %------------------% */
/*< integer info, n >*/
/* %-----------------% */
/* | Array Arguments | */
/* %-----------------% */
/*< >*/
/* .. parameters .. */
/*< >*/
/*< >*/
/*< integer maxit >*/
/*< parameter ( maxit = 30 ) >*/
/* .. */
/* .. local scalars .. */
/*< >*/
/*< >*/
/* .. */
/* .. external functions .. */
/*< logical lsame >*/
/*< >*/
/*< external lsame, dlamch, dlanst, dlapy2 >*/
/* .. */
/* .. external subroutines .. */
/*< >*/
/* .. */
/* .. intrinsic functions .. */
/*< intrinsic abs, max, sign, sqrt >*/
/* .. */
/* .. executable statements .. */
/* test the input parameters. */
/*< info = 0 >*/
/* Parameter adjustments */
--work;
--z__;
--e;
--d__;
/* Function Body */
*info = 0;
/* $$$ IF( LSAME( COMPZ, 'N' ) ) THEN */
/* $$$ ICOMPZ = 0 */
/* $$$ ELSE IF( LSAME( COMPZ, 'V' ) ) THEN */
/* $$$ ICOMPZ = 1 */
/* $$$ ELSE IF( LSAME( COMPZ, 'I' ) ) THEN */
/* $$$ ICOMPZ = 2 */
/* $$$ ELSE */
/* $$$ ICOMPZ = -1 */
/* $$$ END IF */
/* $$$ IF( ICOMPZ.LT.0 ) THEN */
/* $$$ INFO = -1 */
/* $$$ ELSE IF( N.LT.0 ) THEN */
/* $$$ INFO = -2 */
/* $$$ ELSE IF( ( LDZ.LT.1 ) .OR. ( ICOMPZ.GT.0 .AND. LDZ.LT.MAX( 1, */
/* $$$ $ N ) ) ) THEN */
/* $$$ INFO = -6 */
/* $$$ END IF */
/* $$$ IF( INFO.NE.0 ) THEN */
/* $$$ CALL XERBLA( 'SSTEQR', -INFO ) */
/* $$$ RETURN */
/* $$$ END IF */
/* *** New starting with version 2.5 *** */
/*< icompz = 2 >*/
icompz = 2;
/* ************************************* */
/* quick return if possible */
/*< >*/
if (*n == 0) {
return 0;
}
/*< if( n.eq.1 ) then >*/
if (*n == 1) {
/*< if( icompz.eq.2 ) z( 1 ) = one >*/
if (icompz == 2) {
z__[1] = 1.;
}
/*< return >*/
return 0;
/*< end if >*/
}
/* determine the unit roundoff and over/underflow thresholds. */
/*< eps = dlamch( 'e' ) >*/
eps = dlamch_("e", (ftnlen)1);
/*< eps2 = eps**2 >*/
/* Computing 2nd power */
d__1 = eps;
eps2 = d__1 * d__1;
/*< safmin = dlamch( 's' ) >*/
safmin = dlamch_("s", (ftnlen)1);
/*< safmax = one / safmin >*/
safmax = 1. / safmin;
/*< ssfmax = sqrt( safmax ) / three >*/
ssfmax = sqrt(safmax) / 3.;
/*< ssfmin = sqrt( safmin ) / eps2 >*/
ssfmin = sqrt(safmin) / eps2;
/* compute the eigenvalues and eigenvectors of the tridiagonal */
/* matrix. */
/* $$ if( icompz.eq.2 ) */
/* $$$ $ call dlaset( 'full', n, n, zero, one, z, ldz ) */
/* *** New starting with version 2.5 *** */
/*< if ( icompz .eq. 2 ) then >*/
if (icompz == 2) {
/*< do 5 j = 1, n-1 >*/
i__1 = *n - 1;
for (j = 1; j <= i__1; ++j) {
/*< z(j) = zero >*/
z__[j] = 0.;
/*< 5 continue >*/
/* L5: */
}
/*< z( n ) = one >*/
z__[*n] = 1.;
/*< end if >*/
}
/* ************************************* */
/*< nmaxit = n*maxit >*/
nmaxit = *n * 30;
/*< jtot = 0 >*/
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 >*/
l1 = 1;
/*< nm1 = n - 1 >*/
nm1 = *n - 1;
/*< 10 continue >*/
L10:
/*< >*/
if (l1 > *n) {
goto L160;
}
/*< >*/
if (l1 > 1) {
e[l1 - 1] = 0.;
}
/*< if( l1.le.nm1 ) then >*/
if (l1 <= nm1) {
/*< do 20 m = l1, nm1 >*/
i__1 = nm1;
for (m = l1; m <= i__1; ++m) {
/*< tst = abs( e( 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 ) = zero >*/
e[m] = 0.;
/*< go to 30 >*/
goto L30;
/*< end if >*/
}
/*< 20 continue >*/
/* L20: */
}
/*< end if >*/
}
/*< m = n >*/
m = *n;
/*< 30 continue >*/
L30:
/*< l = l1 >*/
l = l1;
/*< lsv = l >*/
lsv = l;
/*< lend = m >*/
lend = m;
/*< lendsv = lend >*/
lendsv = lend;
/*< l1 = m + 1 >*/
l1 = m + 1;
/*< >*/
if (lend == l) {
goto L10;
}
/* scale submatrix in rows and columns l to lend */
/*< anorm = dlanst( 'i', lend-l+1, d( l ), e( l ) ) >*/
i__1 = lend - l + 1;
anorm = dlanst_("i", &i__1, &d__[l], &e[l], (ftnlen)1);
/*< iscale = 0 >*/
iscale = 0;
/*< >*/
if (anorm == 0.) {
goto L10;
}
/*< if( anorm.gt.ssfmax ) then >*/
if (anorm > ssfmax) {
/*< iscale = 1 >*/
iscale = 1;
/*< >*/
i__1 = lend - l + 1;
dlascl_("g", &c__0, &c__0, &anorm, &ssfmax, &i__1, &c__1, &d__[l], n,
info, (ftnlen)1);
/*< >*/
i__1 = lend - l;
dlascl_("g", &c__0, &c__0, &anorm, &ssfmax, &i__1, &c__1, &e[l], n,
info, (ftnlen)1);
/*< else if( anorm.lt.ssfmin ) then >*/
} else if (anorm < ssfmin) {
/*< iscale = 2 >*/
iscale = 2;
/*< >*/
i__1 = lend - l + 1;
dlascl_("g", &c__0, &c__0, &anorm, &ssfmin, &i__1, &c__1, &d__[l], n,
info, (ftnlen)1);
/*< >*/
i__1 = lend - l;
dlascl_("g", &c__0, &c__0, &anorm, &ssfmin, &i__1, &c__1, &e[l], n,
info, (ftnlen)1);
/*< end if >*/
}
/* choose between ql and qr iteration */
/*< if( abs( d( lend ) ).lt.abs( d( l ) ) ) then >*/
if ((d__1 = d__[lend], abs(d__1)) < (d__2 = d__[l], abs(d__2))) {
/*< lend = lsv >*/
lend = lsv;
/*< l = lendsv >*/
l = lendsv;
/*< end if >*/
}
/*< if( lend.gt.l ) then >*/
if (lend > l) {
/* ql iteration */
/* look for small subdiagonal element. */
/*< 40 continue >*/
L40:
/*< if( l.ne.lend ) then >*/
if (l != lend) {
/*< lendm1 = lend - 1 >*/
lendm1 = lend - 1;
/*< do 50 m = l, lendm1 >*/
i__1 = lendm1;
for (m = l; m <= i__1; ++m) {
/*< tst = abs( e( m ) )**2 >*/
/* 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;
}
/*< 50 continue >*/
/* L50: */
}
/*< end if >*/
}
/*< m = lend >*/
m = lend;
/*< 60 continue >*/
L60:
/*< >*/
if (m < lend) {
e[m] = 0.;
}
/*< p = d( l ) >*/
p = d__[l];
/*< >*/
if (m == l) {
goto L80;
}
/* if remaining matrix is 2-by-2, use dlae2 or dlaev2 */
/* to compute its eigensystem. */
/*< if( m.eq.l+1 ) then >*/
if (m == l + 1) {
/*< if( icompz.gt.0 ) then >*/
if (icompz > 0) {
/*< call dlaev2( d( l ), e( l ), d( l+1 ), rt1, rt2, c, s ) >*/
dlaev2_(&d__[l], &e[l], &d__[l + 1], &rt1, &rt2, &c__, &s);
/*< work( l ) = c >*/
work[l] = c__;
/*< work( n-1+l ) = s >*/
work[*n - 1 + l] = s;
/* $$$ call dlasr( 'r', 'v', 'b', n, 2, work( l ), */
/* $$$ $ work( n-1+l ), z( 1, l ), ldz ) */
/* *** New starting with version 2.5 *** */
/*< tst = z(l+1) >*/
tst = z__[l + 1];
/*< z(l+1) = c*tst - s*z(l) >*/
z__[l + 1] = c__ * tst - s * z__[l];
/*< z(l) = s*tst + c*z(l) >*/
z__[l] = s * tst + c__ * z__[l];
/* ************************************* */
/*< else >*/
} else {
/*< call dlae2( d( l ), e( l ), d( l+1 ), rt1, rt2 ) >*/
dlae2_(&d__[l], &e[l], &d__[l + 1], &rt1, &rt2);
/*< end if >*/
}
/*< d( l ) = rt1 >*/
d__[l] = rt1;
/*< d( l+1 ) = rt2 >*/
d__[l + 1] = rt2;
/*< e( l ) = zero >*/
e[l] = 0.;
/*< l = l + 2 >*/
l += 2;
/*< >*/
if (l <= lend) {
goto L40;
}
/*< go to 140 >*/
goto L140;
/*< end if >*/
}
/*< >*/
if (jtot == nmaxit) {
goto L140;
}
/*< jtot = jtot + 1 >*/
++jtot;
/* form shift. */
/*< g = ( d( l+1 )-p ) / ( two*e( l ) ) >*/
g = (d__[l + 1] - p) / (e[l] * 2.);
/*< r = dlapy2( g, one ) >*/
r__ = dlapy2_(&g, &c_b31);
/*< g = d( m ) - p + ( e( l ) / ( g+sign( r, g ) ) ) >*/
g = d__[m] - p + e[l] / (g + d_sign(&r__, &g));
/*< s = one >*/
s = 1.;
/*< c = one >*/
c__ = 1.;
/*< p = zero >*/
p = 0.;
/* inner loop */
/*< mm1 = m - 1 >*/
mm1 = m - 1;
/*< do 70 i = mm1, l, -1 >*/
i__1 = l;
for (i__ = mm1; i__ >= i__1; --i__) {
/*< f = s*e( i ) >*/
f = s * e[i__];
/*< b = c*e( i ) >*/
b = c__ * e[i__];
/*< call dlartg( g, f, c, s, r ) >*/
dlartg_(&g, &f, &c__, &s, &r__);
/*< >*/
if (i__ != m - 1) {
e[i__ + 1] = r__;
}
/*< g = d( i+1 ) - p >*/
g = d__[i__ + 1] - p;
/*< r = ( d( i )-g )*s + two*c*b >*/
r__ = (d__[i__] - g) * s + c__ * 2. * b;
/*< p = s*r >*/
p = s * r__;
/*< d( i+1 ) = g + p >*/
d__[i__ + 1] = g + p;
/*< g = c*r - b >*/
g = c__ * r__ - b;
/* if eigenvectors are desired, then save rotations. */
/*< if( icompz.gt.0 ) then >*/
if (icompz > 0) {
/*< work( i ) = c >*/
work[i__] = c__;
/*< work( n-1+i ) = -s >*/
work[*n - 1 + i__] = -s;
/*< end if >*/
}
/*< 70 continue >*/
/* L70: */
}
/* if eigenvectors are desired, then apply saved rotations. */
/*< if( icompz.gt.0 ) then >*/
if (icompz > 0) {
/*< mm = m - l + 1 >*/
mm = m - l + 1;
/* $$$ call dlasr( 'r', 'v', 'b', n, mm, work( l ), work( n-1+l ), */
/* $$$ $ z( 1, l ), ldz ) */
/* *** New starting with version 2.5 *** */
/*< >*/
dlasr_("r", "v", "b", &c__1, &mm, &work[l], &work[*n - 1 + l], &
z__[l], &c__1, (ftnlen)1, (ftnlen)1, (ftnlen)1);
/* ************************************* */
/*< end if >*/
}
/*< d( l ) = d( l ) - p >*/
d__[l] -= p;
/*< e( l ) = g >*/
e[l] = g;
/*< go to 40 >*/
goto L40;
/* eigenvalue found. */
/*< 80 continue >*/
L80:
/*< d( l ) = p >*/
d__[l] = p;
/*< l = l + 1 >*/
++l;
/*< >*/
if (l <= lend) {
goto L40;
}
/*< go to 140 >*/
goto L140;
/*< else >*/
} else {
/* qr iteration */
/* look for small superdiagonal element. */
/*< 90 continue >*/
L90:
/*< if( l.ne.lend ) then >*/
if (l != lend) {
/*< lendp1 = lend + 1 >*/
lendp1 = lend + 1;
/*< do 100 m = l, lendp1, -1 >*/
i__1 = lendp1;
for (m = l; m >= i__1; --m) {
/*< tst = abs( e( m-1 ) )**2 >*/
/* 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;
}
/*< 100 continue >*/
/* L100: */
}
/*< end if >*/
}
/*< m = lend >*/
m = lend;
/*< 110 continue >*/
L110:
/*< >*/
if (m > lend) {
e[m - 1] = 0.;
}
/*< p = d( l ) >*/
p = d__[l];
/*< >*/
if (m == l) {
goto L130;
}
/* if remaining matrix is 2-by-2, use dlae2 or dlaev2 */
/* to compute its eigensystem. */
/*< if( m.eq.l-1 ) then >*/
if (m == l - 1) {
/*< if( icompz.gt.0 ) then >*/
if (icompz > 0) {
/*< call dlaev2( d( l-1 ), e( l-1 ), d( l ), rt1, rt2, c, s ) >*/
dlaev2_(&d__[l - 1], &e[l - 1], &d__[l], &rt1, &rt2, &c__, &s)
;
/* $$$ work( m ) = c */
/* $$$ work( n-1+m ) = s */
/* $$$ call dlasr( 'r', 'v', 'f', n, 2, work( m ), */
/* $$$ $ work( n-1+m ), z( 1, l-1 ), ldz ) */
/* *** New starting with version 2.5 *** */
/*< tst = z(l) >*/
tst = z__[l];
/*< z(l) = c*tst - s*z(l-1) >*/
z__[l] = c__ * tst - s * z__[l - 1];
/*< z(l-1) = s*tst + c*z(l-1) >*/
z__[l - 1] = s * tst + c__ * z__[l - 1];
/* ************************************* */
/*< else >*/
} else {
/*< call dlae2( d( l-1 ), e( l-1 ), d( l ), rt1, rt2 ) >*/
dlae2_(&d__[l - 1], &e[l - 1], &d__[l], &rt1, &rt2);
/*< end if >*/
}
/*< d( l-1 ) = rt1 >*/
d__[l - 1] = rt1;
/*< d( l ) = rt2 >*/
d__[l] = rt2;
/*< e( l-1 ) = zero >*/
e[l - 1] = 0.;
/*< l = l - 2 >*/
l += -2;
/*< >*/
if (l >= lend) {
goto L90;
}
/*< go to 140 >*/
goto L140;
/*< end if >*/
}
/*< >*/
if (jtot == nmaxit) {
goto L140;
}
/*< jtot = jtot + 1 >*/
++jtot;
/* form shift. */
/*< g = ( d( l-1 )-p ) / ( two*e( l-1 ) ) >*/
g = (d__[l - 1] - p) / (e[l - 1] * 2.);
/*< r = dlapy2( g, one ) >*/
r__ = dlapy2_(&g, &c_b31);
/*< g = d( m ) - p + ( e( l-1 ) / ( g+sign( r, g ) ) ) >*/
g = d__[m] - p + e[l - 1] / (g + d_sign(&r__, &g));
/*< s = one >*/
s = 1.;
/*< c = one >*/
c__ = 1.;
/*< p = zero >*/
p = 0.;
/* inner loop */
/*< lm1 = l - 1 >*/
lm1 = l - 1;
/*< do 120 i = m, lm1 >*/
i__1 = lm1;
for (i__ = m; i__ <= i__1; ++i__) {
/*< f = s*e( i ) >*/
f = s * e[i__];
/*< b = c*e( i ) >*/
b = c__ * e[i__];
/*< call dlartg( g, f, c, s, r ) >*/
dlartg_(&g, &f, &c__, &s, &r__);
/*< >*/
if (i__ != m) {
e[i__ - 1] = r__;
}
/*< g = d( i ) - p >*/
g = d__[i__] - p;
/*< r = ( d( i+1 )-g )*s + two*c*b >*/
r__ = (d__[i__ + 1] - g) * s + c__ * 2. * b;
/*< p = s*r >*/
p = s * r__;
/*< d( i ) = g + p >*/
d__[i__] = g + p;
/*< g = c*r - b >*/
g = c__ * r__ - b;
/* if eigenvectors are desired, then save rotations. */
/*< if( icompz.gt.0 ) then >*/
if (icompz > 0) {
/*< work( i ) = c >*/
work[i__] = c__;
/*< work( n-1+i ) = s >*/
work[*n - 1 + i__] = s;
/*< end if >*/
}
/*< 120 continue >*/
/* L120: */
}
/* if eigenvectors are desired, then apply saved rotations. */
/*< if( icompz.gt.0 ) then >*/
if (icompz > 0) {
/*< mm = l - m + 1 >*/
mm = l - m + 1;
/* $$$ call dlasr( 'r', 'v', 'f', n, mm, work( m ), work( n-1+m ), */
/* $$$ $ z( 1, m ), ldz ) */
/* *** New starting with version 2.5 *** */
/*< >*/
dlasr_("r", "v", "f", &c__1, &mm, &work[m], &work[*n - 1 + m], &
z__[m], &c__1, (ftnlen)1, (ftnlen)1, (ftnlen)1);
/* ************************************* */
/*< end if >*/
}
/*< d( l ) = d( l ) - p >*/
d__[l] -= p;
/*< e( lm1 ) = g >*/
e[lm1] = g;
/*< go to 90 >*/
goto L90;
/* eigenvalue found. */
/*< 130 continue >*/
L130:
/*< d( l ) = p >*/
d__[l] = p;
/*< l = l - 1 >*/
--l;
/*< >*/
if (l >= lend) {
goto L90;
}
/*< go to 140 >*/
goto L140;
/*< end if >*/
}
/* undo scaling if necessary */
/*< 140 continue >*/
L140:
/*< if( iscale.eq.1 ) then >*/
if (iscale == 1) {
/*< >*/
i__1 = lendsv - lsv + 1;
dlascl_("g", &c__0, &c__0, &ssfmax, &anorm, &i__1, &c__1, &d__[lsv],
n, info, (ftnlen)1);
/*< >*/
i__1 = lendsv - lsv;
dlascl_("g", &c__0, &c__0, &ssfmax, &anorm, &i__1, &c__1, &e[lsv], n,
info, (ftnlen)1);
/*< else if( iscale.eq.2 ) then >*/
} 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, (ftnlen)1);
/*< >*/
i__1 = lendsv - lsv;
dlascl_("g", &c__0, &c__0, &ssfmin, &anorm, &i__1, &c__1, &e[lsv], n,
info, (ftnlen)1);
/*< end if >*/
}
/* check for no convergence to an eigenvalue after a total */
/* of n*maxit iterations. */
/*< >*/
if (jtot < nmaxit) {
goto L10;
}
/*< do 150 i = 1, n - 1 >*/
i__1 = *n - 1;
for (i__ = 1; i__ <= i__1; ++i__) {
/*< >*/
if (e[i__] != 0.) {
++(*info);
}
/*< 150 continue >*/
/* L150: */
}
/*< go to 190 >*/
goto L190;
/* order eigenvalues and eigenvectors. */
/*< 160 continue >*/
L160:
/*< if( icompz.eq.0 ) then >*/
if (icompz == 0) {
/* use quick sort */
/*< call dlasrt( 'i', n, d, info ) >*/
dlasrt_("i", n, &d__[1], info, (ftnlen)1);
/*< else >*/
} else {
/* use selection sort to minimize swaps of eigenvectors */
/*< do 180 ii = 2, n >*/
i__1 = *n;
for (ii = 2; ii <= i__1; ++ii) {
/*< i = ii - 1 >*/
i__ = ii - 1;
/*< k = i >*/
k = i__;
/*< p = d( i ) >*/
p = d__[i__];
/*< do 170 j = ii, n >*/
i__2 = *n;
for (j = ii; j <= i__2; ++j) {
/*< if( d( j ).lt.p ) then >*/
if (d__[j] < p) {
/*< k = j >*/
k = j;
/*< p = d( j ) >*/
p = d__[j];
/*< end if >*/
}
/*< 170 continue >*/
/* L170: */
}
/*< if( k.ne.i ) then >*/
if (k != i__) {
/*< d( k ) = d( i ) >*/
d__[k] = d__[i__];
/*< d( i ) = p >*/
d__[i__] = p;
/* $$$ call dswap( n, z( 1, i ), 1, z( 1, k ), 1 ) */
/* *** New starting with version 2.5 *** */
/*< p = z(k) >*/
p = z__[k];
/*< z(k) = z(i) >*/
z__[k] = z__[i__];
/*< z(i) = p >*/
z__[i__] = p;
/* ************************************* */
/*< end if >*/
}
/*< 180 continue >*/
/* L180: */
}
/*< end if >*/
}
/*< 190 continue >*/
L190:
/*< return >*/
return 0;
/* %---------------% */
/* | End of dstqrb | */
/* %---------------% */
/*< end >*/
} /* dstqrb_ */
/* Subroutine */
int dstev_(char *jobz, integer *n, doublereal *d__, doublereal *e, doublereal *z__, integer *ldz, doublereal *work, integer *info)
{
/* System generated locals */
integer z_dim1, z_offset, i__1;
doublereal d__1;
/* Builtin functions */
double sqrt(doublereal);
/* Local variables */
doublereal eps;
integer imax;
doublereal rmin, rmax, tnrm;
extern /* Subroutine */
int dscal_(integer *, doublereal *, doublereal *, integer *);
doublereal sigma;
extern logical lsame_(char *, char *);
logical wantz;
extern doublereal dlamch_(char *);
integer iscale;
doublereal safmin;
extern /* Subroutine */
int xerbla_(char *, integer *);
doublereal bignum;
extern doublereal dlanst_(char *, integer *, doublereal *, doublereal *);
extern /* Subroutine */
int dsterf_(integer *, doublereal *, doublereal *, integer *), dsteqr_(char *, integer *, doublereal *, doublereal * , doublereal *, integer *, doublereal *, integer *);
doublereal smlnum;
/* -- 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 */
--d__;
--e;
z_dim1 = *ldz;
z_offset = 1 + z_dim1;
z__ -= z_offset;
--work;
/* Function Body */
wantz = lsame_(jobz, "V");
*info = 0;
if (! (wantz || lsame_(jobz, "N")))
{
*info = -1;
}
else if (*n < 0)
{
*info = -2;
}
else if (*ldz < 1 || wantz && *ldz < *n)
{
*info = -6;
}
if (*info != 0)
{
i__1 = -(*info);
xerbla_("DSTEV ", &i__1);
return 0;
}
/* Quick return if possible */
if (*n == 0)
{
return 0;
}
if (*n == 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);
rmax = sqrt(bignum);
/* Scale matrix to allowable range, if necessary. */
iscale = 0;
tnrm = dlanst_("M", n, &d__[1], &e[1]);
if (tnrm > 0. && tnrm < rmin)
{
iscale = 1;
sigma = rmin / tnrm;
}
else if (tnrm > rmax)
{
iscale = 1;
sigma = rmax / tnrm;
}
if (iscale == 1)
{
dscal_(n, &sigma, &d__[1], &c__1);
i__1 = *n - 1;
dscal_(&i__1, &sigma, &e[1], &c__1);
}
/* For eigenvalues only, call DSTERF. For eigenvalues and */
/* eigenvectors, call DSTEQR. */
if (! wantz)
{
dsterf_(n, &d__[1], &e[1], info);
}
else
{
dsteqr_("I", n, &d__[1], &e[1], &z__[z_offset], ldz, &work[1], info);
}
/* If matrix was scaled, then rescale eigenvalues appropriately. */
if (iscale == 1)
{
if (*info == 0)
{
imax = *n;
}
else
{
imax = *info - 1;
}
d__1 = 1. / sigma;
dscal_(&imax, &d__1, &d__[1], &c__1);
}
return 0;
/* End of DSTEV */
}
/* Subroutine */
int dsterf_(integer *n, doublereal *d__, doublereal *e, integer *info)
{
/* System generated locals */
integer i__1;
doublereal d__1, d__2, d__3;
/* Builtin functions */
double sqrt(doublereal), d_sign(doublereal *, doublereal *);
/* Local variables */
doublereal c__;
integer i__, l, m;
doublereal p, r__, s;
integer l1;
doublereal bb, rt1, rt2, eps, rte;
integer lsv;
doublereal eps2, oldc;
integer lend;
doublereal rmax;
integer jtot;
extern /* Subroutine */
int dlae2_(doublereal *, doublereal *, doublereal *, doublereal *, doublereal *);
doublereal gamma, alpha, sigma, anorm;
extern doublereal dlapy2_(doublereal *, doublereal *), dlamch_(char *);
integer iscale;
extern /* Subroutine */
int dlascl_(char *, integer *, integer *, doublereal *, doublereal *, integer *, integer *, doublereal *, integer *, integer *);
doublereal oldgam, safmin;
extern /* Subroutine */
int xerbla_(char *, integer *);
doublereal safmax;
extern doublereal dlanst_(char *, integer *, doublereal *, doublereal *);
extern /* Subroutine */
int dlasrt_(char *, integer *, doublereal *, integer *);
integer lendsv;
doublereal ssfmin;
integer nmaxit;
doublereal ssfmax;
/* -- 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 */
--e;
--d__;
/* Function Body */
*info = 0;
/* Quick return if possible */
if (*n < 0)
{
*info = -1;
i__1 = -(*info);
xerbla_("DSTERF", &i__1);
return 0;
}
if (*n <= 1)
{
return 0;
}
/* Determine the unit roundoff for this environment. */
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;
rmax = dlamch_("O");
/* Compute the eigenvalues of the tridiagonal matrix. */
nmaxit = *n * 30;
sigma = 0.;
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;
L10:
if (l1 > *n)
{
goto L170;
}
if (l1 > 1)
{
e[l1 - 1] = 0.;
}
i__1 = *n - 1;
for (m = l1;
m <= i__1;
++m)
{
if ((d__3 = e[m], f2c_abs(d__3)) <= sqrt((d__1 = d__[m], f2c_abs(d__1))) * sqrt((d__2 = d__[m + 1], f2c_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_("M", &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);
}
i__1 = lend - 1;
for (i__ = l;
i__ <= i__1;
++i__)
{
/* Computing 2nd power */
d__1 = e[i__];
e[i__] = d__1 * d__1;
/* L40: */
}
/* Choose between QL and QR iteration */
if ((d__1 = d__[lend], f2c_abs(d__1)) < (d__2 = d__[l], f2c_abs(d__2)))
{
lend = lsv;
l = lendsv;
}
if (lend >= l)
{
/* QL Iteration */
/* Look for small subdiagonal element. */
L50:
if (l != lend)
{
i__1 = lend - 1;
for (m = l;
m <= i__1;
++m)
{
if ((d__2 = e[m], f2c_abs(d__2)) <= eps2 * (d__1 = d__[m] * d__[m + 1], f2c_abs(d__1)))
{
goto L70;
}
/* L60: */
}
}
m = lend;
L70:
if (m < lend)
{
e[m] = 0.;
}
p = d__[l];
if (m == l)
{
goto L90;
}
/* If remaining matrix is 2 by 2, use DLAE2 to compute its */
/* eigenvalues. */
if (m == l + 1)
{
rte = sqrt(e[l]);
dlae2_(&d__[l], &rte, &d__[l + 1], &rt1, &rt2);
d__[l] = rt1;
d__[l + 1] = rt2;
e[l] = 0.;
l += 2;
if (l <= lend)
{
goto L50;
}
goto L150;
}
if (jtot == nmaxit)
{
goto L150;
}
++jtot;
/* Form shift. */
rte = sqrt(e[l]);
sigma = (d__[l + 1] - p) / (rte * 2.);
r__ = dlapy2_(&sigma, &c_b33);
sigma = p - rte / (sigma + d_sign(&r__, &sigma));
c__ = 1.;
s = 0.;
gamma = d__[m] - sigma;
p = gamma * gamma;
/* Inner loop */
i__1 = l;
for (i__ = m - 1;
i__ >= i__1;
--i__)
{
bb = e[i__];
r__ = p + bb;
if (i__ != m - 1)
{
e[i__ + 1] = s * r__;
}
oldc = c__;
c__ = p / r__;
s = bb / r__;
oldgam = gamma;
alpha = d__[i__];
gamma = c__ * (alpha - sigma) - s * oldgam;
d__[i__ + 1] = oldgam + (alpha - gamma);
if (c__ != 0.)
{
p = gamma * gamma / c__;
}
else
{
p = oldc * bb;
}
/* L80: */
}
e[l] = s * p;
d__[l] = sigma + gamma;
goto L50;
/* Eigenvalue found. */
L90:
d__[l] = p;
++l;
if (l <= lend)
{
goto L50;
}
goto L150;
}
else
{
/* QR Iteration */
/* Look for small superdiagonal element. */
L100:
i__1 = lend + 1;
for (m = l;
m >= i__1;
--m)
{
if ((d__2 = e[m - 1], f2c_abs(d__2)) <= eps2 * (d__1 = d__[m] * d__[m - 1], f2c_abs(d__1)))
{
goto L120;
}
/* L110: */
}
m = lend;
L120:
if (m > lend)
{
e[m - 1] = 0.;
}
p = d__[l];
if (m == l)
{
goto L140;
}
/* If remaining matrix is 2 by 2, use DLAE2 to compute its */
/* eigenvalues. */
if (m == l - 1)
{
rte = sqrt(e[l - 1]);
dlae2_(&d__[l], &rte, &d__[l - 1], &rt1, &rt2);
d__[l] = rt1;
d__[l - 1] = rt2;
e[l - 1] = 0.;
l += -2;
if (l >= lend)
{
goto L100;
}
goto L150;
}
if (jtot == nmaxit)
{
goto L150;
}
++jtot;
/* Form shift. */
rte = sqrt(e[l - 1]);
sigma = (d__[l - 1] - p) / (rte * 2.);
r__ = dlapy2_(&sigma, &c_b33);
sigma = p - rte / (sigma + d_sign(&r__, &sigma));
c__ = 1.;
s = 0.;
gamma = d__[m] - sigma;
p = gamma * gamma;
/* Inner loop */
i__1 = l - 1;
for (i__ = m;
i__ <= i__1;
++i__)
{
bb = e[i__];
r__ = p + bb;
if (i__ != m)
{
e[i__ - 1] = s * r__;
}
oldc = c__;
c__ = p / r__;
s = bb / r__;
oldgam = gamma;
alpha = d__[i__ + 1];
gamma = c__ * (alpha - sigma) - s * oldgam;
d__[i__] = oldgam + (alpha - gamma);
if (c__ != 0.)
{
p = gamma * gamma / c__;
}
else
{
p = oldc * bb;
}
/* L130: */
}
e[l - 1] = s * p;
d__[l] = sigma + gamma;
goto L100;
/* Eigenvalue found. */
L140:
d__[l] = p;
--l;
if (l >= lend)
{
goto L100;
}
goto L150;
}
/* Undo scaling if necessary */
L150:
if (iscale == 1)
{
i__1 = lendsv - lsv + 1;
dlascl_("G", &c__0, &c__0, &ssfmax, &anorm, &i__1, &c__1, &d__[lsv], n, info);
}
if (iscale == 2)
{
i__1 = lendsv - lsv + 1;
dlascl_("G", &c__0, &c__0, &ssfmin, &anorm, &i__1, &c__1, &d__[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);
}
/* L160: */
}
goto L180;
/* Sort eigenvalues in increasing order. */
L170:
dlasrt_("I", n, &d__[1], info);
L180:
return 0;
/* End of DSTERF */
}
/* Subroutine */ int zlalsd_(char *uplo, integer *smlsiz, integer *n, integer
*nrhs, doublereal *d__, doublereal *e, doublecomplex *b, integer *ldb,
doublereal *rcond, integer *rank, doublecomplex *work, doublereal *
rwork, integer *iwork, integer *info)
{
/* System generated locals */
integer b_dim1, b_offset, i__1, i__2, i__3, i__4, i__5, i__6;
doublereal d__1;
doublecomplex z__1;
/* Builtin functions */
double d_imag(doublecomplex *), log(doublereal), d_sign(doublereal *,
doublereal *);
/* Local variables */
static integer difl, difr, jcol, irwb, perm, nsub, nlvl, sqre, bxst, jrow,
irwu, c__, i__, j, k;
static doublereal r__;
static integer s, u, jimag;
extern /* Subroutine */ int dgemm_(char *, char *, integer *, integer *,
integer *, doublereal *, doublereal *, integer *, doublereal *,
integer *, doublereal *, doublereal *, integer *);
static integer z__, jreal, irwib, poles, sizei, irwrb, nsize;
extern /* Subroutine */ int zdrot_(integer *, doublecomplex *, integer *,
doublecomplex *, integer *, doublereal *, doublereal *), zcopy_(
integer *, doublecomplex *, integer *, doublecomplex *, integer *)
;
static integer irwvt, icmpq1, icmpq2;
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 bx;
static doublereal sn;
extern /* Subroutine */ int dlascl_(char *, integer *, integer *,
doublereal *, doublereal *, integer *, integer *, doublereal *,
integer *, integer *);
extern integer idamax_(integer *, doublereal *, integer *);
static integer st;
extern /* Subroutine */ int dlasdq_(char *, integer *, integer *, integer
*, integer *, integer *, doublereal *, doublereal *, doublereal *,
integer *, doublereal *, integer *, doublereal *, integer *,
doublereal *, integer *);
static integer vt;
extern /* Subroutine */ int dlaset_(char *, integer *, integer *,
doublereal *, doublereal *, doublereal *, integer *),
dlartg_(doublereal *, doublereal *, doublereal *, doublereal *,
doublereal *), xerbla_(char *, integer *);
static integer givcol;
extern doublereal dlanst_(char *, integer *, doublereal *, doublereal *);
extern /* Subroutine */ int zlalsa_(integer *, integer *, integer *,
integer *, doublecomplex *, integer *, doublecomplex *, integer *,
doublereal *, integer *, doublereal *, integer *, doublereal *,
doublereal *, doublereal *, doublereal *, integer *, integer *,
integer *, integer *, doublereal *, doublereal *, doublereal *,
doublereal *, integer *, integer *), zlascl_(char *, integer *,
integer *, doublereal *, doublereal *, integer *, integer *,
doublecomplex *, integer *, integer *), dlasrt_(char *,
integer *, doublereal *, integer *), zlacpy_(char *,
integer *, integer *, doublecomplex *, integer *, doublecomplex *,
integer *), zlaset_(char *, integer *, integer *,
doublecomplex *, doublecomplex *, doublecomplex *, integer *);
static doublereal orgnrm;
static integer givnum, givptr, nm1, nrwork, irwwrk, smlszp, st1;
static doublereal eps;
static integer iwk;
static doublereal tol;
#define b_subscr(a_1,a_2) (a_2)*b_dim1 + a_1
#define b_ref(a_1,a_2) b[b_subscr(a_1,a_2)]
/* -- 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
=======
ZLALSD uses the singular value decomposition of A to solve the least
squares problem of finding X to minimize the Euclidean norm of each
column of A*X-B, where A is N-by-N upper bidiagonal, and X and B
are N-by-NRHS. The solution X overwrites B.
The singular values of A smaller than RCOND times the largest
singular value are treated as zero in solving the least squares
problem; in this case a minimum norm solution is returned.
The actual singular values are returned in D in ascending order.
This code makes very mild assumptions about floating point
arithmetic. It will work on machines with a guard digit in
add/subtract, or on those binary machines without guard digits
which subtract like the Cray XMP, Cray YMP, Cray C 90, or Cray 2.
It could conceivably fail on hexadecimal or decimal machines
without guard digits, but we know of none.
Arguments
=========
UPLO (input) CHARACTER*1
= 'U': D and E define an upper bidiagonal matrix.
= 'L': D and E define a lower bidiagonal matrix.
SMLSIZ (input) INTEGER
The maximum size of the subproblems at the bottom of the
computation tree.
N (input) INTEGER
The dimension of the bidiagonal matrix. N >= 0.
NRHS (input) INTEGER
The number of columns of B. NRHS must be at least 1.
D (input/output) DOUBLE PRECISION array, dimension (N)
On entry D contains the main diagonal of the bidiagonal
matrix. On exit, if INFO = 0, D contains its singular values.
E (input) DOUBLE PRECISION array, dimension (N-1)
Contains the super-diagonal entries of the bidiagonal matrix.
On exit, E has been destroyed.
B (input/output) COMPLEX*16 array, dimension (LDB,NRHS)
On input, B contains the right hand sides of the least
squares problem. On output, B contains the solution X.
LDB (input) INTEGER
The leading dimension of B in the calling subprogram.
LDB must be at least max(1,N).
RCOND (input) DOUBLE PRECISION
The singular values of A less than or equal to RCOND times
the largest singular value are treated as zero in solving
the least squares problem. If RCOND is negative,
machine precision is used instead.
For example, if diag(S)*X=B were the least squares problem,
where diag(S) is a diagonal matrix of singular values, the
solution would be X(i) = B(i) / S(i) if S(i) is greater than
RCOND*max(S), and X(i) = 0 if S(i) is less than or equal to
RCOND*max(S).
RANK (output) INTEGER
The number of singular values of A greater than RCOND times
the largest singular value.
WORK (workspace) COMPLEX*16 array, dimension at least
(N * NRHS).
RWORK (workspace) DOUBLE PRECISION array, dimension at least
(9*N + 2*N*SMLSIZ + 8*N*NLVL + 3*SMLSIZ*NRHS + (SMLSIZ+1)**2),
where
NLVL = MAX( 0, INT( LOG_2( MIN( M,N )/(SMLSIZ+1) ) ) + 1 )
IWORK (workspace) INTEGER array, dimension at least
(3*N*NLVL + 11*N).
INFO (output) INTEGER
= 0: successful exit.
< 0: if INFO = -i, the i-th argument had an illegal value.
> 0: The algorithm failed to compute an singular value while
working on the submatrix lying in rows and columns
INFO/(N+1) through MOD(INFO,N+1).
Further Details
===============
Based on contributions by
Ming Gu and Ren-Cang Li, Computer Science Division, University of
California at Berkeley, USA
Osni Marques, LBNL/NERSC, USA
=====================================================================
Test the input parameters.
Parameter adjustments */
--d__;
--e;
b_dim1 = *ldb;
b_offset = 1 + b_dim1 * 1;
b -= b_offset;
--work;
--rwork;
--iwork;
/* Function Body */
*info = 0;
if (*n < 0) {
*info = -3;
} else if (*nrhs < 1) {
*info = -4;
} else if (*ldb < 1 || *ldb < *n) {
*info = -8;
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("ZLALSD", &i__1);
return 0;
}
eps = dlamch_("Epsilon");
/* Set up the tolerance. */
if (*rcond <= 0. || *rcond >= 1.) {
*rcond = eps;
}
*rank = 0;
/* Quick return if possible. */
if (*n == 0) {
return 0;
} else if (*n == 1) {
if (d__[1] == 0.) {
zlaset_("A", &c__1, nrhs, &c_b1, &c_b1, &b[b_offset], ldb);
} else {
*rank = 1;
zlascl_("G", &c__0, &c__0, &d__[1], &c_b10, &c__1, nrhs, &b[
b_offset], ldb, info);
d__[1] = abs(d__[1]);
}
return 0;
}
/* Rotate the matrix if it is lower bidiagonal. */
if (*(unsigned char *)uplo == 'L') {
i__1 = *n - 1;
for (i__ = 1; i__ <= i__1; ++i__) {
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 (*nrhs == 1) {
zdrot_(&c__1, &b_ref(i__, 1), &c__1, &b_ref(i__ + 1, 1), &
c__1, &cs, &sn);
} else {
rwork[(i__ << 1) - 1] = cs;
rwork[i__ * 2] = sn;
}
/* L10: */
}
if (*nrhs > 1) {
i__1 = *nrhs;
for (i__ = 1; i__ <= i__1; ++i__) {
i__2 = *n - 1;
for (j = 1; j <= i__2; ++j) {
cs = rwork[(j << 1) - 1];
sn = rwork[j * 2];
zdrot_(&c__1, &b_ref(j, i__), &c__1, &b_ref(j + 1, i__), &
c__1, &cs, &sn);
/* L20: */
}
/* L30: */
}
}
}
/* Scale. */
nm1 = *n - 1;
orgnrm = dlanst_("M", n, &d__[1], &e[1]);
if (orgnrm == 0.) {
zlaset_("A", n, nrhs, &c_b1, &c_b1, &b[b_offset], ldb);
return 0;
}
dlascl_("G", &c__0, &c__0, &orgnrm, &c_b10, n, &c__1, &d__[1], n, info);
dlascl_("G", &c__0, &c__0, &orgnrm, &c_b10, &nm1, &c__1, &e[1], &nm1,
info);
/* If N is smaller than the minimum divide size SMLSIZ, then solve
the problem with another solver. */
if (*n <= *smlsiz) {
irwu = 1;
irwvt = irwu + *n * *n;
irwwrk = irwvt + *n * *n;
irwrb = irwwrk;
irwib = irwrb + *n * *nrhs;
irwb = irwib + *n * *nrhs;
dlaset_("A", n, n, &c_b35, &c_b10, &rwork[irwu], n);
dlaset_("A", n, n, &c_b35, &c_b10, &rwork[irwvt], n);
dlasdq_("U", &c__0, n, n, n, &c__0, &d__[1], &e[1], &rwork[irwvt], n,
&rwork[irwu], n, &rwork[irwwrk], &c__1, &rwork[irwwrk], info);
if (*info != 0) {
return 0;
}
/* In the real version, B is passed to DLASDQ and multiplied
internally by Q'. Here B is complex and that product is
computed below in two steps (real and imaginary parts). */
j = irwb - 1;
i__1 = *nrhs;
for (jcol = 1; jcol <= i__1; ++jcol) {
i__2 = *n;
for (jrow = 1; jrow <= i__2; ++jrow) {
++j;
i__3 = b_subscr(jrow, jcol);
rwork[j] = b[i__3].r;
/* L40: */
}
/* L50: */
}
dgemm_("T", "N", n, nrhs, n, &c_b10, &rwork[irwu], n, &rwork[irwb], n,
&c_b35, &rwork[irwrb], n);
j = irwb - 1;
i__1 = *nrhs;
for (jcol = 1; jcol <= i__1; ++jcol) {
i__2 = *n;
for (jrow = 1; jrow <= i__2; ++jrow) {
++j;
rwork[j] = d_imag(&b_ref(jrow, jcol));
/* L60: */
}
/* L70: */
}
dgemm_("T", "N", n, nrhs, n, &c_b10, &rwork[irwu], n, &rwork[irwb], n,
&c_b35, &rwork[irwib], n);
jreal = irwrb - 1;
jimag = irwib - 1;
i__1 = *nrhs;
for (jcol = 1; jcol <= i__1; ++jcol) {
i__2 = *n;
for (jrow = 1; jrow <= i__2; ++jrow) {
++jreal;
++jimag;
i__3 = b_subscr(jrow, jcol);
i__4 = jreal;
i__5 = jimag;
z__1.r = rwork[i__4], z__1.i = rwork[i__5];
b[i__3].r = z__1.r, b[i__3].i = z__1.i;
/* L80: */
}
/* L90: */
}
tol = *rcond * (d__1 = d__[idamax_(n, &d__[1], &c__1)], abs(d__1));
i__1 = *n;
for (i__ = 1; i__ <= i__1; ++i__) {
if (d__[i__] <= tol) {
zlaset_("A", &c__1, nrhs, &c_b1, &c_b1, &b_ref(i__, 1), ldb);
} else {
zlascl_("G", &c__0, &c__0, &d__[i__], &c_b10, &c__1, nrhs, &
b_ref(i__, 1), ldb, info);
++(*rank);
}
/* L100: */
}
/* Since B is complex, the following call to DGEMM is performed
in two steps (real and imaginary parts). That is for V * B
(in the real version of the code V' is stored in WORK).
CALL DGEMM( 'T', 'N', N, NRHS, N, ONE, WORK, N, B, LDB, ZERO,
$ WORK( NWORK ), N ) */
j = irwb - 1;
i__1 = *nrhs;
for (jcol = 1; jcol <= i__1; ++jcol) {
i__2 = *n;
for (jrow = 1; jrow <= i__2; ++jrow) {
++j;
i__3 = b_subscr(jrow, jcol);
rwork[j] = b[i__3].r;
/* L110: */
}
/* L120: */
}
dgemm_("T", "N", n, nrhs, n, &c_b10, &rwork[irwvt], n, &rwork[irwb],
n, &c_b35, &rwork[irwrb], n);
j = irwb - 1;
i__1 = *nrhs;
for (jcol = 1; jcol <= i__1; ++jcol) {
i__2 = *n;
for (jrow = 1; jrow <= i__2; ++jrow) {
++j;
rwork[j] = d_imag(&b_ref(jrow, jcol));
/* L130: */
}
/* L140: */
}
dgemm_("T", "N", n, nrhs, n, &c_b10, &rwork[irwvt], n, &rwork[irwb],
n, &c_b35, &rwork[irwib], n);
jreal = irwrb - 1;
jimag = irwib - 1;
i__1 = *nrhs;
for (jcol = 1; jcol <= i__1; ++jcol) {
i__2 = *n;
for (jrow = 1; jrow <= i__2; ++jrow) {
++jreal;
++jimag;
i__3 = b_subscr(jrow, jcol);
i__4 = jreal;
i__5 = jimag;
z__1.r = rwork[i__4], z__1.i = rwork[i__5];
b[i__3].r = z__1.r, b[i__3].i = z__1.i;
/* L150: */
}
/* L160: */
}
/* Unscale. */
dlascl_("G", &c__0, &c__0, &c_b10, &orgnrm, n, &c__1, &d__[1], n,
info);
dlasrt_("D", n, &d__[1], info);
zlascl_("G", &c__0, &c__0, &orgnrm, &c_b10, n, nrhs, &b[b_offset],
ldb, info);
return 0;
}
/* Book-keeping and setting up some constants. */
nlvl = (integer) (log((doublereal) (*n) / (doublereal) (*smlsiz + 1)) /
log(2.)) + 1;
smlszp = *smlsiz + 1;
u = 1;
vt = *smlsiz * *n + 1;
difl = vt + smlszp * *n;
difr = difl + nlvl * *n;
z__ = difr + (nlvl * *n << 1);
c__ = z__ + nlvl * *n;
s = c__ + *n;
poles = s + *n;
givnum = poles + (nlvl << 1) * *n;
nrwork = givnum + (nlvl << 1) * *n;
bx = 1;
irwrb = nrwork;
irwib = irwrb + *smlsiz * *nrhs;
irwb = irwib + *smlsiz * *nrhs;
sizei = *n + 1;
k = sizei + *n;
givptr = k + *n;
perm = givptr + *n;
givcol = perm + nlvl * *n;
iwk = givcol + (nlvl * *n << 1);
st = 1;
sqre = 0;
icmpq1 = 1;
icmpq2 = 0;
nsub = 0;
i__1 = *n;
for (i__ = 1; i__ <= i__1; ++i__) {
if ((d__1 = d__[i__], abs(d__1)) < eps) {
d__[i__] = d_sign(&eps, &d__[i__]);
}
/* L170: */
}
i__1 = nm1;
for (i__ = 1; i__ <= i__1; ++i__) {
if ((d__1 = e[i__], abs(d__1)) < eps || i__ == nm1) {
++nsub;
iwork[nsub] = st;
/* Subproblem found. First determine its size and then
apply divide and conquer on it. */
if (i__ < nm1) {
/* A subproblem with E(I) small for I < NM1. */
nsize = i__ - st + 1;
iwork[sizei + nsub - 1] = nsize;
} else if ((d__1 = e[i__], abs(d__1)) >= eps) {
/* A subproblem with E(NM1) not too small but I = NM1. */
nsize = *n - st + 1;
iwork[sizei + nsub - 1] = nsize;
} else {
/* A subproblem with E(NM1) small. This implies an
1-by-1 subproblem at D(N), which is not solved
explicitly. */
nsize = i__ - st + 1;
iwork[sizei + nsub - 1] = nsize;
++nsub;
iwork[nsub] = *n;
iwork[sizei + nsub - 1] = 1;
zcopy_(nrhs, &b_ref(*n, 1), ldb, &work[bx + nm1], n);
}
st1 = st - 1;
if (nsize == 1) {
/* This is a 1-by-1 subproblem and is not solved
explicitly. */
zcopy_(nrhs, &b_ref(st, 1), ldb, &work[bx + st1], n);
} else if (nsize <= *smlsiz) {
/* This is a small subproblem and is solved by DLASDQ. */
dlaset_("A", &nsize, &nsize, &c_b35, &c_b10, &rwork[vt + st1],
n);
dlaset_("A", &nsize, &nsize, &c_b35, &c_b10, &rwork[u + st1],
n);
dlasdq_("U", &c__0, &nsize, &nsize, &nsize, &c__0, &d__[st], &
e[st], &rwork[vt + st1], n, &rwork[u + st1], n, &
rwork[nrwork], &c__1, &rwork[nrwork], info)
;
if (*info != 0) {
return 0;
}
/* In the real version, B is passed to DLASDQ and multiplied
internally by Q'. Here B is complex and that product is
computed below in two steps (real and imaginary parts). */
j = irwb - 1;
i__2 = *nrhs;
for (jcol = 1; jcol <= i__2; ++jcol) {
i__3 = st + nsize - 1;
for (jrow = st; jrow <= i__3; ++jrow) {
++j;
i__4 = b_subscr(jrow, jcol);
rwork[j] = b[i__4].r;
/* L180: */
}
/* L190: */
}
dgemm_("T", "N", &nsize, nrhs, &nsize, &c_b10, &rwork[u + st1]
, n, &rwork[irwb], &nsize, &c_b35, &rwork[irwrb], &
nsize);
j = irwb - 1;
i__2 = *nrhs;
for (jcol = 1; jcol <= i__2; ++jcol) {
i__3 = st + nsize - 1;
for (jrow = st; jrow <= i__3; ++jrow) {
++j;
rwork[j] = d_imag(&b_ref(jrow, jcol));
/* L200: */
}
/* L210: */
}
dgemm_("T", "N", &nsize, nrhs, &nsize, &c_b10, &rwork[u + st1]
, n, &rwork[irwb], &nsize, &c_b35, &rwork[irwib], &
nsize);
jreal = irwrb - 1;
jimag = irwib - 1;
i__2 = *nrhs;
for (jcol = 1; jcol <= i__2; ++jcol) {
i__3 = st + nsize - 1;
for (jrow = st; jrow <= i__3; ++jrow) {
++jreal;
++jimag;
i__4 = b_subscr(jrow, jcol);
i__5 = jreal;
i__6 = jimag;
z__1.r = rwork[i__5], z__1.i = rwork[i__6];
b[i__4].r = z__1.r, b[i__4].i = z__1.i;
/* L220: */
}
/* L230: */
}
zlacpy_("A", &nsize, nrhs, &b_ref(st, 1), ldb, &work[bx + st1]
, n);
} else {
/* A large problem. Solve it using divide and conquer. */
dlasda_(&icmpq1, smlsiz, &nsize, &sqre, &d__[st], &e[st], &
rwork[u + st1], n, &rwork[vt + st1], &iwork[k + st1],
&rwork[difl + st1], &rwork[difr + st1], &rwork[z__ +
st1], &rwork[poles + st1], &iwork[givptr + st1], &
iwork[givcol + st1], n, &iwork[perm + st1], &rwork[
givnum + st1], &rwork[c__ + st1], &rwork[s + st1], &
rwork[nrwork], &iwork[iwk], info);
if (*info != 0) {
return 0;
}
bxst = bx + st1;
zlalsa_(&icmpq2, smlsiz, &nsize, nrhs, &b_ref(st, 1), ldb, &
work[bxst], n, &rwork[u + st1], n, &rwork[vt + st1], &
iwork[k + st1], &rwork[difl + st1], &rwork[difr + st1]
, &rwork[z__ + st1], &rwork[poles + st1], &iwork[
givptr + st1], &iwork[givcol + st1], n, &iwork[perm +
st1], &rwork[givnum + st1], &rwork[c__ + st1], &rwork[
s + st1], &rwork[nrwork], &iwork[iwk], info);
if (*info != 0) {
return 0;
}
}
st = i__ + 1;
}
/* L240: */
}
/* Apply the singular values and treat the tiny ones as zero. */
tol = *rcond * (d__1 = d__[idamax_(n, &d__[1], &c__1)], abs(d__1));
i__1 = *n;
for (i__ = 1; i__ <= i__1; ++i__) {
/* Some of the elements in D can be negative because 1-by-1
subproblems were not solved explicitly. */
if ((d__1 = d__[i__], abs(d__1)) <= tol) {
zlaset_("A", &c__1, nrhs, &c_b1, &c_b1, &work[bx + i__ - 1], n);
} else {
++(*rank);
zlascl_("G", &c__0, &c__0, &d__[i__], &c_b10, &c__1, nrhs, &work[
bx + i__ - 1], n, info);
}
d__[i__] = (d__1 = d__[i__], abs(d__1));
/* L250: */
}
/* Now apply back the right singular vectors. */
icmpq2 = 1;
i__1 = nsub;
for (i__ = 1; i__ <= i__1; ++i__) {
st = iwork[i__];
st1 = st - 1;
nsize = iwork[sizei + i__ - 1];
bxst = bx + st1;
if (nsize == 1) {
zcopy_(nrhs, &work[bxst], n, &b_ref(st, 1), ldb);
} else if (nsize <= *smlsiz) {
/* Since B and BX are complex, the following call to DGEMM
is performed in two steps (real and imaginary parts).
CALL DGEMM( 'T', 'N', NSIZE, NRHS, NSIZE, ONE,
$ RWORK( VT+ST1 ), N, RWORK( BXST ), N, ZERO,
$ B( ST, 1 ), LDB ) */
j = bxst - *n - 1;
jreal = irwb - 1;
i__2 = *nrhs;
for (jcol = 1; jcol <= i__2; ++jcol) {
j += *n;
i__3 = nsize;
for (jrow = 1; jrow <= i__3; ++jrow) {
++jreal;
i__4 = j + jrow;
rwork[jreal] = work[i__4].r;
/* L260: */
}
/* L270: */
}
dgemm_("T", "N", &nsize, nrhs, &nsize, &c_b10, &rwork[vt + st1],
n, &rwork[irwb], &nsize, &c_b35, &rwork[irwrb], &nsize);
j = bxst - *n - 1;
jimag = irwb - 1;
i__2 = *nrhs;
for (jcol = 1; jcol <= i__2; ++jcol) {
j += *n;
i__3 = nsize;
for (jrow = 1; jrow <= i__3; ++jrow) {
++jimag;
rwork[jimag] = d_imag(&work[j + jrow]);
/* L280: */
}
/* L290: */
}
dgemm_("T", "N", &nsize, nrhs, &nsize, &c_b10, &rwork[vt + st1],
n, &rwork[irwb], &nsize, &c_b35, &rwork[irwib], &nsize);
jreal = irwrb - 1;
jimag = irwib - 1;
i__2 = *nrhs;
for (jcol = 1; jcol <= i__2; ++jcol) {
i__3 = st + nsize - 1;
for (jrow = st; jrow <= i__3; ++jrow) {
++jreal;
++jimag;
i__4 = b_subscr(jrow, jcol);
i__5 = jreal;
i__6 = jimag;
z__1.r = rwork[i__5], z__1.i = rwork[i__6];
b[i__4].r = z__1.r, b[i__4].i = z__1.i;
/* L300: */
}
/* L310: */
}
} else {
zlalsa_(&icmpq2, smlsiz, &nsize, nrhs, &work[bxst], n, &b_ref(st,
1), ldb, &rwork[u + st1], n, &rwork[vt + st1], &iwork[k +
st1], &rwork[difl + st1], &rwork[difr + st1], &rwork[z__
+ st1], &rwork[poles + st1], &iwork[givptr + st1], &iwork[
givcol + st1], n, &iwork[perm + st1], &rwork[givnum + st1]
, &rwork[c__ + st1], &rwork[s + st1], &rwork[nrwork], &
iwork[iwk], info);
if (*info != 0) {
return 0;
}
}
/* L320: */
}
/* Unscale and sort the singular values. */
dlascl_("G", &c__0, &c__0, &c_b10, &orgnrm, n, &c__1, &d__[1], n, info);
dlasrt_("D", n, &d__[1], info);
zlascl_("G", &c__0, &c__0, &orgnrm, &c_b10, n, nrhs, &b[b_offset], ldb,
info);
return 0;
/* End of ZLALSD */
} /* zlalsd_ */
/* 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 */
integer i__, j, k;
doublereal p, r__;
integer z__, ic, ii, kk;
doublereal cs;
integer is, iu;
doublereal sn;
integer nm1;
doublereal eps;
integer ivt, difl, difr, ierr, perm, mlvl, sqre;
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 *);
integer poles, iuplo, nsize, start;
extern /* Subroutine */ int dlasd0_(integer *, integer *, doublereal *,
doublereal *, doublereal *, integer *, doublereal *, integer *,
integer *, integer *, doublereal *, integer *);
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 *), 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 *);
extern /* Subroutine */ int xerbla_(char *, integer *);
integer givcol;
extern doublereal dlanst_(char *, integer *, doublereal *, doublereal *);
integer icompq;
doublereal orgnrm;
integer 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 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 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 = (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[*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_ */
int TRL::dstqrb_(integer_ * n, doublereal_ * d__, doublereal_ * e,
doublereal_ * z__, doublereal_ * work, integer_ * info)
{
/*
Purpose
=======
DSTQRB computes all eigenvalues and the last component of the eigenvectors of a
symmetric tridiagonal matrix using the implicit QL or QR method.
This is mainly a modification of the CLAPACK subroutine dsteqr.c
Arguments
=========
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.
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.
=====================================================================
*/
/* Table of constant values */
doublereal_ c_b10 = 1.;
integer_ c__0 = 0;
integer_ c__1 = 1;
/* System generated locals */
integer_ i__1, i__2;
doublereal_ d__1, d__2;
/* Builtin functions */
//double sqrt_(doublereal_), d_sign(doublereal_ *, doublereal_ *);
//extern /* Subroutine */ int dlae2_(doublereal_ *, doublereal_ *, doublereal_
// *, doublereal_ *, doublereal_ *);
doublereal_ b, c__, f, g;
integer_ i__, j, k, l, m;
doublereal_ p, r__, s;
//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_ *);
integer_ l1;
//extern /* Subroutine */ int dlaev2_(doublereal_ *, doublereal_ *,
// doublereal_ *, doublereal_ *,
// doublereal_ *, doublereal_ *,
// doublereal_ *);
integer_ lendm1, lendp1;
//extern doublereal_ dlapy2_(doublereal_ *, doublereal_ *);
integer_ ii;
//extern doublereal_ dlamch_(char *);
integer_ mm, 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_ *);
/* Local variables */
integer_ lend, jtot;
integer_ lendsv;
doublereal_ ssfmin;
integer_ nmaxit;
doublereal_ ssfmax;
integer_ lm1, mm1, nm1;
doublereal_ rt1, rt2, eps;
integer_ lsv;
doublereal_ tst, eps2;
--d__;
--e;
--z__;
/* z_dim1 = *ldz; */
/* z_offset = 1 + z_dim1 * 1; */
/* z__ -= z_offset; */
--work;
/* Function Body */
*info = 0;
/* Taken out for TRLan
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;
}
*/
/* icompz = 2; */
/* Quick return if possible */
if (*n == 0) {
return 0;
}
if (*n == 1) {
z__[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. */
/* Taken out for TRLan
if (icompz == 2) {
dlaset_("Full", n, n, &c_b9, &c_b10, &z__[z_offset], ldz);
}
*/
for (j = 1; j < *n; j++) {
z__[j] = 0.0;
}
z__[*n] = 1.0;
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], fabs(d__1));
if (tst == 0.) {
goto L30;
}
if (tst <=
sqrt_((d__1 = d__[m], fabs(d__1))) * sqrt_((d__2 =
d__[m + 1],
fabs(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], fabs(d__1)) < (d__2 = d__[l], fabs(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], fabs(d__1));
tst = d__2 * d__2;
if (tst <=
eps2 * (d__1 = d__[m], fabs(d__1)) * (d__2 =
d__[m + 1],
fabs(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) {
dlaev2_(&d__[l], &e[l], &d__[l + 1], &rt1, &rt2, &c__, &s);
work[l] = c__;
work[*n - 1 + l] = s;
/* Taken out for TRLan
dlasr_("R", "V", "B", n, &c__2, &work[l], &work[*n - 1 + l], &
z___ref(1, l), ldz);
*/
tst = z__[l + 1];
z__[l + 1] = c__ * tst - s * z__[l];
z__[l] = s * tst + c__ * z__[l];
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. */
work[i__] = c__;
work[*n - 1 + i__] = -s;
/* L70: */
}
/* If eigenvectors are desired, then apply saved rotations. */
mm = m - l + 1;
/* Taken out for TRLan
dlasr_("R", "V", "B", n, &mm, &work[l], &work[*n - 1 + l], &
z___ref(1, l), ldz);
*/
dlasr_("R", "V", "B", &c__1, &mm, &work[l], &work[*n - 1 + l],
&z__[l], &c__1);
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], fabs(d__1));
tst = d__2 * d__2;
if (tst <=
eps2 * (d__1 = d__[m], fabs(d__1)) * (d__2 =
d__[m - 1],
fabs(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) {
dlaev2_(&d__[l - 1], &e[l - 1], &d__[l], &rt1, &rt2, &c__, &s);
/* Taken out for TRLan
work[m] = c__;
work[*n - 1 + m] = s;
dlasr_("R", "V", "F", n, &c__2, &work[m], &work[*n - 1 + m], &
z___ref(1, l - 1), ldz);
*/
tst = z__[l];
z__[l] = c__ * tst - s * z__[l - 1];
z__[l - 1] = s * tst + c__ * z__[l - 1];
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. */
work[i__] = c__;
work[*n - 1 + i__] = s;
/* L120: */
}
/* If eigenvectors are desired, then apply saved rotations. */
mm = l - m + 1;
/*
dlasr_("R", "V", "F", n, &mm, &work[m], &work[*n - 1 + m], &
z___ref(1, m), ldz);
*/
dlasr_("R", "V", "F", &c__1, &mm, &work[m], &work[*n - 1 + m],
&z__[m], &c__1);
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:
/* 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;
/* Taken out for TRLan
dswap_(n, &z___ref(1, i__), &c__1, &z___ref(1, k), &c__1);
*/
p = z__[k];
z__[k] = z__[i__];
z__[i__] = p;
}
/* L180: */
}
L190:
return 0;
}
/*< SUBROUTINE DSTEQR( COMPZ, N, D, E, Z, LDZ, WORK, INFO ) >*/
/* Subroutine */ int dsteqr_(char *compz, integer *n, doublereal *d__,
doublereal *e, doublereal *z__, integer *ldz, doublereal *work,
integer *info, ftnlen compz_len)
{
/* 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_(const char *, const char *, ftnlen, ftnlen);
extern /* Subroutine */ int dlasr_(char *, char *, char *, integer *,
integer *, doublereal *, doublereal *, doublereal *, integer *,
ftnlen, ftnlen, ftnlen);
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 *,
ftnlen);
integer iscale;
extern /* Subroutine */ int dlascl_(char *, integer *, integer *,
doublereal *, doublereal *, integer *, integer *, doublereal *,
integer *, integer *, ftnlen), dlaset_(char *, integer *, integer
*, doublereal *, doublereal *, doublereal *, integer *, ftnlen);
doublereal safmin;
extern /* Subroutine */ int dlartg_(doublereal *, doublereal *,
doublereal *, doublereal *, doublereal *);
doublereal safmax;
extern /* Subroutine */ int xerbla_(char *, integer *, ftnlen);
extern doublereal dlanst_(char *, integer *, doublereal *, doublereal *,
ftnlen);
extern /* Subroutine */ int dlasrt_(char *, integer *, doublereal *,
integer *, ftnlen);
integer lendsv;
doublereal ssfmin;
integer nmaxit, icompz;
doublereal ssfmax;
/* -- LAPACK routine (version 3.2) -- */
/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */
/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */
/* November 2006 */
/* .. Scalar Arguments .. */
/*< CHARACTER COMPZ >*/
/*< INTEGER INFO, LDZ, N >*/
/* .. */
/* .. Array Arguments .. */
/*< DOUBLE PRECISION D( * ), E( * ), WORK( * ), Z( LDZ, * ) >*/
/* .. */
/* 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 .. */
/*< DOUBLE PRECISION ZERO, ONE, TWO, THREE >*/
/*< >*/
/*< INTEGER MAXIT >*/
/*< PARAMETER ( MAXIT = 30 ) >*/
/* .. */
/* .. Local Scalars .. */
/*< >*/
/*< >*/
/* .. */
/* .. External Functions .. */
/*< LOGICAL LSAME >*/
/*< DOUBLE PRECISION DLAMCH, DLANST, DLAPY2 >*/
/*< EXTERNAL LSAME, DLAMCH, DLANST, DLAPY2 >*/
/* .. */
/* .. External Subroutines .. */
/*< >*/
/* .. */
/* .. Intrinsic Functions .. */
/*< INTRINSIC ABS, MAX, SIGN, SQRT >*/
/* .. */
/* .. Executable Statements .. */
/* Test the input parameters. */
/*< INFO = 0 >*/
/* Parameter adjustments */
--d__;
--e;
z_dim1 = *ldz;
z_offset = 1 + z_dim1;
z__ -= z_offset;
--work;
/* Function Body */
*info = 0;
/*< IF( LSAME( COMPZ, 'N' ) ) THEN >*/
if (lsame_(compz, "N", (ftnlen)1, (ftnlen)1)) {
/*< ICOMPZ = 0 >*/
icompz = 0;
/*< ELSE IF( LSAME( COMPZ, 'V' ) ) THEN >*/
} else if (lsame_(compz, "V", (ftnlen)1, (ftnlen)1)) {
/*< ICOMPZ = 1 >*/
icompz = 1;
/*< ELSE IF( LSAME( COMPZ, 'I' ) ) THEN >*/
} else if (lsame_(compz, "I", (ftnlen)1, (ftnlen)1)) {
/*< ICOMPZ = 2 >*/
icompz = 2;
/*< ELSE >*/
} else {
/*< ICOMPZ = -1 >*/
icompz = -1;
/*< END IF >*/
}
/*< IF( ICOMPZ.LT.0 ) THEN >*/
if (icompz < 0) {
/*< INFO = -1 >*/
*info = -1;
/*< ELSE IF( N.LT.0 ) THEN >*/
} else if (*n < 0) {
/*< INFO = -2 >*/
*info = -2;
/*< >*/
} else if (*ldz < 1 || (icompz > 0 && *ldz < max(1,*n))) {
/*< INFO = -6 >*/
*info = -6;
/*< END IF >*/
}
/*< IF( INFO.NE.0 ) THEN >*/
if (*info != 0) {
/*< CALL XERBLA( 'DSTEQR', -INFO ) >*/
i__1 = -(*info);
xerbla_("DSTEQR", &i__1, (ftnlen)6);
/*< RETURN >*/
return 0;
/*< END IF >*/
}
/* Quick return if possible */
/*< >*/
if (*n == 0) {
return 0;
}
/*< IF( N.EQ.1 ) THEN >*/
if (*n == 1) {
/*< >*/
if (icompz == 2) {
z__[z_dim1 + 1] = 1.;
}
/*< RETURN >*/
return 0;
/*< END IF >*/
}
/* Determine the unit roundoff and over/underflow thresholds. */
/*< EPS = DLAMCH( 'E' ) >*/
eps = dlamch_("E", (ftnlen)1);
/*< EPS2 = EPS**2 >*/
/* Computing 2nd power */
d__1 = eps;
eps2 = d__1 * d__1;
/*< SAFMIN = DLAMCH( 'S' ) >*/
safmin = dlamch_("S", (ftnlen)1);
/*< SAFMAX = ONE / SAFMIN >*/
safmax = 1. / safmin;
/*< SSFMAX = SQRT( SAFMAX ) / THREE >*/
ssfmax = sqrt(safmax) / 3.;
/*< SSFMIN = SQRT( SAFMIN ) / EPS2 >*/
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, (ftnlen)4);
}
/*< NMAXIT = N*MAXIT >*/
nmaxit = *n * 30;
/*< JTOT = 0 >*/
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 >*/
l1 = 1;
/*< NM1 = N - 1 >*/
nm1 = *n - 1;
/*< 10 CONTINUE >*/
L10:
/*< >*/
if (l1 > *n) {
goto L160;
}
/*< >*/
if (l1 > 1) {
e[l1 - 1] = 0.;
}
/*< IF( L1.LE.NM1 ) THEN >*/
if (l1 <= nm1) {
/*< DO 20 M = L1, NM1 >*/
i__1 = nm1;
for (m = l1; m <= i__1; ++m) {
/*< TST = ABS( E( 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 ) = ZERO >*/
e[m] = 0.;
/*< GO TO 30 >*/
goto L30;
/*< END IF >*/
}
/*< 20 CONTINUE >*/
/* L20: */
}
/*< END IF >*/
}
/*< M = N >*/
m = *n;
/*< 30 CONTINUE >*/
L30:
/*< L = L1 >*/
l = l1;
/*< LSV = L >*/
lsv = l;
/*< LEND = M >*/
lend = m;
/*< LENDSV = LEND >*/
lendsv = lend;
/*< L1 = M + 1 >*/
l1 = m + 1;
/*< >*/
if (lend == l) {
goto L10;
}
/* Scale submatrix in rows and columns L to LEND */
/*< ANORM = DLANST( 'I', LEND-L+1, D( L ), E( L ) ) >*/
i__1 = lend - l + 1;
anorm = dlanst_("I", &i__1, &d__[l], &e[l], (ftnlen)1);
/*< ISCALE = 0 >*/
iscale = 0;
/*< >*/
if (anorm == 0.) {
goto L10;
}
/*< IF( ANORM.GT.SSFMAX ) THEN >*/
if (anorm > ssfmax) {
/*< ISCALE = 1 >*/
iscale = 1;
/*< >*/
i__1 = lend - l + 1;
dlascl_("G", &c__0, &c__0, &anorm, &ssfmax, &i__1, &c__1, &d__[l], n,
info, (ftnlen)1);
/*< >*/
i__1 = lend - l;
dlascl_("G", &c__0, &c__0, &anorm, &ssfmax, &i__1, &c__1, &e[l], n,
info, (ftnlen)1);
/*< ELSE IF( ANORM.LT.SSFMIN ) THEN >*/
} else if (anorm < ssfmin) {
/*< ISCALE = 2 >*/
iscale = 2;
/*< >*/
i__1 = lend - l + 1;
dlascl_("G", &c__0, &c__0, &anorm, &ssfmin, &i__1, &c__1, &d__[l], n,
info, (ftnlen)1);
/*< >*/
i__1 = lend - l;
dlascl_("G", &c__0, &c__0, &anorm, &ssfmin, &i__1, &c__1, &e[l], n,
info, (ftnlen)1);
/*< END IF >*/
}
/* Choose between QL and QR iteration */
/*< IF( ABS( D( LEND ) ).LT.ABS( D( L ) ) ) THEN >*/
if ((d__1 = d__[lend], abs(d__1)) < (d__2 = d__[l], abs(d__2))) {
/*< LEND = LSV >*/
lend = lsv;
/*< L = LENDSV >*/
l = lendsv;
/*< END IF >*/
}
/*< IF( LEND.GT.L ) THEN >*/
if (lend > l) {
/* QL Iteration */
/* Look for small subdiagonal element. */
/*< 40 CONTINUE >*/
L40:
/*< IF( L.NE.LEND ) THEN >*/
if (l != lend) {
/*< LENDM1 = LEND - 1 >*/
lendm1 = lend - 1;
/*< DO 50 M = L, LENDM1 >*/
i__1 = lendm1;
for (m = l; m <= i__1; ++m) {
/*< TST = ABS( E( M ) )**2 >*/
/* 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;
}
/*< 50 CONTINUE >*/
/* L50: */
}
/*< END IF >*/
}
/*< M = LEND >*/
m = lend;
/*< 60 CONTINUE >*/
L60:
/*< >*/
if (m < lend) {
e[m] = 0.;
}
/*< P = D( L ) >*/
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.EQ.L+1 ) THEN >*/
if (m == l + 1) {
/*< IF( ICOMPZ.GT.0 ) THEN >*/
if (icompz > 0) {
/*< CALL DLAEV2( D( L ), E( L ), D( L+1 ), RT1, RT2, C, S ) >*/
dlaev2_(&d__[l], &e[l], &d__[l + 1], &rt1, &rt2, &c__, &s);
/*< WORK( L ) = C >*/
work[l] = c__;
/*< WORK( N-1+L ) = S >*/
work[*n - 1 + l] = s;
/*< >*/
dlasr_("R", "V", "B", n, &c__2, &work[l], &work[*n - 1 + l], &
z__[l * z_dim1 + 1], ldz, (ftnlen)1, (ftnlen)1, (
ftnlen)1);
/*< ELSE >*/
} else {
/*< CALL DLAE2( D( L ), E( L ), D( L+1 ), RT1, RT2 ) >*/
dlae2_(&d__[l], &e[l], &d__[l + 1], &rt1, &rt2);
/*< END IF >*/
}
/*< D( L ) = RT1 >*/
d__[l] = rt1;
/*< D( L+1 ) = RT2 >*/
d__[l + 1] = rt2;
/*< E( L ) = ZERO >*/
e[l] = 0.;
/*< L = L + 2 >*/
l += 2;
/*< >*/
if (l <= lend) {
goto L40;
}
/*< GO TO 140 >*/
goto L140;
/*< END IF >*/
}
/*< >*/
if (jtot == nmaxit) {
goto L140;
}
/*< JTOT = JTOT + 1 >*/
++jtot;
/* Form shift. */
/*< G = ( D( L+1 )-P ) / ( TWO*E( L ) ) >*/
g = (d__[l + 1] - p) / (e[l] * 2.);
/*< R = DLAPY2( G, ONE ) >*/
r__ = dlapy2_(&g, &c_b10);
/*< G = D( M ) - P + ( E( L ) / ( G+SIGN( R, G ) ) ) >*/
g = d__[m] - p + e[l] / (g + d_sign(&r__, &g));
/*< S = ONE >*/
s = 1.;
/*< C = ONE >*/
c__ = 1.;
/*< P = ZERO >*/
p = 0.;
/* Inner loop */
/*< MM1 = M - 1 >*/
mm1 = m - 1;
/*< DO 70 I = MM1, L, -1 >*/
i__1 = l;
for (i__ = mm1; i__ >= i__1; --i__) {
/*< F = S*E( I ) >*/
f = s * e[i__];
/*< B = C*E( I ) >*/
b = c__ * e[i__];
/*< CALL DLARTG( G, F, C, S, R ) >*/
dlartg_(&g, &f, &c__, &s, &r__);
/*< >*/
if (i__ != m - 1) {
e[i__ + 1] = r__;
}
/*< G = D( I+1 ) - P >*/
g = d__[i__ + 1] - p;
/*< R = ( D( I )-G )*S + TWO*C*B >*/
r__ = (d__[i__] - g) * s + c__ * 2. * b;
/*< P = S*R >*/
p = s * r__;
/*< D( I+1 ) = G + P >*/
d__[i__ + 1] = g + p;
/*< G = C*R - B >*/
g = c__ * r__ - b;
/* If eigenvectors are desired, then save rotations. */
/*< IF( ICOMPZ.GT.0 ) THEN >*/
if (icompz > 0) {
/*< WORK( I ) = C >*/
work[i__] = c__;
/*< WORK( N-1+I ) = -S >*/
work[*n - 1 + i__] = -s;
/*< END IF >*/
}
/*< 70 CONTINUE >*/
/* L70: */
}
/* If eigenvectors are desired, then apply saved rotations. */
/*< IF( ICOMPZ.GT.0 ) THEN >*/
if (icompz > 0) {
/*< MM = M - L + 1 >*/
mm = m - l + 1;
/*< >*/
dlasr_("R", "V", "B", n, &mm, &work[l], &work[*n - 1 + l], &z__[l
* z_dim1 + 1], ldz, (ftnlen)1, (ftnlen)1, (ftnlen)1);
/*< END IF >*/
}
/*< D( L ) = D( L ) - P >*/
d__[l] -= p;
/*< E( L ) = G >*/
e[l] = g;
/*< GO TO 40 >*/
goto L40;
/* Eigenvalue found. */
/*< 80 CONTINUE >*/
L80:
/*< D( L ) = P >*/
d__[l] = p;
/*< L = L + 1 >*/
++l;
/*< >*/
if (l <= lend) {
goto L40;
}
/*< GO TO 140 >*/
goto L140;
/*< ELSE >*/
} else {
/* QR Iteration */
/* Look for small superdiagonal element. */
/*< 90 CONTINUE >*/
L90:
/*< IF( L.NE.LEND ) THEN >*/
if (l != lend) {
/*< LENDP1 = LEND + 1 >*/
lendp1 = lend + 1;
/*< DO 100 M = L, LENDP1, -1 >*/
i__1 = lendp1;
for (m = l; m >= i__1; --m) {
/*< TST = ABS( E( M-1 ) )**2 >*/
/* 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;
}
/*< 100 CONTINUE >*/
/* L100: */
}
/*< END IF >*/
}
/*< M = LEND >*/
m = lend;
/*< 110 CONTINUE >*/
L110:
/*< >*/
if (m > lend) {
e[m - 1] = 0.;
}
/*< P = D( L ) >*/
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.EQ.L-1 ) THEN >*/
if (m == l - 1) {
/*< IF( ICOMPZ.GT.0 ) THEN >*/
if (icompz > 0) {
/*< CALL DLAEV2( D( L-1 ), E( L-1 ), D( L ), RT1, RT2, C, S ) >*/
dlaev2_(&d__[l - 1], &e[l - 1], &d__[l], &rt1, &rt2, &c__, &s)
;
/*< WORK( M ) = C >*/
work[m] = c__;
/*< WORK( N-1+M ) = S >*/
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, (ftnlen)1, (ftnlen)1,
(ftnlen)1);
/*< ELSE >*/
} else {
/*< CALL DLAE2( D( L-1 ), E( L-1 ), D( L ), RT1, RT2 ) >*/
dlae2_(&d__[l - 1], &e[l - 1], &d__[l], &rt1, &rt2);
/*< END IF >*/
}
/*< D( L-1 ) = RT1 >*/
d__[l - 1] = rt1;
/*< D( L ) = RT2 >*/
d__[l] = rt2;
/*< E( L-1 ) = ZERO >*/
e[l - 1] = 0.;
/*< L = L - 2 >*/
l += -2;
/*< >*/
if (l >= lend) {
goto L90;
}
/*< GO TO 140 >*/
goto L140;
/*< END IF >*/
}
/*< >*/
if (jtot == nmaxit) {
goto L140;
}
/*< JTOT = JTOT + 1 >*/
++jtot;
/* Form shift. */
/*< G = ( D( L-1 )-P ) / ( TWO*E( L-1 ) ) >*/
g = (d__[l - 1] - p) / (e[l - 1] * 2.);
/*< R = DLAPY2( G, ONE ) >*/
r__ = dlapy2_(&g, &c_b10);
/*< G = D( M ) - P + ( E( L-1 ) / ( G+SIGN( R, G ) ) ) >*/
g = d__[m] - p + e[l - 1] / (g + d_sign(&r__, &g));
/*< S = ONE >*/
s = 1.;
/*< C = ONE >*/
c__ = 1.;
/*< P = ZERO >*/
p = 0.;
/* Inner loop */
/*< LM1 = L - 1 >*/
lm1 = l - 1;
/*< DO 120 I = M, LM1 >*/
i__1 = lm1;
for (i__ = m; i__ <= i__1; ++i__) {
/*< F = S*E( I ) >*/
f = s * e[i__];
/*< B = C*E( I ) >*/
b = c__ * e[i__];
/*< CALL DLARTG( G, F, C, S, R ) >*/
dlartg_(&g, &f, &c__, &s, &r__);
/*< >*/
if (i__ != m) {
e[i__ - 1] = r__;
}
/*< G = D( I ) - P >*/
g = d__[i__] - p;
/*< R = ( D( I+1 )-G )*S + TWO*C*B >*/
r__ = (d__[i__ + 1] - g) * s + c__ * 2. * b;
/*< P = S*R >*/
p = s * r__;
/*< D( I ) = G + P >*/
d__[i__] = g + p;
/*< G = C*R - B >*/
g = c__ * r__ - b;
/* If eigenvectors are desired, then save rotations. */
/*< IF( ICOMPZ.GT.0 ) THEN >*/
if (icompz > 0) {
/*< WORK( I ) = C >*/
work[i__] = c__;
/*< WORK( N-1+I ) = S >*/
work[*n - 1 + i__] = s;
/*< END IF >*/
}
/*< 120 CONTINUE >*/
/* L120: */
}
/* If eigenvectors are desired, then apply saved rotations. */
/*< IF( ICOMPZ.GT.0 ) THEN >*/
if (icompz > 0) {
/*< MM = L - M + 1 >*/
mm = l - m + 1;
/*< >*/
dlasr_("R", "V", "F", n, &mm, &work[m], &work[*n - 1 + m], &z__[m
* z_dim1 + 1], ldz, (ftnlen)1, (ftnlen)1, (ftnlen)1);
/*< END IF >*/
}
/*< D( L ) = D( L ) - P >*/
d__[l] -= p;
/*< E( LM1 ) = G >*/
e[lm1] = g;
/*< GO TO 90 >*/
goto L90;
/* Eigenvalue found. */
/*< 130 CONTINUE >*/
L130:
/*< D( L ) = P >*/
d__[l] = p;
/*< L = L - 1 >*/
--l;
/*< >*/
if (l >= lend) {
goto L90;
}
/*< GO TO 140 >*/
goto L140;
/*< END IF >*/
}
/* Undo scaling if necessary */
/*< 140 CONTINUE >*/
L140:
/*< IF( ISCALE.EQ.1 ) THEN >*/
if (iscale == 1) {
/*< >*/
i__1 = lendsv - lsv + 1;
dlascl_("G", &c__0, &c__0, &ssfmax, &anorm, &i__1, &c__1, &d__[lsv],
n, info, (ftnlen)1);
/*< >*/
i__1 = lendsv - lsv;
dlascl_("G", &c__0, &c__0, &ssfmax, &anorm, &i__1, &c__1, &e[lsv], n,
info, (ftnlen)1);
/*< ELSE IF( ISCALE.EQ.2 ) THEN >*/
} 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, (ftnlen)1);
/*< >*/
i__1 = lendsv - lsv;
dlascl_("G", &c__0, &c__0, &ssfmin, &anorm, &i__1, &c__1, &e[lsv], n,
info, (ftnlen)1);
/*< END IF >*/
}
/* Check for no convergence to an eigenvalue after a total */
/* of N*MAXIT iterations. */
/*< >*/
if (jtot < nmaxit) {
goto L10;
}
/*< DO 150 I = 1, N - 1 >*/
i__1 = *n - 1;
for (i__ = 1; i__ <= i__1; ++i__) {
/*< >*/
if (e[i__] != 0.) {
++(*info);
}
/*< 150 CONTINUE >*/
/* L150: */
}
/*< GO TO 190 >*/
goto L190;
/* Order eigenvalues and eigenvectors. */
/*< 160 CONTINUE >*/
L160:
/*< IF( ICOMPZ.EQ.0 ) THEN >*/
if (icompz == 0) {
/* Use Quick Sort */
/*< CALL DLASRT( 'I', N, D, INFO ) >*/
dlasrt_("I", n, &d__[1], info, (ftnlen)1);
/*< ELSE >*/
} else {
/* Use Selection Sort to minimize swaps of eigenvectors */
/*< DO 180 II = 2, N >*/
i__1 = *n;
for (ii = 2; ii <= i__1; ++ii) {
/*< I = II - 1 >*/
i__ = ii - 1;
/*< K = I >*/
k = i__;
/*< P = D( I ) >*/
p = d__[i__];
/*< DO 170 J = II, N >*/
i__2 = *n;
for (j = ii; j <= i__2; ++j) {
/*< IF( D( J ).LT.P ) THEN >*/
if (d__[j] < p) {
/*< K = J >*/
k = j;
/*< P = D( J ) >*/
p = d__[j];
/*< END IF >*/
}
/*< 170 CONTINUE >*/
/* L170: */
}
/*< IF( K.NE.I ) THEN >*/
if (k != i__) {
/*< D( K ) = D( I ) >*/
d__[k] = d__[i__];
/*< D( I ) = P >*/
d__[i__] = p;
/*< CALL DSWAP( N, Z( 1, I ), 1, Z( 1, K ), 1 ) >*/
dswap_(n, &z__[i__ * z_dim1 + 1], &c__1, &z__[k * z_dim1 + 1],
&c__1);
/*< END IF >*/
}
/*< 180 CONTINUE >*/
/* L180: */
}
/*< END IF >*/
}
/*< 190 CONTINUE >*/
L190:
/*< RETURN >*/
return 0;
/* End of DSTEQR */
/*< END >*/
} /* dsteqr_ */
/* Subroutine */ int dstevd_(char *jobz, integer *n, doublereal *d__,
doublereal *e, doublereal *z__, integer *ldz, doublereal *work,
integer *lwork, integer *iwork, integer *liwork, integer *info)
{
/* System generated locals */
integer z_dim1, z_offset, i__1;
doublereal d__1;
/* Builtin functions */
double sqrt(doublereal);
/* Local variables */
doublereal eps, rmin, rmax, tnrm;
extern /* Subroutine */ int dscal_(integer *, doublereal *, doublereal *,
integer *);
doublereal sigma;
extern logical lsame_(char *, char *);
integer lwmin;
logical wantz;
extern doublereal dlamch_(char *);
integer iscale;
extern /* Subroutine */ int dstedc_(char *, integer *, doublereal *,
doublereal *, doublereal *, integer *, doublereal *, integer *,
integer *, integer *, integer *);
doublereal safmin;
extern /* Subroutine */ int xerbla_(char *, integer *);
doublereal bignum;
extern doublereal dlanst_(char *, integer *, doublereal *, doublereal *);
extern /* Subroutine */ int dsterf_(integer *, doublereal *, doublereal *,
integer *);
integer liwmin;
doublereal smlnum;
logical lquery;
/* -- LAPACK driver routine (version 3.1) -- */
/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/* November 2006 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* DSTEVD computes all eigenvalues and, optionally, eigenvectors of a */
/* real symmetric tridiagonal matrix. If eigenvectors are desired, it */
/* uses a divide and conquer algorithm. */
/* The divide and conquer algorithm makes very mild assumptions about */
/* floating point arithmetic. It will work on machines with a guard */
/* digit in add/subtract, or on those binary machines without guard */
/* digits which subtract like the Cray X-MP, Cray Y-MP, Cray C-90, or */
/* Cray-2. It could conceivably fail on hexadecimal or decimal machines */
/* without guard digits, but we know of none. */
/* Arguments */
/* ========= */
/* JOBZ (input) CHARACTER*1 */
/* = 'N': Compute eigenvalues only; */
/* = 'V': Compute eigenvalues and eigenvectors. */
/* 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 */
/* A. */
/* 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 A, stored in elements 1 to N-1 of E. */
/* On exit, the contents of E are destroyed. */
/* Z (output) DOUBLE PRECISION array, dimension (LDZ, N) */
/* If JOBZ = 'V', then if INFO = 0, Z contains the orthonormal */
/* eigenvectors of the matrix A, with the i-th column of Z */
/* holding the eigenvector associated with D(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 (LWORK) */
/* On exit, if INFO = 0, WORK(1) returns the optimal LWORK. */
/* LWORK (input) INTEGER */
/* The dimension of the array WORK. */
/* If JOBZ = 'N' or N <= 1 then LWORK must be at least 1. */
/* If JOBZ = 'V' and N > 1 then LWORK must be at least */
/* ( 1 + 4*N + N**2 ). */
/* If LWORK = -1, then a workspace query is assumed; the routine */
/* only calculates the optimal sizes of the WORK and IWORK */
/* arrays, returns these values as the first entries of the WORK */
/* and IWORK arrays, and no error message related to LWORK or */
/* LIWORK is issued by XERBLA. */
/* IWORK (workspace/output) INTEGER array, dimension (MAX(1,LIWORK)) */
/* On exit, if INFO = 0, IWORK(1) returns the optimal LIWORK. */
/* LIWORK (input) INTEGER */
/* The dimension of the array IWORK. */
/* If JOBZ = 'N' or N <= 1 then LIWORK must be at least 1. */
/* If JOBZ = 'V' and N > 1 then LIWORK must be at least 3+5*N. */
/* If LIWORK = -1, then a workspace query is assumed; the */
/* routine only calculates the optimal sizes of the WORK and */
/* IWORK arrays, returns these values as the first entries of */
/* the WORK and IWORK arrays, and no error message related to */
/* LWORK or LIWORK is issued by XERBLA. */
/* INFO (output) INTEGER */
/* = 0: successful exit */
/* < 0: if INFO = -i, the i-th argument had an illegal value */
/* > 0: if INFO = i, the algorithm failed to converge; i */
/* off-diagonal elements of E did not converge to zero. */
/* ===================================================================== */
/* .. 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;
--iwork;
/* Function Body */
wantz = lsame_(jobz, "V");
lquery = *lwork == -1 || *liwork == -1;
*info = 0;
liwmin = 1;
lwmin = 1;
if (*n > 1 && wantz) {
/* Computing 2nd power */
i__1 = *n;
lwmin = (*n << 2) + 1 + i__1 * i__1;
liwmin = *n * 5 + 3;
}
if (! (wantz || lsame_(jobz, "N"))) {
*info = -1;
} else if (*n < 0) {
*info = -2;
} else if (*ldz < 1 || wantz && *ldz < *n) {
*info = -6;
}
if (*info == 0) {
work[1] = (doublereal) lwmin;
iwork[1] = liwmin;
if (*lwork < lwmin && ! lquery) {
*info = -8;
} else if (*liwork < liwmin && ! lquery) {
*info = -10;
}
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("DSTEVD", &i__1);
return 0;
} else if (lquery) {
return 0;
}
/* Quick return if possible */
if (*n == 0) {
return 0;
}
if (*n == 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);
rmax = sqrt(bignum);
/* Scale matrix to allowable range, if necessary. */
iscale = 0;
tnrm = dlanst_("M", n, &d__[1], &e[1]);
if (tnrm > 0. && tnrm < rmin) {
iscale = 1;
sigma = rmin / tnrm;
} else if (tnrm > rmax) {
iscale = 1;
sigma = rmax / tnrm;
}
if (iscale == 1) {
dscal_(n, &sigma, &d__[1], &c__1);
i__1 = *n - 1;
dscal_(&i__1, &sigma, &e[1], &c__1);
}
/* For eigenvalues only, call DSTERF. For eigenvalues and */
/* eigenvectors, call DSTEDC. */
if (! wantz) {
dsterf_(n, &d__[1], &e[1], info);
} else {
dstedc_("I", n, &d__[1], &e[1], &z__[z_offset], ldz, &work[1], lwork,
&iwork[1], liwork, info);
}
/* If matrix was scaled, then rescale eigenvalues appropriately. */
if (iscale == 1) {
d__1 = 1. / sigma;
dscal_(n, &d__1, &d__[1], &c__1);
}
work[1] = (doublereal) lwmin;
iwork[1] = liwmin;
return 0;
/* End of DSTEVD */
} /* dstevd_ */
/* Subroutine */ int dstedc_(char *compz, integer *n, doublereal *d__,
doublereal *e, doublereal *z__, integer *ldz, doublereal *work,
integer *lwork, integer *iwork, integer *liwork, integer *info)
{
/* System generated locals */
integer z_dim1, z_offset, i__1, i__2;
doublereal d__1, d__2;
/* Builtin functions */
double log(doublereal);
integer pow_ii(integer *, integer *);
double sqrt(doublereal);
/* Local variables */
integer i__, j, k, m;
doublereal p;
integer ii, lgn;
doublereal eps, tiny;
extern /* Subroutine */ int dgemm_(char *, char *, integer *, integer *,
integer *, doublereal *, doublereal *, integer *, doublereal *,
integer *, doublereal *, doublereal *, integer *);
extern logical lsame_(char *, char *);
extern /* Subroutine */ int dswap_(integer *, doublereal *, integer *,
doublereal *, integer *);
integer lwmin;
extern /* Subroutine */ int dlaed0_(integer *, integer *, integer *,
doublereal *, doublereal *, doublereal *, integer *, doublereal *,
integer *, doublereal *, integer *, integer *);
integer start;
extern doublereal dlamch_(char *);
extern /* Subroutine */ int dlascl_(char *, integer *, integer *,
doublereal *, doublereal *, integer *, integer *, doublereal *,
integer *, integer *), dlacpy_(char *, integer *, integer
*, doublereal *, integer *, doublereal *, integer *),
dlaset_(char *, integer *, integer *, doublereal *, doublereal *,
doublereal *, integer *);
extern integer ilaenv_(integer *, char *, char *, integer *, integer *,
integer *, integer *);
extern /* Subroutine */ int xerbla_(char *, integer *);
integer finish;
extern doublereal dlanst_(char *, integer *, doublereal *, doublereal *);
extern /* Subroutine */ int dsterf_(integer *, doublereal *, doublereal *,
integer *), dlasrt_(char *, integer *, doublereal *, integer *);
integer liwmin, icompz;
extern /* Subroutine */ int dsteqr_(char *, integer *, doublereal *,
doublereal *, doublereal *, integer *, doublereal *, integer *);
doublereal orgnrm;
logical lquery;
integer smlsiz, storez, strtrw;
/* -- LAPACK driver routine (version 3.1) -- */
/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/* November 2006 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* DSTEDC computes all eigenvalues and, optionally, eigenvectors of a */
/* symmetric tridiagonal matrix using the divide and conquer method. */
/* The eigenvectors of a full or band real symmetric matrix can also be */
/* found if DSYTRD or DSPTRD or DSBTRD has been used to reduce this */
/* matrix to tridiagonal 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 DLAED3 for details. */
/* Arguments */
/* ========= */
/* COMPZ (input) CHARACTER*1 */
/* = 'N': Compute eigenvalues only. */
/* = 'I': Compute eigenvectors of tridiagonal matrix also. */
/* = 'V': Compute eigenvectors of original dense symmetric */
/* matrix also. On entry, Z contains the orthogonal */
/* matrix used to reduce the original matrix to */
/* tridiagonal form. */
/* N (input) INTEGER */
/* The dimension of the symmetric tridiagonal 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 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. */
/* If eigenvectors are desired, then LDZ >= max(1,N). */
/* WORK (workspace/output) DOUBLE PRECISION array, */
/* dimension (LWORK) */
/* On exit, if INFO = 0, WORK(1) returns the optimal LWORK. */
/* LWORK (input) INTEGER */
/* The dimension of the array WORK. */
/* If COMPZ = 'N' or N <= 1 then LWORK must be at least 1. */
/* If COMPZ = 'V' and N > 1 then LWORK must be at least */
/* ( 1 + 3*N + 2*N*lg N + 3*N**2 ), */
/* where lg( N ) = smallest integer k such */
/* that 2**k >= N. */
/* If COMPZ = 'I' and N > 1 then LWORK must be at least */
/* ( 1 + 4*N + N**2 ). */
/* Note that for COMPZ = 'I' or 'V', then if N is less than or */
/* equal to the minimum divide size, usually 25, then LWORK need */
/* only be max(1,2*(N-1)). */
/* If LWORK = -1, then a workspace query is assumed; the routine */
/* only calculates the optimal size of the WORK array, returns */
/* this value as the first entry of the WORK array, and no error */
/* message related to LWORK is issued by XERBLA. */
/* 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. */
/* If COMPZ = 'N' or N <= 1 then LIWORK must be at least 1. */
/* If COMPZ = 'V' and N > 1 then LIWORK must be at least */
/* ( 6 + 6*N + 5*N*lg N ). */
/* If COMPZ = 'I' and N > 1 then LIWORK must be at least */
/* ( 3 + 5*N ). */
/* Note that for COMPZ = 'I' or 'V', then if N is less than or */
/* equal to the minimum divide size, usually 25, then LIWORK */
/* need only be 1. */
/* 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 */
/* = 0: successful exit. */
/* < 0: if INFO = -i, the i-th argument had an illegal value. */
/* > 0: The algorithm failed to compute an eigenvalue while */
/* working on the submatrix lying in rows and columns */
/* INFO/(N+1) through mod(INFO,N+1). */
/* Further Details */
/* =============== */
/* Based on contributions by */
/* Jeff Rutter, Computer Science Division, University of California */
/* at Berkeley, USA */
/* Modified by Francoise Tisseur, University of Tennessee. */
/* ===================================================================== */
/* .. 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;
--iwork;
/* Function Body */
*info = 0;
lquery = *lwork == -1 || *liwork == -1;
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) {
/* Compute the workspace requirements */
smlsiz = ilaenv_(&c__9, "DSTEDC", " ", &c__0, &c__0, &c__0, &c__0);
if (*n <= 1 || icompz == 0) {
liwmin = 1;
lwmin = 1;
} else if (*n <= smlsiz) {
liwmin = 1;
lwmin = *n - 1 << 1;
} else {
lgn = (integer) (log((doublereal) (*n)) / log(2.));
if (pow_ii(&c__2, &lgn) < *n) {
++lgn;
}
if (pow_ii(&c__2, &lgn) < *n) {
++lgn;
}
if (icompz == 1) {
/* Computing 2nd power */
i__1 = *n;
lwmin = *n * 3 + 1 + (*n << 1) * lgn + i__1 * i__1 * 3;
liwmin = *n * 6 + 6 + *n * 5 * lgn;
} else if (icompz == 2) {
/* Computing 2nd power */
i__1 = *n;
lwmin = (*n << 2) + 1 + i__1 * i__1;
liwmin = *n * 5 + 3;
}
}
work[1] = (doublereal) lwmin;
iwork[1] = liwmin;
if (*lwork < lwmin && ! lquery) {
*info = -8;
} else if (*liwork < liwmin && ! lquery) {
*info = -10;
}
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("DSTEDC", &i__1);
return 0;
} else if (lquery) {
return 0;
}
/* Quick return if possible */
if (*n == 0) {
return 0;
}
if (*n == 1) {
if (icompz != 0) {
z__[z_dim1 + 1] = 1.;
}
return 0;
}
/* If the following conditional clause is removed, then the routine */
/* will use the Divide and Conquer routine to compute only the */
/* eigenvalues, which requires (3N + 3N**2) real workspace and */
/* (2 + 5N + 2N lg(N)) integer workspace. */
/* Since on many architectures DSTERF is much faster than any other */
/* algorithm for finding eigenvalues only, it is used here */
/* as the default. If the conditional clause is removed, then */
/* information on the size of workspace needs to be changed. */
/* If COMPZ = 'N', use DSTERF to compute the eigenvalues. */
if (icompz == 0) {
dsterf_(n, &d__[1], &e[1], info);
goto L50;
}
/* If N is smaller than the minimum divide size (SMLSIZ+1), then */
/* solve the problem with another solver. */
if (*n <= smlsiz) {
dsteqr_(compz, n, &d__[1], &e[1], &z__[z_offset], ldz, &work[1], info);
} else {
/* If COMPZ = 'V', the Z matrix must be stored elsewhere for later */
/* use. */
if (icompz == 1) {
storez = *n * *n + 1;
} else {
storez = 1;
}
if (icompz == 2) {
dlaset_("Full", n, n, &c_b17, &c_b18, &z__[z_offset], ldz);
}
/* Scale. */
orgnrm = dlanst_("M", n, &d__[1], &e[1]);
if (orgnrm == 0.) {
goto L50;
}
eps = dlamch_("Epsilon");
start = 1;
/* while ( START <= N ) */
L10:
if (start <= *n) {
/* Let FINISH be the position of the next subdiagonal entry */
/* such that E( FINISH ) <= TINY or FINISH = N if no such */
/* subdiagonal exists. The matrix identified by the elements */
/* between START and FINISH constitutes an independent */
/* sub-problem. */
finish = start;
L20:
if (finish < *n) {
tiny = eps * sqrt((d__1 = d__[finish], abs(d__1))) * sqrt((
d__2 = d__[finish + 1], abs(d__2)));
if ((d__1 = e[finish], abs(d__1)) > tiny) {
++finish;
goto L20;
}
}
/* (Sub) Problem determined. Compute its size and solve it. */
m = finish - start + 1;
if (m == 1) {
start = finish + 1;
goto L10;
}
if (m > smlsiz) {
/* Scale. */
orgnrm = dlanst_("M", &m, &d__[start], &e[start]);
dlascl_("G", &c__0, &c__0, &orgnrm, &c_b18, &m, &c__1, &d__[
start], &m, info);
i__1 = m - 1;
i__2 = m - 1;
dlascl_("G", &c__0, &c__0, &orgnrm, &c_b18, &i__1, &c__1, &e[
start], &i__2, info);
if (icompz == 1) {
strtrw = 1;
} else {
strtrw = start;
}
dlaed0_(&icompz, n, &m, &d__[start], &e[start], &z__[strtrw +
start * z_dim1], ldz, &work[1], n, &work[storez], &
iwork[1], info);
if (*info != 0) {
*info = (*info / (m + 1) + start - 1) * (*n + 1) + *info %
(m + 1) + start - 1;
goto L50;
}
/* Scale back. */
dlascl_("G", &c__0, &c__0, &c_b18, &orgnrm, &m, &c__1, &d__[
start], &m, info);
} else {
if (icompz == 1) {
/* Since QR won't update a Z matrix which is larger than */
/* the length of D, we must solve the sub-problem in a */
/* workspace and then multiply back into Z. */
dsteqr_("I", &m, &d__[start], &e[start], &work[1], &m, &
work[m * m + 1], info);
dlacpy_("A", n, &m, &z__[start * z_dim1 + 1], ldz, &work[
storez], n);
dgemm_("N", "N", n, &m, &m, &c_b18, &work[storez], n, &
work[1], &m, &c_b17, &z__[start * z_dim1 + 1],
ldz);
} else if (icompz == 2) {
dsteqr_("I", &m, &d__[start], &e[start], &z__[start +
start * z_dim1], ldz, &work[1], info);
} else {
dsterf_(&m, &d__[start], &e[start], info);
}
if (*info != 0) {
*info = start * (*n + 1) + finish;
goto L50;
}
}
start = finish + 1;
goto L10;
}
/* endwhile */
/* If the problem split any number of times, then the eigenvalues */
/* will not be properly ordered. Here we permute the eigenvalues */
/* (and the associated eigenvectors) into ascending order. */
if (m != *n) {
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];
}
/* L30: */
}
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);
}
/* L40: */
}
}
}
}
L50:
work[1] = (doublereal) lwmin;
iwork[1] = liwmin;
return 0;
/* End of DSTEDC */
} /* dstedc_ */
/* Subroutine */ int dptsvx_(char *fact, integer *n, integer *nrhs,
doublereal *d__, doublereal *e, doublereal *df, doublereal *ef,
doublereal *b, integer *ldb, doublereal *x, integer *ldx, doublereal *
rcond, doublereal *ferr, doublereal *berr, doublereal *work, integer *
info)
{
/* System generated locals */
integer b_dim1, b_offset, x_dim1, x_offset, i__1;
/* Local variables */
extern logical lsame_(char *, char *);
doublereal anorm;
extern /* Subroutine */ int dcopy_(integer *, doublereal *, integer *,
doublereal *, integer *);
extern doublereal dlamch_(char *);
logical nofact;
extern /* Subroutine */ int dlacpy_(char *, integer *, integer *,
doublereal *, integer *, doublereal *, integer *),
xerbla_(char *, integer *);
extern doublereal dlanst_(char *, integer *, doublereal *, doublereal *);
extern /* Subroutine */ int dptcon_(integer *, doublereal *, doublereal *,
doublereal *, doublereal *, doublereal *, integer *), dptrfs_(
integer *, integer *, doublereal *, doublereal *, doublereal *,
doublereal *, doublereal *, integer *, doublereal *, integer *,
doublereal *, doublereal *, doublereal *, integer *), dpttrf_(
integer *, doublereal *, doublereal *, integer *), dpttrs_(
integer *, integer *, doublereal *, doublereal *, doublereal *,
integer *, integer *);
/* -- LAPACK routine (version 3.2) -- */
/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/* November 2006 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* DPTSVX uses the factorization A = L*D*L**T to compute the solution */
/* to a real system of linear equations A*X = B, where A is an N-by-N */
/* symmetric positive definite tridiagonal matrix and X and B are */
/* N-by-NRHS matrices. */
/* Error bounds on the solution and a condition estimate are also */
/* provided. */
/* Description */
/* =========== */
/* The following steps are performed: */
/* 1. If FACT = 'N', the matrix A is factored as A = L*D*L**T, where L */
/* is a unit lower bidiagonal matrix and D is diagonal. The */
/* factorization can also be regarded as having the form */
/* A = U**T*D*U. */
/* 2. If the leading i-by-i principal minor is not positive definite, */
/* then the routine returns with INFO = i. Otherwise, the factored */
/* form of A is used to estimate the condition number of the matrix */
/* A. If the reciprocal of the condition number is less than machine */
/* precision, INFO = N+1 is returned as a warning, but the routine */
/* still goes on to solve for X and compute error bounds as */
/* described below. */
/* 3. The system of equations is solved for X using the factored form */
/* of A. */
/* 4. Iterative refinement is applied to improve the computed solution */
/* matrix and calculate error bounds and backward error estimates */
/* for it. */
/* Arguments */
/* ========= */
/* FACT (input) CHARACTER*1 */
/* Specifies whether or not the factored form of A has been */
/* supplied on entry. */
/* = 'F': On entry, DF and EF contain the factored form of A. */
/* D, E, DF, and EF will not be modified. */
/* = 'N': The matrix A will be copied to DF and EF and */
/* factored. */
/* N (input) INTEGER */
/* The order of the matrix A. N >= 0. */
/* NRHS (input) INTEGER */
/* The number of right hand sides, i.e., the number of columns */
/* of the matrices B and X. NRHS >= 0. */
/* D (input) DOUBLE PRECISION array, dimension (N) */
/* The n diagonal elements of the tridiagonal matrix A. */
/* E (input) DOUBLE PRECISION array, dimension (N-1) */
/* The (n-1) subdiagonal elements of the tridiagonal matrix A. */
/* DF (input or output) DOUBLE PRECISION array, dimension (N) */
/* If FACT = 'F', then DF is an input argument and on entry */
/* contains the n diagonal elements of the diagonal matrix D */
/* from the L*D*L**T factorization of A. */
/* If FACT = 'N', then DF is an output argument and on exit */
/* contains the n diagonal elements of the diagonal matrix D */
/* from the L*D*L**T factorization of A. */
/* EF (input or output) DOUBLE PRECISION array, dimension (N-1) */
/* If FACT = 'F', then EF is an input argument and on entry */
/* contains the (n-1) subdiagonal elements of the unit */
/* bidiagonal factor L from the L*D*L**T factorization of A. */
/* If FACT = 'N', then EF is an output argument and on exit */
/* contains the (n-1) subdiagonal elements of the unit */
/* bidiagonal factor L from the L*D*L**T factorization of A. */
/* B (input) DOUBLE PRECISION array, dimension (LDB,NRHS) */
/* The N-by-NRHS right hand side matrix B. */
/* LDB (input) INTEGER */
/* The leading dimension of the array B. LDB >= max(1,N). */
/* X (output) DOUBLE PRECISION array, dimension (LDX,NRHS) */
/* If INFO = 0 of INFO = N+1, the N-by-NRHS solution matrix X. */
/* LDX (input) INTEGER */
/* The leading dimension of the array X. LDX >= max(1,N). */
/* RCOND (output) DOUBLE PRECISION */
/* The reciprocal condition number of the matrix A. If RCOND */
/* is less than the machine precision (in particular, if */
/* RCOND = 0), the matrix is singular to working precision. */
/* This condition is indicated by a return code of INFO > 0. */
/* FERR (output) DOUBLE PRECISION array, dimension (NRHS) */
/* The forward error bound for each solution vector */
/* X(j) (the j-th column of the solution matrix X). */
/* If XTRUE is the true solution corresponding to X(j), FERR(j) */
/* is an estimated upper bound for the magnitude of the largest */
/* element in (X(j) - XTRUE) divided by the magnitude of the */
/* largest element in X(j). */
/* BERR (output) DOUBLE PRECISION array, dimension (NRHS) */
/* The componentwise relative backward error of each solution */
/* vector X(j) (i.e., the smallest relative change in any */
/* element of A or B that makes X(j) an exact solution). */
/* WORK (workspace) DOUBLE PRECISION array, dimension (2*N) */
/* INFO (output) INTEGER */
/* = 0: successful exit */
/* < 0: if INFO = -i, the i-th argument had an illegal value */
/* > 0: if INFO = i, and i is */
/* <= N: the leading minor of order i of A is */
/* not positive definite, so the factorization */
/* could not be completed, and the solution has not */
/* been computed. RCOND = 0 is returned. */
/* = N+1: U is nonsingular, but RCOND is less than machine */
/* precision, meaning that the matrix is singular */
/* to working precision. Nevertheless, the */
/* solution and error bounds are computed because */
/* there are a number of situations where the */
/* computed solution can be more accurate than the */
/* value of RCOND would suggest. */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Executable Statements .. */
/* Test the input parameters. */
/* Parameter adjustments */
--d__;
--e;
--df;
--ef;
b_dim1 = *ldb;
b_offset = 1 + b_dim1;
b -= b_offset;
x_dim1 = *ldx;
x_offset = 1 + x_dim1;
x -= x_offset;
--ferr;
--berr;
--work;
/* Function Body */
*info = 0;
nofact = lsame_(fact, "N");
if (! nofact && ! lsame_(fact, "F")) {
*info = -1;
} else if (*n < 0) {
*info = -2;
} else if (*nrhs < 0) {
*info = -3;
} else if (*ldb < max(1,*n)) {
*info = -9;
} else if (*ldx < max(1,*n)) {
*info = -11;
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("DPTSVX", &i__1);
return 0;
}
if (nofact) {
/* Compute the L*D*L' (or U'*D*U) factorization of A. */
dcopy_(n, &d__[1], &c__1, &df[1], &c__1);
if (*n > 1) {
i__1 = *n - 1;
dcopy_(&i__1, &e[1], &c__1, &ef[1], &c__1);
}
dpttrf_(n, &df[1], &ef[1], info);
/* Return if INFO is non-zero. */
if (*info > 0) {
*rcond = 0.;
return 0;
}
}
/* Compute the norm of the matrix A. */
anorm = dlanst_("1", n, &d__[1], &e[1]);
/* Compute the reciprocal of the condition number of A. */
dptcon_(n, &df[1], &ef[1], &anorm, rcond, &work[1], info);
/* Compute the solution vectors X. */
dlacpy_("Full", n, nrhs, &b[b_offset], ldb, &x[x_offset], ldx);
dpttrs_(n, nrhs, &df[1], &ef[1], &x[x_offset], ldx, info);
/* Use iterative refinement to improve the computed solutions and */
/* compute error bounds and backward error estimates for them. */
dptrfs_(n, nrhs, &d__[1], &e[1], &df[1], &ef[1], &b[b_offset], ldb, &x[
x_offset], ldx, &ferr[1], &berr[1], &work[1], info);
/* Set INFO = N+1 if the matrix is singular to working precision. */
if (*rcond < dlamch_("Epsilon")) {
*info = *n + 1;
}
return 0;
/* End of DPTSVX */
} /* dptsvx_ */
/* Subroutine */ int dstqrb_(integer *n, doublereal *d__, doublereal *e,
doublereal *z__, doublereal *work, integer *info)
{
/* System generated locals */
integer i__1, i__2;
doublereal d__1, d__2;
/* Local variables */
static doublereal b, c__, f, g;
static integer i__, j, k, l, m;
static doublereal p, r__, s;
static integer l1, ii, mm, lm1, mm1, nm1;
static doublereal rt1, rt2, eps;
static integer lsv;
static doublereal tst, eps2;
static integer lend, jtot;
extern /* Subroutine */ int dlae2_(doublereal *, doublereal *, doublereal
*, doublereal *, doublereal *), dlasr_(char *, char *, char *,
integer *, integer *, doublereal *, doublereal *, doublereal *,
integer *, ftnlen, ftnlen, ftnlen);
static doublereal anorm;
extern /* Subroutine */ int dlaev2_(doublereal *, doublereal *,
doublereal *, doublereal *, doublereal *, doublereal *,
doublereal *);
static integer lendm1, lendp1;
extern doublereal dlapy2_(doublereal *, doublereal *), dlamch_(char *,
ftnlen);
static integer iscale;
extern /* Subroutine */ int dlascl_(char *, integer *, integer *,
doublereal *, doublereal *, integer *, integer *, doublereal *,
integer *, integer *, ftnlen);
static doublereal safmin;
extern /* Subroutine */ int dlartg_(doublereal *, doublereal *,
doublereal *, doublereal *, doublereal *);
static doublereal safmax;
extern doublereal dlanst_(char *, integer *, doublereal *, doublereal *,
ftnlen);
extern /* Subroutine */ int dlasrt_(char *, integer *, doublereal *,
integer *, ftnlen);
static integer lendsv, nmaxit, icompz;
static doublereal ssfmax, ssfmin;
/* %------------------% */
/* | Scalar Arguments | */
/* %------------------% */
/* %-----------------% */
/* | Array Arguments | */
/* %-----------------% */
/* .. parameters .. */
/* .. */
/* .. local scalars .. */
/* .. */
/* .. external functions .. */
/* .. */
/* .. external subroutines .. */
/* .. */
/* .. intrinsic functions .. */
/* .. */
/* .. executable statements .. */
/* test the input parameters. */
/* Parameter adjustments */
--work;
--z__;
--e;
--d__;
/* Function Body */
*info = 0;
/* $$$ IF( LSAME( COMPZ, 'N' ) ) THEN */
/* $$$ ICOMPZ = 0 */
/* $$$ ELSE IF( LSAME( COMPZ, 'V' ) ) THEN */
/* $$$ ICOMPZ = 1 */
/* $$$ ELSE IF( LSAME( COMPZ, 'I' ) ) THEN */
/* $$$ ICOMPZ = 2 */
/* $$$ ELSE */
/* $$$ ICOMPZ = -1 */
/* $$$ END IF */
/* $$$ IF( ICOMPZ.LT.0 ) THEN */
/* $$$ INFO = -1 */
/* $$$ ELSE IF( N.LT.0 ) THEN */
/* $$$ INFO = -2 */
/* $$$ ELSE IF( ( LDZ.LT.1 ) .OR. ( ICOMPZ.GT.0 .AND. LDZ.LT.MAX( 1, */
/* $$$ $ N ) ) ) THEN */
/* $$$ INFO = -6 */
/* $$$ END IF */
/* $$$ IF( INFO.NE.0 ) THEN */
/* $$$ CALL XERBLA( 'SSTEQR', -INFO ) */
/* $$$ RETURN */
/* $$$ END IF */
/* *** New starting with version 2.5 *** */
icompz = 2;
/* ************************************* */
/* quick return if possible */
if (*n == 0) {
return 0;
}
if (*n == 1) {
if (icompz == 2) {
z__[1] = 1.;
}
return 0;
}
/* determine the unit roundoff and over/underflow thresholds. */
eps = dlamch_("e", (ftnlen)1);
/* Computing 2nd power */
d__1 = eps;
eps2 = d__1 * d__1;
safmin = dlamch_("s", (ftnlen)1);
safmax = 1. / safmin;
ssfmax = sqrt(safmax) / 3.;
ssfmin = sqrt(safmin) / eps2;
/* compute the eigenvalues and eigenvectors of the tridiagonal */
/* matrix. */
/* $$ if( icompz.eq.2 ) */
/* $$$ $ call dlaset( 'full', n, n, zero, one, z, ldz ) */
/* *** New starting with version 2.5 *** */
if (icompz == 2) {
i__1 = *n - 1;
for (j = 1; j <= i__1; ++j) {
z__[j] = 0.;
/* L5: */
}
z__[*n] = 1.;
}
/* ************************************* */
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], (ftnlen)1);
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, (ftnlen)1);
i__1 = lend - l;
dlascl_("g", &c__0, &c__0, &anorm, &ssfmax, &i__1, &c__1, &e[l], n,
info, (ftnlen)1);
} 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, (ftnlen)1);
i__1 = lend - l;
dlascl_("g", &c__0, &c__0, &anorm, &ssfmin, &i__1, &c__1, &e[l], n,
info, (ftnlen)1);
}
/* 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 dlaev2 */
/* 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;
/* $$$ call dlasr( 'r', 'v', 'b', n, 2, work( l ), */
/* $$$ $ work( n-1+l ), z( 1, l ), ldz ) */
/* *** New starting with version 2.5 *** */
tst = z__[l + 1];
z__[l + 1] = c__ * tst - s * z__[l];
z__[l] = s * tst + c__ * z__[l];
/* ************************************* */
} 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_b31);
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;
/* $$$ call dlasr( 'r', 'v', 'b', n, mm, work( l ), work( n-1+l ), */
/* $$$ $ z( 1, l ), ldz ) */
/* *** New starting with version 2.5 *** */
dlasr_("r", "v", "b", &c__1, &mm, &work[l], &work[*n - 1 + l], &
z__[l], &c__1, (ftnlen)1, (ftnlen)1, (ftnlen)1);
/* ************************************* */
}
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 dlaev2 */
/* 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 */
/* $$$ call dlasr( 'r', 'v', 'f', n, 2, work( m ), */
/* $$$ $ work( n-1+m ), z( 1, l-1 ), ldz ) */
/* *** New starting with version 2.5 *** */
tst = z__[l];
z__[l] = c__ * tst - s * z__[l - 1];
z__[l - 1] = s * tst + c__ * z__[l - 1];
/* ************************************* */
} 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_b31);
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;
/* $$$ call dlasr( 'r', 'v', 'f', n, mm, work( m ), work( n-1+m ), */
/* $$$ $ z( 1, m ), ldz ) */
/* *** New starting with version 2.5 *** */
dlasr_("r", "v", "f", &c__1, &mm, &work[m], &work[*n - 1 + m], &
z__[m], &c__1, (ftnlen)1, (ftnlen)1, (ftnlen)1);
/* ************************************* */
}
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, (ftnlen)1);
i__1 = lendsv - lsv;
dlascl_("g", &c__0, &c__0, &ssfmax, &anorm, &i__1, &c__1, &e[lsv], n,
info, (ftnlen)1);
} 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, (ftnlen)1);
i__1 = lendsv - lsv;
dlascl_("g", &c__0, &c__0, &ssfmin, &anorm, &i__1, &c__1, &e[lsv], n,
info, (ftnlen)1);
}
/* 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, (ftnlen)1);
} 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;
/* $$$ call dswap( n, z( 1, i ), 1, z( 1, k ), 1 ) */
/* *** New starting with version 2.5 *** */
p = z__[k];
z__[k] = z__[i__];
z__[i__] = p;
/* ************************************* */
}
/* L180: */
}
}
L190:
return 0;
/* %---------------% */
/* | End of dstqrb | */
/* %---------------% */
} /* dstqrb_ */
