/* eispack.f -- translated by f2c (version 19950110). You must link the resulting object file with the libraries: -lf2c -lm (in that order) */ #ifdef __cplusplus extern "C" { #endif #include "f2c.h" /* Table of constant values */ static doublereal c_b141 = 1.; static doublereal c_b550 = 0.; /* Subroutine */ int cdiv_(doublereal *ar, doublereal *ai, doublereal *br, doublereal *bi, doublereal *cr, doublereal *ci) { /* System generated locals */ doublereal d_1, d_2; /* Local variables */ static doublereal s, ais, bis, ars, brs; /* COMPLEX DIVISION, (CR,CI) = (AR,AI)/(BR,BI) */ s = abs(*br) + abs(*bi); ars = *ar / s; ais = *ai / s; brs = *br / s; bis = *bi / s; /* Computing 2nd power */ d_1 = brs; /* Computing 2nd power */ d_2 = bis; s = d_1 * d_1 + d_2 * d_2; *cr = (ars * brs + ais * bis) / s; *ci = (ais * brs - ars * bis) / s; return 0; } /* cdiv_ */ /* Subroutine */ int csroot_(doublereal *xr, doublereal *xi, doublereal *yr, doublereal *yi) { /* Builtin functions */ double sqrt(doublereal); /* Local variables */ static doublereal s, ti, tr; extern doublereal pythag_(doublereal *, doublereal *); /* (YR,YI) = COMPLEX DSQRT(XR,XI) */ /* BRANCH CHOSEN SO THAT YR .GE. 0.0 AND SIGN(YI) .EQ. SIGN(XI) */ tr = *xr; ti = *xi; s = sqrt((pythag_(&tr, &ti) + abs(tr)) * .5); if (tr >= 0.) { *yr = s; } if (ti < 0.) { s = -s; } if (tr <= 0.) { *yi = s; } if (tr < 0.) { *yr = ti / *yi * .5; } if (tr > 0.) { *yi = ti / *yr * .5; } return 0; } /* csroot_ */ doublereal epslon_(doublereal *x) { /* System generated locals */ doublereal ret_val, d_1; /* Local variables */ static doublereal a, b, c, eps; /* ESTIMATE UNIT ROUNDOFF IN QUANTITIES OF SIZE X. */ /* THIS PROGRAM SHOULD FUNCTION PROPERLY ON ALL SYSTEMS */ /* SATISFYING THE FOLLOWING TWO ASSUMPTIONS, */ /* 1. THE BASE USED IN REPRESENTING FLOATING POINT */ /* NUMBERS IS NOT A POWER OF THREE. */ /* 2. THE QUANTITY A IN STATEMENT 10 IS REPRESENTED TO */ /* THE ACCURACY USED IN FLOATING POINT VARIABLES */ /* THAT ARE STORED IN MEMORY. */ /* THE STATEMENT NUMBER 10 AND THE GO TO 10 ARE INTENDED TO */ /* FORCE OPTIMIZING COMPILERS TO GENERATE CODE SATISFYING */ /* ASSUMPTION 2. */ /* UNDER THESE ASSUMPTIONS, IT SHOULD BE TRUE THAT, */ /* A IS NOT EXACTLY EQUAL TO FOUR-THIRDS, */ /* B HAS A ZERO FOR ITS LAST BIT OR DIGIT, */ /* C IS NOT EXACTLY EQUAL TO ONE, */ /* EPS MEASURES THE SEPARATION OF 1.0 FROM */ /* THE NEXT LARGER FLOATING POINT NUMBER. */ /* THE DEVELOPERS OF EISPACK WOULD APPRECIATE BEING INFORMED */ /* ABOUT ANY SYSTEMS WHERE THESE ASSUMPTIONS DO NOT HOLD. */ /* THIS VERSION DATED 4/6/83. */ a = 1.3333333333333333; L10: b = a - 1.; c = b + b + b; eps = (d_1 = c - 1., abs(d_1)); if (eps == 0.) { goto L10; } ret_val = eps * abs(*x); return ret_val; } /* epslon_ */ doublereal pythag_(doublereal *a, doublereal *b) { /* System generated locals */ doublereal ret_val, d_1, d_2, d_3; /* Local variables */ static doublereal p, r, s, t, u; /* FINDS DSQRT(A**2+B**2) WITHOUT OVERFLOW OR DESTRUCTIVE UNDERFLOW */ /* Computing MAX */ d_1 = abs(*a), d_2 = abs(*b); p = max(d_1,d_2); if (p == 0.) { goto L20; } /* Computing MIN */ d_2 = abs(*a), d_3 = abs(*b); /* Computing 2nd power */ d_1 = min(d_2,d_3) / p; r = d_1 * d_1; L10: t = r + 4.; if (t == 4.) { goto L20; } s = r / t; u = s * 2. + 1.; p = u * p; /* Computing 2nd power */ d_1 = s / u; r = d_1 * d_1 * r; goto L10; L20: ret_val = p; return ret_val; } /* pythag_ */ /* Subroutine */ int bakvec_(integer *nm, integer *n, doublereal *t, doublereal *e, integer *m, doublereal *z, integer *ierr) { /* System generated locals */ integer t_dim1, t_offset, z_dim1, z_offset, i_1, i_2; /* Local variables */ static integer i, j; /* THIS SUBROUTINE FORMS THE EIGENVECTORS OF A NONSYMMETRIC */ /* TRIDIAGONAL MATRIX BY BACK TRANSFORMING THOSE OF THE */ /* CORRESPONDING SYMMETRIC MATRIX DETERMINED BY FIGI. */ /* ON INPUT */ /* NM MUST BE SET TO THE ROW DIMENSION OF TWO-DIMENSIONAL */ /* ARRAY PARAMETERS AS DECLARED IN THE CALLING PROGRAM */ /* DIMENSION STATEMENT. */ /* N IS THE ORDER OF THE MATRIX. */ /* T CONTAINS THE NONSYMMETRIC MATRIX. ITS SUBDIAGONAL IS */ /* STORED IN THE LAST N-1 POSITIONS OF THE FIRST COLUMN, */ /* ITS DIAGONAL IN THE N POSITIONS OF THE SECOND COLUMN, */ /* AND ITS SUPERDIAGONAL IN THE FIRST N-1 POSITIONS OF */ /* THE THIRD COLUMN. T(1,1) AND T(N,3) ARE ARBITRARY. */ /* E CONTAINS THE SUBDIAGONAL ELEMENTS OF THE SYMMETRIC */ /* MATRIX IN ITS LAST N-1 POSITIONS. E(1) IS ARBITRARY. */ /* M IS THE NUMBER OF EIGENVECTORS TO BE BACK TRANSFORMED. */ /* Z CONTAINS THE EIGENVECTORS TO BE BACK TRANSFORMED */ /* IN ITS FIRST M COLUMNS. */ /* ON OUTPUT */ /* T IS UNALTERED. */ /* E IS DESTROYED. */ /* Z CONTAINS THE TRANSFORMED EIGENVECTORS */ /* IN ITS FIRST M COLUMNS. */ /* IERR IS SET TO */ /* ZERO FOR NORMAL RETURN, */ /* 2*N+I IF E(I) IS ZERO WITH T(I,1) OR T(I-1,3) NON-ZERO. */ /* IN THIS CASE, THE SYMMETRIC MATRIX IS NOT SIMILAR */ /* TO THE ORIGINAL MATRIX, AND THE EIGENVECTORS */ /* CANNOT BE FOUND BY THIS PROGRAM. */ /* 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 */ t_dim1 = *nm; t_offset = t_dim1 + 1; t -= t_offset; --e; z_dim1 = *nm; z_offset = z_dim1 + 1; z -= z_offset; /* Function Body */ *ierr = 0; if (*m == 0) { goto L1001; } e[1] = 1.; if (*n == 1) { goto L1001; } i_1 = *n; for (i = 2; i <= i_1; ++i) { if (e[i] != 0.) { goto L80; } if (t[i + t_dim1] != 0. || t[i - 1 + t_dim1 * 3] != 0.) { goto L1000; } e[i] = 1.; goto L100; L80: e[i] = e[i - 1] * e[i] / t[i - 1 + t_dim1 * 3]; L100: ; } i_1 = *m; for (j = 1; j <= i_1; ++j) { i_2 = *n; for (i = 2; i <= i_2; ++i) { z[i + j * z_dim1] *= e[i]; /* L120: */ } } goto L1001; /* .......... SET ERROR -- EIGENVECTORS CANNOT BE */ /* FOUND BY THIS PROGRAM .......... */ L1000: *ierr = (*n << 1) + i; L1001: return 0; } /* bakvec_ */ /* Subroutine */ int balanc_(integer *nm, integer *n, doublereal *a, integer * low, integer *igh, doublereal *scale) { /* System generated locals */ integer a_dim1, a_offset, i_1, i_2; doublereal d_1; /* Local variables */ static integer iexc; static doublereal c, f, g; static integer i, j, k, l, m; static doublereal r, s, radix, b2; static integer jj; static logical noconv; /* THIS SUBROUTINE IS A TRANSLATION OF THE ALGOL PROCEDURE BALANCE, */ /* NUM. MATH. 13, 293-304(1969) BY PARLETT AND REINSCH. */ /* HANDBOOK FOR AUTO. COMP., VOL.II-LINEAR ALGEBRA, 315-326(1971). */ /* THIS SUBROUTINE BALANCES A REAL MATRIX AND ISOLATES */ /* EIGENVALUES WHENEVER POSSIBLE. */ /* ON INPUT */ /* NM MUST BE SET TO THE ROW DIMENSION OF TWO-DIMENSIONAL */ /* ARRAY PARAMETERS AS DECLARED IN THE CALLING PROGRAM */ /* DIMENSION STATEMENT. */ /* N IS THE ORDER OF THE MATRIX. */ /* A CONTAINS THE INPUT MATRIX TO BE BALANCED. */ /* ON OUTPUT */ /* A CONTAINS THE BALANCED MATRIX. */ /* LOW AND IGH ARE TWO INTEGERS SUCH THAT A(I,J) */ /* IS EQUAL TO ZERO IF */ /* (1) I IS GREATER THAN J AND */ /* (2) J=1,...,LOW-1 OR I=IGH+1,...,N. */ /* SCALE CONTAINS INFORMATION DETERMINING THE */ /* PERMUTATIONS AND SCALING FACTORS USED. */ /* SUPPOSE THAT THE PRINCIPAL SUBMATRIX IN ROWS LOW THROUGH IGH */ /* HAS BEEN BALANCED, THAT P(J) DENOTES THE INDEX INTERCHANGED */ /* WITH J DURING THE PERMUTATION STEP, AND THAT THE ELEMENTS */ /* OF THE DIAGONAL MATRIX USED ARE DENOTED BY D(I,J). THEN */ /* SCALE(J) = P(J), FOR J = 1,...,LOW-1 */ /* = D(J,J), J = LOW,...,IGH */ /* = P(J) J = IGH+1,...,N. */ /* THE ORDER IN WHICH THE INTERCHANGES ARE MADE IS N TO IGH+1, */ /* THEN 1 TO LOW-1. */ /* NOTE THAT 1 IS RETURNED FOR IGH IF IGH IS ZERO FORMALLY. */ /* THE ALGOL PROCEDURE EXC CONTAINED IN BALANCE APPEARS IN */ /* BALANC IN LINE. (NOTE THAT THE ALGOL ROLES OF IDENTIFIERS */ /* K,L HAVE BEEN REVERSED.) */ /* 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 */ --scale; a_dim1 = *nm; a_offset = a_dim1 + 1; a -= a_offset; /* Function Body */ radix = 16.; b2 = radix * radix; k = 1; l = *n; goto L100; /* .......... IN-LINE PROCEDURE FOR ROW AND */ /* COLUMN EXCHANGE .......... */ L20: scale[m] = (doublereal) j; if (j == m) { goto L50; } i_1 = l; for (i = 1; i <= i_1; ++i) { f = a[i + j * a_dim1]; a[i + j * a_dim1] = a[i + m * a_dim1]; a[i + m * a_dim1] = f; /* L30: */ } i_1 = *n; for (i = k; i <= i_1; ++i) { f = a[j + i * a_dim1]; a[j + i * a_dim1] = a[m + i * a_dim1]; a[m + i * a_dim1] = f; /* L40: */ } L50: switch (iexc) { case 1: goto L80; case 2: goto L130; } /* .......... SEARCH FOR ROWS ISOLATING AN EIGENVALUE */ /* AND PUSH THEM DOWN .......... */ L80: if (l == 1) { goto L280; } --l; /* .......... FOR J=L STEP -1 UNTIL 1 DO -- .......... */ L100: i_1 = l; for (jj = 1; jj <= i_1; ++jj) { j = l + 1 - jj; i_2 = l; for (i = 1; i <= i_2; ++i) { if (i == j) { goto L110; } if (a[j + i * a_dim1] != 0.) { goto L120; } L110: ; } m = l; iexc = 1; goto L20; L120: ; } goto L140; /* .......... SEARCH FOR COLUMNS ISOLATING AN EIGENVALUE */ /* AND PUSH THEM LEFT .......... */ L130: ++k; L140: i_1 = l; for (j = k; j <= i_1; ++j) { i_2 = l; for (i = k; i <= i_2; ++i) { if (i == j) { goto L150; } if (a[i + j * a_dim1] != 0.) { goto L170; } L150: ; } m = k; iexc = 2; goto L20; L170: ; } /* .......... NOW BALANCE THE SUBMATRIX IN ROWS K TO L .......... */ i_1 = l; for (i = k; i <= i_1; ++i) { /* L180: */ scale[i] = 1.; } /* .......... ITERATIVE LOOP FOR NORM REDUCTION .......... */ L190: noconv = FALSE_; i_1 = l; for (i = k; i <= i_1; ++i) { c = 0.; r = 0.; i_2 = l; for (j = k; j <= i_2; ++j) { if (j == i) { goto L200; } c += (d_1 = a[j + i * a_dim1], abs(d_1)); r += (d_1 = a[i + j * a_dim1], abs(d_1)); L200: ; } /* .......... GUARD AGAINST ZERO C OR R DUE TO UNDERFLOW ......... . */ if (c == 0. || r == 0.) { goto L270; } g = r / radix; f = 1.; s = c + r; L210: if (c >= g) { goto L220; } f *= radix; c *= b2; goto L210; L220: g = r * radix; L230: if (c < g) { goto L240; } f /= radix; c /= b2; goto L230; /* .......... NOW BALANCE .......... */ L240: if ((c + r) / f >= s * .95) { goto L270; } g = 1. / f; scale[i] *= f; noconv = TRUE_; i_2 = *n; for (j = k; j <= i_2; ++j) { /* L250: */ a[i + j * a_dim1] *= g; } i_2 = l; for (j = 1; j <= i_2; ++j) { /* L260: */ a[j + i * a_dim1] *= f; } L270: ; } if (noconv) { goto L190; } L280: *low = k; *igh = l; return 0; } /* balanc_ */ /* Subroutine */ int balbak_(integer *nm, integer *n, integer *low, integer * igh, doublereal *scale, integer *m, doublereal *z) { /* System generated locals */ integer z_dim1, z_offset, i_1, i_2; /* Local variables */ static integer i, j, k; static doublereal s; static integer ii; /* THIS SUBROUTINE IS A TRANSLATION OF THE ALGOL PROCEDURE BALBAK, */ /* NUM. MATH. 13, 293-304(1969) BY PARLETT AND REINSCH. */ /* HANDBOOK FOR AUTO. COMP., VOL.II-LINEAR ALGEBRA, 315-326(1971). */ /* THIS SUBROUTINE FORMS THE EIGENVECTORS OF A REAL GENERAL */ /* MATRIX BY BACK TRANSFORMING THOSE OF THE CORRESPONDING */ /* BALANCED MATRIX DETERMINED BY BALANC. */ /* ON INPUT */ /* NM MUST BE SET TO THE ROW DIMENSION OF TWO-DIMENSIONAL */ /* ARRAY PARAMETERS AS DECLARED IN THE CALLING PROGRAM */ /* DIMENSION STATEMENT. */ /* N IS THE ORDER OF THE MATRIX. */ /* LOW AND IGH ARE INTEGERS DETERMINED BY BALANC. */ /* SCALE CONTAINS INFORMATION DETERMINING THE PERMUTATIONS */ /* AND SCALING FACTORS USED BY BALANC. */ /* M IS THE NUMBER OF COLUMNS OF Z TO BE BACK TRANSFORMED. */ /* Z CONTAINS THE REAL AND IMAGINARY PARTS OF THE EIGEN- */ /* VECTORS TO BE BACK TRANSFORMED IN ITS FIRST M COLUMNS. */ /* ON OUTPUT */ /* Z CONTAINS THE REAL AND IMAGINARY PARTS OF THE */ /* TRANSFORMED EIGENVECTORS IN ITS FIRST M COLUMNS. */ /* 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 */ --scale; z_dim1 = *nm; z_offset = z_dim1 + 1; z -= z_offset; /* Function Body */ if (*m == 0) { goto L200; } if (*igh == *low) { goto L120; } i_1 = *igh; for (i = *low; i <= i_1; ++i) { s = scale[i]; /* .......... LEFT HAND EIGENVECTORS ARE BACK TRANSFORMED */ /* IF THE FOREGOING STATEMENT IS REPLACED BY */ /* S=1.0D0/SCALE(I). .......... */ i_2 = *m; for (j = 1; j <= i_2; ++j) { /* L100: */ z[i + j * z_dim1] *= s; } /* L110: */ } /* ......... FOR I=LOW-1 STEP -1 UNTIL 1, */ /* IGH+1 STEP 1 UNTIL N DO -- .......... */ L120: i_1 = *n; for (ii = 1; ii <= i_1; ++ii) { i = ii; if (i >= *low && i <= *igh) { goto L140; } if (i < *low) { i = *low - ii; } k = (integer) scale[i]; if (k == i) { goto L140; } i_2 = *m; for (j = 1; j <= i_2; ++j) { s = z[i + j * z_dim1]; z[i + j * z_dim1] = z[k + j * z_dim1]; z[k + j * z_dim1] = s; /* L130: */ } L140: ; } L200: return 0; } /* balbak_ */ /* Subroutine */ int bandr_(integer *nm, integer *n, integer *mb, doublereal * a, doublereal *d, doublereal *e, doublereal *e2, logical *matz, doublereal *z) { /* System generated locals */ integer a_dim1, a_offset, z_dim1, z_offset, i_1, i_2, i_3, i_4, i_5, i_6; doublereal d_1; /* Builtin functions */ double sqrt(doublereal); /* Local variables */ static doublereal dmin_; static integer maxl, maxr; static doublereal g; static integer j, k, l, r; static doublereal u, b1, b2, c2, f1, f2; static integer i1, i2, j1, j2, m1, n2, r1; static doublereal s2; static integer kr, mr; static doublereal dminrt; static integer ugl; /* THIS SUBROUTINE IS A TRANSLATION OF THE ALGOL PROCEDURE BANDRD, */ /* NUM. MATH. 12, 231-241(1968) BY SCHWARZ. */ /* HANDBOOK FOR AUTO. COMP., VOL.II-LINEAR ALGEBRA, 273-283(1971). */ /* THIS SUBROUTINE REDUCES A REAL SYMMETRIC BAND MATRIX */ /* TO A SYMMETRIC TRIDIAGONAL MATRIX USING AND OPTIONALLY */ /* ACCUMULATING ORTHOGONAL SIMILARITY TRANSFORMATIONS. */ /* ON INPUT */ /* NM MUST BE SET TO THE ROW DIMENSION OF TWO-DIMENSIONAL */ /* ARRAY PARAMETERS AS DECLARED IN THE CALLING PROGRAM */ /* DIMENSION STATEMENT. */ /* N IS THE ORDER OF THE MATRIX. */ /* MB IS THE (HALF) BAND WIDTH OF THE MATRIX, DEFINED AS THE */ /* NUMBER OF ADJACENT DIAGONALS, INCLUDING THE PRINCIPAL */ /* DIAGONAL, REQUIRED TO SPECIFY THE NON-ZERO PORTION OF THE */ /* LOWER TRIANGLE OF THE MATRIX. */ /* A CONTAINS THE LOWER TRIANGLE OF THE SYMMETRIC BAND INPUT */ /* MATRIX STORED AS AN N BY MB ARRAY. ITS LOWEST SUBDIAGONAL */ /* IS STORED IN THE LAST N+1-MB POSITIONS OF THE FIRST COLUMN, */ /* ITS NEXT SUBDIAGONAL IN THE LAST N+2-MB POSITIONS OF THE */ /* SECOND COLUMN, FURTHER SUBDIAGONALS SIMILARLY, AND FINALLY */ /* ITS PRINCIPAL DIAGONAL IN THE N POSITIONS OF THE LAST COLUMN. */ /* CONTENTS OF STORAGES NOT PART OF THE MATRIX ARE ARBITRARY. */ /* MATZ SHOULD BE SET TO .TRUE. IF THE TRANSFORMATION MATRIX IS */ /* TO BE ACCUMULATED, AND TO .FALSE. OTHERWISE. */ /* ON OUTPUT */ /* A HAS BEEN DESTROYED, EXCEPT FOR ITS LAST TWO COLUMNS WHICH */ /* CONTAIN A COPY OF THE TRIDIAGONAL MATRIX. */ /* D CONTAINS THE DIAGONAL ELEMENTS OF THE TRIDIAGONAL MATRIX. */ /* E CONTAINS THE SUBDIAGONAL ELEMENTS OF THE TRIDIAGONAL */ /* MATRIX IN ITS LAST N-1 POSITIONS. E(1) IS SET TO ZERO. */ /* E2 CONTAINS THE SQUARES OF THE CORRESPONDING ELEMENTS OF E. */ /* E2 MAY COINCIDE WITH E IF THE SQUARES ARE NOT NEEDED. */ /* Z CONTAINS THE ORTHOGONAL TRANSFORMATION MATRIX PRODUCED IN */ /* THE REDUCTION IF MATZ HAS BEEN SET TO .TRUE. OTHERWISE, Z */ /* IS NOT REFERENCED. */ /* 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 */ z_dim1 = *nm; z_offset = z_dim1 + 1; z -= z_offset; --e2; --e; --d; a_dim1 = *nm; a_offset = a_dim1 + 1; a -= a_offset; /* Function Body */ dmin_ = 5.4210108624275222e-20; dminrt = 2.3283064365386963e-10; /* .......... INITIALIZE DIAGONAL SCALING MATRIX .......... */ i_1 = *n; for (j = 1; j <= i_1; ++j) { /* L30: */ d[j] = 1.; } if (! (*matz)) { goto L60; } i_1 = *n; for (j = 1; j <= i_1; ++j) { i_2 = *n; for (k = 1; k <= i_2; ++k) { /* L40: */ z[j + k * z_dim1] = 0.; } z[j + j * z_dim1] = 1.; /* L50: */ } L60: m1 = *mb - 1; if ((i_1 = m1 - 1) < 0) { goto L900; } else if (i_1 == 0) { goto L800; } else { goto L70; } L70: n2 = *n - 2; i_1 = n2; for (k = 1; k <= i_1; ++k) { /* Computing MIN */ i_2 = m1, i_3 = *n - k; maxr = min(i_2,i_3); /* .......... FOR R=MAXR STEP -1 UNTIL 2 DO -- .......... */ i_2 = maxr; for (r1 = 2; r1 <= i_2; ++r1) { r = maxr + 2 - r1; kr = k + r; mr = *mb - r; g = a[kr + mr * a_dim1]; a[kr - 1 + a_dim1] = a[kr - 1 + (mr + 1) * a_dim1]; ugl = k; i_3 = *n; i_4 = m1; for (j = kr; i_4 < 0 ? j >= i_3 : j <= i_3; j += i_4) { j1 = j - 1; j2 = j1 - 1; if (g == 0.) { goto L600; } b1 = a[j1 + a_dim1] / g; b2 = b1 * d[j1] / d[j]; s2 = 1. / (b1 * b2 + 1.); if (s2 >= .5) { goto L450; } b1 = g / a[j1 + a_dim1]; b2 = b1 * d[j] / d[j1]; c2 = 1. - s2; d[j1] = c2 * d[j1]; d[j] = c2 * d[j]; f1 = a[j + m1 * a_dim1] * 2.; f2 = b1 * a[j1 + *mb * a_dim1]; a[j + m1 * a_dim1] = -b2 * (b1 * a[j + m1 * a_dim1] - a[j + * mb * a_dim1]) - f2 + a[j + m1 * a_dim1]; a[j1 + *mb * a_dim1] = b2 * (b2 * a[j + *mb * a_dim1] + f1) + a[j1 + *mb * a_dim1]; a[j + *mb * a_dim1] = b1 * (f2 - f1) + a[j + *mb * a_dim1]; i_5 = j2; for (l = ugl; l <= i_5; ++l) { i2 = *mb - j + l; u = a[j1 + (i2 + 1) * a_dim1] + b2 * a[j + i2 * a_dim1]; a[j + i2 * a_dim1] = -b1 * a[j1 + (i2 + 1) * a_dim1] + a[ j + i2 * a_dim1]; a[j1 + (i2 + 1) * a_dim1] = u; /* L200: */ } ugl = j; a[j1 + a_dim1] += b2 * g; if (j == *n) { goto L350; } /* Computing MIN */ i_5 = m1, i_6 = *n - j1; maxl = min(i_5,i_6); i_5 = maxl; for (l = 2; l <= i_5; ++l) { i1 = j1 + l; i2 = *mb - l; u = a[i1 + i2 * a_dim1] + b2 * a[i1 + (i2 + 1) * a_dim1]; a[i1 + (i2 + 1) * a_dim1] = -b1 * a[i1 + i2 * a_dim1] + a[ i1 + (i2 + 1) * a_dim1]; a[i1 + i2 * a_dim1] = u; /* L300: */ } i1 = j + m1; if (i1 > *n) { goto L350; } g = b2 * a[i1 + a_dim1]; L350: if (! (*matz)) { goto L500; } i_5 = *n; for (l = 1; l <= i_5; ++l) { u = z[l + j1 * z_dim1] + b2 * z[l + j * z_dim1]; z[l + j * z_dim1] = -b1 * z[l + j1 * z_dim1] + z[l + j * z_dim1]; z[l + j1 * z_dim1] = u; /* L400: */ } goto L500; L450: u = d[j1]; d[j1] = s2 * d[j]; d[j] = s2 * u; f1 = a[j + m1 * a_dim1] * 2.; f2 = b1 * a[j + *mb * a_dim1]; u = b1 * (f2 - f1) + a[j1 + *mb * a_dim1]; a[j + m1 * a_dim1] = b2 * (b1 * a[j + m1 * a_dim1] - a[j1 + * mb * a_dim1]) + f2 - a[j + m1 * a_dim1]; a[j1 + *mb * a_dim1] = b2 * (b2 * a[j1 + *mb * a_dim1] + f1) + a[j + *mb * a_dim1]; a[j + *mb * a_dim1] = u; i_5 = j2; for (l = ugl; l <= i_5; ++l) { i2 = *mb - j + l; u = b2 * a[j1 + (i2 + 1) * a_dim1] + a[j + i2 * a_dim1]; a[j + i2 * a_dim1] = -a[j1 + (i2 + 1) * a_dim1] + b1 * a[ j + i2 * a_dim1]; a[j1 + (i2 + 1) * a_dim1] = u; /* L460: */ } ugl = j; a[j1 + a_dim1] = b2 * a[j1 + a_dim1] + g; if (j == *n) { goto L480; } /* Computing MIN */ i_5 = m1, i_6 = *n - j1; maxl = min(i_5,i_6); i_5 = maxl; for (l = 2; l <= i_5; ++l) { i1 = j1 + l; i2 = *mb - l; u = b2 * a[i1 + i2 * a_dim1] + a[i1 + (i2 + 1) * a_dim1]; a[i1 + (i2 + 1) * a_dim1] = -a[i1 + i2 * a_dim1] + b1 * a[ i1 + (i2 + 1) * a_dim1]; a[i1 + i2 * a_dim1] = u; /* L470: */ } i1 = j + m1; if (i1 > *n) { goto L480; } g = a[i1 + a_dim1]; a[i1 + a_dim1] = b1 * a[i1 + a_dim1]; L480: if (! (*matz)) { goto L500; } i_5 = *n; for (l = 1; l <= i_5; ++l) { u = b2 * z[l + j1 * z_dim1] + z[l + j * z_dim1]; z[l + j * z_dim1] = -z[l + j1 * z_dim1] + b1 * z[l + j * z_dim1]; z[l + j1 * z_dim1] = u; /* L490: */ } L500: ; } L600: ; } if (k % 64 != 0) { goto L700; } /* .......... RESCALE TO AVOID UNDERFLOW OR OVERFLOW .......... */ i_2 = *n; for (j = k; j <= i_2; ++j) { if (d[j] >= dmin_) { goto L650; } /* Computing MAX */ i_4 = 1, i_3 = *mb + 1 - j; maxl = max(i_4,i_3); i_4 = m1; for (l = maxl; l <= i_4; ++l) { /* L610: */ a[j + l * a_dim1] = dminrt * a[j + l * a_dim1]; } if (j == *n) { goto L630; } /* Computing MIN */ i_4 = m1, i_3 = *n - j; maxl = min(i_4,i_3); i_4 = maxl; for (l = 1; l <= i_4; ++l) { i1 = j + l; i2 = *mb - l; a[i1 + i2 * a_dim1] = dminrt * a[i1 + i2 * a_dim1]; /* L620: */ } L630: if (! (*matz)) { goto L645; } i_4 = *n; for (l = 1; l <= i_4; ++l) { /* L640: */ z[l + j * z_dim1] = dminrt * z[l + j * z_dim1]; } L645: a[j + *mb * a_dim1] = dmin_ * a[j + *mb * a_dim1]; d[j] /= dmin_; L650: ; } L700: ; } /* .......... FORM SQUARE ROOT OF SCALING MATRIX .......... */ L800: i_1 = *n; for (j = 2; j <= i_1; ++j) { /* L810: */ e[j] = sqrt(d[j]); } if (! (*matz)) { goto L840; } i_1 = *n; for (j = 1; j <= i_1; ++j) { i_2 = *n; for (k = 2; k <= i_2; ++k) { /* L820: */ z[j + k * z_dim1] = e[k] * z[j + k * z_dim1]; } /* L830: */ } L840: u = 1.; i_1 = *n; for (j = 2; j <= i_1; ++j) { a[j + m1 * a_dim1] = u * e[j] * a[j + m1 * a_dim1]; u = e[j]; /* Computing 2nd power */ d_1 = a[j + m1 * a_dim1]; e2[j] = d_1 * d_1; a[j + *mb * a_dim1] = d[j] * a[j + *mb * a_dim1]; d[j] = a[j + *mb * a_dim1]; e[j] = a[j + m1 * a_dim1]; /* L850: */ } d[1] = a[*mb * a_dim1 + 1]; e[1] = 0.; e2[1] = 0.; goto L1001; L900: i_1 = *n; for (j = 1; j <= i_1; ++j) { d[j] = a[j + *mb * a_dim1]; e[j] = 0.; e2[j] = 0.; /* L950: */ } L1001: return 0; } /* bandr_ */ /* Subroutine */ int bandv_(integer *nm, integer *n, integer *mbw, doublereal *a, doublereal *e21, integer *m, doublereal *w, doublereal *z, integer *ierr, integer */*nv*/, doublereal *rv, doublereal *rv6) { /* System generated locals */ integer a_dim1, a_offset, z_dim1, z_offset, i_1, i_2, i_3, i_4, i_5; doublereal d_1; /* Builtin functions */ double sqrt(doublereal), d_sign(doublereal *, doublereal *); /* Local variables */ static integer maxj, maxk; static doublereal norm; static integer i, j, k, r; static doublereal u, v, order; static integer group, m1; static doublereal x0, x1; static integer mb, m21, ii, ij, jj, kj; static doublereal uk, xu; extern doublereal pythag_(doublereal *, doublereal *), epslon_(doublereal *); static integer ij1, kj1, its; static doublereal eps2, eps3, eps4; /* THIS SUBROUTINE FINDS THOSE EIGENVECTORS OF A REAL SYMMETRIC */ /* BAND MATRIX CORRESPONDING TO SPECIFIED EIGENVALUES, USING INVERSE */ /* ITERATION. THE SUBROUTINE MAY ALSO BE USED TO SOLVE SYSTEMS */ /* OF LINEAR EQUATIONS WITH A SYMMETRIC OR NON-SYMMETRIC BAND */ /* COEFFICIENT MATRIX. */ /* ON INPUT */ /* NM MUST BE SET TO THE ROW DIMENSION OF TWO-DIMENSIONAL */ /* ARRAY PARAMETERS AS DECLARED IN THE CALLING PROGRAM */ /* DIMENSION STATEMENT. */ /* N IS THE ORDER OF THE MATRIX. */ /* MBW IS THE NUMBER OF COLUMNS OF THE ARRAY A USED TO STORE THE */ /* BAND MATRIX. IF THE MATRIX IS SYMMETRIC, MBW IS ITS (HALF) */ /* BAND WIDTH, DENOTED MB AND DEFINED AS THE NUMBER OF ADJACENT */ /* DIAGONALS, INCLUDING THE PRINCIPAL DIAGONAL, REQUIRED TO */ /* SPECIFY THE NON-ZERO PORTION OF THE LOWER TRIANGLE OF THE */ /* MATRIX. IF THE SUBROUTINE IS BEING USED TO SOLVE SYSTEMS */ /* OF LINEAR EQUATIONS AND THE COEFFICIENT MATRIX IS NOT */ /* SYMMETRIC, IT MUST HOWEVER HAVE THE SAME NUMBER OF ADJACENT */ /* DIAGONALS ABOVE THE MAIN DIAGONAL AS BELOW, AND IN THIS */ /* CASE, MBW=2*MB-1. */ /* A CONTAINS THE LOWER TRIANGLE OF THE SYMMETRIC BAND INPUT */ /* MATRIX STORED AS AN N BY MB ARRAY. ITS LOWEST SUBDIAGONAL */ /* IS STORED IN THE LAST N+1-MB POSITIONS OF THE FIRST COLUMN, */ /* ITS NEXT SUBDIAGONAL IN THE LAST N+2-MB POSITIONS OF THE */ /* SECOND COLUMN, FURTHER SUBDIAGONALS SIMILARLY, AND FINALLY */ /* ITS PRINCIPAL DIAGONAL IN THE N POSITIONS OF COLUMN MB. */ /* IF THE SUBROUTINE IS BEING USED TO SOLVE SYSTEMS OF LINEAR */ /* EQUATIONS AND THE COEFFICIENT MATRIX IS NOT SYMMETRIC, A IS */ /* N BY 2*MB-1 INSTEAD WITH LOWER TRIANGLE AS ABOVE AND WITH */ /* ITS FIRST SUPERDIAGONAL STORED IN THE FIRST N-1 POSITIONS OF */ /* COLUMN MB+1, ITS SECOND SUPERDIAGONAL IN THE FIRST N-2 */ /* POSITIONS OF COLUMN MB+2, FURTHER SUPERDIAGONALS SIMILARLY, */ /* AND FINALLY ITS HIGHEST SUPERDIAGONAL IN THE FIRST N+1-MB */ /* POSITIONS OF THE LAST COLUMN. */ /* CONTENTS OF STORAGES NOT PART OF THE MATRIX ARE ARBITRARY. */ /* E21 SPECIFIES THE ORDERING OF THE EIGENVALUES AND CONTAINS */ /* 0.0D0 IF THE EIGENVALUES ARE IN ASCENDING ORDER, OR */ /* 2.0D0 IF THE EIGENVALUES ARE IN DESCENDING ORDER. */ /* IF THE SUBROUTINE IS BEING USED TO SOLVE SYSTEMS OF LINEAR */ /* EQUATIONS, E21 SHOULD BE SET TO 1.0D0 IF THE COEFFICIENT */ /* MATRIX IS SYMMETRIC AND TO -1.0D0 IF NOT. */ /* M IS THE NUMBER OF SPECIFIED EIGENVALUES OR THE NUMBER OF */ /* SYSTEMS OF LINEAR EQUATIONS. */ /* W CONTAINS THE M EIGENVALUES IN ASCENDING OR DESCENDING ORDER. */ /* IF THE SUBROUTINE IS BEING USED TO SOLVE SYSTEMS OF LINEAR */ /* EQUATIONS (A-W(R)*I)*X(R)=B(R), WHERE I IS THE IDENTITY */ /* MATRIX, W(R) SHOULD BE SET ACCORDINGLY, FOR R=1,2,...,M. */ /* Z CONTAINS THE CONSTANT MATRIX COLUMNS (B(R),R=1,2,...,M), IF */ /* THE SUBROUTINE IS USED TO SOLVE SYSTEMS OF LINEAR EQUATIONS. */ /* NV MUST BE SET TO THE DIMENSION OF THE ARRAY PARAMETER RV */ /* AS DECLARED IN THE CALLING PROGRAM DIMENSION STATEMENT. */ /* ON OUTPUT */ /* A AND W ARE UNALTERED. */ /* Z CONTAINS THE ASSOCIATED SET OF ORTHOGONAL EIGENVECTORS. */ /* ANY VECTOR WHICH FAILS TO CONVERGE IS SET TO ZERO. IF THE */ /* SUBROUTINE IS USED TO SOLVE SYSTEMS OF LINEAR EQUATIONS, */ /* Z CONTAINS THE SOLUTION MATRIX COLUMNS (X(R),R=1,2,...,M). */ /* IERR IS SET TO */ /* ZERO FOR NORMAL RETURN, */ /* -R IF THE EIGENVECTOR CORRESPONDING TO THE R-TH */ /* EIGENVALUE FAILS TO CONVERGE, OR IF THE R-TH */ /* SYSTEM OF LINEAR EQUATIONS IS NEARLY SINGULAR. */ /* RV AND RV6 ARE TEMPORARY STORAGE ARRAYS. NOTE THAT RV IS */ /* OF DIMENSION AT LEAST N*(2*MB-1). IF THE SUBROUTINE */ /* IS BEING USED TO SOLVE SYSTEMS OF LINEAR EQUATIONS, THE */ /* DETERMINANT (UP TO SIGN) OF A-W(M)*I IS AVAILABLE, UPON */ /* RETURN, AS THE PRODUCT OF THE FIRST N ELEMENTS OF RV. */ /* 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 */ --rv6; a_dim1 = *nm; a_offset = a_dim1 + 1; a -= a_offset; z_dim1 = *nm; z_offset = z_dim1 + 1; z -= z_offset; --w; --rv; /* Function Body */ *ierr = 0; if (*m == 0) { goto L1001; } mb = *mbw; if (*e21 < 0.) { mb = (*mbw + 1) / 2; } m1 = mb - 1; m21 = m1 + mb; order = 1. - abs(*e21); /* .......... FIND VECTORS BY INVERSE ITERATION .......... */ i_1 = *m; for (r = 1; r <= i_1; ++r) { its = 1; x1 = w[r]; if (r != 1) { goto L100; } /* .......... COMPUTE NORM OF MATRIX .......... */ norm = 0.; i_2 = mb; for (j = 1; j <= i_2; ++j) { jj = mb + 1 - j; kj = jj + m1; ij = 1; v = 0.; i_3 = *n; for (i = jj; i <= i_3; ++i) { v += (d_1 = a[i + j * a_dim1], abs(d_1)); if (*e21 >= 0.) { goto L40; } v += (d_1 = a[ij + kj * a_dim1], abs(d_1)); ++ij; L40: ; } norm = max(norm,v); /* L60: */ } if (*e21 < 0.) { norm *= .5; } /* .......... EPS2 IS THE CRITERION FOR GROUPING, */ /* EPS3 REPLACES ZERO PIVOTS AND EQUAL */ /* ROOTS ARE MODIFIED BY EPS3, */ /* EPS4 IS TAKEN VERY SMALL TO AVOID OVERFLOW ......... . */ if (norm == 0.) { norm = 1.; } eps2 = norm * .001 * abs(order); eps3 = epslon_(&norm); uk = (doublereal) (*n); uk = sqrt(uk); eps4 = uk * eps3; L80: group = 0; goto L120; /* .......... LOOK FOR CLOSE OR COINCIDENT ROOTS .......... */ L100: if ((d_1 = x1 - x0, abs(d_1)) >= eps2) { goto L80; } ++group; if (order * (x1 - x0) <= 0.) { x1 = x0 + order * eps3; } /* .......... EXPAND MATRIX, SUBTRACT EIGENVALUE, */ /* AND INITIALIZE VECTOR .......... */ L120: i_2 = *n; for (i = 1; i <= i_2; ++i) { /* Computing MIN */ i_3 = 0, i_4 = i - m1; ij = i + min(i_3,i_4) * *n; kj = ij + mb * *n; ij1 = kj + m1 * *n; if (m1 == 0) { goto L180; } i_3 = m1; for (j = 1; j <= i_3; ++j) { if (ij > m1) { goto L125; } if (ij > 0) { goto L130; } rv[ij1] = 0.; ij1 += *n; goto L130; L125: rv[ij] = a[i + j * a_dim1]; L130: ij += *n; ii = i + j; if (ii > *n) { goto L150; } jj = mb - j; if (*e21 >= 0.) { goto L140; } ii = i; jj = mb + j; L140: rv[kj] = a[ii + jj * a_dim1]; kj += *n; L150: ; } L180: rv[ij] = a[i + mb * a_dim1] - x1; rv6[i] = eps4; if (order == 0.) { rv6[i] = z[i + r * z_dim1]; } /* L200: */ } if (m1 == 0) { goto L600; } /* .......... ELIMINATION WITH INTERCHANGES .......... */ i_2 = *n; for (i = 1; i <= i_2; ++i) { ii = i + 1; /* Computing MIN */ i_3 = i + m1 - 1; maxk = min(i_3,*n); /* Computing MIN */ i_3 = *n - i, i_4 = m21 - 2; maxj = min(i_3,i_4) * *n; i_3 = maxk; for (k = i; k <= i_3; ++k) { kj1 = k; j = kj1 + *n; jj = j + maxj; i_4 = jj; i_5 = *n; for (kj = j; i_5 < 0 ? kj >= i_4 : kj <= i_4; kj += i_5) { rv[kj1] = rv[kj]; kj1 = kj; /* L340: */ } rv[kj1] = 0.; /* L360: */ } if (i == *n) { goto L580; } u = 0.; /* Computing MIN */ i_3 = i + m1; maxk = min(i_3,*n); /* Computing MIN */ i_3 = *n - ii, i_5 = m21 - 2; maxj = min(i_3,i_5) * *n; i_3 = maxk; for (j = i; j <= i_3; ++j) { if ((d_1 = rv[j], abs(d_1)) < abs(u)) { goto L450; } u = rv[j]; k = j; L450: ; } j = i + *n; jj = j + maxj; if (k == i) { goto L520; } kj = k; i_3 = jj; i_5 = *n; for (ij = i; i_5 < 0 ? ij >= i_3 : ij <= i_3; ij += i_5) { v = rv[ij]; rv[ij] = rv[kj]; rv[kj] = v; kj += *n; /* L500: */ } if (order != 0.) { goto L520; } v = rv6[i]; rv6[i] = rv6[k]; rv6[k] = v; L520: if (u == 0.) { goto L580; } i_5 = maxk; for (k = ii; k <= i_5; ++k) { v = rv[k] / u; kj = k; i_3 = jj; i_4 = *n; for (ij = j; i_4 < 0 ? ij >= i_3 : ij <= i_3; ij += i_4) { kj += *n; rv[kj] -= v * rv[ij]; /* L540: */ } if (order == 0.) { rv6[k] -= v * rv6[i]; } /* L560: */ } L580: ; } /* .......... BACK SUBSTITUTION */ /* FOR I=N STEP -1 UNTIL 1 DO -- .......... */ L600: i_2 = *n; for (ii = 1; ii <= i_2; ++ii) { i = *n + 1 - ii; maxj = min(ii,m21); if (maxj == 1) { goto L620; } ij1 = i; j = ij1 + *n; jj = j + (maxj - 2) * *n; i_5 = jj; i_4 = *n; for (ij = j; i_4 < 0 ? ij >= i_5 : ij <= i_5; ij += i_4) { ++ij1; rv6[i] -= rv[ij] * rv6[ij1]; /* L610: */ } L620: v = rv[i]; if (abs(v) >= eps3) { goto L625; } /* .......... SET ERROR -- NEARLY SINGULAR LINEAR SYSTEM ..... ..... */ if (order == 0.) { *ierr = -r; } v = d_sign(&eps3, &v); L625: rv6[i] /= v; /* L630: */ } xu = 1.; if (order == 0.) { goto L870; } /* .......... ORTHOGONALIZE WITH RESPECT TO PREVIOUS */ /* MEMBERS OF GROUP .......... */ if (group == 0) { goto L700; } i_2 = group; for (jj = 1; jj <= i_2; ++jj) { j = r - group - 1 + jj; xu = 0.; i_4 = *n; for (i = 1; i <= i_4; ++i) { /* L640: */ xu += rv6[i] * z[i + j * z_dim1]; } i_4 = *n; for (i = 1; i <= i_4; ++i) { /* L660: */ rv6[i] -= xu * z[i + j * z_dim1]; } /* L680: */ } L700: norm = 0.; i_2 = *n; for (i = 1; i <= i_2; ++i) { /* L720: */ norm += (d_1 = rv6[i], abs(d_1)); } if (norm >= .1) { goto L840; } /* .......... IN-LINE PROCEDURE FOR CHOOSING */ /* A NEW STARTING VECTOR .......... */ if (its >= *n) { goto L830; } ++its; xu = eps4 / (uk + 1.); rv6[1] = eps4; i_2 = *n; for (i = 2; i <= i_2; ++i) { /* L760: */ rv6[i] = xu; } rv6[its] -= eps4 * uk; goto L600; /* .......... SET ERROR -- NON-CONVERGED EIGENVECTOR .......... */ L830: *ierr = -r; xu = 0.; goto L870; /* .......... NORMALIZE SO THAT SUM OF SQUARES IS */ /* 1 AND EXPAND TO FULL ORDER .......... */ L840: u = 0.; i_2 = *n; for (i = 1; i <= i_2; ++i) { /* L860: */ u = pythag_(&u, &rv6[i]); } xu = 1. / u; L870: i_2 = *n; for (i = 1; i <= i_2; ++i) { /* L900: */ z[i + r * z_dim1] = rv6[i] * xu; } x0 = x1; /* L920: */ } L1001: return 0; } /* bandv_ */ /* Subroutine */ int bisect_(integer *n, doublereal *eps1, doublereal *d, doublereal *e, doublereal *e2, doublereal *lb, doublereal *ub, integer *mm, integer *m, doublereal *w, integer *ind, integer *ierr, doublereal *rv4, doublereal *rv5) { /* System generated locals */ integer i_1, i_2; doublereal d_1, d_2, d_3; /* Local variables */ static integer i, j, k, l, p, q, r, s; static doublereal u, v; static integer m1, m2; static doublereal t1, t2, x0, x1; static integer ii; static doublereal xu; extern doublereal epslon_(doublereal *); static integer isturm, tag; static doublereal tst1, tst2; /* THIS SUBROUTINE IS A TRANSLATION OF THE BISECTION TECHNIQUE */ /* IN THE ALGOL PROCEDURE TRISTURM BY PETERS AND WILKINSON. */ /* HANDBOOK FOR AUTO. COMP., VOL.II-LINEAR ALGEBRA, 418-439(1971). */ /* THIS SUBROUTINE FINDS THOSE EIGENVALUES OF A TRIDIAGONAL */ /* SYMMETRIC MATRIX WHICH LIE IN A SPECIFIED INTERVAL, */ /* USING BISECTION. */ /* ON INPUT */ /* N IS THE ORDER OF THE MATRIX. */ /* EPS1 IS AN ABSOLUTE ERROR TOLERANCE FOR THE COMPUTED */ /* EIGENVALUES. IF THE INPUT EPS1 IS NON-POSITIVE, */ /* IT IS RESET FOR EACH SUBMATRIX TO A DEFAULT VALUE, */ /* NAMELY, MINUS THE PRODUCT OF THE RELATIVE MACHINE */ /* PRECISION AND THE 1-NORM OF THE SUBMATRIX. */ /* D CONTAINS THE DIAGONAL ELEMENTS OF THE INPUT MATRIX. */ /* E CONTAINS THE SUBDIAGONAL ELEMENTS OF THE INPUT MATRIX */ /* IN ITS LAST N-1 POSITIONS. E(1) IS ARBITRARY. */ /* E2 CONTAINS THE SQUARES OF THE CORRESPONDING ELEMENTS OF E. */ /* E2(1) IS ARBITRARY. */ /* LB AND UB DEFINE THE INTERVAL TO BE SEARCHED FOR EIGENVALUES. */ /* IF LB IS NOT LESS THAN UB, NO EIGENVALUES WILL BE FOUND. */ /* MM SHOULD BE SET TO AN UPPER BOUND FOR THE NUMBER OF */ /* EIGENVALUES IN THE INTERVAL. WARNING. IF MORE THAN */ /* MM EIGENVALUES ARE DETERMINED TO LIE IN THE INTERVAL, */ /* AN ERROR RETURN IS MADE WITH NO EIGENVALUES FOUND. */ /* ON OUTPUT */ /* EPS1 IS UNALTERED UNLESS IT HAS BEEN RESET TO ITS */ /* (LAST) DEFAULT VALUE. */ /* 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. */ /* M IS THE NUMBER OF EIGENVALUES DETERMINED TO LIE IN (LB,UB). */ /* W CONTAINS THE M EIGENVALUES IN ASCENDING ORDER. */ /* IND CONTAINS IN ITS FIRST M POSITIONS 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.. */ /* IERR IS SET TO */ /* ZERO FOR NORMAL RETURN, */ /* 3*N+1 IF M EXCEEDS MM. */ /* RV4 AND RV5 ARE TEMPORARY STORAGE ARRAYS. */ /* THE ALGOL PROCEDURE STURMCNT CONTAINED IN TRISTURM */ /* APPEARS IN BISECT IN-LINE. */ /* NOTE THAT SUBROUTINE TQL1 OR IMTQL1 IS GENERALLY FASTER THAN */ /* BISECT, IF MORE THAN N/4 EIGENVALUES ARE TO BE FOUND. */ /* 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 */ --rv5; --rv4; --e2; --e; --d; --ind; --w; /* Function Body */ *ierr = 0; tag = 0; t1 = *lb; t2 = *ub; /* .......... LOOK FOR SMALL SUB-DIAGONAL ENTRIES .......... */ i_1 = *n; for (i = 1; i <= i_1; ++i) { if (i == 1) { goto L20; } tst1 = (d_1 = d[i], abs(d_1)) + (d_2 = d[i - 1], abs(d_2)); tst2 = tst1 + (d_1 = e[i], abs(d_1)); if (tst2 > tst1) { goto L40; } L20: e2[i] = 0.; L40: ; } /* .......... DETERMINE THE NUMBER OF EIGENVALUES */ /* IN THE INTERVAL .......... */ p = 1; q = *n; x1 = *ub; isturm = 1; goto L320; L60: *m = s; x1 = *lb; isturm = 2; goto L320; L80: *m -= s; if (*m > *mm) { goto L980; } q = 0; r = 0; /* .......... ESTABLISH AND PROCESS NEXT SUBMATRIX, REFINING */ /* INTERVAL BY THE GERSCHGORIN BOUNDS .......... */ L100: if (r == *m) { goto L1001; } ++tag; p = q + 1; xu = d[p]; x0 = d[p]; u = 0.; i_1 = *n; for (q = p; q <= i_1; ++q) { x1 = u; u = 0.; v = 0.; if (q == *n) { goto L110; } u = (d_1 = e[q + 1], abs(d_1)); v = e2[q + 1]; L110: /* Computing MIN */ d_1 = d[q] - (x1 + u); xu = min(d_1,xu); /* Computing MAX */ d_1 = d[q] + (x1 + u); x0 = max(d_1,x0); if (v == 0.) { goto L140; } /* L120: */ } L140: /* Computing MAX */ d_2 = abs(xu), d_3 = abs(x0); d_1 = max(d_2,d_3); x1 = epslon_(&d_1); if (*eps1 <= 0.) { *eps1 = -x1; } if (p != q) { goto L180; } /* .......... CHECK FOR ISOLATED ROOT WITHIN INTERVAL .......... */ if (t1 > d[p] || d[p] >= t2) { goto L940; } m1 = p; m2 = p; rv5[p] = d[p]; goto L900; L180: x1 *= q - p + 1; /* Computing MAX */ d_1 = t1, d_2 = xu - x1; *lb = max(d_1,d_2); /* Computing MIN */ d_1 = t2, d_2 = x0 + x1; *ub = min(d_1,d_2); x1 = *lb; isturm = 3; goto L320; L200: m1 = s + 1; x1 = *ub; isturm = 4; goto L320; L220: m2 = s; if (m1 > m2) { goto L940; } /* .......... FIND ROOTS BY BISECTION .......... */ x0 = *ub; isturm = 5; i_1 = m2; for (i = m1; i <= i_1; ++i) { rv5[i] = *ub; rv4[i] = *lb; /* L240: */ } /* .......... LOOP FOR K-TH EIGENVALUE */ /* FOR K=M2 STEP -1 UNTIL M1 DO -- */ /* (-DO- NOT USED TO LEGALIZE -COMPUTED GO TO-) .......... */ k = m2; L250: xu = *lb; /* .......... FOR I=K STEP -1 UNTIL M1 DO -- .......... */ i_1 = k; for (ii = m1; ii <= i_1; ++ii) { i = m1 + k - ii; if (xu >= rv4[i]) { goto L260; } xu = rv4[i]; goto L280; L260: ; } L280: if (x0 > rv5[k]) { x0 = rv5[k]; } /* .......... NEXT BISECTION STEP .......... */ L300: x1 = (xu + x0) * .5; if (x0 - xu <= abs(*eps1)) { goto L420; } tst1 = (abs(xu) + abs(x0)) * 2.; tst2 = tst1 + (x0 - xu); if (tst2 == tst1) { goto L420; } /* .......... IN-LINE PROCEDURE FOR STURM SEQUENCE .......... */ L320: s = p - 1; u = 1.; i_1 = q; for (i = p; i <= i_1; ++i) { if (u != 0.) { goto L325; } v = (d_1 = e[i], abs(d_1)) / epslon_(&c_b141); if (e2[i] == 0.) { v = 0.; } goto L330; L325: v = e2[i] / u; L330: u = d[i] - x1 - v; if (u < 0.) { ++s; } /* L340: */ } switch (isturm) { case 1: goto L60; case 2: goto L80; case 3: goto L200; case 4: goto L220; case 5: goto L360; } /* .......... REFINE INTERVALS .......... */ L360: if (s >= k) { goto L400; } xu = x1; if (s >= m1) { goto L380; } rv4[m1] = x1; goto L300; L380: rv4[s + 1] = x1; if (rv5[s] > x1) { rv5[s] = x1; } goto L300; L400: x0 = x1; goto L300; /* .......... K-TH EIGENVALUE FOUND .......... */ L420: rv5[k] = x1; --k; if (k >= m1) { goto L250; } /* .......... ORDER EIGENVALUES TAGGED WITH THEIR */ /* SUBMATRIX ASSOCIATIONS .......... */ L900: s = r; r = r + m2 - m1 + 1; j = 1; k = m1; i_1 = r; for (l = 1; l <= i_1; ++l) { if (j > s) { goto L910; } if (k > m2) { goto L940; } if (rv5[k] >= w[l]) { goto L915; } i_2 = s; for (ii = j; ii <= i_2; ++ii) { i = l + s - ii; w[i + 1] = w[i]; ind[i + 1] = ind[i]; /* L905: */ } L910: w[l] = rv5[k]; ind[l] = tag; ++k; goto L920; L915: ++j; L920: ; } L940: if (q < *n) { goto L100; } goto L1001; /* .......... SET ERROR -- UNDERESTIMATE OF NUMBER OF */ /* EIGENVALUES IN INTERVAL .......... */ L980: *ierr = *n * 3 + 1; L1001: *lb = t1; *ub = t2; return 0; } /* bisect_ */ /* Subroutine */ int bqr_(integer *nm, integer *n, integer *mb, doublereal *a, doublereal *t, doublereal *r, integer *ierr, integer */*nv*/, doublereal *rv) { /* System generated locals */ integer a_dim1, a_offset, i_1, i_2, i_3; doublereal d_1; /* Builtin functions */ double d_sign(doublereal *, doublereal *), sqrt(doublereal); /* Local variables */ static doublereal f, g; static integer i, j, k, l, m; static doublereal q, s, scale; static integer imult, m1, m2, m3, m4, m21, m31, ii, ik, jk, kj, jm, kk, km, ll, mk, mn, ni, mz; extern doublereal pythag_(doublereal *, doublereal *); static integer kj1, its; static doublereal tst1, tst2; /* THIS SUBROUTINE IS A TRANSLATION OF THE ALGOL PROCEDURE BQR, */ /* NUM. MATH. 16, 85-92(1970) BY MARTIN, REINSCH, AND WILKINSON. */ /* HANDBOOK FOR AUTO. COMP., VOL II-LINEAR ALGEBRA, 266-272(1971). */ /* THIS SUBROUTINE FINDS THE EIGENVALUE OF SMALLEST (USUALLY) */ /* MAGNITUDE OF A REAL SYMMETRIC BAND MATRIX USING THE */ /* QR ALGORITHM WITH SHIFTS OF ORIGIN. CONSECUTIVE CALLS */ /* CAN BE MADE TO FIND FURTHER EIGENVALUES. */ /* ON INPUT */ /* NM MUST BE SET TO THE ROW DIMENSION OF TWO-DIMENSIONAL */ /* ARRAY PARAMETERS AS DECLARED IN THE CALLING PROGRAM */ /* DIMENSION STATEMENT. */ /* N IS THE ORDER OF THE MATRIX. */ /* MB IS THE (HALF) BAND WIDTH OF THE MATRIX, DEFINED AS THE */ /* NUMBER OF ADJACENT DIAGONALS, INCLUDING THE PRINCIPAL */ /* DIAGONAL, REQUIRED TO SPECIFY THE NON-ZERO PORTION OF THE */ /* LOWER TRIANGLE OF THE MATRIX. */ /* A CONTAINS THE LOWER TRIANGLE OF THE SYMMETRIC BAND INPUT */ /* MATRIX STORED AS AN N BY MB ARRAY. ITS LOWEST SUBDIAGONAL */ /* IS STORED IN THE LAST N+1-MB POSITIONS OF THE FIRST COLUMN, */ /* ITS NEXT SUBDIAGONAL IN THE LAST N+2-MB POSITIONS OF THE */ /* SECOND COLUMN, FURTHER SUBDIAGONALS SIMILARLY, AND FINALLY */ /* ITS PRINCIPAL DIAGONAL IN THE N POSITIONS OF THE LAST COLUMN. */ /* CONTENTS OF STORAGES NOT PART OF THE MATRIX ARE ARBITRARY. */ /* ON A SUBSEQUENT CALL, ITS OUTPUT CONTENTS FROM THE PREVIOUS */ /* CALL SHOULD BE PASSED. */ /* T SPECIFIES THE SHIFT (OF EIGENVALUES) APPLIED TO THE DIAGONAL */ /* OF A IN FORMING THE INPUT MATRIX. WHAT IS ACTUALLY DETERMINED */ /* IS THE EIGENVALUE OF A+TI (I IS THE IDENTITY MATRIX) NEAREST */ /* TO T. ON A SUBSEQUENT CALL, THE OUTPUT VALUE OF T FROM THE */ /* PREVIOUS CALL SHOULD BE PASSED IF THE NEXT NEAREST EIGENVALUE */ /* IS SOUGHT. */ /* R SHOULD BE SPECIFIED AS ZERO ON THE FIRST CALL, AND AS ITS */ /* OUTPUT VALUE FROM THE PREVIOUS CALL ON A SUBSEQUENT CALL. */ /* IT IS USED TO DETERMINE WHEN THE LAST ROW AND COLUMN OF */ /* THE TRANSFORMED BAND MATRIX CAN BE REGARDED AS NEGLIGIBLE. */ /* NV MUST BE SET TO THE DIMENSION OF THE ARRAY PARAMETER RV */ /* AS DECLARED IN THE CALLING PROGRAM DIMENSION STATEMENT. */ /* ON OUTPUT */ /* A CONTAINS THE TRANSFORMED BAND MATRIX. THE MATRIX A+TI */ /* DERIVED FROM THE OUTPUT PARAMETERS IS SIMILAR TO THE */ /* INPUT A+TI TO WITHIN ROUNDING ERRORS. ITS LAST ROW AND */ /* COLUMN ARE NULL (IF IERR IS ZERO). */ /* T CONTAINS THE COMPUTED EIGENVALUE OF A+TI (IF IERR IS ZERO). */ /* R CONTAINS THE MAXIMUM OF ITS INPUT VALUE AND THE NORM OF THE */ /* LAST COLUMN OF THE INPUT MATRIX A. */ /* IERR IS SET TO */ /* ZERO FOR NORMAL RETURN, */ /* N IF THE EIGENVALUE HAS NOT BEEN */ /* DETERMINED AFTER 30 ITERATIONS. */ /* RV IS A TEMPORARY STORAGE ARRAY OF DIMENSION AT LEAST */ /* (2*MB**2+4*MB-3). THE FIRST (3*MB-2) LOCATIONS CORRESPOND */ /* TO THE ALGOL ARRAY B, THE NEXT (2*MB-1) LOCATIONS CORRESPOND */ /* TO THE ALGOL ARRAY H, AND THE FINAL (2*MB**2-MB) LOCATIONS */ /* CORRESPOND TO THE MB BY (2*MB-1) ALGOL ARRAY U. */ /* NOTE. FOR A SUBSEQUENT CALL, N SHOULD BE REPLACED BY N-1, BUT */ /* MB SHOULD NOT BE ALTERED EVEN WHEN IT EXCEEDS THE CURRENT N. */ /* 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 */ a_dim1 = *nm; a_offset = a_dim1 + 1; a -= a_offset; --rv; /* Function Body */ *ierr = 0; m1 = min(*mb,*n); m = m1 - 1; m2 = m + m; m21 = m2 + 1; m3 = m21 + m; m31 = m3 + 1; m4 = m31 + m2; mn = m + *n; mz = *mb - m1; its = 0; /* .......... TEST FOR CONVERGENCE .......... */ L40: g = a[*n + *mb * a_dim1]; if (m == 0) { goto L360; } f = 0.; i_1 = m; for (k = 1; k <= i_1; ++k) { mk = k + mz; f += (d_1 = a[*n + mk * a_dim1], abs(d_1)); /* L50: */ } if (its == 0 && f > *r) { *r = f; } tst1 = *r; tst2 = tst1 + f; if (tst2 <= tst1) { goto L360; } if (its == 30) { goto L1000; } ++its; /* .......... FORM SHIFT FROM BOTTOM 2 BY 2 MINOR .......... */ if (f > *r * .25 && its < 5) { goto L90; } f = a[*n + (*mb - 1) * a_dim1]; if (f == 0.) { goto L70; } q = (a[*n - 1 + *mb * a_dim1] - g) / (f * 2.); s = pythag_(&q, &c_b141); g -= f / (q + d_sign(&s, &q)); L70: *t += g; i_1 = *n; for (i = 1; i <= i_1; ++i) { /* L80: */ a[i + *mb * a_dim1] -= g; } L90: i_1 = m4; for (k = m31; k <= i_1; ++k) { /* L100: */ rv[k] = 0.; } i_1 = mn; for (ii = 1; ii <= i_1; ++ii) { i = ii - m; ni = *n - ii; if (ni < 0) { goto L230; } /* .......... FORM COLUMN OF SHIFTED MATRIX A-G*I .......... */ /* Computing MAX */ i_2 = 1, i_3 = 2 - i; l = max(i_2,i_3); i_2 = m3; for (k = 1; k <= i_2; ++k) { /* L110: */ rv[k] = 0.; } i_2 = m1; for (k = l; k <= i_2; ++k) { km = k + m; mk = k + mz; rv[km] = a[ii + mk * a_dim1]; /* L120: */ } ll = min(m,ni); if (ll == 0) { goto L135; } i_2 = ll; for (k = 1; k <= i_2; ++k) { km = k + m21; ik = ii + k; mk = *mb - k; rv[km] = a[ik + mk * a_dim1]; /* L130: */ } /* .......... PRE-MULTIPLY WITH HOUSEHOLDER REFLECTIONS .......... */ L135: ll = m2; imult = 0; /* .......... MULTIPLICATION PROCEDURE .......... */ L140: kj = m4 - m1; i_2 = ll; for (j = 1; j <= i_2; ++j) { kj += m1; jm = j + m3; if (rv[jm] == 0.) { goto L170; } f = 0.; i_3 = m1; for (k = 1; k <= i_3; ++k) { ++kj; jk = j + k - 1; f += rv[kj] * rv[jk]; /* L150: */ } f /= rv[jm]; kj -= m1; i_3 = m1; for (k = 1; k <= i_3; ++k) { ++kj; jk = j + k - 1; rv[jk] -= rv[kj] * f; /* L160: */ } kj -= m1; L170: ; } if (imult != 0) { goto L280; } /* .......... HOUSEHOLDER REFLECTION .......... */ f = rv[m21]; s = 0.; rv[m4] = 0.; scale = 0.; i_2 = m3; for (k = m21; k <= i_2; ++k) { /* L180: */ scale += (d_1 = rv[k], abs(d_1)); } if (scale == 0.) { goto L210; } i_2 = m3; for (k = m21; k <= i_2; ++k) { /* L190: */ /* Computing 2nd power */ d_1 = rv[k] / scale; s += d_1 * d_1; } s = scale * scale * s; d_1 = sqrt(s); g = -d_sign(&d_1, &f); rv[m21] = g; rv[m4] = s - f * g; kj = m4 + m2 * m1 + 1; rv[kj] = f - g; i_2 = m1; for (k = 2; k <= i_2; ++k) { ++kj; km = k + m2; rv[kj] = rv[km]; /* L200: */ } /* .......... SAVE COLUMN OF TRIANGULAR FACTOR R .......... */ L210: i_2 = m1; for (k = l; k <= i_2; ++k) { km = k + m; mk = k + mz; a[ii + mk * a_dim1] = rv[km]; /* L220: */ } L230: /* Computing MAX */ i_2 = 1, i_3 = m1 + 1 - i; l = max(i_2,i_3); if (i <= 0) { goto L300; } /* .......... PERFORM ADDITIONAL STEPS .......... */ i_2 = m21; for (k = 1; k <= i_2; ++k) { /* L240: */ rv[k] = 0.; } /* Computing MIN */ i_2 = m1, i_3 = ni + m1; ll = min(i_2,i_3); /* .......... GET ROW OF TRIANGULAR FACTOR R .......... */ i_2 = ll; for (kk = 1; kk <= i_2; ++kk) { k = kk - 1; km = k + m1; ik = i + k; mk = *mb - k; rv[km] = a[ik + mk * a_dim1]; /* L250: */ } /* .......... POST-MULTIPLY WITH HOUSEHOLDER REFLECTIONS ......... . */ ll = m1; imult = 1; goto L140; /* .......... STORE COLUMN OF NEW A MATRIX .......... */ L280: i_2 = m1; for (k = l; k <= i_2; ++k) { mk = k + mz; a[i + mk * a_dim1] = rv[k]; /* L290: */ } /* .......... UPDATE HOUSEHOLDER REFLECTIONS .......... */ L300: if (l > 1) { --l; } kj1 = m4 + l * m1; i_2 = m2; for (j = l; j <= i_2; ++j) { jm = j + m3; rv[jm] = rv[jm + 1]; i_3 = m1; for (k = 1; k <= i_3; ++k) { ++kj1; kj = kj1 - m1; rv[kj] = rv[kj1]; /* L320: */ } } /* L350: */ } goto L40; /* .......... CONVERGENCE .......... */ L360: *t += g; i_1 = *n; for (i = 1; i <= i_1; ++i) { /* L380: */ a[i + *mb * a_dim1] -= g; } i_1 = m1; for (k = 1; k <= i_1; ++k) { mk = k + mz; a[*n + mk * a_dim1] = 0.; /* L400: */ } goto L1001; /* .......... SET ERROR -- NO CONVERGENCE TO */ /* EIGENVALUE AFTER 30 ITERATIONS .......... */ L1000: *ierr = *n; L1001: return 0; } /* bqr_ */ /* Subroutine */ int cbabk2_(integer *nm, integer *n, integer *low, integer * igh, doublereal *scale, integer *m, doublereal *zr, doublereal *zi) { /* System generated locals */ integer zr_dim1, zr_offset, zi_dim1, zi_offset, i_1, i_2; /* Local variables */ static integer i, j, k; static doublereal s; static integer ii; /* THIS SUBROUTINE IS A TRANSLATION OF THE ALGOL PROCEDURE */ /* CBABK2, WHICH IS A COMPLEX VERSION OF BALBAK, */ /* NUM. MATH. 13, 293-304(1969) BY PARLETT AND REINSCH. */ /* HANDBOOK FOR AUTO. COMP., VOL.II-LINEAR ALGEBRA, 315-326(1971). */ /* THIS SUBROUTINE FORMS THE EIGENVECTORS OF A COMPLEX GENERAL */ /* MATRIX BY BACK TRANSFORMING THOSE OF THE CORRESPONDING */ /* BALANCED MATRIX DETERMINED BY CBAL. */ /* ON INPUT */ /* NM MUST BE SET TO THE ROW DIMENSION OF TWO-DIMENSIONAL */ /* ARRAY PARAMETERS AS DECLARED IN THE CALLING PROGRAM */ /* DIMENSION STATEMENT. */ /* N IS THE ORDER OF THE MATRIX. */ /* LOW AND IGH ARE INTEGERS DETERMINED BY CBAL. */ /* SCALE CONTAINS INFORMATION DETERMINING THE PERMUTATIONS */ /* AND SCALING FACTORS USED BY CBAL. */ /* M IS THE NUMBER OF EIGENVECTORS TO BE BACK TRANSFORMED. */ /* ZR AND ZI CONTAIN THE REAL AND IMAGINARY PARTS, */ /* RESPECTIVELY, OF THE EIGENVECTORS TO BE */ /* BACK TRANSFORMED IN THEIR FIRST M COLUMNS. */ /* ON OUTPUT */ /* ZR AND ZI CONTAIN THE REAL AND IMAGINARY PARTS, */ /* RESPECTIVELY, OF THE TRANSFORMED EIGENVECTORS */ /* IN THEIR FIRST M COLUMNS. */ /* 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 */ --scale; zi_dim1 = *nm; zi_offset = zi_dim1 + 1; zi -= zi_offset; zr_dim1 = *nm; zr_offset = zr_dim1 + 1; zr -= zr_offset; /* Function Body */ if (*m == 0) { goto L200; } if (*igh == *low) { goto L120; } i_1 = *igh; for (i = *low; i <= i_1; ++i) { s = scale[i]; /* .......... LEFT HAND EIGENVECTORS ARE BACK TRANSFORMED */ /* IF THE FOREGOING STATEMENT IS REPLACED BY */ /* S=1.0D0/SCALE(I). .......... */ i_2 = *m; for (j = 1; j <= i_2; ++j) { zr[i + j * zr_dim1] *= s; zi[i + j * zi_dim1] *= s; /* L100: */ } /* L110: */ } /* .......... FOR I=LOW-1 STEP -1 UNTIL 1, */ /* IGH+1 STEP 1 UNTIL N DO -- .......... */ L120: i_1 = *n; for (ii = 1; ii <= i_1; ++ii) { i = ii; if (i >= *low && i <= *igh) { goto L140; } if (i < *low) { i = *low - ii; } k = (integer) scale[i]; if (k == i) { goto L140; } i_2 = *m; for (j = 1; j <= i_2; ++j) { s = zr[i + j * zr_dim1]; zr[i + j * zr_dim1] = zr[k + j * zr_dim1]; zr[k + j * zr_dim1] = s; s = zi[i + j * zi_dim1]; zi[i + j * zi_dim1] = zi[k + j * zi_dim1]; zi[k + j * zi_dim1] = s; /* L130: */ } L140: ; } L200: return 0; } /* cbabk2_ */ /* Subroutine */ int cbal_(integer *nm, integer *n, doublereal *ar, doublereal *ai, integer *low, integer *igh, doublereal *scale) { /* System generated locals */ integer ar_dim1, ar_offset, ai_dim1, ai_offset, i_1, i_2; doublereal d_1, d_2; /* Local variables */ static integer iexc; static doublereal c, f, g; static integer i, j, k, l, m; static doublereal r, s, radix, b2; static integer jj; static logical noconv; /* THIS SUBROUTINE IS A TRANSLATION OF THE ALGOL PROCEDURE */ /* CBALANCE, WHICH IS A COMPLEX VERSION OF BALANCE, */ /* NUM. MATH. 13, 293-304(1969) BY PARLETT AND REINSCH. */ /* HANDBOOK FOR AUTO. COMP., VOL.II-LINEAR ALGEBRA, 315-326(1971). */ /* THIS SUBROUTINE BALANCES A COMPLEX MATRIX AND ISOLATES */ /* EIGENVALUES WHENEVER POSSIBLE. */ /* ON INPUT */ /* NM MUST BE SET TO THE ROW DIMENSION OF TWO-DIMENSIONAL */ /* ARRAY PARAMETERS AS DECLARED IN THE CALLING PROGRAM */ /* DIMENSION STATEMENT. */ /* N IS THE ORDER OF THE MATRIX. */ /* AR AND AI CONTAIN THE REAL AND IMAGINARY PARTS, */ /* RESPECTIVELY, OF THE COMPLEX MATRIX TO BE BALANCED. */ /* ON OUTPUT */ /* AR AND AI CONTAIN THE REAL AND IMAGINARY PARTS, */ /* RESPECTIVELY, OF THE BALANCED MATRIX. */ /* LOW AND IGH ARE TWO INTEGERS SUCH THAT AR(I,J) AND AI(I,J) */ /* ARE EQUAL TO ZERO IF */ /* (1) I IS GREATER THAN J AND */ /* (2) J=1,...,LOW-1 OR I=IGH+1,...,N. */ /* SCALE CONTAINS INFORMATION DETERMINING THE */ /* PERMUTATIONS AND SCALING FACTORS USED. */ /* SUPPOSE THAT THE PRINCIPAL SUBMATRIX IN ROWS LOW THROUGH IGH */ /* HAS BEEN BALANCED, THAT P(J) DENOTES THE INDEX INTERCHANGED */ /* WITH J DURING THE PERMUTATION STEP, AND THAT THE ELEMENTS */ /* OF THE DIAGONAL MATRIX USED ARE DENOTED BY D(I,J). THEN */ /* SCALE(J) = P(J), FOR J = 1,...,LOW-1 */ /* = D(J,J) J = LOW,...,IGH */ /* = P(J) J = IGH+1,...,N. */ /* THE ORDER IN WHICH THE INTERCHANGES ARE MADE IS N TO IGH+1, */ /* THEN 1 TO LOW-1. */ /* NOTE THAT 1 IS RETURNED FOR IGH IF IGH IS ZERO FORMALLY. */ /* THE ALGOL PROCEDURE EXC CONTAINED IN CBALANCE APPEARS IN */ /* CBAL IN LINE. (NOTE THAT THE ALGOL ROLES OF IDENTIFIERS */ /* K,L HAVE BEEN REVERSED.) */ /* ARITHMETIC IS REAL THROUGHOUT. */ /* 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 */ --scale; ai_dim1 = *nm; ai_offset = ai_dim1 + 1; ai -= ai_offset; ar_dim1 = *nm; ar_offset = ar_dim1 + 1; ar -= ar_offset; /* Function Body */ radix = 16.; b2 = radix * radix; k = 1; l = *n; goto L100; /* .......... IN-LINE PROCEDURE FOR ROW AND */ /* COLUMN EXCHANGE .......... */ L20: scale[m] = (doublereal) j; if (j == m) { goto L50; } i_1 = l; for (i = 1; i <= i_1; ++i) { f = ar[i + j * ar_dim1]; ar[i + j * ar_dim1] = ar[i + m * ar_dim1]; ar[i + m * ar_dim1] = f; f = ai[i + j * ai_dim1]; ai[i + j * ai_dim1] = ai[i + m * ai_dim1]; ai[i + m * ai_dim1] = f; /* L30: */ } i_1 = *n; for (i = k; i <= i_1; ++i) { f = ar[j + i * ar_dim1]; ar[j + i * ar_dim1] = ar[m + i * ar_dim1]; ar[m + i * ar_dim1] = f; f = ai[j + i * ai_dim1]; ai[j + i * ai_dim1] = ai[m + i * ai_dim1]; ai[m + i * ai_dim1] = f; /* L40: */ } L50: switch (iexc) { case 1: goto L80; case 2: goto L130; } /* .......... SEARCH FOR ROWS ISOLATING AN EIGENVALUE */ /* AND PUSH THEM DOWN .......... */ L80: if (l == 1) { goto L280; } --l; /* .......... FOR J=L STEP -1 UNTIL 1 DO -- .......... */ L100: i_1 = l; for (jj = 1; jj <= i_1; ++jj) { j = l + 1 - jj; i_2 = l; for (i = 1; i <= i_2; ++i) { if (i == j) { goto L110; } if (ar[j + i * ar_dim1] != 0. || ai[j + i * ai_dim1] != 0.) { goto L120; } L110: ; } m = l; iexc = 1; goto L20; L120: ; } goto L140; /* .......... SEARCH FOR COLUMNS ISOLATING AN EIGENVALUE */ /* AND PUSH THEM LEFT .......... */ L130: ++k; L140: i_1 = l; for (j = k; j <= i_1; ++j) { i_2 = l; for (i = k; i <= i_2; ++i) { if (i == j) { goto L150; } if (ar[i + j * ar_dim1] != 0. || ai[i + j * ai_dim1] != 0.) { goto L170; } L150: ; } m = k; iexc = 2; goto L20; L170: ; } /* .......... NOW BALANCE THE SUBMATRIX IN ROWS K TO L .......... */ i_1 = l; for (i = k; i <= i_1; ++i) { /* L180: */ scale[i] = 1.; } /* .......... ITERATIVE LOOP FOR NORM REDUCTION .......... */ L190: noconv = FALSE_; i_1 = l; for (i = k; i <= i_1; ++i) { c = 0.; r = 0.; i_2 = l; for (j = k; j <= i_2; ++j) { if (j == i) { goto L200; } c = c + (d_1 = ar[j + i * ar_dim1], abs(d_1)) + (d_2 = ai[j + i * ai_dim1], abs(d_2)); r = r + (d_1 = ar[i + j * ar_dim1], abs(d_1)) + (d_2 = ai[i + j * ai_dim1], abs(d_2)); L200: ; } /* .......... GUARD AGAINST ZERO C OR R DUE TO UNDERFLOW ......... . */ if (c == 0. || r == 0.) { goto L270; } g = r / radix; f = 1.; s = c + r; L210: if (c >= g) { goto L220; } f *= radix; c *= b2; goto L210; L220: g = r * radix; L230: if (c < g) { goto L240; } f /= radix; c /= b2; goto L230; /* .......... NOW BALANCE .......... */ L240: if ((c + r) / f >= s * .95) { goto L270; } g = 1. / f; scale[i] *= f; noconv = TRUE_; i_2 = *n; for (j = k; j <= i_2; ++j) { ar[i + j * ar_dim1] *= g; ai[i + j * ai_dim1] *= g; /* L250: */ } i_2 = l; for (j = 1; j <= i_2; ++j) { ar[j + i * ar_dim1] *= f; ai[j + i * ai_dim1] *= f; /* L260: */ } L270: ; } if (noconv) { goto L190; } L280: *low = k; *igh = l; return 0; } /* cbal_ */ /* Subroutine */ int cg_(integer *nm, integer *n, doublereal *ar, doublereal * ai, doublereal *wr, doublereal *wi, integer *matz, doublereal *zr, doublereal *zi, doublereal *fv1, doublereal *fv2, doublereal *fv3, integer *ierr) { /* System generated locals */ integer ar_dim1, ar_offset, ai_dim1, ai_offset, zr_dim1, zr_offset, zi_dim1, zi_offset; /* Local variables */ extern /* Subroutine */ int cbal_(integer *, integer *, doublereal *, doublereal *, integer *, integer *, doublereal *), corth_(integer *, integer *, integer *, integer *, doublereal *, doublereal *, doublereal *, doublereal *), comqr_(integer *, integer *, integer *, integer *, doublereal *, doublereal *, doublereal *, doublereal *, integer *), cbabk2_(integer *, integer *, integer *, integer *, doublereal *, integer *, doublereal *, doublereal *), comqr2_(integer *, integer *, integer *, integer *, doublereal *, doublereal *, doublereal *, doublereal *, doublereal *, doublereal *, doublereal *, doublereal *, integer *); static integer is1, is2; /* THIS SUBROUTINE CALLS THE RECOMMENDED SEQUENCE OF */ /* SUBROUTINES FROM THE EIGENSYSTEM SUBROUTINE PACKAGE (EISPACK) */ /* TO FIND THE EIGENVALUES AND EIGENVECTORS (IF DESIRED) */ /* OF A COMPLEX GENERAL MATRIX. */ /* ON INPUT */ /* NM MUST BE SET TO THE ROW DIMENSION OF THE TWO-DIMENSIONAL */ /* ARRAY PARAMETERS AS DECLARED IN THE CALLING PROGRAM */ /* DIMENSION STATEMENT. */ /* N IS THE ORDER OF THE MATRIX A=(AR,AI). */ /* AR AND AI CONTAIN THE REAL AND IMAGINARY PARTS, */ /* RESPECTIVELY, OF THE COMPLEX GENERAL MATRIX. */ /* MATZ IS AN INTEGER VARIABLE SET EQUAL TO ZERO IF */ /* ONLY EIGENVALUES ARE DESIRED. OTHERWISE IT IS SET TO */ /* ANY NON-ZERO INTEGER FOR BOTH EIGENVALUES AND EIGENVECTORS. */ /* ON OUTPUT */ /* WR AND WI CONTAIN THE REAL AND IMAGINARY PARTS, */ /* RESPECTIVELY, OF THE EIGENVALUES. */ /* ZR AND ZI CONTAIN THE REAL AND IMAGINARY PARTS, */ /* RESPECTIVELY, OF THE EIGENVECTORS IF MATZ IS NOT ZERO. */ /* IERR IS AN INTEGER OUTPUT VARIABLE SET EQUAL TO AN ERROR */ /* COMPLETION CODE DESCRIBED IN THE DOCUMENTATION FOR COMQR */ /* AND COMQR2. THE NORMAL COMPLETION CODE IS ZERO. */ /* FV1, FV2, AND FV3 ARE TEMPORARY STORAGE ARRAYS. */ /* 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 */ --fv3; --fv2; --fv1; zi_dim1 = *nm; zi_offset = zi_dim1 + 1; zi -= zi_offset; zr_dim1 = *nm; zr_offset = zr_dim1 + 1; zr -= zr_offset; --wi; --wr; ai_dim1 = *nm; ai_offset = ai_dim1 + 1; ai -= ai_offset; ar_dim1 = *nm; ar_offset = ar_dim1 + 1; ar -= ar_offset; /* Function Body */ if (*n <= *nm) { goto L10; } *ierr = *n * 10; goto L50; L10: cbal_(nm, n, &ar[ar_offset], &ai[ai_offset], &is1, &is2, &fv1[1]); corth_(nm, n, &is1, &is2, &ar[ar_offset], &ai[ai_offset], &fv2[1], &fv3[1] ); if (*matz != 0) { goto L20; } /* .......... FIND EIGENVALUES ONLY .......... */ comqr_(nm, n, &is1, &is2, &ar[ar_offset], &ai[ai_offset], &wr[1], &wi[1], ierr); goto L50; /* .......... FIND BOTH EIGENVALUES AND EIGENVECTORS .......... */ L20: comqr2_(nm, n, &is1, &is2, &fv2[1], &fv3[1], &ar[ar_offset], &ai[ ai_offset], &wr[1], &wi[1], &zr[zr_offset], &zi[zi_offset], ierr); if (*ierr != 0) { goto L50; } cbabk2_(nm, n, &is1, &is2, &fv1[1], n, &zr[zr_offset], &zi[zi_offset]); L50: return 0; } /* cg_ */ /* Subroutine */ int ch_(integer *nm, integer *n, doublereal *ar, doublereal * ai, doublereal *w, integer *matz, doublereal *zr, doublereal *zi, doublereal *fv1, doublereal *fv2, doublereal *fm1, integer *ierr) { /* System generated locals */ integer ar_dim1, ar_offset, ai_dim1, ai_offset, zr_dim1, zr_offset, zi_dim1, zi_offset, i_1, i_2; /* Local variables */ static integer i, j; extern /* Subroutine */ int htridi_(integer *, integer *, doublereal *, doublereal *, doublereal *, doublereal *, doublereal *, doublereal *), htribk_(integer *, integer *, doublereal *, doublereal *, doublereal *, integer *, doublereal *, doublereal *) , tqlrat_(integer *, doublereal *, doublereal *, integer *), tql2_(integer *, integer *, doublereal *, doublereal *, doublereal *, integer *); /* THIS SUBROUTINE CALLS THE RECOMMENDED SEQUENCE OF */ /* SUBROUTINES FROM THE EIGENSYSTEM SUBROUTINE PACKAGE (EISPACK) */ /* TO FIND THE EIGENVALUES AND EIGENVECTORS (IF DESIRED) */ /* OF A COMPLEX HERMITIAN MATRIX. */ /* ON INPUT */ /* NM MUST BE SET TO THE ROW DIMENSION OF THE TWO-DIMENSIONAL */ /* ARRAY PARAMETERS AS DECLARED IN THE CALLING PROGRAM */ /* DIMENSION STATEMENT. */ /* N IS THE ORDER OF THE MATRIX A=(AR,AI). */ /* AR AND AI CONTAIN THE REAL AND IMAGINARY PARTS, */ /* RESPECTIVELY, OF THE COMPLEX HERMITIAN MATRIX. */ /* MATZ IS AN INTEGER VARIABLE SET EQUAL TO ZERO IF */ /* ONLY EIGENVALUES ARE DESIRED. OTHERWISE IT IS SET TO */ /* ANY NON-ZERO INTEGER FOR BOTH EIGENVALUES AND EIGENVECTORS. */ /* ON OUTPUT */ /* W CONTAINS THE EIGENVALUES IN ASCENDING ORDER. */ /* ZR AND ZI CONTAIN THE REAL AND IMAGINARY PARTS, */ /* RESPECTIVELY, OF THE EIGENVECTORS IF MATZ IS NOT ZERO. */ /* IERR IS AN INTEGER OUTPUT VARIABLE SET EQUAL TO AN ERROR */ /* COMPLETION CODE DESCRIBED IN THE DOCUMENTATION FOR TQLRAT */ /* AND TQL2. THE NORMAL COMPLETION CODE IS ZERO. */ /* FV1, FV2, AND FM1 ARE TEMPORARY STORAGE ARRAYS. */ /* 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 */ fm1 -= 3; --fv2; --fv1; zi_dim1 = *nm; zi_offset = zi_dim1 + 1; zi -= zi_offset; zr_dim1 = *nm; zr_offset = zr_dim1 + 1; zr -= zr_offset; --w; ai_dim1 = *nm; ai_offset = ai_dim1 + 1; ai -= ai_offset; ar_dim1 = *nm; ar_offset = ar_dim1 + 1; ar -= ar_offset; /* Function Body */ if (*n <= *nm) { goto L10; } *ierr = *n * 10; goto L50; L10: htridi_(nm, n, &ar[ar_offset], &ai[ai_offset], &w[1], &fv1[1], &fv2[1], & fm1[3]); if (*matz != 0) { goto L20; } /* .......... FIND EIGENVALUES ONLY .......... */ tqlrat_(n, &w[1], &fv2[1], ierr); goto L50; /* .......... FIND BOTH EIGENVALUES AND EIGENVECTORS .......... */ L20: i_1 = *n; for (i = 1; i <= i_1; ++i) { i_2 = *n; for (j = 1; j <= i_2; ++j) { zr[j + i * zr_dim1] = 0.; /* L30: */ } zr[i + i * zr_dim1] = 1.; /* L40: */ } tql2_(nm, n, &w[1], &fv1[1], &zr[zr_offset], ierr); if (*ierr != 0) { goto L50; } htribk_(nm, n, &ar[ar_offset], &ai[ai_offset], &fm1[3], n, &zr[zr_offset], &zi[zi_offset]); L50: return 0; } /* ch_ */ /* Subroutine */ int cinvit_(integer *nm, integer *n, doublereal *ar, doublereal *ai, doublereal *wr, doublereal *wi, logical *select, integer *mm, integer *m, doublereal *zr, doublereal *zi, integer * ierr, doublereal *rm1, doublereal *rm2, doublereal *rv1, doublereal * rv2) { /* System generated locals */ integer ar_dim1, ar_offset, ai_dim1, ai_offset, zr_dim1, zr_offset, zi_dim1, zi_offset, rm1_dim1, rm1_offset, rm2_dim1, rm2_offset, i_1, i_2, i_3; doublereal d_1, d_2; /* Builtin functions */ double sqrt(doublereal); /* Local variables */ extern /* Subroutine */ int cdiv_(doublereal *, doublereal *, doublereal * , doublereal *, doublereal *, doublereal *); static doublereal norm; static integer i, j, k, s; static doublereal x, y, normv; static integer ii; static doublereal ilambd; static integer mp, uk; static doublereal rlambd; extern doublereal pythag_(doublereal *, doublereal *), epslon_(doublereal *); static integer km1, ip1; static doublereal growto, ukroot; static integer its; static doublereal eps3; /* THIS SUBROUTINE IS A TRANSLATION OF THE ALGOL PROCEDURE CX INVIT */ /* BY PETERS AND WILKINSON. */ /* HANDBOOK FOR AUTO. COMP. VOL.II-LINEAR ALGEBRA, 418-439(1971). */ /* THIS SUBROUTINE FINDS THOSE EIGENVECTORS OF A COMPLEX UPPER */ /* HESSENBERG MATRIX CORRESPONDING TO SPECIFIED EIGENVALUES, */ /* USING INVERSE ITERATION. */ /* ON INPUT */ /* NM MUST BE SET TO THE ROW DIMENSION OF TWO-DIMENSIONAL */ /* ARRAY PARAMETERS AS DECLARED IN THE CALLING PROGRAM */ /* DIMENSION STATEMENT. */ /* N IS THE ORDER OF THE MATRIX. */ /* AR AND AI CONTAIN THE REAL AND IMAGINARY PARTS, */ /* RESPECTIVELY, OF THE HESSENBERG MATRIX. */ /* WR AND WI CONTAIN THE REAL AND IMAGINARY PARTS, RESPECTIVELY, */ /* OF THE EIGENVALUES OF THE MATRIX. THE EIGENVALUES MUST BE */ /* STORED IN A MANNER IDENTICAL TO THAT OF SUBROUTINE COMLR, */ /* WHICH RECOGNIZES POSSIBLE SPLITTING OF THE MATRIX. */ /* SELECT SPECIFIES THE EIGENVECTORS TO BE FOUND. THE */ /* EIGENVECTOR CORRESPONDING TO THE J-TH EIGENVALUE IS */ /* SPECIFIED BY SETTING SELECT(J) TO .TRUE.. */ /* MM SHOULD BE SET TO AN UPPER BOUND FOR THE NUMBER OF */ /* EIGENVECTORS TO BE FOUND. */ /* ON OUTPUT */ /* AR, AI, WI, AND SELECT ARE UNALTERED. */ /* WR MAY HAVE BEEN ALTERED SINCE CLOSE EIGENVALUES ARE PERTURBED */ /* SLIGHTLY IN SEARCHING FOR INDEPENDENT EIGENVECTORS. */ /* M IS THE NUMBER OF EIGENVECTORS ACTUALLY FOUND. */ /* ZR AND ZI CONTAIN THE REAL AND IMAGINARY PARTS, RESPECTIVELY, */ /* OF THE EIGENVECTORS. THE EIGENVECTORS ARE NORMALIZED */ /* SO THAT THE COMPONENT OF LARGEST MAGNITUDE IS 1. */ /* ANY VECTOR WHICH FAILS THE ACCEPTANCE TEST IS SET TO ZERO. */ /* IERR IS SET TO */ /* ZERO FOR NORMAL RETURN, */ /* -(2*N+1) IF MORE THAN MM EIGENVECTORS HAVE BEEN SPECIFIED, */ /* -K IF THE ITERATION CORRESPONDING TO THE K-TH */ /* VALUE FAILS, */ /* -(N+K) IF BOTH ERROR SITUATIONS OCCUR. */ /* RM1, RM2, RV1, AND RV2 ARE TEMPORARY STORAGE ARRAYS. */ /* THE ALGOL PROCEDURE GUESSVEC APPEARS IN CINVIT IN LINE. */ /* CALLS CDIV FOR COMPLEX DIVISION. */ /* 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 */ --rv2; --rv1; rm2_dim1 = *n; rm2_offset = rm2_dim1 + 1; rm2 -= rm2_offset; rm1_dim1 = *n; rm1_offset = rm1_dim1 + 1; rm1 -= rm1_offset; --select; --wi; --wr; ai_dim1 = *nm; ai_offset = ai_dim1 + 1; ai -= ai_offset; ar_dim1 = *nm; ar_offset = ar_dim1 + 1; ar -= ar_offset; zi_dim1 = *nm; zi_offset = zi_dim1 + 1; zi -= zi_offset; zr_dim1 = *nm; zr_offset = zr_dim1 + 1; zr -= zr_offset; /* Function Body */ *ierr = 0; uk = 0; s = 1; i_1 = *n; for (k = 1; k <= i_1; ++k) { if (! select[k]) { goto L980; } if (s > *mm) { goto L1000; } if (uk >= k) { goto L200; } /* .......... CHECK FOR POSSIBLE SPLITTING .......... */ i_2 = *n; for (uk = k; uk <= i_2; ++uk) { if (uk == *n) { goto L140; } if (ar[uk + 1 + uk * ar_dim1] == 0. && ai[uk + 1 + uk * ai_dim1] == 0.) { goto L140; } /* L120: */ } /* .......... COMPUTE INFINITY NORM OF LEADING UK BY UK */ /* (HESSENBERG) MATRIX .......... */ L140: norm = 0.; mp = 1; i_2 = uk; for (i = 1; i <= i_2; ++i) { x = 0.; i_3 = uk; for (j = mp; j <= i_3; ++j) { /* L160: */ x += pythag_(&ar[i + j * ar_dim1], &ai[i + j * ai_dim1]); } if (x > norm) { norm = x; } mp = i; /* L180: */ } /* .......... EPS3 REPLACES ZERO PIVOT IN DECOMPOSITION */ /* AND CLOSE ROOTS ARE MODIFIED BY EPS3 .......... */ if (norm == 0.) { norm = 1.; } eps3 = epslon_(&norm); /* .......... GROWTO IS THE CRITERION FOR GROWTH .......... */ ukroot = (doublereal) uk; ukroot = sqrt(ukroot); growto = .1 / ukroot; L200: rlambd = wr[k]; ilambd = wi[k]; if (k == 1) { goto L280; } km1 = k - 1; goto L240; /* .......... PERTURB EIGENVALUE IF IT IS CLOSE */ /* TO ANY PREVIOUS EIGENVALUE .......... */ L220: rlambd += eps3; /* .......... FOR I=K-1 STEP -1 UNTIL 1 DO -- .......... */ L240: i_2 = km1; for (ii = 1; ii <= i_2; ++ii) { i = k - ii; if (select[i] && (d_1 = wr[i] - rlambd, abs(d_1)) < eps3 && ( d_2 = wi[i] - ilambd, abs(d_2)) < eps3) { goto L220; } /* L260: */ } wr[k] = rlambd; /* .......... FORM UPPER HESSENBERG (AR,AI)-(RLAMBD,ILAMBD)*I */ /* AND INITIAL COMPLEX VECTOR .......... */ L280: mp = 1; i_2 = uk; for (i = 1; i <= i_2; ++i) { i_3 = uk; for (j = mp; j <= i_3; ++j) { rm1[i + j * rm1_dim1] = ar[i + j * ar_dim1]; rm2[i + j * rm2_dim1] = ai[i + j * ai_dim1]; /* L300: */ } rm1[i + i * rm1_dim1] -= rlambd; rm2[i + i * rm2_dim1] -= ilambd; mp = i; rv1[i] = eps3; /* L320: */ } /* .......... TRIANGULAR DECOMPOSITION WITH INTERCHANGES, */ /* REPLACING ZERO PIVOTS BY EPS3 .......... */ if (uk == 1) { goto L420; } i_2 = uk; for (i = 2; i <= i_2; ++i) { mp = i - 1; if (pythag_(&rm1[i + mp * rm1_dim1], &rm2[i + mp * rm2_dim1]) <= pythag_(&rm1[mp + mp * rm1_dim1], &rm2[mp + mp * rm2_dim1] )) { goto L360; } i_3 = uk; for (j = mp; j <= i_3; ++j) { y = rm1[i + j * rm1_dim1]; rm1[i + j * rm1_dim1] = rm1[mp + j * rm1_dim1]; rm1[mp + j * rm1_dim1] = y; y = rm2[i + j * rm2_dim1]; rm2[i + j * rm2_dim1] = rm2[mp + j * rm2_dim1]; rm2[mp + j * rm2_dim1] = y; /* L340: */ } L360: if (rm1[mp + mp * rm1_dim1] == 0. && rm2[mp + mp * rm2_dim1] == 0.) { rm1[mp + mp * rm1_dim1] = eps3; } cdiv_(&rm1[i + mp * rm1_dim1], &rm2[i + mp * rm2_dim1], &rm1[mp + mp * rm1_dim1], &rm2[mp + mp * rm2_dim1], &x, &y); if (x == 0. && y == 0.) { goto L400; } i_3 = uk; for (j = i; j <= i_3; ++j) { rm1[i + j * rm1_dim1] = rm1[i + j * rm1_dim1] - x * rm1[mp + j * rm1_dim1] + y * rm2[mp + j * rm2_dim1]; rm2[i + j * rm2_dim1] = rm2[i + j * rm2_dim1] - x * rm2[mp + j * rm2_dim1] - y * rm1[mp + j * rm1_dim1]; /* L380: */ } L400: ; } L420: if (rm1[uk + uk * rm1_dim1] == 0. && rm2[uk + uk * rm2_dim1] == 0.) { rm1[uk + uk * rm1_dim1] = eps3; } its = 0; /* .......... BACK SUBSTITUTION */ /* FOR I=UK STEP -1 UNTIL 1 DO -- .......... */ L660: i_2 = uk; for (ii = 1; ii <= i_2; ++ii) { i = uk + 1 - ii; x = rv1[i]; y = 0.; if (i == uk) { goto L700; } ip1 = i + 1; i_3 = uk; for (j = ip1; j <= i_3; ++j) { x = x - rm1[i + j * rm1_dim1] * rv1[j] + rm2[i + j * rm2_dim1] * rv2[j]; y = y - rm1[i + j * rm1_dim1] * rv2[j] - rm2[i + j * rm2_dim1] * rv1[j]; /* L680: */ } L700: cdiv_(&x, &y, &rm1[i + i * rm1_dim1], &rm2[i + i * rm2_dim1], & rv1[i], &rv2[i]); /* L720: */ } /* .......... ACCEPTANCE TEST FOR EIGENVECTOR */ /* AND NORMALIZATION .......... */ ++its; norm = 0.; normv = 0.; i_2 = uk; for (i = 1; i <= i_2; ++i) { x = pythag_(&rv1[i], &rv2[i]); if (normv >= x) { goto L760; } normv = x; j = i; L760: norm += x; /* L780: */ } if (norm < growto) { goto L840; } /* .......... ACCEPT VECTOR .......... */ x = rv1[j]; y = rv2[j]; i_2 = uk; for (i = 1; i <= i_2; ++i) { cdiv_(&rv1[i], &rv2[i], &x, &y, &zr[i + s * zr_dim1], &zi[i + s * zi_dim1]); /* L820: */ } if (uk == *n) { goto L940; } j = uk + 1; goto L900; /* .......... IN-LINE PROCEDURE FOR CHOOSING */ /* A NEW STARTING VECTOR .......... */ L840: if (its >= uk) { goto L880; } x = ukroot; y = eps3 / (x + 1.); rv1[1] = eps3; i_2 = uk; for (i = 2; i <= i_2; ++i) { /* L860: */ rv1[i] = y; } j = uk - its + 1; rv1[j] -= eps3 * x; goto L660; /* .......... SET ERROR -- UNACCEPTED EIGENVECTOR .......... */ L880: j = 1; *ierr = -k; /* .......... SET REMAINING VECTOR COMPONENTS TO ZERO .......... */ L900: i_2 = *n; for (i = j; i <= i_2; ++i) { zr[i + s * zr_dim1] = 0.; zi[i + s * zi_dim1] = 0.; /* L920: */ } L940: ++s; L980: ; } goto L1001; /* .......... SET ERROR -- UNDERESTIMATE OF EIGENVECTOR */ /* SPACE REQUIRED .......... */ L1000: if (*ierr != 0) { *ierr -= *n; } if (*ierr == 0) { *ierr = -((*n << 1) + 1); } L1001: *m = s - 1; return 0; } /* cinvit_ */ /* Subroutine */ int combak_(integer *nm, integer *low, integer *igh, doublereal *ar, doublereal *ai, integer *int_, integer *m, doublereal *zr, doublereal *zi) { /* System generated locals */ integer ar_dim1, ar_offset, ai_dim1, ai_offset, zr_dim1, zr_offset, zi_dim1, zi_offset, i_1, i_2, i_3; /* Local variables */ static integer i, j, la, mm, mp; static doublereal xi, xr; static integer kp1, mp1; /* THIS SUBROUTINE IS A TRANSLATION OF THE ALGOL PROCEDURE COMBAK, */ /* NUM. MATH. 12, 349-368(1968) BY MARTIN AND WILKINSON. */ /* HANDBOOK FOR AUTO. COMP., VOL.II-LINEAR ALGEBRA, 339-358(1971). */ /* THIS SUBROUTINE FORMS THE EIGENVECTORS OF A COMPLEX GENERAL */ /* MATRIX BY BACK TRANSFORMING THOSE OF THE CORRESPONDING */ /* UPPER HESSENBERG MATRIX DETERMINED BY COMHES. */ /* ON INPUT */ /* NM MUST BE SET TO THE ROW DIMENSION OF TWO-DIMENSIONAL */ /* ARRAY PARAMETERS AS DECLARED IN THE CALLING PROGRAM */ /* DIMENSION STATEMENT. */ /* LOW AND IGH ARE INTEGERS DETERMINED BY THE BALANCING */ /* SUBROUTINE CBAL. IF CBAL HAS NOT BEEN USED, */ /* SET LOW=1 AND IGH EQUAL TO THE ORDER OF THE MATRIX. */ /* AR AND AI CONTAIN THE MULTIPLIERS WHICH WERE USED IN THE */ /* REDUCTION BY COMHES IN THEIR LOWER TRIANGLES */ /* BELOW THE SUBDIAGONAL. */ /* INT CONTAINS INFORMATION ON THE ROWS AND COLUMNS */ /* INTERCHANGED IN THE REDUCTION BY COMHES. */ /* ONLY ELEMENTS LOW THROUGH IGH ARE USED. */ /* M IS THE NUMBER OF EIGENVECTORS TO BE BACK TRANSFORMED. */ /* ZR AND ZI CONTAIN THE REAL AND IMAGINARY PARTS, */ /* RESPECTIVELY, OF THE EIGENVECTORS TO BE */ /* BACK TRANSFORMED IN THEIR FIRST M COLUMNS. */ /* ON OUTPUT */ /* ZR AND ZI CONTAIN THE REAL AND IMAGINARY PARTS, */ /* RESPECTIVELY, OF THE TRANSFORMED EIGENVECTORS */ /* IN THEIR FIRST M COLUMNS. */ /* 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 */ --int_; ai_dim1 = *nm; ai_offset = ai_dim1 + 1; ai -= ai_offset; ar_dim1 = *nm; ar_offset = ar_dim1 + 1; ar -= ar_offset; zi_dim1 = *nm; zi_offset = zi_dim1 + 1; zi -= zi_offset; zr_dim1 = *nm; zr_offset = zr_dim1 + 1; zr -= zr_offset; /* Function Body */ if (*m == 0) { goto L200; } la = *igh - 1; kp1 = *low + 1; if (la < kp1) { goto L200; } /* .......... FOR MP=IGH-1 STEP -1 UNTIL LOW+1 DO -- .......... */ i_1 = la; for (mm = kp1; mm <= i_1; ++mm) { mp = *low + *igh - mm; mp1 = mp + 1; i_2 = *igh; for (i = mp1; i <= i_2; ++i) { xr = ar[i + (mp - 1) * ar_dim1]; xi = ai[i + (mp - 1) * ai_dim1]; if (xr == 0. && xi == 0.) { goto L110; } i_3 = *m; for (j = 1; j <= i_3; ++j) { zr[i + j * zr_dim1] = zr[i + j * zr_dim1] + xr * zr[mp + j * zr_dim1] - xi * zi[mp + j * zi_dim1]; zi[i + j * zi_dim1] = zi[i + j * zi_dim1] + xr * zi[mp + j * zi_dim1] + xi * zr[mp + j * zr_dim1]; /* L100: */ } L110: ; } i = int_[mp]; if (i == mp) { goto L140; } i_2 = *m; for (j = 1; j <= i_2; ++j) { xr = zr[i + j * zr_dim1]; zr[i + j * zr_dim1] = zr[mp + j * zr_dim1]; zr[mp + j * zr_dim1] = xr; xi = zi[i + j * zi_dim1]; zi[i + j * zi_dim1] = zi[mp + j * zi_dim1]; zi[mp + j * zi_dim1] = xi; /* L130: */ } L140: ; } L200: return 0; } /* combak_ */ /* Subroutine */ int comhes_(integer *nm, integer *n, integer *low, integer * igh, doublereal *ar, doublereal *ai, integer *int_) { /* System generated locals */ integer ar_dim1, ar_offset, ai_dim1, ai_offset, i_1, i_2, i_3; doublereal d_1, d_2; /* Local variables */ extern /* Subroutine */ int cdiv_(doublereal *, doublereal *, doublereal * , doublereal *, doublereal *, doublereal *); static integer i, j, m, la; static doublereal xi, yi, xr, yr; static integer mm1, kp1, mp1; /* THIS SUBROUTINE IS A TRANSLATION OF THE ALGOL PROCEDURE COMHES, */ /* NUM. MATH. 12, 349-368(1968) BY MARTIN AND WILKINSON. */ /* HANDBOOK FOR AUTO. COMP., VOL.II-LINEAR ALGEBRA, 339-358(1971). */ /* GIVEN A COMPLEX GENERAL MATRIX, THIS SUBROUTINE */ /* REDUCES A SUBMATRIX SITUATED IN ROWS AND COLUMNS */ /* LOW THROUGH IGH TO UPPER HESSENBERG FORM BY */ /* STABILIZED ELEMENTARY SIMILARITY TRANSFORMATIONS. */ /* ON INPUT */ /* NM MUST BE SET TO THE ROW DIMENSION OF TWO-DIMENSIONAL */ /* ARRAY PARAMETERS AS DECLARED IN THE CALLING PROGRAM */ /* DIMENSION STATEMENT. */ /* N IS THE ORDER OF THE MATRIX. */ /* LOW AND IGH ARE INTEGERS DETERMINED BY THE BALANCING */ /* SUBROUTINE CBAL. IF CBAL HAS NOT BEEN USED, */ /* SET LOW=1, IGH=N. */ /* AR AND AI CONTAIN THE REAL AND IMAGINARY PARTS, */ /* RESPECTIVELY, OF THE COMPLEX INPUT MATRIX. */ /* ON OUTPUT */ /* AR AND AI CONTAIN THE REAL AND IMAGINARY PARTS, */ /* RESPECTIVELY, OF THE HESSENBERG MATRIX. THE */ /* MULTIPLIERS WHICH WERE USED IN THE REDUCTION */ /* ARE STORED IN THE REMAINING TRIANGLES UNDER THE */ /* HESSENBERG MATRIX. */ /* INT CONTAINS INFORMATION ON THE ROWS AND COLUMNS */ /* INTERCHANGED IN THE REDUCTION. */ /* ONLY ELEMENTS LOW THROUGH IGH ARE USED. */ /* CALLS CDIV FOR COMPLEX DIVISION. */ /* 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 */ ai_dim1 = *nm; ai_offset = ai_dim1 + 1; ai -= ai_offset; ar_dim1 = *nm; ar_offset = ar_dim1 + 1; ar -= ar_offset; --int_; /* Function Body */ la = *igh - 1; kp1 = *low + 1; if (la < kp1) { goto L200; } i_1 = la; for (m = kp1; m <= i_1; ++m) { mm1 = m - 1; xr = 0.; xi = 0.; i = m; i_2 = *igh; for (j = m; j <= i_2; ++j) { if ((d_1 = ar[j + mm1 * ar_dim1], abs(d_1)) + (d_2 = ai[j + mm1 * ai_dim1], abs(d_2)) <= abs(xr) + abs(xi)) { goto L100; } xr = ar[j + mm1 * ar_dim1]; xi = ai[j + mm1 * ai_dim1]; i = j; L100: ; } int_[m] = i; if (i == m) { goto L130; } /* .......... INTERCHANGE ROWS AND COLUMNS OF AR AND AI .......... */ i_2 = *n; for (j = mm1; j <= i_2; ++j) { yr = ar[i + j * ar_dim1]; ar[i + j * ar_dim1] = ar[m + j * ar_dim1]; ar[m + j * ar_dim1] = yr; yi = ai[i + j * ai_dim1]; ai[i + j * ai_dim1] = ai[m + j * ai_dim1]; ai[m + j * ai_dim1] = yi; /* L110: */ } i_2 = *igh; for (j = 1; j <= i_2; ++j) { yr = ar[j + i * ar_dim1]; ar[j + i * ar_dim1] = ar[j + m * ar_dim1]; ar[j + m * ar_dim1] = yr; yi = ai[j + i * ai_dim1]; ai[j + i * ai_dim1] = ai[j + m * ai_dim1]; ai[j + m * ai_dim1] = yi; /* L120: */ } /* .......... END INTERCHANGE .......... */ L130: if (xr == 0. && xi == 0.) { goto L180; } mp1 = m + 1; i_2 = *igh; for (i = mp1; i <= i_2; ++i) { yr = ar[i + mm1 * ar_dim1]; yi = ai[i + mm1 * ai_dim1]; if (yr == 0. && yi == 0.) { goto L160; } cdiv_(&yr, &yi, &xr, &xi, &yr, &yi); ar[i + mm1 * ar_dim1] = yr; ai[i + mm1 * ai_dim1] = yi; i_3 = *n; for (j = m; j <= i_3; ++j) { ar[i + j * ar_dim1] = ar[i + j * ar_dim1] - yr * ar[m + j * ar_dim1] + yi * ai[m + j * ai_dim1]; ai[i + j * ai_dim1] = ai[i + j * ai_dim1] - yr * ai[m + j * ai_dim1] - yi * ar[m + j * ar_dim1]; /* L140: */ } i_3 = *igh; for (j = 1; j <= i_3; ++j) { ar[j + m * ar_dim1] = ar[j + m * ar_dim1] + yr * ar[j + i * ar_dim1] - yi * ai[j + i * ai_dim1]; ai[j + m * ai_dim1] = ai[j + m * ai_dim1] + yr * ai[j + i * ai_dim1] + yi * ar[j + i * ar_dim1]; /* L150: */ } L160: ; } L180: ; } L200: return 0; } /* comhes_ */ /* Subroutine */ int comlr_(integer *nm, integer *n, integer *low, integer * igh, doublereal *hr, doublereal *hi, doublereal *wr, doublereal *wi, integer *ierr) { /* System generated locals */ integer hr_dim1, hr_offset, hi_dim1, hi_offset, i_1, i_2; doublereal d_1, d_2, d_3, d_4; /* Local variables */ extern /* Subroutine */ int cdiv_(doublereal *, doublereal *, doublereal * , doublereal *, doublereal *, doublereal *); static integer i, j, l, m, en, ll, mm; static doublereal si, ti, xi, yi, sr, tr, xr, yr; static integer im1; extern /* Subroutine */ int csroot_(doublereal *, doublereal *, doublereal *, doublereal *); static integer mp1, itn, its; static doublereal zzi, zzr; static integer enm1; static doublereal tst1, tst2; /* THIS SUBROUTINE IS A TRANSLATION OF THE ALGOL PROCEDURE COMLR, */ /* NUM. MATH. 12, 369-376(1968) BY MARTIN AND WILKINSON. */ /* HANDBOOK FOR AUTO. COMP., VOL.II-LINEAR ALGEBRA, 396-403(1971). */ /* THIS SUBROUTINE FINDS THE EIGENVALUES OF A COMPLEX */ /* UPPER HESSENBERG MATRIX BY THE MODIFIED LR METHOD. */ /* ON INPUT */ /* NM MUST BE SET TO THE ROW DIMENSION OF TWO-DIMENSIONAL */ /* ARRAY PARAMETERS AS DECLARED IN THE CALLING PROGRAM */ /* DIMENSION STATEMENT. */ /* N IS THE ORDER OF THE MATRIX. */ /* LOW AND IGH ARE INTEGERS DETERMINED BY THE BALANCING */ /* SUBROUTINE CBAL. IF CBAL HAS NOT BEEN USED, */ /* SET LOW=1, IGH=N. */ /* HR AND HI CONTAIN THE REAL AND IMAGINARY PARTS, */ /* RESPECTIVELY, OF THE COMPLEX UPPER HESSENBERG MATRIX. */ /* THEIR LOWER TRIANGLES BELOW THE SUBDIAGONAL CONTAIN THE */ /* MULTIPLIERS WHICH WERE USED IN THE REDUCTION BY COMHES, */ /* IF PERFORMED. */ /* ON OUTPUT */ /* THE UPPER HESSENBERG PORTIONS OF HR AND HI HAVE BEEN */ /* DESTROYED. THEREFORE, THEY MUST BE SAVED BEFORE */ /* CALLING COMLR IF SUBSEQUENT CALCULATION OF */ /* EIGENVECTORS IS TO BE PERFORMED. */ /* WR AND WI CONTAIN THE REAL AND IMAGINARY PARTS, */ /* RESPECTIVELY, OF THE EIGENVALUES. IF AN ERROR */ /* EXIT IS MADE, THE EIGENVALUES SHOULD BE CORRECT */ /* FOR INDICES IERR+1,...,N. */ /* IERR IS SET TO */ /* ZERO FOR NORMAL RETURN, */ /* J IF THE LIMIT OF 30*N ITERATIONS IS EXHAUSTED */ /* WHILE THE J-TH EIGENVALUE IS BEING SOUGHT. */ /* CALLS CDIV FOR COMPLEX DIVISION. */ /* CALLS CSROOT FOR COMPLEX SQUARE ROOT. */ /* 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 */ --wi; --wr; hi_dim1 = *nm; hi_offset = hi_dim1 + 1; hi -= hi_offset; hr_dim1 = *nm; hr_offset = hr_dim1 + 1; hr -= hr_offset; /* Function Body */ *ierr = 0; /* .......... STORE ROOTS ISOLATED BY CBAL .......... */ i_1 = *n; for (i = 1; i <= i_1; ++i) { if (i >= *low && i <= *igh) { goto L200; } wr[i] = hr[i + i * hr_dim1]; wi[i] = hi[i + i * hi_dim1]; L200: ; } en = *igh; tr = 0.; ti = 0.; itn = *n * 30; /* .......... SEARCH FOR NEXT EIGENVALUE .......... */ L220: if (en < *low) { goto L1001; } its = 0; enm1 = en - 1; /* .......... LOOK FOR SINGLE SMALL SUB-DIAGONAL ELEMENT */ /* FOR L=EN STEP -1 UNTIL LOW D0 -- .......... */ L240: i_1 = en; for (ll = *low; ll <= i_1; ++ll) { l = en + *low - ll; if (l == *low) { goto L300; } tst1 = (d_1 = hr[l - 1 + (l - 1) * hr_dim1], abs(d_1)) + (d_2 = hi[ l - 1 + (l - 1) * hi_dim1], abs(d_2)) + (d_3 = hr[l + l * hr_dim1], abs(d_3)) + (d_4 = hi[l + l * hi_dim1], abs(d_4)) ; tst2 = tst1 + (d_1 = hr[l + (l - 1) * hr_dim1], abs(d_1)) + (d_2 = hi[l + (l - 1) * hi_dim1], abs(d_2)); if (tst2 == tst1) { goto L300; } /* L260: */ } /* .......... FORM SHIFT .......... */ L300: if (l == en) { goto L660; } if (itn == 0) { goto L1000; } if (its == 10 || its == 20) { goto L320; } sr = hr[en + en * hr_dim1]; si = hi[en + en * hi_dim1]; xr = hr[enm1 + en * hr_dim1] * hr[en + enm1 * hr_dim1] - hi[enm1 + en * hi_dim1] * hi[en + enm1 * hi_dim1]; xi = hr[enm1 + en * hr_dim1] * hi[en + enm1 * hi_dim1] + hi[enm1 + en * hi_dim1] * hr[en + enm1 * hr_dim1]; if (xr == 0. && xi == 0.) { goto L340; } yr = (hr[enm1 + enm1 * hr_dim1] - sr) / 2.; yi = (hi[enm1 + enm1 * hi_dim1] - si) / 2.; /* Computing 2nd power */ d_2 = yr; /* Computing 2nd power */ d_3 = yi; d_1 = d_2 * d_2 - d_3 * d_3 + xr; d_4 = yr * 2. * yi + xi; csroot_(&d_1, &d_4, &zzr, &zzi); if (yr * zzr + yi * zzi >= 0.) { goto L310; } zzr = -zzr; zzi = -zzi; L310: d_1 = yr + zzr; d_2 = yi + zzi; cdiv_(&xr, &xi, &d_1, &d_2, &xr, &xi); sr -= xr; si -= xi; goto L340; /* .......... FORM EXCEPTIONAL SHIFT .......... */ L320: sr = (d_1 = hr[en + enm1 * hr_dim1], abs(d_1)) + (d_2 = hr[enm1 + (en - 2) * hr_dim1], abs(d_2)); si = (d_1 = hi[en + enm1 * hi_dim1], abs(d_1)) + (d_2 = hi[enm1 + (en - 2) * hi_dim1], abs(d_2)); L340: i_1 = en; for (i = *low; i <= i_1; ++i) { hr[i + i * hr_dim1] -= sr; hi[i + i * hi_dim1] -= si; /* L360: */ } tr += sr; ti += si; ++its; --itn; /* .......... LOOK FOR TWO CONSECUTIVE SMALL */ /* SUB-DIAGONAL ELEMENTS .......... */ xr = (d_1 = hr[enm1 + enm1 * hr_dim1], abs(d_1)) + (d_2 = hi[enm1 + enm1 * hi_dim1], abs(d_2)); yr = (d_1 = hr[en + enm1 * hr_dim1], abs(d_1)) + (d_2 = hi[en + enm1 * hi_dim1], abs(d_2)); zzr = (d_1 = hr[en + en * hr_dim1], abs(d_1)) + (d_2 = hi[en + en * hi_dim1], abs(d_2)); /* .......... FOR M=EN-1 STEP -1 UNTIL L DO -- .......... */ i_1 = enm1; for (mm = l; mm <= i_1; ++mm) { m = enm1 + l - mm; if (m == l) { goto L420; } yi = yr; yr = (d_1 = hr[m + (m - 1) * hr_dim1], abs(d_1)) + (d_2 = hi[m + ( m - 1) * hi_dim1], abs(d_2)); xi = zzr; zzr = xr; xr = (d_1 = hr[m - 1 + (m - 1) * hr_dim1], abs(d_1)) + (d_2 = hi[m - 1 + (m - 1) * hi_dim1], abs(d_2)); tst1 = zzr / yi * (zzr + xr + xi); tst2 = tst1 + yr; if (tst2 == tst1) { goto L420; } /* L380: */ } /* .......... TRIANGULAR DECOMPOSITION H=L*R .......... */ L420: mp1 = m + 1; i_1 = en; for (i = mp1; i <= i_1; ++i) { im1 = i - 1; xr = hr[im1 + im1 * hr_dim1]; xi = hi[im1 + im1 * hi_dim1]; yr = hr[i + im1 * hr_dim1]; yi = hi[i + im1 * hi_dim1]; if (abs(xr) + abs(xi) >= abs(yr) + abs(yi)) { goto L460; } /* .......... INTERCHANGE ROWS OF HR AND HI .......... */ i_2 = en; for (j = im1; j <= i_2; ++j) { zzr = hr[im1 + j * hr_dim1]; hr[im1 + j * hr_dim1] = hr[i + j * hr_dim1]; hr[i + j * hr_dim1] = zzr; zzi = hi[im1 + j * hi_dim1]; hi[im1 + j * hi_dim1] = hi[i + j * hi_dim1]; hi[i + j * hi_dim1] = zzi; /* L440: */ } cdiv_(&xr, &xi, &yr, &yi, &zzr, &zzi); wr[i] = 1.; goto L480; L460: cdiv_(&yr, &yi, &xr, &xi, &zzr, &zzi); wr[i] = -1.; L480: hr[i + im1 * hr_dim1] = zzr; hi[i + im1 * hi_dim1] = zzi; i_2 = en; for (j = i; j <= i_2; ++j) { hr[i + j * hr_dim1] = hr[i + j * hr_dim1] - zzr * hr[im1 + j * hr_dim1] + zzi * hi[im1 + j * hi_dim1]; hi[i + j * hi_dim1] = hi[i + j * hi_dim1] - zzr * hi[im1 + j * hi_dim1] - zzi * hr[im1 + j * hr_dim1]; /* L500: */ } /* L520: */ } /* .......... COMPOSITION R*L=H .......... */ i_1 = en; for (j = mp1; j <= i_1; ++j) { xr = hr[j + (j - 1) * hr_dim1]; xi = hi[j + (j - 1) * hi_dim1]; hr[j + (j - 1) * hr_dim1] = 0.; hi[j + (j - 1) * hi_dim1] = 0.; /* .......... INTERCHANGE COLUMNS OF HR AND HI, */ /* IF NECESSARY .......... */ if (wr[j] <= 0.) { goto L580; } i_2 = j; for (i = l; i <= i_2; ++i) { zzr = hr[i + (j - 1) * hr_dim1]; hr[i + (j - 1) * hr_dim1] = hr[i + j * hr_dim1]; hr[i + j * hr_dim1] = zzr; zzi = hi[i + (j - 1) * hi_dim1]; hi[i + (j - 1) * hi_dim1] = hi[i + j * hi_dim1]; hi[i + j * hi_dim1] = zzi; /* L540: */ } L580: i_2 = j; for (i = l; i <= i_2; ++i) { hr[i + (j - 1) * hr_dim1] = hr[i + (j - 1) * hr_dim1] + xr * hr[i + j * hr_dim1] - xi * hi[i + j * hi_dim1]; hi[i + (j - 1) * hi_dim1] = hi[i + (j - 1) * hi_dim1] + xr * hi[i + j * hi_dim1] + xi * hr[i + j * hr_dim1]; /* L600: */ } /* L640: */ } goto L240; /* .......... A ROOT FOUND .......... */ L660: wr[en] = hr[en + en * hr_dim1] + tr; wi[en] = hi[en + en * hi_dim1] + ti; en = enm1; goto L220; /* .......... SET ERROR -- ALL EIGENVALUES HAVE NOT */ /* CONVERGED AFTER 30*N ITERATIONS .......... */ L1000: *ierr = en; L1001: return 0; } /* comlr_ */ /* Subroutine */ int comlr2_(integer *nm, integer *n, integer *low, integer * igh, integer *int_, doublereal *hr, doublereal *hi, doublereal *wr, doublereal *wi, doublereal *zr, doublereal *zi, integer *ierr) { /* System generated locals */ integer hr_dim1, hr_offset, hi_dim1, hi_offset, zr_dim1, zr_offset, zi_dim1, zi_offset, i_1, i_2, i_3; doublereal d_1, d_2, d_3, d_4; /* Local variables */ static integer iend; extern /* Subroutine */ int cdiv_(doublereal *, doublereal *, doublereal * , doublereal *, doublereal *, doublereal *); static doublereal norm; static integer i, j, k, l, m, ii, en, jj, ll, mm, nn; static doublereal si, ti, xi, yi, sr, tr, xr, yr; static integer im1; extern /* Subroutine */ int csroot_(doublereal *, doublereal *, doublereal *, doublereal *); static integer ip1, mp1, itn, its; static doublereal zzi, zzr; static integer enm1; static doublereal tst1, tst2; /* THIS SUBROUTINE IS A TRANSLATION OF THE ALGOL PROCEDURE COMLR2, */ /* NUM. MATH. 16, 181-204(1970) BY PETERS AND WILKINSON. */ /* HANDBOOK FOR AUTO. COMP., VOL.II-LINEAR ALGEBRA, 372-395(1971). */ /* THIS SUBROUTINE FINDS THE EIGENVALUES AND EIGENVECTORS */ /* OF A COMPLEX UPPER HESSENBERG MATRIX BY THE MODIFIED LR */ /* METHOD. THE EIGENVECTORS OF A COMPLEX GENERAL MATRIX */ /* CAN ALSO BE FOUND IF COMHES HAS BEEN USED TO REDUCE */ /* THIS GENERAL MATRIX TO HESSENBERG FORM. */ /* ON INPUT */ /* NM MUST BE SET TO THE ROW DIMENSION OF TWO-DIMENSIONAL */ /* ARRAY PARAMETERS AS DECLARED IN THE CALLING PROGRAM */ /* DIMENSION STATEMENT. */ /* N IS THE ORDER OF THE MATRIX. */ /* LOW AND IGH ARE INTEGERS DETERMINED BY THE BALANCING */ /* SUBROUTINE CBAL. IF CBAL HAS NOT BEEN USED, */ /* SET LOW=1, IGH=N. */ /* INT CONTAINS INFORMATION ON THE ROWS AND COLUMNS INTERCHANGED */ /* IN THE REDUCTION BY COMHES, IF PERFORMED. ONLY ELEMENTS */ /* LOW THROUGH IGH ARE USED. IF THE EIGENVECTORS OF THE HESSEN- */ /* BERG MATRIX ARE DESIRED, SET INT(J)=J FOR THESE ELEMENTS. */ /* HR AND HI CONTAIN THE REAL AND IMAGINARY PARTS, */ /* RESPECTIVELY, OF THE COMPLEX UPPER HESSENBERG MATRIX. */ /* THEIR LOWER TRIANGLES BELOW THE SUBDIAGONAL CONTAIN THE */ /* MULTIPLIERS WHICH WERE USED IN THE REDUCTION BY COMHES, */ /* IF PERFORMED. IF THE EIGENVECTORS OF THE HESSENBERG */ /* MATRIX ARE DESIRED, THESE ELEMENTS MUST BE SET TO ZERO. */ /* ON OUTPUT */ /* THE UPPER HESSENBERG PORTIONS OF HR AND HI HAVE BEEN */ /* DESTROYED, BUT THE LOCATION HR(1,1) CONTAINS THE NORM */ /* OF THE TRIANGULARIZED MATRIX. */ /* WR AND WI CONTAIN THE REAL AND IMAGINARY PARTS, */ /* RESPECTIVELY, OF THE EIGENVALUES. IF AN ERROR */ /* EXIT IS MADE, THE EIGENVALUES SHOULD BE CORRECT */ /* FOR INDICES IERR+1,...,N. */ /* ZR AND ZI CONTAIN THE REAL AND IMAGINARY PARTS, */ /* RESPECTIVELY, OF THE EIGENVECTORS. THE EIGENVECTORS */ /* ARE UNNORMALIZED. IF AN ERROR EXIT IS MADE, NONE OF */ /* THE EIGENVECTORS HAS BEEN FOUND. */ /* IERR IS SET TO */ /* ZERO FOR NORMAL RETURN, */ /* J IF THE LIMIT OF 30*N ITERATIONS IS EXHAUSTED */ /* WHILE THE J-TH EIGENVALUE IS BEING SOUGHT. */ /* CALLS CDIV FOR COMPLEX DIVISION. */ /* CALLS CSROOT FOR COMPLEX SQUARE ROOT. */ /* 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 */ zi_dim1 = *nm; zi_offset = zi_dim1 + 1; zi -= zi_offset; zr_dim1 = *nm; zr_offset = zr_dim1 + 1; zr -= zr_offset; --wi; --wr; hi_dim1 = *nm; hi_offset = hi_dim1 + 1; hi -= hi_offset; hr_dim1 = *nm; hr_offset = hr_dim1 + 1; hr -= hr_offset; --int_; /* Function Body */ *ierr = 0; /* .......... INITIALIZE EIGENVECTOR MATRIX .......... */ i_1 = *n; for (i = 1; i <= i_1; ++i) { i_2 = *n; for (j = 1; j <= i_2; ++j) { zr[i + j * zr_dim1] = 0.; zi[i + j * zi_dim1] = 0.; if (i == j) { zr[i + j * zr_dim1] = 1.; } /* L100: */ } } /* .......... FORM THE MATRIX OF ACCUMULATED TRANSFORMATIONS */ /* FROM THE INFORMATION LEFT BY COMHES .......... */ iend = *igh - *low - 1; if (iend <= 0) { goto L180; } /* .......... FOR I=IGH-1 STEP -1 UNTIL LOW+1 DO -- .......... */ i_2 = iend; for (ii = 1; ii <= i_2; ++ii) { i = *igh - ii; ip1 = i + 1; i_1 = *igh; for (k = ip1; k <= i_1; ++k) { zr[k + i * zr_dim1] = hr[k + (i - 1) * hr_dim1]; zi[k + i * zi_dim1] = hi[k + (i - 1) * hi_dim1]; /* L120: */ } j = int_[i]; if (i == j) { goto L160; } i_1 = *igh; for (k = i; k <= i_1; ++k) { zr[i + k * zr_dim1] = zr[j + k * zr_dim1]; zi[i + k * zi_dim1] = zi[j + k * zi_dim1]; zr[j + k * zr_dim1] = 0.; zi[j + k * zi_dim1] = 0.; /* L140: */ } zr[j + i * zr_dim1] = 1.; L160: ; } /* .......... STORE ROOTS ISOLATED BY CBAL .......... */ L180: i_2 = *n; for (i = 1; i <= i_2; ++i) { if (i >= *low && i <= *igh) { goto L200; } wr[i] = hr[i + i * hr_dim1]; wi[i] = hi[i + i * hi_dim1]; L200: ; } en = *igh; tr = 0.; ti = 0.; itn = *n * 30; /* .......... SEARCH FOR NEXT EIGENVALUE .......... */ L220: if (en < *low) { goto L680; } its = 0; enm1 = en - 1; /* .......... LOOK FOR SINGLE SMALL SUB-DIAGONAL ELEMENT */ /* FOR L=EN STEP -1 UNTIL LOW DO -- .......... */ L240: i_2 = en; for (ll = *low; ll <= i_2; ++ll) { l = en + *low - ll; if (l == *low) { goto L300; } tst1 = (d_1 = hr[l - 1 + (l - 1) * hr_dim1], abs(d_1)) + (d_2 = hi[ l - 1 + (l - 1) * hi_dim1], abs(d_2)) + (d_3 = hr[l + l * hr_dim1], abs(d_3)) + (d_4 = hi[l + l * hi_dim1], abs(d_4)) ; tst2 = tst1 + (d_1 = hr[l + (l - 1) * hr_dim1], abs(d_1)) + (d_2 = hi[l + (l - 1) * hi_dim1], abs(d_2)); if (tst2 == tst1) { goto L300; } /* L260: */ } /* .......... FORM SHIFT .......... */ L300: if (l == en) { goto L660; } if (itn == 0) { goto L1000; } if (its == 10 || its == 20) { goto L320; } sr = hr[en + en * hr_dim1]; si = hi[en + en * hi_dim1]; xr = hr[enm1 + en * hr_dim1] * hr[en + enm1 * hr_dim1] - hi[enm1 + en * hi_dim1] * hi[en + enm1 * hi_dim1]; xi = hr[enm1 + en * hr_dim1] * hi[en + enm1 * hi_dim1] + hi[enm1 + en * hi_dim1] * hr[en + enm1 * hr_dim1]; if (xr == 0. && xi == 0.) { goto L340; } yr = (hr[enm1 + enm1 * hr_dim1] - sr) / 2.; yi = (hi[enm1 + enm1 * hi_dim1] - si) / 2.; /* Computing 2nd power */ d_2 = yr; /* Computing 2nd power */ d_3 = yi; d_1 = d_2 * d_2 - d_3 * d_3 + xr; d_4 = yr * 2. * yi + xi; csroot_(&d_1, &d_4, &zzr, &zzi); if (yr * zzr + yi * zzi >= 0.) { goto L310; } zzr = -zzr; zzi = -zzi; L310: d_1 = yr + zzr; d_2 = yi + zzi; cdiv_(&xr, &xi, &d_1, &d_2, &xr, &xi); sr -= xr; si -= xi; goto L340; /* .......... FORM EXCEPTIONAL SHIFT .......... */ L320: sr = (d_1 = hr[en + enm1 * hr_dim1], abs(d_1)) + (d_2 = hr[enm1 + (en - 2) * hr_dim1], abs(d_2)); si = (d_1 = hi[en + enm1 * hi_dim1], abs(d_1)) + (d_2 = hi[enm1 + (en - 2) * hi_dim1], abs(d_2)); L340: i_2 = en; for (i = *low; i <= i_2; ++i) { hr[i + i * hr_dim1] -= sr; hi[i + i * hi_dim1] -= si; /* L360: */ } tr += sr; ti += si; ++its; --itn; /* .......... LOOK FOR TWO CONSECUTIVE SMALL */ /* SUB-DIAGONAL ELEMENTS .......... */ xr = (d_1 = hr[enm1 + enm1 * hr_dim1], abs(d_1)) + (d_2 = hi[enm1 + enm1 * hi_dim1], abs(d_2)); yr = (d_1 = hr[en + enm1 * hr_dim1], abs(d_1)) + (d_2 = hi[en + enm1 * hi_dim1], abs(d_2)); zzr = (d_1 = hr[en + en * hr_dim1], abs(d_1)) + (d_2 = hi[en + en * hi_dim1], abs(d_2)); /* .......... FOR M=EN-1 STEP -1 UNTIL L DO -- .......... */ i_2 = enm1; for (mm = l; mm <= i_2; ++mm) { m = enm1 + l - mm; if (m == l) { goto L420; } yi = yr; yr = (d_1 = hr[m + (m - 1) * hr_dim1], abs(d_1)) + (d_2 = hi[m + ( m - 1) * hi_dim1], abs(d_2)); xi = zzr; zzr = xr; xr = (d_1 = hr[m - 1 + (m - 1) * hr_dim1], abs(d_1)) + (d_2 = hi[m - 1 + (m - 1) * hi_dim1], abs(d_2)); tst1 = zzr / yi * (zzr + xr + xi); tst2 = tst1 + yr; if (tst2 == tst1) { goto L420; } /* L380: */ } /* .......... TRIANGULAR DECOMPOSITION H=L*R .......... */ L420: mp1 = m + 1; i_2 = en; for (i = mp1; i <= i_2; ++i) { im1 = i - 1; xr = hr[im1 + im1 * hr_dim1]; xi = hi[im1 + im1 * hi_dim1]; yr = hr[i + im1 * hr_dim1]; yi = hi[i + im1 * hi_dim1]; if (abs(xr) + abs(xi) >= abs(yr) + abs(yi)) { goto L460; } /* .......... INTERCHANGE ROWS OF HR AND HI .......... */ i_1 = *n; for (j = im1; j <= i_1; ++j) { zzr = hr[im1 + j * hr_dim1]; hr[im1 + j * hr_dim1] = hr[i + j * hr_dim1]; hr[i + j * hr_dim1] = zzr; zzi = hi[im1 + j * hi_dim1]; hi[im1 + j * hi_dim1] = hi[i + j * hi_dim1]; hi[i + j * hi_dim1] = zzi; /* L440: */ } cdiv_(&xr, &xi, &yr, &yi, &zzr, &zzi); wr[i] = 1.; goto L480; L460: cdiv_(&yr, &yi, &xr, &xi, &zzr, &zzi); wr[i] = -1.; L480: hr[i + im1 * hr_dim1] = zzr; hi[i + im1 * hi_dim1] = zzi; i_1 = *n; for (j = i; j <= i_1; ++j) { hr[i + j * hr_dim1] = hr[i + j * hr_dim1] - zzr * hr[im1 + j * hr_dim1] + zzi * hi[im1 + j * hi_dim1]; hi[i + j * hi_dim1] = hi[i + j * hi_dim1] - zzr * hi[im1 + j * hi_dim1] - zzi * hr[im1 + j * hr_dim1]; /* L500: */ } /* L520: */ } /* .......... COMPOSITION R*L=H .......... */ i_2 = en; for (j = mp1; j <= i_2; ++j) { xr = hr[j + (j - 1) * hr_dim1]; xi = hi[j + (j - 1) * hi_dim1]; hr[j + (j - 1) * hr_dim1] = 0.; hi[j + (j - 1) * hi_dim1] = 0.; /* .......... INTERCHANGE COLUMNS OF HR, HI, ZR, AND ZI, */ /* IF NECESSARY .......... */ if (wr[j] <= 0.) { goto L580; } i_1 = j; for (i = 1; i <= i_1; ++i) { zzr = hr[i + (j - 1) * hr_dim1]; hr[i + (j - 1) * hr_dim1] = hr[i + j * hr_dim1]; hr[i + j * hr_dim1] = zzr; zzi = hi[i + (j - 1) * hi_dim1]; hi[i + (j - 1) * hi_dim1] = hi[i + j * hi_dim1]; hi[i + j * hi_dim1] = zzi; /* L540: */ } i_1 = *igh; for (i = *low; i <= i_1; ++i) { zzr = zr[i + (j - 1) * zr_dim1]; zr[i + (j - 1) * zr_dim1] = zr[i + j * zr_dim1]; zr[i + j * zr_dim1] = zzr; zzi = zi[i + (j - 1) * zi_dim1]; zi[i + (j - 1) * zi_dim1] = zi[i + j * zi_dim1]; zi[i + j * zi_dim1] = zzi; /* L560: */ } L580: i_1 = j; for (i = 1; i <= i_1; ++i) { hr[i + (j - 1) * hr_dim1] = hr[i + (j - 1) * hr_dim1] + xr * hr[i + j * hr_dim1] - xi * hi[i + j * hi_dim1]; hi[i + (j - 1) * hi_dim1] = hi[i + (j - 1) * hi_dim1] + xr * hi[i + j * hi_dim1] + xi * hr[i + j * hr_dim1]; /* L600: */ } /* .......... ACCUMULATE TRANSFORMATIONS .......... */ i_1 = *igh; for (i = *low; i <= i_1; ++i) { zr[i + (j - 1) * zr_dim1] = zr[i + (j - 1) * zr_dim1] + xr * zr[i + j * zr_dim1] - xi * zi[i + j * zi_dim1]; zi[i + (j - 1) * zi_dim1] = zi[i + (j - 1) * zi_dim1] + xr * zi[i + j * zi_dim1] + xi * zr[i + j * zr_dim1]; /* L620: */ } /* L640: */ } goto L240; /* .......... A ROOT FOUND .......... */ L660: hr[en + en * hr_dim1] += tr; wr[en] = hr[en + en * hr_dim1]; hi[en + en * hi_dim1] += ti; wi[en] = hi[en + en * hi_dim1]; en = enm1; goto L220; /* .......... ALL ROOTS FOUND. BACKSUBSTITUTE TO FIND */ /* VECTORS OF UPPER TRIANGULAR FORM .......... */ L680: norm = 0.; i_2 = *n; for (i = 1; i <= i_2; ++i) { i_1 = *n; for (j = i; j <= i_1; ++j) { tr = (d_1 = hr[i + j * hr_dim1], abs(d_1)) + (d_2 = hi[i + j * hi_dim1], abs(d_2)); if (tr > norm) { norm = tr; } /* L720: */ } } hr[hr_dim1 + 1] = norm; if (*n == 1 || norm == 0.) { goto L1001; } /* .......... FOR EN=N STEP -1 UNTIL 2 DO -- .......... */ i_1 = *n; for (nn = 2; nn <= i_1; ++nn) { en = *n + 2 - nn; xr = wr[en]; xi = wi[en]; hr[en + en * hr_dim1] = 1.; hi[en + en * hi_dim1] = 0.; enm1 = en - 1; /* .......... FOR I=EN-1 STEP -1 UNTIL 1 DO -- .......... */ i_2 = enm1; for (ii = 1; ii <= i_2; ++ii) { i = en - ii; zzr = 0.; zzi = 0.; ip1 = i + 1; i_3 = en; for (j = ip1; j <= i_3; ++j) { zzr = zzr + hr[i + j * hr_dim1] * hr[j + en * hr_dim1] - hi[i + j * hi_dim1] * hi[j + en * hi_dim1]; zzi = zzi + hr[i + j * hr_dim1] * hi[j + en * hi_dim1] + hi[i + j * hi_dim1] * hr[j + en * hr_dim1]; /* L740: */ } yr = xr - wr[i]; yi = xi - wi[i]; if (yr != 0. || yi != 0.) { goto L765; } tst1 = norm; yr = tst1; L760: yr *= .01; tst2 = norm + yr; if (tst2 > tst1) { goto L760; } L765: cdiv_(&zzr, &zzi, &yr, &yi, &hr[i + en * hr_dim1], &hi[i + en * hi_dim1]); /* .......... OVERFLOW CONTROL .......... */ tr = (d_1 = hr[i + en * hr_dim1], abs(d_1)) + (d_2 = hi[i + en * hi_dim1], abs(d_2)); if (tr == 0.) { goto L780; } tst1 = tr; tst2 = tst1 + 1. / tst1; if (tst2 > tst1) { goto L780; } i_3 = en; for (j = i; j <= i_3; ++j) { hr[j + en * hr_dim1] /= tr; hi[j + en * hi_dim1] /= tr; /* L770: */ } L780: ; } /* L800: */ } /* .......... END BACKSUBSTITUTION .......... */ enm1 = *n - 1; /* .......... VECTORS OF ISOLATED ROOTS .......... */ i_1 = enm1; for (i = 1; i <= i_1; ++i) { if (i >= *low && i <= *igh) { goto L840; } ip1 = i + 1; i_2 = *n; for (j = ip1; j <= i_2; ++j) { zr[i + j * zr_dim1] = hr[i + j * hr_dim1]; zi[i + j * zi_dim1] = hi[i + j * hi_dim1]; /* L820: */ } L840: ; } /* .......... MULTIPLY BY TRANSFORMATION MATRIX TO GIVE */ /* VECTORS OF ORIGINAL FULL MATRIX. */ /* FOR J=N STEP -1 UNTIL LOW+1 DO -- .......... */ i_1 = enm1; for (jj = *low; jj <= i_1; ++jj) { j = *n + *low - jj; m = min(j,*igh); i_2 = *igh; for (i = *low; i <= i_2; ++i) { zzr = 0.; zzi = 0.; i_3 = m; for (k = *low; k <= i_3; ++k) { zzr = zzr + zr[i + k * zr_dim1] * hr[k + j * hr_dim1] - zi[i + k * zi_dim1] * hi[k + j * hi_dim1]; zzi = zzi + zr[i + k * zr_dim1] * hi[k + j * hi_dim1] + zi[i + k * zi_dim1] * hr[k + j * hr_dim1]; /* L860: */ } zr[i + j * zr_dim1] = zzr; zi[i + j * zi_dim1] = zzi; /* L880: */ } } goto L1001; /* .......... SET ERROR -- ALL EIGENVALUES HAVE NOT */ /* CONVERGED AFTER 30*N ITERATIONS .......... */ L1000: *ierr = en; L1001: return 0; } /* comlr2_ */ /* Subroutine */ int comqr_(integer *nm, integer *n, integer *low, integer * igh, doublereal *hr, doublereal *hi, doublereal *wr, doublereal *wi, integer *ierr) { /* System generated locals */ integer hr_dim1, hr_offset, hi_dim1, hi_offset, i_1, i_2; doublereal d_1, d_2, d_3, d_4; /* Local variables */ extern /* Subroutine */ int cdiv_(doublereal *, doublereal *, doublereal * , doublereal *, doublereal *, doublereal *); static doublereal norm; static integer i, j, l, en, ll; static doublereal si, ti, xi, yi, sr, tr, xr, yr; extern doublereal pythag_(doublereal *, doublereal *); extern /* Subroutine */ int csroot_(doublereal *, doublereal *, doublereal *, doublereal *); static integer lp1, itn, its; static doublereal zzi, zzr; static integer enm1; static doublereal tst1, tst2; /* THIS SUBROUTINE IS A TRANSLATION OF A UNITARY ANALOGUE OF THE */ /* ALGOL PROCEDURE COMLR, NUM. MATH. 12, 369-376(1968) BY MARTIN */ /* AND WILKINSON. */ /* HANDBOOK FOR AUTO. COMP., VOL.II-LINEAR ALGEBRA, 396-403(1971). */ /* THE UNITARY ANALOGUE SUBSTITUTES THE QR ALGORITHM OF FRANCIS */ /* (COMP. JOUR. 4, 332-345(1962)) FOR THE LR ALGORITHM. */ /* THIS SUBROUTINE FINDS THE EIGENVALUES OF A COMPLEX */ /* UPPER HESSENBERG MATRIX BY THE QR METHOD. */ /* ON INPUT */ /* NM MUST BE SET TO THE ROW DIMENSION OF TWO-DIMENSIONAL */ /* ARRAY PARAMETERS AS DECLARED IN THE CALLING PROGRAM */ /* DIMENSION STATEMENT. */ /* N IS THE ORDER OF THE MATRIX. */ /* LOW AND IGH ARE INTEGERS DETERMINED BY THE BALANCING */ /* SUBROUTINE CBAL. IF CBAL HAS NOT BEEN USED, */ /* SET LOW=1, IGH=N. */ /* HR AND HI CONTAIN THE REAL AND IMAGINARY PARTS, */ /* RESPECTIVELY, OF THE COMPLEX UPPER HESSENBERG MATRIX. */ /* THEIR LOWER TRIANGLES BELOW THE SUBDIAGONAL CONTAIN */ /* INFORMATION ABOUT THE UNITARY TRANSFORMATIONS USED IN */ /* THE REDUCTION BY CORTH, IF PERFORMED. */ /* ON OUTPUT */ /* THE UPPER HESSENBERG PORTIONS OF HR AND HI HAVE BEEN */ /* DESTROYED. THEREFORE, THEY MUST BE SAVED BEFORE */ /* CALLING COMQR IF SUBSEQUENT CALCULATION OF */ /* EIGENVECTORS IS TO BE PERFORMED. */ /* WR AND WI CONTAIN THE REAL AND IMAGINARY PARTS, */ /* RESPECTIVELY, OF THE EIGENVALUES. IF AN ERROR */ /* EXIT IS MADE, THE EIGENVALUES SHOULD BE CORRECT */ /* FOR INDICES IERR+1,...,N. */ /* IERR IS SET TO */ /* ZERO FOR NORMAL RETURN, */ /* J IF THE LIMIT OF 30*N ITERATIONS IS EXHAUSTED */ /* WHILE THE J-TH EIGENVALUE IS BEING SOUGHT. */ /* CALLS CDIV FOR COMPLEX DIVISION. */ /* CALLS CSROOT FOR COMPLEX SQUARE ROOT. */ /* 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 */ --wi; --wr; hi_dim1 = *nm; hi_offset = hi_dim1 + 1; hi -= hi_offset; hr_dim1 = *nm; hr_offset = hr_dim1 + 1; hr -= hr_offset; /* Function Body */ *ierr = 0; if (*low == *igh) { goto L180; } /* .......... CREATE REAL SUBDIAGONAL ELEMENTS .......... */ l = *low + 1; i_1 = *igh; for (i = l; i <= i_1; ++i) { /* Computing MIN */ i_2 = i + 1; ll = min(i_2,*igh); if (hi[i + (i - 1) * hi_dim1] == 0.) { goto L170; } norm = pythag_(&hr[i + (i - 1) * hr_dim1], &hi[i + (i - 1) * hi_dim1]) ; yr = hr[i + (i - 1) * hr_dim1] / norm; yi = hi[i + (i - 1) * hi_dim1] / norm; hr[i + (i - 1) * hr_dim1] = norm; hi[i + (i - 1) * hi_dim1] = 0.; i_2 = *igh; for (j = i; j <= i_2; ++j) { si = yr * hi[i + j * hi_dim1] - yi * hr[i + j * hr_dim1]; hr[i + j * hr_dim1] = yr * hr[i + j * hr_dim1] + yi * hi[i + j * hi_dim1]; hi[i + j * hi_dim1] = si; /* L155: */ } i_2 = ll; for (j = *low; j <= i_2; ++j) { si = yr * hi[j + i * hi_dim1] + yi * hr[j + i * hr_dim1]; hr[j + i * hr_dim1] = yr * hr[j + i * hr_dim1] - yi * hi[j + i * hi_dim1]; hi[j + i * hi_dim1] = si; /* L160: */ } L170: ; } /* .......... STORE ROOTS ISOLATED BY CBAL .......... */ L180: i_1 = *n; for (i = 1; i <= i_1; ++i) { if (i >= *low && i <= *igh) { goto L200; } wr[i] = hr[i + i * hr_dim1]; wi[i] = hi[i + i * hi_dim1]; L200: ; } en = *igh; tr = 0.; ti = 0.; itn = *n * 30; /* .......... SEARCH FOR NEXT EIGENVALUE .......... */ L220: if (en < *low) { goto L1001; } its = 0; enm1 = en - 1; /* .......... LOOK FOR SINGLE SMALL SUB-DIAGONAL ELEMENT */ /* FOR L=EN STEP -1 UNTIL LOW D0 -- .......... */ L240: i_1 = en; for (ll = *low; ll <= i_1; ++ll) { l = en + *low - ll; if (l == *low) { goto L300; } tst1 = (d_1 = hr[l - 1 + (l - 1) * hr_dim1], abs(d_1)) + (d_2 = hi[ l - 1 + (l - 1) * hi_dim1], abs(d_2)) + (d_3 = hr[l + l * hr_dim1], abs(d_3)) + (d_4 = hi[l + l * hi_dim1], abs(d_4)) ; tst2 = tst1 + (d_1 = hr[l + (l - 1) * hr_dim1], abs(d_1)); if (tst2 == tst1) { goto L300; } /* L260: */ } /* .......... FORM SHIFT .......... */ L300: if (l == en) { goto L660; } if (itn == 0) { goto L1000; } if (its == 10 || its == 20) { goto L320; } sr = hr[en + en * hr_dim1]; si = hi[en + en * hi_dim1]; xr = hr[enm1 + en * hr_dim1] * hr[en + enm1 * hr_dim1]; xi = hi[enm1 + en * hi_dim1] * hr[en + enm1 * hr_dim1]; if (xr == 0. && xi == 0.) { goto L340; } yr = (hr[enm1 + enm1 * hr_dim1] - sr) / 2.; yi = (hi[enm1 + enm1 * hi_dim1] - si) / 2.; /* Computing 2nd power */ d_2 = yr; /* Computing 2nd power */ d_3 = yi; d_1 = d_2 * d_2 - d_3 * d_3 + xr; d_4 = yr * 2. * yi + xi; csroot_(&d_1, &d_4, &zzr, &zzi); if (yr * zzr + yi * zzi >= 0.) { goto L310; } zzr = -zzr; zzi = -zzi; L310: d_1 = yr + zzr; d_2 = yi + zzi; cdiv_(&xr, &xi, &d_1, &d_2, &xr, &xi); sr -= xr; si -= xi; goto L340; /* .......... FORM EXCEPTIONAL SHIFT .......... */ L320: sr = (d_1 = hr[en + enm1 * hr_dim1], abs(d_1)) + (d_2 = hr[enm1 + (en - 2) * hr_dim1], abs(d_2)); si = 0.; L340: i_1 = en; for (i = *low; i <= i_1; ++i) { hr[i + i * hr_dim1] -= sr; hi[i + i * hi_dim1] -= si; /* L360: */ } tr += sr; ti += si; ++its; --itn; /* .......... REDUCE TO TRIANGLE (ROWS) .......... */ lp1 = l + 1; i_1 = en; for (i = lp1; i <= i_1; ++i) { sr = hr[i + (i - 1) * hr_dim1]; hr[i + (i - 1) * hr_dim1] = 0.; d_1 = pythag_(&hr[i - 1 + (i - 1) * hr_dim1], &hi[i - 1 + (i - 1) * hi_dim1]); norm = pythag_(&d_1, &sr); xr = hr[i - 1 + (i - 1) * hr_dim1] / norm; wr[i - 1] = xr; xi = hi[i - 1 + (i - 1) * hi_dim1] / norm; wi[i - 1] = xi; hr[i - 1 + (i - 1) * hr_dim1] = norm; hi[i - 1 + (i - 1) * hi_dim1] = 0.; hi[i + (i - 1) * hi_dim1] = sr / norm; i_2 = en; for (j = i; j <= i_2; ++j) { yr = hr[i - 1 + j * hr_dim1]; yi = hi[i - 1 + j * hi_dim1]; zzr = hr[i + j * hr_dim1]; zzi = hi[i + j * hi_dim1]; hr[i - 1 + j * hr_dim1] = xr * yr + xi * yi + hi[i + (i - 1) * hi_dim1] * zzr; hi[i - 1 + j * hi_dim1] = xr * yi - xi * yr + hi[i + (i - 1) * hi_dim1] * zzi; hr[i + j * hr_dim1] = xr * zzr - xi * zzi - hi[i + (i - 1) * hi_dim1] * yr; hi[i + j * hi_dim1] = xr * zzi + xi * zzr - hi[i + (i - 1) * hi_dim1] * yi; /* L490: */ } /* L500: */ } si = hi[en + en * hi_dim1]; if (si == 0.) { goto L540; } norm = pythag_(&hr[en + en * hr_dim1], &si); sr = hr[en + en * hr_dim1] / norm; si /= norm; hr[en + en * hr_dim1] = norm; hi[en + en * hi_dim1] = 0.; /* .......... INVERSE OPERATION (COLUMNS) .......... */ L540: i_1 = en; for (j = lp1; j <= i_1; ++j) { xr = wr[j - 1]; xi = wi[j - 1]; i_2 = j; for (i = l; i <= i_2; ++i) { yr = hr[i + (j - 1) * hr_dim1]; yi = 0.; zzr = hr[i + j * hr_dim1]; zzi = hi[i + j * hi_dim1]; if (i == j) { goto L560; } yi = hi[i + (j - 1) * hi_dim1]; hi[i + (j - 1) * hi_dim1] = xr * yi + xi * yr + hi[j + (j - 1) * hi_dim1] * zzi; L560: hr[i + (j - 1) * hr_dim1] = xr * yr - xi * yi + hi[j + (j - 1) * hi_dim1] * zzr; hr[i + j * hr_dim1] = xr * zzr + xi * zzi - hi[j + (j - 1) * hi_dim1] * yr; hi[i + j * hi_dim1] = xr * zzi - xi * zzr - hi[j + (j - 1) * hi_dim1] * yi; /* L580: */ } /* L600: */ } if (si == 0.) { goto L240; } i_1 = en; for (i = l; i <= i_1; ++i) { yr = hr[i + en * hr_dim1]; yi = hi[i + en * hi_dim1]; hr[i + en * hr_dim1] = sr * yr - si * yi; hi[i + en * hi_dim1] = sr * yi + si * yr; /* L630: */ } goto L240; /* .......... A ROOT FOUND .......... */ L660: wr[en] = hr[en + en * hr_dim1] + tr; wi[en] = hi[en + en * hi_dim1] + ti; en = enm1; goto L220; /* .......... SET ERROR -- ALL EIGENVALUES HAVE NOT */ /* CONVERGED AFTER 30*N ITERATIONS .......... */ L1000: *ierr = en; L1001: return 0; } /* comqr_ */ /* Subroutine */ int comqr2_(integer *nm, integer *n, integer *low, integer * igh, doublereal *ortr, doublereal *orti, doublereal *hr, doublereal * hi, doublereal *wr, doublereal *wi, doublereal *zr, doublereal *zi, integer *ierr) { /* System generated locals */ integer hr_dim1, hr_offset, hi_dim1, hi_offset, zr_dim1, zr_offset, zi_dim1, zi_offset, i_1, i_2, i_3; doublereal d_1, d_2, d_3, d_4; /* Local variables */ static integer iend; extern /* Subroutine */ int cdiv_(doublereal *, doublereal *, doublereal * , doublereal *, doublereal *, doublereal *); static doublereal norm; static integer i, j, k, l, m, ii, en, jj, ll, nn; static doublereal si, ti, xi, yi, sr, tr, xr, yr; extern doublereal pythag_(doublereal *, doublereal *); extern /* Subroutine */ int csroot_(doublereal *, doublereal *, doublereal *, doublereal *); static integer ip1, lp1, itn, its; static doublereal zzi, zzr; static integer enm1; static doublereal tst1, tst2; /* THIS SUBROUTINE IS A TRANSLATION OF A UNITARY ANALOGUE OF THE */ /* ALGOL PROCEDURE COMLR2, NUM. MATH. 16, 181-204(1970) BY PETERS */ /* AND WILKINSON. */ /* HANDBOOK FOR AUTO. COMP., VOL.II-LINEAR ALGEBRA, 372-395(1971). */ /* THE UNITARY ANALOGUE SUBSTITUTES THE QR ALGORITHM OF FRANCIS */ /* (COMP. JOUR. 4, 332-345(1962)) FOR THE LR ALGORITHM. */ /* THIS SUBROUTINE FINDS THE EIGENVALUES AND EIGENVECTORS */ /* OF A COMPLEX UPPER HESSENBERG MATRIX BY THE QR */ /* METHOD. THE EIGENVECTORS OF A COMPLEX GENERAL MATRIX */ /* CAN ALSO BE FOUND IF CORTH HAS BEEN USED TO REDUCE */ /* THIS GENERAL MATRIX TO HESSENBERG FORM. */ /* ON INPUT */ /* NM MUST BE SET TO THE ROW DIMENSION OF TWO-DIMENSIONAL */ /* ARRAY PARAMETERS AS DECLARED IN THE CALLING PROGRAM */ /* DIMENSION STATEMENT. */ /* N IS THE ORDER OF THE MATRIX. */ /* LOW AND IGH ARE INTEGERS DETERMINED BY THE BALANCING */ /* SUBROUTINE CBAL. IF CBAL HAS NOT BEEN USED, */ /* SET LOW=1, IGH=N. */ /* ORTR AND ORTI CONTAIN INFORMATION ABOUT THE UNITARY TRANS- */ /* FORMATIONS USED IN THE REDUCTION BY CORTH, IF PERFORMED. */ /* ONLY ELEMENTS LOW THROUGH IGH ARE USED. IF THE EIGENVECTORS */ /* OF THE HESSENBERG MATRIX ARE DESIRED, SET ORTR(J) AND */ /* ORTI(J) TO 0.0D0 FOR THESE ELEMENTS. */ /* HR AND HI CONTAIN THE REAL AND IMAGINARY PARTS, */ /* RESPECTIVELY, OF THE COMPLEX UPPER HESSENBERG MATRIX. */ /* THEIR LOWER TRIANGLES BELOW THE SUBDIAGONAL CONTAIN FURTHER */ /* INFORMATION ABOUT THE TRANSFORMATIONS WHICH WERE USED IN THE */ /* REDUCTION BY CORTH, IF PERFORMED. IF THE EIGENVECTORS OF */ /* THE HESSENBERG MATRIX ARE DESIRED, THESE ELEMENTS MAY BE */ /* ARBITRARY. */ /* ON OUTPUT */ /* ORTR, ORTI, AND THE UPPER HESSENBERG PORTIONS OF HR AND HI */ /* HAVE BEEN DESTROYED. */ /* WR AND WI CONTAIN THE REAL AND IMAGINARY PARTS, */ /* RESPECTIVELY, OF THE EIGENVALUES. IF AN ERROR */ /* EXIT IS MADE, THE EIGENVALUES SHOULD BE CORRECT */ /* FOR INDICES IERR+1,...,N. */ /* ZR AND ZI CONTAIN THE REAL AND IMAGINARY PARTS, */ /* RESPECTIVELY, OF THE EIGENVECTORS. THE EIGENVECTORS */ /* ARE UNNORMALIZED. IF AN ERROR EXIT IS MADE, NONE OF */ /* THE EIGENVECTORS HAS BEEN FOUND. */ /* IERR IS SET TO */ /* ZERO FOR NORMAL RETURN, */ /* J IF THE LIMIT OF 30*N ITERATIONS IS EXHAUSTED */ /* WHILE THE J-TH EIGENVALUE IS BEING SOUGHT. */ /* CALLS CDIV FOR COMPLEX DIVISION. */ /* CALLS CSROOT FOR COMPLEX SQUARE ROOT. */ /* 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 */ zi_dim1 = *nm; zi_offset = zi_dim1 + 1; zi -= zi_offset; zr_dim1 = *nm; zr_offset = zr_dim1 + 1; zr -= zr_offset; --wi; --wr; hi_dim1 = *nm; hi_offset = hi_dim1 + 1; hi -= hi_offset; hr_dim1 = *nm; hr_offset = hr_dim1 + 1; hr -= hr_offset; --orti; --ortr; /* Function Body */ *ierr = 0; /* .......... INITIALIZE EIGENVECTOR MATRIX .......... */ i_1 = *n; for (j = 1; j <= i_1; ++j) { i_2 = *n; for (i = 1; i <= i_2; ++i) { zr[i + j * zr_dim1] = 0.; zi[i + j * zi_dim1] = 0.; /* L100: */ } zr[j + j * zr_dim1] = 1.; /* L101: */ } /* .......... FORM THE MATRIX OF ACCUMULATED TRANSFORMATIONS */ /* FROM THE INFORMATION LEFT BY CORTH .......... */ iend = *igh - *low - 1; if (iend < 0) { goto L180; } else if (iend == 0) { goto L150; } else { goto L105; } /* .......... FOR I=IGH-1 STEP -1 UNTIL LOW+1 DO -- .......... */ L105: i_1 = iend; for (ii = 1; ii <= i_1; ++ii) { i = *igh - ii; if (ortr[i] == 0. && orti[i] == 0.) { goto L140; } if (hr[i + (i - 1) * hr_dim1] == 0. && hi[i + (i - 1) * hi_dim1] == 0.) { goto L140; } /* .......... NORM BELOW IS NEGATIVE OF H FORMED IN CORTH ........ .. */ norm = hr[i + (i - 1) * hr_dim1] * ortr[i] + hi[i + (i - 1) * hi_dim1] * orti[i]; ip1 = i + 1; i_2 = *igh; for (k = ip1; k <= i_2; ++k) { ortr[k] = hr[k + (i - 1) * hr_dim1]; orti[k] = hi[k + (i - 1) * hi_dim1]; /* L110: */ } i_2 = *igh; for (j = i; j <= i_2; ++j) { sr = 0.; si = 0.; i_3 = *igh; for (k = i; k <= i_3; ++k) { sr = sr + ortr[k] * zr[k + j * zr_dim1] + orti[k] * zi[k + j * zi_dim1]; si = si + ortr[k] * zi[k + j * zi_dim1] - orti[k] * zr[k + j * zr_dim1]; /* L115: */ } sr /= norm; si /= norm; i_3 = *igh; for (k = i; k <= i_3; ++k) { zr[k + j * zr_dim1] = zr[k + j * zr_dim1] + sr * ortr[k] - si * orti[k]; zi[k + j * zi_dim1] = zi[k + j * zi_dim1] + sr * orti[k] + si * ortr[k]; /* L120: */ } /* L130: */ } L140: ; } /* .......... CREATE REAL SUBDIAGONAL ELEMENTS .......... */ L150: l = *low + 1; i_1 = *igh; for (i = l; i <= i_1; ++i) { /* Computing MIN */ i_2 = i + 1; ll = min(i_2,*igh); if (hi[i + (i - 1) * hi_dim1] == 0.) { goto L170; } norm = pythag_(&hr[i + (i - 1) * hr_dim1], &hi[i + (i - 1) * hi_dim1]) ; yr = hr[i + (i - 1) * hr_dim1] / norm; yi = hi[i + (i - 1) * hi_dim1] / norm; hr[i + (i - 1) * hr_dim1] = norm; hi[i + (i - 1) * hi_dim1] = 0.; i_2 = *n; for (j = i; j <= i_2; ++j) { si = yr * hi[i + j * hi_dim1] - yi * hr[i + j * hr_dim1]; hr[i + j * hr_dim1] = yr * hr[i + j * hr_dim1] + yi * hi[i + j * hi_dim1]; hi[i + j * hi_dim1] = si; /* L155: */ } i_2 = ll; for (j = 1; j <= i_2; ++j) { si = yr * hi[j + i * hi_dim1] + yi * hr[j + i * hr_dim1]; hr[j + i * hr_dim1] = yr * hr[j + i * hr_dim1] - yi * hi[j + i * hi_dim1]; hi[j + i * hi_dim1] = si; /* L160: */ } i_2 = *igh; for (j = *low; j <= i_2; ++j) { si = yr * zi[j + i * zi_dim1] + yi * zr[j + i * zr_dim1]; zr[j + i * zr_dim1] = yr * zr[j + i * zr_dim1] - yi * zi[j + i * zi_dim1]; zi[j + i * zi_dim1] = si; /* L165: */ } L170: ; } /* .......... STORE ROOTS ISOLATED BY CBAL .......... */ L180: i_1 = *n; for (i = 1; i <= i_1; ++i) { if (i >= *low && i <= *igh) { goto L200; } wr[i] = hr[i + i * hr_dim1]; wi[i] = hi[i + i * hi_dim1]; L200: ; } en = *igh; tr = 0.; ti = 0.; itn = *n * 30; /* .......... SEARCH FOR NEXT EIGENVALUE .......... */ L220: if (en < *low) { goto L680; } its = 0; enm1 = en - 1; /* .......... LOOK FOR SINGLE SMALL SUB-DIAGONAL ELEMENT */ /* FOR L=EN STEP -1 UNTIL LOW DO -- .......... */ L240: i_1 = en; for (ll = *low; ll <= i_1; ++ll) { l = en + *low - ll; if (l == *low) { goto L300; } tst1 = (d_1 = hr[l - 1 + (l - 1) * hr_dim1], abs(d_1)) + (d_2 = hi[ l - 1 + (l - 1) * hi_dim1], abs(d_2)) + (d_3 = hr[l + l * hr_dim1], abs(d_3)) + (d_4 = hi[l + l * hi_dim1], abs(d_4)) ; tst2 = tst1 + (d_1 = hr[l + (l - 1) * hr_dim1], abs(d_1)); if (tst2 == tst1) { goto L300; } /* L260: */ } /* .......... FORM SHIFT .......... */ L300: if (l == en) { goto L660; } if (itn == 0) { goto L1000; } if (its == 10 || its == 20) { goto L320; } sr = hr[en + en * hr_dim1]; si = hi[en + en * hi_dim1]; xr = hr[enm1 + en * hr_dim1] * hr[en + enm1 * hr_dim1]; xi = hi[enm1 + en * hi_dim1] * hr[en + enm1 * hr_dim1]; if (xr == 0. && xi == 0.) { goto L340; } yr = (hr[enm1 + enm1 * hr_dim1] - sr) / 2.; yi = (hi[enm1 + enm1 * hi_dim1] - si) / 2.; /* Computing 2nd power */ d_2 = yr; /* Computing 2nd power */ d_3 = yi; d_1 = d_2 * d_2 - d_3 * d_3 + xr; d_4 = yr * 2. * yi + xi; csroot_(&d_1, &d_4, &zzr, &zzi); if (yr * zzr + yi * zzi >= 0.) { goto L310; } zzr = -zzr; zzi = -zzi; L310: d_1 = yr + zzr; d_2 = yi + zzi; cdiv_(&xr, &xi, &d_1, &d_2, &xr, &xi); sr -= xr; si -= xi; goto L340; /* .......... FORM EXCEPTIONAL SHIFT .......... */ L320: sr = (d_1 = hr[en + enm1 * hr_dim1], abs(d_1)) + (d_2 = hr[enm1 + (en - 2) * hr_dim1], abs(d_2)); si = 0.; L340: i_1 = en; for (i = *low; i <= i_1; ++i) { hr[i + i * hr_dim1] -= sr; hi[i + i * hi_dim1] -= si; /* L360: */ } tr += sr; ti += si; ++its; --itn; /* .......... REDUCE TO TRIANGLE (ROWS) .......... */ lp1 = l + 1; i_1 = en; for (i = lp1; i <= i_1; ++i) { sr = hr[i + (i - 1) * hr_dim1]; hr[i + (i - 1) * hr_dim1] = 0.; d_1 = pythag_(&hr[i - 1 + (i - 1) * hr_dim1], &hi[i - 1 + (i - 1) * hi_dim1]); norm = pythag_(&d_1, &sr); xr = hr[i - 1 + (i - 1) * hr_dim1] / norm; wr[i - 1] = xr; xi = hi[i - 1 + (i - 1) * hi_dim1] / norm; wi[i - 1] = xi; hr[i - 1 + (i - 1) * hr_dim1] = norm; hi[i - 1 + (i - 1) * hi_dim1] = 0.; hi[i + (i - 1) * hi_dim1] = sr / norm; i_2 = *n; for (j = i; j <= i_2; ++j) { yr = hr[i - 1 + j * hr_dim1]; yi = hi[i - 1 + j * hi_dim1]; zzr = hr[i + j * hr_dim1]; zzi = hi[i + j * hi_dim1]; hr[i - 1 + j * hr_dim1] = xr * yr + xi * yi + hi[i + (i - 1) * hi_dim1] * zzr; hi[i - 1 + j * hi_dim1] = xr * yi - xi * yr + hi[i + (i - 1) * hi_dim1] * zzi; hr[i + j * hr_dim1] = xr * zzr - xi * zzi - hi[i + (i - 1) * hi_dim1] * yr; hi[i + j * hi_dim1] = xr * zzi + xi * zzr - hi[i + (i - 1) * hi_dim1] * yi; /* L490: */ } /* L500: */ } si = hi[en + en * hi_dim1]; if (si == 0.) { goto L540; } norm = pythag_(&hr[en + en * hr_dim1], &si); sr = hr[en + en * hr_dim1] / norm; si /= norm; hr[en + en * hr_dim1] = norm; hi[en + en * hi_dim1] = 0.; if (en == *n) { goto L540; } ip1 = en + 1; i_1 = *n; for (j = ip1; j <= i_1; ++j) { yr = hr[en + j * hr_dim1]; yi = hi[en + j * hi_dim1]; hr[en + j * hr_dim1] = sr * yr + si * yi; hi[en + j * hi_dim1] = sr * yi - si * yr; /* L520: */ } /* .......... INVERSE OPERATION (COLUMNS) .......... */ L540: i_1 = en; for (j = lp1; j <= i_1; ++j) { xr = wr[j - 1]; xi = wi[j - 1]; i_2 = j; for (i = 1; i <= i_2; ++i) { yr = hr[i + (j - 1) * hr_dim1]; yi = 0.; zzr = hr[i + j * hr_dim1]; zzi = hi[i + j * hi_dim1]; if (i == j) { goto L560; } yi = hi[i + (j - 1) * hi_dim1]; hi[i + (j - 1) * hi_dim1] = xr * yi + xi * yr + hi[j + (j - 1) * hi_dim1] * zzi; L560: hr[i + (j - 1) * hr_dim1] = xr * yr - xi * yi + hi[j + (j - 1) * hi_dim1] * zzr; hr[i + j * hr_dim1] = xr * zzr + xi * zzi - hi[j + (j - 1) * hi_dim1] * yr; hi[i + j * hi_dim1] = xr * zzi - xi * zzr - hi[j + (j - 1) * hi_dim1] * yi; /* L580: */ } i_2 = *igh; for (i = *low; i <= i_2; ++i) { yr = zr[i + (j - 1) * zr_dim1]; yi = zi[i + (j - 1) * zi_dim1]; zzr = zr[i + j * zr_dim1]; zzi = zi[i + j * zi_dim1]; zr[i + (j - 1) * zr_dim1] = xr * yr - xi * yi + hi[j + (j - 1) * hi_dim1] * zzr; zi[i + (j - 1) * zi_dim1] = xr * yi + xi * yr + hi[j + (j - 1) * hi_dim1] * zzi; zr[i + j * zr_dim1] = xr * zzr + xi * zzi - hi[j + (j - 1) * hi_dim1] * yr; zi[i + j * zi_dim1] = xr * zzi - xi * zzr - hi[j + (j - 1) * hi_dim1] * yi; /* L590: */ } /* L600: */ } if (si == 0.) { goto L240; } i_1 = en; for (i = 1; i <= i_1; ++i) { yr = hr[i + en * hr_dim1]; yi = hi[i + en * hi_dim1]; hr[i + en * hr_dim1] = sr * yr - si * yi; hi[i + en * hi_dim1] = sr * yi + si * yr; /* L630: */ } i_1 = *igh; for (i = *low; i <= i_1; ++i) { yr = zr[i + en * zr_dim1]; yi = zi[i + en * zi_dim1]; zr[i + en * zr_dim1] = sr * yr - si * yi; zi[i + en * zi_dim1] = sr * yi + si * yr; /* L640: */ } goto L240; /* .......... A ROOT FOUND .......... */ L660: hr[en + en * hr_dim1] += tr; wr[en] = hr[en + en * hr_dim1]; hi[en + en * hi_dim1] += ti; wi[en] = hi[en + en * hi_dim1]; en = enm1; goto L220; /* .......... ALL ROOTS FOUND. BACKSUBSTITUTE TO FIND */ /* VECTORS OF UPPER TRIANGULAR FORM .......... */ L680: norm = 0.; i_1 = *n; for (i = 1; i <= i_1; ++i) { i_2 = *n; for (j = i; j <= i_2; ++j) { tr = (d_1 = hr[i + j * hr_dim1], abs(d_1)) + (d_2 = hi[i + j * hi_dim1], abs(d_2)); if (tr > norm) { norm = tr; } /* L720: */ } } if (*n == 1 || norm == 0.) { goto L1001; } /* .......... FOR EN=N STEP -1 UNTIL 2 DO -- .......... */ i_2 = *n; for (nn = 2; nn <= i_2; ++nn) { en = *n + 2 - nn; xr = wr[en]; xi = wi[en]; hr[en + en * hr_dim1] = 1.; hi[en + en * hi_dim1] = 0.; enm1 = en - 1; /* .......... FOR I=EN-1 STEP -1 UNTIL 1 DO -- .......... */ i_1 = enm1; for (ii = 1; ii <= i_1; ++ii) { i = en - ii; zzr = 0.; zzi = 0.; ip1 = i + 1; i_3 = en; for (j = ip1; j <= i_3; ++j) { zzr = zzr + hr[i + j * hr_dim1] * hr[j + en * hr_dim1] - hi[i + j * hi_dim1] * hi[j + en * hi_dim1]; zzi = zzi + hr[i + j * hr_dim1] * hi[j + en * hi_dim1] + hi[i + j * hi_dim1] * hr[j + en * hr_dim1]; /* L740: */ } yr = xr - wr[i]; yi = xi - wi[i]; if (yr != 0. || yi != 0.) { goto L765; } tst1 = norm; yr = tst1; L760: yr *= .01; tst2 = norm + yr; if (tst2 > tst1) { goto L760; } L765: cdiv_(&zzr, &zzi, &yr, &yi, &hr[i + en * hr_dim1], &hi[i + en * hi_dim1]); /* .......... OVERFLOW CONTROL .......... */ tr = (d_1 = hr[i + en * hr_dim1], abs(d_1)) + (d_2 = hi[i + en * hi_dim1], abs(d_2)); if (tr == 0.) { goto L780; } tst1 = tr; tst2 = tst1 + 1. / tst1; if (tst2 > tst1) { goto L780; } i_3 = en; for (j = i; j <= i_3; ++j) { hr[j + en * hr_dim1] /= tr; hi[j + en * hi_dim1] /= tr; /* L770: */ } L780: ; } /* L800: */ } /* .......... END BACKSUBSTITUTION .......... */ enm1 = *n - 1; /* .......... VECTORS OF ISOLATED ROOTS .......... */ i_2 = enm1; for (i = 1; i <= i_2; ++i) { if (i >= *low && i <= *igh) { goto L840; } ip1 = i + 1; i_1 = *n; for (j = ip1; j <= i_1; ++j) { zr[i + j * zr_dim1] = hr[i + j * hr_dim1]; zi[i + j * zi_dim1] = hi[i + j * hi_dim1]; /* L820: */ } L840: ; } /* .......... MULTIPLY BY TRANSFORMATION MATRIX TO GIVE */ /* VECTORS OF ORIGINAL FULL MATRIX. */ /* FOR J=N STEP -1 UNTIL LOW+1 DO -- .......... */ i_2 = enm1; for (jj = *low; jj <= i_2; ++jj) { j = *n + *low - jj; m = min(j,*igh); i_1 = *igh; for (i = *low; i <= i_1; ++i) { zzr = 0.; zzi = 0.; i_3 = m; for (k = *low; k <= i_3; ++k) { zzr = zzr + zr[i + k * zr_dim1] * hr[k + j * hr_dim1] - zi[i + k * zi_dim1] * hi[k + j * hi_dim1]; zzi = zzi + zr[i + k * zr_dim1] * hi[k + j * hi_dim1] + zi[i + k * zi_dim1] * hr[k + j * hr_dim1]; /* L860: */ } zr[i + j * zr_dim1] = zzr; zi[i + j * zi_dim1] = zzi; /* L880: */ } } goto L1001; /* .......... SET ERROR -- ALL EIGENVALUES HAVE NOT */ /* CONVERGED AFTER 30*N ITERATIONS .......... */ L1000: *ierr = en; L1001: return 0; } /* comqr2_ */ /* Subroutine */ int cortb_(integer *nm, integer *low, integer *igh, doublereal *ar, doublereal *ai, doublereal *ortr, doublereal *orti, integer *m, doublereal *zr, doublereal *zi) { /* System generated locals */ integer ar_dim1, ar_offset, ai_dim1, ai_offset, zr_dim1, zr_offset, zi_dim1, zi_offset, i_1, i_2, i_3; /* Local variables */ static doublereal h; static integer i, j, la; static doublereal gi, gr; static integer mm, mp, kp1, mp1; /* THIS SUBROUTINE IS A TRANSLATION OF A COMPLEX ANALOGUE OF */ /* THE ALGOL PROCEDURE ORTBAK, NUM. MATH. 12, 349-368(1968) */ /* BY MARTIN AND WILKINSON. */ /* HANDBOOK FOR AUTO. COMP., VOL.II-LINEAR ALGEBRA, 339-358(1971). */ /* THIS SUBROUTINE FORMS THE EIGENVECTORS OF A COMPLEX GENERAL */ /* MATRIX BY BACK TRANSFORMING THOSE OF THE CORRESPONDING */ /* UPPER HESSENBERG MATRIX DETERMINED BY CORTH. */ /* ON INPUT */ /* NM MUST BE SET TO THE ROW DIMENSION OF TWO-DIMENSIONAL */ /* ARRAY PARAMETERS AS DECLARED IN THE CALLING PROGRAM */ /* DIMENSION STATEMENT. */ /* LOW AND IGH ARE INTEGERS DETERMINED BY THE BALANCING */ /* SUBROUTINE CBAL. IF CBAL HAS NOT BEEN USED, */ /* SET LOW=1 AND IGH EQUAL TO THE ORDER OF THE MATRIX. */ /* AR AND AI CONTAIN INFORMATION ABOUT THE UNITARY */ /* TRANSFORMATIONS USED IN THE REDUCTION BY CORTH */ /* IN THEIR STRICT LOWER TRIANGLES. */ /* ORTR AND ORTI CONTAIN FURTHER INFORMATION ABOUT THE */ /* TRANSFORMATIONS USED IN THE REDUCTION BY CORTH. */ /* ONLY ELEMENTS LOW THROUGH IGH ARE USED. */ /* M IS THE NUMBER OF COLUMNS OF ZR AND ZI TO BE BACK TRANSFORMED. */ /* ZR AND ZI CONTAIN THE REAL AND IMAGINARY PARTS, */ /* RESPECTIVELY, OF THE EIGENVECTORS TO BE */ /* BACK TRANSFORMED IN THEIR FIRST M COLUMNS. */ /* ON OUTPUT */ /* ZR AND ZI CONTAIN THE REAL AND IMAGINARY PARTS, */ /* RESPECTIVELY, OF THE TRANSFORMED EIGENVECTORS */ /* IN THEIR FIRST M COLUMNS. */ /* ORTR AND ORTI HAVE BEEN ALTERED. */ /* NOTE THAT CORTB PRESERVES VECTOR EUCLIDEAN NORMS. */ /* 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 */ --orti; --ortr; ai_dim1 = *nm; ai_offset = ai_dim1 + 1; ai -= ai_offset; ar_dim1 = *nm; ar_offset = ar_dim1 + 1; ar -= ar_offset; zi_dim1 = *nm; zi_offset = zi_dim1 + 1; zi -= zi_offset; zr_dim1 = *nm; zr_offset = zr_dim1 + 1; zr -= zr_offset; /* Function Body */ if (*m == 0) { goto L200; } la = *igh - 1; kp1 = *low + 1; if (la < kp1) { goto L200; } /* .......... FOR MP=IGH-1 STEP -1 UNTIL LOW+1 DO -- .......... */ i_1 = la; for (mm = kp1; mm <= i_1; ++mm) { mp = *low + *igh - mm; if (ar[mp + (mp - 1) * ar_dim1] == 0. && ai[mp + (mp - 1) * ai_dim1] == 0.) { goto L140; } /* .......... H BELOW IS NEGATIVE OF H FORMED IN CORTH .......... */ h = ar[mp + (mp - 1) * ar_dim1] * ortr[mp] + ai[mp + (mp - 1) * ai_dim1] * orti[mp]; mp1 = mp + 1; i_2 = *igh; for (i = mp1; i <= i_2; ++i) { ortr[i] = ar[i + (mp - 1) * ar_dim1]; orti[i] = ai[i + (mp - 1) * ai_dim1]; /* L100: */ } i_2 = *m; for (j = 1; j <= i_2; ++j) { gr = 0.; gi = 0.; i_3 = *igh; for (i = mp; i <= i_3; ++i) { gr = gr + ortr[i] * zr[i + j * zr_dim1] + orti[i] * zi[i + j * zi_dim1]; gi = gi + ortr[i] * zi[i + j * zi_dim1] - orti[i] * zr[i + j * zr_dim1]; /* L110: */ } gr /= h; gi /= h; i_3 = *igh; for (i = mp; i <= i_3; ++i) { zr[i + j * zr_dim1] = zr[i + j * zr_dim1] + gr * ortr[i] - gi * orti[i]; zi[i + j * zi_dim1] = zi[i + j * zi_dim1] + gr * orti[i] + gi * ortr[i]; /* L120: */ } /* L130: */ } L140: ; } L200: return 0; } /* cortb_ */ /* Subroutine */ int corth_(integer *nm, integer *n, integer *low, integer * igh, doublereal *ar, doublereal *ai, doublereal *ortr, doublereal * orti) { /* System generated locals */ integer ar_dim1, ar_offset, ai_dim1, ai_offset, i_1, i_2, i_3; doublereal d_1, d_2; /* Builtin functions */ double sqrt(doublereal); /* Local variables */ static doublereal f, g, h; static integer i, j, m; static doublereal scale; static integer la; static doublereal fi; static integer ii, jj; static doublereal fr; static integer mp; extern doublereal pythag_(doublereal *, doublereal *); static integer kp1; /* THIS SUBROUTINE IS A TRANSLATION OF A COMPLEX ANALOGUE OF */ /* THE ALGOL PROCEDURE ORTHES, NUM. MATH. 12, 349-368(1968) */ /* BY MARTIN AND WILKINSON. */ /* HANDBOOK FOR AUTO. COMP., VOL.II-LINEAR ALGEBRA, 339-358(1971). */ /* GIVEN A COMPLEX GENERAL MATRIX, THIS SUBROUTINE */ /* REDUCES A SUBMATRIX SITUATED IN ROWS AND COLUMNS */ /* LOW THROUGH IGH TO UPPER HESSENBERG FORM BY */ /* UNITARY SIMILARITY TRANSFORMATIONS. */ /* ON INPUT */ /* NM MUST BE SET TO THE ROW DIMENSION OF TWO-DIMENSIONAL */ /* ARRAY PARAMETERS AS DECLARED IN THE CALLING PROGRAM */ /* DIMENSION STATEMENT. */ /* N IS THE ORDER OF THE MATRIX. */ /* LOW AND IGH ARE INTEGERS DETERMINED BY THE BALANCING */ /* SUBROUTINE CBAL. IF CBAL HAS NOT BEEN USED, */ /* SET LOW=1, IGH=N. */ /* AR AND AI CONTAIN THE REAL AND IMAGINARY PARTS, */ /* RESPECTIVELY, OF THE COMPLEX INPUT MATRIX. */ /* ON OUTPUT */ /* AR AND AI CONTAIN THE REAL AND IMAGINARY PARTS, */ /* RESPECTIVELY, OF THE HESSENBERG MATRIX. INFORMATION */ /* ABOUT THE UNITARY TRANSFORMATIONS USED IN THE REDUCTION */ /* IS STORED IN THE REMAINING TRIANGLES UNDER THE */ /* HESSENBERG MATRIX. */ /* ORTR AND ORTI CONTAIN FURTHER INFORMATION ABOUT THE */ /* TRANSFORMATIONS. ONLY ELEMENTS LOW THROUGH IGH ARE USED. */ /* 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 */ ai_dim1 = *nm; ai_offset = ai_dim1 + 1; ai -= ai_offset; ar_dim1 = *nm; ar_offset = ar_dim1 + 1; ar -= ar_offset; --orti; --ortr; /* Function Body */ la = *igh - 1; kp1 = *low + 1; if (la < kp1) { goto L200; } i_1 = la; for (m = kp1; m <= i_1; ++m) { h = 0.; ortr[m] = 0.; orti[m] = 0.; scale = 0.; /* .......... SCALE COLUMN (ALGOL TOL THEN NOT NEEDED) .......... */ i_2 = *igh; for (i = m; i <= i_2; ++i) { /* L90: */ scale = scale + (d_1 = ar[i + (m - 1) * ar_dim1], abs(d_1)) + ( d_2 = ai[i + (m - 1) * ai_dim1], abs(d_2)); } if (scale == 0.) { goto L180; } mp = m + *igh; /* .......... FOR I=IGH STEP -1 UNTIL M DO -- .......... */ i_2 = *igh; for (ii = m; ii <= i_2; ++ii) { i = mp - ii; ortr[i] = ar[i + (m - 1) * ar_dim1] / scale; orti[i] = ai[i + (m - 1) * ai_dim1] / scale; h = h + ortr[i] * ortr[i] + orti[i] * orti[i]; /* L100: */ } g = sqrt(h); f = pythag_(&ortr[m], &orti[m]); if (f == 0.) { goto L103; } h += f * g; g /= f; ortr[m] = (g + 1.) * ortr[m]; orti[m] = (g + 1.) * orti[m]; goto L105; L103: ortr[m] = g; ar[m + (m - 1) * ar_dim1] = scale; /* .......... FORM (I-(U*UT)/H) * A .......... */ L105: i_2 = *n; for (j = m; j <= i_2; ++j) { fr = 0.; fi = 0.; /* .......... FOR I=IGH STEP -1 UNTIL M DO -- .......... */ i_3 = *igh; for (ii = m; ii <= i_3; ++ii) { i = mp - ii; fr = fr + ortr[i] * ar[i + j * ar_dim1] + orti[i] * ai[i + j * ai_dim1]; fi = fi + ortr[i] * ai[i + j * ai_dim1] - orti[i] * ar[i + j * ar_dim1]; /* L110: */ } fr /= h; fi /= h; i_3 = *igh; for (i = m; i <= i_3; ++i) { ar[i + j * ar_dim1] = ar[i + j * ar_dim1] - fr * ortr[i] + fi * orti[i]; ai[i + j * ai_dim1] = ai[i + j * ai_dim1] - fr * orti[i] - fi * ortr[i]; /* L120: */ } /* L130: */ } /* .......... FORM (I-(U*UT)/H)*A*(I-(U*UT)/H) .......... */ i_2 = *igh; for (i = 1; i <= i_2; ++i) { fr = 0.; fi = 0.; /* .......... FOR J=IGH STEP -1 UNTIL M DO -- .......... */ i_3 = *igh; for (jj = m; jj <= i_3; ++jj) { j = mp - jj; fr = fr + ortr[j] * ar[i + j * ar_dim1] - orti[j] * ai[i + j * ai_dim1]; fi = fi + ortr[j] * ai[i + j * ai_dim1] + orti[j] * ar[i + j * ar_dim1]; /* L140: */ } fr /= h; fi /= h; i_3 = *igh; for (j = m; j <= i_3; ++j) { ar[i + j * ar_dim1] = ar[i + j * ar_dim1] - fr * ortr[j] - fi * orti[j]; ai[i + j * ai_dim1] = ai[i + j * ai_dim1] + fr * orti[j] - fi * ortr[j]; /* L150: */ } /* L160: */ } ortr[m] = scale * ortr[m]; orti[m] = scale * orti[m]; ar[m + (m - 1) * ar_dim1] = -g * ar[m + (m - 1) * ar_dim1]; ai[m + (m - 1) * ai_dim1] = -g * ai[m + (m - 1) * ai_dim1]; L180: ; } L200: return 0; } /* corth_ */ /* Subroutine */ int elmbak_(integer *nm, integer *low, integer *igh, doublereal *a, integer *int_, integer *m, doublereal *z) { /* System generated locals */ integer a_dim1, a_offset, z_dim1, z_offset, i_1, i_2, i_3; /* Local variables */ static integer i, j; static doublereal x; static integer la, mm, mp, kp1, mp1; /* THIS SUBROUTINE IS A TRANSLATION OF THE ALGOL PROCEDURE ELMBAK, */ /* NUM. MATH. 12, 349-368(1968) BY MARTIN AND WILKINSON. */ /* HANDBOOK FOR AUTO. COMP., VOL.II-LINEAR ALGEBRA, 339-358(1971). */ /* THIS SUBROUTINE FORMS THE EIGENVECTORS OF A REAL GENERAL */ /* MATRIX BY BACK TRANSFORMING THOSE OF THE CORRESPONDING */ /* UPPER HESSENBERG MATRIX DETERMINED BY ELMHES. */ /* ON INPUT */ /* NM MUST BE SET TO THE ROW DIMENSION OF TWO-DIMENSIONAL */ /* ARRAY PARAMETERS AS DECLARED IN THE CALLING PROGRAM */ /* DIMENSION STATEMENT. */ /* LOW AND IGH ARE INTEGERS DETERMINED BY THE BALANCING */ /* SUBROUTINE BALANC. IF BALANC HAS NOT BEEN USED, */ /* SET LOW=1 AND IGH EQUAL TO THE ORDER OF THE MATRIX. */ /* A CONTAINS THE MULTIPLIERS WHICH WERE USED IN THE */ /* REDUCTION BY ELMHES IN ITS LOWER TRIANGLE */ /* BELOW THE SUBDIAGONAL. */ /* INT CONTAINS INFORMATION ON THE ROWS AND COLUMNS */ /* INTERCHANGED IN THE REDUCTION BY ELMHES. */ /* ONLY ELEMENTS LOW THROUGH IGH ARE USED. */ /* M IS THE NUMBER OF COLUMNS OF Z TO BE BACK TRANSFORMED. */ /* Z CONTAINS THE REAL AND IMAGINARY PARTS OF THE EIGEN- */ /* VECTORS TO BE BACK TRANSFORMED IN ITS FIRST M COLUMNS. */ /* ON OUTPUT */ /* Z CONTAINS THE REAL AND IMAGINARY PARTS OF THE */ /* TRANSFORMED EIGENVECTORS IN ITS FIRST M COLUMNS. */ /* 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 */ --int_; a_dim1 = *nm; a_offset = a_dim1 + 1; a -= a_offset; z_dim1 = *nm; z_offset = z_dim1 + 1; z -= z_offset; /* Function Body */ if (*m == 0) { goto L200; } la = *igh - 1; kp1 = *low + 1; if (la < kp1) { goto L200; } /* .......... FOR MP=IGH-1 STEP -1 UNTIL LOW+1 DO -- .......... */ i_1 = la; for (mm = kp1; mm <= i_1; ++mm) { mp = *low + *igh - mm; mp1 = mp + 1; i_2 = *igh; for (i = mp1; i <= i_2; ++i) { x = a[i + (mp - 1) * a_dim1]; if (x == 0.) { goto L110; } i_3 = *m; for (j = 1; j <= i_3; ++j) { /* L100: */ z[i + j * z_dim1] += x * z[mp + j * z_dim1]; } L110: ; } i = int_[mp]; if (i == mp) { goto L140; } i_2 = *m; for (j = 1; j <= i_2; ++j) { x = z[i + j * z_dim1]; z[i + j * z_dim1] = z[mp + j * z_dim1]; z[mp + j * z_dim1] = x; /* L130: */ } L140: ; } L200: return 0; } /* elmbak_ */ /* Subroutine */ int elmhes_(integer *nm, integer *n, integer *low, integer * igh, doublereal *a, integer *int_) { /* System generated locals */ integer a_dim1, a_offset, i_1, i_2, i_3; doublereal d_1; /* Local variables */ static integer i, j, m; static doublereal x, y; static integer la, mm1, kp1, mp1; /* THIS SUBROUTINE IS A TRANSLATION OF THE ALGOL PROCEDURE ELMHES, */ /* NUM. MATH. 12, 349-368(1968) BY MARTIN AND WILKINSON. */ /* HANDBOOK FOR AUTO. COMP., VOL.II-LINEAR ALGEBRA, 339-358(1971). */ /* GIVEN A REAL GENERAL MATRIX, THIS SUBROUTINE */ /* REDUCES A SUBMATRIX SITUATED IN ROWS AND COLUMNS */ /* LOW THROUGH IGH TO UPPER HESSENBERG FORM BY */ /* STABILIZED ELEMENTARY SIMILARITY TRANSFORMATIONS. */ /* ON INPUT */ /* NM MUST BE SET TO THE ROW DIMENSION OF TWO-DIMENSIONAL */ /* ARRAY PARAMETERS AS DECLARED IN THE CALLING PROGRAM */ /* DIMENSION STATEMENT. */ /* N IS THE ORDER OF THE MATRIX. */ /* LOW AND IGH ARE INTEGERS DETERMINED BY THE BALANCING */ /* SUBROUTINE BALANC. IF BALANC HAS NOT BEEN USED, */ /* SET LOW=1, IGH=N. */ /* A CONTAINS THE INPUT MATRIX. */ /* ON OUTPUT */ /* A CONTAINS THE HESSENBERG MATRIX. THE MULTIPLIERS */ /* WHICH WERE USED IN THE REDUCTION ARE STORED IN THE */ /* REMAINING TRIANGLE UNDER THE HESSENBERG MATRIX. */ /* INT CONTAINS INFORMATION ON THE ROWS AND COLUMNS */ /* INTERCHANGED IN THE REDUCTION. */ /* ONLY ELEMENTS LOW THROUGH IGH ARE USED. */ /* 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 */ a_dim1 = *nm; a_offset = a_dim1 + 1; a -= a_offset; --int_; /* Function Body */ la = *igh - 1; kp1 = *low + 1; if (la < kp1) { goto L200; } i_1 = la; for (m = kp1; m <= i_1; ++m) { mm1 = m - 1; x = 0.; i = m; i_2 = *igh; for (j = m; j <= i_2; ++j) { if ((d_1 = a[j + mm1 * a_dim1], abs(d_1)) <= abs(x)) { goto L100; } x = a[j + mm1 * a_dim1]; i = j; L100: ; } int_[m] = i; if (i == m) { goto L130; } /* .......... INTERCHANGE ROWS AND COLUMNS OF A .......... */ i_2 = *n; for (j = mm1; j <= i_2; ++j) { y = a[i + j * a_dim1]; a[i + j * a_dim1] = a[m + j * a_dim1]; a[m + j * a_dim1] = y; /* L110: */ } i_2 = *igh; for (j = 1; j <= i_2; ++j) { y = a[j + i * a_dim1]; a[j + i * a_dim1] = a[j + m * a_dim1]; a[j + m * a_dim1] = y; /* L120: */ } /* .......... END INTERCHANGE .......... */ L130: if (x == 0.) { goto L180; } mp1 = m + 1; i_2 = *igh; for (i = mp1; i <= i_2; ++i) { y = a[i + mm1 * a_dim1]; if (y == 0.) { goto L160; } y /= x; a[i + mm1 * a_dim1] = y; i_3 = *n; for (j = m; j <= i_3; ++j) { /* L140: */ a[i + j * a_dim1] -= y * a[m + j * a_dim1]; } i_3 = *igh; for (j = 1; j <= i_3; ++j) { /* L150: */ a[j + m * a_dim1] += y * a[j + i * a_dim1]; } L160: ; } L180: ; } L200: return 0; } /* elmhes_ */ /* Subroutine */ int eltran_(integer *nm, integer *n, integer *low, integer * igh, doublereal *a, integer *int_, doublereal *z) { /* System generated locals */ integer a_dim1, a_offset, z_dim1, z_offset, i_1, i_2; /* Local variables */ static integer i, j, kl, mm, mp, mp1; /* THIS SUBROUTINE IS A TRANSLATION OF THE ALGOL PROCEDURE ELMTRANS, */ /* NUM. MATH. 16, 181-204(1970) BY PETERS AND WILKINSON. */ /* HANDBOOK FOR AUTO. COMP., VOL.II-LINEAR ALGEBRA, 372-395(1971). */ /* THIS SUBROUTINE ACCUMULATES THE STABILIZED ELEMENTARY */ /* SIMILARITY TRANSFORMATIONS USED IN THE REDUCTION OF A */ /* REAL GENERAL MATRIX TO UPPER HESSENBERG FORM BY ELMHES. */ /* ON INPUT */ /* NM MUST BE SET TO THE ROW DIMENSION OF TWO-DIMENSIONAL */ /* ARRAY PARAMETERS AS DECLARED IN THE CALLING PROGRAM */ /* DIMENSION STATEMENT. */ /* N IS THE ORDER OF THE MATRIX. */ /* LOW AND IGH ARE INTEGERS DETERMINED BY THE BALANCING */ /* SUBROUTINE BALANC. IF BALANC HAS NOT BEEN USED, */ /* SET LOW=1, IGH=N. */ /* A CONTAINS THE MULTIPLIERS WHICH WERE USED IN THE */ /* REDUCTION BY ELMHES IN ITS LOWER TRIANGLE */ /* BELOW THE SUBDIAGONAL. */ /* INT CONTAINS INFORMATION ON THE ROWS AND COLUMNS */ /* INTERCHANGED IN THE REDUCTION BY ELMHES. */ /* ONLY ELEMENTS LOW THROUGH IGH ARE USED. */ /* ON OUTPUT */ /* Z CONTAINS THE TRANSFORMATION MATRIX PRODUCED IN THE */ /* REDUCTION BY ELMHES. */ /* QUESTIONS AND COMMENTS SHOULD BE DIRECTED TO BURTON S. GARBOW, */ /* MATHEMATICS AND COMPUTER SCIENCE DIV, ARGONNE NATIONAL LABORATORY */ /* THIS VERSION DATED AUGUST 1983. */ /* ------------------------------------------------------------------ */ /* .......... INITIALIZE Z TO IDENTITY MATRIX .......... */ /* Parameter adjustments */ z_dim1 = *nm; z_offset = z_dim1 + 1; z -= z_offset; --int_; a_dim1 = *nm; a_offset = a_dim1 + 1; a -= a_offset; /* Function Body */ i_1 = *n; for (j = 1; j <= i_1; ++j) { i_2 = *n; for (i = 1; i <= i_2; ++i) { /* L60: */ z[i + j * z_dim1] = 0.; } z[j + j * z_dim1] = 1.; /* L80: */ } kl = *igh - *low - 1; if (kl < 1) { goto L200; } /* .......... FOR MP=IGH-1 STEP -1 UNTIL LOW+1 DO -- .......... */ i_1 = kl; for (mm = 1; mm <= i_1; ++mm) { mp = *igh - mm; mp1 = mp + 1; i_2 = *igh; for (i = mp1; i <= i_2; ++i) { /* L100: */ z[i + mp * z_dim1] = a[i + (mp - 1) * a_dim1]; } i = int_[mp]; if (i == mp) { goto L140; } i_2 = *igh; for (j = mp; j <= i_2; ++j) { z[mp + j * z_dim1] = z[i + j * z_dim1]; z[i + j * z_dim1] = 0.; /* L130: */ } z[i + mp * z_dim1] = 1.; L140: ; } L200: return 0; } /* eltran_ */ /* Subroutine */ int figi_(integer *nm, integer *n, doublereal *t, doublereal *d, doublereal *e, doublereal *e2, integer *ierr) { /* System generated locals */ integer t_dim1, t_offset, i_1; doublereal d_1; /* Builtin functions */ double sqrt(doublereal); /* Local variables */ static integer i; /* GIVEN A NONSYMMETRIC TRIDIAGONAL MATRIX SUCH THAT THE PRODUCTS */ /* OF CORRESPONDING PAIRS OF OFF-DIAGONAL ELEMENTS ARE ALL */ /* NON-NEGATIVE, THIS SUBROUTINE REDUCES IT TO A SYMMETRIC */ /* TRIDIAGONAL MATRIX WITH THE SAME EIGENVALUES. IF, FURTHER, */ /* A ZERO PRODUCT ONLY OCCURS WHEN BOTH FACTORS ARE ZERO, */ /* THE REDUCED MATRIX IS SIMILAR TO THE ORIGINAL MATRIX. */ /* ON INPUT */ /* NM MUST BE SET TO THE ROW DIMENSION OF TWO-DIMENSIONAL */ /* ARRAY PARAMETERS AS DECLARED IN THE CALLING PROGRAM */ /* DIMENSION STATEMENT. */ /* N IS THE ORDER OF THE MATRIX. */ /* T CONTAINS THE INPUT MATRIX. ITS SUBDIAGONAL IS */ /* STORED IN THE LAST N-1 POSITIONS OF THE FIRST COLUMN, */ /* ITS DIAGONAL IN THE N POSITIONS OF THE SECOND COLUMN, */ /* AND ITS SUPERDIAGONAL IN THE FIRST N-1 POSITIONS OF */ /* THE THIRD COLUMN. T(1,1) AND T(N,3) ARE ARBITRARY. */ /* ON OUTPUT */ /* T IS UNALTERED. */ /* D CONTAINS THE DIAGONAL ELEMENTS OF THE SYMMETRIC MATRIX. */ /* E CONTAINS THE SUBDIAGONAL ELEMENTS OF THE SYMMETRIC */ /* MATRIX IN ITS LAST N-1 POSITIONS. E(1) IS NOT SET. */ /* E2 CONTAINS THE SQUARES OF THE CORRESPONDING ELEMENTS OF E. */ /* E2 MAY COINCIDE WITH E IF THE SQUARES ARE NOT NEEDED. */ /* IERR IS SET TO */ /* ZERO FOR NORMAL RETURN, */ /* N+I IF T(I,1)*T(I-1,3) IS NEGATIVE, */ /* -(3*N+I) IF T(I,1)*T(I-1,3) IS ZERO WITH ONE FACTOR */ /* NON-ZERO. IN THIS CASE, THE EIGENVECTORS OF */ /* THE SYMMETRIC MATRIX ARE NOT SIMPLY RELATED */ /* TO THOSE OF T AND SHOULD NOT BE SOUGHT. */ /* 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 */ t_dim1 = *nm; t_offset = t_dim1 + 1; t -= t_offset; --e2; --e; --d; /* Function Body */ *ierr = 0; i_1 = *n; for (i = 1; i <= i_1; ++i) { if (i == 1) { goto L90; } e2[i] = t[i + t_dim1] * t[i - 1 + t_dim1 * 3]; if ((d_1 = e2[i]) < 0.) { goto L1000; } else if (d_1 == 0) { goto L60; } else { goto L80; } L60: if (t[i + t_dim1] == 0. && t[i - 1 + t_dim1 * 3] == 0.) { goto L80; } /* .......... SET ERROR -- PRODUCT OF SOME PAIR OF OFF-DIAGONAL */ /* ELEMENTS IS ZERO WITH ONE MEMBER NON-ZERO .......... */ *ierr = -(*n * 3 + i); L80: e[i] = sqrt(e2[i]); L90: d[i] = t[i + (t_dim1 << 1)]; /* L100: */ } goto L1001; /* .......... SET ERROR -- PRODUCT OF SOME PAIR OF OFF-DIAGONAL */ /* ELEMENTS IS NEGATIVE .......... */ L1000: *ierr = *n + i; L1001: return 0; } /* figi_ */ /* Subroutine */ int figi2_(integer *nm, integer *n, doublereal *t, doublereal *d, doublereal *e, doublereal *z, integer *ierr) { /* System generated locals */ integer t_dim1, t_offset, z_dim1, z_offset, i_1, i_2; /* Builtin functions */ double sqrt(doublereal); /* Local variables */ static doublereal h; static integer i, j; /* GIVEN A NONSYMMETRIC TRIDIAGONAL MATRIX SUCH THAT THE PRODUCTS */ /* OF CORRESPONDING PAIRS OF OFF-DIAGONAL ELEMENTS ARE ALL */ /* NON-NEGATIVE, AND ZERO ONLY WHEN BOTH FACTORS ARE ZERO, THIS */ /* SUBROUTINE REDUCES IT TO A SYMMETRIC TRIDIAGONAL MATRIX */ /* USING AND ACCUMULATING DIAGONAL SIMILARITY TRANSFORMATIONS. */ /* ON INPUT */ /* NM MUST BE SET TO THE ROW DIMENSION OF TWO-DIMENSIONAL */ /* ARRAY PARAMETERS AS DECLARED IN THE CALLING PROGRAM */ /* DIMENSION STATEMENT. */ /* N IS THE ORDER OF THE MATRIX. */ /* T CONTAINS THE INPUT MATRIX. ITS SUBDIAGONAL IS */ /* STORED IN THE LAST N-1 POSITIONS OF THE FIRST COLUMN, */ /* ITS DIAGONAL IN THE N POSITIONS OF THE SECOND COLUMN, */ /* AND ITS SUPERDIAGONAL IN THE FIRST N-1 POSITIONS OF */ /* THE THIRD COLUMN. T(1,1) AND T(N,3) ARE ARBITRARY. */ /* ON OUTPUT */ /* T IS UNALTERED. */ /* D CONTAINS THE DIAGONAL ELEMENTS OF THE SYMMETRIC MATRIX. */ /* E CONTAINS THE SUBDIAGONAL ELEMENTS OF THE SYMMETRIC */ /* MATRIX IN ITS LAST N-1 POSITIONS. E(1) IS NOT SET. */ /* Z CONTAINS THE TRANSFORMATION MATRIX PRODUCED IN */ /* THE REDUCTION. */ /* IERR IS SET TO */ /* ZERO FOR NORMAL RETURN, */ /* N+I IF T(I,1)*T(I-1,3) IS NEGATIVE, */ /* 2*N+I IF T(I,1)*T(I-1,3) IS ZERO WITH */ /* ONE FACTOR NON-ZERO. */ /* 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 */ t_dim1 = *nm; t_offset = t_dim1 + 1; t -= t_offset; z_dim1 = *nm; z_offset = z_dim1 + 1; z -= z_offset; --e; --d; /* Function Body */ *ierr = 0; i_1 = *n; for (i = 1; i <= i_1; ++i) { i_2 = *n; for (j = 1; j <= i_2; ++j) { /* L50: */ z[i + j * z_dim1] = 0.; } if (i == 1) { goto L70; } h = t[i + t_dim1] * t[i - 1 + t_dim1 * 3]; if (h < 0.) { goto L900; } else if (h == 0) { goto L60; } else { goto L80; } L60: if (t[i + t_dim1] != 0. || t[i - 1 + t_dim1 * 3] != 0.) { goto L1000; } e[i] = 0.; L70: z[i + i * z_dim1] = 1.; goto L90; L80: e[i] = sqrt(h); z[i + i * z_dim1] = z[i - 1 + (i - 1) * z_dim1] * e[i] / t[i - 1 + t_dim1 * 3]; L90: d[i] = t[i + (t_dim1 << 1)]; /* L100: */ } goto L1001; /* .......... SET ERROR -- PRODUCT OF SOME PAIR OF OFF-DIAGONAL */ /* ELEMENTS IS NEGATIVE .......... */ L900: *ierr = *n + i; goto L1001; /* .......... SET ERROR -- PRODUCT OF SOME PAIR OF OFF-DIAGONAL */ /* ELEMENTS IS ZERO WITH ONE MEMBER NON-ZERO .......... */ L1000: *ierr = (*n << 1) + i; L1001: return 0; } /* figi2_ */ /* Subroutine */ int hqr_(integer *nm, integer *n, integer *low, integer *igh, doublereal *h, doublereal *wr, doublereal *wi, integer *ierr) { /* System generated locals */ integer h_dim1, h_offset, i_1, i_2, i_3; doublereal d_1, d_2; /* Builtin functions */ double sqrt(doublereal), d_sign(doublereal *, doublereal *); /* Local variables */ static doublereal norm; static integer i, j, k, l, m; static doublereal p, q, r, s, t, w, x, y; static integer na, en, ll, mm; static doublereal zz; static logical notlas; static integer mp2, itn, its, enm2; static doublereal tst1, tst2; /* THIS SUBROUTINE IS A TRANSLATION OF THE ALGOL PROCEDURE HQR, */ /* NUM. MATH. 14, 219-231(1970) BY MARTIN, PETERS, AND WILKINSON. */ /* HANDBOOK FOR AUTO. COMP., VOL.II-LINEAR ALGEBRA, 359-371(1971). */ /* THIS SUBROUTINE FINDS THE EIGENVALUES OF A REAL */ /* UPPER HESSENBERG MATRIX BY THE QR METHOD. */ /* ON INPUT */ /* NM MUST BE SET TO THE ROW DIMENSION OF TWO-DIMENSIONAL */ /* ARRAY PARAMETERS AS DECLARED IN THE CALLING PROGRAM */ /* DIMENSION STATEMENT. */ /* N IS THE ORDER OF THE MATRIX. */ /* LOW AND IGH ARE INTEGERS DETERMINED BY THE BALANCING */ /* SUBROUTINE BALANC. IF BALANC HAS NOT BEEN USED, */ /* SET LOW=1, IGH=N. */ /* H CONTAINS THE UPPER HESSENBERG MATRIX. INFORMATION ABOUT */ /* THE TRANSFORMATIONS USED IN THE REDUCTION TO HESSENBERG */ /* FORM BY ELMHES OR ORTHES, IF PERFORMED, IS STORED */ /* IN THE REMAINING TRIANGLE UNDER THE HESSENBERG MATRIX. */ /* ON OUTPUT */ /* H HAS BEEN DESTROYED. THEREFORE, IT MUST BE SAVED */ /* BEFORE CALLING HQR IF SUBSEQUENT CALCULATION AND */ /* BACK TRANSFORMATION OF EIGENVECTORS IS TO BE PERFORMED. */ /* WR AND WI CONTAIN THE REAL AND IMAGINARY PARTS, */ /* RESPECTIVELY, OF THE EIGENVALUES. THE EIGENVALUES */ /* ARE UNORDERED EXCEPT THAT COMPLEX CONJUGATE PAIRS */ /* OF VALUES APPEAR CONSECUTIVELY WITH THE EIGENVALUE */ /* HAVING THE POSITIVE IMAGINARY PART FIRST. IF AN */ /* ERROR EXIT IS MADE, THE EIGENVALUES SHOULD BE CORRECT */ /* FOR INDICES IERR+1,...,N. */ /* IERR IS SET TO */ /* ZERO FOR NORMAL RETURN, */ /* J IF THE LIMIT OF 30*N ITERATIONS IS EXHAUSTED */ /* WHILE THE J-TH EIGENVALUE IS BEING SOUGHT. */ /* 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 */ --wi; --wr; h_dim1 = *nm; h_offset = h_dim1 + 1; h -= h_offset; /* Function Body */ *ierr = 0; norm = 0.; k = 1; /* .......... STORE ROOTS ISOLATED BY BALANC */ /* AND COMPUTE MATRIX NORM .......... */ i_1 = *n; for (i = 1; i <= i_1; ++i) { i_2 = *n; for (j = k; j <= i_2; ++j) { /* L40: */ norm += (d_1 = h[i + j * h_dim1], abs(d_1)); } k = i; if (i >= *low && i <= *igh) { goto L50; } wr[i] = h[i + i * h_dim1]; wi[i] = 0.; L50: ; } en = *igh; t = 0.; itn = *n * 30; /* .......... SEARCH FOR NEXT EIGENVALUES .......... */ L60: if (en < *low) { goto L1001; } its = 0; na = en - 1; enm2 = na - 1; /* .......... LOOK FOR SINGLE SMALL SUB-DIAGONAL ELEMENT */ /* FOR L=EN STEP -1 UNTIL LOW DO -- .......... */ L70: i_1 = en; for (ll = *low; ll <= i_1; ++ll) { l = en + *low - ll; if (l == *low) { goto L100; } s = (d_1 = h[l - 1 + (l - 1) * h_dim1], abs(d_1)) + (d_2 = h[l + l * h_dim1], abs(d_2)); if (s == 0.) { s = norm; } tst1 = s; tst2 = tst1 + (d_1 = h[l + (l - 1) * h_dim1], abs(d_1)); if (tst2 == tst1) { goto L100; } /* L80: */ } /* .......... FORM SHIFT .......... */ L100: x = h[en + en * h_dim1]; if (l == en) { goto L270; } y = h[na + na * h_dim1]; w = h[en + na * h_dim1] * h[na + en * h_dim1]; if (l == na) { goto L280; } if (itn == 0) { goto L1000; } if (its != 10 && its != 20) { goto L130; } /* .......... FORM EXCEPTIONAL SHIFT .......... */ t += x; i_1 = en; for (i = *low; i <= i_1; ++i) { /* L120: */ h[i + i * h_dim1] -= x; } s = (d_1 = h[en + na * h_dim1], abs(d_1)) + (d_2 = h[na + enm2 * h_dim1], abs(d_2)); x = s * .75; y = x; w = s * -.4375 * s; L130: ++its; --itn; /* .......... LOOK FOR TWO CONSECUTIVE SMALL */ /* SUB-DIAGONAL ELEMENTS. */ /* FOR M=EN-2 STEP -1 UNTIL L DO -- .......... */ i_1 = enm2; for (mm = l; mm <= i_1; ++mm) { m = enm2 + l - mm; zz = h[m + m * h_dim1]; r = x - zz; s = y - zz; p = (r * s - w) / h[m + 1 + m * h_dim1] + h[m + (m + 1) * h_dim1]; q = h[m + 1 + (m + 1) * h_dim1] - zz - r - s; r = h[m + 2 + (m + 1) * h_dim1]; s = abs(p) + abs(q) + abs(r); p /= s; q /= s; r /= s; if (m == l) { goto L150; } tst1 = abs(p) * ((d_1 = h[m - 1 + (m - 1) * h_dim1], abs(d_1)) + abs(zz) + (d_2 = h[m + 1 + (m + 1) * h_dim1], abs(d_2))); tst2 = tst1 + (d_1 = h[m + (m - 1) * h_dim1], abs(d_1)) * (abs(q) + abs(r)); if (tst2 == tst1) { goto L150; } /* L140: */ } L150: mp2 = m + 2; i_1 = en; for (i = mp2; i <= i_1; ++i) { h[i + (i - 2) * h_dim1] = 0.; if (i == mp2) { goto L160; } h[i + (i - 3) * h_dim1] = 0.; L160: ; } /* .......... DOUBLE QR STEP INVOLVING ROWS L TO EN AND */ /* COLUMNS M TO EN .......... */ i_1 = na; for (k = m; k <= i_1; ++k) { notlas = k != na; if (k == m) { goto L170; } p = h[k + (k - 1) * h_dim1]; q = h[k + 1 + (k - 1) * h_dim1]; r = 0.; if (notlas) { r = h[k + 2 + (k - 1) * h_dim1]; } x = abs(p) + abs(q) + abs(r); if (x == 0.) { goto L260; } p /= x; q /= x; r /= x; L170: d_1 = sqrt(p * p + q * q + r * r); s = d_sign(&d_1, &p); if (k == m) { goto L180; } h[k + (k - 1) * h_dim1] = -s * x; goto L190; L180: if (l != m) { h[k + (k - 1) * h_dim1] = -h[k + (k - 1) * h_dim1]; } L190: p += s; x = p / s; y = q / s; zz = r / s; q /= p; r /= p; if (notlas) { goto L225; } /* .......... ROW MODIFICATION .......... */ i_2 = *n; for (j = k; j <= i_2; ++j) { p = h[k + j * h_dim1] + q * h[k + 1 + j * h_dim1]; h[k + j * h_dim1] -= p * x; h[k + 1 + j * h_dim1] -= p * y; /* L200: */ } /* Computing MIN */ i_2 = en, i_3 = k + 3; j = min(i_2,i_3); /* .......... COLUMN MODIFICATION .......... */ i_2 = j; for (i = 1; i <= i_2; ++i) { p = x * h[i + k * h_dim1] + y * h[i + (k + 1) * h_dim1]; h[i + k * h_dim1] -= p; h[i + (k + 1) * h_dim1] -= p * q; /* L210: */ } goto L255; L225: /* .......... ROW MODIFICATION .......... */ i_2 = *n; for (j = k; j <= i_2; ++j) { p = h[k + j * h_dim1] + q * h[k + 1 + j * h_dim1] + r * h[k + 2 + j * h_dim1]; h[k + j * h_dim1] -= p * x; h[k + 1 + j * h_dim1] -= p * y; h[k + 2 + j * h_dim1] -= p * zz; /* L230: */ } /* Computing MIN */ i_2 = en, i_3 = k + 3; j = min(i_2,i_3); /* .......... COLUMN MODIFICATION .......... */ i_2 = j; for (i = 1; i <= i_2; ++i) { p = x * h[i + k * h_dim1] + y * h[i + (k + 1) * h_dim1] + zz * h[ i + (k + 2) * h_dim1]; h[i + k * h_dim1] -= p; h[i + (k + 1) * h_dim1] -= p * q; h[i + (k + 2) * h_dim1] -= p * r; /* L240: */ } L255: L260: ; } goto L70; /* .......... ONE ROOT FOUND .......... */ L270: wr[en] = x + t; wi[en] = 0.; en = na; goto L60; /* .......... TWO ROOTS FOUND .......... */ L280: p = (y - x) / 2.; q = p * p + w; zz = sqrt((abs(q))); x += t; if (q < 0.) { goto L320; } /* .......... REAL PAIR .......... */ zz = p + d_sign(&zz, &p); wr[na] = x + zz; wr[en] = wr[na]; if (zz != 0.) { wr[en] = x - w / zz; } wi[na] = 0.; wi[en] = 0.; goto L330; /* .......... COMPLEX PAIR .......... */ L320: wr[na] = x + p; wr[en] = x + p; wi[na] = zz; wi[en] = -zz; L330: en = enm2; goto L60; /* .......... SET ERROR -- ALL EIGENVALUES HAVE NOT */ /* CONVERGED AFTER 30*N ITERATIONS .......... */ L1000: *ierr = en; L1001: return 0; } /* hqr_ */ /* Subroutine */ int hqr2_(integer *nm, integer *n, integer *low, integer * igh, doublereal *h, doublereal *wr, doublereal *wi, doublereal *z, integer *ierr) { /* System generated locals */ integer h_dim1, h_offset, z_dim1, z_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 */ extern /* Subroutine */ int cdiv_(doublereal *, doublereal *, doublereal * , doublereal *, doublereal *, doublereal *); static doublereal norm; static integer i, j, k, l, m; static doublereal p, q, r, s, t, w, x, y; static integer na, ii, en, jj; static doublereal ra, sa; static integer ll, mm, nn; static doublereal vi, vr, zz; static logical notlas; static integer mp2, itn, its, enm2; static doublereal tst1, tst2; /* THIS SUBROUTINE IS A TRANSLATION OF THE ALGOL PROCEDURE HQR2, */ /* NUM. MATH. 16, 181-204(1970) BY PETERS AND WILKINSON. */ /* HANDBOOK FOR AUTO. COMP., VOL.II-LINEAR ALGEBRA, 372-395(1971). */ /* THIS SUBROUTINE FINDS THE EIGENVALUES AND EIGENVECTORS */ /* OF A REAL UPPER HESSENBERG MATRIX BY THE QR METHOD. THE */ /* EIGENVECTORS OF A REAL GENERAL MATRIX CAN ALSO BE FOUND */ /* IF ELMHES AND ELTRAN OR ORTHES AND ORTRAN HAVE */ /* BEEN USED TO REDUCE THIS GENERAL MATRIX TO HESSENBERG FORM */ /* AND TO ACCUMULATE THE SIMILARITY TRANSFORMATIONS. */ /* ON INPUT */ /* NM MUST BE SET TO THE ROW DIMENSION OF TWO-DIMENSIONAL */ /* ARRAY PARAMETERS AS DECLARED IN THE CALLING PROGRAM */ /* DIMENSION STATEMENT. */ /* N IS THE ORDER OF THE MATRIX. */ /* LOW AND IGH ARE INTEGERS DETERMINED BY THE BALANCING */ /* SUBROUTINE BALANC. IF BALANC HAS NOT BEEN USED, */ /* SET LOW=1, IGH=N. */ /* H CONTAINS THE UPPER HESSENBERG MATRIX. */ /* Z CONTAINS THE TRANSFORMATION MATRIX PRODUCED BY ELTRAN */ /* AFTER THE REDUCTION BY ELMHES, OR BY ORTRAN AFTER THE */ /* REDUCTION BY ORTHES, IF PERFORMED. IF THE EIGENVECTORS */ /* OF THE HESSENBERG MATRIX ARE DESIRED, Z MUST CONTAIN THE */ /* IDENTITY MATRIX. */ /* ON OUTPUT */ /* H HAS BEEN DESTROYED. */ /* WR AND WI CONTAIN THE REAL AND IMAGINARY PARTS, */ /* RESPECTIVELY, OF THE EIGENVALUES. THE EIGENVALUES */ /* ARE UNORDERED EXCEPT THAT COMPLEX CONJUGATE PAIRS */ /* OF VALUES APPEAR CONSECUTIVELY WITH THE EIGENVALUE */ /* HAVING THE POSITIVE IMAGINARY PART FIRST. IF AN */ /* ERROR EXIT IS MADE, THE EIGENVALUES SHOULD BE CORRECT */ /* FOR INDICES IERR+1,...,N. */ /* Z CONTAINS THE REAL AND IMAGINARY PARTS OF THE EIGENVECTORS. */ /* IF THE I-TH EIGENVALUE IS REAL, THE I-TH COLUMN OF Z */ /* CONTAINS ITS EIGENVECTOR. IF THE I-TH EIGENVALUE IS COMPLEX */ /* WITH POSITIVE IMAGINARY PART, THE I-TH AND (I+1)-TH */ /* COLUMNS OF Z CONTAIN THE REAL AND IMAGINARY PARTS OF ITS */ /* EIGENVECTOR. THE EIGENVECTORS ARE UNNORMALIZED. IF AN */ /* ERROR EXIT IS MADE, NONE OF THE EIGENVECTORS HAS BEEN FOUND. */ /* IERR IS SET TO */ /* ZERO FOR NORMAL RETURN, */ /* J IF THE LIMIT OF 30*N ITERATIONS IS EXHAUSTED */ /* WHILE THE J-TH EIGENVALUE IS BEING SOUGHT. */ /* CALLS CDIV FOR COMPLEX DIVISION. */ /* 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 */ z_dim1 = *nm; z_offset = z_dim1 + 1; z -= z_offset; --wi; --wr; h_dim1 = *nm; h_offset = h_dim1 + 1; h -= h_offset; /* Function Body */ *ierr = 0; norm = 0.; k = 1; /* .......... STORE ROOTS ISOLATED BY BALANC */ /* AND COMPUTE MATRIX NORM .......... */ i_1 = *n; for (i = 1; i <= i_1; ++i) { i_2 = *n; for (j = k; j <= i_2; ++j) { /* L40: */ norm += (d_1 = h[i + j * h_dim1], abs(d_1)); } k = i; if (i >= *low && i <= *igh) { goto L50; } wr[i] = h[i + i * h_dim1]; wi[i] = 0.; L50: ; } en = *igh; t = 0.; itn = *n * 30; /* .......... SEARCH FOR NEXT EIGENVALUES .......... */ L60: if (en < *low) { goto L340; } its = 0; na = en - 1; enm2 = na - 1; /* .......... LOOK FOR SINGLE SMALL SUB-DIAGONAL ELEMENT */ /* FOR L=EN STEP -1 UNTIL LOW DO -- .......... */ L70: i_1 = en; for (ll = *low; ll <= i_1; ++ll) { l = en + *low - ll; if (l == *low) { goto L100; } s = (d_1 = h[l - 1 + (l - 1) * h_dim1], abs(d_1)) + (d_2 = h[l + l * h_dim1], abs(d_2)); if (s == 0.) { s = norm; } tst1 = s; tst2 = tst1 + (d_1 = h[l + (l - 1) * h_dim1], abs(d_1)); if (tst2 == tst1) { goto L100; } /* L80: */ } /* .......... FORM SHIFT .......... */ L100: x = h[en + en * h_dim1]; if (l == en) { goto L270; } y = h[na + na * h_dim1]; w = h[en + na * h_dim1] * h[na + en * h_dim1]; if (l == na) { goto L280; } if (itn == 0) { goto L1000; } if (its != 10 && its != 20) { goto L130; } /* .......... FORM EXCEPTIONAL SHIFT .......... */ t += x; i_1 = en; for (i = *low; i <= i_1; ++i) { /* L120: */ h[i + i * h_dim1] -= x; } s = (d_1 = h[en + na * h_dim1], abs(d_1)) + (d_2 = h[na + enm2 * h_dim1], abs(d_2)); x = s * .75; y = x; w = s * -.4375 * s; L130: ++its; --itn; /* .......... LOOK FOR TWO CONSECUTIVE SMALL */ /* SUB-DIAGONAL ELEMENTS. */ /* FOR M=EN-2 STEP -1 UNTIL L DO -- .......... */ i_1 = enm2; for (mm = l; mm <= i_1; ++mm) { m = enm2 + l - mm; zz = h[m + m * h_dim1]; r = x - zz; s = y - zz; p = (r * s - w) / h[m + 1 + m * h_dim1] + h[m + (m + 1) * h_dim1]; q = h[m + 1 + (m + 1) * h_dim1] - zz - r - s; r = h[m + 2 + (m + 1) * h_dim1]; s = abs(p) + abs(q) + abs(r); p /= s; q /= s; r /= s; if (m == l) { goto L150; } tst1 = abs(p) * ((d_1 = h[m - 1 + (m - 1) * h_dim1], abs(d_1)) + abs(zz) + (d_2 = h[m + 1 + (m + 1) * h_dim1], abs(d_2))); tst2 = tst1 + (d_1 = h[m + (m - 1) * h_dim1], abs(d_1)) * (abs(q) + abs(r)); if (tst2 == tst1) { goto L150; } /* L140: */ } L150: mp2 = m + 2; i_1 = en; for (i = mp2; i <= i_1; ++i) { h[i + (i - 2) * h_dim1] = 0.; if (i == mp2) { goto L160; } h[i + (i - 3) * h_dim1] = 0.; L160: ; } /* .......... DOUBLE QR STEP INVOLVING ROWS L TO EN AND */ /* COLUMNS M TO EN .......... */ i_1 = na; for (k = m; k <= i_1; ++k) { notlas = k != na; if (k == m) { goto L170; } p = h[k + (k - 1) * h_dim1]; q = h[k + 1 + (k - 1) * h_dim1]; r = 0.; if (notlas) { r = h[k + 2 + (k - 1) * h_dim1]; } x = abs(p) + abs(q) + abs(r); if (x == 0.) { goto L260; } p /= x; q /= x; r /= x; L170: d_1 = sqrt(p * p + q * q + r * r); s = d_sign(&d_1, &p); if (k == m) { goto L180; } h[k + (k - 1) * h_dim1] = -s * x; goto L190; L180: if (l != m) { h[k + (k - 1) * h_dim1] = -h[k + (k - 1) * h_dim1]; } L190: p += s; x = p / s; y = q / s; zz = r / s; q /= p; r /= p; if (notlas) { goto L225; } /* .......... ROW MODIFICATION .......... */ i_2 = *n; for (j = k; j <= i_2; ++j) { p = h[k + j * h_dim1] + q * h[k + 1 + j * h_dim1]; h[k + j * h_dim1] -= p * x; h[k + 1 + j * h_dim1] -= p * y; /* L200: */ } /* Computing MIN */ i_2 = en, i_3 = k + 3; j = min(i_2,i_3); /* .......... COLUMN MODIFICATION .......... */ i_2 = j; for (i = 1; i <= i_2; ++i) { p = x * h[i + k * h_dim1] + y * h[i + (k + 1) * h_dim1]; h[i + k * h_dim1] -= p; h[i + (k + 1) * h_dim1] -= p * q; /* L210: */ } /* .......... ACCUMULATE TRANSFORMATIONS .......... */ i_2 = *igh; for (i = *low; i <= i_2; ++i) { p = x * z[i + k * z_dim1] + y * z[i + (k + 1) * z_dim1]; z[i + k * z_dim1] -= p; z[i + (k + 1) * z_dim1] -= p * q; /* L220: */ } goto L255; L225: /* .......... ROW MODIFICATION .......... */ i_2 = *n; for (j = k; j <= i_2; ++j) { p = h[k + j * h_dim1] + q * h[k + 1 + j * h_dim1] + r * h[k + 2 + j * h_dim1]; h[k + j * h_dim1] -= p * x; h[k + 1 + j * h_dim1] -= p * y; h[k + 2 + j * h_dim1] -= p * zz; /* L230: */ } /* Computing MIN */ i_2 = en, i_3 = k + 3; j = min(i_2,i_3); /* .......... COLUMN MODIFICATION .......... */ i_2 = j; for (i = 1; i <= i_2; ++i) { p = x * h[i + k * h_dim1] + y * h[i + (k + 1) * h_dim1] + zz * h[ i + (k + 2) * h_dim1]; h[i + k * h_dim1] -= p; h[i + (k + 1) * h_dim1] -= p * q; h[i + (k + 2) * h_dim1] -= p * r; /* L240: */ } /* .......... ACCUMULATE TRANSFORMATIONS .......... */ i_2 = *igh; for (i = *low; i <= i_2; ++i) { p = x * z[i + k * z_dim1] + y * z[i + (k + 1) * z_dim1] + zz * z[ i + (k + 2) * z_dim1]; z[i + k * z_dim1] -= p; z[i + (k + 1) * z_dim1] -= p * q; z[i + (k + 2) * z_dim1] -= p * r; /* L250: */ } L255: L260: ; } goto L70; /* .......... ONE ROOT FOUND .......... */ L270: h[en + en * h_dim1] = x + t; wr[en] = h[en + en * h_dim1]; wi[en] = 0.; en = na; goto L60; /* .......... TWO ROOTS FOUND .......... */ L280: p = (y - x) / 2.; q = p * p + w; zz = sqrt((abs(q))); h[en + en * h_dim1] = x + t; x = h[en + en * h_dim1]; h[na + na * h_dim1] = y + t; if (q < 0.) { goto L320; } /* .......... REAL PAIR .......... */ zz = p + d_sign(&zz, &p); wr[na] = x + zz; wr[en] = wr[na]; if (zz != 0.) { wr[en] = x - w / zz; } wi[na] = 0.; wi[en] = 0.; x = h[en + na * h_dim1]; s = abs(x) + abs(zz); p = x / s; q = zz / s; r = sqrt(p * p + q * q); p /= r; q /= r; /* .......... ROW MODIFICATION .......... */ i_1 = *n; for (j = na; j <= i_1; ++j) { zz = h[na + j * h_dim1]; h[na + j * h_dim1] = q * zz + p * h[en + j * h_dim1]; h[en + j * h_dim1] = q * h[en + j * h_dim1] - p * zz; /* L290: */ } /* .......... COLUMN MODIFICATION .......... */ i_1 = en; for (i = 1; i <= i_1; ++i) { zz = h[i + na * h_dim1]; h[i + na * h_dim1] = q * zz + p * h[i + en * h_dim1]; h[i + en * h_dim1] = q * h[i + en * h_dim1] - p * zz; /* L300: */ } /* .......... ACCUMULATE TRANSFORMATIONS .......... */ i_1 = *igh; for (i = *low; i <= i_1; ++i) { zz = z[i + na * z_dim1]; z[i + na * z_dim1] = q * zz + p * z[i + en * z_dim1]; z[i + en * z_dim1] = q * z[i + en * z_dim1] - p * zz; /* L310: */ } goto L330; /* .......... COMPLEX PAIR .......... */ L320: wr[na] = x + p; wr[en] = x + p; wi[na] = zz; wi[en] = -zz; L330: en = enm2; goto L60; /* .......... ALL ROOTS FOUND. BACKSUBSTITUTE TO FIND */ /* VECTORS OF UPPER TRIANGULAR FORM .......... */ L340: if (norm == 0.) { goto L1001; } /* .......... FOR EN=N STEP -1 UNTIL 1 DO -- .......... */ i_1 = *n; for (nn = 1; nn <= i_1; ++nn) { en = *n + 1 - nn; p = wr[en]; q = wi[en]; na = en - 1; if (q < 0.) { goto L710; } else if (q == 0) { goto L600; } else { goto L800; } /* .......... REAL VECTOR .......... */ L600: m = en; h[en + en * h_dim1] = 1.; if (na == 0) { goto L800; } /* .......... FOR I=EN-1 STEP -1 UNTIL 1 DO -- .......... */ i_2 = na; for (ii = 1; ii <= i_2; ++ii) { i = en - ii; w = h[i + i * h_dim1] - p; r = 0.; i_3 = en; for (j = m; j <= i_3; ++j) { /* L610: */ r += h[i + j * h_dim1] * h[j + en * h_dim1]; } if (wi[i] >= 0.) { goto L630; } zz = w; s = r; goto L700; L630: m = i; if (wi[i] != 0.) { goto L640; } t = w; if (t != 0.) { goto L635; } tst1 = norm; t = tst1; L632: t *= .01; tst2 = norm + t; if (tst2 > tst1) { goto L632; } L635: h[i + en * h_dim1] = -r / t; goto L680; /* .......... SOLVE REAL EQUATIONS .......... */ L640: x = h[i + (i + 1) * h_dim1]; y = h[i + 1 + i * h_dim1]; q = (wr[i] - p) * (wr[i] - p) + wi[i] * wi[i]; t = (x * s - zz * r) / q; h[i + en * h_dim1] = t; if (abs(x) <= abs(zz)) { goto L650; } h[i + 1 + en * h_dim1] = (-r - w * t) / x; goto L680; L650: h[i + 1 + en * h_dim1] = (-s - y * t) / zz; /* .......... OVERFLOW CONTROL .......... */ L680: t = (d_1 = h[i + en * h_dim1], abs(d_1)); if (t == 0.) { goto L700; } tst1 = t; tst2 = tst1 + 1. / tst1; if (tst2 > tst1) { goto L700; } i_3 = en; for (j = i; j <= i_3; ++j) { h[j + en * h_dim1] /= t; /* L690: */ } L700: ; } /* .......... END REAL VECTOR .......... */ goto L800; /* .......... COMPLEX VECTOR .......... */ L710: m = na; /* .......... LAST VECTOR COMPONENT CHOSEN IMAGINARY SO THAT */ /* EIGENVECTOR MATRIX IS TRIANGULAR .......... */ if ((d_1 = h[en + na * h_dim1], abs(d_1)) <= (d_2 = h[na + en * h_dim1], abs(d_2))) { goto L720; } h[na + na * h_dim1] = q / h[en + na * h_dim1]; h[na + en * h_dim1] = -(h[en + en * h_dim1] - p) / h[en + na * h_dim1] ; goto L730; L720: d_1 = -h[na + en * h_dim1]; d_2 = h[na + na * h_dim1] - p; cdiv_(&c_b550, &d_1, &d_2, &q, &h[na + na * h_dim1], &h[na + en * h_dim1]); L730: h[en + na * h_dim1] = 0.; h[en + en * h_dim1] = 1.; enm2 = na - 1; if (enm2 == 0) { goto L800; } /* .......... FOR I=EN-2 STEP -1 UNTIL 1 DO -- .......... */ i_2 = enm2; for (ii = 1; ii <= i_2; ++ii) { i = na - ii; w = h[i + i * h_dim1] - p; ra = 0.; sa = 0.; i_3 = en; for (j = m; j <= i_3; ++j) { ra += h[i + j * h_dim1] * h[j + na * h_dim1]; sa += h[i + j * h_dim1] * h[j + en * h_dim1]; /* L760: */ } if (wi[i] >= 0.) { goto L770; } zz = w; r = ra; s = sa; goto L795; L770: m = i; if (wi[i] != 0.) { goto L780; } d_1 = -ra; d_2 = -sa; cdiv_(&d_1, &d_2, &w, &q, &h[i + na * h_dim1], &h[i + en * h_dim1]); goto L790; /* .......... SOLVE COMPLEX EQUATIONS .......... */ L780: x = h[i + (i + 1) * h_dim1]; y = h[i + 1 + i * h_dim1]; vr = (wr[i] - p) * (wr[i] - p) + wi[i] * wi[i] - q * q; vi = (wr[i] - p) * 2. * q; if (vr != 0. || vi != 0.) { goto L784; } tst1 = norm * (abs(w) + abs(q) + abs(x) + abs(y) + abs(zz)); vr = tst1; L783: vr *= .01; tst2 = tst1 + vr; if (tst2 > tst1) { goto L783; } L784: d_1 = x * r - zz * ra + q * sa; d_2 = x * s - zz * sa - q * ra; cdiv_(&d_1, &d_2, &vr, &vi, &h[i + na * h_dim1], &h[i + en * h_dim1]); if (abs(x) <= abs(zz) + abs(q)) { goto L785; } h[i + 1 + na * h_dim1] = (-ra - w * h[i + na * h_dim1] + q * h[i + en * h_dim1]) / x; h[i + 1 + en * h_dim1] = (-sa - w * h[i + en * h_dim1] - q * h[i + na * h_dim1]) / x; goto L790; L785: d_1 = -r - y * h[i + na * h_dim1]; d_2 = -s - y * h[i + en * h_dim1]; cdiv_(&d_1, &d_2, &zz, &q, &h[i + 1 + na * h_dim1], &h[i + 1 + en * h_dim1]); /* .......... OVERFLOW CONTROL .......... */ L790: /* Computing MAX */ d_3 = (d_1 = h[i + na * h_dim1], abs(d_1)), d_4 = (d_2 = h[i + en * h_dim1], abs(d_2)); t = max(d_3,d_4); if (t == 0.) { goto L795; } tst1 = t; tst2 = tst1 + 1. / tst1; if (tst2 > tst1) { goto L795; } i_3 = en; for (j = i; j <= i_3; ++j) { h[j + na * h_dim1] /= t; h[j + en * h_dim1] /= t; /* L792: */ } L795: ; } /* .......... END COMPLEX VECTOR .......... */ L800: ; } /* .......... END BACK SUBSTITUTION. */ /* VECTORS OF ISOLATED ROOTS .......... */ i_1 = *n; for (i = 1; i <= i_1; ++i) { if (i >= *low && i <= *igh) { goto L840; } i_2 = *n; for (j = i; j <= i_2; ++j) { /* L820: */ z[i + j * z_dim1] = h[i + j * h_dim1]; } L840: ; } /* .......... MULTIPLY BY TRANSFORMATION MATRIX TO GIVE */ /* VECTORS OF ORIGINAL FULL MATRIX. */ /* FOR J=N STEP -1 UNTIL LOW DO -- .......... */ i_1 = *n; for (jj = *low; jj <= i_1; ++jj) { j = *n + *low - jj; m = min(j,*igh); i_2 = *igh; for (i = *low; i <= i_2; ++i) { zz = 0.; i_3 = m; for (k = *low; k <= i_3; ++k) { /* L860: */ zz += z[i + k * z_dim1] * h[k + j * h_dim1]; } z[i + j * z_dim1] = zz; /* L880: */ } } goto L1001; /* .......... SET ERROR -- ALL EIGENVALUES HAVE NOT */ /* CONVERGED AFTER 30*N ITERATIONS .......... */ L1000: *ierr = en; L1001: return 0; } /* hqr2_ */ /* Subroutine */ int htrib3_(integer *nm, integer *n, doublereal *a, doublereal *tau, integer *m, doublereal *zr, doublereal *zi) { /* System generated locals */ integer a_dim1, a_offset, zr_dim1, zr_offset, zi_dim1, zi_offset, i_1, i_2, i_3; /* Local variables */ static doublereal h; static integer i, j, k, l; static doublereal s, si; /* THIS SUBROUTINE IS A TRANSLATION OF A COMPLEX ANALOGUE OF */ /* THE ALGOL PROCEDURE TRBAK3, NUM. MATH. 11, 181-195(1968) */ /* BY MARTIN, REINSCH, AND WILKINSON. */ /* HANDBOOK FOR AUTO. COMP., VOL.II-LINEAR ALGEBRA, 212-226(1971). */ /* THIS SUBROUTINE FORMS THE EIGENVECTORS OF A COMPLEX HERMITIAN */ /* MATRIX BY BACK TRANSFORMING THOSE OF THE CORRESPONDING */ /* REAL SYMMETRIC TRIDIAGONAL MATRIX DETERMINED BY HTRID3. */ /* ON INPUT */ /* NM MUST BE SET TO THE ROW DIMENSION OF TWO-DIMENSIONAL */ /* ARRAY PARAMETERS AS DECLARED IN THE CALLING PROGRAM */ /* DIMENSION STATEMENT. */ /* N IS THE ORDER OF THE MATRIX. */ /* A CONTAINS INFORMATION ABOUT THE UNITARY TRANSFORMATIONS */ /* USED IN THE REDUCTION BY HTRID3. */ /* TAU CONTAINS FURTHER INFORMATION ABOUT THE TRANSFORMATIONS. */ /* M IS THE NUMBER OF EIGENVECTORS TO BE BACK TRANSFORMED. */ /* ZR CONTAINS THE EIGENVECTORS TO BE BACK TRANSFORMED */ /* IN ITS FIRST M COLUMNS. */ /* ON OUTPUT */ /* ZR AND ZI CONTAIN THE REAL AND IMAGINARY PARTS, */ /* RESPECTIVELY, OF THE TRANSFORMED EIGENVECTORS */ /* IN THEIR FIRST M COLUMNS. */ /* NOTE THAT THE LAST COMPONENT OF EACH RETURNED VECTOR */ /* IS REAL AND THAT VECTOR EUCLIDEAN NORMS ARE PRESERVED. */ /* 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 */ tau -= 3; a_dim1 = *nm; a_offset = a_dim1 + 1; a -= a_offset; zi_dim1 = *nm; zi_offset = zi_dim1 + 1; zi -= zi_offset; zr_dim1 = *nm; zr_offset = zr_dim1 + 1; zr -= zr_offset; /* Function Body */ if (*m == 0) { goto L200; } /* .......... TRANSFORM THE EIGENVECTORS OF THE REAL SYMMETRIC */ /* TRIDIAGONAL MATRIX TO THOSE OF THE HERMITIAN */ /* TRIDIAGONAL MATRIX. .......... */ i_1 = *n; for (k = 1; k <= i_1; ++k) { i_2 = *m; for (j = 1; j <= i_2; ++j) { zi[k + j * zi_dim1] = -zr[k + j * zr_dim1] * tau[(k << 1) + 2]; zr[k + j * zr_dim1] *= tau[(k << 1) + 1]; /* L50: */ } } if (*n == 1) { goto L200; } /* .......... RECOVER AND APPLY THE HOUSEHOLDER MATRICES .......... */ i_2 = *n; for (i = 2; i <= i_2; ++i) { l = i - 1; h = a[i + i * a_dim1]; if (h == 0.) { goto L140; } i_1 = *m; for (j = 1; j <= i_1; ++j) { s = 0.; si = 0.; i_3 = l; for (k = 1; k <= i_3; ++k) { s = s + a[i + k * a_dim1] * zr[k + j * zr_dim1] - a[k + i * a_dim1] * zi[k + j * zi_dim1]; si = si + a[i + k * a_dim1] * zi[k + j * zi_dim1] + a[k + i * a_dim1] * zr[k + j * zr_dim1]; /* L110: */ } /* .......... DOUBLE DIVISIONS AVOID POSSIBLE UNDERFLOW ...... .... */ s = s / h / h; si = si / h / h; i_3 = l; for (k = 1; k <= i_3; ++k) { zr[k + j * zr_dim1] = zr[k + j * zr_dim1] - s * a[i + k * a_dim1] - si * a[k + i * a_dim1]; zi[k + j * zi_dim1] = zi[k + j * zi_dim1] - si * a[i + k * a_dim1] + s * a[k + i * a_dim1]; /* L120: */ } /* L130: */ } L140: ; } L200: return 0; } /* htrib3_ */ /* Subroutine */ int htribk_(integer *nm, integer *n, doublereal *ar, doublereal *ai, doublereal *tau, integer *m, doublereal *zr, doublereal *zi) { /* System generated locals */ integer ar_dim1, ar_offset, ai_dim1, ai_offset, zr_dim1, zr_offset, zi_dim1, zi_offset, i_1, i_2, i_3; /* Local variables */ static doublereal h; static integer i, j, k, l; static doublereal s, si; /* THIS SUBROUTINE IS A TRANSLATION OF A COMPLEX ANALOGUE OF */ /* THE ALGOL PROCEDURE TRBAK1, NUM. MATH. 11, 181-195(1968) */ /* BY MARTIN, REINSCH, AND WILKINSON. */ /* HANDBOOK FOR AUTO. COMP., VOL.II-LINEAR ALGEBRA, 212-226(1971). */ /* THIS SUBROUTINE FORMS THE EIGENVECTORS OF A COMPLEX HERMITIAN */ /* MATRIX BY BACK TRANSFORMING THOSE OF THE CORRESPONDING */ /* REAL SYMMETRIC TRIDIAGONAL MATRIX DETERMINED BY HTRIDI. */ /* ON INPUT */ /* NM MUST BE SET TO THE ROW DIMENSION OF TWO-DIMENSIONAL */ /* ARRAY PARAMETERS AS DECLARED IN THE CALLING PROGRAM */ /* DIMENSION STATEMENT. */ /* N IS THE ORDER OF THE MATRIX. */ /* AR AND AI CONTAIN INFORMATION ABOUT THE UNITARY TRANS- */ /* FORMATIONS USED IN THE REDUCTION BY HTRIDI IN THEIR */ /* FULL LOWER TRIANGLES EXCEPT FOR THE DIAGONAL OF AR. */ /* TAU CONTAINS FURTHER INFORMATION ABOUT THE TRANSFORMATIONS. */ /* M IS THE NUMBER OF EIGENVECTORS TO BE BACK TRANSFORMED. */ /* ZR CONTAINS THE EIGENVECTORS TO BE BACK TRANSFORMED */ /* IN ITS FIRST M COLUMNS. */ /* ON OUTPUT */ /* ZR AND ZI CONTAIN THE REAL AND IMAGINARY PARTS, */ /* RESPECTIVELY, OF THE TRANSFORMED EIGENVECTORS */ /* IN THEIR FIRST M COLUMNS. */ /* NOTE THAT THE LAST COMPONENT OF EACH RETURNED VECTOR */ /* IS REAL AND THAT VECTOR EUCLIDEAN NORMS ARE PRESERVED. */ /* 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 */ tau -= 3; ai_dim1 = *nm; ai_offset = ai_dim1 + 1; ai -= ai_offset; ar_dim1 = *nm; ar_offset = ar_dim1 + 1; ar -= ar_offset; zi_dim1 = *nm; zi_offset = zi_dim1 + 1; zi -= zi_offset; zr_dim1 = *nm; zr_offset = zr_dim1 + 1; zr -= zr_offset; /* Function Body */ if (*m == 0) { goto L200; } /* .......... TRANSFORM THE EIGENVECTORS OF THE REAL SYMMETRIC */ /* TRIDIAGONAL MATRIX TO THOSE OF THE HERMITIAN */ /* TRIDIAGONAL MATRIX. .......... */ i_1 = *n; for (k = 1; k <= i_1; ++k) { i_2 = *m; for (j = 1; j <= i_2; ++j) { zi[k + j * zi_dim1] = -zr[k + j * zr_dim1] * tau[(k << 1) + 2]; zr[k + j * zr_dim1] *= tau[(k << 1) + 1]; /* L50: */ } } if (*n == 1) { goto L200; } /* .......... RECOVER AND APPLY THE HOUSEHOLDER MATRICES .......... */ i_2 = *n; for (i = 2; i <= i_2; ++i) { l = i - 1; h = ai[i + i * ai_dim1]; if (h == 0.) { goto L140; } i_1 = *m; for (j = 1; j <= i_1; ++j) { s = 0.; si = 0.; i_3 = l; for (k = 1; k <= i_3; ++k) { s = s + ar[i + k * ar_dim1] * zr[k + j * zr_dim1] - ai[i + k * ai_dim1] * zi[k + j * zi_dim1]; si = si + ar[i + k * ar_dim1] * zi[k + j * zi_dim1] + ai[i + k * ai_dim1] * zr[k + j * zr_dim1]; /* L110: */ } /* .......... DOUBLE DIVISIONS AVOID POSSIBLE UNDERFLOW ...... .... */ s = s / h / h; si = si / h / h; i_3 = l; for (k = 1; k <= i_3; ++k) { zr[k + j * zr_dim1] = zr[k + j * zr_dim1] - s * ar[i + k * ar_dim1] - si * ai[i + k * ai_dim1]; zi[k + j * zi_dim1] = zi[k + j * zi_dim1] - si * ar[i + k * ar_dim1] + s * ai[i + k * ai_dim1]; /* L120: */ } /* L130: */ } L140: ; } L200: return 0; } /* htribk_ */ /* Subroutine */ int htrid3_(integer *nm, integer *n, doublereal *a, doublereal *d, doublereal *e, doublereal *e2, doublereal *tau) { /* System generated locals */ integer a_dim1, a_offset, i_1, i_2, i_3; doublereal d_1, d_2; /* Builtin functions */ double sqrt(doublereal); /* Local variables */ static doublereal f, g, h; static integer i, j, k, l; static doublereal scale, fi, gi, hh; static integer ii; static doublereal si; extern doublereal pythag_(doublereal *, doublereal *); static integer jm1, jp1; /* THIS SUBROUTINE IS A TRANSLATION OF A COMPLEX ANALOGUE OF */ /* THE ALGOL PROCEDURE TRED3, 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, STORED AS */ /* A SINGLE SQUARE ARRAY, TO A REAL SYMMETRIC TRIDIAGONAL MATRIX */ /* USING UNITARY SIMILARITY TRANSFORMATIONS. */ /* ON INPUT */ /* NM MUST BE SET TO THE ROW DIMENSION OF TWO-DIMENSIONAL */ /* ARRAY PARAMETERS AS DECLARED IN THE CALLING PROGRAM */ /* DIMENSION STATEMENT. */ /* N IS THE ORDER OF THE MATRIX. */ /* A CONTAINS THE LOWER TRIANGLE OF THE COMPLEX HERMITIAN INPUT */ /* MATRIX. THE REAL PARTS OF THE MATRIX ELEMENTS ARE STORED */ /* IN THE FULL LOWER TRIANGLE OF A, AND THE IMAGINARY PARTS */ /* ARE STORED IN THE TRANSPOSED POSITIONS OF THE STRICT UPPER */ /* TRIANGLE OF A. NO STORAGE IS REQUIRED FOR THE ZERO */ /* IMAGINARY PARTS OF THE DIAGONAL ELEMENTS. */ /* ON OUTPUT */ /* A CONTAINS INFORMATION ABOUT THE UNITARY TRANSFORMATIONS */ /* USED IN THE REDUCTION. */ /* D CONTAINS THE DIAGONAL ELEMENTS OF THE THE TRIDIAGONAL MATRIX. */ /* E CONTAINS THE SUBDIAGONAL ELEMENTS OF THE TRIDIAGONAL */ /* MATRIX IN ITS LAST N-1 POSITIONS. E(1) IS SET TO ZERO. */ /* E2 CONTAINS THE SQUARES OF THE CORRESPONDING ELEMENTS OF E. */ /* E2 MAY COINCIDE WITH E IF THE SQUARES ARE NOT NEEDED. */ /* TAU CONTAINS FURTHER INFORMATION ABOUT THE TRANSFORMATIONS. */ /* 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 */ tau -= 3; --e2; --e; --d; a_dim1 = *nm; a_offset = a_dim1 + 1; a -= a_offset; /* Function Body */ tau[(*n << 1) + 1] = 1.; tau[(*n << 1) + 2] = 0.; /* .......... 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.; scale = 0.; 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 + (d_1 = a[i + k * a_dim1], abs(d_1)) + (d_2 = a[ k + i * a_dim1], abs(d_2)); } if (scale != 0.) { goto L140; } tau[(l << 1) + 1] = 1.; tau[(l << 1) + 2] = 0.; L130: e[i] = 0.; e2[i] = 0.; goto L290; L140: i_2 = l; for (k = 1; k <= i_2; ++k) { a[i + k * a_dim1] /= scale; a[k + i * a_dim1] /= scale; h = h + a[i + k * a_dim1] * a[i + k * a_dim1] + a[k + i * a_dim1] * a[k + i * a_dim1]; /* L150: */ } e2[i] = scale * scale * h; g = sqrt(h); e[i] = scale * g; f = pythag_(&a[i + l * a_dim1], &a[l + i * a_dim1]); /* .......... FORM NEXT DIAGONAL ELEMENT OF MATRIX T .......... */ if (f == 0.) { goto L160; } tau[(l << 1) + 1] = (a[l + i * a_dim1] * tau[(i << 1) + 2] - a[i + l * a_dim1] * tau[(i << 1) + 1]) / f; si = (a[i + l * a_dim1] * tau[(i << 1) + 2] + a[l + i * a_dim1] * tau[ (i << 1) + 1]) / f; h += f * g; g = g / f + 1.; a[i + l * a_dim1] = g * a[i + l * a_dim1]; a[l + i * a_dim1] = g * a[l + i * a_dim1]; if (l == 1) { goto L270; } goto L170; L160: tau[(l << 1) + 1] = -tau[(i << 1) + 1]; si = tau[(i << 1) + 2]; a[i + l * a_dim1] = g; L170: f = 0.; i_2 = l; for (j = 1; j <= i_2; ++j) { g = 0.; gi = 0.; if (j == 1) { goto L190; } jm1 = j - 1; /* .......... FORM ELEMENT OF A*U .......... */ i_3 = jm1; for (k = 1; k <= i_3; ++k) { g = g + a[j + k * a_dim1] * a[i + k * a_dim1] + a[k + j * a_dim1] * a[k + i * a_dim1]; gi = gi - a[j + k * a_dim1] * a[k + i * a_dim1] + a[k + j * a_dim1] * a[i + k * a_dim1]; /* L180: */ } L190: g += a[j + j * a_dim1] * a[i + j * a_dim1]; gi -= a[j + j * a_dim1] * a[j + i * a_dim1]; jp1 = j + 1; if (l < jp1) { goto L220; } i_3 = l; for (k = jp1; k <= i_3; ++k) { g = g + a[k + j * a_dim1] * a[i + k * a_dim1] - a[j + k * a_dim1] * a[k + i * a_dim1]; gi = gi - a[k + j * a_dim1] * a[k + i * a_dim1] - a[j + k * a_dim1] * a[i + k * a_dim1]; /* L200: */ } /* .......... FORM ELEMENT OF P .......... */ L220: e[j] = g / h; tau[(j << 1) + 2] = gi / h; f = f + e[j] * a[i + j * a_dim1] - tau[(j << 1) + 2] * a[j + i * a_dim1]; /* L240: */ } hh = f / (h + h); /* .......... FORM REDUCED A .......... */ i_2 = l; for (j = 1; j <= i_2; ++j) { f = a[i + j * a_dim1]; g = e[j] - hh * f; e[j] = g; fi = -a[j + i * a_dim1]; gi = tau[(j << 1) + 2] - hh * fi; tau[(j << 1) + 2] = -gi; a[j + j * a_dim1] -= (f * g + fi * gi) * 2.; if (j == 1) { goto L260; } jm1 = j - 1; i_3 = jm1; for (k = 1; k <= i_3; ++k) { a[j + k * a_dim1] = a[j + k * a_dim1] - f * e[k] - g * a[i + k * a_dim1] + fi * tau[(k << 1) + 2] + gi * a[k + i * a_dim1]; a[k + j * a_dim1] = a[k + j * a_dim1] - f * tau[(k << 1) + 2] - g * a[k + i * a_dim1] - fi * e[k] - gi * a[i + k * a_dim1]; /* L250: */ } L260: ; } L270: i_2 = l; for (k = 1; k <= i_2; ++k) { a[i + k * a_dim1] = scale * a[i + k * a_dim1]; a[k + i * a_dim1] = scale * a[k + i * a_dim1]; /* L280: */ } tau[(l << 1) + 2] = -si; L290: d[i] = a[i + i * a_dim1]; a[i + i * a_dim1] = scale * sqrt(h); /* L300: */ } return 0; } /* htrid3_ */ /* Subroutine */ int htridi_(integer *nm, integer *n, doublereal *ar, doublereal *ai, doublereal *d, doublereal *e, doublereal *e2, doublereal *tau) { /* System generated locals */ integer ar_dim1, ar_offset, ai_dim1, ai_offset, i_1, i_2, i_3; doublereal d_1, d_2; /* Builtin functions */ double sqrt(doublereal); /* Local variables */ static doublereal f, g, h; static integer i, j, k, l; static doublereal scale, fi, gi, hh; static integer ii; static doublereal si; extern doublereal pythag_(doublereal *, doublereal *); static integer jp1; /* 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 TWO-DIMENSIONAL */ /* ARRAY PARAMETERS AS DECLARED IN THE CALLING PROGRAM */ /* DIMENSION STATEMENT. */ /* N IS THE ORDER OF THE MATRIX. */ /* 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. */ /* ON OUTPUT */ /* AR AND AI CONTAIN INFORMATION ABOUT THE UNITARY TRANS- */ /* FORMATIONS USED IN THE REDUCTION IN THEIR FULL LOWER */ /* TRIANGLES. THEIR STRICT UPPER TRIANGLES AND THE */ /* DIAGONAL OF AR ARE UNALTERED. */ /* D CONTAINS THE DIAGONAL ELEMENTS OF THE THE TRIDIAGONAL MATRIX. */ /* E CONTAINS THE SUBDIAGONAL ELEMENTS OF THE TRIDIAGONAL */ /* MATRIX IN ITS LAST N-1 POSITIONS. E(1) IS SET TO ZERO. */ /* E2 CONTAINS THE SQUARES OF THE CORRESPONDING ELEMENTS OF E. */ /* E2 MAY COINCIDE WITH E IF THE SQUARES ARE NOT NEEDED. */ /* TAU CONTAINS FURTHER INFORMATION ABOUT THE TRANSFORMATIONS. */ /* 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 */ tau -= 3; --e2; --e; --d; ai_dim1 = *nm; ai_offset = ai_dim1 + 1; ai -= ai_offset; ar_dim1 = *nm; ar_offset = ar_dim1 + 1; ar -= ar_offset; /* Function Body */ tau[(*n << 1) + 1] = 1.; tau[(*n << 1) + 2] = 0.; 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.; scale = 0.; 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 + (d_1 = ar[i + k * ar_dim1], abs(d_1)) + (d_2 = ai[i + k * ai_dim1], abs(d_2)); } if (scale != 0.) { goto L140; } tau[(l << 1) + 1] = 1.; tau[(l << 1) + 2] = 0.; L130: e[i] = 0.; e2[i] = 0.; 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.) { 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.; 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.; i_2 = l; for (j = 1; j <= i_2; ++j) { g = 0.; gi = 0.; /* .......... 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 imtql1_(integer *n, doublereal *d, doublereal *e, integer *ierr) { /* System generated locals */ integer i_1, i_2; doublereal d_1, d_2; /* Builtin functions */ double d_sign(doublereal *, doublereal *); /* Local variables */ static doublereal b, c, f, g; static integer i, j, l, m; static doublereal p, r, s; static integer ii; extern doublereal pythag_(doublereal *, doublereal *); static integer mml; static doublereal tst1, tst2; /* THIS SUBROUTINE IS A TRANSLATION OF THE 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. */ /* ON INPUT */ /* N IS THE ORDER OF THE MATRIX. */ /* D CONTAINS THE DIAGONAL ELEMENTS OF THE INPUT MATRIX. */ /* E CONTAINS THE SUBDIAGONAL ELEMENTS OF THE INPUT MATRIX */ /* IN ITS LAST N-1 POSITIONS. E(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. */ /* E 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. */ /* ------------------------------------------------------------------ */ /* Parameter adjustments */ --e; --d; /* 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.; 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; } tst1 = (d_1 = d[m], abs(d_1)) + (d_2 = d[m + 1], abs(d_2)); tst2 = tst1 + (d_1 = e[m], abs(d_1)); if (tst2 == tst1) { goto L120; } /* L110: */ } L120: p = d[l]; if (m == l) { goto L215; } if (j == 30) { goto L1000; } ++j; /* .......... FORM SHIFT .......... */ g = (d[l + 1] - p) / (e[l] * 2.); r = pythag_(&g, &c_b141); g = d[m] - p + e[l] / (g + d_sign(&r, &g)); s = 1.; c = 1.; p = 0.; 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]; r = pythag_(&f, &g); e[i + 1] = r; if (r == 0.) { goto L210; } s = f / r; c = g / r; g = d[i + 1] - p; r = (d[i] - g) * s + c * 2. * b; p = s * r; d[i + 1] = g + p; g = c * r - b; /* L200: */ } d[l] -= p; e[l] = g; e[m] = 0.; goto L105; /* .......... RECOVER FROM UNDERFLOW .......... */ L210: d[i + 1] -= p; e[m] = 0.; 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 >= d[i - 1]) { goto L270; } d[i] = d[i - 1]; /* L230: */ } L250: i = 1; L270: d[i] = p; /* L290: */ } goto L1001; /* .......... SET ERROR -- NO CONVERGENCE TO AN */ /* EIGENVALUE AFTER 30 ITERATIONS .......... */ L1000: *ierr = l; L1001: return 0; } /* imtql1_ */ /* Subroutine */ int imtql2_(integer *nm, integer *n, doublereal *d, doublereal *e, doublereal *z, integer *ierr) { /* System generated locals */ integer z_dim1, z_offset, i_1, i_2, i_3; doublereal d_1, d_2; /* Builtin functions */ double d_sign(doublereal *, doublereal *); /* Local variables */ static doublereal b, c, f, g; static integer i, j, k, l, m; static doublereal p, r, s; static integer ii; extern doublereal pythag_(doublereal *, doublereal *); static integer mml; static doublereal tst1, tst2; /* 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 TWO-DIMENSIONAL */ /* ARRAY PARAMETERS AS DECLARED IN THE CALLING PROGRAM */ /* DIMENSION STATEMENT. */ /* N IS THE ORDER OF THE MATRIX. */ /* D CONTAINS THE DIAGONAL ELEMENTS OF THE INPUT MATRIX. */ /* E CONTAINS THE SUBDIAGONAL ELEMENTS OF THE INPUT MATRIX */ /* IN ITS LAST N-1 POSITIONS. E(1) IS ARBITRARY. */ /* Z CONTAINS THE TRANSFORMATION MATRIX PRODUCED IN THE */ /* REDUCTION BY TRED2, IF PERFORMED. IF THE EIGENVECTORS */ /* OF THE TRIDIAGONAL MATRIX ARE DESIRED, Z MUST CONTAIN */ /* THE IDENTITY MATRIX. */ /* 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 SYMMETRIC */ /* TRIDIAGONAL (OR FULL) MATRIX. IF AN ERROR EXIT IS MADE, */ /* Z CONTAINS THE EIGENVECTORS ASSOCIATED WITH THE STORED */ /* EIGENVALUES. */ /* 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. */ /* ------------------------------------------------------------------ */ /* Parameter adjustments */ z_dim1 = *nm; z_offset = z_dim1 + 1; z -= z_offset; --e; --d; /* 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.; 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; } tst1 = (d_1 = d[m], abs(d_1)) + (d_2 = d[m + 1], abs(d_2)); tst2 = tst1 + (d_1 = e[m], abs(d_1)); if (tst2 == tst1) { 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.); r = pythag_(&g, &c_b141); g = d[m] - p + e[l] / (g + d_sign(&r, &g)); s = 1.; c = 1.; p = 0.; 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]; r = pythag_(&f, &g); e[i + 1] = r; if (r == 0.) { goto L210; } s = f / r; c = g / r; g = d[i + 1] - p; r = (d[i] - g) * s + c * 2. * b; p = s * r; d[i + 1] = g + p; g = c * r - b; /* .......... 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.; goto L105; /* .......... RECOVER FROM UNDERFLOW .......... */ L210: d[i + 1] -= p; e[m] = 0.; 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_ */ /* Subroutine */ int imtqlv_(integer *n, doublereal *d, doublereal *e, doublereal *e2, doublereal *w, integer *ind, integer *ierr, doublereal *rv1) { /* System generated locals */ integer i_1, i_2; doublereal d_1, d_2; /* Builtin functions */ double d_sign(doublereal *, doublereal *); /* Local variables */ static doublereal b, c, f, g; static integer i, j, k, l, m; static doublereal p, r, s; static integer ii; extern doublereal pythag_(doublereal *, doublereal *); static integer tag, mml; static doublereal tst1, tst2; /* 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. */ /* D CONTAINS THE DIAGONAL ELEMENTS OF THE INPUT MATRIX. */ /* E CONTAINS THE SUBDIAGONAL ELEMENTS OF THE INPUT MATRIX */ /* IN ITS LAST N-1 POSITIONS. E(1) IS ARBITRARY. */ /* E2 CONTAINS THE SQUARES OF THE CORRESPONDING ELEMENTS OF E. */ /* E2(1) IS ARBITRARY. */ /* 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. */ /* 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.. */ /* IERR IS SET TO */ /* ZERO FOR NORMAL RETURN, */ /* J IF THE J-TH EIGENVALUE 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; --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.; rv1[*n] = 0.; 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; } tst1 = (d_1 = w[m], abs(d_1)) + (d_2 = w[m + 1], abs(d_2)); tst2 = tst1 + (d_1 = rv1[m], abs(d_1)); if (tst2 == tst1) { goto L120; } /* .......... GUARD AGAINST UNDERFLOWED ELEMENT OF E2 ........ .. */ if (e2[m + 1] == 0.) { goto L125; } /* L110: */ } L120: if (m <= k) { goto L130; } if (m != *n) { e2[m + 1] = 0.; } 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.); r = pythag_(&g, &c_b141); g = w[m] - p + rv1[l] / (g + d_sign(&r, &g)); s = 1.; c = 1.; p = 0.; 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]; r = pythag_(&f, &g); rv1[i + 1] = r; if (r == 0.) { goto L210; } s = f / r; c = g / r; g = w[i + 1] - p; r = (w[i] - g) * s + c * 2. * b; p = s * r; w[i + 1] = g + p; g = c * r - b; /* L200: */ } w[l] -= p; rv1[l] = g; rv1[m] = 0.; goto L105; /* .......... RECOVER FROM UNDERFLOW .......... */ L210: w[i + 1] -= p; rv1[m] = 0.; 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_ */ /* Subroutine */ int invit_(integer *nm, integer *n, doublereal *a, doublereal *wr, doublereal *wi, logical *select, integer *mm, integer *m, doublereal *z, integer *ierr, doublereal *rm1, doublereal *rv1, doublereal *rv2) { /* System generated locals */ integer a_dim1, a_offset, z_dim1, z_offset, rm1_dim1, rm1_offset, i_1, i_2, i_3; doublereal d_1, d_2; /* Builtin functions */ double sqrt(doublereal); /* Local variables */ extern /* Subroutine */ int cdiv_(doublereal *, doublereal *, doublereal * , doublereal *, doublereal *, doublereal *); static doublereal norm; static integer i, j, k, l, s; static doublereal t, w, x, y; static integer n1; static doublereal normv; static integer ii; static doublereal ilambd; static integer ip, mp, ns, uk; static doublereal rlambd; extern doublereal pythag_(doublereal *, doublereal *), epslon_(doublereal *); static integer km1, ip1; static doublereal growto, ukroot; static integer its; static doublereal eps3; /* THIS SUBROUTINE IS A TRANSLATION OF THE ALGOL PROCEDURE INVIT */ /* BY PETERS AND WILKINSON. */ /* HANDBOOK FOR AUTO. COMP., VOL.II-LINEAR ALGEBRA, 418-439(1971). */ /* THIS SUBROUTINE FINDS THOSE EIGENVECTORS OF A REAL UPPER */ /* HESSENBERG MATRIX CORRESPONDING TO SPECIFIED EIGENVALUES, */ /* USING INVERSE ITERATION. */ /* ON INPUT */ /* NM MUST BE SET TO THE ROW DIMENSION OF TWO-DIMENSIONAL */ /* ARRAY PARAMETERS AS DECLARED IN THE CALLING PROGRAM */ /* DIMENSION STATEMENT. */ /* N IS THE ORDER OF THE MATRIX. */ /* A CONTAINS THE HESSENBERG MATRIX. */ /* WR AND WI CONTAIN THE REAL AND IMAGINARY PARTS, RESPECTIVELY, */ /* OF THE EIGENVALUES OF THE MATRIX. THE EIGENVALUES MUST BE */ /* STORED IN A MANNER IDENTICAL TO THAT OF SUBROUTINE HQR, */ /* WHICH RECOGNIZES POSSIBLE SPLITTING OF THE MATRIX. */ /* SELECT SPECIFIES THE EIGENVECTORS TO BE FOUND. THE */ /* EIGENVECTOR CORRESPONDING TO THE J-TH EIGENVALUE IS */ /* SPECIFIED BY SETTING SELECT(J) TO .TRUE.. */ /* MM SHOULD BE SET TO AN UPPER BOUND FOR THE NUMBER OF */ /* COLUMNS REQUIRED TO STORE THE EIGENVECTORS TO BE FOUND. */ /* NOTE THAT TWO COLUMNS ARE REQUIRED TO STORE THE */ /* EIGENVECTOR CORRESPONDING TO A COMPLEX EIGENVALUE. */ /* ON OUTPUT */ /* A AND WI ARE UNALTERED. */ /* WR MAY HAVE BEEN ALTERED SINCE CLOSE EIGENVALUES ARE PERTURBED */ /* SLIGHTLY IN SEARCHING FOR INDEPENDENT EIGENVECTORS. */ /* SELECT MAY HAVE BEEN ALTERED. IF THE ELEMENTS CORRESPONDING */ /* TO A PAIR OF CONJUGATE COMPLEX EIGENVALUES WERE EACH */ /* INITIALLY SET TO .TRUE., THE PROGRAM RESETS THE SECOND OF */ /* THE TWO ELEMENTS TO .FALSE.. */ /* M IS THE NUMBER OF COLUMNS ACTUALLY USED TO STORE */ /* THE EIGENVECTORS. */ /* Z CONTAINS THE REAL AND IMAGINARY PARTS OF THE EIGENVECTORS. */ /* IF THE NEXT SELECTED EIGENVALUE IS REAL, THE NEXT COLUMN */ /* OF Z CONTAINS ITS EIGENVECTOR. IF THE EIGENVALUE IS */ /* COMPLEX, THE NEXT TWO COLUMNS OF Z CONTAIN THE REAL AND */ /* IMAGINARY PARTS OF ITS EIGENVECTOR. THE EIGENVECTORS ARE */ /* NORMALIZED SO THAT THE COMPONENT OF LARGEST MAGNITUDE IS 1. */ /* ANY VECTOR WHICH FAILS THE ACCEPTANCE TEST IS SET TO ZERO. */ /* IERR IS SET TO */ /* ZERO FOR NORMAL RETURN, */ /* -(2*N+1) IF MORE THAN MM COLUMNS OF Z ARE NECESSARY */ /* TO STORE THE EIGENVECTORS CORRESPONDING TO */ /* THE SPECIFIED EIGENVALUES. */ /* -K IF THE ITERATION CORRESPONDING TO THE K-TH */ /* VALUE FAILS, */ /* -(N+K) IF BOTH ERROR SITUATIONS OCCUR. */ /* RM1, RV1, AND RV2 ARE TEMPORARY STORAGE ARRAYS. NOTE THAT RM1 */ /* IS SQUARE OF DIMENSION N BY N AND, AUGMENTED BY TWO COLUMNS */ /* OF Z, IS THE TRANSPOSE OF THE CORRESPONDING ALGOL B ARRAY. */ /* THE ALGOL PROCEDURE GUESSVEC APPEARS IN INVIT IN LINE. */ /* CALLS CDIV FOR COMPLEX DIVISION. */ /* 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 */ --rv2; --rv1; rm1_dim1 = *n; rm1_offset = rm1_dim1 + 1; rm1 -= rm1_offset; --select; --wi; --wr; a_dim1 = *nm; a_offset = a_dim1 + 1; a -= a_offset; z_dim1 = *nm; z_offset = z_dim1 + 1; z -= z_offset; /* Function Body */ *ierr = 0; uk = 0; s = 1; /* .......... IP = 0, REAL EIGENVALUE */ /* 1, FIRST OF CONJUGATE COMPLEX PAIR */ /* -1, SECOND OF CONJUGATE COMPLEX PAIR .......... */ ip = 0; n1 = *n - 1; i_1 = *n; for (k = 1; k <= i_1; ++k) { if (wi[k] == 0. || ip < 0) { goto L100; } ip = 1; if (select[k] && select[k + 1]) { select[k + 1] = FALSE_; } L100: if (! select[k]) { goto L960; } if (wi[k] != 0.) { ++s; } if (s > *mm) { goto L1000; } if (uk >= k) { goto L200; } /* .......... CHECK FOR POSSIBLE SPLITTING .......... */ i_2 = *n; for (uk = k; uk <= i_2; ++uk) { if (uk == *n) { goto L140; } if (a[uk + 1 + uk * a_dim1] == 0.) { goto L140; } /* L120: */ } /* .......... COMPUTE INFINITY NORM OF LEADING UK BY UK */ /* (HESSENBERG) MATRIX .......... */ L140: norm = 0.; mp = 1; i_2 = uk; for (i = 1; i <= i_2; ++i) { x = 0.; i_3 = uk; for (j = mp; j <= i_3; ++j) { /* L160: */ x += (d_1 = a[i + j * a_dim1], abs(d_1)); } if (x > norm) { norm = x; } mp = i; /* L180: */ } /* .......... EPS3 REPLACES ZERO PIVOT IN DECOMPOSITION */ /* AND CLOSE ROOTS ARE MODIFIED BY EPS3 .......... */ if (norm == 0.) { norm = 1.; } eps3 = epslon_(&norm); /* .......... GROWTO IS THE CRITERION FOR THE GROWTH .......... */ ukroot = (doublereal) uk; ukroot = sqrt(ukroot); growto = .1 / ukroot; L200: rlambd = wr[k]; ilambd = wi[k]; if (k == 1) { goto L280; } km1 = k - 1; goto L240; /* .......... PERTURB EIGENVALUE IF IT IS CLOSE */ /* TO ANY PREVIOUS EIGENVALUE .......... */ L220: rlambd += eps3; /* .......... FOR I=K-1 STEP -1 UNTIL 1 DO -- .......... */ L240: i_2 = km1; for (ii = 1; ii <= i_2; ++ii) { i = k - ii; if (select[i] && (d_1 = wr[i] - rlambd, abs(d_1)) < eps3 && ( d_2 = wi[i] - ilambd, abs(d_2)) < eps3) { goto L220; } /* L260: */ } wr[k] = rlambd; /* .......... PERTURB CONJUGATE EIGENVALUE TO MATCH .......... */ ip1 = k + ip; wr[ip1] = rlambd; /* .......... FORM UPPER HESSENBERG A-RLAMBD*I (TRANSPOSED) */ /* AND INITIAL REAL VECTOR .......... */ L280: mp = 1; i_2 = uk; for (i = 1; i <= i_2; ++i) { i_3 = uk; for (j = mp; j <= i_3; ++j) { /* L300: */ rm1[j + i * rm1_dim1] = a[i + j * a_dim1]; } rm1[i + i * rm1_dim1] -= rlambd; mp = i; rv1[i] = eps3; /* L320: */ } its = 0; if (ilambd != 0.) { goto L520; } /* .......... REAL EIGENVALUE. */ /* TRIANGULAR DECOMPOSITION WITH INTERCHANGES, */ /* REPLACING ZERO PIVOTS BY EPS3 .......... */ if (uk == 1) { goto L420; } i_2 = uk; for (i = 2; i <= i_2; ++i) { mp = i - 1; if ((d_1 = rm1[mp + i * rm1_dim1], abs(d_1)) <= (d_2 = rm1[mp + mp * rm1_dim1], abs(d_2))) { goto L360; } i_3 = uk; for (j = mp; j <= i_3; ++j) { y = rm1[j + i * rm1_dim1]; rm1[j + i * rm1_dim1] = rm1[j + mp * rm1_dim1]; rm1[j + mp * rm1_dim1] = y; /* L340: */ } L360: if (rm1[mp + mp * rm1_dim1] == 0.) { rm1[mp + mp * rm1_dim1] = eps3; } x = rm1[mp + i * rm1_dim1] / rm1[mp + mp * rm1_dim1]; if (x == 0.) { goto L400; } i_3 = uk; for (j = i; j <= i_3; ++j) { /* L380: */ rm1[j + i * rm1_dim1] -= x * rm1[j + mp * rm1_dim1]; } L400: ; } L420: if (rm1[uk + uk * rm1_dim1] == 0.) { rm1[uk + uk * rm1_dim1] = eps3; } /* .......... BACK SUBSTITUTION FOR REAL VECTOR */ /* FOR I=UK STEP -1 UNTIL 1 DO -- .......... */ L440: i_2 = uk; for (ii = 1; ii <= i_2; ++ii) { i = uk + 1 - ii; y = rv1[i]; if (i == uk) { goto L480; } ip1 = i + 1; i_3 = uk; for (j = ip1; j <= i_3; ++j) { /* L460: */ y -= rm1[j + i * rm1_dim1] * rv1[j]; } L480: rv1[i] = y / rm1[i + i * rm1_dim1]; /* L500: */ } goto L740; /* .......... COMPLEX EIGENVALUE. */ /* TRIANGULAR DECOMPOSITION WITH INTERCHANGES, */ /* REPLACING ZERO PIVOTS BY EPS3. STORE IMAGINARY */ /* PARTS IN UPPER TRIANGLE STARTING AT (1,3) .......... */ L520: ns = *n - s; z[(s - 1) * z_dim1 + 1] = -ilambd; z[s * z_dim1 + 1] = 0.; if (*n == 2) { goto L550; } rm1[rm1_dim1 * 3 + 1] = -ilambd; z[(s - 1) * z_dim1 + 1] = 0.; if (*n == 3) { goto L550; } i_2 = *n; for (i = 4; i <= i_2; ++i) { /* L540: */ rm1[i * rm1_dim1 + 1] = 0.; } L550: i_2 = uk; for (i = 2; i <= i_2; ++i) { mp = i - 1; w = rm1[mp + i * rm1_dim1]; if (i < *n) { t = rm1[mp + (i + 1) * rm1_dim1]; } if (i == *n) { t = z[mp + (s - 1) * z_dim1]; } x = rm1[mp + mp * rm1_dim1] * rm1[mp + mp * rm1_dim1] + t * t; if (w * w <= x) { goto L580; } x = rm1[mp + mp * rm1_dim1] / w; y = t / w; rm1[mp + mp * rm1_dim1] = w; if (i < *n) { rm1[mp + (i + 1) * rm1_dim1] = 0.; } if (i == *n) { z[mp + (s - 1) * z_dim1] = 0.; } i_3 = uk; for (j = i; j <= i_3; ++j) { w = rm1[j + i * rm1_dim1]; rm1[j + i * rm1_dim1] = rm1[j + mp * rm1_dim1] - x * w; rm1[j + mp * rm1_dim1] = w; if (j < n1) { goto L555; } l = j - ns; z[i + l * z_dim1] = z[mp + l * z_dim1] - y * w; z[mp + l * z_dim1] = 0.; goto L560; L555: rm1[i + (j + 2) * rm1_dim1] = rm1[mp + (j + 2) * rm1_dim1] - y * w; rm1[mp + (j + 2) * rm1_dim1] = 0.; L560: ; } rm1[i + i * rm1_dim1] -= y * ilambd; if (i < n1) { goto L570; } l = i - ns; z[mp + l * z_dim1] = -ilambd; z[i + l * z_dim1] += x * ilambd; goto L640; L570: rm1[mp + (i + 2) * rm1_dim1] = -ilambd; rm1[i + (i + 2) * rm1_dim1] += x * ilambd; goto L640; L580: if (x != 0.) { goto L600; } rm1[mp + mp * rm1_dim1] = eps3; if (i < *n) { rm1[mp + (i + 1) * rm1_dim1] = 0.; } if (i == *n) { z[mp + (s - 1) * z_dim1] = 0.; } t = 0.; x = eps3 * eps3; L600: w /= x; x = rm1[mp + mp * rm1_dim1] * w; y = -t * w; i_3 = uk; for (j = i; j <= i_3; ++j) { if (j < n1) { goto L610; } l = j - ns; t = z[mp + l * z_dim1]; z[i + l * z_dim1] = -x * t - y * rm1[j + mp * rm1_dim1]; goto L615; L610: t = rm1[mp + (j + 2) * rm1_dim1]; rm1[i + (j + 2) * rm1_dim1] = -x * t - y * rm1[j + mp * rm1_dim1]; L615: rm1[j + i * rm1_dim1] = rm1[j + i * rm1_dim1] - x * rm1[j + mp * rm1_dim1] + y * t; /* L620: */ } if (i < n1) { goto L630; } l = i - ns; z[i + l * z_dim1] -= ilambd; goto L640; L630: rm1[i + (i + 2) * rm1_dim1] -= ilambd; L640: ; } if (uk < n1) { goto L650; } l = uk - ns; t = z[uk + l * z_dim1]; goto L655; L650: t = rm1[uk + (uk + 2) * rm1_dim1]; L655: if (rm1[uk + uk * rm1_dim1] == 0. && t == 0.) { rm1[uk + uk * rm1_dim1] = eps3; } /* .......... BACK SUBSTITUTION FOR COMPLEX VECTOR */ /* FOR I=UK STEP -1 UNTIL 1 DO -- .......... */ L660: i_2 = uk; for (ii = 1; ii <= i_2; ++ii) { i = uk + 1 - ii; x = rv1[i]; y = 0.; if (i == uk) { goto L700; } ip1 = i + 1; i_3 = uk; for (j = ip1; j <= i_3; ++j) { if (j < n1) { goto L670; } l = j - ns; t = z[i + l * z_dim1]; goto L675; L670: t = rm1[i + (j + 2) * rm1_dim1]; L675: x = x - rm1[j + i * rm1_dim1] * rv1[j] + t * rv2[j]; y = y - rm1[j + i * rm1_dim1] * rv2[j] - t * rv1[j]; /* L680: */ } L700: if (i < n1) { goto L710; } l = i - ns; t = z[i + l * z_dim1]; goto L715; L710: t = rm1[i + (i + 2) * rm1_dim1]; L715: cdiv_(&x, &y, &rm1[i + i * rm1_dim1], &t, &rv1[i], &rv2[i]); /* L720: */ } /* .......... ACCEPTANCE TEST FOR REAL OR COMPLEX */ /* EIGENVECTOR AND NORMALIZATION .......... */ L740: ++its; norm = 0.; normv = 0.; i_2 = uk; for (i = 1; i <= i_2; ++i) { if (ilambd == 0.) { x = (d_1 = rv1[i], abs(d_1)); } if (ilambd != 0.) { x = pythag_(&rv1[i], &rv2[i]); } if (normv >= x) { goto L760; } normv = x; j = i; L760: norm += x; /* L780: */ } if (norm < growto) { goto L840; } /* .......... ACCEPT VECTOR .......... */ x = rv1[j]; if (ilambd == 0.) { x = 1. / x; } if (ilambd != 0.) { y = rv2[j]; } i_2 = uk; for (i = 1; i <= i_2; ++i) { if (ilambd != 0.) { goto L800; } z[i + s * z_dim1] = rv1[i] * x; goto L820; L800: cdiv_(&rv1[i], &rv2[i], &x, &y, &z[i + (s - 1) * z_dim1], &z[i + s * z_dim1]); L820: ; } if (uk == *n) { goto L940; } j = uk + 1; goto L900; /* .......... IN-LINE PROCEDURE FOR CHOOSING */ /* A NEW STARTING VECTOR .......... */ L840: if (its >= uk) { goto L880; } x = ukroot; y = eps3 / (x + 1.); rv1[1] = eps3; i_2 = uk; for (i = 2; i <= i_2; ++i) { /* L860: */ rv1[i] = y; } j = uk - its + 1; rv1[j] -= eps3 * x; if (ilambd == 0.) { goto L440; } goto L660; /* .......... SET ERROR -- UNACCEPTED EIGENVECTOR .......... */ L880: j = 1; *ierr = -k; /* .......... SET REMAINING VECTOR COMPONENTS TO ZERO .......... */ L900: i_2 = *n; for (i = j; i <= i_2; ++i) { z[i + s * z_dim1] = 0.; if (ilambd != 0.) { z[i + (s - 1) * z_dim1] = 0.; } /* L920: */ } L940: ++s; L960: if (ip == -1) { ip = 0; } if (ip == 1) { ip = -1; } /* L980: */ } goto L1001; /* .......... SET ERROR -- UNDERESTIMATE OF EIGENVECTOR */ /* SPACE REQUIRED .......... */ L1000: if (*ierr != 0) { *ierr -= *n; } if (*ierr == 0) { *ierr = -((*n << 1) + 1); } L1001: *m = s - 1 - abs(ip); return 0; } /* invit_ */ /* 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 */ static doublereal c, f, g, h; static integer i, j, k, l; static doublereal s, x, y, z, scale; static integer i1, k1, l1, m1, ii, kk, ll; extern doublereal pythag_(doublereal *, doublereal *); static integer its; static 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_b141); 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 */ int ortbak_(integer *nm, integer *low, integer *igh, doublereal *a, doublereal *ort, integer *m, doublereal *z) { /* System generated locals */ integer a_dim1, a_offset, z_dim1, z_offset, i_1, i_2, i_3; /* Local variables */ static doublereal g; static integer i, j, la, mm, mp, kp1, mp1; /* THIS SUBROUTINE IS A TRANSLATION OF THE ALGOL PROCEDURE ORTBAK, */ /* NUM. MATH. 12, 349-368(1968) BY MARTIN AND WILKINSON. */ /* HANDBOOK FOR AUTO. COMP., VOL.II-LINEAR ALGEBRA, 339-358(1971). */ /* THIS SUBROUTINE FORMS THE EIGENVECTORS OF A REAL GENERAL */ /* MATRIX BY BACK TRANSFORMING THOSE OF THE CORRESPONDING */ /* UPPER HESSENBERG MATRIX DETERMINED BY ORTHES. */ /* ON INPUT */ /* NM MUST BE SET TO THE ROW DIMENSION OF TWO-DIMENSIONAL */ /* ARRAY PARAMETERS AS DECLARED IN THE CALLING PROGRAM */ /* DIMENSION STATEMENT. */ /* LOW AND IGH ARE INTEGERS DETERMINED BY THE BALANCING */ /* SUBROUTINE BALANC. IF BALANC HAS NOT BEEN USED, */ /* SET LOW=1 AND IGH EQUAL TO THE ORDER OF THE MATRIX. */ /* A CONTAINS INFORMATION ABOUT THE ORTHOGONAL TRANS- */ /* FORMATIONS USED IN THE REDUCTION BY ORTHES */ /* IN ITS STRICT LOWER TRIANGLE. */ /* ORT CONTAINS FURTHER INFORMATION ABOUT THE TRANS- */ /* FORMATIONS USED IN THE REDUCTION BY ORTHES. */ /* ONLY ELEMENTS LOW THROUGH IGH ARE USED. */ /* M IS THE NUMBER OF COLUMNS OF Z TO BE BACK TRANSFORMED. */ /* Z CONTAINS THE REAL AND IMAGINARY PARTS OF THE EIGEN- */ /* VECTORS TO BE BACK TRANSFORMED IN ITS FIRST M COLUMNS. */ /* ON OUTPUT */ /* Z CONTAINS THE REAL AND IMAGINARY PARTS OF THE */ /* TRANSFORMED EIGENVECTORS IN ITS FIRST M COLUMNS. */ /* ORT HAS BEEN ALTERED. */ /* NOTE THAT ORTBAK PRESERVES VECTOR EUCLIDEAN NORMS. */ /* 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 */ --ort; a_dim1 = *nm; a_offset = a_dim1 + 1; a -= a_offset; z_dim1 = *nm; z_offset = z_dim1 + 1; z -= z_offset; /* Function Body */ if (*m == 0) { goto L200; } la = *igh - 1; kp1 = *low + 1; if (la < kp1) { goto L200; } /* .......... FOR MP=IGH-1 STEP -1 UNTIL LOW+1 DO -- .......... */ i_1 = la; for (mm = kp1; mm <= i_1; ++mm) { mp = *low + *igh - mm; if (a[mp + (mp - 1) * a_dim1] == 0.) { goto L140; } mp1 = mp + 1; i_2 = *igh; for (i = mp1; i <= i_2; ++i) { /* L100: */ ort[i] = a[i + (mp - 1) * a_dim1]; } i_2 = *m; for (j = 1; j <= i_2; ++j) { g = 0.; i_3 = *igh; for (i = mp; i <= i_3; ++i) { /* L110: */ g += ort[i] * z[i + j * z_dim1]; } /* .......... DIVISOR BELOW IS NEGATIVE OF H FORMED IN ORTHES. */ /* DOUBLE DIVISION AVOIDS POSSIBLE UNDERFLOW ...... .... */ g = g / ort[mp] / a[mp + (mp - 1) * a_dim1]; i_3 = *igh; for (i = mp; i <= i_3; ++i) { /* L120: */ z[i + j * z_dim1] += g * ort[i]; } /* L130: */ } L140: ; } L200: return 0; } /* ortbak_ */ /* Subroutine */ int orthes_(integer *nm, integer *n, integer *low, integer * igh, doublereal *a, doublereal *ort) { /* System generated locals */ integer a_dim1, a_offset, i_1, i_2, i_3; doublereal d_1; /* Builtin functions */ double sqrt(doublereal), d_sign(doublereal *, doublereal *); /* Local variables */ static doublereal f, g, h; static integer i, j, m; static doublereal scale; static integer la, ii, jj, mp, kp1; /* THIS SUBROUTINE IS A TRANSLATION OF THE ALGOL PROCEDURE ORTHES, */ /* NUM. MATH. 12, 349-368(1968) BY MARTIN AND WILKINSON. */ /* HANDBOOK FOR AUTO. COMP., VOL.II-LINEAR ALGEBRA, 339-358(1971). */ /* GIVEN A REAL GENERAL MATRIX, THIS SUBROUTINE */ /* REDUCES A SUBMATRIX SITUATED IN ROWS AND COLUMNS */ /* LOW THROUGH IGH TO UPPER HESSENBERG FORM BY */ /* ORTHOGONAL SIMILARITY TRANSFORMATIONS. */ /* ON INPUT */ /* NM MUST BE SET TO THE ROW DIMENSION OF TWO-DIMENSIONAL */ /* ARRAY PARAMETERS AS DECLARED IN THE CALLING PROGRAM */ /* DIMENSION STATEMENT. */ /* N IS THE ORDER OF THE MATRIX. */ /* LOW AND IGH ARE INTEGERS DETERMINED BY THE BALANCING */ /* SUBROUTINE BALANC. IF BALANC HAS NOT BEEN USED, */ /* SET LOW=1, IGH=N. */ /* A CONTAINS THE INPUT MATRIX. */ /* ON OUTPUT */ /* A CONTAINS THE HESSENBERG MATRIX. INFORMATION ABOUT */ /* THE ORTHOGONAL TRANSFORMATIONS USED IN THE REDUCTION */ /* IS STORED IN THE REMAINING TRIANGLE UNDER THE */ /* HESSENBERG MATRIX. */ /* ORT CONTAINS FURTHER INFORMATION ABOUT THE TRANSFORMATIONS. */ /* ONLY ELEMENTS LOW THROUGH IGH ARE USED. */ /* 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 */ a_dim1 = *nm; a_offset = a_dim1 + 1; a -= a_offset; --ort; /* Function Body */ la = *igh - 1; kp1 = *low + 1; if (la < kp1) { goto L200; } i_1 = la; for (m = kp1; m <= i_1; ++m) { h = 0.; ort[m] = 0.; scale = 0.; /* .......... SCALE COLUMN (ALGOL TOL THEN NOT NEEDED) .......... */ i_2 = *igh; for (i = m; i <= i_2; ++i) { /* L90: */ scale += (d_1 = a[i + (m - 1) * a_dim1], abs(d_1)); } if (scale == 0.) { goto L180; } mp = m + *igh; /* .......... FOR I=IGH STEP -1 UNTIL M DO -- .......... */ i_2 = *igh; for (ii = m; ii <= i_2; ++ii) { i = mp - ii; ort[i] = a[i + (m - 1) * a_dim1] / scale; h += ort[i] * ort[i]; /* L100: */ } d_1 = sqrt(h); g = -d_sign(&d_1, &ort[m]); h -= ort[m] * g; ort[m] -= g; /* .......... FORM (I-(U*UT)/H) * A .......... */ i_2 = *n; for (j = m; j <= i_2; ++j) { f = 0.; /* .......... FOR I=IGH STEP -1 UNTIL M DO -- .......... */ i_3 = *igh; for (ii = m; ii <= i_3; ++ii) { i = mp - ii; f += ort[i] * a[i + j * a_dim1]; /* L110: */ } f /= h; i_3 = *igh; for (i = m; i <= i_3; ++i) { /* L120: */ a[i + j * a_dim1] -= f * ort[i]; } /* L130: */ } /* .......... FORM (I-(U*UT)/H)*A*(I-(U*UT)/H) .......... */ i_2 = *igh; for (i = 1; i <= i_2; ++i) { f = 0.; /* .......... FOR J=IGH STEP -1 UNTIL M DO -- .......... */ i_3 = *igh; for (jj = m; jj <= i_3; ++jj) { j = mp - jj; f += ort[j] * a[i + j * a_dim1]; /* L140: */ } f /= h; i_3 = *igh; for (j = m; j <= i_3; ++j) { /* L150: */ a[i + j * a_dim1] -= f * ort[j]; } /* L160: */ } ort[m] = scale * ort[m]; a[m + (m - 1) * a_dim1] = scale * g; L180: ; } L200: return 0; } /* orthes_ */ /* Subroutine */ int ortran_(integer *nm, integer *n, integer *low, integer * igh, doublereal *a, doublereal *ort, doublereal *z) { /* System generated locals */ integer a_dim1, a_offset, z_dim1, z_offset, i_1, i_2, i_3; /* Local variables */ static doublereal g; static integer i, j, kl, mm, mp, mp1; /* THIS SUBROUTINE IS A TRANSLATION OF THE ALGOL PROCEDURE ORTRANS, */ /* NUM. MATH. 16, 181-204(1970) BY PETERS AND WILKINSON. */ /* HANDBOOK FOR AUTO. COMP., VOL.II-LINEAR ALGEBRA, 372-395(1971). */ /* THIS SUBROUTINE ACCUMULATES THE ORTHOGONAL SIMILARITY */ /* TRANSFORMATIONS USED IN THE REDUCTION OF A REAL GENERAL */ /* MATRIX TO UPPER HESSENBERG FORM BY ORTHES. */ /* ON INPUT */ /* NM MUST BE SET TO THE ROW DIMENSION OF TWO-DIMENSIONAL */ /* ARRAY PARAMETERS AS DECLARED IN THE CALLING PROGRAM */ /* DIMENSION STATEMENT. */ /* N IS THE ORDER OF THE MATRIX. */ /* LOW AND IGH ARE INTEGERS DETERMINED BY THE BALANCING */ /* SUBROUTINE BALANC. IF BALANC HAS NOT BEEN USED, */ /* SET LOW=1, IGH=N. */ /* A CONTAINS INFORMATION ABOUT THE ORTHOGONAL TRANS- */ /* FORMATIONS USED IN THE REDUCTION BY ORTHES */ /* IN ITS STRICT LOWER TRIANGLE. */ /* ORT CONTAINS FURTHER INFORMATION ABOUT THE TRANS- */ /* FORMATIONS USED IN THE REDUCTION BY ORTHES. */ /* ONLY ELEMENTS LOW THROUGH IGH ARE USED. */ /* ON OUTPUT */ /* Z CONTAINS THE TRANSFORMATION MATRIX PRODUCED IN THE */ /* REDUCTION BY ORTHES. */ /* ORT HAS BEEN ALTERED. */ /* QUESTIONS AND COMMENTS SHOULD BE DIRECTED TO BURTON S. GARBOW, */ /* MATHEMATICS AND COMPUTER SCIENCE DIV, ARGONNE NATIONAL LABORATORY */ /* THIS VERSION DATED AUGUST 1983. */ /* ------------------------------------------------------------------ */ /* .......... INITIALIZE Z TO IDENTITY MATRIX .......... */ /* Parameter adjustments */ z_dim1 = *nm; z_offset = z_dim1 + 1; z -= z_offset; --ort; a_dim1 = *nm; a_offset = a_dim1 + 1; a -= a_offset; /* Function Body */ i_1 = *n; for (j = 1; j <= i_1; ++j) { i_2 = *n; for (i = 1; i <= i_2; ++i) { /* L60: */ z[i + j * z_dim1] = 0.; } z[j + j * z_dim1] = 1.; /* L80: */ } kl = *igh - *low - 1; if (kl < 1) { goto L200; } /* .......... FOR MP=IGH-1 STEP -1 UNTIL LOW+1 DO -- .......... */ i_1 = kl; for (mm = 1; mm <= i_1; ++mm) { mp = *igh - mm; if (a[mp + (mp - 1) * a_dim1] == 0.) { goto L140; } mp1 = mp + 1; i_2 = *igh; for (i = mp1; i <= i_2; ++i) { /* L100: */ ort[i] = a[i + (mp - 1) * a_dim1]; } i_2 = *igh; for (j = mp; j <= i_2; ++j) { g = 0.; i_3 = *igh; for (i = mp; i <= i_3; ++i) { /* L110: */ g += ort[i] * z[i + j * z_dim1]; } /* .......... DIVISOR BELOW IS NEGATIVE OF H FORMED IN ORTHES. */ /* DOUBLE DIVISION AVOIDS POSSIBLE UNDERFLOW ...... .... */ g = g / ort[mp] / a[mp + (mp - 1) * a_dim1]; i_3 = *igh; for (i = mp; i <= i_3; ++i) { /* L120: */ z[i + j * z_dim1] += g * ort[i]; } /* L130: */ } L140: ; } L200: return 0; } /* ortran_ */ /* Subroutine */ int qzhes_(integer *nm, integer *n, doublereal *a, doublereal *b, logical *matz, doublereal *z) { /* System generated locals */ integer a_dim1, a_offset, b_dim1, b_offset, z_dim1, z_offset, i_1, i_2, i_3; doublereal d_1, d_2; /* Builtin functions */ double sqrt(doublereal), d_sign(doublereal *, doublereal *); /* Local variables */ static integer i, j, k, l; static doublereal r, s, t; static integer l1; static doublereal u1, u2, v1, v2; static integer lb, nk1, nm1, nm2; static doublereal rho; /* THIS SUBROUTINE IS THE FIRST STEP OF THE QZ ALGORITHM */ /* FOR SOLVING GENERALIZED MATRIX EIGENVALUE PROBLEMS, */ /* SIAM J. NUMER. ANAL. 10, 241-256(1973) BY MOLER AND STEWART. */ /* THIS SUBROUTINE ACCEPTS A PAIR OF REAL GENERAL MATRICES AND */ /* REDUCES ONE OF THEM TO UPPER HESSENBERG FORM AND THE OTHER */ /* TO UPPER TRIANGULAR FORM USING ORTHOGONAL TRANSFORMATIONS. */ /* IT IS USUALLY FOLLOWED BY QZIT, QZVAL AND, POSSIBLY, QZVEC. */ /* ON INPUT */ /* NM MUST BE SET TO THE ROW DIMENSION OF TWO-DIMENSIONAL */ /* ARRAY PARAMETERS AS DECLARED IN THE CALLING PROGRAM */ /* DIMENSION STATEMENT. */ /* N IS THE ORDER OF THE MATRICES. */ /* A CONTAINS A REAL GENERAL MATRIX. */ /* B CONTAINS A REAL GENERAL MATRIX. */ /* MATZ SHOULD BE SET TO .TRUE. IF THE RIGHT HAND TRANSFORMATIONS */ /* ARE TO BE ACCUMULATED FOR LATER USE IN COMPUTING */ /* EIGENVECTORS, AND TO .FALSE. OTHERWISE. */ /* ON OUTPUT */ /* A HAS BEEN REDUCED TO UPPER HESSENBERG FORM. THE ELEMENTS */ /* BELOW THE FIRST SUBDIAGONAL HAVE BEEN SET TO ZERO. */ /* B HAS BEEN REDUCED TO UPPER TRIANGULAR FORM. THE ELEMENTS */ /* BELOW THE MAIN DIAGONAL HAVE BEEN SET TO ZERO. */ /* Z CONTAINS THE PRODUCT OF THE RIGHT HAND TRANSFORMATIONS IF */ /* MATZ HAS BEEN SET TO .TRUE. OTHERWISE, Z IS NOT REFERENCED. */ /* QUESTIONS AND COMMENTS SHOULD BE DIRECTED TO BURTON S. GARBOW, */ /* MATHEMATICS AND COMPUTER SCIENCE DIV, ARGONNE NATIONAL LABORATORY */ /* THIS VERSION DATED AUGUST 1983. */ /* ------------------------------------------------------------------ */ /* .......... INITIALIZE Z .......... */ /* Parameter adjustments */ z_dim1 = *nm; z_offset = z_dim1 + 1; z -= z_offset; b_dim1 = *nm; b_offset = b_dim1 + 1; b -= b_offset; a_dim1 = *nm; a_offset = a_dim1 + 1; a -= a_offset; /* Function Body */ if (! (*matz)) { goto L10; } i_1 = *n; for (j = 1; j <= i_1; ++j) { i_2 = *n; for (i = 1; i <= i_2; ++i) { z[i + j * z_dim1] = 0.; /* L2: */ } z[j + j * z_dim1] = 1.; /* L3: */ } /* .......... REDUCE B TO UPPER TRIANGULAR FORM .......... */ L10: if (*n <= 1) { goto L170; } nm1 = *n - 1; i_1 = nm1; for (l = 1; l <= i_1; ++l) { l1 = l + 1; s = 0.; i_2 = *n; for (i = l1; i <= i_2; ++i) { s += (d_1 = b[i + l * b_dim1], abs(d_1)); /* L20: */ } if (s == 0.) { goto L100; } s += (d_1 = b[l + l * b_dim1], abs(d_1)); r = 0.; i_2 = *n; for (i = l; i <= i_2; ++i) { b[i + l * b_dim1] /= s; /* Computing 2nd power */ d_1 = b[i + l * b_dim1]; r += d_1 * d_1; /* L25: */ } d_1 = sqrt(r); r = d_sign(&d_1, &b[l + l * b_dim1]); b[l + l * b_dim1] += r; rho = r * b[l + l * b_dim1]; i_2 = *n; for (j = l1; j <= i_2; ++j) { t = 0.; i_3 = *n; for (i = l; i <= i_3; ++i) { t += b[i + l * b_dim1] * b[i + j * b_dim1]; /* L30: */ } t = -t / rho; i_3 = *n; for (i = l; i <= i_3; ++i) { b[i + j * b_dim1] += t * b[i + l * b_dim1]; /* L40: */ } /* L50: */ } i_2 = *n; for (j = 1; j <= i_2; ++j) { t = 0.; i_3 = *n; for (i = l; i <= i_3; ++i) { t += b[i + l * b_dim1] * a[i + j * a_dim1]; /* L60: */ } t = -t / rho; i_3 = *n; for (i = l; i <= i_3; ++i) { a[i + j * a_dim1] += t * b[i + l * b_dim1]; /* L70: */ } /* L80: */ } b[l + l * b_dim1] = -s * r; i_2 = *n; for (i = l1; i <= i_2; ++i) { b[i + l * b_dim1] = 0.; /* L90: */ } L100: ; } /* .......... REDUCE A TO UPPER HESSENBERG FORM, WHILE */ /* KEEPING B TRIANGULAR .......... */ if (*n == 2) { goto L170; } nm2 = *n - 2; i_1 = nm2; for (k = 1; k <= i_1; ++k) { nk1 = nm1 - k; /* .......... FOR L=N-1 STEP -1 UNTIL K+1 DO -- .......... */ i_2 = nk1; for (lb = 1; lb <= i_2; ++lb) { l = *n - lb; l1 = l + 1; /* .......... ZERO A(L+1,K) .......... */ s = (d_1 = a[l + k * a_dim1], abs(d_1)) + (d_2 = a[l1 + k * a_dim1], abs(d_2)); if (s == 0.) { goto L150; } u1 = a[l + k * a_dim1] / s; u2 = a[l1 + k * a_dim1] / s; d_1 = sqrt(u1 * u1 + u2 * u2); r = d_sign(&d_1, &u1); v1 = -(u1 + r) / r; v2 = -u2 / r; u2 = v2 / v1; i_3 = *n; for (j = k; j <= i_3; ++j) { t = a[l + j * a_dim1] + u2 * a[l1 + j * a_dim1]; a[l + j * a_dim1] += t * v1; a[l1 + j * a_dim1] += t * v2; /* L110: */ } a[l1 + k * a_dim1] = 0.; i_3 = *n; for (j = l; j <= i_3; ++j) { t = b[l + j * b_dim1] + u2 * b[l1 + j * b_dim1]; b[l + j * b_dim1] += t * v1; b[l1 + j * b_dim1] += t * v2; /* L120: */ } /* .......... ZERO B(L+1,L) .......... */ s = (d_1 = b[l1 + l1 * b_dim1], abs(d_1)) + (d_2 = b[l1 + l * b_dim1], abs(d_2)); if (s == 0.) { goto L150; } u1 = b[l1 + l1 * b_dim1] / s; u2 = b[l1 + l * b_dim1] / s; d_1 = sqrt(u1 * u1 + u2 * u2); r = d_sign(&d_1, &u1); v1 = -(u1 + r) / r; v2 = -u2 / r; u2 = v2 / v1; i_3 = l1; for (i = 1; i <= i_3; ++i) { t = b[i + l1 * b_dim1] + u2 * b[i + l * b_dim1]; b[i + l1 * b_dim1] += t * v1; b[i + l * b_dim1] += t * v2; /* L130: */ } b[l1 + l * b_dim1] = 0.; i_3 = *n; for (i = 1; i <= i_3; ++i) { t = a[i + l1 * a_dim1] + u2 * a[i + l * a_dim1]; a[i + l1 * a_dim1] += t * v1; a[i + l * a_dim1] += t * v2; /* L140: */ } if (! (*matz)) { goto L150; } i_3 = *n; for (i = 1; i <= i_3; ++i) { t = z[i + l1 * z_dim1] + u2 * z[i + l * z_dim1]; z[i + l1 * z_dim1] += t * v1; z[i + l * z_dim1] += t * v2; /* L145: */ } L150: ; } /* L160: */ } L170: return 0; } /* qzhes_ */ /* Subroutine */ int qzit_(integer *nm, integer *n, doublereal *a, doublereal *b, doublereal *eps1, logical *matz, doublereal *z, integer *ierr) { /* System generated locals */ integer a_dim1, a_offset, b_dim1, b_offset, z_dim1, z_offset, i_1, i_2, i_3; doublereal d_1, d_2, d_3; /* Builtin functions */ double sqrt(doublereal), d_sign(doublereal *, doublereal *); /* Local variables */ static doublereal epsa, epsb; static integer i, j, k, l; static doublereal r, s, t, anorm, bnorm; static integer enorn; static doublereal a1, a2, a3; static integer k1, k2, l1; static doublereal u1, u2, u3, v1, v2, v3, a11, a12, a21, a22, a33, a34, a43, a44, b11, b12, b22, b33; static integer na, ld; static doublereal b34, b44; static integer en; static doublereal ep; static integer ll; static doublereal sh; extern doublereal epslon_(doublereal *); static logical notlas; static integer km1, lm1; static doublereal ani, bni; static integer ish, itn, its, enm2, lor1; /* THIS SUBROUTINE IS THE SECOND STEP OF THE QZ ALGORITHM */ /* FOR SOLVING GENERALIZED MATRIX EIGENVALUE PROBLEMS, */ /* SIAM J. NUMER. ANAL. 10, 241-256(1973) BY MOLER AND STEWART, */ /* AS MODIFIED IN TECHNICAL NOTE NASA TN D-7305(1973) BY WARD. */ /* THIS SUBROUTINE ACCEPTS A PAIR OF REAL MATRICES, ONE OF THEM */ /* IN UPPER HESSENBERG FORM AND THE OTHER IN UPPER TRIANGULAR FORM. */ /* IT REDUCES THE HESSENBERG MATRIX TO QUASI-TRIANGULAR FORM USING */ /* ORTHOGONAL TRANSFORMATIONS WHILE MAINTAINING THE TRIANGULAR FORM */ /* OF THE OTHER MATRIX. IT IS USUALLY PRECEDED BY QZHES AND */ /* FOLLOWED BY QZVAL AND, POSSIBLY, QZVEC. */ /* ON INPUT */ /* NM MUST BE SET TO THE ROW DIMENSION OF TWO-DIMENSIONAL */ /* ARRAY PARAMETERS AS DECLARED IN THE CALLING PROGRAM */ /* DIMENSION STATEMENT. */ /* N IS THE ORDER OF THE MATRICES. */ /* A CONTAINS A REAL UPPER HESSENBERG MATRIX. */ /* B CONTAINS A REAL UPPER TRIANGULAR MATRIX. */ /* EPS1 IS A TOLERANCE USED TO DETERMINE NEGLIGIBLE ELEMENTS. */ /* EPS1 = 0.0 (OR NEGATIVE) MAY BE INPUT, IN WHICH CASE AN */ /* ELEMENT WILL BE NEGLECTED ONLY IF IT IS LESS THAN ROUNDOFF */ /* ERROR TIMES THE NORM OF ITS MATRIX. IF THE INPUT EPS1 IS */ /* POSITIVE, THEN AN ELEMENT WILL BE CONSIDERED NEGLIGIBLE */ /* IF IT IS LESS THAN EPS1 TIMES THE NORM OF ITS MATRIX. A */ /* POSITIVE VALUE OF EPS1 MAY RESULT IN FASTER EXECUTION, */ /* BUT LESS ACCURATE RESULTS. */ /* MATZ SHOULD BE SET TO .TRUE. IF THE RIGHT HAND TRANSFORMATIONS */ /* ARE TO BE ACCUMULATED FOR LATER USE IN COMPUTING */ /* EIGENVECTORS, AND TO .FALSE. OTHERWISE. */ /* Z CONTAINS, IF MATZ HAS BEEN SET TO .TRUE., THE */ /* TRANSFORMATION MATRIX PRODUCED IN THE REDUCTION */ /* BY QZHES, IF PERFORMED, OR ELSE THE IDENTITY MATRIX. */ /* IF MATZ HAS BEEN SET TO .FALSE., Z IS NOT REFERENCED. */ /* ON OUTPUT */ /* A HAS BEEN REDUCED TO QUASI-TRIANGULAR FORM. THE ELEMENTS */ /* BELOW THE FIRST SUBDIAGONAL ARE STILL ZERO AND NO TWO */ /* CONSECUTIVE SUBDIAGONAL ELEMENTS ARE NONZERO. */ /* B IS STILL IN UPPER TRIANGULAR FORM, ALTHOUGH ITS ELEMENTS */ /* HAVE BEEN ALTERED. THE LOCATION B(N,1) IS USED TO STORE */ /* EPS1 TIMES THE NORM OF B FOR LATER USE BY QZVAL AND QZVEC. */ /* Z CONTAINS THE PRODUCT OF THE RIGHT HAND TRANSFORMATIONS */ /* (FOR BOTH STEPS) IF MATZ HAS BEEN SET TO .TRUE.. */ /* IERR IS SET TO */ /* ZERO FOR NORMAL RETURN, */ /* J IF THE LIMIT OF 30*N ITERATIONS IS EXHAUSTED */ /* WHILE THE J-TH EIGENVALUE IS BEING SOUGHT. */ /* 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 */ z_dim1 = *nm; z_offset = z_dim1 + 1; z -= z_offset; b_dim1 = *nm; b_offset = b_dim1 + 1; b -= b_offset; a_dim1 = *nm; a_offset = a_dim1 + 1; a -= a_offset; /* Function Body */ *ierr = 0; /* .......... COMPUTE EPSA,EPSB .......... */ anorm = 0.; bnorm = 0.; i_1 = *n; for (i = 1; i <= i_1; ++i) { ani = 0.; if (i != 1) { ani = (d_1 = a[i + (i - 1) * a_dim1], abs(d_1)); } bni = 0.; i_2 = *n; for (j = i; j <= i_2; ++j) { ani += (d_1 = a[i + j * a_dim1], abs(d_1)); bni += (d_1 = b[i + j * b_dim1], abs(d_1)); /* L20: */ } if (ani > anorm) { anorm = ani; } if (bni > bnorm) { bnorm = bni; } /* L30: */ } if (anorm == 0.) { anorm = 1.; } if (bnorm == 0.) { bnorm = 1.; } ep = *eps1; if (ep > 0.) { goto L50; } /* .......... USE ROUNDOFF LEVEL IF EPS1 IS ZERO .......... */ ep = epslon_(&c_b141); L50: epsa = ep * anorm; epsb = ep * bnorm; /* .......... REDUCE A TO QUASI-TRIANGULAR FORM, WHILE */ /* KEEPING B TRIANGULAR .......... */ lor1 = 1; enorn = *n; en = *n; itn = *n * 30; /* .......... BEGIN QZ STEP .......... */ L60: if (en <= 2) { goto L1001; } if (! (*matz)) { enorn = en; } its = 0; na = en - 1; enm2 = na - 1; L70: ish = 2; /* .......... CHECK FOR CONVERGENCE OR REDUCIBILITY. */ /* FOR L=EN STEP -1 UNTIL 1 DO -- .......... */ i_1 = en; for (ll = 1; ll <= i_1; ++ll) { lm1 = en - ll; l = lm1 + 1; if (l == 1) { goto L95; } if ((d_1 = a[l + lm1 * a_dim1], abs(d_1)) <= epsa) { goto L90; } /* L80: */ } L90: a[l + lm1 * a_dim1] = 0.; if (l < na) { goto L95; } /* .......... 1-BY-1 OR 2-BY-2 BLOCK ISOLATED .......... */ en = lm1; goto L60; /* .......... CHECK FOR SMALL TOP OF B .......... */ L95: ld = l; L100: l1 = l + 1; b11 = b[l + l * b_dim1]; if (abs(b11) > epsb) { goto L120; } b[l + l * b_dim1] = 0.; s = (d_1 = a[l + l * a_dim1], abs(d_1)) + (d_2 = a[l1 + l * a_dim1], abs(d_2)); u1 = a[l + l * a_dim1] / s; u2 = a[l1 + l * a_dim1] / s; d_1 = sqrt(u1 * u1 + u2 * u2); r = d_sign(&d_1, &u1); v1 = -(u1 + r) / r; v2 = -u2 / r; u2 = v2 / v1; i_1 = enorn; for (j = l; j <= i_1; ++j) { t = a[l + j * a_dim1] + u2 * a[l1 + j * a_dim1]; a[l + j * a_dim1] += t * v1; a[l1 + j * a_dim1] += t * v2; t = b[l + j * b_dim1] + u2 * b[l1 + j * b_dim1]; b[l + j * b_dim1] += t * v1; b[l1 + j * b_dim1] += t * v2; /* L110: */ } if (l != 1) { a[l + lm1 * a_dim1] = -a[l + lm1 * a_dim1]; } lm1 = l; l = l1; goto L90; L120: a11 = a[l + l * a_dim1] / b11; a21 = a[l1 + l * a_dim1] / b11; if (ish == 1) { goto L140; } /* .......... ITERATION STRATEGY .......... */ if (itn == 0) { goto L1000; } if (its == 10) { goto L155; } /* .......... DETERMINE TYPE OF SHIFT .......... */ b22 = b[l1 + l1 * b_dim1]; if (abs(b22) < epsb) { b22 = epsb; } b33 = b[na + na * b_dim1]; if (abs(b33) < epsb) { b33 = epsb; } b44 = b[en + en * b_dim1]; if (abs(b44) < epsb) { b44 = epsb; } a33 = a[na + na * a_dim1] / b33; a34 = a[na + en * a_dim1] / b44; a43 = a[en + na * a_dim1] / b33; a44 = a[en + en * a_dim1] / b44; b34 = b[na + en * b_dim1] / b44; t = (a43 * b34 - a33 - a44) * .5; r = t * t + a34 * a43 - a33 * a44; if (r < 0.) { goto L150; } /* .......... DETERMINE SINGLE SHIFT ZEROTH COLUMN OF A .......... */ ish = 1; r = sqrt(r); sh = -t + r; s = -t - r; if ((d_1 = s - a44, abs(d_1)) < (d_2 = sh - a44, abs(d_2))) { sh = s; } /* .......... LOOK FOR TWO CONSECUTIVE SMALL */ /* SUB-DIAGONAL ELEMENTS OF A. */ /* FOR L=EN-2 STEP -1 UNTIL LD DO -- .......... */ i_1 = enm2; for (ll = ld; ll <= i_1; ++ll) { l = enm2 + ld - ll; if (l == ld) { goto L140; } lm1 = l - 1; l1 = l + 1; t = a[l + l * a_dim1]; if ((d_1 = b[l + l * b_dim1], abs(d_1)) > epsb) { t -= sh * b[l + l * b_dim1]; } if ((d_1 = a[l + lm1 * a_dim1], abs(d_1)) <= (d_2 = t / a[l1 + l * a_dim1], abs(d_2)) * epsa) { goto L100; } /* L130: */ } L140: a1 = a11 - sh; a2 = a21; if (l != ld) { a[l + lm1 * a_dim1] = -a[l + lm1 * a_dim1]; } goto L160; /* .......... DETERMINE DOUBLE SHIFT ZEROTH COLUMN OF A .......... */ L150: a12 = a[l + l1 * a_dim1] / b22; a22 = a[l1 + l1 * a_dim1] / b22; b12 = b[l + l1 * b_dim1] / b22; a1 = ((a33 - a11) * (a44 - a11) - a34 * a43 + a43 * b34 * a11) / a21 + a12 - a11 * b12; a2 = a22 - a11 - a21 * b12 - (a33 - a11) - (a44 - a11) + a43 * b34; a3 = a[l1 + 1 + l1 * a_dim1] / b22; goto L160; /* .......... AD HOC SHIFT .......... */ L155: a1 = 0.; a2 = 1.; a3 = 1.1605; L160: ++its; --itn; if (! (*matz)) { lor1 = ld; } /* .......... MAIN LOOP .......... */ i_1 = na; for (k = l; k <= i_1; ++k) { notlas = k != na && ish == 2; k1 = k + 1; k2 = k + 2; /* Computing MAX */ i_2 = k - 1; km1 = max(i_2,l); /* Computing MIN */ i_2 = en, i_3 = k1 + ish; ll = min(i_2,i_3); if (notlas) { goto L190; } /* .......... ZERO A(K+1,K-1) .......... */ if (k == l) { goto L170; } a1 = a[k + km1 * a_dim1]; a2 = a[k1 + km1 * a_dim1]; L170: s = abs(a1) + abs(a2); if (s == 0.) { goto L70; } u1 = a1 / s; u2 = a2 / s; d_1 = sqrt(u1 * u1 + u2 * u2); r = d_sign(&d_1, &u1); v1 = -(u1 + r) / r; v2 = -u2 / r; u2 = v2 / v1; i_2 = enorn; for (j = km1; j <= i_2; ++j) { t = a[k + j * a_dim1] + u2 * a[k1 + j * a_dim1]; a[k + j * a_dim1] += t * v1; a[k1 + j * a_dim1] += t * v2; t = b[k + j * b_dim1] + u2 * b[k1 + j * b_dim1]; b[k + j * b_dim1] += t * v1; b[k1 + j * b_dim1] += t * v2; /* L180: */ } if (k != l) { a[k1 + km1 * a_dim1] = 0.; } goto L240; /* .......... ZERO A(K+1,K-1) AND A(K+2,K-1) .......... */ L190: if (k == l) { goto L200; } a1 = a[k + km1 * a_dim1]; a2 = a[k1 + km1 * a_dim1]; a3 = a[k2 + km1 * a_dim1]; L200: s = abs(a1) + abs(a2) + abs(a3); if (s == 0.) { goto L260; } u1 = a1 / s; u2 = a2 / s; u3 = a3 / s; d_1 = sqrt(u1 * u1 + u2 * u2 + u3 * u3); r = d_sign(&d_1, &u1); v1 = -(u1 + r) / r; v2 = -u2 / r; v3 = -u3 / r; u2 = v2 / v1; u3 = v3 / v1; i_2 = enorn; for (j = km1; j <= i_2; ++j) { t = a[k + j * a_dim1] + u2 * a[k1 + j * a_dim1] + u3 * a[k2 + j * a_dim1]; a[k + j * a_dim1] += t * v1; a[k1 + j * a_dim1] += t * v2; a[k2 + j * a_dim1] += t * v3; t = b[k + j * b_dim1] + u2 * b[k1 + j * b_dim1] + u3 * b[k2 + j * b_dim1]; b[k + j * b_dim1] += t * v1; b[k1 + j * b_dim1] += t * v2; b[k2 + j * b_dim1] += t * v3; /* L210: */ } if (k == l) { goto L220; } a[k1 + km1 * a_dim1] = 0.; a[k2 + km1 * a_dim1] = 0.; /* .......... ZERO B(K+2,K+1) AND B(K+2,K) .......... */ L220: s = (d_1 = b[k2 + k2 * b_dim1], abs(d_1)) + (d_2 = b[k2 + k1 * b_dim1], abs(d_2)) + (d_3 = b[k2 + k * b_dim1], abs(d_3)); if (s == 0.) { goto L240; } u1 = b[k2 + k2 * b_dim1] / s; u2 = b[k2 + k1 * b_dim1] / s; u3 = b[k2 + k * b_dim1] / s; d_1 = sqrt(u1 * u1 + u2 * u2 + u3 * u3); r = d_sign(&d_1, &u1); v1 = -(u1 + r) / r; v2 = -u2 / r; v3 = -u3 / r; u2 = v2 / v1; u3 = v3 / v1; i_2 = ll; for (i = lor1; i <= i_2; ++i) { t = a[i + k2 * a_dim1] + u2 * a[i + k1 * a_dim1] + u3 * a[i + k * a_dim1]; a[i + k2 * a_dim1] += t * v1; a[i + k1 * a_dim1] += t * v2; a[i + k * a_dim1] += t * v3; t = b[i + k2 * b_dim1] + u2 * b[i + k1 * b_dim1] + u3 * b[i + k * b_dim1]; b[i + k2 * b_dim1] += t * v1; b[i + k1 * b_dim1] += t * v2; b[i + k * b_dim1] += t * v3; /* L230: */ } b[k2 + k * b_dim1] = 0.; b[k2 + k1 * b_dim1] = 0.; if (! (*matz)) { goto L240; } i_2 = *n; for (i = 1; i <= i_2; ++i) { t = z[i + k2 * z_dim1] + u2 * z[i + k1 * z_dim1] + u3 * z[i + k * z_dim1]; z[i + k2 * z_dim1] += t * v1; z[i + k1 * z_dim1] += t * v2; z[i + k * z_dim1] += t * v3; /* L235: */ } /* .......... ZERO B(K+1,K) .......... */ L240: s = (d_1 = b[k1 + k1 * b_dim1], abs(d_1)) + (d_2 = b[k1 + k * b_dim1], abs(d_2)); if (s == 0.) { goto L260; } u1 = b[k1 + k1 * b_dim1] / s; u2 = b[k1 + k * b_dim1] / s; d_1 = sqrt(u1 * u1 + u2 * u2); r = d_sign(&d_1, &u1); v1 = -(u1 + r) / r; v2 = -u2 / r; u2 = v2 / v1; i_2 = ll; for (i = lor1; i <= i_2; ++i) { t = a[i + k1 * a_dim1] + u2 * a[i + k * a_dim1]; a[i + k1 * a_dim1] += t * v1; a[i + k * a_dim1] += t * v2; t = b[i + k1 * b_dim1] + u2 * b[i + k * b_dim1]; b[i + k1 * b_dim1] += t * v1; b[i + k * b_dim1] += t * v2; /* L250: */ } b[k1 + k * b_dim1] = 0.; if (! (*matz)) { goto L260; } i_2 = *n; for (i = 1; i <= i_2; ++i) { t = z[i + k1 * z_dim1] + u2 * z[i + k * z_dim1]; z[i + k1 * z_dim1] += t * v1; z[i + k * z_dim1] += t * v2; /* L255: */ } L260: ; } /* .......... END QZ STEP .......... */ goto L70; /* .......... SET ERROR -- ALL EIGENVALUES HAVE NOT */ /* CONVERGED AFTER 30*N ITERATIONS .......... */ L1000: *ierr = en; /* .......... SAVE EPSB FOR USE BY QZVAL AND QZVEC .......... */ L1001: if (*n > 1) { b[*n + b_dim1] = epsb; } return 0; } /* qzit_ */ /* Subroutine */ int qzval_(integer *nm, integer *n, doublereal *a, doublereal *b, doublereal *alfr, doublereal *alfi, doublereal *beta, logical *matz, doublereal *z) { /* System generated locals */ integer a_dim1, a_offset, b_dim1, b_offset, z_dim1, z_offset, i_1, i_2; doublereal d_1, d_2, d_3, d_4; /* Builtin functions */ double sqrt(doublereal), d_sign(doublereal *, doublereal *); /* Local variables */ static doublereal epsb, c, d, e; static integer i, j; static doublereal r, s, t, a1, a2, u1, u2, v1, v2, a11, a12, a21, a22, b11, b12, b22, di, ei; static integer na; static doublereal an, bn; static integer en; static doublereal cq, dr; static integer nn; static doublereal cz, ti, tr, a1i, a2i, a11i, a12i, a22i, a11r, a12r, a22r, sqi, ssi; static integer isw; static doublereal sqr, szi, ssr, szr; /* THIS SUBROUTINE IS THE THIRD STEP OF THE QZ ALGORITHM */ /* FOR SOLVING GENERALIZED MATRIX EIGENVALUE PROBLEMS, */ /* SIAM J. NUMER. ANAL. 10, 241-256(1973) BY MOLER AND STEWART. */ /* THIS SUBROUTINE ACCEPTS A PAIR OF REAL MATRICES, ONE OF THEM */ /* IN QUASI-TRIANGULAR FORM AND THE OTHER IN UPPER TRIANGULAR FORM. */ /* IT REDUCES THE QUASI-TRIANGULAR MATRIX FURTHER, SO THAT ANY */ /* REMAINING 2-BY-2 BLOCKS CORRESPOND TO PAIRS OF COMPLEX */ /* EIGENVALUES, AND RETURNS QUANTITIES WHOSE RATIOS GIVE THE */ /* GENERALIZED EIGENVALUES. IT IS USUALLY PRECEDED BY QZHES */ /* AND QZIT AND MAY BE FOLLOWED BY QZVEC. */ /* ON INPUT */ /* NM MUST BE SET TO THE ROW DIMENSION OF TWO-DIMENSIONAL */ /* ARRAY PARAMETERS AS DECLARED IN THE CALLING PROGRAM */ /* DIMENSION STATEMENT. */ /* N IS THE ORDER OF THE MATRICES. */ /* A CONTAINS A REAL UPPER QUASI-TRIANGULAR MATRIX. */ /* B CONTAINS A REAL UPPER TRIANGULAR MATRIX. IN ADDITION, */ /* LOCATION B(N,1) CONTAINS THE TOLERANCE QUANTITY (EPSB) */ /* COMPUTED AND SAVED IN QZIT. */ /* MATZ SHOULD BE SET TO .TRUE. IF THE RIGHT HAND TRANSFORMATIONS */ /* ARE TO BE ACCUMULATED FOR LATER USE IN COMPUTING */ /* EIGENVECTORS, AND TO .FALSE. OTHERWISE. */ /* Z CONTAINS, IF MATZ HAS BEEN SET TO .TRUE., THE */ /* TRANSFORMATION MATRIX PRODUCED IN THE REDUCTIONS BY QZHES */ /* AND QZIT, IF PERFORMED, OR ELSE THE IDENTITY MATRIX. */ /* IF MATZ HAS BEEN SET TO .FALSE., Z IS NOT REFERENCED. */ /* ON OUTPUT */ /* A HAS BEEN REDUCED FURTHER TO A QUASI-TRIANGULAR MATRIX */ /* IN WHICH ALL NONZERO SUBDIAGONAL ELEMENTS CORRESPOND TO */ /* PAIRS OF COMPLEX EIGENVALUES. */ /* B IS STILL IN UPPER TRIANGULAR FORM, ALTHOUGH ITS ELEMENTS */ /* HAVE BEEN ALTERED. B(N,1) IS UNALTERED. */ /* ALFR AND ALFI CONTAIN THE REAL AND IMAGINARY PARTS OF THE */ /* DIAGONAL ELEMENTS OF THE TRIANGULAR MATRIX THAT WOULD BE */ /* OBTAINED IF A WERE REDUCED COMPLETELY TO TRIANGULAR FORM */ /* BY UNITARY TRANSFORMATIONS. NON-ZERO VALUES OF ALFI OCCUR */ /* IN PAIRS, THE FIRST MEMBER POSITIVE AND THE SECOND NEGATIVE. */ /* BETA CONTAINS THE DIAGONAL ELEMENTS OF THE CORRESPONDING B, */ /* NORMALIZED TO BE REAL AND NON-NEGATIVE. THE GENERALIZED */ /* EIGENVALUES ARE THEN THE RATIOS ((ALFR+I*ALFI)/BETA). */ /* Z CONTAINS THE PRODUCT OF THE RIGHT HAND TRANSFORMATIONS */ /* (FOR ALL THREE STEPS) IF MATZ HAS BEEN SET TO .TRUE. */ /* 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 */ z_dim1 = *nm; z_offset = z_dim1 + 1; z -= z_offset; --beta; --alfi; --alfr; b_dim1 = *nm; b_offset = b_dim1 + 1; b -= b_offset; a_dim1 = *nm; a_offset = a_dim1 + 1; a -= a_offset; /* Function Body */ epsb = b[*n + b_dim1]; isw = 1; /* .......... FIND EIGENVALUES OF QUASI-TRIANGULAR MATRICES. */ /* FOR EN=N STEP -1 UNTIL 1 DO -- .......... */ i_1 = *n; for (nn = 1; nn <= i_1; ++nn) { en = *n + 1 - nn; na = en - 1; if (isw == 2) { goto L505; } if (en == 1) { goto L410; } if (a[en + na * a_dim1] != 0.) { goto L420; } /* .......... 1-BY-1 BLOCK, ONE REAL ROOT .......... */ L410: alfr[en] = a[en + en * a_dim1]; if (b[en + en * b_dim1] < 0.) { alfr[en] = -alfr[en]; } beta[en] = (d_1 = b[en + en * b_dim1], abs(d_1)); alfi[en] = 0.; goto L510; /* .......... 2-BY-2 BLOCK .......... */ L420: if ((d_1 = b[na + na * b_dim1], abs(d_1)) <= epsb) { goto L455; } if ((d_1 = b[en + en * b_dim1], abs(d_1)) > epsb) { goto L430; } a1 = a[en + en * a_dim1]; a2 = a[en + na * a_dim1]; bn = 0.; goto L435; L430: an = (d_1 = a[na + na * a_dim1], abs(d_1)) + (d_2 = a[na + en * a_dim1], abs(d_2)) + (d_3 = a[en + na * a_dim1], abs(d_3)) + (d_4 = a[en + en * a_dim1], abs(d_4)); bn = (d_1 = b[na + na * b_dim1], abs(d_1)) + (d_2 = b[na + en * b_dim1], abs(d_2)) + (d_3 = b[en + en * b_dim1], abs(d_3)); a11 = a[na + na * a_dim1] / an; a12 = a[na + en * a_dim1] / an; a21 = a[en + na * a_dim1] / an; a22 = a[en + en * a_dim1] / an; b11 = b[na + na * b_dim1] / bn; b12 = b[na + en * b_dim1] / bn; b22 = b[en + en * b_dim1] / bn; e = a11 / b11; ei = a22 / b22; s = a21 / (b11 * b22); t = (a22 - e * b22) / b22; if (abs(e) <= abs(ei)) { goto L431; } e = ei; t = (a11 - e * b11) / b11; L431: c = (t - s * b12) * .5; d = c * c + s * (a12 - e * b12); if (d < 0.) { goto L480; } /* .......... TWO REAL ROOTS. */ /* ZERO BOTH A(EN,NA) AND B(EN,NA) .......... */ d_1 = sqrt(d); e += c + d_sign(&d_1, &c); a11 -= e * b11; a12 -= e * b12; a22 -= e * b22; if (abs(a11) + abs(a12) < abs(a21) + abs(a22)) { goto L432; } a1 = a12; a2 = a11; goto L435; L432: a1 = a22; a2 = a21; /* .......... CHOOSE AND APPLY REAL Z .......... */ L435: s = abs(a1) + abs(a2); u1 = a1 / s; u2 = a2 / s; d_1 = sqrt(u1 * u1 + u2 * u2); r = d_sign(&d_1, &u1); v1 = -(u1 + r) / r; v2 = -u2 / r; u2 = v2 / v1; i_2 = en; for (i = 1; i <= i_2; ++i) { t = a[i + en * a_dim1] + u2 * a[i + na * a_dim1]; a[i + en * a_dim1] += t * v1; a[i + na * a_dim1] += t * v2; t = b[i + en * b_dim1] + u2 * b[i + na * b_dim1]; b[i + en * b_dim1] += t * v1; b[i + na * b_dim1] += t * v2; /* L440: */ } if (! (*matz)) { goto L450; } i_2 = *n; for (i = 1; i <= i_2; ++i) { t = z[i + en * z_dim1] + u2 * z[i + na * z_dim1]; z[i + en * z_dim1] += t * v1; z[i + na * z_dim1] += t * v2; /* L445: */ } L450: if (bn == 0.) { goto L475; } if (an < abs(e) * bn) { goto L455; } a1 = b[na + na * b_dim1]; a2 = b[en + na * b_dim1]; goto L460; L455: a1 = a[na + na * a_dim1]; a2 = a[en + na * a_dim1]; /* .......... CHOOSE AND APPLY REAL Q .......... */ L460: s = abs(a1) + abs(a2); if (s == 0.) { goto L475; } u1 = a1 / s; u2 = a2 / s; d_1 = sqrt(u1 * u1 + u2 * u2); r = d_sign(&d_1, &u1); v1 = -(u1 + r) / r; v2 = -u2 / r; u2 = v2 / v1; i_2 = *n; for (j = na; j <= i_2; ++j) { t = a[na + j * a_dim1] + u2 * a[en + j * a_dim1]; a[na + j * a_dim1] += t * v1; a[en + j * a_dim1] += t * v2; t = b[na + j * b_dim1] + u2 * b[en + j * b_dim1]; b[na + j * b_dim1] += t * v1; b[en + j * b_dim1] += t * v2; /* L470: */ } L475: a[en + na * a_dim1] = 0.; b[en + na * b_dim1] = 0.; alfr[na] = a[na + na * a_dim1]; alfr[en] = a[en + en * a_dim1]; if (b[na + na * b_dim1] < 0.) { alfr[na] = -alfr[na]; } if (b[en + en * b_dim1] < 0.) { alfr[en] = -alfr[en]; } beta[na] = (d_1 = b[na + na * b_dim1], abs(d_1)); beta[en] = (d_1 = b[en + en * b_dim1], abs(d_1)); alfi[en] = 0.; alfi[na] = 0.; goto L505; /* .......... TWO COMPLEX ROOTS .......... */ L480: e += c; ei = sqrt(-d); a11r = a11 - e * b11; a11i = ei * b11; a12r = a12 - e * b12; a12i = ei * b12; a22r = a22 - e * b22; a22i = ei * b22; if (abs(a11r) + abs(a11i) + abs(a12r) + abs(a12i) < abs(a21) + abs( a22r) + abs(a22i)) { goto L482; } a1 = a12r; a1i = a12i; a2 = -a11r; a2i = -a11i; goto L485; L482: a1 = a22r; a1i = a22i; a2 = -a21; a2i = 0.; /* .......... CHOOSE COMPLEX Z .......... */ L485: cz = sqrt(a1 * a1 + a1i * a1i); if (cz == 0.) { goto L487; } szr = (a1 * a2 + a1i * a2i) / cz; szi = (a1 * a2i - a1i * a2) / cz; r = sqrt(cz * cz + szr * szr + szi * szi); cz /= r; szr /= r; szi /= r; goto L490; L487: szr = 1.; szi = 0.; L490: if (an < (abs(e) + ei) * bn) { goto L492; } a1 = cz * b11 + szr * b12; a1i = szi * b12; a2 = szr * b22; a2i = szi * b22; goto L495; L492: a1 = cz * a11 + szr * a12; a1i = szi * a12; a2 = cz * a21 + szr * a22; a2i = szi * a22; /* .......... CHOOSE COMPLEX Q .......... */ L495: cq = sqrt(a1 * a1 + a1i * a1i); if (cq == 0.) { goto L497; } sqr = (a1 * a2 + a1i * a2i) / cq; sqi = (a1 * a2i - a1i * a2) / cq; r = sqrt(cq * cq + sqr * sqr + sqi * sqi); cq /= r; sqr /= r; sqi /= r; goto L500; L497: sqr = 1.; sqi = 0.; /* .......... COMPUTE DIAGONAL ELEMENTS THAT WOULD RESULT */ /* IF TRANSFORMATIONS WERE APPLIED .......... */ L500: ssr = sqr * szr + sqi * szi; ssi = sqr * szi - sqi * szr; i = 1; tr = cq * cz * a11 + cq * szr * a12 + sqr * cz * a21 + ssr * a22; ti = cq * szi * a12 - sqi * cz * a21 + ssi * a22; dr = cq * cz * b11 + cq * szr * b12 + ssr * b22; di = cq * szi * b12 + ssi * b22; goto L503; L502: i = 2; tr = ssr * a11 - sqr * cz * a12 - cq * szr * a21 + cq * cz * a22; ti = -ssi * a11 - sqi * cz * a12 + cq * szi * a21; dr = ssr * b11 - sqr * cz * b12 + cq * cz * b22; di = -ssi * b11 - sqi * cz * b12; L503: t = ti * dr - tr * di; j = na; if (t < 0.) { j = en; } r = sqrt(dr * dr + di * di); beta[j] = bn * r; alfr[j] = an * (tr * dr + ti * di) / r; alfi[j] = an * t / r; if (i == 1) { goto L502; } L505: isw = 3 - isw; L510: ; } b[*n + b_dim1] = epsb; return 0; } /* qzval_ */ /* Subroutine */ int qzvec_(integer *nm, integer *n, doublereal *a, doublereal *b, doublereal *alfr, doublereal *alfi, doublereal *beta, doublereal *z) { /* System generated locals */ integer a_dim1, a_offset, b_dim1, b_offset, z_dim1, z_offset, i_1, i_2, i_3; doublereal d_1, d_2; /* Builtin functions */ double sqrt(doublereal); /* Local variables */ static doublereal alfm, almi, betm, epsb, almr, d; static integer i, j, k, m; static doublereal q, r, s, t, w, x, y, t1, t2, w1, x1, z1, di; static integer na, ii, en, jj; static doublereal ra, dr, sa; static integer nn; static doublereal ti, rr, tr, zz; static integer isw, enm2; /* THIS SUBROUTINE IS THE OPTIONAL FOURTH STEP OF THE QZ ALGORITHM */ /* FOR SOLVING GENERALIZED MATRIX EIGENVALUE PROBLEMS, */ /* SIAM J. NUMER. ANAL. 10, 241-256(1973) BY MOLER AND STEWART. */ /* THIS SUBROUTINE ACCEPTS A PAIR OF REAL MATRICES, ONE OF THEM IN */ /* QUASI-TRIANGULAR FORM (IN WHICH EACH 2-BY-2 BLOCK CORRESPONDS TO */ /* A PAIR OF COMPLEX EIGENVALUES) AND THE OTHER IN UPPER TRIANGULAR */ /* FORM. IT COMPUTES THE EIGENVECTORS OF THE TRIANGULAR PROBLEM AND */ /* TRANSFORMS THE RESULTS BACK TO THE ORIGINAL COORDINATE SYSTEM. */ /* IT IS USUALLY PRECEDED BY QZHES, QZIT, AND QZVAL. */ /* ON INPUT */ /* NM MUST BE SET TO THE ROW DIMENSION OF TWO-DIMENSIONAL */ /* ARRAY PARAMETERS AS DECLARED IN THE CALLING PROGRAM */ /* DIMENSION STATEMENT. */ /* N IS THE ORDER OF THE MATRICES. */ /* A CONTAINS A REAL UPPER QUASI-TRIANGULAR MATRIX. */ /* B CONTAINS A REAL UPPER TRIANGULAR MATRIX. IN ADDITION, */ /* LOCATION B(N,1) CONTAINS THE TOLERANCE QUANTITY (EPSB) */ /* COMPUTED AND SAVED IN QZIT. */ /* ALFR, ALFI, AND BETA ARE VECTORS WITH COMPONENTS WHOSE */ /* RATIOS ((ALFR+I*ALFI)/BETA) ARE THE GENERALIZED */ /* EIGENVALUES. THEY ARE USUALLY OBTAINED FROM QZVAL. */ /* Z CONTAINS THE TRANSFORMATION MATRIX PRODUCED IN THE */ /* REDUCTIONS BY QZHES, QZIT, AND QZVAL, IF PERFORMED. */ /* IF THE EIGENVECTORS OF THE TRIANGULAR PROBLEM ARE */ /* DESIRED, Z MUST CONTAIN THE IDENTITY MATRIX. */ /* ON OUTPUT */ /* A IS UNALTERED. ITS SUBDIAGONAL ELEMENTS PROVIDE INFORMATION */ /* ABOUT THE STORAGE OF THE COMPLEX EIGENVECTORS. */ /* B HAS BEEN DESTROYED. */ /* ALFR, ALFI, AND BETA ARE UNALTERED. */ /* Z CONTAINS THE REAL AND IMAGINARY PARTS OF THE EIGENVECTORS. */ /* IF ALFI(I) .EQ. 0.0, THE I-TH EIGENVALUE IS REAL AND */ /* THE I-TH COLUMN OF Z CONTAINS ITS EIGENVECTOR. */ /* IF ALFI(I) .NE. 0.0, THE I-TH EIGENVALUE IS COMPLEX. */ /* IF ALFI(I) .GT. 0.0, THE EIGENVALUE IS THE FIRST OF */ /* A COMPLEX PAIR AND THE I-TH AND (I+1)-TH COLUMNS */ /* OF Z CONTAIN ITS EIGENVECTOR. */ /* IF ALFI(I) .LT. 0.0, THE EIGENVALUE IS THE SECOND OF */ /* A COMPLEX PAIR AND THE (I-1)-TH AND I-TH COLUMNS */ /* OF Z CONTAIN THE CONJUGATE OF ITS EIGENVECTOR. */ /* EACH EIGENVECTOR IS NORMALIZED SO THAT THE MODULUS */ /* OF ITS LARGEST COMPONENT IS 1.0 . */ /* 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 */ z_dim1 = *nm; z_offset = z_dim1 + 1; z -= z_offset; --beta; --alfi; --alfr; b_dim1 = *nm; b_offset = b_dim1 + 1; b -= b_offset; a_dim1 = *nm; a_offset = a_dim1 + 1; a -= a_offset; /* Function Body */ epsb = b[*n + b_dim1]; isw = 1; /* .......... FOR EN=N STEP -1 UNTIL 1 DO -- .......... */ i_1 = *n; for (nn = 1; nn <= i_1; ++nn) { en = *n + 1 - nn; na = en - 1; if (isw == 2) { goto L795; } if (alfi[en] != 0.) { goto L710; } /* .......... REAL VECTOR .......... */ m = en; b[en + en * b_dim1] = 1.; if (na == 0) { goto L800; } alfm = alfr[m]; betm = beta[m]; /* .......... FOR I=EN-1 STEP -1 UNTIL 1 DO -- .......... */ i_2 = na; for (ii = 1; ii <= i_2; ++ii) { i = en - ii; w = betm * a[i + i * a_dim1] - alfm * b[i + i * b_dim1]; r = 0.; i_3 = en; for (j = m; j <= i_3; ++j) { /* L610: */ r += (betm * a[i + j * a_dim1] - alfm * b[i + j * b_dim1]) * b[j + en * b_dim1]; } if (i == 1 || isw == 2) { goto L630; } if (betm * a[i + (i - 1) * a_dim1] == 0.) { goto L630; } zz = w; s = r; goto L690; L630: m = i; if (isw == 2) { goto L640; } /* .......... REAL 1-BY-1 BLOCK .......... */ t = w; if (w == 0.) { t = epsb; } b[i + en * b_dim1] = -r / t; goto L700; /* .......... REAL 2-BY-2 BLOCK .......... */ L640: x = betm * a[i + (i + 1) * a_dim1] - alfm * b[i + (i + 1) * b_dim1]; y = betm * a[i + 1 + i * a_dim1]; q = w * zz - x * y; t = (x * s - zz * r) / q; b[i + en * b_dim1] = t; if (abs(x) <= abs(zz)) { goto L650; } b[i + 1 + en * b_dim1] = (-r - w * t) / x; goto L690; L650: b[i + 1 + en * b_dim1] = (-s - y * t) / zz; L690: isw = 3 - isw; L700: ; } /* .......... END REAL VECTOR .......... */ goto L800; /* .......... COMPLEX VECTOR .......... */ L710: m = na; almr = alfr[m]; almi = alfi[m]; betm = beta[m]; /* .......... LAST VECTOR COMPONENT CHOSEN IMAGINARY SO THAT */ /* EIGENVECTOR MATRIX IS TRIANGULAR .......... */ y = betm * a[en + na * a_dim1]; b[na + na * b_dim1] = -almi * b[en + en * b_dim1] / y; b[na + en * b_dim1] = (almr * b[en + en * b_dim1] - betm * a[en + en * a_dim1]) / y; b[en + na * b_dim1] = 0.; b[en + en * b_dim1] = 1.; enm2 = na - 1; if (enm2 == 0) { goto L795; } /* .......... FOR I=EN-2 STEP -1 UNTIL 1 DO -- .......... */ i_2 = enm2; for (ii = 1; ii <= i_2; ++ii) { i = na - ii; w = betm * a[i + i * a_dim1] - almr * b[i + i * b_dim1]; w1 = -almi * b[i + i * b_dim1]; ra = 0.; sa = 0.; i_3 = en; for (j = m; j <= i_3; ++j) { x = betm * a[i + j * a_dim1] - almr * b[i + j * b_dim1]; x1 = -almi * b[i + j * b_dim1]; ra = ra + x * b[j + na * b_dim1] - x1 * b[j + en * b_dim1]; sa = sa + x * b[j + en * b_dim1] + x1 * b[j + na * b_dim1]; /* L760: */ } if (i == 1 || isw == 2) { goto L770; } if (betm * a[i + (i - 1) * a_dim1] == 0.) { goto L770; } zz = w; z1 = w1; r = ra; s = sa; isw = 2; goto L790; L770: m = i; if (isw == 2) { goto L780; } /* .......... COMPLEX 1-BY-1 BLOCK .......... */ tr = -ra; ti = -sa; L773: dr = w; di = w1; /* .......... COMPLEX DIVIDE (T1,T2) = (TR,TI) / (DR,DI) ..... ..... */ L775: if (abs(di) > abs(dr)) { goto L777; } rr = di / dr; d = dr + di * rr; t1 = (tr + ti * rr) / d; t2 = (ti - tr * rr) / d; switch (isw) { case 1: goto L787; case 2: goto L782; } L777: rr = dr / di; d = dr * rr + di; t1 = (tr * rr + ti) / d; t2 = (ti * rr - tr) / d; switch (isw) { case 1: goto L787; case 2: goto L782; } /* .......... COMPLEX 2-BY-2 BLOCK .......... */ L780: x = betm * a[i + (i + 1) * a_dim1] - almr * b[i + (i + 1) * b_dim1]; x1 = -almi * b[i + (i + 1) * b_dim1]; y = betm * a[i + 1 + i * a_dim1]; tr = y * ra - w * r + w1 * s; ti = y * sa - w * s - w1 * r; dr = w * zz - w1 * z1 - x * y; di = w * z1 + w1 * zz - x1 * y; if (dr == 0. && di == 0.) { dr = epsb; } goto L775; L782: b[i + 1 + na * b_dim1] = t1; b[i + 1 + en * b_dim1] = t2; isw = 1; if (abs(y) > abs(w) + abs(w1)) { goto L785; } tr = -ra - x * b[i + 1 + na * b_dim1] + x1 * b[i + 1 + en * b_dim1]; ti = -sa - x * b[i + 1 + en * b_dim1] - x1 * b[i + 1 + na * b_dim1]; goto L773; L785: t1 = (-r - zz * b[i + 1 + na * b_dim1] + z1 * b[i + 1 + en * b_dim1]) / y; t2 = (-s - zz * b[i + 1 + en * b_dim1] - z1 * b[i + 1 + na * b_dim1]) / y; L787: b[i + na * b_dim1] = t1; b[i + en * b_dim1] = t2; L790: ; } /* .......... END COMPLEX VECTOR .......... */ L795: isw = 3 - isw; L800: ; } /* .......... END BACK SUBSTITUTION. */ /* TRANSFORM TO ORIGINAL COORDINATE SYSTEM. */ /* FOR J=N STEP -1 UNTIL 1 DO -- .......... */ i_1 = *n; for (jj = 1; jj <= i_1; ++jj) { j = *n + 1 - jj; i_2 = *n; for (i = 1; i <= i_2; ++i) { zz = 0.; i_3 = j; for (k = 1; k <= i_3; ++k) { /* L860: */ zz += z[i + k * z_dim1] * b[k + j * b_dim1]; } z[i + j * z_dim1] = zz; /* L880: */ } } /* .......... NORMALIZE SO THAT MODULUS OF LARGEST */ /* COMPONENT OF EACH VECTOR IS 1. */ /* (ISW IS 1 INITIALLY FROM BEFORE) .......... */ i_2 = *n; for (j = 1; j <= i_2; ++j) { d = 0.; if (isw == 2) { goto L920; } if (alfi[j] != 0.) { goto L945; } i_1 = *n; for (i = 1; i <= i_1; ++i) { if ((d_1 = z[i + j * z_dim1], abs(d_1)) > d) { d = (d_2 = z[i + j * z_dim1], abs(d_2)); } /* L890: */ } i_1 = *n; for (i = 1; i <= i_1; ++i) { /* L900: */ z[i + j * z_dim1] /= d; } goto L950; L920: i_1 = *n; for (i = 1; i <= i_1; ++i) { r = (d_1 = z[i + (j - 1) * z_dim1], abs(d_1)) + (d_2 = z[i + j * z_dim1], abs(d_2)); if (r != 0.) { /* Computing 2nd power */ d_1 = z[i + (j - 1) * z_dim1] / r; /* Computing 2nd power */ d_2 = z[i + j * z_dim1] / r; r *= sqrt(d_1 * d_1 + d_2 * d_2); } if (r > d) { d = r; } /* L930: */ } i_1 = *n; for (i = 1; i <= i_1; ++i) { z[i + (j - 1) * z_dim1] /= d; z[i + j * z_dim1] /= d; /* L940: */ } L945: isw = 3 - isw; L950: ; } return 0; } /* qzvec_ */ /* Subroutine */ int ratqr_(integer *n, doublereal *eps1, doublereal *d, doublereal *e, doublereal *e2, integer *m, doublereal *w, integer * ind, doublereal *bd, logical *type, integer *idef, integer *ierr) { /* System generated locals */ integer i_1, i_2; doublereal d_1, d_2, d_3; /* Local variables */ static integer jdef; static doublereal f; static integer i, j, k; static doublereal p, q, r, s, delta; static integer k1, ii, jj; static doublereal ep, qp; extern doublereal epslon_(doublereal *); static doublereal err, tot; /* THIS SUBROUTINE IS A TRANSLATION OF THE ALGOL PROCEDURE RATQR, */ /* NUM. MATH. 11, 264-272(1968) BY REINSCH AND BAUER. */ /* HANDBOOK FOR AUTO. COMP., VOL.II-LINEAR ALGEBRA, 257-265(1971). */ /* THIS SUBROUTINE FINDS THE ALGEBRAICALLY SMALLEST OR LARGEST */ /* EIGENVALUES OF A SYMMETRIC TRIDIAGONAL MATRIX BY THE */ /* RATIONAL QR METHOD WITH NEWTON CORRECTIONS. */ /* ON INPUT */ /* N IS THE ORDER OF THE MATRIX. */ /* EPS1 IS A THEORETICAL ABSOLUTE ERROR TOLERANCE FOR THE */ /* COMPUTED EIGENVALUES. IF THE INPUT EPS1 IS NON-POSITIVE, */ /* OR INDEED SMALLER THAN ITS DEFAULT VALUE, IT IS RESET */ /* AT EACH ITERATION TO THE RESPECTIVE DEFAULT VALUE, */ /* NAMELY, THE PRODUCT OF THE RELATIVE MACHINE PRECISION */ /* AND THE MAGNITUDE OF THE CURRENT EIGENVALUE ITERATE. */ /* THE THEORETICAL ABSOLUTE ERROR IN THE K-TH EIGENVALUE */ /* IS USUALLY NOT GREATER THAN K TIMES EPS1. */ /* D CONTAINS THE DIAGONAL ELEMENTS OF THE INPUT MATRIX. */ /* E CONTAINS THE SUBDIAGONAL ELEMENTS OF THE INPUT MATRIX */ /* IN ITS LAST N-1 POSITIONS. E(1) IS ARBITRARY. */ /* E2 CONTAINS THE SQUARES OF THE CORRESPONDING ELEMENTS OF E. */ /* E2(1) IS ARBITRARY. */ /* M IS THE NUMBER OF EIGENVALUES TO BE FOUND. */ /* IDEF SHOULD BE SET TO 1 IF THE INPUT MATRIX IS KNOWN TO BE */ /* POSITIVE DEFINITE, TO -1 IF THE INPUT MATRIX IS KNOWN TO */ /* BE NEGATIVE DEFINITE, AND TO 0 OTHERWISE. */ /* TYPE SHOULD BE SET TO .TRUE. IF THE SMALLEST EIGENVALUES */ /* ARE TO BE FOUND, AND TO .FALSE. IF THE LARGEST EIGENVALUES */ /* ARE TO BE FOUND. */ /* ON OUTPUT */ /* EPS1 IS UNALTERED UNLESS IT HAS BEEN RESET TO ITS */ /* (LAST) DEFAULT VALUE. */ /* D AND E ARE UNALTERED (UNLESS W OVERWRITES D). */ /* 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 SET TO 0.0D0 IF THE SMALLEST EIGENVALUES HAVE BEEN */ /* FOUND, AND TO 2.0D0 IF THE LARGEST EIGENVALUES HAVE BEEN */ /* FOUND. E2 IS OTHERWISE UNALTERED (UNLESS OVERWRITTEN BY BD). */ /* W CONTAINS THE M ALGEBRAICALLY SMALLEST EIGENVALUES IN */ /* ASCENDING ORDER, OR THE M LARGEST EIGENVALUES IN */ /* DESCENDING ORDER. IF AN ERROR EXIT IS MADE BECAUSE OF */ /* AN INCORRECT SPECIFICATION OF IDEF, NO EIGENVALUES */ /* ARE FOUND. IF THE NEWTON ITERATES FOR A PARTICULAR */ /* EIGENVALUE ARE NOT MONOTONE, THE BEST ESTIMATE OBTAINED */ /* IS RETURNED AND IERR IS SET. W MAY COINCIDE WITH D. */ /* IND CONTAINS IN ITS FIRST M POSITIONS 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.. */ /* BD CONTAINS REFINED BOUNDS FOR THE THEORETICAL ERRORS OF THE */ /* CORRESPONDING EIGENVALUES IN W. THESE BOUNDS ARE USUALLY */ /* WITHIN THE TOLERANCE SPECIFIED BY EPS1. BD MAY COINCIDE */ /* WITH E2. */ /* IERR IS SET TO */ /* ZERO FOR NORMAL RETURN, */ /* 6*N+1 IF IDEF IS SET TO 1 AND TYPE TO .TRUE. */ /* WHEN THE MATRIX IS NOT POSITIVE DEFINITE, OR */ /* IF IDEF IS SET TO -1 AND TYPE TO .FALSE. */ /* WHEN THE MATRIX IS NOT NEGATIVE DEFINITE, */ /* 5*N+K IF SUCCESSIVE ITERATES TO THE K-TH EIGENVALUE */ /* ARE NOT MONOTONE INCREASING, WHERE K REFERS */ /* TO THE LAST SUCH OCCURRENCE. */ /* NOTE THAT SUBROUTINE TRIDIB IS GENERALLY FASTER AND MORE */ /* ACCURATE THAN RATQR IF THE EIGENVALUES ARE CLUSTERED. */ /* 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 */ --bd; --ind; --w; --e2; --e; --d; /* Function Body */ *ierr = 0; jdef = *idef; /* .......... COPY D ARRAY INTO W .......... */ i_1 = *n; for (i = 1; i <= i_1; ++i) { /* L20: */ w[i] = d[i]; } if (*type) { goto L40; } j = 1; goto L400; L40: err = 0.; s = 0.; /* .......... LOOK FOR SMALL SUB-DIAGONAL ENTRIES AND DEFINE */ /* INITIAL SHIFT FROM LOWER GERSCHGORIN BOUND. */ /* COPY E2 ARRAY INTO BD .......... */ tot = w[1]; q = 0.; j = 0; i_1 = *n; for (i = 1; i <= i_1; ++i) { p = q; if (i == 1) { goto L60; } d_3 = (d_1 = d[i], abs(d_1)) + (d_2 = d[i - 1], abs(d_2)); if (p > epslon_(&d_3)) { goto L80; } L60: e2[i] = 0.; L80: bd[i] = e2[i]; /* .......... COUNT ALSO IF ELEMENT OF E2 HAS UNDERFLOWED ........ .. */ if (e2[i] == 0.) { ++j; } ind[i] = j; q = 0.; if (i != *n) { q = (d_1 = e[i + 1], abs(d_1)); } /* Computing MIN */ d_1 = w[i] - p - q; tot = min(d_1,tot); /* L100: */ } if (jdef == 1 && tot < 0.) { goto L140; } i_1 = *n; for (i = 1; i <= i_1; ++i) { /* L110: */ w[i] -= tot; } goto L160; L140: tot = 0.; L160: i_1 = *m; for (k = 1; k <= i_1; ++k) { /* .......... NEXT QR TRANSFORMATION .......... */ L180: tot += s; delta = w[*n] - s; i = *n; f = (d_1 = epslon_(&tot), abs(d_1)); if (*eps1 < f) { *eps1 = f; } if (delta > *eps1) { goto L190; } if (delta < -(*eps1)) { goto L1000; } goto L300; /* .......... REPLACE SMALL SUB-DIAGONAL SQUARES BY ZERO */ /* TO REDUCE THE INCIDENCE OF UNDERFLOWS .......... */ L190: if (k == *n) { goto L210; } k1 = k + 1; i_2 = *n; for (j = k1; j <= i_2; ++j) { d_2 = w[j] + w[j - 1]; /* Computing 2nd power */ d_1 = epslon_(&d_2); if (bd[j] <= d_1 * d_1) { bd[j] = 0.; } /* L200: */ } L210: f = bd[*n] / delta; qp = delta + f; p = 1.; if (k == *n) { goto L260; } k1 = *n - k; /* .......... FOR I=N-1 STEP -1 UNTIL K DO -- .......... */ i_2 = k1; for (ii = 1; ii <= i_2; ++ii) { i = *n - ii; q = w[i] - s - f; r = q / qp; p = p * r + 1.; ep = f * r; w[i + 1] = qp + ep; delta = q - ep; if (delta > *eps1) { goto L220; } if (delta < -(*eps1)) { goto L1000; } goto L300; L220: f = bd[i] / q; qp = delta + f; bd[i + 1] = qp * ep; /* L240: */ } L260: w[k] = qp; s = qp / p; if (tot + s > tot) { goto L180; } /* .......... SET ERROR -- IRREGULAR END OF ITERATION. */ /* DEFLATE MINIMUM DIAGONAL ELEMENT .......... */ *ierr = *n * 5 + k; s = 0.; delta = qp; i_2 = *n; for (j = k; j <= i_2; ++j) { if (w[j] > delta) { goto L280; } i = j; delta = w[j]; L280: ; } /* .......... CONVERGENCE .......... */ L300: if (i < *n) { bd[i + 1] = bd[i] * f / qp; } ii = ind[i]; if (i == k) { goto L340; } k1 = i - k; /* .......... FOR J=I-1 STEP -1 UNTIL K DO -- .......... */ i_2 = k1; for (jj = 1; jj <= i_2; ++jj) { j = i - jj; w[j + 1] = w[j] - s; bd[j + 1] = bd[j]; ind[j + 1] = ind[j]; /* L320: */ } L340: w[k] = tot; err += abs(delta); bd[k] = err; ind[k] = ii; /* L360: */ } if (*type) { goto L1001; } f = bd[1]; e2[1] = 2.; bd[1] = f; j = 2; /* .......... NEGATE ELEMENTS OF W FOR LARGEST VALUES .......... */ L400: i_1 = *n; for (i = 1; i <= i_1; ++i) { /* L500: */ w[i] = -w[i]; } jdef = -jdef; switch (j) { case 1: goto L40; case 2: goto L1001; } /* .......... SET ERROR -- IDEF SPECIFIED INCORRECTLY .......... */ L1000: *ierr = *n * 6 + 1; L1001: return 0; } /* ratqr_ */ /* Subroutine */ int rebak_(integer *nm, integer *n, doublereal *b, doublereal *dl, integer *m, doublereal *z) { /* System generated locals */ integer b_dim1, b_offset, z_dim1, z_offset, i_1, i_2, i_3; /* Local variables */ static integer i, j, k; static doublereal x; static integer i1, ii; /* THIS SUBROUTINE IS A TRANSLATION OF THE ALGOL PROCEDURE REBAKA, */ /* NUM. MATH. 11, 99-110(1968) BY MARTIN AND WILKINSON. */ /* HANDBOOK FOR AUTO. COMP., VOL.II-LINEAR ALGEBRA, 303-314(1971). */ /* THIS SUBROUTINE FORMS THE EIGENVECTORS OF A GENERALIZED */ /* SYMMETRIC EIGENSYSTEM BY BACK TRANSFORMING THOSE OF THE */ /* DERIVED SYMMETRIC MATRIX DETERMINED BY REDUC. */ /* ON INPUT */ /* NM MUST BE SET TO THE ROW DIMENSION OF TWO-DIMENSIONAL */ /* ARRAY PARAMETERS AS DECLARED IN THE CALLING PROGRAM */ /* DIMENSION STATEMENT. */ /* N IS THE ORDER OF THE MATRIX SYSTEM. */ /* B CONTAINS INFORMATION ABOUT THE SIMILARITY TRANSFORMATION */ /* (CHOLESKY DECOMPOSITION) USED IN THE REDUCTION BY REDUC */ /* IN ITS STRICT LOWER TRIANGLE. */ /* DL CONTAINS FURTHER INFORMATION ABOUT THE TRANSFORMATION. */ /* M IS THE NUMBER OF EIGENVECTORS TO BE BACK TRANSFORMED. */ /* Z CONTAINS THE EIGENVECTORS TO BE BACK TRANSFORMED */ /* IN ITS FIRST M COLUMNS. */ /* ON OUTPUT */ /* Z CONTAINS THE TRANSFORMED EIGENVECTORS */ /* IN ITS FIRST M COLUMNS. */ /* 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 */ --dl; b_dim1 = *nm; b_offset = b_dim1 + 1; b -= b_offset; z_dim1 = *nm; z_offset = z_dim1 + 1; z -= z_offset; /* Function Body */ if (*m == 0) { goto L200; } i_1 = *m; for (j = 1; j <= i_1; ++j) { /* .......... FOR I=N STEP -1 UNTIL 1 DO -- .......... */ i_2 = *n; for (ii = 1; ii <= i_2; ++ii) { i = *n + 1 - ii; i1 = i + 1; x = z[i + j * z_dim1]; if (i == *n) { goto L80; } i_3 = *n; for (k = i1; k <= i_3; ++k) { /* L60: */ x -= b[k + i * b_dim1] * z[k + j * z_dim1]; } L80: z[i + j * z_dim1] = x / dl[i]; /* L100: */ } } L200: return 0; } /* rebak_ */ /* Subroutine */ int rebakb_(integer *nm, integer *n, doublereal *b, doublereal *dl, integer *m, doublereal *z) { /* System generated locals */ integer b_dim1, b_offset, z_dim1, z_offset, i_1, i_2, i_3; /* Local variables */ static integer i, j, k; static doublereal x; static integer i1, ii; /* THIS SUBROUTINE IS A TRANSLATION OF THE ALGOL PROCEDURE REBAKB, */ /* NUM. MATH. 11, 99-110(1968) BY MARTIN AND WILKINSON. */ /* HANDBOOK FOR AUTO. COMP., VOL.II-LINEAR ALGEBRA, 303-314(1971). */ /* THIS SUBROUTINE FORMS THE EIGENVECTORS OF A GENERALIZED */ /* SYMMETRIC EIGENSYSTEM BY BACK TRANSFORMING THOSE OF THE */ /* DERIVED SYMMETRIC MATRIX DETERMINED BY REDUC2. */ /* ON INPUT */ /* NM MUST BE SET TO THE ROW DIMENSION OF TWO-DIMENSIONAL */ /* ARRAY PARAMETERS AS DECLARED IN THE CALLING PROGRAM */ /* DIMENSION STATEMENT. */ /* N IS THE ORDER OF THE MATRIX SYSTEM. */ /* B CONTAINS INFORMATION ABOUT THE SIMILARITY TRANSFORMATION */ /* (CHOLESKY DECOMPOSITION) USED IN THE REDUCTION BY REDUC2 */ /* IN ITS STRICT LOWER TRIANGLE. */ /* DL CONTAINS FURTHER INFORMATION ABOUT THE TRANSFORMATION. */ /* M IS THE NUMBER OF EIGENVECTORS TO BE BACK TRANSFORMED. */ /* Z CONTAINS THE EIGENVECTORS TO BE BACK TRANSFORMED */ /* IN ITS FIRST M COLUMNS. */ /* ON OUTPUT */ /* Z CONTAINS THE TRANSFORMED EIGENVECTORS */ /* IN ITS FIRST M COLUMNS. */ /* 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 */ --dl; b_dim1 = *nm; b_offset = b_dim1 + 1; b -= b_offset; z_dim1 = *nm; z_offset = z_dim1 + 1; z -= z_offset; /* Function Body */ if (*m == 0) { goto L200; } i_1 = *m; for (j = 1; j <= i_1; ++j) { /* .......... FOR I=N STEP -1 UNTIL 1 DO -- .......... */ i_2 = *n; for (ii = 1; ii <= i_2; ++ii) { i1 = *n - ii; i = i1 + 1; x = dl[i] * z[i + j * z_dim1]; if (i == 1) { goto L80; } i_3 = i1; for (k = 1; k <= i_3; ++k) { /* L60: */ x += b[i + k * b_dim1] * z[k + j * z_dim1]; } L80: z[i + j * z_dim1] = x; /* L100: */ } } L200: return 0; } /* rebakb_ */ /* Subroutine */ int reduc_(integer *nm, integer *n, doublereal *a, doublereal *b, doublereal *dl, integer *ierr) { /* System generated locals */ integer a_dim1, a_offset, b_dim1, b_offset, i_1, i_2, i_3; /* Builtin functions */ double sqrt(doublereal); /* Local variables */ static integer i, j, k; static doublereal x, y; static integer i1, j1, nn; /* THIS SUBROUTINE IS A TRANSLATION OF THE ALGOL PROCEDURE REDUC1, */ /* NUM. MATH. 11, 99-110(1968) BY MARTIN AND WILKINSON. */ /* HANDBOOK FOR AUTO. COMP., VOL.II-LINEAR ALGEBRA, 303-314(1971). */ /* THIS SUBROUTINE REDUCES THE GENERALIZED SYMMETRIC EIGENPROBLEM */ /* AX=(LAMBDA)BX, WHERE B IS POSITIVE DEFINITE, TO THE STANDARD */ /* SYMMETRIC EIGENPROBLEM USING THE CHOLESKY FACTORIZATION OF B. */ /* ON INPUT */ /* NM MUST BE SET TO THE ROW DIMENSION OF TWO-DIMENSIONAL */ /* ARRAY PARAMETERS AS DECLARED IN THE CALLING PROGRAM */ /* DIMENSION STATEMENT. */ /* N IS THE ORDER OF THE MATRICES A AND B. IF THE CHOLESKY */ /* FACTOR L OF B IS ALREADY AVAILABLE, N SHOULD BE PREFIXED */ /* WITH A MINUS SIGN. */ /* A AND B CONTAIN THE REAL SYMMETRIC INPUT MATRICES. ONLY THE */ /* FULL UPPER TRIANGLES OF THE MATRICES NEED BE SUPPLIED. IF */ /* N IS NEGATIVE, THE STRICT LOWER TRIANGLE OF B CONTAINS, */ /* INSTEAD, THE STRICT LOWER TRIANGLE OF ITS CHOLESKY FACTOR L. */ /* DL CONTAINS, IF N IS NEGATIVE, THE DIAGONAL ELEMENTS OF L. */ /* ON OUTPUT */ /* A CONTAINS IN ITS FULL LOWER TRIANGLE THE FULL LOWER TRIANGLE */ /* OF THE SYMMETRIC MATRIX DERIVED FROM THE REDUCTION TO THE */ /* STANDARD FORM. THE STRICT UPPER TRIANGLE OF A IS UNALTERED. */ /* B CONTAINS IN ITS STRICT LOWER TRIANGLE THE STRICT LOWER */ /* TRIANGLE OF ITS CHOLESKY FACTOR L. THE FULL UPPER */ /* TRIANGLE OF B IS UNALTERED. */ /* DL CONTAINS THE DIAGONAL ELEMENTS OF L. */ /* IERR IS SET TO */ /* ZERO FOR NORMAL RETURN, */ /* 7*N+1 IF B IS NOT POSITIVE DEFINITE. */ /* 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 */ --dl; b_dim1 = *nm; b_offset = b_dim1 + 1; b -= b_offset; a_dim1 = *nm; a_offset = a_dim1 + 1; a -= a_offset; /* Function Body */ *ierr = 0; nn = abs(*n); if (*n < 0) { goto L100; } /* .......... FORM L IN THE ARRAYS B AND DL .......... */ i_1 = *n; for (i = 1; i <= i_1; ++i) { i1 = i - 1; i_2 = *n; for (j = i; j <= i_2; ++j) { x = b[i + j * b_dim1]; if (i == 1) { goto L40; } i_3 = i1; for (k = 1; k <= i_3; ++k) { /* L20: */ x -= b[i + k * b_dim1] * b[j + k * b_dim1]; } L40: if (j != i) { goto L60; } if (x <= 0.) { goto L1000; } y = sqrt(x); dl[i] = y; goto L80; L60: b[j + i * b_dim1] = x / y; L80: ; } } /* .......... FORM THE TRANSPOSE OF THE UPPER TRIANGLE OF INV(L)*A */ /* IN THE LOWER TRIANGLE OF THE ARRAY A .......... */ L100: i_2 = nn; for (i = 1; i <= i_2; ++i) { i1 = i - 1; y = dl[i]; i_1 = nn; for (j = i; j <= i_1; ++j) { x = a[i + j * a_dim1]; if (i == 1) { goto L180; } i_3 = i1; for (k = 1; k <= i_3; ++k) { /* L160: */ x -= b[i + k * b_dim1] * a[j + k * a_dim1]; } L180: a[j + i * a_dim1] = x / y; /* L200: */ } } /* .......... PRE-MULTIPLY BY INV(L) AND OVERWRITE .......... */ i_1 = nn; for (j = 1; j <= i_1; ++j) { j1 = j - 1; i_2 = nn; for (i = j; i <= i_2; ++i) { x = a[i + j * a_dim1]; if (i == j) { goto L240; } i1 = i - 1; i_3 = i1; for (k = j; k <= i_3; ++k) { /* L220: */ x -= a[k + j * a_dim1] * b[i + k * b_dim1]; } L240: if (j == 1) { goto L280; } i_3 = j1; for (k = 1; k <= i_3; ++k) { /* L260: */ x -= a[j + k * a_dim1] * b[i + k * b_dim1]; } L280: a[i + j * a_dim1] = x / dl[i]; /* L300: */ } } goto L1001; /* .......... SET ERROR -- B IS NOT POSITIVE DEFINITE .......... */ L1000: *ierr = *n * 7 + 1; L1001: return 0; } /* reduc_ */ /* Subroutine */ int reduc2_(integer *nm, integer *n, doublereal *a, doublereal *b, doublereal *dl, integer *ierr) { /* System generated locals */ integer a_dim1, a_offset, b_dim1, b_offset, i_1, i_2, i_3; /* Builtin functions */ double sqrt(doublereal); /* Local variables */ static integer i, j, k; static doublereal x, y; static integer i1, j1, nn; /* THIS SUBROUTINE IS A TRANSLATION OF THE ALGOL PROCEDURE REDUC2, */ /* NUM. MATH. 11, 99-110(1968) BY MARTIN AND WILKINSON. */ /* HANDBOOK FOR AUTO. COMP., VOL.II-LINEAR ALGEBRA, 303-314(1971). */ /* THIS SUBROUTINE REDUCES THE GENERALIZED SYMMETRIC EIGENPROBLEMS */ /* ABX=(LAMBDA)X OR BAY=(LAMBDA)Y, WHERE B IS POSITIVE DEFINITE, */ /* TO THE STANDARD SYMMETRIC EIGENPROBLEM USING THE CHOLESKY */ /* FACTORIZATION OF B. */ /* ON INPUT */ /* NM MUST BE SET TO THE ROW DIMENSION OF TWO-DIMENSIONAL */ /* ARRAY PARAMETERS AS DECLARED IN THE CALLING PROGRAM */ /* DIMENSION STATEMENT. */ /* N IS THE ORDER OF THE MATRICES A AND B. IF THE CHOLESKY */ /* FACTOR L OF B IS ALREADY AVAILABLE, N SHOULD BE PREFIXED */ /* WITH A MINUS SIGN. */ /* A AND B CONTAIN THE REAL SYMMETRIC INPUT MATRICES. ONLY THE */ /* FULL UPPER TRIANGLES OF THE MATRICES NEED BE SUPPLIED. IF */ /* N IS NEGATIVE, THE STRICT LOWER TRIANGLE OF B CONTAINS, */ /* INSTEAD, THE STRICT LOWER TRIANGLE OF ITS CHOLESKY FACTOR L. */ /* DL CONTAINS, IF N IS NEGATIVE, THE DIAGONAL ELEMENTS OF L. */ /* ON OUTPUT */ /* A CONTAINS IN ITS FULL LOWER TRIANGLE THE FULL LOWER TRIANGLE */ /* OF THE SYMMETRIC MATRIX DERIVED FROM THE REDUCTION TO THE */ /* STANDARD FORM. THE STRICT UPPER TRIANGLE OF A IS UNALTERED. */ /* B CONTAINS IN ITS STRICT LOWER TRIANGLE THE STRICT LOWER */ /* TRIANGLE OF ITS CHOLESKY FACTOR L. THE FULL UPPER */ /* TRIANGLE OF B IS UNALTERED. */ /* DL CONTAINS THE DIAGONAL ELEMENTS OF L. */ /* IERR IS SET TO */ /* ZERO FOR NORMAL RETURN, */ /* 7*N+1 IF B IS NOT POSITIVE DEFINITE. */ /* 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 */ --dl; b_dim1 = *nm; b_offset = b_dim1 + 1; b -= b_offset; a_dim1 = *nm; a_offset = a_dim1 + 1; a -= a_offset; /* Function Body */ *ierr = 0; nn = abs(*n); if (*n < 0) { goto L100; } /* .......... FORM L IN THE ARRAYS B AND DL .......... */ i_1 = *n; for (i = 1; i <= i_1; ++i) { i1 = i - 1; i_2 = *n; for (j = i; j <= i_2; ++j) { x = b[i + j * b_dim1]; if (i == 1) { goto L40; } i_3 = i1; for (k = 1; k <= i_3; ++k) { /* L20: */ x -= b[i + k * b_dim1] * b[j + k * b_dim1]; } L40: if (j != i) { goto L60; } if (x <= 0.) { goto L1000; } y = sqrt(x); dl[i] = y; goto L80; L60: b[j + i * b_dim1] = x / y; L80: ; } } /* .......... FORM THE LOWER TRIANGLE OF A*L */ /* IN THE LOWER TRIANGLE OF THE ARRAY A .......... */ L100: i_2 = nn; for (i = 1; i <= i_2; ++i) { i1 = i + 1; i_1 = i; for (j = 1; j <= i_1; ++j) { x = a[j + i * a_dim1] * dl[j]; if (j == i) { goto L140; } j1 = j + 1; i_3 = i; for (k = j1; k <= i_3; ++k) { /* L120: */ x += a[k + i * a_dim1] * b[k + j * b_dim1]; } L140: if (i == nn) { goto L180; } i_3 = nn; for (k = i1; k <= i_3; ++k) { /* L160: */ x += a[i + k * a_dim1] * b[k + j * b_dim1]; } L180: a[i + j * a_dim1] = x; /* L200: */ } } /* .......... PRE-MULTIPLY BY TRANSPOSE(L) AND OVERWRITE .......... */ i_1 = nn; for (i = 1; i <= i_1; ++i) { i1 = i + 1; y = dl[i]; i_2 = i; for (j = 1; j <= i_2; ++j) { x = y * a[i + j * a_dim1]; if (i == nn) { goto L280; } i_3 = nn; for (k = i1; k <= i_3; ++k) { /* L260: */ x += a[k + j * a_dim1] * b[k + i * b_dim1]; } L280: a[i + j * a_dim1] = x; /* L300: */ } } goto L1001; /* .......... SET ERROR -- B IS NOT POSITIVE DEFINITE .......... */ L1000: *ierr = *n * 7 + 1; L1001: return 0; } /* reduc2_ */ /* Subroutine */ int rg_(integer *nm, integer *n, doublereal *a, doublereal * wr, doublereal *wi, integer *matz, doublereal *z, integer *iv1, doublereal *fv1, integer *ierr) { /* System generated locals */ integer a_dim1, a_offset, z_dim1, z_offset; /* Local variables */ extern /* Subroutine */ int balbak_(integer *, integer *, integer *, integer *, doublereal *, integer *, doublereal *), balanc_( integer *, integer *, doublereal *, integer *, integer *, doublereal *), elmhes_(integer *, integer *, integer *, integer *, doublereal *, integer *), eltran_(integer *, integer *, integer * , integer *, doublereal *, integer *, doublereal *); static integer is1, is2; extern /* Subroutine */ int hqr_(integer *, integer *, integer *, integer *, doublereal *, doublereal *, doublereal *, integer *), hqr2_( integer *, integer *, integer *, integer *, doublereal *, doublereal *, doublereal *, doublereal *, integer *); /* THIS SUBROUTINE CALLS THE RECOMMENDED SEQUENCE OF */ /* SUBROUTINES FROM THE EIGENSYSTEM SUBROUTINE PACKAGE (EISPACK) */ /* TO FIND THE EIGENVALUES AND EIGENVECTORS (IF DESIRED) */ /* OF A REAL GENERAL MATRIX. */ /* ON INPUT */ /* NM MUST BE SET TO THE ROW DIMENSION OF THE TWO-DIMENSIONAL */ /* ARRAY PARAMETERS AS DECLARED IN THE CALLING PROGRAM */ /* DIMENSION STATEMENT. */ /* N IS THE ORDER OF THE MATRIX A. */ /* A CONTAINS THE REAL GENERAL MATRIX. */ /* MATZ IS AN INTEGER VARIABLE SET EQUAL TO ZERO IF */ /* ONLY EIGENVALUES ARE DESIRED. OTHERWISE IT IS SET TO */ /* ANY NON-ZERO INTEGER FOR BOTH EIGENVALUES AND EIGENVECTORS. */ /* ON OUTPUT */ /* WR AND WI CONTAIN THE REAL AND IMAGINARY PARTS, */ /* RESPECTIVELY, OF THE EIGENVALUES. COMPLEX CONJUGATE */ /* PAIRS OF EIGENVALUES APPEAR CONSECUTIVELY WITH THE */ /* EIGENVALUE HAVING THE POSITIVE IMAGINARY PART FIRST. */ /* Z CONTAINS THE REAL AND IMAGINARY PARTS OF THE EIGENVECTORS */ /* IF MATZ IS NOT ZERO. IF THE J-TH EIGENVALUE IS REAL, THE */ /* J-TH COLUMN OF Z CONTAINS ITS EIGENVECTOR. IF THE J-TH */ /* EIGENVALUE IS COMPLEX WITH POSITIVE IMAGINARY PART, THE */ /* J-TH AND (J+1)-TH COLUMNS OF Z CONTAIN THE REAL AND */ /* IMAGINARY PARTS OF ITS EIGENVECTOR. THE CONJUGATE OF THIS */ /* VECTOR IS THE EIGENVECTOR FOR THE CONJUGATE EIGENVALUE. */ /* IERR IS AN INTEGER OUTPUT VARIABLE SET EQUAL TO AN ERROR */ /* COMPLETION CODE DESCRIBED IN THE DOCUMENTATION FOR HQR */ /* AND HQR2. THE NORMAL COMPLETION CODE IS ZERO. */ /* IV1 AND FV1 ARE TEMPORARY STORAGE ARRAYS. */ /* 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 */ --fv1; --iv1; z_dim1 = *nm; z_offset = z_dim1 + 1; z -= z_offset; --wi; --wr; a_dim1 = *nm; a_offset = a_dim1 + 1; a -= a_offset; /* Function Body */ if (*n <= *nm) { goto L10; } *ierr = *n * 10; goto L50; L10: balanc_(nm, n, &a[a_offset], &is1, &is2, &fv1[1]); elmhes_(nm, n, &is1, &is2, &a[a_offset], &iv1[1]); if (*matz != 0) { goto L20; } /* .......... FIND EIGENVALUES ONLY .......... */ hqr_(nm, n, &is1, &is2, &a[a_offset], &wr[1], &wi[1], ierr); goto L50; /* .......... FIND BOTH EIGENVALUES AND EIGENVECTORS .......... */ L20: eltran_(nm, n, &is1, &is2, &a[a_offset], &iv1[1], &z[z_offset]); hqr2_(nm, n, &is1, &is2, &a[a_offset], &wr[1], &wi[1], &z[z_offset], ierr) ; if (*ierr != 0) { goto L50; } balbak_(nm, n, &is1, &is2, &fv1[1], n, &z[z_offset]); L50: return 0; } /* rg_ */ /* Subroutine */ int rgg_(integer *nm, integer *n, doublereal *a, doublereal * b, doublereal *alfr, doublereal *alfi, doublereal *beta, integer * matz, doublereal *z, integer *ierr) { /* System generated locals */ integer a_dim1, a_offset, b_dim1, b_offset, z_dim1, z_offset; /* Local variables */ extern /* Subroutine */ int qzit_(integer *, integer *, doublereal *, doublereal *, doublereal *, logical *, doublereal *, integer *), qzvec_(integer *, integer *, doublereal *, doublereal *, doublereal *, doublereal *, doublereal *, doublereal *), qzhes_( integer *, integer *, doublereal *, doublereal *, logical *, doublereal *), qzval_(integer *, integer *, doublereal *, doublereal *, doublereal *, doublereal *, doublereal *, logical *, doublereal *); static logical tf; /* THIS SUBROUTINE CALLS THE RECOMMENDED SEQUENCE OF */ /* SUBROUTINES FROM THE EIGENSYSTEM SUBROUTINE PACKAGE (EISPACK) */ /* TO FIND THE EIGENVALUES AND EIGENVECTORS (IF DESIRED) */ /* FOR THE REAL GENERAL GENERALIZED EIGENPROBLEM AX = (LAMBDA)BX. */ /* ON INPUT */ /* NM MUST BE SET TO THE ROW DIMENSION OF THE TWO-DIMENSIONAL */ /* ARRAY PARAMETERS AS DECLARED IN THE CALLING PROGRAM */ /* DIMENSION STATEMENT. */ /* N IS THE ORDER OF THE MATRICES A AND B. */ /* A CONTAINS A REAL GENERAL MATRIX. */ /* B CONTAINS A REAL GENERAL MATRIX. */ /* MATZ IS AN INTEGER VARIABLE SET EQUAL TO ZERO IF */ /* ONLY EIGENVALUES ARE DESIRED. OTHERWISE IT IS SET TO */ /* ANY NON-ZERO INTEGER FOR BOTH EIGENVALUES AND EIGENVECTORS. */ /* ON OUTPUT */ /* ALFR AND ALFI CONTAIN THE REAL AND IMAGINARY PARTS, */ /* RESPECTIVELY, OF THE NUMERATORS OF THE EIGENVALUES. */ /* BETA CONTAINS THE DENOMINATORS OF THE EIGENVALUES, */ /* WHICH ARE THUS GIVEN BY THE RATIOS (ALFR+I*ALFI)/BETA. */ /* COMPLEX CONJUGATE PAIRS OF EIGENVALUES APPEAR CONSECUTIVELY */ /* WITH THE EIGENVALUE HAVING THE POSITIVE IMAGINARY PART FIRST. */ /* Z CONTAINS THE REAL AND IMAGINARY PARTS OF THE EIGENVECTORS */ /* IF MATZ IS NOT ZERO. IF THE J-TH EIGENVALUE IS REAL, THE */ /* J-TH COLUMN OF Z CONTAINS ITS EIGENVECTOR. IF THE J-TH */ /* EIGENVALUE IS COMPLEX WITH POSITIVE IMAGINARY PART, THE */ /* J-TH AND (J+1)-TH COLUMNS OF Z CONTAIN THE REAL AND */ /* IMAGINARY PARTS OF ITS EIGENVECTOR. THE CONJUGATE OF THIS */ /* VECTOR IS THE EIGENVECTOR FOR THE CONJUGATE EIGENVALUE. */ /* IERR IS AN INTEGER OUTPUT VARIABLE SET EQUAL TO AN ERROR */ /* COMPLETION CODE DESCRIBED IN THE DOCUMENTATION FOR QZIT. */ /* THE NORMAL COMPLETION CODE IS ZERO. */ /* 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 */ z_dim1 = *nm; z_offset = z_dim1 + 1; z -= z_offset; --beta; --alfi; --alfr; b_dim1 = *nm; b_offset = b_dim1 + 1; b -= b_offset; a_dim1 = *nm; a_offset = a_dim1 + 1; a -= a_offset; /* Function Body */ if (*n <= *nm) { goto L10; } *ierr = *n * 10; goto L50; L10: if (*matz != 0) { goto L20; } /* .......... FIND EIGENVALUES ONLY .......... */ tf = FALSE_; qzhes_(nm, n, &a[a_offset], &b[b_offset], &tf, &z[z_offset]); qzit_(nm, n, &a[a_offset], &b[b_offset], &c_b550, &tf, &z[z_offset], ierr) ; qzval_(nm, n, &a[a_offset], &b[b_offset], &alfr[1], &alfi[1], &beta[1], & tf, &z[z_offset]); goto L50; /* .......... FIND BOTH EIGENVALUES AND EIGENVECTORS .......... */ L20: tf = TRUE_; qzhes_(nm, n, &a[a_offset], &b[b_offset], &tf, &z[z_offset]); qzit_(nm, n, &a[a_offset], &b[b_offset], &c_b550, &tf, &z[z_offset], ierr) ; qzval_(nm, n, &a[a_offset], &b[b_offset], &alfr[1], &alfi[1], &beta[1], & tf, &z[z_offset]); if (*ierr != 0) { goto L50; } qzvec_(nm, n, &a[a_offset], &b[b_offset], &alfr[1], &alfi[1], &beta[1], & z[z_offset]); L50: return 0; } /* rgg_ */ /* Subroutine */ int rs_(integer *nm, integer *n, doublereal *a, doublereal * w, integer *matz, doublereal *z, doublereal *fv1, doublereal *fv2, integer *ierr) { /* System generated locals */ integer a_dim1, a_offset, z_dim1, z_offset; /* Local variables */ extern /* Subroutine */ int tred1_(integer *, integer *, doublereal *, doublereal *, doublereal *, doublereal *), tred2_(integer *, integer *, doublereal *, doublereal *, doublereal *, doublereal *) , tqlrat_(integer *, doublereal *, doublereal *, integer *), tql2_(integer *, integer *, doublereal *, doublereal *, doublereal *, integer *); /* THIS SUBROUTINE CALLS THE RECOMMENDED SEQUENCE OF */ /* SUBROUTINES FROM THE EIGENSYSTEM SUBROUTINE PACKAGE (EISPACK) */ /* TO FIND THE EIGENVALUES AND EIGENVECTORS (IF DESIRED) */ /* OF A REAL SYMMETRIC MATRIX. */ /* ON INPUT */ /* NM MUST BE SET TO THE ROW DIMENSION OF THE TWO-DIMENSIONAL */ /* ARRAY PARAMETERS AS DECLARED IN THE CALLING PROGRAM */ /* DIMENSION STATEMENT. */ /* N IS THE ORDER OF THE MATRIX A. */ /* A CONTAINS THE REAL SYMMETRIC MATRIX. */ /* MATZ IS AN INTEGER VARIABLE SET EQUAL TO ZERO IF */ /* ONLY EIGENVALUES ARE DESIRED. OTHERWISE IT IS SET TO */ /* ANY NON-ZERO INTEGER FOR BOTH EIGENVALUES AND EIGENVECTORS. */ /* ON OUTPUT */ /* W CONTAINS THE EIGENVALUES IN ASCENDING ORDER. */ /* Z CONTAINS THE EIGENVECTORS IF MATZ IS NOT ZERO. */ /* IERR IS AN INTEGER OUTPUT VARIABLE SET EQUAL TO AN ERROR */ /* COMPLETION CODE DESCRIBED IN THE DOCUMENTATION FOR TQLRAT */ /* AND TQL2. THE NORMAL COMPLETION CODE IS ZERO. */ /* FV1 AND FV2 ARE TEMPORARY STORAGE ARRAYS. */ /* 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 */ --fv2; --fv1; z_dim1 = *nm; z_offset = z_dim1 + 1; z -= z_offset; --w; a_dim1 = *nm; a_offset = a_dim1 + 1; a -= a_offset; /* Function Body */ if (*n <= *nm) { goto L10; } *ierr = *n * 10; goto L50; L10: if (*matz != 0) { goto L20; } /* .......... FIND EIGENVALUES ONLY .......... */ tred1_(nm, n, &a[a_offset], &w[1], &fv1[1], &fv2[1]); tqlrat_(n, &w[1], &fv2[1], ierr); goto L50; /* .......... FIND BOTH EIGENVALUES AND EIGENVECTORS .......... */ L20: tred2_(nm, n, &a[a_offset], &w[1], &fv1[1], &z[z_offset]); tql2_(nm, n, &w[1], &fv1[1], &z[z_offset], ierr); L50: return 0; } /* rs_ */ /* Subroutine */ int rsb_(integer *nm, integer *n, integer *mb, doublereal *a, doublereal *w, integer *matz, doublereal *z, doublereal *fv1, doublereal *fv2, integer *ierr) { /* System generated locals */ integer a_dim1, a_offset, z_dim1, z_offset; /* Local variables */ extern /* Subroutine */ int bandr_(integer *, integer *, integer *, doublereal *, doublereal *, doublereal *, doublereal *, logical *, doublereal *); static logical tf; extern /* Subroutine */ int tqlrat_(integer *, doublereal *, doublereal *, integer *), tql2_(integer *, integer *, doublereal *, doublereal *, doublereal *, integer *); /* THIS SUBROUTINE CALLS THE RECOMMENDED SEQUENCE OF */ /* SUBROUTINES FROM THE EIGENSYSTEM SUBROUTINE PACKAGE (EISPACK) */ /* TO FIND THE EIGENVALUES AND EIGENVECTORS (IF DESIRED) */ /* OF A REAL SYMMETRIC BAND MATRIX. */ /* ON INPUT */ /* NM MUST BE SET TO THE ROW DIMENSION OF THE TWO-DIMENSIONAL */ /* ARRAY PARAMETERS AS DECLARED IN THE CALLING PROGRAM */ /* DIMENSION STATEMENT. */ /* N IS THE ORDER OF THE MATRIX A. */ /* MB IS THE HALF BAND WIDTH OF THE MATRIX, DEFINED AS THE */ /* NUMBER OF ADJACENT DIAGONALS, INCLUDING THE PRINCIPAL */ /* DIAGONAL, REQUIRED TO SPECIFY THE NON-ZERO PORTION OF THE */ /* LOWER TRIANGLE OF THE MATRIX. */ /* A CONTAINS THE LOWER TRIANGLE OF THE REAL SYMMETRIC */ /* BAND MATRIX. ITS LOWEST SUBDIAGONAL IS STORED IN THE */ /* LAST N+1-MB POSITIONS OF THE FIRST COLUMN, ITS NEXT */ /* SUBDIAGONAL IN THE LAST N+2-MB POSITIONS OF THE */ /* SECOND COLUMN, FURTHER SUBDIAGONALS SIMILARLY, AND */ /* FINALLY ITS PRINCIPAL DIAGONAL IN THE N POSITIONS */ /* OF THE LAST COLUMN. CONTENTS OF STORAGES NOT PART */ /* OF THE MATRIX ARE ARBITRARY. */ /* MATZ IS AN INTEGER VARIABLE SET EQUAL TO ZERO IF */ /* ONLY EIGENVALUES ARE DESIRED. OTHERWISE IT IS SET TO */ /* ANY NON-ZERO INTEGER FOR BOTH EIGENVALUES AND EIGENVECTORS. */ /* ON OUTPUT */ /* W CONTAINS THE EIGENVALUES IN ASCENDING ORDER. */ /* Z CONTAINS THE EIGENVECTORS IF MATZ IS NOT ZERO. */ /* IERR IS AN INTEGER OUTPUT VARIABLE SET EQUAL TO AN ERROR */ /* COMPLETION CODE DESCRIBED IN THE DOCUMENTATION FOR TQLRAT */ /* AND TQL2. THE NORMAL COMPLETION CODE IS ZERO. */ /* FV1 AND FV2 ARE TEMPORARY STORAGE ARRAYS. */ /* 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 */ --fv2; --fv1; z_dim1 = *nm; z_offset = z_dim1 + 1; z -= z_offset; --w; a_dim1 = *nm; a_offset = a_dim1 + 1; a -= a_offset; /* Function Body */ if (*n <= *nm) { goto L5; } *ierr = *n * 10; goto L50; L5: if (*mb > 0) { goto L10; } *ierr = *n * 12; goto L50; L10: if (*mb <= *n) { goto L15; } *ierr = *n * 12; goto L50; L15: if (*matz != 0) { goto L20; } /* .......... FIND EIGENVALUES ONLY .......... */ tf = FALSE_; bandr_(nm, n, mb, &a[a_offset], &w[1], &fv1[1], &fv2[1], &tf, &z[z_offset] ); tqlrat_(n, &w[1], &fv2[1], ierr); goto L50; /* .......... FIND BOTH EIGENVALUES AND EIGENVECTORS .......... */ L20: tf = TRUE_; bandr_(nm, n, mb, &a[a_offset], &w[1], &fv1[1], &fv1[1], &tf, &z[z_offset] ); tql2_(nm, n, &w[1], &fv1[1], &z[z_offset], ierr); L50: return 0; } /* rsb_ */ /* Subroutine */ int rsg_(integer *nm, integer *n, doublereal *a, doublereal * b, doublereal *w, integer *matz, doublereal *z, doublereal *fv1, doublereal *fv2, integer *ierr) { /* System generated locals */ integer a_dim1, a_offset, b_dim1, b_offset, z_dim1, z_offset; /* Local variables */ extern /* Subroutine */ int tred1_(integer *, integer *, doublereal *, doublereal *, doublereal *, doublereal *), tred2_(integer *, integer *, doublereal *, doublereal *, doublereal *, doublereal *) , rebak_(integer *, integer *, doublereal *, doublereal *, integer *, doublereal *), reduc_(integer *, integer *, doublereal *, doublereal *, doublereal *, integer *), tqlrat_(integer *, doublereal *, doublereal *, integer *), tql2_(integer *, integer * , doublereal *, doublereal *, doublereal *, integer *); /* THIS SUBROUTINE CALLS THE RECOMMENDED SEQUENCE OF */ /* SUBROUTINES FROM THE EIGENSYSTEM SUBROUTINE PACKAGE (EISPACK) */ /* TO FIND THE EIGENVALUES AND EIGENVECTORS (IF DESIRED) */ /* FOR THE REAL SYMMETRIC GENERALIZED EIGENPROBLEM AX = (LAMBDA)BX. */ /* ON INPUT */ /* NM MUST BE SET TO THE ROW DIMENSION OF THE TWO-DIMENSIONAL */ /* ARRAY PARAMETERS AS DECLARED IN THE CALLING PROGRAM */ /* DIMENSION STATEMENT. */ /* N IS THE ORDER OF THE MATRICES A AND B. */ /* A CONTAINS A REAL SYMMETRIC MATRIX. */ /* B CONTAINS A POSITIVE DEFINITE REAL SYMMETRIC MATRIX. */ /* MATZ IS AN INTEGER VARIABLE SET EQUAL TO ZERO IF */ /* ONLY EIGENVALUES ARE DESIRED. OTHERWISE IT IS SET TO */ /* ANY NON-ZERO INTEGER FOR BOTH EIGENVALUES AND EIGENVECTORS. */ /* ON OUTPUT */ /* W CONTAINS THE EIGENVALUES IN ASCENDING ORDER. */ /* Z CONTAINS THE EIGENVECTORS IF MATZ IS NOT ZERO. */ /* IERR IS AN INTEGER OUTPUT VARIABLE SET EQUAL TO AN ERROR */ /* COMPLETION CODE DESCRIBED IN THE DOCUMENTATION FOR TQLRAT */ /* AND TQL2. THE NORMAL COMPLETION CODE IS ZERO. */ /* FV1 AND FV2 ARE TEMPORARY STORAGE ARRAYS. */ /* 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 */ --fv2; --fv1; z_dim1 = *nm; z_offset = z_dim1 + 1; z -= z_offset; --w; b_dim1 = *nm; b_offset = b_dim1 + 1; b -= b_offset; a_dim1 = *nm; a_offset = a_dim1 + 1; a -= a_offset; /* Function Body */ if (*n <= *nm) { goto L10; } *ierr = *n * 10; goto L50; L10: reduc_(nm, n, &a[a_offset], &b[b_offset], &fv2[1], ierr); if (*ierr != 0) { goto L50; } if (*matz != 0) { goto L20; } /* .......... FIND EIGENVALUES ONLY .......... */ tred1_(nm, n, &a[a_offset], &w[1], &fv1[1], &fv2[1]); tqlrat_(n, &w[1], &fv2[1], ierr); goto L50; /* .......... FIND BOTH EIGENVALUES AND EIGENVECTORS .......... */ L20: tred2_(nm, n, &a[a_offset], &w[1], &fv1[1], &z[z_offset]); tql2_(nm, n, &w[1], &fv1[1], &z[z_offset], ierr); if (*ierr != 0) { goto L50; } rebak_(nm, n, &b[b_offset], &fv2[1], n, &z[z_offset]); L50: return 0; } /* rsg_ */ /* Subroutine */ int rsgab_(integer *nm, integer *n, doublereal *a, doublereal *b, doublereal *w, integer *matz, doublereal *z, doublereal *fv1, doublereal *fv2, integer *ierr) { /* System generated locals */ integer a_dim1, a_offset, b_dim1, b_offset, z_dim1, z_offset; /* Local variables */ extern /* Subroutine */ int tred1_(integer *, integer *, doublereal *, doublereal *, doublereal *, doublereal *), tred2_(integer *, integer *, doublereal *, doublereal *, doublereal *, doublereal *) , rebak_(integer *, integer *, doublereal *, doublereal *, integer *, doublereal *), reduc2_(integer *, integer *, doublereal *, doublereal *, doublereal *, integer *), tqlrat_( integer *, doublereal *, doublereal *, integer *), tql2_(integer * , integer *, doublereal *, doublereal *, doublereal *, integer *); /* THIS SUBROUTINE CALLS THE RECOMMENDED SEQUENCE OF */ /* SUBROUTINES FROM THE EIGENSYSTEM SUBROUTINE PACKAGE (EISPACK) */ /* TO FIND THE EIGENVALUES AND EIGENVECTORS (IF DESIRED) */ /* FOR THE REAL SYMMETRIC GENERALIZED EIGENPROBLEM ABX = (LAMBDA)X. */ /* ON INPUT */ /* NM MUST BE SET TO THE ROW DIMENSION OF THE TWO-DIMENSIONAL */ /* ARRAY PARAMETERS AS DECLARED IN THE CALLING PROGRAM */ /* DIMENSION STATEMENT. */ /* N IS THE ORDER OF THE MATRICES A AND B. */ /* A CONTAINS A REAL SYMMETRIC MATRIX. */ /* B CONTAINS A POSITIVE DEFINITE REAL SYMMETRIC MATRIX. */ /* MATZ IS AN INTEGER VARIABLE SET EQUAL TO ZERO IF */ /* ONLY EIGENVALUES ARE DESIRED. OTHERWISE IT IS SET TO */ /* ANY NON-ZERO INTEGER FOR BOTH EIGENVALUES AND EIGENVECTORS. */ /* ON OUTPUT */ /* W CONTAINS THE EIGENVALUES IN ASCENDING ORDER. */ /* Z CONTAINS THE EIGENVECTORS IF MATZ IS NOT ZERO. */ /* IERR IS AN INTEGER OUTPUT VARIABLE SET EQUAL TO AN ERROR */ /* COMPLETION CODE DESCRIBED IN THE DOCUMENTATION FOR TQLRAT */ /* AND TQL2. THE NORMAL COMPLETION CODE IS ZERO. */ /* FV1 AND FV2 ARE TEMPORARY STORAGE ARRAYS. */ /* 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 */ --fv2; --fv1; z_dim1 = *nm; z_offset = z_dim1 + 1; z -= z_offset; --w; b_dim1 = *nm; b_offset = b_dim1 + 1; b -= b_offset; a_dim1 = *nm; a_offset = a_dim1 + 1; a -= a_offset; /* Function Body */ if (*n <= *nm) { goto L10; } *ierr = *n * 10; goto L50; L10: reduc2_(nm, n, &a[a_offset], &b[b_offset], &fv2[1], ierr); if (*ierr != 0) { goto L50; } if (*matz != 0) { goto L20; } /* .......... FIND EIGENVALUES ONLY .......... */ tred1_(nm, n, &a[a_offset], &w[1], &fv1[1], &fv2[1]); tqlrat_(n, &w[1], &fv2[1], ierr); goto L50; /* .......... FIND BOTH EIGENVALUES AND EIGENVECTORS .......... */ L20: tred2_(nm, n, &a[a_offset], &w[1], &fv1[1], &z[z_offset]); tql2_(nm, n, &w[1], &fv1[1], &z[z_offset], ierr); if (*ierr != 0) { goto L50; } rebak_(nm, n, &b[b_offset], &fv2[1], n, &z[z_offset]); L50: return 0; } /* rsgab_ */ /* Subroutine */ int rsgba_(integer *nm, integer *n, doublereal *a, doublereal *b, doublereal *w, integer *matz, doublereal *z, doublereal *fv1, doublereal *fv2, integer *ierr) { /* System generated locals */ integer a_dim1, a_offset, b_dim1, b_offset, z_dim1, z_offset; /* Local variables */ extern /* Subroutine */ int tred1_(integer *, integer *, doublereal *, doublereal *, doublereal *, doublereal *), tred2_(integer *, integer *, doublereal *, doublereal *, doublereal *, doublereal *) , reduc2_(integer *, integer *, doublereal *, doublereal *, doublereal *, integer *), rebakb_(integer *, integer *, doublereal *, doublereal *, integer *, doublereal *), tqlrat_( integer *, doublereal *, doublereal *, integer *), tql2_(integer * , integer *, doublereal *, doublereal *, doublereal *, integer *); /* THIS SUBROUTINE CALLS THE RECOMMENDED SEQUENCE OF */ /* SUBROUTINES FROM THE EIGENSYSTEM SUBROUTINE PACKAGE (EISPACK) */ /* TO FIND THE EIGENVALUES AND EIGENVECTORS (IF DESIRED) */ /* FOR THE REAL SYMMETRIC GENERALIZED EIGENPROBLEM BAX = (LAMBDA)X. */ /* ON INPUT */ /* NM MUST BE SET TO THE ROW DIMENSION OF THE TWO-DIMENSIONAL */ /* ARRAY PARAMETERS AS DECLARED IN THE CALLING PROGRAM */ /* DIMENSION STATEMENT. */ /* N IS THE ORDER OF THE MATRICES A AND B. */ /* A CONTAINS A REAL SYMMETRIC MATRIX. */ /* B CONTAINS A POSITIVE DEFINITE REAL SYMMETRIC MATRIX. */ /* MATZ IS AN INTEGER VARIABLE SET EQUAL TO ZERO IF */ /* ONLY EIGENVALUES ARE DESIRED. OTHERWISE IT IS SET TO */ /* ANY NON-ZERO INTEGER FOR BOTH EIGENVALUES AND EIGENVECTORS. */ /* ON OUTPUT */ /* W CONTAINS THE EIGENVALUES IN ASCENDING ORDER. */ /* Z CONTAINS THE EIGENVECTORS IF MATZ IS NOT ZERO. */ /* IERR IS AN INTEGER OUTPUT VARIABLE SET EQUAL TO AN ERROR */ /* COMPLETION CODE DESCRIBED IN THE DOCUMENTATION FOR TQLRAT */ /* AND TQL2. THE NORMAL COMPLETION CODE IS ZERO. */ /* FV1 AND FV2 ARE TEMPORARY STORAGE ARRAYS. */ /* 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 */ --fv2; --fv1; z_dim1 = *nm; z_offset = z_dim1 + 1; z -= z_offset; --w; b_dim1 = *nm; b_offset = b_dim1 + 1; b -= b_offset; a_dim1 = *nm; a_offset = a_dim1 + 1; a -= a_offset; /* Function Body */ if (*n <= *nm) { goto L10; } *ierr = *n * 10; goto L50; L10: reduc2_(nm, n, &a[a_offset], &b[b_offset], &fv2[1], ierr); if (*ierr != 0) { goto L50; } if (*matz != 0) { goto L20; } /* .......... FIND EIGENVALUES ONLY .......... */ tred1_(nm, n, &a[a_offset], &w[1], &fv1[1], &fv2[1]); tqlrat_(n, &w[1], &fv2[1], ierr); goto L50; /* .......... FIND BOTH EIGENVALUES AND EIGENVECTORS .......... */ L20: tred2_(nm, n, &a[a_offset], &w[1], &fv1[1], &z[z_offset]); tql2_(nm, n, &w[1], &fv1[1], &z[z_offset], ierr); if (*ierr != 0) { goto L50; } rebakb_(nm, n, &b[b_offset], &fv2[1], n, &z[z_offset]); L50: return 0; } /* rsgba_ */ /* Subroutine */ int rsm_(integer *nm, integer *n, doublereal *a, doublereal * w, integer *m, doublereal *z, doublereal *fwork, integer *iwork, integer *ierr) { /* System generated locals */ integer a_dim1, a_offset, z_dim1, z_offset; /* Local variables */ extern /* Subroutine */ int tred1_(integer *, integer *, doublereal *, doublereal *, doublereal *, doublereal *); static integer k1, k2, k3, k4, k5, k6, k7, k8; extern /* Subroutine */ int trbak1_(integer *, integer *, doublereal *, doublereal *, integer *, doublereal *), tqlrat_(integer *, doublereal *, doublereal *, integer *), imtqlv_(integer *, doublereal *, doublereal *, doublereal *, doublereal *, integer *, integer *, doublereal *), tinvit_(integer *, integer *, doublereal *, doublereal *, doublereal *, integer *, doublereal *, integer *, doublereal *, integer *, doublereal *, doublereal *, doublereal *, doublereal *, doublereal *); /* THIS SUBROUTINE CALLS THE RECOMMENDED SEQUENCE OF */ /* SUBROUTINES FROM THE EIGENSYSTEM SUBROUTINE PACKAGE (EISPACK) */ /* TO FIND ALL OF THE EIGENVALUES AND SOME OF THE EIGENVECTORS */ /* OF A REAL SYMMETRIC MATRIX. */ /* ON INPUT */ /* NM MUST BE SET TO THE ROW DIMENSION OF THE TWO-DIMENSIONAL */ /* ARRAY PARAMETERS AS DECLARED IN THE CALLING PROGRAM */ /* DIMENSION STATEMENT. */ /* N IS THE ORDER OF THE MATRIX A. */ /* A CONTAINS THE REAL SYMMETRIC MATRIX. */ /* M THE EIGENVECTORS CORRESPONDING TO THE FIRST M EIGENVALUES */ /* ARE TO BE COMPUTED. */ /* IF M = 0 THEN NO EIGENVECTORS ARE COMPUTED. */ /* IF M = N THEN ALL OF THE EIGENVECTORS ARE COMPUTED. */ /* ON OUTPUT */ /* W CONTAINS ALL N EIGENVALUES IN ASCENDING ORDER. */ /* Z CONTAINS THE ORTHONORMAL EIGENVECTORS ASSOCIATED WITH */ /* THE FIRST M EIGENVALUES. */ /* IERR IS AN INTEGER OUTPUT VARIABLE SET EQUAL TO AN ERROR */ /* COMPLETION CODE DESCRIBED IN THE DOCUMENTATION FOR TQLRAT, */ /* IMTQLV AND TINVIT. THE NORMAL COMPLETION CODE IS ZERO. */ /* FWORK IS A TEMPORARY STORAGE ARRAY OF DIMENSION 8*N. */ /* IWORK IS AN INTEGER TEMPORARY STORAGE ARRAY OF DIMENSION N. */ /* 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 */ --iwork; --w; a_dim1 = *nm; a_offset = a_dim1 + 1; a -= a_offset; z_dim1 = *nm; z_offset = z_dim1 + 1; z -= z_offset; --fwork; /* Function Body */ *ierr = *n * 10; if (*n > *nm || *m > *nm) { goto L50; } k1 = 1; k2 = k1 + *n; k3 = k2 + *n; k4 = k3 + *n; k5 = k4 + *n; k6 = k5 + *n; k7 = k6 + *n; k8 = k7 + *n; if (*m > 0) { goto L10; } /* .......... FIND EIGENVALUES ONLY .......... */ tred1_(nm, n, &a[a_offset], &w[1], &fwork[k1], &fwork[k2]); tqlrat_(n, &w[1], &fwork[k2], ierr); goto L50; /* .......... FIND ALL EIGENVALUES AND M EIGENVECTORS .......... */ L10: tred1_(nm, n, &a[a_offset], &fwork[k1], &fwork[k2], &fwork[k3]); imtqlv_(n, &fwork[k1], &fwork[k2], &fwork[k3], &w[1], &iwork[1], ierr, & fwork[k4]); tinvit_(nm, n, &fwork[k1], &fwork[k2], &fwork[k3], m, &w[1], &iwork[1], & z[z_offset], ierr, &fwork[k4], &fwork[k5], &fwork[k6], &fwork[k7], &fwork[k8]); trbak1_(nm, n, &a[a_offset], &fwork[k2], m, &z[z_offset]); L50: return 0; } /* rsm_ */ /* Subroutine */ int rsp_(integer *nm, integer *n, integer *nv, doublereal *a, doublereal *w, integer *matz, doublereal *z, doublereal *fv1, doublereal *fv2, integer *ierr) { /* System generated locals */ integer z_dim1, z_offset, i_1, i_2; /* Local variables */ extern /* Subroutine */ int tred3_(integer *, integer *, doublereal *, doublereal *, doublereal *, doublereal *); static integer i, j; extern /* Subroutine */ int trbak3_(integer *, integer *, integer *, doublereal *, integer *, doublereal *), tqlrat_(integer *, doublereal *, doublereal *, integer *), tql2_(integer *, integer * , doublereal *, doublereal *, doublereal *, integer *); /* THIS SUBROUTINE CALLS THE RECOMMENDED SEQUENCE OF */ /* SUBROUTINES FROM THE EIGENSYSTEM SUBROUTINE PACKAGE (EISPACK) */ /* TO FIND THE EIGENVALUES AND EIGENVECTORS (IF DESIRED) */ /* OF A REAL SYMMETRIC PACKED MATRIX. */ /* ON INPUT */ /* NM MUST BE SET TO THE ROW DIMENSION OF THE TWO-DIMENSIONAL */ /* ARRAY PARAMETERS AS DECLARED IN THE CALLING PROGRAM */ /* DIMENSION STATEMENT. */ /* N IS THE ORDER OF THE MATRIX A. */ /* NV IS AN INTEGER VARIABLE SET EQUAL TO THE */ /* DIMENSION OF THE ARRAY A AS SPECIFIED FOR */ /* A IN THE CALLING PROGRAM. NV MUST NOT BE */ /* LESS THAN N*(N+1)/2. */ /* A CONTAINS THE LOWER TRIANGLE OF THE REAL SYMMETRIC */ /* PACKED MATRIX STORED ROW-WISE. */ /* MATZ IS AN INTEGER VARIABLE SET EQUAL TO ZERO IF */ /* ONLY EIGENVALUES ARE DESIRED. OTHERWISE IT IS SET TO */ /* ANY NON-ZERO INTEGER FOR BOTH EIGENVALUES AND EIGENVECTORS. */ /* ON OUTPUT */ /* W CONTAINS THE EIGENVALUES IN ASCENDING ORDER. */ /* Z CONTAINS THE EIGENVECTORS IF MATZ IS NOT ZERO. */ /* IERR IS AN INTEGER OUTPUT VARIABLE SET EQUAL TO AN ERROR */ /* COMPLETION CODE DESCRIBED IN THE DOCUMENTATION FOR TQLRAT */ /* AND TQL2. THE NORMAL COMPLETION CODE IS ZERO. */ /* FV1 AND FV2 ARE TEMPORARY STORAGE ARRAYS. */ /* 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 */ --fv2; --fv1; z_dim1 = *nm; z_offset = z_dim1 + 1; z -= z_offset; --w; --a; /* Function Body */ if (*n <= *nm) { goto L5; } *ierr = *n * 10; goto L50; L5: if (*nv >= *n * (*n + 1) / 2) { goto L10; } *ierr = *n * 20; goto L50; L10: tred3_(n, nv, &a[1], &w[1], &fv1[1], &fv2[1]); if (*matz != 0) { goto L20; } /* .......... FIND EIGENVALUES ONLY .......... */ tqlrat_(n, &w[1], &fv2[1], ierr); goto L50; /* .......... FIND BOTH EIGENVALUES AND EIGENVECTORS .......... */ L20: i_1 = *n; for (i = 1; i <= i_1; ++i) { i_2 = *n; for (j = 1; j <= i_2; ++j) { z[j + i * z_dim1] = 0.; /* L30: */ } z[i + i * z_dim1] = 1.; /* L40: */ } tql2_(nm, n, &w[1], &fv1[1], &z[z_offset], ierr); if (*ierr != 0) { goto L50; } trbak3_(nm, n, nv, &a[1], n, &z[z_offset]); L50: return 0; } /* rsp_ */ /* Subroutine */ int rst_(integer *nm, integer *n, doublereal *w, doublereal * e, integer *matz, doublereal *z, integer *ierr) { /* System generated locals */ integer z_dim1, z_offset, i_1, i_2; /* Local variables */ static integer i, j; extern /* Subroutine */ int imtql1_(integer *, doublereal *, doublereal *, integer *), imtql2_(integer *, integer *, doublereal *, doublereal *, doublereal *, integer *); /* THIS SUBROUTINE CALLS THE RECOMMENDED SEQUENCE OF */ /* SUBROUTINES FROM THE EIGENSYSTEM SUBROUTINE PACKAGE (EISPACK) */ /* TO FIND THE EIGENVALUES AND EIGENVECTORS (IF DESIRED) */ /* OF A REAL SYMMETRIC TRIDIAGONAL MATRIX. */ /* ON INPUT */ /* NM MUST BE SET TO THE ROW DIMENSION OF THE TWO-DIMENSIONAL */ /* ARRAY PARAMETERS AS DECLARED IN THE CALLING PROGRAM */ /* DIMENSION STATEMENT. */ /* N IS THE ORDER OF THE MATRIX. */ /* W CONTAINS THE DIAGONAL ELEMENTS OF THE REAL */ /* SYMMETRIC TRIDIAGONAL MATRIX. */ /* E CONTAINS THE SUBDIAGONAL ELEMENTS OF THE MATRIX IN */ /* ITS LAST N-1 POSITIONS. E(1) IS ARBITRARY. */ /* MATZ IS AN INTEGER VARIABLE SET EQUAL TO ZERO IF */ /* ONLY EIGENVALUES ARE DESIRED. OTHERWISE IT IS SET TO */ /* ANY NON-ZERO INTEGER FOR BOTH EIGENVALUES AND EIGENVECTORS. */ /* ON OUTPUT */ /* W CONTAINS THE EIGENVALUES IN ASCENDING ORDER. */ /* Z CONTAINS THE EIGENVECTORS IF MATZ IS NOT ZERO. */ /* IERR IS AN INTEGER OUTPUT VARIABLE SET EQUAL TO AN ERROR */ /* COMPLETION CODE DESCRIBED IN THE DOCUMENTATION FOR IMTQL1 */ /* AND IMTQL2. THE NORMAL COMPLETION CODE IS ZERO. */ /* 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 */ z_dim1 = *nm; z_offset = z_dim1 + 1; z -= z_offset; --e; --w; /* Function Body */ if (*n <= *nm) { goto L10; } *ierr = *n * 10; goto L50; L10: if (*matz != 0) { goto L20; } /* .......... FIND EIGENVALUES ONLY .......... */ imtql1_(n, &w[1], &e[1], ierr); goto L50; /* .......... FIND BOTH EIGENVALUES AND EIGENVECTORS .......... */ L20: i_1 = *n; for (i = 1; i <= i_1; ++i) { i_2 = *n; for (j = 1; j <= i_2; ++j) { z[j + i * z_dim1] = 0.; /* L30: */ } z[i + i * z_dim1] = 1.; /* L40: */ } imtql2_(nm, n, &w[1], &e[1], &z[z_offset], ierr); L50: return 0; } /* rst_ */ /* Subroutine */ int rt_(integer *nm, integer *n, doublereal *a, doublereal * w, integer *matz, doublereal *z, doublereal *fv1, integer *ierr) { /* System generated locals */ integer a_dim1, a_offset, z_dim1, z_offset; /* Local variables */ extern /* Subroutine */ int figi_(integer *, integer *, doublereal *, doublereal *, doublereal *, doublereal *, integer *), figi2_( integer *, integer *, doublereal *, doublereal *, doublereal *, doublereal *, integer *), imtql1_(integer *, doublereal *, doublereal *, integer *), imtql2_(integer *, integer *, doublereal *, doublereal *, doublereal *, integer *); /* THIS SUBROUTINE CALLS THE RECOMMENDED SEQUENCE OF */ /* SUBROUTINES FROM THE EIGENSYSTEM SUBROUTINE PACKAGE (EISPACK) */ /* TO FIND THE EIGENVALUES AND EIGENVECTORS (IF DESIRED) */ /* OF A SPECIAL REAL TRIDIAGONAL MATRIX. */ /* ON INPUT */ /* NM MUST BE SET TO THE ROW DIMENSION OF THE TWO-DIMENSIONAL */ /* ARRAY PARAMETERS AS DECLARED IN THE CALLING PROGRAM */ /* DIMENSION STATEMENT. */ /* N IS THE ORDER OF THE MATRIX A. */ /* A CONTAINS THE SPECIAL REAL TRIDIAGONAL MATRIX IN ITS */ /* FIRST THREE COLUMNS. THE SUBDIAGONAL ELEMENTS ARE STORED */ /* IN THE LAST N-1 POSITIONS OF THE FIRST COLUMN, THE */ /* DIAGONAL ELEMENTS IN THE SECOND COLUMN, AND THE SUPERDIAGONAL */ /* ELEMENTS IN THE FIRST N-1 POSITIONS OF THE THIRD COLUMN. */ /* ELEMENTS A(1,1) AND A(N,3) ARE ARBITRARY. */ /* MATZ IS AN INTEGER VARIABLE SET EQUAL TO ZERO IF */ /* ONLY EIGENVALUES ARE DESIRED. OTHERWISE IT IS SET TO */ /* ANY NON-ZERO INTEGER FOR BOTH EIGENVALUES AND EIGENVECTORS. */ /* ON OUTPUT */ /* W CONTAINS THE EIGENVALUES IN ASCENDING ORDER. */ /* Z CONTAINS THE EIGENVECTORS IF MATZ IS NOT ZERO. */ /* IERR IS AN INTEGER OUTPUT VARIABLE SET EQUAL TO AN ERROR */ /* COMPLETION CODE DESCRIBED IN THE DOCUMENTATION FOR IMTQL1 */ /* AND IMTQL2. THE NORMAL COMPLETION CODE IS ZERO. */ /* FV1 IS A TEMPORARY STORAGE ARRAY. */ /* 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 */ a_dim1 = *nm; a_offset = a_dim1 + 1; a -= a_offset; --fv1; z_dim1 = *nm; z_offset = z_dim1 + 1; z -= z_offset; --w; /* Function Body */ if (*n <= *nm) { goto L10; } *ierr = *n * 10; goto L50; L10: if (*matz != 0) { goto L20; } /* .......... FIND EIGENVALUES ONLY .......... */ figi_(nm, n, &a[a_offset], &w[1], &fv1[1], &fv1[1], ierr); if (*ierr > 0) { goto L50; } imtql1_(n, &w[1], &fv1[1], ierr); goto L50; /* .......... FIND BOTH EIGENVALUES AND EIGENVECTORS .......... */ L20: figi2_(nm, n, &a[a_offset], &w[1], &fv1[1], &z[z_offset], ierr); if (*ierr != 0) { goto L50; } imtql2_(nm, n, &w[1], &fv1[1], &z[z_offset], ierr); L50: return 0; } /* rt_ */ /* Subroutine */ int svd_(integer *nm, integer *m, integer *n, doublereal *a, doublereal *w, logical *matu, doublereal *u, logical *matv, doublereal *v, integer *ierr, doublereal *rv1) { /* System generated locals */ integer a_dim1, a_offset, u_dim1, u_offset, v_dim1, v_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 */ static doublereal c, f, g, h; static integer i, j, k, l; static doublereal s, x, y, z, scale; static integer i1, k1, l1, ii, kk, ll, mn; extern doublereal pythag_(doublereal *, doublereal *); static integer its; static doublereal tst1, tst2; /* THIS SUBROUTINE IS A TRANSLATION OF THE ALGOL PROCEDURE SVD, */ /* NUM. MATH. 14, 403-420(1970) BY GOLUB AND REINSCH. */ /* HANDBOOK FOR AUTO. COMP., VOL II-LINEAR ALGEBRA, 134-151(1971). */ /* THIS SUBROUTINE DETERMINES THE SINGULAR VALUE DECOMPOSITION */ /* T */ /* A=USV OF A REAL M BY N RECTANGULAR MATRIX. 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 U). */ /* N IS THE NUMBER OF COLUMNS OF A (AND U) AND THE ORDER OF V. */ /* A CONTAINS THE RECTANGULAR INPUT MATRIX TO BE DECOMPOSED. */ /* MATU SHOULD BE SET TO .TRUE. IF THE U MATRIX IN THE */ /* DECOMPOSITION IS DESIRED, AND TO .FALSE. OTHERWISE. */ /* MATV SHOULD BE SET TO .TRUE. IF THE V MATRIX IN THE */ /* DECOMPOSITION IS DESIRED, AND TO .FALSE. OTHERWISE. */ /* ON OUTPUT */ /* A IS UNALTERED (UNLESS OVERWRITTEN BY U OR V). */ /* 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. */ /* U CONTAINS THE MATRIX U (ORTHOGONAL COLUMN VECTORS) OF THE */ /* DECOMPOSITION IF MATU HAS BEEN SET TO .TRUE. OTHERWISE */ /* U IS USED AS A TEMPORARY ARRAY. U MAY COINCIDE WITH A. */ /* IF AN ERROR EXIT IS MADE, THE COLUMNS OF U CORRESPONDING */ /* TO INDICES OF CORRECT SINGULAR VALUES SHOULD BE CORRECT. */ /* V CONTAINS THE MATRIX V (ORTHOGONAL) OF THE DECOMPOSITION IF */ /* MATV HAS BEEN SET TO .TRUE. OTHERWISE V IS NOT REFERENCED. */ /* V MAY ALSO COINCIDE WITH A IF U IS NOT NEEDED. IF AN ERROR */ /* EXIT IS MADE, THE COLUMNS OF V 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; v_dim1 = *nm; v_offset = v_dim1 + 1; v -= v_offset; u_dim1 = *nm; u_offset = u_dim1 + 1; u -= u_offset; --w; a_dim1 = *nm; a_offset = a_dim1 + 1; a -= a_offset; /* Function Body */ *ierr = 0; i_1 = *m; for (i = 1; i <= i_1; ++i) { i_2 = *n; for (j = 1; j <= i_2; ++j) { u[i + j * u_dim1] = a[i + j * a_dim1]; /* L100: */ } } /* .......... HOUSEHOLDER REDUCTION TO BIDIAGONAL FORM .......... */ g = 0.; scale = 0.; x = 0.; i_2 = *n; for (i = 1; i <= i_2; ++i) { l = i + 1; rv1[i] = scale * g; g = 0.; s = 0.; scale = 0.; if (i > *m) { goto L210; } i_1 = *m; for (k = i; k <= i_1; ++k) { /* L120: */ scale += (d_1 = u[k + i * u_dim1], abs(d_1)); } if (scale == 0.) { goto L210; } i_1 = *m; for (k = i; k <= i_1; ++k) { u[k + i * u_dim1] /= scale; /* Computing 2nd power */ d_1 = u[k + i * u_dim1]; s += d_1 * d_1; /* L130: */ } f = u[i + i * u_dim1]; d_1 = sqrt(s); g = -d_sign(&d_1, &f); h = f * g - s; u[i + i * u_dim1] = f - g; if (i == *n) { goto L190; } i_1 = *n; for (j = l; j <= i_1; ++j) { s = 0.; i_3 = *m; for (k = i; k <= i_3; ++k) { /* L140: */ s += u[k + i * u_dim1] * u[k + j * u_dim1]; } f = s / h; i_3 = *m; for (k = i; k <= i_3; ++k) { u[k + j * u_dim1] += f * u[k + i * u_dim1]; /* L150: */ } } L190: i_3 = *m; for (k = i; k <= i_3; ++k) { /* L200: */ u[k + i * u_dim1] = scale * u[k + i * u_dim1]; } L210: w[i] = scale * g; g = 0.; s = 0.; scale = 0.; if (i > *m || i == *n) { goto L290; } i_3 = *n; for (k = l; k <= i_3; ++k) { /* L220: */ scale += (d_1 = u[i + k * u_dim1], abs(d_1)); } if (scale == 0.) { goto L290; } i_3 = *n; for (k = l; k <= i_3; ++k) { u[i + k * u_dim1] /= scale; /* Computing 2nd power */ d_1 = u[i + k * u_dim1]; s += d_1 * d_1; /* L230: */ } f = u[i + l * u_dim1]; d_1 = sqrt(s); g = -d_sign(&d_1, &f); h = f * g - s; u[i + l * u_dim1] = f - g; i_3 = *n; for (k = l; k <= i_3; ++k) { /* L240: */ rv1[k] = u[i + k * u_dim1] / h; } if (i == *m) { goto L270; } i_3 = *m; for (j = l; j <= i_3; ++j) { s = 0.; i_1 = *n; for (k = l; k <= i_1; ++k) { /* L250: */ s += u[j + k * u_dim1] * u[i + k * u_dim1]; } i_1 = *n; for (k = l; k <= i_1; ++k) { u[j + k * u_dim1] += s * rv1[k]; /* L260: */ } } L270: i_1 = *n; for (k = l; k <= i_1; ++k) { /* L280: */ u[i + k * u_dim1] = scale * u[i + k * u_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 .......... */ if (! (*matv)) { goto L410; } /* .......... FOR I=N STEP -1 UNTIL 1 DO -- .......... */ i_2 = *n; for (ii = 1; ii <= i_2; ++ii) { i = *n + 1 - ii; if (i == *n) { goto L390; } if (g == 0.) { goto L360; } i_1 = *n; for (j = l; j <= i_1; ++j) { /* .......... DOUBLE DIVISION AVOIDS POSSIBLE UNDERFLOW ...... .... */ /* L320: */ v[j + i * v_dim1] = u[i + j * u_dim1] / u[i + l * u_dim1] / g; } i_1 = *n; for (j = l; j <= i_1; ++j) { s = 0.; i_3 = *n; for (k = l; k <= i_3; ++k) { /* L340: */ s += u[i + k * u_dim1] * v[k + j * v_dim1]; } i_3 = *n; for (k = l; k <= i_3; ++k) { v[k + j * v_dim1] += s * v[k + i * v_dim1]; /* L350: */ } } L360: i_3 = *n; for (j = l; j <= i_3; ++j) { v[i + j * v_dim1] = 0.; v[j + i * v_dim1] = 0.; /* L380: */ } L390: v[i + i * v_dim1] = 1.; g = rv1[i]; l = i; /* L400: */ } /* .......... ACCUMULATION OF LEFT-HAND TRANSFORMATIONS .......... */ L410: if (! (*matu)) { goto L510; } /* ..........FOR I=MIN(M,N) STEP -1 UNTIL 1 DO -- .......... */ mn = *n; if (*m < *n) { mn = *m; } i_2 = mn; for (ii = 1; ii <= i_2; ++ii) { i = mn + 1 - ii; l = i + 1; g = w[i]; if (i == *n) { goto L430; } i_3 = *n; for (j = l; j <= i_3; ++j) { /* L420: */ u[i + j * u_dim1] = 0.; } L430: if (g == 0.) { goto L475; } if (i == mn) { goto L460; } i_3 = *n; for (j = l; j <= i_3; ++j) { s = 0.; i_1 = *m; for (k = l; k <= i_1; ++k) { /* L440: */ s += u[k + i * u_dim1] * u[k + j * u_dim1]; } /* .......... DOUBLE DIVISION AVOIDS POSSIBLE UNDERFLOW ...... .... */ f = s / u[i + i * u_dim1] / g; i_1 = *m; for (k = i; k <= i_1; ++k) { u[k + j * u_dim1] += f * u[k + i * u_dim1]; /* L450: */ } } L460: i_1 = *m; for (j = i; j <= i_1; ++j) { /* L470: */ u[j + i * u_dim1] /= g; } goto L490; L475: i_1 = *m; for (j = i; j <= i_1; ++j) { /* L480: */ u[j + i * u_dim1] = 0.; } L490: u[i + i * u_dim1] += 1.; /* 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 (! (*matu)) { goto L560; } i_3 = *m; for (j = 1; j <= i_3; ++j) { y = u[j + l1 * u_dim1]; z = u[j + i * u_dim1]; u[j + l1 * u_dim1] = y * c + z * s; u[j + i * u_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_b141); 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; if (! (*matv)) { goto L575; } i_3 = *n; for (j = 1; j <= i_3; ++j) { x = v[j + i1 * v_dim1]; z = v[j + i * v_dim1]; v[j + i1 * v_dim1] = x * c + z * s; v[j + i * v_dim1] = -x * s + z * c; /* L570: */ } L575: 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 (! (*matu)) { goto L600; } i_3 = *m; for (j = 1; j <= i_3; ++j) { y = u[j + i1 * u_dim1]; z = u[j + i * u_dim1]; u[j + i1 * u_dim1] = y * c + z * s; u[j + i * u_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; if (! (*matv)) { goto L700; } i_1 = *n; for (j = 1; j <= i_1; ++j) { /* L690: */ v[j + k * v_dim1] = -v[j + k * v_dim1]; } L700: ; } goto L1001; /* .......... SET ERROR -- NO CONVERGENCE TO A */ /* SINGULAR VALUE AFTER 30 ITERATIONS .......... */ L1000: *ierr = k; L1001: return 0; } /* svd_ */ /* Subroutine */ int tinvit_(integer *nm, integer *n, doublereal *d, doublereal *e, doublereal *e2, integer *m, doublereal *w, integer * ind, doublereal *z, integer *ierr, doublereal *rv1, doublereal *rv2, doublereal *rv3, doublereal *rv4, doublereal *rv6) { /* System generated locals */ integer z_dim1, z_offset, i_1, i_2, i_3; doublereal d_1, d_2, d_3, d_4; /* Builtin functions */ double sqrt(doublereal); /* Local variables */ static doublereal norm; static integer i, j, p, q, r, s; static doublereal u, v, order; static integer group; static doublereal x0, x1; static integer ii, jj, ip; static doublereal uk, xu; extern doublereal pythag_(doublereal *, doublereal *), epslon_(doublereal *); static integer tag, its; static doublereal eps2, eps3, eps4; /* THIS SUBROUTINE IS A TRANSLATION OF THE INVERSE ITERATION TECH- */ /* NIQUE IN THE ALGOL PROCEDURE TRISTURM BY PETERS AND WILKINSON. */ /* HANDBOOK FOR AUTO. COMP., VOL.II-LINEAR ALGEBRA, 418-439(1971). */ /* THIS SUBROUTINE FINDS THOSE EIGENVECTORS OF A TRIDIAGONAL */ /* SYMMETRIC MATRIX CORRESPONDING TO SPECIFIED EIGENVALUES, */ /* USING INVERSE ITERATION. */ /* ON INPUT */ /* NM MUST BE SET TO THE ROW DIMENSION OF TWO-DIMENSIONAL */ /* ARRAY PARAMETERS AS DECLARED IN THE CALLING PROGRAM */ /* DIMENSION STATEMENT. */ /* N IS THE ORDER OF THE MATRIX. */ /* D CONTAINS THE DIAGONAL ELEMENTS OF THE INPUT MATRIX. */ /* E CONTAINS THE SUBDIAGONAL ELEMENTS OF THE INPUT MATRIX */ /* IN ITS LAST N-1 POSITIONS. E(1) IS ARBITRARY. */ /* E2 CONTAINS THE SQUARES OF THE CORRESPONDING ELEMENTS OF E, */ /* WITH ZEROS CORRESPONDING TO NEGLIGIBLE ELEMENTS OF E. */ /* E(I) IS CONSIDERED NEGLIGIBLE IF IT IS NOT LARGER THAN */ /* THE PRODUCT OF THE RELATIVE MACHINE PRECISION AND THE SUM */ /* OF THE MAGNITUDES OF D(I) AND D(I-1). E2(1) MUST CONTAIN */ /* 0.0D0 IF THE EIGENVALUES ARE IN ASCENDING ORDER, OR 2.0D0 */ /* IF THE EIGENVALUES ARE IN DESCENDING ORDER. IF BISECT, */ /* TRIDIB, OR IMTQLV HAS BEEN USED TO FIND THE EIGENVALUES, */ /* THEIR OUTPUT E2 ARRAY IS EXACTLY WHAT IS EXPECTED HERE. */ /* M IS THE NUMBER OF SPECIFIED EIGENVALUES. */ /* W CONTAINS THE M EIGENVALUES IN ASCENDING OR DESCENDING ORDER. */ /* IND CONTAINS IN ITS FIRST M POSITIONS 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. */ /* ON OUTPUT */ /* ALL INPUT ARRAYS ARE UNALTERED. */ /* Z CONTAINS THE ASSOCIATED SET OF ORTHONORMAL EIGENVECTORS. */ /* ANY VECTOR WHICH FAILS TO CONVERGE IS SET TO ZERO. */ /* IERR IS SET TO */ /* ZERO FOR NORMAL RETURN, */ /* -R IF THE EIGENVECTOR CORRESPONDING TO THE R-TH */ /* EIGENVALUE FAILS TO CONVERGE IN 5 ITERATIONS. */ /* RV1, RV2, RV3, RV4, AND RV6 ARE TEMPORARY STORAGE ARRAYS. */ /* 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 */ --rv6; --rv4; --rv3; --rv2; --rv1; --e2; --e; --d; z_dim1 = *nm; z_offset = z_dim1 + 1; z -= z_offset; --ind; --w; /* Function Body */ *ierr = 0; if (*m == 0) { goto L1001; } tag = 0; order = 1. - e2[1]; q = 0; /* .......... ESTABLISH AND PROCESS NEXT SUBMATRIX .......... */ L100: p = q + 1; i_1 = *n; for (q = p; q <= i_1; ++q) { if (q == *n) { goto L140; } if (e2[q + 1] == 0.) { goto L140; } /* L120: */ } /* .......... FIND VECTORS BY INVERSE ITERATION .......... */ L140: ++tag; s = 0; i_1 = *m; for (r = 1; r <= i_1; ++r) { if (ind[r] != tag) { goto L920; } its = 1; x1 = w[r]; if (s != 0) { goto L510; } /* .......... CHECK FOR ISOLATED ROOT .......... */ xu = 1.; if (p != q) { goto L490; } rv6[p] = 1.; goto L870; L490: norm = (d_1 = d[p], abs(d_1)); ip = p + 1; i_2 = q; for (i = ip; i <= i_2; ++i) { /* L500: */ /* Computing MAX */ d_3 = norm, d_4 = (d_1 = d[i], abs(d_1)) + (d_2 = e[i], abs( d_2)); norm = max(d_3,d_4); } /* .......... EPS2 IS THE CRITERION FOR GROUPING, */ /* EPS3 REPLACES ZERO PIVOTS AND EQUAL */ /* ROOTS ARE MODIFIED BY EPS3, */ /* EPS4 IS TAKEN VERY SMALL TO AVOID OVERFLOW ......... . */ eps2 = norm * .001; eps3 = epslon_(&norm); uk = (doublereal) (q - p + 1); eps4 = uk * eps3; uk = eps4 / sqrt(uk); s = p; L505: group = 0; goto L520; /* .......... LOOK FOR CLOSE OR COINCIDENT ROOTS .......... */ L510: if ((d_1 = x1 - x0, abs(d_1)) >= eps2) { goto L505; } ++group; if (order * (x1 - x0) <= 0.) { x1 = x0 + order * eps3; } /* .......... ELIMINATION WITH INTERCHANGES AND */ /* INITIALIZATION OF VECTOR .......... */ L520: v = 0.; i_2 = q; for (i = p; i <= i_2; ++i) { rv6[i] = uk; if (i == p) { goto L560; } if ((d_1 = e[i], abs(d_1)) < abs(u)) { goto L540; } /* .......... WARNING -- A DIVIDE CHECK MAY OCCUR HERE IF */ /* E2 ARRAY HAS NOT BEEN SPECIFIED CORRECTLY ...... .... */ xu = u / e[i]; rv4[i] = xu; rv1[i - 1] = e[i]; rv2[i - 1] = d[i] - x1; rv3[i - 1] = 0.; if (i != q) { rv3[i - 1] = e[i + 1]; } u = v - xu * rv2[i - 1]; v = -xu * rv3[i - 1]; goto L580; L540: xu = e[i] / u; rv4[i] = xu; rv1[i - 1] = u; rv2[i - 1] = v; rv3[i - 1] = 0.; L560: u = d[i] - x1 - xu * v; if (i != q) { v = e[i + 1]; } L580: ; } if (u == 0.) { u = eps3; } rv1[q] = u; rv2[q] = 0.; rv3[q] = 0.; /* .......... BACK SUBSTITUTION */ /* FOR I=Q STEP -1 UNTIL P DO -- .......... */ L600: i_2 = q; for (ii = p; ii <= i_2; ++ii) { i = p + q - ii; rv6[i] = (rv6[i] - u * rv2[i] - v * rv3[i]) / rv1[i]; v = u; u = rv6[i]; /* L620: */ } /* .......... ORTHOGONALIZE WITH RESPECT TO PREVIOUS */ /* MEMBERS OF GROUP .......... */ if (group == 0) { goto L700; } j = r; i_2 = group; for (jj = 1; jj <= i_2; ++jj) { L630: --j; if (ind[j] != tag) { goto L630; } xu = 0.; i_3 = q; for (i = p; i <= i_3; ++i) { /* L640: */ xu += rv6[i] * z[i + j * z_dim1]; } i_3 = q; for (i = p; i <= i_3; ++i) { /* L660: */ rv6[i] -= xu * z[i + j * z_dim1]; } /* L680: */ } L700: norm = 0.; i_2 = q; for (i = p; i <= i_2; ++i) { /* L720: */ norm += (d_1 = rv6[i], abs(d_1)); } if (norm >= 1.) { goto L840; } /* .......... FORWARD SUBSTITUTION .......... */ if (its == 5) { goto L830; } if (norm != 0.) { goto L740; } rv6[s] = eps4; ++s; if (s > q) { s = p; } goto L780; L740: xu = eps4 / norm; i_2 = q; for (i = p; i <= i_2; ++i) { /* L760: */ rv6[i] *= xu; } /* .......... ELIMINATION OPERATIONS ON NEXT VECTOR */ /* ITERATE .......... */ L780: i_2 = q; for (i = ip; i <= i_2; ++i) { u = rv6[i]; /* .......... IF RV1(I-1) .EQ. E(I), A ROW INTERCHANGE */ /* WAS PERFORMED EARLIER IN THE */ /* TRIANGULARIZATION PROCESS .......... */ if (rv1[i - 1] != e[i]) { goto L800; } u = rv6[i - 1]; rv6[i - 1] = rv6[i]; L800: rv6[i] = u - rv4[i] * rv6[i - 1]; /* L820: */ } ++its; goto L600; /* .......... SET ERROR -- NON-CONVERGED EIGENVECTOR .......... */ L830: *ierr = -r; xu = 0.; goto L870; /* .......... NORMALIZE SO THAT SUM OF SQUARES IS */ /* 1 AND EXPAND TO FULL ORDER .......... */ L840: u = 0.; i_2 = q; for (i = p; i <= i_2; ++i) { /* L860: */ u = pythag_(&u, &rv6[i]); } xu = 1. / u; L870: i_2 = *n; for (i = 1; i <= i_2; ++i) { /* L880: */ z[i + r * z_dim1] = 0.; } i_2 = q; for (i = p; i <= i_2; ++i) { /* L900: */ z[i + r * z_dim1] = rv6[i] * xu; } x0 = x1; L920: ; } if (q < *n) { goto L100; } L1001: return 0; } /* tinvit_ */ /* Subroutine */ int tql1_(integer *n, doublereal *d, doublereal *e, integer * ierr) { /* System generated locals */ integer i_1, i_2; doublereal d_1, d_2; /* Builtin functions */ double d_sign(doublereal *, doublereal *); /* Local variables */ static doublereal c, f, g, h; static integer i, j, l, m; static doublereal p, r, s, c2, c3; static integer l1, l2; static doublereal s2; static integer ii; extern doublereal pythag_(doublereal *, doublereal *); static doublereal dl1, el1; static integer mml; static doublereal tst1, tst2; /* THIS SUBROUTINE IS A TRANSLATION OF THE ALGOL PROCEDURE TQL1, */ /* NUM. MATH. 11, 293-306(1968) BY BOWDLER, MARTIN, REINSCH, AND */ /* WILKINSON. */ /* HANDBOOK FOR AUTO. COMP., VOL.II-LINEAR ALGEBRA, 227-240(1971). */ /* THIS SUBROUTINE FINDS THE EIGENVALUES OF A SYMMETRIC */ /* TRIDIAGONAL MATRIX BY THE QL METHOD. */ /* ON INPUT */ /* N IS THE ORDER OF THE MATRIX. */ /* D CONTAINS THE DIAGONAL ELEMENTS OF THE INPUT MATRIX. */ /* E CONTAINS THE SUBDIAGONAL ELEMENTS OF THE INPUT MATRIX */ /* IN ITS LAST N-1 POSITIONS. E(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. */ /* E 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. */ /* ------------------------------------------------------------------ */ /* Parameter adjustments */ --e; --d; /* 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]; } f = 0.; tst1 = 0.; e[*n] = 0.; i_1 = *n; for (l = 1; l <= i_1; ++l) { j = 0; h = (d_1 = d[l], abs(d_1)) + (d_2 = e[l], abs(d_2)); if (tst1 < h) { tst1 = h; } /* .......... LOOK FOR SMALL SUB-DIAGONAL ELEMENT .......... */ i_2 = *n; for (m = l; m <= i_2; ++m) { tst2 = tst1 + (d_1 = e[m], abs(d_1)); if (tst2 == tst1) { goto L120; } /* .......... E(N) IS ALWAYS ZERO, SO THERE IS NO EXIT */ /* THROUGH THE BOTTOM OF THE LOOP .......... */ /* L110: */ } L120: if (m == l) { goto L210; } L130: if (j == 30) { goto L1000; } ++j; /* .......... FORM SHIFT .......... */ l1 = l + 1; l2 = l1 + 1; g = d[l]; p = (d[l1] - g) / (e[l] * 2.); r = pythag_(&p, &c_b141); d[l] = e[l] / (p + d_sign(&r, &p)); d[l1] = e[l] * (p + d_sign(&r, &p)); dl1 = d[l1]; h = g - d[l]; if (l2 > *n) { goto L145; } i_2 = *n; for (i = l2; i <= i_2; ++i) { /* L140: */ d[i] -= h; } L145: f += h; /* .......... QL TRANSFORMATION .......... */ p = d[m]; c = 1.; c2 = c; el1 = e[l1]; s = 0.; mml = m - l; /* .......... FOR I=M-1 STEP -1 UNTIL L DO -- .......... */ i_2 = mml; for (ii = 1; ii <= i_2; ++ii) { c3 = c2; c2 = c; s2 = s; i = m - ii; g = c * e[i]; h = c * p; r = pythag_(&p, &e[i]); e[i + 1] = s * r; s = e[i] / r; c = p / r; p = c * d[i] - s * g; d[i + 1] = h + s * (c * g + s * d[i]); /* L200: */ } p = -s * s2 * c3 * el1 * e[l] / dl1; e[l] = s * p; d[l] = c * p; tst2 = tst1 + (d_1 = e[l], abs(d_1)); if (tst2 > tst1) { goto L130; } L210: p = d[l] + f; /* .......... ORDER EIGENVALUES .......... */ 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 >= d[i - 1]) { goto L270; } d[i] = d[i - 1]; /* L230: */ } L250: i = 1; L270: d[i] = p; /* L290: */ } goto L1001; /* .......... SET ERROR -- NO CONVERGENCE TO AN */ /* EIGENVALUE AFTER 30 ITERATIONS .......... */ L1000: *ierr = l; L1001: return 0; } /* tql1_ */ /* Subroutine */ int tql2_(integer *nm, integer *n, doublereal *d, doublereal *e, doublereal *z, integer *ierr) { /* System generated locals */ integer z_dim1, z_offset, i_1, i_2, i_3; doublereal d_1, d_2; /* Builtin functions */ double d_sign(doublereal *, doublereal *); /* Local variables */ static doublereal c, f, g, h; static integer i, j, k, l, m; static doublereal p, r, s, c2, c3; static integer l1, l2; static doublereal s2; static integer ii; extern doublereal pythag_(doublereal *, doublereal *); static doublereal dl1, el1; static integer mml; static doublereal tst1, tst2; /* THIS SUBROUTINE IS A TRANSLATION OF THE ALGOL PROCEDURE TQL2, */ /* NUM. MATH. 11, 293-306(1968) BY BOWDLER, MARTIN, REINSCH, AND */ /* WILKINSON. */ /* HANDBOOK FOR AUTO. COMP., VOL.II-LINEAR ALGEBRA, 227-240(1971). */ /* THIS SUBROUTINE FINDS THE EIGENVALUES AND EIGENVECTORS */ /* OF A SYMMETRIC TRIDIAGONAL MATRIX BY THE 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 TWO-DIMENSIONAL */ /* ARRAY PARAMETERS AS DECLARED IN THE CALLING PROGRAM */ /* DIMENSION STATEMENT. */ /* N IS THE ORDER OF THE MATRIX. */ /* D CONTAINS THE DIAGONAL ELEMENTS OF THE INPUT MATRIX. */ /* E CONTAINS THE SUBDIAGONAL ELEMENTS OF THE INPUT MATRIX */ /* IN ITS LAST N-1 POSITIONS. E(1) IS ARBITRARY. */ /* Z CONTAINS THE TRANSFORMATION MATRIX PRODUCED IN THE */ /* REDUCTION BY TRED2, IF PERFORMED. IF THE EIGENVECTORS */ /* OF THE TRIDIAGONAL MATRIX ARE DESIRED, Z MUST CONTAIN */ /* THE IDENTITY MATRIX. */ /* 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 SYMMETRIC */ /* TRIDIAGONAL (OR FULL) MATRIX. IF AN ERROR EXIT IS MADE, */ /* Z CONTAINS THE EIGENVECTORS ASSOCIATED WITH THE STORED */ /* EIGENVALUES. */ /* 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. */ /* ------------------------------------------------------------------ */ /* Parameter adjustments */ z_dim1 = *nm; z_offset = z_dim1 + 1; z -= z_offset; --e; --d; /* 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]; } f = 0.; tst1 = 0.; e[*n] = 0.; i_1 = *n; for (l = 1; l <= i_1; ++l) { j = 0; h = (d_1 = d[l], abs(d_1)) + (d_2 = e[l], abs(d_2)); if (tst1 < h) { tst1 = h; } /* .......... LOOK FOR SMALL SUB-DIAGONAL ELEMENT .......... */ i_2 = *n; for (m = l; m <= i_2; ++m) { tst2 = tst1 + (d_1 = e[m], abs(d_1)); if (tst2 == tst1) { goto L120; } /* .......... E(N) IS ALWAYS ZERO, SO THERE IS NO EXIT */ /* THROUGH THE BOTTOM OF THE LOOP .......... */ /* L110: */ } L120: if (m == l) { goto L220; } L130: if (j == 30) { goto L1000; } ++j; /* .......... FORM SHIFT .......... */ l1 = l + 1; l2 = l1 + 1; g = d[l]; p = (d[l1] - g) / (e[l] * 2.); r = pythag_(&p, &c_b141); d[l] = e[l] / (p + d_sign(&r, &p)); d[l1] = e[l] * (p + d_sign(&r, &p)); dl1 = d[l1]; h = g - d[l]; if (l2 > *n) { goto L145; } i_2 = *n; for (i = l2; i <= i_2; ++i) { /* L140: */ d[i] -= h; } L145: f += h; /* .......... QL TRANSFORMATION .......... */ p = d[m]; c = 1.; c2 = c; el1 = e[l1]; s = 0.; mml = m - l; /* .......... FOR I=M-1 STEP -1 UNTIL L DO -- .......... */ i_2 = mml; for (ii = 1; ii <= i_2; ++ii) { c3 = c2; c2 = c; s2 = s; i = m - ii; g = c * e[i]; h = c * p; r = pythag_(&p, &e[i]); e[i + 1] = s * r; s = e[i] / r; c = p / r; p = c * d[i] - s * g; d[i + 1] = h + s * (c * g + s * d[i]); /* .......... FORM VECTOR .......... */ i_3 = *n; for (k = 1; k <= i_3; ++k) { h = z[k + (i + 1) * z_dim1]; z[k + (i + 1) * z_dim1] = s * z[k + i * z_dim1] + c * h; z[k + i * z_dim1] = c * z[k + i * z_dim1] - s * h; /* L180: */ } /* L200: */ } p = -s * s2 * c3 * el1 * e[l] / dl1; e[l] = s * p; d[l] = c * p; tst2 = tst1 + (d_1 = e[l], abs(d_1)); if (tst2 > tst1) { goto L130; } L220: d[l] += f; /* 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; } /* tql2_ */ /* 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 */ static doublereal b, c, f, g, h; static integer i, j, l, m; static doublereal p, r, s, t; static integer l1, ii; extern doublereal pythag_(doublereal *, doublereal *), epslon_(doublereal *); static integer mml; /* 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. */ /* ------------------------------------------------------------------ */ /* Parameter adjustments */ --e2; --d; /* Function Body */ *ierr = 0; if (*n == 1) { goto L1001; } i_1 = *n; for (i = 2; i <= i_1; ++i) { /* L100: */ e2[i - 1] = e2[i]; } f = 0.; t = 0.; e2[*n] = 0.; i_1 = *n; for (l = 1; l <= i_1; ++l) { j = 0; h = (d_1 = d[l], abs(d_1)) + sqrt(e2[l]); if (t > h) { goto L105; } t = h; b = epslon_(&t); c = b * b; /* .......... LOOK FOR SMALL SQUARED SUB-DIAGONAL ELEMENT ........ .. */ L105: i_2 = *n; for (m = l; m <= i_2; ++m) { if (e2[m] <= c) { goto L120; } /* .......... E2(N) IS ALWAYS ZERO, SO THERE IS NO EXIT */ /* THROUGH THE BOTTOM OF THE LOOP .......... */ /* L110: */ } L120: if (m == l) { goto L210; } L130: if (j == 30) { goto L1000; } ++j; /* .......... FORM SHIFT .......... */ l1 = l + 1; s = sqrt(e2[l]); g = d[l]; p = (d[l1] - g) / (s * 2.); r = pythag_(&p, &c_b141); d[l] = s / (p + d_sign(&r, &p)); h = g - d[l]; i_2 = *n; for (i = l1; i <= i_2; ++i) { /* L140: */ d[i] -= h; } f += h; /* .......... RATIONAL QL TRANSFORMATION .......... */ g = d[m]; if (g == 0.) { g = b; } h = g; s = 0.; 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; p = g * h; r = p + e2[i]; e2[i + 1] = s * r; s = e2[i] / r; d[i + 1] = h + s * (h + d[i]); g = d[i] - e2[i] / g; if (g == 0.) { g = b; } h = g * p / r; /* L200: */ } e2[l] = s * g; d[l] = h; /* .......... GUARD AGAINST UNDERFLOW IN CONVERGENCE TEST ........ .. */ if (h == 0.) { goto L210; } if ((d_1 = e2[l], abs(d_1)) <= (d_2 = c / h, abs(d_2))) { goto L210; } e2[l] = h * e2[l]; if (e2[l] != 0.) { goto L130; } L210: p = d[l] + f; /* .......... ORDER EIGENVALUES .......... */ 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 >= d[i - 1]) { goto L270; } d[i] = d[i - 1]; /* L230: */ } L250: i = 1; L270: d[i] = p; /* L290: */ } goto L1001; /* .......... SET ERROR -- NO CONVERGENCE TO AN */ /* EIGENVALUE AFTER 30 ITERATIONS .......... */ L1000: *ierr = l; L1001: return 0; } /* tqlrat_ */ /* Subroutine */ int trbak1_(integer *nm, integer *n, doublereal *a, doublereal *e, integer *m, doublereal *z) { /* System generated locals */ integer a_dim1, a_offset, z_dim1, z_offset, i_1, i_2, i_3; /* Local variables */ static integer i, j, k, l; static doublereal s; /* THIS SUBROUTINE IS A TRANSLATION OF THE ALGOL PROCEDURE TRBAK1, */ /* NUM. MATH. 11, 181-195(1968) BY MARTIN, REINSCH, AND WILKINSON. */ /* HANDBOOK FOR AUTO. COMP., VOL.II-LINEAR ALGEBRA, 212-226(1971). */ /* THIS SUBROUTINE FORMS THE EIGENVECTORS OF A REAL SYMMETRIC */ /* MATRIX BY BACK TRANSFORMING THOSE OF THE CORRESPONDING */ /* SYMMETRIC TRIDIAGONAL MATRIX DETERMINED BY TRED1. */ /* ON INPUT */ /* NM MUST BE SET TO THE ROW DIMENSION OF TWO-DIMENSIONAL */ /* ARRAY PARAMETERS AS DECLARED IN THE CALLING PROGRAM */ /* DIMENSION STATEMENT. */ /* N IS THE ORDER OF THE MATRIX. */ /* A CONTAINS INFORMATION ABOUT THE ORTHOGONAL TRANS- */ /* FORMATIONS USED IN THE REDUCTION BY TRED1 */ /* IN ITS STRICT LOWER TRIANGLE. */ /* E CONTAINS THE SUBDIAGONAL ELEMENTS OF THE TRIDIAGONAL */ /* MATRIX IN ITS LAST N-1 POSITIONS. E(1) IS ARBITRARY. */ /* M IS THE NUMBER OF EIGENVECTORS TO BE BACK TRANSFORMED. */ /* Z CONTAINS THE EIGENVECTORS TO BE BACK TRANSFORMED */ /* IN ITS FIRST M COLUMNS. */ /* ON OUTPUT */ /* Z CONTAINS THE TRANSFORMED EIGENVECTORS */ /* IN ITS FIRST M COLUMNS. */ /* NOTE THAT TRBAK1 PRESERVES VECTOR EUCLIDEAN NORMS. */ /* 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 */ --e; a_dim1 = *nm; a_offset = a_dim1 + 1; a -= a_offset; z_dim1 = *nm; z_offset = z_dim1 + 1; z -= z_offset; /* Function Body */ if (*m == 0) { goto L200; } if (*n == 1) { goto L200; } i_1 = *n; for (i = 2; i <= i_1; ++i) { l = i - 1; if (e[i] == 0.) { goto L140; } i_2 = *m; for (j = 1; j <= i_2; ++j) { s = 0.; i_3 = l; for (k = 1; k <= i_3; ++k) { /* L110: */ s += a[i + k * a_dim1] * z[k + j * z_dim1]; } /* .......... DIVISOR BELOW IS NEGATIVE OF H FORMED IN TRED1. */ /* DOUBLE DIVISION AVOIDS POSSIBLE UNDERFLOW ...... .... */ s = s / a[i + l * a_dim1] / e[i]; i_3 = l; for (k = 1; k <= i_3; ++k) { /* L120: */ z[k + j * z_dim1] += s * a[i + k * a_dim1]; } /* L130: */ } L140: ; } L200: return 0; } /* trbak1_ */ /* Subroutine */ int trbak3_(integer *nm, integer *n, integer */*nv*/, doublereal *a, integer *m, doublereal *z) { /* System generated locals */ integer z_dim1, z_offset, i_1, i_2, i_3; /* Local variables */ static doublereal h; static integer i, j, k, l; static doublereal s; static integer ik, iz; /* THIS SUBROUTINE IS A TRANSLATION OF THE ALGOL PROCEDURE TRBAK3, */ /* NUM. MATH. 11, 181-195(1968) BY MARTIN, REINSCH, AND WILKINSON. */ /* HANDBOOK FOR AUTO. COMP., VOL.II-LINEAR ALGEBRA, 212-226(1971). */ /* THIS SUBROUTINE FORMS THE EIGENVECTORS OF A REAL SYMMETRIC */ /* MATRIX BY BACK TRANSFORMING THOSE OF THE CORRESPONDING */ /* SYMMETRIC TRIDIAGONAL MATRIX DETERMINED BY TRED3. */ /* ON INPUT */ /* NM MUST BE SET TO THE ROW DIMENSION OF TWO-DIMENSIONAL */ /* ARRAY PARAMETERS AS DECLARED IN THE CALLING PROGRAM */ /* DIMENSION STATEMENT. */ /* N IS THE ORDER OF THE MATRIX. */ /* NV MUST BE SET TO THE DIMENSION OF THE ARRAY PARAMETER A */ /* AS DECLARED IN THE CALLING PROGRAM DIMENSION STATEMENT. */ /* A CONTAINS INFORMATION ABOUT THE ORTHOGONAL TRANSFORMATIONS */ /* USED IN THE REDUCTION BY TRED3 IN ITS FIRST */ /* N*(N+1)/2 POSITIONS. */ /* M IS THE NUMBER OF EIGENVECTORS TO BE BACK TRANSFORMED. */ /* Z CONTAINS THE EIGENVECTORS TO BE BACK TRANSFORMED */ /* IN ITS FIRST M COLUMNS. */ /* ON OUTPUT */ /* Z CONTAINS THE TRANSFORMED EIGENVECTORS */ /* IN ITS FIRST M COLUMNS. */ /* NOTE THAT TRBAK3 PRESERVES VECTOR EUCLIDEAN NORMS. */ /* 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 */ --a; z_dim1 = *nm; z_offset = z_dim1 + 1; z -= z_offset; /* Function Body */ if (*m == 0) { goto L200; } if (*n == 1) { goto L200; } i_1 = *n; for (i = 2; i <= i_1; ++i) { l = i - 1; iz = i * l / 2; ik = iz + i; h = a[ik]; if (h == 0.) { goto L140; } i_2 = *m; for (j = 1; j <= i_2; ++j) { s = 0.; ik = iz; i_3 = l; for (k = 1; k <= i_3; ++k) { ++ik; s += a[ik] * z[k + j * z_dim1]; /* L110: */ } /* .......... DOUBLE DIVISION AVOIDS POSSIBLE UNDERFLOW ...... .... */ s = s / h / h; ik = iz; i_3 = l; for (k = 1; k <= i_3; ++k) { ++ik; z[k + j * z_dim1] -= s * a[ik]; /* L120: */ } /* L130: */ } L140: ; } L200: return 0; } /* trbak3_ */ /* Subroutine */ int tred1_(integer *nm, integer *n, doublereal *a, doublereal *d, doublereal *e, doublereal *e2) { /* System generated locals */ integer a_dim1, a_offset, i_1, i_2, i_3; doublereal d_1; /* Builtin functions */ double sqrt(doublereal), d_sign(doublereal *, doublereal *); /* Local variables */ static doublereal f, g, h; static integer i, j, k, l; static doublereal scale; static integer ii, jp1; /* THIS SUBROUTINE IS A TRANSLATION 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 REAL SYMMETRIC MATRIX */ /* TO A SYMMETRIC TRIDIAGONAL MATRIX USING */ /* ORTHOGONAL SIMILARITY TRANSFORMATIONS. */ /* ON INPUT */ /* NM MUST BE SET TO THE ROW DIMENSION OF TWO-DIMENSIONAL */ /* ARRAY PARAMETERS AS DECLARED IN THE CALLING PROGRAM */ /* DIMENSION STATEMENT. */ /* N IS THE ORDER OF THE MATRIX. */ /* A CONTAINS THE REAL SYMMETRIC INPUT MATRIX. ONLY THE */ /* LOWER TRIANGLE OF THE MATRIX NEED BE SUPPLIED. */ /* ON OUTPUT */ /* A CONTAINS INFORMATION ABOUT THE ORTHOGONAL TRANS- */ /* FORMATIONS USED IN THE REDUCTION IN ITS STRICT LOWER */ /* TRIANGLE. THE FULL UPPER TRIANGLE OF A IS UNALTERED. */ /* D CONTAINS THE DIAGONAL ELEMENTS OF THE TRIDIAGONAL MATRIX. */ /* E CONTAINS THE SUBDIAGONAL ELEMENTS OF THE TRIDIAGONAL */ /* MATRIX IN ITS LAST N-1 POSITIONS. E(1) IS SET TO ZERO. */ /* E2 CONTAINS THE SQUARES OF THE CORRESPONDING ELEMENTS OF E. */ /* E2 MAY COINCIDE WITH E IF THE SQUARES ARE NOT NEEDED. */ /* 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 */ --e2; --e; --d; a_dim1 = *nm; a_offset = a_dim1 + 1; a -= a_offset; /* Function Body */ i_1 = *n; for (i = 1; i <= i_1; ++i) { d[i] = a[*n + i * a_dim1]; a[*n + i * a_dim1] = a[i + i * a_dim1]; /* L100: */ } /* .......... 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.; scale = 0.; if (l < 1) { goto L130; } /* .......... SCALE ROW (ALGOL TOL THEN NOT NEEDED) .......... */ i_2 = l; for (k = 1; k <= i_2; ++k) { /* L120: */ scale += (d_1 = d[k], abs(d_1)); } if (scale != 0.) { goto L140; } i_2 = l; for (j = 1; j <= i_2; ++j) { d[j] = a[l + j * a_dim1]; a[l + j * a_dim1] = a[i + j * a_dim1]; a[i + j * a_dim1] = 0.; /* L125: */ } L130: e[i] = 0.; e2[i] = 0.; goto L300; L140: i_2 = l; for (k = 1; k <= i_2; ++k) { d[k] /= scale; h += d[k] * d[k]; /* L150: */ } e2[i] = scale * scale * h; f = d[l]; d_1 = sqrt(h); g = -d_sign(&d_1, &f); e[i] = scale * g; h -= f * g; d[l] = f - g; if (l == 1) { goto L285; } /* .......... FORM A*U .......... */ i_2 = l; for (j = 1; j <= i_2; ++j) { /* L170: */ e[j] = 0.; } i_2 = l; for (j = 1; j <= i_2; ++j) { f = d[j]; g = e[j] + a[j + j * a_dim1] * f; jp1 = j + 1; if (l < jp1) { goto L220; } i_3 = l; for (k = jp1; k <= i_3; ++k) { g += a[k + j * a_dim1] * d[k]; e[k] += a[k + j * a_dim1] * f; /* L200: */ } L220: e[j] = g; /* L240: */ } /* .......... FORM P .......... */ f = 0.; i_2 = l; for (j = 1; j <= i_2; ++j) { e[j] /= h; f += e[j] * d[j]; /* L245: */ } h = f / (h + h); /* .......... FORM Q .......... */ i_2 = l; for (j = 1; j <= i_2; ++j) { /* L250: */ e[j] -= h * d[j]; } /* .......... FORM REDUCED A .......... */ i_2 = l; for (j = 1; j <= i_2; ++j) { f = d[j]; g = e[j]; i_3 = l; for (k = j; k <= i_3; ++k) { /* L260: */ a[k + j * a_dim1] = a[k + j * a_dim1] - f * e[k] - g * d[k]; } /* L280: */ } L285: i_2 = l; for (j = 1; j <= i_2; ++j) { f = d[j]; d[j] = a[l + j * a_dim1]; a[l + j * a_dim1] = a[i + j * a_dim1]; a[i + j * a_dim1] = f * scale; /* L290: */ } L300: ; } return 0; } /* tred1_ */ /* Subroutine */ int tred2_(integer *nm, integer *n, doublereal *a, doublereal *d, doublereal *e, doublereal *z) { /* System generated locals */ integer a_dim1, a_offset, z_dim1, z_offset, i_1, i_2, i_3; doublereal d_1; /* Builtin functions */ double sqrt(doublereal), d_sign(doublereal *, doublereal *); /* Local variables */ static doublereal f, g, h; static integer i, j, k, l; static doublereal scale, hh; static integer ii, jp1; /* THIS SUBROUTINE IS A TRANSLATION OF THE ALGOL PROCEDURE TRED2, */ /* 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 REAL SYMMETRIC MATRIX TO A */ /* SYMMETRIC TRIDIAGONAL MATRIX USING AND ACCUMULATING */ /* ORTHOGONAL SIMILARITY TRANSFORMATIONS. */ /* ON INPUT */ /* NM MUST BE SET TO THE ROW DIMENSION OF TWO-DIMENSIONAL */ /* ARRAY PARAMETERS AS DECLARED IN THE CALLING PROGRAM */ /* DIMENSION STATEMENT. */ /* N IS THE ORDER OF THE MATRIX. */ /* A CONTAINS THE REAL SYMMETRIC INPUT MATRIX. ONLY THE */ /* LOWER TRIANGLE OF THE MATRIX NEED BE SUPPLIED. */ /* ON OUTPUT */ /* D CONTAINS THE DIAGONAL ELEMENTS OF THE TRIDIAGONAL MATRIX. */ /* E CONTAINS THE SUBDIAGONAL ELEMENTS OF THE TRIDIAGONAL */ /* MATRIX IN ITS LAST N-1 POSITIONS. E(1) IS SET TO ZERO. */ /* Z CONTAINS THE ORTHOGONAL TRANSFORMATION MATRIX */ /* PRODUCED IN THE REDUCTION. */ /* A AND Z MAY COINCIDE. IF DISTINCT, A IS UNALTERED. */ /* 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 */ z_dim1 = *nm; z_offset = z_dim1 + 1; z -= z_offset; --e; --d; a_dim1 = *nm; a_offset = a_dim1 + 1; a -= a_offset; /* Function Body */ i_1 = *n; for (i = 1; i <= i_1; ++i) { i_2 = *n; for (j = i; j <= i_2; ++j) { /* L80: */ z[j + i * z_dim1] = a[j + i * a_dim1]; } d[i] = a[*n + i * a_dim1]; /* L100: */ } if (*n == 1) { goto L510; } /* .......... FOR I=N STEP -1 UNTIL 2 DO -- .......... */ i_1 = *n; for (ii = 2; ii <= i_1; ++ii) { i = *n + 2 - ii; l = i - 1; h = 0.; scale = 0.; if (l < 2) { goto L130; } /* .......... SCALE ROW (ALGOL TOL THEN NOT NEEDED) .......... */ i_2 = l; for (k = 1; k <= i_2; ++k) { /* L120: */ scale += (d_1 = d[k], abs(d_1)); } if (scale != 0.) { goto L140; } L130: e[i] = d[l]; i_2 = l; for (j = 1; j <= i_2; ++j) { d[j] = z[l + j * z_dim1]; z[i + j * z_dim1] = 0.; z[j + i * z_dim1] = 0.; /* L135: */ } goto L290; L140: i_2 = l; for (k = 1; k <= i_2; ++k) { d[k] /= scale; h += d[k] * d[k]; /* L150: */ } f = d[l]; d_1 = sqrt(h); g = -d_sign(&d_1, &f); e[i] = scale * g; h -= f * g; d[l] = f - g; /* .......... FORM A*U .......... */ i_2 = l; for (j = 1; j <= i_2; ++j) { /* L170: */ e[j] = 0.; } i_2 = l; for (j = 1; j <= i_2; ++j) { f = d[j]; z[j + i * z_dim1] = f; g = e[j] + z[j + j * z_dim1] * f; jp1 = j + 1; if (l < jp1) { goto L220; } i_3 = l; for (k = jp1; k <= i_3; ++k) { g += z[k + j * z_dim1] * d[k]; e[k] += z[k + j * z_dim1] * f; /* L200: */ } L220: e[j] = g; /* L240: */ } /* .......... FORM P .......... */ f = 0.; i_2 = l; for (j = 1; j <= i_2; ++j) { e[j] /= h; f += e[j] * d[j]; /* L245: */ } hh = f / (h + h); /* .......... FORM Q .......... */ i_2 = l; for (j = 1; j <= i_2; ++j) { /* L250: */ e[j] -= hh * d[j]; } /* .......... FORM REDUCED A .......... */ i_2 = l; for (j = 1; j <= i_2; ++j) { f = d[j]; g = e[j]; i_3 = l; for (k = j; k <= i_3; ++k) { /* L260: */ z[k + j * z_dim1] = z[k + j * z_dim1] - f * e[k] - g * d[k]; } d[j] = z[l + j * z_dim1]; z[i + j * z_dim1] = 0.; /* L280: */ } L290: d[i] = h; /* L300: */ } /* .......... ACCUMULATION OF TRANSFORMATION MATRICES .......... */ i_1 = *n; for (i = 2; i <= i_1; ++i) { l = i - 1; z[*n + l * z_dim1] = z[l + l * z_dim1]; z[l + l * z_dim1] = 1.; h = d[i]; if (h == 0.) { goto L380; } i_2 = l; for (k = 1; k <= i_2; ++k) { /* L330: */ d[k] = z[k + i * z_dim1] / h; } i_2 = l; for (j = 1; j <= i_2; ++j) { g = 0.; i_3 = l; for (k = 1; k <= i_3; ++k) { /* L340: */ g += z[k + i * z_dim1] * z[k + j * z_dim1]; } i_3 = l; for (k = 1; k <= i_3; ++k) { z[k + j * z_dim1] -= g * d[k]; /* L360: */ } } L380: i_3 = l; for (k = 1; k <= i_3; ++k) { /* L400: */ z[k + i * z_dim1] = 0.; } /* L500: */ } L510: i_1 = *n; for (i = 1; i <= i_1; ++i) { d[i] = z[*n + i * z_dim1]; z[*n + i * z_dim1] = 0.; /* L520: */ } z[*n + *n * z_dim1] = 1.; e[1] = 0.; return 0; } /* tred2_ */ /* Subroutine */ int tred3_(integer *n, integer */*nv*/, doublereal *a, doublereal *d, doublereal *e, doublereal *e2) { /* System generated locals */ integer i_1, i_2, i_3; doublereal d_1; /* Builtin functions */ double sqrt(doublereal), d_sign(doublereal *, doublereal *); /* Local variables */ static doublereal f, g, h; static integer i, j, k, l; static doublereal scale, hh; static integer ii, jk, iz, jm1; /* THIS SUBROUTINE IS A TRANSLATION OF THE ALGOL PROCEDURE TRED3, */ /* 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 REAL SYMMETRIC MATRIX, STORED AS */ /* A ONE-DIMENSIONAL ARRAY, TO A SYMMETRIC TRIDIAGONAL MATRIX */ /* USING ORTHOGONAL SIMILARITY TRANSFORMATIONS. */ /* ON INPUT */ /* N IS THE ORDER OF THE MATRIX. */ /* NV MUST BE SET TO THE DIMENSION OF THE ARRAY PARAMETER A */ /* AS DECLARED IN THE CALLING PROGRAM DIMENSION STATEMENT. */ /* A CONTAINS THE LOWER TRIANGLE OF THE REAL SYMMETRIC */ /* INPUT MATRIX, STORED ROW-WISE AS A ONE-DIMENSIONAL */ /* ARRAY, IN ITS FIRST N*(N+1)/2 POSITIONS. */ /* ON OUTPUT */ /* A CONTAINS INFORMATION ABOUT THE ORTHOGONAL */ /* TRANSFORMATIONS USED IN THE REDUCTION. */ /* D CONTAINS THE DIAGONAL ELEMENTS OF THE TRIDIAGONAL MATRIX. */ /* E CONTAINS THE SUBDIAGONAL ELEMENTS OF THE TRIDIAGONAL */ /* MATRIX IN ITS LAST N-1 POSITIONS. E(1) IS SET TO ZERO. */ /* E2 CONTAINS THE SQUARES OF THE CORRESPONDING ELEMENTS OF E. */ /* E2 MAY COINCIDE WITH E IF THE SQUARES ARE NOT NEEDED. */ /* QUESTIONS AND COMMENTS SHOULD BE DIRECTED TO BURTON S. GARBOW, */ /* MATHEMATICS AND COMPUTER SCIENCE DIV, ARGONNE NATIONAL LABORATORY */ /* THIS VERSION DATED AUGUST 1983. */ /* ------------------------------------------------------------------ */ /* .......... FOR I=N STEP -1 UNTIL 1 DO -- .......... */ /* Parameter adjustments */ --e2; --e; --d; --a; /* Function Body */ i_1 = *n; for (ii = 1; ii <= i_1; ++ii) { i = *n + 1 - ii; l = i - 1; iz = i * l / 2; h = 0.; scale = 0.; if (l < 1) { goto L130; } /* .......... SCALE ROW (ALGOL TOL THEN NOT NEEDED) .......... */ i_2 = l; for (k = 1; k <= i_2; ++k) { ++iz; d[k] = a[iz]; scale += (d_1 = d[k], abs(d_1)); /* L120: */ } if (scale != 0.) { goto L140; } L130: e[i] = 0.; e2[i] = 0.; goto L290; L140: i_2 = l; for (k = 1; k <= i_2; ++k) { d[k] /= scale; h += d[k] * d[k]; /* L150: */ } e2[i] = scale * scale * h; f = d[l]; d_1 = sqrt(h); g = -d_sign(&d_1, &f); e[i] = scale * g; h -= f * g; d[l] = f - g; a[iz] = scale * d[l]; if (l == 1) { goto L290; } jk = 1; i_2 = l; for (j = 1; j <= i_2; ++j) { f = d[j]; g = 0.; jm1 = j - 1; if (jm1 < 1) { goto L220; } i_3 = jm1; for (k = 1; k <= i_3; ++k) { g += a[jk] * d[k]; e[k] += a[jk] * f; ++jk; /* L200: */ } L220: e[j] = g + a[jk] * f; ++jk; /* L240: */ } /* .......... FORM P .......... */ f = 0.; i_2 = l; for (j = 1; j <= i_2; ++j) { e[j] /= h; f += e[j] * d[j]; /* L245: */ } hh = f / (h + h); /* .......... FORM Q .......... */ i_2 = l; for (j = 1; j <= i_2; ++j) { /* L250: */ e[j] -= hh * d[j]; } jk = 1; /* .......... FORM REDUCED A .......... */ i_2 = l; for (j = 1; j <= i_2; ++j) { f = d[j]; g = e[j]; i_3 = j; for (k = 1; k <= i_3; ++k) { a[jk] = a[jk] - f * e[k] - g * d[k]; ++jk; /* L260: */ } /* L280: */ } L290: d[i] = a[iz + 1]; a[iz + 1] = scale * sqrt(h); /* L300: */ } return 0; } /* tred3_ */ /* Subroutine */ int tridib_(integer *n, doublereal *eps1, doublereal *d, doublereal *e, doublereal *e2, doublereal *lb, doublereal *ub, integer *m11, integer *m, doublereal *w, integer *ind, integer *ierr, doublereal *rv4, doublereal *rv5) { /* System generated locals */ integer i_1, i_2; doublereal d_1, d_2, d_3; /* Local variables */ static integer i, j, k, l, p, q, r, s; static doublereal u, v; static integer m1, m2; static doublereal t1, t2, x0, x1; static integer m22, ii; static doublereal xu; extern doublereal epslon_(doublereal *); static integer isturm, tag; static doublereal tst1, tst2; /* THIS SUBROUTINE IS A TRANSLATION OF THE ALGOL PROCEDURE BISECT, */ /* NUM. MATH. 9, 386-393(1967) BY BARTH, MARTIN, AND WILKINSON. */ /* HANDBOOK FOR AUTO. COMP., VOL.II-LINEAR ALGEBRA, 249-256(1971). */ /* THIS SUBROUTINE FINDS THOSE EIGENVALUES OF A TRIDIAGONAL */ /* SYMMETRIC MATRIX BETWEEN SPECIFIED BOUNDARY INDICES, */ /* USING BISECTION. */ /* ON INPUT */ /* N IS THE ORDER OF THE MATRIX. */ /* EPS1 IS AN ABSOLUTE ERROR TOLERANCE FOR THE COMPUTED */ /* EIGENVALUES. IF THE INPUT EPS1 IS NON-POSITIVE, */ /* IT IS RESET FOR EACH SUBMATRIX TO A DEFAULT VALUE, */ /* NAMELY, MINUS THE PRODUCT OF THE RELATIVE MACHINE */ /* PRECISION AND THE 1-NORM OF THE SUBMATRIX. */ /* D CONTAINS THE DIAGONAL ELEMENTS OF THE INPUT MATRIX. */ /* E CONTAINS THE SUBDIAGONAL ELEMENTS OF THE INPUT MATRIX */ /* IN ITS LAST N-1 POSITIONS. E(1) IS ARBITRARY. */ /* E2 CONTAINS THE SQUARES OF THE CORRESPONDING ELEMENTS OF E. */ /* E2(1) IS ARBITRARY. */ /* M11 SPECIFIES THE LOWER BOUNDARY INDEX FOR THE DESIRED */ /* EIGENVALUES. */ /* M SPECIFIES THE NUMBER OF EIGENVALUES DESIRED. THE UPPER */ /* BOUNDARY INDEX M22 IS THEN OBTAINED AS M22=M11+M-1. */ /* ON OUTPUT */ /* EPS1 IS UNALTERED UNLESS IT HAS BEEN RESET TO ITS */ /* (LAST) DEFAULT VALUE. */ /* 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. */ /* LB AND UB DEFINE AN INTERVAL CONTAINING EXACTLY THE DESIRED */ /* EIGENVALUES. */ /* W CONTAINS, IN ITS FIRST M POSITIONS, THE EIGENVALUES */ /* BETWEEN INDICES M11 AND M22 IN ASCENDING ORDER. */ /* IND CONTAINS IN ITS FIRST M POSITIONS 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.. */ /* IERR IS SET TO */ /* ZERO FOR NORMAL RETURN, */ /* 3*N+1 IF MULTIPLE EIGENVALUES AT INDEX M11 MAKE */ /* UNIQUE SELECTION IMPOSSIBLE, */ /* 3*N+2 IF MULTIPLE EIGENVALUES AT INDEX M22 MAKE */ /* UNIQUE SELECTION IMPOSSIBLE. */ /* RV4 AND RV5 ARE TEMPORARY STORAGE ARRAYS. */ /* NOTE THAT SUBROUTINE TQL1, IMTQL1, OR TQLRAT IS GENERALLY FASTER */ /* THAN TRIDIB, IF MORE THAN N/4 EIGENVALUES ARE TO BE FOUND. */ /* 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 */ --rv5; --rv4; --e2; --e; --d; --ind; --w; /* Function Body */ *ierr = 0; tag = 0; xu = d[1]; x0 = d[1]; u = 0.; /* .......... LOOK FOR SMALL SUB-DIAGONAL ENTRIES AND DETERMINE AN */ /* INTERVAL CONTAINING ALL THE EIGENVALUES .......... */ i_1 = *n; for (i = 1; i <= i_1; ++i) { x1 = u; u = 0.; if (i != *n) { u = (d_1 = e[i + 1], abs(d_1)); } /* Computing MIN */ d_1 = d[i] - (x1 + u); xu = min(d_1,xu); /* Computing MAX */ d_1 = d[i] + (x1 + u); x0 = max(d_1,x0); if (i == 1) { goto L20; } tst1 = (d_1 = d[i], abs(d_1)) + (d_2 = d[i - 1], abs(d_2)); tst2 = tst1 + (d_1 = e[i], abs(d_1)); if (tst2 > tst1) { goto L40; } L20: e2[i] = 0.; L40: ; } x1 = (doublereal) (*n); /* Computing MAX */ d_2 = abs(xu), d_3 = abs(x0); d_1 = max(d_2,d_3); x1 *= epslon_(&d_1); xu -= x1; t1 = xu; x0 += x1; t2 = x0; /* .......... DETERMINE AN INTERVAL CONTAINING EXACTLY */ /* THE DESIRED EIGENVALUES .......... */ p = 1; q = *n; m1 = *m11 - 1; if (m1 == 0) { goto L75; } isturm = 1; L50: v = x1; x1 = xu + (x0 - xu) * .5; if (x1 == v) { goto L980; } goto L320; L60: if ((i_1 = s - m1) < 0) { goto L65; } else if (i_1 == 0) { goto L73; } else { goto L70; } L65: xu = x1; goto L50; L70: x0 = x1; goto L50; L73: xu = x1; t1 = x1; L75: m22 = m1 + *m; if (m22 == *n) { goto L90; } x0 = t2; isturm = 2; goto L50; L80: if ((i_1 = s - m22) < 0) { goto L65; } else if (i_1 == 0) { goto L85; } else { goto L70; } L85: t2 = x1; L90: q = 0; r = 0; /* .......... ESTABLISH AND PROCESS NEXT SUBMATRIX, REFINING */ /* INTERVAL BY THE GERSCHGORIN BOUNDS .......... */ L100: if (r == *m) { goto L1001; } ++tag; p = q + 1; xu = d[p]; x0 = d[p]; u = 0.; i_1 = *n; for (q = p; q <= i_1; ++q) { x1 = u; u = 0.; v = 0.; if (q == *n) { goto L110; } u = (d_1 = e[q + 1], abs(d_1)); v = e2[q + 1]; L110: /* Computing MIN */ d_1 = d[q] - (x1 + u); xu = min(d_1,xu); /* Computing MAX */ d_1 = d[q] + (x1 + u); x0 = max(d_1,x0); if (v == 0.) { goto L140; } /* L120: */ } L140: /* Computing MAX */ d_2 = abs(xu), d_3 = abs(x0); d_1 = max(d_2,d_3); x1 = epslon_(&d_1); if (*eps1 <= 0.) { *eps1 = -x1; } if (p != q) { goto L180; } /* .......... CHECK FOR ISOLATED ROOT WITHIN INTERVAL .......... */ if (t1 > d[p] || d[p] >= t2) { goto L940; } m1 = p; m2 = p; rv5[p] = d[p]; goto L900; L180: x1 *= q - p + 1; /* Computing MAX */ d_1 = t1, d_2 = xu - x1; *lb = max(d_1,d_2); /* Computing MIN */ d_1 = t2, d_2 = x0 + x1; *ub = min(d_1,d_2); x1 = *lb; isturm = 3; goto L320; L200: m1 = s + 1; x1 = *ub; isturm = 4; goto L320; L220: m2 = s; if (m1 > m2) { goto L940; } /* .......... FIND ROOTS BY BISECTION .......... */ x0 = *ub; isturm = 5; i_1 = m2; for (i = m1; i <= i_1; ++i) { rv5[i] = *ub; rv4[i] = *lb; /* L240: */ } /* .......... LOOP FOR K-TH EIGENVALUE */ /* FOR K=M2 STEP -1 UNTIL M1 DO -- */ /* (-DO- NOT USED TO LEGALIZE -COMPUTED GO TO-) .......... */ k = m2; L250: xu = *lb; /* .......... FOR I=K STEP -1 UNTIL M1 DO -- .......... */ i_1 = k; for (ii = m1; ii <= i_1; ++ii) { i = m1 + k - ii; if (xu >= rv4[i]) { goto L260; } xu = rv4[i]; goto L280; L260: ; } L280: if (x0 > rv5[k]) { x0 = rv5[k]; } /* .......... NEXT BISECTION STEP .......... */ L300: x1 = (xu + x0) * .5; if (x0 - xu <= abs(*eps1)) { goto L420; } tst1 = (abs(xu) + abs(x0)) * 2.; tst2 = tst1 + (x0 - xu); if (tst2 == tst1) { goto L420; } /* .......... IN-LINE PROCEDURE FOR STURM SEQUENCE .......... */ L320: s = p - 1; u = 1.; i_1 = q; for (i = p; i <= i_1; ++i) { if (u != 0.) { goto L325; } v = (d_1 = e[i], abs(d_1)) / epslon_(&c_b141); if (e2[i] == 0.) { v = 0.; } goto L330; L325: v = e2[i] / u; L330: u = d[i] - x1 - v; if (u < 0.) { ++s; } /* L340: */ } switch (isturm) { case 1: goto L60; case 2: goto L80; case 3: goto L200; case 4: goto L220; case 5: goto L360; } /* .......... REFINE INTERVALS .......... */ L360: if (s >= k) { goto L400; } xu = x1; if (s >= m1) { goto L380; } rv4[m1] = x1; goto L300; L380: rv4[s + 1] = x1; if (rv5[s] > x1) { rv5[s] = x1; } goto L300; L400: x0 = x1; goto L300; /* .......... K-TH EIGENVALUE FOUND .......... */ L420: rv5[k] = x1; --k; if (k >= m1) { goto L250; } /* .......... ORDER EIGENVALUES TAGGED WITH THEIR */ /* SUBMATRIX ASSOCIATIONS .......... */ L900: s = r; r = r + m2 - m1 + 1; j = 1; k = m1; i_1 = r; for (l = 1; l <= i_1; ++l) { if (j > s) { goto L910; } if (k > m2) { goto L940; } if (rv5[k] >= w[l]) { goto L915; } i_2 = s; for (ii = j; ii <= i_2; ++ii) { i = l + s - ii; w[i + 1] = w[i]; ind[i + 1] = ind[i]; /* L905: */ } L910: w[l] = rv5[k]; ind[l] = tag; ++k; goto L920; L915: ++j; L920: ; } L940: if (q < *n) { goto L100; } goto L1001; /* .......... SET ERROR -- INTERVAL CANNOT BE FOUND CONTAINING */ /* EXACTLY THE DESIRED EIGENVALUES .......... */ L980: *ierr = *n * 3 + isturm; L1001: *lb = t1; *ub = t2; return 0; } /* tridib_ */ /* Subroutine */ int tsturm_(integer *nm, integer *n, doublereal *eps1, doublereal *d, doublereal *e, doublereal *e2, doublereal *lb, doublereal *ub, integer *mm, integer *m, doublereal *w, doublereal *z, integer *ierr, doublereal *rv1, doublereal *rv2, doublereal *rv3, doublereal *rv4, doublereal *rv5, doublereal *rv6) { /* System generated locals */ integer z_dim1, z_offset, i_1, i_2, i_3; doublereal d_1, d_2, d_3, d_4; /* Builtin functions */ double sqrt(doublereal); /* Local variables */ static doublereal norm; static integer i, j, k, p, q, r, s; static doublereal u, v; static integer group, m1, m2; static doublereal t1, t2, x0, x1; static integer ii, jj, ip; static doublereal uk, xu; extern doublereal pythag_(doublereal *, doublereal *), epslon_(doublereal *); static integer isturm, its; static doublereal eps2, eps3, eps4, tst1, tst2; /* THIS SUBROUTINE IS A TRANSLATION OF THE ALGOL PROCEDURE TRISTURM */ /* BY PETERS AND WILKINSON. */ /* HANDBOOK FOR AUTO. COMP., VOL.II-LINEAR ALGEBRA, 418-439(1971). */ /* THIS SUBROUTINE FINDS THOSE EIGENVALUES OF A TRIDIAGONAL */ /* SYMMETRIC MATRIX WHICH LIE IN A SPECIFIED INTERVAL AND THEIR */ /* ASSOCIATED EIGENVECTORS, USING BISECTION AND INVERSE ITERATION. */ /* ON INPUT */ /* NM MUST BE SET TO THE ROW DIMENSION OF TWO-DIMENSIONAL */ /* ARRAY PARAMETERS AS DECLARED IN THE CALLING PROGRAM */ /* DIMENSION STATEMENT. */ /* N IS THE ORDER OF THE MATRIX. */ /* EPS1 IS AN ABSOLUTE ERROR TOLERANCE FOR THE COMPUTED */ /* EIGENVALUES. IT SHOULD BE CHOSEN COMMENSURATE WITH */ /* RELATIVE PERTURBATIONS IN THE MATRIX ELEMENTS OF THE */ /* ORDER OF THE RELATIVE MACHINE PRECISION. IF THE */ /* INPUT EPS1 IS NON-POSITIVE, IT IS RESET FOR EACH */ /* SUBMATRIX TO A DEFAULT VALUE, NAMELY, MINUS THE */ /* PRODUCT OF THE RELATIVE MACHINE PRECISION AND THE */ /* 1-NORM OF THE SUBMATRIX. */ /* D CONTAINS THE DIAGONAL ELEMENTS OF THE INPUT MATRIX. */ /* E CONTAINS THE SUBDIAGONAL ELEMENTS OF THE INPUT MATRIX */ /* IN ITS LAST N-1 POSITIONS. E(1) IS ARBITRARY. */ /* E2 CONTAINS THE SQUARES OF THE CORRESPONDING ELEMENTS OF E. */ /* E2(1) IS ARBITRARY. */ /* LB AND UB DEFINE THE INTERVAL TO BE SEARCHED FOR EIGENVALUES. */ /* IF LB IS NOT LESS THAN UB, NO EIGENVALUES WILL BE FOUND. */ /* MM SHOULD BE SET TO AN UPPER BOUND FOR THE NUMBER OF */ /* EIGENVALUES IN THE INTERVAL. WARNING. IF MORE THAN */ /* MM EIGENVALUES ARE DETERMINED TO LIE IN THE INTERVAL, */ /* AN ERROR RETURN IS MADE WITH NO VALUES OR VECTORS FOUND. */ /* ON OUTPUT */ /* EPS1 IS UNALTERED UNLESS IT HAS BEEN RESET TO ITS */ /* (LAST) DEFAULT VALUE. */ /* 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. */ /* M IS THE NUMBER OF EIGENVALUES DETERMINED TO LIE IN (LB,UB). */ /* W CONTAINS THE M EIGENVALUES IN ASCENDING ORDER IF THE MATRIX */ /* DOES NOT SPLIT. IF THE MATRIX SPLITS, THE EIGENVALUES ARE */ /* IN ASCENDING ORDER FOR EACH SUBMATRIX. IF A VECTOR ERROR */ /* EXIT IS MADE, W CONTAINS THOSE VALUES ALREADY FOUND. */ /* Z CONTAINS THE ASSOCIATED SET OF ORTHONORMAL EIGENVECTORS. */ /* IF AN ERROR EXIT IS MADE, Z CONTAINS THOSE VECTORS */ /* ALREADY FOUND. */ /* IERR IS SET TO */ /* ZERO FOR NORMAL RETURN, */ /* 3*N+1 IF M EXCEEDS MM. */ /* 4*N+R IF THE EIGENVECTOR CORRESPONDING TO THE R-TH */ /* EIGENVALUE FAILS TO CONVERGE IN 5 ITERATIONS. */ /* RV1, RV2, RV3, RV4, RV5, AND RV6 ARE TEMPORARY STORAGE ARRAYS. */ /* THE ALGOL PROCEDURE STURMCNT CONTAINED IN TRISTURM */ /* APPEARS IN TSTURM IN-LINE. */ /* 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 */ --rv6; --rv5; --rv4; --rv3; --rv2; --rv1; --e2; --e; --d; z_dim1 = *nm; z_offset = z_dim1 + 1; z -= z_offset; --w; /* Function Body */ *ierr = 0; t1 = *lb; t2 = *ub; /* .......... LOOK FOR SMALL SUB-DIAGONAL ENTRIES .......... */ i_1 = *n; for (i = 1; i <= i_1; ++i) { if (i == 1) { goto L20; } tst1 = (d_1 = d[i], abs(d_1)) + (d_2 = d[i - 1], abs(d_2)); tst2 = tst1 + (d_1 = e[i], abs(d_1)); if (tst2 > tst1) { goto L40; } L20: e2[i] = 0.; L40: ; } /* .......... DETERMINE THE NUMBER OF EIGENVALUES */ /* IN THE INTERVAL .......... */ p = 1; q = *n; x1 = *ub; isturm = 1; goto L320; L60: *m = s; x1 = *lb; isturm = 2; goto L320; L80: *m -= s; if (*m > *mm) { goto L980; } q = 0; r = 0; /* .......... ESTABLISH AND PROCESS NEXT SUBMATRIX, REFINING */ /* INTERVAL BY THE GERSCHGORIN BOUNDS .......... */ L100: if (r == *m) { goto L1001; } p = q + 1; xu = d[p]; x0 = d[p]; u = 0.; i_1 = *n; for (q = p; q <= i_1; ++q) { x1 = u; u = 0.; v = 0.; if (q == *n) { goto L110; } u = (d_1 = e[q + 1], abs(d_1)); v = e2[q + 1]; L110: /* Computing MIN */ d_1 = d[q] - (x1 + u); xu = min(d_1,xu); /* Computing MAX */ d_1 = d[q] + (x1 + u); x0 = max(d_1,x0); if (v == 0.) { goto L140; } /* L120: */ } L140: /* Computing MAX */ d_2 = abs(xu), d_3 = abs(x0); d_1 = max(d_2,d_3); x1 = epslon_(&d_1); if (*eps1 <= 0.) { *eps1 = -x1; } if (p != q) { goto L180; } /* .......... CHECK FOR ISOLATED ROOT WITHIN INTERVAL .......... */ if (t1 > d[p] || d[p] >= t2) { goto L940; } ++r; i_1 = *n; for (i = 1; i <= i_1; ++i) { /* L160: */ z[i + r * z_dim1] = 0.; } w[r] = d[p]; z[p + r * z_dim1] = 1.; goto L940; L180: u = (doublereal) (q - p + 1); x1 = u * x1; /* Computing MAX */ d_1 = t1, d_2 = xu - x1; *lb = max(d_1,d_2); /* Computing MIN */ d_1 = t2, d_2 = x0 + x1; *ub = min(d_1,d_2); x1 = *lb; isturm = 3; goto L320; L200: m1 = s + 1; x1 = *ub; isturm = 4; goto L320; L220: m2 = s; if (m1 > m2) { goto L940; } /* .......... FIND ROOTS BY BISECTION .......... */ x0 = *ub; isturm = 5; i_1 = m2; for (i = m1; i <= i_1; ++i) { rv5[i] = *ub; rv4[i] = *lb; /* L240: */ } /* .......... LOOP FOR K-TH EIGENVALUE */ /* FOR K=M2 STEP -1 UNTIL M1 DO -- */ /* (-DO- NOT USED TO LEGALIZE -COMPUTED GO TO-) .......... */ k = m2; L250: xu = *lb; /* .......... FOR I=K STEP -1 UNTIL M1 DO -- .......... */ i_1 = k; for (ii = m1; ii <= i_1; ++ii) { i = m1 + k - ii; if (xu >= rv4[i]) { goto L260; } xu = rv4[i]; goto L280; L260: ; } L280: if (x0 > rv5[k]) { x0 = rv5[k]; } /* .......... NEXT BISECTION STEP .......... */ L300: x1 = (xu + x0) * .5; if (x0 - xu <= abs(*eps1)) { goto L420; } tst1 = (abs(xu) + abs(x0)) * 2.; tst2 = tst1 + (x0 - xu); if (tst2 == tst1) { goto L420; } /* .......... IN-LINE PROCEDURE FOR STURM SEQUENCE .......... */ L320: s = p - 1; u = 1.; i_1 = q; for (i = p; i <= i_1; ++i) { if (u != 0.) { goto L325; } v = (d_1 = e[i], abs(d_1)) / epslon_(&c_b141); if (e2[i] == 0.) { v = 0.; } goto L330; L325: v = e2[i] / u; L330: u = d[i] - x1 - v; if (u < 0.) { ++s; } /* L340: */ } switch (isturm) { case 1: goto L60; case 2: goto L80; case 3: goto L200; case 4: goto L220; case 5: goto L360; } /* .......... REFINE INTERVALS .......... */ L360: if (s >= k) { goto L400; } xu = x1; if (s >= m1) { goto L380; } rv4[m1] = x1; goto L300; L380: rv4[s + 1] = x1; if (rv5[s] > x1) { rv5[s] = x1; } goto L300; L400: x0 = x1; goto L300; /* .......... K-TH EIGENVALUE FOUND .......... */ L420: rv5[k] = x1; --k; if (k >= m1) { goto L250; } /* .......... FIND VECTORS BY INVERSE ITERATION .......... */ norm = (d_1 = d[p], abs(d_1)); ip = p + 1; i_1 = q; for (i = ip; i <= i_1; ++i) { /* L500: */ /* Computing MAX */ d_3 = norm, d_4 = (d_1 = d[i], abs(d_1)) + (d_2 = e[i], abs(d_2) ); norm = max(d_3,d_4); } /* .......... EPS2 IS THE CRITERION FOR GROUPING, */ /* EPS3 REPLACES ZERO PIVOTS AND EQUAL */ /* ROOTS ARE MODIFIED BY EPS3, */ /* EPS4 IS TAKEN VERY SMALL TO AVOID OVERFLOW .......... */ eps2 = norm * .001; eps3 = epslon_(&norm); uk = (doublereal) (q - p + 1); eps4 = uk * eps3; uk = eps4 / sqrt(uk); group = 0; s = p; i_1 = m2; for (k = m1; k <= i_1; ++k) { ++r; its = 1; w[r] = rv5[k]; x1 = rv5[k]; /* .......... LOOK FOR CLOSE OR COINCIDENT ROOTS .......... */ if (k == m1) { goto L520; } if (x1 - x0 >= eps2) { group = -1; } ++group; if (x1 <= x0) { x1 = x0 + eps3; } /* .......... ELIMINATION WITH INTERCHANGES AND */ /* INITIALIZATION OF VECTOR .......... */ L520: v = 0.; i_2 = q; for (i = p; i <= i_2; ++i) { rv6[i] = uk; if (i == p) { goto L560; } if ((d_1 = e[i], abs(d_1)) < abs(u)) { goto L540; } xu = u / e[i]; rv4[i] = xu; rv1[i - 1] = e[i]; rv2[i - 1] = d[i] - x1; rv3[i - 1] = 0.; if (i != q) { rv3[i - 1] = e[i + 1]; } u = v - xu * rv2[i - 1]; v = -xu * rv3[i - 1]; goto L580; L540: xu = e[i] / u; rv4[i] = xu; rv1[i - 1] = u; rv2[i - 1] = v; rv3[i - 1] = 0.; L560: u = d[i] - x1 - xu * v; if (i != q) { v = e[i + 1]; } L580: ; } if (u == 0.) { u = eps3; } rv1[q] = u; rv2[q] = 0.; rv3[q] = 0.; /* .......... BACK SUBSTITUTION */ /* FOR I=Q STEP -1 UNTIL P DO -- .......... */ L600: i_2 = q; for (ii = p; ii <= i_2; ++ii) { i = p + q - ii; rv6[i] = (rv6[i] - u * rv2[i] - v * rv3[i]) / rv1[i]; v = u; u = rv6[i]; /* L620: */ } /* .......... ORTHOGONALIZE WITH RESPECT TO PREVIOUS */ /* MEMBERS OF GROUP .......... */ if (group == 0) { goto L700; } i_2 = group; for (jj = 1; jj <= i_2; ++jj) { j = r - group - 1 + jj; xu = 0.; i_3 = q; for (i = p; i <= i_3; ++i) { /* L640: */ xu += rv6[i] * z[i + j * z_dim1]; } i_3 = q; for (i = p; i <= i_3; ++i) { /* L660: */ rv6[i] -= xu * z[i + j * z_dim1]; } /* L680: */ } L700: norm = 0.; i_2 = q; for (i = p; i <= i_2; ++i) { /* L720: */ norm += (d_1 = rv6[i], abs(d_1)); } if (norm >= 1.) { goto L840; } /* .......... FORWARD SUBSTITUTION .......... */ if (its == 5) { goto L960; } if (norm != 0.) { goto L740; } rv6[s] = eps4; ++s; if (s > q) { s = p; } goto L780; L740: xu = eps4 / norm; i_2 = q; for (i = p; i <= i_2; ++i) { /* L760: */ rv6[i] *= xu; } /* .......... ELIMINATION OPERATIONS ON NEXT VECTOR */ /* ITERATE .......... */ L780: i_2 = q; for (i = ip; i <= i_2; ++i) { u = rv6[i]; /* .......... IF RV1(I-1) .EQ. E(I), A ROW INTERCHANGE */ /* WAS PERFORMED EARLIER IN THE */ /* TRIANGULARIZATION PROCESS .......... */ if (rv1[i - 1] != e[i]) { goto L800; } u = rv6[i - 1]; rv6[i - 1] = rv6[i]; L800: rv6[i] = u - rv4[i] * rv6[i - 1]; /* L820: */ } ++its; goto L600; /* .......... NORMALIZE SO THAT SUM OF SQUARES IS */ /* 1 AND EXPAND TO FULL ORDER .......... */ L840: u = 0.; i_2 = q; for (i = p; i <= i_2; ++i) { /* L860: */ u = pythag_(&u, &rv6[i]); } xu = 1. / u; i_2 = *n; for (i = 1; i <= i_2; ++i) { /* L880: */ z[i + r * z_dim1] = 0.; } i_2 = q; for (i = p; i <= i_2; ++i) { /* L900: */ z[i + r * z_dim1] = rv6[i] * xu; } x0 = x1; /* L920: */ } L940: if (q < *n) { goto L100; } goto L1001; /* .......... SET ERROR -- NON-CONVERGED EIGENVECTOR .......... */ L960: *ierr = (*n << 2) + r; goto L1001; /* .......... SET ERROR -- UNDERESTIMATE OF NUMBER OF */ /* EIGENVALUES IN INTERVAL .......... */ L980: *ierr = *n * 3 + 1; L1001: *lb = t1; *ub = t2; return 0; } /* tsturm_ */ #ifdef __cplusplus } #endif