/* 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_ */