/* DECK IMTQLV */
/* Subroutine */ int imtqlv_(integer *n, real *d__, real *e, real *e2, real *
w, integer *ind, integer *ierr, real *rv1)
{
/* System generated locals */
integer i__1, i__2;
real r__1, r__2;
/* Local variables */
static real b, c__, f, g;
static integer i__, j, k, l, m;
static real p, r__, s, s1, s2;
static integer ii, tag, mml;
extern doublereal pythag_(real *, real *);
/* ***BEGIN PROLOGUE IMTQLV */
/* ***PURPOSE Compute the eigenvalues of a symmetric tridiagonal matrix */
/* using the implicit QL method. Eigenvectors may be computed */
/* later. */
/* ***LIBRARY SLATEC (EISPACK) */
/* ***CATEGORY D4A5, D4C2A */
/* ***TYPE SINGLE PRECISION (IMTQLV-S) */
/* ***KEYWORDS EIGENVALUES, EIGENVECTORS, EISPACK */
/* ***AUTHOR Smith, B. T., et al. */
/* ***DESCRIPTION */
/* This subroutine is a variant of IMTQL1 which is a translation of */
/* ALGOL procedure IMTQL1, NUM. MATH. 12, 377-383(1968) by Martin and */
/* Wilkinson, as modified in NUM. MATH. 15, 450(1970) by Dubrulle. */
/* HANDBOOK FOR AUTO. COMP., VOL.II-LINEAR ALGEBRA, 241-248(1971). */
/* This subroutine finds the eigenvalues of a SYMMETRIC TRIDIAGONAL */
/* matrix by the implicit QL method and associates with them */
/* their corresponding submatrix indices. */
/* On INPUT */
/* N is the order of the matrix. N is an INTEGER variable. */
/* D contains the diagonal elements of the symmetric tridiagonal */
/* matrix. D is a one-dimensional REAL array, dimensioned D(N). */
/* E contains the subdiagonal elements of the symmetric */
/* tridiagonal matrix in its last N-1 positions. E(1) is */
/* arbitrary. E is a one-dimensional REAL array, dimensioned */
/* E(N). */
/* E2 contains the squares of the corresponding elements of E in */
/* its last N-1 positions. E2(1) is arbitrary. E2 is a one- */
/* dimensional REAL array, dimensioned E2(N). */
/* On OUTPUT */
/* D and E are unaltered. */
/* Elements of E2, corresponding to elements of E regarded as */
/* negligible, have been replaced by zero causing the matrix to */
/* split into a direct sum of submatrices. E2(1) is also set */
/* to zero. */
/* W contains the eigenvalues in ascending order. If an error */
/* exit is made, the eigenvalues are correct and ordered for */
/* indices 1, 2, ..., IERR-1, but may not be the smallest */
/* eigenvalues. W is a one-dimensional REAL array, dimensioned */
/* W(N). */
/* IND contains the submatrix indices associated with the */
/* corresponding eigenvalues in W -- 1 for eigenvalues belonging */
/* to the first submatrix from the top, 2 for those belonging to */
/* the second submatrix, etc. IND is a one-dimensional REAL */
/* array, dimensioned IND(N). */
/* IERR is an INTEGER flag set to */
/* Zero for normal return, */
/* J if the J-th eigenvalue has not been */
/* determined after 30 iterations. */
/* The eigenvalues should be correct for indices */
/* 1, 2, ..., IERR-1. These eigenvalues are */
/* ordered, but are not necessarily the smallest. */
/* RV1 is a one-dimensional REAL array used for temporary storage, */
/* dimensioned RV1(N). */
/* Calls PYTHAG(A,B) for sqrt(A**2 + B**2). */
/* Questions and comments should be directed to B. S. Garbow, */
/* APPLIED MATHEMATICS DIVISION, ARGONNE NATIONAL LABORATORY */
/* ------------------------------------------------------------------ */
/* ***REFERENCES B. T. Smith, J. M. Boyle, J. J. Dongarra, B. S. Garbow, */
/* Y. Ikebe, V. C. Klema and C. B. Moler, Matrix Eigen- */
/* system Routines - EISPACK Guide, Springer-Verlag, */
/* 1976. */
/* ***ROUTINES CALLED PYTHAG */
/* ***REVISION HISTORY (YYMMDD) */
/* 760101 DATE WRITTEN */
/* 890831 Modified array declarations. (WRB) */
/* 890831 REVISION DATE from Version 3.2 */
/* 891214 Prologue converted to Version 4.0 format. (BAB) */
/* 920501 Reformatted the REFERENCES section. (WRB) */
/* ***END PROLOGUE IMTQLV */
/* ***FIRST EXECUTABLE STATEMENT IMTQLV */
/* Parameter adjustments */
--rv1;
--ind;
--w;
--e2;
--e;
--d__;
/* Function Body */
*ierr = 0;
k = 0;
tag = 0;
i__1 = *n;
for (i__ = 1; i__ <= i__1; ++i__) {
w[i__] = d__[i__];
if (i__ != 1) {
rv1[i__ - 1] = e[i__];
}
/* L100: */
}
e2[1] = 0.f;
rv1[*n] = 0.f;
i__1 = *n;
for (l = 1; l <= i__1; ++l) {
j = 0;
/* .......... LOOK FOR SMALL SUB-DIAGONAL ELEMENT .......... */
L105:
i__2 = *n;
for (m = l; m <= i__2; ++m) {
if (m == *n) {
goto L120;
}
s1 = (r__1 = w[m], dabs(r__1)) + (r__2 = w[m + 1], dabs(r__2));
s2 = s1 + (r__1 = rv1[m], dabs(r__1));
if (s2 == s1) {
goto L120;
}
/* .......... GUARD AGAINST UNDERFLOWED ELEMENT OF E2 .......... */
if (e2[m + 1] == 0.f) {
goto L125;
}
/* L110: */
}
L120:
if (m <= k) {
goto L130;
}
if (m != *n) {
e2[m + 1] = 0.f;
}
L125:
k = m;
++tag;
L130:
p = w[l];
if (m == l) {
goto L215;
}
if (j == 30) {
goto L1000;
}
++j;
/* .......... FORM SHIFT .......... */
g = (w[l + 1] - p) / (rv1[l] * 2.f);
r__ = pythag_(&g, &c_b11);
g = w[m] - p + rv1[l] / (g + r_sign(&r__, &g));
s = 1.f;
c__ = 1.f;
p = 0.f;
mml = m - l;
/* .......... FOR I=M-1 STEP -1 UNTIL L DO -- .......... */
i__2 = mml;
for (ii = 1; ii <= i__2; ++ii) {
i__ = m - ii;
f = s * rv1[i__];
b = c__ * rv1[i__];
if (dabs(f) < dabs(g)) {
goto L150;
}
c__ = g / f;
r__ = sqrt(c__ * c__ + 1.f);
rv1[i__ + 1] = f * r__;
s = 1.f / r__;
c__ *= s;
goto L160;
L150:
s = f / g;
r__ = sqrt(s * s + 1.f);
rv1[i__ + 1] = g * r__;
c__ = 1.f / r__;
s *= c__;
L160:
g = w[i__ + 1] - p;
r__ = (w[i__] - g) * s + c__ * 2.f * b;
p = s * r__;
w[i__ + 1] = g + p;
g = c__ * r__ - b;
/* L200: */
}
w[l] -= p;
rv1[l] = g;
rv1[m] = 0.f;
goto L105;
/* .......... ORDER EIGENVALUES .......... */
L215:
if (l == 1) {
goto L250;
}
/* .......... FOR I=L STEP -1 UNTIL 2 DO -- .......... */
i__2 = l;
for (ii = 2; ii <= i__2; ++ii) {
i__ = l + 2 - ii;
if (p >= w[i__ - 1]) {
goto L270;
}
w[i__] = w[i__ - 1];
ind[i__] = ind[i__ - 1];
/* L230: */
}
L250:
i__ = 1;
L270:
w[i__] = p;
ind[i__] = tag;
/* L290: */
}
goto L1001;
/* .......... SET ERROR -- NO CONVERGENCE TO AN */
/* EIGENVALUE AFTER 30 ITERATIONS .......... */
L1000:
*ierr = l;
L1001:
return 0;
} /* imtqlv_ */
/* DECK IMTQL2 */
/* Subroutine */ int imtql2_(integer *nm, integer *n, real *d__, real *e,
real *z__, integer *ierr)
{
/* System generated locals */
integer z_dim1, z_offset, i__1, i__2, i__3;
real r__1, r__2;
/* Local variables */
static real b, c__, f, g;
static integer i__, j, k, l, m;
static real p, r__, s, s1, s2;
static integer ii, mml;
extern doublereal pythag_(real *, real *);
/* ***BEGIN PROLOGUE IMTQL2 */
/* ***PURPOSE Compute the eigenvalues and eigenvectors of a symmetric */
/* tridiagonal matrix using the implicit QL method. */
/* ***LIBRARY SLATEC (EISPACK) */
/* ***CATEGORY D4A5, D4C2A */
/* ***TYPE SINGLE PRECISION (IMTQL2-S) */
/* ***KEYWORDS EIGENVALUES, EIGENVECTORS, EISPACK */
/* ***AUTHOR Smith, B. T., et al. */
/* ***DESCRIPTION */
/* This subroutine is a translation of the ALGOL procedure IMTQL2, */
/* NUM. MATH. 12, 377-383(1968) by Martin and Wilkinson, */
/* as modified in NUM. MATH. 15, 450(1970) by Dubrulle. */
/* HANDBOOK FOR AUTO. COMP., VOL.II-LINEAR ALGEBRA, 241-248(1971). */
/* This subroutine finds the eigenvalues and eigenvectors */
/* of a SYMMETRIC TRIDIAGONAL matrix by the implicit QL method. */
/* The eigenvectors of a FULL SYMMETRIC matrix can also */
/* be found if TRED2 has been used to reduce this */
/* full matrix to tridiagonal form. */
/* On INPUT */
/* NM must be set to the row dimension of the two-dimensional */
/* array parameter, Z, as declared in the calling program */
/* dimension statement. NM is an INTEGER variable. */
/* N is the order of the matrix. N is an INTEGER variable. */
/* N must be less than or equal to NM. */
/* D contains the diagonal elements of the symmetric tridiagonal */
/* matrix. D is a one-dimensional REAL array, dimensioned D(N). */
/* E contains the subdiagonal elements of the symmetric */
/* tridiagonal matrix in its last N-1 positions. E(1) is */
/* arbitrary. E is a one-dimensional REAL array, dimensioned */
/* E(N). */
/* Z contains the transformation matrix produced in the reduction */
/* by TRED2, if performed. This transformation matrix is */
/* necessary if you want to obtain the eigenvectors of the full */
/* symmetric matrix. If the eigenvectors of the symmetric */
/* tridiagonal matrix are desired, Z must contain the identity */
/* matrix. Z is a two-dimensional REAL array, dimensioned */
/* Z(NM,N). */
/* On OUTPUT */
/* D contains the eigenvalues in ascending order. If an */
/* error exit is made, the eigenvalues are correct but */
/* unordered for indices 1, 2, ..., IERR-1. */
/* E has been destroyed. */
/* Z contains orthonormal eigenvectors of the full symmetric */
/* or symmetric tridiagonal matrix, depending on what it */
/* contained on input. If an error exit is made, Z contains */
/* the eigenvectors associated with the stored eigenvalues. */
/* IERR is an INTEGER flag set to */
/* Zero for normal return, */
/* J if the J-th eigenvalue has not been */
/* determined after 30 iterations. */
/* The eigenvalues and eigenvectors should be correct */
/* for indices 1, 2, ..., IERR-1, but the eigenvalues */
/* are not ordered. */
/* Calls PYTHAG(A,B) for sqrt(A**2 + B**2). */
/* Questions and comments should be directed to B. S. Garbow, */
/* APPLIED MATHEMATICS DIVISION, ARGONNE NATIONAL LABORATORY */
/* ------------------------------------------------------------------ */
/* ***REFERENCES B. T. Smith, J. M. Boyle, J. J. Dongarra, B. S. Garbow, */
/* Y. Ikebe, V. C. Klema and C. B. Moler, Matrix Eigen- */
/* system Routines - EISPACK Guide, Springer-Verlag, */
/* 1976. */
/* ***ROUTINES CALLED PYTHAG */
/* ***REVISION HISTORY (YYMMDD) */
/* 760101 DATE WRITTEN */
/* 890831 Modified array declarations. (WRB) */
/* 890831 REVISION DATE from Version 3.2 */
/* 891214 Prologue converted to Version 4.0 format. (BAB) */
/* 920501 Reformatted the REFERENCES section. (WRB) */
/* ***END PROLOGUE IMTQL2 */
/* ***FIRST EXECUTABLE STATEMENT IMTQL2 */
/* Parameter adjustments */
z_dim1 = *nm;
z_offset = 1 + z_dim1;
z__ -= z_offset;
--d__;
--e;
/* Function Body */
*ierr = 0;
if (*n == 1) {
goto L1001;
}
i__1 = *n;
for (i__ = 2; i__ <= i__1; ++i__) {
/* L100: */
e[i__ - 1] = e[i__];
}
e[*n] = 0.f;
i__1 = *n;
for (l = 1; l <= i__1; ++l) {
j = 0;
/* .......... LOOK FOR SMALL SUB-DIAGONAL ELEMENT .......... */
L105:
i__2 = *n;
for (m = l; m <= i__2; ++m) {
if (m == *n) {
goto L120;
}
s1 = (r__1 = d__[m], dabs(r__1)) + (r__2 = d__[m + 1], dabs(r__2))
;
s2 = s1 + (r__1 = e[m], dabs(r__1));
if (s2 == s1) {
goto L120;
}
/* L110: */
}
L120:
p = d__[l];
if (m == l) {
goto L240;
}
if (j == 30) {
goto L1000;
}
++j;
/* .......... FORM SHIFT .......... */
g = (d__[l + 1] - p) / (e[l] * 2.f);
r__ = pythag_(&g, &c_b9);
g = d__[m] - p + e[l] / (g + r_sign(&r__, &g));
s = 1.f;
c__ = 1.f;
p = 0.f;
mml = m - l;
/* .......... FOR I=M-1 STEP -1 UNTIL L DO -- .......... */
i__2 = mml;
for (ii = 1; ii <= i__2; ++ii) {
i__ = m - ii;
f = s * e[i__];
b = c__ * e[i__];
if (dabs(f) < dabs(g)) {
goto L150;
}
c__ = g / f;
r__ = sqrt(c__ * c__ + 1.f);
e[i__ + 1] = f * r__;
s = 1.f / r__;
c__ *= s;
goto L160;
L150:
s = f / g;
r__ = sqrt(s * s + 1.f);
e[i__ + 1] = g * r__;
c__ = 1.f / r__;
s *= c__;
L160:
g = d__[i__ + 1] - p;
r__ = (d__[i__] - g) * s + c__ * 2.f * b;
p = s * r__;
d__[i__ + 1] = g + p;
g = c__ * r__ - b;
/* .......... FORM VECTOR .......... */
i__3 = *n;
for (k = 1; k <= i__3; ++k) {
f = z__[k + (i__ + 1) * z_dim1];
z__[k + (i__ + 1) * z_dim1] = s * z__[k + i__ * z_dim1] + c__
* f;
z__[k + i__ * z_dim1] = c__ * z__[k + i__ * z_dim1] - s * f;
/* L180: */
}
/* L200: */
}
d__[l] -= p;
e[l] = g;
e[m] = 0.f;
goto L105;
L240:
;
}
/* .......... ORDER EIGENVALUES AND EIGENVECTORS .......... */
i__1 = *n;
for (ii = 2; ii <= i__1; ++ii) {
i__ = ii - 1;
k = i__;
p = d__[i__];
i__2 = *n;
for (j = ii; j <= i__2; ++j) {
if (d__[j] >= p) {
goto L260;
}
k = j;
p = d__[j];
L260:
;
}
if (k == i__) {
goto L300;
}
d__[k] = d__[i__];
d__[i__] = p;
i__2 = *n;
for (j = 1; j <= i__2; ++j) {
p = z__[j + i__ * z_dim1];
z__[j + i__ * z_dim1] = z__[j + k * z_dim1];
z__[j + k * z_dim1] = p;
/* L280: */
}
L300:
;
}
goto L1001;
/* .......... SET ERROR -- NO CONVERGENCE TO AN */
/* EIGENVALUE AFTER 30 ITERATIONS .......... */
L1000:
*ierr = l;
L1001:
return 0;
} /* imtql2_ */
/* DECK HTRIDI */
/* Subroutine */ int htridi_(integer *nm, integer *n, real *ar, real *ai,
real *d__, real *e, real *e2, real *tau)
{
/* System generated locals */
integer ar_dim1, ar_offset, ai_dim1, ai_offset, i__1, i__2, i__3;
real r__1, r__2;
/* Local variables */
static real f, g, h__;
static integer i__, j, k, l;
static real fi, gi, hh;
static integer ii;
static real si;
static integer jp1;
static real scale;
extern doublereal pythag_(real *, real *);
/* ***BEGIN PROLOGUE HTRIDI */
/* ***PURPOSE Reduce a complex Hermitian matrix to a real symmetric */
/* tridiagonal matrix using unitary similarity */
/* transformations. */
/* ***LIBRARY SLATEC (EISPACK) */
/* ***CATEGORY D4C1B1 */
/* ***TYPE SINGLE PRECISION (HTRIDI-S) */
/* ***KEYWORDS EIGENVALUES, EIGENVECTORS, EISPACK */
/* ***AUTHOR Smith, B. T., et al. */
/* ***DESCRIPTION */
/* This subroutine is a translation of a complex analogue of */
/* the ALGOL procedure TRED1, NUM. MATH. 11, 181-195(1968) */
/* by Martin, Reinsch, and Wilkinson. */
/* HANDBOOK FOR AUTO. COMP., VOL.II-LINEAR ALGEBRA, 212-226(1971). */
/* This subroutine reduces a COMPLEX HERMITIAN matrix */
/* to a real symmetric tridiagonal matrix using */
/* unitary similarity transformations. */
/* On INPUT */
/* NM must be set to the row dimension of the two-dimensional */
/* array parameters, AR and AI, as declared in the calling */
/* program dimension statement. NM is an INTEGER variable. */
/* N is the order of the matrix A=(AR,AI). N is an INTEGER */
/* variable. N must be less than or equal to NM. */
/* AR and AI contain the real and imaginary parts, respectively, */
/* of the complex Hermitian input matrix. Only the lower */
/* triangle of the matrix need be supplied. AR and AI are two- */
/* dimensional REAL arrays, dimensioned AR(NM,N) and AI(NM,N). */
/* On OUTPUT */
/* AR and AI contain some information about the unitary trans- */
/* formations used in the reduction in the strict lower triangle */
/* of AR and the full lower triangle of AI. The rest of the */
/* matrices are unaltered. */
/* D contains the diagonal elements of the real symmetric */
/* tridiagonal matrix. D is a one-dimensional REAL array, */
/* dimensioned D(N). */
/* E contains the subdiagonal elements of the real tridiagonal */
/* matrix in its last N-1 positions. E(1) is set to zero. */
/* E is a one-dimensional REAL array, dimensioned E(N). */
/* E2 contains the squares of the corresponding elements of E. */
/* E2(1) is set to zero. E2 may coincide with E if the squares */
/* are not needed. E2 is a one-dimensional REAL array, */
/* dimensioned E2(N). */
/* TAU contains further information about the transformations. */
/* TAU is a one-dimensional REAL array, dimensioned TAU(2,N). */
/* Calls PYTHAG(A,B) for sqrt(A**2 + B**2). */
/* Questions and comments should be directed to B. S. Garbow, */
/* APPLIED MATHEMATICS DIVISION, ARGONNE NATIONAL LABORATORY */
/* ------------------------------------------------------------------ */
/* ***REFERENCES B. T. Smith, J. M. Boyle, J. J. Dongarra, B. S. Garbow, */
/* Y. Ikebe, V. C. Klema and C. B. Moler, Matrix Eigen- */
/* system Routines - EISPACK Guide, Springer-Verlag, */
/* 1976. */
/* ***ROUTINES CALLED PYTHAG */
/* ***REVISION HISTORY (YYMMDD) */
/* 760101 DATE WRITTEN */
/* 890831 Modified array declarations. (WRB) */
/* 890831 REVISION DATE from Version 3.2 */
/* 891214 Prologue converted to Version 4.0 format. (BAB) */
/* 920501 Reformatted the REFERENCES section. (WRB) */
/* ***END PROLOGUE HTRIDI */
/* ***FIRST EXECUTABLE STATEMENT HTRIDI */
/* Parameter adjustments */
ai_dim1 = *nm;
ai_offset = 1 + ai_dim1;
ai -= ai_offset;
ar_dim1 = *nm;
ar_offset = 1 + ar_dim1;
ar -= ar_offset;
--d__;
--e;
--e2;
tau -= 3;
/* Function Body */
tau[(*n << 1) + 1] = 1.f;
tau[(*n << 1) + 2] = 0.f;
i__1 = *n;
for (i__ = 1; i__ <= i__1; ++i__) {
/* L100: */
d__[i__] = ar[i__ + i__ * ar_dim1];
}
/* .......... FOR I=N STEP -1 UNTIL 1 DO -- .......... */
i__1 = *n;
for (ii = 1; ii <= i__1; ++ii) {
i__ = *n + 1 - ii;
l = i__ - 1;
h__ = 0.f;
scale = 0.f;
if (l < 1) {
goto L130;
}
/* .......... SCALE ROW (ALGOL TOL THEN NOT NEEDED) .......... */
i__2 = l;
for (k = 1; k <= i__2; ++k) {
/* L120: */
scale = scale + (r__1 = ar[i__ + k * ar_dim1], dabs(r__1)) + (
r__2 = ai[i__ + k * ai_dim1], dabs(r__2));
}
if (scale != 0.f) {
goto L140;
}
tau[(l << 1) + 1] = 1.f;
tau[(l << 1) + 2] = 0.f;
L130:
e[i__] = 0.f;
e2[i__] = 0.f;
goto L290;
L140:
i__2 = l;
for (k = 1; k <= i__2; ++k) {
ar[i__ + k * ar_dim1] /= scale;
ai[i__ + k * ai_dim1] /= scale;
h__ = h__ + ar[i__ + k * ar_dim1] * ar[i__ + k * ar_dim1] + ai[
i__ + k * ai_dim1] * ai[i__ + k * ai_dim1];
/* L150: */
}
e2[i__] = scale * scale * h__;
g = sqrt(h__);
e[i__] = scale * g;
f = pythag_(&ar[i__ + l * ar_dim1], &ai[i__ + l * ai_dim1]);
/* .......... FORM NEXT DIAGONAL ELEMENT OF MATRIX T .......... */
if (f == 0.f) {
goto L160;
}
tau[(l << 1) + 1] = (ai[i__ + l * ai_dim1] * tau[(i__ << 1) + 2] - ar[
i__ + l * ar_dim1] * tau[(i__ << 1) + 1]) / f;
si = (ar[i__ + l * ar_dim1] * tau[(i__ << 1) + 2] + ai[i__ + l *
ai_dim1] * tau[(i__ << 1) + 1]) / f;
h__ += f * g;
g = g / f + 1.f;
ar[i__ + l * ar_dim1] = g * ar[i__ + l * ar_dim1];
ai[i__ + l * ai_dim1] = g * ai[i__ + l * ai_dim1];
if (l == 1) {
goto L270;
}
goto L170;
L160:
tau[(l << 1) + 1] = -tau[(i__ << 1) + 1];
si = tau[(i__ << 1) + 2];
ar[i__ + l * ar_dim1] = g;
L170:
f = 0.f;
i__2 = l;
for (j = 1; j <= i__2; ++j) {
g = 0.f;
gi = 0.f;
/* .......... FORM ELEMENT OF A*U .......... */
i__3 = j;
for (k = 1; k <= i__3; ++k) {
g = g + ar[j + k * ar_dim1] * ar[i__ + k * ar_dim1] + ai[j +
k * ai_dim1] * ai[i__ + k * ai_dim1];
gi = gi - ar[j + k * ar_dim1] * ai[i__ + k * ai_dim1] + ai[j
+ k * ai_dim1] * ar[i__ + k * ar_dim1];
/* L180: */
}
jp1 = j + 1;
if (l < jp1) {
goto L220;
}
i__3 = l;
for (k = jp1; k <= i__3; ++k) {
g = g + ar[k + j * ar_dim1] * ar[i__ + k * ar_dim1] - ai[k +
j * ai_dim1] * ai[i__ + k * ai_dim1];
gi = gi - ar[k + j * ar_dim1] * ai[i__ + k * ai_dim1] - ai[k
+ j * ai_dim1] * ar[i__ + k * ar_dim1];
/* L200: */
}
/* .......... FORM ELEMENT OF P .......... */
L220:
e[j] = g / h__;
tau[(j << 1) + 2] = gi / h__;
f = f + e[j] * ar[i__ + j * ar_dim1] - tau[(j << 1) + 2] * ai[i__
+ j * ai_dim1];
/* L240: */
}
hh = f / (h__ + h__);
/* .......... FORM REDUCED A .......... */
i__2 = l;
for (j = 1; j <= i__2; ++j) {
f = ar[i__ + j * ar_dim1];
g = e[j] - hh * f;
e[j] = g;
fi = -ai[i__ + j * ai_dim1];
gi = tau[(j << 1) + 2] - hh * fi;
tau[(j << 1) + 2] = -gi;
i__3 = j;
for (k = 1; k <= i__3; ++k) {
ar[j + k * ar_dim1] = ar[j + k * ar_dim1] - f * e[k] - g * ar[
i__ + k * ar_dim1] + fi * tau[(k << 1) + 2] + gi * ai[
i__ + k * ai_dim1];
ai[j + k * ai_dim1] = ai[j + k * ai_dim1] - f * tau[(k << 1)
+ 2] - g * ai[i__ + k * ai_dim1] - fi * e[k] - gi *
ar[i__ + k * ar_dim1];
/* L260: */
}
}
L270:
i__3 = l;
for (k = 1; k <= i__3; ++k) {
ar[i__ + k * ar_dim1] = scale * ar[i__ + k * ar_dim1];
ai[i__ + k * ai_dim1] = scale * ai[i__ + k * ai_dim1];
/* L280: */
}
tau[(l << 1) + 2] = -si;
L290:
hh = d__[i__];
d__[i__] = ar[i__ + i__ * ar_dim1];
ar[i__ + i__ * ar_dim1] = hh;
ai[i__ + i__ * ai_dim1] = scale * sqrt(h__);
/* L300: */
}
return 0;
} /* htridi_ */
/* Subroutine */ int minfit_(integer *nm, integer *m, integer *n, doublereal *
a, doublereal *w, integer *ip, doublereal *b, integer *ierr,
doublereal *rv1)
{
/* System generated locals */
integer a_dim1, a_offset, b_dim1, b_offset, i__1, i__2, i__3;
doublereal d__1, d__2, d__3, d__4;
/* Builtin functions */
double sqrt(doublereal), d_sign(doublereal *, doublereal *);
/* Local variables */
doublereal c__, f, g, h__;
integer i__, j, k, l=0;
doublereal s, x, y, z__, scale;
integer i1, k1, l1=0, m1, ii, kk, ll;
extern doublereal pythag_(doublereal *, doublereal *);
integer its;
doublereal tst1, tst2;
/* THIS SUBROUTINE IS A TRANSLATION OF THE ALGOL PROCEDURE MINFIT, */
/* NUM. MATH. 14, 403-420(1970) BY GOLUB AND REINSCH. */
/* HANDBOOK FOR AUTO. COMP., VOL II-LINEAR ALGEBRA, 134-151(1971). */
/* THIS SUBROUTINE DETERMINES, TOWARDS THE SOLUTION OF THE LINEAR */
/* T */
/* SYSTEM AX=B, THE SINGULAR VALUE DECOMPOSITION A=USV OF A REAL */
/* T */
/* M BY N RECTANGULAR MATRIX, FORMING U B RATHER THAN U. HOUSEHOLDER
*/
/* BIDIAGONALIZATION AND A VARIANT OF THE QR ALGORITHM ARE USED. */
/* ON INPUT */
/* NM MUST BE SET TO THE ROW DIMENSION OF TWO-DIMENSIONAL */
/* ARRAY PARAMETERS AS DECLARED IN THE CALLING PROGRAM */
/* DIMENSION STATEMENT. NOTE THAT NM MUST BE AT LEAST */
/* AS LARGE AS THE MAXIMUM OF M AND N. */
/* M IS THE NUMBER OF ROWS OF A AND B. */
/* N IS THE NUMBER OF COLUMNS OF A AND THE ORDER OF V. */
/* A CONTAINS THE RECTANGULAR COEFFICIENT MATRIX OF THE SYSTEM. */
/* IP IS THE NUMBER OF COLUMNS OF B. IP CAN BE ZERO. */
/* B CONTAINS THE CONSTANT COLUMN MATRIX OF THE SYSTEM */
/* IF IP IS NOT ZERO. OTHERWISE B IS NOT REFERENCED. */
/* ON OUTPUT */
/* A HAS BEEN OVERWRITTEN BY THE MATRIX V (ORTHOGONAL) OF THE */
/* DECOMPOSITION IN ITS FIRST N ROWS AND COLUMNS. IF AN */
/* ERROR EXIT IS MADE, THE COLUMNS OF V CORRESPONDING TO */
/* INDICES OF CORRECT SINGULAR VALUES SHOULD BE CORRECT. */
/* W CONTAINS THE N (NON-NEGATIVE) SINGULAR VALUES OF A (THE */
/* DIAGONAL ELEMENTS OF S). THEY ARE UNORDERED. IF AN */
/* ERROR EXIT IS MADE, THE SINGULAR VALUES SHOULD BE CORRECT */
/* FOR INDICES IERR+1,IERR+2,...,N. */
/* T */
/* B HAS BEEN OVERWRITTEN BY U B. IF AN ERROR EXIT IS MADE, */
/* T */
/* THE ROWS OF U B CORRESPONDING TO INDICES OF CORRECT */
/* SINGULAR VALUES SHOULD BE CORRECT. */
/* IERR IS SET TO */
/* ZERO FOR NORMAL RETURN, */
/* K IF THE K-TH SINGULAR VALUE HAS NOT BEEN */
/* DETERMINED AFTER 30 ITERATIONS. */
/* RV1 IS A TEMPORARY STORAGE ARRAY. */
/* CALLS PYTHAG FOR DSQRT(A*A + B*B) . */
/* QUESTIONS AND COMMENTS SHOULD BE DIRECTED TO BURTON S. GARBOW, */
/* MATHEMATICS AND COMPUTER SCIENCE DIV, ARGONNE NATIONAL LABORATORY
*/
/* THIS VERSION DATED AUGUST 1983. */
/* ------------------------------------------------------------------
*/
/* Parameter adjustments */
--rv1;
--w;
a_dim1 = *nm;
a_offset = a_dim1 + 1;
a -= a_offset;
b_dim1 = *nm;
b_offset = b_dim1 + 1;
b -= b_offset;
/* Function Body */
*ierr = 0;
/* .......... HOUSEHOLDER REDUCTION TO BIDIAGONAL FORM .......... */
g = 0.;
scale = 0.;
x = 0.;
i__1 = *n;
for (i__ = 1; i__ <= i__1; ++i__) {
l = i__ + 1;
rv1[i__] = scale * g;
g = 0.;
s = 0.;
scale = 0.;
if (i__ > *m) {
goto L210;
}
i__2 = *m;
for (k = i__; k <= i__2; ++k) {
/* L120: */
scale += (d__1 = a[k + i__ * a_dim1], abs(d__1));
}
if (scale == 0.) {
goto L210;
}
i__2 = *m;
for (k = i__; k <= i__2; ++k) {
a[k + i__ * a_dim1] /= scale;
/* Computing 2nd power */
d__1 = a[k + i__ * a_dim1];
s += d__1 * d__1;
/* L130: */
}
f = a[i__ + i__ * a_dim1];
d__1 = sqrt(s);
g = -d_sign(&d__1, &f);
h__ = f * g - s;
a[i__ + i__ * a_dim1] = f - g;
if (i__ == *n) {
goto L160;
}
i__2 = *n;
for (j = l; j <= i__2; ++j) {
s = 0.;
i__3 = *m;
for (k = i__; k <= i__3; ++k) {
/* L140: */
s += a[k + i__ * a_dim1] * a[k + j * a_dim1];
}
f = s / h__;
i__3 = *m;
for (k = i__; k <= i__3; ++k) {
a[k + j * a_dim1] += f * a[k + i__ * a_dim1];
/* L150: */
}
}
L160:
if (*ip == 0) {
goto L190;
}
i__3 = *ip;
for (j = 1; j <= i__3; ++j) {
s = 0.;
i__2 = *m;
for (k = i__; k <= i__2; ++k) {
/* L170: */
s += a[k + i__ * a_dim1] * b[k + j * b_dim1];
}
f = s / h__;
i__2 = *m;
for (k = i__; k <= i__2; ++k) {
b[k + j * b_dim1] += f * a[k + i__ * a_dim1];
/* L180: */
}
}
L190:
i__2 = *m;
for (k = i__; k <= i__2; ++k) {
/* L200: */
a[k + i__ * a_dim1] = scale * a[k + i__ * a_dim1];
}
L210:
w[i__] = scale * g;
g = 0.;
s = 0.;
scale = 0.;
if (i__ > *m || i__ == *n) {
goto L290;
}
i__2 = *n;
for (k = l; k <= i__2; ++k) {
/* L220: */
scale += (d__1 = a[i__ + k * a_dim1], abs(d__1));
}
if (scale == 0.) {
goto L290;
}
i__2 = *n;
for (k = l; k <= i__2; ++k) {
a[i__ + k * a_dim1] /= scale;
/* Computing 2nd power */
d__1 = a[i__ + k * a_dim1];
s += d__1 * d__1;
/* L230: */
}
f = a[i__ + l * a_dim1];
d__1 = sqrt(s);
g = -d_sign(&d__1, &f);
h__ = f * g - s;
a[i__ + l * a_dim1] = f - g;
i__2 = *n;
for (k = l; k <= i__2; ++k) {
/* L240: */
rv1[k] = a[i__ + k * a_dim1] / h__;
}
if (i__ == *m) {
goto L270;
}
i__2 = *m;
for (j = l; j <= i__2; ++j) {
s = 0.;
i__3 = *n;
for (k = l; k <= i__3; ++k) {
/* L250: */
s += a[j + k * a_dim1] * a[i__ + k * a_dim1];
}
i__3 = *n;
for (k = l; k <= i__3; ++k) {
a[j + k * a_dim1] += s * rv1[k];
/* L260: */
}
}
L270:
i__3 = *n;
for (k = l; k <= i__3; ++k) {
/* L280: */
a[i__ + k * a_dim1] = scale * a[i__ + k * a_dim1];
}
L290:
/* Computing MAX */
d__3 = x, d__4 = (d__1 = w[i__], abs(d__1)) + (d__2 = rv1[i__], abs(
d__2));
x = max(d__3,d__4);
/* L300: */
}
/* .......... ACCUMULATION OF RIGHT-HAND TRANSFORMATIONS. */
/* FOR I=N STEP -1 UNTIL 1 DO -- .......... */
i__1 = *n;
for (ii = 1; ii <= i__1; ++ii) {
i__ = *n + 1 - ii;
if (i__ == *n) {
goto L390;
}
if (g == 0.) {
goto L360;
}
i__3 = *n;
for (j = l; j <= i__3; ++j) {
/* .......... DOUBLE DIVISION AVOIDS POSSIBLE UNDERFLOW ......
.... */
/* L320: */
a[j + i__ * a_dim1] = a[i__ + j * a_dim1] / a[i__ + l * a_dim1] /
g;
}
i__3 = *n;
for (j = l; j <= i__3; ++j) {
s = 0.;
i__2 = *n;
for (k = l; k <= i__2; ++k) {
/* L340: */
s += a[i__ + k * a_dim1] * a[k + j * a_dim1];
}
i__2 = *n;
for (k = l; k <= i__2; ++k) {
a[k + j * a_dim1] += s * a[k + i__ * a_dim1];
/* L350: */
}
}
L360:
i__2 = *n;
for (j = l; j <= i__2; ++j) {
a[i__ + j * a_dim1] = 0.;
a[j + i__ * a_dim1] = 0.;
/* L380: */
}
L390:
a[i__ + i__ * a_dim1] = 1.;
g = rv1[i__];
l = i__;
/* L400: */
}
if (*m >= *n || *ip == 0) {
goto L510;
}
m1 = *m + 1;
i__1 = *n;
for (i__ = m1; i__ <= i__1; ++i__) {
i__2 = *ip;
for (j = 1; j <= i__2; ++j) {
b[i__ + j * b_dim1] = 0.;
/* L500: */
}
}
/* .......... DIAGONALIZATION OF THE BIDIAGONAL FORM .......... */
L510:
tst1 = x;
/* .......... FOR K=N STEP -1 UNTIL 1 DO -- .......... */
i__2 = *n;
for (kk = 1; kk <= i__2; ++kk) {
k1 = *n - kk;
k = k1 + 1;
its = 0;
/* .......... TEST FOR SPLITTING. */
/* FOR L=K STEP -1 UNTIL 1 DO -- .......... */
L520:
i__1 = k;
for (ll = 1; ll <= i__1; ++ll) {
l1 = k - ll;
l = l1 + 1;
tst2 = tst1 + (d__1 = rv1[l], abs(d__1));
if (tst2 == tst1) {
goto L565;
}
/* .......... RV1(1) IS ALWAYS ZERO, SO THERE IS NO EXIT */
/* THROUGH THE BOTTOM OF THE LOOP .......... */
tst2 = tst1 + (d__1 = w[l1], abs(d__1));
if (tst2 == tst1) {
goto L540;
}
/* L530: */
}
/* .......... CANCELLATION OF RV1(L) IF L GREATER THAN 1 .........
. */
L540:
c__ = 0.;
s = 1.;
i__1 = k;
for (i__ = l; i__ <= i__1; ++i__) {
f = s * rv1[i__];
rv1[i__] = c__ * rv1[i__];
tst2 = tst1 + abs(f);
if (tst2 == tst1) {
goto L565;
}
g = w[i__];
h__ = pythag_(&f, &g);
w[i__] = h__;
c__ = g / h__;
s = -f / h__;
if (*ip == 0) {
goto L560;
}
i__3 = *ip;
for (j = 1; j <= i__3; ++j) {
y = b[l1 + j * b_dim1];
z__ = b[i__ + j * b_dim1];
b[l1 + j * b_dim1] = y * c__ + z__ * s;
b[i__ + j * b_dim1] = -y * s + z__ * c__;
/* L550: */
}
L560:
;
}
/* .......... TEST FOR CONVERGENCE .......... */
L565:
z__ = w[k];
if (l == k) {
goto L650;
}
/* .......... SHIFT FROM BOTTOM 2 BY 2 MINOR .......... */
if (its == 30) {
goto L1000;
}
++its;
x = w[l];
y = w[k1];
g = rv1[k1];
h__ = rv1[k];
f = ((g + z__) / h__ * ((g - z__) / y) + y / h__ - h__ / y) * .5;
g = pythag_(&f, &c_b39);
f = x - z__ / x * z__ + h__ / x * (y / (f + d_sign(&g, &f)) - h__);
/* .......... NEXT QR TRANSFORMATION .......... */
c__ = 1.;
s = 1.;
i__1 = k1;
for (i1 = l; i1 <= i__1; ++i1) {
i__ = i1 + 1;
g = rv1[i__];
y = w[i__];
h__ = s * g;
g = c__ * g;
z__ = pythag_(&f, &h__);
rv1[i1] = z__;
c__ = f / z__;
s = h__ / z__;
f = x * c__ + g * s;
g = -x * s + g * c__;
h__ = y * s;
y *= c__;
i__3 = *n;
for (j = 1; j <= i__3; ++j) {
x = a[j + i1 * a_dim1];
z__ = a[j + i__ * a_dim1];
a[j + i1 * a_dim1] = x * c__ + z__ * s;
a[j + i__ * a_dim1] = -x * s + z__ * c__;
/* L570: */
}
z__ = pythag_(&f, &h__);
w[i1] = z__;
/* .......... ROTATION CAN BE ARBITRARY IF Z IS ZERO .........
. */
if (z__ == 0.) {
goto L580;
}
c__ = f / z__;
s = h__ / z__;
L580:
f = c__ * g + s * y;
x = -s * g + c__ * y;
if (*ip == 0) {
goto L600;
}
i__3 = *ip;
for (j = 1; j <= i__3; ++j) {
y = b[i1 + j * b_dim1];
z__ = b[i__ + j * b_dim1];
b[i1 + j * b_dim1] = y * c__ + z__ * s;
b[i__ + j * b_dim1] = -y * s + z__ * c__;
/* L590: */
}
L600:
;
}
rv1[l] = 0.;
rv1[k] = f;
w[k] = x;
goto L520;
/* .......... CONVERGENCE .......... */
L650:
if (z__ >= 0.) {
goto L700;
}
/* .......... W(K) IS MADE NON-NEGATIVE .......... */
w[k] = -z__;
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
/* L690: */
a[j + k * a_dim1] = -a[j + k * a_dim1];
}
L700:
;
}
goto L1001;
/* .......... SET ERROR -- NO CONVERGENCE TO A */
/* SINGULAR VALUE AFTER 30 ITERATIONS .......... */
L1000:
*ierr = k;
L1001:
return 0;
} /* minfit_ */
/*< subroutine tqlrat(n,d,e2,ierr) >*/
/* Subroutine */ int tqlrat_(integer *n, doublereal *d__, doublereal *e2,
integer *ierr)
{
/* System generated locals */
integer i__1, i__2;
doublereal d__1, d__2;
/* Builtin functions */
double sqrt(doublereal), d_sign(doublereal *, doublereal *);
/* Local variables */
doublereal b=0, c__=0, f, g, h__;
integer i__, j, l, m;
doublereal p, r__, s, t;
integer l1, ii, mml;
extern doublereal pythag_(doublereal *, doublereal *), epslon_(doublereal
*);
/*< integer i,j,l,m,n,ii,l1,mml,ierr >*/
/*< double precision d(n),e2(n) >*/
/*< double precision b,c,f,g,h,p,r,s,t,epslon,pythag >*/
/* this subroutine is a translation of the algol procedure tqlrat, */
/* algorithm 464, comm. acm 16, 689(1973) by reinsch. */
/* this subroutine finds the eigenvalues of a symmetric */
/* tridiagonal matrix by the rational ql method. */
/* on input */
/* n is the order of the matrix. */
/* d contains the diagonal elements of the input matrix. */
/* e2 contains the squares of the subdiagonal elements of the */
/* input matrix in its last n-1 positions. e2(1) is arbitrary. */
/* on output */
/* d contains the eigenvalues in ascending order. if an */
/* error exit is made, the eigenvalues are correct and */
/* ordered for indices 1,2,...ierr-1, but may not be */
/* the smallest eigenvalues. */
/* e2 has been destroyed. */
/* ierr is set to */
/* zero for normal return, */
/* j if the j-th eigenvalue has not been */
/* determined after 30 iterations. */
/* calls pythag for dsqrt(a*a + b*b) . */
/* questions and comments should be directed to burton s. garbow, */
/* mathematics and computer science div, argonne national laboratory */
/* this version dated august 1983. */
/* ------------------------------------------------------------------ */
/*< ierr = 0 >*/
/* Parameter adjustments */
--e2;
--d__;
/* Function Body */
*ierr = 0;
/*< if (n .eq. 1) go to 1001 >*/
if (*n == 1) {
goto L1001;
}
/*< do 100 i = 2, n >*/
i__1 = *n;
for (i__ = 2; i__ <= i__1; ++i__) {
/*< 100 e2(i-1) = e2(i) >*/
/* L100: */
e2[i__ - 1] = e2[i__];
}
/*< f = 0.0d0 >*/
f = 0.;
/*< t = 0.0d0 >*/
t = 0.;
/*< e2(n) = 0.0d0 >*/
e2[*n] = 0.;
/*< do 290 l = 1, n >*/
i__1 = *n;
for (l = 1; l <= i__1; ++l) {
/*< j = 0 >*/
j = 0;
/*< h = dabs(d(l)) + dsqrt(e2(l)) >*/
h__ = (d__1 = d__[l], abs(d__1)) + sqrt(e2[l]);
/*< if (t .gt. h) go to 105 >*/
if (t > h__) {
goto L105;
}
/*< t = h >*/
t = h__;
/*< b = epslon(t) >*/
b = epslon_(&t);
/*< c = b * b >*/
c__ = b * b;
/* .......... look for small squared sub-diagonal element .......... */
/*< 105 do 110 m = l, n >*/
L105:
i__2 = *n;
for (m = l; m <= i__2; ++m) {
/*< if (e2(m) .le. c) go to 120 >*/
if (e2[m] <= c__) {
goto L120;
}
/* .......... e2(n) is always zero, so there is no exit */
/* through the bottom of the loop .......... */
/*< 110 continue >*/
/* L110: */
}
/*< 120 if (m .eq. l) go to 210 >*/
L120:
if (m == l) {
goto L210;
}
/*< 130 if (j .eq. 30) go to 1000 >*/
L130:
if (j == 30) {
goto L1000;
}
/*< j = j + 1 >*/
++j;
/* .......... form shift .......... */
/*< l1 = l + 1 >*/
l1 = l + 1;
/*< s = dsqrt(e2(l)) >*/
s = sqrt(e2[l]);
/*< g = d(l) >*/
g = d__[l];
/*< p = (d(l1) - g) / (2.0d0 * s) >*/
p = (d__[l1] - g) / (s * 2.);
/*< r = pythag(p,1.0d0) >*/
r__ = pythag_(&p, &c_b11);
/*< d(l) = s / (p + dsign(r,p)) >*/
d__[l] = s / (p + d_sign(&r__, &p));
/*< h = g - d(l) >*/
h__ = g - d__[l];
/*< do 140 i = l1, n >*/
i__2 = *n;
for (i__ = l1; i__ <= i__2; ++i__) {
/*< 140 d(i) = d(i) - h >*/
/* L140: */
d__[i__] -= h__;
}
/*< f = f + h >*/
f += h__;
/* .......... rational ql transformation .......... */
/*< g = d(m) >*/
g = d__[m];
/*< if (g .eq. 0.0d0) g = b >*/
if (g == 0.) {
g = b;
}
/*< h = g >*/
h__ = g;
/*< s = 0.0d0 >*/
s = 0.;
/*< mml = m - l >*/
mml = m - l;
/* .......... for i=m-1 step -1 until l do -- .......... */
/*< do 200 ii = 1, mml >*/
i__2 = mml;
for (ii = 1; ii <= i__2; ++ii) {
/*< i = m - ii >*/
i__ = m - ii;
/*< p = g * h >*/
p = g * h__;
/*< r = p + e2(i) >*/
r__ = p + e2[i__];
/*< e2(i+1) = s * r >*/
e2[i__ + 1] = s * r__;
/*< s = e2(i) / r >*/
s = e2[i__] / r__;
/*< d(i+1) = h + s * (h + d(i)) >*/
d__[i__ + 1] = h__ + s * (h__ + d__[i__]);
/*< g = d(i) - e2(i) / g >*/
g = d__[i__] - e2[i__] / g;
/*< if (g .eq. 0.0d0) g = b >*/
if (g == 0.) {
g = b;
}
/*< h = g * p / r >*/
h__ = g * p / r__;
/*< 200 continue >*/
/* L200: */
}
/*< e2(l) = s * g >*/
e2[l] = s * g;
/*< d(l) = h >*/
d__[l] = h__;
/* .......... guard against underflow in convergence test .......... */
/*< if (h .eq. 0.0d0) go to 210 >*/
if (h__ == 0.) {
goto L210;
}
/*< if (dabs(e2(l)) .le. dabs(c/h)) go to 210 >*/
if ((d__1 = e2[l], abs(d__1)) <= (d__2 = c__ / h__, abs(d__2))) {
goto L210;
}
/*< e2(l) = h * e2(l) >*/
e2[l] = h__ * e2[l];
/*< if (e2(l) .ne. 0.0d0) go to 130 >*/
if (e2[l] != 0.) {
goto L130;
}
/*< 210 p = d(l) + f >*/
L210:
p = d__[l] + f;
/* .......... order eigenvalues .......... */
/*< if (l .eq. 1) go to 250 >*/
if (l == 1) {
goto L250;
}
/* .......... for i=l step -1 until 2 do -- .......... */
/*< do 230 ii = 2, l >*/
i__2 = l;
for (ii = 2; ii <= i__2; ++ii) {
/*< i = l + 2 - ii >*/
i__ = l + 2 - ii;
/*< if (p .ge. d(i-1)) go to 270 >*/
if (p >= d__[i__ - 1]) {
goto L270;
}
/*< d(i) = d(i-1) >*/
d__[i__] = d__[i__ - 1];
/*< 230 continue >*/
/* L230: */
}
/*< 250 i = 1 >*/
L250:
i__ = 1;
/*< 270 d(i) = p >*/
L270:
d__[i__] = p;
/*< 290 continue >*/
/* L290: */
}
/*< go to 1001 >*/
goto L1001;
/* .......... set error -- no convergence to an */
/* eigenvalue after 30 iterations .......... */
/*< 1000 ierr = l >*/
L1000:
*ierr = l;
/*< 1001 return >*/
L1001:
return 0;
/*< end >*/
} /* tqlrat_ */
