/* Subroutine */ int sgetrf_(integer *m, integer *n, real *a, integer *lda,
integer *ipiv, integer *info)
{
/* System generated locals */
integer a_dim1, a_offset, i__1, i__2, i__3;
real r__1;
/* Local variables */
integer i__, j, ipivstart, jpivstart, jp;
real tmp;
extern /* Subroutine */ int sscal_(integer *, real *, real *, integer *),
sgemm_(char *, char *, integer *, integer *, integer *, real *,
real *, integer *, real *, integer *, real *, real *, integer *);
integer kcols;
real sfmin;
integer nstep;
extern /* Subroutine */ int strsm_(char *, char *, char *, char *,
integer *, integer *, real *, real *, integer *, real *, integer *
);
integer kahead;
extern doublereal slamch_(char *);
extern /* Subroutine */ int xerbla_(char *, integer *);
extern integer isamax_(integer *, real *, integer *);
integer npived;
extern logical sisnan_(real *);
integer kstart;
extern /* Subroutine */ int slaswp_(integer *, real *, integer *, integer
*, integer *, integer *, integer *);
integer ntopiv;
/* -- LAPACK routine (version 3.X) -- */
/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/* May 2008 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* SGETRF computes an LU factorization of a general M-by-N matrix A */
/* using partial pivoting with row interchanges. */
/* The factorization has the form */
/* A = P * L * U */
/* where P is a permutation matrix, L is lower triangular with unit */
/* diagonal elements (lower trapezoidal if m > n), and U is upper */
/* triangular (upper trapezoidal if m < n). */
/* This code implements an iterative version of Sivan Toledo's recursive */
/* LU algorithm[1]. For square matrices, this iterative versions should */
/* be within a factor of two of the optimum number of memory transfers. */
/* The pattern is as follows, with the large blocks of U being updated */
/* in one call to STRSM, and the dotted lines denoting sections that */
/* have had all pending permutations applied: */
/* 1 2 3 4 5 6 7 8 */
/* +-+-+---+-------+------ */
/* | |1| | | */
/* |.+-+ 2 | | */
/* | | | | | */
/* |.|.+-+-+ 4 | */
/* | | | |1| | */
/* | | |.+-+ | */
/* | | | | | | */
/* |.|.|.|.+-+-+---+ 8 */
/* | | | | | |1| | */
/* | | | | |.+-+ 2 | */
/* | | | | | | | | */
/* | | | | |.|.+-+-+ */
/* | | | | | | | |1| */
/* | | | | | | |.+-+ */
/* | | | | | | | | | */
/* |.|.|.|.|.|.|.|.+----- */
/* | | | | | | | | | */
/* The 1-2-1-4-1-2-1-8-... pattern is the position of the last 1 bit in */
/* the binary expansion of the current column. Each Schur update is */
/* applied as soon as the necessary portion of U is available. */
/* [1] Toledo, S. 1997. Locality of Reference in LU Decomposition with */
/* Partial Pivoting. SIAM J. Matrix Anal. Appl. 18, 4 (Oct. 1997), */
/* 1065-1081. http://dx.doi.org/10.1137/S0895479896297744 */
/* Arguments */
/* ========= */
/* M (input) INTEGER */
/* The number of rows of the matrix A. M >= 0. */
/* N (input) INTEGER */
/* The number of columns of the matrix A. N >= 0. */
/* A (input/output) REAL array, dimension (LDA,N) */
/* On entry, the M-by-N matrix to be factored. */
/* On exit, the factors L and U from the factorization */
/* A = P*L*U; the unit diagonal elements of L are not stored. */
/* LDA (input) INTEGER */
/* The leading dimension of the array A. LDA >= max(1,M). */
/* IPIV (output) INTEGER array, dimension (min(M,N)) */
/* The pivot indices; for 1 <= i <= min(M,N), row i of the */
/* matrix was interchanged with row IPIV(i). */
/* INFO (output) INTEGER */
/* = 0: successful exit */
/* < 0: if INFO = -i, the i-th argument had an illegal value */
/* > 0: if INFO = i, U(i,i) is exactly zero. The factorization */
/* has been completed, but the factor U is exactly */
/* singular, and division by zero will occur if it is used */
/* to solve a system of equations. */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Executable Statements .. */
/* Test the input parameters. */
/* Parameter adjustments */
a_dim1 = *lda;
a_offset = 1 + a_dim1;
a -= a_offset;
--ipiv;
/* Function Body */
*info = 0;
if (*m < 0) {
*info = -1;
} else if (*n < 0) {
*info = -2;
} else if (*lda < max(1,*m)) {
*info = -4;
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("SGETRF", &i__1);
return 0;
}
/* Quick return if possible */
if (*m == 0 || *n == 0) {
return 0;
}
/* Compute machine safe minimum */
sfmin = slamch_("S");
nstep = min(*m,*n);
i__1 = nstep;
for (j = 1; j <= i__1; ++j) {
kahead = j & -j;
kstart = j + 1 - kahead;
/* Computing MIN */
i__2 = kahead, i__3 = *m - j;
kcols = min(i__2,i__3);
/* Find pivot. */
i__2 = *m - j + 1;
jp = j - 1 + isamax_(&i__2, &a[j + j * a_dim1], &c__1);
ipiv[j] = jp;
/* Permute just this column. */
if (jp != j) {
tmp = a[j + j * a_dim1];
a[j + j * a_dim1] = a[jp + j * a_dim1];
a[jp + j * a_dim1] = tmp;
}
/* Apply pending permutations to L */
ntopiv = 1;
ipivstart = j;
jpivstart = j - ntopiv;
while(ntopiv < kahead) {
slaswp_(&ntopiv, &a[jpivstart * a_dim1 + 1], lda, &ipivstart, &j,
&ipiv[1], &c__1);
ipivstart -= ntopiv;
ntopiv <<= 1;
jpivstart -= ntopiv;
}
/* Permute U block to match L */
slaswp_(&kcols, &a[(j + 1) * a_dim1 + 1], lda, &kstart, &j, &ipiv[1],
&c__1);
/* Factor the current column */
if (a[j + j * a_dim1] != 0.f && ! sisnan_(&a[j + j * a_dim1])) {
if ((r__1 = a[j + j * a_dim1], dabs(r__1)) >= sfmin) {
i__2 = *m - j;
r__1 = 1.f / a[j + j * a_dim1];
sscal_(&i__2, &r__1, &a[j + 1 + j * a_dim1], &c__1);
} else {
i__2 = *m - j;
for (i__ = 1; i__ <= i__2; ++i__) {
a[j + i__ + j * a_dim1] /= a[j + j * a_dim1];
}
}
} else if (a[j + j * a_dim1] == 0.f && *info == 0) {
*info = j;
}
/* Solve for U block. */
strsm_("Left", "Lower", "No transpose", "Unit", &kahead, &kcols, &
c_b12, &a[kstart + kstart * a_dim1], lda, &a[kstart + (j + 1)
* a_dim1], lda);
/* Schur complement. */
i__2 = *m - j;
sgemm_("No transpose", "No transpose", &i__2, &kcols, &kahead, &c_b15,
&a[j + 1 + kstart * a_dim1], lda, &a[kstart + (j + 1) *
a_dim1], lda, &c_b12, &a[j + 1 + (j + 1) * a_dim1], lda);
}
/* Handle pivot permutations on the way out of the recursion */
npived = nstep & -nstep;
j = nstep - npived;
while(j > 0) {
ntopiv = j & -j;
i__1 = j + 1;
slaswp_(&ntopiv, &a[(j - ntopiv + 1) * a_dim1 + 1], lda, &i__1, &
nstep, &ipiv[1], &c__1);
j -= ntopiv;
}
/* If short and wide, handle the rest of the columns. */
if (*m < *n) {
i__1 = *n - *m;
slaswp_(&i__1, &a[(*m + kcols + 1) * a_dim1 + 1], lda, &c__1, m, &
ipiv[1], &c__1);
i__1 = *n - *m;
strsm_("Left", "Lower", "No transpose", "Unit", m, &i__1, &c_b12, &a[
a_offset], lda, &a[(*m + kcols + 1) * a_dim1 + 1], lda);
}
return 0;
/* End of SGETRF */
} /* sgetrf_ */
/* Subroutine */
int sgebal_(char *job, integer *n, real *a, integer *lda, integer *ilo, integer *ihi, real *scale, integer *info)
{
/* System generated locals */
integer a_dim1, a_offset, i__1, i__2;
real r__1, r__2;
/* Local variables */
real c__, f, g;
integer i__, j, k, l, m;
real r__, s, ca, ra;
integer ica, ira, iexc;
extern real snrm2_(integer *, real *, integer *);
extern logical lsame_(char *, char *);
extern /* Subroutine */
int sscal_(integer *, real *, real *, integer *), sswap_(integer *, real *, integer *, real *, integer *);
real sfmin1, sfmin2, sfmax1, sfmax2;
extern real slamch_(char *);
extern /* Subroutine */
int xerbla_(char *, integer *);
extern integer isamax_(integer *, real *, integer *);
extern logical sisnan_(real *);
logical noconv;
/* -- 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 */
a_dim1 = *lda;
a_offset = 1 + a_dim1;
a -= a_offset;
--scale;
/* Function Body */
*info = 0;
if (! lsame_(job, "N") && ! lsame_(job, "P") && ! lsame_(job, "S") && ! lsame_(job, "B"))
{
*info = -1;
}
else if (*n < 0)
{
*info = -2;
}
else if (*lda < max(1,*n))
{
*info = -4;
}
if (*info != 0)
{
i__1 = -(*info);
xerbla_("SGEBAL", &i__1);
return 0;
}
k = 1;
l = *n;
if (*n == 0)
{
goto L210;
}
if (lsame_(job, "N"))
{
i__1 = *n;
for (i__ = 1;
i__ <= i__1;
++i__)
{
scale[i__] = 1.f;
/* L10: */
}
goto L210;
}
if (lsame_(job, "S"))
{
goto L120;
}
/* Permutation to isolate eigenvalues if possible */
goto L50;
/* Row and column exchange. */
L20:
scale[m] = (real) j;
if (j == m)
{
goto L30;
}
sswap_(&l, &a[j * a_dim1 + 1], &c__1, &a[m * a_dim1 + 1], &c__1);
i__1 = *n - k + 1;
sswap_(&i__1, &a[j + k * a_dim1], lda, &a[m + k * a_dim1], lda);
L30:
switch (iexc)
{
case 1:
goto L40;
case 2:
goto L80;
}
/* Search for rows isolating an eigenvalue and push them down. */
L40:
if (l == 1)
{
goto L210;
}
--l;
L50:
for (j = l;
j >= 1;
--j)
{
i__1 = l;
for (i__ = 1;
i__ <= i__1;
++i__)
{
if (i__ == j)
{
goto L60;
}
if (a[j + i__ * a_dim1] != 0.f)
{
goto L70;
}
L60:
;
}
m = l;
iexc = 1;
goto L20;
L70:
;
}
goto L90;
/* Search for columns isolating an eigenvalue and push them left. */
L80:
++k;
L90:
i__1 = l;
for (j = k;
j <= i__1;
++j)
{
i__2 = l;
for (i__ = k;
i__ <= i__2;
++i__)
{
if (i__ == j)
{
goto L100;
}
if (a[i__ + j * a_dim1] != 0.f)
{
goto L110;
}
L100:
;
}
m = k;
iexc = 2;
goto L20;
L110:
;
}
L120:
i__1 = l;
for (i__ = k;
i__ <= i__1;
++i__)
{
scale[i__] = 1.f;
/* L130: */
}
if (lsame_(job, "P"))
{
goto L210;
}
/* Balance the submatrix in rows K to L. */
/* Iterative loop for norm reduction */
sfmin1 = slamch_("S") / slamch_("P");
sfmax1 = 1.f / sfmin1;
sfmin2 = sfmin1 * 2.f;
sfmax2 = 1.f / sfmin2;
L140:
noconv = FALSE_;
i__1 = l;
for (i__ = k;
i__ <= i__1;
++i__)
{
i__2 = l - k + 1;
c__ = snrm2_(&i__2, &a[k + i__ * a_dim1], &c__1);
i__2 = l - k + 1;
r__ = snrm2_(&i__2, &a[i__ + k * a_dim1], lda);
ica = isamax_(&l, &a[i__ * a_dim1 + 1], &c__1);
ca = (r__1 = a[ica + i__ * a_dim1], f2c_abs(r__1));
i__2 = *n - k + 1;
ira = isamax_(&i__2, &a[i__ + k * a_dim1], lda);
ra = (r__1 = a[i__ + (ira + k - 1) * a_dim1], f2c_abs(r__1));
/* Guard against zero C or R due to underflow. */
if (c__ == 0.f || r__ == 0.f)
{
goto L200;
}
g = r__ / 2.f;
f = 1.f;
s = c__ + r__;
L160: /* Computing MAX */
r__1 = max(f,c__);
/* Computing MIN */
r__2 = min(r__,g);
if (c__ >= g || max(r__1,ca) >= sfmax2 || min(r__2,ra) <= sfmin2)
{
goto L170;
}
f *= 2.f;
c__ *= 2.f;
ca *= 2.f;
r__ /= 2.f;
g /= 2.f;
ra /= 2.f;
goto L160;
L170:
g = c__ / 2.f;
L180: /* Computing MIN */
r__1 = min(f,c__);
r__1 = min(r__1,g); // , expr subst
if (g < r__ || max(r__,ra) >= sfmax2 || min(r__1,ca) <= sfmin2)
{
goto L190;
}
r__1 = c__ + f + ca + r__ + g + ra;
if (sisnan_(&r__1))
{
/* Exit if NaN to avoid infinite loop */
*info = -3;
i__2 = -(*info);
xerbla_("SGEBAL", &i__2);
return 0;
}
f /= 2.f;
c__ /= 2.f;
g /= 2.f;
ca /= 2.f;
r__ *= 2.f;
ra *= 2.f;
goto L180;
/* Now balance. */
L190:
if (c__ + r__ >= s * .95f)
{
goto L200;
}
if (f < 1.f && scale[i__] < 1.f)
{
if (f * scale[i__] <= sfmin1)
{
goto L200;
}
}
if (f > 1.f && scale[i__] > 1.f)
{
if (scale[i__] >= sfmax1 / f)
{
goto L200;
}
}
g = 1.f / f;
scale[i__] *= f;
noconv = TRUE_;
i__2 = *n - k + 1;
sscal_(&i__2, &g, &a[i__ + k * a_dim1], lda);
sscal_(&l, &f, &a[i__ * a_dim1 + 1], &c__1);
L200:
;
}
if (noconv)
{
goto L140;
}
L210:
*ilo = k;
*ihi = l;
return 0;
/* End of SGEBAL */
}
/* Subroutine */
int slasq3_(integer *i0, integer *n0, real *z__, integer *pp, real *dmin__, real *sigma, real *desig, real *qmax, integer *nfail, integer *iter, integer *ndiv, logical *ieee, integer *ttype, real * dmin1, real *dmin2, real *dn, real *dn1, real *dn2, real *g, real * tau)
{
/* System generated locals */
integer i__1;
real r__1, r__2;
/* Builtin functions */
double sqrt(doublereal);
/* Local variables */
real s, t;
integer j4, nn;
real eps, tol;
integer n0in, ipn4;
real tol2, temp;
extern /* Subroutine */
int slasq4_(integer *, integer *, real *, integer *, integer *, real *, real *, real *, real *, real *, real *, real *, integer *, real *), slasq5_(integer *, integer *, real *, integer *, real *, real *, real *, real *, real *, real *, real *, real *, logical *, real *), slasq6_(integer *, integer *, real *, integer *, real *, real *, real *, real *, real *, real *);
extern real slamch_(char *);
extern logical sisnan_(real *);
/* -- 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 Subroutines .. */
/* .. */
/* .. External Function .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Executable Statements .. */
/* Parameter adjustments */
--z__;
/* Function Body */
n0in = *n0;
eps = slamch_("Precision");
tol = eps * 100.f;
/* Computing 2nd power */
r__1 = tol;
tol2 = r__1 * r__1;
/* Check for deflation. */
L10:
if (*n0 < *i0)
{
return 0;
}
if (*n0 == *i0)
{
goto L20;
}
nn = (*n0 << 2) + *pp;
if (*n0 == *i0 + 1)
{
goto L40;
}
/* Check whether E(N0-1) is negligible, 1 eigenvalue. */
if (z__[nn - 5] > tol2 * (*sigma + z__[nn - 3]) && z__[nn - (*pp << 1) - 4] > tol2 * z__[nn - 7])
{
goto L30;
}
L20:
z__[(*n0 << 2) - 3] = z__[(*n0 << 2) + *pp - 3] + *sigma;
--(*n0);
goto L10;
/* Check whether E(N0-2) is negligible, 2 eigenvalues. */
L30:
if (z__[nn - 9] > tol2 * *sigma && z__[nn - (*pp << 1) - 8] > tol2 * z__[ nn - 11])
{
goto L50;
}
L40:
if (z__[nn - 3] > z__[nn - 7])
{
s = z__[nn - 3];
z__[nn - 3] = z__[nn - 7];
z__[nn - 7] = s;
}
t = (z__[nn - 7] - z__[nn - 3] + z__[nn - 5]) * .5f;
if (z__[nn - 5] > z__[nn - 3] * tol2 && t != 0.f)
{
s = z__[nn - 3] * (z__[nn - 5] / t);
if (s <= t)
{
s = z__[nn - 3] * (z__[nn - 5] / (t * (sqrt(s / t + 1.f) + 1.f)));
}
else
{
s = z__[nn - 3] * (z__[nn - 5] / (t + sqrt(t) * sqrt(t + s)));
}
t = z__[nn - 7] + (s + z__[nn - 5]);
z__[nn - 3] *= z__[nn - 7] / t;
z__[nn - 7] = t;
}
z__[(*n0 << 2) - 7] = z__[nn - 7] + *sigma;
z__[(*n0 << 2) - 3] = z__[nn - 3] + *sigma;
*n0 += -2;
goto L10;
L50:
if (*pp == 2)
{
*pp = 0;
}
/* Reverse the qd-array, if warranted. */
if (*dmin__ <= 0.f || *n0 < n0in)
{
if (z__[(*i0 << 2) + *pp - 3] * 1.5f < z__[(*n0 << 2) + *pp - 3])
{
ipn4 = *i0 + *n0 << 2;
i__1 = *i0 + *n0 - 1 << 1;
for (j4 = *i0 << 2;
j4 <= i__1;
j4 += 4)
{
temp = z__[j4 - 3];
z__[j4 - 3] = z__[ipn4 - j4 - 3];
z__[ipn4 - j4 - 3] = temp;
temp = z__[j4 - 2];
z__[j4 - 2] = z__[ipn4 - j4 - 2];
z__[ipn4 - j4 - 2] = temp;
temp = z__[j4 - 1];
z__[j4 - 1] = z__[ipn4 - j4 - 5];
z__[ipn4 - j4 - 5] = temp;
temp = z__[j4];
z__[j4] = z__[ipn4 - j4 - 4];
z__[ipn4 - j4 - 4] = temp;
/* L60: */
}
if (*n0 - *i0 <= 4)
{
z__[(*n0 << 2) + *pp - 1] = z__[(*i0 << 2) + *pp - 1];
z__[(*n0 << 2) - *pp] = z__[(*i0 << 2) - *pp];
}
/* Computing MIN */
r__1 = *dmin2;
r__2 = z__[(*n0 << 2) + *pp - 1]; // , expr subst
*dmin2 = min(r__1,r__2);
/* Computing MIN */
r__1 = z__[(*n0 << 2) + *pp - 1], r__2 = z__[(*i0 << 2) + *pp - 1] ;
r__1 = min(r__1,r__2);
r__2 = z__[(*i0 << 2) + *pp + 3]; // ; expr subst
z__[(*n0 << 2) + *pp - 1] = min(r__1,r__2);
/* Computing MIN */
r__1 = z__[(*n0 << 2) - *pp], r__2 = z__[(*i0 << 2) - *pp];
r__1 = min(r__1,r__2);
r__2 = z__[(*i0 << 2) - *pp + 4]; // ; expr subst
z__[(*n0 << 2) - *pp] = min(r__1,r__2);
/* Computing MAX */
r__1 = *qmax, r__2 = z__[(*i0 << 2) + *pp - 3];
r__1 = max(r__1, r__2);
r__2 = z__[(*i0 << 2) + *pp + 1]; // ; expr subst
*qmax = max(r__1,r__2);
*dmin__ = -0.f;
}
}
/* Choose a shift. */
slasq4_(i0, n0, &z__[1], pp, &n0in, dmin__, dmin1, dmin2, dn, dn1, dn2, tau, ttype, g);
/* Call dqds until DMIN > 0. */
L70:
slasq5_(i0, n0, &z__[1], pp, tau, sigma, dmin__, dmin1, dmin2, dn, dn1, dn2, ieee, &eps);
*ndiv += *n0 - *i0 + 2;
++(*iter);
/* Check status. */
if (*dmin__ >= 0.f && *dmin1 >= 0.f)
{
/* Success. */
goto L90;
}
else if (*dmin__ < 0.f && *dmin1 > 0.f && z__[(*n0 - 1 << 2) - *pp] < tol * (*sigma + *dn1) && abs(*dn) < tol * *sigma)
{
/* Convergence hidden by negative DN. */
z__[(*n0 - 1 << 2) - *pp + 2] = 0.f;
*dmin__ = 0.f;
goto L90;
}
else if (*dmin__ < 0.f)
{
/* TAU too big. Select new TAU and try again. */
++(*nfail);
if (*ttype < -22)
{
/* Failed twice. Play it safe. */
*tau = 0.f;
}
else if (*dmin1 > 0.f)
{
/* Late failure. Gives excellent shift. */
*tau = (*tau + *dmin__) * (1.f - eps * 2.f);
*ttype += -11;
}
else
{
/* Early failure. Divide by 4. */
*tau *= .25f;
*ttype += -12;
}
goto L70;
}
else if (sisnan_(dmin__))
{
/* NaN. */
if (*tau == 0.f)
{
goto L80;
}
else
{
*tau = 0.f;
goto L70;
}
}
else
{
/* Possible underflow. Play it safe. */
goto L80;
}
/* Risk of underflow. */
L80:
slasq6_(i0, n0, &z__[1], pp, dmin__, dmin1, dmin2, dn, dn1, dn2);
*ndiv += *n0 - *i0 + 2;
++(*iter);
*tau = 0.f;
L90:
if (*tau < *sigma)
{
*desig += *tau;
t = *sigma + *desig;
*desig -= t - *sigma;
}
else
{
t = *sigma + *tau;
*desig = *sigma - (t - *tau) + *desig;
}
*sigma = t;
return 0;
/* End of SLASQ3 */
}
/* ===================================================================== */
real slantr_(char *norm, char *uplo, char *diag, integer *m, integer *n, real *a, integer *lda, real *work)
{
/* System generated locals */
integer a_dim1, a_offset, i__1, i__2, i__3, i__4;
real ret_val, r__1;
/* Builtin functions */
double sqrt(doublereal);
/* Local variables */
integer i__, j;
real sum, scale;
logical udiag;
extern logical lsame_(char *, char *);
real value;
extern logical sisnan_(real *);
extern /* Subroutine */
int slassq_(integer *, real *, integer *, real *, real *);
/* -- LAPACK auxiliary 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 Subroutines .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Executable Statements .. */
/* Parameter adjustments */
a_dim1 = *lda;
a_offset = 1 + a_dim1;
a -= a_offset;
--work;
/* Function Body */
if (min(*m,*n) == 0)
{
value = 0.f;
}
else if (lsame_(norm, "M"))
{
/* Find max(f2c_abs(A(i,j))). */
if (lsame_(diag, "U"))
{
value = 1.f;
if (lsame_(uplo, "U"))
{
i__1 = *n;
for (j = 1;
j <= i__1;
++j)
{
/* Computing MIN */
i__3 = *m;
i__4 = j - 1; // , expr subst
i__2 = min(i__3,i__4);
for (i__ = 1;
i__ <= i__2;
++i__)
{
sum = (r__1 = a[i__ + j * a_dim1], f2c_abs(r__1));
if (value < sum || sisnan_(&sum))
{
value = sum;
}
/* L10: */
}
/* L20: */
}
}
else
{
i__1 = *n;
for (j = 1;
j <= i__1;
++j)
{
i__2 = *m;
for (i__ = j + 1;
i__ <= i__2;
++i__)
{
sum = (r__1 = a[i__ + j * a_dim1], f2c_abs(r__1));
if (value < sum || sisnan_(&sum))
{
value = sum;
}
/* L30: */
}
/* L40: */
}
}
}
else
{
value = 0.f;
if (lsame_(uplo, "U"))
{
i__1 = *n;
for (j = 1;
j <= i__1;
++j)
{
i__2 = min(*m,j);
for (i__ = 1;
i__ <= i__2;
++i__)
{
sum = (r__1 = a[i__ + j * a_dim1], f2c_abs(r__1));
if (value < sum || sisnan_(&sum))
{
value = sum;
}
/* L50: */
}
/* L60: */
}
}
else
{
i__1 = *n;
for (j = 1;
j <= i__1;
++j)
{
i__2 = *m;
for (i__ = j;
i__ <= i__2;
++i__)
{
sum = (r__1 = a[i__ + j * a_dim1], f2c_abs(r__1));
if (value < sum || sisnan_(&sum))
{
value = sum;
}
/* L70: */
}
/* L80: */
}
}
}
}
else if (lsame_(norm, "O") || *(unsigned char *) norm == '1')
{
/* Find norm1(A). */
value = 0.f;
udiag = lsame_(diag, "U");
if (lsame_(uplo, "U"))
{
i__1 = *n;
for (j = 1;
j <= i__1;
++j)
{
if (udiag && j <= *m)
{
sum = 1.f;
i__2 = j - 1;
for (i__ = 1;
i__ <= i__2;
++i__)
{
sum += (r__1 = a[i__ + j * a_dim1], f2c_abs(r__1));
/* L90: */
}
}
else
{
sum = 0.f;
i__2 = min(*m,j);
for (i__ = 1;
i__ <= i__2;
++i__)
{
sum += (r__1 = a[i__ + j * a_dim1], f2c_abs(r__1));
/* L100: */
}
}
if (value < sum || sisnan_(&sum))
{
value = sum;
}
/* L110: */
}
}
else
{
i__1 = *n;
for (j = 1;
j <= i__1;
++j)
{
if (udiag)
{
sum = 1.f;
i__2 = *m;
for (i__ = j + 1;
i__ <= i__2;
++i__)
{
sum += (r__1 = a[i__ + j * a_dim1], f2c_abs(r__1));
/* L120: */
}
}
else
{
sum = 0.f;
i__2 = *m;
for (i__ = j;
i__ <= i__2;
++i__)
{
sum += (r__1 = a[i__ + j * a_dim1], f2c_abs(r__1));
/* L130: */
}
}
if (value < sum || sisnan_(&sum))
{
value = sum;
}
/* L140: */
}
}
}
else if (lsame_(norm, "I"))
{
/* Find normI(A). */
if (lsame_(uplo, "U"))
{
if (lsame_(diag, "U"))
{
i__1 = *m;
for (i__ = 1;
i__ <= i__1;
++i__)
{
work[i__] = 1.f;
/* L150: */
}
i__1 = *n;
for (j = 1;
j <= i__1;
++j)
{
/* Computing MIN */
i__3 = *m;
i__4 = j - 1; // , expr subst
i__2 = min(i__3,i__4);
for (i__ = 1;
i__ <= i__2;
++i__)
{
work[i__] += (r__1 = a[i__ + j * a_dim1], f2c_abs(r__1));
/* L160: */
}
/* L170: */
}
}
else
{
i__1 = *m;
for (i__ = 1;
i__ <= i__1;
++i__)
{
work[i__] = 0.f;
/* L180: */
}
i__1 = *n;
for (j = 1;
j <= i__1;
++j)
{
i__2 = min(*m,j);
for (i__ = 1;
i__ <= i__2;
++i__)
{
work[i__] += (r__1 = a[i__ + j * a_dim1], f2c_abs(r__1));
/* L190: */
}
/* L200: */
}
}
}
else
{
if (lsame_(diag, "U"))
{
i__1 = *n;
for (i__ = 1;
i__ <= i__1;
++i__)
{
work[i__] = 1.f;
/* L210: */
}
i__1 = *m;
for (i__ = *n + 1;
i__ <= i__1;
++i__)
{
work[i__] = 0.f;
/* L220: */
}
i__1 = *n;
for (j = 1;
j <= i__1;
++j)
{
i__2 = *m;
for (i__ = j + 1;
i__ <= i__2;
++i__)
{
work[i__] += (r__1 = a[i__ + j * a_dim1], f2c_abs(r__1));
/* L230: */
}
/* L240: */
}
}
else
{
i__1 = *m;
for (i__ = 1;
i__ <= i__1;
++i__)
{
work[i__] = 0.f;
/* L250: */
}
i__1 = *n;
for (j = 1;
j <= i__1;
++j)
{
i__2 = *m;
for (i__ = j;
i__ <= i__2;
++i__)
{
work[i__] += (r__1 = a[i__ + j * a_dim1], f2c_abs(r__1));
/* L260: */
}
/* L270: */
}
}
}
value = 0.f;
i__1 = *m;
for (i__ = 1;
i__ <= i__1;
++i__)
{
sum = work[i__];
if (value < sum || sisnan_(&sum))
{
value = sum;
}
/* L280: */
}
}
else if (lsame_(norm, "F") || lsame_(norm, "E"))
{
/* Find normF(A). */
if (lsame_(uplo, "U"))
{
if (lsame_(diag, "U"))
{
scale = 1.f;
sum = (real) min(*m,*n);
i__1 = *n;
for (j = 2;
j <= i__1;
++j)
{
/* Computing MIN */
i__3 = *m;
i__4 = j - 1; // , expr subst
i__2 = min(i__3,i__4);
slassq_(&i__2, &a[j * a_dim1 + 1], &c__1, &scale, &sum);
/* L290: */
}
}
else
{
scale = 0.f;
sum = 1.f;
i__1 = *n;
for (j = 1;
j <= i__1;
++j)
{
i__2 = min(*m,j);
slassq_(&i__2, &a[j * a_dim1 + 1], &c__1, &scale, &sum);
/* L300: */
}
}
}
else
{
if (lsame_(diag, "U"))
{
scale = 1.f;
sum = (real) min(*m,*n);
i__1 = *n;
for (j = 1;
j <= i__1;
++j)
{
i__2 = *m - j;
/* Computing MIN */
i__3 = *m;
i__4 = j + 1; // , expr subst
slassq_(&i__2, &a[min(i__3,i__4) + j * a_dim1], &c__1, & scale, &sum);
/* L310: */
}
}
else
{
scale = 0.f;
sum = 1.f;
i__1 = *n;
for (j = 1;
j <= i__1;
++j)
{
i__2 = *m - j + 1;
slassq_(&i__2, &a[j + j * a_dim1], &c__1, &scale, &sum);
/* L320: */
}
}
}
value = scale * sqrt(sum);
}
ret_val = value;
return ret_val;
/* End of SLANTR */
}
/* Subroutine */
int slar1v_(integer *n, integer *b1, integer *bn, real * lambda, real *d__, real *l, real *ld, real *lld, real *pivmin, real * gaptol, real *z__, logical *wantnc, integer *negcnt, real *ztz, real * mingma, integer *r__, integer *isuppz, real *nrminv, real *resid, real *rqcorr, real *work)
{
/* System generated locals */
integer i__1;
real r__1, r__2, r__3;
/* Builtin functions */
double sqrt(doublereal);
/* Local variables */
integer i__;
real s;
integer r1, r2;
real eps, tmp;
integer neg1, neg2, indp, inds;
real dplus;
extern real slamch_(char *);
integer indlpl, indumn;
extern logical sisnan_(real *);
real dminus;
logical sawnan1, sawnan2;
/* -- LAPACK auxiliary 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 .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Executable Statements .. */
/* Parameter adjustments */
--work;
--isuppz;
--z__;
--lld;
--ld;
--l;
--d__;
/* Function Body */
eps = slamch_("Precision");
if (*r__ == 0)
{
r1 = *b1;
r2 = *bn;
}
else
{
r1 = *r__;
r2 = *r__;
}
/* Storage for LPLUS */
indlpl = 0;
/* Storage for UMINUS */
indumn = *n;
inds = (*n << 1) + 1;
indp = *n * 3 + 1;
if (*b1 == 1)
{
work[inds] = 0.f;
}
else
{
work[inds + *b1 - 1] = lld[*b1 - 1];
}
/* Compute the stationary transform (using the differential form) */
/* until the index R2. */
sawnan1 = FALSE_;
neg1 = 0;
s = work[inds + *b1 - 1] - *lambda;
i__1 = r1 - 1;
for (i__ = *b1;
i__ <= i__1;
++i__)
{
dplus = d__[i__] + s;
work[indlpl + i__] = ld[i__] / dplus;
if (dplus < 0.f)
{
++neg1;
}
work[inds + i__] = s * work[indlpl + i__] * l[i__];
s = work[inds + i__] - *lambda;
/* L50: */
}
sawnan1 = sisnan_(&s);
if (sawnan1)
{
goto L60;
}
i__1 = r2 - 1;
for (i__ = r1;
i__ <= i__1;
++i__)
{
dplus = d__[i__] + s;
work[indlpl + i__] = ld[i__] / dplus;
work[inds + i__] = s * work[indlpl + i__] * l[i__];
s = work[inds + i__] - *lambda;
/* L51: */
}
sawnan1 = sisnan_(&s);
L60:
if (sawnan1)
{
/* Runs a slower version of the above loop if a NaN is detected */
neg1 = 0;
s = work[inds + *b1 - 1] - *lambda;
i__1 = r1 - 1;
for (i__ = *b1;
i__ <= i__1;
++i__)
{
dplus = d__[i__] + s;
if (abs(dplus) < *pivmin)
{
dplus = -(*pivmin);
}
work[indlpl + i__] = ld[i__] / dplus;
if (dplus < 0.f)
{
++neg1;
}
work[inds + i__] = s * work[indlpl + i__] * l[i__];
if (work[indlpl + i__] == 0.f)
{
work[inds + i__] = lld[i__];
}
s = work[inds + i__] - *lambda;
/* L70: */
}
i__1 = r2 - 1;
for (i__ = r1;
i__ <= i__1;
++i__)
{
dplus = d__[i__] + s;
if (abs(dplus) < *pivmin)
{
dplus = -(*pivmin);
}
work[indlpl + i__] = ld[i__] / dplus;
work[inds + i__] = s * work[indlpl + i__] * l[i__];
if (work[indlpl + i__] == 0.f)
{
work[inds + i__] = lld[i__];
}
s = work[inds + i__] - *lambda;
/* L71: */
}
}
/* Compute the progressive transform (using the differential form) */
/* until the index R1 */
sawnan2 = FALSE_;
neg2 = 0;
work[indp + *bn - 1] = d__[*bn] - *lambda;
i__1 = r1;
for (i__ = *bn - 1;
i__ >= i__1;
--i__)
{
dminus = lld[i__] + work[indp + i__];
tmp = d__[i__] / dminus;
if (dminus < 0.f)
{
++neg2;
}
work[indumn + i__] = l[i__] * tmp;
work[indp + i__ - 1] = work[indp + i__] * tmp - *lambda;
/* L80: */
}
tmp = work[indp + r1 - 1];
sawnan2 = sisnan_(&tmp);
if (sawnan2)
{
/* Runs a slower version of the above loop if a NaN is detected */
neg2 = 0;
i__1 = r1;
for (i__ = *bn - 1;
i__ >= i__1;
--i__)
{
dminus = lld[i__] + work[indp + i__];
if (abs(dminus) < *pivmin)
{
dminus = -(*pivmin);
}
tmp = d__[i__] / dminus;
if (dminus < 0.f)
{
++neg2;
}
work[indumn + i__] = l[i__] * tmp;
work[indp + i__ - 1] = work[indp + i__] * tmp - *lambda;
if (tmp == 0.f)
{
work[indp + i__ - 1] = d__[i__] - *lambda;
}
/* L100: */
}
}
/* Find the index (from R1 to R2) of the largest (in magnitude) */
/* diagonal element of the inverse */
*mingma = work[inds + r1 - 1] + work[indp + r1 - 1];
if (*mingma < 0.f)
{
++neg1;
}
if (*wantnc)
{
*negcnt = neg1 + neg2;
}
else
{
*negcnt = -1;
}
if (abs(*mingma) == 0.f)
{
*mingma = eps * work[inds + r1 - 1];
}
*r__ = r1;
i__1 = r2 - 1;
for (i__ = r1;
i__ <= i__1;
++i__)
{
tmp = work[inds + i__] + work[indp + i__];
if (tmp == 0.f)
{
tmp = eps * work[inds + i__];
}
if (abs(tmp) <= abs(*mingma))
{
*mingma = tmp;
*r__ = i__ + 1;
}
/* L110: */
}
/* Compute the FP vector: solve N^T v = e_r */
isuppz[1] = *b1;
isuppz[2] = *bn;
z__[*r__] = 1.f;
*ztz = 1.f;
/* Compute the FP vector upwards from R */
if (! sawnan1 && ! sawnan2)
{
i__1 = *b1;
for (i__ = *r__ - 1;
i__ >= i__1;
--i__)
{
z__[i__] = -(work[indlpl + i__] * z__[i__ + 1]);
if (((r__1 = z__[i__], abs(r__1)) + (r__2 = z__[i__ + 1], abs( r__2))) * (r__3 = ld[i__], abs(r__3)) < *gaptol)
{
z__[i__] = 0.f;
isuppz[1] = i__ + 1;
goto L220;
}
*ztz += z__[i__] * z__[i__];
/* L210: */
}
L220:
;
}
else
{
/* Run slower loop if NaN occurred. */
i__1 = *b1;
for (i__ = *r__ - 1;
i__ >= i__1;
--i__)
{
if (z__[i__ + 1] == 0.f)
{
z__[i__] = -(ld[i__ + 1] / ld[i__]) * z__[i__ + 2];
}
else
{
z__[i__] = -(work[indlpl + i__] * z__[i__ + 1]);
}
if (((r__1 = z__[i__], abs(r__1)) + (r__2 = z__[i__ + 1], abs( r__2))) * (r__3 = ld[i__], abs(r__3)) < *gaptol)
{
z__[i__] = 0.f;
isuppz[1] = i__ + 1;
goto L240;
}
*ztz += z__[i__] * z__[i__];
/* L230: */
}
L240:
;
}
/* Compute the FP vector downwards from R in blocks of size BLKSIZ */
if (! sawnan1 && ! sawnan2)
{
i__1 = *bn - 1;
for (i__ = *r__;
i__ <= i__1;
++i__)
{
z__[i__ + 1] = -(work[indumn + i__] * z__[i__]);
if (((r__1 = z__[i__], abs(r__1)) + (r__2 = z__[i__ + 1], abs( r__2))) * (r__3 = ld[i__], abs(r__3)) < *gaptol)
{
z__[i__ + 1] = 0.f;
isuppz[2] = i__;
goto L260;
}
*ztz += z__[i__ + 1] * z__[i__ + 1];
/* L250: */
}
L260:
;
}
else
{
/* Run slower loop if NaN occurred. */
i__1 = *bn - 1;
for (i__ = *r__;
i__ <= i__1;
++i__)
{
if (z__[i__] == 0.f)
{
z__[i__ + 1] = -(ld[i__ - 1] / ld[i__]) * z__[i__ - 1];
}
else
{
z__[i__ + 1] = -(work[indumn + i__] * z__[i__]);
}
if (((r__1 = z__[i__], abs(r__1)) + (r__2 = z__[i__ + 1], abs( r__2))) * (r__3 = ld[i__], abs(r__3)) < *gaptol)
{
z__[i__ + 1] = 0.f;
isuppz[2] = i__;
goto L280;
}
*ztz += z__[i__ + 1] * z__[i__ + 1];
/* L270: */
}
L280:
;
}
/* Compute quantities for convergence test */
tmp = 1.f / *ztz;
*nrminv = sqrt(tmp);
*resid = abs(*mingma) * *nrminv;
*rqcorr = *mingma * tmp;
return 0;
/* End of SLAR1V */
}
/* Subroutine */ int spotf2_(char *uplo, integer *n, real *a, integer *lda,
integer *info)
{
/* System generated locals */
integer a_dim1, a_offset, i__1, i__2, i__3;
real r__1;
/* Local variables */
integer j;
real ajj;
logical upper;
/* -- LAPACK routine (version 3.2) -- */
/* November 2006 */
/* Purpose */
/* ======= */
/* SPOTF2 computes the Cholesky factorization of a real symmetric */
/* positive definite matrix A. */
/* The factorization has the form */
/* A = U' * U , if UPLO = 'U', or */
/* A = L * L', if UPLO = 'L', */
/* where U is an upper triangular matrix and L is lower triangular. */
/* This is the unblocked version of the algorithm, calling Level 2 BLAS. */
/* Arguments */
/* ========= */
/* UPLO (input) CHARACTER*1 */
/* Specifies whether the upper or lower triangular part of the */
/* symmetric matrix A is stored. */
/* = 'U': Upper triangular */
/* = 'L': Lower triangular */
/* N (input) INTEGER */
/* The order of the matrix A. N >= 0. */
/* A (input/output) REAL array, dimension (LDA,N) */
/* On entry, the symmetric matrix A. If UPLO = 'U', the leading */
/* n by n upper triangular part of A contains the upper */
/* triangular part of the matrix A, and the strictly lower */
/* triangular part of A is not referenced. If UPLO = 'L', the */
/* leading n by n lower triangular part of A contains the lower */
/* triangular part of the matrix A, and the strictly upper */
/* triangular part of A is not referenced. */
/* On exit, if INFO = 0, the factor U or L from the Cholesky */
/* factorization A = U'*U or A = L*L'. */
/* LDA (input) INTEGER */
/* The leading dimension of the array A. LDA >= max(1,N). */
/* INFO (output) INTEGER */
/* = 0: successful exit */
/* < 0: if INFO = -k, the k-th argument had an illegal value */
/* > 0: if INFO = k, the leading minor of order k is not */
/* positive definite, and the factorization could not be */
/* completed. */
/* ===================================================================== */
/* Test the input parameters. */
/* Parameter adjustments */
a_dim1 = *lda;
a_offset = 1 + a_dim1;
a -= a_offset;
/* Function Body */
*info = 0;
upper = lsame_(uplo, "U");
if (! upper && ! lsame_(uplo, "L")) {
*info = -1;
} else if (*n < 0) {
*info = -2;
} else if (*lda < max(1,*n)) {
*info = -4;
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("SPOTF2", &i__1);
return 0;
}
/* Quick return if possible */
if (*n == 0) {
return 0;
}
if (upper) {
/* Compute the Cholesky factorization A = U'*U. */
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
/* Compute U(J,J) and test for non-positive-definiteness. */
i__2 = j - 1;
ajj = a[j + j * a_dim1] - sdot_(&i__2, &a[j * a_dim1 + 1], &c__1,
&a[j * a_dim1 + 1], &c__1);
if (ajj <= 0.f || sisnan_(&ajj)) {
a[j + j * a_dim1] = ajj;
goto L30;
}
ajj = sqrt(ajj);
a[j + j * a_dim1] = ajj;
/* Compute elements J+1:N of row J. */
if (j < *n) {
i__2 = j - 1;
i__3 = *n - j;
sgemv_("Transpose", &i__2, &i__3, &c_b10, &a[(j + 1) * a_dim1
+ 1], lda, &a[j * a_dim1 + 1], &c__1, &c_b12, &a[j + (
j + 1) * a_dim1], lda);
i__2 = *n - j;
r__1 = 1.f / ajj;
sscal_(&i__2, &r__1, &a[j + (j + 1) * a_dim1], lda);
}
}
} else {
/* Compute the Cholesky factorization A = L*L'. */
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
/* Compute L(J,J) and test for non-positive-definiteness. */
i__2 = j - 1;
ajj = a[j + j * a_dim1] - sdot_(&i__2, &a[j + a_dim1], lda, &a[j
+ a_dim1], lda);
if (ajj <= 0.f || sisnan_(&ajj)) {
a[j + j * a_dim1] = ajj;
goto L30;
}
ajj = sqrt(ajj);
a[j + j * a_dim1] = ajj;
/* Compute elements J+1:N of column J. */
if (j < *n) {
i__2 = *n - j;
i__3 = j - 1;
sgemv_("No transpose", &i__2, &i__3, &c_b10, &a[j + 1 +
a_dim1], lda, &a[j + a_dim1], lda, &c_b12, &a[j + 1 +
j * a_dim1], &c__1);
i__2 = *n - j;
r__1 = 1.f / ajj;
sscal_(&i__2, &r__1, &a[j + 1 + j * a_dim1], &c__1);
}
}
}
goto L40;
L30:
*info = j;
L40:
return 0;
/* End of SPOTF2 */
} /* spotf2_ */
/* Subroutine */ int spstrf_(char *uplo, integer *n, real *a, integer *lda,
integer *piv, integer *rank, real *tol, real *work, integer *info)
{
/* System generated locals */
integer a_dim1, a_offset, i__1, i__2, i__3, i__4, i__5;
real r__1;
/* Builtin functions */
double sqrt(doublereal);
/* Local variables */
integer i__, j, k, maxlocval, jb, nb;
real ajj;
integer pvt;
extern logical lsame_(char *, char *);
extern /* Subroutine */ int sscal_(integer *, real *, real *, integer *);
integer itemp;
extern /* Subroutine */ int sgemv_(char *, integer *, integer *, real *,
real *, integer *, real *, integer *, real *, real *, integer *);
real stemp;
logical upper;
extern /* Subroutine */ int sswap_(integer *, real *, integer *, real *,
integer *);
real sstop;
extern /* Subroutine */ int ssyrk_(char *, char *, integer *, integer *,
real *, real *, integer *, real *, real *, integer *), spstf2_(char *, integer *, real *, integer *, integer *,
integer *, real *, real *, integer *);
extern doublereal slamch_(char *);
extern /* Subroutine */ int xerbla_(char *, integer *);
extern integer ilaenv_(integer *, char *, char *, integer *, integer *,
integer *, integer *);
extern logical sisnan_(real *);
extern integer smaxloc_(real *, integer *);
/* -- LAPACK routine (version 3.2) -- */
/* Craig Lucas, University of Manchester / NAG Ltd. */
/* October, 2008 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* SPSTRF computes the Cholesky factorization with complete */
/* pivoting of a real symmetric positive semidefinite matrix A. */
/* The factorization has the form */
/* P' * A * P = U' * U , if UPLO = 'U', */
/* P' * A * P = L * L', if UPLO = 'L', */
/* where U is an upper triangular matrix and L is lower triangular, and */
/* P is stored as vector PIV. */
/* This algorithm does not attempt to check that A is positive */
/* semidefinite. This version of the algorithm calls level 3 BLAS. */
/* Arguments */
/* ========= */
/* UPLO (input) CHARACTER*1 */
/* Specifies whether the upper or lower triangular part of the */
/* symmetric matrix A is stored. */
/* = 'U': Upper triangular */
/* = 'L': Lower triangular */
/* N (input) INTEGER */
/* The order of the matrix A. N >= 0. */
/* A (input/output) REAL array, dimension (LDA,N) */
/* On entry, the symmetric matrix A. If UPLO = 'U', the leading */
/* n by n upper triangular part of A contains the upper */
/* triangular part of the matrix A, and the strictly lower */
/* triangular part of A is not referenced. If UPLO = 'L', the */
/* leading n by n lower triangular part of A contains the lower */
/* triangular part of the matrix A, and the strictly upper */
/* triangular part of A is not referenced. */
/* On exit, if INFO = 0, the factor U or L from the Cholesky */
/* factorization as above. */
/* LDA (input) INTEGER */
/* The leading dimension of the array A. LDA >= max(1,N). */
/* PIV (output) INTEGER array, dimension (N) */
/* PIV is such that the nonzero entries are P( PIV(K), K ) = 1. */
/* RANK (output) INTEGER */
/* The rank of A given by the number of steps the algorithm */
/* completed. */
/* TOL (input) REAL */
/* User defined tolerance. If TOL < 0, then N*U*MAX( A(K,K) ) */
/* will be used. The algorithm terminates at the (K-1)st step */
/* if the pivot <= TOL. */
/* WORK REAL array, dimension (2*N) */
/* Work space. */
/* INFO (output) INTEGER */
/* < 0: If INFO = -K, the K-th argument had an illegal value, */
/* = 0: algorithm completed successfully, and */
/* > 0: the matrix A is either rank deficient with computed rank */
/* as returned in RANK, or is indefinite. See Section 7 of */
/* LAPACK Working Note #161 for further information. */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Executable Statements .. */
/* Test the input parameters. */
/* Parameter adjustments */
--work;
--piv;
a_dim1 = *lda;
a_offset = 1 + a_dim1;
a -= a_offset;
/* Function Body */
*info = 0;
upper = lsame_(uplo, "U");
if (! upper && ! lsame_(uplo, "L")) {
*info = -1;
} else if (*n < 0) {
*info = -2;
} else if (*lda < max(1,*n)) {
*info = -4;
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("SPSTRF", &i__1);
return 0;
}
/* Quick return if possible */
if (*n == 0) {
return 0;
}
/* Get block size */
nb = ilaenv_(&c__1, "SPOTRF", uplo, n, &c_n1, &c_n1, &c_n1);
if (nb <= 1 || nb >= *n) {
/* Use unblocked code */
spstf2_(uplo, n, &a[a_dim1 + 1], lda, &piv[1], rank, tol, &work[1],
info);
goto L200;
} else {
/* Initialize PIV */
i__1 = *n;
for (i__ = 1; i__ <= i__1; ++i__) {
piv[i__] = i__;
/* L100: */
}
/* Compute stopping value */
pvt = 1;
ajj = a[pvt + pvt * a_dim1];
i__1 = *n;
for (i__ = 2; i__ <= i__1; ++i__) {
if (a[i__ + i__ * a_dim1] > ajj) {
pvt = i__;
ajj = a[pvt + pvt * a_dim1];
}
}
if (ajj == 0.f || sisnan_(&ajj)) {
*rank = 0;
*info = 1;
goto L200;
}
/* Compute stopping value if not supplied */
if (*tol < 0.f) {
sstop = *n * slamch_("Epsilon") * ajj;
} else {
sstop = *tol;
}
if (upper) {
/* Compute the Cholesky factorization P' * A * P = U' * U */
i__1 = *n;
i__2 = nb;
for (k = 1; i__2 < 0 ? k >= i__1 : k <= i__1; k += i__2) {
/* Account for last block not being NB wide */
/* Computing MIN */
i__3 = nb, i__4 = *n - k + 1;
jb = min(i__3,i__4);
/* Set relevant part of first half of WORK to zero, */
/* holds dot products */
i__3 = *n;
for (i__ = k; i__ <= i__3; ++i__) {
work[i__] = 0.f;
/* L110: */
}
i__3 = k + jb - 1;
for (j = k; j <= i__3; ++j) {
/* Find pivot, test for exit, else swap rows and columns */
/* Update dot products, compute possible pivots which are */
/* stored in the second half of WORK */
i__4 = *n;
for (i__ = j; i__ <= i__4; ++i__) {
if (j > k) {
/* Computing 2nd power */
r__1 = a[j - 1 + i__ * a_dim1];
work[i__] += r__1 * r__1;
}
work[*n + i__] = a[i__ + i__ * a_dim1] - work[i__];
/* L120: */
}
if (j > 1) {
maxlocval = (*n << 1) - (*n + j) + 1;
itemp = smaxloc_(&work[*n + j], &maxlocval);
pvt = itemp + j - 1;
ajj = work[*n + pvt];
if (ajj <= sstop || sisnan_(&ajj)) {
a[j + j * a_dim1] = ajj;
goto L190;
}
}
if (j != pvt) {
/* Pivot OK, so can now swap pivot rows and columns */
a[pvt + pvt * a_dim1] = a[j + j * a_dim1];
i__4 = j - 1;
sswap_(&i__4, &a[j * a_dim1 + 1], &c__1, &a[pvt *
a_dim1 + 1], &c__1);
if (pvt < *n) {
i__4 = *n - pvt;
sswap_(&i__4, &a[j + (pvt + 1) * a_dim1], lda, &a[
pvt + (pvt + 1) * a_dim1], lda);
}
i__4 = pvt - j - 1;
sswap_(&i__4, &a[j + (j + 1) * a_dim1], lda, &a[j + 1
+ pvt * a_dim1], &c__1);
/* Swap dot products and PIV */
stemp = work[j];
work[j] = work[pvt];
work[pvt] = stemp;
itemp = piv[pvt];
piv[pvt] = piv[j];
piv[j] = itemp;
}
ajj = sqrt(ajj);
a[j + j * a_dim1] = ajj;
/* Compute elements J+1:N of row J. */
if (j < *n) {
i__4 = j - k;
i__5 = *n - j;
sgemv_("Trans", &i__4, &i__5, &c_b22, &a[k + (j + 1) *
a_dim1], lda, &a[k + j * a_dim1], &c__1, &
c_b24, &a[j + (j + 1) * a_dim1], lda);
i__4 = *n - j;
r__1 = 1.f / ajj;
sscal_(&i__4, &r__1, &a[j + (j + 1) * a_dim1], lda);
}
/* L130: */
}
/* Update trailing matrix, J already incremented */
if (k + jb <= *n) {
i__3 = *n - j + 1;
ssyrk_("Upper", "Trans", &i__3, &jb, &c_b22, &a[k + j *
a_dim1], lda, &c_b24, &a[j + j * a_dim1], lda);
}
/* L140: */
}
} else {
/* Compute the Cholesky factorization P' * A * P = L * L' */
i__2 = *n;
i__1 = nb;
for (k = 1; i__1 < 0 ? k >= i__2 : k <= i__2; k += i__1) {
/* Account for last block not being NB wide */
/* Computing MIN */
i__3 = nb, i__4 = *n - k + 1;
jb = min(i__3,i__4);
/* Set relevant part of first half of WORK to zero, */
/* holds dot products */
i__3 = *n;
for (i__ = k; i__ <= i__3; ++i__) {
work[i__] = 0.f;
/* L150: */
}
i__3 = k + jb - 1;
for (j = k; j <= i__3; ++j) {
/* Find pivot, test for exit, else swap rows and columns */
/* Update dot products, compute possible pivots which are */
/* stored in the second half of WORK */
i__4 = *n;
for (i__ = j; i__ <= i__4; ++i__) {
if (j > k) {
/* Computing 2nd power */
r__1 = a[i__ + (j - 1) * a_dim1];
work[i__] += r__1 * r__1;
}
work[*n + i__] = a[i__ + i__ * a_dim1] - work[i__];
/* L160: */
}
if (j > 1) {
maxlocval = (*n << 1) - (*n + j) + 1;
itemp = smaxloc_(&work[*n + j], &maxlocval);
pvt = itemp + j - 1;
ajj = work[*n + pvt];
if (ajj <= sstop || sisnan_(&ajj)) {
a[j + j * a_dim1] = ajj;
goto L190;
}
}
if (j != pvt) {
/* Pivot OK, so can now swap pivot rows and columns */
a[pvt + pvt * a_dim1] = a[j + j * a_dim1];
i__4 = j - 1;
sswap_(&i__4, &a[j + a_dim1], lda, &a[pvt + a_dim1],
lda);
if (pvt < *n) {
i__4 = *n - pvt;
sswap_(&i__4, &a[pvt + 1 + j * a_dim1], &c__1, &a[
pvt + 1 + pvt * a_dim1], &c__1);
}
i__4 = pvt - j - 1;
sswap_(&i__4, &a[j + 1 + j * a_dim1], &c__1, &a[pvt +
(j + 1) * a_dim1], lda);
/* Swap dot products and PIV */
stemp = work[j];
work[j] = work[pvt];
work[pvt] = stemp;
itemp = piv[pvt];
piv[pvt] = piv[j];
piv[j] = itemp;
}
ajj = sqrt(ajj);
a[j + j * a_dim1] = ajj;
/* Compute elements J+1:N of column J. */
if (j < *n) {
i__4 = *n - j;
i__5 = j - k;
sgemv_("No Trans", &i__4, &i__5, &c_b22, &a[j + 1 + k
* a_dim1], lda, &a[j + k * a_dim1], lda, &
c_b24, &a[j + 1 + j * a_dim1], &c__1);
i__4 = *n - j;
r__1 = 1.f / ajj;
sscal_(&i__4, &r__1, &a[j + 1 + j * a_dim1], &c__1);
}
/* L170: */
}
/* Update trailing matrix, J already incremented */
if (k + jb <= *n) {
i__3 = *n - j + 1;
ssyrk_("Lower", "No Trans", &i__3, &jb, &c_b22, &a[j + k *
a_dim1], lda, &c_b24, &a[j + j * a_dim1], lda);
}
/* L180: */
}
}
}
/* Ran to completion, A has full rank */
*rank = *n;
goto L200;
L190:
/* Rank is the number of steps completed. Set INFO = 1 to signal */
/* that the factorization cannot be used to solve a system. */
*rank = j - 1;
*info = 1;
L200:
return 0;
/* End of SPSTRF */
} /* spstrf_ */
/* Subroutine */ int clar1v_(integer *n, integer *b1, integer *bn, real *
lambda, real *d__, real *l, real *ld, real *lld, real *pivmin, real *
gaptol, complex *z__, logical *wantnc, integer *negcnt, real *ztz,
real *mingma, integer *r__, integer *isuppz, real *nrminv, real *
resid, real *rqcorr, real *work)
{
/* System generated locals */
integer i__1, i__2, i__3, i__4;
real r__1;
complex q__1, q__2;
/* Builtin functions */
double c_abs(complex *), sqrt(doublereal);
/* Local variables */
integer i__;
real s;
integer r1, r2;
real eps, tmp;
integer neg1, neg2, indp, inds;
real dplus;
extern doublereal slamch_(char *);
integer indlpl, indumn;
extern logical sisnan_(real *);
real dminus;
logical sawnan1, sawnan2;
/* -- LAPACK auxiliary routine (version 3.2) -- */
/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/* November 2006 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* CLAR1V computes the (scaled) r-th column of the inverse of */
/* the sumbmatrix in rows B1 through BN of the tridiagonal matrix */
/* L D L^T - sigma I. When sigma is close to an eigenvalue, the */
/* computed vector is an accurate eigenvector. Usually, r corresponds */
/* to the index where the eigenvector is largest in magnitude. */
/* The following steps accomplish this computation : */
/* (a) Stationary qd transform, L D L^T - sigma I = L(+) D(+) L(+)^T, */
/* (b) Progressive qd transform, L D L^T - sigma I = U(-) D(-) U(-)^T, */
/* (c) Computation of the diagonal elements of the inverse of */
/* L D L^T - sigma I by combining the above transforms, and choosing */
/* r as the index where the diagonal of the inverse is (one of the) */
/* largest in magnitude. */
/* (d) Computation of the (scaled) r-th column of the inverse using the */
/* twisted factorization obtained by combining the top part of the */
/* the stationary and the bottom part of the progressive transform. */
/* Arguments */
/* ========= */
/* N (input) INTEGER */
/* The order of the matrix L D L^T. */
/* B1 (input) INTEGER */
/* First index of the submatrix of L D L^T. */
/* BN (input) INTEGER */
/* Last index of the submatrix of L D L^T. */
/* LAMBDA (input) REAL */
/* The shift. In order to compute an accurate eigenvector, */
/* LAMBDA should be a good approximation to an eigenvalue */
/* of L D L^T. */
/* L (input) REAL array, dimension (N-1) */
/* The (n-1) subdiagonal elements of the unit bidiagonal matrix */
/* L, in elements 1 to N-1. */
/* D (input) REAL array, dimension (N) */
/* The n diagonal elements of the diagonal matrix D. */
/* LD (input) REAL array, dimension (N-1) */
/* The n-1 elements L(i)*D(i). */
/* LLD (input) REAL array, dimension (N-1) */
/* The n-1 elements L(i)*L(i)*D(i). */
/* PIVMIN (input) REAL */
/* The minimum pivot in the Sturm sequence. */
/* GAPTOL (input) REAL */
/* Tolerance that indicates when eigenvector entries are negligible */
/* w.r.t. their contribution to the residual. */
/* Z (input/output) COMPLEX array, dimension (N) */
/* On input, all entries of Z must be set to 0. */
/* On output, Z contains the (scaled) r-th column of the */
/* inverse. The scaling is such that Z(R) equals 1. */
/* WANTNC (input) LOGICAL */
/* Specifies whether NEGCNT has to be computed. */
/* NEGCNT (output) INTEGER */
/* If WANTNC is .TRUE. then NEGCNT = the number of pivots < pivmin */
/* in the matrix factorization L D L^T, and NEGCNT = -1 otherwise. */
/* ZTZ (output) REAL */
/* The square of the 2-norm of Z. */
/* MINGMA (output) REAL */
/* The reciprocal of the largest (in magnitude) diagonal */
/* element of the inverse of L D L^T - sigma I. */
/* R (input/output) INTEGER */
/* The twist index for the twisted factorization used to */
/* compute Z. */
/* On input, 0 <= R <= N. If R is input as 0, R is set to */
/* the index where (L D L^T - sigma I)^{-1} is largest */
/* in magnitude. If 1 <= R <= N, R is unchanged. */
/* On output, R contains the twist index used to compute Z. */
/* Ideally, R designates the position of the maximum entry in the */
/* eigenvector. */
/* ISUPPZ (output) INTEGER array, dimension (2) */
/* The support of the vector in Z, i.e., the vector Z is */
/* nonzero only in elements ISUPPZ(1) through ISUPPZ( 2 ). */
/* NRMINV (output) REAL */
/* NRMINV = 1/SQRT( ZTZ ) */
/* RESID (output) REAL */
/* The residual of the FP vector. */
/* RESID = ABS( MINGMA )/SQRT( ZTZ ) */
/* RQCORR (output) REAL */
/* The Rayleigh Quotient correction to LAMBDA. */
/* RQCORR = MINGMA*TMP */
/* WORK (workspace) REAL array, dimension (4*N) */
/* 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 .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Executable Statements .. */
/* Parameter adjustments */
--work;
--isuppz;
--z__;
--lld;
--ld;
--l;
--d__;
/* Function Body */
eps = slamch_("Precision");
if (*r__ == 0) {
r1 = *b1;
r2 = *bn;
} else {
r1 = *r__;
r2 = *r__;
}
/* Storage for LPLUS */
indlpl = 0;
/* Storage for UMINUS */
indumn = *n;
inds = (*n << 1) + 1;
indp = *n * 3 + 1;
if (*b1 == 1) {
work[inds] = 0.f;
} else {
work[inds + *b1 - 1] = lld[*b1 - 1];
}
/* Compute the stationary transform (using the differential form) */
/* until the index R2. */
sawnan1 = FALSE_;
neg1 = 0;
s = work[inds + *b1 - 1] - *lambda;
i__1 = r1 - 1;
for (i__ = *b1; i__ <= i__1; ++i__) {
dplus = d__[i__] + s;
work[indlpl + i__] = ld[i__] / dplus;
if (dplus < 0.f) {
++neg1;
}
work[inds + i__] = s * work[indlpl + i__] * l[i__];
s = work[inds + i__] - *lambda;
/* L50: */
}
sawnan1 = sisnan_(&s);
if (sawnan1) {
goto L60;
}
i__1 = r2 - 1;
for (i__ = r1; i__ <= i__1; ++i__) {
dplus = d__[i__] + s;
work[indlpl + i__] = ld[i__] / dplus;
work[inds + i__] = s * work[indlpl + i__] * l[i__];
s = work[inds + i__] - *lambda;
/* L51: */
}
sawnan1 = sisnan_(&s);
L60:
if (sawnan1) {
/* Runs a slower version of the above loop if a NaN is detected */
neg1 = 0;
s = work[inds + *b1 - 1] - *lambda;
i__1 = r1 - 1;
for (i__ = *b1; i__ <= i__1; ++i__) {
dplus = d__[i__] + s;
if (dabs(dplus) < *pivmin) {
dplus = -(*pivmin);
}
work[indlpl + i__] = ld[i__] / dplus;
if (dplus < 0.f) {
++neg1;
}
work[inds + i__] = s * work[indlpl + i__] * l[i__];
if (work[indlpl + i__] == 0.f) {
work[inds + i__] = lld[i__];
}
s = work[inds + i__] - *lambda;
/* L70: */
}
i__1 = r2 - 1;
for (i__ = r1; i__ <= i__1; ++i__) {
dplus = d__[i__] + s;
if (dabs(dplus) < *pivmin) {
dplus = -(*pivmin);
}
work[indlpl + i__] = ld[i__] / dplus;
work[inds + i__] = s * work[indlpl + i__] * l[i__];
if (work[indlpl + i__] == 0.f) {
work[inds + i__] = lld[i__];
}
s = work[inds + i__] - *lambda;
/* L71: */
}
}
/* Compute the progressive transform (using the differential form) */
/* until the index R1 */
sawnan2 = FALSE_;
neg2 = 0;
work[indp + *bn - 1] = d__[*bn] - *lambda;
i__1 = r1;
for (i__ = *bn - 1; i__ >= i__1; --i__) {
dminus = lld[i__] + work[indp + i__];
tmp = d__[i__] / dminus;
if (dminus < 0.f) {
++neg2;
}
work[indumn + i__] = l[i__] * tmp;
work[indp + i__ - 1] = work[indp + i__] * tmp - *lambda;
/* L80: */
}
tmp = work[indp + r1 - 1];
sawnan2 = sisnan_(&tmp);
if (sawnan2) {
/* Runs a slower version of the above loop if a NaN is detected */
neg2 = 0;
i__1 = r1;
for (i__ = *bn - 1; i__ >= i__1; --i__) {
dminus = lld[i__] + work[indp + i__];
if (dabs(dminus) < *pivmin) {
dminus = -(*pivmin);
}
tmp = d__[i__] / dminus;
if (dminus < 0.f) {
++neg2;
}
work[indumn + i__] = l[i__] * tmp;
work[indp + i__ - 1] = work[indp + i__] * tmp - *lambda;
if (tmp == 0.f) {
work[indp + i__ - 1] = d__[i__] - *lambda;
}
/* L100: */
}
}
/* Find the index (from R1 to R2) of the largest (in magnitude) */
/* diagonal element of the inverse */
*mingma = work[inds + r1 - 1] + work[indp + r1 - 1];
if (*mingma < 0.f) {
++neg1;
}
if (*wantnc) {
*negcnt = neg1 + neg2;
} else {
*negcnt = -1;
}
if (dabs(*mingma) == 0.f) {
*mingma = eps * work[inds + r1 - 1];
}
*r__ = r1;
i__1 = r2 - 1;
for (i__ = r1; i__ <= i__1; ++i__) {
tmp = work[inds + i__] + work[indp + i__];
if (tmp == 0.f) {
tmp = eps * work[inds + i__];
}
if (dabs(tmp) <= dabs(*mingma)) {
*mingma = tmp;
*r__ = i__ + 1;
}
/* L110: */
}
/* Compute the FP vector: solve N^T v = e_r */
isuppz[1] = *b1;
isuppz[2] = *bn;
i__1 = *r__;
z__[i__1].r = 1.f, z__[i__1].i = 0.f;
*ztz = 1.f;
/* Compute the FP vector upwards from R */
if (! sawnan1 && ! sawnan2) {
i__1 = *b1;
for (i__ = *r__ - 1; i__ >= i__1; --i__) {
i__2 = i__;
i__3 = indlpl + i__;
i__4 = i__ + 1;
q__2.r = work[i__3] * z__[i__4].r, q__2.i = work[i__3] * z__[i__4]
.i;
q__1.r = -q__2.r, q__1.i = -q__2.i;
z__[i__2].r = q__1.r, z__[i__2].i = q__1.i;
if ((c_abs(&z__[i__]) + c_abs(&z__[i__ + 1])) * (r__1 = ld[i__],
dabs(r__1)) < *gaptol) {
i__2 = i__;
z__[i__2].r = 0.f, z__[i__2].i = 0.f;
isuppz[1] = i__ + 1;
goto L220;
}
i__2 = i__;
i__3 = i__;
q__1.r = z__[i__2].r * z__[i__3].r - z__[i__2].i * z__[i__3].i,
q__1.i = z__[i__2].r * z__[i__3].i + z__[i__2].i * z__[
i__3].r;
*ztz += q__1.r;
/* L210: */
}
L220:
;
} else {
/* Run slower loop if NaN occurred. */
i__1 = *b1;
for (i__ = *r__ - 1; i__ >= i__1; --i__) {
i__2 = i__ + 1;
if (z__[i__2].r == 0.f && z__[i__2].i == 0.f) {
i__2 = i__;
r__1 = -(ld[i__ + 1] / ld[i__]);
i__3 = i__ + 2;
q__1.r = r__1 * z__[i__3].r, q__1.i = r__1 * z__[i__3].i;
z__[i__2].r = q__1.r, z__[i__2].i = q__1.i;
} else {
i__2 = i__;
i__3 = indlpl + i__;
i__4 = i__ + 1;
q__2.r = work[i__3] * z__[i__4].r, q__2.i = work[i__3] * z__[
i__4].i;
q__1.r = -q__2.r, q__1.i = -q__2.i;
z__[i__2].r = q__1.r, z__[i__2].i = q__1.i;
}
if ((c_abs(&z__[i__]) + c_abs(&z__[i__ + 1])) * (r__1 = ld[i__],
dabs(r__1)) < *gaptol) {
i__2 = i__;
z__[i__2].r = 0.f, z__[i__2].i = 0.f;
isuppz[1] = i__ + 1;
goto L240;
}
i__2 = i__;
i__3 = i__;
q__1.r = z__[i__2].r * z__[i__3].r - z__[i__2].i * z__[i__3].i,
q__1.i = z__[i__2].r * z__[i__3].i + z__[i__2].i * z__[
i__3].r;
*ztz += q__1.r;
/* L230: */
}
L240:
;
}
/* Compute the FP vector downwards from R in blocks of size BLKSIZ */
if (! sawnan1 && ! sawnan2) {
i__1 = *bn - 1;
for (i__ = *r__; i__ <= i__1; ++i__) {
i__2 = i__ + 1;
i__3 = indumn + i__;
i__4 = i__;
q__2.r = work[i__3] * z__[i__4].r, q__2.i = work[i__3] * z__[i__4]
.i;
q__1.r = -q__2.r, q__1.i = -q__2.i;
z__[i__2].r = q__1.r, z__[i__2].i = q__1.i;
if ((c_abs(&z__[i__]) + c_abs(&z__[i__ + 1])) * (r__1 = ld[i__],
dabs(r__1)) < *gaptol) {
i__2 = i__ + 1;
z__[i__2].r = 0.f, z__[i__2].i = 0.f;
isuppz[2] = i__;
goto L260;
}
i__2 = i__ + 1;
i__3 = i__ + 1;
q__1.r = z__[i__2].r * z__[i__3].r - z__[i__2].i * z__[i__3].i,
q__1.i = z__[i__2].r * z__[i__3].i + z__[i__2].i * z__[
i__3].r;
*ztz += q__1.r;
/* L250: */
}
L260:
;
} else {
/* Run slower loop if NaN occurred. */
i__1 = *bn - 1;
for (i__ = *r__; i__ <= i__1; ++i__) {
i__2 = i__;
if (z__[i__2].r == 0.f && z__[i__2].i == 0.f) {
i__2 = i__ + 1;
r__1 = -(ld[i__ - 1] / ld[i__]);
i__3 = i__ - 1;
q__1.r = r__1 * z__[i__3].r, q__1.i = r__1 * z__[i__3].i;
z__[i__2].r = q__1.r, z__[i__2].i = q__1.i;
} else {
i__2 = i__ + 1;
i__3 = indumn + i__;
i__4 = i__;
q__2.r = work[i__3] * z__[i__4].r, q__2.i = work[i__3] * z__[
i__4].i;
q__1.r = -q__2.r, q__1.i = -q__2.i;
z__[i__2].r = q__1.r, z__[i__2].i = q__1.i;
}
if ((c_abs(&z__[i__]) + c_abs(&z__[i__ + 1])) * (r__1 = ld[i__],
dabs(r__1)) < *gaptol) {
i__2 = i__ + 1;
z__[i__2].r = 0.f, z__[i__2].i = 0.f;
isuppz[2] = i__;
goto L280;
}
i__2 = i__ + 1;
i__3 = i__ + 1;
q__1.r = z__[i__2].r * z__[i__3].r - z__[i__2].i * z__[i__3].i,
q__1.i = z__[i__2].r * z__[i__3].i + z__[i__2].i * z__[
i__3].r;
*ztz += q__1.r;
/* L270: */
}
L280:
;
}
/* Compute quantities for convergence test */
tmp = 1.f / *ztz;
*nrminv = sqrt(tmp);
*resid = dabs(*mingma) * *nrminv;
*rqcorr = *mingma * tmp;
return 0;
/* End of CLAR1V */
} /* clar1v_ */
/* Subroutine */
int classq_(integer *n, complex *x, integer *incx, real * scale, real *sumsq)
{
/* System generated locals */
integer i__1, i__2, i__3;
real r__1;
/* Builtin functions */
double r_imag(complex *);
/* Local variables */
integer ix;
real temp1;
extern logical sisnan_(real *);
/* -- LAPACK auxiliary 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 .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Executable Statements .. */
/* Parameter adjustments */
--x;
/* Function Body */
if (*n > 0)
{
i__1 = (*n - 1) * *incx + 1;
i__2 = *incx;
for (ix = 1;
i__2 < 0 ? ix >= i__1 : ix <= i__1;
ix += i__2)
{
i__3 = ix;
temp1 = (r__1 = x[i__3].r, f2c_abs(r__1));
if (temp1 > 0.f || sisnan_(&temp1))
{
if (*scale < temp1)
{
/* Computing 2nd power */
r__1 = *scale / temp1;
*sumsq = *sumsq * (r__1 * r__1) + 1;
*scale = temp1;
}
else
{
/* Computing 2nd power */
r__1 = temp1 / *scale;
*sumsq += r__1 * r__1;
}
}
temp1 = (r__1 = r_imag(&x[ix]), f2c_abs(r__1));
if (temp1 > 0.f || sisnan_(&temp1))
{
if (*scale < temp1 || sisnan_(&temp1))
{
/* Computing 2nd power */
r__1 = *scale / temp1;
*sumsq = *sumsq * (r__1 * r__1) + 1;
*scale = temp1;
}
else
{
/* Computing 2nd power */
r__1 = temp1 / *scale;
*sumsq += r__1 * r__1;
}
}
/* L10: */
}
}
return 0;
/* End of CLASSQ */
}
/* Subroutine */ int clascl_(char *type__, integer *kl, integer *ku, real *
cfrom, real *cto, integer *m, integer *n, complex *a, integer *lda,
integer *info)
{
/* System generated locals */
integer a_dim1, a_offset, i__1, i__2, i__3, i__4, i__5;
complex q__1;
/* Local variables */
integer i__, j, k1, k2, k3, k4;
real mul, cto1;
logical done;
real ctoc;
integer itype;
real cfrom1;
real cfromc;
real bignum;
real smlnum;
/* -- LAPACK auxiliary routine (version 3.2) -- */
/* November 2006 */
/* Purpose */
/* ======= */
/* CLASCL multiplies the M by N complex matrix A by the real scalar */
/* CTO/CFROM. This is done without over/underflow as long as the final */
/* result CTO*A(I,J)/CFROM does not over/underflow. TYPE specifies that */
/* A may be full, upper triangular, lower triangular, upper Hessenberg, */
/* or banded. */
/* Arguments */
/* ========= */
/* TYPE (input) CHARACTER*1 */
/* TYPE indices the storage type of the input matrix. */
/* = 'G': A is a full matrix. */
/* = 'L': A is a lower triangular matrix. */
/* = 'U': A is an upper triangular matrix. */
/* = 'H': A is an upper Hessenberg matrix. */
/* = 'B': A is a symmetric band matrix with lower bandwidth KL */
/* and upper bandwidth KU and with the only the lower */
/* half stored. */
/* = 'Q': A is a symmetric band matrix with lower bandwidth KL */
/* and upper bandwidth KU and with the only the upper */
/* half stored. */
/* = 'Z': A is a band matrix with lower bandwidth KL and upper */
/* bandwidth KU. */
/* KL (input) INTEGER */
/* The lower bandwidth of A. Referenced only if TYPE = 'B', */
/* 'Q' or 'Z'. */
/* KU (input) INTEGER */
/* The upper bandwidth of A. Referenced only if TYPE = 'B', */
/* 'Q' or 'Z'. */
/* CFROM (input) REAL */
/* CTO (input) REAL */
/* The matrix A is multiplied by CTO/CFROM. A(I,J) is computed */
/* without over/underflow if the final result CTO*A(I,J)/CFROM */
/* can be represented without over/underflow. CFROM must be */
/* nonzero. */
/* M (input) INTEGER */
/* The number of rows of the matrix A. M >= 0. */
/* N (input) INTEGER */
/* The number of columns of the matrix A. N >= 0. */
/* A (input/output) COMPLEX array, dimension (LDA,N) */
/* The matrix to be multiplied by CTO/CFROM. See TYPE for the */
/* storage type. */
/* LDA (input) INTEGER */
/* The leading dimension of the array A. LDA >= max(1,M). */
/* INFO (output) INTEGER */
/* 0 - successful exit */
/* <0 - if INFO = -i, the i-th argument had an illegal value. */
/* ===================================================================== */
/* Test the input arguments */
/* Parameter adjustments */
a_dim1 = *lda;
a_offset = 1 + a_dim1;
a -= a_offset;
/* Function Body */
*info = 0;
if (lsame_(type__, "G")) {
itype = 0;
} else if (lsame_(type__, "L")) {
itype = 1;
} else if (lsame_(type__, "U")) {
itype = 2;
} else if (lsame_(type__, "H")) {
itype = 3;
} else if (lsame_(type__, "B")) {
itype = 4;
} else if (lsame_(type__, "Q")) {
itype = 5;
} else if (lsame_(type__, "Z")) {
itype = 6;
} else {
itype = -1;
}
if (itype == -1) {
*info = -1;
} else if (*cfrom == 0.f || sisnan_(cfrom)) {
*info = -4;
} else if (sisnan_(cto)) {
*info = -5;
} else if (*m < 0) {
*info = -6;
} else if (*n < 0 || itype == 4 && *n != *m || itype == 5 && *n != *m) {
*info = -7;
} else if (itype <= 3 && *lda < max(1,*m)) {
*info = -9;
} else if (itype >= 4) {
/* Computing MAX */
i__1 = *m - 1;
if (*kl < 0 || *kl > max(i__1,0)) {
*info = -2;
} else /* if(complicated condition) */ {
/* Computing MAX */
i__1 = *n - 1;
if (*ku < 0 || *ku > max(i__1,0) || (itype == 4 || itype == 5) &&
*kl != *ku) {
*info = -3;
} else if (itype == 4 && *lda < *kl + 1 || itype == 5 && *lda < *
ku + 1 || itype == 6 && *lda < (*kl << 1) + *ku + 1) {
*info = -9;
}
}
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("CLASCL", &i__1);
return 0;
}
/* Quick return if possible */
if (*n == 0 || *m == 0) {
return 0;
}
/* Get machine parameters */
smlnum = slamch_("S");
bignum = 1.f / smlnum;
cfromc = *cfrom;
ctoc = *cto;
L10:
cfrom1 = cfromc * smlnum;
if (cfrom1 == cfromc) {
/* CFROMC is an inf. Multiply by a correctly signed zero for */
/* finite CTOC, or a NaN if CTOC is infinite. */
mul = ctoc / cfromc;
done = TRUE_;
cto1 = ctoc;
} else {
cto1 = ctoc / bignum;
if (cto1 == ctoc) {
/* CTOC is either 0 or an inf. In both cases, CTOC itself */
/* serves as the correct multiplication factor. */
mul = ctoc;
done = TRUE_;
cfromc = 1.f;
} else if (dabs(cfrom1) > dabs(ctoc) && ctoc != 0.f) {
mul = smlnum;
done = FALSE_;
cfromc = cfrom1;
} else if (dabs(cto1) > dabs(cfromc)) {
mul = bignum;
done = FALSE_;
ctoc = cto1;
} else {
mul = ctoc / cfromc;
done = TRUE_;
}
}
if (itype == 0) {
/* Full matrix */
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
i__2 = *m;
for (i__ = 1; i__ <= i__2; ++i__) {
i__3 = i__ + j * a_dim1;
i__4 = i__ + j * a_dim1;
q__1.r = mul * a[i__4].r, q__1.i = mul * a[i__4].i;
a[i__3].r = q__1.r, a[i__3].i = q__1.i;
}
}
} else if (itype == 1) {
/* Lower triangular matrix */
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
i__2 = *m;
for (i__ = j; i__ <= i__2; ++i__) {
i__3 = i__ + j * a_dim1;
i__4 = i__ + j * a_dim1;
q__1.r = mul * a[i__4].r, q__1.i = mul * a[i__4].i;
a[i__3].r = q__1.r, a[i__3].i = q__1.i;
}
}
} else if (itype == 2) {
/* Upper triangular matrix */
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
i__2 = min(j,*m);
for (i__ = 1; i__ <= i__2; ++i__) {
i__3 = i__ + j * a_dim1;
i__4 = i__ + j * a_dim1;
q__1.r = mul * a[i__4].r, q__1.i = mul * a[i__4].i;
a[i__3].r = q__1.r, a[i__3].i = q__1.i;
}
}
} else if (itype == 3) {
/* Upper Hessenberg matrix */
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
/* Computing MIN */
i__3 = j + 1;
i__2 = min(i__3,*m);
for (i__ = 1; i__ <= i__2; ++i__) {
i__3 = i__ + j * a_dim1;
i__4 = i__ + j * a_dim1;
q__1.r = mul * a[i__4].r, q__1.i = mul * a[i__4].i;
a[i__3].r = q__1.r, a[i__3].i = q__1.i;
}
}
} else if (itype == 4) {
/* Lower half of a symmetric band matrix */
k3 = *kl + 1;
k4 = *n + 1;
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
/* Computing MIN */
i__3 = k3, i__4 = k4 - j;
i__2 = min(i__3,i__4);
for (i__ = 1; i__ <= i__2; ++i__) {
i__3 = i__ + j * a_dim1;
i__4 = i__ + j * a_dim1;
q__1.r = mul * a[i__4].r, q__1.i = mul * a[i__4].i;
a[i__3].r = q__1.r, a[i__3].i = q__1.i;
}
}
} else if (itype == 5) {
/* Upper half of a symmetric band matrix */
k1 = *ku + 2;
k3 = *ku + 1;
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
/* Computing MAX */
i__2 = k1 - j;
i__3 = k3;
for (i__ = max(i__2,1); i__ <= i__3; ++i__) {
i__2 = i__ + j * a_dim1;
i__4 = i__ + j * a_dim1;
q__1.r = mul * a[i__4].r, q__1.i = mul * a[i__4].i;
a[i__2].r = q__1.r, a[i__2].i = q__1.i;
}
}
} else if (itype == 6) {
/* Band matrix */
k1 = *kl + *ku + 2;
k2 = *kl + 1;
k3 = (*kl << 1) + *ku + 1;
k4 = *kl + *ku + 1 + *m;
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
/* Computing MAX */
i__3 = k1 - j;
/* Computing MIN */
i__4 = k3, i__5 = k4 - j;
i__2 = min(i__4,i__5);
for (i__ = max(i__3,k2); i__ <= i__2; ++i__) {
i__3 = i__ + j * a_dim1;
i__4 = i__ + j * a_dim1;
q__1.r = mul * a[i__4].r, q__1.i = mul * a[i__4].i;
a[i__3].r = q__1.r, a[i__3].i = q__1.i;
}
}
}
if (! done) {
goto L10;
}
return 0;
/* End of CLASCL */
} /* clascl_ */
/* ===================================================================== */
real slansp_(char *norm, char *uplo, integer *n, real *ap, real *work)
{
/* System generated locals */
integer i__1, i__2;
real ret_val, r__1;
/* Builtin functions */
double sqrt(doublereal);
/* Local variables */
integer i__, j, k;
real sum, absa, scale;
extern logical lsame_(char *, char *);
real value;
extern logical sisnan_(real *);
extern /* Subroutine */
int slassq_(integer *, real *, integer *, real *, real *);
/* -- LAPACK auxiliary 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 Subroutines .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Executable Statements .. */
/* Parameter adjustments */
--work;
--ap;
/* Function Body */
if (*n == 0)
{
value = 0.f;
}
else if (lsame_(norm, "M"))
{
/* Find max(f2c_abs(A(i,j))). */
value = 0.f;
if (lsame_(uplo, "U"))
{
k = 1;
i__1 = *n;
for (j = 1;
j <= i__1;
++j)
{
i__2 = k + j - 1;
for (i__ = k;
i__ <= i__2;
++i__)
{
sum = (r__1 = ap[i__], f2c_abs(r__1));
if (value < sum || sisnan_(&sum))
{
value = sum;
}
/* L10: */
}
k += j;
/* L20: */
}
}
else
{
k = 1;
i__1 = *n;
for (j = 1;
j <= i__1;
++j)
{
i__2 = k + *n - j;
for (i__ = k;
i__ <= i__2;
++i__)
{
sum = (r__1 = ap[i__], f2c_abs(r__1));
if (value < sum || sisnan_(&sum))
{
value = sum;
}
/* L30: */
}
k = k + *n - j + 1;
/* L40: */
}
}
}
else if (lsame_(norm, "I") || lsame_(norm, "O") || *(unsigned char *)norm == '1')
{
/* Find normI(A) ( = norm1(A), since A is symmetric). */
value = 0.f;
k = 1;
if (lsame_(uplo, "U"))
{
i__1 = *n;
for (j = 1;
j <= i__1;
++j)
{
sum = 0.f;
i__2 = j - 1;
for (i__ = 1;
i__ <= i__2;
++i__)
{
absa = (r__1 = ap[k], f2c_abs(r__1));
sum += absa;
work[i__] += absa;
++k;
/* L50: */
}
work[j] = sum + (r__1 = ap[k], f2c_abs(r__1));
++k;
/* L60: */
}
i__1 = *n;
for (i__ = 1;
i__ <= i__1;
++i__)
{
sum = work[i__];
if (value < sum || sisnan_(&sum))
{
value = sum;
}
/* L70: */
}
}
else
{
i__1 = *n;
for (i__ = 1;
i__ <= i__1;
++i__)
{
work[i__] = 0.f;
/* L80: */
}
i__1 = *n;
for (j = 1;
j <= i__1;
++j)
{
sum = work[j] + (r__1 = ap[k], f2c_abs(r__1));
++k;
i__2 = *n;
for (i__ = j + 1;
i__ <= i__2;
++i__)
{
absa = (r__1 = ap[k], f2c_abs(r__1));
sum += absa;
work[i__] += absa;
++k;
/* L90: */
}
if (value < sum || sisnan_(&sum))
{
value = sum;
}
/* L100: */
}
}
}
else if (lsame_(norm, "F") || lsame_(norm, "E"))
{
/* Find normF(A). */
scale = 0.f;
sum = 1.f;
k = 2;
if (lsame_(uplo, "U"))
{
i__1 = *n;
for (j = 2;
j <= i__1;
++j)
{
i__2 = j - 1;
slassq_(&i__2, &ap[k], &c__1, &scale, &sum);
k += j;
/* L110: */
}
}
else
{
i__1 = *n - 1;
for (j = 1;
j <= i__1;
++j)
{
i__2 = *n - j;
slassq_(&i__2, &ap[k], &c__1, &scale, &sum);
k = k + *n - j + 1;
/* L120: */
}
}
sum *= 2;
k = 1;
i__1 = *n;
for (i__ = 1;
i__ <= i__1;
++i__)
{
if (ap[k] != 0.f)
{
absa = (r__1 = ap[k], f2c_abs(r__1));
if (scale < absa)
{
/* Computing 2nd power */
r__1 = scale / absa;
sum = sum * (r__1 * r__1) + 1.f;
scale = absa;
}
else
{
/* Computing 2nd power */
r__1 = absa / scale;
sum += r__1 * r__1;
}
}
if (lsame_(uplo, "U"))
{
k = k + i__ + 1;
}
else
{
k = k + *n - i__ + 1;
}
/* L130: */
}
value = scale * sqrt(sum);
}
ret_val = value;
return ret_val;
/* End of SLANSP */
}
/* ===================================================================== */
real clansy_(char *norm, char *uplo, integer *n, complex *a, integer *lda, real *work)
{
/* System generated locals */
integer a_dim1, a_offset, i__1, i__2;
real ret_val;
/* Builtin functions */
double c_abs(complex *), sqrt(doublereal);
/* Local variables */
integer i__, j;
real sum, absa, scale;
extern logical lsame_(char *, char *);
real value;
extern /* Subroutine */
int classq_(integer *, complex *, integer *, real *, real *);
extern logical sisnan_(real *);
/* -- LAPACK auxiliary 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 .. */
/* Parameter adjustments */
a_dim1 = *lda;
a_offset = 1 + a_dim1;
a -= a_offset;
--work;
/* Function Body */
if (*n == 0)
{
value = 0.f;
}
else if (lsame_(norm, "M"))
{
/* Find max(f2c_abs(A(i,j))). */
value = 0.f;
if (lsame_(uplo, "U"))
{
i__1 = *n;
for (j = 1;
j <= i__1;
++j)
{
i__2 = j;
for (i__ = 1;
i__ <= i__2;
++i__)
{
sum = c_abs(&a[i__ + j * a_dim1]);
if (value < sum || sisnan_(&sum))
{
value = sum;
}
/* L10: */
}
/* L20: */
}
}
else
{
i__1 = *n;
for (j = 1;
j <= i__1;
++j)
{
i__2 = *n;
for (i__ = j;
i__ <= i__2;
++i__)
{
sum = c_abs(&a[i__ + j * a_dim1]);
if (value < sum || sisnan_(&sum))
{
value = sum;
}
/* L30: */
}
/* L40: */
}
}
}
else if (lsame_(norm, "I") || lsame_(norm, "O") || *(unsigned char *)norm == '1')
{
/* Find normI(A) ( = norm1(A), since A is symmetric). */
value = 0.f;
if (lsame_(uplo, "U"))
{
i__1 = *n;
for (j = 1;
j <= i__1;
++j)
{
sum = 0.f;
i__2 = j - 1;
for (i__ = 1;
i__ <= i__2;
++i__)
{
absa = c_abs(&a[i__ + j * a_dim1]);
sum += absa;
work[i__] += absa;
/* L50: */
}
work[j] = sum + c_abs(&a[j + j * a_dim1]);
/* L60: */
}
i__1 = *n;
for (i__ = 1;
i__ <= i__1;
++i__)
{
sum = work[i__];
if (value < sum || sisnan_(&sum))
{
value = sum;
}
/* L70: */
}
}
else
{
i__1 = *n;
for (i__ = 1;
i__ <= i__1;
++i__)
{
work[i__] = 0.f;
/* L80: */
}
i__1 = *n;
for (j = 1;
j <= i__1;
++j)
{
sum = work[j] + c_abs(&a[j + j * a_dim1]);
i__2 = *n;
for (i__ = j + 1;
i__ <= i__2;
++i__)
{
absa = c_abs(&a[i__ + j * a_dim1]);
sum += absa;
work[i__] += absa;
/* L90: */
}
if (value < sum || sisnan_(&sum))
{
value = sum;
}
/* L100: */
}
}
}
else if (lsame_(norm, "F") || lsame_(norm, "E"))
{
/* Find normF(A). */
scale = 0.f;
sum = 1.f;
if (lsame_(uplo, "U"))
{
i__1 = *n;
for (j = 2;
j <= i__1;
++j)
{
i__2 = j - 1;
classq_(&i__2, &a[j * a_dim1 + 1], &c__1, &scale, &sum);
/* L110: */
}
}
else
{
i__1 = *n - 1;
for (j = 1;
j <= i__1;
++j)
{
i__2 = *n - j;
classq_(&i__2, &a[j + 1 + j * a_dim1], &c__1, &scale, &sum);
/* L120: */
}
}
sum *= 2;
i__1 = *lda + 1;
classq_(n, &a[a_offset], &i__1, &scale, &sum);
value = scale * sqrt(sum);
}
ret_val = value;
return ret_val;
/* End of CLANSY */
}
/* Subroutine */ int cpstf2_(char *uplo, integer *n, complex *a, integer *lda,
integer *piv, integer *rank, real *tol, real *work, integer *info)
{
/* System generated locals */
integer a_dim1, a_offset, i__1, i__2, i__3;
real r__1;
complex q__1, q__2;
/* Builtin functions */
void r_cnjg(complex *, complex *);
double sqrt(doublereal);
/* Local variables */
integer i__, j, maxlocval;
real ajj;
integer pvt;
extern logical lsame_(char *, char *);
extern /* Subroutine */ int cgemv_(char *, integer *, integer *, complex *
, complex *, integer *, complex *, integer *, complex *, complex *
, integer *);
complex ctemp;
extern /* Subroutine */ int cswap_(integer *, complex *, integer *,
complex *, integer *);
integer itemp;
real stemp;
logical upper;
real sstop;
extern /* Subroutine */ int clacgv_(integer *, complex *, integer *);
extern doublereal slamch_(char *);
extern /* Subroutine */ int csscal_(integer *, real *, complex *, integer
*), xerbla_(char *, integer *);
extern logical sisnan_(real *);
extern integer smaxloc_(real *, integer *);
/* -- LAPACK PROTOTYPE routine (version 3.2) -- */
/* Craig Lucas, University of Manchester / NAG Ltd. */
/* October, 2008 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* CPSTF2 computes the Cholesky factorization with complete */
/* pivoting of a complex Hermitian positive semidefinite matrix A. */
/* The factorization has the form */
/* P' * A * P = U' * U , if UPLO = 'U', */
/* P' * A * P = L * L', if UPLO = 'L', */
/* where U is an upper triangular matrix and L is lower triangular, and */
/* P is stored as vector PIV. */
/* This algorithm does not attempt to check that A is positive */
/* semidefinite. This version of the algorithm calls level 2 BLAS. */
/* Arguments */
/* ========= */
/* UPLO (input) CHARACTER*1 */
/* Specifies whether the upper or lower triangular part of the */
/* symmetric matrix A is stored. */
/* = 'U': Upper triangular */
/* = 'L': Lower triangular */
/* N (input) INTEGER */
/* The order of the matrix A. N >= 0. */
/* A (input/output) COMPLEX array, dimension (LDA,N) */
/* On entry, the symmetric matrix A. If UPLO = 'U', the leading */
/* n by n upper triangular part of A contains the upper */
/* triangular part of the matrix A, and the strictly lower */
/* triangular part of A is not referenced. If UPLO = 'L', the */
/* leading n by n lower triangular part of A contains the lower */
/* triangular part of the matrix A, and the strictly upper */
/* triangular part of A is not referenced. */
/* On exit, if INFO = 0, the factor U or L from the Cholesky */
/* factorization as above. */
/* PIV (output) INTEGER array, dimension (N) */
/* PIV is such that the nonzero entries are P( PIV(K), K ) = 1. */
/* RANK (output) INTEGER */
/* The rank of A given by the number of steps the algorithm */
/* completed. */
/* TOL (input) REAL */
/* User defined tolerance. If TOL < 0, then N*U*MAX( A( K,K ) ) */
/* will be used. The algorithm terminates at the (K-1)st step */
/* if the pivot <= TOL. */
/* LDA (input) INTEGER */
/* The leading dimension of the array A. LDA >= max(1,N). */
/* WORK REAL array, dimension (2*N) */
/* Work space. */
/* INFO (output) INTEGER */
/* < 0: If INFO = -K, the K-th argument had an illegal value, */
/* = 0: algorithm completed successfully, and */
/* > 0: the matrix A is either rank deficient with computed rank */
/* as returned in RANK, or is indefinite. See Section 7 of */
/* LAPACK Working Note #161 for further information. */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Executable Statements .. */
/* Test the input parameters */
/* Parameter adjustments */
--work;
--piv;
a_dim1 = *lda;
a_offset = 1 + a_dim1;
a -= a_offset;
/* Function Body */
*info = 0;
upper = lsame_(uplo, "U");
if (! upper && ! lsame_(uplo, "L")) {
*info = -1;
} else if (*n < 0) {
*info = -2;
} else if (*lda < max(1,*n)) {
*info = -4;
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("CPSTF2", &i__1);
return 0;
}
/* Quick return if possible */
if (*n == 0) {
return 0;
}
/* Initialize PIV */
i__1 = *n;
for (i__ = 1; i__ <= i__1; ++i__) {
piv[i__] = i__;
/* L100: */
}
/* Compute stopping value */
i__1 = *n;
for (i__ = 1; i__ <= i__1; ++i__) {
i__2 = i__ + i__ * a_dim1;
work[i__] = a[i__2].r;
/* L110: */
}
pvt = smaxloc_(&work[1], n);
i__1 = pvt + pvt * a_dim1;
ajj = a[i__1].r;
if (ajj == 0.f || sisnan_(&ajj)) {
*rank = 0;
*info = 1;
goto L200;
}
/* Compute stopping value if not supplied */
if (*tol < 0.f) {
sstop = *n * slamch_("Epsilon") * ajj;
} else {
sstop = *tol;
}
/* Set first half of WORK to zero, holds dot products */
i__1 = *n;
for (i__ = 1; i__ <= i__1; ++i__) {
work[i__] = 0.f;
/* L120: */
}
if (upper) {
/* Compute the Cholesky factorization P' * A * P = U' * U */
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
/* Find pivot, test for exit, else swap rows and columns */
/* Update dot products, compute possible pivots which are */
/* stored in the second half of WORK */
i__2 = *n;
for (i__ = j; i__ <= i__2; ++i__) {
if (j > 1) {
r_cnjg(&q__2, &a[j - 1 + i__ * a_dim1]);
i__3 = j - 1 + i__ * a_dim1;
q__1.r = q__2.r * a[i__3].r - q__2.i * a[i__3].i, q__1.i =
q__2.r * a[i__3].i + q__2.i * a[i__3].r;
work[i__] += q__1.r;
}
i__3 = i__ + i__ * a_dim1;
work[*n + i__] = a[i__3].r - work[i__];
/* L130: */
}
if (j > 1) {
maxlocval = (*n << 1) - (*n + j) + 1;
itemp = smaxloc_(&work[*n + j], &maxlocval);
pvt = itemp + j - 1;
ajj = work[*n + pvt];
if (ajj <= sstop || sisnan_(&ajj)) {
i__2 = j + j * a_dim1;
a[i__2].r = ajj, a[i__2].i = 0.f;
goto L190;
}
}
if (j != pvt) {
/* Pivot OK, so can now swap pivot rows and columns */
i__2 = pvt + pvt * a_dim1;
i__3 = j + j * a_dim1;
a[i__2].r = a[i__3].r, a[i__2].i = a[i__3].i;
i__2 = j - 1;
cswap_(&i__2, &a[j * a_dim1 + 1], &c__1, &a[pvt * a_dim1 + 1],
&c__1);
if (pvt < *n) {
i__2 = *n - pvt;
cswap_(&i__2, &a[j + (pvt + 1) * a_dim1], lda, &a[pvt + (
pvt + 1) * a_dim1], lda);
}
i__2 = pvt - 1;
for (i__ = j + 1; i__ <= i__2; ++i__) {
r_cnjg(&q__1, &a[j + i__ * a_dim1]);
ctemp.r = q__1.r, ctemp.i = q__1.i;
i__3 = j + i__ * a_dim1;
r_cnjg(&q__1, &a[i__ + pvt * a_dim1]);
a[i__3].r = q__1.r, a[i__3].i = q__1.i;
i__3 = i__ + pvt * a_dim1;
a[i__3].r = ctemp.r, a[i__3].i = ctemp.i;
/* L140: */
}
i__2 = j + pvt * a_dim1;
r_cnjg(&q__1, &a[j + pvt * a_dim1]);
a[i__2].r = q__1.r, a[i__2].i = q__1.i;
/* Swap dot products and PIV */
stemp = work[j];
work[j] = work[pvt];
work[pvt] = stemp;
itemp = piv[pvt];
piv[pvt] = piv[j];
piv[j] = itemp;
}
ajj = sqrt(ajj);
i__2 = j + j * a_dim1;
a[i__2].r = ajj, a[i__2].i = 0.f;
/* Compute elements J+1:N of row J */
if (j < *n) {
i__2 = j - 1;
clacgv_(&i__2, &a[j * a_dim1 + 1], &c__1);
i__2 = j - 1;
i__3 = *n - j;
q__1.r = -1.f, q__1.i = -0.f;
cgemv_("Trans", &i__2, &i__3, &q__1, &a[(j + 1) * a_dim1 + 1],
lda, &a[j * a_dim1 + 1], &c__1, &c_b1, &a[j + (j + 1)
* a_dim1], lda);
i__2 = j - 1;
clacgv_(&i__2, &a[j * a_dim1 + 1], &c__1);
i__2 = *n - j;
r__1 = 1.f / ajj;
csscal_(&i__2, &r__1, &a[j + (j + 1) * a_dim1], lda);
}
/* L150: */
}
} else {
/* Compute the Cholesky factorization P' * A * P = L * L' */
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
/* Find pivot, test for exit, else swap rows and columns */
/* Update dot products, compute possible pivots which are */
/* stored in the second half of WORK */
i__2 = *n;
for (i__ = j; i__ <= i__2; ++i__) {
if (j > 1) {
r_cnjg(&q__2, &a[i__ + (j - 1) * a_dim1]);
i__3 = i__ + (j - 1) * a_dim1;
q__1.r = q__2.r * a[i__3].r - q__2.i * a[i__3].i, q__1.i =
q__2.r * a[i__3].i + q__2.i * a[i__3].r;
work[i__] += q__1.r;
}
i__3 = i__ + i__ * a_dim1;
work[*n + i__] = a[i__3].r - work[i__];
/* L160: */
}
if (j > 1) {
maxlocval = (*n << 1) - (*n + j) + 1;
itemp = smaxloc_(&work[*n + j], &maxlocval);
pvt = itemp + j - 1;
ajj = work[*n + pvt];
if (ajj <= sstop || sisnan_(&ajj)) {
i__2 = j + j * a_dim1;
a[i__2].r = ajj, a[i__2].i = 0.f;
goto L190;
}
}
if (j != pvt) {
/* Pivot OK, so can now swap pivot rows and columns */
i__2 = pvt + pvt * a_dim1;
i__3 = j + j * a_dim1;
a[i__2].r = a[i__3].r, a[i__2].i = a[i__3].i;
i__2 = j - 1;
cswap_(&i__2, &a[j + a_dim1], lda, &a[pvt + a_dim1], lda);
if (pvt < *n) {
i__2 = *n - pvt;
cswap_(&i__2, &a[pvt + 1 + j * a_dim1], &c__1, &a[pvt + 1
+ pvt * a_dim1], &c__1);
}
i__2 = pvt - 1;
for (i__ = j + 1; i__ <= i__2; ++i__) {
r_cnjg(&q__1, &a[i__ + j * a_dim1]);
ctemp.r = q__1.r, ctemp.i = q__1.i;
i__3 = i__ + j * a_dim1;
r_cnjg(&q__1, &a[pvt + i__ * a_dim1]);
a[i__3].r = q__1.r, a[i__3].i = q__1.i;
i__3 = pvt + i__ * a_dim1;
a[i__3].r = ctemp.r, a[i__3].i = ctemp.i;
/* L170: */
}
i__2 = pvt + j * a_dim1;
r_cnjg(&q__1, &a[pvt + j * a_dim1]);
a[i__2].r = q__1.r, a[i__2].i = q__1.i;
/* Swap dot products and PIV */
stemp = work[j];
work[j] = work[pvt];
work[pvt] = stemp;
itemp = piv[pvt];
piv[pvt] = piv[j];
piv[j] = itemp;
}
ajj = sqrt(ajj);
i__2 = j + j * a_dim1;
a[i__2].r = ajj, a[i__2].i = 0.f;
/* Compute elements J+1:N of column J */
if (j < *n) {
i__2 = j - 1;
clacgv_(&i__2, &a[j + a_dim1], lda);
i__2 = *n - j;
i__3 = j - 1;
q__1.r = -1.f, q__1.i = -0.f;
cgemv_("No Trans", &i__2, &i__3, &q__1, &a[j + 1 + a_dim1],
lda, &a[j + a_dim1], lda, &c_b1, &a[j + 1 + j *
a_dim1], &c__1);
i__2 = j - 1;
clacgv_(&i__2, &a[j + a_dim1], lda);
i__2 = *n - j;
r__1 = 1.f / ajj;
csscal_(&i__2, &r__1, &a[j + 1 + j * a_dim1], &c__1);
}
/* L180: */
}
}
/* Ran to completion, A has full rank */
*rank = *n;
goto L200;
L190:
/* Rank is number of steps completed. Set INFO = 1 to signal */
/* that the factorization cannot be used to solve a system. */
*rank = j - 1;
*info = 1;
L200:
return 0;
/* End of CPSTF2 */
} /* cpstf2_ */
integer slaneg_(integer *n, real *d__, real *lld, real *sigma, real *pivmin,
integer *r__)
{
/* System generated locals */
integer ret_val, i__1, i__2, i__3, i__4;
/* Local variables */
integer j;
real p, t;
integer bj;
real tmp;
integer neg1, neg2;
real bsav, gamma, dplus;
integer negcnt;
logical sawnan;
extern logical sisnan_(real *);
real dminus;
/* -- LAPACK auxiliary routine (version 3.1) -- */
/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/* November 2006 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* SLANEG computes the Sturm count, the number of negative pivots */
/* encountered while factoring tridiagonal T - sigma I = L D L^T. */
/* This implementation works directly on the factors without forming */
/* the tridiagonal matrix T. The Sturm count is also the number of */
/* eigenvalues of T less than sigma. */
/* This routine is called from SLARRB. */
/* The current routine does not use the PIVMIN parameter but rather */
/* requires IEEE-754 propagation of Infinities and NaNs. This */
/* routine also has no input range restrictions but does require */
/* default exception handling such that x/0 produces Inf when x is */
/* non-zero, and Inf/Inf produces NaN. For more information, see: */
/* Marques, Riedy, and Voemel, "Benefits of IEEE-754 Features in */
/* Modern Symmetric Tridiagonal Eigensolvers," SIAM Journal on */
/* Scientific Computing, v28, n5, 2006. DOI 10.1137/050641624 */
/* (Tech report version in LAWN 172 with the same title.) */
/* Arguments */
/* ========= */
/* N (input) INTEGER */
/* The order of the matrix. */
/* D (input) REAL array, dimension (N) */
/* The N diagonal elements of the diagonal matrix D. */
/* LLD (input) REAL array, dimension (N-1) */
/* The (N-1) elements L(i)*L(i)*D(i). */
/* SIGMA (input) REAL */
/* Shift amount in T - sigma I = L D L^T. */
/* PIVMIN (input) REAL */
/* The minimum pivot in the Sturm sequence. May be used */
/* when zero pivots are encountered on non-IEEE-754 */
/* architectures. */
/* R (input) INTEGER */
/* The twist index for the twisted factorization that is used */
/* for the negcount. */
/* Further Details */
/* =============== */
/* Based on contributions by */
/* Osni Marques, LBNL/NERSC, USA */
/* Christof Voemel, University of California, Berkeley, USA */
/* Jason Riedy, University of California, Berkeley, USA */
/* ===================================================================== */
/* .. Parameters .. */
/* Some architectures propagate Infinities and NaNs very slowly, so */
/* the code computes counts in BLKLEN chunks. Then a NaN can */
/* propagate at most BLKLEN columns before being detected. This is */
/* not a general tuning parameter; it needs only to be just large */
/* enough that the overhead is tiny in common cases. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. Executable Statements .. */
/* Parameter adjustments */
--lld;
--d__;
/* Function Body */
negcnt = 0;
/* I) upper part: L D L^T - SIGMA I = L+ D+ L+^T */
t = -(*sigma);
i__1 = *r__ - 1;
for (bj = 1; bj <= i__1; bj += 128) {
neg1 = 0;
bsav = t;
/* Computing MIN */
i__3 = bj + 127, i__4 = *r__ - 1;
i__2 = min(i__3,i__4);
for (j = bj; j <= i__2; ++j) {
dplus = d__[j] + t;
if (dplus < 0.f) {
++neg1;
}
tmp = t / dplus;
t = tmp * lld[j] - *sigma;
/* L21: */
}
sawnan = sisnan_(&t);
/* Run a slower version of the above loop if a NaN is detected. */
/* A NaN should occur only with a zero pivot after an infinite */
/* pivot. In that case, substituting 1 for T/DPLUS is the */
/* correct limit. */
if (sawnan) {
neg1 = 0;
t = bsav;
/* Computing MIN */
i__3 = bj + 127, i__4 = *r__ - 1;
i__2 = min(i__3,i__4);
for (j = bj; j <= i__2; ++j) {
dplus = d__[j] + t;
if (dplus < 0.f) {
++neg1;
}
tmp = t / dplus;
if (sisnan_(&tmp)) {
tmp = 1.f;
}
t = tmp * lld[j] - *sigma;
/* L22: */
}
}
negcnt += neg1;
/* L210: */
}
/* II) lower part: L D L^T - SIGMA I = U- D- U-^T */
p = d__[*n] - *sigma;
i__1 = *r__;
for (bj = *n - 1; bj >= i__1; bj += -128) {
neg2 = 0;
bsav = p;
/* Computing MAX */
i__3 = bj - 127;
i__2 = max(i__3,*r__);
for (j = bj; j >= i__2; --j) {
dminus = lld[j] + p;
if (dminus < 0.f) {
++neg2;
}
tmp = p / dminus;
p = tmp * d__[j] - *sigma;
/* L23: */
}
sawnan = sisnan_(&p);
/* As above, run a slower version that substitutes 1 for Inf/Inf. */
if (sawnan) {
neg2 = 0;
p = bsav;
/* Computing MAX */
i__3 = bj - 127;
i__2 = max(i__3,*r__);
for (j = bj; j >= i__2; --j) {
dminus = lld[j] + p;
if (dminus < 0.f) {
++neg2;
}
tmp = p / dminus;
if (sisnan_(&tmp)) {
tmp = 1.f;
}
p = tmp * d__[j] - *sigma;
/* L24: */
}
}
negcnt += neg2;
/* L230: */
}
/* III) Twist index */
/* T was shifted by SIGMA initially. */
gamma = t + *sigma + p;
if (gamma < 0.f) {
++negcnt;
}
ret_val = negcnt;
return ret_val;
} /* slaneg_ */
/* Subroutine */ int slasq3_(integer *i0, integer *n0, real *z__, integer *pp,
real *dmin__, real *sigma, real *desig, real *qmax, integer *nfail,
integer *iter, integer *ndiv, logical *ieee, integer *ttype, real *
dmin1, real *dmin2, real *dn, real *dn1, real *dn2, real *g, real *
tau)
{
/* System generated locals */
integer i__1;
real r__1, r__2;
/* Builtin functions */
double sqrt(doublereal);
/* Local variables */
real s, t;
integer j4, nn;
real eps, tol;
integer n0in, ipn4;
real tol2, temp;
extern /* Subroutine */ int slasq4_(integer *, integer *, real *, integer
*, integer *, real *, real *, real *, real *, real *, real *,
real *, integer *, real *), slasq5_(integer *, integer *, real *,
integer *, real *, real *, real *, real *, real *, real *, real *,
logical *), slasq6_(integer *, integer *, real *, integer *,
real *, real *, real *, real *, real *, real *);
extern doublereal slamch_(char *);
extern logical sisnan_(real *);
/* -- LAPACK routine (version 3.2) -- */
/* -- Contributed by Osni Marques of the Lawrence Berkeley National -- */
/* -- Laboratory and Beresford Parlett of the Univ. of California at -- */
/* -- Berkeley -- */
/* -- November 2008 -- */
/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */
/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* SLASQ3 checks for deflation, computes a shift (TAU) and calls dqds. */
/* In case of failure it changes shifts, and tries again until output */
/* is positive. */
/* Arguments */
/* ========= */
/* I0 (input) INTEGER */
/* First index. */
/* N0 (input) INTEGER */
/* Last index. */
/* Z (input) REAL array, dimension ( 4*N ) */
/* Z holds the qd array. */
/* PP (input/output) INTEGER */
/* PP=0 for ping, PP=1 for pong. */
/* PP=2 indicates that flipping was applied to the Z array */
/* and that the initial tests for deflation should not be */
/* performed. */
/* DMIN (output) REAL */
/* Minimum value of d. */
/* SIGMA (output) REAL */
/* Sum of shifts used in current segment. */
/* DESIG (input/output) REAL */
/* Lower order part of SIGMA */
/* QMAX (input) REAL */
/* Maximum value of q. */
/* NFAIL (output) INTEGER */
/* Number of times shift was too big. */
/* ITER (output) INTEGER */
/* Number of iterations. */
/* NDIV (output) INTEGER */
/* Number of divisions. */
/* IEEE (input) LOGICAL */
/* Flag for IEEE or non IEEE arithmetic (passed to SLASQ5). */
/* TTYPE (input/output) INTEGER */
/* Shift type. */
/* DMIN1, DMIN2, DN, DN1, DN2, G, TAU (input/output) REAL */
/* These are passed as arguments in order to save their values */
/* between calls to SLASQ3. */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. External Function .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Executable Statements .. */
/* Parameter adjustments */
--z__;
/* Function Body */
n0in = *n0;
eps = slamch_("Precision");
tol = eps * 100.f;
/* Computing 2nd power */
r__1 = tol;
tol2 = r__1 * r__1;
/* Check for deflation. */
L10:
if (*n0 < *i0) {
return 0;
}
if (*n0 == *i0) {
goto L20;
}
nn = (*n0 << 2) + *pp;
if (*n0 == *i0 + 1) {
goto L40;
}
/* Check whether E(N0-1) is negligible, 1 eigenvalue. */
if (z__[nn - 5] > tol2 * (*sigma + z__[nn - 3]) && z__[nn - (*pp << 1) -
4] > tol2 * z__[nn - 7]) {
goto L30;
}
L20:
z__[(*n0 << 2) - 3] = z__[(*n0 << 2) + *pp - 3] + *sigma;
--(*n0);
goto L10;
/* Check whether E(N0-2) is negligible, 2 eigenvalues. */
L30:
if (z__[nn - 9] > tol2 * *sigma && z__[nn - (*pp << 1) - 8] > tol2 * z__[
nn - 11]) {
goto L50;
}
L40:
if (z__[nn - 3] > z__[nn - 7]) {
s = z__[nn - 3];
z__[nn - 3] = z__[nn - 7];
z__[nn - 7] = s;
}
if (z__[nn - 5] > z__[nn - 3] * tol2) {
t = (z__[nn - 7] - z__[nn - 3] + z__[nn - 5]) * .5f;
s = z__[nn - 3] * (z__[nn - 5] / t);
if (s <= t) {
s = z__[nn - 3] * (z__[nn - 5] / (t * (sqrt(s / t + 1.f) + 1.f)));
} else {
s = z__[nn - 3] * (z__[nn - 5] / (t + sqrt(t) * sqrt(t + s)));
}
t = z__[nn - 7] + (s + z__[nn - 5]);
z__[nn - 3] *= z__[nn - 7] / t;
z__[nn - 7] = t;
}
z__[(*n0 << 2) - 7] = z__[nn - 7] + *sigma;
z__[(*n0 << 2) - 3] = z__[nn - 3] + *sigma;
*n0 += -2;
goto L10;
L50:
if (*pp == 2) {
*pp = 0;
}
/* Reverse the qd-array, if warranted. */
if (*dmin__ <= 0.f || *n0 < n0in) {
if (z__[(*i0 << 2) + *pp - 3] * 1.5f < z__[(*n0 << 2) + *pp - 3]) {
ipn4 = *i0 + *n0 << 2;
i__1 = *i0 + *n0 - 1 << 1;
for (j4 = *i0 << 2; j4 <= i__1; j4 += 4) {
temp = z__[j4 - 3];
z__[j4 - 3] = z__[ipn4 - j4 - 3];
z__[ipn4 - j4 - 3] = temp;
temp = z__[j4 - 2];
z__[j4 - 2] = z__[ipn4 - j4 - 2];
z__[ipn4 - j4 - 2] = temp;
temp = z__[j4 - 1];
z__[j4 - 1] = z__[ipn4 - j4 - 5];
z__[ipn4 - j4 - 5] = temp;
temp = z__[j4];
z__[j4] = z__[ipn4 - j4 - 4];
z__[ipn4 - j4 - 4] = temp;
/* L60: */
}
if (*n0 - *i0 <= 4) {
z__[(*n0 << 2) + *pp - 1] = z__[(*i0 << 2) + *pp - 1];
z__[(*n0 << 2) - *pp] = z__[(*i0 << 2) - *pp];
}
/* Computing MIN */
r__1 = *dmin2, r__2 = z__[(*n0 << 2) + *pp - 1];
*dmin2 = dmin(r__1,r__2);
/* Computing MIN */
r__1 = z__[(*n0 << 2) + *pp - 1], r__2 = z__[(*i0 << 2) + *pp - 1]
, r__1 = min(r__1,r__2), r__2 = z__[(*i0 << 2) + *pp + 3];
z__[(*n0 << 2) + *pp - 1] = dmin(r__1,r__2);
/* Computing MIN */
r__1 = z__[(*n0 << 2) - *pp], r__2 = z__[(*i0 << 2) - *pp], r__1 =
min(r__1,r__2), r__2 = z__[(*i0 << 2) - *pp + 4];
z__[(*n0 << 2) - *pp] = dmin(r__1,r__2);
/* Computing MAX */
r__1 = *qmax, r__2 = z__[(*i0 << 2) + *pp - 3], r__1 = max(r__1,
r__2), r__2 = z__[(*i0 << 2) + *pp + 1];
*qmax = dmax(r__1,r__2);
*dmin__ = -0.f;
}
}
/* Choose a shift. */
slasq4_(i0, n0, &z__[1], pp, &n0in, dmin__, dmin1, dmin2, dn, dn1, dn2,
tau, ttype, g);
/* Call dqds until DMIN > 0. */
L70:
slasq5_(i0, n0, &z__[1], pp, tau, dmin__, dmin1, dmin2, dn, dn1, dn2,
ieee);
*ndiv += *n0 - *i0 + 2;
++(*iter);
/* Check status. */
if (*dmin__ >= 0.f && *dmin1 > 0.f) {
/* Success. */
goto L90;
} else if (*dmin__ < 0.f && *dmin1 > 0.f && z__[(*n0 - 1 << 2) - *pp] <
tol * (*sigma + *dn1) && dabs(*dn) < tol * *sigma) {
/* Convergence hidden by negative DN. */
z__[(*n0 - 1 << 2) - *pp + 2] = 0.f;
*dmin__ = 0.f;
goto L90;
} else if (*dmin__ < 0.f) {
/* TAU too big. Select new TAU and try again. */
++(*nfail);
if (*ttype < -22) {
/* Failed twice. Play it safe. */
*tau = 0.f;
} else if (*dmin1 > 0.f) {
/* Late failure. Gives excellent shift. */
*tau = (*tau + *dmin__) * (1.f - eps * 2.f);
*ttype += -11;
} else {
/* Early failure. Divide by 4. */
*tau *= .25f;
*ttype += -12;
}
goto L70;
} else if (sisnan_(dmin__)) {
/* NaN. */
if (*tau == 0.f) {
goto L80;
} else {
*tau = 0.f;
goto L70;
}
} else {
/* Possible underflow. Play it safe. */
goto L80;
}
/* Risk of underflow. */
L80:
slasq6_(i0, n0, &z__[1], pp, dmin__, dmin1, dmin2, dn, dn1, dn2);
*ndiv += *n0 - *i0 + 2;
++(*iter);
*tau = 0.f;
L90:
if (*tau < *sigma) {
*desig += *tau;
t = *sigma + *desig;
*desig -= t - *sigma;
} else {
t = *sigma + *tau;
*desig = *sigma - (t - *tau) + *desig;
}
*sigma = t;
return 0;
/* End of SLASQ3 */
} /* slasq3_ */
/* ===================================================================== */
real slantp_(char *norm, char *uplo, char *diag, integer *n, real *ap, real * work)
{
/* System generated locals */
integer i__1, i__2;
real ret_val, r__1;
/* Builtin functions */
double sqrt(doublereal);
/* Local variables */
integer i__, j, k;
real sum, scale;
logical udiag;
extern logical lsame_(char *, char *);
real value;
extern logical sisnan_(real *);
extern /* Subroutine */
int slassq_(integer *, real *, integer *, real *, real *);
/* -- LAPACK auxiliary 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 Subroutines .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Executable Statements .. */
/* Parameter adjustments */
--work;
--ap;
/* Function Body */
if (*n == 0)
{
value = 0.f;
}
else if (lsame_(norm, "M"))
{
/* Find max(f2c_abs(A(i,j))). */
k = 1;
if (lsame_(diag, "U"))
{
value = 1.f;
if (lsame_(uplo, "U"))
{
i__1 = *n;
for (j = 1;
j <= i__1;
++j)
{
i__2 = k + j - 2;
for (i__ = k;
i__ <= i__2;
++i__)
{
sum = (r__1 = ap[i__], f2c_abs(r__1));
if (value < sum || sisnan_(&sum))
{
value = sum;
}
/* L10: */
}
k += j;
/* L20: */
}
}
else
{
i__1 = *n;
for (j = 1;
j <= i__1;
++j)
{
i__2 = k + *n - j;
for (i__ = k + 1;
i__ <= i__2;
++i__)
{
sum = (r__1 = ap[i__], f2c_abs(r__1));
if (value < sum || sisnan_(&sum))
{
value = sum;
}
/* L30: */
}
k = k + *n - j + 1;
/* L40: */
}
}
}
else
{
value = 0.f;
if (lsame_(uplo, "U"))
{
i__1 = *n;
for (j = 1;
j <= i__1;
++j)
{
i__2 = k + j - 1;
for (i__ = k;
i__ <= i__2;
++i__)
{
sum = (r__1 = ap[i__], f2c_abs(r__1));
if (value < sum || sisnan_(&sum))
{
value = sum;
}
/* L50: */
}
k += j;
/* L60: */
}
}
else
{
i__1 = *n;
for (j = 1;
j <= i__1;
++j)
{
i__2 = k + *n - j;
for (i__ = k;
i__ <= i__2;
++i__)
{
sum = (r__1 = ap[i__], f2c_abs(r__1));
if (value < sum || sisnan_(&sum))
{
value = sum;
}
/* L70: */
}
k = k + *n - j + 1;
/* L80: */
}
}
}
}
else if (lsame_(norm, "O") || *(unsigned char *) norm == '1')
{
/* Find norm1(A). */
value = 0.f;
k = 1;
udiag = lsame_(diag, "U");
if (lsame_(uplo, "U"))
{
i__1 = *n;
for (j = 1;
j <= i__1;
++j)
{
if (udiag)
{
sum = 1.f;
i__2 = k + j - 2;
for (i__ = k;
i__ <= i__2;
++i__)
{
sum += (r__1 = ap[i__], f2c_abs(r__1));
/* L90: */
}
}
else
{
sum = 0.f;
i__2 = k + j - 1;
for (i__ = k;
i__ <= i__2;
++i__)
{
sum += (r__1 = ap[i__], f2c_abs(r__1));
/* L100: */
}
}
k += j;
if (value < sum || sisnan_(&sum))
{
value = sum;
}
/* L110: */
}
}
else
{
i__1 = *n;
for (j = 1;
j <= i__1;
++j)
{
if (udiag)
{
sum = 1.f;
i__2 = k + *n - j;
for (i__ = k + 1;
i__ <= i__2;
++i__)
{
sum += (r__1 = ap[i__], f2c_abs(r__1));
/* L120: */
}
}
else
{
sum = 0.f;
i__2 = k + *n - j;
for (i__ = k;
i__ <= i__2;
++i__)
{
sum += (r__1 = ap[i__], f2c_abs(r__1));
/* L130: */
}
}
k = k + *n - j + 1;
if (value < sum || sisnan_(&sum))
{
value = sum;
}
/* L140: */
}
}
}
else if (lsame_(norm, "I"))
{
/* Find normI(A). */
k = 1;
if (lsame_(uplo, "U"))
{
if (lsame_(diag, "U"))
{
i__1 = *n;
for (i__ = 1;
i__ <= i__1;
++i__)
{
work[i__] = 1.f;
/* L150: */
}
i__1 = *n;
for (j = 1;
j <= i__1;
++j)
{
i__2 = j - 1;
for (i__ = 1;
i__ <= i__2;
++i__)
{
work[i__] += (r__1 = ap[k], f2c_abs(r__1));
++k;
/* L160: */
}
++k;
/* L170: */
}
}
else
{
i__1 = *n;
for (i__ = 1;
i__ <= i__1;
++i__)
{
work[i__] = 0.f;
/* L180: */
}
i__1 = *n;
for (j = 1;
j <= i__1;
++j)
{
i__2 = j;
for (i__ = 1;
i__ <= i__2;
++i__)
{
work[i__] += (r__1 = ap[k], f2c_abs(r__1));
++k;
/* L190: */
}
/* L200: */
}
}
}
else
{
if (lsame_(diag, "U"))
{
i__1 = *n;
for (i__ = 1;
i__ <= i__1;
++i__)
{
work[i__] = 1.f;
/* L210: */
}
i__1 = *n;
for (j = 1;
j <= i__1;
++j)
{
++k;
i__2 = *n;
for (i__ = j + 1;
i__ <= i__2;
++i__)
{
work[i__] += (r__1 = ap[k], f2c_abs(r__1));
++k;
/* L220: */
}
/* L230: */
}
}
else
{
i__1 = *n;
for (i__ = 1;
i__ <= i__1;
++i__)
{
work[i__] = 0.f;
/* L240: */
}
i__1 = *n;
for (j = 1;
j <= i__1;
++j)
{
i__2 = *n;
for (i__ = j;
i__ <= i__2;
++i__)
{
work[i__] += (r__1 = ap[k], f2c_abs(r__1));
++k;
/* L250: */
}
/* L260: */
}
}
}
value = 0.f;
i__1 = *n;
for (i__ = 1;
i__ <= i__1;
++i__)
{
sum = work[i__];
if (value < sum || sisnan_(&sum))
{
value = sum;
}
/* L270: */
}
}
else if (lsame_(norm, "F") || lsame_(norm, "E"))
{
/* Find normF(A). */
if (lsame_(uplo, "U"))
{
if (lsame_(diag, "U"))
{
scale = 1.f;
sum = (real) (*n);
k = 2;
i__1 = *n;
for (j = 2;
j <= i__1;
++j)
{
i__2 = j - 1;
slassq_(&i__2, &ap[k], &c__1, &scale, &sum);
k += j;
/* L280: */
}
}
else
{
scale = 0.f;
sum = 1.f;
k = 1;
i__1 = *n;
for (j = 1;
j <= i__1;
++j)
{
slassq_(&j, &ap[k], &c__1, &scale, &sum);
k += j;
/* L290: */
}
}
}
else
{
if (lsame_(diag, "U"))
{
scale = 1.f;
sum = (real) (*n);
k = 2;
i__1 = *n - 1;
for (j = 1;
j <= i__1;
++j)
{
i__2 = *n - j;
slassq_(&i__2, &ap[k], &c__1, &scale, &sum);
k = k + *n - j + 1;
/* L300: */
}
}
else
{
scale = 0.f;
sum = 1.f;
k = 1;
i__1 = *n;
for (j = 1;
j <= i__1;
++j)
{
i__2 = *n - j + 1;
slassq_(&i__2, &ap[k], &c__1, &scale, &sum);
k = k + *n - j + 1;
/* L310: */
}
}
}
value = scale * sqrt(sum);
}
ret_val = value;
return ret_val;
/* End of SLANTP */
}
/* ===================================================================== */
real slanst_(char *norm, integer *n, real *d__, real *e)
{
/* System generated locals */
integer i__1;
real ret_val, r__1, r__2, r__3;
/* Builtin functions */
double sqrt(doublereal);
/* Local variables */
integer i__;
real sum, scale;
extern logical lsame_(char *, char *);
real anorm;
extern logical sisnan_(real *);
extern /* Subroutine */
int slassq_(integer *, real *, integer *, real *, real *);
/* -- LAPACK auxiliary 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 .. */
/* Parameter adjustments */
--e;
--d__;
/* Function Body */
if (*n <= 0)
{
anorm = 0.f;
}
else if (lsame_(norm, "M"))
{
/* Find max(f2c_abs(A(i,j))). */
anorm = (r__1 = d__[*n], f2c_abs(r__1));
i__1 = *n - 1;
for (i__ = 1;
i__ <= i__1;
++i__)
{
sum = (r__1 = d__[i__], f2c_abs(r__1));
if (anorm < sum || sisnan_(&sum))
{
anorm = sum;
}
sum = (r__1 = e[i__], f2c_abs(r__1));
if (anorm < sum || sisnan_(&sum))
{
anorm = sum;
}
/* L10: */
}
}
else if (lsame_(norm, "O") || *(unsigned char *) norm == '1' || lsame_(norm, "I"))
{
/* Find norm1(A). */
if (*n == 1)
{
anorm = f2c_abs(d__[1]);
}
else
{
anorm = f2c_abs(d__[1]) + f2c_abs(e[1]);
sum = (r__1 = e[*n - 1], f2c_abs(r__1)) + (r__2 = d__[*n], f2c_abs(r__2));
if (anorm < sum || sisnan_(&sum))
{
anorm = sum;
}
i__1 = *n - 1;
for (i__ = 2;
i__ <= i__1;
++i__)
{
sum = (r__1 = d__[i__], f2c_abs(r__1)) + (r__2 = e[i__], f2c_abs(r__2) ) + (r__3 = e[i__ - 1], f2c_abs(r__3));
if (anorm < sum || sisnan_(&sum))
{
anorm = sum;
}
/* L20: */
}
}
}
else if (lsame_(norm, "F") || lsame_(norm, "E"))
{
/* Find normF(A). */
scale = 0.f;
sum = 1.f;
if (*n > 1)
{
i__1 = *n - 1;
slassq_(&i__1, &e[1], &c__1, &scale, &sum);
sum *= 2;
}
slassq_(n, &d__[1], &c__1, &scale, &sum);
anorm = scale * sqrt(sum);
}
ret_val = anorm;
return ret_val;
/* End of SLANST */
}
/* ===================================================================== */
real slangb_(char *norm, integer *n, integer *kl, integer *ku, real *ab, integer *ldab, real *work)
{
/* System generated locals */
integer ab_dim1, ab_offset, i__1, i__2, i__3, i__4, i__5, i__6;
real ret_val, r__1;
/* Builtin functions */
double sqrt(doublereal);
/* Local variables */
integer i__, j, k, l;
real sum, temp, scale;
extern logical lsame_(char *, char *);
real value;
extern logical sisnan_(real *);
extern /* Subroutine */
int slassq_(integer *, real *, integer *, real *, real *);
/* -- LAPACK auxiliary 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 Subroutines .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Executable Statements .. */
/* Parameter adjustments */
ab_dim1 = *ldab;
ab_offset = 1 + ab_dim1;
ab -= ab_offset;
--work;
/* Function Body */
if (*n == 0)
{
value = 0.f;
}
else if (lsame_(norm, "M"))
{
/* Find max(abs(A(i,j))). */
value = 0.f;
i__1 = *n;
for (j = 1;
j <= i__1;
++j)
{
/* Computing MAX */
i__2 = *ku + 2 - j;
/* Computing MIN */
i__4 = *n + *ku + 1 - j;
i__5 = *kl + *ku + 1; // , expr subst
i__3 = min(i__4,i__5);
for (i__ = max(i__2,1);
i__ <= i__3;
++i__)
{
temp = (r__1 = ab[i__ + j * ab_dim1], abs(r__1));
if (value < temp || sisnan_(&temp))
{
value = temp;
}
/* L10: */
}
/* L20: */
}
}
else if (lsame_(norm, "O") || *(unsigned char *) norm == '1')
{
/* Find norm1(A). */
value = 0.f;
i__1 = *n;
for (j = 1;
j <= i__1;
++j)
{
sum = 0.f;
/* Computing MAX */
i__3 = *ku + 2 - j;
/* Computing MIN */
i__4 = *n + *ku + 1 - j;
i__5 = *kl + *ku + 1; // , expr subst
i__2 = min(i__4,i__5);
for (i__ = max(i__3,1);
i__ <= i__2;
++i__)
{
sum += (r__1 = ab[i__ + j * ab_dim1], abs(r__1));
/* L30: */
}
if (value < sum || sisnan_(&sum))
{
value = sum;
}
/* L40: */
}
}
else if (lsame_(norm, "I"))
{
/* Find normI(A). */
i__1 = *n;
for (i__ = 1;
i__ <= i__1;
++i__)
{
work[i__] = 0.f;
/* L50: */
}
i__1 = *n;
for (j = 1;
j <= i__1;
++j)
{
k = *ku + 1 - j;
/* Computing MAX */
i__2 = 1;
i__3 = j - *ku; // , expr subst
/* Computing MIN */
i__5 = *n;
i__6 = j + *kl; // , expr subst
i__4 = min(i__5,i__6);
for (i__ = max(i__2,i__3);
i__ <= i__4;
++i__)
{
work[i__] += (r__1 = ab[k + i__ + j * ab_dim1], abs(r__1));
/* L60: */
}
/* L70: */
}
value = 0.f;
i__1 = *n;
for (i__ = 1;
i__ <= i__1;
++i__)
{
temp = work[i__];
if (value < temp || sisnan_(&temp))
{
value = temp;
}
/* L80: */
}
}
else if (lsame_(norm, "F") || lsame_(norm, "E"))
{
/* Find normF(A). */
scale = 0.f;
sum = 1.f;
i__1 = *n;
for (j = 1;
j <= i__1;
++j)
{
/* Computing MAX */
i__4 = 1;
i__2 = j - *ku; // , expr subst
l = max(i__4,i__2);
k = *ku + 1 - j + l;
/* Computing MIN */
i__2 = *n;
i__3 = j + *kl; // , expr subst
i__4 = min(i__2,i__3) - l + 1;
slassq_(&i__4, &ab[k + j * ab_dim1], &c__1, &scale, &sum);
/* L90: */
}
value = scale * sqrt(sum);
}
ret_val = value;
return ret_val;
/* End of SLANGB */
}
/* Subroutine */ int slarrf_(integer *n, real *d__, real *l, real *ld,
integer *clstrt, integer *clend, real *w, real *wgap, real *werr,
real *spdiam, real *clgapl, real *clgapr, real *pivmin, real *sigma,
real *dplus, real *lplus, real *work, integer *info)
{
/* System generated locals */
integer i__1;
real r__1, r__2, r__3;
/* Builtin functions */
double sqrt(doublereal);
/* Local variables */
integer i__;
real s, bestshift, smlgrowth, eps, tmp, max1, max2, rrr1, rrr2, znm2,
growthbound, fail, fact, oldp;
integer indx;
real prod;
integer ktry;
real fail2, avgap, ldmax, rdmax;
integer shift;
extern /* Subroutine */ int scopy_(integer *, real *, integer *, real *,
integer *);
logical dorrr1;
real ldelta;
extern doublereal slamch_(char *);
logical nofail;
real mingap, lsigma, rdelta;
logical forcer;
real rsigma, clwdth;
extern logical sisnan_(real *);
logical sawnan1, sawnan2, tryrrr1;
/* -- LAPACK auxiliary routine (version 3.2) -- */
/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/* November 2006 */
/* * */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* Given the initial representation L D L^T and its cluster of close */
/* eigenvalues (in a relative measure), W( CLSTRT ), W( CLSTRT+1 ), ... */
/* W( CLEND ), SLARRF finds a new relatively robust representation */
/* L D L^T - SIGMA I = L(+) D(+) L(+)^T such that at least one of the */
/* eigenvalues of L(+) D(+) L(+)^T is relatively isolated. */
/* Arguments */
/* ========= */
/* N (input) INTEGER */
/* The order of the matrix (subblock, if the matrix splitted). */
/* D (input) REAL array, dimension (N) */
/* The N diagonal elements of the diagonal matrix D. */
/* L (input) REAL array, dimension (N-1) */
/* The (N-1) subdiagonal elements of the unit bidiagonal */
/* matrix L. */
/* LD (input) REAL array, dimension (N-1) */
/* The (N-1) elements L(i)*D(i). */
/* CLSTRT (input) INTEGER */
/* The index of the first eigenvalue in the cluster. */
/* CLEND (input) INTEGER */
/* The index of the last eigenvalue in the cluster. */
/* W (input) REAL array, dimension >= (CLEND-CLSTRT+1) */
/* The eigenvalue APPROXIMATIONS of L D L^T in ascending order. */
/* W( CLSTRT ) through W( CLEND ) form the cluster of relatively */
/* close eigenalues. */
/* WGAP (input/output) REAL array, dimension >= (CLEND-CLSTRT+1) */
/* The separation from the right neighbor eigenvalue in W. */
/* WERR (input) REAL array, dimension >= (CLEND-CLSTRT+1) */
/* WERR contain the semiwidth of the uncertainty */
/* interval of the corresponding eigenvalue APPROXIMATION in W */
/* SPDIAM (input) estimate of the spectral diameter obtained from the */
/* Gerschgorin intervals */
/* CLGAPL, CLGAPR (input) absolute gap on each end of the cluster. */
/* Set by the calling routine to protect against shifts too close */
/* to eigenvalues outside the cluster. */
/* PIVMIN (input) DOUBLE PRECISION */
/* The minimum pivot allowed in the Sturm sequence. */
/* SIGMA (output) REAL */
/* The shift used to form L(+) D(+) L(+)^T. */
/* DPLUS (output) REAL array, dimension (N) */
/* The N diagonal elements of the diagonal matrix D(+). */
/* LPLUS (output) REAL array, dimension (N-1) */
/* The first (N-1) elements of LPLUS contain the subdiagonal */
/* elements of the unit bidiagonal matrix L(+). */
/* WORK (workspace) REAL array, dimension (2*N) */
/* Workspace. */
/* 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 .. */
/* Parameter adjustments */
--work;
--lplus;
--dplus;
--werr;
--wgap;
--w;
--ld;
--l;
--d__;
/* Function Body */
*info = 0;
fact = 2.f;
eps = slamch_("Precision");
shift = 0;
forcer = FALSE_;
/* Note that we cannot guarantee that for any of the shifts tried, */
/* the factorization has a small or even moderate element growth. */
/* There could be Ritz values at both ends of the cluster and despite */
/* backing off, there are examples where all factorizations tried */
/* (in IEEE mode, allowing zero pivots & infinities) have INFINITE */
/* element growth. */
/* For this reason, we should use PIVMIN in this subroutine so that at */
/* least the L D L^T factorization exists. It can be checked afterwards */
/* whether the element growth caused bad residuals/orthogonality. */
/* Decide whether the code should accept the best among all */
/* representations despite large element growth or signal INFO=1 */
nofail = TRUE_;
/* Compute the average gap length of the cluster */
clwdth = (r__1 = w[*clend] - w[*clstrt], dabs(r__1)) + werr[*clend] +
werr[*clstrt];
avgap = clwdth / (real) (*clend - *clstrt);
mingap = dmin(*clgapl,*clgapr);
/* Initial values for shifts to both ends of cluster */
/* Computing MIN */
r__1 = w[*clstrt], r__2 = w[*clend];
lsigma = dmin(r__1,r__2) - werr[*clstrt];
/* Computing MAX */
r__1 = w[*clstrt], r__2 = w[*clend];
rsigma = dmax(r__1,r__2) + werr[*clend];
/* Use a small fudge to make sure that we really shift to the outside */
lsigma -= dabs(lsigma) * 2.f * eps;
rsigma += dabs(rsigma) * 2.f * eps;
/* Compute upper bounds for how much to back off the initial shifts */
ldmax = mingap * .25f + *pivmin * 2.f;
rdmax = mingap * .25f + *pivmin * 2.f;
/* Computing MAX */
r__1 = avgap, r__2 = wgap[*clstrt];
ldelta = dmax(r__1,r__2) / fact;
/* Computing MAX */
r__1 = avgap, r__2 = wgap[*clend - 1];
rdelta = dmax(r__1,r__2) / fact;
/* Initialize the record of the best representation found */
s = slamch_("S");
smlgrowth = 1.f / s;
fail = (real) (*n - 1) * mingap / (*spdiam * eps);
fail2 = (real) (*n - 1) * mingap / (*spdiam * sqrt(eps));
bestshift = lsigma;
/* while (KTRY <= KTRYMAX) */
ktry = 0;
growthbound = *spdiam * 8.f;
L5:
sawnan1 = FALSE_;
sawnan2 = FALSE_;
/* Ensure that we do not back off too much of the initial shifts */
ldelta = dmin(ldmax,ldelta);
rdelta = dmin(rdmax,rdelta);
/* Compute the element growth when shifting to both ends of the cluster */
/* accept the shift if there is no element growth at one of the two ends */
/* Left end */
s = -lsigma;
dplus[1] = d__[1] + s;
if (dabs(dplus[1]) < *pivmin) {
dplus[1] = -(*pivmin);
/* Need to set SAWNAN1 because refined RRR test should not be used */
/* in this case */
sawnan1 = TRUE_;
}
max1 = dabs(dplus[1]);
i__1 = *n - 1;
for (i__ = 1; i__ <= i__1; ++i__) {
lplus[i__] = ld[i__] / dplus[i__];
s = s * lplus[i__] * l[i__] - lsigma;
dplus[i__ + 1] = d__[i__ + 1] + s;
if ((r__1 = dplus[i__ + 1], dabs(r__1)) < *pivmin) {
dplus[i__ + 1] = -(*pivmin);
/* Need to set SAWNAN1 because refined RRR test should not be used */
/* in this case */
sawnan1 = TRUE_;
}
/* Computing MAX */
r__2 = max1, r__3 = (r__1 = dplus[i__ + 1], dabs(r__1));
max1 = dmax(r__2,r__3);
/* L6: */
}
sawnan1 = sawnan1 || sisnan_(&max1);
if (forcer || max1 <= growthbound && ! sawnan1) {
*sigma = lsigma;
shift = 1;
goto L100;
}
/* Right end */
s = -rsigma;
work[1] = d__[1] + s;
if (dabs(work[1]) < *pivmin) {
work[1] = -(*pivmin);
/* Need to set SAWNAN2 because refined RRR test should not be used */
/* in this case */
sawnan2 = TRUE_;
}
max2 = dabs(work[1]);
i__1 = *n - 1;
for (i__ = 1; i__ <= i__1; ++i__) {
work[*n + i__] = ld[i__] / work[i__];
s = s * work[*n + i__] * l[i__] - rsigma;
work[i__ + 1] = d__[i__ + 1] + s;
if ((r__1 = work[i__ + 1], dabs(r__1)) < *pivmin) {
work[i__ + 1] = -(*pivmin);
/* Need to set SAWNAN2 because refined RRR test should not be used */
/* in this case */
sawnan2 = TRUE_;
}
/* Computing MAX */
r__2 = max2, r__3 = (r__1 = work[i__ + 1], dabs(r__1));
max2 = dmax(r__2,r__3);
/* L7: */
}
sawnan2 = sawnan2 || sisnan_(&max2);
if (forcer || max2 <= growthbound && ! sawnan2) {
*sigma = rsigma;
shift = 2;
goto L100;
}
/* If we are at this point, both shifts led to too much element growth */
/* Record the better of the two shifts (provided it didn't lead to NaN) */
if (sawnan1 && sawnan2) {
/* both MAX1 and MAX2 are NaN */
goto L50;
} else {
if (! sawnan1) {
indx = 1;
if (max1 <= smlgrowth) {
smlgrowth = max1;
bestshift = lsigma;
}
}
if (! sawnan2) {
if (sawnan1 || max2 <= max1) {
indx = 2;
}
if (max2 <= smlgrowth) {
smlgrowth = max2;
bestshift = rsigma;
}
}
}
/* If we are here, both the left and the right shift led to */
/* element growth. If the element growth is moderate, then */
/* we may still accept the representation, if it passes a */
/* refined test for RRR. This test supposes that no NaN occurred. */
/* Moreover, we use the refined RRR test only for isolated clusters. */
if (clwdth < mingap / 128.f && dmin(max1,max2) < fail2 && ! sawnan1 && !
sawnan2) {
dorrr1 = TRUE_;
} else {
dorrr1 = FALSE_;
}
tryrrr1 = TRUE_;
if (tryrrr1 && dorrr1) {
if (indx == 1) {
tmp = (r__1 = dplus[*n], dabs(r__1));
znm2 = 1.f;
prod = 1.f;
oldp = 1.f;
for (i__ = *n - 1; i__ >= 1; --i__) {
if (prod <= eps) {
prod = dplus[i__ + 1] * work[*n + i__ + 1] / (dplus[i__] *
work[*n + i__]) * oldp;
} else {
prod *= (r__1 = work[*n + i__], dabs(r__1));
}
oldp = prod;
/* Computing 2nd power */
r__1 = prod;
znm2 += r__1 * r__1;
/* Computing MAX */
r__2 = tmp, r__3 = (r__1 = dplus[i__] * prod, dabs(r__1));
tmp = dmax(r__2,r__3);
/* L15: */
}
rrr1 = tmp / (*spdiam * sqrt(znm2));
if (rrr1 <= 8.f) {
*sigma = lsigma;
shift = 1;
goto L100;
}
} else if (indx == 2) {
tmp = (r__1 = work[*n], dabs(r__1));
znm2 = 1.f;
prod = 1.f;
oldp = 1.f;
for (i__ = *n - 1; i__ >= 1; --i__) {
if (prod <= eps) {
prod = work[i__ + 1] * lplus[i__ + 1] / (work[i__] *
lplus[i__]) * oldp;
} else {
prod *= (r__1 = lplus[i__], dabs(r__1));
}
oldp = prod;
/* Computing 2nd power */
r__1 = prod;
znm2 += r__1 * r__1;
/* Computing MAX */
r__2 = tmp, r__3 = (r__1 = work[i__] * prod, dabs(r__1));
tmp = dmax(r__2,r__3);
/* L16: */
}
rrr2 = tmp / (*spdiam * sqrt(znm2));
if (rrr2 <= 8.f) {
*sigma = rsigma;
shift = 2;
goto L100;
}
}
}
L50:
if (ktry < 1) {
/* If we are here, both shifts failed also the RRR test. */
/* Back off to the outside */
/* Computing MAX */
r__1 = lsigma - ldelta, r__2 = lsigma - ldmax;
lsigma = dmax(r__1,r__2);
/* Computing MIN */
r__1 = rsigma + rdelta, r__2 = rsigma + rdmax;
rsigma = dmin(r__1,r__2);
ldelta *= 2.f;
rdelta *= 2.f;
++ktry;
goto L5;
} else {
/* None of the representations investigated satisfied our */
/* criteria. Take the best one we found. */
if (smlgrowth < fail || nofail) {
lsigma = bestshift;
rsigma = bestshift;
forcer = TRUE_;
goto L5;
} else {
*info = 1;
return 0;
}
}
L100:
if (shift == 1) {
} else if (shift == 2) {
/* store new L and D back into DPLUS, LPLUS */
scopy_(n, &work[1], &c__1, &dplus[1], &c__1);
i__1 = *n - 1;
scopy_(&i__1, &work[*n + 1], &c__1, &lplus[1], &c__1);
}
return 0;
/* End of SLARRF */
} /* slarrf_ */
