/* ===================================================================== */
doublereal zlantb_(char *norm, char *uplo, char *diag, integer *n, integer *k, doublecomplex *ab, integer *ldab, doublereal *work)
{
/* System generated locals */
integer ab_dim1, ab_offset, i__1, i__2, i__3, i__4, i__5;
doublereal ret_val;
/* Builtin functions */
double z_abs(doublecomplex *), sqrt(doublereal);
/* Local variables */
integer i__, j, l;
doublereal sum, scale;
logical udiag;
extern logical lsame_(char *, char *);
doublereal value;
extern logical disnan_(doublereal *);
extern /* Subroutine */
int zlassq_(integer *, doublecomplex *, integer *, doublereal *, doublereal *);
/* -- 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 */
ab_dim1 = *ldab;
ab_offset = 1 + ab_dim1;
ab -= ab_offset;
--work;
/* Function Body */
if (*n == 0)
{
value = 0.;
}
else if (lsame_(norm, "M"))
{
/* Find max(f2c_abs(A(i,j))). */
if (lsame_(diag, "U"))
{
value = 1.;
if (lsame_(uplo, "U"))
{
i__1 = *n;
for (j = 1;
j <= i__1;
++j)
{
/* Computing MAX */
i__2 = *k + 2 - j;
i__3 = *k;
for (i__ = max(i__2,1);
i__ <= i__3;
++i__)
{
sum = z_abs(&ab[i__ + j * ab_dim1]);
if (value < sum || disnan_(&sum))
{
value = sum;
}
/* L10: */
}
/* L20: */
}
}
else
{
i__1 = *n;
for (j = 1;
j <= i__1;
++j)
{
/* Computing MIN */
i__2 = *n + 1 - j;
i__4 = *k + 1; // , expr subst
i__3 = min(i__2,i__4);
for (i__ = 2;
i__ <= i__3;
++i__)
{
sum = z_abs(&ab[i__ + j * ab_dim1]);
if (value < sum || disnan_(&sum))
{
value = sum;
}
/* L30: */
}
/* L40: */
}
}
}
else
{
value = 0.;
if (lsame_(uplo, "U"))
{
i__1 = *n;
for (j = 1;
j <= i__1;
++j)
{
/* Computing MAX */
i__3 = *k + 2 - j;
i__2 = *k + 1;
for (i__ = max(i__3,1);
i__ <= i__2;
++i__)
{
sum = z_abs(&ab[i__ + j * ab_dim1]);
if (value < sum || disnan_(&sum))
{
value = sum;
}
/* L50: */
}
/* L60: */
}
}
else
{
i__1 = *n;
for (j = 1;
j <= i__1;
++j)
{
/* Computing MIN */
i__3 = *n + 1 - j;
i__4 = *k + 1; // , expr subst
i__2 = min(i__3,i__4);
for (i__ = 1;
i__ <= i__2;
++i__)
{
sum = z_abs(&ab[i__ + j * ab_dim1]);
if (value < sum || disnan_(&sum))
{
value = sum;
}
/* L70: */
}
/* L80: */
}
}
}
}
else if (lsame_(norm, "O") || *(unsigned char *) norm == '1')
{
/* Find norm1(A). */
value = 0.;
udiag = lsame_(diag, "U");
if (lsame_(uplo, "U"))
{
i__1 = *n;
for (j = 1;
j <= i__1;
++j)
{
if (udiag)
{
sum = 1.;
/* Computing MAX */
i__2 = *k + 2 - j;
i__3 = *k;
for (i__ = max(i__2,1);
i__ <= i__3;
++i__)
{
sum += z_abs(&ab[i__ + j * ab_dim1]);
/* L90: */
}
}
else
{
sum = 0.;
/* Computing MAX */
i__3 = *k + 2 - j;
i__2 = *k + 1;
for (i__ = max(i__3,1);
i__ <= i__2;
++i__)
{
sum += z_abs(&ab[i__ + j * ab_dim1]);
/* L100: */
}
}
if (value < sum || disnan_(&sum))
{
value = sum;
}
/* L110: */
}
}
else
{
i__1 = *n;
for (j = 1;
j <= i__1;
++j)
{
if (udiag)
{
sum = 1.;
/* Computing MIN */
i__3 = *n + 1 - j;
i__4 = *k + 1; // , expr subst
i__2 = min(i__3,i__4);
for (i__ = 2;
i__ <= i__2;
++i__)
{
sum += z_abs(&ab[i__ + j * ab_dim1]);
/* L120: */
}
}
else
{
sum = 0.;
/* Computing MIN */
i__3 = *n + 1 - j;
i__4 = *k + 1; // , expr subst
i__2 = min(i__3,i__4);
for (i__ = 1;
i__ <= i__2;
++i__)
{
sum += z_abs(&ab[i__ + j * ab_dim1]);
/* L130: */
}
}
if (value < sum || disnan_(&sum))
{
value = sum;
}
/* L140: */
}
}
}
else if (lsame_(norm, "I"))
{
/* Find normI(A). */
value = 0.;
if (lsame_(uplo, "U"))
{
if (lsame_(diag, "U"))
{
i__1 = *n;
for (i__ = 1;
i__ <= i__1;
++i__)
{
work[i__] = 1.;
/* L150: */
}
i__1 = *n;
for (j = 1;
j <= i__1;
++j)
{
l = *k + 1 - j;
/* Computing MAX */
i__2 = 1;
i__3 = j - *k; // , expr subst
i__4 = j - 1;
for (i__ = max(i__2,i__3);
i__ <= i__4;
++i__)
{
work[i__] += z_abs(&ab[l + i__ + j * ab_dim1]);
/* L160: */
}
/* L170: */
}
}
else
{
i__1 = *n;
for (i__ = 1;
i__ <= i__1;
++i__)
{
work[i__] = 0.;
/* L180: */
}
i__1 = *n;
for (j = 1;
j <= i__1;
++j)
{
l = *k + 1 - j;
/* Computing MAX */
i__4 = 1;
i__2 = j - *k; // , expr subst
i__3 = j;
for (i__ = max(i__4,i__2);
i__ <= i__3;
++i__)
{
work[i__] += z_abs(&ab[l + i__ + j * ab_dim1]);
/* L190: */
}
/* L200: */
}
}
}
else
{
if (lsame_(diag, "U"))
{
i__1 = *n;
for (i__ = 1;
i__ <= i__1;
++i__)
{
work[i__] = 1.;
/* L210: */
}
i__1 = *n;
for (j = 1;
j <= i__1;
++j)
{
l = 1 - j;
/* Computing MIN */
i__4 = *n;
i__2 = j + *k; // , expr subst
i__3 = min(i__4,i__2);
for (i__ = j + 1;
i__ <= i__3;
++i__)
{
work[i__] += z_abs(&ab[l + i__ + j * ab_dim1]);
/* L220: */
}
/* L230: */
}
}
else
{
i__1 = *n;
for (i__ = 1;
i__ <= i__1;
++i__)
{
work[i__] = 0.;
/* L240: */
}
i__1 = *n;
for (j = 1;
j <= i__1;
++j)
{
l = 1 - j;
/* Computing MIN */
i__4 = *n;
i__2 = j + *k; // , expr subst
i__3 = min(i__4,i__2);
for (i__ = j;
i__ <= i__3;
++i__)
{
work[i__] += z_abs(&ab[l + i__ + j * ab_dim1]);
/* L250: */
}
/* L260: */
}
}
}
i__1 = *n;
for (i__ = 1;
i__ <= i__1;
++i__)
{
sum = work[i__];
if (value < sum || disnan_(&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.;
sum = (doublereal) (*n);
if (*k > 0)
{
i__1 = *n;
for (j = 2;
j <= i__1;
++j)
{
/* Computing MIN */
i__4 = j - 1;
i__3 = min(i__4,*k);
/* Computing MAX */
i__2 = *k + 2 - j;
zlassq_(&i__3, &ab[max(i__2,1) + j * ab_dim1], &c__1, &scale, &sum);
/* L280: */
}
}
}
else
{
scale = 0.;
sum = 1.;
i__1 = *n;
for (j = 1;
j <= i__1;
++j)
{
/* Computing MIN */
i__4 = j;
i__2 = *k + 1; // , expr subst
i__3 = min(i__4,i__2);
/* Computing MAX */
i__5 = *k + 2 - j;
zlassq_(&i__3, &ab[max(i__5,1) + j * ab_dim1], &c__1, & scale, &sum);
/* L290: */
}
}
}
else
{
if (lsame_(diag, "U"))
{
scale = 1.;
sum = (doublereal) (*n);
if (*k > 0)
{
i__1 = *n - 1;
for (j = 1;
j <= i__1;
++j)
{
/* Computing MIN */
i__4 = *n - j;
i__3 = min(i__4,*k);
zlassq_(&i__3, &ab[j * ab_dim1 + 2], &c__1, &scale, & sum);
/* L300: */
}
}
}
else
{
scale = 0.;
sum = 1.;
i__1 = *n;
for (j = 1;
j <= i__1;
++j)
{
/* Computing MIN */
i__4 = *n - j + 1;
i__2 = *k + 1; // , expr subst
i__3 = min(i__4,i__2);
zlassq_(&i__3, &ab[j * ab_dim1 + 1], &c__1, &scale, &sum);
/* L310: */
}
}
}
value = scale * sqrt(sum);
}
ret_val = value;
return ret_val;
/* End of ZLANTB */
}
/* Subroutine */ int zhetf2_(char *uplo, integer *n, doublecomplex *a,
integer *lda, integer *ipiv, integer *info)
{
/* System generated locals */
integer a_dim1, a_offset, i__1, i__2, i__3, i__4, i__5, i__6;
doublereal d__1, d__2, d__3, d__4;
doublecomplex z__1, z__2, z__3, z__4, z__5, z__6;
/* Builtin functions */
double sqrt(doublereal), d_imag(doublecomplex *);
void d_cnjg(doublecomplex *, doublecomplex *);
/* Local variables */
doublereal d__;
integer i__, j, k;
doublecomplex t;
doublereal r1, d11;
doublecomplex d12;
doublereal d22;
doublecomplex d21;
integer kk, kp;
doublecomplex wk;
doublereal tt;
doublecomplex wkm1, wkp1;
integer imax, jmax;
extern /* Subroutine */ int zher_(char *, integer *, doublereal *,
doublecomplex *, integer *, doublecomplex *, integer *);
doublereal alpha;
extern logical lsame_(char *, char *);
integer kstep;
logical upper;
extern /* Subroutine */ int zswap_(integer *, doublecomplex *, integer *,
doublecomplex *, integer *);
extern doublereal dlapy2_(doublereal *, doublereal *);
doublereal absakk;
extern logical disnan_(doublereal *);
extern /* Subroutine */ int xerbla_(char *, integer *), zdscal_(
integer *, doublereal *, doublecomplex *, integer *);
doublereal colmax;
extern integer izamax_(integer *, doublecomplex *, integer *);
doublereal rowmax;
/* -- LAPACK routine (version 3.2) -- */
/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/* November 2006 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* ZHETF2 computes the factorization of a complex Hermitian matrix A */
/* using the Bunch-Kaufman diagonal pivoting method: */
/* A = U*D*U' or A = L*D*L' */
/* where U (or L) is a product of permutation and unit upper (lower) */
/* triangular matrices, U' is the conjugate transpose of U, and D is */
/* Hermitian and block diagonal with 1-by-1 and 2-by-2 diagonal blocks. */
/* 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 */
/* Hermitian 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*16 array, dimension (LDA,N) */
/* On entry, the Hermitian 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, the block diagonal matrix D and the multipliers used */
/* to obtain the factor U or L (see below for further details). */
/* LDA (input) INTEGER */
/* The leading dimension of the array A. LDA >= max(1,N). */
/* IPIV (output) INTEGER array, dimension (N) */
/* Details of the interchanges and the block structure of D. */
/* If IPIV(k) > 0, then rows and columns k and IPIV(k) were */
/* interchanged and D(k,k) is a 1-by-1 diagonal block. */
/* If UPLO = 'U' and IPIV(k) = IPIV(k-1) < 0, then rows and */
/* columns k-1 and -IPIV(k) were interchanged and D(k-1:k,k-1:k) */
/* is a 2-by-2 diagonal block. If UPLO = 'L' and IPIV(k) = */
/* IPIV(k+1) < 0, then rows and columns k+1 and -IPIV(k) were */
/* interchanged and D(k:k+1,k:k+1) is a 2-by-2 diagonal block. */
/* INFO (output) INTEGER */
/* = 0: successful exit */
/* < 0: if INFO = -k, the k-th argument had an illegal value */
/* > 0: if INFO = k, D(k,k) is exactly zero. The factorization */
/* has been completed, but the block diagonal matrix D is */
/* exactly singular, and division by zero will occur if it */
/* is used to solve a system of equations. */
/* Further Details */
/* =============== */
/* 09-29-06 - patch from */
/* Bobby Cheng, MathWorks */
/* Replace l.210 and l.393 */
/* IF( MAX( ABSAKK, COLMAX ).EQ.ZERO ) THEN */
/* by */
/* IF( (MAX( ABSAKK, COLMAX ).EQ.ZERO) .OR. DISNAN(ABSAKK) ) THEN */
/* 01-01-96 - Based on modifications by */
/* J. Lewis, Boeing Computer Services Company */
/* A. Petitet, Computer Science Dept., Univ. of Tenn., Knoxville, USA */
/* If UPLO = 'U', then A = U*D*U', where */
/* U = P(n)*U(n)* ... *P(k)U(k)* ..., */
/* i.e., U is a product of terms P(k)*U(k), where k decreases from n to */
/* 1 in steps of 1 or 2, and D is a block diagonal matrix with 1-by-1 */
/* and 2-by-2 diagonal blocks D(k). P(k) is a permutation matrix as */
/* defined by IPIV(k), and U(k) is a unit upper triangular matrix, such */
/* that if the diagonal block D(k) is of order s (s = 1 or 2), then */
/* ( I v 0 ) k-s */
/* U(k) = ( 0 I 0 ) s */
/* ( 0 0 I ) n-k */
/* k-s s n-k */
/* If s = 1, D(k) overwrites A(k,k), and v overwrites A(1:k-1,k). */
/* If s = 2, the upper triangle of D(k) overwrites A(k-1,k-1), A(k-1,k), */
/* and A(k,k), and v overwrites A(1:k-2,k-1:k). */
/* If UPLO = 'L', then A = L*D*L', where */
/* L = P(1)*L(1)* ... *P(k)*L(k)* ..., */
/* i.e., L is a product of terms P(k)*L(k), where k increases from 1 to */
/* n in steps of 1 or 2, and D is a block diagonal matrix with 1-by-1 */
/* and 2-by-2 diagonal blocks D(k). P(k) is a permutation matrix as */
/* defined by IPIV(k), and L(k) is a unit lower triangular matrix, such */
/* that if the diagonal block D(k) is of order s (s = 1 or 2), then */
/* ( I 0 0 ) k-1 */
/* L(k) = ( 0 I 0 ) s */
/* ( 0 v I ) n-k-s+1 */
/* k-1 s n-k-s+1 */
/* If s = 1, D(k) overwrites A(k,k), and v overwrites A(k+1:n,k). */
/* If s = 2, the lower triangle of D(k) overwrites A(k,k), A(k+1,k), */
/* and A(k+1,k+1), and v overwrites A(k+2:n,k:k+1). */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Statement Functions .. */
/* .. */
/* .. Statement Function definitions .. */
/* .. */
/* .. Executable Statements .. */
/* Test the input parameters. */
/* Parameter adjustments */
a_dim1 = *lda;
a_offset = 1 + a_dim1;
a -= a_offset;
--ipiv;
/* 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_("ZHETF2", &i__1);
return 0;
}
/* Initialize ALPHA for use in choosing pivot block size. */
alpha = (sqrt(17.) + 1.) / 8.;
if (upper) {
/* Factorize A as U*D*U' using the upper triangle of A */
/* K is the main loop index, decreasing from N to 1 in steps of */
/* 1 or 2 */
k = *n;
L10:
/* If K < 1, exit from loop */
if (k < 1) {
goto L90;
}
kstep = 1;
/* Determine rows and columns to be interchanged and whether */
/* a 1-by-1 or 2-by-2 pivot block will be used */
i__1 = k + k * a_dim1;
absakk = (d__1 = a[i__1].r, abs(d__1));
/* IMAX is the row-index of the largest off-diagonal element in */
/* column K, and COLMAX is its absolute value */
if (k > 1) {
i__1 = k - 1;
imax = izamax_(&i__1, &a[k * a_dim1 + 1], &c__1);
i__1 = imax + k * a_dim1;
colmax = (d__1 = a[i__1].r, abs(d__1)) + (d__2 = d_imag(&a[imax +
k * a_dim1]), abs(d__2));
} else {
colmax = 0.;
}
if (max(absakk,colmax) == 0. || disnan_(&absakk)) {
/* Column K is zero or contains a NaN: set INFO and continue */
if (*info == 0) {
*info = k;
}
kp = k;
i__1 = k + k * a_dim1;
i__2 = k + k * a_dim1;
d__1 = a[i__2].r;
a[i__1].r = d__1, a[i__1].i = 0.;
} else {
if (absakk >= alpha * colmax) {
/* no interchange, use 1-by-1 pivot block */
kp = k;
} else {
/* JMAX is the column-index of the largest off-diagonal */
/* element in row IMAX, and ROWMAX is its absolute value */
i__1 = k - imax;
jmax = imax + izamax_(&i__1, &a[imax + (imax + 1) * a_dim1],
lda);
i__1 = imax + jmax * a_dim1;
rowmax = (d__1 = a[i__1].r, abs(d__1)) + (d__2 = d_imag(&a[
imax + jmax * a_dim1]), abs(d__2));
if (imax > 1) {
i__1 = imax - 1;
jmax = izamax_(&i__1, &a[imax * a_dim1 + 1], &c__1);
/* Computing MAX */
i__1 = jmax + imax * a_dim1;
d__3 = rowmax, d__4 = (d__1 = a[i__1].r, abs(d__1)) + (
d__2 = d_imag(&a[jmax + imax * a_dim1]), abs(d__2)
);
rowmax = max(d__3,d__4);
}
if (absakk >= alpha * colmax * (colmax / rowmax)) {
/* no interchange, use 1-by-1 pivot block */
kp = k;
} else /* if(complicated condition) */ {
i__1 = imax + imax * a_dim1;
if ((d__1 = a[i__1].r, abs(d__1)) >= alpha * rowmax) {
/* interchange rows and columns K and IMAX, use 1-by-1 */
/* pivot block */
kp = imax;
} else {
/* interchange rows and columns K-1 and IMAX, use 2-by-2 */
/* pivot block */
kp = imax;
kstep = 2;
}
}
}
kk = k - kstep + 1;
if (kp != kk) {
/* Interchange rows and columns KK and KP in the leading */
/* submatrix A(1:k,1:k) */
i__1 = kp - 1;
zswap_(&i__1, &a[kk * a_dim1 + 1], &c__1, &a[kp * a_dim1 + 1],
&c__1);
i__1 = kk - 1;
for (j = kp + 1; j <= i__1; ++j) {
d_cnjg(&z__1, &a[j + kk * a_dim1]);
t.r = z__1.r, t.i = z__1.i;
i__2 = j + kk * a_dim1;
d_cnjg(&z__1, &a[kp + j * a_dim1]);
a[i__2].r = z__1.r, a[i__2].i = z__1.i;
i__2 = kp + j * a_dim1;
a[i__2].r = t.r, a[i__2].i = t.i;
/* L20: */
}
i__1 = kp + kk * a_dim1;
d_cnjg(&z__1, &a[kp + kk * a_dim1]);
a[i__1].r = z__1.r, a[i__1].i = z__1.i;
i__1 = kk + kk * a_dim1;
r1 = a[i__1].r;
i__1 = kk + kk * a_dim1;
i__2 = kp + kp * a_dim1;
d__1 = a[i__2].r;
a[i__1].r = d__1, a[i__1].i = 0.;
i__1 = kp + kp * a_dim1;
a[i__1].r = r1, a[i__1].i = 0.;
if (kstep == 2) {
i__1 = k + k * a_dim1;
i__2 = k + k * a_dim1;
d__1 = a[i__2].r;
a[i__1].r = d__1, a[i__1].i = 0.;
i__1 = k - 1 + k * a_dim1;
t.r = a[i__1].r, t.i = a[i__1].i;
i__1 = k - 1 + k * a_dim1;
i__2 = kp + k * a_dim1;
a[i__1].r = a[i__2].r, a[i__1].i = a[i__2].i;
i__1 = kp + k * a_dim1;
a[i__1].r = t.r, a[i__1].i = t.i;
}
} else {
i__1 = k + k * a_dim1;
i__2 = k + k * a_dim1;
d__1 = a[i__2].r;
a[i__1].r = d__1, a[i__1].i = 0.;
if (kstep == 2) {
i__1 = k - 1 + (k - 1) * a_dim1;
i__2 = k - 1 + (k - 1) * a_dim1;
d__1 = a[i__2].r;
a[i__1].r = d__1, a[i__1].i = 0.;
}
}
/* Update the leading submatrix */
if (kstep == 1) {
/* 1-by-1 pivot block D(k): column k now holds */
/* W(k) = U(k)*D(k) */
/* where U(k) is the k-th column of U */
/* Perform a rank-1 update of A(1:k-1,1:k-1) as */
/* A := A - U(k)*D(k)*U(k)' = A - W(k)*1/D(k)*W(k)' */
i__1 = k + k * a_dim1;
r1 = 1. / a[i__1].r;
i__1 = k - 1;
d__1 = -r1;
zher_(uplo, &i__1, &d__1, &a[k * a_dim1 + 1], &c__1, &a[
a_offset], lda);
/* Store U(k) in column k */
i__1 = k - 1;
zdscal_(&i__1, &r1, &a[k * a_dim1 + 1], &c__1);
} else {
/* 2-by-2 pivot block D(k): columns k and k-1 now hold */
/* ( W(k-1) W(k) ) = ( U(k-1) U(k) )*D(k) */
/* where U(k) and U(k-1) are the k-th and (k-1)-th columns */
/* of U */
/* Perform a rank-2 update of A(1:k-2,1:k-2) as */
/* A := A - ( U(k-1) U(k) )*D(k)*( U(k-1) U(k) )' */
/* = A - ( W(k-1) W(k) )*inv(D(k))*( W(k-1) W(k) )' */
if (k > 2) {
i__1 = k - 1 + k * a_dim1;
d__1 = a[i__1].r;
d__2 = d_imag(&a[k - 1 + k * a_dim1]);
d__ = dlapy2_(&d__1, &d__2);
i__1 = k - 1 + (k - 1) * a_dim1;
d22 = a[i__1].r / d__;
i__1 = k + k * a_dim1;
d11 = a[i__1].r / d__;
tt = 1. / (d11 * d22 - 1.);
i__1 = k - 1 + k * a_dim1;
z__1.r = a[i__1].r / d__, z__1.i = a[i__1].i / d__;
d12.r = z__1.r, d12.i = z__1.i;
d__ = tt / d__;
for (j = k - 2; j >= 1; --j) {
i__1 = j + (k - 1) * a_dim1;
z__3.r = d11 * a[i__1].r, z__3.i = d11 * a[i__1].i;
d_cnjg(&z__5, &d12);
i__2 = j + k * a_dim1;
z__4.r = z__5.r * a[i__2].r - z__5.i * a[i__2].i,
z__4.i = z__5.r * a[i__2].i + z__5.i * a[i__2]
.r;
z__2.r = z__3.r - z__4.r, z__2.i = z__3.i - z__4.i;
z__1.r = d__ * z__2.r, z__1.i = d__ * z__2.i;
wkm1.r = z__1.r, wkm1.i = z__1.i;
i__1 = j + k * a_dim1;
z__3.r = d22 * a[i__1].r, z__3.i = d22 * a[i__1].i;
i__2 = j + (k - 1) * a_dim1;
z__4.r = d12.r * a[i__2].r - d12.i * a[i__2].i,
z__4.i = d12.r * a[i__2].i + d12.i * a[i__2]
.r;
z__2.r = z__3.r - z__4.r, z__2.i = z__3.i - z__4.i;
z__1.r = d__ * z__2.r, z__1.i = d__ * z__2.i;
wk.r = z__1.r, wk.i = z__1.i;
for (i__ = j; i__ >= 1; --i__) {
i__1 = i__ + j * a_dim1;
i__2 = i__ + j * a_dim1;
i__3 = i__ + k * a_dim1;
d_cnjg(&z__4, &wk);
z__3.r = a[i__3].r * z__4.r - a[i__3].i * z__4.i,
z__3.i = a[i__3].r * z__4.i + a[i__3].i *
z__4.r;
z__2.r = a[i__2].r - z__3.r, z__2.i = a[i__2].i -
z__3.i;
i__4 = i__ + (k - 1) * a_dim1;
d_cnjg(&z__6, &wkm1);
z__5.r = a[i__4].r * z__6.r - a[i__4].i * z__6.i,
z__5.i = a[i__4].r * z__6.i + a[i__4].i *
z__6.r;
z__1.r = z__2.r - z__5.r, z__1.i = z__2.i -
z__5.i;
a[i__1].r = z__1.r, a[i__1].i = z__1.i;
/* L30: */
}
i__1 = j + k * a_dim1;
a[i__1].r = wk.r, a[i__1].i = wk.i;
i__1 = j + (k - 1) * a_dim1;
a[i__1].r = wkm1.r, a[i__1].i = wkm1.i;
i__1 = j + j * a_dim1;
i__2 = j + j * a_dim1;
d__1 = a[i__2].r;
z__1.r = d__1, z__1.i = 0.;
a[i__1].r = z__1.r, a[i__1].i = z__1.i;
/* L40: */
}
}
}
}
/* Store details of the interchanges in IPIV */
if (kstep == 1) {
ipiv[k] = kp;
} else {
ipiv[k] = -kp;
ipiv[k - 1] = -kp;
}
/* Decrease K and return to the start of the main loop */
k -= kstep;
goto L10;
} else {
/* Factorize A as L*D*L' using the lower triangle of A */
/* K is the main loop index, increasing from 1 to N in steps of */
/* 1 or 2 */
k = 1;
L50:
/* If K > N, exit from loop */
if (k > *n) {
goto L90;
}
kstep = 1;
/* Determine rows and columns to be interchanged and whether */
/* a 1-by-1 or 2-by-2 pivot block will be used */
i__1 = k + k * a_dim1;
absakk = (d__1 = a[i__1].r, abs(d__1));
/* IMAX is the row-index of the largest off-diagonal element in */
/* column K, and COLMAX is its absolute value */
if (k < *n) {
i__1 = *n - k;
imax = k + izamax_(&i__1, &a[k + 1 + k * a_dim1], &c__1);
i__1 = imax + k * a_dim1;
colmax = (d__1 = a[i__1].r, abs(d__1)) + (d__2 = d_imag(&a[imax +
k * a_dim1]), abs(d__2));
} else {
colmax = 0.;
}
if (max(absakk,colmax) == 0. || disnan_(&absakk)) {
/* Column K is zero or contains a NaN: set INFO and continue */
if (*info == 0) {
*info = k;
}
kp = k;
i__1 = k + k * a_dim1;
i__2 = k + k * a_dim1;
d__1 = a[i__2].r;
a[i__1].r = d__1, a[i__1].i = 0.;
} else {
if (absakk >= alpha * colmax) {
/* no interchange, use 1-by-1 pivot block */
kp = k;
} else {
/* JMAX is the column-index of the largest off-diagonal */
/* element in row IMAX, and ROWMAX is its absolute value */
i__1 = imax - k;
jmax = k - 1 + izamax_(&i__1, &a[imax + k * a_dim1], lda);
i__1 = imax + jmax * a_dim1;
rowmax = (d__1 = a[i__1].r, abs(d__1)) + (d__2 = d_imag(&a[
imax + jmax * a_dim1]), abs(d__2));
if (imax < *n) {
i__1 = *n - imax;
jmax = imax + izamax_(&i__1, &a[imax + 1 + imax * a_dim1],
&c__1);
/* Computing MAX */
i__1 = jmax + imax * a_dim1;
d__3 = rowmax, d__4 = (d__1 = a[i__1].r, abs(d__1)) + (
d__2 = d_imag(&a[jmax + imax * a_dim1]), abs(d__2)
);
rowmax = max(d__3,d__4);
}
if (absakk >= alpha * colmax * (colmax / rowmax)) {
/* no interchange, use 1-by-1 pivot block */
kp = k;
} else /* if(complicated condition) */ {
i__1 = imax + imax * a_dim1;
if ((d__1 = a[i__1].r, abs(d__1)) >= alpha * rowmax) {
/* interchange rows and columns K and IMAX, use 1-by-1 */
/* pivot block */
kp = imax;
} else {
/* interchange rows and columns K+1 and IMAX, use 2-by-2 */
/* pivot block */
kp = imax;
kstep = 2;
}
}
}
kk = k + kstep - 1;
if (kp != kk) {
/* Interchange rows and columns KK and KP in the trailing */
/* submatrix A(k:n,k:n) */
if (kp < *n) {
i__1 = *n - kp;
zswap_(&i__1, &a[kp + 1 + kk * a_dim1], &c__1, &a[kp + 1
+ kp * a_dim1], &c__1);
}
i__1 = kp - 1;
for (j = kk + 1; j <= i__1; ++j) {
d_cnjg(&z__1, &a[j + kk * a_dim1]);
t.r = z__1.r, t.i = z__1.i;
i__2 = j + kk * a_dim1;
d_cnjg(&z__1, &a[kp + j * a_dim1]);
a[i__2].r = z__1.r, a[i__2].i = z__1.i;
i__2 = kp + j * a_dim1;
a[i__2].r = t.r, a[i__2].i = t.i;
/* L60: */
}
i__1 = kp + kk * a_dim1;
d_cnjg(&z__1, &a[kp + kk * a_dim1]);
a[i__1].r = z__1.r, a[i__1].i = z__1.i;
i__1 = kk + kk * a_dim1;
r1 = a[i__1].r;
i__1 = kk + kk * a_dim1;
i__2 = kp + kp * a_dim1;
d__1 = a[i__2].r;
a[i__1].r = d__1, a[i__1].i = 0.;
i__1 = kp + kp * a_dim1;
a[i__1].r = r1, a[i__1].i = 0.;
if (kstep == 2) {
i__1 = k + k * a_dim1;
i__2 = k + k * a_dim1;
d__1 = a[i__2].r;
a[i__1].r = d__1, a[i__1].i = 0.;
i__1 = k + 1 + k * a_dim1;
t.r = a[i__1].r, t.i = a[i__1].i;
i__1 = k + 1 + k * a_dim1;
i__2 = kp + k * a_dim1;
a[i__1].r = a[i__2].r, a[i__1].i = a[i__2].i;
i__1 = kp + k * a_dim1;
a[i__1].r = t.r, a[i__1].i = t.i;
}
} else {
i__1 = k + k * a_dim1;
i__2 = k + k * a_dim1;
d__1 = a[i__2].r;
a[i__1].r = d__1, a[i__1].i = 0.;
if (kstep == 2) {
i__1 = k + 1 + (k + 1) * a_dim1;
i__2 = k + 1 + (k + 1) * a_dim1;
d__1 = a[i__2].r;
a[i__1].r = d__1, a[i__1].i = 0.;
}
}
/* Update the trailing submatrix */
if (kstep == 1) {
/* 1-by-1 pivot block D(k): column k now holds */
/* W(k) = L(k)*D(k) */
/* where L(k) is the k-th column of L */
if (k < *n) {
/* Perform a rank-1 update of A(k+1:n,k+1:n) as */
/* A := A - L(k)*D(k)*L(k)' = A - W(k)*(1/D(k))*W(k)' */
i__1 = k + k * a_dim1;
r1 = 1. / a[i__1].r;
i__1 = *n - k;
d__1 = -r1;
zher_(uplo, &i__1, &d__1, &a[k + 1 + k * a_dim1], &c__1, &
a[k + 1 + (k + 1) * a_dim1], lda);
/* Store L(k) in column K */
i__1 = *n - k;
zdscal_(&i__1, &r1, &a[k + 1 + k * a_dim1], &c__1);
}
} else {
/* 2-by-2 pivot block D(k) */
if (k < *n - 1) {
/* Perform a rank-2 update of A(k+2:n,k+2:n) as */
/* A := A - ( L(k) L(k+1) )*D(k)*( L(k) L(k+1) )' */
/* = A - ( W(k) W(k+1) )*inv(D(k))*( W(k) W(k+1) )' */
/* where L(k) and L(k+1) are the k-th and (k+1)-th */
/* columns of L */
i__1 = k + 1 + k * a_dim1;
d__1 = a[i__1].r;
d__2 = d_imag(&a[k + 1 + k * a_dim1]);
d__ = dlapy2_(&d__1, &d__2);
i__1 = k + 1 + (k + 1) * a_dim1;
d11 = a[i__1].r / d__;
i__1 = k + k * a_dim1;
d22 = a[i__1].r / d__;
tt = 1. / (d11 * d22 - 1.);
i__1 = k + 1 + k * a_dim1;
z__1.r = a[i__1].r / d__, z__1.i = a[i__1].i / d__;
d21.r = z__1.r, d21.i = z__1.i;
d__ = tt / d__;
i__1 = *n;
for (j = k + 2; j <= i__1; ++j) {
i__2 = j + k * a_dim1;
z__3.r = d11 * a[i__2].r, z__3.i = d11 * a[i__2].i;
i__3 = j + (k + 1) * a_dim1;
z__4.r = d21.r * a[i__3].r - d21.i * a[i__3].i,
z__4.i = d21.r * a[i__3].i + d21.i * a[i__3]
.r;
z__2.r = z__3.r - z__4.r, z__2.i = z__3.i - z__4.i;
z__1.r = d__ * z__2.r, z__1.i = d__ * z__2.i;
wk.r = z__1.r, wk.i = z__1.i;
i__2 = j + (k + 1) * a_dim1;
z__3.r = d22 * a[i__2].r, z__3.i = d22 * a[i__2].i;
d_cnjg(&z__5, &d21);
i__3 = j + k * a_dim1;
z__4.r = z__5.r * a[i__3].r - z__5.i * a[i__3].i,
z__4.i = z__5.r * a[i__3].i + z__5.i * a[i__3]
.r;
z__2.r = z__3.r - z__4.r, z__2.i = z__3.i - z__4.i;
z__1.r = d__ * z__2.r, z__1.i = d__ * z__2.i;
wkp1.r = z__1.r, wkp1.i = z__1.i;
i__2 = *n;
for (i__ = j; i__ <= i__2; ++i__) {
i__3 = i__ + j * a_dim1;
i__4 = i__ + j * a_dim1;
i__5 = i__ + k * a_dim1;
d_cnjg(&z__4, &wk);
z__3.r = a[i__5].r * z__4.r - a[i__5].i * z__4.i,
z__3.i = a[i__5].r * z__4.i + a[i__5].i *
z__4.r;
z__2.r = a[i__4].r - z__3.r, z__2.i = a[i__4].i -
z__3.i;
i__6 = i__ + (k + 1) * a_dim1;
d_cnjg(&z__6, &wkp1);
z__5.r = a[i__6].r * z__6.r - a[i__6].i * z__6.i,
z__5.i = a[i__6].r * z__6.i + a[i__6].i *
z__6.r;
z__1.r = z__2.r - z__5.r, z__1.i = z__2.i -
z__5.i;
a[i__3].r = z__1.r, a[i__3].i = z__1.i;
/* L70: */
}
i__2 = j + k * a_dim1;
a[i__2].r = wk.r, a[i__2].i = wk.i;
i__2 = j + (k + 1) * a_dim1;
a[i__2].r = wkp1.r, a[i__2].i = wkp1.i;
i__2 = j + j * a_dim1;
i__3 = j + j * a_dim1;
d__1 = a[i__3].r;
z__1.r = d__1, z__1.i = 0.;
a[i__2].r = z__1.r, a[i__2].i = z__1.i;
/* L80: */
}
}
}
}
/* Store details of the interchanges in IPIV */
if (kstep == 1) {
ipiv[k] = kp;
} else {
ipiv[k] = -kp;
ipiv[k + 1] = -kp;
}
/* Increase K and return to the start of the main loop */
k += kstep;
goto L50;
}
L90:
return 0;
/* End of ZHETF2 */
} /* zhetf2_ */
/* ===================================================================== */
doublereal zlansp_(char *norm, char *uplo, integer *n, doublecomplex *ap, doublereal *work)
{
/* System generated locals */
integer i__1, i__2;
doublereal ret_val, d__1;
/* Builtin functions */
double z_abs(doublecomplex *), d_imag(doublecomplex *), sqrt(doublereal);
/* Local variables */
integer i__, j, k;
doublereal sum, absa, scale;
extern logical lsame_(char *, char *);
doublereal value;
extern logical disnan_(doublereal *);
extern /* Subroutine */
int zlassq_(integer *, doublecomplex *, integer *, doublereal *, doublereal *);
/* -- 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 */
--work;
--ap;
/* Function Body */
if (*n == 0)
{
value = 0.;
}
else if (lsame_(norm, "M"))
{
/* Find max(abs(A(i,j))). */
value = 0.;
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 = z_abs(&ap[i__]);
if (value < sum || disnan_(&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 = z_abs(&ap[i__]);
if (value < sum || disnan_(&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.;
k = 1;
if (lsame_(uplo, "U"))
{
i__1 = *n;
for (j = 1;
j <= i__1;
++j)
{
sum = 0.;
i__2 = j - 1;
for (i__ = 1;
i__ <= i__2;
++i__)
{
absa = z_abs(&ap[k]);
sum += absa;
work[i__] += absa;
++k;
/* L50: */
}
work[j] = sum + z_abs(&ap[k]);
++k;
/* L60: */
}
i__1 = *n;
for (i__ = 1;
i__ <= i__1;
++i__)
{
sum = work[i__];
if (value < sum || disnan_(&sum))
{
value = sum;
}
/* L70: */
}
}
else
{
i__1 = *n;
for (i__ = 1;
i__ <= i__1;
++i__)
{
work[i__] = 0.;
/* L80: */
}
i__1 = *n;
for (j = 1;
j <= i__1;
++j)
{
sum = work[j] + z_abs(&ap[k]);
++k;
i__2 = *n;
for (i__ = j + 1;
i__ <= i__2;
++i__)
{
absa = z_abs(&ap[k]);
sum += absa;
work[i__] += absa;
++k;
/* L90: */
}
if (value < sum || disnan_(&sum))
{
value = sum;
}
/* L100: */
}
}
}
else if (lsame_(norm, "F") || lsame_(norm, "E"))
{
/* Find normF(A). */
scale = 0.;
sum = 1.;
k = 2;
if (lsame_(uplo, "U"))
{
i__1 = *n;
for (j = 2;
j <= i__1;
++j)
{
i__2 = j - 1;
zlassq_(&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;
zlassq_(&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__)
{
i__2 = k;
if (ap[i__2].r != 0.)
{
i__2 = k;
absa = (d__1 = ap[i__2].r, abs(d__1));
if (scale < absa)
{
/* Computing 2nd power */
d__1 = scale / absa;
sum = sum * (d__1 * d__1) + 1.;
scale = absa;
}
else
{
/* Computing 2nd power */
d__1 = absa / scale;
sum += d__1 * d__1;
}
}
if (d_imag(&ap[k]) != 0.)
{
absa = (d__1 = d_imag(&ap[k]), abs(d__1));
if (scale < absa)
{
/* Computing 2nd power */
d__1 = scale / absa;
sum = sum * (d__1 * d__1) + 1.;
scale = absa;
}
else
{
/* Computing 2nd power */
d__1 = absa / scale;
sum += d__1 * d__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 ZLANSP */
}
/* ===================================================================== */
doublereal zlantp_(char *norm, char *uplo, char *diag, integer *n, doublecomplex *ap, doublereal *work)
{
/* System generated locals */
integer i__1, i__2;
doublereal ret_val;
/* Builtin functions */
double z_abs(doublecomplex *), sqrt(doublereal);
/* Local variables */
integer i__, j, k;
doublereal sum, scale;
logical udiag;
extern logical lsame_(char *, char *);
doublereal value;
extern logical disnan_(doublereal *);
extern /* Subroutine */
int zlassq_(integer *, doublecomplex *, integer *, doublereal *, doublereal *);
/* -- 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 */
--work;
--ap;
/* Function Body */
if (*n == 0)
{
value = 0.;
}
else if (lsame_(norm, "M"))
{
/* Find max(abs(A(i,j))). */
k = 1;
if (lsame_(diag, "U"))
{
value = 1.;
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 = z_abs(&ap[i__]);
if (value < sum || disnan_(&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 = z_abs(&ap[i__]);
if (value < sum || disnan_(&sum))
{
value = sum;
}
/* L30: */
}
k = k + *n - j + 1;
/* L40: */
}
}
}
else
{
value = 0.;
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 = z_abs(&ap[i__]);
if (value < sum || disnan_(&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 = z_abs(&ap[i__]);
if (value < sum || disnan_(&sum))
{
value = sum;
}
/* L70: */
}
k = k + *n - j + 1;
/* L80: */
}
}
}
}
else if (lsame_(norm, "O") || *(unsigned char *) norm == '1')
{
/* Find norm1(A). */
value = 0.;
k = 1;
udiag = lsame_(diag, "U");
if (lsame_(uplo, "U"))
{
i__1 = *n;
for (j = 1;
j <= i__1;
++j)
{
if (udiag)
{
sum = 1.;
i__2 = k + j - 2;
for (i__ = k;
i__ <= i__2;
++i__)
{
sum += z_abs(&ap[i__]);
/* L90: */
}
}
else
{
sum = 0.;
i__2 = k + j - 1;
for (i__ = k;
i__ <= i__2;
++i__)
{
sum += z_abs(&ap[i__]);
/* L100: */
}
}
k += j;
if (value < sum || disnan_(&sum))
{
value = sum;
}
/* L110: */
}
}
else
{
i__1 = *n;
for (j = 1;
j <= i__1;
++j)
{
if (udiag)
{
sum = 1.;
i__2 = k + *n - j;
for (i__ = k + 1;
i__ <= i__2;
++i__)
{
sum += z_abs(&ap[i__]);
/* L120: */
}
}
else
{
sum = 0.;
i__2 = k + *n - j;
for (i__ = k;
i__ <= i__2;
++i__)
{
sum += z_abs(&ap[i__]);
/* L130: */
}
}
k = k + *n - j + 1;
if (value < sum || disnan_(&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.;
/* L150: */
}
i__1 = *n;
for (j = 1;
j <= i__1;
++j)
{
i__2 = j - 1;
for (i__ = 1;
i__ <= i__2;
++i__)
{
work[i__] += z_abs(&ap[k]);
++k;
/* L160: */
}
++k;
/* L170: */
}
}
else
{
i__1 = *n;
for (i__ = 1;
i__ <= i__1;
++i__)
{
work[i__] = 0.;
/* L180: */
}
i__1 = *n;
for (j = 1;
j <= i__1;
++j)
{
i__2 = j;
for (i__ = 1;
i__ <= i__2;
++i__)
{
work[i__] += z_abs(&ap[k]);
++k;
/* L190: */
}
/* L200: */
}
}
}
else
{
if (lsame_(diag, "U"))
{
i__1 = *n;
for (i__ = 1;
i__ <= i__1;
++i__)
{
work[i__] = 1.;
/* 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__] += z_abs(&ap[k]);
++k;
/* L220: */
}
/* L230: */
}
}
else
{
i__1 = *n;
for (i__ = 1;
i__ <= i__1;
++i__)
{
work[i__] = 0.;
/* L240: */
}
i__1 = *n;
for (j = 1;
j <= i__1;
++j)
{
i__2 = *n;
for (i__ = j;
i__ <= i__2;
++i__)
{
work[i__] += z_abs(&ap[k]);
++k;
/* L250: */
}
/* L260: */
}
}
}
value = 0.;
i__1 = *n;
for (i__ = 1;
i__ <= i__1;
++i__)
{
sum = work[i__];
if (value < sum || disnan_(&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.;
sum = (doublereal) (*n);
k = 2;
i__1 = *n;
for (j = 2;
j <= i__1;
++j)
{
i__2 = j - 1;
zlassq_(&i__2, &ap[k], &c__1, &scale, &sum);
k += j;
/* L280: */
}
}
else
{
scale = 0.;
sum = 1.;
k = 1;
i__1 = *n;
for (j = 1;
j <= i__1;
++j)
{
zlassq_(&j, &ap[k], &c__1, &scale, &sum);
k += j;
/* L290: */
}
}
}
else
{
if (lsame_(diag, "U"))
{
scale = 1.;
sum = (doublereal) (*n);
k = 2;
i__1 = *n - 1;
for (j = 1;
j <= i__1;
++j)
{
i__2 = *n - j;
zlassq_(&i__2, &ap[k], &c__1, &scale, &sum);
k = k + *n - j + 1;
/* L300: */
}
}
else
{
scale = 0.;
sum = 1.;
k = 1;
i__1 = *n;
for (j = 1;
j <= i__1;
++j)
{
i__2 = *n - j + 1;
zlassq_(&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 ZLANTP */
}
/* Subroutine */ int zlar1v_(integer *n, integer *b1, integer *bn, doublereal
*lambda, doublereal *d__, doublereal *l, doublereal *ld, doublereal *
lld, doublereal *pivmin, doublereal *gaptol, doublecomplex *z__,
logical *wantnc, integer *negcnt, doublereal *ztz, doublereal *mingma,
integer *r__, integer *isuppz, doublereal *nrminv, doublereal *resid,
doublereal *rqcorr, doublereal *work)
{
/* System generated locals */
integer i__1, i__2, i__3, i__4;
doublereal d__1;
doublecomplex z__1, z__2;
/* Local variables */
integer i__;
doublereal s;
integer r1, r2;
doublereal eps, tmp;
integer neg1, neg2, indp, inds;
doublereal dplus;
integer indlpl, indumn;
doublereal dminus;
logical sawnan1, sawnan2;
/* -- LAPACK auxiliary routine (version 3.2) -- */
/* November 2006 */
/* Purpose */
/* ======= */
/* ZLAR1V 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) DOUBLE PRECISION */
/* 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) DOUBLE PRECISION array, dimension (N-1) */
/* The (n-1) subdiagonal elements of the unit bidiagonal matrix */
/* L, in elements 1 to N-1. */
/* D (input) DOUBLE PRECISION array, dimension (N) */
/* The n diagonal elements of the diagonal matrix D. */
/* LD (input) DOUBLE PRECISION array, dimension (N-1) */
/* The n-1 elements L(i)*D(i). */
/* LLD (input) DOUBLE PRECISION array, dimension (N-1) */
/* The n-1 elements L(i)*L(i)*D(i). */
/* PIVMIN (input) DOUBLE PRECISION */
/* The minimum pivot in the Sturm sequence. */
/* GAPTOL (input) DOUBLE PRECISION */
/* Tolerance that indicates when eigenvector entries are negligible */
/* w.r.t. their contribution to the residual. */
/* Z (input/output) COMPLEX*16 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) DOUBLE PRECISION */
/* The square of the 2-norm of Z. */
/* MINGMA (output) DOUBLE PRECISION */
/* 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) DOUBLE PRECISION */
/* NRMINV = 1/SQRT( ZTZ ) */
/* RESID (output) DOUBLE PRECISION */
/* The residual of the FP vector. */
/* RESID = ABS( MINGMA )/SQRT( ZTZ ) */
/* RQCORR (output) DOUBLE PRECISION */
/* The Rayleigh Quotient correction to LAMBDA. */
/* RQCORR = MINGMA*TMP */
/* WORK (workspace) DOUBLE PRECISION 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 */
/* ===================================================================== */
/* Parameter adjustments */
--work;
--isuppz;
--z__;
--lld;
--ld;
--l;
--d__;
/* Function Body */
eps = dlamch_("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.;
} 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.) {
++neg1;
}
work[inds + i__] = s * work[indlpl + i__] * l[i__];
s = work[inds + i__] - *lambda;
}
sawnan1 = disnan_(&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;
}
sawnan1 = disnan_(&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.) {
++neg1;
}
work[inds + i__] = s * work[indlpl + i__] * l[i__];
if (work[indlpl + i__] == 0.) {
work[inds + i__] = lld[i__];
}
s = work[inds + i__] - *lambda;
}
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.) {
work[inds + i__] = lld[i__];
}
s = work[inds + i__] - *lambda;
}
}
/* 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.) {
++neg2;
}
work[indumn + i__] = l[i__] * tmp;
work[indp + i__ - 1] = work[indp + i__] * tmp - *lambda;
}
tmp = work[indp + r1 - 1];
sawnan2 = disnan_(&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.) {
++neg2;
}
work[indumn + i__] = l[i__] * tmp;
work[indp + i__ - 1] = work[indp + i__] * tmp - *lambda;
if (tmp == 0.) {
work[indp + i__ - 1] = d__[i__] - *lambda;
}
}
}
/* 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.) {
++neg1;
}
if (*wantnc) {
*negcnt = neg1 + neg2;
} else {
*negcnt = -1;
}
if (abs(*mingma) == 0.) {
*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.) {
tmp = eps * work[inds + i__];
}
if (abs(tmp) <= abs(*mingma)) {
*mingma = tmp;
*r__ = i__ + 1;
}
}
/* Compute the FP vector: solve N^T v = e_r */
isuppz[1] = *b1;
isuppz[2] = *bn;
i__1 = *r__;
z__[i__1].r = 1., z__[i__1].i = 0.;
*ztz = 1.;
/* 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;
z__2.r = work[i__3] * z__[i__4].r, z__2.i = work[i__3] * z__[i__4]
.i;
z__1.r = -z__2.r, z__1.i = -z__2.i;
z__[i__2].r = z__1.r, z__[i__2].i = z__1.i;
if ((z_abs(&z__[i__]) + z_abs(&z__[i__ + 1])) * (d__1 = ld[i__],
abs(d__1)) < *gaptol) {
i__2 = i__;
z__[i__2].r = 0., z__[i__2].i = 0.;
isuppz[1] = i__ + 1;
goto L220;
}
i__2 = i__;
i__3 = i__;
z__1.r = z__[i__2].r * z__[i__3].r - z__[i__2].i * z__[i__3].i,
z__1.i = z__[i__2].r * z__[i__3].i + z__[i__2].i * z__[
i__3].r;
*ztz += z__1.r;
}
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. && z__[i__2].i == 0.) {
i__2 = i__;
d__1 = -(ld[i__ + 1] / ld[i__]);
i__3 = i__ + 2;
z__1.r = d__1 * z__[i__3].r, z__1.i = d__1 * z__[i__3].i;
z__[i__2].r = z__1.r, z__[i__2].i = z__1.i;
} else {
i__2 = i__;
i__3 = indlpl + i__;
i__4 = i__ + 1;
z__2.r = work[i__3] * z__[i__4].r, z__2.i = work[i__3] * z__[
i__4].i;
z__1.r = -z__2.r, z__1.i = -z__2.i;
z__[i__2].r = z__1.r, z__[i__2].i = z__1.i;
}
if ((z_abs(&z__[i__]) + z_abs(&z__[i__ + 1])) * (d__1 = ld[i__],
abs(d__1)) < *gaptol) {
i__2 = i__;
z__[i__2].r = 0., z__[i__2].i = 0.;
isuppz[1] = i__ + 1;
goto L240;
}
i__2 = i__;
i__3 = i__;
z__1.r = z__[i__2].r * z__[i__3].r - z__[i__2].i * z__[i__3].i,
z__1.i = z__[i__2].r * z__[i__3].i + z__[i__2].i * z__[
i__3].r;
*ztz += z__1.r;
}
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__;
z__2.r = work[i__3] * z__[i__4].r, z__2.i = work[i__3] * z__[i__4]
.i;
z__1.r = -z__2.r, z__1.i = -z__2.i;
z__[i__2].r = z__1.r, z__[i__2].i = z__1.i;
if ((z_abs(&z__[i__]) + z_abs(&z__[i__ + 1])) * (d__1 = ld[i__],
abs(d__1)) < *gaptol) {
i__2 = i__ + 1;
z__[i__2].r = 0., z__[i__2].i = 0.;
isuppz[2] = i__;
goto L260;
}
i__2 = i__ + 1;
i__3 = i__ + 1;
z__1.r = z__[i__2].r * z__[i__3].r - z__[i__2].i * z__[i__3].i,
z__1.i = z__[i__2].r * z__[i__3].i + z__[i__2].i * z__[
i__3].r;
*ztz += z__1.r;
}
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. && z__[i__2].i == 0.) {
i__2 = i__ + 1;
d__1 = -(ld[i__ - 1] / ld[i__]);
i__3 = i__ - 1;
z__1.r = d__1 * z__[i__3].r, z__1.i = d__1 * z__[i__3].i;
z__[i__2].r = z__1.r, z__[i__2].i = z__1.i;
} else {
i__2 = i__ + 1;
i__3 = indumn + i__;
i__4 = i__;
z__2.r = work[i__3] * z__[i__4].r, z__2.i = work[i__3] * z__[
i__4].i;
z__1.r = -z__2.r, z__1.i = -z__2.i;
z__[i__2].r = z__1.r, z__[i__2].i = z__1.i;
}
if ((z_abs(&z__[i__]) + z_abs(&z__[i__ + 1])) * (d__1 = ld[i__],
abs(d__1)) < *gaptol) {
i__2 = i__ + 1;
z__[i__2].r = 0., z__[i__2].i = 0.;
isuppz[2] = i__;
goto L280;
}
i__2 = i__ + 1;
i__3 = i__ + 1;
z__1.r = z__[i__2].r * z__[i__3].r - z__[i__2].i * z__[i__3].i,
z__1.i = z__[i__2].r * z__[i__3].i + z__[i__2].i * z__[
i__3].r;
*ztz += z__1.r;
}
L280:
;
}
/* Compute quantities for convergence test */
tmp = 1. / *ztz;
*nrminv = sqrt(tmp);
*resid = abs(*mingma) * *nrminv;
*rqcorr = *mingma * tmp;
return 0;
/* End of ZLAR1V */
} /* zlar1v_ */
/* Subroutine */ int dlasq3_(integer *i0, integer *n0, doublereal *z__,
integer *pp, doublereal *dmin__, doublereal *sigma, doublereal *desig,
doublereal *qmax, integer *nfail, integer *iter, integer *ndiv,
logical *ieee, integer *ttype, doublereal *dmin1, doublereal *dmin2,
doublereal *dn, doublereal *dn1, doublereal *dn2, doublereal *g,
doublereal *tau)
{
/* System generated locals */
integer i__1;
doublereal d__1, d__2;
/* Builtin functions */
double sqrt(doublereal);
/* Local variables */
doublereal s, t;
integer j4, nn;
doublereal eps, tol;
integer n0in, ipn4;
doublereal tol2, temp;
extern /* Subroutine */ int dlasq4_(integer *, integer *, doublereal *,
integer *, integer *, doublereal *, doublereal *, doublereal *,
doublereal *, doublereal *, doublereal *, doublereal *, integer *,
doublereal *), dlasq5_(integer *, integer *, doublereal *,
integer *, doublereal *, doublereal *, doublereal *, doublereal *,
doublereal *, doublereal *, doublereal *, logical *), dlasq6_(
integer *, integer *, doublereal *, integer *, doublereal *,
doublereal *, doublereal *, doublereal *, doublereal *,
doublereal *);
extern doublereal dlamch_(char *);
extern logical disnan_(doublereal *);
/* -- 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 */
/* ======= */
/* DLASQ3 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) DOUBLE PRECISION 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) DOUBLE PRECISION */
/* Minimum value of d. */
/* SIGMA (output) DOUBLE PRECISION */
/* Sum of shifts used in current segment. */
/* DESIG (input/output) DOUBLE PRECISION */
/* Lower order part of SIGMA */
/* QMAX (input) DOUBLE PRECISION */
/* 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 DLASQ5). */
/* TTYPE (input/output) INTEGER */
/* Shift type. */
/* DMIN1, DMIN2, DN, DN1, DN2, G, TAU (input/output) DOUBLE PRECISION */
/* These are passed as arguments in order to save their values */
/* between calls to DLASQ3. */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. External Function .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Executable Statements .. */
/* Parameter adjustments */
--z__;
/* Function Body */
n0in = *n0;
eps = dlamch_("Precision");
tol = eps * 100.;
/* Computing 2nd power */
d__1 = tol;
tol2 = d__1 * d__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]) * .5;
s = z__[nn - 3] * (z__[nn - 5] / t);
if (s <= t) {
s = z__[nn - 3] * (z__[nn - 5] / (t * (sqrt(s / t + 1.) + 1.)));
} 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. || *n0 < n0in) {
if (z__[(*i0 << 2) + *pp - 3] * 1.5 < 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 */
d__1 = *dmin2, d__2 = z__[(*n0 << 2) + *pp - 1];
*dmin2 = min(d__1,d__2);
/* Computing MIN */
d__1 = z__[(*n0 << 2) + *pp - 1], d__2 = z__[(*i0 << 2) + *pp - 1]
, d__1 = min(d__1,d__2), d__2 = z__[(*i0 << 2) + *pp + 3];
z__[(*n0 << 2) + *pp - 1] = min(d__1,d__2);
/* Computing MIN */
d__1 = z__[(*n0 << 2) - *pp], d__2 = z__[(*i0 << 2) - *pp], d__1 =
min(d__1,d__2), d__2 = z__[(*i0 << 2) - *pp + 4];
z__[(*n0 << 2) - *pp] = min(d__1,d__2);
/* Computing MAX */
d__1 = *qmax, d__2 = z__[(*i0 << 2) + *pp - 3], d__1 = max(d__1,
d__2), d__2 = z__[(*i0 << 2) + *pp + 1];
*qmax = max(d__1,d__2);
*dmin__ = -0.;
}
}
/* Choose a shift. */
dlasq4_(i0, n0, &z__[1], pp, &n0in, dmin__, dmin1, dmin2, dn, dn1, dn2,
tau, ttype, g);
/* Call dqds until DMIN > 0. */
L70:
dlasq5_(i0, n0, &z__[1], pp, tau, dmin__, dmin1, dmin2, dn, dn1, dn2,
ieee);
*ndiv += *n0 - *i0 + 2;
++(*iter);
/* Check status. */
if (*dmin__ >= 0. && *dmin1 > 0.) {
/* Success. */
goto L90;
} else if (*dmin__ < 0. && *dmin1 > 0. && z__[(*n0 - 1 << 2) - *pp] < tol
* (*sigma + *dn1) && abs(*dn) < tol * *sigma) {
/* Convergence hidden by negative DN. */
z__[(*n0 - 1 << 2) - *pp + 2] = 0.;
*dmin__ = 0.;
goto L90;
} else if (*dmin__ < 0.) {
/* TAU too big. Select new TAU and try again. */
++(*nfail);
if (*ttype < -22) {
/* Failed twice. Play it safe. */
*tau = 0.;
} else if (*dmin1 > 0.) {
/* Late failure. Gives excellent shift. */
*tau = (*tau + *dmin__) * (1. - eps * 2.);
*ttype += -11;
} else {
/* Early failure. Divide by 4. */
*tau *= .25;
*ttype += -12;
}
goto L70;
} else if (disnan_(dmin__)) {
/* NaN. */
if (*tau == 0.) {
goto L80;
} else {
*tau = 0.;
goto L70;
}
} else {
/* Possible underflow. Play it safe. */
goto L80;
}
/* Risk of underflow. */
L80:
dlasq6_(i0, n0, &z__[1], pp, dmin__, dmin1, dmin2, dn, dn1, dn2);
*ndiv += *n0 - *i0 + 2;
++(*iter);
*tau = 0.;
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 DLASQ3 */
} /* dlasq3_ */
/* Subroutine */ int zpotf2_(char *uplo, integer *n, doublecomplex *a,
integer *lda, integer *info)
{
/* System generated locals */
integer a_dim1, a_offset, i__1, i__2, i__3;
doublereal d__1;
doublecomplex z__1, z__2;
/* Local variables */
integer j;
doublereal ajj;
logical upper;
/* -- LAPACK routine (version 3.2) -- */
/* November 2006 */
/* Purpose */
/* ======= */
/* ZPOTF2 computes the Cholesky factorization of a complex Hermitian */
/* 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 */
/* Hermitian 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*16 array, dimension (LDA,N) */
/* On entry, the Hermitian 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_("ZPOTF2", &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 + j * a_dim1;
d__1 = a[i__2].r;
i__3 = j - 1;
zdotc_(&z__2, &i__3, &a[j * a_dim1 + 1], &c__1, &a[j * a_dim1 + 1]
, &c__1);
z__1.r = d__1 - z__2.r, z__1.i = -z__2.i;
ajj = z__1.r;
if (ajj <= 0. || disnan_(&ajj)) {
i__2 = j + j * a_dim1;
a[i__2].r = ajj, a[i__2].i = 0.;
goto L30;
}
ajj = sqrt(ajj);
i__2 = j + j * a_dim1;
a[i__2].r = ajj, a[i__2].i = 0.;
/* Compute elements J+1:N of row J. */
if (j < *n) {
i__2 = j - 1;
zlacgv_(&i__2, &a[j * a_dim1 + 1], &c__1);
i__2 = j - 1;
i__3 = *n - j;
z__1.r = -1., z__1.i = -0.;
zgemv_("Transpose", &i__2, &i__3, &z__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;
zlacgv_(&i__2, &a[j * a_dim1 + 1], &c__1);
i__2 = *n - j;
d__1 = 1. / ajj;
zdscal_(&i__2, &d__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 + j * a_dim1;
d__1 = a[i__2].r;
i__3 = j - 1;
zdotc_(&z__2, &i__3, &a[j + a_dim1], lda, &a[j + a_dim1], lda);
z__1.r = d__1 - z__2.r, z__1.i = -z__2.i;
ajj = z__1.r;
if (ajj <= 0. || disnan_(&ajj)) {
i__2 = j + j * a_dim1;
a[i__2].r = ajj, a[i__2].i = 0.;
goto L30;
}
ajj = sqrt(ajj);
i__2 = j + j * a_dim1;
a[i__2].r = ajj, a[i__2].i = 0.;
/* Compute elements J+1:N of column J. */
if (j < *n) {
i__2 = j - 1;
zlacgv_(&i__2, &a[j + a_dim1], lda);
i__2 = *n - j;
i__3 = j - 1;
z__1.r = -1., z__1.i = -0.;
zgemv_("No transpose", &i__2, &i__3, &z__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;
zlacgv_(&i__2, &a[j + a_dim1], lda);
i__2 = *n - j;
d__1 = 1. / ajj;
zdscal_(&i__2, &d__1, &a[j + 1 + j * a_dim1], &c__1);
}
}
}
goto L40;
L30:
*info = j;
L40:
return 0;
/* End of ZPOTF2 */
} /* zpotf2_ */
/* Subroutine */
int dgebal_(char *job, integer *n, doublereal *a, integer * lda, integer *ilo, integer *ihi, doublereal *scale, integer *info)
{
/* System generated locals */
integer a_dim1, a_offset, i__1, i__2;
doublereal d__1, d__2;
/* Local variables */
doublereal c__, f, g;
integer i__, j, k, l, m;
doublereal r__, s, ca, ra;
integer ica, ira, iexc;
extern doublereal dnrm2_(integer *, doublereal *, integer *);
extern /* Subroutine */
int dscal_(integer *, doublereal *, doublereal *, integer *);
extern logical lsame_(char *, char *);
extern /* Subroutine */
int dswap_(integer *, doublereal *, integer *, doublereal *, integer *);
doublereal sfmin1, sfmin2, sfmax1, sfmax2;
extern doublereal dlamch_(char *);
extern integer idamax_(integer *, doublereal *, integer *);
extern logical disnan_(doublereal *);
extern /* Subroutine */
int xerbla_(char *, integer *);
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_("DGEBAL", &i__1);
return 0;
}
k = 1;
l = *n;
if (*n == 0)
{
goto L210;
}
if (lsame_(job, "N"))
{
i__1 = *n;
for (i__ = 1;
i__ <= i__1;
++i__)
{
scale[i__] = 1.;
/* L10: */
}
goto L210;
}
if (lsame_(job, "S"))
{
goto L120;
}
/* Permutation to isolate eigenvalues if possible */
goto L50;
/* Row and column exchange. */
L20:
scale[m] = (doublereal) j;
if (j == m)
{
goto L30;
}
dswap_(&l, &a[j * a_dim1 + 1], &c__1, &a[m * a_dim1 + 1], &c__1);
i__1 = *n - k + 1;
dswap_(&i__1, &a[j + k * a_dim1], lda, &a[m + k * a_dim1], lda);
L30:
switch (iexc)
{
case 1:
goto L40;
case 2:
goto L80;
}
/* Search for rows isolating an eigenvalue and push them down. */
L40:
if (l == 1)
{
goto L210;
}
--l;
L50:
for (j = l;
j >= 1;
--j)
{
i__1 = l;
for (i__ = 1;
i__ <= i__1;
++i__)
{
if (i__ == j)
{
goto L60;
}
if (a[j + i__ * a_dim1] != 0.)
{
goto L70;
}
L60:
;
}
m = l;
iexc = 1;
goto L20;
L70:
;
}
goto L90;
/* Search for columns isolating an eigenvalue and push them left. */
L80:
++k;
L90:
i__1 = l;
for (j = k;
j <= i__1;
++j)
{
i__2 = l;
for (i__ = k;
i__ <= i__2;
++i__)
{
if (i__ == j)
{
goto L100;
}
if (a[i__ + j * a_dim1] != 0.)
{
goto L110;
}
L100:
;
}
m = k;
iexc = 2;
goto L20;
L110:
;
}
L120:
i__1 = l;
for (i__ = k;
i__ <= i__1;
++i__)
{
scale[i__] = 1.;
/* L130: */
}
if (lsame_(job, "P"))
{
goto L210;
}
/* Balance the submatrix in rows K to L. */
/* Iterative loop for norm reduction */
sfmin1 = dlamch_("S") / dlamch_("P");
sfmax1 = 1. / sfmin1;
sfmin2 = sfmin1 * 2.;
sfmax2 = 1. / sfmin2;
L140:
noconv = FALSE_;
i__1 = l;
for (i__ = k;
i__ <= i__1;
++i__)
{
i__2 = l - k + 1;
c__ = dnrm2_(&i__2, &a[k + i__ * a_dim1], &c__1);
i__2 = l - k + 1;
r__ = dnrm2_(&i__2, &a[i__ + k * a_dim1], lda);
ica = idamax_(&l, &a[i__ * a_dim1 + 1], &c__1);
ca = (d__1 = a[ica + i__ * a_dim1], f2c_abs(d__1));
i__2 = *n - k + 1;
ira = idamax_(&i__2, &a[i__ + k * a_dim1], lda);
ra = (d__1 = a[i__ + (ira + k - 1) * a_dim1], f2c_abs(d__1));
/* Guard against zero C or R due to underflow. */
if (c__ == 0. || r__ == 0.)
{
goto L200;
}
g = r__ / 2.;
f = 1.;
s = c__ + r__;
L160: /* Computing MAX */
d__1 = max(f,c__);
/* Computing MIN */
d__2 = min(r__,g);
if (c__ >= g || max(d__1,ca) >= sfmax2 || min(d__2,ra) <= sfmin2)
{
goto L170;
}
d__1 = c__ + f + ca + r__ + g + ra;
if (disnan_(&d__1))
{
/* Exit if NaN to avoid infinite loop */
*info = -3;
i__2 = -(*info);
xerbla_("DGEBAL", &i__2);
return 0;
}
f *= 2.;
c__ *= 2.;
ca *= 2.;
r__ /= 2.;
g /= 2.;
ra /= 2.;
goto L160;
L170:
g = c__ / 2.;
L180: /* Computing MIN */
d__1 = min(f,c__);
d__1 = min(d__1,g); // , expr subst
if (g < r__ || max(r__,ra) >= sfmax2 || min(d__1,ca) <= sfmin2)
{
goto L190;
}
f /= 2.;
c__ /= 2.;
g /= 2.;
ca /= 2.;
r__ *= 2.;
ra *= 2.;
goto L180;
/* Now balance. */
L190:
if (c__ + r__ >= s * .95)
{
goto L200;
}
if (f < 1. && scale[i__] < 1.)
{
if (f * scale[i__] <= sfmin1)
{
goto L200;
}
}
if (f > 1. && scale[i__] > 1.)
{
if (scale[i__] >= sfmax1 / f)
{
goto L200;
}
}
g = 1. / f;
scale[i__] *= f;
noconv = TRUE_;
i__2 = *n - k + 1;
dscal_(&i__2, &g, &a[i__ + k * a_dim1], lda);
dscal_(&l, &f, &a[i__ * a_dim1 + 1], &c__1);
L200:
;
}
if (noconv)
{
goto L140;
}
L210:
*ilo = k;
*ihi = l;
return 0;
/* End of DGEBAL */
}
/* ===================================================================== */
integer dlaneg_(integer *n, doublereal *d__, doublereal *lld, doublereal * sigma, doublereal *pivmin, integer *r__)
{
/* System generated locals */
integer ret_val, i__1, i__2, i__3, i__4;
/* Local variables */
integer j;
doublereal p, t;
integer bj;
doublereal tmp;
integer neg1, neg2;
doublereal bsav, gamma, dplus;
extern logical disnan_(doublereal *);
integer negcnt;
logical sawnan;
doublereal dminus;
/* -- 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 .. */
/* 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; // , expr subst
i__2 = min(i__3,i__4);
for (j = bj;
j <= i__2;
++j)
{
dplus = d__[j] + t;
if (dplus < 0.)
{
++neg1;
}
tmp = t / dplus;
t = tmp * lld[j] - *sigma;
/* L21: */
}
sawnan = disnan_(&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; // , expr subst
i__2 = min(i__3,i__4);
for (j = bj;
j <= i__2;
++j)
{
dplus = d__[j] + t;
if (dplus < 0.)
{
++neg1;
}
tmp = t / dplus;
if (disnan_(&tmp))
{
tmp = 1.;
}
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.)
{
++neg2;
}
tmp = p / dminus;
p = tmp * d__[j] - *sigma;
/* L23: */
}
sawnan = disnan_(&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.)
{
++neg2;
}
tmp = p / dminus;
if (disnan_(&tmp))
{
tmp = 1.;
}
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.)
{
++negcnt;
}
ret_val = negcnt;
return ret_val;
}
/* ===================================================================== */
doublereal dlangb_(char *norm, integer *n, integer *kl, integer *ku, doublereal *ab, integer *ldab, doublereal *work)
{
/* System generated locals */
integer ab_dim1, ab_offset, i__1, i__2, i__3, i__4, i__5, i__6;
doublereal ret_val, d__1;
/* Builtin functions */
double sqrt(doublereal);
/* Local variables */
integer i__, j, k, l;
doublereal sum, temp, scale;
extern logical lsame_(char *, char *);
doublereal value;
extern logical disnan_(doublereal *);
extern /* Subroutine */
int dlassq_(integer *, doublereal *, integer *, doublereal *, doublereal *);
/* -- 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.;
}
else if (lsame_(norm, "M"))
{
/* Find max(abs(A(i,j))). */
value = 0.;
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 = (d__1 = ab[i__ + j * ab_dim1], abs(d__1));
if (value < temp || disnan_(&temp))
{
value = temp;
}
/* L10: */
}
/* L20: */
}
}
else if (lsame_(norm, "O") || *(unsigned char *) norm == '1')
{
/* Find norm1(A). */
value = 0.;
i__1 = *n;
for (j = 1;
j <= i__1;
++j)
{
sum = 0.;
/* 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 += (d__1 = ab[i__ + j * ab_dim1], abs(d__1));
/* L30: */
}
if (value < sum || disnan_(&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.;
/* 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__] += (d__1 = ab[k + i__ + j * ab_dim1], abs(d__1));
/* L60: */
}
/* L70: */
}
value = 0.;
i__1 = *n;
for (i__ = 1;
i__ <= i__1;
++i__)
{
temp = work[i__];
if (value < temp || disnan_(&temp))
{
value = temp;
}
/* L80: */
}
}
else if (lsame_(norm, "F") || lsame_(norm, "E"))
{
/* Find normF(A). */
scale = 0.;
sum = 1.;
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;
dlassq_(&i__4, &ab[k + j * ab_dim1], &c__1, &scale, &sum);
/* L90: */
}
value = scale * sqrt(sum);
}
ret_val = value;
return ret_val;
/* End of DLANGB */
}
/* Subroutine */ int zgetrf_(integer *m, integer *n, doublecomplex *a,
integer *lda, integer *ipiv, integer *info)
{
/* System generated locals */
integer a_dim1, a_offset, i__1, i__2, i__3;
doublecomplex z__1;
/* Local variables */
integer i__, j, ipivstart, jpivstart, jp;
doublecomplex tmp;
integer kcols;
doublereal sfmin;
extern /* Subroutine */ int zscal_(integer *, doublecomplex *,
doublecomplex *, integer *), zgemm_(char *, char *, integer *,
integer *, integer *, doublecomplex *, doublecomplex *, integer *,
doublecomplex *, integer *, doublecomplex *, doublecomplex *,
integer *);
integer nstep;
extern /* Subroutine */ int ztrsm_(char *, char *, char *, char *,
integer *, integer *, doublecomplex *, doublecomplex *, integer *,
doublecomplex *, integer *);
integer kahead;
extern doublereal dlamch_(char *);
extern logical disnan_(doublereal *);
doublereal pivmag;
integer npived;
extern integer izamax_(integer *, doublecomplex *, integer *);
integer kstart, ntopiv;
extern /* Subroutine */ int zlaswp_(integer *, doublecomplex *, integer *,
integer *, integer *, integer *, integer *);
/* -- LAPACK routine (version 3.X) -- */
/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/* May 2008 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* ZGETRF 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 DTRSM, 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) COMPLEX*16 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_("ZGETRF", &i__1);
return 0;
}
/* Quick return if possible */
if (*m == 0 || *n == 0) {
return 0;
}
/* Compute machine safe minimum */
sfmin = dlamch_("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 + izamax_(&i__2, &a[j + j * a_dim1], &c__1);
ipiv[j] = jp;
/* Permute just this column. */
if (jp != j) {
i__2 = j + j * a_dim1;
tmp.r = a[i__2].r, tmp.i = a[i__2].i;
i__2 = j + j * a_dim1;
i__3 = jp + j * a_dim1;
a[i__2].r = a[i__3].r, a[i__2].i = a[i__3].i;
i__2 = jp + j * a_dim1;
a[i__2].r = tmp.r, a[i__2].i = tmp.i;
}
/* Apply pending permutations to L */
ntopiv = 1;
ipivstart = j;
jpivstart = j - ntopiv;
while(ntopiv < kahead) {
zlaswp_(&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 */
zlaswp_(&kcols, &a[(j + 1) * a_dim1 + 1], lda, &kstart, &j, &ipiv[1],
&c__1);
/* Factor the current column */
pivmag = z_abs(&a[j + j * a_dim1]);
if (pivmag != 0. && ! disnan_(&pivmag)) {
if (pivmag >= sfmin) {
i__2 = *m - j;
z_div(&z__1, &c_b1, &a[j + j * a_dim1]);
zscal_(&i__2, &z__1, &a[j + 1 + j * a_dim1], &c__1);
} else {
i__2 = *m - j;
for (i__ = 1; i__ <= i__2; ++i__) {
i__3 = j + i__ + j * a_dim1;
z_div(&z__1, &a[j + i__ + j * a_dim1], &a[j + j * a_dim1])
;
a[i__3].r = z__1.r, a[i__3].i = z__1.i;
}
}
} else if (pivmag == 0. && *info == 0) {
*info = j;
}
/* Solve for U block. */
ztrsm_("Left", "Lower", "No transpose", "Unit", &kahead, &kcols, &
c_b1, &a[kstart + kstart * a_dim1], lda, &a[kstart + (j + 1) *
a_dim1], lda);
/* Schur complement. */
i__2 = *m - j;
zgemm_("No transpose", "No transpose", &i__2, &kcols, &kahead, &c_b2,
&a[j + 1 + kstart * a_dim1], lda, &a[kstart + (j + 1) *
a_dim1], lda, &c_b1, &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;
zlaswp_(&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;
zlaswp_(&i__1, &a[(*m + kcols + 1) * a_dim1 + 1], lda, &c__1, m, &
ipiv[1], &c__1);
i__1 = *n - *m;
ztrsm_("Left", "Lower", "No transpose", "Unit", m, &i__1, &c_b1, &a[
a_offset], lda, &a[(*m + kcols + 1) * a_dim1 + 1], lda);
}
return 0;
/* End of ZGETRF */
} /* zgetrf_ */
/* Subroutine */ int zpstf2_(char *uplo, integer *n, doublecomplex *a,
integer *lda, integer *piv, integer *rank, doublereal *tol,
doublereal *work, integer *info)
{
/* System generated locals */
integer a_dim1, a_offset, i__1, i__2, i__3;
doublereal d__1;
doublecomplex z__1, z__2;
/* Builtin functions */
void d_cnjg(doublecomplex *, doublecomplex *);
double sqrt(doublereal);
/* Local variables */
integer i__, j, maxlocval;
doublereal ajj;
integer pvt;
extern logical lsame_(char *, char *);
doublereal dtemp;
integer itemp;
extern /* Subroutine */ int zgemv_(char *, integer *, integer *,
doublecomplex *, doublecomplex *, integer *, doublecomplex *,
integer *, doublecomplex *, doublecomplex *, integer *);
doublereal dstop;
logical upper;
doublecomplex ztemp;
extern /* Subroutine */ int zswap_(integer *, doublecomplex *, integer *,
doublecomplex *, integer *);
extern doublereal dlamch_(char *);
extern logical disnan_(doublereal *);
extern /* Subroutine */ int xerbla_(char *, integer *), zdscal_(
integer *, doublereal *, doublecomplex *, integer *), zlacgv_(
integer *, doublecomplex *, integer *);
extern integer dmaxloc_(doublereal *, integer *);
/* -- LAPACK PROTOTYPE routine (version 3.2) -- */
/* Craig Lucas, University of Manchester / NAG Ltd. */
/* October, 2008 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* ZPSTF2 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*16 array, dimension (LDA,N) */
/* On entry, the symmetric matrix A. If UPLO = 'U', the leading */
/* n by n upper triangular part of A contains the upper */
/* triangular part of the matrix A, and the strictly lower */
/* triangular part of A is not referenced. If UPLO = 'L', the */
/* leading n by n lower triangular part of A contains the lower */
/* triangular part of the matrix A, and the strictly upper */
/* triangular part of A is not referenced. */
/* On exit, if INFO = 0, the factor U or L from the Cholesky */
/* factorization as above. */
/* PIV (output) INTEGER array, dimension (N) */
/* PIV is such that the nonzero entries are P( PIV(K), K ) = 1. */
/* RANK (output) INTEGER */
/* The rank of A given by the number of steps the algorithm */
/* completed. */
/* TOL (input) DOUBLE PRECISION */
/* User defined tolerance. If TOL < 0, then N*U*MAX( A( K,K ) ) */
/* will be used. The algorithm terminates at the (K-1)st step */
/* if the pivot <= TOL. */
/* LDA (input) INTEGER */
/* The leading dimension of the array A. LDA >= max(1,N). */
/* WORK DOUBLE PRECISION array, dimension (2*N) */
/* Work space. */
/* INFO (output) INTEGER */
/* < 0: If INFO = -K, the K-th argument had an illegal value, */
/* = 0: algorithm completed successfully, and */
/* > 0: the matrix A is either rank deficient with computed rank */
/* as returned in RANK, or is indefinite. See Section 7 of */
/* LAPACK Working Note #161 for further information. */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Executable Statements .. */
/* Test the input parameters */
/* Parameter adjustments */
--work;
--piv;
a_dim1 = *lda;
a_offset = 1 + a_dim1;
a -= a_offset;
/* Function Body */
*info = 0;
upper = lsame_(uplo, "U");
if (! upper && ! lsame_(uplo, "L")) {
*info = -1;
} else if (*n < 0) {
*info = -2;
} else if (*lda < max(1,*n)) {
*info = -4;
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("ZPSTF2", &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 = dmaxloc_(&work[1], n);
i__1 = pvt + pvt * a_dim1;
ajj = a[i__1].r;
if (ajj == 0. || disnan_(&ajj)) {
*rank = 0;
*info = 1;
goto L200;
}
/* Compute stopping value if not supplied */
if (*tol < 0.) {
dstop = *n * dlamch_("Epsilon") * ajj;
} else {
dstop = *tol;
}
/* Set first half of WORK to zero, holds dot products */
i__1 = *n;
for (i__ = 1; i__ <= i__1; ++i__) {
work[i__] = 0.;
/* 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) {
d_cnjg(&z__2, &a[j - 1 + i__ * a_dim1]);
i__3 = j - 1 + i__ * a_dim1;
z__1.r = z__2.r * a[i__3].r - z__2.i * a[i__3].i, z__1.i =
z__2.r * a[i__3].i + z__2.i * a[i__3].r;
work[i__] += z__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 = dmaxloc_(&work[*n + j], &maxlocval);
pvt = itemp + j - 1;
ajj = work[*n + pvt];
if (ajj <= dstop || disnan_(&ajj)) {
i__2 = j + j * a_dim1;
a[i__2].r = ajj, a[i__2].i = 0.;
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;
zswap_(&i__2, &a[j * a_dim1 + 1], &c__1, &a[pvt * a_dim1 + 1],
&c__1);
if (pvt < *n) {
i__2 = *n - pvt;
zswap_(&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__) {
d_cnjg(&z__1, &a[j + i__ * a_dim1]);
ztemp.r = z__1.r, ztemp.i = z__1.i;
i__3 = j + i__ * a_dim1;
d_cnjg(&z__1, &a[i__ + pvt * a_dim1]);
a[i__3].r = z__1.r, a[i__3].i = z__1.i;
i__3 = i__ + pvt * a_dim1;
a[i__3].r = ztemp.r, a[i__3].i = ztemp.i;
/* L140: */
}
i__2 = j + pvt * a_dim1;
d_cnjg(&z__1, &a[j + pvt * a_dim1]);
a[i__2].r = z__1.r, a[i__2].i = z__1.i;
/* Swap dot products and PIV */
dtemp = work[j];
work[j] = work[pvt];
work[pvt] = dtemp;
itemp = piv[pvt];
piv[pvt] = piv[j];
piv[j] = itemp;
}
ajj = sqrt(ajj);
i__2 = j + j * a_dim1;
a[i__2].r = ajj, a[i__2].i = 0.;
/* Compute elements J+1:N of row J */
if (j < *n) {
i__2 = j - 1;
zlacgv_(&i__2, &a[j * a_dim1 + 1], &c__1);
i__2 = j - 1;
i__3 = *n - j;
z__1.r = -1., z__1.i = -0.;
zgemv_("Trans", &i__2, &i__3, &z__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;
zlacgv_(&i__2, &a[j * a_dim1 + 1], &c__1);
i__2 = *n - j;
d__1 = 1. / ajj;
zdscal_(&i__2, &d__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) {
d_cnjg(&z__2, &a[i__ + (j - 1) * a_dim1]);
i__3 = i__ + (j - 1) * a_dim1;
z__1.r = z__2.r * a[i__3].r - z__2.i * a[i__3].i, z__1.i =
z__2.r * a[i__3].i + z__2.i * a[i__3].r;
work[i__] += z__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 = dmaxloc_(&work[*n + j], &maxlocval);
pvt = itemp + j - 1;
ajj = work[*n + pvt];
if (ajj <= dstop || disnan_(&ajj)) {
i__2 = j + j * a_dim1;
a[i__2].r = ajj, a[i__2].i = 0.;
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;
zswap_(&i__2, &a[j + a_dim1], lda, &a[pvt + a_dim1], lda);
if (pvt < *n) {
i__2 = *n - pvt;
zswap_(&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__) {
d_cnjg(&z__1, &a[i__ + j * a_dim1]);
ztemp.r = z__1.r, ztemp.i = z__1.i;
i__3 = i__ + j * a_dim1;
d_cnjg(&z__1, &a[pvt + i__ * a_dim1]);
a[i__3].r = z__1.r, a[i__3].i = z__1.i;
i__3 = pvt + i__ * a_dim1;
a[i__3].r = ztemp.r, a[i__3].i = ztemp.i;
/* L170: */
}
i__2 = pvt + j * a_dim1;
d_cnjg(&z__1, &a[pvt + j * a_dim1]);
a[i__2].r = z__1.r, a[i__2].i = z__1.i;
/* Swap dot products and PIV */
dtemp = work[j];
work[j] = work[pvt];
work[pvt] = dtemp;
itemp = piv[pvt];
piv[pvt] = piv[j];
piv[j] = itemp;
}
ajj = sqrt(ajj);
i__2 = j + j * a_dim1;
a[i__2].r = ajj, a[i__2].i = 0.;
/* Compute elements J+1:N of column J */
if (j < *n) {
i__2 = j - 1;
zlacgv_(&i__2, &a[j + a_dim1], lda);
i__2 = *n - j;
i__3 = j - 1;
z__1.r = -1., z__1.i = -0.;
zgemv_("No Trans", &i__2, &i__3, &z__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;
zlacgv_(&i__2, &a[j + a_dim1], lda);
i__2 = *n - j;
d__1 = 1. / ajj;
zdscal_(&i__2, &d__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 ZPSTF2 */
} /* zpstf2_ */
/* ===================================================================== */
doublereal zlangt_(char *norm, integer *n, doublecomplex *dl, doublecomplex * d__, doublecomplex *du)
{
/* System generated locals */
integer i__1;
doublereal ret_val, d__1;
/* Builtin functions */
double z_abs(doublecomplex *), sqrt(doublereal);
/* Local variables */
integer i__;
doublereal sum, temp, scale;
extern logical lsame_(char *, char *);
doublereal anorm;
extern logical disnan_(doublereal *);
extern /* Subroutine */
int zlassq_(integer *, doublecomplex *, integer *, doublereal *, doublereal *);
/* -- 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 */
--du;
--d__;
--dl;
/* Function Body */
if (*n <= 0)
{
anorm = 0.;
}
else if (lsame_(norm, "M"))
{
/* Find max(abs(A(i,j))). */
anorm = z_abs(&d__[*n]);
i__1 = *n - 1;
for (i__ = 1;
i__ <= i__1;
++i__)
{
d__1 = z_abs(&dl[i__]);
if (anorm < z_abs(&dl[i__]) || disnan_(&d__1))
{
anorm = z_abs(&dl[i__]);
}
d__1 = z_abs(&d__[i__]);
if (anorm < z_abs(&d__[i__]) || disnan_(&d__1))
{
anorm = z_abs(&d__[i__]);
}
d__1 = z_abs(&du[i__]);
if (anorm < z_abs(&du[i__]) || disnan_(&d__1))
{
anorm = z_abs(&du[i__]);
}
/* L10: */
}
}
else if (lsame_(norm, "O") || *(unsigned char *) norm == '1')
{
/* Find norm1(A). */
if (*n == 1)
{
anorm = z_abs(&d__[1]);
}
else
{
anorm = z_abs(&d__[1]) + z_abs(&dl[1]);
temp = z_abs(&d__[*n]) + z_abs(&du[*n - 1]);
if (anorm < temp || disnan_(&temp))
{
anorm = temp;
}
i__1 = *n - 1;
for (i__ = 2;
i__ <= i__1;
++i__)
{
temp = z_abs(&d__[i__]) + z_abs(&dl[i__]) + z_abs(&du[i__ - 1] );
if (anorm < temp || disnan_(&temp))
{
anorm = temp;
}
/* L20: */
}
}
}
else if (lsame_(norm, "I"))
{
/* Find normI(A). */
if (*n == 1)
{
anorm = z_abs(&d__[1]);
}
else
{
anorm = z_abs(&d__[1]) + z_abs(&du[1]);
temp = z_abs(&d__[*n]) + z_abs(&dl[*n - 1]);
if (anorm < temp || disnan_(&temp))
{
anorm = temp;
}
i__1 = *n - 1;
for (i__ = 2;
i__ <= i__1;
++i__)
{
temp = z_abs(&d__[i__]) + z_abs(&du[i__]) + z_abs(&dl[i__ - 1] );
if (anorm < temp || disnan_(&temp))
{
anorm = temp;
}
/* L30: */
}
}
}
else if (lsame_(norm, "F") || lsame_(norm, "E"))
{
/* Find normF(A). */
scale = 0.;
sum = 1.;
zlassq_(n, &d__[1], &c__1, &scale, &sum);
if (*n > 1)
{
i__1 = *n - 1;
zlassq_(&i__1, &dl[1], &c__1, &scale, &sum);
i__1 = *n - 1;
zlassq_(&i__1, &du[1], &c__1, &scale, &sum);
}
anorm = scale * sqrt(sum);
}
ret_val = anorm;
return ret_val;
/* End of ZLANGT */
}
/* Subroutine */ int dlascl_(char *type__, integer *kl, integer *ku,
doublereal *cfrom, doublereal *cto, integer *m, integer *n,
doublereal *a, integer *lda, integer *info)
{
/* System generated locals */
integer a_dim1, a_offset, i__1, i__2, i__3, i__4, i__5;
/* Local variables */
integer i__, j, k1, k2, k3, k4;
doublereal mul, cto1;
logical done;
doublereal ctoc;
integer itype;
doublereal cfrom1;
doublereal cfromc;
doublereal bignum, smlnum;
/* -- LAPACK auxiliary routine (version 3.2) -- */
/* November 2006 */
/* Purpose */
/* ======= */
/* DLASCL multiplies the M by N real 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) DOUBLE PRECISION */
/* CTO (input) DOUBLE PRECISION */
/* 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) DOUBLE PRECISION 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. || disnan_(cfrom)) {
*info = -4;
} else if (disnan_(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_("DLASCL", &i__1);
return 0;
}
/* Quick return if possible */
if (*n == 0 || *m == 0) {
return 0;
}
/* Get machine parameters */
smlnum = dlamch_("S");
bignum = 1. / 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.;
} else if (abs(cfrom1) > abs(ctoc) && ctoc != 0.) {
mul = smlnum;
done = FALSE_;
cfromc = cfrom1;
} else if (abs(cto1) > abs(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__) {
a[i__ + j * a_dim1] *= mul;
}
}
} 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__) {
a[i__ + j * a_dim1] *= mul;
}
}
} 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__) {
a[i__ + j * a_dim1] *= mul;
}
}
} 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__) {
a[i__ + j * a_dim1] *= mul;
}
}
} 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__) {
a[i__ + j * a_dim1] *= mul;
}
}
} 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__) {
a[i__ + j * a_dim1] *= mul;
}
}
} 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__) {
a[i__ + j * a_dim1] *= mul;
}
}
}
if (! done) {
goto L10;
}
return 0;
/* End of DLASCL */
} /* dlascl_ */
/* Subroutine */ int dpotf2_(char *uplo, integer *n, doublereal *a, integer *
lda, integer *info)
{
/* System generated locals */
integer a_dim1, a_offset, i__1, i__2, i__3;
doublereal d__1;
/* Builtin functions */
double sqrt(doublereal);
/* Local variables */
integer j;
doublereal ajj;
extern doublereal ddot_(integer *, doublereal *, integer *, doublereal *,
integer *);
extern /* Subroutine */ int dscal_(integer *, doublereal *, doublereal *,
integer *);
extern logical lsame_(char *, char *);
extern /* Subroutine */ int dgemv_(char *, integer *, integer *,
doublereal *, doublereal *, integer *, doublereal *, integer *,
doublereal *, doublereal *, integer *);
logical upper;
extern logical disnan_(doublereal *);
extern /* Subroutine */ int xerbla_(char *, integer *);
/* -- LAPACK routine (version 3.2) -- */
/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/* November 2006 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* DPOTF2 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) DOUBLE PRECISION array, dimension (LDA,N) */
/* On entry, the symmetric matrix A. If UPLO = 'U', the leading */
/* n by n upper triangular part of A contains the upper */
/* triangular part of the matrix A, and the strictly lower */
/* triangular part of A is not referenced. If UPLO = 'L', the */
/* leading n by n lower triangular part of A contains the lower */
/* triangular part of the matrix A, and the strictly upper */
/* triangular part of A is not referenced. */
/* On exit, if INFO = 0, the factor U or L from the Cholesky */
/* factorization 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. */
/* ===================================================================== */
/* .. 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;
/* 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_("DPOTF2", &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] - ddot_(&i__2, &a[j * a_dim1 + 1], &c__1,
&a[j * a_dim1 + 1], &c__1);
if (ajj <= 0. || disnan_(&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;
dgemv_("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;
d__1 = 1. / ajj;
dscal_(&i__2, &d__1, &a[j + (j + 1) * a_dim1], lda);
}
/* L10: */
}
} 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] - ddot_(&i__2, &a[j + a_dim1], lda, &a[j
+ a_dim1], lda);
if (ajj <= 0. || disnan_(&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;
dgemv_("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;
d__1 = 1. / ajj;
dscal_(&i__2, &d__1, &a[j + 1 + j * a_dim1], &c__1);
}
/* L20: */
}
}
goto L40;
L30:
*info = j;
L40:
return 0;
/* End of DPOTF2 */
} /* dpotf2_ */
/* Subroutine */ int dlarrf_(integer *n, doublereal *d__, doublereal *l,
doublereal *ld, integer *clstrt, integer *clend, doublereal *w,
doublereal *wgap, doublereal *werr, doublereal *spdiam, doublereal *
clgapl, doublereal *clgapr, doublereal *pivmin, doublereal *sigma,
doublereal *dplus, doublereal *lplus, doublereal *work, integer *info)
{
/* System generated locals */
integer i__1;
doublereal d__1, d__2, d__3;
/* Builtin functions */
double sqrt(doublereal);
/* Local variables */
integer i__;
doublereal s, bestshift, smlgrowth, eps, tmp, max1, max2, rrr1, rrr2,
znm2, growthbound, fail, fact, oldp;
integer indx;
doublereal prod;
integer ktry;
doublereal fail2, avgap, ldmax, rdmax;
integer shift;
extern /* Subroutine */ int dcopy_(integer *, doublereal *, integer *,
doublereal *, integer *);
logical dorrr1;
extern doublereal dlamch_(char *);
doublereal ldelta;
logical nofail;
doublereal mingap, lsigma, rdelta;
extern logical disnan_(doublereal *);
logical forcer;
doublereal rsigma, clwdth;
logical sawnan1, sawnan2, tryrrr1;
/* -- LAPACK auxiliary routine (version 3.1) -- */
/* 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 ), DLARRF 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) DOUBLE PRECISION array, dimension (N) */
/* The N diagonal elements of the diagonal matrix D. */
/* L (input) DOUBLE PRECISION array, dimension (N-1) */
/* The (N-1) subdiagonal elements of the unit bidiagonal */
/* matrix L. */
/* LD (input) DOUBLE PRECISION 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) DOUBLE PRECISION 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) DOUBLE PRECISION array, dimension >= (CLEND-CLSTRT+1) */
/* The separation from the right neighbor eigenvalue in W. */
/* WERR (input) DOUBLE PRECISION 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) DOUBLE PRECISION */
/* The shift used to form L(+) D(+) L(+)^T. */
/* DPLUS (output) DOUBLE PRECISION array, dimension (N) */
/* The N diagonal elements of the diagonal matrix D(+). */
/* LPLUS (output) DOUBLE PRECISION array, dimension (N-1) */
/* The first (N-1) elements of LPLUS contain the subdiagonal */
/* elements of the unit bidiagonal matrix L(+). */
/* WORK (workspace) DOUBLE PRECISION 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.;
eps = dlamch_("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 = (d__1 = w[*clend] - w[*clstrt], abs(d__1)) + werr[*clend] + werr[
*clstrt];
avgap = clwdth / (doublereal) (*clend - *clstrt);
mingap = min(*clgapl,*clgapr);
/* Initial values for shifts to both ends of cluster */
/* Computing MIN */
d__1 = w[*clstrt], d__2 = w[*clend];
lsigma = min(d__1,d__2) - werr[*clstrt];
/* Computing MAX */
d__1 = w[*clstrt], d__2 = w[*clend];
rsigma = max(d__1,d__2) + werr[*clend];
/* Use a small fudge to make sure that we really shift to the outside */
lsigma -= abs(lsigma) * 4. * eps;
rsigma += abs(rsigma) * 4. * eps;
/* Compute upper bounds for how much to back off the initial shifts */
ldmax = mingap * .25 + *pivmin * 2.;
rdmax = mingap * .25 + *pivmin * 2.;
/* Computing MAX */
d__1 = avgap, d__2 = wgap[*clstrt];
ldelta = max(d__1,d__2) / fact;
/* Computing MAX */
d__1 = avgap, d__2 = wgap[*clend - 1];
rdelta = max(d__1,d__2) / fact;
/* Initialize the record of the best representation found */
s = dlamch_("S");
smlgrowth = 1. / s;
fail = (doublereal) (*n - 1) * mingap / (*spdiam * eps);
fail2 = (doublereal) (*n - 1) * mingap / (*spdiam * sqrt(eps));
bestshift = lsigma;
/* while (KTRY <= KTRYMAX) */
ktry = 0;
growthbound = *spdiam * 8.;
L5:
sawnan1 = FALSE_;
sawnan2 = FALSE_;
/* Ensure that we do not back off too much of the initial shifts */
ldelta = min(ldmax,ldelta);
rdelta = min(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 (abs(dplus[1]) < *pivmin) {
dplus[1] = -(*pivmin);
/* Need to set SAWNAN1 because refined RRR test should not be used */
/* in this case */
sawnan1 = TRUE_;
}
max1 = abs(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 ((d__1 = dplus[i__ + 1], abs(d__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 */
d__2 = max1, d__3 = (d__1 = dplus[i__ + 1], abs(d__1));
max1 = max(d__2,d__3);
/* L6: */
}
sawnan1 = sawnan1 || disnan_(&max1);
if (forcer || max1 <= growthbound && ! sawnan1) {
*sigma = lsigma;
shift = 1;
goto L100;
}
/* Right end */
s = -rsigma;
work[1] = d__[1] + s;
if (abs(work[1]) < *pivmin) {
work[1] = -(*pivmin);
/* Need to set SAWNAN2 because refined RRR test should not be used */
/* in this case */
sawnan2 = TRUE_;
}
max2 = abs(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 ((d__1 = work[i__ + 1], abs(d__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 */
d__2 = max2, d__3 = (d__1 = work[i__ + 1], abs(d__1));
max2 = max(d__2,d__3);
/* L7: */
}
sawnan2 = sawnan2 || disnan_(&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. && min(max1,max2) < fail2 && ! sawnan1 && !
sawnan2) {
dorrr1 = TRUE_;
} else {
dorrr1 = FALSE_;
}
tryrrr1 = TRUE_;
if (tryrrr1 && dorrr1) {
if (indx == 1) {
tmp = (d__1 = dplus[*n], abs(d__1));
znm2 = 1.;
prod = 1.;
oldp = 1.;
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 *= (d__1 = work[*n + i__], abs(d__1));
}
oldp = prod;
/* Computing 2nd power */
d__1 = prod;
znm2 += d__1 * d__1;
/* Computing MAX */
d__2 = tmp, d__3 = (d__1 = dplus[i__] * prod, abs(d__1));
tmp = max(d__2,d__3);
/* L15: */
}
rrr1 = tmp / (*spdiam * sqrt(znm2));
if (rrr1 <= 8.) {
*sigma = lsigma;
shift = 1;
goto L100;
}
} else if (indx == 2) {
tmp = (d__1 = work[*n], abs(d__1));
znm2 = 1.;
prod = 1.;
oldp = 1.;
for (i__ = *n - 1; i__ >= 1; --i__) {
if (prod <= eps) {
prod = work[i__ + 1] * lplus[i__ + 1] / (work[i__] *
lplus[i__]) * oldp;
} else {
prod *= (d__1 = lplus[i__], abs(d__1));
}
oldp = prod;
/* Computing 2nd power */
d__1 = prod;
znm2 += d__1 * d__1;
/* Computing MAX */
d__2 = tmp, d__3 = (d__1 = work[i__] * prod, abs(d__1));
tmp = max(d__2,d__3);
/* L16: */
}
rrr2 = tmp / (*spdiam * sqrt(znm2));
if (rrr2 <= 8.) {
*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 */
d__1 = lsigma - ldelta, d__2 = lsigma - ldmax;
lsigma = max(d__1,d__2);
/* Computing MIN */
d__1 = rsigma + rdelta, d__2 = rsigma + rdmax;
rsigma = min(d__1,d__2);
ldelta *= 2.;
rdelta *= 2.;
++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 */
dcopy_(n, &work[1], &c__1, &dplus[1], &c__1);
i__1 = *n - 1;
dcopy_(&i__1, &work[*n + 1], &c__1, &lplus[1], &c__1);
}
return 0;
/* End of DLARRF */
} /* dlarrf_ */
int dlaneg_(int *n, double *d__, double *lld, double *
sigma, double *pivmin, int *r__)
{
/* System generated locals */
int ret_val, i__1, i__2, i__3, i__4;
/* Local variables */
int j;
double p, t;
int bj;
double tmp;
int neg1, neg2;
double bsav, gamma, dplus;
extern int disnan_(double *);
int negcnt;
int sawnan;
double dminus;
/* -- LAPACK auxiliary routine (version 3.2) -- */
/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/* November 2006 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* DLANEG 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 DLARRB. */
/* 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) DOUBLE PRECISION array, dimension (N) */
/* The N diagonal elements of the diagonal matrix D. */
/* LLD (input) DOUBLE PRECISION array, dimension (N-1) */
/* The (N-1) elements L(i)*L(i)*D(i). */
/* SIGMA (input) DOUBLE PRECISION */
/* Shift amount in T - sigma I = L D L^T. */
/* PIVMIN (input) DOUBLE PRECISION */
/* 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.) {
++neg1;
}
tmp = t / dplus;
t = tmp * lld[j] - *sigma;
/* L21: */
}
sawnan = disnan_(&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.) {
++neg1;
}
tmp = t / dplus;
if (disnan_(&tmp)) {
tmp = 1.;
}
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.) {
++neg2;
}
tmp = p / dminus;
p = tmp * d__[j] - *sigma;
/* L23: */
}
sawnan = disnan_(&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.) {
++neg2;
}
tmp = p / dminus;
if (disnan_(&tmp)) {
tmp = 1.;
}
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.) {
++negcnt;
}
ret_val = negcnt;
return ret_val;
} /* dlaneg_ */
/* Subroutine */ int dpstrf_(char *uplo, integer *n, doublereal *a, integer *
lda, integer *piv, integer *rank, doublereal *tol, doublereal *work,
integer *info)
{
/* System generated locals */
integer a_dim1, a_offset, i__1, i__2, i__3, i__4, i__5;
doublereal d__1;
/* Builtin functions */
double sqrt(doublereal);
/* Local variables */
integer i__, j, k, maxlocvar, jb, nb;
doublereal ajj;
integer pvt;
extern /* Subroutine */ int dscal_(integer *, doublereal *, doublereal *,
integer *);
extern logical lsame_(char *, char *);
extern /* Subroutine */ int dgemv_(char *, integer *, integer *,
doublereal *, doublereal *, integer *, doublereal *, integer *,
doublereal *, doublereal *, integer *);
doublereal dtemp;
integer itemp;
extern /* Subroutine */ int dswap_(integer *, doublereal *, integer *,
doublereal *, integer *);
doublereal dstop;
logical upper;
extern /* Subroutine */ int dsyrk_(char *, char *, integer *, integer *,
doublereal *, doublereal *, integer *, doublereal *, doublereal *,
integer *), dpstf2_(char *, integer *,
doublereal *, integer *, integer *, integer *, doublereal *,
doublereal *, integer *);
extern doublereal dlamch_(char *);
extern logical disnan_(doublereal *);
extern /* Subroutine */ int xerbla_(char *, integer *);
extern integer ilaenv_(integer *, char *, char *, integer *, integer *,
integer *, integer *);
extern integer dmaxloc_(doublereal *, integer *);
/* -- LAPACK routine (version 3.2) -- */
/* Craig Lucas, University of Manchester / NAG Ltd. */
/* October, 2008 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* DPSTRF 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) DOUBLE PRECISION array, dimension (LDA,N) */
/* On entry, the symmetric matrix A. If UPLO = 'U', the leading */
/* n by n upper triangular part of A contains the upper */
/* triangular part of the matrix A, and the strictly lower */
/* triangular part of A is not referenced. If UPLO = 'L', the */
/* leading n by n lower triangular part of A contains the lower */
/* triangular part of the matrix A, and the strictly upper */
/* triangular part of A is not referenced. */
/* On exit, if INFO = 0, the factor U or L from the Cholesky */
/* factorization as above. */
/* 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) DOUBLE PRECISION */
/* User defined tolerance. If TOL < 0, then N*U*MAX( A(K,K) ) */
/* will be used. The algorithm terminates at the (K-1)st step */
/* if the pivot <= TOL. */
/* WORK DOUBLE PRECISION array, dimension (2*N) */
/* Work space. */
/* INFO (output) INTEGER */
/* < 0: If INFO = -K, the K-th argument had an illegal value, */
/* = 0: algorithm completed successfully, and */
/* > 0: the matrix A is either rank deficient with computed rank */
/* as returned in RANK, or is indefinite. See Section 7 of */
/* LAPACK Working Note #161 for further information. */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Executable Statements .. */
/* Test the input parameters. */
/* Parameter adjustments */
--work;
--piv;
a_dim1 = *lda;
a_offset = 1 + a_dim1;
a -= a_offset;
/* Function Body */
*info = 0;
upper = lsame_(uplo, "U");
if (! upper && ! lsame_(uplo, "L")) {
*info = -1;
} else if (*n < 0) {
*info = -2;
} else if (*lda < max(1,*n)) {
*info = -4;
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("DPSTRF", &i__1);
return 0;
}
/* Quick return if possible */
if (*n == 0) {
return 0;
}
/* Get block size */
nb = ilaenv_(&c__1, "DPOTRF", uplo, n, &c_n1, &c_n1, &c_n1);
if (nb <= 1 || nb >= *n) {
/* Use unblocked code */
dpstf2_(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. || disnan_(&ajj)) {
*rank = 0;
*info = 1;
goto L200;
}
/* Compute stopping value if not supplied */
if (*tol < 0.) {
dstop = *n * dlamch_("Epsilon") * ajj;
} else {
dstop = *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.;
/* 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 */
d__1 = a[j - 1 + i__ * a_dim1];
work[i__] += d__1 * d__1;
}
work[*n + i__] = a[i__ + i__ * a_dim1] - work[i__];
/* L120: */
}
if (j > 1) {
maxlocvar = (*n << 1) - (*n + j) + 1;
itemp = dmaxloc_(&work[*n + j], &maxlocvar);
pvt = itemp + j - 1;
ajj = work[*n + pvt];
if (ajj <= dstop || disnan_(&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;
dswap_(&i__4, &a[j * a_dim1 + 1], &c__1, &a[pvt *
a_dim1 + 1], &c__1);
if (pvt < *n) {
i__4 = *n - pvt;
dswap_(&i__4, &a[j + (pvt + 1) * a_dim1], lda, &a[
pvt + (pvt + 1) * a_dim1], lda);
}
i__4 = pvt - j - 1;
dswap_(&i__4, &a[j + (j + 1) * a_dim1], lda, &a[j + 1
+ pvt * a_dim1], &c__1);
/* Swap dot products and PIV */
dtemp = work[j];
work[j] = work[pvt];
work[pvt] = dtemp;
itemp = piv[pvt];
piv[pvt] = piv[j];
piv[j] = itemp;
}
ajj = sqrt(ajj);
a[j + j * a_dim1] = ajj;
/* Compute elements J+1:N of row J. */
if (j < *n) {
i__4 = j - k;
i__5 = *n - j;
dgemv_("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;
d__1 = 1. / ajj;
dscal_(&i__4, &d__1, &a[j + (j + 1) * a_dim1], lda);
}
/* L130: */
}
/* Update trailing matrix, J already incremented */
if (k + jb <= *n) {
i__3 = *n - j + 1;
dsyrk_("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.;
/* 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 */
d__1 = a[i__ + (j - 1) * a_dim1];
work[i__] += d__1 * d__1;
}
work[*n + i__] = a[i__ + i__ * a_dim1] - work[i__];
/* L160: */
}
if (j > 1) {
maxlocvar = (*n << 1) - (*n + j) + 1;
itemp = dmaxloc_(&work[*n + j], &maxlocvar);
pvt = itemp + j - 1;
ajj = work[*n + pvt];
if (ajj <= dstop || disnan_(&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;
dswap_(&i__4, &a[j + a_dim1], lda, &a[pvt + a_dim1],
lda);
if (pvt < *n) {
i__4 = *n - pvt;
dswap_(&i__4, &a[pvt + 1 + j * a_dim1], &c__1, &a[
pvt + 1 + pvt * a_dim1], &c__1);
}
i__4 = pvt - j - 1;
dswap_(&i__4, &a[j + 1 + j * a_dim1], &c__1, &a[pvt +
(j + 1) * a_dim1], lda);
/* Swap dot products and PIV */
dtemp = work[j];
work[j] = work[pvt];
work[pvt] = dtemp;
itemp = piv[pvt];
piv[pvt] = piv[j];
piv[j] = itemp;
}
ajj = sqrt(ajj);
a[j + j * a_dim1] = ajj;
/* Compute elements J+1:N of column J. */
if (j < *n) {
i__4 = *n - j;
i__5 = j - k;
dgemv_("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;
d__1 = 1. / ajj;
dscal_(&i__4, &d__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;
dsyrk_("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 DPSTRF */
} /* dpstrf_ */
/* Subroutine */ int dsytf2_(char *uplo, integer *n, doublereal *a, integer *
lda, integer *ipiv, integer *info)
{
/* -- LAPACK routine (version 3.1) --
Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
November 2006
Purpose
=======
DSYTF2 computes the factorization of a real symmetric matrix A using
the Bunch-Kaufman diagonal pivoting method:
A = U*D*U' or A = L*D*L'
where U (or L) is a product of permutation and unit upper (lower)
triangular matrices, U' is the transpose of U, and D is symmetric and
block diagonal with 1-by-1 and 2-by-2 diagonal blocks.
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) DOUBLE PRECISION array, dimension (LDA,N)
On entry, the symmetric matrix A. If UPLO = 'U', the leading
n-by-n upper triangular part of A contains the upper
triangular part of the matrix A, and the strictly lower
triangular part of A is not referenced. If UPLO = 'L', the
leading n-by-n lower triangular part of A contains the lower
triangular part of the matrix A, and the strictly upper
triangular part of A is not referenced.
On exit, the block diagonal matrix D and the multipliers used
to obtain the factor U or L (see below for further details).
LDA (input) INTEGER
The leading dimension of the array A. LDA >= max(1,N).
IPIV (output) INTEGER array, dimension (N)
Details of the interchanges and the block structure of D.
If IPIV(k) > 0, then rows and columns k and IPIV(k) were
interchanged and D(k,k) is a 1-by-1 diagonal block.
If UPLO = 'U' and IPIV(k) = IPIV(k-1) < 0, then rows and
columns k-1 and -IPIV(k) were interchanged and D(k-1:k,k-1:k)
is a 2-by-2 diagonal block. If UPLO = 'L' and IPIV(k) =
IPIV(k+1) < 0, then rows and columns k+1 and -IPIV(k) were
interchanged and D(k:k+1,k:k+1) is a 2-by-2 diagonal block.
INFO (output) INTEGER
= 0: successful exit
< 0: if INFO = -k, the k-th argument had an illegal value
> 0: if INFO = k, D(k,k) is exactly zero. The factorization
has been completed, but the block diagonal matrix D is
exactly singular, and division by zero will occur if it
is used to solve a system of equations.
Further Details
===============
09-29-06 - patch from
Bobby Cheng, MathWorks
Replace l.204 and l.372
IF( MAX( ABSAKK, COLMAX ).EQ.ZERO ) THEN
by
IF( (MAX( ABSAKK, COLMAX ).EQ.ZERO) .OR. DISNAN(ABSAKK) ) THEN
01-01-96 - Based on modifications by
J. Lewis, Boeing Computer Services Company
A. Petitet, Computer Science Dept., Univ. of Tenn., Knoxville, USA
1-96 - Based on modifications by J. Lewis, Boeing Computer Services
Company
If UPLO = 'U', then A = U*D*U', where
U = P(n)*U(n)* ... *P(k)U(k)* ...,
i.e., U is a product of terms P(k)*U(k), where k decreases from n to
1 in steps of 1 or 2, and D is a block diagonal matrix with 1-by-1
and 2-by-2 diagonal blocks D(k). P(k) is a permutation matrix as
defined by IPIV(k), and U(k) is a unit upper triangular matrix, such
that if the diagonal block D(k) is of order s (s = 1 or 2), then
( I v 0 ) k-s
U(k) = ( 0 I 0 ) s
( 0 0 I ) n-k
k-s s n-k
If s = 1, D(k) overwrites A(k,k), and v overwrites A(1:k-1,k).
If s = 2, the upper triangle of D(k) overwrites A(k-1,k-1), A(k-1,k),
and A(k,k), and v overwrites A(1:k-2,k-1:k).
If UPLO = 'L', then A = L*D*L', where
L = P(1)*L(1)* ... *P(k)*L(k)* ...,
i.e., L is a product of terms P(k)*L(k), where k increases from 1 to
n in steps of 1 or 2, and D is a block diagonal matrix with 1-by-1
and 2-by-2 diagonal blocks D(k). P(k) is a permutation matrix as
defined by IPIV(k), and L(k) is a unit lower triangular matrix, such
that if the diagonal block D(k) is of order s (s = 1 or 2), then
( I 0 0 ) k-1
L(k) = ( 0 I 0 ) s
( 0 v I ) n-k-s+1
k-1 s n-k-s+1
If s = 1, D(k) overwrites A(k,k), and v overwrites A(k+1:n,k).
If s = 2, the lower triangle of D(k) overwrites A(k,k), A(k+1,k),
and A(k+1,k+1), and v overwrites A(k+2:n,k:k+1).
=====================================================================
Test the input parameters.
Parameter adjustments */
/* Table of constant values */
static const integer c__1 = 1;
/* System generated locals */
integer a_dim1, a_offset, i__1, i__2;
doublereal d__1, d__2, d__3;
/* Builtin functions */
double sqrt(doublereal);
/* Local variables */
_THREAD_STATIC_ integer i__, j, k;
_THREAD_STATIC_ doublereal t, r1, d11, d12, d21, d22;
_THREAD_STATIC_ integer kk, kp;
_THREAD_STATIC_ doublereal wk, wkm1, wkp1;
_THREAD_STATIC_ integer imax, jmax;
extern /* Subroutine */ int dsyr_(char *, integer *, doublereal *,
doublereal *, integer *, doublereal *, integer *);
_THREAD_STATIC_ doublereal alpha;
extern /* Subroutine */ int dscal_(integer *, doublereal *, doublereal *,
integer *);
extern logical lsame_(char *, char *);
extern /* Subroutine */ int dswap_(integer *, doublereal *, integer *,
doublereal *, integer *);
_THREAD_STATIC_ integer kstep;
_THREAD_STATIC_ logical upper;
_THREAD_STATIC_ doublereal absakk;
extern integer idamax_(integer *, doublereal *, integer *);
extern logical disnan_(doublereal *);
extern /* Subroutine */ int xerbla_(char *, integer *);
_THREAD_STATIC_ doublereal colmax, rowmax;
a_dim1 = *lda;
a_offset = 1 + a_dim1;
a -= a_offset;
--ipiv;
/* 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_("DSYTF2", &i__1);
return 0;
}
/* Initialize ALPHA for use in choosing pivot block size. */
alpha = (sqrt(17.) + 1.) / 8.;
if (upper) {
/* Factorize A as U*D*U' using the upper triangle of A
K is the main loop index, decreasing from N to 1 in steps of
1 or 2 */
k = *n;
L10:
/* If K < 1, exit from loop */
if (k < 1) {
goto L70;
}
kstep = 1;
/* Determine rows and columns to be interchanged and whether
a 1-by-1 or 2-by-2 pivot block will be used */
absakk = (d__1 = a[k + k * a_dim1], abs(d__1));
/* IMAX is the row-index of the largest off-diagonal element in
column K, and COLMAX is its absolute value */
if (k > 1) {
i__1 = k - 1;
imax = idamax_(&i__1, &a[k * a_dim1 + 1], &c__1);
colmax = (d__1 = a[imax + k * a_dim1], abs(d__1));
} else {
colmax = 0.;
}
if (max(absakk,colmax) == 0. || disnan_(&absakk)) {
/* Column K is zero or contains a NaN: set INFO and continue */
if (*info == 0) {
*info = k;
}
kp = k;
} else {
if (absakk >= alpha * colmax) {
/* no interchange, use 1-by-1 pivot block */
kp = k;
} else {
/* JMAX is the column-index of the largest off-diagonal
element in row IMAX, and ROWMAX is its absolute value */
i__1 = k - imax;
jmax = imax + idamax_(&i__1, &a[imax + (imax + 1) * a_dim1],
lda);
rowmax = (d__1 = a[imax + jmax * a_dim1], abs(d__1));
if (imax > 1) {
i__1 = imax - 1;
jmax = idamax_(&i__1, &a[imax * a_dim1 + 1], &c__1);
/* Computing MAX */
d__2 = rowmax, d__3 = (d__1 = a[jmax + imax * a_dim1],
abs(d__1));
rowmax = max(d__2,d__3);
}
if (absakk >= alpha * colmax * (colmax / rowmax)) {
/* no interchange, use 1-by-1 pivot block */
kp = k;
} else if ((d__1 = a[imax + imax * a_dim1], abs(d__1)) >=
alpha * rowmax) {
/* interchange rows and columns K and IMAX, use 1-by-1
pivot block */
kp = imax;
} else {
/* interchange rows and columns K-1 and IMAX, use 2-by-2
pivot block */
kp = imax;
kstep = 2;
}
}
kk = k - kstep + 1;
if (kp != kk) {
/* Interchange rows and columns KK and KP in the leading
submatrix A(1:k,1:k) */
i__1 = kp - 1;
dswap_(&i__1, &a[kk * a_dim1 + 1], &c__1, &a[kp * a_dim1 + 1],
&c__1);
i__1 = kk - kp - 1;
dswap_(&i__1, &a[kp + 1 + kk * a_dim1], &c__1, &a[kp + (kp +
1) * a_dim1], lda);
t = a[kk + kk * a_dim1];
a[kk + kk * a_dim1] = a[kp + kp * a_dim1];
a[kp + kp * a_dim1] = t;
if (kstep == 2) {
t = a[k - 1 + k * a_dim1];
a[k - 1 + k * a_dim1] = a[kp + k * a_dim1];
a[kp + k * a_dim1] = t;
}
}
/* Update the leading submatrix */
if (kstep == 1) {
/* 1-by-1 pivot block D(k): column k now holds
W(k) = U(k)*D(k)
where U(k) is the k-th column of U
Perform a rank-1 update of A(1:k-1,1:k-1) as
A := A - U(k)*D(k)*U(k)' = A - W(k)*1/D(k)*W(k)' */
r1 = 1. / a[k + k * a_dim1];
i__1 = k - 1;
d__1 = -r1;
dsyr_(uplo, &i__1, &d__1, &a[k * a_dim1 + 1], &c__1, &a[
a_offset], lda);
/* Store U(k) in column k */
i__1 = k - 1;
dscal_(&i__1, &r1, &a[k * a_dim1 + 1], &c__1);
} else {
/* 2-by-2 pivot block D(k): columns k and k-1 now hold
( W(k-1) W(k) ) = ( U(k-1) U(k) )*D(k)
where U(k) and U(k-1) are the k-th and (k-1)-th columns
of U
Perform a rank-2 update of A(1:k-2,1:k-2) as
A := A - ( U(k-1) U(k) )*D(k)*( U(k-1) U(k) )'
= A - ( W(k-1) W(k) )*inv(D(k))*( W(k-1) W(k) )' */
if (k > 2) {
d12 = a[k - 1 + k * a_dim1];
d22 = a[k - 1 + (k - 1) * a_dim1] / d12;
d11 = a[k + k * a_dim1] / d12;
t = 1. / (d11 * d22 - 1.);
d12 = t / d12;
for (j = k - 2; j >= 1; --j) {
wkm1 = d12 * (d11 * a[j + (k - 1) * a_dim1] - a[j + k
* a_dim1]);
wk = d12 * (d22 * a[j + k * a_dim1] - a[j + (k - 1) *
a_dim1]);
for (i__ = j; i__ >= 1; --i__) {
a[i__ + j * a_dim1] = a[i__ + j * a_dim1] - a[i__
+ k * a_dim1] * wk - a[i__ + (k - 1) *
a_dim1] * wkm1;
/* L20: */
}
a[j + k * a_dim1] = wk;
a[j + (k - 1) * a_dim1] = wkm1;
/* L30: */
}
}
}
}
/* Store details of the interchanges in IPIV */
if (kstep == 1) {
ipiv[k] = kp;
} else {
ipiv[k] = -kp;
ipiv[k - 1] = -kp;
}
/* Decrease K and return to the start of the main loop */
k -= kstep;
goto L10;
} else {
/* Factorize A as L*D*L' using the lower triangle of A
K is the main loop index, increasing from 1 to N in steps of
1 or 2 */
k = 1;
L40:
/* If K > N, exit from loop */
if (k > *n) {
goto L70;
}
kstep = 1;
/* Determine rows and columns to be interchanged and whether
a 1-by-1 or 2-by-2 pivot block will be used */
absakk = (d__1 = a[k + k * a_dim1], abs(d__1));
/* IMAX is the row-index of the largest off-diagonal element in
column K, and COLMAX is its absolute value */
if (k < *n) {
i__1 = *n - k;
imax = k + idamax_(&i__1, &a[k + 1 + k * a_dim1], &c__1);
colmax = (d__1 = a[imax + k * a_dim1], abs(d__1));
} else {
colmax = 0.;
}
if (max(absakk,colmax) == 0. || disnan_(&absakk)) {
/* Column K is zero or contains a NaN: set INFO and continue */
if (*info == 0) {
*info = k;
}
kp = k;
} else {
if (absakk >= alpha * colmax) {
/* no interchange, use 1-by-1 pivot block */
kp = k;
} else {
/* JMAX is the column-index of the largest off-diagonal
element in row IMAX, and ROWMAX is its absolute value */
i__1 = imax - k;
jmax = k - 1 + idamax_(&i__1, &a[imax + k * a_dim1], lda);
rowmax = (d__1 = a[imax + jmax * a_dim1], abs(d__1));
if (imax < *n) {
i__1 = *n - imax;
jmax = imax + idamax_(&i__1, &a[imax + 1 + imax * a_dim1],
&c__1);
/* Computing MAX */
d__2 = rowmax, d__3 = (d__1 = a[jmax + imax * a_dim1],
abs(d__1));
rowmax = max(d__2,d__3);
}
if (absakk >= alpha * colmax * (colmax / rowmax)) {
/* no interchange, use 1-by-1 pivot block */
kp = k;
} else if ((d__1 = a[imax + imax * a_dim1], abs(d__1)) >=
alpha * rowmax) {
/* interchange rows and columns K and IMAX, use 1-by-1
pivot block */
kp = imax;
} else {
/* interchange rows and columns K+1 and IMAX, use 2-by-2
pivot block */
kp = imax;
kstep = 2;
}
}
kk = k + kstep - 1;
if (kp != kk) {
/* Interchange rows and columns KK and KP in the trailing
submatrix A(k:n,k:n) */
if (kp < *n) {
i__1 = *n - kp;
dswap_(&i__1, &a[kp + 1 + kk * a_dim1], &c__1, &a[kp + 1
+ kp * a_dim1], &c__1);
}
i__1 = kp - kk - 1;
dswap_(&i__1, &a[kk + 1 + kk * a_dim1], &c__1, &a[kp + (kk +
1) * a_dim1], lda);
t = a[kk + kk * a_dim1];
a[kk + kk * a_dim1] = a[kp + kp * a_dim1];
a[kp + kp * a_dim1] = t;
if (kstep == 2) {
t = a[k + 1 + k * a_dim1];
a[k + 1 + k * a_dim1] = a[kp + k * a_dim1];
a[kp + k * a_dim1] = t;
}
}
/* Update the trailing submatrix */
if (kstep == 1) {
/* 1-by-1 pivot block D(k): column k now holds
W(k) = L(k)*D(k)
where L(k) is the k-th column of L */
if (k < *n) {
/* Perform a rank-1 update of A(k+1:n,k+1:n) as
A := A - L(k)*D(k)*L(k)' = A - W(k)*(1/D(k))*W(k)' */
d11 = 1. / a[k + k * a_dim1];
i__1 = *n - k;
d__1 = -d11;
dsyr_(uplo, &i__1, &d__1, &a[k + 1 + k * a_dim1], &c__1, &
a[k + 1 + (k + 1) * a_dim1], lda);
/* Store L(k) in column K */
i__1 = *n - k;
dscal_(&i__1, &d11, &a[k + 1 + k * a_dim1], &c__1);
}
} else {
/* 2-by-2 pivot block D(k) */
if (k < *n - 1) {
/* Perform a rank-2 update of A(k+2:n,k+2:n) as
A := A - ( (A(k) A(k+1))*D(k)**(-1) ) * (A(k) A(k+1))'
where L(k) and L(k+1) are the k-th and (k+1)-th
columns of L */
d21 = a[k + 1 + k * a_dim1];
d11 = a[k + 1 + (k + 1) * a_dim1] / d21;
d22 = a[k + k * a_dim1] / d21;
t = 1. / (d11 * d22 - 1.);
d21 = t / d21;
i__1 = *n;
for (j = k + 2; j <= i__1; ++j) {
wk = d21 * (d11 * a[j + k * a_dim1] - a[j + (k + 1) *
a_dim1]);
wkp1 = d21 * (d22 * a[j + (k + 1) * a_dim1] - a[j + k
* a_dim1]);
i__2 = *n;
for (i__ = j; i__ <= i__2; ++i__) {
a[i__ + j * a_dim1] = a[i__ + j * a_dim1] - a[i__
+ k * a_dim1] * wk - a[i__ + (k + 1) *
a_dim1] * wkp1;
/* L50: */
}
a[j + k * a_dim1] = wk;
a[j + (k + 1) * a_dim1] = wkp1;
/* L60: */
}
}
}
}
/* Store details of the interchanges in IPIV */
if (kstep == 1) {
ipiv[k] = kp;
} else {
ipiv[k] = -kp;
ipiv[k + 1] = -kp;
}
/* Increase K and return to the start of the main loop */
k += kstep;
goto L40;
}
L70:
return 0;
/* End of DSYTF2 */
} /* dsytf2_ */
/* Subroutine */
int zlartg_(doublecomplex *f, doublecomplex *g, doublereal * cs, doublecomplex *sn, doublecomplex *r__)
{
/* System generated locals */
integer i__1;
doublereal d__1, d__2, d__3, d__4, d__5, d__6, d__7, d__8, d__9, d__10;
doublecomplex z__1, z__2, z__3;
/* Builtin functions */
double log(doublereal), pow_di(doublereal *, integer *), d_imag( doublecomplex *), z_abs(doublecomplex *), sqrt(doublereal);
void d_cnjg(doublecomplex *, doublecomplex *);
/* Local variables */
doublereal d__;
integer i__;
doublereal f2, g2;
doublecomplex ff;
doublereal di, dr;
doublecomplex fs, gs;
doublereal f2s, g2s, eps, scale;
integer count;
doublereal safmn2;
extern doublereal dlapy2_(doublereal *, doublereal *);
doublereal safmx2;
extern doublereal dlamch_(char *);
extern logical disnan_(doublereal *);
doublereal safmin;
/* -- LAPACK auxiliary routine (version 3.5.0) -- */
/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */
/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */
/* November 2013 */
/* .. Scalar Arguments .. */
/* .. */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* LOGICAL FIRST */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Statement Functions .. */
/* .. */
/* .. Statement Function definitions .. */
/* .. */
/* .. Executable Statements .. */
safmin = dlamch_("S");
eps = dlamch_("E");
d__1 = dlamch_("B");
i__1 = (integer) (log(safmin / eps) / log(dlamch_("B")) / 2.);
safmn2 = pow_di(&d__1, &i__1);
safmx2 = 1. / safmn2;
/* Computing MAX */
/* Computing MAX */
d__7 = (d__1 = f->r, f2c_abs(d__1));
d__8 = (d__2 = d_imag(f), f2c_abs(d__2)); // , expr subst
/* Computing MAX */
d__9 = (d__3 = g->r, f2c_abs(d__3));
d__10 = (d__4 = d_imag(g), f2c_abs(d__4)); // , expr subst
d__5 = max(d__7,d__8);
d__6 = max(d__9,d__10); // , expr subst
scale = max(d__5,d__6);
fs.r = f->r;
fs.i = f->i; // , expr subst
gs.r = g->r;
gs.i = g->i; // , expr subst
count = 0;
if (scale >= safmx2)
{
L10:
++count;
z__1.r = safmn2 * fs.r;
z__1.i = safmn2 * fs.i; // , expr subst
fs.r = z__1.r;
fs.i = z__1.i; // , expr subst
z__1.r = safmn2 * gs.r;
z__1.i = safmn2 * gs.i; // , expr subst
gs.r = z__1.r;
gs.i = z__1.i; // , expr subst
scale *= safmn2;
if (scale >= safmx2)
{
goto L10;
}
}
else if (scale <= safmn2)
{
d__1 = z_abs(g);
if (g->r == 0. && g->i == 0. || disnan_(&d__1))
{
*cs = 1.;
sn->r = 0., sn->i = 0.;
r__->r = f->r, r__->i = f->i;
return 0;
}
L20:
--count;
z__1.r = safmx2 * fs.r;
z__1.i = safmx2 * fs.i; // , expr subst
fs.r = z__1.r;
fs.i = z__1.i; // , expr subst
z__1.r = safmx2 * gs.r;
z__1.i = safmx2 * gs.i; // , expr subst
gs.r = z__1.r;
gs.i = z__1.i; // , expr subst
scale *= safmx2;
if (scale <= safmn2)
{
goto L20;
}
}
/* Computing 2nd power */
d__1 = fs.r;
/* Computing 2nd power */
d__2 = d_imag(&fs);
f2 = d__1 * d__1 + d__2 * d__2;
/* Computing 2nd power */
d__1 = gs.r;
/* Computing 2nd power */
d__2 = d_imag(&gs);
g2 = d__1 * d__1 + d__2 * d__2;
if (f2 <= max(g2,1.) * safmin)
{
/* This is a rare case: F is very small. */
if (f->r == 0. && f->i == 0.)
{
*cs = 0.;
d__2 = g->r;
d__3 = d_imag(g);
d__1 = dlapy2_(&d__2, &d__3);
r__->r = d__1, r__->i = 0.;
/* Do complex/real division explicitly with two real divisions */
d__1 = gs.r;
d__2 = d_imag(&gs);
d__ = dlapy2_(&d__1, &d__2);
d__1 = gs.r / d__;
d__2 = -d_imag(&gs) / d__;
z__1.r = d__1;
z__1.i = d__2; // , expr subst
sn->r = z__1.r, sn->i = z__1.i;
return 0;
}
d__1 = fs.r;
d__2 = d_imag(&fs);
f2s = dlapy2_(&d__1, &d__2);
/* G2 and G2S are accurate */
/* G2 is at least SAFMIN, and G2S is at least SAFMN2 */
g2s = sqrt(g2);
/* Error in CS from underflow in F2S is at most */
/* UNFL / SAFMN2 .lt. sqrt(UNFL*EPS) .lt. EPS */
/* If MAX(G2,ONE)=G2, then F2 .lt. G2*SAFMIN, */
/* and so CS .lt. sqrt(SAFMIN) */
/* If MAX(G2,ONE)=ONE, then F2 .lt. SAFMIN */
/* and so CS .lt. sqrt(SAFMIN)/SAFMN2 = sqrt(EPS) */
/* Therefore, CS = F2S/G2S / sqrt( 1 + (F2S/G2S)**2 ) = F2S/G2S */
*cs = f2s / g2s;
/* Make sure f2c_abs(FF) = 1 */
/* Do complex/real division explicitly with 2 real divisions */
/* Computing MAX */
d__3 = (d__1 = f->r, f2c_abs(d__1));
d__4 = (d__2 = d_imag(f), f2c_abs(d__2)); // , expr subst
if (max(d__3,d__4) > 1.)
{
d__1 = f->r;
d__2 = d_imag(f);
d__ = dlapy2_(&d__1, &d__2);
d__1 = f->r / d__;
d__2 = d_imag(f) / d__;
z__1.r = d__1;
z__1.i = d__2; // , expr subst
ff.r = z__1.r;
ff.i = z__1.i; // , expr subst
}
else
{
dr = safmx2 * f->r;
di = safmx2 * d_imag(f);
d__ = dlapy2_(&dr, &di);
d__1 = dr / d__;
d__2 = di / d__;
z__1.r = d__1;
z__1.i = d__2; // , expr subst
ff.r = z__1.r;
ff.i = z__1.i; // , expr subst
}
d__1 = gs.r / g2s;
d__2 = -d_imag(&gs) / g2s;
z__2.r = d__1;
z__2.i = d__2; // , expr subst
z__1.r = ff.r * z__2.r - ff.i * z__2.i;
z__1.i = ff.r * z__2.i + ff.i * z__2.r; // , expr subst
sn->r = z__1.r, sn->i = z__1.i;
z__2.r = *cs * f->r;
z__2.i = *cs * f->i; // , expr subst
z__3.r = sn->r * g->r - sn->i * g->i;
z__3.i = sn->r * g->i + sn->i * g->r; // , expr subst
z__1.r = z__2.r + z__3.r;
z__1.i = z__2.i + z__3.i; // , expr subst
r__->r = z__1.r, r__->i = z__1.i;
}
else
{
/* This is the most common case. */
/* Neither F2 nor F2/G2 are less than SAFMIN */
/* F2S cannot overflow, and it is accurate */
f2s = sqrt(g2 / f2 + 1.);
/* Do the F2S(real)*FS(complex) multiply with two real multiplies */
d__1 = f2s * fs.r;
d__2 = f2s * d_imag(&fs);
z__1.r = d__1;
z__1.i = d__2; // , expr subst
r__->r = z__1.r, r__->i = z__1.i;
*cs = 1. / f2s;
d__ = f2 + g2;
/* Do complex/real division explicitly with two real divisions */
d__1 = r__->r / d__;
d__2 = d_imag(r__) / d__;
z__1.r = d__1;
z__1.i = d__2; // , expr subst
sn->r = z__1.r, sn->i = z__1.i;
d_cnjg(&z__2, &gs);
z__1.r = sn->r * z__2.r - sn->i * z__2.i;
z__1.i = sn->r * z__2.i + sn->i * z__2.r; // , expr subst
sn->r = z__1.r, sn->i = z__1.i;
if (count != 0)
{
if (count > 0)
{
i__1 = count;
for (i__ = 1;
i__ <= i__1;
++i__)
{
z__1.r = safmx2 * r__->r;
z__1.i = safmx2 * r__->i; // , expr subst
r__->r = z__1.r, r__->i = z__1.i;
/* L30: */
}
}
else
{
i__1 = -count;
for (i__ = 1;
i__ <= i__1;
++i__)
{
z__1.r = safmn2 * r__->r;
z__1.i = safmn2 * r__->i; // , expr subst
r__->r = z__1.r, r__->i = z__1.i;
/* L40: */
}
}
}
}
return 0;
/* End of ZLARTG */
}
