Doxygen Source Code Documentation
eispack.h File Reference
#include "f2c.h"Go to the source code of this file.
Function Documentation
|
||||||||||||||||||||||||||||||||
|
Definition at line 8 of file eis_bakvec.c.
00010 {
00011 /* System generated locals */
00012 integer t_dim1, t_offset, z_dim1, z_offset, i__1, i__2;
00013
00014 /* Local variables */
00015 static integer i__, j;
00016
00017
00018
00019 /* THIS SUBROUTINE FORMS THE EIGENVECTORS OF A NONSYMMETRIC */
00020 /* TRIDIAGONAL MATRIX BY BACK TRANSFORMING THOSE OF THE */
00021 /* CORRESPONDING SYMMETRIC MATRIX DETERMINED BY FIGI. */
00022
00023 /* ON INPUT */
00024
00025 /* NM MUST BE SET TO THE ROW DIMENSION OF TWO-DIMENSIONAL */
00026 /* ARRAY PARAMETERS AS DECLARED IN THE CALLING PROGRAM */
00027 /* DIMENSION STATEMENT. */
00028
00029 /* N IS THE ORDER OF THE MATRIX. */
00030
00031 /* T CONTAINS THE NONSYMMETRIC MATRIX. ITS SUBDIAGONAL IS */
00032 /* STORED IN THE LAST N-1 POSITIONS OF THE FIRST COLUMN, */
00033 /* ITS DIAGONAL IN THE N POSITIONS OF THE SECOND COLUMN, */
00034 /* AND ITS SUPERDIAGONAL IN THE FIRST N-1 POSITIONS OF */
00035 /* THE THIRD COLUMN. T(1,1) AND T(N,3) ARE ARBITRARY. */
00036
00037 /* E CONTAINS THE SUBDIAGONAL ELEMENTS OF THE SYMMETRIC */
00038 /* MATRIX IN ITS LAST N-1 POSITIONS. E(1) IS ARBITRARY. */
00039
00040 /* M IS THE NUMBER OF EIGENVECTORS TO BE BACK TRANSFORMED. */
00041
00042 /* Z CONTAINS THE EIGENVECTORS TO BE BACK TRANSFORMED */
00043 /* IN ITS FIRST M COLUMNS. */
00044
00045 /* ON OUTPUT */
00046
00047 /* T IS UNALTERED. */
00048
00049 /* E IS DESTROYED. */
00050
00051 /* Z CONTAINS THE TRANSFORMED EIGENVECTORS */
00052 /* IN ITS FIRST M COLUMNS. */
00053
00054 /* IERR IS SET TO */
00055 /* ZERO FOR NORMAL RETURN, */
00056 /* 2*N+I IF E(I) IS ZERO WITH T(I,1) OR T(I-1,3) NON-ZERO.
00057 */
00058 /* IN THIS CASE, THE SYMMETRIC MATRIX IS NOT SIMILAR
00059 */
00060 /* TO THE ORIGINAL MATRIX, AND THE EIGENVECTORS */
00061 /* CANNOT BE FOUND BY THIS PROGRAM. */
00062
00063 /* QUESTIONS AND COMMENTS SHOULD BE DIRECTED TO BURTON S. GARBOW, */
00064 /* MATHEMATICS AND COMPUTER SCIENCE DIV, ARGONNE NATIONAL LABORATORY
00065 */
00066
00067 /* THIS VERSION DATED AUGUST 1983. */
00068
00069 /* ------------------------------------------------------------------
00070 */
00071
00072 /* Parameter adjustments */
00073 t_dim1 = *nm;
00074 t_offset = t_dim1 + 1;
00075 t -= t_offset;
00076 --e;
00077 z_dim1 = *nm;
00078 z_offset = z_dim1 + 1;
00079 z__ -= z_offset;
00080
00081 /* Function Body */
00082 *ierr = 0;
00083 if (*m == 0) {
00084 goto L1001;
00085 }
00086 e[1] = 1.;
00087 if (*n == 1) {
00088 goto L1001;
00089 }
00090
00091 i__1 = *n;
00092 for (i__ = 2; i__ <= i__1; ++i__) {
00093 if (e[i__] != 0.) {
00094 goto L80;
00095 }
00096 if (t[i__ + t_dim1] != 0. || t[i__ - 1 + t_dim1 * 3] != 0.) {
00097 goto L1000;
00098 }
00099 e[i__] = 1.;
00100 goto L100;
00101 L80:
00102 e[i__] = e[i__ - 1] * e[i__] / t[i__ - 1 + t_dim1 * 3];
00103 L100:
00104 ;
00105 }
00106
00107 i__1 = *m;
00108 for (j = 1; j <= i__1; ++j) {
00109
00110 i__2 = *n;
00111 for (i__ = 2; i__ <= i__2; ++i__) {
00112 z__[i__ + j * z_dim1] *= e[i__];
00113 /* L120: */
00114 }
00115 }
00116
00117 goto L1001;
00118 /* .......... SET ERROR -- EIGENVECTORS CANNOT BE */
00119 /* FOUND BY THIS PROGRAM .......... */
00120 L1000:
00121 *ierr = (*n << 1) + i__;
00122 L1001:
00123 return 0;
00124 } /* bakvec_ */
|
|
||||||||||||||||||||||||||||
|
Definition at line 8 of file eis_balanc.c. References a, abs, l, and scale. Referenced by rg_().
00010 {
00011 /* System generated locals */
00012 integer a_dim1, a_offset, i__1, i__2;
00013 doublereal d__1;
00014
00015 /* Local variables */
00016 static integer iexc;
00017 static doublereal c__, f, g;
00018 static integer i__, j, k, l, m;
00019 static doublereal r__, s, radix, b2;
00020 static integer jj;
00021 static logical noconv;
00022
00023
00024
00025 /* THIS SUBROUTINE IS A TRANSLATION OF THE ALGOL PROCEDURE BALANCE, */
00026 /* NUM. MATH. 13, 293-304(1969) BY PARLETT AND REINSCH. */
00027 /* HANDBOOK FOR AUTO. COMP., VOL.II-LINEAR ALGEBRA, 315-326(1971). */
00028
00029 /* THIS SUBROUTINE BALANCES A REAL MATRIX AND ISOLATES */
00030 /* EIGENVALUES WHENEVER POSSIBLE. */
00031
00032 /* ON INPUT */
00033
00034 /* NM MUST BE SET TO THE ROW DIMENSION OF TWO-DIMENSIONAL */
00035 /* ARRAY PARAMETERS AS DECLARED IN THE CALLING PROGRAM */
00036 /* DIMENSION STATEMENT. */
00037
00038 /* N IS THE ORDER OF THE MATRIX. */
00039
00040 /* A CONTAINS THE INPUT MATRIX TO BE BALANCED. */
00041
00042 /* ON OUTPUT */
00043
00044 /* A CONTAINS THE BALANCED MATRIX. */
00045
00046 /* LOW AND IGH ARE TWO INTEGERS SUCH THAT A(I,J) */
00047 /* IS EQUAL TO ZERO IF */
00048 /* (1) I IS GREATER THAN J AND */
00049 /* (2) J=1,...,LOW-1 OR I=IGH+1,...,N. */
00050
00051 /* SCALE CONTAINS INFORMATION DETERMINING THE */
00052 /* PERMUTATIONS AND SCALING FACTORS USED. */
00053
00054 /* SUPPOSE THAT THE PRINCIPAL SUBMATRIX IN ROWS LOW THROUGH IGH */
00055 /* HAS BEEN BALANCED, THAT P(J) DENOTES THE INDEX INTERCHANGED */
00056 /* WITH J DURING THE PERMUTATION STEP, AND THAT THE ELEMENTS */
00057 /* OF THE DIAGONAL MATRIX USED ARE DENOTED BY D(I,J). THEN */
00058 /* SCALE(J) = P(J), FOR J = 1,...,LOW-1 */
00059 /* = D(J,J), J = LOW,...,IGH */
00060 /* = P(J) J = IGH+1,...,N. */
00061 /* THE ORDER IN WHICH THE INTERCHANGES ARE MADE IS N TO IGH+1, */
00062 /* THEN 1 TO LOW-1. */
00063
00064 /* NOTE THAT 1 IS RETURNED FOR IGH IF IGH IS ZERO FORMALLY. */
00065
00066 /* THE ALGOL PROCEDURE EXC CONTAINED IN BALANCE APPEARS IN */
00067 /* BALANC IN LINE. (NOTE THAT THE ALGOL ROLES OF IDENTIFIERS */
00068 /* K,L HAVE BEEN REVERSED.) */
00069
00070 /* QUESTIONS AND COMMENTS SHOULD BE DIRECTED TO BURTON S. GARBOW, */
00071 /* MATHEMATICS AND COMPUTER SCIENCE DIV, ARGONNE NATIONAL LABORATORY
00072 */
00073
00074 /* THIS VERSION DATED AUGUST 1983. */
00075
00076 /* ------------------------------------------------------------------
00077 */
00078
00079 /* Parameter adjustments */
00080 --scale;
00081 a_dim1 = *nm;
00082 a_offset = a_dim1 + 1;
00083 a -= a_offset;
00084
00085 /* Function Body */
00086 radix = 16.;
00087
00088 b2 = radix * radix;
00089 k = 1;
00090 l = *n;
00091 goto L100;
00092 /* .......... IN-LINE PROCEDURE FOR ROW AND */
00093 /* COLUMN EXCHANGE .......... */
00094 L20:
00095 scale[m] = (doublereal) j;
00096 if (j == m) {
00097 goto L50;
00098 }
00099
00100 i__1 = l;
00101 for (i__ = 1; i__ <= i__1; ++i__) {
00102 f = a[i__ + j * a_dim1];
00103 a[i__ + j * a_dim1] = a[i__ + m * a_dim1];
00104 a[i__ + m * a_dim1] = f;
00105 /* L30: */
00106 }
00107
00108 i__1 = *n;
00109 for (i__ = k; i__ <= i__1; ++i__) {
00110 f = a[j + i__ * a_dim1];
00111 a[j + i__ * a_dim1] = a[m + i__ * a_dim1];
00112 a[m + i__ * a_dim1] = f;
00113 /* L40: */
00114 }
00115
00116 L50:
00117 switch (iexc) {
00118 case 1: goto L80;
00119 case 2: goto L130;
00120 }
00121 /* .......... SEARCH FOR ROWS ISOLATING AN EIGENVALUE */
00122 /* AND PUSH THEM DOWN .......... */
00123 L80:
00124 if (l == 1) {
00125 goto L280;
00126 }
00127 --l;
00128 /* .......... FOR J=L STEP -1 UNTIL 1 DO -- .......... */
00129 L100:
00130 i__1 = l;
00131 for (jj = 1; jj <= i__1; ++jj) {
00132 j = l + 1 - jj;
00133
00134 i__2 = l;
00135 for (i__ = 1; i__ <= i__2; ++i__) {
00136 if (i__ == j) {
00137 goto L110;
00138 }
00139 if (a[j + i__ * a_dim1] != 0.) {
00140 goto L120;
00141 }
00142 L110:
00143 ;
00144 }
00145
00146 m = l;
00147 iexc = 1;
00148 goto L20;
00149 L120:
00150 ;
00151 }
00152
00153 goto L140;
00154 /* .......... SEARCH FOR COLUMNS ISOLATING AN EIGENVALUE */
00155 /* AND PUSH THEM LEFT .......... */
00156 L130:
00157 ++k;
00158
00159 L140:
00160 i__1 = l;
00161 for (j = k; j <= i__1; ++j) {
00162
00163 i__2 = l;
00164 for (i__ = k; i__ <= i__2; ++i__) {
00165 if (i__ == j) {
00166 goto L150;
00167 }
00168 if (a[i__ + j * a_dim1] != 0.) {
00169 goto L170;
00170 }
00171 L150:
00172 ;
00173 }
00174
00175 m = k;
00176 iexc = 2;
00177 goto L20;
00178 L170:
00179 ;
00180 }
00181 /* .......... NOW BALANCE THE SUBMATRIX IN ROWS K TO L .......... */
00182 i__1 = l;
00183 for (i__ = k; i__ <= i__1; ++i__) {
00184 /* L180: */
00185 scale[i__] = 1.;
00186 }
00187 /* .......... ITERATIVE LOOP FOR NORM REDUCTION .......... */
00188 L190:
00189 noconv = FALSE_;
00190
00191 i__1 = l;
00192 for (i__ = k; i__ <= i__1; ++i__) {
00193 c__ = 0.;
00194 r__ = 0.;
00195
00196 i__2 = l;
00197 for (j = k; j <= i__2; ++j) {
00198 if (j == i__) {
00199 goto L200;
00200 }
00201 c__ += (d__1 = a[j + i__ * a_dim1], abs(d__1));
00202 r__ += (d__1 = a[i__ + j * a_dim1], abs(d__1));
00203 L200:
00204 ;
00205 }
00206 /* .......... GUARD AGAINST ZERO C OR R DUE TO UNDERFLOW .........
00207 . */
00208 if (c__ == 0. || r__ == 0.) {
00209 goto L270;
00210 }
00211 g = r__ / radix;
00212 f = 1.;
00213 s = c__ + r__;
00214 L210:
00215 if (c__ >= g) {
00216 goto L220;
00217 }
00218 f *= radix;
00219 c__ *= b2;
00220 goto L210;
00221 L220:
00222 g = r__ * radix;
00223 L230:
00224 if (c__ < g) {
00225 goto L240;
00226 }
00227 f /= radix;
00228 c__ /= b2;
00229 goto L230;
00230 /* .......... NOW BALANCE .......... */
00231 L240:
00232 if ((c__ + r__) / f >= s * .95) {
00233 goto L270;
00234 }
00235 g = 1. / f;
00236 scale[i__] *= f;
00237 noconv = TRUE_;
00238
00239 i__2 = *n;
00240 for (j = k; j <= i__2; ++j) {
00241 /* L250: */
00242 a[i__ + j * a_dim1] *= g;
00243 }
00244
00245 i__2 = l;
00246 for (j = 1; j <= i__2; ++j) {
00247 /* L260: */
00248 a[j + i__ * a_dim1] *= f;
00249 }
00250
00251 L270:
00252 ;
00253 }
00254
00255 if (noconv) {
00256 goto L190;
00257 }
00258
00259 L280:
00260 *low = k;
00261 *igh = l;
00262 return 0;
00263 } /* balanc_ */
|
|
||||||||||||||||||||||||||||||||
|
Definition at line 8 of file eis_balbak.c. References scale. Referenced by rg_().
00010 {
00011 /* System generated locals */
00012 integer z_dim1, z_offset, i__1, i__2;
00013
00014 /* Local variables */
00015 static integer i__, j, k;
00016 static doublereal s;
00017 static integer ii;
00018
00019
00020
00021 /* THIS SUBROUTINE IS A TRANSLATION OF THE ALGOL PROCEDURE BALBAK, */
00022 /* NUM. MATH. 13, 293-304(1969) BY PARLETT AND REINSCH. */
00023 /* HANDBOOK FOR AUTO. COMP., VOL.II-LINEAR ALGEBRA, 315-326(1971). */
00024
00025 /* THIS SUBROUTINE FORMS THE EIGENVECTORS OF A REAL GENERAL */
00026 /* MATRIX BY BACK TRANSFORMING THOSE OF THE CORRESPONDING */
00027 /* BALANCED MATRIX DETERMINED BY BALANC. */
00028
00029 /* ON INPUT */
00030
00031 /* NM MUST BE SET TO THE ROW DIMENSION OF TWO-DIMENSIONAL */
00032 /* ARRAY PARAMETERS AS DECLARED IN THE CALLING PROGRAM */
00033 /* DIMENSION STATEMENT. */
00034
00035 /* N IS THE ORDER OF THE MATRIX. */
00036
00037 /* LOW AND IGH ARE INTEGERS DETERMINED BY BALANC. */
00038
00039 /* SCALE CONTAINS INFORMATION DETERMINING THE PERMUTATIONS */
00040 /* AND SCALING FACTORS USED BY BALANC. */
00041
00042 /* M IS THE NUMBER OF COLUMNS OF Z TO BE BACK TRANSFORMED. */
00043
00044 /* Z CONTAINS THE REAL AND IMAGINARY PARTS OF THE EIGEN- */
00045 /* VECTORS TO BE BACK TRANSFORMED IN ITS FIRST M COLUMNS. */
00046
00047 /* ON OUTPUT */
00048
00049 /* Z CONTAINS THE REAL AND IMAGINARY PARTS OF THE */
00050 /* TRANSFORMED EIGENVECTORS IN ITS FIRST M COLUMNS. */
00051
00052 /* QUESTIONS AND COMMENTS SHOULD BE DIRECTED TO BURTON S. GARBOW, */
00053 /* MATHEMATICS AND COMPUTER SCIENCE DIV, ARGONNE NATIONAL LABORATORY
00054 */
00055
00056 /* THIS VERSION DATED AUGUST 1983. */
00057
00058 /* ------------------------------------------------------------------
00059 */
00060
00061 /* Parameter adjustments */
00062 --scale;
00063 z_dim1 = *nm;
00064 z_offset = z_dim1 + 1;
00065 z__ -= z_offset;
00066
00067 /* Function Body */
00068 if (*m == 0) {
00069 goto L200;
00070 }
00071 if (*igh == *low) {
00072 goto L120;
00073 }
00074
00075 i__1 = *igh;
00076 for (i__ = *low; i__ <= i__1; ++i__) {
00077 s = scale[i__];
00078 /* .......... LEFT HAND EIGENVECTORS ARE BACK TRANSFORMED */
00079 /* IF THE FOREGOING STATEMENT IS REPLACED BY */
00080 /* S=1.0D0/SCALE(I). .......... */
00081 i__2 = *m;
00082 for (j = 1; j <= i__2; ++j) {
00083 /* L100: */
00084 z__[i__ + j * z_dim1] *= s;
00085 }
00086
00087 /* L110: */
00088 }
00089 /* ......... FOR I=LOW-1 STEP -1 UNTIL 1, */
00090 /* IGH+1 STEP 1 UNTIL N DO -- .......... */
00091 L120:
00092 i__1 = *n;
00093 for (ii = 1; ii <= i__1; ++ii) {
00094 i__ = ii;
00095 if (i__ >= *low && i__ <= *igh) {
00096 goto L140;
00097 }
00098 if (i__ < *low) {
00099 i__ = *low - ii;
00100 }
00101 k = (integer) scale[i__];
00102 if (k == i__) {
00103 goto L140;
00104 }
00105
00106 i__2 = *m;
00107 for (j = 1; j <= i__2; ++j) {
00108 s = z__[i__ + j * z_dim1];
00109 z__[i__ + j * z_dim1] = z__[k + j * z_dim1];
00110 z__[k + j * z_dim1] = s;
00111 /* L130: */
00112 }
00113
00114 L140:
00115 ;
00116 }
00117
00118 L200:
00119 return 0;
00120 } /* balbak_ */
|
|
||||||||||||||||||||||||||||||||||||||||
|
Definition at line 8 of file eis_bandr.c. References a, i1, i2, l, m1, max, min, n2, and s2. Referenced by rsb_().
00011 {
00012 /* System generated locals */
00013 integer a_dim1, a_offset, z_dim1, z_offset, i__1, i__2, i__3, i__4, i__5,
00014 i__6;
00015 doublereal d__1;
00016
00017 /* Builtin functions */
00018 double sqrt(doublereal);
00019
00020 /* Local variables */
00021 static doublereal dmin__;
00022 static integer maxl, maxr;
00023 static doublereal g;
00024 static integer j, k, l, r__;
00025 static doublereal u, b1, b2, c2, f1, f2;
00026 static integer i1, i2, j1, j2, m1, n2, r1;
00027 static doublereal s2;
00028 static integer kr, mr;
00029 static doublereal dminrt;
00030 static integer ugl;
00031
00032
00033
00034 /* THIS SUBROUTINE IS A TRANSLATION OF THE ALGOL PROCEDURE BANDRD, */
00035 /* NUM. MATH. 12, 231-241(1968) BY SCHWARZ. */
00036 /* HANDBOOK FOR AUTO. COMP., VOL.II-LINEAR ALGEBRA, 273-283(1971). */
00037
00038 /* THIS SUBROUTINE REDUCES A REAL SYMMETRIC BAND MATRIX */
00039 /* TO A SYMMETRIC TRIDIAGONAL MATRIX USING AND OPTIONALLY */
00040 /* ACCUMULATING ORTHOGONAL SIMILARITY TRANSFORMATIONS. */
00041
00042 /* ON INPUT */
00043
00044 /* NM MUST BE SET TO THE ROW DIMENSION OF TWO-DIMENSIONAL */
00045 /* ARRAY PARAMETERS AS DECLARED IN THE CALLING PROGRAM */
00046 /* DIMENSION STATEMENT. */
00047
00048 /* N IS THE ORDER OF THE MATRIX. */
00049
00050 /* MB IS THE (HALF) BAND WIDTH OF THE MATRIX, DEFINED AS THE */
00051 /* NUMBER OF ADJACENT DIAGONALS, INCLUDING THE PRINCIPAL */
00052 /* DIAGONAL, REQUIRED TO SPECIFY THE NON-ZERO PORTION OF THE */
00053 /* LOWER TRIANGLE OF THE MATRIX. */
00054
00055 /* A CONTAINS THE LOWER TRIANGLE OF THE SYMMETRIC BAND INPUT */
00056 /* MATRIX STORED AS AN N BY MB ARRAY. ITS LOWEST SUBDIAGONAL */
00057 /* IS STORED IN THE LAST N+1-MB POSITIONS OF THE FIRST COLUMN, */
00058 /* ITS NEXT SUBDIAGONAL IN THE LAST N+2-MB POSITIONS OF THE */
00059 /* SECOND COLUMN, FURTHER SUBDIAGONALS SIMILARLY, AND FINALLY */
00060 /* ITS PRINCIPAL DIAGONAL IN THE N POSITIONS OF THE LAST COLUMN.
00061 */
00062 /* CONTENTS OF STORAGES NOT PART OF THE MATRIX ARE ARBITRARY. */
00063
00064 /* MATZ SHOULD BE SET TO .TRUE. IF THE TRANSFORMATION MATRIX IS */
00065 /* TO BE ACCUMULATED, AND TO .FALSE. OTHERWISE. */
00066
00067 /* ON OUTPUT */
00068
00069 /* A HAS BEEN DESTROYED, EXCEPT FOR ITS LAST TWO COLUMNS WHICH */
00070 /* CONTAIN A COPY OF THE TRIDIAGONAL MATRIX. */
00071
00072 /* D CONTAINS THE DIAGONAL ELEMENTS OF THE TRIDIAGONAL MATRIX. */
00073
00074 /* E CONTAINS THE SUBDIAGONAL ELEMENTS OF THE TRIDIAGONAL */
00075 /* MATRIX IN ITS LAST N-1 POSITIONS. E(1) IS SET TO ZERO. */
00076
00077 /* E2 CONTAINS THE SQUARES OF THE CORRESPONDING ELEMENTS OF E. */
00078 /* E2 MAY COINCIDE WITH E IF THE SQUARES ARE NOT NEEDED. */
00079
00080 /* Z CONTAINS THE ORTHOGONAL TRANSFORMATION MATRIX PRODUCED IN */
00081 /* THE REDUCTION IF MATZ HAS BEEN SET TO .TRUE. OTHERWISE, Z */
00082 /* IS NOT REFERENCED. */
00083
00084 /* QUESTIONS AND COMMENTS SHOULD BE DIRECTED TO BURTON S. GARBOW, */
00085 /* MATHEMATICS AND COMPUTER SCIENCE DIV, ARGONNE NATIONAL LABORATORY
00086 */
00087
00088 /* THIS VERSION DATED AUGUST 1983. */
00089
00090 /* ------------------------------------------------------------------
00091 */
00092
00093 /* Parameter adjustments */
00094 z_dim1 = *nm;
00095 z_offset = z_dim1 + 1;
00096 z__ -= z_offset;
00097 --e2;
00098 --e;
00099 --d__;
00100 a_dim1 = *nm;
00101 a_offset = a_dim1 + 1;
00102 a -= a_offset;
00103
00104 /* Function Body */
00105 dmin__ = 5.4210108624275222e-20;
00106 dminrt = 2.3283064365386963e-10;
00107 /* .......... INITIALIZE DIAGONAL SCALING MATRIX .......... */
00108 i__1 = *n;
00109 for (j = 1; j <= i__1; ++j) {
00110 /* L30: */
00111 d__[j] = 1.;
00112 }
00113
00114 if (! (*matz)) {
00115 goto L60;
00116 }
00117
00118 i__1 = *n;
00119 for (j = 1; j <= i__1; ++j) {
00120
00121 i__2 = *n;
00122 for (k = 1; k <= i__2; ++k) {
00123 /* L40: */
00124 z__[j + k * z_dim1] = 0.;
00125 }
00126
00127 z__[j + j * z_dim1] = 1.;
00128 /* L50: */
00129 }
00130
00131 L60:
00132 m1 = *mb - 1;
00133 if ((i__1 = m1 - 1) < 0) {
00134 goto L900;
00135 } else if (i__1 == 0) {
00136 goto L800;
00137 } else {
00138 goto L70;
00139 }
00140 L70:
00141 n2 = *n - 2;
00142
00143 i__1 = n2;
00144 for (k = 1; k <= i__1; ++k) {
00145 /* Computing MIN */
00146 i__2 = m1, i__3 = *n - k;
00147 maxr = min(i__2,i__3);
00148 /* .......... FOR R=MAXR STEP -1 UNTIL 2 DO -- .......... */
00149 i__2 = maxr;
00150 for (r1 = 2; r1 <= i__2; ++r1) {
00151 r__ = maxr + 2 - r1;
00152 kr = k + r__;
00153 mr = *mb - r__;
00154 g = a[kr + mr * a_dim1];
00155 a[kr - 1 + a_dim1] = a[kr - 1 + (mr + 1) * a_dim1];
00156 ugl = k;
00157
00158 i__3 = *n;
00159 i__4 = m1;
00160 for (j = kr; i__4 < 0 ? j >= i__3 : j <= i__3; j += i__4) {
00161 j1 = j - 1;
00162 j2 = j1 - 1;
00163 if (g == 0.) {
00164 goto L600;
00165 }
00166 b1 = a[j1 + a_dim1] / g;
00167 b2 = b1 * d__[j1] / d__[j];
00168 s2 = 1. / (b1 * b2 + 1.);
00169 if (s2 >= .5) {
00170 goto L450;
00171 }
00172 b1 = g / a[j1 + a_dim1];
00173 b2 = b1 * d__[j] / d__[j1];
00174 c2 = 1. - s2;
00175 d__[j1] = c2 * d__[j1];
00176 d__[j] = c2 * d__[j];
00177 f1 = a[j + m1 * a_dim1] * 2.;
00178 f2 = b1 * a[j1 + *mb * a_dim1];
00179 a[j + m1 * a_dim1] = -b2 * (b1 * a[j + m1 * a_dim1] - a[j + *
00180 mb * a_dim1]) - f2 + a[j + m1 * a_dim1];
00181 a[j1 + *mb * a_dim1] = b2 * (b2 * a[j + *mb * a_dim1] + f1) +
00182 a[j1 + *mb * a_dim1];
00183 a[j + *mb * a_dim1] = b1 * (f2 - f1) + a[j + *mb * a_dim1];
00184
00185 i__5 = j2;
00186 for (l = ugl; l <= i__5; ++l) {
00187 i2 = *mb - j + l;
00188 u = a[j1 + (i2 + 1) * a_dim1] + b2 * a[j + i2 * a_dim1];
00189 a[j + i2 * a_dim1] = -b1 * a[j1 + (i2 + 1) * a_dim1] + a[
00190 j + i2 * a_dim1];
00191 a[j1 + (i2 + 1) * a_dim1] = u;
00192 /* L200: */
00193 }
00194
00195 ugl = j;
00196 a[j1 + a_dim1] += b2 * g;
00197 if (j == *n) {
00198 goto L350;
00199 }
00200 /* Computing MIN */
00201 i__5 = m1, i__6 = *n - j1;
00202 maxl = min(i__5,i__6);
00203
00204 i__5 = maxl;
00205 for (l = 2; l <= i__5; ++l) {
00206 i1 = j1 + l;
00207 i2 = *mb - l;
00208 u = a[i1 + i2 * a_dim1] + b2 * a[i1 + (i2 + 1) * a_dim1];
00209 a[i1 + (i2 + 1) * a_dim1] = -b1 * a[i1 + i2 * a_dim1] + a[
00210 i1 + (i2 + 1) * a_dim1];
00211 a[i1 + i2 * a_dim1] = u;
00212 /* L300: */
00213 }
00214
00215 i1 = j + m1;
00216 if (i1 > *n) {
00217 goto L350;
00218 }
00219 g = b2 * a[i1 + a_dim1];
00220 L350:
00221 if (! (*matz)) {
00222 goto L500;
00223 }
00224
00225 i__5 = *n;
00226 for (l = 1; l <= i__5; ++l) {
00227 u = z__[l + j1 * z_dim1] + b2 * z__[l + j * z_dim1];
00228 z__[l + j * z_dim1] = -b1 * z__[l + j1 * z_dim1] + z__[l
00229 + j * z_dim1];
00230 z__[l + j1 * z_dim1] = u;
00231 /* L400: */
00232 }
00233
00234 goto L500;
00235
00236 L450:
00237 u = d__[j1];
00238 d__[j1] = s2 * d__[j];
00239 d__[j] = s2 * u;
00240 f1 = a[j + m1 * a_dim1] * 2.;
00241 f2 = b1 * a[j + *mb * a_dim1];
00242 u = b1 * (f2 - f1) + a[j1 + *mb * a_dim1];
00243 a[j + m1 * a_dim1] = b2 * (b1 * a[j + m1 * a_dim1] - a[j1 + *
00244 mb * a_dim1]) + f2 - a[j + m1 * a_dim1];
00245 a[j1 + *mb * a_dim1] = b2 * (b2 * a[j1 + *mb * a_dim1] + f1)
00246 + a[j + *mb * a_dim1];
00247 a[j + *mb * a_dim1] = u;
00248
00249 i__5 = j2;
00250 for (l = ugl; l <= i__5; ++l) {
00251 i2 = *mb - j + l;
00252 u = b2 * a[j1 + (i2 + 1) * a_dim1] + a[j + i2 * a_dim1];
00253 a[j + i2 * a_dim1] = -a[j1 + (i2 + 1) * a_dim1] + b1 * a[
00254 j + i2 * a_dim1];
00255 a[j1 + (i2 + 1) * a_dim1] = u;
00256 /* L460: */
00257 }
00258
00259 ugl = j;
00260 a[j1 + a_dim1] = b2 * a[j1 + a_dim1] + g;
00261 if (j == *n) {
00262 goto L480;
00263 }
00264 /* Computing MIN */
00265 i__5 = m1, i__6 = *n - j1;
00266 maxl = min(i__5,i__6);
00267
00268 i__5 = maxl;
00269 for (l = 2; l <= i__5; ++l) {
00270 i1 = j1 + l;
00271 i2 = *mb - l;
00272 u = b2 * a[i1 + i2 * a_dim1] + a[i1 + (i2 + 1) * a_dim1];
00273 a[i1 + (i2 + 1) * a_dim1] = -a[i1 + i2 * a_dim1] + b1 * a[
00274 i1 + (i2 + 1) * a_dim1];
00275 a[i1 + i2 * a_dim1] = u;
00276 /* L470: */
00277 }
00278
00279 i1 = j + m1;
00280 if (i1 > *n) {
00281 goto L480;
00282 }
00283 g = a[i1 + a_dim1];
00284 a[i1 + a_dim1] = b1 * a[i1 + a_dim1];
00285 L480:
00286 if (! (*matz)) {
00287 goto L500;
00288 }
00289
00290 i__5 = *n;
00291 for (l = 1; l <= i__5; ++l) {
00292 u = b2 * z__[l + j1 * z_dim1] + z__[l + j * z_dim1];
00293 z__[l + j * z_dim1] = -z__[l + j1 * z_dim1] + b1 * z__[l
00294 + j * z_dim1];
00295 z__[l + j1 * z_dim1] = u;
00296 /* L490: */
00297 }
00298
00299 L500:
00300 ;
00301 }
00302
00303 L600:
00304 ;
00305 }
00306
00307 if (k % 64 != 0) {
00308 goto L700;
00309 }
00310 /* .......... RESCALE TO AVOID UNDERFLOW OR OVERFLOW .......... */
00311 i__2 = *n;
00312 for (j = k; j <= i__2; ++j) {
00313 if (d__[j] >= dmin__) {
00314 goto L650;
00315 }
00316 /* Computing MAX */
00317 i__4 = 1, i__3 = *mb + 1 - j;
00318 maxl = max(i__4,i__3);
00319
00320 i__4 = m1;
00321 for (l = maxl; l <= i__4; ++l) {
00322 /* L610: */
00323 a[j + l * a_dim1] = dminrt * a[j + l * a_dim1];
00324 }
00325
00326 if (j == *n) {
00327 goto L630;
00328 }
00329 /* Computing MIN */
00330 i__4 = m1, i__3 = *n - j;
00331 maxl = min(i__4,i__3);
00332
00333 i__4 = maxl;
00334 for (l = 1; l <= i__4; ++l) {
00335 i1 = j + l;
00336 i2 = *mb - l;
00337 a[i1 + i2 * a_dim1] = dminrt * a[i1 + i2 * a_dim1];
00338 /* L620: */
00339 }
00340
00341 L630:
00342 if (! (*matz)) {
00343 goto L645;
00344 }
00345
00346 i__4 = *n;
00347 for (l = 1; l <= i__4; ++l) {
00348 /* L640: */
00349 z__[l + j * z_dim1] = dminrt * z__[l + j * z_dim1];
00350 }
00351
00352 L645:
00353 a[j + *mb * a_dim1] = dmin__ * a[j + *mb * a_dim1];
00354 d__[j] /= dmin__;
00355 L650:
00356 ;
00357 }
00358
00359 L700:
00360 ;
00361 }
00362 /* .......... FORM SQUARE ROOT OF SCALING MATRIX .......... */
00363 L800:
00364 i__1 = *n;
00365 for (j = 2; j <= i__1; ++j) {
00366 /* L810: */
00367 e[j] = sqrt(d__[j]);
00368 }
00369
00370 if (! (*matz)) {
00371 goto L840;
00372 }
00373
00374 i__1 = *n;
00375 for (j = 1; j <= i__1; ++j) {
00376
00377 i__2 = *n;
00378 for (k = 2; k <= i__2; ++k) {
00379 /* L820: */
00380 z__[j + k * z_dim1] = e[k] * z__[j + k * z_dim1];
00381 }
00382
00383 /* L830: */
00384 }
00385
00386 L840:
00387 u = 1.;
00388
00389 i__1 = *n;
00390 for (j = 2; j <= i__1; ++j) {
00391 a[j + m1 * a_dim1] = u * e[j] * a[j + m1 * a_dim1];
00392 u = e[j];
00393 /* Computing 2nd power */
00394 d__1 = a[j + m1 * a_dim1];
00395 e2[j] = d__1 * d__1;
00396 a[j + *mb * a_dim1] = d__[j] * a[j + *mb * a_dim1];
00397 d__[j] = a[j + *mb * a_dim1];
00398 e[j] = a[j + m1 * a_dim1];
00399 /* L850: */
00400 }
00401
00402 d__[1] = a[*mb * a_dim1 + 1];
00403 e[1] = 0.;
00404 e2[1] = 0.;
00405 goto L1001;
00406
00407 L900:
00408 i__1 = *n;
00409 for (j = 1; j <= i__1; ++j) {
00410 d__[j] = a[j + *mb * a_dim1];
00411 e[j] = 0.;
00412 e2[j] = 0.;
00413 /* L950: */
00414 }
00415
00416 L1001:
00417 return 0;
00418 } /* bandr_ */
|
|
||||||||||||||||||||||||||||||||||||||||||||||||||||
|
Definition at line 8 of file eis_bandv.c. References a, abs, d_sign(), epslon_(), m1, max, min, pythag_(), v, and x0.
00011 {
00012 /* System generated locals */
00013 integer a_dim1, a_offset, z_dim1, z_offset, i__1, i__2, i__3, i__4, i__5;
00014 doublereal d__1;
00015
00016 /* Builtin functions */
00017 double sqrt(doublereal), d_sign(doublereal *, doublereal *);
00018
00019 /* Local variables */
00020 static integer maxj, maxk;
00021 static doublereal norm;
00022 static integer i__, j, k, r__;
00023 static doublereal u, v, order;
00024 static integer group, m1;
00025 static doublereal x0, x1;
00026 static integer mb, m21, ii, ij, jj, kj;
00027 static doublereal uk, xu;
00028 extern doublereal pythag_(doublereal *, doublereal *), epslon_(doublereal
00029 *);
00030 static integer ij1, kj1, its;
00031 static doublereal eps2, eps3, eps4;
00032
00033
00034
00035 /* THIS SUBROUTINE FINDS THOSE EIGENVECTORS OF A REAL SYMMETRIC */
00036 /* BAND MATRIX CORRESPONDING TO SPECIFIED EIGENVALUES, USING INVERSE
00037 */
00038 /* ITERATION. THE SUBROUTINE MAY ALSO BE USED TO SOLVE SYSTEMS */
00039 /* OF LINEAR EQUATIONS WITH A SYMMETRIC OR NON-SYMMETRIC BAND */
00040 /* COEFFICIENT MATRIX. */
00041
00042 /* ON INPUT */
00043
00044 /* NM MUST BE SET TO THE ROW DIMENSION OF TWO-DIMENSIONAL */
00045 /* ARRAY PARAMETERS AS DECLARED IN THE CALLING PROGRAM */
00046 /* DIMENSION STATEMENT. */
00047
00048 /* N IS THE ORDER OF THE MATRIX. */
00049
00050 /* MBW IS THE NUMBER OF COLUMNS OF THE ARRAY A USED TO STORE THE */
00051 /* BAND MATRIX. IF THE MATRIX IS SYMMETRIC, MBW IS ITS (HALF) */
00052 /* BAND WIDTH, DENOTED MB AND DEFINED AS THE NUMBER OF ADJACENT
00053 */
00054 /* DIAGONALS, INCLUDING THE PRINCIPAL DIAGONAL, REQUIRED TO */
00055 /* SPECIFY THE NON-ZERO PORTION OF THE LOWER TRIANGLE OF THE */
00056 /* MATRIX. IF THE SUBROUTINE IS BEING USED TO SOLVE SYSTEMS */
00057 /* OF LINEAR EQUATIONS AND THE COEFFICIENT MATRIX IS NOT */
00058 /* SYMMETRIC, IT MUST HOWEVER HAVE THE SAME NUMBER OF ADJACENT */
00059 /* DIAGONALS ABOVE THE MAIN DIAGONAL AS BELOW, AND IN THIS */
00060 /* CASE, MBW=2*MB-1. */
00061
00062 /* A CONTAINS THE LOWER TRIANGLE OF THE SYMMETRIC BAND INPUT */
00063 /* MATRIX STORED AS AN N BY MB ARRAY. ITS LOWEST SUBDIAGONAL */
00064 /* IS STORED IN THE LAST N+1-MB POSITIONS OF THE FIRST COLUMN, */
00065 /* ITS NEXT SUBDIAGONAL IN THE LAST N+2-MB POSITIONS OF THE */
00066 /* SECOND COLUMN, FURTHER SUBDIAGONALS SIMILARLY, AND FINALLY */
00067 /* ITS PRINCIPAL DIAGONAL IN THE N POSITIONS OF COLUMN MB. */
00068 /* IF THE SUBROUTINE IS BEING USED TO SOLVE SYSTEMS OF LINEAR */
00069 /* EQUATIONS AND THE COEFFICIENT MATRIX IS NOT SYMMETRIC, A IS */
00070 /* N BY 2*MB-1 INSTEAD WITH LOWER TRIANGLE AS ABOVE AND WITH */
00071 /* ITS FIRST SUPERDIAGONAL STORED IN THE FIRST N-1 POSITIONS OF
00072 */
00073 /* COLUMN MB+1, ITS SECOND SUPERDIAGONAL IN THE FIRST N-2 */
00074 /* POSITIONS OF COLUMN MB+2, FURTHER SUPERDIAGONALS SIMILARLY, */
00075 /* AND FINALLY ITS HIGHEST SUPERDIAGONAL IN THE FIRST N+1-MB */
00076 /* POSITIONS OF THE LAST COLUMN. */
00077 /* CONTENTS OF STORAGES NOT PART OF THE MATRIX ARE ARBITRARY. */
00078
00079 /* E21 SPECIFIES THE ORDERING OF THE EIGENVALUES AND CONTAINS */
00080 /* 0.0D0 IF THE EIGENVALUES ARE IN ASCENDING ORDER, OR */
00081 /* 2.0D0 IF THE EIGENVALUES ARE IN DESCENDING ORDER. */
00082 /* IF THE SUBROUTINE IS BEING USED TO SOLVE SYSTEMS OF LINEAR */
00083 /* EQUATIONS, E21 SHOULD BE SET TO 1.0D0 IF THE COEFFICIENT */
00084 /* MATRIX IS SYMMETRIC AND TO -1.0D0 IF NOT. */
00085
00086 /* M IS THE NUMBER OF SPECIFIED EIGENVALUES OR THE NUMBER OF */
00087 /* SYSTEMS OF LINEAR EQUATIONS. */
00088
00089 /* W CONTAINS THE M EIGENVALUES IN ASCENDING OR DESCENDING ORDER.
00090 */
00091 /* IF THE SUBROUTINE IS BEING USED TO SOLVE SYSTEMS OF LINEAR */
00092 /* EQUATIONS (A-W(R)*I)*X(R)=B(R), WHERE I IS THE IDENTITY */
00093 /* MATRIX, W(R) SHOULD BE SET ACCORDINGLY, FOR R=1,2,...,M. */
00094
00095 /* Z CONTAINS THE CONSTANT MATRIX COLUMNS (B(R),R=1,2,...,M), IF */
00096 /* THE SUBROUTINE IS USED TO SOLVE SYSTEMS OF LINEAR EQUATIONS.
00097 */
00098
00099 /* NV MUST BE SET TO THE DIMENSION OF THE ARRAY PARAMETER RV */
00100 /* AS DECLARED IN THE CALLING PROGRAM DIMENSION STATEMENT. */
00101
00102 /* ON OUTPUT */
00103
00104 /* A AND W ARE UNALTERED. */
00105
00106 /* Z CONTAINS THE ASSOCIATED SET OF ORTHOGONAL EIGENVECTORS. */
00107 /* ANY VECTOR WHICH FAILS TO CONVERGE IS SET TO ZERO. IF THE */
00108 /* SUBROUTINE IS USED TO SOLVE SYSTEMS OF LINEAR EQUATIONS, */
00109 /* Z CONTAINS THE SOLUTION MATRIX COLUMNS (X(R),R=1,2,...,M). */
00110
00111 /* IERR IS SET TO */
00112 /* ZERO FOR NORMAL RETURN, */
00113 /* -R IF THE EIGENVECTOR CORRESPONDING TO THE R-TH */
00114 /* EIGENVALUE FAILS TO CONVERGE, OR IF THE R-TH */
00115 /* SYSTEM OF LINEAR EQUATIONS IS NEARLY SINGULAR. */
00116
00117 /* RV AND RV6 ARE TEMPORARY STORAGE ARRAYS. NOTE THAT RV IS */
00118 /* OF DIMENSION AT LEAST N*(2*MB-1). IF THE SUBROUTINE */
00119 /* IS BEING USED TO SOLVE SYSTEMS OF LINEAR EQUATIONS, THE */
00120 /* DETERMINANT (UP TO SIGN) OF A-W(M)*I IS AVAILABLE, UPON */
00121 /* RETURN, AS THE PRODUCT OF THE FIRST N ELEMENTS OF RV. */
00122
00123 /* CALLS PYTHAG FOR DSQRT(A*A + B*B) . */
00124
00125 /* QUESTIONS AND COMMENTS SHOULD BE DIRECTED TO BURTON S. GARBOW, */
00126 /* MATHEMATICS AND COMPUTER SCIENCE DIV, ARGONNE NATIONAL LABORATORY
00127 */
00128
00129 /* THIS VERSION DATED AUGUST 1983. */
00130
00131 /* ------------------------------------------------------------------
00132 */
00133
00134 /* Parameter adjustments */
00135 --rv6;
00136 a_dim1 = *nm;
00137 a_offset = a_dim1 + 1;
00138 a -= a_offset;
00139 z_dim1 = *nm;
00140 z_offset = z_dim1 + 1;
00141 z__ -= z_offset;
00142 --w;
00143 --rv;
00144
00145 /* Function Body */
00146 *ierr = 0;
00147 if (*m == 0) {
00148 goto L1001;
00149 }
00150 mb = *mbw;
00151 if (*e21 < 0.) {
00152 mb = (*mbw + 1) / 2;
00153 }
00154 m1 = mb - 1;
00155 m21 = m1 + mb;
00156 order = 1. - abs(*e21);
00157 /* .......... FIND VECTORS BY INVERSE ITERATION .......... */
00158 i__1 = *m;
00159 for (r__ = 1; r__ <= i__1; ++r__) {
00160 its = 1;
00161 x1 = w[r__];
00162 if (r__ != 1) {
00163 goto L100;
00164 }
00165 /* .......... COMPUTE NORM OF MATRIX .......... */
00166 norm = 0.;
00167
00168 i__2 = mb;
00169 for (j = 1; j <= i__2; ++j) {
00170 jj = mb + 1 - j;
00171 kj = jj + m1;
00172 ij = 1;
00173 v = 0.;
00174
00175 i__3 = *n;
00176 for (i__ = jj; i__ <= i__3; ++i__) {
00177 v += (d__1 = a[i__ + j * a_dim1], abs(d__1));
00178 if (*e21 >= 0.) {
00179 goto L40;
00180 }
00181 v += (d__1 = a[ij + kj * a_dim1], abs(d__1));
00182 ++ij;
00183 L40:
00184 ;
00185 }
00186
00187 norm = max(norm,v);
00188 /* L60: */
00189 }
00190
00191 if (*e21 < 0.) {
00192 norm *= .5;
00193 }
00194 /* .......... EPS2 IS THE CRITERION FOR GROUPING, */
00195 /* EPS3 REPLACES ZERO PIVOTS AND EQUAL */
00196 /* ROOTS ARE MODIFIED BY EPS3, */
00197 /* EPS4 IS TAKEN VERY SMALL TO AVOID OVERFLOW .........
00198 . */
00199 if (norm == 0.) {
00200 norm = 1.;
00201 }
00202 eps2 = norm * .001 * abs(order);
00203 eps3 = epslon_(&norm);
00204 uk = (doublereal) (*n);
00205 uk = sqrt(uk);
00206 eps4 = uk * eps3;
00207 L80:
00208 group = 0;
00209 goto L120;
00210 /* .......... LOOK FOR CLOSE OR COINCIDENT ROOTS .......... */
00211 L100:
00212 if ((d__1 = x1 - x0, abs(d__1)) >= eps2) {
00213 goto L80;
00214 }
00215 ++group;
00216 if (order * (x1 - x0) <= 0.) {
00217 x1 = x0 + order * eps3;
00218 }
00219 /* .......... EXPAND MATRIX, SUBTRACT EIGENVALUE, */
00220 /* AND INITIALIZE VECTOR .......... */
00221 L120:
00222 i__2 = *n;
00223 for (i__ = 1; i__ <= i__2; ++i__) {
00224 /* Computing MIN */
00225 i__3 = 0, i__4 = i__ - m1;
00226 ij = i__ + min(i__3,i__4) * *n;
00227 kj = ij + mb * *n;
00228 ij1 = kj + m1 * *n;
00229 if (m1 == 0) {
00230 goto L180;
00231 }
00232
00233 i__3 = m1;
00234 for (j = 1; j <= i__3; ++j) {
00235 if (ij > m1) {
00236 goto L125;
00237 }
00238 if (ij > 0) {
00239 goto L130;
00240 }
00241 rv[ij1] = 0.;
00242 ij1 += *n;
00243 goto L130;
00244 L125:
00245 rv[ij] = a[i__ + j * a_dim1];
00246 L130:
00247 ij += *n;
00248 ii = i__ + j;
00249 if (ii > *n) {
00250 goto L150;
00251 }
00252 jj = mb - j;
00253 if (*e21 >= 0.) {
00254 goto L140;
00255 }
00256 ii = i__;
00257 jj = mb + j;
00258 L140:
00259 rv[kj] = a[ii + jj * a_dim1];
00260 kj += *n;
00261 L150:
00262 ;
00263 }
00264
00265 L180:
00266 rv[ij] = a[i__ + mb * a_dim1] - x1;
00267 rv6[i__] = eps4;
00268 if (order == 0.) {
00269 rv6[i__] = z__[i__ + r__ * z_dim1];
00270 }
00271 /* L200: */
00272 }
00273
00274 if (m1 == 0) {
00275 goto L600;
00276 }
00277 /* .......... ELIMINATION WITH INTERCHANGES .......... */
00278 i__2 = *n;
00279 for (i__ = 1; i__ <= i__2; ++i__) {
00280 ii = i__ + 1;
00281 /* Computing MIN */
00282 i__3 = i__ + m1 - 1;
00283 maxk = min(i__3,*n);
00284 /* Computing MIN */
00285 i__3 = *n - i__, i__4 = m21 - 2;
00286 maxj = min(i__3,i__4) * *n;
00287
00288 i__3 = maxk;
00289 for (k = i__; k <= i__3; ++k) {
00290 kj1 = k;
00291 j = kj1 + *n;
00292 jj = j + maxj;
00293
00294 i__4 = jj;
00295 i__5 = *n;
00296 for (kj = j; i__5 < 0 ? kj >= i__4 : kj <= i__4; kj += i__5) {
00297 rv[kj1] = rv[kj];
00298 kj1 = kj;
00299 /* L340: */
00300 }
00301
00302 rv[kj1] = 0.;
00303 /* L360: */
00304 }
00305
00306 if (i__ == *n) {
00307 goto L580;
00308 }
00309 u = 0.;
00310 /* Computing MIN */
00311 i__3 = i__ + m1;
00312 maxk = min(i__3,*n);
00313 /* Computing MIN */
00314 i__3 = *n - ii, i__5 = m21 - 2;
00315 maxj = min(i__3,i__5) * *n;
00316
00317 i__3 = maxk;
00318 for (j = i__; j <= i__3; ++j) {
00319 if ((d__1 = rv[j], abs(d__1)) < abs(u)) {
00320 goto L450;
00321 }
00322 u = rv[j];
00323 k = j;
00324 L450:
00325 ;
00326 }
00327
00328 j = i__ + *n;
00329 jj = j + maxj;
00330 if (k == i__) {
00331 goto L520;
00332 }
00333 kj = k;
00334
00335 i__3 = jj;
00336 i__5 = *n;
00337 for (ij = i__; i__5 < 0 ? ij >= i__3 : ij <= i__3; ij += i__5) {
00338 v = rv[ij];
00339 rv[ij] = rv[kj];
00340 rv[kj] = v;
00341 kj += *n;
00342 /* L500: */
00343 }
00344
00345 if (order != 0.) {
00346 goto L520;
00347 }
00348 v = rv6[i__];
00349 rv6[i__] = rv6[k];
00350 rv6[k] = v;
00351 L520:
00352 if (u == 0.) {
00353 goto L580;
00354 }
00355
00356 i__5 = maxk;
00357 for (k = ii; k <= i__5; ++k) {
00358 v = rv[k] / u;
00359 kj = k;
00360
00361 i__3 = jj;
00362 i__4 = *n;
00363 for (ij = j; i__4 < 0 ? ij >= i__3 : ij <= i__3; ij += i__4) {
00364 kj += *n;
00365 rv[kj] -= v * rv[ij];
00366 /* L540: */
00367 }
00368
00369 if (order == 0.) {
00370 rv6[k] -= v * rv6[i__];
00371 }
00372 /* L560: */
00373 }
00374
00375 L580:
00376 ;
00377 }
00378 /* .......... BACK SUBSTITUTION */
00379 /* FOR I=N STEP -1 UNTIL 1 DO -- .......... */
00380 L600:
00381 i__2 = *n;
00382 for (ii = 1; ii <= i__2; ++ii) {
00383 i__ = *n + 1 - ii;
00384 maxj = min(ii,m21);
00385 if (maxj == 1) {
00386 goto L620;
00387 }
00388 ij1 = i__;
00389 j = ij1 + *n;
00390 jj = j + (maxj - 2) * *n;
00391
00392 i__5 = jj;
00393 i__4 = *n;
00394 for (ij = j; i__4 < 0 ? ij >= i__5 : ij <= i__5; ij += i__4) {
00395 ++ij1;
00396 rv6[i__] -= rv[ij] * rv6[ij1];
00397 /* L610: */
00398 }
00399
00400 L620:
00401 v = rv[i__];
00402 if (abs(v) >= eps3) {
00403 goto L625;
00404 }
00405 /* .......... SET ERROR -- NEARLY SINGULAR LINEAR SYSTEM .....
00406 ..... */
00407 if (order == 0.) {
00408 *ierr = -r__;
00409 }
00410 v = d_sign(&eps3, &v);
00411 L625:
00412 rv6[i__] /= v;
00413 /* L630: */
00414 }
00415
00416 xu = 1.;
00417 if (order == 0.) {
00418 goto L870;
00419 }
00420 /* .......... ORTHOGONALIZE WITH RESPECT TO PREVIOUS */
00421 /* MEMBERS OF GROUP .......... */
00422 if (group == 0) {
00423 goto L700;
00424 }
00425
00426 i__2 = group;
00427 for (jj = 1; jj <= i__2; ++jj) {
00428 j = r__ - group - 1 + jj;
00429 xu = 0.;
00430
00431 i__4 = *n;
00432 for (i__ = 1; i__ <= i__4; ++i__) {
00433 /* L640: */
00434 xu += rv6[i__] * z__[i__ + j * z_dim1];
00435 }
00436
00437 i__4 = *n;
00438 for (i__ = 1; i__ <= i__4; ++i__) {
00439 /* L660: */
00440 rv6[i__] -= xu * z__[i__ + j * z_dim1];
00441 }
00442
00443 /* L680: */
00444 }
00445
00446 L700:
00447 norm = 0.;
00448
00449 i__2 = *n;
00450 for (i__ = 1; i__ <= i__2; ++i__) {
00451 /* L720: */
00452 norm += (d__1 = rv6[i__], abs(d__1));
00453 }
00454
00455 if (norm >= .1) {
00456 goto L840;
00457 }
00458 /* .......... IN-LINE PROCEDURE FOR CHOOSING */
00459 /* A NEW STARTING VECTOR .......... */
00460 if (its >= *n) {
00461 goto L830;
00462 }
00463 ++its;
00464 xu = eps4 / (uk + 1.);
00465 rv6[1] = eps4;
00466
00467 i__2 = *n;
00468 for (i__ = 2; i__ <= i__2; ++i__) {
00469 /* L760: */
00470 rv6[i__] = xu;
00471 }
00472
00473 rv6[its] -= eps4 * uk;
00474 goto L600;
00475 /* .......... SET ERROR -- NON-CONVERGED EIGENVECTOR .......... */
00476 L830:
00477 *ierr = -r__;
00478 xu = 0.;
00479 goto L870;
00480 /* .......... NORMALIZE SO THAT SUM OF SQUARES IS */
00481 /* 1 AND EXPAND TO FULL ORDER .......... */
00482 L840:
00483 u = 0.;
00484
00485 i__2 = *n;
00486 for (i__ = 1; i__ <= i__2; ++i__) {
00487 /* L860: */
00488 u = pythag_(&u, &rv6[i__]);
00489 }
00490
00491 xu = 1. / u;
00492
00493 L870:
00494 i__2 = *n;
00495 for (i__ = 1; i__ <= i__2; ++i__) {
00496 /* L900: */
00497 z__[i__ + r__ * z_dim1] = rv6[i__] * xu;
00498 }
00499
00500 x0 = x1;
00501 /* L920: */
00502 }
00503
00504 L1001:
00505 return 0;
00506 } /* bandv_ */
|
|
||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||
|
Definition at line 12 of file eis_bisect.c. References abs, c_b26, epslon_(), ind, l, m1, m2, max, min, p, q, v, and x0.
00016 {
00017 /* System generated locals */
00018 integer i__1, i__2;
00019 doublereal d__1, d__2, d__3;
00020
00021 /* Local variables */
00022 static integer i__, j, k, l, p, q, r__, s;
00023 static doublereal u, v;
00024 static integer m1, m2;
00025 static doublereal t1, t2, x0, x1;
00026 static integer ii;
00027 static doublereal xu;
00028 extern doublereal epslon_(doublereal *);
00029 static integer isturm, tag;
00030 static doublereal tst1, tst2;
00031
00032
00033
00034 /* THIS SUBROUTINE IS A TRANSLATION OF THE BISECTION TECHNIQUE */
00035 /* IN THE ALGOL PROCEDURE TRISTURM BY PETERS AND WILKINSON. */
00036 /* HANDBOOK FOR AUTO. COMP., VOL.II-LINEAR ALGEBRA, 418-439(1971). */
00037
00038 /* THIS SUBROUTINE FINDS THOSE EIGENVALUES OF A TRIDIAGONAL */
00039 /* SYMMETRIC MATRIX WHICH LIE IN A SPECIFIED INTERVAL, */
00040 /* USING BISECTION. */
00041
00042 /* ON INPUT */
00043
00044 /* N IS THE ORDER OF THE MATRIX. */
00045
00046 /* EPS1 IS AN ABSOLUTE ERROR TOLERANCE FOR THE COMPUTED */
00047 /* EIGENVALUES. IF THE INPUT EPS1 IS NON-POSITIVE, */
00048 /* IT IS RESET FOR EACH SUBMATRIX TO A DEFAULT VALUE, */
00049 /* NAMELY, MINUS THE PRODUCT OF THE RELATIVE MACHINE */
00050 /* PRECISION AND THE 1-NORM OF THE SUBMATRIX. */
00051
00052 /* D CONTAINS THE DIAGONAL ELEMENTS OF THE INPUT MATRIX. */
00053
00054 /* E CONTAINS THE SUBDIAGONAL ELEMENTS OF THE INPUT MATRIX */
00055 /* IN ITS LAST N-1 POSITIONS. E(1) IS ARBITRARY. */
00056
00057 /* E2 CONTAINS THE SQUARES OF THE CORRESPONDING ELEMENTS OF E. */
00058 /* E2(1) IS ARBITRARY. */
00059
00060 /* LB AND UB DEFINE THE INTERVAL TO BE SEARCHED FOR EIGENVALUES. */
00061 /* IF LB IS NOT LESS THAN UB, NO EIGENVALUES WILL BE FOUND. */
00062
00063 /* MM SHOULD BE SET TO AN UPPER BOUND FOR THE NUMBER OF */
00064 /* EIGENVALUES IN THE INTERVAL. WARNING. IF MORE THAN */
00065 /* MM EIGENVALUES ARE DETERMINED TO LIE IN THE INTERVAL, */
00066 /* AN ERROR RETURN IS MADE WITH NO EIGENVALUES FOUND. */
00067
00068 /* ON OUTPUT */
00069
00070 /* EPS1 IS UNALTERED UNLESS IT HAS BEEN RESET TO ITS */
00071 /* (LAST) DEFAULT VALUE. */
00072
00073 /* D AND E ARE UNALTERED. */
00074
00075 /* ELEMENTS OF E2, CORRESPONDING TO ELEMENTS OF E REGARDED */
00076 /* AS NEGLIGIBLE, HAVE BEEN REPLACED BY ZERO CAUSING THE */
00077 /* MATRIX TO SPLIT INTO A DIRECT SUM OF SUBMATRICES. */
00078 /* E2(1) IS ALSO SET TO ZERO. */
00079
00080 /* M IS THE NUMBER OF EIGENVALUES DETERMINED TO LIE IN (LB,UB). */
00081
00082 /* W CONTAINS THE M EIGENVALUES IN ASCENDING ORDER. */
00083
00084 /* IND CONTAINS IN ITS FIRST M POSITIONS THE SUBMATRIX INDICES */
00085 /* ASSOCIATED WITH THE CORRESPONDING EIGENVALUES IN W -- */
00086 /* 1 FOR EIGENVALUES BELONGING TO THE FIRST SUBMATRIX FROM */
00087 /* THE TOP, 2 FOR THOSE BELONGING TO THE SECOND SUBMATRIX, ETC..
00088 */
00089
00090 /* IERR IS SET TO */
00091 /* ZERO FOR NORMAL RETURN, */
00092 /* 3*N+1 IF M EXCEEDS MM. */
00093
00094 /* RV4 AND RV5 ARE TEMPORARY STORAGE ARRAYS. */
00095
00096 /* THE ALGOL PROCEDURE STURMCNT CONTAINED IN TRISTURM */
00097 /* APPEARS IN BISECT IN-LINE. */
00098
00099 /* NOTE THAT SUBROUTINE TQL1 OR IMTQL1 IS GENERALLY FASTER THAN */
00100 /* BISECT, IF MORE THAN N/4 EIGENVALUES ARE TO BE FOUND. */
00101
00102 /* QUESTIONS AND COMMENTS SHOULD BE DIRECTED TO BURTON S. GARBOW, */
00103 /* MATHEMATICS AND COMPUTER SCIENCE DIV, ARGONNE NATIONAL LABORATORY
00104 */
00105
00106 /* THIS VERSION DATED AUGUST 1983. */
00107
00108 /* ------------------------------------------------------------------
00109 */
00110
00111 /* Parameter adjustments */
00112 --rv5;
00113 --rv4;
00114 --e2;
00115 --e;
00116 --d__;
00117 --ind;
00118 --w;
00119
00120 /* Function Body */
00121 *ierr = 0;
00122 tag = 0;
00123 t1 = *lb;
00124 t2 = *ub;
00125 /* .......... LOOK FOR SMALL SUB-DIAGONAL ENTRIES .......... */
00126 i__1 = *n;
00127 for (i__ = 1; i__ <= i__1; ++i__) {
00128 if (i__ == 1) {
00129 goto L20;
00130 }
00131 tst1 = (d__1 = d__[i__], abs(d__1)) + (d__2 = d__[i__ - 1], abs(d__2))
00132 ;
00133 tst2 = tst1 + (d__1 = e[i__], abs(d__1));
00134 if (tst2 > tst1) {
00135 goto L40;
00136 }
00137 L20:
00138 e2[i__] = 0.;
00139 L40:
00140 ;
00141 }
00142 /* .......... DETERMINE THE NUMBER OF EIGENVALUES */
00143 /* IN THE INTERVAL .......... */
00144 p = 1;
00145 q = *n;
00146 x1 = *ub;
00147 isturm = 1;
00148 goto L320;
00149 L60:
00150 *m = s;
00151 x1 = *lb;
00152 isturm = 2;
00153 goto L320;
00154 L80:
00155 *m -= s;
00156 if (*m > *mm) {
00157 goto L980;
00158 }
00159 q = 0;
00160 r__ = 0;
00161 /* .......... ESTABLISH AND PROCESS NEXT SUBMATRIX, REFINING */
00162 /* INTERVAL BY THE GERSCHGORIN BOUNDS .......... */
00163 L100:
00164 if (r__ == *m) {
00165 goto L1001;
00166 }
00167 ++tag;
00168 p = q + 1;
00169 xu = d__[p];
00170 x0 = d__[p];
00171 u = 0.;
00172
00173 i__1 = *n;
00174 for (q = p; q <= i__1; ++q) {
00175 x1 = u;
00176 u = 0.;
00177 v = 0.;
00178 if (q == *n) {
00179 goto L110;
00180 }
00181 u = (d__1 = e[q + 1], abs(d__1));
00182 v = e2[q + 1];
00183 L110:
00184 /* Computing MIN */
00185 d__1 = d__[q] - (x1 + u);
00186 xu = min(d__1,xu);
00187 /* Computing MAX */
00188 d__1 = d__[q] + (x1 + u);
00189 x0 = max(d__1,x0);
00190 if (v == 0.) {
00191 goto L140;
00192 }
00193 /* L120: */
00194 }
00195
00196 L140:
00197 /* Computing MAX */
00198 d__2 = abs(xu), d__3 = abs(x0);
00199 d__1 = max(d__2,d__3);
00200 x1 = epslon_(&d__1);
00201 if (*eps1 <= 0.) {
00202 *eps1 = -x1;
00203 }
00204 if (p != q) {
00205 goto L180;
00206 }
00207 /* .......... CHECK FOR ISOLATED ROOT WITHIN INTERVAL .......... */
00208 if (t1 > d__[p] || d__[p] >= t2) {
00209 goto L940;
00210 }
00211 m1 = p;
00212 m2 = p;
00213 rv5[p] = d__[p];
00214 goto L900;
00215 L180:
00216 x1 *= q - p + 1;
00217 /* Computing MAX */
00218 d__1 = t1, d__2 = xu - x1;
00219 *lb = max(d__1,d__2);
00220 /* Computing MIN */
00221 d__1 = t2, d__2 = x0 + x1;
00222 *ub = min(d__1,d__2);
00223 x1 = *lb;
00224 isturm = 3;
00225 goto L320;
00226 L200:
00227 m1 = s + 1;
00228 x1 = *ub;
00229 isturm = 4;
00230 goto L320;
00231 L220:
00232 m2 = s;
00233 if (m1 > m2) {
00234 goto L940;
00235 }
00236 /* .......... FIND ROOTS BY BISECTION .......... */
00237 x0 = *ub;
00238 isturm = 5;
00239
00240 i__1 = m2;
00241 for (i__ = m1; i__ <= i__1; ++i__) {
00242 rv5[i__] = *ub;
00243 rv4[i__] = *lb;
00244 /* L240: */
00245 }
00246 /* .......... LOOP FOR K-TH EIGENVALUE */
00247 /* FOR K=M2 STEP -1 UNTIL M1 DO -- */
00248 /* (-DO- NOT USED TO LEGALIZE -COMPUTED GO TO-) ..........
00249 */
00250 k = m2;
00251 L250:
00252 xu = *lb;
00253 /* .......... FOR I=K STEP -1 UNTIL M1 DO -- .......... */
00254 i__1 = k;
00255 for (ii = m1; ii <= i__1; ++ii) {
00256 i__ = m1 + k - ii;
00257 if (xu >= rv4[i__]) {
00258 goto L260;
00259 }
00260 xu = rv4[i__];
00261 goto L280;
00262 L260:
00263 ;
00264 }
00265
00266 L280:
00267 if (x0 > rv5[k]) {
00268 x0 = rv5[k];
00269 }
00270 /* .......... NEXT BISECTION STEP .......... */
00271 L300:
00272 x1 = (xu + x0) * .5;
00273 if (x0 - xu <= abs(*eps1)) {
00274 goto L420;
00275 }
00276 tst1 = (abs(xu) + abs(x0)) * 2.;
00277 tst2 = tst1 + (x0 - xu);
00278 if (tst2 == tst1) {
00279 goto L420;
00280 }
00281 /* .......... IN-LINE PROCEDURE FOR STURM SEQUENCE .......... */
00282 L320:
00283 s = p - 1;
00284 u = 1.;
00285
00286 i__1 = q;
00287 for (i__ = p; i__ <= i__1; ++i__) {
00288 if (u != 0.) {
00289 goto L325;
00290 }
00291 v = (d__1 = e[i__], abs(d__1)) / epslon_(&c_b26);
00292 if (e2[i__] == 0.) {
00293 v = 0.;
00294 }
00295 goto L330;
00296 L325:
00297 v = e2[i__] / u;
00298 L330:
00299 u = d__[i__] - x1 - v;
00300 if (u < 0.) {
00301 ++s;
00302 }
00303 /* L340: */
00304 }
00305
00306 switch (isturm) {
00307 case 1: goto L60;
00308 case 2: goto L80;
00309 case 3: goto L200;
00310 case 4: goto L220;
00311 case 5: goto L360;
00312 }
00313 /* .......... REFINE INTERVALS .......... */
00314 L360:
00315 if (s >= k) {
00316 goto L400;
00317 }
00318 xu = x1;
00319 if (s >= m1) {
00320 goto L380;
00321 }
00322 rv4[m1] = x1;
00323 goto L300;
00324 L380:
00325 rv4[s + 1] = x1;
00326 if (rv5[s] > x1) {
00327 rv5[s] = x1;
00328 }
00329 goto L300;
00330 L400:
00331 x0 = x1;
00332 goto L300;
00333 /* .......... K-TH EIGENVALUE FOUND .......... */
00334 L420:
00335 rv5[k] = x1;
00336 --k;
00337 if (k >= m1) {
00338 goto L250;
00339 }
00340 /* .......... ORDER EIGENVALUES TAGGED WITH THEIR */
00341 /* SUBMATRIX ASSOCIATIONS .......... */
00342 L900:
00343 s = r__;
00344 r__ = r__ + m2 - m1 + 1;
00345 j = 1;
00346 k = m1;
00347
00348 i__1 = r__;
00349 for (l = 1; l <= i__1; ++l) {
00350 if (j > s) {
00351 goto L910;
00352 }
00353 if (k > m2) {
00354 goto L940;
00355 }
00356 if (rv5[k] >= w[l]) {
00357 goto L915;
00358 }
00359
00360 i__2 = s;
00361 for (ii = j; ii <= i__2; ++ii) {
00362 i__ = l + s - ii;
00363 w[i__ + 1] = w[i__];
00364 ind[i__ + 1] = ind[i__];
00365 /* L905: */
00366 }
00367
00368 L910:
00369 w[l] = rv5[k];
00370 ind[l] = tag;
00371 ++k;
00372 goto L920;
00373 L915:
00374 ++j;
00375 L920:
00376 ;
00377 }
00378
00379 L940:
00380 if (q < *n) {
00381 goto L100;
00382 }
00383 goto L1001;
00384 /* .......... SET ERROR -- UNDERESTIMATE OF NUMBER OF */
00385 /* EIGENVALUES IN INTERVAL .......... */
00386 L980:
00387 *ierr = *n * 3 + 1;
00388 L1001:
00389 *lb = t1;
00390 *ub = t2;
00391 return 0;
00392 } /* bisect_ */
|
|
||||||||||||||||||||||||||||||||||||||||
|
Definition at line 12 of file eis_bqr.c. References a, abs, c_b8, d_sign(), l, m1, m2, max, min, pythag_(), q, and scale.
00015 {
00016 /* System generated locals */
00017 integer a_dim1, a_offset, i__1, i__2, i__3;
00018 doublereal d__1;
00019
00020 /* Builtin functions */
00021 double d_sign(doublereal *, doublereal *), sqrt(doublereal);
00022
00023 /* Local variables */
00024 static doublereal f, g;
00025 static integer i__, j, k, l, m;
00026 static doublereal q, s, scale;
00027 static integer imult, m1, m2, m3, m4, m21, m31, ii, ik, jk, kj, jm, kk,
00028 km, ll, mk, mn, ni, mz;
00029 extern doublereal pythag_(doublereal *, doublereal *);
00030 static integer kj1, its;
00031 static doublereal tst1, tst2;
00032
00033
00034
00035 /* THIS SUBROUTINE IS A TRANSLATION OF THE ALGOL PROCEDURE BQR, */
00036 /* NUM. MATH. 16, 85-92(1970) BY MARTIN, REINSCH, AND WILKINSON. */
00037 /* HANDBOOK FOR AUTO. COMP., VOL II-LINEAR ALGEBRA, 266-272(1971). */
00038
00039 /* THIS SUBROUTINE FINDS THE EIGENVALUE OF SMALLEST (USUALLY) */
00040 /* MAGNITUDE OF A REAL SYMMETRIC BAND MATRIX USING THE */
00041 /* QR ALGORITHM WITH SHIFTS OF ORIGIN. CONSECUTIVE CALLS */
00042 /* CAN BE MADE TO FIND FURTHER EIGENVALUES. */
00043
00044 /* ON INPUT */
00045
00046 /* NM MUST BE SET TO THE ROW DIMENSION OF TWO-DIMENSIONAL */
00047 /* ARRAY PARAMETERS AS DECLARED IN THE CALLING PROGRAM */
00048 /* DIMENSION STATEMENT. */
00049
00050 /* N IS THE ORDER OF THE MATRIX. */
00051
00052 /* MB IS THE (HALF) BAND WIDTH OF THE MATRIX, DEFINED AS THE */
00053 /* NUMBER OF ADJACENT DIAGONALS, INCLUDING THE PRINCIPAL */
00054 /* DIAGONAL, REQUIRED TO SPECIFY THE NON-ZERO PORTION OF THE */
00055 /* LOWER TRIANGLE OF THE MATRIX. */
00056
00057 /* A CONTAINS THE LOWER TRIANGLE OF THE SYMMETRIC BAND INPUT */
00058 /* MATRIX STORED AS AN N BY MB ARRAY. ITS LOWEST SUBDIAGONAL */
00059 /* IS STORED IN THE LAST N+1-MB POSITIONS OF THE FIRST COLUMN, */
00060 /* ITS NEXT SUBDIAGONAL IN THE LAST N+2-MB POSITIONS OF THE */
00061 /* SECOND COLUMN, FURTHER SUBDIAGONALS SIMILARLY, AND FINALLY */
00062 /* ITS PRINCIPAL DIAGONAL IN THE N POSITIONS OF THE LAST COLUMN.
00063 */
00064 /* CONTENTS OF STORAGES NOT PART OF THE MATRIX ARE ARBITRARY. */
00065 /* ON A SUBSEQUENT CALL, ITS OUTPUT CONTENTS FROM THE PREVIOUS */
00066 /* CALL SHOULD BE PASSED. */
00067
00068 /* T SPECIFIES THE SHIFT (OF EIGENVALUES) APPLIED TO THE DIAGONAL
00069 */
00070 /* OF A IN FORMING THE INPUT MATRIX. WHAT IS ACTUALLY DETERMINED
00071 */
00072 /* IS THE EIGENVALUE OF A+TI (I IS THE IDENTITY MATRIX) NEAREST
00073 */
00074 /* TO T. ON A SUBSEQUENT CALL, THE OUTPUT VALUE OF T FROM THE */
00075 /* PREVIOUS CALL SHOULD BE PASSED IF THE NEXT NEAREST EIGENVALUE
00076 */
00077 /* IS SOUGHT. */
00078
00079 /* R SHOULD BE SPECIFIED AS ZERO ON THE FIRST CALL, AND AS ITS */
00080 /* OUTPUT VALUE FROM THE PREVIOUS CALL ON A SUBSEQUENT CALL. */
00081 /* IT IS USED TO DETERMINE WHEN THE LAST ROW AND COLUMN OF */
00082 /* THE TRANSFORMED BAND MATRIX CAN BE REGARDED AS NEGLIGIBLE. */
00083
00084 /* NV MUST BE SET TO THE DIMENSION OF THE ARRAY PARAMETER RV */
00085 /* AS DECLARED IN THE CALLING PROGRAM DIMENSION STATEMENT. */
00086
00087 /* ON OUTPUT */
00088
00089 /* A CONTAINS THE TRANSFORMED BAND MATRIX. THE MATRIX A+TI */
00090 /* DERIVED FROM THE OUTPUT PARAMETERS IS SIMILAR TO THE */
00091 /* INPUT A+TI TO WITHIN ROUNDING ERRORS. ITS LAST ROW AND */
00092 /* COLUMN ARE NULL (IF IERR IS ZERO). */
00093
00094 /* T CONTAINS THE COMPUTED EIGENVALUE OF A+TI (IF IERR IS ZERO). */
00095
00096 /* R CONTAINS THE MAXIMUM OF ITS INPUT VALUE AND THE NORM OF THE */
00097 /* LAST COLUMN OF THE INPUT MATRIX A. */
00098
00099 /* IERR IS SET TO */
00100 /* ZERO FOR NORMAL RETURN, */
00101 /* N IF THE EIGENVALUE HAS NOT BEEN */
00102 /* DETERMINED AFTER 30 ITERATIONS. */
00103
00104 /* RV IS A TEMPORARY STORAGE ARRAY OF DIMENSION AT LEAST */
00105 /* (2*MB**2+4*MB-3). THE FIRST (3*MB-2) LOCATIONS CORRESPOND */
00106 /* TO THE ALGOL ARRAY B, THE NEXT (2*MB-1) LOCATIONS CORRESPOND
00107 */
00108 /* TO THE ALGOL ARRAY H, AND THE FINAL (2*MB**2-MB) LOCATIONS */
00109 /* CORRESPOND TO THE MB BY (2*MB-1) ALGOL ARRAY U. */
00110
00111 /* NOTE. FOR A SUBSEQUENT CALL, N SHOULD BE REPLACED BY N-1, BUT */
00112 /* MB SHOULD NOT BE ALTERED EVEN WHEN IT EXCEEDS THE CURRENT N. */
00113
00114 /* CALLS PYTHAG FOR DSQRT(A*A + B*B) . */
00115
00116 /* QUESTIONS AND COMMENTS SHOULD BE DIRECTED TO BURTON S. GARBOW, */
00117 /* MATHEMATICS AND COMPUTER SCIENCE DIV, ARGONNE NATIONAL LABORATORY
00118 */
00119
00120 /* THIS VERSION DATED AUGUST 1983. */
00121
00122 /* ------------------------------------------------------------------
00123 */
00124
00125 /* Parameter adjustments */
00126 a_dim1 = *nm;
00127 a_offset = a_dim1 + 1;
00128 a -= a_offset;
00129 --rv;
00130
00131 /* Function Body */
00132 *ierr = 0;
00133 m1 = min(*mb,*n);
00134 m = m1 - 1;
00135 m2 = m + m;
00136 m21 = m2 + 1;
00137 m3 = m21 + m;
00138 m31 = m3 + 1;
00139 m4 = m31 + m2;
00140 mn = m + *n;
00141 mz = *mb - m1;
00142 its = 0;
00143 /* .......... TEST FOR CONVERGENCE .......... */
00144 L40:
00145 g = a[*n + *mb * a_dim1];
00146 if (m == 0) {
00147 goto L360;
00148 }
00149 f = 0.;
00150
00151 i__1 = m;
00152 for (k = 1; k <= i__1; ++k) {
00153 mk = k + mz;
00154 f += (d__1 = a[*n + mk * a_dim1], abs(d__1));
00155 /* L50: */
00156 }
00157
00158 if (its == 0 && f > *r__) {
00159 *r__ = f;
00160 }
00161 tst1 = *r__;
00162 tst2 = tst1 + f;
00163 if (tst2 <= tst1) {
00164 goto L360;
00165 }
00166 if (its == 30) {
00167 goto L1000;
00168 }
00169 ++its;
00170 /* .......... FORM SHIFT FROM BOTTOM 2 BY 2 MINOR .......... */
00171 if (f > *r__ * .25 && its < 5) {
00172 goto L90;
00173 }
00174 f = a[*n + (*mb - 1) * a_dim1];
00175 if (f == 0.) {
00176 goto L70;
00177 }
00178 q = (a[*n - 1 + *mb * a_dim1] - g) / (f * 2.);
00179 s = pythag_(&q, &c_b8);
00180 g -= f / (q + d_sign(&s, &q));
00181 L70:
00182 *t += g;
00183
00184 i__1 = *n;
00185 for (i__ = 1; i__ <= i__1; ++i__) {
00186 /* L80: */
00187 a[i__ + *mb * a_dim1] -= g;
00188 }
00189
00190 L90:
00191 i__1 = m4;
00192 for (k = m31; k <= i__1; ++k) {
00193 /* L100: */
00194 rv[k] = 0.;
00195 }
00196
00197 i__1 = mn;
00198 for (ii = 1; ii <= i__1; ++ii) {
00199 i__ = ii - m;
00200 ni = *n - ii;
00201 if (ni < 0) {
00202 goto L230;
00203 }
00204 /* .......... FORM COLUMN OF SHIFTED MATRIX A-G*I .......... */
00205 /* Computing MAX */
00206 i__2 = 1, i__3 = 2 - i__;
00207 l = max(i__2,i__3);
00208
00209 i__2 = m3;
00210 for (k = 1; k <= i__2; ++k) {
00211 /* L110: */
00212 rv[k] = 0.;
00213 }
00214
00215 i__2 = m1;
00216 for (k = l; k <= i__2; ++k) {
00217 km = k + m;
00218 mk = k + mz;
00219 rv[km] = a[ii + mk * a_dim1];
00220 /* L120: */
00221 }
00222
00223 ll = min(m,ni);
00224 if (ll == 0) {
00225 goto L135;
00226 }
00227
00228 i__2 = ll;
00229 for (k = 1; k <= i__2; ++k) {
00230 km = k + m21;
00231 ik = ii + k;
00232 mk = *mb - k;
00233 rv[km] = a[ik + mk * a_dim1];
00234 /* L130: */
00235 }
00236 /* .......... PRE-MULTIPLY WITH HOUSEHOLDER REFLECTIONS ..........
00237 */
00238 L135:
00239 ll = m2;
00240 imult = 0;
00241 /* .......... MULTIPLICATION PROCEDURE .......... */
00242 L140:
00243 kj = m4 - m1;
00244
00245 i__2 = ll;
00246 for (j = 1; j <= i__2; ++j) {
00247 kj += m1;
00248 jm = j + m3;
00249 if (rv[jm] == 0.) {
00250 goto L170;
00251 }
00252 f = 0.;
00253
00254 i__3 = m1;
00255 for (k = 1; k <= i__3; ++k) {
00256 ++kj;
00257 jk = j + k - 1;
00258 f += rv[kj] * rv[jk];
00259 /* L150: */
00260 }
00261
00262 f /= rv[jm];
00263 kj -= m1;
00264
00265 i__3 = m1;
00266 for (k = 1; k <= i__3; ++k) {
00267 ++kj;
00268 jk = j + k - 1;
00269 rv[jk] -= rv[kj] * f;
00270 /* L160: */
00271 }
00272
00273 kj -= m1;
00274 L170:
00275 ;
00276 }
00277
00278 if (imult != 0) {
00279 goto L280;
00280 }
00281 /* .......... HOUSEHOLDER REFLECTION .......... */
00282 f = rv[m21];
00283 s = 0.;
00284 rv[m4] = 0.;
00285 scale = 0.;
00286
00287 i__2 = m3;
00288 for (k = m21; k <= i__2; ++k) {
00289 /* L180: */
00290 scale += (d__1 = rv[k], abs(d__1));
00291 }
00292
00293 if (scale == 0.) {
00294 goto L210;
00295 }
00296
00297 i__2 = m3;
00298 for (k = m21; k <= i__2; ++k) {
00299 /* L190: */
00300 /* Computing 2nd power */
00301 d__1 = rv[k] / scale;
00302 s += d__1 * d__1;
00303 }
00304
00305 s = scale * scale * s;
00306 d__1 = sqrt(s);
00307 g = -d_sign(&d__1, &f);
00308 rv[m21] = g;
00309 rv[m4] = s - f * g;
00310 kj = m4 + m2 * m1 + 1;
00311 rv[kj] = f - g;
00312
00313 i__2 = m1;
00314 for (k = 2; k <= i__2; ++k) {
00315 ++kj;
00316 km = k + m2;
00317 rv[kj] = rv[km];
00318 /* L200: */
00319 }
00320 /* .......... SAVE COLUMN OF TRIANGULAR FACTOR R .......... */
00321 L210:
00322 i__2 = m1;
00323 for (k = l; k <= i__2; ++k) {
00324 km = k + m;
00325 mk = k + mz;
00326 a[ii + mk * a_dim1] = rv[km];
00327 /* L220: */
00328 }
00329
00330 L230:
00331 /* Computing MAX */
00332 i__2 = 1, i__3 = m1 + 1 - i__;
00333 l = max(i__2,i__3);
00334 if (i__ <= 0) {
00335 goto L300;
00336 }
00337 /* .......... PERFORM ADDITIONAL STEPS .......... */
00338 i__2 = m21;
00339 for (k = 1; k <= i__2; ++k) {
00340 /* L240: */
00341 rv[k] = 0.;
00342 }
00343
00344 /* Computing MIN */
00345 i__2 = m1, i__3 = ni + m1;
00346 ll = min(i__2,i__3);
00347 /* .......... GET ROW OF TRIANGULAR FACTOR R .......... */
00348 i__2 = ll;
00349 for (kk = 1; kk <= i__2; ++kk) {
00350 k = kk - 1;
00351 km = k + m1;
00352 ik = i__ + k;
00353 mk = *mb - k;
00354 rv[km] = a[ik + mk * a_dim1];
00355 /* L250: */
00356 }
00357 /* .......... POST-MULTIPLY WITH HOUSEHOLDER REFLECTIONS .........
00358 . */
00359 ll = m1;
00360 imult = 1;
00361 goto L140;
00362 /* .......... STORE COLUMN OF NEW A MATRIX .......... */
00363 L280:
00364 i__2 = m1;
00365 for (k = l; k <= i__2; ++k) {
00366 mk = k + mz;
00367 a[i__ + mk * a_dim1] = rv[k];
00368 /* L290: */
00369 }
00370 /* .......... UPDATE HOUSEHOLDER REFLECTIONS .......... */
00371 L300:
00372 if (l > 1) {
00373 --l;
00374 }
00375 kj1 = m4 + l * m1;
00376
00377 i__2 = m2;
00378 for (j = l; j <= i__2; ++j) {
00379 jm = j + m3;
00380 rv[jm] = rv[jm + 1];
00381
00382 i__3 = m1;
00383 for (k = 1; k <= i__3; ++k) {
00384 ++kj1;
00385 kj = kj1 - m1;
00386 rv[kj] = rv[kj1];
00387 /* L320: */
00388 }
00389 }
00390
00391 /* L350: */
00392 }
00393
00394 goto L40;
00395 /* .......... CONVERGENCE .......... */
00396 L360:
00397 *t += g;
00398
00399 i__1 = *n;
00400 for (i__ = 1; i__ <= i__1; ++i__) {
00401 /* L380: */
00402 a[i__ + *mb * a_dim1] -= g;
00403 }
00404
00405 i__1 = m1;
00406 for (k = 1; k <= i__1; ++k) {
00407 mk = k + mz;
00408 a[*n + mk * a_dim1] = 0.;
00409 /* L400: */
00410 }
00411
00412 goto L1001;
00413 /* .......... SET ERROR -- NO CONVERGENCE TO */
00414 /* EIGENVALUE AFTER 30 ITERATIONS .......... */
00415 L1000:
00416 *ierr = *n;
00417 L1001:
00418 return 0;
00419 } /* bqr_ */
|
|
||||||||||||||||||||||||||||||||||||
|
Definition at line 8 of file eis_cbabk2.c. References scale. Referenced by cg_().
00010 {
00011 /* System generated locals */
00012 integer zr_dim1, zr_offset, zi_dim1, zi_offset, i__1, i__2;
00013
00014 /* Local variables */
00015 static integer i__, j, k;
00016 static doublereal s;
00017 static integer ii;
00018
00019
00020
00021 /* THIS SUBROUTINE IS A TRANSLATION OF THE ALGOL PROCEDURE */
00022 /* CBABK2, WHICH IS A COMPLEX VERSION OF BALBAK, */
00023 /* NUM. MATH. 13, 293-304(1969) BY PARLETT AND REINSCH. */
00024 /* HANDBOOK FOR AUTO. COMP., VOL.II-LINEAR ALGEBRA, 315-326(1971). */
00025
00026 /* THIS SUBROUTINE FORMS THE EIGENVECTORS OF A COMPLEX GENERAL */
00027 /* MATRIX BY BACK TRANSFORMING THOSE OF THE CORRESPONDING */
00028 /* BALANCED MATRIX DETERMINED BY CBAL. */
00029
00030 /* ON INPUT */
00031
00032 /* NM MUST BE SET TO THE ROW DIMENSION OF TWO-DIMENSIONAL */
00033 /* ARRAY PARAMETERS AS DECLARED IN THE CALLING PROGRAM */
00034 /* DIMENSION STATEMENT. */
00035
00036 /* N IS THE ORDER OF THE MATRIX. */
00037
00038 /* LOW AND IGH ARE INTEGERS DETERMINED BY CBAL. */
00039
00040 /* SCALE CONTAINS INFORMATION DETERMINING THE PERMUTATIONS */
00041 /* AND SCALING FACTORS USED BY CBAL. */
00042
00043 /* M IS THE NUMBER OF EIGENVECTORS TO BE BACK TRANSFORMED. */
00044
00045 /* ZR AND ZI CONTAIN THE REAL AND IMAGINARY PARTS, */
00046 /* RESPECTIVELY, OF THE EIGENVECTORS TO BE */
00047 /* BACK TRANSFORMED IN THEIR FIRST M COLUMNS. */
00048
00049 /* ON OUTPUT */
00050
00051 /* ZR AND ZI CONTAIN THE REAL AND IMAGINARY PARTS, */
00052 /* RESPECTIVELY, OF THE TRANSFORMED EIGENVECTORS */
00053 /* IN THEIR FIRST M COLUMNS. */
00054
00055 /* QUESTIONS AND COMMENTS SHOULD BE DIRECTED TO BURTON S. GARBOW, */
00056 /* MATHEMATICS AND COMPUTER SCIENCE DIV, ARGONNE NATIONAL LABORATORY
00057 */
00058
00059 /* THIS VERSION DATED AUGUST 1983. */
00060
00061 /* ------------------------------------------------------------------
00062 */
00063
00064 /* Parameter adjustments */
00065 --scale;
00066 zi_dim1 = *nm;
00067 zi_offset = zi_dim1 + 1;
00068 zi -= zi_offset;
00069 zr_dim1 = *nm;
00070 zr_offset = zr_dim1 + 1;
00071 zr -= zr_offset;
00072
00073 /* Function Body */
00074 if (*m == 0) {
00075 goto L200;
00076 }
00077 if (*igh == *low) {
00078 goto L120;
00079 }
00080
00081 i__1 = *igh;
00082 for (i__ = *low; i__ <= i__1; ++i__) {
00083 s = scale[i__];
00084 /* .......... LEFT HAND EIGENVECTORS ARE BACK TRANSFORMED */
00085 /* IF THE FOREGOING STATEMENT IS REPLACED BY */
00086 /* S=1.0D0/SCALE(I). .......... */
00087 i__2 = *m;
00088 for (j = 1; j <= i__2; ++j) {
00089 zr[i__ + j * zr_dim1] *= s;
00090 zi[i__ + j * zi_dim1] *= s;
00091 /* L100: */
00092 }
00093
00094 /* L110: */
00095 }
00096 /* .......... FOR I=LOW-1 STEP -1 UNTIL 1, */
00097 /* IGH+1 STEP 1 UNTIL N DO -- .......... */
00098 L120:
00099 i__1 = *n;
00100 for (ii = 1; ii <= i__1; ++ii) {
00101 i__ = ii;
00102 if (i__ >= *low && i__ <= *igh) {
00103 goto L140;
00104 }
00105 if (i__ < *low) {
00106 i__ = *low - ii;
00107 }
00108 k = (integer) scale[i__];
00109 if (k == i__) {
00110 goto L140;
00111 }
00112
00113 i__2 = *m;
00114 for (j = 1; j <= i__2; ++j) {
00115 s = zr[i__ + j * zr_dim1];
00116 zr[i__ + j * zr_dim1] = zr[k + j * zr_dim1];
00117 zr[k + j * zr_dim1] = s;
00118 s = zi[i__ + j * zi_dim1];
00119 zi[i__ + j * zi_dim1] = zi[k + j * zi_dim1];
00120 zi[k + j * zi_dim1] = s;
00121 /* L130: */
00122 }
00123
00124 L140:
00125 ;
00126 }
00127
00128 L200:
00129 return 0;
00130 } /* cbabk2_ */
|
|
||||||||||||||||||||||||||||||||
|
Definition at line 8 of file eis_cbal.c. Referenced by cg_().
00010 {
00011 /* System generated locals */
00012 integer ar_dim1, ar_offset, ai_dim1, ai_offset, i__1, i__2;
00013 doublereal d__1, d__2;
00014
00015 /* Local variables */
00016 static integer iexc;
00017 static doublereal c__, f, g;
00018 static integer i__, j, k, l, m;
00019 static doublereal r__, s, radix, b2;
00020 static integer jj;
00021 static logical noconv;
00022
00023
00024
00025 /* THIS SUBROUTINE IS A TRANSLATION OF THE ALGOL PROCEDURE */
00026 /* CBALANCE, WHICH IS A COMPLEX VERSION OF BALANCE, */
00027 /* NUM. MATH. 13, 293-304(1969) BY PARLETT AND REINSCH. */
00028 /* HANDBOOK FOR AUTO. COMP., VOL.II-LINEAR ALGEBRA, 315-326(1971). */
00029
00030 /* THIS SUBROUTINE BALANCES A COMPLEX MATRIX AND ISOLATES */
00031 /* EIGENVALUES WHENEVER POSSIBLE. */
00032
00033 /* ON INPUT */
00034
00035 /* NM MUST BE SET TO THE ROW DIMENSION OF TWO-DIMENSIONAL */
00036 /* ARRAY PARAMETERS AS DECLARED IN THE CALLING PROGRAM */
00037 /* DIMENSION STATEMENT. */
00038
00039 /* N IS THE ORDER OF THE MATRIX. */
00040
00041 /* AR AND AI CONTAIN THE REAL AND IMAGINARY PARTS, */
00042 /* RESPECTIVELY, OF THE COMPLEX MATRIX TO BE BALANCED. */
00043
00044 /* ON OUTPUT */
00045
00046 /* AR AND AI CONTAIN THE REAL AND IMAGINARY PARTS, */
00047 /* RESPECTIVELY, OF THE BALANCED MATRIX. */
00048
00049 /* LOW AND IGH ARE TWO INTEGERS SUCH THAT AR(I,J) AND AI(I,J) */
00050 /* ARE EQUAL TO ZERO IF */
00051 /* (1) I IS GREATER THAN J AND */
00052 /* (2) J=1,...,LOW-1 OR I=IGH+1,...,N. */
00053
00054 /* SCALE CONTAINS INFORMATION DETERMINING THE */
00055 /* PERMUTATIONS AND SCALING FACTORS USED. */
00056
00057 /* SUPPOSE THAT THE PRINCIPAL SUBMATRIX IN ROWS LOW THROUGH IGH */
00058 /* HAS BEEN BALANCED, THAT P(J) DENOTES THE INDEX INTERCHANGED */
00059 /* WITH J DURING THE PERMUTATION STEP, AND THAT THE ELEMENTS */
00060 /* OF THE DIAGONAL MATRIX USED ARE DENOTED BY D(I,J). THEN */
00061 /* SCALE(J) = P(J), FOR J = 1,...,LOW-1 */
00062 /* = D(J,J) J = LOW,...,IGH */
00063 /* = P(J) J = IGH+1,...,N. */
00064 /* THE ORDER IN WHICH THE INTERCHANGES ARE MADE IS N TO IGH+1, */
00065 /* THEN 1 TO LOW-1. */
00066
00067 /* NOTE THAT 1 IS RETURNED FOR IGH IF IGH IS ZERO FORMALLY. */
00068
00069 /* THE ALGOL PROCEDURE EXC CONTAINED IN CBALANCE APPEARS IN */
00070 /* CBAL IN LINE. (NOTE THAT THE ALGOL ROLES OF IDENTIFIERS */
00071 /* K,L HAVE BEEN REVERSED.) */
00072
00073 /* ARITHMETIC IS REAL THROUGHOUT. */
00074
00075 /* QUESTIONS AND COMMENTS SHOULD BE DIRECTED TO BURTON S. GARBOW, */
00076 /* MATHEMATICS AND COMPUTER SCIENCE DIV, ARGONNE NATIONAL LABORATORY
00077 */
00078
00079 /* THIS VERSION DATED AUGUST 1983. */
00080
00081 /* ------------------------------------------------------------------
00082 */
00083
00084 /* Parameter adjustments */
00085 --scale;
00086 ai_dim1 = *nm;
00087 ai_offset = ai_dim1 + 1;
00088 ai -= ai_offset;
00089 ar_dim1 = *nm;
00090 ar_offset = ar_dim1 + 1;
00091 ar -= ar_offset;
00092
00093 /* Function Body */
00094 radix = 16.;
00095
00096 b2 = radix * radix;
00097 k = 1;
00098 l = *n;
00099 goto L100;
00100 /* .......... IN-LINE PROCEDURE FOR ROW AND */
00101 /* COLUMN EXCHANGE .......... */
00102 L20:
00103 scale[m] = (doublereal) j;
00104 if (j == m) {
00105 goto L50;
00106 }
00107
00108 i__1 = l;
00109 for (i__ = 1; i__ <= i__1; ++i__) {
00110 f = ar[i__ + j * ar_dim1];
00111 ar[i__ + j * ar_dim1] = ar[i__ + m * ar_dim1];
00112 ar[i__ + m * ar_dim1] = f;
00113 f = ai[i__ + j * ai_dim1];
00114 ai[i__ + j * ai_dim1] = ai[i__ + m * ai_dim1];
00115 ai[i__ + m * ai_dim1] = f;
00116 /* L30: */
00117 }
00118
00119 i__1 = *n;
00120 for (i__ = k; i__ <= i__1; ++i__) {
00121 f = ar[j + i__ * ar_dim1];
00122 ar[j + i__ * ar_dim1] = ar[m + i__ * ar_dim1];
00123 ar[m + i__ * ar_dim1] = f;
00124 f = ai[j + i__ * ai_dim1];
00125 ai[j + i__ * ai_dim1] = ai[m + i__ * ai_dim1];
00126 ai[m + i__ * ai_dim1] = f;
00127 /* L40: */
00128 }
00129
00130 L50:
00131 switch (iexc) {
00132 case 1: goto L80;
00133 case 2: goto L130;
00134 }
00135 /* .......... SEARCH FOR ROWS ISOLATING AN EIGENVALUE */
00136 /* AND PUSH THEM DOWN .......... */
00137 L80:
00138 if (l == 1) {
00139 goto L280;
00140 }
00141 --l;
00142 /* .......... FOR J=L STEP -1 UNTIL 1 DO -- .......... */
00143 L100:
00144 i__1 = l;
00145 for (jj = 1; jj <= i__1; ++jj) {
00146 j = l + 1 - jj;
00147
00148 i__2 = l;
00149 for (i__ = 1; i__ <= i__2; ++i__) {
00150 if (i__ == j) {
00151 goto L110;
00152 }
00153 if (ar[j + i__ * ar_dim1] != 0. || ai[j + i__ * ai_dim1] != 0.) {
00154 goto L120;
00155 }
00156 L110:
00157 ;
00158 }
00159
00160 m = l;
00161 iexc = 1;
00162 goto L20;
00163 L120:
00164 ;
00165 }
00166
00167 goto L140;
00168 /* .......... SEARCH FOR COLUMNS ISOLATING AN EIGENVALUE */
00169 /* AND PUSH THEM LEFT .......... */
00170 L130:
00171 ++k;
00172
00173 L140:
00174 i__1 = l;
00175 for (j = k; j <= i__1; ++j) {
00176
00177 i__2 = l;
00178 for (i__ = k; i__ <= i__2; ++i__) {
00179 if (i__ == j) {
00180 goto L150;
00181 }
00182 if (ar[i__ + j * ar_dim1] != 0. || ai[i__ + j * ai_dim1] != 0.) {
00183 goto L170;
00184 }
00185 L150:
00186 ;
00187 }
00188
00189 m = k;
00190 iexc = 2;
00191 goto L20;
00192 L170:
00193 ;
00194 }
00195 /* .......... NOW BALANCE THE SUBMATRIX IN ROWS K TO L .......... */
00196 i__1 = l;
00197 for (i__ = k; i__ <= i__1; ++i__) {
00198 /* L180: */
00199 scale[i__] = 1.;
00200 }
00201 /* .......... ITERATIVE LOOP FOR NORM REDUCTION .......... */
00202 L190:
00203 noconv = FALSE_;
00204
00205 i__1 = l;
00206 for (i__ = k; i__ <= i__1; ++i__) {
00207 c__ = 0.;
00208 r__ = 0.;
00209
00210 i__2 = l;
00211 for (j = k; j <= i__2; ++j) {
00212 if (j == i__) {
00213 goto L200;
00214 }
00215 c__ = c__ + (d__1 = ar[j + i__ * ar_dim1], abs(d__1)) + (d__2 =
00216 ai[j + i__ * ai_dim1], abs(d__2));
00217 r__ = r__ + (d__1 = ar[i__ + j * ar_dim1], abs(d__1)) + (d__2 =
00218 ai[i__ + j * ai_dim1], abs(d__2));
00219 L200:
00220 ;
00221 }
00222 /* .......... GUARD AGAINST ZERO C OR R DUE TO UNDERFLOW .........
00223 . */
00224 if (c__ == 0. || r__ == 0.) {
00225 goto L270;
00226 }
00227 g = r__ / radix;
00228 f = 1.;
00229 s = c__ + r__;
00230 L210:
00231 if (c__ >= g) {
00232 goto L220;
00233 }
00234 f *= radix;
00235 c__ *= b2;
00236 goto L210;
00237 L220:
00238 g = r__ * radix;
00239 L230:
00240 if (c__ < g) {
00241 goto L240;
00242 }
00243 f /= radix;
00244 c__ /= b2;
00245 goto L230;
00246 /* .......... NOW BALANCE .......... */
00247 L240:
00248 if ((c__ + r__) / f >= s * .95) {
00249 goto L270;
00250 }
00251 g = 1. / f;
00252 scale[i__] *= f;
00253 noconv = TRUE_;
00254
00255 i__2 = *n;
00256 for (j = k; j <= i__2; ++j) {
00257 ar[i__ + j * ar_dim1] *= g;
00258 ai[i__ + j * ai_dim1] *= g;
00259 /* L250: */
00260 }
00261
00262 i__2 = l;
00263 for (j = 1; j <= i__2; ++j) {
00264 ar[j + i__ * ar_dim1] *= f;
00265 ai[j + i__ * ai_dim1] *= f;
00266 /* L260: */
00267 }
00268
00269 L270:
00270 ;
00271 }
00272
00273 if (noconv) {
00274 goto L190;
00275 }
00276
00277 L280:
00278 *low = k;
00279 *igh = l;
00280 return 0;
00281 } /* cbal_ */
|
|
||||||||||||||||||||||||||||
|
Definition at line 8 of file eis_cdiv.c. References abs. Referenced by cinvit_(), comhes_(), comlr2_(), comlr_(), comqr2_(), comqr_(), hqr2_(), and invit_().
00010 {
00011 /* System generated locals */
00012 doublereal d__1, d__2;
00013
00014 /* Local variables */
00015 static doublereal s, ais, bis, ars, brs;
00016
00017
00018 /* COMPLEX DIVISION, (CR,CI) = (AR,AI)/(BR,BI) */
00019
00020 s = abs(*br) + abs(*bi);
00021 ars = *ar / s;
00022 ais = *ai / s;
00023 brs = *br / s;
00024 bis = *bi / s;
00025 /* Computing 2nd power */
00026 d__1 = brs;
00027 /* Computing 2nd power */
00028 d__2 = bis;
00029 s = d__1 * d__1 + d__2 * d__2;
00030 *cr = (ars * brs + ais * bis) / s;
00031 *ci = (ais * brs - ars * bis) / s;
00032 return 0;
00033 } /* cdiv_ */
|
|
||||||||||||||||||||||||||||||||||||||||||||||||||||||||
|
Definition at line 8 of file eis_cg.c. References cbabk2_(), cbal_(), comqr2_(), comqr_(), and corth_().
00012 {
00013 /* System generated locals */
00014 integer ar_dim1, ar_offset, ai_dim1, ai_offset, zr_dim1, zr_offset,
00015 zi_dim1, zi_offset;
00016
00017 /* Local variables */
00018 extern /* Subroutine */ int cbal_(integer *, integer *, doublereal *,
00019 doublereal *, integer *, integer *, doublereal *), corth_(integer
00020 *, integer *, integer *, integer *, doublereal *, doublereal *,
00021 doublereal *, doublereal *), comqr_(integer *, integer *, integer
00022 *, integer *, doublereal *, doublereal *, doublereal *,
00023 doublereal *, integer *), cbabk2_(integer *, integer *, integer *,
00024 integer *, doublereal *, integer *, doublereal *, doublereal *),
00025 comqr2_(integer *, integer *, integer *, integer *, doublereal *,
00026 doublereal *, doublereal *, doublereal *, doublereal *,
00027 doublereal *, doublereal *, doublereal *, integer *);
00028 static integer is1, is2;
00029
00030
00031
00032 /* THIS SUBROUTINE CALLS THE RECOMMENDED SEQUENCE OF */
00033 /* SUBROUTINES FROM THE EIGENSYSTEM SUBROUTINE PACKAGE (EISPACK) */
00034 /* TO FIND THE EIGENVALUES AND EIGENVECTORS (IF DESIRED) */
00035 /* OF A COMPLEX GENERAL MATRIX. */
00036
00037 /* ON INPUT */
00038
00039 /* NM MUST BE SET TO THE ROW DIMENSION OF THE TWO-DIMENSIONAL */
00040 /* ARRAY PARAMETERS AS DECLARED IN THE CALLING PROGRAM */
00041 /* DIMENSION STATEMENT. */
00042
00043 /* N IS THE ORDER OF THE MATRIX A=(AR,AI). */
00044
00045 /* AR AND AI CONTAIN THE REAL AND IMAGINARY PARTS, */
00046 /* RESPECTIVELY, OF THE COMPLEX GENERAL MATRIX. */
00047
00048 /* MATZ IS AN INTEGER VARIABLE SET EQUAL TO ZERO IF */
00049 /* ONLY EIGENVALUES ARE DESIRED. OTHERWISE IT IS SET TO */
00050 /* ANY NON-ZERO INTEGER FOR BOTH EIGENVALUES AND EIGENVECTORS. */
00051
00052 /* ON OUTPUT */
00053
00054 /* WR AND WI CONTAIN THE REAL AND IMAGINARY PARTS, */
00055 /* RESPECTIVELY, OF THE EIGENVALUES. */
00056
00057 /* ZR AND ZI CONTAIN THE REAL AND IMAGINARY PARTS, */
00058 /* RESPECTIVELY, OF THE EIGENVECTORS IF MATZ IS NOT ZERO. */
00059
00060 /* IERR IS AN INTEGER OUTPUT VARIABLE SET EQUAL TO AN ERROR */
00061 /* COMPLETION CODE DESCRIBED IN THE DOCUMENTATION FOR COMQR */
00062 /* AND COMQR2. THE NORMAL COMPLETION CODE IS ZERO. */
00063
00064 /* FV1, FV2, AND FV3 ARE TEMPORARY STORAGE ARRAYS. */
00065
00066 /* QUESTIONS AND COMMENTS SHOULD BE DIRECTED TO BURTON S. GARBOW, */
00067 /* MATHEMATICS AND COMPUTER SCIENCE DIV, ARGONNE NATIONAL LABORATORY
00068 */
00069
00070 /* THIS VERSION DATED AUGUST 1983. */
00071
00072 /* ------------------------------------------------------------------
00073 */
00074
00075 /* Parameter adjustments */
00076 --fv3;
00077 --fv2;
00078 --fv1;
00079 zi_dim1 = *nm;
00080 zi_offset = zi_dim1 + 1;
00081 zi -= zi_offset;
00082 zr_dim1 = *nm;
00083 zr_offset = zr_dim1 + 1;
00084 zr -= zr_offset;
00085 --wi;
00086 --wr;
00087 ai_dim1 = *nm;
00088 ai_offset = ai_dim1 + 1;
00089 ai -= ai_offset;
00090 ar_dim1 = *nm;
00091 ar_offset = ar_dim1 + 1;
00092 ar -= ar_offset;
00093
00094 /* Function Body */
00095 if (*n <= *nm) {
00096 goto L10;
00097 }
00098 *ierr = *n * 10;
00099 goto L50;
00100
00101 L10:
00102 cbal_(nm, n, &ar[ar_offset], &ai[ai_offset], &is1, &is2, &fv1[1]);
00103 corth_(nm, n, &is1, &is2, &ar[ar_offset], &ai[ai_offset], &fv2[1], &fv3[1]
00104 );
00105 if (*matz != 0) {
00106 goto L20;
00107 }
00108 /* .......... FIND EIGENVALUES ONLY .......... */
00109 comqr_(nm, n, &is1, &is2, &ar[ar_offset], &ai[ai_offset], &wr[1], &wi[1],
00110 ierr);
00111 goto L50;
00112 /* .......... FIND BOTH EIGENVALUES AND EIGENVECTORS .......... */
00113 L20:
00114 comqr2_(nm, n, &is1, &is2, &fv2[1], &fv3[1], &ar[ar_offset], &ai[
00115 ai_offset], &wr[1], &wi[1], &zr[zr_offset], &zi[zi_offset], ierr);
00116 if (*ierr != 0) {
00117 goto L50;
00118 }
00119 cbabk2_(nm, n, &is1, &is2, &fv1[1], n, &zr[zr_offset], &zi[zi_offset]);
00120 L50:
00121 return 0;
00122 } /* cg_ */
|
|
||||||||||||||||||||||||||||||||||||||||||||||||||||
|
Definition at line 8 of file eis_ch.c. References htribk_(), htridi_(), tql2_(), and tqlrat_().
00011 {
00012 /* System generated locals */
00013 integer ar_dim1, ar_offset, ai_dim1, ai_offset, zr_dim1, zr_offset,
00014 zi_dim1, zi_offset, i__1, i__2;
00015
00016 /* Local variables */
00017 static integer i__, j;
00018 extern /* Subroutine */ int htridi_(integer *, integer *, doublereal *,
00019 doublereal *, doublereal *, doublereal *, doublereal *,
00020 doublereal *), htribk_(integer *, integer *, doublereal *,
00021 doublereal *, doublereal *, integer *, doublereal *, doublereal *)
00022 , tqlrat_(integer *, doublereal *, doublereal *, integer *),
00023 tql2_(integer *, integer *, doublereal *, doublereal *,
00024 doublereal *, integer *);
00025
00026
00027
00028 /* THIS SUBROUTINE CALLS THE RECOMMENDED SEQUENCE OF */
00029 /* SUBROUTINES FROM THE EIGENSYSTEM SUBROUTINE PACKAGE (EISPACK) */
00030 /* TO FIND THE EIGENVALUES AND EIGENVECTORS (IF DESIRED) */
00031 /* OF A COMPLEX HERMITIAN MATRIX. */
00032
00033 /* ON INPUT */
00034
00035 /* NM MUST BE SET TO THE ROW DIMENSION OF THE TWO-DIMENSIONAL */
00036 /* ARRAY PARAMETERS AS DECLARED IN THE CALLING PROGRAM */
00037 /* DIMENSION STATEMENT. */
00038
00039 /* N IS THE ORDER OF THE MATRIX A=(AR,AI). */
00040
00041 /* AR AND AI CONTAIN THE REAL AND IMAGINARY PARTS, */
00042 /* RESPECTIVELY, OF THE COMPLEX HERMITIAN MATRIX. */
00043
00044 /* MATZ IS AN INTEGER VARIABLE SET EQUAL TO ZERO IF */
00045 /* ONLY EIGENVALUES ARE DESIRED. OTHERWISE IT IS SET TO */
00046 /* ANY NON-ZERO INTEGER FOR BOTH EIGENVALUES AND EIGENVECTORS. */
00047
00048 /* ON OUTPUT */
00049
00050 /* W CONTAINS THE EIGENVALUES IN ASCENDING ORDER. */
00051
00052 /* ZR AND ZI CONTAIN THE REAL AND IMAGINARY PARTS, */
00053 /* RESPECTIVELY, OF THE EIGENVECTORS IF MATZ IS NOT ZERO. */
00054
00055 /* IERR IS AN INTEGER OUTPUT VARIABLE SET EQUAL TO AN ERROR */
00056 /* COMPLETION CODE DESCRIBED IN THE DOCUMENTATION FOR TQLRAT */
00057 /* AND TQL2. THE NORMAL COMPLETION CODE IS ZERO. */
00058
00059 /* FV1, FV2, AND FM1 ARE TEMPORARY STORAGE ARRAYS. */
00060
00061 /* QUESTIONS AND COMMENTS SHOULD BE DIRECTED TO BURTON S. GARBOW, */
00062 /* MATHEMATICS AND COMPUTER SCIENCE DIV, ARGONNE NATIONAL LABORATORY
00063 */
00064
00065 /* THIS VERSION DATED AUGUST 1983. */
00066
00067 /* ------------------------------------------------------------------
00068 */
00069
00070 /* Parameter adjustments */
00071 fm1 -= 3;
00072 --fv2;
00073 --fv1;
00074 zi_dim1 = *nm;
00075 zi_offset = zi_dim1 + 1;
00076 zi -= zi_offset;
00077 zr_dim1 = *nm;
00078 zr_offset = zr_dim1 + 1;
00079 zr -= zr_offset;
00080 --w;
00081 ai_dim1 = *nm;
00082 ai_offset = ai_dim1 + 1;
00083 ai -= ai_offset;
00084 ar_dim1 = *nm;
00085 ar_offset = ar_dim1 + 1;
00086 ar -= ar_offset;
00087
00088 /* Function Body */
00089 if (*n <= *nm) {
00090 goto L10;
00091 }
00092 *ierr = *n * 10;
00093 goto L50;
00094
00095 L10:
00096 htridi_(nm, n, &ar[ar_offset], &ai[ai_offset], &w[1], &fv1[1], &fv2[1], &
00097 fm1[3]);
00098 if (*matz != 0) {
00099 goto L20;
00100 }
00101 /* .......... FIND EIGENVALUES ONLY .......... */
00102 tqlrat_(n, &w[1], &fv2[1], ierr);
00103 goto L50;
00104 /* .......... FIND BOTH EIGENVALUES AND EIGENVECTORS .......... */
00105 L20:
00106 i__1 = *n;
00107 for (i__ = 1; i__ <= i__1; ++i__) {
00108
00109 i__2 = *n;
00110 for (j = 1; j <= i__2; ++j) {
00111 zr[j + i__ * zr_dim1] = 0.;
00112 /* L30: */
00113 }
00114
00115 zr[i__ + i__ * zr_dim1] = 1.;
00116 /* L40: */
00117 }
00118
00119 tql2_(nm, n, &w[1], &fv1[1], &zr[zr_offset], ierr);
00120 if (*ierr != 0) {
00121 goto L50;
00122 }
00123 htribk_(nm, n, &ar[ar_offset], &ai[ai_offset], &fm1[3], n, &zr[zr_offset],
00124 &zi[zi_offset]);
00125 L50:
00126 return 0;
00127 } /* ch_ */
|
|
||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||
|
Definition at line 8 of file eis_cinvit.c. References abs, cdiv_(), epslon_(), mp, and pythag_().
00013 {
00014 /* System generated locals */
00015 integer ar_dim1, ar_offset, ai_dim1, ai_offset, zr_dim1, zr_offset,
00016 zi_dim1, zi_offset, rm1_dim1, rm1_offset, rm2_dim1, rm2_offset,
00017 i__1, i__2, i__3;
00018 doublereal d__1, d__2;
00019
00020 /* Builtin functions */
00021 double sqrt(doublereal);
00022
00023 /* Local variables */
00024 extern /* Subroutine */ int cdiv_(doublereal *, doublereal *, doublereal *
00025 , doublereal *, doublereal *, doublereal *);
00026 static doublereal norm;
00027 static integer i__, j, k, s;
00028 static doublereal x, y, normv;
00029 static integer ii;
00030 static doublereal ilambd;
00031 static integer mp, uk;
00032 static doublereal rlambd;
00033 extern doublereal pythag_(doublereal *, doublereal *), epslon_(doublereal
00034 *);
00035 static integer km1, ip1;
00036 static doublereal growto, ukroot;
00037 static integer its;
00038 static doublereal eps3;
00039
00040
00041
00042 /* THIS SUBROUTINE IS A TRANSLATION OF THE ALGOL PROCEDURE CX INVIT */
00043 /* BY PETERS AND WILKINSON. */
00044 /* HANDBOOK FOR AUTO. COMP. VOL.II-LINEAR ALGEBRA, 418-439(1971). */
00045
00046 /* THIS SUBROUTINE FINDS THOSE EIGENVECTORS OF A COMPLEX UPPER */
00047 /* HESSENBERG MATRIX CORRESPONDING TO SPECIFIED EIGENVALUES, */
00048 /* USING INVERSE ITERATION. */
00049
00050 /* ON INPUT */
00051
00052 /* NM MUST BE SET TO THE ROW DIMENSION OF TWO-DIMENSIONAL */
00053 /* ARRAY PARAMETERS AS DECLARED IN THE CALLING PROGRAM */
00054 /* DIMENSION STATEMENT. */
00055
00056 /* N IS THE ORDER OF THE MATRIX. */
00057
00058 /* AR AND AI CONTAIN THE REAL AND IMAGINARY PARTS, */
00059 /* RESPECTIVELY, OF THE HESSENBERG MATRIX. */
00060
00061 /* WR AND WI CONTAIN THE REAL AND IMAGINARY PARTS, RESPECTIVELY, */
00062 /* OF THE EIGENVALUES OF THE MATRIX. THE EIGENVALUES MUST BE */
00063 /* STORED IN A MANNER IDENTICAL TO THAT OF SUBROUTINE COMLR, */
00064 /* WHICH RECOGNIZES POSSIBLE SPLITTING OF THE MATRIX. */
00065
00066 /* SELECT SPECIFIES THE EIGENVECTORS TO BE FOUND. THE */
00067 /* EIGENVECTOR CORRESPONDING TO THE J-TH EIGENVALUE IS */
00068 /* SPECIFIED BY SETTING SELECT(J) TO .TRUE.. */
00069
00070 /* MM SHOULD BE SET TO AN UPPER BOUND FOR THE NUMBER OF */
00071 /* EIGENVECTORS TO BE FOUND. */
00072
00073 /* ON OUTPUT */
00074
00075 /* AR, AI, WI, AND SELECT ARE UNALTERED. */
00076
00077 /* WR MAY HAVE BEEN ALTERED SINCE CLOSE EIGENVALUES ARE PERTURBED
00078 */
00079 /* SLIGHTLY IN SEARCHING FOR INDEPENDENT EIGENVECTORS. */
00080
00081 /* M IS THE NUMBER OF EIGENVECTORS ACTUALLY FOUND. */
00082
00083 /* ZR AND ZI CONTAIN THE REAL AND IMAGINARY PARTS, RESPECTIVELY, */
00084 /* OF THE EIGENVECTORS. THE EIGENVECTORS ARE NORMALIZED */
00085 /* SO THAT THE COMPONENT OF LARGEST MAGNITUDE IS 1. */
00086 /* ANY VECTOR WHICH FAILS THE ACCEPTANCE TEST IS SET TO ZERO. */
00087
00088 /* IERR IS SET TO */
00089 /* ZERO FOR NORMAL RETURN, */
00090 /* -(2*N+1) IF MORE THAN MM EIGENVECTORS HAVE BEEN SPECIFIED,
00091 */
00092 /* -K IF THE ITERATION CORRESPONDING TO THE K-TH */
00093 /* VALUE FAILS, */
00094 /* -(N+K) IF BOTH ERROR SITUATIONS OCCUR. */
00095
00096 /* RM1, RM2, RV1, AND RV2 ARE TEMPORARY STORAGE ARRAYS. */
00097
00098 /* THE ALGOL PROCEDURE GUESSVEC APPEARS IN CINVIT IN LINE. */
00099
00100 /* CALLS CDIV FOR COMPLEX DIVISION. */
00101 /* CALLS PYTHAG FOR DSQRT(A*A + B*B) . */
00102
00103 /* QUESTIONS AND COMMENTS SHOULD BE DIRECTED TO BURTON S. GARBOW, */
00104 /* MATHEMATICS AND COMPUTER SCIENCE DIV, ARGONNE NATIONAL LABORATORY
00105 */
00106
00107 /* THIS VERSION DATED AUGUST 1983. */
00108
00109 /* ------------------------------------------------------------------
00110 */
00111
00112 /* Parameter adjustments */
00113 --rv2;
00114 --rv1;
00115 rm2_dim1 = *n;
00116 rm2_offset = rm2_dim1 + 1;
00117 rm2 -= rm2_offset;
00118 rm1_dim1 = *n;
00119 rm1_offset = rm1_dim1 + 1;
00120 rm1 -= rm1_offset;
00121 --select;
00122 --wi;
00123 --wr;
00124 ai_dim1 = *nm;
00125 ai_offset = ai_dim1 + 1;
00126 ai -= ai_offset;
00127 ar_dim1 = *nm;
00128 ar_offset = ar_dim1 + 1;
00129 ar -= ar_offset;
00130 zi_dim1 = *nm;
00131 zi_offset = zi_dim1 + 1;
00132 zi -= zi_offset;
00133 zr_dim1 = *nm;
00134 zr_offset = zr_dim1 + 1;
00135 zr -= zr_offset;
00136
00137 /* Function Body */
00138 *ierr = 0;
00139 uk = 0;
00140 s = 1;
00141
00142 i__1 = *n;
00143 for (k = 1; k <= i__1; ++k) {
00144 if (! select[k]) {
00145 goto L980;
00146 }
00147 if (s > *mm) {
00148 goto L1000;
00149 }
00150 if (uk >= k) {
00151 goto L200;
00152 }
00153 /* .......... CHECK FOR POSSIBLE SPLITTING .......... */
00154 i__2 = *n;
00155 for (uk = k; uk <= i__2; ++uk) {
00156 if (uk == *n) {
00157 goto L140;
00158 }
00159 if (ar[uk + 1 + uk * ar_dim1] == 0. && ai[uk + 1 + uk * ai_dim1]
00160 == 0.) {
00161 goto L140;
00162 }
00163 /* L120: */
00164 }
00165 /* .......... COMPUTE INFINITY NORM OF LEADING UK BY UK */
00166 /* (HESSENBERG) MATRIX .......... */
00167 L140:
00168 norm = 0.;
00169 mp = 1;
00170
00171 i__2 = uk;
00172 for (i__ = 1; i__ <= i__2; ++i__) {
00173 x = 0.;
00174
00175 i__3 = uk;
00176 for (j = mp; j <= i__3; ++j) {
00177 /* L160: */
00178 x += pythag_(&ar[i__ + j * ar_dim1], &ai[i__ + j * ai_dim1]);
00179 }
00180
00181 if (x > norm) {
00182 norm = x;
00183 }
00184 mp = i__;
00185 /* L180: */
00186 }
00187 /* .......... EPS3 REPLACES ZERO PIVOT IN DECOMPOSITION */
00188 /* AND CLOSE ROOTS ARE MODIFIED BY EPS3 .......... */
00189 if (norm == 0.) {
00190 norm = 1.;
00191 }
00192 eps3 = epslon_(&norm);
00193 /* .......... GROWTO IS THE CRITERION FOR GROWTH .......... */
00194 ukroot = (doublereal) uk;
00195 ukroot = sqrt(ukroot);
00196 growto = .1 / ukroot;
00197 L200:
00198 rlambd = wr[k];
00199 ilambd = wi[k];
00200 if (k == 1) {
00201 goto L280;
00202 }
00203 km1 = k - 1;
00204 goto L240;
00205 /* .......... PERTURB EIGENVALUE IF IT IS CLOSE */
00206 /* TO ANY PREVIOUS EIGENVALUE .......... */
00207 L220:
00208 rlambd += eps3;
00209 /* .......... FOR I=K-1 STEP -1 UNTIL 1 DO -- .......... */
00210 L240:
00211 i__2 = km1;
00212 for (ii = 1; ii <= i__2; ++ii) {
00213 i__ = k - ii;
00214 if (select[i__] && (d__1 = wr[i__] - rlambd, abs(d__1)) < eps3 &&
00215 (d__2 = wi[i__] - ilambd, abs(d__2)) < eps3) {
00216 goto L220;
00217 }
00218 /* L260: */
00219 }
00220
00221 wr[k] = rlambd;
00222 /* .......... FORM UPPER HESSENBERG (AR,AI)-(RLAMBD,ILAMBD)*I */
00223 /* AND INITIAL COMPLEX VECTOR .......... */
00224 L280:
00225 mp = 1;
00226
00227 i__2 = uk;
00228 for (i__ = 1; i__ <= i__2; ++i__) {
00229
00230 i__3 = uk;
00231 for (j = mp; j <= i__3; ++j) {
00232 rm1[i__ + j * rm1_dim1] = ar[i__ + j * ar_dim1];
00233 rm2[i__ + j * rm2_dim1] = ai[i__ + j * ai_dim1];
00234 /* L300: */
00235 }
00236
00237 rm1[i__ + i__ * rm1_dim1] -= rlambd;
00238 rm2[i__ + i__ * rm2_dim1] -= ilambd;
00239 mp = i__;
00240 rv1[i__] = eps3;
00241 /* L320: */
00242 }
00243 /* .......... TRIANGULAR DECOMPOSITION WITH INTERCHANGES, */
00244 /* REPLACING ZERO PIVOTS BY EPS3 .......... */
00245 if (uk == 1) {
00246 goto L420;
00247 }
00248
00249 i__2 = uk;
00250 for (i__ = 2; i__ <= i__2; ++i__) {
00251 mp = i__ - 1;
00252 if (pythag_(&rm1[i__ + mp * rm1_dim1], &rm2[i__ + mp * rm2_dim1])
00253 <= pythag_(&rm1[mp + mp * rm1_dim1], &rm2[mp + mp *
00254 rm2_dim1])) {
00255 goto L360;
00256 }
00257
00258 i__3 = uk;
00259 for (j = mp; j <= i__3; ++j) {
00260 y = rm1[i__ + j * rm1_dim1];
00261 rm1[i__ + j * rm1_dim1] = rm1[mp + j * rm1_dim1];
00262 rm1[mp + j * rm1_dim1] = y;
00263 y = rm2[i__ + j * rm2_dim1];
00264 rm2[i__ + j * rm2_dim1] = rm2[mp + j * rm2_dim1];
00265 rm2[mp + j * rm2_dim1] = y;
00266 /* L340: */
00267 }
00268
00269 L360:
00270 if (rm1[mp + mp * rm1_dim1] == 0. && rm2[mp + mp * rm2_dim1] ==
00271 0.) {
00272 rm1[mp + mp * rm1_dim1] = eps3;
00273 }
00274 cdiv_(&rm1[i__ + mp * rm1_dim1], &rm2[i__ + mp * rm2_dim1], &rm1[
00275 mp + mp * rm1_dim1], &rm2[mp + mp * rm2_dim1], &x, &y);
00276 if (x == 0. && y == 0.) {
00277 goto L400;
00278 }
00279
00280 i__3 = uk;
00281 for (j = i__; j <= i__3; ++j) {
00282 rm1[i__ + j * rm1_dim1] = rm1[i__ + j * rm1_dim1] - x * rm1[
00283 mp + j * rm1_dim1] + y * rm2[mp + j * rm2_dim1];
00284 rm2[i__ + j * rm2_dim1] = rm2[i__ + j * rm2_dim1] - x * rm2[
00285 mp + j * rm2_dim1] - y * rm1[mp + j * rm1_dim1];
00286 /* L380: */
00287 }
00288
00289 L400:
00290 ;
00291 }
00292
00293 L420:
00294 if (rm1[uk + uk * rm1_dim1] == 0. && rm2[uk + uk * rm2_dim1] == 0.) {
00295 rm1[uk + uk * rm1_dim1] = eps3;
00296 }
00297 its = 0;
00298 /* .......... BACK SUBSTITUTION */
00299 /* FOR I=UK STEP -1 UNTIL 1 DO -- .......... */
00300 L660:
00301 i__2 = uk;
00302 for (ii = 1; ii <= i__2; ++ii) {
00303 i__ = uk + 1 - ii;
00304 x = rv1[i__];
00305 y = 0.;
00306 if (i__ == uk) {
00307 goto L700;
00308 }
00309 ip1 = i__ + 1;
00310
00311 i__3 = uk;
00312 for (j = ip1; j <= i__3; ++j) {
00313 x = x - rm1[i__ + j * rm1_dim1] * rv1[j] + rm2[i__ + j *
00314 rm2_dim1] * rv2[j];
00315 y = y - rm1[i__ + j * rm1_dim1] * rv2[j] - rm2[i__ + j *
00316 rm2_dim1] * rv1[j];
00317 /* L680: */
00318 }
00319
00320 L700:
00321 cdiv_(&x, &y, &rm1[i__ + i__ * rm1_dim1], &rm2[i__ + i__ *
00322 rm2_dim1], &rv1[i__], &rv2[i__]);
00323 /* L720: */
00324 }
00325 /* .......... ACCEPTANCE TEST FOR EIGENVECTOR */
00326 /* AND NORMALIZATION .......... */
00327 ++its;
00328 norm = 0.;
00329 normv = 0.;
00330
00331 i__2 = uk;
00332 for (i__ = 1; i__ <= i__2; ++i__) {
00333 x = pythag_(&rv1[i__], &rv2[i__]);
00334 if (normv >= x) {
00335 goto L760;
00336 }
00337 normv = x;
00338 j = i__;
00339 L760:
00340 norm += x;
00341 /* L780: */
00342 }
00343
00344 if (norm < growto) {
00345 goto L840;
00346 }
00347 /* .......... ACCEPT VECTOR .......... */
00348 x = rv1[j];
00349 y = rv2[j];
00350
00351 i__2 = uk;
00352 for (i__ = 1; i__ <= i__2; ++i__) {
00353 cdiv_(&rv1[i__], &rv2[i__], &x, &y, &zr[i__ + s * zr_dim1], &zi[
00354 i__ + s * zi_dim1]);
00355 /* L820: */
00356 }
00357
00358 if (uk == *n) {
00359 goto L940;
00360 }
00361 j = uk + 1;
00362 goto L900;
00363 /* .......... IN-LINE PROCEDURE FOR CHOOSING */
00364 /* A NEW STARTING VECTOR .......... */
00365 L840:
00366 if (its >= uk) {
00367 goto L880;
00368 }
00369 x = ukroot;
00370 y = eps3 / (x + 1.);
00371 rv1[1] = eps3;
00372
00373 i__2 = uk;
00374 for (i__ = 2; i__ <= i__2; ++i__) {
00375 /* L860: */
00376 rv1[i__] = y;
00377 }
00378
00379 j = uk - its + 1;
00380 rv1[j] -= eps3 * x;
00381 goto L660;
00382 /* .......... SET ERROR -- UNACCEPTED EIGENVECTOR .......... */
00383 L880:
00384 j = 1;
00385 *ierr = -k;
00386 /* .......... SET REMAINING VECTOR COMPONENTS TO ZERO ..........
00387 */
00388 L900:
00389 i__2 = *n;
00390 for (i__ = j; i__ <= i__2; ++i__) {
00391 zr[i__ + s * zr_dim1] = 0.;
00392 zi[i__ + s * zi_dim1] = 0.;
00393 /* L920: */
00394 }
00395
00396 L940:
00397 ++s;
00398 L980:
00399 ;
00400 }
00401
00402 goto L1001;
00403 /* .......... SET ERROR -- UNDERESTIMATE OF EIGENVECTOR */
00404 /* SPACE REQUIRED .......... */
00405 L1000:
00406 if (*ierr != 0) {
00407 *ierr -= *n;
00408 }
00409 if (*ierr == 0) {
00410 *ierr = -((*n << 1) + 1);
00411 }
00412 L1001:
00413 *m = s - 1;
00414 return 0;
00415 } /* cinvit_ */
|
|
||||||||||||||||||||||||||||||||||||||||
|
Definition at line 8 of file eis_combak.c. References mp.
00011 {
00012 /* System generated locals */
00013 integer ar_dim1, ar_offset, ai_dim1, ai_offset, zr_dim1, zr_offset,
00014 zi_dim1, zi_offset, i__1, i__2, i__3;
00015
00016 /* Local variables */
00017 static integer i__, j, la, mm, mp;
00018 static doublereal xi, xr;
00019 static integer kp1, mp1;
00020
00021
00022
00023 /* THIS SUBROUTINE IS A TRANSLATION OF THE ALGOL PROCEDURE COMBAK, */
00024 /* NUM. MATH. 12, 349-368(1968) BY MARTIN AND WILKINSON. */
00025 /* HANDBOOK FOR AUTO. COMP., VOL.II-LINEAR ALGEBRA, 339-358(1971). */
00026
00027 /* THIS SUBROUTINE FORMS THE EIGENVECTORS OF A COMPLEX GENERAL */
00028 /* MATRIX BY BACK TRANSFORMING THOSE OF THE CORRESPONDING */
00029 /* UPPER HESSENBERG MATRIX DETERMINED BY COMHES. */
00030
00031 /* ON INPUT */
00032
00033 /* NM MUST BE SET TO THE ROW DIMENSION OF TWO-DIMENSIONAL */
00034 /* ARRAY PARAMETERS AS DECLARED IN THE CALLING PROGRAM */
00035 /* DIMENSION STATEMENT. */
00036
00037 /* LOW AND IGH ARE INTEGERS DETERMINED BY THE BALANCING */
00038 /* SUBROUTINE CBAL. IF CBAL HAS NOT BEEN USED, */
00039 /* SET LOW=1 AND IGH EQUAL TO THE ORDER OF THE MATRIX. */
00040
00041 /* AR AND AI CONTAIN THE MULTIPLIERS WHICH WERE USED IN THE */
00042 /* REDUCTION BY COMHES IN THEIR LOWER TRIANGLES */
00043 /* BELOW THE SUBDIAGONAL. */
00044
00045 /* INT CONTAINS INFORMATION ON THE ROWS AND COLUMNS */
00046 /* INTERCHANGED IN THE REDUCTION BY COMHES. */
00047 /* ONLY ELEMENTS LOW THROUGH IGH ARE USED. */
00048
00049 /* M IS THE NUMBER OF EIGENVECTORS TO BE BACK TRANSFORMED. */
00050
00051 /* ZR AND ZI CONTAIN THE REAL AND IMAGINARY PARTS, */
00052 /* RESPECTIVELY, OF THE EIGENVECTORS TO BE */
00053 /* BACK TRANSFORMED IN THEIR FIRST M COLUMNS. */
00054
00055 /* ON OUTPUT */
00056
00057 /* ZR AND ZI CONTAIN THE REAL AND IMAGINARY PARTS, */
00058 /* RESPECTIVELY, OF THE TRANSFORMED EIGENVECTORS */
00059 /* IN THEIR FIRST M COLUMNS. */
00060
00061 /* QUESTIONS AND COMMENTS SHOULD BE DIRECTED TO BURTON S. GARBOW, */
00062 /* MATHEMATICS AND COMPUTER SCIENCE DIV, ARGONNE NATIONAL LABORATORY
00063 */
00064
00065 /* THIS VERSION DATED AUGUST 1983. */
00066
00067 /* ------------------------------------------------------------------
00068 */
00069
00070 /* Parameter adjustments */
00071 --int__;
00072 ai_dim1 = *nm;
00073 ai_offset = ai_dim1 + 1;
00074 ai -= ai_offset;
00075 ar_dim1 = *nm;
00076 ar_offset = ar_dim1 + 1;
00077 ar -= ar_offset;
00078 zi_dim1 = *nm;
00079 zi_offset = zi_dim1 + 1;
00080 zi -= zi_offset;
00081 zr_dim1 = *nm;
00082 zr_offset = zr_dim1 + 1;
00083 zr -= zr_offset;
00084
00085 /* Function Body */
00086 if (*m == 0) {
00087 goto L200;
00088 }
00089 la = *igh - 1;
00090 kp1 = *low + 1;
00091 if (la < kp1) {
00092 goto L200;
00093 }
00094 /* .......... FOR MP=IGH-1 STEP -1 UNTIL LOW+1 DO -- .......... */
00095 i__1 = la;
00096 for (mm = kp1; mm <= i__1; ++mm) {
00097 mp = *low + *igh - mm;
00098 mp1 = mp + 1;
00099
00100 i__2 = *igh;
00101 for (i__ = mp1; i__ <= i__2; ++i__) {
00102 xr = ar[i__ + (mp - 1) * ar_dim1];
00103 xi = ai[i__ + (mp - 1) * ai_dim1];
00104 if (xr == 0. && xi == 0.) {
00105 goto L110;
00106 }
00107
00108 i__3 = *m;
00109 for (j = 1; j <= i__3; ++j) {
00110 zr[i__ + j * zr_dim1] = zr[i__ + j * zr_dim1] + xr * zr[mp +
00111 j * zr_dim1] - xi * zi[mp + j * zi_dim1];
00112 zi[i__ + j * zi_dim1] = zi[i__ + j * zi_dim1] + xr * zi[mp +
00113 j * zi_dim1] + xi * zr[mp + j * zr_dim1];
00114 /* L100: */
00115 }
00116
00117 L110:
00118 ;
00119 }
00120
00121 i__ = int__[mp];
00122 if (i__ == mp) {
00123 goto L140;
00124 }
00125
00126 i__2 = *m;
00127 for (j = 1; j <= i__2; ++j) {
00128 xr = zr[i__ + j * zr_dim1];
00129 zr[i__ + j * zr_dim1] = zr[mp + j * zr_dim1];
00130 zr[mp + j * zr_dim1] = xr;
00131 xi = zi[i__ + j * zi_dim1];
00132 zi[i__ + j * zi_dim1] = zi[mp + j * zi_dim1];
00133 zi[mp + j * zi_dim1] = xi;
00134 /* L130: */
00135 }
00136
00137 L140:
00138 ;
00139 }
00140
00141 L200:
00142 return 0;
00143 } /* combak_ */
|
|
||||||||||||||||||||||||||||||||
|
Definition at line 8 of file eis_comhes.c.
00010 {
00011 /* System generated locals */
00012 integer ar_dim1, ar_offset, ai_dim1, ai_offset, i__1, i__2, i__3;
00013 doublereal d__1, d__2;
00014
00015 /* Local variables */
00016 extern /* Subroutine */ int cdiv_(doublereal *, doublereal *, doublereal *
00017 , doublereal *, doublereal *, doublereal *);
00018 static integer i__, j, m, la;
00019 static doublereal xi, yi, xr, yr;
00020 static integer mm1, kp1, mp1;
00021
00022
00023
00024 /* THIS SUBROUTINE IS A TRANSLATION OF THE ALGOL PROCEDURE COMHES, */
00025 /* NUM. MATH. 12, 349-368(1968) BY MARTIN AND WILKINSON. */
00026 /* HANDBOOK FOR AUTO. COMP., VOL.II-LINEAR ALGEBRA, 339-358(1971). */
00027
00028 /* GIVEN A COMPLEX GENERAL MATRIX, THIS SUBROUTINE */
00029 /* REDUCES A SUBMATRIX SITUATED IN ROWS AND COLUMNS */
00030 /* LOW THROUGH IGH TO UPPER HESSENBERG FORM BY */
00031 /* STABILIZED ELEMENTARY SIMILARITY TRANSFORMATIONS. */
00032
00033 /* ON INPUT */
00034
00035 /* NM MUST BE SET TO THE ROW DIMENSION OF TWO-DIMENSIONAL */
00036 /* ARRAY PARAMETERS AS DECLARED IN THE CALLING PROGRAM */
00037 /* DIMENSION STATEMENT. */
00038
00039 /* N IS THE ORDER OF THE MATRIX. */
00040
00041 /* LOW AND IGH ARE INTEGERS DETERMINED BY THE BALANCING */
00042 /* SUBROUTINE CBAL. IF CBAL HAS NOT BEEN USED, */
00043 /* SET LOW=1, IGH=N. */
00044
00045 /* AR AND AI CONTAIN THE REAL AND IMAGINARY PARTS, */
00046 /* RESPECTIVELY, OF THE COMPLEX INPUT MATRIX. */
00047
00048 /* ON OUTPUT */
00049
00050 /* AR AND AI CONTAIN THE REAL AND IMAGINARY PARTS, */
00051 /* RESPECTIVELY, OF THE HESSENBERG MATRIX. THE */
00052 /* MULTIPLIERS WHICH WERE USED IN THE REDUCTION */
00053 /* ARE STORED IN THE REMAINING TRIANGLES UNDER THE */
00054 /* HESSENBERG MATRIX. */
00055
00056 /* INT CONTAINS INFORMATION ON THE ROWS AND COLUMNS */
00057 /* INTERCHANGED IN THE REDUCTION. */
00058 /* ONLY ELEMENTS LOW THROUGH IGH ARE USED. */
00059
00060 /* CALLS CDIV FOR COMPLEX DIVISION. */
00061
00062 /* QUESTIONS AND COMMENTS SHOULD BE DIRECTED TO BURTON S. GARBOW, */
00063 /* MATHEMATICS AND COMPUTER SCIENCE DIV, ARGONNE NATIONAL LABORATORY
00064 */
00065
00066 /* THIS VERSION DATED AUGUST 1983. */
00067
00068 /* ------------------------------------------------------------------
00069 */
00070
00071 /* Parameter adjustments */
00072 ai_dim1 = *nm;
00073 ai_offset = ai_dim1 + 1;
00074 ai -= ai_offset;
00075 ar_dim1 = *nm;
00076 ar_offset = ar_dim1 + 1;
00077 ar -= ar_offset;
00078 --int__;
00079
00080 /* Function Body */
00081 la = *igh - 1;
00082 kp1 = *low + 1;
00083 if (la < kp1) {
00084 goto L200;
00085 }
00086
00087 i__1 = la;
00088 for (m = kp1; m <= i__1; ++m) {
00089 mm1 = m - 1;
00090 xr = 0.;
00091 xi = 0.;
00092 i__ = m;
00093
00094 i__2 = *igh;
00095 for (j = m; j <= i__2; ++j) {
00096 if ((d__1 = ar[j + mm1 * ar_dim1], abs(d__1)) + (d__2 = ai[j +
00097 mm1 * ai_dim1], abs(d__2)) <= abs(xr) + abs(xi)) {
00098 goto L100;
00099 }
00100 xr = ar[j + mm1 * ar_dim1];
00101 xi = ai[j + mm1 * ai_dim1];
00102 i__ = j;
00103 L100:
00104 ;
00105 }
00106
00107 int__[m] = i__;
00108 if (i__ == m) {
00109 goto L130;
00110 }
00111 /* .......... INTERCHANGE ROWS AND COLUMNS OF AR AND AI ..........
00112 */
00113 i__2 = *n;
00114 for (j = mm1; j <= i__2; ++j) {
00115 yr = ar[i__ + j * ar_dim1];
00116 ar[i__ + j * ar_dim1] = ar[m + j * ar_dim1];
00117 ar[m + j * ar_dim1] = yr;
00118 yi = ai[i__ + j * ai_dim1];
00119 ai[i__ + j * ai_dim1] = ai[m + j * ai_dim1];
00120 ai[m + j * ai_dim1] = yi;
00121 /* L110: */
00122 }
00123
00124 i__2 = *igh;
00125 for (j = 1; j <= i__2; ++j) {
00126 yr = ar[j + i__ * ar_dim1];
00127 ar[j + i__ * ar_dim1] = ar[j + m * ar_dim1];
00128 ar[j + m * ar_dim1] = yr;
00129 yi = ai[j + i__ * ai_dim1];
00130 ai[j + i__ * ai_dim1] = ai[j + m * ai_dim1];
00131 ai[j + m * ai_dim1] = yi;
00132 /* L120: */
00133 }
00134 /* .......... END INTERCHANGE .......... */
00135 L130:
00136 if (xr == 0. && xi == 0.) {
00137 goto L180;
00138 }
00139 mp1 = m + 1;
00140
00141 i__2 = *igh;
00142 for (i__ = mp1; i__ <= i__2; ++i__) {
00143 yr = ar[i__ + mm1 * ar_dim1];
00144 yi = ai[i__ + mm1 * ai_dim1];
00145 if (yr == 0. && yi == 0.) {
00146 goto L160;
00147 }
00148 cdiv_(&yr, &yi, &xr, &xi, &yr, &yi);
00149 ar[i__ + mm1 * ar_dim1] = yr;
00150 ai[i__ + mm1 * ai_dim1] = yi;
00151
00152 i__3 = *n;
00153 for (j = m; j <= i__3; ++j) {
00154 ar[i__ + j * ar_dim1] = ar[i__ + j * ar_dim1] - yr * ar[m + j
00155 * ar_dim1] + yi * ai[m + j * ai_dim1];
00156 ai[i__ + j * ai_dim1] = ai[i__ + j * ai_dim1] - yr * ai[m + j
00157 * ai_dim1] - yi * ar[m + j * ar_dim1];
00158 /* L140: */
00159 }
00160
00161 i__3 = *igh;
00162 for (j = 1; j <= i__3; ++j) {
00163 ar[j + m * ar_dim1] = ar[j + m * ar_dim1] + yr * ar[j + i__ *
00164 ar_dim1] - yi * ai[j + i__ * ai_dim1];
00165 ai[j + m * ai_dim1] = ai[j + m * ai_dim1] + yr * ai[j + i__ *
00166 ai_dim1] + yi * ar[j + i__ * ar_dim1];
00167 /* L150: */
00168 }
00169
00170 L160:
00171 ;
00172 }
00173
00174 L180:
00175 ;
00176 }
00177
00178 L200:
00179 return 0;
00180 } /* comhes_ */
|
|
||||||||||||||||||||||||||||||||||||||||||||||||||||
|
Definition at line 8 of file eis_comlr2.c. References abs, cdiv_(), csroot_(), l, and min.
00011 {
00012 /* System generated locals */
00013 integer hr_dim1, hr_offset, hi_dim1, hi_offset, zr_dim1, zr_offset,
00014 zi_dim1, zi_offset, i__1, i__2, i__3;
00015 doublereal d__1, d__2, d__3, d__4;
00016
00017 /* Local variables */
00018 static integer iend;
00019 extern /* Subroutine */ int cdiv_(doublereal *, doublereal *, doublereal *
00020 , doublereal *, doublereal *, doublereal *);
00021 static doublereal norm;
00022 static integer i__, j, k, l, m, ii, en, jj, ll, mm, nn;
00023 static doublereal si, ti, xi, yi, sr, tr, xr, yr;
00024 static integer im1;
00025 extern /* Subroutine */ int csroot_(doublereal *, doublereal *,
00026 doublereal *, doublereal *);
00027 static integer ip1, mp1, itn, its;
00028 static doublereal zzi, zzr;
00029 static integer enm1;
00030 static doublereal tst1, tst2;
00031
00032
00033
00034 /* THIS SUBROUTINE IS A TRANSLATION OF THE ALGOL PROCEDURE COMLR2, */
00035 /* NUM. MATH. 16, 181-204(1970) BY PETERS AND WILKINSON. */
00036 /* HANDBOOK FOR AUTO. COMP., VOL.II-LINEAR ALGEBRA, 372-395(1971). */
00037
00038 /* THIS SUBROUTINE FINDS THE EIGENVALUES AND EIGENVECTORS */
00039 /* OF A COMPLEX UPPER HESSENBERG MATRIX BY THE MODIFIED LR */
00040 /* METHOD. THE EIGENVECTORS OF A COMPLEX GENERAL MATRIX */
00041 /* CAN ALSO BE FOUND IF COMHES HAS BEEN USED TO REDUCE */
00042 /* THIS GENERAL MATRIX TO HESSENBERG FORM. */
00043
00044 /* ON INPUT */
00045
00046 /* NM MUST BE SET TO THE ROW DIMENSION OF TWO-DIMENSIONAL */
00047 /* ARRAY PARAMETERS AS DECLARED IN THE CALLING PROGRAM */
00048 /* DIMENSION STATEMENT. */
00049
00050 /* N IS THE ORDER OF THE MATRIX. */
00051
00052 /* LOW AND IGH ARE INTEGERS DETERMINED BY THE BALANCING */
00053 /* SUBROUTINE CBAL. IF CBAL HAS NOT BEEN USED, */
00054 /* SET LOW=1, IGH=N. */
00055
00056 /* INT CONTAINS INFORMATION ON THE ROWS AND COLUMNS INTERCHANGED */
00057 /* IN THE REDUCTION BY COMHES, IF PERFORMED. ONLY ELEMENTS */
00058 /* LOW THROUGH IGH ARE USED. IF THE EIGENVECTORS OF THE HESSEN-
00059 */
00060 /* BERG MATRIX ARE DESIRED, SET INT(J)=J FOR THESE ELEMENTS. */
00061
00062 /* HR AND HI CONTAIN THE REAL AND IMAGINARY PARTS, */
00063 /* RESPECTIVELY, OF THE COMPLEX UPPER HESSENBERG MATRIX. */
00064 /* THEIR LOWER TRIANGLES BELOW THE SUBDIAGONAL CONTAIN THE */
00065 /* MULTIPLIERS WHICH WERE USED IN THE REDUCTION BY COMHES, */
00066 /* IF PERFORMED. IF THE EIGENVECTORS OF THE HESSENBERG */
00067 /* MATRIX ARE DESIRED, THESE ELEMENTS MUST BE SET TO ZERO. */
00068
00069 /* ON OUTPUT */
00070
00071 /* THE UPPER HESSENBERG PORTIONS OF HR AND HI HAVE BEEN */
00072 /* DESTROYED, BUT THE LOCATION HR(1,1) CONTAINS THE NORM */
00073 /* OF THE TRIANGULARIZED MATRIX. */
00074
00075 /* WR AND WI CONTAIN THE REAL AND IMAGINARY PARTS, */
00076 /* RESPECTIVELY, OF THE EIGENVALUES. IF AN ERROR */
00077 /* EXIT IS MADE, THE EIGENVALUES SHOULD BE CORRECT */
00078 /* FOR INDICES IERR+1,...,N. */
00079
00080 /* ZR AND ZI CONTAIN THE REAL AND IMAGINARY PARTS, */
00081 /* RESPECTIVELY, OF THE EIGENVECTORS. THE EIGENVECTORS */
00082 /* ARE UNNORMALIZED. IF AN ERROR EXIT IS MADE, NONE OF */
00083 /* THE EIGENVECTORS HAS BEEN FOUND. */
00084
00085 /* IERR IS SET TO */
00086 /* ZERO FOR NORMAL RETURN, */
00087 /* J IF THE LIMIT OF 30*N ITERATIONS IS EXHAUSTED */
00088 /* WHILE THE J-TH EIGENVALUE IS BEING SOUGHT. */
00089
00090
00091 /* CALLS CDIV FOR COMPLEX DIVISION. */
00092 /* CALLS CSROOT FOR COMPLEX SQUARE ROOT. */
00093
00094 /* QUESTIONS AND COMMENTS SHOULD BE DIRECTED TO BURTON S. GARBOW, */
00095 /* MATHEMATICS AND COMPUTER SCIENCE DIV, ARGONNE NATIONAL LABORATORY
00096 */
00097
00098 /* THIS VERSION DATED AUGUST 1983. */
00099
00100 /* ------------------------------------------------------------------
00101 */
00102
00103 /* Parameter adjustments */
00104 zi_dim1 = *nm;
00105 zi_offset = zi_dim1 + 1;
00106 zi -= zi_offset;
00107 zr_dim1 = *nm;
00108 zr_offset = zr_dim1 + 1;
00109 zr -= zr_offset;
00110 --wi;
00111 --wr;
00112 hi_dim1 = *nm;
00113 hi_offset = hi_dim1 + 1;
00114 hi -= hi_offset;
00115 hr_dim1 = *nm;
00116 hr_offset = hr_dim1 + 1;
00117 hr -= hr_offset;
00118 --int__;
00119
00120 /* Function Body */
00121 *ierr = 0;
00122 /* .......... INITIALIZE EIGENVECTOR MATRIX .......... */
00123 i__1 = *n;
00124 for (i__ = 1; i__ <= i__1; ++i__) {
00125
00126 i__2 = *n;
00127 for (j = 1; j <= i__2; ++j) {
00128 zr[i__ + j * zr_dim1] = 0.;
00129 zi[i__ + j * zi_dim1] = 0.;
00130 if (i__ == j) {
00131 zr[i__ + j * zr_dim1] = 1.;
00132 }
00133 /* L100: */
00134 }
00135 }
00136 /* .......... FORM THE MATRIX OF ACCUMULATED TRANSFORMATIONS */
00137 /* FROM THE INFORMATION LEFT BY COMHES .......... */
00138 iend = *igh - *low - 1;
00139 if (iend <= 0) {
00140 goto L180;
00141 }
00142 /* .......... FOR I=IGH-1 STEP -1 UNTIL LOW+1 DO -- .......... */
00143 i__2 = iend;
00144 for (ii = 1; ii <= i__2; ++ii) {
00145 i__ = *igh - ii;
00146 ip1 = i__ + 1;
00147
00148 i__1 = *igh;
00149 for (k = ip1; k <= i__1; ++k) {
00150 zr[k + i__ * zr_dim1] = hr[k + (i__ - 1) * hr_dim1];
00151 zi[k + i__ * zi_dim1] = hi[k + (i__ - 1) * hi_dim1];
00152 /* L120: */
00153 }
00154
00155 j = int__[i__];
00156 if (i__ == j) {
00157 goto L160;
00158 }
00159
00160 i__1 = *igh;
00161 for (k = i__; k <= i__1; ++k) {
00162 zr[i__ + k * zr_dim1] = zr[j + k * zr_dim1];
00163 zi[i__ + k * zi_dim1] = zi[j + k * zi_dim1];
00164 zr[j + k * zr_dim1] = 0.;
00165 zi[j + k * zi_dim1] = 0.;
00166 /* L140: */
00167 }
00168
00169 zr[j + i__ * zr_dim1] = 1.;
00170 L160:
00171 ;
00172 }
00173 /* .......... STORE ROOTS ISOLATED BY CBAL .......... */
00174 L180:
00175 i__2 = *n;
00176 for (i__ = 1; i__ <= i__2; ++i__) {
00177 if (i__ >= *low && i__ <= *igh) {
00178 goto L200;
00179 }
00180 wr[i__] = hr[i__ + i__ * hr_dim1];
00181 wi[i__] = hi[i__ + i__ * hi_dim1];
00182 L200:
00183 ;
00184 }
00185
00186 en = *igh;
00187 tr = 0.;
00188 ti = 0.;
00189 itn = *n * 30;
00190 /* .......... SEARCH FOR NEXT EIGENVALUE .......... */
00191 L220:
00192 if (en < *low) {
00193 goto L680;
00194 }
00195 its = 0;
00196 enm1 = en - 1;
00197 /* .......... LOOK FOR SINGLE SMALL SUB-DIAGONAL ELEMENT */
00198 /* FOR L=EN STEP -1 UNTIL LOW DO -- .......... */
00199 L240:
00200 i__2 = en;
00201 for (ll = *low; ll <= i__2; ++ll) {
00202 l = en + *low - ll;
00203 if (l == *low) {
00204 goto L300;
00205 }
00206 tst1 = (d__1 = hr[l - 1 + (l - 1) * hr_dim1], abs(d__1)) + (d__2 = hi[
00207 l - 1 + (l - 1) * hi_dim1], abs(d__2)) + (d__3 = hr[l + l *
00208 hr_dim1], abs(d__3)) + (d__4 = hi[l + l * hi_dim1], abs(d__4))
00209 ;
00210 tst2 = tst1 + (d__1 = hr[l + (l - 1) * hr_dim1], abs(d__1)) + (d__2 =
00211 hi[l + (l - 1) * hi_dim1], abs(d__2));
00212 if (tst2 == tst1) {
00213 goto L300;
00214 }
00215 /* L260: */
00216 }
00217 /* .......... FORM SHIFT .......... */
00218 L300:
00219 if (l == en) {
00220 goto L660;
00221 }
00222 if (itn == 0) {
00223 goto L1000;
00224 }
00225 if (its == 10 || its == 20) {
00226 goto L320;
00227 }
00228 sr = hr[en + en * hr_dim1];
00229 si = hi[en + en * hi_dim1];
00230 xr = hr[enm1 + en * hr_dim1] * hr[en + enm1 * hr_dim1] - hi[enm1 + en *
00231 hi_dim1] * hi[en + enm1 * hi_dim1];
00232 xi = hr[enm1 + en * hr_dim1] * hi[en + enm1 * hi_dim1] + hi[enm1 + en *
00233 hi_dim1] * hr[en + enm1 * hr_dim1];
00234 if (xr == 0. && xi == 0.) {
00235 goto L340;
00236 }
00237 yr = (hr[enm1 + enm1 * hr_dim1] - sr) / 2.;
00238 yi = (hi[enm1 + enm1 * hi_dim1] - si) / 2.;
00239 /* Computing 2nd power */
00240 d__2 = yr;
00241 /* Computing 2nd power */
00242 d__3 = yi;
00243 d__1 = d__2 * d__2 - d__3 * d__3 + xr;
00244 d__4 = yr * 2. * yi + xi;
00245 csroot_(&d__1, &d__4, &zzr, &zzi);
00246 if (yr * zzr + yi * zzi >= 0.) {
00247 goto L310;
00248 }
00249 zzr = -zzr;
00250 zzi = -zzi;
00251 L310:
00252 d__1 = yr + zzr;
00253 d__2 = yi + zzi;
00254 cdiv_(&xr, &xi, &d__1, &d__2, &xr, &xi);
00255 sr -= xr;
00256 si -= xi;
00257 goto L340;
00258 /* .......... FORM EXCEPTIONAL SHIFT .......... */
00259 L320:
00260 sr = (d__1 = hr[en + enm1 * hr_dim1], abs(d__1)) + (d__2 = hr[enm1 + (en
00261 - 2) * hr_dim1], abs(d__2));
00262 si = (d__1 = hi[en + enm1 * hi_dim1], abs(d__1)) + (d__2 = hi[enm1 + (en
00263 - 2) * hi_dim1], abs(d__2));
00264
00265 L340:
00266 i__2 = en;
00267 for (i__ = *low; i__ <= i__2; ++i__) {
00268 hr[i__ + i__ * hr_dim1] -= sr;
00269 hi[i__ + i__ * hi_dim1] -= si;
00270 /* L360: */
00271 }
00272
00273 tr += sr;
00274 ti += si;
00275 ++its;
00276 --itn;
00277 /* .......... LOOK FOR TWO CONSECUTIVE SMALL */
00278 /* SUB-DIAGONAL ELEMENTS .......... */
00279 xr = (d__1 = hr[enm1 + enm1 * hr_dim1], abs(d__1)) + (d__2 = hi[enm1 +
00280 enm1 * hi_dim1], abs(d__2));
00281 yr = (d__1 = hr[en + enm1 * hr_dim1], abs(d__1)) + (d__2 = hi[en + enm1 *
00282 hi_dim1], abs(d__2));
00283 zzr = (d__1 = hr[en + en * hr_dim1], abs(d__1)) + (d__2 = hi[en + en *
00284 hi_dim1], abs(d__2));
00285 /* .......... FOR M=EN-1 STEP -1 UNTIL L DO -- .......... */
00286 i__2 = enm1;
00287 for (mm = l; mm <= i__2; ++mm) {
00288 m = enm1 + l - mm;
00289 if (m == l) {
00290 goto L420;
00291 }
00292 yi = yr;
00293 yr = (d__1 = hr[m + (m - 1) * hr_dim1], abs(d__1)) + (d__2 = hi[m + (
00294 m - 1) * hi_dim1], abs(d__2));
00295 xi = zzr;
00296 zzr = xr;
00297 xr = (d__1 = hr[m - 1 + (m - 1) * hr_dim1], abs(d__1)) + (d__2 = hi[m
00298 - 1 + (m - 1) * hi_dim1], abs(d__2));
00299 tst1 = zzr / yi * (zzr + xr + xi);
00300 tst2 = tst1 + yr;
00301 if (tst2 == tst1) {
00302 goto L420;
00303 }
00304 /* L380: */
00305 }
00306 /* .......... TRIANGULAR DECOMPOSITION H=L*R .......... */
00307 L420:
00308 mp1 = m + 1;
00309
00310 i__2 = en;
00311 for (i__ = mp1; i__ <= i__2; ++i__) {
00312 im1 = i__ - 1;
00313 xr = hr[im1 + im1 * hr_dim1];
00314 xi = hi[im1 + im1 * hi_dim1];
00315 yr = hr[i__ + im1 * hr_dim1];
00316 yi = hi[i__ + im1 * hi_dim1];
00317 if (abs(xr) + abs(xi) >= abs(yr) + abs(yi)) {
00318 goto L460;
00319 }
00320 /* .......... INTERCHANGE ROWS OF HR AND HI .......... */
00321 i__1 = *n;
00322 for (j = im1; j <= i__1; ++j) {
00323 zzr = hr[im1 + j * hr_dim1];
00324 hr[im1 + j * hr_dim1] = hr[i__ + j * hr_dim1];
00325 hr[i__ + j * hr_dim1] = zzr;
00326 zzi = hi[im1 + j * hi_dim1];
00327 hi[im1 + j * hi_dim1] = hi[i__ + j * hi_dim1];
00328 hi[i__ + j * hi_dim1] = zzi;
00329 /* L440: */
00330 }
00331
00332 cdiv_(&xr, &xi, &yr, &yi, &zzr, &zzi);
00333 wr[i__] = 1.;
00334 goto L480;
00335 L460:
00336 cdiv_(&yr, &yi, &xr, &xi, &zzr, &zzi);
00337 wr[i__] = -1.;
00338 L480:
00339 hr[i__ + im1 * hr_dim1] = zzr;
00340 hi[i__ + im1 * hi_dim1] = zzi;
00341
00342 i__1 = *n;
00343 for (j = i__; j <= i__1; ++j) {
00344 hr[i__ + j * hr_dim1] = hr[i__ + j * hr_dim1] - zzr * hr[im1 + j *
00345 hr_dim1] + zzi * hi[im1 + j * hi_dim1];
00346 hi[i__ + j * hi_dim1] = hi[i__ + j * hi_dim1] - zzr * hi[im1 + j *
00347 hi_dim1] - zzi * hr[im1 + j * hr_dim1];
00348 /* L500: */
00349 }
00350
00351 /* L520: */
00352 }
00353 /* .......... COMPOSITION R*L=H .......... */
00354 i__2 = en;
00355 for (j = mp1; j <= i__2; ++j) {
00356 xr = hr[j + (j - 1) * hr_dim1];
00357 xi = hi[j + (j - 1) * hi_dim1];
00358 hr[j + (j - 1) * hr_dim1] = 0.;
00359 hi[j + (j - 1) * hi_dim1] = 0.;
00360 /* .......... INTERCHANGE COLUMNS OF HR, HI, ZR, AND ZI, */
00361 /* IF NECESSARY .......... */
00362 if (wr[j] <= 0.) {
00363 goto L580;
00364 }
00365
00366 i__1 = j;
00367 for (i__ = 1; i__ <= i__1; ++i__) {
00368 zzr = hr[i__ + (j - 1) * hr_dim1];
00369 hr[i__ + (j - 1) * hr_dim1] = hr[i__ + j * hr_dim1];
00370 hr[i__ + j * hr_dim1] = zzr;
00371 zzi = hi[i__ + (j - 1) * hi_dim1];
00372 hi[i__ + (j - 1) * hi_dim1] = hi[i__ + j * hi_dim1];
00373 hi[i__ + j * hi_dim1] = zzi;
00374 /* L540: */
00375 }
00376
00377 i__1 = *igh;
00378 for (i__ = *low; i__ <= i__1; ++i__) {
00379 zzr = zr[i__ + (j - 1) * zr_dim1];
00380 zr[i__ + (j - 1) * zr_dim1] = zr[i__ + j * zr_dim1];
00381 zr[i__ + j * zr_dim1] = zzr;
00382 zzi = zi[i__ + (j - 1) * zi_dim1];
00383 zi[i__ + (j - 1) * zi_dim1] = zi[i__ + j * zi_dim1];
00384 zi[i__ + j * zi_dim1] = zzi;
00385 /* L560: */
00386 }
00387
00388 L580:
00389 i__1 = j;
00390 for (i__ = 1; i__ <= i__1; ++i__) {
00391 hr[i__ + (j - 1) * hr_dim1] = hr[i__ + (j - 1) * hr_dim1] + xr *
00392 hr[i__ + j * hr_dim1] - xi * hi[i__ + j * hi_dim1];
00393 hi[i__ + (j - 1) * hi_dim1] = hi[i__ + (j - 1) * hi_dim1] + xr *
00394 hi[i__ + j * hi_dim1] + xi * hr[i__ + j * hr_dim1];
00395 /* L600: */
00396 }
00397 /* .......... ACCUMULATE TRANSFORMATIONS .......... */
00398 i__1 = *igh;
00399 for (i__ = *low; i__ <= i__1; ++i__) {
00400 zr[i__ + (j - 1) * zr_dim1] = zr[i__ + (j - 1) * zr_dim1] + xr *
00401 zr[i__ + j * zr_dim1] - xi * zi[i__ + j * zi_dim1];
00402 zi[i__ + (j - 1) * zi_dim1] = zi[i__ + (j - 1) * zi_dim1] + xr *
00403 zi[i__ + j * zi_dim1] + xi * zr[i__ + j * zr_dim1];
00404 /* L620: */
00405 }
00406
00407 /* L640: */
00408 }
00409
00410 goto L240;
00411 /* .......... A ROOT FOUND .......... */
00412 L660:
00413 hr[en + en * hr_dim1] += tr;
00414 wr[en] = hr[en + en * hr_dim1];
00415 hi[en + en * hi_dim1] += ti;
00416 wi[en] = hi[en + en * hi_dim1];
00417 en = enm1;
00418 goto L220;
00419 /* .......... ALL ROOTS FOUND. BACKSUBSTITUTE TO FIND */
00420 /* VECTORS OF UPPER TRIANGULAR FORM .......... */
00421 L680:
00422 norm = 0.;
00423
00424 i__2 = *n;
00425 for (i__ = 1; i__ <= i__2; ++i__) {
00426
00427 i__1 = *n;
00428 for (j = i__; j <= i__1; ++j) {
00429 tr = (d__1 = hr[i__ + j * hr_dim1], abs(d__1)) + (d__2 = hi[i__ +
00430 j * hi_dim1], abs(d__2));
00431 if (tr > norm) {
00432 norm = tr;
00433 }
00434 /* L720: */
00435 }
00436 }
00437
00438 hr[hr_dim1 + 1] = norm;
00439 if (*n == 1 || norm == 0.) {
00440 goto L1001;
00441 }
00442 /* .......... FOR EN=N STEP -1 UNTIL 2 DO -- .......... */
00443 i__1 = *n;
00444 for (nn = 2; nn <= i__1; ++nn) {
00445 en = *n + 2 - nn;
00446 xr = wr[en];
00447 xi = wi[en];
00448 hr[en + en * hr_dim1] = 1.;
00449 hi[en + en * hi_dim1] = 0.;
00450 enm1 = en - 1;
00451 /* .......... FOR I=EN-1 STEP -1 UNTIL 1 DO -- .......... */
00452 i__2 = enm1;
00453 for (ii = 1; ii <= i__2; ++ii) {
00454 i__ = en - ii;
00455 zzr = 0.;
00456 zzi = 0.;
00457 ip1 = i__ + 1;
00458
00459 i__3 = en;
00460 for (j = ip1; j <= i__3; ++j) {
00461 zzr = zzr + hr[i__ + j * hr_dim1] * hr[j + en * hr_dim1] - hi[
00462 i__ + j * hi_dim1] * hi[j + en * hi_dim1];
00463 zzi = zzi + hr[i__ + j * hr_dim1] * hi[j + en * hi_dim1] + hi[
00464 i__ + j * hi_dim1] * hr[j + en * hr_dim1];
00465 /* L740: */
00466 }
00467
00468 yr = xr - wr[i__];
00469 yi = xi - wi[i__];
00470 if (yr != 0. || yi != 0.) {
00471 goto L765;
00472 }
00473 tst1 = norm;
00474 yr = tst1;
00475 L760:
00476 yr *= .01;
00477 tst2 = norm + yr;
00478 if (tst2 > tst1) {
00479 goto L760;
00480 }
00481 L765:
00482 cdiv_(&zzr, &zzi, &yr, &yi, &hr[i__ + en * hr_dim1], &hi[i__ + en
00483 * hi_dim1]);
00484 /* .......... OVERFLOW CONTROL .......... */
00485 tr = (d__1 = hr[i__ + en * hr_dim1], abs(d__1)) + (d__2 = hi[i__
00486 + en * hi_dim1], abs(d__2));
00487 if (tr == 0.) {
00488 goto L780;
00489 }
00490 tst1 = tr;
00491 tst2 = tst1 + 1. / tst1;
00492 if (tst2 > tst1) {
00493 goto L780;
00494 }
00495 i__3 = en;
00496 for (j = i__; j <= i__3; ++j) {
00497 hr[j + en * hr_dim1] /= tr;
00498 hi[j + en * hi_dim1] /= tr;
00499 /* L770: */
00500 }
00501
00502 L780:
00503 ;
00504 }
00505
00506 /* L800: */
00507 }
00508 /* .......... END BACKSUBSTITUTION .......... */
00509 enm1 = *n - 1;
00510 /* .......... VECTORS OF ISOLATED ROOTS .......... */
00511 i__1 = enm1;
00512 for (i__ = 1; i__ <= i__1; ++i__) {
00513 if (i__ >= *low && i__ <= *igh) {
00514 goto L840;
00515 }
00516 ip1 = i__ + 1;
00517
00518 i__2 = *n;
00519 for (j = ip1; j <= i__2; ++j) {
00520 zr[i__ + j * zr_dim1] = hr[i__ + j * hr_dim1];
00521 zi[i__ + j * zi_dim1] = hi[i__ + j * hi_dim1];
00522 /* L820: */
00523 }
00524
00525 L840:
00526 ;
00527 }
00528 /* .......... MULTIPLY BY TRANSFORMATION MATRIX TO GIVE */
00529 /* VECTORS OF ORIGINAL FULL MATRIX. */
00530 /* FOR J=N STEP -1 UNTIL LOW+1 DO -- .......... */
00531 i__1 = enm1;
00532 for (jj = *low; jj <= i__1; ++jj) {
00533 j = *n + *low - jj;
00534 m = min(j,*igh);
00535
00536 i__2 = *igh;
00537 for (i__ = *low; i__ <= i__2; ++i__) {
00538 zzr = 0.;
00539 zzi = 0.;
00540
00541 i__3 = m;
00542 for (k = *low; k <= i__3; ++k) {
00543 zzr = zzr + zr[i__ + k * zr_dim1] * hr[k + j * hr_dim1] - zi[
00544 i__ + k * zi_dim1] * hi[k + j * hi_dim1];
00545 zzi = zzi + zr[i__ + k * zr_dim1] * hi[k + j * hi_dim1] + zi[
00546 i__ + k * zi_dim1] * hr[k + j * hr_dim1];
00547 /* L860: */
00548 }
00549
00550 zr[i__ + j * zr_dim1] = zzr;
00551 zi[i__ + j * zi_dim1] = zzi;
00552 /* L880: */
00553 }
00554 }
00555
00556 goto L1001;
00557 /* .......... SET ERROR -- ALL EIGENVALUES HAVE NOT */
00558 /* CONVERGED AFTER 30*N ITERATIONS .......... */
00559 L1000:
00560 *ierr = en;
00561 L1001:
00562 return 0;
00563 } /* comlr2_ */
|
|
||||||||||||||||||||||||||||||||||||||||
|
Definition at line 8 of file eis_comlr.c. References abs, cdiv_(), csroot_(), and l.
00011 {
00012 /* System generated locals */
00013 integer hr_dim1, hr_offset, hi_dim1, hi_offset, i__1, i__2;
00014 doublereal d__1, d__2, d__3, d__4;
00015
00016 /* Local variables */
00017 extern /* Subroutine */ int cdiv_(doublereal *, doublereal *, doublereal *
00018 , doublereal *, doublereal *, doublereal *);
00019 static integer i__, j, l, m, en, ll, mm;
00020 static doublereal si, ti, xi, yi, sr, tr, xr, yr;
00021 static integer im1;
00022 extern /* Subroutine */ int csroot_(doublereal *, doublereal *,
00023 doublereal *, doublereal *);
00024 static integer mp1, itn, its;
00025 static doublereal zzi, zzr;
00026 static integer enm1;
00027 static doublereal tst1, tst2;
00028
00029
00030
00031 /* THIS SUBROUTINE IS A TRANSLATION OF THE ALGOL PROCEDURE COMLR, */
00032 /* NUM. MATH. 12, 369-376(1968) BY MARTIN AND WILKINSON. */
00033 /* HANDBOOK FOR AUTO. COMP., VOL.II-LINEAR ALGEBRA, 396-403(1971). */
00034
00035 /* THIS SUBROUTINE FINDS THE EIGENVALUES OF A COMPLEX */
00036 /* UPPER HESSENBERG MATRIX BY THE MODIFIED LR METHOD. */
00037
00038 /* ON INPUT */
00039
00040 /* NM MUST BE SET TO THE ROW DIMENSION OF TWO-DIMENSIONAL */
00041 /* ARRAY PARAMETERS AS DECLARED IN THE CALLING PROGRAM */
00042 /* DIMENSION STATEMENT. */
00043
00044 /* N IS THE ORDER OF THE MATRIX. */
00045
00046 /* LOW AND IGH ARE INTEGERS DETERMINED BY THE BALANCING */
00047 /* SUBROUTINE CBAL. IF CBAL HAS NOT BEEN USED, */
00048 /* SET LOW=1, IGH=N. */
00049
00050 /* HR AND HI CONTAIN THE REAL AND IMAGINARY PARTS, */
00051 /* RESPECTIVELY, OF THE COMPLEX UPPER HESSENBERG MATRIX. */
00052 /* THEIR LOWER TRIANGLES BELOW THE SUBDIAGONAL CONTAIN THE */
00053 /* MULTIPLIERS WHICH WERE USED IN THE REDUCTION BY COMHES, */
00054 /* IF PERFORMED. */
00055
00056 /* ON OUTPUT */
00057
00058 /* THE UPPER HESSENBERG PORTIONS OF HR AND HI HAVE BEEN */
00059 /* DESTROYED. THEREFORE, THEY MUST BE SAVED BEFORE */
00060 /* CALLING COMLR IF SUBSEQUENT CALCULATION OF */
00061 /* EIGENVECTORS IS TO BE PERFORMED. */
00062
00063 /* WR AND WI CONTAIN THE REAL AND IMAGINARY PARTS, */
00064 /* RESPECTIVELY, OF THE EIGENVALUES. IF AN ERROR */
00065 /* EXIT IS MADE, THE EIGENVALUES SHOULD BE CORRECT */
00066 /* FOR INDICES IERR+1,...,N. */
00067
00068 /* IERR IS SET TO */
00069 /* ZERO FOR NORMAL RETURN, */
00070 /* J IF THE LIMIT OF 30*N ITERATIONS IS EXHAUSTED */
00071 /* WHILE THE J-TH EIGENVALUE IS BEING SOUGHT. */
00072
00073 /* CALLS CDIV FOR COMPLEX DIVISION. */
00074 /* CALLS CSROOT FOR COMPLEX SQUARE ROOT. */
00075
00076 /* QUESTIONS AND COMMENTS SHOULD BE DIRECTED TO BURTON S. GARBOW, */
00077 /* MATHEMATICS AND COMPUTER SCIENCE DIV, ARGONNE NATIONAL LABORATORY
00078 */
00079
00080 /* THIS VERSION DATED AUGUST 1983. */
00081
00082 /* ------------------------------------------------------------------
00083 */
00084
00085 /* Parameter adjustments */
00086 --wi;
00087 --wr;
00088 hi_dim1 = *nm;
00089 hi_offset = hi_dim1 + 1;
00090 hi -= hi_offset;
00091 hr_dim1 = *nm;
00092 hr_offset = hr_dim1 + 1;
00093 hr -= hr_offset;
00094
00095 /* Function Body */
00096 *ierr = 0;
00097 /* .......... STORE ROOTS ISOLATED BY CBAL .......... */
00098 i__1 = *n;
00099 for (i__ = 1; i__ <= i__1; ++i__) {
00100 if (i__ >= *low && i__ <= *igh) {
00101 goto L200;
00102 }
00103 wr[i__] = hr[i__ + i__ * hr_dim1];
00104 wi[i__] = hi[i__ + i__ * hi_dim1];
00105 L200:
00106 ;
00107 }
00108
00109 en = *igh;
00110 tr = 0.;
00111 ti = 0.;
00112 itn = *n * 30;
00113 /* .......... SEARCH FOR NEXT EIGENVALUE .......... */
00114 L220:
00115 if (en < *low) {
00116 goto L1001;
00117 }
00118 its = 0;
00119 enm1 = en - 1;
00120 /* .......... LOOK FOR SINGLE SMALL SUB-DIAGONAL ELEMENT */
00121 /* FOR L=EN STEP -1 UNTIL LOW D0 -- .......... */
00122 L240:
00123 i__1 = en;
00124 for (ll = *low; ll <= i__1; ++ll) {
00125 l = en + *low - ll;
00126 if (l == *low) {
00127 goto L300;
00128 }
00129 tst1 = (d__1 = hr[l - 1 + (l - 1) * hr_dim1], abs(d__1)) + (d__2 = hi[
00130 l - 1 + (l - 1) * hi_dim1], abs(d__2)) + (d__3 = hr[l + l *
00131 hr_dim1], abs(d__3)) + (d__4 = hi[l + l * hi_dim1], abs(d__4))
00132 ;
00133 tst2 = tst1 + (d__1 = hr[l + (l - 1) * hr_dim1], abs(d__1)) + (d__2 =
00134 hi[l + (l - 1) * hi_dim1], abs(d__2));
00135 if (tst2 == tst1) {
00136 goto L300;
00137 }
00138 /* L260: */
00139 }
00140 /* .......... FORM SHIFT .......... */
00141 L300:
00142 if (l == en) {
00143 goto L660;
00144 }
00145 if (itn == 0) {
00146 goto L1000;
00147 }
00148 if (its == 10 || its == 20) {
00149 goto L320;
00150 }
00151 sr = hr[en + en * hr_dim1];
00152 si = hi[en + en * hi_dim1];
00153 xr = hr[enm1 + en * hr_dim1] * hr[en + enm1 * hr_dim1] - hi[enm1 + en *
00154 hi_dim1] * hi[en + enm1 * hi_dim1];
00155 xi = hr[enm1 + en * hr_dim1] * hi[en + enm1 * hi_dim1] + hi[enm1 + en *
00156 hi_dim1] * hr[en + enm1 * hr_dim1];
00157 if (xr == 0. && xi == 0.) {
00158 goto L340;
00159 }
00160 yr = (hr[enm1 + enm1 * hr_dim1] - sr) / 2.;
00161 yi = (hi[enm1 + enm1 * hi_dim1] - si) / 2.;
00162 /* Computing 2nd power */
00163 d__2 = yr;
00164 /* Computing 2nd power */
00165 d__3 = yi;
00166 d__1 = d__2 * d__2 - d__3 * d__3 + xr;
00167 d__4 = yr * 2. * yi + xi;
00168 csroot_(&d__1, &d__4, &zzr, &zzi);
00169 if (yr * zzr + yi * zzi >= 0.) {
00170 goto L310;
00171 }
00172 zzr = -zzr;
00173 zzi = -zzi;
00174 L310:
00175 d__1 = yr + zzr;
00176 d__2 = yi + zzi;
00177 cdiv_(&xr, &xi, &d__1, &d__2, &xr, &xi);
00178 sr -= xr;
00179 si -= xi;
00180 goto L340;
00181 /* .......... FORM EXCEPTIONAL SHIFT .......... */
00182 L320:
00183 sr = (d__1 = hr[en + enm1 * hr_dim1], abs(d__1)) + (d__2 = hr[enm1 + (en
00184 - 2) * hr_dim1], abs(d__2));
00185 si = (d__1 = hi[en + enm1 * hi_dim1], abs(d__1)) + (d__2 = hi[enm1 + (en
00186 - 2) * hi_dim1], abs(d__2));
00187
00188 L340:
00189 i__1 = en;
00190 for (i__ = *low; i__ <= i__1; ++i__) {
00191 hr[i__ + i__ * hr_dim1] -= sr;
00192 hi[i__ + i__ * hi_dim1] -= si;
00193 /* L360: */
00194 }
00195
00196 tr += sr;
00197 ti += si;
00198 ++its;
00199 --itn;
00200 /* .......... LOOK FOR TWO CONSECUTIVE SMALL */
00201 /* SUB-DIAGONAL ELEMENTS .......... */
00202 xr = (d__1 = hr[enm1 + enm1 * hr_dim1], abs(d__1)) + (d__2 = hi[enm1 +
00203 enm1 * hi_dim1], abs(d__2));
00204 yr = (d__1 = hr[en + enm1 * hr_dim1], abs(d__1)) + (d__2 = hi[en + enm1 *
00205 hi_dim1], abs(d__2));
00206 zzr = (d__1 = hr[en + en * hr_dim1], abs(d__1)) + (d__2 = hi[en + en *
00207 hi_dim1], abs(d__2));
00208 /* .......... FOR M=EN-1 STEP -1 UNTIL L DO -- .......... */
00209 i__1 = enm1;
00210 for (mm = l; mm <= i__1; ++mm) {
00211 m = enm1 + l - mm;
00212 if (m == l) {
00213 goto L420;
00214 }
00215 yi = yr;
00216 yr = (d__1 = hr[m + (m - 1) * hr_dim1], abs(d__1)) + (d__2 = hi[m + (
00217 m - 1) * hi_dim1], abs(d__2));
00218 xi = zzr;
00219 zzr = xr;
00220 xr = (d__1 = hr[m - 1 + (m - 1) * hr_dim1], abs(d__1)) + (d__2 = hi[m
00221 - 1 + (m - 1) * hi_dim1], abs(d__2));
00222 tst1 = zzr / yi * (zzr + xr + xi);
00223 tst2 = tst1 + yr;
00224 if (tst2 == tst1) {
00225 goto L420;
00226 }
00227 /* L380: */
00228 }
00229 /* .......... TRIANGULAR DECOMPOSITION H=L*R .......... */
00230 L420:
00231 mp1 = m + 1;
00232
00233 i__1 = en;
00234 for (i__ = mp1; i__ <= i__1; ++i__) {
00235 im1 = i__ - 1;
00236 xr = hr[im1 + im1 * hr_dim1];
00237 xi = hi[im1 + im1 * hi_dim1];
00238 yr = hr[i__ + im1 * hr_dim1];
00239 yi = hi[i__ + im1 * hi_dim1];
00240 if (abs(xr) + abs(xi) >= abs(yr) + abs(yi)) {
00241 goto L460;
00242 }
00243 /* .......... INTERCHANGE ROWS OF HR AND HI .......... */
00244 i__2 = en;
00245 for (j = im1; j <= i__2; ++j) {
00246 zzr = hr[im1 + j * hr_dim1];
00247 hr[im1 + j * hr_dim1] = hr[i__ + j * hr_dim1];
00248 hr[i__ + j * hr_dim1] = zzr;
00249 zzi = hi[im1 + j * hi_dim1];
00250 hi[im1 + j * hi_dim1] = hi[i__ + j * hi_dim1];
00251 hi[i__ + j * hi_dim1] = zzi;
00252 /* L440: */
00253 }
00254
00255 cdiv_(&xr, &xi, &yr, &yi, &zzr, &zzi);
00256 wr[i__] = 1.;
00257 goto L480;
00258 L460:
00259 cdiv_(&yr, &yi, &xr, &xi, &zzr, &zzi);
00260 wr[i__] = -1.;
00261 L480:
00262 hr[i__ + im1 * hr_dim1] = zzr;
00263 hi[i__ + im1 * hi_dim1] = zzi;
00264
00265 i__2 = en;
00266 for (j = i__; j <= i__2; ++j) {
00267 hr[i__ + j * hr_dim1] = hr[i__ + j * hr_dim1] - zzr * hr[im1 + j *
00268 hr_dim1] + zzi * hi[im1 + j * hi_dim1];
00269 hi[i__ + j * hi_dim1] = hi[i__ + j * hi_dim1] - zzr * hi[im1 + j *
00270 hi_dim1] - zzi * hr[im1 + j * hr_dim1];
00271 /* L500: */
00272 }
00273
00274 /* L520: */
00275 }
00276 /* .......... COMPOSITION R*L=H .......... */
00277 i__1 = en;
00278 for (j = mp1; j <= i__1; ++j) {
00279 xr = hr[j + (j - 1) * hr_dim1];
00280 xi = hi[j + (j - 1) * hi_dim1];
00281 hr[j + (j - 1) * hr_dim1] = 0.;
00282 hi[j + (j - 1) * hi_dim1] = 0.;
00283 /* .......... INTERCHANGE COLUMNS OF HR AND HI, */
00284 /* IF NECESSARY .......... */
00285 if (wr[j] <= 0.) {
00286 goto L580;
00287 }
00288
00289 i__2 = j;
00290 for (i__ = l; i__ <= i__2; ++i__) {
00291 zzr = hr[i__ + (j - 1) * hr_dim1];
00292 hr[i__ + (j - 1) * hr_dim1] = hr[i__ + j * hr_dim1];
00293 hr[i__ + j * hr_dim1] = zzr;
00294 zzi = hi[i__ + (j - 1) * hi_dim1];
00295 hi[i__ + (j - 1) * hi_dim1] = hi[i__ + j * hi_dim1];
00296 hi[i__ + j * hi_dim1] = zzi;
00297 /* L540: */
00298 }
00299
00300 L580:
00301 i__2 = j;
00302 for (i__ = l; i__ <= i__2; ++i__) {
00303 hr[i__ + (j - 1) * hr_dim1] = hr[i__ + (j - 1) * hr_dim1] + xr *
00304 hr[i__ + j * hr_dim1] - xi * hi[i__ + j * hi_dim1];
00305 hi[i__ + (j - 1) * hi_dim1] = hi[i__ + (j - 1) * hi_dim1] + xr *
00306 hi[i__ + j * hi_dim1] + xi * hr[i__ + j * hr_dim1];
00307 /* L600: */
00308 }
00309
00310 /* L640: */
00311 }
00312
00313 goto L240;
00314 /* .......... A ROOT FOUND .......... */
00315 L660:
00316 wr[en] = hr[en + en * hr_dim1] + tr;
00317 wi[en] = hi[en + en * hi_dim1] + ti;
00318 en = enm1;
00319 goto L220;
00320 /* .......... SET ERROR -- ALL EIGENVALUES HAVE NOT */
00321 /* CONVERGED AFTER 30*N ITERATIONS .......... */
00322 L1000:
00323 *ierr = en;
00324 L1001:
00325 return 0;
00326 } /* comlr_ */
|
|
||||||||||||||||||||||||||||||||||||||||||||||||||||||||
|
Definition at line 8 of file eis_comqr2.c. References abs, cdiv_(), csroot_(), l, min, and pythag_(). Referenced by cg_().
00012 {
00013 /* System generated locals */
00014 integer hr_dim1, hr_offset, hi_dim1, hi_offset, zr_dim1, zr_offset,
00015 zi_dim1, zi_offset, i__1, i__2, i__3;
00016 doublereal d__1, d__2, d__3, d__4;
00017
00018 /* Local variables */
00019 static integer iend;
00020 extern /* Subroutine */ int cdiv_(doublereal *, doublereal *, doublereal *
00021 , doublereal *, doublereal *, doublereal *);
00022 static doublereal norm;
00023 static integer i__, j, k, l, m, ii, en, jj, ll, nn;
00024 static doublereal si, ti, xi, yi, sr, tr, xr, yr;
00025 extern doublereal pythag_(doublereal *, doublereal *);
00026 extern /* Subroutine */ int csroot_(doublereal *, doublereal *,
00027 doublereal *, doublereal *);
00028 static integer ip1, lp1, itn, its;
00029 static doublereal zzi, zzr;
00030 static integer enm1;
00031 static doublereal tst1, tst2;
00032
00033
00034
00035 /* THIS SUBROUTINE IS A TRANSLATION OF A UNITARY ANALOGUE OF THE */
00036 /* ALGOL PROCEDURE COMLR2, NUM. MATH. 16, 181-204(1970) BY PETERS */
00037 /* AND WILKINSON. */
00038 /* HANDBOOK FOR AUTO. COMP., VOL.II-LINEAR ALGEBRA, 372-395(1971). */
00039 /* THE UNITARY ANALOGUE SUBSTITUTES THE QR ALGORITHM OF FRANCIS */
00040 /* (COMP. JOUR. 4, 332-345(1962)) FOR THE LR ALGORITHM. */
00041
00042 /* THIS SUBROUTINE FINDS THE EIGENVALUES AND EIGENVECTORS */
00043 /* OF A COMPLEX UPPER HESSENBERG MATRIX BY THE QR */
00044 /* METHOD. THE EIGENVECTORS OF A COMPLEX GENERAL MATRIX */
00045 /* CAN ALSO BE FOUND IF CORTH HAS BEEN USED TO REDUCE */
00046 /* THIS GENERAL MATRIX TO HESSENBERG FORM. */
00047
00048 /* ON INPUT */
00049
00050 /* NM MUST BE SET TO THE ROW DIMENSION OF TWO-DIMENSIONAL */
00051 /* ARRAY PARAMETERS AS DECLARED IN THE CALLING PROGRAM */
00052 /* DIMENSION STATEMENT. */
00053
00054 /* N IS THE ORDER OF THE MATRIX. */
00055
00056 /* LOW AND IGH ARE INTEGERS DETERMINED BY THE BALANCING */
00057 /* SUBROUTINE CBAL. IF CBAL HAS NOT BEEN USED, */
00058 /* SET LOW=1, IGH=N. */
00059
00060 /* ORTR AND ORTI CONTAIN INFORMATION ABOUT THE UNITARY TRANS- */
00061 /* FORMATIONS USED IN THE REDUCTION BY CORTH, IF PERFORMED. */
00062 /* ONLY ELEMENTS LOW THROUGH IGH ARE USED. IF THE EIGENVECTORS
00063 */
00064 /* OF THE HESSENBERG MATRIX ARE DESIRED, SET ORTR(J) AND */
00065 /* ORTI(J) TO 0.0D0 FOR THESE ELEMENTS. */
00066
00067 /* HR AND HI CONTAIN THE REAL AND IMAGINARY PARTS, */
00068 /* RESPECTIVELY, OF THE COMPLEX UPPER HESSENBERG MATRIX. */
00069 /* THEIR LOWER TRIANGLES BELOW THE SUBDIAGONAL CONTAIN FURTHER */
00070 /* INFORMATION ABOUT THE TRANSFORMATIONS WHICH WERE USED IN THE
00071 */
00072 /* REDUCTION BY CORTH, IF PERFORMED. IF THE EIGENVECTORS OF */
00073 /* THE HESSENBERG MATRIX ARE DESIRED, THESE ELEMENTS MAY BE */
00074 /* ARBITRARY. */
00075
00076 /* ON OUTPUT */
00077
00078 /* ORTR, ORTI, AND THE UPPER HESSENBERG PORTIONS OF HR AND HI */
00079 /* HAVE BEEN DESTROYED. */
00080
00081 /* WR AND WI CONTAIN THE REAL AND IMAGINARY PARTS, */
00082 /* RESPECTIVELY, OF THE EIGENVALUES. IF AN ERROR */
00083 /* EXIT IS MADE, THE EIGENVALUES SHOULD BE CORRECT */
00084 /* FOR INDICES IERR+1,...,N. */
00085
00086 /* ZR AND ZI CONTAIN THE REAL AND IMAGINARY PARTS, */
00087 /* RESPECTIVELY, OF THE EIGENVECTORS. THE EIGENVECTORS */
00088 /* ARE UNNORMALIZED. IF AN ERROR EXIT IS MADE, NONE OF */
00089 /* THE EIGENVECTORS HAS BEEN FOUND. */
00090
00091 /* IERR IS SET TO */
00092 /* ZERO FOR NORMAL RETURN, */
00093 /* J IF THE LIMIT OF 30*N ITERATIONS IS EXHAUSTED */
00094 /* WHILE THE J-TH EIGENVALUE IS BEING SOUGHT. */
00095
00096 /* CALLS CDIV FOR COMPLEX DIVISION. */
00097 /* CALLS CSROOT FOR COMPLEX SQUARE ROOT. */
00098 /* CALLS PYTHAG FOR DSQRT(A*A + B*B) . */
00099
00100 /* QUESTIONS AND COMMENTS SHOULD BE DIRECTED TO BURTON S. GARBOW, */
00101 /* MATHEMATICS AND COMPUTER SCIENCE DIV, ARGONNE NATIONAL LABORATORY
00102 */
00103
00104 /* THIS VERSION DATED AUGUST 1983. */
00105
00106 /* ------------------------------------------------------------------
00107 */
00108
00109 /* Parameter adjustments */
00110 zi_dim1 = *nm;
00111 zi_offset = zi_dim1 + 1;
00112 zi -= zi_offset;
00113 zr_dim1 = *nm;
00114 zr_offset = zr_dim1 + 1;
00115 zr -= zr_offset;
00116 --wi;
00117 --wr;
00118 hi_dim1 = *nm;
00119 hi_offset = hi_dim1 + 1;
00120 hi -= hi_offset;
00121 hr_dim1 = *nm;
00122 hr_offset = hr_dim1 + 1;
00123 hr -= hr_offset;
00124 --orti;
00125 --ortr;
00126
00127 /* Function Body */
00128 *ierr = 0;
00129 /* .......... INITIALIZE EIGENVECTOR MATRIX .......... */
00130 i__1 = *n;
00131 for (j = 1; j <= i__1; ++j) {
00132
00133 i__2 = *n;
00134 for (i__ = 1; i__ <= i__2; ++i__) {
00135 zr[i__ + j * zr_dim1] = 0.;
00136 zi[i__ + j * zi_dim1] = 0.;
00137 /* L100: */
00138 }
00139 zr[j + j * zr_dim1] = 1.;
00140 /* L101: */
00141 }
00142 /* .......... FORM THE MATRIX OF ACCUMULATED TRANSFORMATIONS */
00143 /* FROM THE INFORMATION LEFT BY CORTH .......... */
00144 iend = *igh - *low - 1;
00145 if (iend < 0) {
00146 goto L180;
00147 } else if (iend == 0) {
00148 goto L150;
00149 } else {
00150 goto L105;
00151 }
00152 /* .......... FOR I=IGH-1 STEP -1 UNTIL LOW+1 DO -- .......... */
00153 L105:
00154 i__1 = iend;
00155 for (ii = 1; ii <= i__1; ++ii) {
00156 i__ = *igh - ii;
00157 if (ortr[i__] == 0. && orti[i__] == 0.) {
00158 goto L140;
00159 }
00160 if (hr[i__ + (i__ - 1) * hr_dim1] == 0. && hi[i__ + (i__ - 1) *
00161 hi_dim1] == 0.) {
00162 goto L140;
00163 }
00164 /* .......... NORM BELOW IS NEGATIVE OF H FORMED IN CORTH ........
00165 .. */
00166 norm = hr[i__ + (i__ - 1) * hr_dim1] * ortr[i__] + hi[i__ + (i__ - 1)
00167 * hi_dim1] * orti[i__];
00168 ip1 = i__ + 1;
00169
00170 i__2 = *igh;
00171 for (k = ip1; k <= i__2; ++k) {
00172 ortr[k] = hr[k + (i__ - 1) * hr_dim1];
00173 orti[k] = hi[k + (i__ - 1) * hi_dim1];
00174 /* L110: */
00175 }
00176
00177 i__2 = *igh;
00178 for (j = i__; j <= i__2; ++j) {
00179 sr = 0.;
00180 si = 0.;
00181
00182 i__3 = *igh;
00183 for (k = i__; k <= i__3; ++k) {
00184 sr = sr + ortr[k] * zr[k + j * zr_dim1] + orti[k] * zi[k + j *
00185 zi_dim1];
00186 si = si + ortr[k] * zi[k + j * zi_dim1] - orti[k] * zr[k + j *
00187 zr_dim1];
00188 /* L115: */
00189 }
00190
00191 sr /= norm;
00192 si /= norm;
00193
00194 i__3 = *igh;
00195 for (k = i__; k <= i__3; ++k) {
00196 zr[k + j * zr_dim1] = zr[k + j * zr_dim1] + sr * ortr[k] - si
00197 * orti[k];
00198 zi[k + j * zi_dim1] = zi[k + j * zi_dim1] + sr * orti[k] + si
00199 * ortr[k];
00200 /* L120: */
00201 }
00202
00203 /* L130: */
00204 }
00205
00206 L140:
00207 ;
00208 }
00209 /* .......... CREATE REAL SUBDIAGONAL ELEMENTS .......... */
00210 L150:
00211 l = *low + 1;
00212
00213 i__1 = *igh;
00214 for (i__ = l; i__ <= i__1; ++i__) {
00215 /* Computing MIN */
00216 i__2 = i__ + 1;
00217 ll = min(i__2,*igh);
00218 if (hi[i__ + (i__ - 1) * hi_dim1] == 0.) {
00219 goto L170;
00220 }
00221 norm = pythag_(&hr[i__ + (i__ - 1) * hr_dim1], &hi[i__ + (i__ - 1) *
00222 hi_dim1]);
00223 yr = hr[i__ + (i__ - 1) * hr_dim1] / norm;
00224 yi = hi[i__ + (i__ - 1) * hi_dim1] / norm;
00225 hr[i__ + (i__ - 1) * hr_dim1] = norm;
00226 hi[i__ + (i__ - 1) * hi_dim1] = 0.;
00227
00228 i__2 = *n;
00229 for (j = i__; j <= i__2; ++j) {
00230 si = yr * hi[i__ + j * hi_dim1] - yi * hr[i__ + j * hr_dim1];
00231 hr[i__ + j * hr_dim1] = yr * hr[i__ + j * hr_dim1] + yi * hi[i__
00232 + j * hi_dim1];
00233 hi[i__ + j * hi_dim1] = si;
00234 /* L155: */
00235 }
00236
00237 i__2 = ll;
00238 for (j = 1; j <= i__2; ++j) {
00239 si = yr * hi[j + i__ * hi_dim1] + yi * hr[j + i__ * hr_dim1];
00240 hr[j + i__ * hr_dim1] = yr * hr[j + i__ * hr_dim1] - yi * hi[j +
00241 i__ * hi_dim1];
00242 hi[j + i__ * hi_dim1] = si;
00243 /* L160: */
00244 }
00245
00246 i__2 = *igh;
00247 for (j = *low; j <= i__2; ++j) {
00248 si = yr * zi[j + i__ * zi_dim1] + yi * zr[j + i__ * zr_dim1];
00249 zr[j + i__ * zr_dim1] = yr * zr[j + i__ * zr_dim1] - yi * zi[j +
00250 i__ * zi_dim1];
00251 zi[j + i__ * zi_dim1] = si;
00252 /* L165: */
00253 }
00254
00255 L170:
00256 ;
00257 }
00258 /* .......... STORE ROOTS ISOLATED BY CBAL .......... */
00259 L180:
00260 i__1 = *n;
00261 for (i__ = 1; i__ <= i__1; ++i__) {
00262 if (i__ >= *low && i__ <= *igh) {
00263 goto L200;
00264 }
00265 wr[i__] = hr[i__ + i__ * hr_dim1];
00266 wi[i__] = hi[i__ + i__ * hi_dim1];
00267 L200:
00268 ;
00269 }
00270
00271 en = *igh;
00272 tr = 0.;
00273 ti = 0.;
00274 itn = *n * 30;
00275 /* .......... SEARCH FOR NEXT EIGENVALUE .......... */
00276 L220:
00277 if (en < *low) {
00278 goto L680;
00279 }
00280 its = 0;
00281 enm1 = en - 1;
00282 /* .......... LOOK FOR SINGLE SMALL SUB-DIAGONAL ELEMENT */
00283 /* FOR L=EN STEP -1 UNTIL LOW DO -- .......... */
00284 L240:
00285 i__1 = en;
00286 for (ll = *low; ll <= i__1; ++ll) {
00287 l = en + *low - ll;
00288 if (l == *low) {
00289 goto L300;
00290 }
00291 tst1 = (d__1 = hr[l - 1 + (l - 1) * hr_dim1], abs(d__1)) + (d__2 = hi[
00292 l - 1 + (l - 1) * hi_dim1], abs(d__2)) + (d__3 = hr[l + l *
00293 hr_dim1], abs(d__3)) + (d__4 = hi[l + l * hi_dim1], abs(d__4))
00294 ;
00295 tst2 = tst1 + (d__1 = hr[l + (l - 1) * hr_dim1], abs(d__1));
00296 if (tst2 == tst1) {
00297 goto L300;
00298 }
00299 /* L260: */
00300 }
00301 /* .......... FORM SHIFT .......... */
00302 L300:
00303 if (l == en) {
00304 goto L660;
00305 }
00306 if (itn == 0) {
00307 goto L1000;
00308 }
00309 if (its == 10 || its == 20) {
00310 goto L320;
00311 }
00312 sr = hr[en + en * hr_dim1];
00313 si = hi[en + en * hi_dim1];
00314 xr = hr[enm1 + en * hr_dim1] * hr[en + enm1 * hr_dim1];
00315 xi = hi[enm1 + en * hi_dim1] * hr[en + enm1 * hr_dim1];
00316 if (xr == 0. && xi == 0.) {
00317 goto L340;
00318 }
00319 yr = (hr[enm1 + enm1 * hr_dim1] - sr) / 2.;
00320 yi = (hi[enm1 + enm1 * hi_dim1] - si) / 2.;
00321 /* Computing 2nd power */
00322 d__2 = yr;
00323 /* Computing 2nd power */
00324 d__3 = yi;
00325 d__1 = d__2 * d__2 - d__3 * d__3 + xr;
00326 d__4 = yr * 2. * yi + xi;
00327 csroot_(&d__1, &d__4, &zzr, &zzi);
00328 if (yr * zzr + yi * zzi >= 0.) {
00329 goto L310;
00330 }
00331 zzr = -zzr;
00332 zzi = -zzi;
00333 L310:
00334 d__1 = yr + zzr;
00335 d__2 = yi + zzi;
00336 cdiv_(&xr, &xi, &d__1, &d__2, &xr, &xi);
00337 sr -= xr;
00338 si -= xi;
00339 goto L340;
00340 /* .......... FORM EXCEPTIONAL SHIFT .......... */
00341 L320:
00342 sr = (d__1 = hr[en + enm1 * hr_dim1], abs(d__1)) + (d__2 = hr[enm1 + (en
00343 - 2) * hr_dim1], abs(d__2));
00344 si = 0.;
00345
00346 L340:
00347 i__1 = en;
00348 for (i__ = *low; i__ <= i__1; ++i__) {
00349 hr[i__ + i__ * hr_dim1] -= sr;
00350 hi[i__ + i__ * hi_dim1] -= si;
00351 /* L360: */
00352 }
00353
00354 tr += sr;
00355 ti += si;
00356 ++its;
00357 --itn;
00358 /* .......... REDUCE TO TRIANGLE (ROWS) .......... */
00359 lp1 = l + 1;
00360
00361 i__1 = en;
00362 for (i__ = lp1; i__ <= i__1; ++i__) {
00363 sr = hr[i__ + (i__ - 1) * hr_dim1];
00364 hr[i__ + (i__ - 1) * hr_dim1] = 0.;
00365 d__1 = pythag_(&hr[i__ - 1 + (i__ - 1) * hr_dim1], &hi[i__ - 1 + (i__
00366 - 1) * hi_dim1]);
00367 norm = pythag_(&d__1, &sr);
00368 xr = hr[i__ - 1 + (i__ - 1) * hr_dim1] / norm;
00369 wr[i__ - 1] = xr;
00370 xi = hi[i__ - 1 + (i__ - 1) * hi_dim1] / norm;
00371 wi[i__ - 1] = xi;
00372 hr[i__ - 1 + (i__ - 1) * hr_dim1] = norm;
00373 hi[i__ - 1 + (i__ - 1) * hi_dim1] = 0.;
00374 hi[i__ + (i__ - 1) * hi_dim1] = sr / norm;
00375
00376 i__2 = *n;
00377 for (j = i__; j <= i__2; ++j) {
00378 yr = hr[i__ - 1 + j * hr_dim1];
00379 yi = hi[i__ - 1 + j * hi_dim1];
00380 zzr = hr[i__ + j * hr_dim1];
00381 zzi = hi[i__ + j * hi_dim1];
00382 hr[i__ - 1 + j * hr_dim1] = xr * yr + xi * yi + hi[i__ + (i__ - 1)
00383 * hi_dim1] * zzr;
00384 hi[i__ - 1 + j * hi_dim1] = xr * yi - xi * yr + hi[i__ + (i__ - 1)
00385 * hi_dim1] * zzi;
00386 hr[i__ + j * hr_dim1] = xr * zzr - xi * zzi - hi[i__ + (i__ - 1) *
00387 hi_dim1] * yr;
00388 hi[i__ + j * hi_dim1] = xr * zzi + xi * zzr - hi[i__ + (i__ - 1) *
00389 hi_dim1] * yi;
00390 /* L490: */
00391 }
00392
00393 /* L500: */
00394 }
00395
00396 si = hi[en + en * hi_dim1];
00397 if (si == 0.) {
00398 goto L540;
00399 }
00400 norm = pythag_(&hr[en + en * hr_dim1], &si);
00401 sr = hr[en + en * hr_dim1] / norm;
00402 si /= norm;
00403 hr[en + en * hr_dim1] = norm;
00404 hi[en + en * hi_dim1] = 0.;
00405 if (en == *n) {
00406 goto L540;
00407 }
00408 ip1 = en + 1;
00409
00410 i__1 = *n;
00411 for (j = ip1; j <= i__1; ++j) {
00412 yr = hr[en + j * hr_dim1];
00413 yi = hi[en + j * hi_dim1];
00414 hr[en + j * hr_dim1] = sr * yr + si * yi;
00415 hi[en + j * hi_dim1] = sr * yi - si * yr;
00416 /* L520: */
00417 }
00418 /* .......... INVERSE OPERATION (COLUMNS) .......... */
00419 L540:
00420 i__1 = en;
00421 for (j = lp1; j <= i__1; ++j) {
00422 xr = wr[j - 1];
00423 xi = wi[j - 1];
00424
00425 i__2 = j;
00426 for (i__ = 1; i__ <= i__2; ++i__) {
00427 yr = hr[i__ + (j - 1) * hr_dim1];
00428 yi = 0.;
00429 zzr = hr[i__ + j * hr_dim1];
00430 zzi = hi[i__ + j * hi_dim1];
00431 if (i__ == j) {
00432 goto L560;
00433 }
00434 yi = hi[i__ + (j - 1) * hi_dim1];
00435 hi[i__ + (j - 1) * hi_dim1] = xr * yi + xi * yr + hi[j + (j - 1) *
00436 hi_dim1] * zzi;
00437 L560:
00438 hr[i__ + (j - 1) * hr_dim1] = xr * yr - xi * yi + hi[j + (j - 1) *
00439 hi_dim1] * zzr;
00440 hr[i__ + j * hr_dim1] = xr * zzr + xi * zzi - hi[j + (j - 1) *
00441 hi_dim1] * yr;
00442 hi[i__ + j * hi_dim1] = xr * zzi - xi * zzr - hi[j + (j - 1) *
00443 hi_dim1] * yi;
00444 /* L580: */
00445 }
00446
00447 i__2 = *igh;
00448 for (i__ = *low; i__ <= i__2; ++i__) {
00449 yr = zr[i__ + (j - 1) * zr_dim1];
00450 yi = zi[i__ + (j - 1) * zi_dim1];
00451 zzr = zr[i__ + j * zr_dim1];
00452 zzi = zi[i__ + j * zi_dim1];
00453 zr[i__ + (j - 1) * zr_dim1] = xr * yr - xi * yi + hi[j + (j - 1) *
00454 hi_dim1] * zzr;
00455 zi[i__ + (j - 1) * zi_dim1] = xr * yi + xi * yr + hi[j + (j - 1) *
00456 hi_dim1] * zzi;
00457 zr[i__ + j * zr_dim1] = xr * zzr + xi * zzi - hi[j + (j - 1) *
00458 hi_dim1] * yr;
00459 zi[i__ + j * zi_dim1] = xr * zzi - xi * zzr - hi[j + (j - 1) *
00460 hi_dim1] * yi;
00461 /* L590: */
00462 }
00463
00464 /* L600: */
00465 }
00466
00467 if (si == 0.) {
00468 goto L240;
00469 }
00470
00471 i__1 = en;
00472 for (i__ = 1; i__ <= i__1; ++i__) {
00473 yr = hr[i__ + en * hr_dim1];
00474 yi = hi[i__ + en * hi_dim1];
00475 hr[i__ + en * hr_dim1] = sr * yr - si * yi;
00476 hi[i__ + en * hi_dim1] = sr * yi + si * yr;
00477 /* L630: */
00478 }
00479
00480 i__1 = *igh;
00481 for (i__ = *low; i__ <= i__1; ++i__) {
00482 yr = zr[i__ + en * zr_dim1];
00483 yi = zi[i__ + en * zi_dim1];
00484 zr[i__ + en * zr_dim1] = sr * yr - si * yi;
00485 zi[i__ + en * zi_dim1] = sr * yi + si * yr;
00486 /* L640: */
00487 }
00488
00489 goto L240;
00490 /* .......... A ROOT FOUND .......... */
00491 L660:
00492 hr[en + en * hr_dim1] += tr;
00493 wr[en] = hr[en + en * hr_dim1];
00494 hi[en + en * hi_dim1] += ti;
00495 wi[en] = hi[en + en * hi_dim1];
00496 en = enm1;
00497 goto L220;
00498 /* .......... ALL ROOTS FOUND. BACKSUBSTITUTE TO FIND */
00499 /* VECTORS OF UPPER TRIANGULAR FORM .......... */
00500 L680:
00501 norm = 0.;
00502
00503 i__1 = *n;
00504 for (i__ = 1; i__ <= i__1; ++i__) {
00505
00506 i__2 = *n;
00507 for (j = i__; j <= i__2; ++j) {
00508 tr = (d__1 = hr[i__ + j * hr_dim1], abs(d__1)) + (d__2 = hi[i__ +
00509 j * hi_dim1], abs(d__2));
00510 if (tr > norm) {
00511 norm = tr;
00512 }
00513 /* L720: */
00514 }
00515 }
00516
00517 if (*n == 1 || norm == 0.) {
00518 goto L1001;
00519 }
00520 /* .......... FOR EN=N STEP -1 UNTIL 2 DO -- .......... */
00521 i__2 = *n;
00522 for (nn = 2; nn <= i__2; ++nn) {
00523 en = *n + 2 - nn;
00524 xr = wr[en];
00525 xi = wi[en];
00526 hr[en + en * hr_dim1] = 1.;
00527 hi[en + en * hi_dim1] = 0.;
00528 enm1 = en - 1;
00529 /* .......... FOR I=EN-1 STEP -1 UNTIL 1 DO -- .......... */
00530 i__1 = enm1;
00531 for (ii = 1; ii <= i__1; ++ii) {
00532 i__ = en - ii;
00533 zzr = 0.;
00534 zzi = 0.;
00535 ip1 = i__ + 1;
00536
00537 i__3 = en;
00538 for (j = ip1; j <= i__3; ++j) {
00539 zzr = zzr + hr[i__ + j * hr_dim1] * hr[j + en * hr_dim1] - hi[
00540 i__ + j * hi_dim1] * hi[j + en * hi_dim1];
00541 zzi = zzi + hr[i__ + j * hr_dim1] * hi[j + en * hi_dim1] + hi[
00542 i__ + j * hi_dim1] * hr[j + en * hr_dim1];
00543 /* L740: */
00544 }
00545
00546 yr = xr - wr[i__];
00547 yi = xi - wi[i__];
00548 if (yr != 0. || yi != 0.) {
00549 goto L765;
00550 }
00551 tst1 = norm;
00552 yr = tst1;
00553 L760:
00554 yr *= .01;
00555 tst2 = norm + yr;
00556 if (tst2 > tst1) {
00557 goto L760;
00558 }
00559 L765:
00560 cdiv_(&zzr, &zzi, &yr, &yi, &hr[i__ + en * hr_dim1], &hi[i__ + en
00561 * hi_dim1]);
00562 /* .......... OVERFLOW CONTROL .......... */
00563 tr = (d__1 = hr[i__ + en * hr_dim1], abs(d__1)) + (d__2 = hi[i__
00564 + en * hi_dim1], abs(d__2));
00565 if (tr == 0.) {
00566 goto L780;
00567 }
00568 tst1 = tr;
00569 tst2 = tst1 + 1. / tst1;
00570 if (tst2 > tst1) {
00571 goto L780;
00572 }
00573 i__3 = en;
00574 for (j = i__; j <= i__3; ++j) {
00575 hr[j + en * hr_dim1] /= tr;
00576 hi[j + en * hi_dim1] /= tr;
00577 /* L770: */
00578 }
00579
00580 L780:
00581 ;
00582 }
00583
00584 /* L800: */
00585 }
00586 /* .......... END BACKSUBSTITUTION .......... */
00587 enm1 = *n - 1;
00588 /* .......... VECTORS OF ISOLATED ROOTS .......... */
00589 i__2 = enm1;
00590 for (i__ = 1; i__ <= i__2; ++i__) {
00591 if (i__ >= *low && i__ <= *igh) {
00592 goto L840;
00593 }
00594 ip1 = i__ + 1;
00595
00596 i__1 = *n;
00597 for (j = ip1; j <= i__1; ++j) {
00598 zr[i__ + j * zr_dim1] = hr[i__ + j * hr_dim1];
00599 zi[i__ + j * zi_dim1] = hi[i__ + j * hi_dim1];
00600 /* L820: */
00601 }
00602
00603 L840:
00604 ;
00605 }
00606 /* .......... MULTIPLY BY TRANSFORMATION MATRIX TO GIVE */
00607 /* VECTORS OF ORIGINAL FULL MATRIX. */
00608 /* FOR J=N STEP -1 UNTIL LOW+1 DO -- .......... */
00609 i__2 = enm1;
00610 for (jj = *low; jj <= i__2; ++jj) {
00611 j = *n + *low - jj;
00612 m = min(j,*igh);
00613
00614 i__1 = *igh;
00615 for (i__ = *low; i__ <= i__1; ++i__) {
00616 zzr = 0.;
00617 zzi = 0.;
00618
00619 i__3 = m;
00620 for (k = *low; k <= i__3; ++k) {
00621 zzr = zzr + zr[i__ + k * zr_dim1] * hr[k + j * hr_dim1] - zi[
00622 i__ + k * zi_dim1] * hi[k + j * hi_dim1];
00623 zzi = zzi + zr[i__ + k * zr_dim1] * hi[k + j * hi_dim1] + zi[
00624 i__ + k * zi_dim1] * hr[k + j * hr_dim1];
00625 /* L860: */
00626 }
00627
00628 zr[i__ + j * zr_dim1] = zzr;
00629 zi[i__ + j * zi_dim1] = zzi;
00630 /* L880: */
00631 }
00632 }
00633
00634 goto L1001;
00635 /* .......... SET ERROR -- ALL EIGENVALUES HAVE NOT */
00636 /* CONVERGED AFTER 30*N ITERATIONS .......... */
00637 L1000:
00638 *ierr = en;
00639 L1001:
00640 return 0;
00641 } /* comqr2_ */
|
|
||||||||||||||||||||||||||||||||||||||||
|
Definition at line 8 of file eis_comqr.c. References abs, cdiv_(), csroot_(), l, min, and pythag_(). Referenced by cg_().
00011 {
00012 /* System generated locals */
00013 integer hr_dim1, hr_offset, hi_dim1, hi_offset, i__1, i__2;
00014 doublereal d__1, d__2, d__3, d__4;
00015
00016 /* Local variables */
00017 extern /* Subroutine */ int cdiv_(doublereal *, doublereal *, doublereal *
00018 , doublereal *, doublereal *, doublereal *);
00019 static doublereal norm;
00020 static integer i__, j, l, en, ll;
00021 static doublereal si, ti, xi, yi, sr, tr, xr, yr;
00022 extern doublereal pythag_(doublereal *, doublereal *);
00023 extern /* Subroutine */ int csroot_(doublereal *, doublereal *,
00024 doublereal *, doublereal *);
00025 static integer lp1, itn, its;
00026 static doublereal zzi, zzr;
00027 static integer enm1;
00028 static doublereal tst1, tst2;
00029
00030
00031
00032 /* THIS SUBROUTINE IS A TRANSLATION OF A UNITARY ANALOGUE OF THE */
00033 /* ALGOL PROCEDURE COMLR, NUM. MATH. 12, 369-376(1968) BY MARTIN */
00034 /* AND WILKINSON. */
00035 /* HANDBOOK FOR AUTO. COMP., VOL.II-LINEAR ALGEBRA, 396-403(1971). */
00036 /* THE UNITARY ANALOGUE SUBSTITUTES THE QR ALGORITHM OF FRANCIS */
00037 /* (COMP. JOUR. 4, 332-345(1962)) FOR THE LR ALGORITHM. */
00038
00039 /* THIS SUBROUTINE FINDS THE EIGENVALUES OF A COMPLEX */
00040 /* UPPER HESSENBERG MATRIX BY THE QR METHOD. */
00041
00042 /* ON INPUT */
00043
00044 /* NM MUST BE SET TO THE ROW DIMENSION OF TWO-DIMENSIONAL */
00045 /* ARRAY PARAMETERS AS DECLARED IN THE CALLING PROGRAM */
00046 /* DIMENSION STATEMENT. */
00047
00048 /* N IS THE ORDER OF THE MATRIX. */
00049
00050 /* LOW AND IGH ARE INTEGERS DETERMINED BY THE BALANCING */
00051 /* SUBROUTINE CBAL. IF CBAL HAS NOT BEEN USED, */
00052 /* SET LOW=1, IGH=N. */
00053
00054 /* HR AND HI CONTAIN THE REAL AND IMAGINARY PARTS, */
00055 /* RESPECTIVELY, OF THE COMPLEX UPPER HESSENBERG MATRIX. */
00056 /* THEIR LOWER TRIANGLES BELOW THE SUBDIAGONAL CONTAIN */
00057 /* INFORMATION ABOUT THE UNITARY TRANSFORMATIONS USED IN */
00058 /* THE REDUCTION BY CORTH, IF PERFORMED. */
00059
00060 /* ON OUTPUT */
00061
00062 /* THE UPPER HESSENBERG PORTIONS OF HR AND HI HAVE BEEN */
00063 /* DESTROYED. THEREFORE, THEY MUST BE SAVED BEFORE */
00064 /* CALLING COMQR IF SUBSEQUENT CALCULATION OF */
00065 /* EIGENVECTORS IS TO BE PERFORMED. */
00066
00067 /* WR AND WI CONTAIN THE REAL AND IMAGINARY PARTS, */
00068 /* RESPECTIVELY, OF THE EIGENVALUES. IF AN ERROR */
00069 /* EXIT IS MADE, THE EIGENVALUES SHOULD BE CORRECT */
00070 /* FOR INDICES IERR+1,...,N. */
00071
00072 /* IERR IS SET TO */
00073 /* ZERO FOR NORMAL RETURN, */
00074 /* J IF THE LIMIT OF 30*N ITERATIONS IS EXHAUSTED */
00075 /* WHILE THE J-TH EIGENVALUE IS BEING SOUGHT. */
00076
00077 /* CALLS CDIV FOR COMPLEX DIVISION. */
00078 /* CALLS CSROOT FOR COMPLEX SQUARE ROOT. */
00079 /* CALLS PYTHAG FOR DSQRT(A*A + B*B) . */
00080
00081 /* QUESTIONS AND COMMENTS SHOULD BE DIRECTED TO BURTON S. GARBOW, */
00082 /* MATHEMATICS AND COMPUTER SCIENCE DIV, ARGONNE NATIONAL LABORATORY
00083 */
00084
00085 /* THIS VERSION DATED AUGUST 1983. */
00086
00087 /* ------------------------------------------------------------------
00088 */
00089
00090 /* Parameter adjustments */
00091 --wi;
00092 --wr;
00093 hi_dim1 = *nm;
00094 hi_offset = hi_dim1 + 1;
00095 hi -= hi_offset;
00096 hr_dim1 = *nm;
00097 hr_offset = hr_dim1 + 1;
00098 hr -= hr_offset;
00099
00100 /* Function Body */
00101 *ierr = 0;
00102 if (*low == *igh) {
00103 goto L180;
00104 }
00105 /* .......... CREATE REAL SUBDIAGONAL ELEMENTS .......... */
00106 l = *low + 1;
00107
00108 i__1 = *igh;
00109 for (i__ = l; i__ <= i__1; ++i__) {
00110 /* Computing MIN */
00111 i__2 = i__ + 1;
00112 ll = min(i__2,*igh);
00113 if (hi[i__ + (i__ - 1) * hi_dim1] == 0.) {
00114 goto L170;
00115 }
00116 norm = pythag_(&hr[i__ + (i__ - 1) * hr_dim1], &hi[i__ + (i__ - 1) *
00117 hi_dim1]);
00118 yr = hr[i__ + (i__ - 1) * hr_dim1] / norm;
00119 yi = hi[i__ + (i__ - 1) * hi_dim1] / norm;
00120 hr[i__ + (i__ - 1) * hr_dim1] = norm;
00121 hi[i__ + (i__ - 1) * hi_dim1] = 0.;
00122
00123 i__2 = *igh;
00124 for (j = i__; j <= i__2; ++j) {
00125 si = yr * hi[i__ + j * hi_dim1] - yi * hr[i__ + j * hr_dim1];
00126 hr[i__ + j * hr_dim1] = yr * hr[i__ + j * hr_dim1] + yi * hi[i__
00127 + j * hi_dim1];
00128 hi[i__ + j * hi_dim1] = si;
00129 /* L155: */
00130 }
00131
00132 i__2 = ll;
00133 for (j = *low; j <= i__2; ++j) {
00134 si = yr * hi[j + i__ * hi_dim1] + yi * hr[j + i__ * hr_dim1];
00135 hr[j + i__ * hr_dim1] = yr * hr[j + i__ * hr_dim1] - yi * hi[j +
00136 i__ * hi_dim1];
00137 hi[j + i__ * hi_dim1] = si;
00138 /* L160: */
00139 }
00140
00141 L170:
00142 ;
00143 }
00144 /* .......... STORE ROOTS ISOLATED BY CBAL .......... */
00145 L180:
00146 i__1 = *n;
00147 for (i__ = 1; i__ <= i__1; ++i__) {
00148 if (i__ >= *low && i__ <= *igh) {
00149 goto L200;
00150 }
00151 wr[i__] = hr[i__ + i__ * hr_dim1];
00152 wi[i__] = hi[i__ + i__ * hi_dim1];
00153 L200:
00154 ;
00155 }
00156
00157 en = *igh;
00158 tr = 0.;
00159 ti = 0.;
00160 itn = *n * 30;
00161 /* .......... SEARCH FOR NEXT EIGENVALUE .......... */
00162 L220:
00163 if (en < *low) {
00164 goto L1001;
00165 }
00166 its = 0;
00167 enm1 = en - 1;
00168 /* .......... LOOK FOR SINGLE SMALL SUB-DIAGONAL ELEMENT */
00169 /* FOR L=EN STEP -1 UNTIL LOW D0 -- .......... */
00170 L240:
00171 i__1 = en;
00172 for (ll = *low; ll <= i__1; ++ll) {
00173 l = en + *low - ll;
00174 if (l == *low) {
00175 goto L300;
00176 }
00177 tst1 = (d__1 = hr[l - 1 + (l - 1) * hr_dim1], abs(d__1)) + (d__2 = hi[
00178 l - 1 + (l - 1) * hi_dim1], abs(d__2)) + (d__3 = hr[l + l *
00179 hr_dim1], abs(d__3)) + (d__4 = hi[l + l * hi_dim1], abs(d__4))
00180 ;
00181 tst2 = tst1 + (d__1 = hr[l + (l - 1) * hr_dim1], abs(d__1));
00182 if (tst2 == tst1) {
00183 goto L300;
00184 }
00185 /* L260: */
00186 }
00187 /* .......... FORM SHIFT .......... */
00188 L300:
00189 if (l == en) {
00190 goto L660;
00191 }
00192 if (itn == 0) {
00193 goto L1000;
00194 }
00195 if (its == 10 || its == 20) {
00196 goto L320;
00197 }
00198 sr = hr[en + en * hr_dim1];
00199 si = hi[en + en * hi_dim1];
00200 xr = hr[enm1 + en * hr_dim1] * hr[en + enm1 * hr_dim1];
00201 xi = hi[enm1 + en * hi_dim1] * hr[en + enm1 * hr_dim1];
00202 if (xr == 0. && xi == 0.) {
00203 goto L340;
00204 }
00205 yr = (hr[enm1 + enm1 * hr_dim1] - sr) / 2.;
00206 yi = (hi[enm1 + enm1 * hi_dim1] - si) / 2.;
00207 /* Computing 2nd power */
00208 d__2 = yr;
00209 /* Computing 2nd power */
00210 d__3 = yi;
00211 d__1 = d__2 * d__2 - d__3 * d__3 + xr;
00212 d__4 = yr * 2. * yi + xi;
00213 csroot_(&d__1, &d__4, &zzr, &zzi);
00214 if (yr * zzr + yi * zzi >= 0.) {
00215 goto L310;
00216 }
00217 zzr = -zzr;
00218 zzi = -zzi;
00219 L310:
00220 d__1 = yr + zzr;
00221 d__2 = yi + zzi;
00222 cdiv_(&xr, &xi, &d__1, &d__2, &xr, &xi);
00223 sr -= xr;
00224 si -= xi;
00225 goto L340;
00226 /* .......... FORM EXCEPTIONAL SHIFT .......... */
00227 L320:
00228 sr = (d__1 = hr[en + enm1 * hr_dim1], abs(d__1)) + (d__2 = hr[enm1 + (en
00229 - 2) * hr_dim1], abs(d__2));
00230 si = 0.;
00231
00232 L340:
00233 i__1 = en;
00234 for (i__ = *low; i__ <= i__1; ++i__) {
00235 hr[i__ + i__ * hr_dim1] -= sr;
00236 hi[i__ + i__ * hi_dim1] -= si;
00237 /* L360: */
00238 }
00239
00240 tr += sr;
00241 ti += si;
00242 ++its;
00243 --itn;
00244 /* .......... REDUCE TO TRIANGLE (ROWS) .......... */
00245 lp1 = l + 1;
00246
00247 i__1 = en;
00248 for (i__ = lp1; i__ <= i__1; ++i__) {
00249 sr = hr[i__ + (i__ - 1) * hr_dim1];
00250 hr[i__ + (i__ - 1) * hr_dim1] = 0.;
00251 d__1 = pythag_(&hr[i__ - 1 + (i__ - 1) * hr_dim1], &hi[i__ - 1 + (i__
00252 - 1) * hi_dim1]);
00253 norm = pythag_(&d__1, &sr);
00254 xr = hr[i__ - 1 + (i__ - 1) * hr_dim1] / norm;
00255 wr[i__ - 1] = xr;
00256 xi = hi[i__ - 1 + (i__ - 1) * hi_dim1] / norm;
00257 wi[i__ - 1] = xi;
00258 hr[i__ - 1 + (i__ - 1) * hr_dim1] = norm;
00259 hi[i__ - 1 + (i__ - 1) * hi_dim1] = 0.;
00260 hi[i__ + (i__ - 1) * hi_dim1] = sr / norm;
00261
00262 i__2 = en;
00263 for (j = i__; j <= i__2; ++j) {
00264 yr = hr[i__ - 1 + j * hr_dim1];
00265 yi = hi[i__ - 1 + j * hi_dim1];
00266 zzr = hr[i__ + j * hr_dim1];
00267 zzi = hi[i__ + j * hi_dim1];
00268 hr[i__ - 1 + j * hr_dim1] = xr * yr + xi * yi + hi[i__ + (i__ - 1)
00269 * hi_dim1] * zzr;
00270 hi[i__ - 1 + j * hi_dim1] = xr * yi - xi * yr + hi[i__ + (i__ - 1)
00271 * hi_dim1] * zzi;
00272 hr[i__ + j * hr_dim1] = xr * zzr - xi * zzi - hi[i__ + (i__ - 1) *
00273 hi_dim1] * yr;
00274 hi[i__ + j * hi_dim1] = xr * zzi + xi * zzr - hi[i__ + (i__ - 1) *
00275 hi_dim1] * yi;
00276 /* L490: */
00277 }
00278
00279 /* L500: */
00280 }
00281
00282 si = hi[en + en * hi_dim1];
00283 if (si == 0.) {
00284 goto L540;
00285 }
00286 norm = pythag_(&hr[en + en * hr_dim1], &si);
00287 sr = hr[en + en * hr_dim1] / norm;
00288 si /= norm;
00289 hr[en + en * hr_dim1] = norm;
00290 hi[en + en * hi_dim1] = 0.;
00291 /* .......... INVERSE OPERATION (COLUMNS) .......... */
00292 L540:
00293 i__1 = en;
00294 for (j = lp1; j <= i__1; ++j) {
00295 xr = wr[j - 1];
00296 xi = wi[j - 1];
00297
00298 i__2 = j;
00299 for (i__ = l; i__ <= i__2; ++i__) {
00300 yr = hr[i__ + (j - 1) * hr_dim1];
00301 yi = 0.;
00302 zzr = hr[i__ + j * hr_dim1];
00303 zzi = hi[i__ + j * hi_dim1];
00304 if (i__ == j) {
00305 goto L560;
00306 }
00307 yi = hi[i__ + (j - 1) * hi_dim1];
00308 hi[i__ + (j - 1) * hi_dim1] = xr * yi + xi * yr + hi[j + (j - 1) *
00309 hi_dim1] * zzi;
00310 L560:
00311 hr[i__ + (j - 1) * hr_dim1] = xr * yr - xi * yi + hi[j + (j - 1) *
00312 hi_dim1] * zzr;
00313 hr[i__ + j * hr_dim1] = xr * zzr + xi * zzi - hi[j + (j - 1) *
00314 hi_dim1] * yr;
00315 hi[i__ + j * hi_dim1] = xr * zzi - xi * zzr - hi[j + (j - 1) *
00316 hi_dim1] * yi;
00317 /* L580: */
00318 }
00319
00320 /* L600: */
00321 }
00322
00323 if (si == 0.) {
00324 goto L240;
00325 }
00326
00327 i__1 = en;
00328 for (i__ = l; i__ <= i__1; ++i__) {
00329 yr = hr[i__ + en * hr_dim1];
00330 yi = hi[i__ + en * hi_dim1];
00331 hr[i__ + en * hr_dim1] = sr * yr - si * yi;
00332 hi[i__ + en * hi_dim1] = sr * yi + si * yr;
00333 /* L630: */
00334 }
00335
00336 goto L240;
00337 /* .......... A ROOT FOUND .......... */
00338 L660:
00339 wr[en] = hr[en + en * hr_dim1] + tr;
00340 wi[en] = hi[en + en * hi_dim1] + ti;
00341 en = enm1;
00342 goto L220;
00343 /* .......... SET ERROR -- ALL EIGENVALUES HAVE NOT */
00344 /* CONVERGED AFTER 30*N ITERATIONS .......... */
00345 L1000:
00346 *ierr = en;
00347 L1001:
00348 return 0;
00349 } /* comqr_ */
|
|
||||||||||||||||||||||||||||||||||||||||||||
|
Definition at line 8 of file eis_cortb.c. References mp.
00011 {
00012 /* System generated locals */
00013 integer ar_dim1, ar_offset, ai_dim1, ai_offset, zr_dim1, zr_offset,
00014 zi_dim1, zi_offset, i__1, i__2, i__3;
00015
00016 /* Local variables */
00017 static doublereal h__;
00018 static integer i__, j, la;
00019 static doublereal gi, gr;
00020 static integer mm, mp, kp1, mp1;
00021
00022
00023
00024 /* THIS SUBROUTINE IS A TRANSLATION OF A COMPLEX ANALOGUE OF */
00025 /* THE ALGOL PROCEDURE ORTBAK, NUM. MATH. 12, 349-368(1968) */
00026 /* BY MARTIN AND WILKINSON. */
00027 /* HANDBOOK FOR AUTO. COMP., VOL.II-LINEAR ALGEBRA, 339-358(1971). */
00028
00029 /* THIS SUBROUTINE FORMS THE EIGENVECTORS OF A COMPLEX GENERAL */
00030 /* MATRIX BY BACK TRANSFORMING THOSE OF THE CORRESPONDING */
00031 /* UPPER HESSENBERG MATRIX DETERMINED BY CORTH. */
00032
00033 /* ON INPUT */
00034
00035 /* NM MUST BE SET TO THE ROW DIMENSION OF TWO-DIMENSIONAL */
00036 /* ARRAY PARAMETERS AS DECLARED IN THE CALLING PROGRAM */
00037 /* DIMENSION STATEMENT. */
00038
00039 /* LOW AND IGH ARE INTEGERS DETERMINED BY THE BALANCING */
00040 /* SUBROUTINE CBAL. IF CBAL HAS NOT BEEN USED, */
00041 /* SET LOW=1 AND IGH EQUAL TO THE ORDER OF THE MATRIX. */
00042
00043 /* AR AND AI CONTAIN INFORMATION ABOUT THE UNITARY */
00044 /* TRANSFORMATIONS USED IN THE REDUCTION BY CORTH */
00045 /* IN THEIR STRICT LOWER TRIANGLES. */
00046
00047 /* ORTR AND ORTI CONTAIN FURTHER INFORMATION ABOUT THE */
00048 /* TRANSFORMATIONS USED IN THE REDUCTION BY CORTH. */
00049 /* ONLY ELEMENTS LOW THROUGH IGH ARE USED. */
00050
00051 /* M IS THE NUMBER OF COLUMNS OF ZR AND ZI TO BE BACK TRANSFORMED.
00052 */
00053
00054 /* ZR AND ZI CONTAIN THE REAL AND IMAGINARY PARTS, */
00055 /* RESPECTIVELY, OF THE EIGENVECTORS TO BE */
00056 /* BACK TRANSFORMED IN THEIR FIRST M COLUMNS. */
00057
00058 /* ON OUTPUT */
00059
00060 /* ZR AND ZI CONTAIN THE REAL AND IMAGINARY PARTS, */
00061 /* RESPECTIVELY, OF THE TRANSFORMED EIGENVECTORS */
00062 /* IN THEIR FIRST M COLUMNS. */
00063
00064 /* ORTR AND ORTI HAVE BEEN ALTERED. */
00065
00066 /* NOTE THAT CORTB PRESERVES VECTOR EUCLIDEAN NORMS. */
00067
00068 /* QUESTIONS AND COMMENTS SHOULD BE DIRECTED TO BURTON S. GARBOW, */
00069 /* MATHEMATICS AND COMPUTER SCIENCE DIV, ARGONNE NATIONAL LABORATORY
00070 */
00071
00072 /* THIS VERSION DATED AUGUST 1983. */
00073
00074 /* ------------------------------------------------------------------
00075 */
00076
00077 /* Parameter adjustments */
00078 --orti;
00079 --ortr;
00080 ai_dim1 = *nm;
00081 ai_offset = ai_dim1 + 1;
00082 ai -= ai_offset;
00083 ar_dim1 = *nm;
00084 ar_offset = ar_dim1 + 1;
00085 ar -= ar_offset;
00086 zi_dim1 = *nm;
00087 zi_offset = zi_dim1 + 1;
00088 zi -= zi_offset;
00089 zr_dim1 = *nm;
00090 zr_offset = zr_dim1 + 1;
00091 zr -= zr_offset;
00092
00093 /* Function Body */
00094 if (*m == 0) {
00095 goto L200;
00096 }
00097 la = *igh - 1;
00098 kp1 = *low + 1;
00099 if (la < kp1) {
00100 goto L200;
00101 }
00102 /* .......... FOR MP=IGH-1 STEP -1 UNTIL LOW+1 DO -- .......... */
00103 i__1 = la;
00104 for (mm = kp1; mm <= i__1; ++mm) {
00105 mp = *low + *igh - mm;
00106 if (ar[mp + (mp - 1) * ar_dim1] == 0. && ai[mp + (mp - 1) * ai_dim1]
00107 == 0.) {
00108 goto L140;
00109 }
00110 /* .......... H BELOW IS NEGATIVE OF H FORMED IN CORTH ..........
00111 */
00112 h__ = ar[mp + (mp - 1) * ar_dim1] * ortr[mp] + ai[mp + (mp - 1) *
00113 ai_dim1] * orti[mp];
00114 mp1 = mp + 1;
00115
00116 i__2 = *igh;
00117 for (i__ = mp1; i__ <= i__2; ++i__) {
00118 ortr[i__] = ar[i__ + (mp - 1) * ar_dim1];
00119 orti[i__] = ai[i__ + (mp - 1) * ai_dim1];
00120 /* L100: */
00121 }
00122
00123 i__2 = *m;
00124 for (j = 1; j <= i__2; ++j) {
00125 gr = 0.;
00126 gi = 0.;
00127
00128 i__3 = *igh;
00129 for (i__ = mp; i__ <= i__3; ++i__) {
00130 gr = gr + ortr[i__] * zr[i__ + j * zr_dim1] + orti[i__] * zi[
00131 i__ + j * zi_dim1];
00132 gi = gi + ortr[i__] * zi[i__ + j * zi_dim1] - orti[i__] * zr[
00133 i__ + j * zr_dim1];
00134 /* L110: */
00135 }
00136
00137 gr /= h__;
00138 gi /= h__;
00139
00140 i__3 = *igh;
00141 for (i__ = mp; i__ <= i__3; ++i__) {
00142 zr[i__ + j * zr_dim1] = zr[i__ + j * zr_dim1] + gr * ortr[i__]
00143 - gi * orti[i__];
00144 zi[i__ + j * zi_dim1] = zi[i__ + j * zi_dim1] + gr * orti[i__]
00145 + gi * ortr[i__];
00146 /* L120: */
00147 }
00148
00149 /* L130: */
00150 }
00151
00152 L140:
00153 ;
00154 }
00155
00156 L200:
00157 return 0;
00158 } /* cortb_ */
|
|
||||||||||||||||||||||||||||||||||||
|
Definition at line 8 of file eis_corth.c. References abs, mp, pythag_(), and scale. Referenced by cg_().
00011 {
00012 /* System generated locals */
00013 integer ar_dim1, ar_offset, ai_dim1, ai_offset, i__1, i__2, i__3;
00014 doublereal d__1, d__2;
00015
00016 /* Builtin functions */
00017 double sqrt(doublereal);
00018
00019 /* Local variables */
00020 static doublereal f, g, h__;
00021 static integer i__, j, m;
00022 static doublereal scale;
00023 static integer la;
00024 static doublereal fi;
00025 static integer ii, jj;
00026 static doublereal fr;
00027 static integer mp;
00028 extern doublereal pythag_(doublereal *, doublereal *);
00029 static integer kp1;
00030
00031
00032
00033 /* THIS SUBROUTINE IS A TRANSLATION OF A COMPLEX ANALOGUE OF */
00034 /* THE ALGOL PROCEDURE ORTHES, NUM. MATH. 12, 349-368(1968) */
00035 /* BY MARTIN AND WILKINSON. */
00036 /* HANDBOOK FOR AUTO. COMP., VOL.II-LINEAR ALGEBRA, 339-358(1971). */
00037
00038 /* GIVEN A COMPLEX GENERAL MATRIX, THIS SUBROUTINE */
00039 /* REDUCES A SUBMATRIX SITUATED IN ROWS AND COLUMNS */
00040 /* LOW THROUGH IGH TO UPPER HESSENBERG FORM BY */
00041 /* UNITARY SIMILARITY TRANSFORMATIONS. */
00042
00043 /* ON INPUT */
00044
00045 /* NM MUST BE SET TO THE ROW DIMENSION OF TWO-DIMENSIONAL */
00046 /* ARRAY PARAMETERS AS DECLARED IN THE CALLING PROGRAM */
00047 /* DIMENSION STATEMENT. */
00048
00049 /* N IS THE ORDER OF THE MATRIX. */
00050
00051 /* LOW AND IGH ARE INTEGERS DETERMINED BY THE BALANCING */
00052 /* SUBROUTINE CBAL. IF CBAL HAS NOT BEEN USED, */
00053 /* SET LOW=1, IGH=N. */
00054
00055 /* AR AND AI CONTAIN THE REAL AND IMAGINARY PARTS, */
00056 /* RESPECTIVELY, OF THE COMPLEX INPUT MATRIX. */
00057
00058 /* ON OUTPUT */
00059
00060 /* AR AND AI CONTAIN THE REAL AND IMAGINARY PARTS, */
00061 /* RESPECTIVELY, OF THE HESSENBERG MATRIX. INFORMATION */
00062 /* ABOUT THE UNITARY TRANSFORMATIONS USED IN THE REDUCTION */
00063 /* IS STORED IN THE REMAINING TRIANGLES UNDER THE */
00064 /* HESSENBERG MATRIX. */
00065
00066 /* ORTR AND ORTI CONTAIN FURTHER INFORMATION ABOUT THE */
00067 /* TRANSFORMATIONS. ONLY ELEMENTS LOW THROUGH IGH ARE USED. */
00068
00069 /* CALLS PYTHAG FOR DSQRT(A*A + B*B) . */
00070
00071 /* QUESTIONS AND COMMENTS SHOULD BE DIRECTED TO BURTON S. GARBOW, */
00072 /* MATHEMATICS AND COMPUTER SCIENCE DIV, ARGONNE NATIONAL LABORATORY
00073 */
00074
00075 /* THIS VERSION DATED AUGUST 1983. */
00076
00077 /* ------------------------------------------------------------------
00078 */
00079
00080 /* Parameter adjustments */
00081 ai_dim1 = *nm;
00082 ai_offset = ai_dim1 + 1;
00083 ai -= ai_offset;
00084 ar_dim1 = *nm;
00085 ar_offset = ar_dim1 + 1;
00086 ar -= ar_offset;
00087 --orti;
00088 --ortr;
00089
00090 /* Function Body */
00091 la = *igh - 1;
00092 kp1 = *low + 1;
00093 if (la < kp1) {
00094 goto L200;
00095 }
00096
00097 i__1 = la;
00098 for (m = kp1; m <= i__1; ++m) {
00099 h__ = 0.;
00100 ortr[m] = 0.;
00101 orti[m] = 0.;
00102 scale = 0.;
00103 /* .......... SCALE COLUMN (ALGOL TOL THEN NOT NEEDED) ..........
00104 */
00105 i__2 = *igh;
00106 for (i__ = m; i__ <= i__2; ++i__) {
00107 /* L90: */
00108 scale = scale + (d__1 = ar[i__ + (m - 1) * ar_dim1], abs(d__1)) +
00109 (d__2 = ai[i__ + (m - 1) * ai_dim1], abs(d__2));
00110 }
00111
00112 if (scale == 0.) {
00113 goto L180;
00114 }
00115 mp = m + *igh;
00116 /* .......... FOR I=IGH STEP -1 UNTIL M DO -- .......... */
00117 i__2 = *igh;
00118 for (ii = m; ii <= i__2; ++ii) {
00119 i__ = mp - ii;
00120 ortr[i__] = ar[i__ + (m - 1) * ar_dim1] / scale;
00121 orti[i__] = ai[i__ + (m - 1) * ai_dim1] / scale;
00122 h__ = h__ + ortr[i__] * ortr[i__] + orti[i__] * orti[i__];
00123 /* L100: */
00124 }
00125
00126 g = sqrt(h__);
00127 f = pythag_(&ortr[m], &orti[m]);
00128 if (f == 0.) {
00129 goto L103;
00130 }
00131 h__ += f * g;
00132 g /= f;
00133 ortr[m] = (g + 1.) * ortr[m];
00134 orti[m] = (g + 1.) * orti[m];
00135 goto L105;
00136
00137 L103:
00138 ortr[m] = g;
00139 ar[m + (m - 1) * ar_dim1] = scale;
00140 /* .......... FORM (I-(U*UT)/H) * A .......... */
00141 L105:
00142 i__2 = *n;
00143 for (j = m; j <= i__2; ++j) {
00144 fr = 0.;
00145 fi = 0.;
00146 /* .......... FOR I=IGH STEP -1 UNTIL M DO -- .......... */
00147 i__3 = *igh;
00148 for (ii = m; ii <= i__3; ++ii) {
00149 i__ = mp - ii;
00150 fr = fr + ortr[i__] * ar[i__ + j * ar_dim1] + orti[i__] * ai[
00151 i__ + j * ai_dim1];
00152 fi = fi + ortr[i__] * ai[i__ + j * ai_dim1] - orti[i__] * ar[
00153 i__ + j * ar_dim1];
00154 /* L110: */
00155 }
00156
00157 fr /= h__;
00158 fi /= h__;
00159
00160 i__3 = *igh;
00161 for (i__ = m; i__ <= i__3; ++i__) {
00162 ar[i__ + j * ar_dim1] = ar[i__ + j * ar_dim1] - fr * ortr[i__]
00163 + fi * orti[i__];
00164 ai[i__ + j * ai_dim1] = ai[i__ + j * ai_dim1] - fr * orti[i__]
00165 - fi * ortr[i__];
00166 /* L120: */
00167 }
00168
00169 /* L130: */
00170 }
00171 /* .......... FORM (I-(U*UT)/H)*A*(I-(U*UT)/H) .......... */
00172 i__2 = *igh;
00173 for (i__ = 1; i__ <= i__2; ++i__) {
00174 fr = 0.;
00175 fi = 0.;
00176 /* .......... FOR J=IGH STEP -1 UNTIL M DO -- .......... */
00177 i__3 = *igh;
00178 for (jj = m; jj <= i__3; ++jj) {
00179 j = mp - jj;
00180 fr = fr + ortr[j] * ar[i__ + j * ar_dim1] - orti[j] * ai[i__
00181 + j * ai_dim1];
00182 fi = fi + ortr[j] * ai[i__ + j * ai_dim1] + orti[j] * ar[i__
00183 + j * ar_dim1];
00184 /* L140: */
00185 }
00186
00187 fr /= h__;
00188 fi /= h__;
00189
00190 i__3 = *igh;
00191 for (j = m; j <= i__3; ++j) {
00192 ar[i__ + j * ar_dim1] = ar[i__ + j * ar_dim1] - fr * ortr[j]
00193 - fi * orti[j];
00194 ai[i__ + j * ai_dim1] = ai[i__ + j * ai_dim1] + fr * orti[j]
00195 - fi * ortr[j];
00196 /* L150: */
00197 }
00198
00199 /* L160: */
00200 }
00201
00202 ortr[m] = scale * ortr[m];
00203 orti[m] = scale * orti[m];
00204 ar[m + (m - 1) * ar_dim1] = -g * ar[m + (m - 1) * ar_dim1];
00205 ai[m + (m - 1) * ai_dim1] = -g * ai[m + (m - 1) * ai_dim1];
00206 L180:
00207 ;
00208 }
00209
00210 L200:
00211 return 0;
00212 } /* corth_ */
|
|
||||||||||||||||||||
|
Definition at line 8 of file eis_csroot.c. References abs, and pythag_(). Referenced by comlr2_(), comlr_(), comqr2_(), and comqr_().
00010 {
00011 /* Builtin functions */
00012 double sqrt(doublereal);
00013
00014 /* Local variables */
00015 static doublereal s, ti, tr;
00016 extern doublereal pythag_(doublereal *, doublereal *);
00017
00018
00019 /* (YR,YI) = COMPLEX DSQRT(XR,XI) */
00020 /* BRANCH CHOSEN SO THAT YR .GE. 0.0 AND SIGN(YI) .EQ. SIGN(XI) */
00021
00022 tr = *xr;
00023 ti = *xi;
00024 s = sqrt((pythag_(&tr, &ti) + abs(tr)) * .5);
00025 if (tr >= 0.) {
00026 *yr = s;
00027 }
00028 if (ti < 0.) {
00029 s = -s;
00030 }
00031 if (tr <= 0.) {
00032 *yi = s;
00033 }
00034 if (tr < 0.) {
00035 *yr = ti / *yi * .5;
00036 }
00037 if (tr > 0.) {
00038 *yi = ti / *yr * .5;
00039 }
00040 return 0;
00041 } /* csroot_ */
|
|
||||||||||||||||||||||||||||||||
|
Definition at line 8 of file eis_elmbak.c.
00010 {
00011 /* System generated locals */
00012 integer a_dim1, a_offset, z_dim1, z_offset, i__1, i__2, i__3;
00013
00014 /* Local variables */
00015 static integer i__, j;
00016 static doublereal x;
00017 static integer la, mm, mp, kp1, mp1;
00018
00019
00020
00021 /* THIS SUBROUTINE IS A TRANSLATION OF THE ALGOL PROCEDURE ELMBAK, */
00022 /* NUM. MATH. 12, 349-368(1968) BY MARTIN AND WILKINSON. */
00023 /* HANDBOOK FOR AUTO. COMP., VOL.II-LINEAR ALGEBRA, 339-358(1971). */
00024
00025 /* THIS SUBROUTINE FORMS THE EIGENVECTORS OF A REAL GENERAL */
00026 /* MATRIX BY BACK TRANSFORMING THOSE OF THE CORRESPONDING */
00027 /* UPPER HESSENBERG MATRIX DETERMINED BY ELMHES. */
00028
00029 /* ON INPUT */
00030
00031 /* NM MUST BE SET TO THE ROW DIMENSION OF TWO-DIMENSIONAL */
00032 /* ARRAY PARAMETERS AS DECLARED IN THE CALLING PROGRAM */
00033 /* DIMENSION STATEMENT. */
00034
00035 /* LOW AND IGH ARE INTEGERS DETERMINED BY THE BALANCING */
00036 /* SUBROUTINE BALANC. IF BALANC HAS NOT BEEN USED, */
00037 /* SET LOW=1 AND IGH EQUAL TO THE ORDER OF THE MATRIX. */
00038
00039 /* A CONTAINS THE MULTIPLIERS WHICH WERE USED IN THE */
00040 /* REDUCTION BY ELMHES IN ITS LOWER TRIANGLE */
00041 /* BELOW THE SUBDIAGONAL. */
00042
00043 /* INT CONTAINS INFORMATION ON THE ROWS AND COLUMNS */
00044 /* INTERCHANGED IN THE REDUCTION BY ELMHES. */
00045 /* ONLY ELEMENTS LOW THROUGH IGH ARE USED. */
00046
00047 /* M IS THE NUMBER OF COLUMNS OF Z TO BE BACK TRANSFORMED. */
00048
00049 /* Z CONTAINS THE REAL AND IMAGINARY PARTS OF THE EIGEN- */
00050 /* VECTORS TO BE BACK TRANSFORMED IN ITS FIRST M COLUMNS. */
00051
00052 /* ON OUTPUT */
00053
00054 /* Z CONTAINS THE REAL AND IMAGINARY PARTS OF THE */
00055 /* TRANSFORMED EIGENVECTORS IN ITS FIRST M COLUMNS. */
00056
00057 /* QUESTIONS AND COMMENTS SHOULD BE DIRECTED TO BURTON S. GARBOW, */
00058 /* MATHEMATICS AND COMPUTER SCIENCE DIV, ARGONNE NATIONAL LABORATORY
00059 */
00060
00061 /* THIS VERSION DATED AUGUST 1983. */
00062
00063 /* ------------------------------------------------------------------
00064 */
00065
00066 /* Parameter adjustments */
00067 --int__;
00068 a_dim1 = *nm;
00069 a_offset = a_dim1 + 1;
00070 a -= a_offset;
00071 z_dim1 = *nm;
00072 z_offset = z_dim1 + 1;
00073 z__ -= z_offset;
00074
00075 /* Function Body */
00076 if (*m == 0) {
00077 goto L200;
00078 }
00079 la = *igh - 1;
00080 kp1 = *low + 1;
00081 if (la < kp1) {
00082 goto L200;
00083 }
00084 /* .......... FOR MP=IGH-1 STEP -1 UNTIL LOW+1 DO -- .......... */
00085 i__1 = la;
00086 for (mm = kp1; mm <= i__1; ++mm) {
00087 mp = *low + *igh - mm;
00088 mp1 = mp + 1;
00089
00090 i__2 = *igh;
00091 for (i__ = mp1; i__ <= i__2; ++i__) {
00092 x = a[i__ + (mp - 1) * a_dim1];
00093 if (x == 0.) {
00094 goto L110;
00095 }
00096
00097 i__3 = *m;
00098 for (j = 1; j <= i__3; ++j) {
00099 /* L100: */
00100 z__[i__ + j * z_dim1] += x * z__[mp + j * z_dim1];
00101 }
00102
00103 L110:
00104 ;
00105 }
00106
00107 i__ = int__[mp];
00108 if (i__ == mp) {
00109 goto L140;
00110 }
00111
00112 i__2 = *m;
00113 for (j = 1; j <= i__2; ++j) {
00114 x = z__[i__ + j * z_dim1];
00115 z__[i__ + j * z_dim1] = z__[mp + j * z_dim1];
00116 z__[mp + j * z_dim1] = x;
00117 /* L130: */
00118 }
00119
00120 L140:
00121 ;
00122 }
00123
00124 L200:
00125 return 0;
00126 } /* elmbak_ */
|
|
||||||||||||||||||||||||||||
|
Definition at line 8 of file eis_elmhes.c. Referenced by rg_().
00010 {
00011 /* System generated locals */
00012 integer a_dim1, a_offset, i__1, i__2, i__3;
00013 doublereal d__1;
00014
00015 /* Local variables */
00016 static integer i__, j, m;
00017 static doublereal x, y;
00018 static integer la, mm1, kp1, mp1;
00019
00020
00021
00022 /* THIS SUBROUTINE IS A TRANSLATION OF THE ALGOL PROCEDURE ELMHES, */
00023 /* NUM. MATH. 12, 349-368(1968) BY MARTIN AND WILKINSON. */
00024 /* HANDBOOK FOR AUTO. COMP., VOL.II-LINEAR ALGEBRA, 339-358(1971). */
00025
00026 /* GIVEN A REAL GENERAL MATRIX, THIS SUBROUTINE */
00027 /* REDUCES A SUBMATRIX SITUATED IN ROWS AND COLUMNS */
00028 /* LOW THROUGH IGH TO UPPER HESSENBERG FORM BY */
00029 /* STABILIZED ELEMENTARY SIMILARITY TRANSFORMATIONS. */
00030
00031 /* ON INPUT */
00032
00033 /* NM MUST BE SET TO THE ROW DIMENSION OF TWO-DIMENSIONAL */
00034 /* ARRAY PARAMETERS AS DECLARED IN THE CALLING PROGRAM */
00035 /* DIMENSION STATEMENT. */
00036
00037 /* N IS THE ORDER OF THE MATRIX. */
00038
00039 /* LOW AND IGH ARE INTEGERS DETERMINED BY THE BALANCING */
00040 /* SUBROUTINE BALANC. IF BALANC HAS NOT BEEN USED, */
00041 /* SET LOW=1, IGH=N. */
00042
00043 /* A CONTAINS THE INPUT MATRIX. */
00044
00045 /* ON OUTPUT */
00046
00047 /* A CONTAINS THE HESSENBERG MATRIX. THE MULTIPLIERS */
00048 /* WHICH WERE USED IN THE REDUCTION ARE STORED IN THE */
00049 /* REMAINING TRIANGLE UNDER THE HESSENBERG MATRIX. */
00050
00051 /* INT CONTAINS INFORMATION ON THE ROWS AND COLUMNS */
00052 /* INTERCHANGED IN THE REDUCTION. */
00053 /* ONLY ELEMENTS LOW THROUGH IGH ARE USED. */
00054
00055 /* QUESTIONS AND COMMENTS SHOULD BE DIRECTED TO BURTON S. GARBOW, */
00056 /* MATHEMATICS AND COMPUTER SCIENCE DIV, ARGONNE NATIONAL LABORATORY
00057 */
00058
00059 /* THIS VERSION DATED AUGUST 1983. */
00060
00061 /* ------------------------------------------------------------------
00062 */
00063
00064 /* Parameter adjustments */
00065 a_dim1 = *nm;
00066 a_offset = a_dim1 + 1;
00067 a -= a_offset;
00068 --int__;
00069
00070 /* Function Body */
00071 la = *igh - 1;
00072 kp1 = *low + 1;
00073 if (la < kp1) {
00074 goto L200;
00075 }
00076
00077 i__1 = la;
00078 for (m = kp1; m <= i__1; ++m) {
00079 mm1 = m - 1;
00080 x = 0.;
00081 i__ = m;
00082
00083 i__2 = *igh;
00084 for (j = m; j <= i__2; ++j) {
00085 if ((d__1 = a[j + mm1 * a_dim1], abs(d__1)) <= abs(x)) {
00086 goto L100;
00087 }
00088 x = a[j + mm1 * a_dim1];
00089 i__ = j;
00090 L100:
00091 ;
00092 }
00093
00094 int__[m] = i__;
00095 if (i__ == m) {
00096 goto L130;
00097 }
00098 /* .......... INTERCHANGE ROWS AND COLUMNS OF A .......... */
00099 i__2 = *n;
00100 for (j = mm1; j <= i__2; ++j) {
00101 y = a[i__ + j * a_dim1];
00102 a[i__ + j * a_dim1] = a[m + j * a_dim1];
00103 a[m + j * a_dim1] = y;
00104 /* L110: */
00105 }
00106
00107 i__2 = *igh;
00108 for (j = 1; j <= i__2; ++j) {
00109 y = a[j + i__ * a_dim1];
00110 a[j + i__ * a_dim1] = a[j + m * a_dim1];
00111 a[j + m * a_dim1] = y;
00112 /* L120: */
00113 }
00114 /* .......... END INTERCHANGE .......... */
00115 L130:
00116 if (x == 0.) {
00117 goto L180;
00118 }
00119 mp1 = m + 1;
00120
00121 i__2 = *igh;
00122 for (i__ = mp1; i__ <= i__2; ++i__) {
00123 y = a[i__ + mm1 * a_dim1];
00124 if (y == 0.) {
00125 goto L160;
00126 }
00127 y /= x;
00128 a[i__ + mm1 * a_dim1] = y;
00129
00130 i__3 = *n;
00131 for (j = m; j <= i__3; ++j) {
00132 /* L140: */
00133 a[i__ + j * a_dim1] -= y * a[m + j * a_dim1];
00134 }
00135
00136 i__3 = *igh;
00137 for (j = 1; j <= i__3; ++j) {
00138 /* L150: */
00139 a[j + m * a_dim1] += y * a[j + i__ * a_dim1];
00140 }
00141
00142 L160:
00143 ;
00144 }
00145
00146 L180:
00147 ;
00148 }
00149
00150 L200:
00151 return 0;
00152 } /* elmhes_ */
|
|
||||||||||||||||||||||||||||||||
|
Definition at line 8 of file eis_eltran.c. Referenced by rg_().
00010 {
00011 /* System generated locals */
00012 integer a_dim1, a_offset, z_dim1, z_offset, i__1, i__2;
00013
00014 /* Local variables */
00015 static integer i__, j, kl, mm, mp, mp1;
00016
00017
00018
00019 /* THIS SUBROUTINE IS A TRANSLATION OF THE ALGOL PROCEDURE ELMTRANS,
00020 */
00021 /* NUM. MATH. 16, 181-204(1970) BY PETERS AND WILKINSON. */
00022 /* HANDBOOK FOR AUTO. COMP., VOL.II-LINEAR ALGEBRA, 372-395(1971). */
00023
00024 /* THIS SUBROUTINE ACCUMULATES THE STABILIZED ELEMENTARY */
00025 /* SIMILARITY TRANSFORMATIONS USED IN THE REDUCTION OF A */
00026 /* REAL GENERAL MATRIX TO UPPER HESSENBERG FORM BY ELMHES. */
00027
00028 /* ON INPUT */
00029
00030 /* NM MUST BE SET TO THE ROW DIMENSION OF TWO-DIMENSIONAL */
00031 /* ARRAY PARAMETERS AS DECLARED IN THE CALLING PROGRAM */
00032 /* DIMENSION STATEMENT. */
00033
00034 /* N IS THE ORDER OF THE MATRIX. */
00035
00036 /* LOW AND IGH ARE INTEGERS DETERMINED BY THE BALANCING */
00037 /* SUBROUTINE BALANC. IF BALANC HAS NOT BEEN USED, */
00038 /* SET LOW=1, IGH=N. */
00039
00040 /* A CONTAINS THE MULTIPLIERS WHICH WERE USED IN THE */
00041 /* REDUCTION BY ELMHES IN ITS LOWER TRIANGLE */
00042 /* BELOW THE SUBDIAGONAL. */
00043
00044 /* INT CONTAINS INFORMATION ON THE ROWS AND COLUMNS */
00045 /* INTERCHANGED IN THE REDUCTION BY ELMHES. */
00046 /* ONLY ELEMENTS LOW THROUGH IGH ARE USED. */
00047
00048 /* ON OUTPUT */
00049
00050 /* Z CONTAINS THE TRANSFORMATION MATRIX PRODUCED IN THE */
00051 /* REDUCTION BY ELMHES. */
00052
00053 /* QUESTIONS AND COMMENTS SHOULD BE DIRECTED TO BURTON S. GARBOW, */
00054 /* MATHEMATICS AND COMPUTER SCIENCE DIV, ARGONNE NATIONAL LABORATORY
00055 */
00056
00057 /* THIS VERSION DATED AUGUST 1983. */
00058
00059 /* ------------------------------------------------------------------
00060 */
00061
00062 /* .......... INITIALIZE Z TO IDENTITY MATRIX .......... */
00063 /* Parameter adjustments */
00064 z_dim1 = *nm;
00065 z_offset = z_dim1 + 1;
00066 z__ -= z_offset;
00067 --int__;
00068 a_dim1 = *nm;
00069 a_offset = a_dim1 + 1;
00070 a -= a_offset;
00071
00072 /* Function Body */
00073 i__1 = *n;
00074 for (j = 1; j <= i__1; ++j) {
00075
00076 i__2 = *n;
00077 for (i__ = 1; i__ <= i__2; ++i__) {
00078 /* L60: */
00079 z__[i__ + j * z_dim1] = 0.;
00080 }
00081
00082 z__[j + j * z_dim1] = 1.;
00083 /* L80: */
00084 }
00085
00086 kl = *igh - *low - 1;
00087 if (kl < 1) {
00088 goto L200;
00089 }
00090 /* .......... FOR MP=IGH-1 STEP -1 UNTIL LOW+1 DO -- .......... */
00091 i__1 = kl;
00092 for (mm = 1; mm <= i__1; ++mm) {
00093 mp = *igh - mm;
00094 mp1 = mp + 1;
00095
00096 i__2 = *igh;
00097 for (i__ = mp1; i__ <= i__2; ++i__) {
00098 /* L100: */
00099 z__[i__ + mp * z_dim1] = a[i__ + (mp - 1) * a_dim1];
00100 }
00101
00102 i__ = int__[mp];
00103 if (i__ == mp) {
00104 goto L140;
00105 }
00106
00107 i__2 = *igh;
00108 for (j = mp; j <= i__2; ++j) {
00109 z__[mp + j * z_dim1] = z__[i__ + j * z_dim1];
00110 z__[i__ + j * z_dim1] = 0.;
00111 /* L130: */
00112 }
00113
00114 z__[i__ + mp * z_dim1] = 1.;
00115 L140:
00116 ;
00117 }
00118
00119 L200:
00120 return 0;
00121 } /* eltran_ */
|
|
|
Definition at line 8 of file eis_epslon.c. Referenced by bandv_(), bisect_(), cinvit_(), invit_(), qzit_(), ratqr_(), tinvit_(), tqlrat_(), tridib_(), and tsturm_().
00009 {
00010 /* System generated locals */
00011 doublereal ret_val, d__1;
00012
00013 /* Local variables */
00014 static doublereal a, b, c__, eps;
00015
00016
00017 /* ESTIMATE UNIT ROUNDOFF IN QUANTITIES OF SIZE X. */
00018
00019
00020 /* THIS PROGRAM SHOULD FUNCTION PROPERLY ON ALL SYSTEMS */
00021 /* SATISFYING THE FOLLOWING TWO ASSUMPTIONS, */
00022 /* 1. THE BASE USED IN REPRESENTING FLOATING POINT */
00023 /* NUMBERS IS NOT A POWER OF THREE. */
00024 /* 2. THE QUANTITY A IN STATEMENT 10 IS REPRESENTED TO */
00025 /* THE ACCURACY USED IN FLOATING POINT VARIABLES */
00026 /* THAT ARE STORED IN MEMORY. */
00027 /* THE STATEMENT NUMBER 10 AND THE GO TO 10 ARE INTENDED TO */
00028 /* FORCE OPTIMIZING COMPILERS TO GENERATE CODE SATISFYING */
00029 /* ASSUMPTION 2. */
00030 /* UNDER THESE ASSUMPTIONS, IT SHOULD BE TRUE THAT, */
00031 /* A IS NOT EXACTLY EQUAL TO FOUR-THIRDS, */
00032 /* B HAS A ZERO FOR ITS LAST BIT OR DIGIT, */
00033 /* C IS NOT EXACTLY EQUAL TO ONE, */
00034 /* EPS MEASURES THE SEPARATION OF 1.0 FROM */
00035 /* THE NEXT LARGER FLOATING POINT NUMBER. */
00036 /* THE DEVELOPERS OF EISPACK WOULD APPRECIATE BEING INFORMED */
00037 /* ABOUT ANY SYSTEMS WHERE THESE ASSUMPTIONS DO NOT HOLD. */
00038
00039 /* THIS VERSION DATED 4/6/83. */
00040
00041 a = 1.3333333333333333;
00042 L10:
00043 b = a - 1.;
00044 c__ = b + b + b;
00045 eps = (d__1 = c__ - 1., abs(d__1));
00046 if (eps == 0.) {
00047 goto L10;
00048 }
00049 ret_val = eps * abs(*x);
00050 return ret_val;
00051 } /* epslon_ */
|
|
||||||||||||||||||||||||||||||||
|
Definition at line 8 of file eis_figi2.c. Referenced by rt_().
00010 {
00011 /* System generated locals */
00012 integer t_dim1, t_offset, z_dim1, z_offset, i__1, i__2;
00013
00014 /* Builtin functions */
00015 double sqrt(doublereal);
00016
00017 /* Local variables */
00018 static doublereal h__;
00019 static integer i__, j;
00020
00021
00022
00023 /* GIVEN A NONSYMMETRIC TRIDIAGONAL MATRIX SUCH THAT THE PRODUCTS */
00024 /* OF CORRESPONDING PAIRS OF OFF-DIAGONAL ELEMENTS ARE ALL */
00025 /* NON-NEGATIVE, AND ZERO ONLY WHEN BOTH FACTORS ARE ZERO, THIS */
00026 /* SUBROUTINE REDUCES IT TO A SYMMETRIC TRIDIAGONAL MATRIX */
00027 /* USING AND ACCUMULATING DIAGONAL SIMILARITY TRANSFORMATIONS. */
00028
00029 /* ON INPUT */
00030
00031 /* NM MUST BE SET TO THE ROW DIMENSION OF TWO-DIMENSIONAL */
00032 /* ARRAY PARAMETERS AS DECLARED IN THE CALLING PROGRAM */
00033 /* DIMENSION STATEMENT. */
00034
00035 /* N IS THE ORDER OF THE MATRIX. */
00036
00037 /* T CONTAINS THE INPUT MATRIX. ITS SUBDIAGONAL IS */
00038 /* STORED IN THE LAST N-1 POSITIONS OF THE FIRST COLUMN, */
00039 /* ITS DIAGONAL IN THE N POSITIONS OF THE SECOND COLUMN, */
00040 /* AND ITS SUPERDIAGONAL IN THE FIRST N-1 POSITIONS OF */
00041 /* THE THIRD COLUMN. T(1,1) AND T(N,3) ARE ARBITRARY. */
00042
00043 /* ON OUTPUT */
00044
00045 /* T IS UNALTERED. */
00046
00047 /* D CONTAINS THE DIAGONAL ELEMENTS OF THE SYMMETRIC MATRIX. */
00048
00049 /* E CONTAINS THE SUBDIAGONAL ELEMENTS OF THE SYMMETRIC */
00050 /* MATRIX IN ITS LAST N-1 POSITIONS. E(1) IS NOT SET. */
00051
00052 /* Z CONTAINS THE TRANSFORMATION MATRIX PRODUCED IN */
00053 /* THE REDUCTION. */
00054
00055 /* IERR IS SET TO */
00056 /* ZERO FOR NORMAL RETURN, */
00057 /* N+I IF T(I,1)*T(I-1,3) IS NEGATIVE, */
00058 /* 2*N+I IF T(I,1)*T(I-1,3) IS ZERO WITH */
00059 /* ONE FACTOR NON-ZERO. */
00060
00061 /* QUESTIONS AND COMMENTS SHOULD BE DIRECTED TO BURTON S. GARBOW, */
00062 /* MATHEMATICS AND COMPUTER SCIENCE DIV, ARGONNE NATIONAL LABORATORY
00063 */
00064
00065 /* THIS VERSION DATED AUGUST 1983. */
00066
00067 /* ------------------------------------------------------------------
00068 */
00069
00070 /* Parameter adjustments */
00071 t_dim1 = *nm;
00072 t_offset = t_dim1 + 1;
00073 t -= t_offset;
00074 z_dim1 = *nm;
00075 z_offset = z_dim1 + 1;
00076 z__ -= z_offset;
00077 --e;
00078 --d__;
00079
00080 /* Function Body */
00081 *ierr = 0;
00082
00083 i__1 = *n;
00084 for (i__ = 1; i__ <= i__1; ++i__) {
00085
00086 i__2 = *n;
00087 for (j = 1; j <= i__2; ++j) {
00088 /* L50: */
00089 z__[i__ + j * z_dim1] = 0.;
00090 }
00091
00092 if (i__ == 1) {
00093 goto L70;
00094 }
00095 h__ = t[i__ + t_dim1] * t[i__ - 1 + t_dim1 * 3];
00096 if (h__ < 0.) {
00097 goto L900;
00098 } else if (h__ == 0) {
00099 goto L60;
00100 } else {
00101 goto L80;
00102 }
00103 L60:
00104 if (t[i__ + t_dim1] != 0. || t[i__ - 1 + t_dim1 * 3] != 0.) {
00105 goto L1000;
00106 }
00107 e[i__] = 0.;
00108 L70:
00109 z__[i__ + i__ * z_dim1] = 1.;
00110 goto L90;
00111 L80:
00112 e[i__] = sqrt(h__);
00113 z__[i__ + i__ * z_dim1] = z__[i__ - 1 + (i__ - 1) * z_dim1] * e[i__] /
00114 t[i__ - 1 + t_dim1 * 3];
00115 L90:
00116 d__[i__] = t[i__ + (t_dim1 << 1)];
00117 /* L100: */
00118 }
00119
00120 goto L1001;
00121 /* .......... SET ERROR -- PRODUCT OF SOME PAIR OF OFF-DIAGONAL */
00122 /* ELEMENTS IS NEGATIVE .......... */
00123 L900:
00124 *ierr = *n + i__;
00125 goto L1001;
00126 /* .......... SET ERROR -- PRODUCT OF SOME PAIR OF OFF-DIAGONAL */
00127 /* ELEMENTS IS ZERO WITH ONE MEMBER NON-ZERO .......... */
00128 L1000:
00129 *ierr = (*n << 1) + i__;
00130 L1001:
00131 return 0;
00132 } /* figi2_ */
|
|
||||||||||||||||||||||||||||||||
|
Definition at line 8 of file eis_figi.c. Referenced by rt_().
00010 {
00011 /* System generated locals */
00012 integer t_dim1, t_offset, i__1;
00013 doublereal d__1;
00014
00015 /* Builtin functions */
00016 double sqrt(doublereal);
00017
00018 /* Local variables */
00019 static integer i__;
00020
00021
00022
00023 /* GIVEN A NONSYMMETRIC TRIDIAGONAL MATRIX SUCH THAT THE PRODUCTS */
00024 /* OF CORRESPONDING PAIRS OF OFF-DIAGONAL ELEMENTS ARE ALL */
00025 /* NON-NEGATIVE, THIS SUBROUTINE REDUCES IT TO A SYMMETRIC */
00026 /* TRIDIAGONAL MATRIX WITH THE SAME EIGENVALUES. IF, FURTHER, */
00027 /* A ZERO PRODUCT ONLY OCCURS WHEN BOTH FACTORS ARE ZERO, */
00028 /* THE REDUCED MATRIX IS SIMILAR TO THE ORIGINAL MATRIX. */
00029
00030 /* ON INPUT */
00031
00032 /* NM MUST BE SET TO THE ROW DIMENSION OF TWO-DIMENSIONAL */
00033 /* ARRAY PARAMETERS AS DECLARED IN THE CALLING PROGRAM */
00034 /* DIMENSION STATEMENT. */
00035
00036 /* N IS THE ORDER OF THE MATRIX. */
00037
00038 /* T CONTAINS THE INPUT MATRIX. ITS SUBDIAGONAL IS */
00039 /* STORED IN THE LAST N-1 POSITIONS OF THE FIRST COLUMN, */
00040 /* ITS DIAGONAL IN THE N POSITIONS OF THE SECOND COLUMN, */
00041 /* AND ITS SUPERDIAGONAL IN THE FIRST N-1 POSITIONS OF */
00042 /* THE THIRD COLUMN. T(1,1) AND T(N,3) ARE ARBITRARY. */
00043
00044 /* ON OUTPUT */
00045
00046 /* T IS UNALTERED. */
00047
00048 /* D CONTAINS THE DIAGONAL ELEMENTS OF THE SYMMETRIC MATRIX. */
00049
00050 /* E CONTAINS THE SUBDIAGONAL ELEMENTS OF THE SYMMETRIC */
00051 /* MATRIX IN ITS LAST N-1 POSITIONS. E(1) IS NOT SET. */
00052
00053 /* E2 CONTAINS THE SQUARES OF THE CORRESPONDING ELEMENTS OF E. */
00054 /* E2 MAY COINCIDE WITH E IF THE SQUARES ARE NOT NEEDED. */
00055
00056 /* IERR IS SET TO */
00057 /* ZERO FOR NORMAL RETURN, */
00058 /* N+I IF T(I,1)*T(I-1,3) IS NEGATIVE, */
00059 /* -(3*N+I) IF T(I,1)*T(I-1,3) IS ZERO WITH ONE FACTOR */
00060 /* NON-ZERO. IN THIS CASE, THE EIGENVECTORS OF */
00061 /* THE SYMMETRIC MATRIX ARE NOT SIMPLY RELATED */
00062 /* TO THOSE OF T AND SHOULD NOT BE SOUGHT. */
00063
00064 /* QUESTIONS AND COMMENTS SHOULD BE DIRECTED TO BURTON S. GARBOW, */
00065 /* MATHEMATICS AND COMPUTER SCIENCE DIV, ARGONNE NATIONAL LABORATORY
00066 */
00067
00068 /* THIS VERSION DATED AUGUST 1983. */
00069
00070 /* ------------------------------------------------------------------
00071 */
00072
00073 /* Parameter adjustments */
00074 t_dim1 = *nm;
00075 t_offset = t_dim1 + 1;
00076 t -= t_offset;
00077 --e2;
00078 --e;
00079 --d__;
00080
00081 /* Function Body */
00082 *ierr = 0;
00083
00084 i__1 = *n;
00085 for (i__ = 1; i__ <= i__1; ++i__) {
00086 if (i__ == 1) {
00087 goto L90;
00088 }
00089 e2[i__] = t[i__ + t_dim1] * t[i__ - 1 + t_dim1 * 3];
00090 if ((d__1 = e2[i__]) < 0.) {
00091 goto L1000;
00092 } else if (d__1 == 0) {
00093 goto L60;
00094 } else {
00095 goto L80;
00096 }
00097 L60:
00098 if (t[i__ + t_dim1] == 0. && t[i__ - 1 + t_dim1 * 3] == 0.) {
00099 goto L80;
00100 }
00101 /* .......... SET ERROR -- PRODUCT OF SOME PAIR OF OFF-DIAGONAL */
00102 /* ELEMENTS IS ZERO WITH ONE MEMBER NON-ZERO ..........
00103 */
00104 *ierr = -(*n * 3 + i__);
00105 L80:
00106 e[i__] = sqrt(e2[i__]);
00107 L90:
00108 d__[i__] = t[i__ + (t_dim1 << 1)];
00109 /* L100: */
00110 }
00111
00112 goto L1001;
00113 /* .......... SET ERROR -- PRODUCT OF SOME PAIR OF OFF-DIAGONAL */
00114 /* ELEMENTS IS NEGATIVE .......... */
00115 L1000:
00116 *ierr = *n + i__;
00117 L1001:
00118 return 0;
00119 } /* figi_ */
|
|
||||||||||||||||||||||||||||||||||||||||
|
Definition at line 12 of file eis_hqr2.c. References abs, c_b49, cdiv_(), d_sign(), l, max, min, p, and q. Referenced by rg_().
00015 {
00016 /* System generated locals */
00017 integer h_dim1, h_offset, z_dim1, z_offset, i__1, i__2, i__3;
00018 doublereal d__1, d__2, d__3, d__4;
00019
00020 /* Builtin functions */
00021 double sqrt(doublereal), d_sign(doublereal *, doublereal *);
00022
00023 /* Local variables */
00024 extern /* Subroutine */ int cdiv_(doublereal *, doublereal *, doublereal *
00025 , doublereal *, doublereal *, doublereal *);
00026 static doublereal norm;
00027 static integer i__, j, k, l, m;
00028 static doublereal p, q, r__, s, t, w, x, y;
00029 static integer na, ii, en, jj;
00030 static doublereal ra, sa;
00031 static integer ll, mm, nn;
00032 static doublereal vi, vr, zz;
00033 static logical notlas;
00034 static integer mp2, itn, its, enm2;
00035 static doublereal tst1, tst2;
00036
00037
00038
00039 /* THIS SUBROUTINE IS A TRANSLATION OF THE ALGOL PROCEDURE HQR2, */
00040 /* NUM. MATH. 16, 181-204(1970) BY PETERS AND WILKINSON. */
00041 /* HANDBOOK FOR AUTO. COMP., VOL.II-LINEAR ALGEBRA, 372-395(1971). */
00042
00043 /* THIS SUBROUTINE FINDS THE EIGENVALUES AND EIGENVECTORS */
00044 /* OF A REAL UPPER HESSENBERG MATRIX BY THE QR METHOD. THE */
00045 /* EIGENVECTORS OF A REAL GENERAL MATRIX CAN ALSO BE FOUND */
00046 /* IF ELMHES AND ELTRAN OR ORTHES AND ORTRAN HAVE */
00047 /* BEEN USED TO REDUCE THIS GENERAL MATRIX TO HESSENBERG FORM */
00048 /* AND TO ACCUMULATE THE SIMILARITY TRANSFORMATIONS. */
00049
00050 /* ON INPUT */
00051
00052 /* NM MUST BE SET TO THE ROW DIMENSION OF TWO-DIMENSIONAL */
00053 /* ARRAY PARAMETERS AS DECLARED IN THE CALLING PROGRAM */
00054 /* DIMENSION STATEMENT. */
00055
00056 /* N IS THE ORDER OF THE MATRIX. */
00057
00058 /* LOW AND IGH ARE INTEGERS DETERMINED BY THE BALANCING */
00059 /* SUBROUTINE BALANC. IF BALANC HAS NOT BEEN USED, */
00060 /* SET LOW=1, IGH=N. */
00061
00062 /* H CONTAINS THE UPPER HESSENBERG MATRIX. */
00063
00064 /* Z CONTAINS THE TRANSFORMATION MATRIX PRODUCED BY ELTRAN */
00065 /* AFTER THE REDUCTION BY ELMHES, OR BY ORTRAN AFTER THE */
00066 /* REDUCTION BY ORTHES, IF PERFORMED. IF THE EIGENVECTORS */
00067 /* OF THE HESSENBERG MATRIX ARE DESIRED, Z MUST CONTAIN THE */
00068 /* IDENTITY MATRIX. */
00069
00070 /* ON OUTPUT */
00071
00072 /* H HAS BEEN DESTROYED. */
00073
00074 /* WR AND WI CONTAIN THE REAL AND IMAGINARY PARTS, */
00075 /* RESPECTIVELY, OF THE EIGENVALUES. THE EIGENVALUES */
00076 /* ARE UNORDERED EXCEPT THAT COMPLEX CONJUGATE PAIRS */
00077 /* OF VALUES APPEAR CONSECUTIVELY WITH THE EIGENVALUE */
00078 /* HAVING THE POSITIVE IMAGINARY PART FIRST. IF AN */
00079 /* ERROR EXIT IS MADE, THE EIGENVALUES SHOULD BE CORRECT */
00080 /* FOR INDICES IERR+1,...,N. */
00081
00082 /* Z CONTAINS THE REAL AND IMAGINARY PARTS OF THE EIGENVECTORS. */
00083 /* IF THE I-TH EIGENVALUE IS REAL, THE I-TH COLUMN OF Z */
00084 /* CONTAINS ITS EIGENVECTOR. IF THE I-TH EIGENVALUE IS COMPLEX
00085 */
00086 /* WITH POSITIVE IMAGINARY PART, THE I-TH AND (I+1)-TH */
00087 /* COLUMNS OF Z CONTAIN THE REAL AND IMAGINARY PARTS OF ITS */
00088 /* EIGENVECTOR. THE EIGENVECTORS ARE UNNORMALIZED. IF AN */
00089 /* ERROR EXIT IS MADE, NONE OF THE EIGENVECTORS HAS BEEN FOUND.
00090 */
00091
00092 /* IERR IS SET TO */
00093 /* ZERO FOR NORMAL RETURN, */
00094 /* J IF THE LIMIT OF 30*N ITERATIONS IS EXHAUSTED */
00095 /* WHILE THE J-TH EIGENVALUE IS BEING SOUGHT. */
00096
00097 /* CALLS CDIV FOR COMPLEX DIVISION. */
00098
00099 /* QUESTIONS AND COMMENTS SHOULD BE DIRECTED TO BURTON S. GARBOW, */
00100 /* MATHEMATICS AND COMPUTER SCIENCE DIV, ARGONNE NATIONAL LABORATORY
00101 */
00102
00103 /* THIS VERSION DATED AUGUST 1983. */
00104
00105 /* ------------------------------------------------------------------
00106 */
00107
00108 /* Parameter adjustments */
00109 z_dim1 = *nm;
00110 z_offset = z_dim1 + 1;
00111 z__ -= z_offset;
00112 --wi;
00113 --wr;
00114 h_dim1 = *nm;
00115 h_offset = h_dim1 + 1;
00116 h__ -= h_offset;
00117
00118 /* Function Body */
00119 *ierr = 0;
00120 norm = 0.;
00121 k = 1;
00122 /* .......... STORE ROOTS ISOLATED BY BALANC */
00123 /* AND COMPUTE MATRIX NORM .......... */
00124 i__1 = *n;
00125 for (i__ = 1; i__ <= i__1; ++i__) {
00126
00127 i__2 = *n;
00128 for (j = k; j <= i__2; ++j) {
00129 /* L40: */
00130 norm += (d__1 = h__[i__ + j * h_dim1], abs(d__1));
00131 }
00132
00133 k = i__;
00134 if (i__ >= *low && i__ <= *igh) {
00135 goto L50;
00136 }
00137 wr[i__] = h__[i__ + i__ * h_dim1];
00138 wi[i__] = 0.;
00139 L50:
00140 ;
00141 }
00142
00143 en = *igh;
00144 t = 0.;
00145 itn = *n * 30;
00146 /* .......... SEARCH FOR NEXT EIGENVALUES .......... */
00147 L60:
00148 if (en < *low) {
00149 goto L340;
00150 }
00151 its = 0;
00152 na = en - 1;
00153 enm2 = na - 1;
00154 /* .......... LOOK FOR SINGLE SMALL SUB-DIAGONAL ELEMENT */
00155 /* FOR L=EN STEP -1 UNTIL LOW DO -- .......... */
00156 L70:
00157 i__1 = en;
00158 for (ll = *low; ll <= i__1; ++ll) {
00159 l = en + *low - ll;
00160 if (l == *low) {
00161 goto L100;
00162 }
00163 s = (d__1 = h__[l - 1 + (l - 1) * h_dim1], abs(d__1)) + (d__2 = h__[l
00164 + l * h_dim1], abs(d__2));
00165 if (s == 0.) {
00166 s = norm;
00167 }
00168 tst1 = s;
00169 tst2 = tst1 + (d__1 = h__[l + (l - 1) * h_dim1], abs(d__1));
00170 if (tst2 == tst1) {
00171 goto L100;
00172 }
00173 /* L80: */
00174 }
00175 /* .......... FORM SHIFT .......... */
00176 L100:
00177 x = h__[en + en * h_dim1];
00178 if (l == en) {
00179 goto L270;
00180 }
00181 y = h__[na + na * h_dim1];
00182 w = h__[en + na * h_dim1] * h__[na + en * h_dim1];
00183 if (l == na) {
00184 goto L280;
00185 }
00186 if (itn == 0) {
00187 goto L1000;
00188 }
00189 if (its != 10 && its != 20) {
00190 goto L130;
00191 }
00192 /* .......... FORM EXCEPTIONAL SHIFT .......... */
00193 t += x;
00194
00195 i__1 = en;
00196 for (i__ = *low; i__ <= i__1; ++i__) {
00197 /* L120: */
00198 h__[i__ + i__ * h_dim1] -= x;
00199 }
00200
00201 s = (d__1 = h__[en + na * h_dim1], abs(d__1)) + (d__2 = h__[na + enm2 *
00202 h_dim1], abs(d__2));
00203 x = s * .75;
00204 y = x;
00205 w = s * -.4375 * s;
00206 L130:
00207 ++its;
00208 --itn;
00209 /* .......... LOOK FOR TWO CONSECUTIVE SMALL */
00210 /* SUB-DIAGONAL ELEMENTS. */
00211 /* FOR M=EN-2 STEP -1 UNTIL L DO -- .......... */
00212 i__1 = enm2;
00213 for (mm = l; mm <= i__1; ++mm) {
00214 m = enm2 + l - mm;
00215 zz = h__[m + m * h_dim1];
00216 r__ = x - zz;
00217 s = y - zz;
00218 p = (r__ * s - w) / h__[m + 1 + m * h_dim1] + h__[m + (m + 1) *
00219 h_dim1];
00220 q = h__[m + 1 + (m + 1) * h_dim1] - zz - r__ - s;
00221 r__ = h__[m + 2 + (m + 1) * h_dim1];
00222 s = abs(p) + abs(q) + abs(r__);
00223 p /= s;
00224 q /= s;
00225 r__ /= s;
00226 if (m == l) {
00227 goto L150;
00228 }
00229 tst1 = abs(p) * ((d__1 = h__[m - 1 + (m - 1) * h_dim1], abs(d__1)) +
00230 abs(zz) + (d__2 = h__[m + 1 + (m + 1) * h_dim1], abs(d__2)));
00231 tst2 = tst1 + (d__1 = h__[m + (m - 1) * h_dim1], abs(d__1)) * (abs(q)
00232 + abs(r__));
00233 if (tst2 == tst1) {
00234 goto L150;
00235 }
00236 /* L140: */
00237 }
00238
00239 L150:
00240 mp2 = m + 2;
00241
00242 i__1 = en;
00243 for (i__ = mp2; i__ <= i__1; ++i__) {
00244 h__[i__ + (i__ - 2) * h_dim1] = 0.;
00245 if (i__ == mp2) {
00246 goto L160;
00247 }
00248 h__[i__ + (i__ - 3) * h_dim1] = 0.;
00249 L160:
00250 ;
00251 }
00252 /* .......... DOUBLE QR STEP INVOLVING ROWS L TO EN AND */
00253 /* COLUMNS M TO EN .......... */
00254 i__1 = na;
00255 for (k = m; k <= i__1; ++k) {
00256 notlas = k != na;
00257 if (k == m) {
00258 goto L170;
00259 }
00260 p = h__[k + (k - 1) * h_dim1];
00261 q = h__[k + 1 + (k - 1) * h_dim1];
00262 r__ = 0.;
00263 if (notlas) {
00264 r__ = h__[k + 2 + (k - 1) * h_dim1];
00265 }
00266 x = abs(p) + abs(q) + abs(r__);
00267 if (x == 0.) {
00268 goto L260;
00269 }
00270 p /= x;
00271 q /= x;
00272 r__ /= x;
00273 L170:
00274 d__1 = sqrt(p * p + q * q + r__ * r__);
00275 s = d_sign(&d__1, &p);
00276 if (k == m) {
00277 goto L180;
00278 }
00279 h__[k + (k - 1) * h_dim1] = -s * x;
00280 goto L190;
00281 L180:
00282 if (l != m) {
00283 h__[k + (k - 1) * h_dim1] = -h__[k + (k - 1) * h_dim1];
00284 }
00285 L190:
00286 p += s;
00287 x = p / s;
00288 y = q / s;
00289 zz = r__ / s;
00290 q /= p;
00291 r__ /= p;
00292 if (notlas) {
00293 goto L225;
00294 }
00295 /* .......... ROW MODIFICATION .......... */
00296 i__2 = *n;
00297 for (j = k; j <= i__2; ++j) {
00298 p = h__[k + j * h_dim1] + q * h__[k + 1 + j * h_dim1];
00299 h__[k + j * h_dim1] -= p * x;
00300 h__[k + 1 + j * h_dim1] -= p * y;
00301 /* L200: */
00302 }
00303
00304 /* Computing MIN */
00305 i__2 = en, i__3 = k + 3;
00306 j = min(i__2,i__3);
00307 /* .......... COLUMN MODIFICATION .......... */
00308 i__2 = j;
00309 for (i__ = 1; i__ <= i__2; ++i__) {
00310 p = x * h__[i__ + k * h_dim1] + y * h__[i__ + (k + 1) * h_dim1];
00311 h__[i__ + k * h_dim1] -= p;
00312 h__[i__ + (k + 1) * h_dim1] -= p * q;
00313 /* L210: */
00314 }
00315 /* .......... ACCUMULATE TRANSFORMATIONS .......... */
00316 i__2 = *igh;
00317 for (i__ = *low; i__ <= i__2; ++i__) {
00318 p = x * z__[i__ + k * z_dim1] + y * z__[i__ + (k + 1) * z_dim1];
00319 z__[i__ + k * z_dim1] -= p;
00320 z__[i__ + (k + 1) * z_dim1] -= p * q;
00321 /* L220: */
00322 }
00323 goto L255;
00324 L225:
00325 /* .......... ROW MODIFICATION .......... */
00326 i__2 = *n;
00327 for (j = k; j <= i__2; ++j) {
00328 p = h__[k + j * h_dim1] + q * h__[k + 1 + j * h_dim1] + r__ * h__[
00329 k + 2 + j * h_dim1];
00330 h__[k + j * h_dim1] -= p * x;
00331 h__[k + 1 + j * h_dim1] -= p * y;
00332 h__[k + 2 + j * h_dim1] -= p * zz;
00333 /* L230: */
00334 }
00335
00336 /* Computing MIN */
00337 i__2 = en, i__3 = k + 3;
00338 j = min(i__2,i__3);
00339 /* .......... COLUMN MODIFICATION .......... */
00340 i__2 = j;
00341 for (i__ = 1; i__ <= i__2; ++i__) {
00342 p = x * h__[i__ + k * h_dim1] + y * h__[i__ + (k + 1) * h_dim1] +
00343 zz * h__[i__ + (k + 2) * h_dim1];
00344 h__[i__ + k * h_dim1] -= p;
00345 h__[i__ + (k + 1) * h_dim1] -= p * q;
00346 h__[i__ + (k + 2) * h_dim1] -= p * r__;
00347 /* L240: */
00348 }
00349 /* .......... ACCUMULATE TRANSFORMATIONS .......... */
00350 i__2 = *igh;
00351 for (i__ = *low; i__ <= i__2; ++i__) {
00352 p = x * z__[i__ + k * z_dim1] + y * z__[i__ + (k + 1) * z_dim1] +
00353 zz * z__[i__ + (k + 2) * z_dim1];
00354 z__[i__ + k * z_dim1] -= p;
00355 z__[i__ + (k + 1) * z_dim1] -= p * q;
00356 z__[i__ + (k + 2) * z_dim1] -= p * r__;
00357 /* L250: */
00358 }
00359 L255:
00360
00361 L260:
00362 ;
00363 }
00364
00365 goto L70;
00366 /* .......... ONE ROOT FOUND .......... */
00367 L270:
00368 h__[en + en * h_dim1] = x + t;
00369 wr[en] = h__[en + en * h_dim1];
00370 wi[en] = 0.;
00371 en = na;
00372 goto L60;
00373 /* .......... TWO ROOTS FOUND .......... */
00374 L280:
00375 p = (y - x) / 2.;
00376 q = p * p + w;
00377 zz = sqrt((abs(q)));
00378 h__[en + en * h_dim1] = x + t;
00379 x = h__[en + en * h_dim1];
00380 h__[na + na * h_dim1] = y + t;
00381 if (q < 0.) {
00382 goto L320;
00383 }
00384 /* .......... REAL PAIR .......... */
00385 zz = p + d_sign(&zz, &p);
00386 wr[na] = x + zz;
00387 wr[en] = wr[na];
00388 if (zz != 0.) {
00389 wr[en] = x - w / zz;
00390 }
00391 wi[na] = 0.;
00392 wi[en] = 0.;
00393 x = h__[en + na * h_dim1];
00394 s = abs(x) + abs(zz);
00395 p = x / s;
00396 q = zz / s;
00397 r__ = sqrt(p * p + q * q);
00398 p /= r__;
00399 q /= r__;
00400 /* .......... ROW MODIFICATION .......... */
00401 i__1 = *n;
00402 for (j = na; j <= i__1; ++j) {
00403 zz = h__[na + j * h_dim1];
00404 h__[na + j * h_dim1] = q * zz + p * h__[en + j * h_dim1];
00405 h__[en + j * h_dim1] = q * h__[en + j * h_dim1] - p * zz;
00406 /* L290: */
00407 }
00408 /* .......... COLUMN MODIFICATION .......... */
00409 i__1 = en;
00410 for (i__ = 1; i__ <= i__1; ++i__) {
00411 zz = h__[i__ + na * h_dim1];
00412 h__[i__ + na * h_dim1] = q * zz + p * h__[i__ + en * h_dim1];
00413 h__[i__ + en * h_dim1] = q * h__[i__ + en * h_dim1] - p * zz;
00414 /* L300: */
00415 }
00416 /* .......... ACCUMULATE TRANSFORMATIONS .......... */
00417 i__1 = *igh;
00418 for (i__ = *low; i__ <= i__1; ++i__) {
00419 zz = z__[i__ + na * z_dim1];
00420 z__[i__ + na * z_dim1] = q * zz + p * z__[i__ + en * z_dim1];
00421 z__[i__ + en * z_dim1] = q * z__[i__ + en * z_dim1] - p * zz;
00422 /* L310: */
00423 }
00424
00425 goto L330;
00426 /* .......... COMPLEX PAIR .......... */
00427 L320:
00428 wr[na] = x + p;
00429 wr[en] = x + p;
00430 wi[na] = zz;
00431 wi[en] = -zz;
00432 L330:
00433 en = enm2;
00434 goto L60;
00435 /* .......... ALL ROOTS FOUND. BACKSUBSTITUTE TO FIND */
00436 /* VECTORS OF UPPER TRIANGULAR FORM .......... */
00437 L340:
00438 if (norm == 0.) {
00439 goto L1001;
00440 }
00441 /* .......... FOR EN=N STEP -1 UNTIL 1 DO -- .......... */
00442 i__1 = *n;
00443 for (nn = 1; nn <= i__1; ++nn) {
00444 en = *n + 1 - nn;
00445 p = wr[en];
00446 q = wi[en];
00447 na = en - 1;
00448 if (q < 0.) {
00449 goto L710;
00450 } else if (q == 0) {
00451 goto L600;
00452 } else {
00453 goto L800;
00454 }
00455 /* .......... REAL VECTOR .......... */
00456 L600:
00457 m = en;
00458 h__[en + en * h_dim1] = 1.;
00459 if (na == 0) {
00460 goto L800;
00461 }
00462 /* .......... FOR I=EN-1 STEP -1 UNTIL 1 DO -- .......... */
00463 i__2 = na;
00464 for (ii = 1; ii <= i__2; ++ii) {
00465 i__ = en - ii;
00466 w = h__[i__ + i__ * h_dim1] - p;
00467 r__ = 0.;
00468
00469 i__3 = en;
00470 for (j = m; j <= i__3; ++j) {
00471 /* L610: */
00472 r__ += h__[i__ + j * h_dim1] * h__[j + en * h_dim1];
00473 }
00474
00475 if (wi[i__] >= 0.) {
00476 goto L630;
00477 }
00478 zz = w;
00479 s = r__;
00480 goto L700;
00481 L630:
00482 m = i__;
00483 if (wi[i__] != 0.) {
00484 goto L640;
00485 }
00486 t = w;
00487 if (t != 0.) {
00488 goto L635;
00489 }
00490 tst1 = norm;
00491 t = tst1;
00492 L632:
00493 t *= .01;
00494 tst2 = norm + t;
00495 if (tst2 > tst1) {
00496 goto L632;
00497 }
00498 L635:
00499 h__[i__ + en * h_dim1] = -r__ / t;
00500 goto L680;
00501 /* .......... SOLVE REAL EQUATIONS .......... */
00502 L640:
00503 x = h__[i__ + (i__ + 1) * h_dim1];
00504 y = h__[i__ + 1 + i__ * h_dim1];
00505 q = (wr[i__] - p) * (wr[i__] - p) + wi[i__] * wi[i__];
00506 t = (x * s - zz * r__) / q;
00507 h__[i__ + en * h_dim1] = t;
00508 if (abs(x) <= abs(zz)) {
00509 goto L650;
00510 }
00511 h__[i__ + 1 + en * h_dim1] = (-r__ - w * t) / x;
00512 goto L680;
00513 L650:
00514 h__[i__ + 1 + en * h_dim1] = (-s - y * t) / zz;
00515
00516 /* .......... OVERFLOW CONTROL .......... */
00517 L680:
00518 t = (d__1 = h__[i__ + en * h_dim1], abs(d__1));
00519 if (t == 0.) {
00520 goto L700;
00521 }
00522 tst1 = t;
00523 tst2 = tst1 + 1. / tst1;
00524 if (tst2 > tst1) {
00525 goto L700;
00526 }
00527 i__3 = en;
00528 for (j = i__; j <= i__3; ++j) {
00529 h__[j + en * h_dim1] /= t;
00530 /* L690: */
00531 }
00532
00533 L700:
00534 ;
00535 }
00536 /* .......... END REAL VECTOR .......... */
00537 goto L800;
00538 /* .......... COMPLEX VECTOR .......... */
00539 L710:
00540 m = na;
00541 /* .......... LAST VECTOR COMPONENT CHOSEN IMAGINARY SO THAT */
00542 /* EIGENVECTOR MATRIX IS TRIANGULAR .......... */
00543 if ((d__1 = h__[en + na * h_dim1], abs(d__1)) <= (d__2 = h__[na + en *
00544 h_dim1], abs(d__2))) {
00545 goto L720;
00546 }
00547 h__[na + na * h_dim1] = q / h__[en + na * h_dim1];
00548 h__[na + en * h_dim1] = -(h__[en + en * h_dim1] - p) / h__[en + na *
00549 h_dim1];
00550 goto L730;
00551 L720:
00552 d__1 = -h__[na + en * h_dim1];
00553 d__2 = h__[na + na * h_dim1] - p;
00554 cdiv_(&c_b49, &d__1, &d__2, &q, &h__[na + na * h_dim1], &h__[na + en *
00555 h_dim1]);
00556 L730:
00557 h__[en + na * h_dim1] = 0.;
00558 h__[en + en * h_dim1] = 1.;
00559 enm2 = na - 1;
00560 if (enm2 == 0) {
00561 goto L800;
00562 }
00563 /* .......... FOR I=EN-2 STEP -1 UNTIL 1 DO -- .......... */
00564 i__2 = enm2;
00565 for (ii = 1; ii <= i__2; ++ii) {
00566 i__ = na - ii;
00567 w = h__[i__ + i__ * h_dim1] - p;
00568 ra = 0.;
00569 sa = 0.;
00570
00571 i__3 = en;
00572 for (j = m; j <= i__3; ++j) {
00573 ra += h__[i__ + j * h_dim1] * h__[j + na * h_dim1];
00574 sa += h__[i__ + j * h_dim1] * h__[j + en * h_dim1];
00575 /* L760: */
00576 }
00577
00578 if (wi[i__] >= 0.) {
00579 goto L770;
00580 }
00581 zz = w;
00582 r__ = ra;
00583 s = sa;
00584 goto L795;
00585 L770:
00586 m = i__;
00587 if (wi[i__] != 0.) {
00588 goto L780;
00589 }
00590 d__1 = -ra;
00591 d__2 = -sa;
00592 cdiv_(&d__1, &d__2, &w, &q, &h__[i__ + na * h_dim1], &h__[i__ +
00593 en * h_dim1]);
00594 goto L790;
00595 /* .......... SOLVE COMPLEX EQUATIONS .......... */
00596 L780:
00597 x = h__[i__ + (i__ + 1) * h_dim1];
00598 y = h__[i__ + 1 + i__ * h_dim1];
00599 vr = (wr[i__] - p) * (wr[i__] - p) + wi[i__] * wi[i__] - q * q;
00600 vi = (wr[i__] - p) * 2. * q;
00601 if (vr != 0. || vi != 0.) {
00602 goto L784;
00603 }
00604 tst1 = norm * (abs(w) + abs(q) + abs(x) + abs(y) + abs(zz));
00605 vr = tst1;
00606 L783:
00607 vr *= .01;
00608 tst2 = tst1 + vr;
00609 if (tst2 > tst1) {
00610 goto L783;
00611 }
00612 L784:
00613 d__1 = x * r__ - zz * ra + q * sa;
00614 d__2 = x * s - zz * sa - q * ra;
00615 cdiv_(&d__1, &d__2, &vr, &vi, &h__[i__ + na * h_dim1], &h__[i__ +
00616 en * h_dim1]);
00617 if (abs(x) <= abs(zz) + abs(q)) {
00618 goto L785;
00619 }
00620 h__[i__ + 1 + na * h_dim1] = (-ra - w * h__[i__ + na * h_dim1] +
00621 q * h__[i__ + en * h_dim1]) / x;
00622 h__[i__ + 1 + en * h_dim1] = (-sa - w * h__[i__ + en * h_dim1] -
00623 q * h__[i__ + na * h_dim1]) / x;
00624 goto L790;
00625 L785:
00626 d__1 = -r__ - y * h__[i__ + na * h_dim1];
00627 d__2 = -s - y * h__[i__ + en * h_dim1];
00628 cdiv_(&d__1, &d__2, &zz, &q, &h__[i__ + 1 + na * h_dim1], &h__[
00629 i__ + 1 + en * h_dim1]);
00630
00631 /* .......... OVERFLOW CONTROL .......... */
00632 L790:
00633 /* Computing MAX */
00634 d__3 = (d__1 = h__[i__ + na * h_dim1], abs(d__1)), d__4 = (d__2 =
00635 h__[i__ + en * h_dim1], abs(d__2));
00636 t = max(d__3,d__4);
00637 if (t == 0.) {
00638 goto L795;
00639 }
00640 tst1 = t;
00641 tst2 = tst1 + 1. / tst1;
00642 if (tst2 > tst1) {
00643 goto L795;
00644 }
00645 i__3 = en;
00646 for (j = i__; j <= i__3; ++j) {
00647 h__[j + na * h_dim1] /= t;
00648 h__[j + en * h_dim1] /= t;
00649 /* L792: */
00650 }
00651
00652 L795:
00653 ;
00654 }
00655 /* .......... END COMPLEX VECTOR .......... */
00656 L800:
00657 ;
00658 }
00659 /* .......... END BACK SUBSTITUTION. */
00660 /* VECTORS OF ISOLATED ROOTS .......... */
00661 i__1 = *n;
00662 for (i__ = 1; i__ <= i__1; ++i__) {
00663 if (i__ >= *low && i__ <= *igh) {
00664 goto L840;
00665 }
00666
00667 i__2 = *n;
00668 for (j = i__; j <= i__2; ++j) {
00669 /* L820: */
00670 z__[i__ + j * z_dim1] = h__[i__ + j * h_dim1];
00671 }
00672
00673 L840:
00674 ;
00675 }
00676 /* .......... MULTIPLY BY TRANSFORMATION MATRIX TO GIVE */
00677 /* VECTORS OF ORIGINAL FULL MATRIX. */
00678 /* FOR J=N STEP -1 UNTIL LOW DO -- .......... */
00679 i__1 = *n;
00680 for (jj = *low; jj <= i__1; ++jj) {
00681 j = *n + *low - jj;
00682 m = min(j,*igh);
00683
00684 i__2 = *igh;
00685 for (i__ = *low; i__ <= i__2; ++i__) {
00686 zz = 0.;
00687
00688 i__3 = m;
00689 for (k = *low; k <= i__3; ++k) {
00690 /* L860: */
00691 zz += z__[i__ + k * z_dim1] * h__[k + j * h_dim1];
00692 }
00693
00694 z__[i__ + j * z_dim1] = zz;
00695 /* L880: */
00696 }
00697 }
00698
00699 goto L1001;
00700 /* .......... SET ERROR -- ALL EIGENVALUES HAVE NOT */
00701 /* CONVERGED AFTER 30*N ITERATIONS .......... */
00702 L1000:
00703 *ierr = en;
00704 L1001:
00705 return 0;
00706 } /* hqr2_ */
|
|
||||||||||||||||||||||||||||||||||||
|
Definition at line 8 of file eis_hqr.c. References abs, d_sign(), l, min, p, and q. Referenced by rg_().
00010 {
00011 /* System generated locals */
00012 integer h_dim1, h_offset, i__1, i__2, i__3;
00013 doublereal d__1, d__2;
00014
00015 /* Builtin functions */
00016 double sqrt(doublereal), d_sign(doublereal *, doublereal *);
00017
00018 /* Local variables */
00019 static doublereal norm;
00020 static integer i__, j, k, l, m;
00021 static doublereal p, q, r__, s, t, w, x, y;
00022 static integer na, en, ll, mm;
00023 static doublereal zz;
00024 static logical notlas;
00025 static integer mp2, itn, its, enm2;
00026 static doublereal tst1, tst2;
00027
00028
00029
00030 /* THIS SUBROUTINE IS A TRANSLATION OF THE ALGOL PROCEDURE HQR, */
00031 /* NUM. MATH. 14, 219-231(1970) BY MARTIN, PETERS, AND WILKINSON. */
00032 /* HANDBOOK FOR AUTO. COMP., VOL.II-LINEAR ALGEBRA, 359-371(1971). */
00033
00034 /* THIS SUBROUTINE FINDS THE EIGENVALUES OF A REAL */
00035 /* UPPER HESSENBERG MATRIX BY THE QR METHOD. */
00036
00037 /* ON INPUT */
00038
00039 /* NM MUST BE SET TO THE ROW DIMENSION OF TWO-DIMENSIONAL */
00040 /* ARRAY PARAMETERS AS DECLARED IN THE CALLING PROGRAM */
00041 /* DIMENSION STATEMENT. */
00042
00043 /* N IS THE ORDER OF THE MATRIX. */
00044
00045 /* LOW AND IGH ARE INTEGERS DETERMINED BY THE BALANCING */
00046 /* SUBROUTINE BALANC. IF BALANC HAS NOT BEEN USED, */
00047 /* SET LOW=1, IGH=N. */
00048
00049 /* H CONTAINS THE UPPER HESSENBERG MATRIX. INFORMATION ABOUT */
00050 /* THE TRANSFORMATIONS USED IN THE REDUCTION TO HESSENBERG */
00051 /* FORM BY ELMHES OR ORTHES, IF PERFORMED, IS STORED */
00052 /* IN THE REMAINING TRIANGLE UNDER THE HESSENBERG MATRIX. */
00053
00054 /* ON OUTPUT */
00055
00056 /* H HAS BEEN DESTROYED. THEREFORE, IT MUST BE SAVED */
00057 /* BEFORE CALLING HQR IF SUBSEQUENT CALCULATION AND */
00058 /* BACK TRANSFORMATION OF EIGENVECTORS IS TO BE PERFORMED. */
00059
00060 /* WR AND WI CONTAIN THE REAL AND IMAGINARY PARTS, */
00061 /* RESPECTIVELY, OF THE EIGENVALUES. THE EIGENVALUES */
00062 /* ARE UNORDERED EXCEPT THAT COMPLEX CONJUGATE PAIRS */
00063 /* OF VALUES APPEAR CONSECUTIVELY WITH THE EIGENVALUE */
00064 /* HAVING THE POSITIVE IMAGINARY PART FIRST. IF AN */
00065 /* ERROR EXIT IS MADE, THE EIGENVALUES SHOULD BE CORRECT */
00066 /* FOR INDICES IERR+1,...,N. */
00067
00068 /* IERR IS SET TO */
00069 /* ZERO FOR NORMAL RETURN, */
00070 /* J IF THE LIMIT OF 30*N ITERATIONS IS EXHAUSTED */
00071 /* WHILE THE J-TH EIGENVALUE IS BEING SOUGHT. */
00072
00073 /* QUESTIONS AND COMMENTS SHOULD BE DIRECTED TO BURTON S. GARBOW, */
00074 /* MATHEMATICS AND COMPUTER SCIENCE DIV, ARGONNE NATIONAL LABORATORY
00075 */
00076
00077 /* THIS VERSION DATED AUGUST 1983. */
00078
00079 /* ------------------------------------------------------------------
00080 */
00081
00082 /* Parameter adjustments */
00083 --wi;
00084 --wr;
00085 h_dim1 = *nm;
00086 h_offset = h_dim1 + 1;
00087 h__ -= h_offset;
00088
00089 /* Function Body */
00090 *ierr = 0;
00091 norm = 0.;
00092 k = 1;
00093 /* .......... STORE ROOTS ISOLATED BY BALANC */
00094 /* AND COMPUTE MATRIX NORM .......... */
00095 i__1 = *n;
00096 for (i__ = 1; i__ <= i__1; ++i__) {
00097
00098 i__2 = *n;
00099 for (j = k; j <= i__2; ++j) {
00100 /* L40: */
00101 norm += (d__1 = h__[i__ + j * h_dim1], abs(d__1));
00102 }
00103
00104 k = i__;
00105 if (i__ >= *low && i__ <= *igh) {
00106 goto L50;
00107 }
00108 wr[i__] = h__[i__ + i__ * h_dim1];
00109 wi[i__] = 0.;
00110 L50:
00111 ;
00112 }
00113
00114 en = *igh;
00115 t = 0.;
00116 itn = *n * 30;
00117 /* .......... SEARCH FOR NEXT EIGENVALUES .......... */
00118 L60:
00119 if (en < *low) {
00120 goto L1001;
00121 }
00122 its = 0;
00123 na = en - 1;
00124 enm2 = na - 1;
00125 /* .......... LOOK FOR SINGLE SMALL SUB-DIAGONAL ELEMENT */
00126 /* FOR L=EN STEP -1 UNTIL LOW DO -- .......... */
00127 L70:
00128 i__1 = en;
00129 for (ll = *low; ll <= i__1; ++ll) {
00130 l = en + *low - ll;
00131 if (l == *low) {
00132 goto L100;
00133 }
00134 s = (d__1 = h__[l - 1 + (l - 1) * h_dim1], abs(d__1)) + (d__2 = h__[l
00135 + l * h_dim1], abs(d__2));
00136 if (s == 0.) {
00137 s = norm;
00138 }
00139 tst1 = s;
00140 tst2 = tst1 + (d__1 = h__[l + (l - 1) * h_dim1], abs(d__1));
00141 if (tst2 == tst1) {
00142 goto L100;
00143 }
00144 /* L80: */
00145 }
00146 /* .......... FORM SHIFT .......... */
00147 L100:
00148 x = h__[en + en * h_dim1];
00149 if (l == en) {
00150 goto L270;
00151 }
00152 y = h__[na + na * h_dim1];
00153 w = h__[en + na * h_dim1] * h__[na + en * h_dim1];
00154 if (l == na) {
00155 goto L280;
00156 }
00157 if (itn == 0) {
00158 goto L1000;
00159 }
00160 if (its != 10 && its != 20) {
00161 goto L130;
00162 }
00163 /* .......... FORM EXCEPTIONAL SHIFT .......... */
00164 t += x;
00165
00166 i__1 = en;
00167 for (i__ = *low; i__ <= i__1; ++i__) {
00168 /* L120: */
00169 h__[i__ + i__ * h_dim1] -= x;
00170 }
00171
00172 s = (d__1 = h__[en + na * h_dim1], abs(d__1)) + (d__2 = h__[na + enm2 *
00173 h_dim1], abs(d__2));
00174 x = s * .75;
00175 y = x;
00176 w = s * -.4375 * s;
00177 L130:
00178 ++its;
00179 --itn;
00180 /* .......... LOOK FOR TWO CONSECUTIVE SMALL */
00181 /* SUB-DIAGONAL ELEMENTS. */
00182 /* FOR M=EN-2 STEP -1 UNTIL L DO -- .......... */
00183 i__1 = enm2;
00184 for (mm = l; mm <= i__1; ++mm) {
00185 m = enm2 + l - mm;
00186 zz = h__[m + m * h_dim1];
00187 r__ = x - zz;
00188 s = y - zz;
00189 p = (r__ * s - w) / h__[m + 1 + m * h_dim1] + h__[m + (m + 1) *
00190 h_dim1];
00191 q = h__[m + 1 + (m + 1) * h_dim1] - zz - r__ - s;
00192 r__ = h__[m + 2 + (m + 1) * h_dim1];
00193 s = abs(p) + abs(q) + abs(r__);
00194 p /= s;
00195 q /= s;
00196 r__ /= s;
00197 if (m == l) {
00198 goto L150;
00199 }
00200 tst1 = abs(p) * ((d__1 = h__[m - 1 + (m - 1) * h_dim1], abs(d__1)) +
00201 abs(zz) + (d__2 = h__[m + 1 + (m + 1) * h_dim1], abs(d__2)));
00202 tst2 = tst1 + (d__1 = h__[m + (m - 1) * h_dim1], abs(d__1)) * (abs(q)
00203 + abs(r__));
00204 if (tst2 == tst1) {
00205 goto L150;
00206 }
00207 /* L140: */
00208 }
00209
00210 L150:
00211 mp2 = m + 2;
00212
00213 i__1 = en;
00214 for (i__ = mp2; i__ <= i__1; ++i__) {
00215 h__[i__ + (i__ - 2) * h_dim1] = 0.;
00216 if (i__ == mp2) {
00217 goto L160;
00218 }
00219 h__[i__ + (i__ - 3) * h_dim1] = 0.;
00220 L160:
00221 ;
00222 }
00223 /* .......... DOUBLE QR STEP INVOLVING ROWS L TO EN AND */
00224 /* COLUMNS M TO EN .......... */
00225 i__1 = na;
00226 for (k = m; k <= i__1; ++k) {
00227 notlas = k != na;
00228 if (k == m) {
00229 goto L170;
00230 }
00231 p = h__[k + (k - 1) * h_dim1];
00232 q = h__[k + 1 + (k - 1) * h_dim1];
00233 r__ = 0.;
00234 if (notlas) {
00235 r__ = h__[k + 2 + (k - 1) * h_dim1];
00236 }
00237 x = abs(p) + abs(q) + abs(r__);
00238 if (x == 0.) {
00239 goto L260;
00240 }
00241 p /= x;
00242 q /= x;
00243 r__ /= x;
00244 L170:
00245 d__1 = sqrt(p * p + q * q + r__ * r__);
00246 s = d_sign(&d__1, &p);
00247 if (k == m) {
00248 goto L180;
00249 }
00250 h__[k + (k - 1) * h_dim1] = -s * x;
00251 goto L190;
00252 L180:
00253 if (l != m) {
00254 h__[k + (k - 1) * h_dim1] = -h__[k + (k - 1) * h_dim1];
00255 }
00256 L190:
00257 p += s;
00258 x = p / s;
00259 y = q / s;
00260 zz = r__ / s;
00261 q /= p;
00262 r__ /= p;
00263 if (notlas) {
00264 goto L225;
00265 }
00266 /* .......... ROW MODIFICATION .......... */
00267 i__2 = *n;
00268 for (j = k; j <= i__2; ++j) {
00269 p = h__[k + j * h_dim1] + q * h__[k + 1 + j * h_dim1];
00270 h__[k + j * h_dim1] -= p * x;
00271 h__[k + 1 + j * h_dim1] -= p * y;
00272 /* L200: */
00273 }
00274
00275 /* Computing MIN */
00276 i__2 = en, i__3 = k + 3;
00277 j = min(i__2,i__3);
00278 /* .......... COLUMN MODIFICATION .......... */
00279 i__2 = j;
00280 for (i__ = 1; i__ <= i__2; ++i__) {
00281 p = x * h__[i__ + k * h_dim1] + y * h__[i__ + (k + 1) * h_dim1];
00282 h__[i__ + k * h_dim1] -= p;
00283 h__[i__ + (k + 1) * h_dim1] -= p * q;
00284 /* L210: */
00285 }
00286 goto L255;
00287 L225:
00288 /* .......... ROW MODIFICATION .......... */
00289 i__2 = *n;
00290 for (j = k; j <= i__2; ++j) {
00291 p = h__[k + j * h_dim1] + q * h__[k + 1 + j * h_dim1] + r__ * h__[
00292 k + 2 + j * h_dim1];
00293 h__[k + j * h_dim1] -= p * x;
00294 h__[k + 1 + j * h_dim1] -= p * y;
00295 h__[k + 2 + j * h_dim1] -= p * zz;
00296 /* L230: */
00297 }
00298
00299 /* Computing MIN */
00300 i__2 = en, i__3 = k + 3;
00301 j = min(i__2,i__3);
00302 /* .......... COLUMN MODIFICATION .......... */
00303 i__2 = j;
00304 for (i__ = 1; i__ <= i__2; ++i__) {
00305 p = x * h__[i__ + k * h_dim1] + y * h__[i__ + (k + 1) * h_dim1] +
00306 zz * h__[i__ + (k + 2) * h_dim1];
00307 h__[i__ + k * h_dim1] -= p;
00308 h__[i__ + (k + 1) * h_dim1] -= p * q;
00309 h__[i__ + (k + 2) * h_dim1] -= p * r__;
00310 /* L240: */
00311 }
00312 L255:
00313
00314 L260:
00315 ;
00316 }
00317
00318 goto L70;
00319 /* .......... ONE ROOT FOUND .......... */
00320 L270:
00321 wr[en] = x + t;
00322 wi[en] = 0.;
00323 en = na;
00324 goto L60;
00325 /* .......... TWO ROOTS FOUND .......... */
00326 L280:
00327 p = (y - x) / 2.;
00328 q = p * p + w;
00329 zz = sqrt((abs(q)));
00330 x += t;
00331 if (q < 0.) {
00332 goto L320;
00333 }
00334 /* .......... REAL PAIR .......... */
00335 zz = p + d_sign(&zz, &p);
00336 wr[na] = x + zz;
00337 wr[en] = wr[na];
00338 if (zz != 0.) {
00339 wr[en] = x - w / zz;
00340 }
00341 wi[na] = 0.;
00342 wi[en] = 0.;
00343 goto L330;
00344 /* .......... COMPLEX PAIR .......... */
00345 L320:
00346 wr[na] = x + p;
00347 wr[en] = x + p;
00348 wi[na] = zz;
00349 wi[en] = -zz;
00350 L330:
00351 en = enm2;
00352 goto L60;
00353 /* .......... SET ERROR -- ALL EIGENVALUES HAVE NOT */
00354 /* CONVERGED AFTER 30*N ITERATIONS .......... */
00355 L1000:
00356 *ierr = en;
00357 L1001:
00358 return 0;
00359 } /* hqr_ */
|
|
||||||||||||||||||||||||||||||||
|
Definition at line 8 of file eis_htrib3.c.
00010 {
00011 /* System generated locals */
00012 integer a_dim1, a_offset, zr_dim1, zr_offset, zi_dim1, zi_offset, i__1,
00013 i__2, i__3;
00014
00015 /* Local variables */
00016 static doublereal h__;
00017 static integer i__, j, k, l;
00018 static doublereal s, si;
00019
00020
00021
00022 /* THIS SUBROUTINE IS A TRANSLATION OF A COMPLEX ANALOGUE OF */
00023 /* THE ALGOL PROCEDURE TRBAK3, NUM. MATH. 11, 181-195(1968) */
00024 /* BY MARTIN, REINSCH, AND WILKINSON. */
00025 /* HANDBOOK FOR AUTO. COMP., VOL.II-LINEAR ALGEBRA, 212-226(1971). */
00026
00027 /* THIS SUBROUTINE FORMS THE EIGENVECTORS OF A COMPLEX HERMITIAN */
00028 /* MATRIX BY BACK TRANSFORMING THOSE OF THE CORRESPONDING */
00029 /* REAL SYMMETRIC TRIDIAGONAL MATRIX DETERMINED BY HTRID3. */
00030
00031 /* ON INPUT */
00032
00033 /* NM MUST BE SET TO THE ROW DIMENSION OF TWO-DIMENSIONAL */
00034 /* ARRAY PARAMETERS AS DECLARED IN THE CALLING PROGRAM */
00035 /* DIMENSION STATEMENT. */
00036
00037 /* N IS THE ORDER OF THE MATRIX. */
00038
00039 /* A CONTAINS INFORMATION ABOUT THE UNITARY TRANSFORMATIONS */
00040 /* USED IN THE REDUCTION BY HTRID3. */
00041
00042 /* TAU CONTAINS FURTHER INFORMATION ABOUT THE TRANSFORMATIONS. */
00043
00044 /* M IS THE NUMBER OF EIGENVECTORS TO BE BACK TRANSFORMED. */
00045
00046 /* ZR CONTAINS THE EIGENVECTORS TO BE BACK TRANSFORMED */
00047 /* IN ITS FIRST M COLUMNS. */
00048
00049 /* ON OUTPUT */
00050
00051 /* ZR AND ZI CONTAIN THE REAL AND IMAGINARY PARTS, */
00052 /* RESPECTIVELY, OF THE TRANSFORMED EIGENVECTORS */
00053 /* IN THEIR FIRST M COLUMNS. */
00054
00055 /* NOTE THAT THE LAST COMPONENT OF EACH RETURNED VECTOR */
00056 /* IS REAL AND THAT VECTOR EUCLIDEAN NORMS ARE PRESERVED. */
00057
00058 /* QUESTIONS AND COMMENTS SHOULD BE DIRECTED TO BURTON S. GARBOW, */
00059 /* MATHEMATICS AND COMPUTER SCIENCE DIV, ARGONNE NATIONAL LABORATORY
00060 */
00061
00062 /* THIS VERSION DATED AUGUST 1983. */
00063
00064 /* ------------------------------------------------------------------
00065 */
00066
00067 /* Parameter adjustments */
00068 tau -= 3;
00069 a_dim1 = *nm;
00070 a_offset = a_dim1 + 1;
00071 a -= a_offset;
00072 zi_dim1 = *nm;
00073 zi_offset = zi_dim1 + 1;
00074 zi -= zi_offset;
00075 zr_dim1 = *nm;
00076 zr_offset = zr_dim1 + 1;
00077 zr -= zr_offset;
00078
00079 /* Function Body */
00080 if (*m == 0) {
00081 goto L200;
00082 }
00083 /* .......... TRANSFORM THE EIGENVECTORS OF THE REAL SYMMETRIC */
00084 /* TRIDIAGONAL MATRIX TO THOSE OF THE HERMITIAN */
00085 /* TRIDIAGONAL MATRIX. .......... */
00086 i__1 = *n;
00087 for (k = 1; k <= i__1; ++k) {
00088
00089 i__2 = *m;
00090 for (j = 1; j <= i__2; ++j) {
00091 zi[k + j * zi_dim1] = -zr[k + j * zr_dim1] * tau[(k << 1) + 2];
00092 zr[k + j * zr_dim1] *= tau[(k << 1) + 1];
00093 /* L50: */
00094 }
00095 }
00096
00097 if (*n == 1) {
00098 goto L200;
00099 }
00100 /* .......... RECOVER AND APPLY THE HOUSEHOLDER MATRICES .......... */
00101 i__2 = *n;
00102 for (i__ = 2; i__ <= i__2; ++i__) {
00103 l = i__ - 1;
00104 h__ = a[i__ + i__ * a_dim1];
00105 if (h__ == 0.) {
00106 goto L140;
00107 }
00108
00109 i__1 = *m;
00110 for (j = 1; j <= i__1; ++j) {
00111 s = 0.;
00112 si = 0.;
00113
00114 i__3 = l;
00115 for (k = 1; k <= i__3; ++k) {
00116 s = s + a[i__ + k * a_dim1] * zr[k + j * zr_dim1] - a[k + i__
00117 * a_dim1] * zi[k + j * zi_dim1];
00118 si = si + a[i__ + k * a_dim1] * zi[k + j * zi_dim1] + a[k +
00119 i__ * a_dim1] * zr[k + j * zr_dim1];
00120 /* L110: */
00121 }
00122 /* .......... DOUBLE DIVISIONS AVOID POSSIBLE UNDERFLOW ......
00123 .... */
00124 s = s / h__ / h__;
00125 si = si / h__ / h__;
00126
00127 i__3 = l;
00128 for (k = 1; k <= i__3; ++k) {
00129 zr[k + j * zr_dim1] = zr[k + j * zr_dim1] - s * a[i__ + k *
00130 a_dim1] - si * a[k + i__ * a_dim1];
00131 zi[k + j * zi_dim1] = zi[k + j * zi_dim1] - si * a[i__ + k *
00132 a_dim1] + s * a[k + i__ * a_dim1];
00133 /* L120: */
00134 }
00135
00136 /* L130: */
00137 }
00138
00139 L140:
00140 ;
00141 }
00142
00143 L200:
00144 return 0;
00145 } /* htrib3_ */
|
|
||||||||||||||||||||||||||||||||||||
|
Definition at line 8 of file eis_htribk.c. References l. Referenced by ch_().
00011 {
00012 /* System generated locals */
00013 integer ar_dim1, ar_offset, ai_dim1, ai_offset, zr_dim1, zr_offset,
00014 zi_dim1, zi_offset, i__1, i__2, i__3;
00015
00016 /* Local variables */
00017 static doublereal h__;
00018 static integer i__, j, k, l;
00019 static doublereal s, si;
00020
00021
00022
00023 /* THIS SUBROUTINE IS A TRANSLATION OF A COMPLEX ANALOGUE OF */
00024 /* THE ALGOL PROCEDURE TRBAK1, NUM. MATH. 11, 181-195(1968) */
00025 /* BY MARTIN, REINSCH, AND WILKINSON. */
00026 /* HANDBOOK FOR AUTO. COMP., VOL.II-LINEAR ALGEBRA, 212-226(1971). */
00027
00028 /* THIS SUBROUTINE FORMS THE EIGENVECTORS OF A COMPLEX HERMITIAN */
00029 /* MATRIX BY BACK TRANSFORMING THOSE OF THE CORRESPONDING */
00030 /* REAL SYMMETRIC TRIDIAGONAL MATRIX DETERMINED BY HTRIDI. */
00031
00032 /* ON INPUT */
00033
00034 /* NM MUST BE SET TO THE ROW DIMENSION OF TWO-DIMENSIONAL */
00035 /* ARRAY PARAMETERS AS DECLARED IN THE CALLING PROGRAM */
00036 /* DIMENSION STATEMENT. */
00037
00038 /* N IS THE ORDER OF THE MATRIX. */
00039
00040 /* AR AND AI CONTAIN INFORMATION ABOUT THE UNITARY TRANS- */
00041 /* FORMATIONS USED IN THE REDUCTION BY HTRIDI IN THEIR */
00042 /* FULL LOWER TRIANGLES EXCEPT FOR THE DIAGONAL OF AR. */
00043
00044 /* TAU CONTAINS FURTHER INFORMATION ABOUT THE TRANSFORMATIONS. */
00045
00046 /* M IS THE NUMBER OF EIGENVECTORS TO BE BACK TRANSFORMED. */
00047
00048 /* ZR CONTAINS THE EIGENVECTORS TO BE BACK TRANSFORMED */
00049 /* IN ITS FIRST M COLUMNS. */
00050
00051 /* ON OUTPUT */
00052
00053 /* ZR AND ZI CONTAIN THE REAL AND IMAGINARY PARTS, */
00054 /* RESPECTIVELY, OF THE TRANSFORMED EIGENVECTORS */
00055 /* IN THEIR FIRST M COLUMNS. */
00056
00057 /* NOTE THAT THE LAST COMPONENT OF EACH RETURNED VECTOR */
00058 /* IS REAL AND THAT VECTOR EUCLIDEAN NORMS ARE PRESERVED. */
00059
00060 /* QUESTIONS AND COMMENTS SHOULD BE DIRECTED TO BURTON S. GARBOW, */
00061 /* MATHEMATICS AND COMPUTER SCIENCE DIV, ARGONNE NATIONAL LABORATORY
00062 */
00063
00064 /* THIS VERSION DATED AUGUST 1983. */
00065
00066 /* ------------------------------------------------------------------
00067 */
00068
00069 /* Parameter adjustments */
00070 tau -= 3;
00071 ai_dim1 = *nm;
00072 ai_offset = ai_dim1 + 1;
00073 ai -= ai_offset;
00074 ar_dim1 = *nm;
00075 ar_offset = ar_dim1 + 1;
00076 ar -= ar_offset;
00077 zi_dim1 = *nm;
00078 zi_offset = zi_dim1 + 1;
00079 zi -= zi_offset;
00080 zr_dim1 = *nm;
00081 zr_offset = zr_dim1 + 1;
00082 zr -= zr_offset;
00083
00084 /* Function Body */
00085 if (*m == 0) {
00086 goto L200;
00087 }
00088 /* .......... TRANSFORM THE EIGENVECTORS OF THE REAL SYMMETRIC */
00089 /* TRIDIAGONAL MATRIX TO THOSE OF THE HERMITIAN */
00090 /* TRIDIAGONAL MATRIX. .......... */
00091 i__1 = *n;
00092 for (k = 1; k <= i__1; ++k) {
00093
00094 i__2 = *m;
00095 for (j = 1; j <= i__2; ++j) {
00096 zi[k + j * zi_dim1] = -zr[k + j * zr_dim1] * tau[(k << 1) + 2];
00097 zr[k + j * zr_dim1] *= tau[(k << 1) + 1];
00098 /* L50: */
00099 }
00100 }
00101
00102 if (*n == 1) {
00103 goto L200;
00104 }
00105 /* .......... RECOVER AND APPLY THE HOUSEHOLDER MATRICES .......... */
00106 i__2 = *n;
00107 for (i__ = 2; i__ <= i__2; ++i__) {
00108 l = i__ - 1;
00109 h__ = ai[i__ + i__ * ai_dim1];
00110 if (h__ == 0.) {
00111 goto L140;
00112 }
00113
00114 i__1 = *m;
00115 for (j = 1; j <= i__1; ++j) {
00116 s = 0.;
00117 si = 0.;
00118
00119 i__3 = l;
00120 for (k = 1; k <= i__3; ++k) {
00121 s = s + ar[i__ + k * ar_dim1] * zr[k + j * zr_dim1] - ai[i__
00122 + k * ai_dim1] * zi[k + j * zi_dim1];
00123 si = si + ar[i__ + k * ar_dim1] * zi[k + j * zi_dim1] + ai[
00124 i__ + k * ai_dim1] * zr[k + j * zr_dim1];
00125 /* L110: */
00126 }
00127 /* .......... DOUBLE DIVISIONS AVOID POSSIBLE UNDERFLOW ......
00128 .... */
00129 s = s / h__ / h__;
00130 si = si / h__ / h__;
00131
00132 i__3 = l;
00133 for (k = 1; k <= i__3; ++k) {
00134 zr[k + j * zr_dim1] = zr[k + j * zr_dim1] - s * ar[i__ + k *
00135 ar_dim1] - si * ai[i__ + k * ai_dim1];
00136 zi[k + j * zi_dim1] = zi[k + j * zi_dim1] - si * ar[i__ + k *
00137 ar_dim1] + s * ai[i__ + k * ai_dim1];
00138 /* L120: */
00139 }
00140
00141 /* L130: */
00142 }
00143
00144 L140:
00145 ;
00146 }
00147
00148 L200:
00149 return 0;
00150 } /* htribk_ */
|
|
||||||||||||||||||||||||||||||||
|
Definition at line 8 of file eis_htrid3.c. References a, abs, l, pythag_(), and scale.
00010 {
00011 /* System generated locals */
00012 integer a_dim1, a_offset, i__1, i__2, i__3;
00013 doublereal d__1, d__2;
00014
00015 /* Builtin functions */
00016 double sqrt(doublereal);
00017
00018 /* Local variables */
00019 static doublereal f, g, h__;
00020 static integer i__, j, k, l;
00021 static doublereal scale, fi, gi, hh;
00022 static integer ii;
00023 static doublereal si;
00024 extern doublereal pythag_(doublereal *, doublereal *);
00025 static integer jm1, jp1;
00026
00027
00028
00029 /* THIS SUBROUTINE IS A TRANSLATION OF A COMPLEX ANALOGUE OF */
00030 /* THE ALGOL PROCEDURE TRED3, NUM. MATH. 11, 181-195(1968) */
00031 /* BY MARTIN, REINSCH, AND WILKINSON. */
00032 /* HANDBOOK FOR AUTO. COMP., VOL.II-LINEAR ALGEBRA, 212-226(1971). */
00033
00034 /* THIS SUBROUTINE REDUCES A COMPLEX HERMITIAN MATRIX, STORED AS */
00035 /* A SINGLE SQUARE ARRAY, TO A REAL SYMMETRIC TRIDIAGONAL MATRIX */
00036 /* USING UNITARY SIMILARITY TRANSFORMATIONS. */
00037
00038 /* ON INPUT */
00039
00040 /* NM MUST BE SET TO THE ROW DIMENSION OF TWO-DIMENSIONAL */
00041 /* ARRAY PARAMETERS AS DECLARED IN THE CALLING PROGRAM */
00042 /* DIMENSION STATEMENT. */
00043
00044 /* N IS THE ORDER OF THE MATRIX. */
00045
00046 /* A CONTAINS THE LOWER TRIANGLE OF THE COMPLEX HERMITIAN INPUT */
00047 /* MATRIX. THE REAL PARTS OF THE MATRIX ELEMENTS ARE STORED */
00048 /* IN THE FULL LOWER TRIANGLE OF A, AND THE IMAGINARY PARTS */
00049 /* ARE STORED IN THE TRANSPOSED POSITIONS OF THE STRICT UPPER */
00050 /* TRIANGLE OF A. NO STORAGE IS REQUIRED FOR THE ZERO */
00051 /* IMAGINARY PARTS OF THE DIAGONAL ELEMENTS. */
00052
00053 /* ON OUTPUT */
00054
00055 /* A CONTAINS INFORMATION ABOUT THE UNITARY TRANSFORMATIONS */
00056 /* USED IN THE REDUCTION. */
00057
00058 /* D CONTAINS THE DIAGONAL ELEMENTS OF THE THE TRIDIAGONAL MATRIX.
00059 */
00060
00061 /* E CONTAINS THE SUBDIAGONAL ELEMENTS OF THE TRIDIAGONAL */
00062 /* MATRIX IN ITS LAST N-1 POSITIONS. E(1) IS SET TO ZERO. */
00063
00064 /* E2 CONTAINS THE SQUARES OF THE CORRESPONDING ELEMENTS OF E. */
00065 /* E2 MAY COINCIDE WITH E IF THE SQUARES ARE NOT NEEDED. */
00066
00067 /* TAU CONTAINS FURTHER INFORMATION ABOUT THE TRANSFORMATIONS. */
00068
00069 /* CALLS PYTHAG FOR DSQRT(A*A + B*B) . */
00070
00071 /* QUESTIONS AND COMMENTS SHOULD BE DIRECTED TO BURTON S. GARBOW, */
00072 /* MATHEMATICS AND COMPUTER SCIENCE DIV, ARGONNE NATIONAL LABORATORY
00073 */
00074
00075 /* THIS VERSION DATED AUGUST 1983. */
00076
00077 /* ------------------------------------------------------------------
00078 */
00079
00080 /* Parameter adjustments */
00081 tau -= 3;
00082 --e2;
00083 --e;
00084 --d__;
00085 a_dim1 = *nm;
00086 a_offset = a_dim1 + 1;
00087 a -= a_offset;
00088
00089 /* Function Body */
00090 tau[(*n << 1) + 1] = 1.;
00091 tau[(*n << 1) + 2] = 0.;
00092 /* .......... FOR I=N STEP -1 UNTIL 1 DO -- .......... */
00093 i__1 = *n;
00094 for (ii = 1; ii <= i__1; ++ii) {
00095 i__ = *n + 1 - ii;
00096 l = i__ - 1;
00097 h__ = 0.;
00098 scale = 0.;
00099 if (l < 1) {
00100 goto L130;
00101 }
00102 /* .......... SCALE ROW (ALGOL TOL THEN NOT NEEDED) .......... */
00103 i__2 = l;
00104 for (k = 1; k <= i__2; ++k) {
00105 /* L120: */
00106 scale = scale + (d__1 = a[i__ + k * a_dim1], abs(d__1)) + (d__2 =
00107 a[k + i__ * a_dim1], abs(d__2));
00108 }
00109
00110 if (scale != 0.) {
00111 goto L140;
00112 }
00113 tau[(l << 1) + 1] = 1.;
00114 tau[(l << 1) + 2] = 0.;
00115 L130:
00116 e[i__] = 0.;
00117 e2[i__] = 0.;
00118 goto L290;
00119
00120 L140:
00121 i__2 = l;
00122 for (k = 1; k <= i__2; ++k) {
00123 a[i__ + k * a_dim1] /= scale;
00124 a[k + i__ * a_dim1] /= scale;
00125 h__ = h__ + a[i__ + k * a_dim1] * a[i__ + k * a_dim1] + a[k + i__
00126 * a_dim1] * a[k + i__ * a_dim1];
00127 /* L150: */
00128 }
00129
00130 e2[i__] = scale * scale * h__;
00131 g = sqrt(h__);
00132 e[i__] = scale * g;
00133 f = pythag_(&a[i__ + l * a_dim1], &a[l + i__ * a_dim1]);
00134 /* .......... FORM NEXT DIAGONAL ELEMENT OF MATRIX T .......... */
00135 if (f == 0.) {
00136 goto L160;
00137 }
00138 tau[(l << 1) + 1] = (a[l + i__ * a_dim1] * tau[(i__ << 1) + 2] - a[
00139 i__ + l * a_dim1] * tau[(i__ << 1) + 1]) / f;
00140 si = (a[i__ + l * a_dim1] * tau[(i__ << 1) + 2] + a[l + i__ * a_dim1]
00141 * tau[(i__ << 1) + 1]) / f;
00142 h__ += f * g;
00143 g = g / f + 1.;
00144 a[i__ + l * a_dim1] = g * a[i__ + l * a_dim1];
00145 a[l + i__ * a_dim1] = g * a[l + i__ * a_dim1];
00146 if (l == 1) {
00147 goto L270;
00148 }
00149 goto L170;
00150 L160:
00151 tau[(l << 1) + 1] = -tau[(i__ << 1) + 1];
00152 si = tau[(i__ << 1) + 2];
00153 a[i__ + l * a_dim1] = g;
00154 L170:
00155 f = 0.;
00156
00157 i__2 = l;
00158 for (j = 1; j <= i__2; ++j) {
00159 g = 0.;
00160 gi = 0.;
00161 if (j == 1) {
00162 goto L190;
00163 }
00164 jm1 = j - 1;
00165 /* .......... FORM ELEMENT OF A*U .......... */
00166 i__3 = jm1;
00167 for (k = 1; k <= i__3; ++k) {
00168 g = g + a[j + k * a_dim1] * a[i__ + k * a_dim1] + a[k + j *
00169 a_dim1] * a[k + i__ * a_dim1];
00170 gi = gi - a[j + k * a_dim1] * a[k + i__ * a_dim1] + a[k + j *
00171 a_dim1] * a[i__ + k * a_dim1];
00172 /* L180: */
00173 }
00174
00175 L190:
00176 g += a[j + j * a_dim1] * a[i__ + j * a_dim1];
00177 gi -= a[j + j * a_dim1] * a[j + i__ * a_dim1];
00178 jp1 = j + 1;
00179 if (l < jp1) {
00180 goto L220;
00181 }
00182
00183 i__3 = l;
00184 for (k = jp1; k <= i__3; ++k) {
00185 g = g + a[k + j * a_dim1] * a[i__ + k * a_dim1] - a[j + k *
00186 a_dim1] * a[k + i__ * a_dim1];
00187 gi = gi - a[k + j * a_dim1] * a[k + i__ * a_dim1] - a[j + k *
00188 a_dim1] * a[i__ + k * a_dim1];
00189 /* L200: */
00190 }
00191 /* .......... FORM ELEMENT OF P .......... */
00192 L220:
00193 e[j] = g / h__;
00194 tau[(j << 1) + 2] = gi / h__;
00195 f = f + e[j] * a[i__ + j * a_dim1] - tau[(j << 1) + 2] * a[j +
00196 i__ * a_dim1];
00197 /* L240: */
00198 }
00199
00200 hh = f / (h__ + h__);
00201 /* .......... FORM REDUCED A .......... */
00202 i__2 = l;
00203 for (j = 1; j <= i__2; ++j) {
00204 f = a[i__ + j * a_dim1];
00205 g = e[j] - hh * f;
00206 e[j] = g;
00207 fi = -a[j + i__ * a_dim1];
00208 gi = tau[(j << 1) + 2] - hh * fi;
00209 tau[(j << 1) + 2] = -gi;
00210 a[j + j * a_dim1] -= (f * g + fi * gi) * 2.;
00211 if (j == 1) {
00212 goto L260;
00213 }
00214 jm1 = j - 1;
00215
00216 i__3 = jm1;
00217 for (k = 1; k <= i__3; ++k) {
00218 a[j + k * a_dim1] = a[j + k * a_dim1] - f * e[k] - g * a[i__
00219 + k * a_dim1] + fi * tau[(k << 1) + 2] + gi * a[k +
00220 i__ * a_dim1];
00221 a[k + j * a_dim1] = a[k + j * a_dim1] - f * tau[(k << 1) + 2]
00222 - g * a[k + i__ * a_dim1] - fi * e[k] - gi * a[i__ +
00223 k * a_dim1];
00224 /* L250: */
00225 }
00226
00227 L260:
00228 ;
00229 }
00230
00231 L270:
00232 i__2 = l;
00233 for (k = 1; k <= i__2; ++k) {
00234 a[i__ + k * a_dim1] = scale * a[i__ + k * a_dim1];
00235 a[k + i__ * a_dim1] = scale * a[k + i__ * a_dim1];
00236 /* L280: */
00237 }
00238
00239 tau[(l << 1) + 2] = -si;
00240 L290:
00241 d__[i__] = a[i__ + i__ * a_dim1];
00242 a[i__ + i__ * a_dim1] = scale * sqrt(h__);
00243 /* L300: */
00244 }
00245
00246 return 0;
00247 } /* htrid3_ */
|
|
||||||||||||||||||||||||||||||||||||
|
Definition at line 8 of file eis_htridi.c. References abs, l, pythag_(), and scale. Referenced by ch_().
00011 {
00012 /* System generated locals */
00013 integer ar_dim1, ar_offset, ai_dim1, ai_offset, i__1, i__2, i__3;
00014 doublereal d__1, d__2;
00015
00016 /* Builtin functions */
00017 double sqrt(doublereal);
00018
00019 /* Local variables */
00020 static doublereal f, g, h__;
00021 static integer i__, j, k, l;
00022 static doublereal scale, fi, gi, hh;
00023 static integer ii;
00024 static doublereal si;
00025 extern doublereal pythag_(doublereal *, doublereal *);
00026 static integer jp1;
00027
00028
00029
00030 /* THIS SUBROUTINE IS A TRANSLATION OF A COMPLEX ANALOGUE OF */
00031 /* THE ALGOL PROCEDURE TRED1, NUM. MATH. 11, 181-195(1968) */
00032 /* BY MARTIN, REINSCH, AND WILKINSON. */
00033 /* HANDBOOK FOR AUTO. COMP., VOL.II-LINEAR ALGEBRA, 212-226(1971). */
00034
00035 /* THIS SUBROUTINE REDUCES A COMPLEX HERMITIAN MATRIX */
00036 /* TO A REAL SYMMETRIC TRIDIAGONAL MATRIX USING */
00037 /* UNITARY SIMILARITY TRANSFORMATIONS. */
00038
00039 /* ON INPUT */
00040
00041 /* NM MUST BE SET TO THE ROW DIMENSION OF TWO-DIMENSIONAL */
00042 /* ARRAY PARAMETERS AS DECLARED IN THE CALLING PROGRAM */
00043 /* DIMENSION STATEMENT. */
00044
00045 /* N IS THE ORDER OF THE MATRIX. */
00046
00047 /* AR AND AI CONTAIN THE REAL AND IMAGINARY PARTS, */
00048 /* RESPECTIVELY, OF THE COMPLEX HERMITIAN INPUT MATRIX. */
00049 /* ONLY THE LOWER TRIANGLE OF THE MATRIX NEED BE SUPPLIED. */
00050
00051 /* ON OUTPUT */
00052
00053 /* AR AND AI CONTAIN INFORMATION ABOUT THE UNITARY TRANS- */
00054 /* FORMATIONS USED IN THE REDUCTION IN THEIR FULL LOWER */
00055 /* TRIANGLES. THEIR STRICT UPPER TRIANGLES AND THE */
00056 /* DIAGONAL OF AR ARE UNALTERED. */
00057
00058 /* D CONTAINS THE DIAGONAL ELEMENTS OF THE THE TRIDIAGONAL MATRIX.
00059 */
00060
00061 /* E CONTAINS THE SUBDIAGONAL ELEMENTS OF THE TRIDIAGONAL */
00062 /* MATRIX IN ITS LAST N-1 POSITIONS. E(1) IS SET TO ZERO. */
00063
00064 /* E2 CONTAINS THE SQUARES OF THE CORRESPONDING ELEMENTS OF E. */
00065 /* E2 MAY COINCIDE WITH E IF THE SQUARES ARE NOT NEEDED. */
00066
00067 /* TAU CONTAINS FURTHER INFORMATION ABOUT THE TRANSFORMATIONS. */
00068
00069 /* CALLS PYTHAG FOR DSQRT(A*A + B*B) . */
00070
00071 /* QUESTIONS AND COMMENTS SHOULD BE DIRECTED TO BURTON S. GARBOW, */
00072 /* MATHEMATICS AND COMPUTER SCIENCE DIV, ARGONNE NATIONAL LABORATORY
00073 */
00074
00075 /* THIS VERSION DATED AUGUST 1983. */
00076
00077 /* ------------------------------------------------------------------
00078 */
00079
00080 /* Parameter adjustments */
00081 tau -= 3;
00082 --e2;
00083 --e;
00084 --d__;
00085 ai_dim1 = *nm;
00086 ai_offset = ai_dim1 + 1;
00087 ai -= ai_offset;
00088 ar_dim1 = *nm;
00089 ar_offset = ar_dim1 + 1;
00090 ar -= ar_offset;
00091
00092 /* Function Body */
00093 tau[(*n << 1) + 1] = 1.;
00094 tau[(*n << 1) + 2] = 0.;
00095
00096 i__1 = *n;
00097 for (i__ = 1; i__ <= i__1; ++i__) {
00098 /* L100: */
00099 d__[i__] = ar[i__ + i__ * ar_dim1];
00100 }
00101 /* .......... FOR I=N STEP -1 UNTIL 1 DO -- .......... */
00102 i__1 = *n;
00103 for (ii = 1; ii <= i__1; ++ii) {
00104 i__ = *n + 1 - ii;
00105 l = i__ - 1;
00106 h__ = 0.;
00107 scale = 0.;
00108 if (l < 1) {
00109 goto L130;
00110 }
00111 /* .......... SCALE ROW (ALGOL TOL THEN NOT NEEDED) .......... */
00112 i__2 = l;
00113 for (k = 1; k <= i__2; ++k) {
00114 /* L120: */
00115 scale = scale + (d__1 = ar[i__ + k * ar_dim1], abs(d__1)) + (d__2
00116 = ai[i__ + k * ai_dim1], abs(d__2));
00117 }
00118
00119 if (scale != 0.) {
00120 goto L140;
00121 }
00122 tau[(l << 1) + 1] = 1.;
00123 tau[(l << 1) + 2] = 0.;
00124 L130:
00125 e[i__] = 0.;
00126 e2[i__] = 0.;
00127 goto L290;
00128
00129 L140:
00130 i__2 = l;
00131 for (k = 1; k <= i__2; ++k) {
00132 ar[i__ + k * ar_dim1] /= scale;
00133 ai[i__ + k * ai_dim1] /= scale;
00134 h__ = h__ + ar[i__ + k * ar_dim1] * ar[i__ + k * ar_dim1] + ai[
00135 i__ + k * ai_dim1] * ai[i__ + k * ai_dim1];
00136 /* L150: */
00137 }
00138
00139 e2[i__] = scale * scale * h__;
00140 g = sqrt(h__);
00141 e[i__] = scale * g;
00142 f = pythag_(&ar[i__ + l * ar_dim1], &ai[i__ + l * ai_dim1]);
00143 /* .......... FORM NEXT DIAGONAL ELEMENT OF MATRIX T .......... */
00144 if (f == 0.) {
00145 goto L160;
00146 }
00147 tau[(l << 1) + 1] = (ai[i__ + l * ai_dim1] * tau[(i__ << 1) + 2] - ar[
00148 i__ + l * ar_dim1] * tau[(i__ << 1) + 1]) / f;
00149 si = (ar[i__ + l * ar_dim1] * tau[(i__ << 1) + 2] + ai[i__ + l *
00150 ai_dim1] * tau[(i__ << 1) + 1]) / f;
00151 h__ += f * g;
00152 g = g / f + 1.;
00153 ar[i__ + l * ar_dim1] = g * ar[i__ + l * ar_dim1];
00154 ai[i__ + l * ai_dim1] = g * ai[i__ + l * ai_dim1];
00155 if (l == 1) {
00156 goto L270;
00157 }
00158 goto L170;
00159 L160:
00160 tau[(l << 1) + 1] = -tau[(i__ << 1) + 1];
00161 si = tau[(i__ << 1) + 2];
00162 ar[i__ + l * ar_dim1] = g;
00163 L170:
00164 f = 0.;
00165
00166 i__2 = l;
00167 for (j = 1; j <= i__2; ++j) {
00168 g = 0.;
00169 gi = 0.;
00170 /* .......... FORM ELEMENT OF A*U .......... */
00171 i__3 = j;
00172 for (k = 1; k <= i__3; ++k) {
00173 g = g + ar[j + k * ar_dim1] * ar[i__ + k * ar_dim1] + ai[j +
00174 k * ai_dim1] * ai[i__ + k * ai_dim1];
00175 gi = gi - ar[j + k * ar_dim1] * ai[i__ + k * ai_dim1] + ai[j
00176 + k * ai_dim1] * ar[i__ + k * ar_dim1];
00177 /* L180: */
00178 }
00179
00180 jp1 = j + 1;
00181 if (l < jp1) {
00182 goto L220;
00183 }
00184
00185 i__3 = l;
00186 for (k = jp1; k <= i__3; ++k) {
00187 g = g + ar[k + j * ar_dim1] * ar[i__ + k * ar_dim1] - ai[k +
00188 j * ai_dim1] * ai[i__ + k * ai_dim1];
00189 gi = gi - ar[k + j * ar_dim1] * ai[i__ + k * ai_dim1] - ai[k
00190 + j * ai_dim1] * ar[i__ + k * ar_dim1];
00191 /* L200: */
00192 }
00193 /* .......... FORM ELEMENT OF P .......... */
00194 L220:
00195 e[j] = g / h__;
00196 tau[(j << 1) + 2] = gi / h__;
00197 f = f + e[j] * ar[i__ + j * ar_dim1] - tau[(j << 1) + 2] * ai[i__
00198 + j * ai_dim1];
00199 /* L240: */
00200 }
00201
00202 hh = f / (h__ + h__);
00203 /* .......... FORM REDUCED A .......... */
00204 i__2 = l;
00205 for (j = 1; j <= i__2; ++j) {
00206 f = ar[i__ + j * ar_dim1];
00207 g = e[j] - hh * f;
00208 e[j] = g;
00209 fi = -ai[i__ + j * ai_dim1];
00210 gi = tau[(j << 1) + 2] - hh * fi;
00211 tau[(j << 1) + 2] = -gi;
00212
00213 i__3 = j;
00214 for (k = 1; k <= i__3; ++k) {
00215 ar[j + k * ar_dim1] = ar[j + k * ar_dim1] - f * e[k] - g * ar[
00216 i__ + k * ar_dim1] + fi * tau[(k << 1) + 2] + gi * ai[
00217 i__ + k * ai_dim1];
00218 ai[j + k * ai_dim1] = ai[j + k * ai_dim1] - f * tau[(k << 1)
00219 + 2] - g * ai[i__ + k * ai_dim1] - fi * e[k] - gi *
00220 ar[i__ + k * ar_dim1];
00221 /* L260: */
00222 }
00223 }
00224
00225 L270:
00226 i__3 = l;
00227 for (k = 1; k <= i__3; ++k) {
00228 ar[i__ + k * ar_dim1] = scale * ar[i__ + k * ar_dim1];
00229 ai[i__ + k * ai_dim1] = scale * ai[i__ + k * ai_dim1];
00230 /* L280: */
00231 }
00232
00233 tau[(l << 1) + 2] = -si;
00234 L290:
00235 hh = d__[i__];
00236 d__[i__] = ar[i__ + i__ * ar_dim1];
00237 ar[i__ + i__ * ar_dim1] = hh;
00238 ai[i__ + i__ * ai_dim1] = scale * sqrt(h__);
00239 /* L300: */
00240 }
00241
00242 return 0;
00243 } /* htridi_ */
|
|
||||||||||||||||||||
|
Definition at line 12 of file eis_imtql1.c. References abs, c_b10, d_sign(), l, p, and pythag_(). Referenced by rst_(), and rt_().
00014 {
00015 /* System generated locals */
00016 integer i__1, i__2;
00017 doublereal d__1, d__2;
00018
00019 /* Builtin functions */
00020 double d_sign(doublereal *, doublereal *);
00021
00022 /* Local variables */
00023 static doublereal b, c__, f, g;
00024 static integer i__, j, l, m;
00025 static doublereal p, r__, s;
00026 static integer ii;
00027 extern doublereal pythag_(doublereal *, doublereal *);
00028 static integer mml;
00029 static doublereal tst1, tst2;
00030
00031
00032
00033 /* THIS SUBROUTINE IS A TRANSLATION OF THE ALGOL PROCEDURE IMTQL1, */
00034 /* NUM. MATH. 12, 377-383(1968) BY MARTIN AND WILKINSON, */
00035 /* AS MODIFIED IN NUM. MATH. 15, 450(1970) BY DUBRULLE. */
00036 /* HANDBOOK FOR AUTO. COMP., VOL.II-LINEAR ALGEBRA, 241-248(1971). */
00037
00038 /* THIS SUBROUTINE FINDS THE EIGENVALUES OF A SYMMETRIC */
00039 /* TRIDIAGONAL MATRIX BY THE IMPLICIT QL METHOD. */
00040
00041 /* ON INPUT */
00042
00043 /* N IS THE ORDER OF THE MATRIX. */
00044
00045 /* D CONTAINS THE DIAGONAL ELEMENTS OF THE INPUT MATRIX. */
00046
00047 /* E CONTAINS THE SUBDIAGONAL ELEMENTS OF THE INPUT MATRIX */
00048 /* IN ITS LAST N-1 POSITIONS. E(1) IS ARBITRARY. */
00049
00050 /* ON OUTPUT */
00051
00052 /* D CONTAINS THE EIGENVALUES IN ASCENDING ORDER. IF AN */
00053 /* ERROR EXIT IS MADE, THE EIGENVALUES ARE CORRECT AND */
00054 /* ORDERED FOR INDICES 1,2,...IERR-1, BUT MAY NOT BE */
00055 /* THE SMALLEST EIGENVALUES. */
00056
00057 /* E HAS BEEN DESTROYED. */
00058
00059 /* IERR IS SET TO */
00060 /* ZERO FOR NORMAL RETURN, */
00061 /* J IF THE J-TH EIGENVALUE HAS NOT BEEN */
00062 /* DETERMINED AFTER 30 ITERATIONS. */
00063
00064 /* CALLS PYTHAG FOR DSQRT(A*A + B*B) . */
00065
00066 /* QUESTIONS AND COMMENTS SHOULD BE DIRECTED TO BURTON S. GARBOW, */
00067 /* MATHEMATICS AND COMPUTER SCIENCE DIV, ARGONNE NATIONAL LABORATORY
00068 */
00069
00070 /* THIS VERSION DATED AUGUST 1983. */
00071
00072 /* ------------------------------------------------------------------
00073 */
00074
00075 /* Parameter adjustments */
00076 --e;
00077 --d__;
00078
00079 /* Function Body */
00080 *ierr = 0;
00081 if (*n == 1) {
00082 goto L1001;
00083 }
00084
00085 i__1 = *n;
00086 for (i__ = 2; i__ <= i__1; ++i__) {
00087 /* L100: */
00088 e[i__ - 1] = e[i__];
00089 }
00090
00091 e[*n] = 0.;
00092
00093 i__1 = *n;
00094 for (l = 1; l <= i__1; ++l) {
00095 j = 0;
00096 /* .......... LOOK FOR SMALL SUB-DIAGONAL ELEMENT .......... */
00097 L105:
00098 i__2 = *n;
00099 for (m = l; m <= i__2; ++m) {
00100 if (m == *n) {
00101 goto L120;
00102 }
00103 tst1 = (d__1 = d__[m], abs(d__1)) + (d__2 = d__[m + 1], abs(d__2))
00104 ;
00105 tst2 = tst1 + (d__1 = e[m], abs(d__1));
00106 if (tst2 == tst1) {
00107 goto L120;
00108 }
00109 /* L110: */
00110 }
00111
00112 L120:
00113 p = d__[l];
00114 if (m == l) {
00115 goto L215;
00116 }
00117 if (j == 30) {
00118 goto L1000;
00119 }
00120 ++j;
00121 /* .......... FORM SHIFT .......... */
00122 g = (d__[l + 1] - p) / (e[l] * 2.);
00123 r__ = pythag_(&g, &c_b10);
00124 g = d__[m] - p + e[l] / (g + d_sign(&r__, &g));
00125 s = 1.;
00126 c__ = 1.;
00127 p = 0.;
00128 mml = m - l;
00129 /* .......... FOR I=M-1 STEP -1 UNTIL L DO -- .......... */
00130 i__2 = mml;
00131 for (ii = 1; ii <= i__2; ++ii) {
00132 i__ = m - ii;
00133 f = s * e[i__];
00134 b = c__ * e[i__];
00135 r__ = pythag_(&f, &g);
00136 e[i__ + 1] = r__;
00137 if (r__ == 0.) {
00138 goto L210;
00139 }
00140 s = f / r__;
00141 c__ = g / r__;
00142 g = d__[i__ + 1] - p;
00143 r__ = (d__[i__] - g) * s + c__ * 2. * b;
00144 p = s * r__;
00145 d__[i__ + 1] = g + p;
00146 g = c__ * r__ - b;
00147 /* L200: */
00148 }
00149
00150 d__[l] -= p;
00151 e[l] = g;
00152 e[m] = 0.;
00153 goto L105;
00154 /* .......... RECOVER FROM UNDERFLOW .......... */
00155 L210:
00156 d__[i__ + 1] -= p;
00157 e[m] = 0.;
00158 goto L105;
00159 /* .......... ORDER EIGENVALUES .......... */
00160 L215:
00161 if (l == 1) {
00162 goto L250;
00163 }
00164 /* .......... FOR I=L STEP -1 UNTIL 2 DO -- .......... */
00165 i__2 = l;
00166 for (ii = 2; ii <= i__2; ++ii) {
00167 i__ = l + 2 - ii;
00168 if (p >= d__[i__ - 1]) {
00169 goto L270;
00170 }
00171 d__[i__] = d__[i__ - 1];
00172 /* L230: */
00173 }
00174
00175 L250:
00176 i__ = 1;
00177 L270:
00178 d__[i__] = p;
00179 /* L290: */
00180 }
00181
00182 goto L1001;
00183 /* .......... SET ERROR -- NO CONVERGENCE TO AN */
00184 /* EIGENVALUE AFTER 30 ITERATIONS .......... */
00185 L1000:
00186 *ierr = l;
00187 L1001:
00188 return 0;
00189 } /* imtql1_ */
|
|
||||||||||||||||||||||||||||
|
Definition at line 12 of file eis_imtql2.c. References abs, c_b9, d_sign(), l, p, and pythag_(). Referenced by rst_(), and rt_().
00014 {
00015 /* System generated locals */
00016 integer z_dim1, z_offset, i__1, i__2, i__3;
00017 doublereal d__1, d__2;
00018
00019 /* Builtin functions */
00020 double d_sign(doublereal *, doublereal *);
00021
00022 /* Local variables */
00023 static doublereal b, c__, f, g;
00024 static integer i__, j, k, l, m;
00025 static doublereal p, r__, s;
00026 static integer ii;
00027 extern doublereal pythag_(doublereal *, doublereal *);
00028 static integer mml;
00029 static doublereal tst1, tst2;
00030
00031
00032
00033 /* THIS SUBROUTINE IS A TRANSLATION OF THE ALGOL PROCEDURE IMTQL2, */
00034 /* NUM. MATH. 12, 377-383(1968) BY MARTIN AND WILKINSON, */
00035 /* AS MODIFIED IN NUM. MATH. 15, 450(1970) BY DUBRULLE. */
00036 /* HANDBOOK FOR AUTO. COMP., VOL.II-LINEAR ALGEBRA, 241-248(1971). */
00037
00038 /* THIS SUBROUTINE FINDS THE EIGENVALUES AND EIGENVECTORS */
00039 /* OF A SYMMETRIC TRIDIAGONAL MATRIX BY THE IMPLICIT QL METHOD. */
00040 /* THE EIGENVECTORS OF A FULL SYMMETRIC MATRIX CAN ALSO */
00041 /* BE FOUND IF TRED2 HAS BEEN USED TO REDUCE THIS */
00042 /* FULL MATRIX TO TRIDIAGONAL FORM. */
00043
00044 /* ON INPUT */
00045
00046 /* NM MUST BE SET TO THE ROW DIMENSION OF TWO-DIMENSIONAL */
00047 /* ARRAY PARAMETERS AS DECLARED IN THE CALLING PROGRAM */
00048 /* DIMENSION STATEMENT. */
00049
00050 /* N IS THE ORDER OF THE MATRIX. */
00051
00052 /* D CONTAINS THE DIAGONAL ELEMENTS OF THE INPUT MATRIX. */
00053
00054 /* E CONTAINS THE SUBDIAGONAL ELEMENTS OF THE INPUT MATRIX */
00055 /* IN ITS LAST N-1 POSITIONS. E(1) IS ARBITRARY. */
00056
00057 /* Z CONTAINS THE TRANSFORMATION MATRIX PRODUCED IN THE */
00058 /* REDUCTION BY TRED2, IF PERFORMED. IF THE EIGENVECTORS */
00059 /* OF THE TRIDIAGONAL MATRIX ARE DESIRED, Z MUST CONTAIN */
00060 /* THE IDENTITY MATRIX. */
00061
00062 /* ON OUTPUT */
00063
00064 /* D CONTAINS THE EIGENVALUES IN ASCENDING ORDER. IF AN */
00065 /* ERROR EXIT IS MADE, THE EIGENVALUES ARE CORRECT BUT */
00066 /* UNORDERED FOR INDICES 1,2,...,IERR-1. */
00067
00068 /* E HAS BEEN DESTROYED. */
00069
00070 /* Z CONTAINS ORTHONORMAL EIGENVECTORS OF THE SYMMETRIC */
00071 /* TRIDIAGONAL (OR FULL) MATRIX. IF AN ERROR EXIT IS MADE, */
00072 /* Z CONTAINS THE EIGENVECTORS ASSOCIATED WITH THE STORED */
00073 /* EIGENVALUES. */
00074
00075 /* IERR IS SET TO */
00076 /* ZERO FOR NORMAL RETURN, */
00077 /* J IF THE J-TH EIGENVALUE HAS NOT BEEN */
00078 /* DETERMINED AFTER 30 ITERATIONS. */
00079
00080 /* CALLS PYTHAG FOR DSQRT(A*A + B*B) . */
00081
00082 /* QUESTIONS AND COMMENTS SHOULD BE DIRECTED TO BURTON S. GARBOW, */
00083 /* MATHEMATICS AND COMPUTER SCIENCE DIV, ARGONNE NATIONAL LABORATORY
00084 */
00085
00086 /* THIS VERSION DATED AUGUST 1983. */
00087
00088 /* ------------------------------------------------------------------
00089 */
00090
00091 /* Parameter adjustments */
00092 z_dim1 = *nm;
00093 z_offset = z_dim1 + 1;
00094 z__ -= z_offset;
00095 --e;
00096 --d__;
00097
00098 /* Function Body */
00099 *ierr = 0;
00100 if (*n == 1) {
00101 goto L1001;
00102 }
00103
00104 i__1 = *n;
00105 for (i__ = 2; i__ <= i__1; ++i__) {
00106 /* L100: */
00107 e[i__ - 1] = e[i__];
00108 }
00109
00110 e[*n] = 0.;
00111
00112 i__1 = *n;
00113 for (l = 1; l <= i__1; ++l) {
00114 j = 0;
00115 /* .......... LOOK FOR SMALL SUB-DIAGONAL ELEMENT .......... */
00116 L105:
00117 i__2 = *n;
00118 for (m = l; m <= i__2; ++m) {
00119 if (m == *n) {
00120 goto L120;
00121 }
00122 tst1 = (d__1 = d__[m], abs(d__1)) + (d__2 = d__[m + 1], abs(d__2))
00123 ;
00124 tst2 = tst1 + (d__1 = e[m], abs(d__1));
00125 if (tst2 == tst1) {
00126 goto L120;
00127 }
00128 /* L110: */
00129 }
00130
00131 L120:
00132 p = d__[l];
00133 if (m == l) {
00134 goto L240;
00135 }
00136 if (j == 30) {
00137 goto L1000;
00138 }
00139 ++j;
00140 /* .......... FORM SHIFT .......... */
00141 g = (d__[l + 1] - p) / (e[l] * 2.);
00142 r__ = pythag_(&g, &c_b9);
00143 g = d__[m] - p + e[l] / (g + d_sign(&r__, &g));
00144 s = 1.;
00145 c__ = 1.;
00146 p = 0.;
00147 mml = m - l;
00148 /* .......... FOR I=M-1 STEP -1 UNTIL L DO -- .......... */
00149 i__2 = mml;
00150 for (ii = 1; ii <= i__2; ++ii) {
00151 i__ = m - ii;
00152 f = s * e[i__];
00153 b = c__ * e[i__];
00154 r__ = pythag_(&f, &g);
00155 e[i__ + 1] = r__;
00156 if (r__ == 0.) {
00157 goto L210;
00158 }
00159 s = f / r__;
00160 c__ = g / r__;
00161 g = d__[i__ + 1] - p;
00162 r__ = (d__[i__] - g) * s + c__ * 2. * b;
00163 p = s * r__;
00164 d__[i__ + 1] = g + p;
00165 g = c__ * r__ - b;
00166 /* .......... FORM VECTOR .......... */
00167 i__3 = *n;
00168 for (k = 1; k <= i__3; ++k) {
00169 f = z__[k + (i__ + 1) * z_dim1];
00170 z__[k + (i__ + 1) * z_dim1] = s * z__[k + i__ * z_dim1] + c__
00171 * f;
00172 z__[k + i__ * z_dim1] = c__ * z__[k + i__ * z_dim1] - s * f;
00173 /* L180: */
00174 }
00175
00176 /* L200: */
00177 }
00178
00179 d__[l] -= p;
00180 e[l] = g;
00181 e[m] = 0.;
00182 goto L105;
00183 /* .......... RECOVER FROM UNDERFLOW .......... */
00184 L210:
00185 d__[i__ + 1] -= p;
00186 e[m] = 0.;
00187 goto L105;
00188 L240:
00189 ;
00190 }
00191 /* .......... ORDER EIGENVALUES AND EIGENVECTORS .......... */
00192 i__1 = *n;
00193 for (ii = 2; ii <= i__1; ++ii) {
00194 i__ = ii - 1;
00195 k = i__;
00196 p = d__[i__];
00197
00198 i__2 = *n;
00199 for (j = ii; j <= i__2; ++j) {
00200 if (d__[j] >= p) {
00201 goto L260;
00202 }
00203 k = j;
00204 p = d__[j];
00205 L260:
00206 ;
00207 }
00208
00209 if (k == i__) {
00210 goto L300;
00211 }
00212 d__[k] = d__[i__];
00213 d__[i__] = p;
00214
00215 i__2 = *n;
00216 for (j = 1; j <= i__2; ++j) {
00217 p = z__[j + i__ * z_dim1];
00218 z__[j + i__ * z_dim1] = z__[j + k * z_dim1];
00219 z__[j + k * z_dim1] = p;
00220 /* L280: */
00221 }
00222
00223 L300:
00224 ;
00225 }
00226
00227 goto L1001;
00228 /* .......... SET ERROR -- NO CONVERGENCE TO AN */
00229 /* EIGENVALUE AFTER 30 ITERATIONS .......... */
00230 L1000:
00231 *ierr = l;
00232 L1001:
00233 return 0;
00234 } /* imtql2_ */
|
|
||||||||||||||||||||||||||||||||||||
|
Definition at line 12 of file eis_imtqlv.c. References abs, c_b11, d_sign(), ind, l, p, and pythag_(). Referenced by rsm_().
00015 {
00016 /* System generated locals */
00017 integer i__1, i__2;
00018 doublereal d__1, d__2;
00019
00020 /* Builtin functions */
00021 double d_sign(doublereal *, doublereal *);
00022
00023 /* Local variables */
00024 static doublereal b, c__, f, g;
00025 static integer i__, j, k, l, m;
00026 static doublereal p, r__, s;
00027 static integer ii;
00028 extern doublereal pythag_(doublereal *, doublereal *);
00029 static integer tag, mml;
00030 static doublereal tst1, tst2;
00031
00032
00033
00034 /* THIS SUBROUTINE IS A VARIANT OF IMTQL1 WHICH IS A TRANSLATION OF
00035 */
00036 /* ALGOL PROCEDURE IMTQL1, NUM. MATH. 12, 377-383(1968) BY MARTIN AND
00037 */
00038 /* WILKINSON, AS MODIFIED IN NUM. MATH. 15, 450(1970) BY DUBRULLE. */
00039 /* HANDBOOK FOR AUTO. COMP., VOL.II-LINEAR ALGEBRA, 241-248(1971). */
00040
00041 /* THIS SUBROUTINE FINDS THE EIGENVALUES OF A SYMMETRIC TRIDIAGONAL */
00042 /* MATRIX BY THE IMPLICIT QL METHOD AND ASSOCIATES WITH THEM */
00043 /* THEIR CORRESPONDING SUBMATRIX INDICES. */
00044
00045 /* ON INPUT */
00046
00047 /* N IS THE ORDER OF THE MATRIX. */
00048
00049 /* D CONTAINS THE DIAGONAL ELEMENTS OF THE INPUT MATRIX. */
00050
00051 /* E CONTAINS THE SUBDIAGONAL ELEMENTS OF THE INPUT MATRIX */
00052 /* IN ITS LAST N-1 POSITIONS. E(1) IS ARBITRARY. */
00053
00054 /* E2 CONTAINS THE SQUARES OF THE CORRESPONDING ELEMENTS OF E. */
00055 /* E2(1) IS ARBITRARY. */
00056
00057 /* ON OUTPUT */
00058
00059 /* D AND E ARE UNALTERED. */
00060
00061 /* ELEMENTS OF E2, CORRESPONDING TO ELEMENTS OF E REGARDED */
00062 /* AS NEGLIGIBLE, HAVE BEEN REPLACED BY ZERO CAUSING THE */
00063 /* MATRIX TO SPLIT INTO A DIRECT SUM OF SUBMATRICES. */
00064 /* E2(1) IS ALSO SET TO ZERO. */
00065
00066 /* W CONTAINS THE EIGENVALUES IN ASCENDING ORDER. IF AN */
00067 /* ERROR EXIT IS MADE, THE EIGENVALUES ARE CORRECT AND */
00068 /* ORDERED FOR INDICES 1,2,...IERR-1, BUT MAY NOT BE */
00069 /* THE SMALLEST EIGENVALUES. */
00070
00071 /* IND CONTAINS THE SUBMATRIX INDICES ASSOCIATED WITH THE */
00072 /* CORRESPONDING EIGENVALUES IN W -- 1 FOR EIGENVALUES */
00073 /* BELONGING TO THE FIRST SUBMATRIX FROM THE TOP, */
00074 /* 2 FOR THOSE BELONGING TO THE SECOND SUBMATRIX, ETC.. */
00075
00076 /* IERR IS SET TO */
00077 /* ZERO FOR NORMAL RETURN, */
00078 /* J IF THE J-TH EIGENVALUE HAS NOT BEEN */
00079 /* DETERMINED AFTER 30 ITERATIONS. */
00080
00081 /* RV1 IS A TEMPORARY STORAGE ARRAY. */
00082
00083 /* CALLS PYTHAG FOR DSQRT(A*A + B*B) . */
00084
00085 /* QUESTIONS AND COMMENTS SHOULD BE DIRECTED TO BURTON S. GARBOW, */
00086 /* MATHEMATICS AND COMPUTER SCIENCE DIV, ARGONNE NATIONAL LABORATORY
00087 */
00088
00089 /* THIS VERSION DATED AUGUST 1983. */
00090
00091 /* ------------------------------------------------------------------
00092 */
00093
00094 /* Parameter adjustments */
00095 --rv1;
00096 --ind;
00097 --w;
00098 --e2;
00099 --e;
00100 --d__;
00101
00102 /* Function Body */
00103 *ierr = 0;
00104 k = 0;
00105 tag = 0;
00106
00107 i__1 = *n;
00108 for (i__ = 1; i__ <= i__1; ++i__) {
00109 w[i__] = d__[i__];
00110 if (i__ != 1) {
00111 rv1[i__ - 1] = e[i__];
00112 }
00113 /* L100: */
00114 }
00115
00116 e2[1] = 0.;
00117 rv1[*n] = 0.;
00118
00119 i__1 = *n;
00120 for (l = 1; l <= i__1; ++l) {
00121 j = 0;
00122 /* .......... LOOK FOR SMALL SUB-DIAGONAL ELEMENT .......... */
00123 L105:
00124 i__2 = *n;
00125 for (m = l; m <= i__2; ++m) {
00126 if (m == *n) {
00127 goto L120;
00128 }
00129 tst1 = (d__1 = w[m], abs(d__1)) + (d__2 = w[m + 1], abs(d__2));
00130 tst2 = tst1 + (d__1 = rv1[m], abs(d__1));
00131 if (tst2 == tst1) {
00132 goto L120;
00133 }
00134 /* .......... GUARD AGAINST UNDERFLOWED ELEMENT OF E2 ........
00135 .. */
00136 if (e2[m + 1] == 0.) {
00137 goto L125;
00138 }
00139 /* L110: */
00140 }
00141
00142 L120:
00143 if (m <= k) {
00144 goto L130;
00145 }
00146 if (m != *n) {
00147 e2[m + 1] = 0.;
00148 }
00149 L125:
00150 k = m;
00151 ++tag;
00152 L130:
00153 p = w[l];
00154 if (m == l) {
00155 goto L215;
00156 }
00157 if (j == 30) {
00158 goto L1000;
00159 }
00160 ++j;
00161 /* .......... FORM SHIFT .......... */
00162 g = (w[l + 1] - p) / (rv1[l] * 2.);
00163 r__ = pythag_(&g, &c_b11);
00164 g = w[m] - p + rv1[l] / (g + d_sign(&r__, &g));
00165 s = 1.;
00166 c__ = 1.;
00167 p = 0.;
00168 mml = m - l;
00169 /* .......... FOR I=M-1 STEP -1 UNTIL L DO -- .......... */
00170 i__2 = mml;
00171 for (ii = 1; ii <= i__2; ++ii) {
00172 i__ = m - ii;
00173 f = s * rv1[i__];
00174 b = c__ * rv1[i__];
00175 r__ = pythag_(&f, &g);
00176 rv1[i__ + 1] = r__;
00177 if (r__ == 0.) {
00178 goto L210;
00179 }
00180 s = f / r__;
00181 c__ = g / r__;
00182 g = w[i__ + 1] - p;
00183 r__ = (w[i__] - g) * s + c__ * 2. * b;
00184 p = s * r__;
00185 w[i__ + 1] = g + p;
00186 g = c__ * r__ - b;
00187 /* L200: */
00188 }
00189
00190 w[l] -= p;
00191 rv1[l] = g;
00192 rv1[m] = 0.;
00193 goto L105;
00194 /* .......... RECOVER FROM UNDERFLOW .......... */
00195 L210:
00196 w[i__ + 1] -= p;
00197 rv1[m] = 0.;
00198 goto L105;
00199 /* .......... ORDER EIGENVALUES .......... */
00200 L215:
00201 if (l == 1) {
00202 goto L250;
00203 }
00204 /* .......... FOR I=L STEP -1 UNTIL 2 DO -- .......... */
00205 i__2 = l;
00206 for (ii = 2; ii <= i__2; ++ii) {
00207 i__ = l + 2 - ii;
00208 if (p >= w[i__ - 1]) {
00209 goto L270;
00210 }
00211 w[i__] = w[i__ - 1];
00212 ind[i__] = ind[i__ - 1];
00213 /* L230: */
00214 }
00215
00216 L250:
00217 i__ = 1;
00218 L270:
00219 w[i__] = p;
00220 ind[i__] = tag;
00221 /* L290: */
00222 }
00223
00224 goto L1001;
00225 /* .......... SET ERROR -- NO CONVERGENCE TO AN */
00226 /* EIGENVALUE AFTER 30 ITERATIONS .......... */
00227 L1000:
00228 *ierr = l;
00229 L1001:
00230 return 0;
00231 } /* imtqlv_ */
|
|
||||||||||||||||||||||||||||||||||||||||||||||||||||||||
|
Definition at line 8 of file eis_invit.c. References a, abs, cdiv_(), epslon_(), l, mp, n1, and pythag_().
00012 {
00013 /* System generated locals */
00014 integer a_dim1, a_offset, z_dim1, z_offset, rm1_dim1, rm1_offset, i__1,
00015 i__2, i__3;
00016 doublereal d__1, d__2;
00017
00018 /* Builtin functions */
00019 double sqrt(doublereal);
00020
00021 /* Local variables */
00022 extern /* Subroutine */ int cdiv_(doublereal *, doublereal *, doublereal *
00023 , doublereal *, doublereal *, doublereal *);
00024 static doublereal norm;
00025 static integer i__, j, k, l, s;
00026 static doublereal t, w, x, y;
00027 static integer n1;
00028 static doublereal normv;
00029 static integer ii;
00030 static doublereal ilambd;
00031 static integer ip, mp, ns, uk;
00032 static doublereal rlambd;
00033 extern doublereal pythag_(doublereal *, doublereal *), epslon_(doublereal
00034 *);
00035 static integer km1, ip1;
00036 static doublereal growto, ukroot;
00037 static integer its;
00038 static doublereal eps3;
00039
00040
00041
00042 /* THIS SUBROUTINE IS A TRANSLATION OF THE ALGOL PROCEDURE INVIT */
00043 /* BY PETERS AND WILKINSON. */
00044 /* HANDBOOK FOR AUTO. COMP., VOL.II-LINEAR ALGEBRA, 418-439(1971). */
00045
00046 /* THIS SUBROUTINE FINDS THOSE EIGENVECTORS OF A REAL UPPER */
00047 /* HESSENBERG MATRIX CORRESPONDING TO SPECIFIED EIGENVALUES, */
00048 /* USING INVERSE ITERATION. */
00049
00050 /* ON INPUT */
00051
00052 /* NM MUST BE SET TO THE ROW DIMENSION OF TWO-DIMENSIONAL */
00053 /* ARRAY PARAMETERS AS DECLARED IN THE CALLING PROGRAM */
00054 /* DIMENSION STATEMENT. */
00055
00056 /* N IS THE ORDER OF THE MATRIX. */
00057
00058 /* A CONTAINS THE HESSENBERG MATRIX. */
00059
00060 /* WR AND WI CONTAIN THE REAL AND IMAGINARY PARTS, RESPECTIVELY, */
00061 /* OF THE EIGENVALUES OF THE MATRIX. THE EIGENVALUES MUST BE */
00062 /* STORED IN A MANNER IDENTICAL TO THAT OF SUBROUTINE HQR, */
00063 /* WHICH RECOGNIZES POSSIBLE SPLITTING OF THE MATRIX. */
00064
00065 /* SELECT SPECIFIES THE EIGENVECTORS TO BE FOUND. THE */
00066 /* EIGENVECTOR CORRESPONDING TO THE J-TH EIGENVALUE IS */
00067 /* SPECIFIED BY SETTING SELECT(J) TO .TRUE.. */
00068
00069 /* MM SHOULD BE SET TO AN UPPER BOUND FOR THE NUMBER OF */
00070 /* COLUMNS REQUIRED TO STORE THE EIGENVECTORS TO BE FOUND. */
00071 /* NOTE THAT TWO COLUMNS ARE REQUIRED TO STORE THE */
00072 /* EIGENVECTOR CORRESPONDING TO A COMPLEX EIGENVALUE. */
00073
00074 /* ON OUTPUT */
00075
00076 /* A AND WI ARE UNALTERED. */
00077
00078 /* WR MAY HAVE BEEN ALTERED SINCE CLOSE EIGENVALUES ARE PERTURBED
00079 */
00080 /* SLIGHTLY IN SEARCHING FOR INDEPENDENT EIGENVECTORS. */
00081
00082 /* SELECT MAY HAVE BEEN ALTERED. IF THE ELEMENTS CORRESPONDING */
00083 /* TO A PAIR OF CONJUGATE COMPLEX EIGENVALUES WERE EACH */
00084 /* INITIALLY SET TO .TRUE., THE PROGRAM RESETS THE SECOND OF */
00085 /* THE TWO ELEMENTS TO .FALSE.. */
00086
00087 /* M IS THE NUMBER OF COLUMNS ACTUALLY USED TO STORE */
00088 /* THE EIGENVECTORS. */
00089
00090 /* Z CONTAINS THE REAL AND IMAGINARY PARTS OF THE EIGENVECTORS. */
00091 /* IF THE NEXT SELECTED EIGENVALUE IS REAL, THE NEXT COLUMN */
00092 /* OF Z CONTAINS ITS EIGENVECTOR. IF THE EIGENVALUE IS */
00093 /* COMPLEX, THE NEXT TWO COLUMNS OF Z CONTAIN THE REAL AND */
00094 /* IMAGINARY PARTS OF ITS EIGENVECTOR. THE EIGENVECTORS ARE */
00095 /* NORMALIZED SO THAT THE COMPONENT OF LARGEST MAGNITUDE IS 1. */
00096 /* ANY VECTOR WHICH FAILS THE ACCEPTANCE TEST IS SET TO ZERO. */
00097
00098 /* IERR IS SET TO */
00099 /* ZERO FOR NORMAL RETURN, */
00100 /* -(2*N+1) IF MORE THAN MM COLUMNS OF Z ARE NECESSARY */
00101 /* TO STORE THE EIGENVECTORS CORRESPONDING TO */
00102 /* THE SPECIFIED EIGENVALUES. */
00103 /* -K IF THE ITERATION CORRESPONDING TO THE K-TH */
00104 /* VALUE FAILS, */
00105 /* -(N+K) IF BOTH ERROR SITUATIONS OCCUR. */
00106
00107 /* RM1, RV1, AND RV2 ARE TEMPORARY STORAGE ARRAYS. NOTE THAT RM1
00108 */
00109 /* IS SQUARE OF DIMENSION N BY N AND, AUGMENTED BY TWO COLUMNS */
00110 /* OF Z, IS THE TRANSPOSE OF THE CORRESPONDING ALGOL B ARRAY. */
00111
00112 /* THE ALGOL PROCEDURE GUESSVEC APPEARS IN INVIT IN LINE. */
00113
00114 /* CALLS CDIV FOR COMPLEX DIVISION. */
00115 /* CALLS PYTHAG FOR DSQRT(A*A + B*B) . */
00116
00117 /* QUESTIONS AND COMMENTS SHOULD BE DIRECTED TO BURTON S. GARBOW, */
00118 /* MATHEMATICS AND COMPUTER SCIENCE DIV, ARGONNE NATIONAL LABORATORY
00119 */
00120
00121 /* THIS VERSION DATED AUGUST 1983. */
00122
00123 /* ------------------------------------------------------------------
00124 */
00125
00126 /* Parameter adjustments */
00127 --rv2;
00128 --rv1;
00129 rm1_dim1 = *n;
00130 rm1_offset = rm1_dim1 + 1;
00131 rm1 -= rm1_offset;
00132 --select;
00133 --wi;
00134 --wr;
00135 a_dim1 = *nm;
00136 a_offset = a_dim1 + 1;
00137 a -= a_offset;
00138 z_dim1 = *nm;
00139 z_offset = z_dim1 + 1;
00140 z__ -= z_offset;
00141
00142 /* Function Body */
00143 *ierr = 0;
00144 uk = 0;
00145 s = 1;
00146 /* .......... IP = 0, REAL EIGENVALUE */
00147 /* 1, FIRST OF CONJUGATE COMPLEX PAIR */
00148 /* -1, SECOND OF CONJUGATE COMPLEX PAIR .......... */
00149 ip = 0;
00150 n1 = *n - 1;
00151
00152 i__1 = *n;
00153 for (k = 1; k <= i__1; ++k) {
00154 if (wi[k] == 0. || ip < 0) {
00155 goto L100;
00156 }
00157 ip = 1;
00158 if (select[k] && select[k + 1]) {
00159 select[k + 1] = FALSE_;
00160 }
00161 L100:
00162 if (! select[k]) {
00163 goto L960;
00164 }
00165 if (wi[k] != 0.) {
00166 ++s;
00167 }
00168 if (s > *mm) {
00169 goto L1000;
00170 }
00171 if (uk >= k) {
00172 goto L200;
00173 }
00174 /* .......... CHECK FOR POSSIBLE SPLITTING .......... */
00175 i__2 = *n;
00176 for (uk = k; uk <= i__2; ++uk) {
00177 if (uk == *n) {
00178 goto L140;
00179 }
00180 if (a[uk + 1 + uk * a_dim1] == 0.) {
00181 goto L140;
00182 }
00183 /* L120: */
00184 }
00185 /* .......... COMPUTE INFINITY NORM OF LEADING UK BY UK */
00186 /* (HESSENBERG) MATRIX .......... */
00187 L140:
00188 norm = 0.;
00189 mp = 1;
00190
00191 i__2 = uk;
00192 for (i__ = 1; i__ <= i__2; ++i__) {
00193 x = 0.;
00194
00195 i__3 = uk;
00196 for (j = mp; j <= i__3; ++j) {
00197 /* L160: */
00198 x += (d__1 = a[i__ + j * a_dim1], abs(d__1));
00199 }
00200
00201 if (x > norm) {
00202 norm = x;
00203 }
00204 mp = i__;
00205 /* L180: */
00206 }
00207 /* .......... EPS3 REPLACES ZERO PIVOT IN DECOMPOSITION */
00208 /* AND CLOSE ROOTS ARE MODIFIED BY EPS3 .......... */
00209 if (norm == 0.) {
00210 norm = 1.;
00211 }
00212 eps3 = epslon_(&norm);
00213 /* .......... GROWTO IS THE CRITERION FOR THE GROWTH .......... */
00214 ukroot = (doublereal) uk;
00215 ukroot = sqrt(ukroot);
00216 growto = .1 / ukroot;
00217 L200:
00218 rlambd = wr[k];
00219 ilambd = wi[k];
00220 if (k == 1) {
00221 goto L280;
00222 }
00223 km1 = k - 1;
00224 goto L240;
00225 /* .......... PERTURB EIGENVALUE IF IT IS CLOSE */
00226 /* TO ANY PREVIOUS EIGENVALUE .......... */
00227 L220:
00228 rlambd += eps3;
00229 /* .......... FOR I=K-1 STEP -1 UNTIL 1 DO -- .......... */
00230 L240:
00231 i__2 = km1;
00232 for (ii = 1; ii <= i__2; ++ii) {
00233 i__ = k - ii;
00234 if (select[i__] && (d__1 = wr[i__] - rlambd, abs(d__1)) < eps3 &&
00235 (d__2 = wi[i__] - ilambd, abs(d__2)) < eps3) {
00236 goto L220;
00237 }
00238 /* L260: */
00239 }
00240
00241 wr[k] = rlambd;
00242 /* .......... PERTURB CONJUGATE EIGENVALUE TO MATCH .......... */
00243 ip1 = k + ip;
00244 wr[ip1] = rlambd;
00245 /* .......... FORM UPPER HESSENBERG A-RLAMBD*I (TRANSPOSED) */
00246 /* AND INITIAL REAL VECTOR .......... */
00247 L280:
00248 mp = 1;
00249
00250 i__2 = uk;
00251 for (i__ = 1; i__ <= i__2; ++i__) {
00252
00253 i__3 = uk;
00254 for (j = mp; j <= i__3; ++j) {
00255 /* L300: */
00256 rm1[j + i__ * rm1_dim1] = a[i__ + j * a_dim1];
00257 }
00258
00259 rm1[i__ + i__ * rm1_dim1] -= rlambd;
00260 mp = i__;
00261 rv1[i__] = eps3;
00262 /* L320: */
00263 }
00264
00265 its = 0;
00266 if (ilambd != 0.) {
00267 goto L520;
00268 }
00269 /* .......... REAL EIGENVALUE. */
00270 /* TRIANGULAR DECOMPOSITION WITH INTERCHANGES, */
00271 /* REPLACING ZERO PIVOTS BY EPS3 .......... */
00272 if (uk == 1) {
00273 goto L420;
00274 }
00275
00276 i__2 = uk;
00277 for (i__ = 2; i__ <= i__2; ++i__) {
00278 mp = i__ - 1;
00279 if ((d__1 = rm1[mp + i__ * rm1_dim1], abs(d__1)) <= (d__2 = rm1[
00280 mp + mp * rm1_dim1], abs(d__2))) {
00281 goto L360;
00282 }
00283
00284 i__3 = uk;
00285 for (j = mp; j <= i__3; ++j) {
00286 y = rm1[j + i__ * rm1_dim1];
00287 rm1[j + i__ * rm1_dim1] = rm1[j + mp * rm1_dim1];
00288 rm1[j + mp * rm1_dim1] = y;
00289 /* L340: */
00290 }
00291
00292 L360:
00293 if (rm1[mp + mp * rm1_dim1] == 0.) {
00294 rm1[mp + mp * rm1_dim1] = eps3;
00295 }
00296 x = rm1[mp + i__ * rm1_dim1] / rm1[mp + mp * rm1_dim1];
00297 if (x == 0.) {
00298 goto L400;
00299 }
00300
00301 i__3 = uk;
00302 for (j = i__; j <= i__3; ++j) {
00303 /* L380: */
00304 rm1[j + i__ * rm1_dim1] -= x * rm1[j + mp * rm1_dim1];
00305 }
00306
00307 L400:
00308 ;
00309 }
00310
00311 L420:
00312 if (rm1[uk + uk * rm1_dim1] == 0.) {
00313 rm1[uk + uk * rm1_dim1] = eps3;
00314 }
00315 /* .......... BACK SUBSTITUTION FOR REAL VECTOR */
00316 /* FOR I=UK STEP -1 UNTIL 1 DO -- .......... */
00317 L440:
00318 i__2 = uk;
00319 for (ii = 1; ii <= i__2; ++ii) {
00320 i__ = uk + 1 - ii;
00321 y = rv1[i__];
00322 if (i__ == uk) {
00323 goto L480;
00324 }
00325 ip1 = i__ + 1;
00326
00327 i__3 = uk;
00328 for (j = ip1; j <= i__3; ++j) {
00329 /* L460: */
00330 y -= rm1[j + i__ * rm1_dim1] * rv1[j];
00331 }
00332
00333 L480:
00334 rv1[i__] = y / rm1[i__ + i__ * rm1_dim1];
00335 /* L500: */
00336 }
00337
00338 goto L740;
00339 /* .......... COMPLEX EIGENVALUE. */
00340 /* TRIANGULAR DECOMPOSITION WITH INTERCHANGES, */
00341 /* REPLACING ZERO PIVOTS BY EPS3. STORE IMAGINARY */
00342 /* PARTS IN UPPER TRIANGLE STARTING AT (1,3) ..........
00343 */
00344 L520:
00345 ns = *n - s;
00346 z__[(s - 1) * z_dim1 + 1] = -ilambd;
00347 z__[s * z_dim1 + 1] = 0.;
00348 if (*n == 2) {
00349 goto L550;
00350 }
00351 rm1[rm1_dim1 * 3 + 1] = -ilambd;
00352 z__[(s - 1) * z_dim1 + 1] = 0.;
00353 if (*n == 3) {
00354 goto L550;
00355 }
00356
00357 i__2 = *n;
00358 for (i__ = 4; i__ <= i__2; ++i__) {
00359 /* L540: */
00360 rm1[i__ * rm1_dim1 + 1] = 0.;
00361 }
00362
00363 L550:
00364 i__2 = uk;
00365 for (i__ = 2; i__ <= i__2; ++i__) {
00366 mp = i__ - 1;
00367 w = rm1[mp + i__ * rm1_dim1];
00368 if (i__ < *n) {
00369 t = rm1[mp + (i__ + 1) * rm1_dim1];
00370 }
00371 if (i__ == *n) {
00372 t = z__[mp + (s - 1) * z_dim1];
00373 }
00374 x = rm1[mp + mp * rm1_dim1] * rm1[mp + mp * rm1_dim1] + t * t;
00375 if (w * w <= x) {
00376 goto L580;
00377 }
00378 x = rm1[mp + mp * rm1_dim1] / w;
00379 y = t / w;
00380 rm1[mp + mp * rm1_dim1] = w;
00381 if (i__ < *n) {
00382 rm1[mp + (i__ + 1) * rm1_dim1] = 0.;
00383 }
00384 if (i__ == *n) {
00385 z__[mp + (s - 1) * z_dim1] = 0.;
00386 }
00387
00388 i__3 = uk;
00389 for (j = i__; j <= i__3; ++j) {
00390 w = rm1[j + i__ * rm1_dim1];
00391 rm1[j + i__ * rm1_dim1] = rm1[j + mp * rm1_dim1] - x * w;
00392 rm1[j + mp * rm1_dim1] = w;
00393 if (j < n1) {
00394 goto L555;
00395 }
00396 l = j - ns;
00397 z__[i__ + l * z_dim1] = z__[mp + l * z_dim1] - y * w;
00398 z__[mp + l * z_dim1] = 0.;
00399 goto L560;
00400 L555:
00401 rm1[i__ + (j + 2) * rm1_dim1] = rm1[mp + (j + 2) * rm1_dim1]
00402 - y * w;
00403 rm1[mp + (j + 2) * rm1_dim1] = 0.;
00404 L560:
00405 ;
00406 }
00407
00408 rm1[i__ + i__ * rm1_dim1] -= y * ilambd;
00409 if (i__ < n1) {
00410 goto L570;
00411 }
00412 l = i__ - ns;
00413 z__[mp + l * z_dim1] = -ilambd;
00414 z__[i__ + l * z_dim1] += x * ilambd;
00415 goto L640;
00416 L570:
00417 rm1[mp + (i__ + 2) * rm1_dim1] = -ilambd;
00418 rm1[i__ + (i__ + 2) * rm1_dim1] += x * ilambd;
00419 goto L640;
00420 L580:
00421 if (x != 0.) {
00422 goto L600;
00423 }
00424 rm1[mp + mp * rm1_dim1] = eps3;
00425 if (i__ < *n) {
00426 rm1[mp + (i__ + 1) * rm1_dim1] = 0.;
00427 }
00428 if (i__ == *n) {
00429 z__[mp + (s - 1) * z_dim1] = 0.;
00430 }
00431 t = 0.;
00432 x = eps3 * eps3;
00433 L600:
00434 w /= x;
00435 x = rm1[mp + mp * rm1_dim1] * w;
00436 y = -t * w;
00437
00438 i__3 = uk;
00439 for (j = i__; j <= i__3; ++j) {
00440 if (j < n1) {
00441 goto L610;
00442 }
00443 l = j - ns;
00444 t = z__[mp + l * z_dim1];
00445 z__[i__ + l * z_dim1] = -x * t - y * rm1[j + mp * rm1_dim1];
00446 goto L615;
00447 L610:
00448 t = rm1[mp + (j + 2) * rm1_dim1];
00449 rm1[i__ + (j + 2) * rm1_dim1] = -x * t - y * rm1[j + mp *
00450 rm1_dim1];
00451 L615:
00452 rm1[j + i__ * rm1_dim1] = rm1[j + i__ * rm1_dim1] - x * rm1[j
00453 + mp * rm1_dim1] + y * t;
00454 /* L620: */
00455 }
00456
00457 if (i__ < n1) {
00458 goto L630;
00459 }
00460 l = i__ - ns;
00461 z__[i__ + l * z_dim1] -= ilambd;
00462 goto L640;
00463 L630:
00464 rm1[i__ + (i__ + 2) * rm1_dim1] -= ilambd;
00465 L640:
00466 ;
00467 }
00468
00469 if (uk < n1) {
00470 goto L650;
00471 }
00472 l = uk - ns;
00473 t = z__[uk + l * z_dim1];
00474 goto L655;
00475 L650:
00476 t = rm1[uk + (uk + 2) * rm1_dim1];
00477 L655:
00478 if (rm1[uk + uk * rm1_dim1] == 0. && t == 0.) {
00479 rm1[uk + uk * rm1_dim1] = eps3;
00480 }
00481 /* .......... BACK SUBSTITUTION FOR COMPLEX VECTOR */
00482 /* FOR I=UK STEP -1 UNTIL 1 DO -- .......... */
00483 L660:
00484 i__2 = uk;
00485 for (ii = 1; ii <= i__2; ++ii) {
00486 i__ = uk + 1 - ii;
00487 x = rv1[i__];
00488 y = 0.;
00489 if (i__ == uk) {
00490 goto L700;
00491 }
00492 ip1 = i__ + 1;
00493
00494 i__3 = uk;
00495 for (j = ip1; j <= i__3; ++j) {
00496 if (j < n1) {
00497 goto L670;
00498 }
00499 l = j - ns;
00500 t = z__[i__ + l * z_dim1];
00501 goto L675;
00502 L670:
00503 t = rm1[i__ + (j + 2) * rm1_dim1];
00504 L675:
00505 x = x - rm1[j + i__ * rm1_dim1] * rv1[j] + t * rv2[j];
00506 y = y - rm1[j + i__ * rm1_dim1] * rv2[j] - t * rv1[j];
00507 /* L680: */
00508 }
00509
00510 L700:
00511 if (i__ < n1) {
00512 goto L710;
00513 }
00514 l = i__ - ns;
00515 t = z__[i__ + l * z_dim1];
00516 goto L715;
00517 L710:
00518 t = rm1[i__ + (i__ + 2) * rm1_dim1];
00519 L715:
00520 cdiv_(&x, &y, &rm1[i__ + i__ * rm1_dim1], &t, &rv1[i__], &rv2[i__]
00521 );
00522 /* L720: */
00523 }
00524 /* .......... ACCEPTANCE TEST FOR REAL OR COMPLEX */
00525 /* EIGENVECTOR AND NORMALIZATION .......... */
00526 L740:
00527 ++its;
00528 norm = 0.;
00529 normv = 0.;
00530
00531 i__2 = uk;
00532 for (i__ = 1; i__ <= i__2; ++i__) {
00533 if (ilambd == 0.) {
00534 x = (d__1 = rv1[i__], abs(d__1));
00535 }
00536 if (ilambd != 0.) {
00537 x = pythag_(&rv1[i__], &rv2[i__]);
00538 }
00539 if (normv >= x) {
00540 goto L760;
00541 }
00542 normv = x;
00543 j = i__;
00544 L760:
00545 norm += x;
00546 /* L780: */
00547 }
00548
00549 if (norm < growto) {
00550 goto L840;
00551 }
00552 /* .......... ACCEPT VECTOR .......... */
00553 x = rv1[j];
00554 if (ilambd == 0.) {
00555 x = 1. / x;
00556 }
00557 if (ilambd != 0.) {
00558 y = rv2[j];
00559 }
00560
00561 i__2 = uk;
00562 for (i__ = 1; i__ <= i__2; ++i__) {
00563 if (ilambd != 0.) {
00564 goto L800;
00565 }
00566 z__[i__ + s * z_dim1] = rv1[i__] * x;
00567 goto L820;
00568 L800:
00569 cdiv_(&rv1[i__], &rv2[i__], &x, &y, &z__[i__ + (s - 1) * z_dim1],
00570 &z__[i__ + s * z_dim1]);
00571 L820:
00572 ;
00573 }
00574
00575 if (uk == *n) {
00576 goto L940;
00577 }
00578 j = uk + 1;
00579 goto L900;
00580 /* .......... IN-LINE PROCEDURE FOR CHOOSING */
00581 /* A NEW STARTING VECTOR .......... */
00582 L840:
00583 if (its >= uk) {
00584 goto L880;
00585 }
00586 x = ukroot;
00587 y = eps3 / (x + 1.);
00588 rv1[1] = eps3;
00589
00590 i__2 = uk;
00591 for (i__ = 2; i__ <= i__2; ++i__) {
00592 /* L860: */
00593 rv1[i__] = y;
00594 }
00595
00596 j = uk - its + 1;
00597 rv1[j] -= eps3 * x;
00598 if (ilambd == 0.) {
00599 goto L440;
00600 }
00601 goto L660;
00602 /* .......... SET ERROR -- UNACCEPTED EIGENVECTOR .......... */
00603 L880:
00604 j = 1;
00605 *ierr = -k;
00606 /* .......... SET REMAINING VECTOR COMPONENTS TO ZERO ..........
00607 */
00608 L900:
00609 i__2 = *n;
00610 for (i__ = j; i__ <= i__2; ++i__) {
00611 z__[i__ + s * z_dim1] = 0.;
00612 if (ilambd != 0.) {
00613 z__[i__ + (s - 1) * z_dim1] = 0.;
00614 }
00615 /* L920: */
00616 }
00617
00618 L940:
00619 ++s;
00620 L960:
00621 if (ip == -1) {
00622 ip = 0;
00623 }
00624 if (ip == 1) {
00625 ip = -1;
00626 }
00627 /* L980: */
00628 }
00629
00630 goto L1001;
00631 /* .......... SET ERROR -- UNDERESTIMATE OF EIGENVECTOR */
00632 /* SPACE REQUIRED .......... */
00633 L1000:
00634 if (*ierr != 0) {
00635 *ierr -= *n;
00636 }
00637 if (*ierr == 0) {
00638 *ierr = -((*n << 1) + 1);
00639 }
00640 L1001:
00641 *m = s - 1 - abs(ip);
00642 return 0;
00643 } /* invit_ */
|
|
||||||||||||||||||||||||||||||||||||||||
|
Definition at line 12 of file eis_minfit.c. References a, abs, c_b39, d_sign(), i1, l, m1, max, pythag_(), and scale.
00015 {
00016 /* System generated locals */
00017 integer a_dim1, a_offset, b_dim1, b_offset, i__1, i__2, i__3;
00018 doublereal d__1, d__2, d__3, d__4;
00019
00020 /* Builtin functions */
00021 double sqrt(doublereal), d_sign(doublereal *, doublereal *);
00022
00023 /* Local variables */
00024 static doublereal c__, f, g, h__;
00025 static integer i__, j, k, l;
00026 static doublereal s, x, y, z__, scale;
00027 static integer i1, k1, l1, m1, ii, kk, ll;
00028 extern doublereal pythag_(doublereal *, doublereal *);
00029 static integer its;
00030 static doublereal tst1, tst2;
00031
00032
00033
00034 /* THIS SUBROUTINE IS A TRANSLATION OF THE ALGOL PROCEDURE MINFIT, */
00035 /* NUM. MATH. 14, 403-420(1970) BY GOLUB AND REINSCH. */
00036 /* HANDBOOK FOR AUTO. COMP., VOL II-LINEAR ALGEBRA, 134-151(1971). */
00037
00038 /* THIS SUBROUTINE DETERMINES, TOWARDS THE SOLUTION OF THE LINEAR */
00039 /* T */
00040 /* SYSTEM AX=B, THE SINGULAR VALUE DECOMPOSITION A=USV OF A REAL */
00041 /* T */
00042 /* M BY N RECTANGULAR MATRIX, FORMING U B RATHER THAN U. HOUSEHOLDER
00043 */
00044 /* BIDIAGONALIZATION AND A VARIANT OF THE QR ALGORITHM ARE USED. */
00045
00046 /* ON INPUT */
00047
00048 /* NM MUST BE SET TO THE ROW DIMENSION OF TWO-DIMENSIONAL */
00049 /* ARRAY PARAMETERS AS DECLARED IN THE CALLING PROGRAM */
00050 /* DIMENSION STATEMENT. NOTE THAT NM MUST BE AT LEAST */
00051 /* AS LARGE AS THE MAXIMUM OF M AND N. */
00052
00053 /* M IS THE NUMBER OF ROWS OF A AND B. */
00054
00055 /* N IS THE NUMBER OF COLUMNS OF A AND THE ORDER OF V. */
00056
00057 /* A CONTAINS THE RECTANGULAR COEFFICIENT MATRIX OF THE SYSTEM. */
00058
00059 /* IP IS THE NUMBER OF COLUMNS OF B. IP CAN BE ZERO. */
00060
00061 /* B CONTAINS THE CONSTANT COLUMN MATRIX OF THE SYSTEM */
00062 /* IF IP IS NOT ZERO. OTHERWISE B IS NOT REFERENCED. */
00063
00064 /* ON OUTPUT */
00065
00066 /* A HAS BEEN OVERWRITTEN BY THE MATRIX V (ORTHOGONAL) OF THE */
00067 /* DECOMPOSITION IN ITS FIRST N ROWS AND COLUMNS. IF AN */
00068 /* ERROR EXIT IS MADE, THE COLUMNS OF V CORRESPONDING TO */
00069 /* INDICES OF CORRECT SINGULAR VALUES SHOULD BE CORRECT. */
00070
00071 /* W CONTAINS THE N (NON-NEGATIVE) SINGULAR VALUES OF A (THE */
00072 /* DIAGONAL ELEMENTS OF S). THEY ARE UNORDERED. IF AN */
00073 /* ERROR EXIT IS MADE, THE SINGULAR VALUES SHOULD BE CORRECT */
00074 /* FOR INDICES IERR+1,IERR+2,...,N. */
00075
00076 /* T */
00077 /* B HAS BEEN OVERWRITTEN BY U B. IF AN ERROR EXIT IS MADE, */
00078 /* T */
00079 /* THE ROWS OF U B CORRESPONDING TO INDICES OF CORRECT */
00080 /* SINGULAR VALUES SHOULD BE CORRECT. */
00081
00082 /* IERR IS SET TO */
00083 /* ZERO FOR NORMAL RETURN, */
00084 /* K IF THE K-TH SINGULAR VALUE HAS NOT BEEN */
00085 /* DETERMINED AFTER 30 ITERATIONS. */
00086
00087 /* RV1 IS A TEMPORARY STORAGE ARRAY. */
00088
00089 /* CALLS PYTHAG FOR DSQRT(A*A + B*B) . */
00090
00091 /* QUESTIONS AND COMMENTS SHOULD BE DIRECTED TO BURTON S. GARBOW, */
00092 /* MATHEMATICS AND COMPUTER SCIENCE DIV, ARGONNE NATIONAL LABORATORY
00093 */
00094
00095 /* THIS VERSION DATED AUGUST 1983. */
00096
00097 /* ------------------------------------------------------------------
00098 */
00099
00100 /* Parameter adjustments */
00101 --rv1;
00102 --w;
00103 a_dim1 = *nm;
00104 a_offset = a_dim1 + 1;
00105 a -= a_offset;
00106 b_dim1 = *nm;
00107 b_offset = b_dim1 + 1;
00108 b -= b_offset;
00109
00110 /* Function Body */
00111 *ierr = 0;
00112 /* .......... HOUSEHOLDER REDUCTION TO BIDIAGONAL FORM .......... */
00113 g = 0.;
00114 scale = 0.;
00115 x = 0.;
00116
00117 i__1 = *n;
00118 for (i__ = 1; i__ <= i__1; ++i__) {
00119 l = i__ + 1;
00120 rv1[i__] = scale * g;
00121 g = 0.;
00122 s = 0.;
00123 scale = 0.;
00124 if (i__ > *m) {
00125 goto L210;
00126 }
00127
00128 i__2 = *m;
00129 for (k = i__; k <= i__2; ++k) {
00130 /* L120: */
00131 scale += (d__1 = a[k + i__ * a_dim1], abs(d__1));
00132 }
00133
00134 if (scale == 0.) {
00135 goto L210;
00136 }
00137
00138 i__2 = *m;
00139 for (k = i__; k <= i__2; ++k) {
00140 a[k + i__ * a_dim1] /= scale;
00141 /* Computing 2nd power */
00142 d__1 = a[k + i__ * a_dim1];
00143 s += d__1 * d__1;
00144 /* L130: */
00145 }
00146
00147 f = a[i__ + i__ * a_dim1];
00148 d__1 = sqrt(s);
00149 g = -d_sign(&d__1, &f);
00150 h__ = f * g - s;
00151 a[i__ + i__ * a_dim1] = f - g;
00152 if (i__ == *n) {
00153 goto L160;
00154 }
00155
00156 i__2 = *n;
00157 for (j = l; j <= i__2; ++j) {
00158 s = 0.;
00159
00160 i__3 = *m;
00161 for (k = i__; k <= i__3; ++k) {
00162 /* L140: */
00163 s += a[k + i__ * a_dim1] * a[k + j * a_dim1];
00164 }
00165
00166 f = s / h__;
00167
00168 i__3 = *m;
00169 for (k = i__; k <= i__3; ++k) {
00170 a[k + j * a_dim1] += f * a[k + i__ * a_dim1];
00171 /* L150: */
00172 }
00173 }
00174
00175 L160:
00176 if (*ip == 0) {
00177 goto L190;
00178 }
00179
00180 i__3 = *ip;
00181 for (j = 1; j <= i__3; ++j) {
00182 s = 0.;
00183
00184 i__2 = *m;
00185 for (k = i__; k <= i__2; ++k) {
00186 /* L170: */
00187 s += a[k + i__ * a_dim1] * b[k + j * b_dim1];
00188 }
00189
00190 f = s / h__;
00191
00192 i__2 = *m;
00193 for (k = i__; k <= i__2; ++k) {
00194 b[k + j * b_dim1] += f * a[k + i__ * a_dim1];
00195 /* L180: */
00196 }
00197 }
00198
00199 L190:
00200 i__2 = *m;
00201 for (k = i__; k <= i__2; ++k) {
00202 /* L200: */
00203 a[k + i__ * a_dim1] = scale * a[k + i__ * a_dim1];
00204 }
00205
00206 L210:
00207 w[i__] = scale * g;
00208 g = 0.;
00209 s = 0.;
00210 scale = 0.;
00211 if (i__ > *m || i__ == *n) {
00212 goto L290;
00213 }
00214
00215 i__2 = *n;
00216 for (k = l; k <= i__2; ++k) {
00217 /* L220: */
00218 scale += (d__1 = a[i__ + k * a_dim1], abs(d__1));
00219 }
00220
00221 if (scale == 0.) {
00222 goto L290;
00223 }
00224
00225 i__2 = *n;
00226 for (k = l; k <= i__2; ++k) {
00227 a[i__ + k * a_dim1] /= scale;
00228 /* Computing 2nd power */
00229 d__1 = a[i__ + k * a_dim1];
00230 s += d__1 * d__1;
00231 /* L230: */
00232 }
00233
00234 f = a[i__ + l * a_dim1];
00235 d__1 = sqrt(s);
00236 g = -d_sign(&d__1, &f);
00237 h__ = f * g - s;
00238 a[i__ + l * a_dim1] = f - g;
00239
00240 i__2 = *n;
00241 for (k = l; k <= i__2; ++k) {
00242 /* L240: */
00243 rv1[k] = a[i__ + k * a_dim1] / h__;
00244 }
00245
00246 if (i__ == *m) {
00247 goto L270;
00248 }
00249
00250 i__2 = *m;
00251 for (j = l; j <= i__2; ++j) {
00252 s = 0.;
00253
00254 i__3 = *n;
00255 for (k = l; k <= i__3; ++k) {
00256 /* L250: */
00257 s += a[j + k * a_dim1] * a[i__ + k * a_dim1];
00258 }
00259
00260 i__3 = *n;
00261 for (k = l; k <= i__3; ++k) {
00262 a[j + k * a_dim1] += s * rv1[k];
00263 /* L260: */
00264 }
00265 }
00266
00267 L270:
00268 i__3 = *n;
00269 for (k = l; k <= i__3; ++k) {
00270 /* L280: */
00271 a[i__ + k * a_dim1] = scale * a[i__ + k * a_dim1];
00272 }
00273
00274 L290:
00275 /* Computing MAX */
00276 d__3 = x, d__4 = (d__1 = w[i__], abs(d__1)) + (d__2 = rv1[i__], abs(
00277 d__2));
00278 x = max(d__3,d__4);
00279 /* L300: */
00280 }
00281 /* .......... ACCUMULATION OF RIGHT-HAND TRANSFORMATIONS. */
00282 /* FOR I=N STEP -1 UNTIL 1 DO -- .......... */
00283 i__1 = *n;
00284 for (ii = 1; ii <= i__1; ++ii) {
00285 i__ = *n + 1 - ii;
00286 if (i__ == *n) {
00287 goto L390;
00288 }
00289 if (g == 0.) {
00290 goto L360;
00291 }
00292
00293 i__3 = *n;
00294 for (j = l; j <= i__3; ++j) {
00295 /* .......... DOUBLE DIVISION AVOIDS POSSIBLE UNDERFLOW ......
00296 .... */
00297 /* L320: */
00298 a[j + i__ * a_dim1] = a[i__ + j * a_dim1] / a[i__ + l * a_dim1] /
00299 g;
00300 }
00301
00302 i__3 = *n;
00303 for (j = l; j <= i__3; ++j) {
00304 s = 0.;
00305
00306 i__2 = *n;
00307 for (k = l; k <= i__2; ++k) {
00308 /* L340: */
00309 s += a[i__ + k * a_dim1] * a[k + j * a_dim1];
00310 }
00311
00312 i__2 = *n;
00313 for (k = l; k <= i__2; ++k) {
00314 a[k + j * a_dim1] += s * a[k + i__ * a_dim1];
00315 /* L350: */
00316 }
00317 }
00318
00319 L360:
00320 i__2 = *n;
00321 for (j = l; j <= i__2; ++j) {
00322 a[i__ + j * a_dim1] = 0.;
00323 a[j + i__ * a_dim1] = 0.;
00324 /* L380: */
00325 }
00326
00327 L390:
00328 a[i__ + i__ * a_dim1] = 1.;
00329 g = rv1[i__];
00330 l = i__;
00331 /* L400: */
00332 }
00333
00334 if (*m >= *n || *ip == 0) {
00335 goto L510;
00336 }
00337 m1 = *m + 1;
00338
00339 i__1 = *n;
00340 for (i__ = m1; i__ <= i__1; ++i__) {
00341
00342 i__2 = *ip;
00343 for (j = 1; j <= i__2; ++j) {
00344 b[i__ + j * b_dim1] = 0.;
00345 /* L500: */
00346 }
00347 }
00348 /* .......... DIAGONALIZATION OF THE BIDIAGONAL FORM .......... */
00349 L510:
00350 tst1 = x;
00351 /* .......... FOR K=N STEP -1 UNTIL 1 DO -- .......... */
00352 i__2 = *n;
00353 for (kk = 1; kk <= i__2; ++kk) {
00354 k1 = *n - kk;
00355 k = k1 + 1;
00356 its = 0;
00357 /* .......... TEST FOR SPLITTING. */
00358 /* FOR L=K STEP -1 UNTIL 1 DO -- .......... */
00359 L520:
00360 i__1 = k;
00361 for (ll = 1; ll <= i__1; ++ll) {
00362 l1 = k - ll;
00363 l = l1 + 1;
00364 tst2 = tst1 + (d__1 = rv1[l], abs(d__1));
00365 if (tst2 == tst1) {
00366 goto L565;
00367 }
00368 /* .......... RV1(1) IS ALWAYS ZERO, SO THERE IS NO EXIT */
00369 /* THROUGH THE BOTTOM OF THE LOOP .......... */
00370 tst2 = tst1 + (d__1 = w[l1], abs(d__1));
00371 if (tst2 == tst1) {
00372 goto L540;
00373 }
00374 /* L530: */
00375 }
00376 /* .......... CANCELLATION OF RV1(L) IF L GREATER THAN 1 .........
00377 . */
00378 L540:
00379 c__ = 0.;
00380 s = 1.;
00381
00382 i__1 = k;
00383 for (i__ = l; i__ <= i__1; ++i__) {
00384 f = s * rv1[i__];
00385 rv1[i__] = c__ * rv1[i__];
00386 tst2 = tst1 + abs(f);
00387 if (tst2 == tst1) {
00388 goto L565;
00389 }
00390 g = w[i__];
00391 h__ = pythag_(&f, &g);
00392 w[i__] = h__;
00393 c__ = g / h__;
00394 s = -f / h__;
00395 if (*ip == 0) {
00396 goto L560;
00397 }
00398
00399 i__3 = *ip;
00400 for (j = 1; j <= i__3; ++j) {
00401 y = b[l1 + j * b_dim1];
00402 z__ = b[i__ + j * b_dim1];
00403 b[l1 + j * b_dim1] = y * c__ + z__ * s;
00404 b[i__ + j * b_dim1] = -y * s + z__ * c__;
00405 /* L550: */
00406 }
00407
00408 L560:
00409 ;
00410 }
00411 /* .......... TEST FOR CONVERGENCE .......... */
00412 L565:
00413 z__ = w[k];
00414 if (l == k) {
00415 goto L650;
00416 }
00417 /* .......... SHIFT FROM BOTTOM 2 BY 2 MINOR .......... */
00418 if (its == 30) {
00419 goto L1000;
00420 }
00421 ++its;
00422 x = w[l];
00423 y = w[k1];
00424 g = rv1[k1];
00425 h__ = rv1[k];
00426 f = ((g + z__) / h__ * ((g - z__) / y) + y / h__ - h__ / y) * .5;
00427 g = pythag_(&f, &c_b39);
00428 f = x - z__ / x * z__ + h__ / x * (y / (f + d_sign(&g, &f)) - h__);
00429 /* .......... NEXT QR TRANSFORMATION .......... */
00430 c__ = 1.;
00431 s = 1.;
00432
00433 i__1 = k1;
00434 for (i1 = l; i1 <= i__1; ++i1) {
00435 i__ = i1 + 1;
00436 g = rv1[i__];
00437 y = w[i__];
00438 h__ = s * g;
00439 g = c__ * g;
00440 z__ = pythag_(&f, &h__);
00441 rv1[i1] = z__;
00442 c__ = f / z__;
00443 s = h__ / z__;
00444 f = x * c__ + g * s;
00445 g = -x * s + g * c__;
00446 h__ = y * s;
00447 y *= c__;
00448
00449 i__3 = *n;
00450 for (j = 1; j <= i__3; ++j) {
00451 x = a[j + i1 * a_dim1];
00452 z__ = a[j + i__ * a_dim1];
00453 a[j + i1 * a_dim1] = x * c__ + z__ * s;
00454 a[j + i__ * a_dim1] = -x * s + z__ * c__;
00455 /* L570: */
00456 }
00457
00458 z__ = pythag_(&f, &h__);
00459 w[i1] = z__;
00460 /* .......... ROTATION CAN BE ARBITRARY IF Z IS ZERO .........
00461 . */
00462 if (z__ == 0.) {
00463 goto L580;
00464 }
00465 c__ = f / z__;
00466 s = h__ / z__;
00467 L580:
00468 f = c__ * g + s * y;
00469 x = -s * g + c__ * y;
00470 if (*ip == 0) {
00471 goto L600;
00472 }
00473
00474 i__3 = *ip;
00475 for (j = 1; j <= i__3; ++j) {
00476 y = b[i1 + j * b_dim1];
00477 z__ = b[i__ + j * b_dim1];
00478 b[i1 + j * b_dim1] = y * c__ + z__ * s;
00479 b[i__ + j * b_dim1] = -y * s + z__ * c__;
00480 /* L590: */
00481 }
00482
00483 L600:
00484 ;
00485 }
00486
00487 rv1[l] = 0.;
00488 rv1[k] = f;
00489 w[k] = x;
00490 goto L520;
00491 /* .......... CONVERGENCE .......... */
00492 L650:
00493 if (z__ >= 0.) {
00494 goto L700;
00495 }
00496 /* .......... W(K) IS MADE NON-NEGATIVE .......... */
00497 w[k] = -z__;
00498
00499 i__1 = *n;
00500 for (j = 1; j <= i__1; ++j) {
00501 /* L690: */
00502 a[j + k * a_dim1] = -a[j + k * a_dim1];
00503 }
00504
00505 L700:
00506 ;
00507 }
00508
00509 goto L1001;
00510 /* .......... SET ERROR -- NO CONVERGENCE TO A */
00511 /* SINGULAR VALUE AFTER 30 ITERATIONS .......... */
00512 L1000:
00513 *ierr = k;
00514 L1001:
00515 return 0;
00516 } /* minfit_ */
|
|
||||||||||||||||||||||||||||||||
|
Definition at line 8 of file eis_ortbak.c.
00010 {
00011 /* System generated locals */
00012 integer a_dim1, a_offset, z_dim1, z_offset, i__1, i__2, i__3;
00013
00014 /* Local variables */
00015 static doublereal g;
00016 static integer i__, j, la, mm, mp, kp1, mp1;
00017
00018
00019
00020 /* THIS SUBROUTINE IS A TRANSLATION OF THE ALGOL PROCEDURE ORTBAK, */
00021 /* NUM. MATH. 12, 349-368(1968) BY MARTIN AND WILKINSON. */
00022 /* HANDBOOK FOR AUTO. COMP., VOL.II-LINEAR ALGEBRA, 339-358(1971). */
00023
00024 /* THIS SUBROUTINE FORMS THE EIGENVECTORS OF A REAL GENERAL */
00025 /* MATRIX BY BACK TRANSFORMING THOSE OF THE CORRESPONDING */
00026 /* UPPER HESSENBERG MATRIX DETERMINED BY ORTHES. */
00027
00028 /* ON INPUT */
00029
00030 /* NM MUST BE SET TO THE ROW DIMENSION OF TWO-DIMENSIONAL */
00031 /* ARRAY PARAMETERS AS DECLARED IN THE CALLING PROGRAM */
00032 /* DIMENSION STATEMENT. */
00033
00034 /* LOW AND IGH ARE INTEGERS DETERMINED BY THE BALANCING */
00035 /* SUBROUTINE BALANC. IF BALANC HAS NOT BEEN USED, */
00036 /* SET LOW=1 AND IGH EQUAL TO THE ORDER OF THE MATRIX. */
00037
00038 /* A CONTAINS INFORMATION ABOUT THE ORTHOGONAL TRANS- */
00039 /* FORMATIONS USED IN THE REDUCTION BY ORTHES */
00040 /* IN ITS STRICT LOWER TRIANGLE. */
00041
00042 /* ORT CONTAINS FURTHER INFORMATION ABOUT THE TRANS- */
00043 /* FORMATIONS USED IN THE REDUCTION BY ORTHES. */
00044 /* ONLY ELEMENTS LOW THROUGH IGH ARE USED. */
00045
00046 /* M IS THE NUMBER OF COLUMNS OF Z TO BE BACK TRANSFORMED. */
00047
00048 /* Z CONTAINS THE REAL AND IMAGINARY PARTS OF THE EIGEN- */
00049 /* VECTORS TO BE BACK TRANSFORMED IN ITS FIRST M COLUMNS. */
00050
00051 /* ON OUTPUT */
00052
00053 /* Z CONTAINS THE REAL AND IMAGINARY PARTS OF THE */
00054 /* TRANSFORMED EIGENVECTORS IN ITS FIRST M COLUMNS. */
00055
00056 /* ORT HAS BEEN ALTERED. */
00057
00058 /* NOTE THAT ORTBAK PRESERVES VECTOR EUCLIDEAN NORMS. */
00059
00060 /* QUESTIONS AND COMMENTS SHOULD BE DIRECTED TO BURTON S. GARBOW, */
00061 /* MATHEMATICS AND COMPUTER SCIENCE DIV, ARGONNE NATIONAL LABORATORY
00062 */
00063
00064 /* THIS VERSION DATED AUGUST 1983. */
00065
00066 /* ------------------------------------------------------------------
00067 */
00068
00069 /* Parameter adjustments */
00070 --ort;
00071 a_dim1 = *nm;
00072 a_offset = a_dim1 + 1;
00073 a -= a_offset;
00074 z_dim1 = *nm;
00075 z_offset = z_dim1 + 1;
00076 z__ -= z_offset;
00077
00078 /* Function Body */
00079 if (*m == 0) {
00080 goto L200;
00081 }
00082 la = *igh - 1;
00083 kp1 = *low + 1;
00084 if (la < kp1) {
00085 goto L200;
00086 }
00087 /* .......... FOR MP=IGH-1 STEP -1 UNTIL LOW+1 DO -- .......... */
00088 i__1 = la;
00089 for (mm = kp1; mm <= i__1; ++mm) {
00090 mp = *low + *igh - mm;
00091 if (a[mp + (mp - 1) * a_dim1] == 0.) {
00092 goto L140;
00093 }
00094 mp1 = mp + 1;
00095
00096 i__2 = *igh;
00097 for (i__ = mp1; i__ <= i__2; ++i__) {
00098 /* L100: */
00099 ort[i__] = a[i__ + (mp - 1) * a_dim1];
00100 }
00101
00102 i__2 = *m;
00103 for (j = 1; j <= i__2; ++j) {
00104 g = 0.;
00105
00106 i__3 = *igh;
00107 for (i__ = mp; i__ <= i__3; ++i__) {
00108 /* L110: */
00109 g += ort[i__] * z__[i__ + j * z_dim1];
00110 }
00111 /* .......... DIVISOR BELOW IS NEGATIVE OF H FORMED IN ORTHES.
00112 */
00113 /* DOUBLE DIVISION AVOIDS POSSIBLE UNDERFLOW ......
00114 .... */
00115 g = g / ort[mp] / a[mp + (mp - 1) * a_dim1];
00116
00117 i__3 = *igh;
00118 for (i__ = mp; i__ <= i__3; ++i__) {
00119 /* L120: */
00120 z__[i__ + j * z_dim1] += g * ort[i__];
00121 }
00122
00123 /* L130: */
00124 }
00125
00126 L140:
00127 ;
00128 }
00129
00130 L200:
00131 return 0;
00132 } /* ortbak_ */
|
|
||||||||||||||||||||||||||||
|
Definition at line 8 of file eis_orthes.c. References a, abs, d_sign(), mp, and scale.
00010 {
00011 /* System generated locals */
00012 integer a_dim1, a_offset, i__1, i__2, i__3;
00013 doublereal d__1;
00014
00015 /* Builtin functions */
00016 double sqrt(doublereal), d_sign(doublereal *, doublereal *);
00017
00018 /* Local variables */
00019 static doublereal f, g, h__;
00020 static integer i__, j, m;
00021 static doublereal scale;
00022 static integer la, ii, jj, mp, kp1;
00023
00024
00025
00026 /* THIS SUBROUTINE IS A TRANSLATION OF THE ALGOL PROCEDURE ORTHES, */
00027 /* NUM. MATH. 12, 349-368(1968) BY MARTIN AND WILKINSON. */
00028 /* HANDBOOK FOR AUTO. COMP., VOL.II-LINEAR ALGEBRA, 339-358(1971). */
00029
00030 /* GIVEN A REAL GENERAL MATRIX, THIS SUBROUTINE */
00031 /* REDUCES A SUBMATRIX SITUATED IN ROWS AND COLUMNS */
00032 /* LOW THROUGH IGH TO UPPER HESSENBERG FORM BY */
00033 /* ORTHOGONAL SIMILARITY TRANSFORMATIONS. */
00034
00035 /* ON INPUT */
00036
00037 /* NM MUST BE SET TO THE ROW DIMENSION OF TWO-DIMENSIONAL */
00038 /* ARRAY PARAMETERS AS DECLARED IN THE CALLING PROGRAM */
00039 /* DIMENSION STATEMENT. */
00040
00041 /* N IS THE ORDER OF THE MATRIX. */
00042
00043 /* LOW AND IGH ARE INTEGERS DETERMINED BY THE BALANCING */
00044 /* SUBROUTINE BALANC. IF BALANC HAS NOT BEEN USED, */
00045 /* SET LOW=1, IGH=N. */
00046
00047 /* A CONTAINS THE INPUT MATRIX. */
00048
00049 /* ON OUTPUT */
00050
00051 /* A CONTAINS THE HESSENBERG MATRIX. INFORMATION ABOUT */
00052 /* THE ORTHOGONAL TRANSFORMATIONS USED IN THE REDUCTION */
00053 /* IS STORED IN THE REMAINING TRIANGLE UNDER THE */
00054 /* HESSENBERG MATRIX. */
00055
00056 /* ORT CONTAINS FURTHER INFORMATION ABOUT THE TRANSFORMATIONS. */
00057 /* ONLY ELEMENTS LOW THROUGH IGH ARE USED. */
00058
00059 /* QUESTIONS AND COMMENTS SHOULD BE DIRECTED TO BURTON S. GARBOW, */
00060 /* MATHEMATICS AND COMPUTER SCIENCE DIV, ARGONNE NATIONAL LABORATORY
00061 */
00062
00063 /* THIS VERSION DATED AUGUST 1983. */
00064
00065 /* ------------------------------------------------------------------
00066 */
00067
00068 /* Parameter adjustments */
00069 a_dim1 = *nm;
00070 a_offset = a_dim1 + 1;
00071 a -= a_offset;
00072 --ort;
00073
00074 /* Function Body */
00075 la = *igh - 1;
00076 kp1 = *low + 1;
00077 if (la < kp1) {
00078 goto L200;
00079 }
00080
00081 i__1 = la;
00082 for (m = kp1; m <= i__1; ++m) {
00083 h__ = 0.;
00084 ort[m] = 0.;
00085 scale = 0.;
00086 /* .......... SCALE COLUMN (ALGOL TOL THEN NOT NEEDED) ..........
00087 */
00088 i__2 = *igh;
00089 for (i__ = m; i__ <= i__2; ++i__) {
00090 /* L90: */
00091 scale += (d__1 = a[i__ + (m - 1) * a_dim1], abs(d__1));
00092 }
00093
00094 if (scale == 0.) {
00095 goto L180;
00096 }
00097 mp = m + *igh;
00098 /* .......... FOR I=IGH STEP -1 UNTIL M DO -- .......... */
00099 i__2 = *igh;
00100 for (ii = m; ii <= i__2; ++ii) {
00101 i__ = mp - ii;
00102 ort[i__] = a[i__ + (m - 1) * a_dim1] / scale;
00103 h__ += ort[i__] * ort[i__];
00104 /* L100: */
00105 }
00106
00107 d__1 = sqrt(h__);
00108 g = -d_sign(&d__1, &ort[m]);
00109 h__ -= ort[m] * g;
00110 ort[m] -= g;
00111 /* .......... FORM (I-(U*UT)/H) * A .......... */
00112 i__2 = *n;
00113 for (j = m; j <= i__2; ++j) {
00114 f = 0.;
00115 /* .......... FOR I=IGH STEP -1 UNTIL M DO -- .......... */
00116 i__3 = *igh;
00117 for (ii = m; ii <= i__3; ++ii) {
00118 i__ = mp - ii;
00119 f += ort[i__] * a[i__ + j * a_dim1];
00120 /* L110: */
00121 }
00122
00123 f /= h__;
00124
00125 i__3 = *igh;
00126 for (i__ = m; i__ <= i__3; ++i__) {
00127 /* L120: */
00128 a[i__ + j * a_dim1] -= f * ort[i__];
00129 }
00130
00131 /* L130: */
00132 }
00133 /* .......... FORM (I-(U*UT)/H)*A*(I-(U*UT)/H) .......... */
00134 i__2 = *igh;
00135 for (i__ = 1; i__ <= i__2; ++i__) {
00136 f = 0.;
00137 /* .......... FOR J=IGH STEP -1 UNTIL M DO -- .......... */
00138 i__3 = *igh;
00139 for (jj = m; jj <= i__3; ++jj) {
00140 j = mp - jj;
00141 f += ort[j] * a[i__ + j * a_dim1];
00142 /* L140: */
00143 }
00144
00145 f /= h__;
00146
00147 i__3 = *igh;
00148 for (j = m; j <= i__3; ++j) {
00149 /* L150: */
00150 a[i__ + j * a_dim1] -= f * ort[j];
00151 }
00152
00153 /* L160: */
00154 }
00155
00156 ort[m] = scale * ort[m];
00157 a[m + (m - 1) * a_dim1] = scale * g;
00158 L180:
00159 ;
00160 }
00161
00162 L200:
00163 return 0;
00164 } /* orthes_ */
|
|
||||||||||||||||||||||||||||||||
|
Definition at line 8 of file eis_ortran.c.
00010 {
00011 /* System generated locals */
00012 integer a_dim1, a_offset, z_dim1, z_offset, i__1, i__2, i__3;
00013
00014 /* Local variables */
00015 static doublereal g;
00016 static integer i__, j, kl, mm, mp, mp1;
00017
00018
00019
00020 /* THIS SUBROUTINE IS A TRANSLATION OF THE ALGOL PROCEDURE ORTRANS, */
00021 /* NUM. MATH. 16, 181-204(1970) BY PETERS AND WILKINSON. */
00022 /* HANDBOOK FOR AUTO. COMP., VOL.II-LINEAR ALGEBRA, 372-395(1971). */
00023
00024 /* THIS SUBROUTINE ACCUMULATES THE ORTHOGONAL SIMILARITY */
00025 /* TRANSFORMATIONS USED IN THE REDUCTION OF A REAL GENERAL */
00026 /* MATRIX TO UPPER HESSENBERG FORM BY ORTHES. */
00027
00028 /* ON INPUT */
00029
00030 /* NM MUST BE SET TO THE ROW DIMENSION OF TWO-DIMENSIONAL */
00031 /* ARRAY PARAMETERS AS DECLARED IN THE CALLING PROGRAM */
00032 /* DIMENSION STATEMENT. */
00033
00034 /* N IS THE ORDER OF THE MATRIX. */
00035
00036 /* LOW AND IGH ARE INTEGERS DETERMINED BY THE BALANCING */
00037 /* SUBROUTINE BALANC. IF BALANC HAS NOT BEEN USED, */
00038 /* SET LOW=1, IGH=N. */
00039
00040 /* A CONTAINS INFORMATION ABOUT THE ORTHOGONAL TRANS- */
00041 /* FORMATIONS USED IN THE REDUCTION BY ORTHES */
00042 /* IN ITS STRICT LOWER TRIANGLE. */
00043
00044 /* ORT CONTAINS FURTHER INFORMATION ABOUT THE TRANS- */
00045 /* FORMATIONS USED IN THE REDUCTION BY ORTHES. */
00046 /* ONLY ELEMENTS LOW THROUGH IGH ARE USED. */
00047
00048 /* ON OUTPUT */
00049
00050 /* Z CONTAINS THE TRANSFORMATION MATRIX PRODUCED IN THE */
00051 /* REDUCTION BY ORTHES. */
00052
00053 /* ORT HAS BEEN ALTERED. */
00054
00055 /* QUESTIONS AND COMMENTS SHOULD BE DIRECTED TO BURTON S. GARBOW, */
00056 /* MATHEMATICS AND COMPUTER SCIENCE DIV, ARGONNE NATIONAL LABORATORY
00057 */
00058
00059 /* THIS VERSION DATED AUGUST 1983. */
00060
00061 /* ------------------------------------------------------------------
00062 */
00063
00064 /* .......... INITIALIZE Z TO IDENTITY MATRIX .......... */
00065 /* Parameter adjustments */
00066 z_dim1 = *nm;
00067 z_offset = z_dim1 + 1;
00068 z__ -= z_offset;
00069 --ort;
00070 a_dim1 = *nm;
00071 a_offset = a_dim1 + 1;
00072 a -= a_offset;
00073
00074 /* Function Body */
00075 i__1 = *n;
00076 for (j = 1; j <= i__1; ++j) {
00077
00078 i__2 = *n;
00079 for (i__ = 1; i__ <= i__2; ++i__) {
00080 /* L60: */
00081 z__[i__ + j * z_dim1] = 0.;
00082 }
00083
00084 z__[j + j * z_dim1] = 1.;
00085 /* L80: */
00086 }
00087
00088 kl = *igh - *low - 1;
00089 if (kl < 1) {
00090 goto L200;
00091 }
00092 /* .......... FOR MP=IGH-1 STEP -1 UNTIL LOW+1 DO -- .......... */
00093 i__1 = kl;
00094 for (mm = 1; mm <= i__1; ++mm) {
00095 mp = *igh - mm;
00096 if (a[mp + (mp - 1) * a_dim1] == 0.) {
00097 goto L140;
00098 }
00099 mp1 = mp + 1;
00100
00101 i__2 = *igh;
00102 for (i__ = mp1; i__ <= i__2; ++i__) {
00103 /* L100: */
00104 ort[i__] = a[i__ + (mp - 1) * a_dim1];
00105 }
00106
00107 i__2 = *igh;
00108 for (j = mp; j <= i__2; ++j) {
00109 g = 0.;
00110
00111 i__3 = *igh;
00112 for (i__ = mp; i__ <= i__3; ++i__) {
00113 /* L110: */
00114 g += ort[i__] * z__[i__ + j * z_dim1];
00115 }
00116 /* .......... DIVISOR BELOW IS NEGATIVE OF H FORMED IN ORTHES.
00117 */
00118 /* DOUBLE DIVISION AVOIDS POSSIBLE UNDERFLOW ......
00119 .... */
00120 g = g / ort[mp] / a[mp + (mp - 1) * a_dim1];
00121
00122 i__3 = *igh;
00123 for (i__ = mp; i__ <= i__3; ++i__) {
00124 /* L120: */
00125 z__[i__ + j * z_dim1] += g * ort[i__];
00126 }
00127
00128 /* L130: */
00129 }
00130
00131 L140:
00132 ;
00133 }
00134
00135 L200:
00136 return 0;
00137 } /* ortran_ */
|
|
||||||||||||
|
Definition at line 8 of file eis_pythag.c. References a, abs, max, min, and p. Referenced by bandv_(), bqr_(), cinvit_(), comqr2_(), comqr_(), corth_(), csroot_(), htrid3_(), htridi_(), imtql1_(), imtql2_(), imtqlv_(), invit_(), minfit_(), svd_(), tinvit_(), tql1_(), tql2_(), tqlrat_(), and tsturm_().
00009 {
00010 /* System generated locals */
00011 doublereal ret_val, d__1, d__2, d__3;
00012
00013 /* Local variables */
00014 static doublereal p, r__, s, t, u;
00015
00016
00017 /* FINDS DSQRT(A**2+B**2) WITHOUT OVERFLOW OR DESTRUCTIVE UNDERFLOW */
00018
00019 /* Computing MAX */
00020 d__1 = abs(*a), d__2 = abs(*b);
00021 p = max(d__1,d__2);
00022 if (p == 0.) {
00023 goto L20;
00024 }
00025 /* Computing MIN */
00026 d__2 = abs(*a), d__3 = abs(*b);
00027 /* Computing 2nd power */
00028 d__1 = min(d__2,d__3) / p;
00029 r__ = d__1 * d__1;
00030 L10:
00031 t = r__ + 4.;
00032 if (t == 4.) {
00033 goto L20;
00034 }
00035 s = r__ / t;
00036 u = s * 2. + 1.;
00037 p = u * p;
00038 /* Computing 2nd power */
00039 d__1 = s / u;
00040 r__ = d__1 * d__1 * r__;
00041 goto L10;
00042 L20:
00043 ret_val = p;
00044 return ret_val;
00045 } /* pythag_ */
|
|
||||||||||||||||||||||||||||
|
Definition at line 8 of file eis_qzhes.c. References a, abs, d_sign(), l, and v1. Referenced by rgg_().
00010 {
00011 /* System generated locals */
00012 integer a_dim1, a_offset, b_dim1, b_offset, z_dim1, z_offset, i__1, i__2,
00013 i__3;
00014 doublereal d__1, d__2;
00015
00016 /* Builtin functions */
00017 double sqrt(doublereal), d_sign(doublereal *, doublereal *);
00018
00019 /* Local variables */
00020 static integer i__, j, k, l;
00021 static doublereal r__, s, t;
00022 static integer l1;
00023 static doublereal u1, u2, v1, v2;
00024 static integer lb, nk1, nm1, nm2;
00025 static doublereal rho;
00026
00027
00028
00029 /* THIS SUBROUTINE IS THE FIRST STEP OF THE QZ ALGORITHM */
00030 /* FOR SOLVING GENERALIZED MATRIX EIGENVALUE PROBLEMS, */
00031 /* SIAM J. NUMER. ANAL. 10, 241-256(1973) BY MOLER AND STEWART. */
00032
00033 /* THIS SUBROUTINE ACCEPTS A PAIR OF REAL GENERAL MATRICES AND */
00034 /* REDUCES ONE OF THEM TO UPPER HESSENBERG FORM AND THE OTHER */
00035 /* TO UPPER TRIANGULAR FORM USING ORTHOGONAL TRANSFORMATIONS. */
00036 /* IT IS USUALLY FOLLOWED BY QZIT, QZVAL AND, POSSIBLY, QZVEC. */
00037
00038 /* ON INPUT */
00039
00040 /* NM MUST BE SET TO THE ROW DIMENSION OF TWO-DIMENSIONAL */
00041 /* ARRAY PARAMETERS AS DECLARED IN THE CALLING PROGRAM */
00042 /* DIMENSION STATEMENT. */
00043
00044 /* N IS THE ORDER OF THE MATRICES. */
00045
00046 /* A CONTAINS A REAL GENERAL MATRIX. */
00047
00048 /* B CONTAINS A REAL GENERAL MATRIX. */
00049
00050 /* MATZ SHOULD BE SET TO .TRUE. IF THE RIGHT HAND TRANSFORMATIONS
00051 */
00052 /* ARE TO BE ACCUMULATED FOR LATER USE IN COMPUTING */
00053 /* EIGENVECTORS, AND TO .FALSE. OTHERWISE. */
00054
00055 /* ON OUTPUT */
00056
00057 /* A HAS BEEN REDUCED TO UPPER HESSENBERG FORM. THE ELEMENTS */
00058 /* BELOW THE FIRST SUBDIAGONAL HAVE BEEN SET TO ZERO. */
00059
00060 /* B HAS BEEN REDUCED TO UPPER TRIANGULAR FORM. THE ELEMENTS */
00061 /* BELOW THE MAIN DIAGONAL HAVE BEEN SET TO ZERO. */
00062
00063 /* Z CONTAINS THE PRODUCT OF THE RIGHT HAND TRANSFORMATIONS IF */
00064 /* MATZ HAS BEEN SET TO .TRUE. OTHERWISE, Z IS NOT REFERENCED.
00065 */
00066
00067 /* QUESTIONS AND COMMENTS SHOULD BE DIRECTED TO BURTON S. GARBOW, */
00068 /* MATHEMATICS AND COMPUTER SCIENCE DIV, ARGONNE NATIONAL LABORATORY
00069 */
00070
00071 /* THIS VERSION DATED AUGUST 1983. */
00072
00073 /* ------------------------------------------------------------------
00074 */
00075
00076 /* .......... INITIALIZE Z .......... */
00077 /* Parameter adjustments */
00078 z_dim1 = *nm;
00079 z_offset = z_dim1 + 1;
00080 z__ -= z_offset;
00081 b_dim1 = *nm;
00082 b_offset = b_dim1 + 1;
00083 b -= b_offset;
00084 a_dim1 = *nm;
00085 a_offset = a_dim1 + 1;
00086 a -= a_offset;
00087
00088 /* Function Body */
00089 if (! (*matz)) {
00090 goto L10;
00091 }
00092
00093 i__1 = *n;
00094 for (j = 1; j <= i__1; ++j) {
00095
00096 i__2 = *n;
00097 for (i__ = 1; i__ <= i__2; ++i__) {
00098 z__[i__ + j * z_dim1] = 0.;
00099 /* L2: */
00100 }
00101
00102 z__[j + j * z_dim1] = 1.;
00103 /* L3: */
00104 }
00105 /* .......... REDUCE B TO UPPER TRIANGULAR FORM .......... */
00106 L10:
00107 if (*n <= 1) {
00108 goto L170;
00109 }
00110 nm1 = *n - 1;
00111
00112 i__1 = nm1;
00113 for (l = 1; l <= i__1; ++l) {
00114 l1 = l + 1;
00115 s = 0.;
00116
00117 i__2 = *n;
00118 for (i__ = l1; i__ <= i__2; ++i__) {
00119 s += (d__1 = b[i__ + l * b_dim1], abs(d__1));
00120 /* L20: */
00121 }
00122
00123 if (s == 0.) {
00124 goto L100;
00125 }
00126 s += (d__1 = b[l + l * b_dim1], abs(d__1));
00127 r__ = 0.;
00128
00129 i__2 = *n;
00130 for (i__ = l; i__ <= i__2; ++i__) {
00131 b[i__ + l * b_dim1] /= s;
00132 /* Computing 2nd power */
00133 d__1 = b[i__ + l * b_dim1];
00134 r__ += d__1 * d__1;
00135 /* L25: */
00136 }
00137
00138 d__1 = sqrt(r__);
00139 r__ = d_sign(&d__1, &b[l + l * b_dim1]);
00140 b[l + l * b_dim1] += r__;
00141 rho = r__ * b[l + l * b_dim1];
00142
00143 i__2 = *n;
00144 for (j = l1; j <= i__2; ++j) {
00145 t = 0.;
00146
00147 i__3 = *n;
00148 for (i__ = l; i__ <= i__3; ++i__) {
00149 t += b[i__ + l * b_dim1] * b[i__ + j * b_dim1];
00150 /* L30: */
00151 }
00152
00153 t = -t / rho;
00154
00155 i__3 = *n;
00156 for (i__ = l; i__ <= i__3; ++i__) {
00157 b[i__ + j * b_dim1] += t * b[i__ + l * b_dim1];
00158 /* L40: */
00159 }
00160
00161 /* L50: */
00162 }
00163
00164 i__2 = *n;
00165 for (j = 1; j <= i__2; ++j) {
00166 t = 0.;
00167
00168 i__3 = *n;
00169 for (i__ = l; i__ <= i__3; ++i__) {
00170 t += b[i__ + l * b_dim1] * a[i__ + j * a_dim1];
00171 /* L60: */
00172 }
00173
00174 t = -t / rho;
00175
00176 i__3 = *n;
00177 for (i__ = l; i__ <= i__3; ++i__) {
00178 a[i__ + j * a_dim1] += t * b[i__ + l * b_dim1];
00179 /* L70: */
00180 }
00181
00182 /* L80: */
00183 }
00184
00185 b[l + l * b_dim1] = -s * r__;
00186
00187 i__2 = *n;
00188 for (i__ = l1; i__ <= i__2; ++i__) {
00189 b[i__ + l * b_dim1] = 0.;
00190 /* L90: */
00191 }
00192
00193 L100:
00194 ;
00195 }
00196 /* .......... REDUCE A TO UPPER HESSENBERG FORM, WHILE */
00197 /* KEEPING B TRIANGULAR .......... */
00198 if (*n == 2) {
00199 goto L170;
00200 }
00201 nm2 = *n - 2;
00202
00203 i__1 = nm2;
00204 for (k = 1; k <= i__1; ++k) {
00205 nk1 = nm1 - k;
00206 /* .......... FOR L=N-1 STEP -1 UNTIL K+1 DO -- .......... */
00207 i__2 = nk1;
00208 for (lb = 1; lb <= i__2; ++lb) {
00209 l = *n - lb;
00210 l1 = l + 1;
00211 /* .......... ZERO A(L+1,K) .......... */
00212 s = (d__1 = a[l + k * a_dim1], abs(d__1)) + (d__2 = a[l1 + k *
00213 a_dim1], abs(d__2));
00214 if (s == 0.) {
00215 goto L150;
00216 }
00217 u1 = a[l + k * a_dim1] / s;
00218 u2 = a[l1 + k * a_dim1] / s;
00219 d__1 = sqrt(u1 * u1 + u2 * u2);
00220 r__ = d_sign(&d__1, &u1);
00221 v1 = -(u1 + r__) / r__;
00222 v2 = -u2 / r__;
00223 u2 = v2 / v1;
00224
00225 i__3 = *n;
00226 for (j = k; j <= i__3; ++j) {
00227 t = a[l + j * a_dim1] + u2 * a[l1 + j * a_dim1];
00228 a[l + j * a_dim1] += t * v1;
00229 a[l1 + j * a_dim1] += t * v2;
00230 /* L110: */
00231 }
00232
00233 a[l1 + k * a_dim1] = 0.;
00234
00235 i__3 = *n;
00236 for (j = l; j <= i__3; ++j) {
00237 t = b[l + j * b_dim1] + u2 * b[l1 + j * b_dim1];
00238 b[l + j * b_dim1] += t * v1;
00239 b[l1 + j * b_dim1] += t * v2;
00240 /* L120: */
00241 }
00242 /* .......... ZERO B(L+1,L) .......... */
00243 s = (d__1 = b[l1 + l1 * b_dim1], abs(d__1)) + (d__2 = b[l1 + l *
00244 b_dim1], abs(d__2));
00245 if (s == 0.) {
00246 goto L150;
00247 }
00248 u1 = b[l1 + l1 * b_dim1] / s;
00249 u2 = b[l1 + l * b_dim1] / s;
00250 d__1 = sqrt(u1 * u1 + u2 * u2);
00251 r__ = d_sign(&d__1, &u1);
00252 v1 = -(u1 + r__) / r__;
00253 v2 = -u2 / r__;
00254 u2 = v2 / v1;
00255
00256 i__3 = l1;
00257 for (i__ = 1; i__ <= i__3; ++i__) {
00258 t = b[i__ + l1 * b_dim1] + u2 * b[i__ + l * b_dim1];
00259 b[i__ + l1 * b_dim1] += t * v1;
00260 b[i__ + l * b_dim1] += t * v2;
00261 /* L130: */
00262 }
00263
00264 b[l1 + l * b_dim1] = 0.;
00265
00266 i__3 = *n;
00267 for (i__ = 1; i__ <= i__3; ++i__) {
00268 t = a[i__ + l1 * a_dim1] + u2 * a[i__ + l * a_dim1];
00269 a[i__ + l1 * a_dim1] += t * v1;
00270 a[i__ + l * a_dim1] += t * v2;
00271 /* L140: */
00272 }
00273
00274 if (! (*matz)) {
00275 goto L150;
00276 }
00277
00278 i__3 = *n;
00279 for (i__ = 1; i__ <= i__3; ++i__) {
00280 t = z__[i__ + l1 * z_dim1] + u2 * z__[i__ + l * z_dim1];
00281 z__[i__ + l1 * z_dim1] += t * v1;
00282 z__[i__ + l * z_dim1] += t * v2;
00283 /* L145: */
00284 }
00285
00286 L150:
00287 ;
00288 }
00289
00290 /* L160: */
00291 }
00292
00293 L170:
00294 return 0;
00295 } /* qzhes_ */
|
|
||||||||||||||||||||||||||||||||||||
|
Definition at line 12 of file eis_qzit.c. References a, a2, abs, c_b5, d_sign(), ep, epslon_(), l, max, min, and v1. Referenced by rgg_().
00014 {
00015 /* System generated locals */
00016 integer a_dim1, a_offset, b_dim1, b_offset, z_dim1, z_offset, i__1, i__2,
00017 i__3;
00018 doublereal d__1, d__2, d__3;
00019
00020 /* Builtin functions */
00021 double sqrt(doublereal), d_sign(doublereal *, doublereal *);
00022
00023 /* Local variables */
00024 static doublereal epsa, epsb;
00025 static integer i__, j, k, l;
00026 static doublereal r__, s, t, anorm, bnorm;
00027 static integer enorn;
00028 static doublereal a1, a2, a3;
00029 static integer k1, k2, l1;
00030 static doublereal u1, u2, u3, v1, v2, v3, a11, a12, a21, a22, a33, a34,
00031 a43, a44, b11, b12, b22, b33;
00032 static integer na, ld;
00033 static doublereal b34, b44;
00034 static integer en;
00035 static doublereal ep;
00036 static integer ll;
00037 static doublereal sh;
00038 extern doublereal epslon_(doublereal *);
00039 static logical notlas;
00040 static integer km1, lm1;
00041 static doublereal ani, bni;
00042 static integer ish, itn, its, enm2, lor1;
00043
00044
00045
00046 /* THIS SUBROUTINE IS THE SECOND STEP OF THE QZ ALGORITHM */
00047 /* FOR SOLVING GENERALIZED MATRIX EIGENVALUE PROBLEMS, */
00048 /* SIAM J. NUMER. ANAL. 10, 241-256(1973) BY MOLER AND STEWART, */
00049 /* AS MODIFIED IN TECHNICAL NOTE NASA TN D-7305(1973) BY WARD. */
00050
00051 /* THIS SUBROUTINE ACCEPTS A PAIR OF REAL MATRICES, ONE OF THEM */
00052 /* IN UPPER HESSENBERG FORM AND THE OTHER IN UPPER TRIANGULAR FORM. */
00053 /* IT REDUCES THE HESSENBERG MATRIX TO QUASI-TRIANGULAR FORM USING */
00054 /* ORTHOGONAL TRANSFORMATIONS WHILE MAINTAINING THE TRIANGULAR FORM */
00055 /* OF THE OTHER MATRIX. IT IS USUALLY PRECEDED BY QZHES AND */
00056 /* FOLLOWED BY QZVAL AND, POSSIBLY, QZVEC. */
00057
00058 /* ON INPUT */
00059
00060 /* NM MUST BE SET TO THE ROW DIMENSION OF TWO-DIMENSIONAL */
00061 /* ARRAY PARAMETERS AS DECLARED IN THE CALLING PROGRAM */
00062 /* DIMENSION STATEMENT. */
00063
00064 /* N IS THE ORDER OF THE MATRICES. */
00065
00066 /* A CONTAINS A REAL UPPER HESSENBERG MATRIX. */
00067
00068 /* B CONTAINS A REAL UPPER TRIANGULAR MATRIX. */
00069
00070 /* EPS1 IS A TOLERANCE USED TO DETERMINE NEGLIGIBLE ELEMENTS. */
00071 /* EPS1 = 0.0 (OR NEGATIVE) MAY BE INPUT, IN WHICH CASE AN */
00072 /* ELEMENT WILL BE NEGLECTED ONLY IF IT IS LESS THAN ROUNDOFF */
00073 /* ERROR TIMES THE NORM OF ITS MATRIX. IF THE INPUT EPS1 IS */
00074 /* POSITIVE, THEN AN ELEMENT WILL BE CONSIDERED NEGLIGIBLE */
00075 /* IF IT IS LESS THAN EPS1 TIMES THE NORM OF ITS MATRIX. A */
00076 /* POSITIVE VALUE OF EPS1 MAY RESULT IN FASTER EXECUTION, */
00077 /* BUT LESS ACCURATE RESULTS. */
00078
00079 /* MATZ SHOULD BE SET TO .TRUE. IF THE RIGHT HAND TRANSFORMATIONS
00080 */
00081 /* ARE TO BE ACCUMULATED FOR LATER USE IN COMPUTING */
00082 /* EIGENVECTORS, AND TO .FALSE. OTHERWISE. */
00083
00084 /* Z CONTAINS, IF MATZ HAS BEEN SET TO .TRUE., THE */
00085 /* TRANSFORMATION MATRIX PRODUCED IN THE REDUCTION */
00086 /* BY QZHES, IF PERFORMED, OR ELSE THE IDENTITY MATRIX. */
00087 /* IF MATZ HAS BEEN SET TO .FALSE., Z IS NOT REFERENCED. */
00088
00089 /* ON OUTPUT */
00090
00091 /* A HAS BEEN REDUCED TO QUASI-TRIANGULAR FORM. THE ELEMENTS */
00092 /* BELOW THE FIRST SUBDIAGONAL ARE STILL ZERO AND NO TWO */
00093 /* CONSECUTIVE SUBDIAGONAL ELEMENTS ARE NONZERO. */
00094
00095 /* B IS STILL IN UPPER TRIANGULAR FORM, ALTHOUGH ITS ELEMENTS */
00096 /* HAVE BEEN ALTERED. THE LOCATION B(N,1) IS USED TO STORE */
00097 /* EPS1 TIMES THE NORM OF B FOR LATER USE BY QZVAL AND QZVEC.
00098 */
00099
00100 /* Z CONTAINS THE PRODUCT OF THE RIGHT HAND TRANSFORMATIONS */
00101 /* (FOR BOTH STEPS) IF MATZ HAS BEEN SET TO .TRUE.. */
00102
00103 /* IERR IS SET TO */
00104 /* ZERO FOR NORMAL RETURN, */
00105 /* J IF THE LIMIT OF 30*N ITERATIONS IS EXHAUSTED */
00106 /* WHILE THE J-TH EIGENVALUE IS BEING SOUGHT. */
00107
00108 /* QUESTIONS AND COMMENTS SHOULD BE DIRECTED TO BURTON S. GARBOW, */
00109 /* MATHEMATICS AND COMPUTER SCIENCE DIV, ARGONNE NATIONAL LABORATORY
00110 */
00111
00112 /* THIS VERSION DATED AUGUST 1983. */
00113
00114 /* ------------------------------------------------------------------
00115 */
00116
00117 /* Parameter adjustments */
00118 z_dim1 = *nm;
00119 z_offset = z_dim1 + 1;
00120 z__ -= z_offset;
00121 b_dim1 = *nm;
00122 b_offset = b_dim1 + 1;
00123 b -= b_offset;
00124 a_dim1 = *nm;
00125 a_offset = a_dim1 + 1;
00126 a -= a_offset;
00127
00128 /* Function Body */
00129 *ierr = 0;
00130 /* .......... COMPUTE EPSA,EPSB .......... */
00131 anorm = 0.;
00132 bnorm = 0.;
00133
00134 i__1 = *n;
00135 for (i__ = 1; i__ <= i__1; ++i__) {
00136 ani = 0.;
00137 if (i__ != 1) {
00138 ani = (d__1 = a[i__ + (i__ - 1) * a_dim1], abs(d__1));
00139 }
00140 bni = 0.;
00141
00142 i__2 = *n;
00143 for (j = i__; j <= i__2; ++j) {
00144 ani += (d__1 = a[i__ + j * a_dim1], abs(d__1));
00145 bni += (d__1 = b[i__ + j * b_dim1], abs(d__1));
00146 /* L20: */
00147 }
00148
00149 if (ani > anorm) {
00150 anorm = ani;
00151 }
00152 if (bni > bnorm) {
00153 bnorm = bni;
00154 }
00155 /* L30: */
00156 }
00157
00158 if (anorm == 0.) {
00159 anorm = 1.;
00160 }
00161 if (bnorm == 0.) {
00162 bnorm = 1.;
00163 }
00164 ep = *eps1;
00165 if (ep > 0.) {
00166 goto L50;
00167 }
00168 /* .......... USE ROUNDOFF LEVEL IF EPS1 IS ZERO .......... */
00169 ep = epslon_(&c_b5);
00170 L50:
00171 epsa = ep * anorm;
00172 epsb = ep * bnorm;
00173 /* .......... REDUCE A TO QUASI-TRIANGULAR FORM, WHILE */
00174 /* KEEPING B TRIANGULAR .......... */
00175 lor1 = 1;
00176 enorn = *n;
00177 en = *n;
00178 itn = *n * 30;
00179 /* .......... BEGIN QZ STEP .......... */
00180 L60:
00181 if (en <= 2) {
00182 goto L1001;
00183 }
00184 if (! (*matz)) {
00185 enorn = en;
00186 }
00187 its = 0;
00188 na = en - 1;
00189 enm2 = na - 1;
00190 L70:
00191 ish = 2;
00192 /* .......... CHECK FOR CONVERGENCE OR REDUCIBILITY. */
00193 /* FOR L=EN STEP -1 UNTIL 1 DO -- .......... */
00194 i__1 = en;
00195 for (ll = 1; ll <= i__1; ++ll) {
00196 lm1 = en - ll;
00197 l = lm1 + 1;
00198 if (l == 1) {
00199 goto L95;
00200 }
00201 if ((d__1 = a[l + lm1 * a_dim1], abs(d__1)) <= epsa) {
00202 goto L90;
00203 }
00204 /* L80: */
00205 }
00206
00207 L90:
00208 a[l + lm1 * a_dim1] = 0.;
00209 if (l < na) {
00210 goto L95;
00211 }
00212 /* .......... 1-BY-1 OR 2-BY-2 BLOCK ISOLATED .......... */
00213 en = lm1;
00214 goto L60;
00215 /* .......... CHECK FOR SMALL TOP OF B .......... */
00216 L95:
00217 ld = l;
00218 L100:
00219 l1 = l + 1;
00220 b11 = b[l + l * b_dim1];
00221 if (abs(b11) > epsb) {
00222 goto L120;
00223 }
00224 b[l + l * b_dim1] = 0.;
00225 s = (d__1 = a[l + l * a_dim1], abs(d__1)) + (d__2 = a[l1 + l * a_dim1],
00226 abs(d__2));
00227 u1 = a[l + l * a_dim1] / s;
00228 u2 = a[l1 + l * a_dim1] / s;
00229 d__1 = sqrt(u1 * u1 + u2 * u2);
00230 r__ = d_sign(&d__1, &u1);
00231 v1 = -(u1 + r__) / r__;
00232 v2 = -u2 / r__;
00233 u2 = v2 / v1;
00234
00235 i__1 = enorn;
00236 for (j = l; j <= i__1; ++j) {
00237 t = a[l + j * a_dim1] + u2 * a[l1 + j * a_dim1];
00238 a[l + j * a_dim1] += t * v1;
00239 a[l1 + j * a_dim1] += t * v2;
00240 t = b[l + j * b_dim1] + u2 * b[l1 + j * b_dim1];
00241 b[l + j * b_dim1] += t * v1;
00242 b[l1 + j * b_dim1] += t * v2;
00243 /* L110: */
00244 }
00245
00246 if (l != 1) {
00247 a[l + lm1 * a_dim1] = -a[l + lm1 * a_dim1];
00248 }
00249 lm1 = l;
00250 l = l1;
00251 goto L90;
00252 L120:
00253 a11 = a[l + l * a_dim1] / b11;
00254 a21 = a[l1 + l * a_dim1] / b11;
00255 if (ish == 1) {
00256 goto L140;
00257 }
00258 /* .......... ITERATION STRATEGY .......... */
00259 if (itn == 0) {
00260 goto L1000;
00261 }
00262 if (its == 10) {
00263 goto L155;
00264 }
00265 /* .......... DETERMINE TYPE OF SHIFT .......... */
00266 b22 = b[l1 + l1 * b_dim1];
00267 if (abs(b22) < epsb) {
00268 b22 = epsb;
00269 }
00270 b33 = b[na + na * b_dim1];
00271 if (abs(b33) < epsb) {
00272 b33 = epsb;
00273 }
00274 b44 = b[en + en * b_dim1];
00275 if (abs(b44) < epsb) {
00276 b44 = epsb;
00277 }
00278 a33 = a[na + na * a_dim1] / b33;
00279 a34 = a[na + en * a_dim1] / b44;
00280 a43 = a[en + na * a_dim1] / b33;
00281 a44 = a[en + en * a_dim1] / b44;
00282 b34 = b[na + en * b_dim1] / b44;
00283 t = (a43 * b34 - a33 - a44) * .5;
00284 r__ = t * t + a34 * a43 - a33 * a44;
00285 if (r__ < 0.) {
00286 goto L150;
00287 }
00288 /* .......... DETERMINE SINGLE SHIFT ZEROTH COLUMN OF A .......... */
00289 ish = 1;
00290 r__ = sqrt(r__);
00291 sh = -t + r__;
00292 s = -t - r__;
00293 if ((d__1 = s - a44, abs(d__1)) < (d__2 = sh - a44, abs(d__2))) {
00294 sh = s;
00295 }
00296 /* .......... LOOK FOR TWO CONSECUTIVE SMALL */
00297 /* SUB-DIAGONAL ELEMENTS OF A. */
00298 /* FOR L=EN-2 STEP -1 UNTIL LD DO -- .......... */
00299 i__1 = enm2;
00300 for (ll = ld; ll <= i__1; ++ll) {
00301 l = enm2 + ld - ll;
00302 if (l == ld) {
00303 goto L140;
00304 }
00305 lm1 = l - 1;
00306 l1 = l + 1;
00307 t = a[l + l * a_dim1];
00308 if ((d__1 = b[l + l * b_dim1], abs(d__1)) > epsb) {
00309 t -= sh * b[l + l * b_dim1];
00310 }
00311 if ((d__1 = a[l + lm1 * a_dim1], abs(d__1)) <= (d__2 = t / a[l1 + l *
00312 a_dim1], abs(d__2)) * epsa) {
00313 goto L100;
00314 }
00315 /* L130: */
00316 }
00317
00318 L140:
00319 a1 = a11 - sh;
00320 a2 = a21;
00321 if (l != ld) {
00322 a[l + lm1 * a_dim1] = -a[l + lm1 * a_dim1];
00323 }
00324 goto L160;
00325 /* .......... DETERMINE DOUBLE SHIFT ZEROTH COLUMN OF A .......... */
00326 L150:
00327 a12 = a[l + l1 * a_dim1] / b22;
00328 a22 = a[l1 + l1 * a_dim1] / b22;
00329 b12 = b[l + l1 * b_dim1] / b22;
00330 a1 = ((a33 - a11) * (a44 - a11) - a34 * a43 + a43 * b34 * a11) / a21 +
00331 a12 - a11 * b12;
00332 a2 = a22 - a11 - a21 * b12 - (a33 - a11) - (a44 - a11) + a43 * b34;
00333 a3 = a[l1 + 1 + l1 * a_dim1] / b22;
00334 goto L160;
00335 /* .......... AD HOC SHIFT .......... */
00336 L155:
00337 a1 = 0.;
00338 a2 = 1.;
00339 a3 = 1.1605;
00340 L160:
00341 ++its;
00342 --itn;
00343 if (! (*matz)) {
00344 lor1 = ld;
00345 }
00346 /* .......... MAIN LOOP .......... */
00347 i__1 = na;
00348 for (k = l; k <= i__1; ++k) {
00349 notlas = k != na && ish == 2;
00350 k1 = k + 1;
00351 k2 = k + 2;
00352 /* Computing MAX */
00353 i__2 = k - 1;
00354 km1 = max(i__2,l);
00355 /* Computing MIN */
00356 i__2 = en, i__3 = k1 + ish;
00357 ll = min(i__2,i__3);
00358 if (notlas) {
00359 goto L190;
00360 }
00361 /* .......... ZERO A(K+1,K-1) .......... */
00362 if (k == l) {
00363 goto L170;
00364 }
00365 a1 = a[k + km1 * a_dim1];
00366 a2 = a[k1 + km1 * a_dim1];
00367 L170:
00368 s = abs(a1) + abs(a2);
00369 if (s == 0.) {
00370 goto L70;
00371 }
00372 u1 = a1 / s;
00373 u2 = a2 / s;
00374 d__1 = sqrt(u1 * u1 + u2 * u2);
00375 r__ = d_sign(&d__1, &u1);
00376 v1 = -(u1 + r__) / r__;
00377 v2 = -u2 / r__;
00378 u2 = v2 / v1;
00379
00380 i__2 = enorn;
00381 for (j = km1; j <= i__2; ++j) {
00382 t = a[k + j * a_dim1] + u2 * a[k1 + j * a_dim1];
00383 a[k + j * a_dim1] += t * v1;
00384 a[k1 + j * a_dim1] += t * v2;
00385 t = b[k + j * b_dim1] + u2 * b[k1 + j * b_dim1];
00386 b[k + j * b_dim1] += t * v1;
00387 b[k1 + j * b_dim1] += t * v2;
00388 /* L180: */
00389 }
00390
00391 if (k != l) {
00392 a[k1 + km1 * a_dim1] = 0.;
00393 }
00394 goto L240;
00395 /* .......... ZERO A(K+1,K-1) AND A(K+2,K-1) .......... */
00396 L190:
00397 if (k == l) {
00398 goto L200;
00399 }
00400 a1 = a[k + km1 * a_dim1];
00401 a2 = a[k1 + km1 * a_dim1];
00402 a3 = a[k2 + km1 * a_dim1];
00403 L200:
00404 s = abs(a1) + abs(a2) + abs(a3);
00405 if (s == 0.) {
00406 goto L260;
00407 }
00408 u1 = a1 / s;
00409 u2 = a2 / s;
00410 u3 = a3 / s;
00411 d__1 = sqrt(u1 * u1 + u2 * u2 + u3 * u3);
00412 r__ = d_sign(&d__1, &u1);
00413 v1 = -(u1 + r__) / r__;
00414 v2 = -u2 / r__;
00415 v3 = -u3 / r__;
00416 u2 = v2 / v1;
00417 u3 = v3 / v1;
00418
00419 i__2 = enorn;
00420 for (j = km1; j <= i__2; ++j) {
00421 t = a[k + j * a_dim1] + u2 * a[k1 + j * a_dim1] + u3 * a[k2 + j *
00422 a_dim1];
00423 a[k + j * a_dim1] += t * v1;
00424 a[k1 + j * a_dim1] += t * v2;
00425 a[k2 + j * a_dim1] += t * v3;
00426 t = b[k + j * b_dim1] + u2 * b[k1 + j * b_dim1] + u3 * b[k2 + j *
00427 b_dim1];
00428 b[k + j * b_dim1] += t * v1;
00429 b[k1 + j * b_dim1] += t * v2;
00430 b[k2 + j * b_dim1] += t * v3;
00431 /* L210: */
00432 }
00433
00434 if (k == l) {
00435 goto L220;
00436 }
00437 a[k1 + km1 * a_dim1] = 0.;
00438 a[k2 + km1 * a_dim1] = 0.;
00439 /* .......... ZERO B(K+2,K+1) AND B(K+2,K) .......... */
00440 L220:
00441 s = (d__1 = b[k2 + k2 * b_dim1], abs(d__1)) + (d__2 = b[k2 + k1 *
00442 b_dim1], abs(d__2)) + (d__3 = b[k2 + k * b_dim1], abs(d__3));
00443 if (s == 0.) {
00444 goto L240;
00445 }
00446 u1 = b[k2 + k2 * b_dim1] / s;
00447 u2 = b[k2 + k1 * b_dim1] / s;
00448 u3 = b[k2 + k * b_dim1] / s;
00449 d__1 = sqrt(u1 * u1 + u2 * u2 + u3 * u3);
00450 r__ = d_sign(&d__1, &u1);
00451 v1 = -(u1 + r__) / r__;
00452 v2 = -u2 / r__;
00453 v3 = -u3 / r__;
00454 u2 = v2 / v1;
00455 u3 = v3 / v1;
00456
00457 i__2 = ll;
00458 for (i__ = lor1; i__ <= i__2; ++i__) {
00459 t = a[i__ + k2 * a_dim1] + u2 * a[i__ + k1 * a_dim1] + u3 * a[i__
00460 + k * a_dim1];
00461 a[i__ + k2 * a_dim1] += t * v1;
00462 a[i__ + k1 * a_dim1] += t * v2;
00463 a[i__ + k * a_dim1] += t * v3;
00464 t = b[i__ + k2 * b_dim1] + u2 * b[i__ + k1 * b_dim1] + u3 * b[i__
00465 + k * b_dim1];
00466 b[i__ + k2 * b_dim1] += t * v1;
00467 b[i__ + k1 * b_dim1] += t * v2;
00468 b[i__ + k * b_dim1] += t * v3;
00469 /* L230: */
00470 }
00471
00472 b[k2 + k * b_dim1] = 0.;
00473 b[k2 + k1 * b_dim1] = 0.;
00474 if (! (*matz)) {
00475 goto L240;
00476 }
00477
00478 i__2 = *n;
00479 for (i__ = 1; i__ <= i__2; ++i__) {
00480 t = z__[i__ + k2 * z_dim1] + u2 * z__[i__ + k1 * z_dim1] + u3 *
00481 z__[i__ + k * z_dim1];
00482 z__[i__ + k2 * z_dim1] += t * v1;
00483 z__[i__ + k1 * z_dim1] += t * v2;
00484 z__[i__ + k * z_dim1] += t * v3;
00485 /* L235: */
00486 }
00487 /* .......... ZERO B(K+1,K) .......... */
00488 L240:
00489 s = (d__1 = b[k1 + k1 * b_dim1], abs(d__1)) + (d__2 = b[k1 + k *
00490 b_dim1], abs(d__2));
00491 if (s == 0.) {
00492 goto L260;
00493 }
00494 u1 = b[k1 + k1 * b_dim1] / s;
00495 u2 = b[k1 + k * b_dim1] / s;
00496 d__1 = sqrt(u1 * u1 + u2 * u2);
00497 r__ = d_sign(&d__1, &u1);
00498 v1 = -(u1 + r__) / r__;
00499 v2 = -u2 / r__;
00500 u2 = v2 / v1;
00501
00502 i__2 = ll;
00503 for (i__ = lor1; i__ <= i__2; ++i__) {
00504 t = a[i__ + k1 * a_dim1] + u2 * a[i__ + k * a_dim1];
00505 a[i__ + k1 * a_dim1] += t * v1;
00506 a[i__ + k * a_dim1] += t * v2;
00507 t = b[i__ + k1 * b_dim1] + u2 * b[i__ + k * b_dim1];
00508 b[i__ + k1 * b_dim1] += t * v1;
00509 b[i__ + k * b_dim1] += t * v2;
00510 /* L250: */
00511 }
00512
00513 b[k1 + k * b_dim1] = 0.;
00514 if (! (*matz)) {
00515 goto L260;
00516 }
00517
00518 i__2 = *n;
00519 for (i__ = 1; i__ <= i__2; ++i__) {
00520 t = z__[i__ + k1 * z_dim1] + u2 * z__[i__ + k * z_dim1];
00521 z__[i__ + k1 * z_dim1] += t * v1;
00522 z__[i__ + k * z_dim1] += t * v2;
00523 /* L255: */
00524 }
00525
00526 L260:
00527 ;
00528 }
00529 /* .......... END QZ STEP .......... */
00530 goto L70;
00531 /* .......... SET ERROR -- ALL EIGENVALUES HAVE NOT */
00532 /* CONVERGED AFTER 30*N ITERATIONS .......... */
00533 L1000:
00534 *ierr = en;
00535 /* .......... SAVE EPSB FOR USE BY QZVAL AND QZVEC .......... */
00536 L1001:
00537 if (*n > 1) {
00538 b[*n + b_dim1] = epsb;
00539 }
00540 return 0;
00541 } /* qzit_ */
|
|
||||||||||||||||||||||||||||||||||||||||
|
Definition at line 8 of file eis_qzval.c. References a, a2, abs, d_sign(), and v1. Referenced by rgg_().
00011 {
00012 /* System generated locals */
00013 integer a_dim1, a_offset, b_dim1, b_offset, z_dim1, z_offset, i__1, i__2;
00014 doublereal d__1, d__2, d__3, d__4;
00015
00016 /* Builtin functions */
00017 double sqrt(doublereal), d_sign(doublereal *, doublereal *);
00018
00019 /* Local variables */
00020 static doublereal epsb, c__, d__, e;
00021 static integer i__, j;
00022 static doublereal r__, s, t, a1, a2, u1, u2, v1, v2, a11, a12, a21, a22,
00023 b11, b12, b22, di, ei;
00024 static integer na;
00025 static doublereal an, bn;
00026 static integer en;
00027 static doublereal cq, dr;
00028 static integer nn;
00029 static doublereal cz, ti, tr, a1i, a2i, a11i, a12i, a22i, a11r, a12r,
00030 a22r, sqi, ssi;
00031 static integer isw;
00032 static doublereal sqr, szi, ssr, szr;
00033
00034
00035
00036 /* THIS SUBROUTINE IS THE THIRD STEP OF THE QZ ALGORITHM */
00037 /* FOR SOLVING GENERALIZED MATRIX EIGENVALUE PROBLEMS, */
00038 /* SIAM J. NUMER. ANAL. 10, 241-256(1973) BY MOLER AND STEWART. */
00039
00040 /* THIS SUBROUTINE ACCEPTS A PAIR OF REAL MATRICES, ONE OF THEM */
00041 /* IN QUASI-TRIANGULAR FORM AND THE OTHER IN UPPER TRIANGULAR FORM. */
00042 /* IT REDUCES THE QUASI-TRIANGULAR MATRIX FURTHER, SO THAT ANY */
00043 /* REMAINING 2-BY-2 BLOCKS CORRESPOND TO PAIRS OF COMPLEX */
00044 /* EIGENVALUES, AND RETURNS QUANTITIES WHOSE RATIOS GIVE THE */
00045 /* GENERALIZED EIGENVALUES. IT IS USUALLY PRECEDED BY QZHES */
00046 /* AND QZIT AND MAY BE FOLLOWED BY QZVEC. */
00047
00048 /* ON INPUT */
00049
00050 /* NM MUST BE SET TO THE ROW DIMENSION OF TWO-DIMENSIONAL */
00051 /* ARRAY PARAMETERS AS DECLARED IN THE CALLING PROGRAM */
00052 /* DIMENSION STATEMENT. */
00053
00054 /* N IS THE ORDER OF THE MATRICES. */
00055
00056 /* A CONTAINS A REAL UPPER QUASI-TRIANGULAR MATRIX. */
00057
00058 /* B CONTAINS A REAL UPPER TRIANGULAR MATRIX. IN ADDITION, */
00059 /* LOCATION B(N,1) CONTAINS THE TOLERANCE QUANTITY (EPSB) */
00060 /* COMPUTED AND SAVED IN QZIT. */
00061
00062 /* MATZ SHOULD BE SET TO .TRUE. IF THE RIGHT HAND TRANSFORMATIONS
00063 */
00064 /* ARE TO BE ACCUMULATED FOR LATER USE IN COMPUTING */
00065 /* EIGENVECTORS, AND TO .FALSE. OTHERWISE. */
00066
00067 /* Z CONTAINS, IF MATZ HAS BEEN SET TO .TRUE., THE */
00068 /* TRANSFORMATION MATRIX PRODUCED IN THE REDUCTIONS BY QZHES */
00069 /* AND QZIT, IF PERFORMED, OR ELSE THE IDENTITY MATRIX. */
00070 /* IF MATZ HAS BEEN SET TO .FALSE., Z IS NOT REFERENCED. */
00071
00072 /* ON OUTPUT */
00073
00074 /* A HAS BEEN REDUCED FURTHER TO A QUASI-TRIANGULAR MATRIX */
00075 /* IN WHICH ALL NONZERO SUBDIAGONAL ELEMENTS CORRESPOND TO */
00076 /* PAIRS OF COMPLEX EIGENVALUES. */
00077
00078 /* B IS STILL IN UPPER TRIANGULAR FORM, ALTHOUGH ITS ELEMENTS */
00079 /* HAVE BEEN ALTERED. B(N,1) IS UNALTERED. */
00080
00081 /* ALFR AND ALFI CONTAIN THE REAL AND IMAGINARY PARTS OF THE */
00082 /* DIAGONAL ELEMENTS OF THE TRIANGULAR MATRIX THAT WOULD BE */
00083 /* OBTAINED IF A WERE REDUCED COMPLETELY TO TRIANGULAR FORM */
00084 /* BY UNITARY TRANSFORMATIONS. NON-ZERO VALUES OF ALFI OCCUR */
00085 /* IN PAIRS, THE FIRST MEMBER POSITIVE AND THE SECOND NEGATIVE.
00086 */
00087
00088 /* BETA CONTAINS THE DIAGONAL ELEMENTS OF THE CORRESPONDING B, */
00089 /* NORMALIZED TO BE REAL AND NON-NEGATIVE. THE GENERALIZED */
00090 /* EIGENVALUES ARE THEN THE RATIOS ((ALFR+I*ALFI)/BETA). */
00091
00092 /* Z CONTAINS THE PRODUCT OF THE RIGHT HAND TRANSFORMATIONS */
00093 /* (FOR ALL THREE STEPS) IF MATZ HAS BEEN SET TO .TRUE. */
00094
00095 /* QUESTIONS AND COMMENTS SHOULD BE DIRECTED TO BURTON S. GARBOW, */
00096 /* MATHEMATICS AND COMPUTER SCIENCE DIV, ARGONNE NATIONAL LABORATORY
00097 */
00098
00099 /* THIS VERSION DATED AUGUST 1983. */
00100
00101 /* ------------------------------------------------------------------
00102 */
00103
00104 /* Parameter adjustments */
00105 z_dim1 = *nm;
00106 z_offset = z_dim1 + 1;
00107 z__ -= z_offset;
00108 --beta;
00109 --alfi;
00110 --alfr;
00111 b_dim1 = *nm;
00112 b_offset = b_dim1 + 1;
00113 b -= b_offset;
00114 a_dim1 = *nm;
00115 a_offset = a_dim1 + 1;
00116 a -= a_offset;
00117
00118 /* Function Body */
00119 epsb = b[*n + b_dim1];
00120 isw = 1;
00121 /* .......... FIND EIGENVALUES OF QUASI-TRIANGULAR MATRICES. */
00122 /* FOR EN=N STEP -1 UNTIL 1 DO -- .......... */
00123 i__1 = *n;
00124 for (nn = 1; nn <= i__1; ++nn) {
00125 en = *n + 1 - nn;
00126 na = en - 1;
00127 if (isw == 2) {
00128 goto L505;
00129 }
00130 if (en == 1) {
00131 goto L410;
00132 }
00133 if (a[en + na * a_dim1] != 0.) {
00134 goto L420;
00135 }
00136 /* .......... 1-BY-1 BLOCK, ONE REAL ROOT .......... */
00137 L410:
00138 alfr[en] = a[en + en * a_dim1];
00139 if (b[en + en * b_dim1] < 0.) {
00140 alfr[en] = -alfr[en];
00141 }
00142 beta[en] = (d__1 = b[en + en * b_dim1], abs(d__1));
00143 alfi[en] = 0.;
00144 goto L510;
00145 /* .......... 2-BY-2 BLOCK .......... */
00146 L420:
00147 if ((d__1 = b[na + na * b_dim1], abs(d__1)) <= epsb) {
00148 goto L455;
00149 }
00150 if ((d__1 = b[en + en * b_dim1], abs(d__1)) > epsb) {
00151 goto L430;
00152 }
00153 a1 = a[en + en * a_dim1];
00154 a2 = a[en + na * a_dim1];
00155 bn = 0.;
00156 goto L435;
00157 L430:
00158 an = (d__1 = a[na + na * a_dim1], abs(d__1)) + (d__2 = a[na + en *
00159 a_dim1], abs(d__2)) + (d__3 = a[en + na * a_dim1], abs(d__3))
00160 + (d__4 = a[en + en * a_dim1], abs(d__4));
00161 bn = (d__1 = b[na + na * b_dim1], abs(d__1)) + (d__2 = b[na + en *
00162 b_dim1], abs(d__2)) + (d__3 = b[en + en * b_dim1], abs(d__3));
00163 a11 = a[na + na * a_dim1] / an;
00164 a12 = a[na + en * a_dim1] / an;
00165 a21 = a[en + na * a_dim1] / an;
00166 a22 = a[en + en * a_dim1] / an;
00167 b11 = b[na + na * b_dim1] / bn;
00168 b12 = b[na + en * b_dim1] / bn;
00169 b22 = b[en + en * b_dim1] / bn;
00170 e = a11 / b11;
00171 ei = a22 / b22;
00172 s = a21 / (b11 * b22);
00173 t = (a22 - e * b22) / b22;
00174 if (abs(e) <= abs(ei)) {
00175 goto L431;
00176 }
00177 e = ei;
00178 t = (a11 - e * b11) / b11;
00179 L431:
00180 c__ = (t - s * b12) * .5;
00181 d__ = c__ * c__ + s * (a12 - e * b12);
00182 if (d__ < 0.) {
00183 goto L480;
00184 }
00185 /* .......... TWO REAL ROOTS. */
00186 /* ZERO BOTH A(EN,NA) AND B(EN,NA) .......... */
00187 d__1 = sqrt(d__);
00188 e += c__ + d_sign(&d__1, &c__);
00189 a11 -= e * b11;
00190 a12 -= e * b12;
00191 a22 -= e * b22;
00192 if (abs(a11) + abs(a12) < abs(a21) + abs(a22)) {
00193 goto L432;
00194 }
00195 a1 = a12;
00196 a2 = a11;
00197 goto L435;
00198 L432:
00199 a1 = a22;
00200 a2 = a21;
00201 /* .......... CHOOSE AND APPLY REAL Z .......... */
00202 L435:
00203 s = abs(a1) + abs(a2);
00204 u1 = a1 / s;
00205 u2 = a2 / s;
00206 d__1 = sqrt(u1 * u1 + u2 * u2);
00207 r__ = d_sign(&d__1, &u1);
00208 v1 = -(u1 + r__) / r__;
00209 v2 = -u2 / r__;
00210 u2 = v2 / v1;
00211
00212 i__2 = en;
00213 for (i__ = 1; i__ <= i__2; ++i__) {
00214 t = a[i__ + en * a_dim1] + u2 * a[i__ + na * a_dim1];
00215 a[i__ + en * a_dim1] += t * v1;
00216 a[i__ + na * a_dim1] += t * v2;
00217 t = b[i__ + en * b_dim1] + u2 * b[i__ + na * b_dim1];
00218 b[i__ + en * b_dim1] += t * v1;
00219 b[i__ + na * b_dim1] += t * v2;
00220 /* L440: */
00221 }
00222
00223 if (! (*matz)) {
00224 goto L450;
00225 }
00226
00227 i__2 = *n;
00228 for (i__ = 1; i__ <= i__2; ++i__) {
00229 t = z__[i__ + en * z_dim1] + u2 * z__[i__ + na * z_dim1];
00230 z__[i__ + en * z_dim1] += t * v1;
00231 z__[i__ + na * z_dim1] += t * v2;
00232 /* L445: */
00233 }
00234
00235 L450:
00236 if (bn == 0.) {
00237 goto L475;
00238 }
00239 if (an < abs(e) * bn) {
00240 goto L455;
00241 }
00242 a1 = b[na + na * b_dim1];
00243 a2 = b[en + na * b_dim1];
00244 goto L460;
00245 L455:
00246 a1 = a[na + na * a_dim1];
00247 a2 = a[en + na * a_dim1];
00248 /* .......... CHOOSE AND APPLY REAL Q .......... */
00249 L460:
00250 s = abs(a1) + abs(a2);
00251 if (s == 0.) {
00252 goto L475;
00253 }
00254 u1 = a1 / s;
00255 u2 = a2 / s;
00256 d__1 = sqrt(u1 * u1 + u2 * u2);
00257 r__ = d_sign(&d__1, &u1);
00258 v1 = -(u1 + r__) / r__;
00259 v2 = -u2 / r__;
00260 u2 = v2 / v1;
00261
00262 i__2 = *n;
00263 for (j = na; j <= i__2; ++j) {
00264 t = a[na + j * a_dim1] + u2 * a[en + j * a_dim1];
00265 a[na + j * a_dim1] += t * v1;
00266 a[en + j * a_dim1] += t * v2;
00267 t = b[na + j * b_dim1] + u2 * b[en + j * b_dim1];
00268 b[na + j * b_dim1] += t * v1;
00269 b[en + j * b_dim1] += t * v2;
00270 /* L470: */
00271 }
00272
00273 L475:
00274 a[en + na * a_dim1] = 0.;
00275 b[en + na * b_dim1] = 0.;
00276 alfr[na] = a[na + na * a_dim1];
00277 alfr[en] = a[en + en * a_dim1];
00278 if (b[na + na * b_dim1] < 0.) {
00279 alfr[na] = -alfr[na];
00280 }
00281 if (b[en + en * b_dim1] < 0.) {
00282 alfr[en] = -alfr[en];
00283 }
00284 beta[na] = (d__1 = b[na + na * b_dim1], abs(d__1));
00285 beta[en] = (d__1 = b[en + en * b_dim1], abs(d__1));
00286 alfi[en] = 0.;
00287 alfi[na] = 0.;
00288 goto L505;
00289 /* .......... TWO COMPLEX ROOTS .......... */
00290 L480:
00291 e += c__;
00292 ei = sqrt(-d__);
00293 a11r = a11 - e * b11;
00294 a11i = ei * b11;
00295 a12r = a12 - e * b12;
00296 a12i = ei * b12;
00297 a22r = a22 - e * b22;
00298 a22i = ei * b22;
00299 if (abs(a11r) + abs(a11i) + abs(a12r) + abs(a12i) < abs(a21) + abs(
00300 a22r) + abs(a22i)) {
00301 goto L482;
00302 }
00303 a1 = a12r;
00304 a1i = a12i;
00305 a2 = -a11r;
00306 a2i = -a11i;
00307 goto L485;
00308 L482:
00309 a1 = a22r;
00310 a1i = a22i;
00311 a2 = -a21;
00312 a2i = 0.;
00313 /* .......... CHOOSE COMPLEX Z .......... */
00314 L485:
00315 cz = sqrt(a1 * a1 + a1i * a1i);
00316 if (cz == 0.) {
00317 goto L487;
00318 }
00319 szr = (a1 * a2 + a1i * a2i) / cz;
00320 szi = (a1 * a2i - a1i * a2) / cz;
00321 r__ = sqrt(cz * cz + szr * szr + szi * szi);
00322 cz /= r__;
00323 szr /= r__;
00324 szi /= r__;
00325 goto L490;
00326 L487:
00327 szr = 1.;
00328 szi = 0.;
00329 L490:
00330 if (an < (abs(e) + ei) * bn) {
00331 goto L492;
00332 }
00333 a1 = cz * b11 + szr * b12;
00334 a1i = szi * b12;
00335 a2 = szr * b22;
00336 a2i = szi * b22;
00337 goto L495;
00338 L492:
00339 a1 = cz * a11 + szr * a12;
00340 a1i = szi * a12;
00341 a2 = cz * a21 + szr * a22;
00342 a2i = szi * a22;
00343 /* .......... CHOOSE COMPLEX Q .......... */
00344 L495:
00345 cq = sqrt(a1 * a1 + a1i * a1i);
00346 if (cq == 0.) {
00347 goto L497;
00348 }
00349 sqr = (a1 * a2 + a1i * a2i) / cq;
00350 sqi = (a1 * a2i - a1i * a2) / cq;
00351 r__ = sqrt(cq * cq + sqr * sqr + sqi * sqi);
00352 cq /= r__;
00353 sqr /= r__;
00354 sqi /= r__;
00355 goto L500;
00356 L497:
00357 sqr = 1.;
00358 sqi = 0.;
00359 /* .......... COMPUTE DIAGONAL ELEMENTS THAT WOULD RESULT */
00360 /* IF TRANSFORMATIONS WERE APPLIED .......... */
00361 L500:
00362 ssr = sqr * szr + sqi * szi;
00363 ssi = sqr * szi - sqi * szr;
00364 i__ = 1;
00365 tr = cq * cz * a11 + cq * szr * a12 + sqr * cz * a21 + ssr * a22;
00366 ti = cq * szi * a12 - sqi * cz * a21 + ssi * a22;
00367 dr = cq * cz * b11 + cq * szr * b12 + ssr * b22;
00368 di = cq * szi * b12 + ssi * b22;
00369 goto L503;
00370 L502:
00371 i__ = 2;
00372 tr = ssr * a11 - sqr * cz * a12 - cq * szr * a21 + cq * cz * a22;
00373 ti = -ssi * a11 - sqi * cz * a12 + cq * szi * a21;
00374 dr = ssr * b11 - sqr * cz * b12 + cq * cz * b22;
00375 di = -ssi * b11 - sqi * cz * b12;
00376 L503:
00377 t = ti * dr - tr * di;
00378 j = na;
00379 if (t < 0.) {
00380 j = en;
00381 }
00382 r__ = sqrt(dr * dr + di * di);
00383 beta[j] = bn * r__;
00384 alfr[j] = an * (tr * dr + ti * di) / r__;
00385 alfi[j] = an * t / r__;
00386 if (i__ == 1) {
00387 goto L502;
00388 }
00389 L505:
00390 isw = 3 - isw;
00391 L510:
00392 ;
00393 }
00394 b[*n + b_dim1] = epsb;
00395
00396 return 0;
00397 } /* qzval_ */
|
|
||||||||||||||||||||||||||||||||||||
|
Definition at line 8 of file eis_qzvec.c. Referenced by rgg_().
00011 {
00012 /* System generated locals */
00013 integer a_dim1, a_offset, b_dim1, b_offset, z_dim1, z_offset, i__1, i__2,
00014 i__3;
00015 doublereal d__1, d__2;
00016
00017 /* Builtin functions */
00018 double sqrt(doublereal);
00019
00020 /* Local variables */
00021 static doublereal alfm, almi, betm, epsb, almr, d__;
00022 static integer i__, j, k, m;
00023 static doublereal q, r__, s, t, w, x, y, t1, t2, w1, x1, z1, di;
00024 static integer na, ii, en, jj;
00025 static doublereal ra, dr, sa;
00026 static integer nn;
00027 static doublereal ti, rr, tr, zz;
00028 static integer isw, enm2;
00029
00030
00031
00032 /* THIS SUBROUTINE IS THE OPTIONAL FOURTH STEP OF THE QZ ALGORITHM */
00033 /* FOR SOLVING GENERALIZED MATRIX EIGENVALUE PROBLEMS, */
00034 /* SIAM J. NUMER. ANAL. 10, 241-256(1973) BY MOLER AND STEWART. */
00035
00036 /* THIS SUBROUTINE ACCEPTS A PAIR OF REAL MATRICES, ONE OF THEM IN */
00037 /* QUASI-TRIANGULAR FORM (IN WHICH EACH 2-BY-2 BLOCK CORRESPONDS TO */
00038 /* A PAIR OF COMPLEX EIGENVALUES) AND THE OTHER IN UPPER TRIANGULAR */
00039 /* FORM. IT COMPUTES THE EIGENVECTORS OF THE TRIANGULAR PROBLEM AND
00040 */
00041 /* TRANSFORMS THE RESULTS BACK TO THE ORIGINAL COORDINATE SYSTEM. */
00042 /* IT IS USUALLY PRECEDED BY QZHES, QZIT, AND QZVAL. */
00043
00044 /* ON INPUT */
00045
00046 /* NM MUST BE SET TO THE ROW DIMENSION OF TWO-DIMENSIONAL */
00047 /* ARRAY PARAMETERS AS DECLARED IN THE CALLING PROGRAM */
00048 /* DIMENSION STATEMENT. */
00049
00050 /* N IS THE ORDER OF THE MATRICES. */
00051
00052 /* A CONTAINS A REAL UPPER QUASI-TRIANGULAR MATRIX. */
00053
00054 /* B CONTAINS A REAL UPPER TRIANGULAR MATRIX. IN ADDITION, */
00055 /* LOCATION B(N,1) CONTAINS THE TOLERANCE QUANTITY (EPSB) */
00056 /* COMPUTED AND SAVED IN QZIT. */
00057
00058 /* ALFR, ALFI, AND BETA ARE VECTORS WITH COMPONENTS WHOSE */
00059 /* RATIOS ((ALFR+I*ALFI)/BETA) ARE THE GENERALIZED */
00060 /* EIGENVALUES. THEY ARE USUALLY OBTAINED FROM QZVAL. */
00061
00062 /* Z CONTAINS THE TRANSFORMATION MATRIX PRODUCED IN THE */
00063 /* REDUCTIONS BY QZHES, QZIT, AND QZVAL, IF PERFORMED. */
00064 /* IF THE EIGENVECTORS OF THE TRIANGULAR PROBLEM ARE */
00065 /* DESIRED, Z MUST CONTAIN THE IDENTITY MATRIX. */
00066
00067 /* ON OUTPUT */
00068
00069 /* A IS UNALTERED. ITS SUBDIAGONAL ELEMENTS PROVIDE INFORMATION */
00070 /* ABOUT THE STORAGE OF THE COMPLEX EIGENVECTORS. */
00071
00072 /* B HAS BEEN DESTROYED. */
00073
00074 /* ALFR, ALFI, AND BETA ARE UNALTERED. */
00075
00076 /* Z CONTAINS THE REAL AND IMAGINARY PARTS OF THE EIGENVECTORS. */
00077 /* IF ALFI(I) .EQ. 0.0, THE I-TH EIGENVALUE IS REAL AND */
00078 /* THE I-TH COLUMN OF Z CONTAINS ITS EIGENVECTOR. */
00079 /* IF ALFI(I) .NE. 0.0, THE I-TH EIGENVALUE IS COMPLEX. */
00080 /* IF ALFI(I) .GT. 0.0, THE EIGENVALUE IS THE FIRST OF */
00081 /* A COMPLEX PAIR AND THE I-TH AND (I+1)-TH COLUMNS */
00082 /* OF Z CONTAIN ITS EIGENVECTOR. */
00083 /* IF ALFI(I) .LT. 0.0, THE EIGENVALUE IS THE SECOND OF */
00084 /* A COMPLEX PAIR AND THE (I-1)-TH AND I-TH COLUMNS */
00085 /* OF Z CONTAIN THE CONJUGATE OF ITS EIGENVECTOR. */
00086 /* EACH EIGENVECTOR IS NORMALIZED SO THAT THE MODULUS */
00087 /* OF ITS LARGEST COMPONENT IS 1.0 . */
00088
00089 /* QUESTIONS AND COMMENTS SHOULD BE DIRECTED TO BURTON S. GARBOW, */
00090 /* MATHEMATICS AND COMPUTER SCIENCE DIV, ARGONNE NATIONAL LABORATORY
00091 */
00092
00093 /* THIS VERSION DATED AUGUST 1983. */
00094
00095 /* ------------------------------------------------------------------
00096 */
00097
00098 /* Parameter adjustments */
00099 z_dim1 = *nm;
00100 z_offset = z_dim1 + 1;
00101 z__ -= z_offset;
00102 --beta;
00103 --alfi;
00104 --alfr;
00105 b_dim1 = *nm;
00106 b_offset = b_dim1 + 1;
00107 b -= b_offset;
00108 a_dim1 = *nm;
00109 a_offset = a_dim1 + 1;
00110 a -= a_offset;
00111
00112 /* Function Body */
00113 epsb = b[*n + b_dim1];
00114 isw = 1;
00115 /* .......... FOR EN=N STEP -1 UNTIL 1 DO -- .......... */
00116 i__1 = *n;
00117 for (nn = 1; nn <= i__1; ++nn) {
00118 en = *n + 1 - nn;
00119 na = en - 1;
00120 if (isw == 2) {
00121 goto L795;
00122 }
00123 if (alfi[en] != 0.) {
00124 goto L710;
00125 }
00126 /* .......... REAL VECTOR .......... */
00127 m = en;
00128 b[en + en * b_dim1] = 1.;
00129 if (na == 0) {
00130 goto L800;
00131 }
00132 alfm = alfr[m];
00133 betm = beta[m];
00134 /* .......... FOR I=EN-1 STEP -1 UNTIL 1 DO -- .......... */
00135 i__2 = na;
00136 for (ii = 1; ii <= i__2; ++ii) {
00137 i__ = en - ii;
00138 w = betm * a[i__ + i__ * a_dim1] - alfm * b[i__ + i__ * b_dim1];
00139 r__ = 0.;
00140
00141 i__3 = en;
00142 for (j = m; j <= i__3; ++j) {
00143 /* L610: */
00144 r__ += (betm * a[i__ + j * a_dim1] - alfm * b[i__ + j *
00145 b_dim1]) * b[j + en * b_dim1];
00146 }
00147
00148 if (i__ == 1 || isw == 2) {
00149 goto L630;
00150 }
00151 if (betm * a[i__ + (i__ - 1) * a_dim1] == 0.) {
00152 goto L630;
00153 }
00154 zz = w;
00155 s = r__;
00156 goto L690;
00157 L630:
00158 m = i__;
00159 if (isw == 2) {
00160 goto L640;
00161 }
00162 /* .......... REAL 1-BY-1 BLOCK .......... */
00163 t = w;
00164 if (w == 0.) {
00165 t = epsb;
00166 }
00167 b[i__ + en * b_dim1] = -r__ / t;
00168 goto L700;
00169 /* .......... REAL 2-BY-2 BLOCK .......... */
00170 L640:
00171 x = betm * a[i__ + (i__ + 1) * a_dim1] - alfm * b[i__ + (i__ + 1)
00172 * b_dim1];
00173 y = betm * a[i__ + 1 + i__ * a_dim1];
00174 q = w * zz - x * y;
00175 t = (x * s - zz * r__) / q;
00176 b[i__ + en * b_dim1] = t;
00177 if (abs(x) <= abs(zz)) {
00178 goto L650;
00179 }
00180 b[i__ + 1 + en * b_dim1] = (-r__ - w * t) / x;
00181 goto L690;
00182 L650:
00183 b[i__ + 1 + en * b_dim1] = (-s - y * t) / zz;
00184 L690:
00185 isw = 3 - isw;
00186 L700:
00187 ;
00188 }
00189 /* .......... END REAL VECTOR .......... */
00190 goto L800;
00191 /* .......... COMPLEX VECTOR .......... */
00192 L710:
00193 m = na;
00194 almr = alfr[m];
00195 almi = alfi[m];
00196 betm = beta[m];
00197 /* .......... LAST VECTOR COMPONENT CHOSEN IMAGINARY SO THAT */
00198 /* EIGENVECTOR MATRIX IS TRIANGULAR .......... */
00199 y = betm * a[en + na * a_dim1];
00200 b[na + na * b_dim1] = -almi * b[en + en * b_dim1] / y;
00201 b[na + en * b_dim1] = (almr * b[en + en * b_dim1] - betm * a[en + en *
00202 a_dim1]) / y;
00203 b[en + na * b_dim1] = 0.;
00204 b[en + en * b_dim1] = 1.;
00205 enm2 = na - 1;
00206 if (enm2 == 0) {
00207 goto L795;
00208 }
00209 /* .......... FOR I=EN-2 STEP -1 UNTIL 1 DO -- .......... */
00210 i__2 = enm2;
00211 for (ii = 1; ii <= i__2; ++ii) {
00212 i__ = na - ii;
00213 w = betm * a[i__ + i__ * a_dim1] - almr * b[i__ + i__ * b_dim1];
00214 w1 = -almi * b[i__ + i__ * b_dim1];
00215 ra = 0.;
00216 sa = 0.;
00217
00218 i__3 = en;
00219 for (j = m; j <= i__3; ++j) {
00220 x = betm * a[i__ + j * a_dim1] - almr * b[i__ + j * b_dim1];
00221 x1 = -almi * b[i__ + j * b_dim1];
00222 ra = ra + x * b[j + na * b_dim1] - x1 * b[j + en * b_dim1];
00223 sa = sa + x * b[j + en * b_dim1] + x1 * b[j + na * b_dim1];
00224 /* L760: */
00225 }
00226
00227 if (i__ == 1 || isw == 2) {
00228 goto L770;
00229 }
00230 if (betm * a[i__ + (i__ - 1) * a_dim1] == 0.) {
00231 goto L770;
00232 }
00233 zz = w;
00234 z1 = w1;
00235 r__ = ra;
00236 s = sa;
00237 isw = 2;
00238 goto L790;
00239 L770:
00240 m = i__;
00241 if (isw == 2) {
00242 goto L780;
00243 }
00244 /* .......... COMPLEX 1-BY-1 BLOCK .......... */
00245 tr = -ra;
00246 ti = -sa;
00247 L773:
00248 dr = w;
00249 di = w1;
00250 /* .......... COMPLEX DIVIDE (T1,T2) = (TR,TI) / (DR,DI) .....
00251 ..... */
00252 L775:
00253 if (abs(di) > abs(dr)) {
00254 goto L777;
00255 }
00256 rr = di / dr;
00257 d__ = dr + di * rr;
00258 t1 = (tr + ti * rr) / d__;
00259 t2 = (ti - tr * rr) / d__;
00260 switch (isw) {
00261 case 1: goto L787;
00262 case 2: goto L782;
00263 }
00264 L777:
00265 rr = dr / di;
00266 d__ = dr * rr + di;
00267 t1 = (tr * rr + ti) / d__;
00268 t2 = (ti * rr - tr) / d__;
00269 switch (isw) {
00270 case 1: goto L787;
00271 case 2: goto L782;
00272 }
00273 /* .......... COMPLEX 2-BY-2 BLOCK .......... */
00274 L780:
00275 x = betm * a[i__ + (i__ + 1) * a_dim1] - almr * b[i__ + (i__ + 1)
00276 * b_dim1];
00277 x1 = -almi * b[i__ + (i__ + 1) * b_dim1];
00278 y = betm * a[i__ + 1 + i__ * a_dim1];
00279 tr = y * ra - w * r__ + w1 * s;
00280 ti = y * sa - w * s - w1 * r__;
00281 dr = w * zz - w1 * z1 - x * y;
00282 di = w * z1 + w1 * zz - x1 * y;
00283 if (dr == 0. && di == 0.) {
00284 dr = epsb;
00285 }
00286 goto L775;
00287 L782:
00288 b[i__ + 1 + na * b_dim1] = t1;
00289 b[i__ + 1 + en * b_dim1] = t2;
00290 isw = 1;
00291 if (abs(y) > abs(w) + abs(w1)) {
00292 goto L785;
00293 }
00294 tr = -ra - x * b[i__ + 1 + na * b_dim1] + x1 * b[i__ + 1 + en *
00295 b_dim1];
00296 ti = -sa - x * b[i__ + 1 + en * b_dim1] - x1 * b[i__ + 1 + na *
00297 b_dim1];
00298 goto L773;
00299 L785:
00300 t1 = (-r__ - zz * b[i__ + 1 + na * b_dim1] + z1 * b[i__ + 1 + en *
00301 b_dim1]) / y;
00302 t2 = (-s - zz * b[i__ + 1 + en * b_dim1] - z1 * b[i__ + 1 + na *
00303 b_dim1]) / y;
00304 L787:
00305 b[i__ + na * b_dim1] = t1;
00306 b[i__ + en * b_dim1] = t2;
00307 L790:
00308 ;
00309 }
00310 /* .......... END COMPLEX VECTOR .......... */
00311 L795:
00312 isw = 3 - isw;
00313 L800:
00314 ;
00315 }
00316 /* .......... END BACK SUBSTITUTION. */
00317 /* TRANSFORM TO ORIGINAL COORDINATE SYSTEM. */
00318 /* FOR J=N STEP -1 UNTIL 1 DO -- .......... */
00319 i__1 = *n;
00320 for (jj = 1; jj <= i__1; ++jj) {
00321 j = *n + 1 - jj;
00322
00323 i__2 = *n;
00324 for (i__ = 1; i__ <= i__2; ++i__) {
00325 zz = 0.;
00326
00327 i__3 = j;
00328 for (k = 1; k <= i__3; ++k) {
00329 /* L860: */
00330 zz += z__[i__ + k * z_dim1] * b[k + j * b_dim1];
00331 }
00332
00333 z__[i__ + j * z_dim1] = zz;
00334 /* L880: */
00335 }
00336 }
00337 /* .......... NORMALIZE SO THAT MODULUS OF LARGEST */
00338 /* COMPONENT OF EACH VECTOR IS 1. */
00339 /* (ISW IS 1 INITIALLY FROM BEFORE) .......... */
00340 i__2 = *n;
00341 for (j = 1; j <= i__2; ++j) {
00342 d__ = 0.;
00343 if (isw == 2) {
00344 goto L920;
00345 }
00346 if (alfi[j] != 0.) {
00347 goto L945;
00348 }
00349
00350 i__1 = *n;
00351 for (i__ = 1; i__ <= i__1; ++i__) {
00352 if ((d__1 = z__[i__ + j * z_dim1], abs(d__1)) > d__) {
00353 d__ = (d__2 = z__[i__ + j * z_dim1], abs(d__2));
00354 }
00355 /* L890: */
00356 }
00357
00358 i__1 = *n;
00359 for (i__ = 1; i__ <= i__1; ++i__) {
00360 /* L900: */
00361 z__[i__ + j * z_dim1] /= d__;
00362 }
00363
00364 goto L950;
00365
00366 L920:
00367 i__1 = *n;
00368 for (i__ = 1; i__ <= i__1; ++i__) {
00369 r__ = (d__1 = z__[i__ + (j - 1) * z_dim1], abs(d__1)) + (d__2 =
00370 z__[i__ + j * z_dim1], abs(d__2));
00371 if (r__ != 0.) {
00372 /* Computing 2nd power */
00373 d__1 = z__[i__ + (j - 1) * z_dim1] / r__;
00374 /* Computing 2nd power */
00375 d__2 = z__[i__ + j * z_dim1] / r__;
00376 r__ *= sqrt(d__1 * d__1 + d__2 * d__2);
00377 }
00378 if (r__ > d__) {
00379 d__ = r__;
00380 }
00381 /* L930: */
00382 }
00383
00384 i__1 = *n;
00385 for (i__ = 1; i__ <= i__1; ++i__) {
00386 z__[i__ + (j - 1) * z_dim1] /= d__;
00387 z__[i__ + j * z_dim1] /= d__;
00388 /* L940: */
00389 }
00390
00391 L945:
00392 isw = 3 - isw;
00393 L950:
00394 ;
00395 }
00396
00397 return 0;
00398 } /* qzvec_ */
|
|
||||||||||||||||||||||||||||||||||||||||||||||||||||
|
Definition at line 8 of file eis_ratqr.c. References abs, ep, epslon_(), ind, min, p, and q.
00011 {
00012 /* System generated locals */
00013 integer i__1, i__2;
00014 doublereal d__1, d__2, d__3;
00015
00016 /* Local variables */
00017 static integer jdef;
00018 static doublereal f;
00019 static integer i__, j, k;
00020 static doublereal p, q, r__, s, delta;
00021 static integer k1, ii, jj;
00022 static doublereal ep, qp;
00023 extern doublereal epslon_(doublereal *);
00024 static doublereal err, tot;
00025
00026
00027
00028 /* THIS SUBROUTINE IS A TRANSLATION OF THE ALGOL PROCEDURE RATQR, */
00029 /* NUM. MATH. 11, 264-272(1968) BY REINSCH AND BAUER. */
00030 /* HANDBOOK FOR AUTO. COMP., VOL.II-LINEAR ALGEBRA, 257-265(1971). */
00031
00032 /* THIS SUBROUTINE FINDS THE ALGEBRAICALLY SMALLEST OR LARGEST */
00033 /* EIGENVALUES OF A SYMMETRIC TRIDIAGONAL MATRIX BY THE */
00034 /* RATIONAL QR METHOD WITH NEWTON CORRECTIONS. */
00035
00036 /* ON INPUT */
00037
00038 /* N IS THE ORDER OF THE MATRIX. */
00039
00040 /* EPS1 IS A THEORETICAL ABSOLUTE ERROR TOLERANCE FOR THE */
00041 /* COMPUTED EIGENVALUES. IF THE INPUT EPS1 IS NON-POSITIVE, */
00042 /* OR INDEED SMALLER THAN ITS DEFAULT VALUE, IT IS RESET */
00043 /* AT EACH ITERATION TO THE RESPECTIVE DEFAULT VALUE, */
00044 /* NAMELY, THE PRODUCT OF THE RELATIVE MACHINE PRECISION */
00045 /* AND THE MAGNITUDE OF THE CURRENT EIGENVALUE ITERATE. */
00046 /* THE THEORETICAL ABSOLUTE ERROR IN THE K-TH EIGENVALUE */
00047 /* IS USUALLY NOT GREATER THAN K TIMES EPS1. */
00048
00049 /* D CONTAINS THE DIAGONAL ELEMENTS OF THE INPUT MATRIX. */
00050
00051 /* E CONTAINS THE SUBDIAGONAL ELEMENTS OF THE INPUT MATRIX */
00052 /* IN ITS LAST N-1 POSITIONS. E(1) IS ARBITRARY. */
00053
00054 /* E2 CONTAINS THE SQUARES OF THE CORRESPONDING ELEMENTS OF E. */
00055 /* E2(1) IS ARBITRARY. */
00056
00057 /* M IS THE NUMBER OF EIGENVALUES TO BE FOUND. */
00058
00059 /* IDEF SHOULD BE SET TO 1 IF THE INPUT MATRIX IS KNOWN TO BE */
00060 /* POSITIVE DEFINITE, TO -1 IF THE INPUT MATRIX IS KNOWN TO */
00061 /* BE NEGATIVE DEFINITE, AND TO 0 OTHERWISE. */
00062
00063 /* TYPE SHOULD BE SET TO .TRUE. IF THE SMALLEST EIGENVALUES */
00064 /* ARE TO BE FOUND, AND TO .FALSE. IF THE LARGEST EIGENVALUES */
00065 /* ARE TO BE FOUND. */
00066
00067 /* ON OUTPUT */
00068
00069 /* EPS1 IS UNALTERED UNLESS IT HAS BEEN RESET TO ITS */
00070 /* (LAST) DEFAULT VALUE. */
00071
00072 /* D AND E ARE UNALTERED (UNLESS W OVERWRITES D). */
00073
00074 /* ELEMENTS OF E2, CORRESPONDING TO ELEMENTS OF E REGARDED */
00075 /* AS NEGLIGIBLE, HAVE BEEN REPLACED BY ZERO CAUSING THE */
00076 /* MATRIX TO SPLIT INTO A DIRECT SUM OF SUBMATRICES. */
00077 /* E2(1) IS SET TO 0.0D0 IF THE SMALLEST EIGENVALUES HAVE BEEN */
00078 /* FOUND, AND TO 2.0D0 IF THE LARGEST EIGENVALUES HAVE BEEN */
00079 /* FOUND. E2 IS OTHERWISE UNALTERED (UNLESS OVERWRITTEN BY BD).
00080 */
00081
00082 /* W CONTAINS THE M ALGEBRAICALLY SMALLEST EIGENVALUES IN */
00083 /* ASCENDING ORDER, OR THE M LARGEST EIGENVALUES IN */
00084 /* DESCENDING ORDER. IF AN ERROR EXIT IS MADE BECAUSE OF */
00085 /* AN INCORRECT SPECIFICATION OF IDEF, NO EIGENVALUES */
00086 /* ARE FOUND. IF THE NEWTON ITERATES FOR A PARTICULAR */
00087 /* EIGENVALUE ARE NOT MONOTONE, THE BEST ESTIMATE OBTAINED */
00088 /* IS RETURNED AND IERR IS SET. W MAY COINCIDE WITH D. */
00089
00090 /* IND CONTAINS IN ITS FIRST M POSITIONS THE SUBMATRIX INDICES */
00091 /* ASSOCIATED WITH THE CORRESPONDING EIGENVALUES IN W -- */
00092 /* 1 FOR EIGENVALUES BELONGING TO THE FIRST SUBMATRIX FROM */
00093 /* THE TOP, 2 FOR THOSE BELONGING TO THE SECOND SUBMATRIX, ETC..
00094 */
00095
00096 /* BD CONTAINS REFINED BOUNDS FOR THE THEORETICAL ERRORS OF THE */
00097 /* CORRESPONDING EIGENVALUES IN W. THESE BOUNDS ARE USUALLY */
00098 /* WITHIN THE TOLERANCE SPECIFIED BY EPS1. BD MAY COINCIDE */
00099 /* WITH E2. */
00100
00101 /* IERR IS SET TO */
00102 /* ZERO FOR NORMAL RETURN, */
00103 /* 6*N+1 IF IDEF IS SET TO 1 AND TYPE TO .TRUE. */
00104 /* WHEN THE MATRIX IS NOT POSITIVE DEFINITE, OR */
00105 /* IF IDEF IS SET TO -1 AND TYPE TO .FALSE. */
00106 /* WHEN THE MATRIX IS NOT NEGATIVE DEFINITE, */
00107 /* 5*N+K IF SUCCESSIVE ITERATES TO THE K-TH EIGENVALUE */
00108 /* ARE NOT MONOTONE INCREASING, WHERE K REFERS */
00109 /* TO THE LAST SUCH OCCURRENCE. */
00110
00111 /* NOTE THAT SUBROUTINE TRIDIB IS GENERALLY FASTER AND MORE */
00112 /* ACCURATE THAN RATQR IF THE EIGENVALUES ARE CLUSTERED. */
00113
00114 /* QUESTIONS AND COMMENTS SHOULD BE DIRECTED TO BURTON S. GARBOW, */
00115 /* MATHEMATICS AND COMPUTER SCIENCE DIV, ARGONNE NATIONAL LABORATORY
00116 */
00117
00118 /* THIS VERSION DATED AUGUST 1983. */
00119
00120 /* ------------------------------------------------------------------
00121 */
00122
00123 /* Parameter adjustments */
00124 --bd;
00125 --ind;
00126 --w;
00127 --e2;
00128 --e;
00129 --d__;
00130
00131 /* Function Body */
00132 *ierr = 0;
00133 jdef = *idef;
00134 /* .......... COPY D ARRAY INTO W .......... */
00135 i__1 = *n;
00136 for (i__ = 1; i__ <= i__1; ++i__) {
00137 /* L20: */
00138 w[i__] = d__[i__];
00139 }
00140
00141 if (*type__) {
00142 goto L40;
00143 }
00144 j = 1;
00145 goto L400;
00146 L40:
00147 err = 0.;
00148 s = 0.;
00149 /* .......... LOOK FOR SMALL SUB-DIAGONAL ENTRIES AND DEFINE */
00150 /* INITIAL SHIFT FROM LOWER GERSCHGORIN BOUND. */
00151 /* COPY E2 ARRAY INTO BD .......... */
00152 tot = w[1];
00153 q = 0.;
00154 j = 0;
00155
00156 i__1 = *n;
00157 for (i__ = 1; i__ <= i__1; ++i__) {
00158 p = q;
00159 if (i__ == 1) {
00160 goto L60;
00161 }
00162 d__3 = (d__1 = d__[i__], abs(d__1)) + (d__2 = d__[i__ - 1], abs(d__2))
00163 ;
00164 if (p > epslon_(&d__3)) {
00165 goto L80;
00166 }
00167 L60:
00168 e2[i__] = 0.;
00169 L80:
00170 bd[i__] = e2[i__];
00171 /* .......... COUNT ALSO IF ELEMENT OF E2 HAS UNDERFLOWED ........
00172 .. */
00173 if (e2[i__] == 0.) {
00174 ++j;
00175 }
00176 ind[i__] = j;
00177 q = 0.;
00178 if (i__ != *n) {
00179 q = (d__1 = e[i__ + 1], abs(d__1));
00180 }
00181 /* Computing MIN */
00182 d__1 = w[i__] - p - q;
00183 tot = min(d__1,tot);
00184 /* L100: */
00185 }
00186
00187 if (jdef == 1 && tot < 0.) {
00188 goto L140;
00189 }
00190
00191 i__1 = *n;
00192 for (i__ = 1; i__ <= i__1; ++i__) {
00193 /* L110: */
00194 w[i__] -= tot;
00195 }
00196
00197 goto L160;
00198 L140:
00199 tot = 0.;
00200
00201 L160:
00202 i__1 = *m;
00203 for (k = 1; k <= i__1; ++k) {
00204 /* .......... NEXT QR TRANSFORMATION .......... */
00205 L180:
00206 tot += s;
00207 delta = w[*n] - s;
00208 i__ = *n;
00209 f = (d__1 = epslon_(&tot), abs(d__1));
00210 if (*eps1 < f) {
00211 *eps1 = f;
00212 }
00213 if (delta > *eps1) {
00214 goto L190;
00215 }
00216 if (delta < -(*eps1)) {
00217 goto L1000;
00218 }
00219 goto L300;
00220 /* .......... REPLACE SMALL SUB-DIAGONAL SQUARES BY ZERO */
00221 /* TO REDUCE THE INCIDENCE OF UNDERFLOWS .......... */
00222 L190:
00223 if (k == *n) {
00224 goto L210;
00225 }
00226 k1 = k + 1;
00227 i__2 = *n;
00228 for (j = k1; j <= i__2; ++j) {
00229 d__2 = w[j] + w[j - 1];
00230 /* Computing 2nd power */
00231 d__1 = epslon_(&d__2);
00232 if (bd[j] <= d__1 * d__1) {
00233 bd[j] = 0.;
00234 }
00235 /* L200: */
00236 }
00237
00238 L210:
00239 f = bd[*n] / delta;
00240 qp = delta + f;
00241 p = 1.;
00242 if (k == *n) {
00243 goto L260;
00244 }
00245 k1 = *n - k;
00246 /* .......... FOR I=N-1 STEP -1 UNTIL K DO -- .......... */
00247 i__2 = k1;
00248 for (ii = 1; ii <= i__2; ++ii) {
00249 i__ = *n - ii;
00250 q = w[i__] - s - f;
00251 r__ = q / qp;
00252 p = p * r__ + 1.;
00253 ep = f * r__;
00254 w[i__ + 1] = qp + ep;
00255 delta = q - ep;
00256 if (delta > *eps1) {
00257 goto L220;
00258 }
00259 if (delta < -(*eps1)) {
00260 goto L1000;
00261 }
00262 goto L300;
00263 L220:
00264 f = bd[i__] / q;
00265 qp = delta + f;
00266 bd[i__ + 1] = qp * ep;
00267 /* L240: */
00268 }
00269
00270 L260:
00271 w[k] = qp;
00272 s = qp / p;
00273 if (tot + s > tot) {
00274 goto L180;
00275 }
00276 /* .......... SET ERROR -- IRREGULAR END OF ITERATION. */
00277 /* DEFLATE MINIMUM DIAGONAL ELEMENT .......... */
00278 *ierr = *n * 5 + k;
00279 s = 0.;
00280 delta = qp;
00281
00282 i__2 = *n;
00283 for (j = k; j <= i__2; ++j) {
00284 if (w[j] > delta) {
00285 goto L280;
00286 }
00287 i__ = j;
00288 delta = w[j];
00289 L280:
00290 ;
00291 }
00292 /* .......... CONVERGENCE .......... */
00293 L300:
00294 if (i__ < *n) {
00295 bd[i__ + 1] = bd[i__] * f / qp;
00296 }
00297 ii = ind[i__];
00298 if (i__ == k) {
00299 goto L340;
00300 }
00301 k1 = i__ - k;
00302 /* .......... FOR J=I-1 STEP -1 UNTIL K DO -- .......... */
00303 i__2 = k1;
00304 for (jj = 1; jj <= i__2; ++jj) {
00305 j = i__ - jj;
00306 w[j + 1] = w[j] - s;
00307 bd[j + 1] = bd[j];
00308 ind[j + 1] = ind[j];
00309 /* L320: */
00310 }
00311
00312 L340:
00313 w[k] = tot;
00314 err += abs(delta);
00315 bd[k] = err;
00316 ind[k] = ii;
00317 /* L360: */
00318 }
00319
00320 if (*type__) {
00321 goto L1001;
00322 }
00323 f = bd[1];
00324 e2[1] = 2.;
00325 bd[1] = f;
00326 j = 2;
00327 /* .......... NEGATE ELEMENTS OF W FOR LARGEST VALUES .......... */
00328 L400:
00329 i__1 = *n;
00330 for (i__ = 1; i__ <= i__1; ++i__) {
00331 /* L500: */
00332 w[i__] = -w[i__];
00333 }
00334
00335 jdef = -jdef;
00336 switch (j) {
00337 case 1: goto L40;
00338 case 2: goto L1001;
00339 }
00340 /* .......... SET ERROR -- IDEF SPECIFIED INCORRECTLY .......... */
00341 L1000:
00342 *ierr = *n * 6 + 1;
00343 L1001:
00344 return 0;
00345 } /* ratqr_ */
|
|
||||||||||||||||||||||||||||
|
Definition at line 8 of file eis_rebak.c. References i1. Referenced by rsg_(), and rsgab_().
00010 {
00011 /* System generated locals */
00012 integer b_dim1, b_offset, z_dim1, z_offset, i__1, i__2, i__3;
00013
00014 /* Local variables */
00015 static integer i__, j, k;
00016 static doublereal x;
00017 static integer i1, ii;
00018
00019
00020
00021 /* THIS SUBROUTINE IS A TRANSLATION OF THE ALGOL PROCEDURE REBAKA, */
00022 /* NUM. MATH. 11, 99-110(1968) BY MARTIN AND WILKINSON. */
00023 /* HANDBOOK FOR AUTO. COMP., VOL.II-LINEAR ALGEBRA, 303-314(1971). */
00024
00025 /* THIS SUBROUTINE FORMS THE EIGENVECTORS OF A GENERALIZED */
00026 /* SYMMETRIC EIGENSYSTEM BY BACK TRANSFORMING THOSE OF THE */
00027 /* DERIVED SYMMETRIC MATRIX DETERMINED BY REDUC. */
00028
00029 /* ON INPUT */
00030
00031 /* NM MUST BE SET TO THE ROW DIMENSION OF TWO-DIMENSIONAL */
00032 /* ARRAY PARAMETERS AS DECLARED IN THE CALLING PROGRAM */
00033 /* DIMENSION STATEMENT. */
00034
00035 /* N IS THE ORDER OF THE MATRIX SYSTEM. */
00036
00037 /* B CONTAINS INFORMATION ABOUT THE SIMILARITY TRANSFORMATION */
00038 /* (CHOLESKY DECOMPOSITION) USED IN THE REDUCTION BY REDUC */
00039 /* IN ITS STRICT LOWER TRIANGLE. */
00040
00041 /* DL CONTAINS FURTHER INFORMATION ABOUT THE TRANSFORMATION. */
00042
00043 /* M IS THE NUMBER OF EIGENVECTORS TO BE BACK TRANSFORMED. */
00044
00045 /* Z CONTAINS THE EIGENVECTORS TO BE BACK TRANSFORMED */
00046 /* IN ITS FIRST M COLUMNS. */
00047
00048 /* ON OUTPUT */
00049
00050 /* Z CONTAINS THE TRANSFORMED EIGENVECTORS */
00051 /* IN ITS FIRST M COLUMNS. */
00052
00053 /* QUESTIONS AND COMMENTS SHOULD BE DIRECTED TO BURTON S. GARBOW, */
00054 /* MATHEMATICS AND COMPUTER SCIENCE DIV, ARGONNE NATIONAL LABORATORY
00055 */
00056
00057 /* THIS VERSION DATED AUGUST 1983. */
00058
00059 /* ------------------------------------------------------------------
00060 */
00061
00062 /* Parameter adjustments */
00063 --dl;
00064 b_dim1 = *nm;
00065 b_offset = b_dim1 + 1;
00066 b -= b_offset;
00067 z_dim1 = *nm;
00068 z_offset = z_dim1 + 1;
00069 z__ -= z_offset;
00070
00071 /* Function Body */
00072 if (*m == 0) {
00073 goto L200;
00074 }
00075
00076 i__1 = *m;
00077 for (j = 1; j <= i__1; ++j) {
00078 /* .......... FOR I=N STEP -1 UNTIL 1 DO -- .......... */
00079 i__2 = *n;
00080 for (ii = 1; ii <= i__2; ++ii) {
00081 i__ = *n + 1 - ii;
00082 i1 = i__ + 1;
00083 x = z__[i__ + j * z_dim1];
00084 if (i__ == *n) {
00085 goto L80;
00086 }
00087
00088 i__3 = *n;
00089 for (k = i1; k <= i__3; ++k) {
00090 /* L60: */
00091 x -= b[k + i__ * b_dim1] * z__[k + j * z_dim1];
00092 }
00093
00094 L80:
00095 z__[i__ + j * z_dim1] = x / dl[i__];
00096 /* L100: */
00097 }
00098 }
00099
00100 L200:
00101 return 0;
00102 } /* rebak_ */
|
|
||||||||||||||||||||||||||||
|
Definition at line 8 of file eis_rebakb.c. References i1. Referenced by rsgba_().
00010 {
00011 /* System generated locals */
00012 integer b_dim1, b_offset, z_dim1, z_offset, i__1, i__2, i__3;
00013
00014 /* Local variables */
00015 static integer i__, j, k;
00016 static doublereal x;
00017 static integer i1, ii;
00018
00019
00020
00021 /* THIS SUBROUTINE IS A TRANSLATION OF THE ALGOL PROCEDURE REBAKB, */
00022 /* NUM. MATH. 11, 99-110(1968) BY MARTIN AND WILKINSON. */
00023 /* HANDBOOK FOR AUTO. COMP., VOL.II-LINEAR ALGEBRA, 303-314(1971). */
00024
00025 /* THIS SUBROUTINE FORMS THE EIGENVECTORS OF A GENERALIZED */
00026 /* SYMMETRIC EIGENSYSTEM BY BACK TRANSFORMING THOSE OF THE */
00027 /* DERIVED SYMMETRIC MATRIX DETERMINED BY REDUC2. */
00028
00029 /* ON INPUT */
00030
00031 /* NM MUST BE SET TO THE ROW DIMENSION OF TWO-DIMENSIONAL */
00032 /* ARRAY PARAMETERS AS DECLARED IN THE CALLING PROGRAM */
00033 /* DIMENSION STATEMENT. */
00034
00035 /* N IS THE ORDER OF THE MATRIX SYSTEM. */
00036
00037 /* B CONTAINS INFORMATION ABOUT THE SIMILARITY TRANSFORMATION */
00038 /* (CHOLESKY DECOMPOSITION) USED IN THE REDUCTION BY REDUC2 */
00039 /* IN ITS STRICT LOWER TRIANGLE. */
00040
00041 /* DL CONTAINS FURTHER INFORMATION ABOUT THE TRANSFORMATION. */
00042
00043 /* M IS THE NUMBER OF EIGENVECTORS TO BE BACK TRANSFORMED. */
00044
00045 /* Z CONTAINS THE EIGENVECTORS TO BE BACK TRANSFORMED */
00046 /* IN ITS FIRST M COLUMNS. */
00047
00048 /* ON OUTPUT */
00049
00050 /* Z CONTAINS THE TRANSFORMED EIGENVECTORS */
00051 /* IN ITS FIRST M COLUMNS. */
00052
00053 /* QUESTIONS AND COMMENTS SHOULD BE DIRECTED TO BURTON S. GARBOW, */
00054 /* MATHEMATICS AND COMPUTER SCIENCE DIV, ARGONNE NATIONAL LABORATORY
00055 */
00056
00057 /* THIS VERSION DATED AUGUST 1983. */
00058
00059 /* ------------------------------------------------------------------
00060 */
00061
00062 /* Parameter adjustments */
00063 --dl;
00064 b_dim1 = *nm;
00065 b_offset = b_dim1 + 1;
00066 b -= b_offset;
00067 z_dim1 = *nm;
00068 z_offset = z_dim1 + 1;
00069 z__ -= z_offset;
00070
00071 /* Function Body */
00072 if (*m == 0) {
00073 goto L200;
00074 }
00075
00076 i__1 = *m;
00077 for (j = 1; j <= i__1; ++j) {
00078 /* .......... FOR I=N STEP -1 UNTIL 1 DO -- .......... */
00079 i__2 = *n;
00080 for (ii = 1; ii <= i__2; ++ii) {
00081 i1 = *n - ii;
00082 i__ = i1 + 1;
00083 x = dl[i__] * z__[i__ + j * z_dim1];
00084 if (i__ == 1) {
00085 goto L80;
00086 }
00087
00088 i__3 = i1;
00089 for (k = 1; k <= i__3; ++k) {
00090 /* L60: */
00091 x += b[i__ + k * b_dim1] * z__[k + j * z_dim1];
00092 }
00093
00094 L80:
00095 z__[i__ + j * z_dim1] = x;
00096 /* L100: */
00097 }
00098 }
00099
00100 L200:
00101 return 0;
00102 } /* rebakb_ */
|
|
||||||||||||||||||||||||||||
|
Definition at line 8 of file eis_reduc2.c. Referenced by rsgab_(), and rsgba_().
00010 {
00011 /* System generated locals */
00012 integer a_dim1, a_offset, b_dim1, b_offset, i__1, i__2, i__3;
00013
00014 /* Builtin functions */
00015 double sqrt(doublereal);
00016
00017 /* Local variables */
00018 static integer i__, j, k;
00019 static doublereal x, y;
00020 static integer i1, j1, nn;
00021
00022
00023
00024 /* THIS SUBROUTINE IS A TRANSLATION OF THE ALGOL PROCEDURE REDUC2, */
00025 /* NUM. MATH. 11, 99-110(1968) BY MARTIN AND WILKINSON. */
00026 /* HANDBOOK FOR AUTO. COMP., VOL.II-LINEAR ALGEBRA, 303-314(1971). */
00027
00028 /* THIS SUBROUTINE REDUCES THE GENERALIZED SYMMETRIC EIGENPROBLEMS */
00029 /* ABX=(LAMBDA)X OR BAY=(LAMBDA)Y, WHERE B IS POSITIVE DEFINITE, */
00030 /* TO THE STANDARD SYMMETRIC EIGENPROBLEM USING THE CHOLESKY */
00031 /* FACTORIZATION OF B. */
00032
00033 /* ON INPUT */
00034
00035 /* NM MUST BE SET TO THE ROW DIMENSION OF TWO-DIMENSIONAL */
00036 /* ARRAY PARAMETERS AS DECLARED IN THE CALLING PROGRAM */
00037 /* DIMENSION STATEMENT. */
00038
00039 /* N IS THE ORDER OF THE MATRICES A AND B. IF THE CHOLESKY */
00040 /* FACTOR L OF B IS ALREADY AVAILABLE, N SHOULD BE PREFIXED */
00041 /* WITH A MINUS SIGN. */
00042
00043 /* A AND B CONTAIN THE REAL SYMMETRIC INPUT MATRICES. ONLY THE */
00044 /* FULL UPPER TRIANGLES OF THE MATRICES NEED BE SUPPLIED. IF */
00045 /* N IS NEGATIVE, THE STRICT LOWER TRIANGLE OF B CONTAINS, */
00046 /* INSTEAD, THE STRICT LOWER TRIANGLE OF ITS CHOLESKY FACTOR L.
00047 */
00048
00049 /* DL CONTAINS, IF N IS NEGATIVE, THE DIAGONAL ELEMENTS OF L. */
00050
00051 /* ON OUTPUT */
00052
00053 /* A CONTAINS IN ITS FULL LOWER TRIANGLE THE FULL LOWER TRIANGLE */
00054 /* OF THE SYMMETRIC MATRIX DERIVED FROM THE REDUCTION TO THE */
00055 /* STANDARD FORM. THE STRICT UPPER TRIANGLE OF A IS UNALTERED.
00056 */
00057
00058 /* B CONTAINS IN ITS STRICT LOWER TRIANGLE THE STRICT LOWER */
00059 /* TRIANGLE OF ITS CHOLESKY FACTOR L. THE FULL UPPER */
00060 /* TRIANGLE OF B IS UNALTERED. */
00061
00062 /* DL CONTAINS THE DIAGONAL ELEMENTS OF L. */
00063
00064 /* IERR IS SET TO */
00065 /* ZERO FOR NORMAL RETURN, */
00066 /* 7*N+1 IF B IS NOT POSITIVE DEFINITE. */
00067
00068 /* QUESTIONS AND COMMENTS SHOULD BE DIRECTED TO BURTON S. GARBOW, */
00069 /* MATHEMATICS AND COMPUTER SCIENCE DIV, ARGONNE NATIONAL LABORATORY
00070 */
00071
00072 /* THIS VERSION DATED AUGUST 1983. */
00073
00074 /* ------------------------------------------------------------------
00075 */
00076
00077 /* Parameter adjustments */
00078 --dl;
00079 b_dim1 = *nm;
00080 b_offset = b_dim1 + 1;
00081 b -= b_offset;
00082 a_dim1 = *nm;
00083 a_offset = a_dim1 + 1;
00084 a -= a_offset;
00085
00086 /* Function Body */
00087 *ierr = 0;
00088 nn = abs(*n);
00089 if (*n < 0) {
00090 goto L100;
00091 }
00092 /* .......... FORM L IN THE ARRAYS B AND DL .......... */
00093 i__1 = *n;
00094 for (i__ = 1; i__ <= i__1; ++i__) {
00095 i1 = i__ - 1;
00096
00097 i__2 = *n;
00098 for (j = i__; j <= i__2; ++j) {
00099 x = b[i__ + j * b_dim1];
00100 if (i__ == 1) {
00101 goto L40;
00102 }
00103
00104 i__3 = i1;
00105 for (k = 1; k <= i__3; ++k) {
00106 /* L20: */
00107 x -= b[i__ + k * b_dim1] * b[j + k * b_dim1];
00108 }
00109
00110 L40:
00111 if (j != i__) {
00112 goto L60;
00113 }
00114 if (x <= 0.) {
00115 goto L1000;
00116 }
00117 y = sqrt(x);
00118 dl[i__] = y;
00119 goto L80;
00120 L60:
00121 b[j + i__ * b_dim1] = x / y;
00122 L80:
00123 ;
00124 }
00125 }
00126 /* .......... FORM THE LOWER TRIANGLE OF A*L */
00127 /* IN THE LOWER TRIANGLE OF THE ARRAY A .......... */
00128 L100:
00129 i__2 = nn;
00130 for (i__ = 1; i__ <= i__2; ++i__) {
00131 i1 = i__ + 1;
00132
00133 i__1 = i__;
00134 for (j = 1; j <= i__1; ++j) {
00135 x = a[j + i__ * a_dim1] * dl[j];
00136 if (j == i__) {
00137 goto L140;
00138 }
00139 j1 = j + 1;
00140
00141 i__3 = i__;
00142 for (k = j1; k <= i__3; ++k) {
00143 /* L120: */
00144 x += a[k + i__ * a_dim1] * b[k + j * b_dim1];
00145 }
00146
00147 L140:
00148 if (i__ == nn) {
00149 goto L180;
00150 }
00151
00152 i__3 = nn;
00153 for (k = i1; k <= i__3; ++k) {
00154 /* L160: */
00155 x += a[i__ + k * a_dim1] * b[k + j * b_dim1];
00156 }
00157
00158 L180:
00159 a[i__ + j * a_dim1] = x;
00160 /* L200: */
00161 }
00162 }
00163 /* .......... PRE-MULTIPLY BY TRANSPOSE(L) AND OVERWRITE .......... */
00164 i__1 = nn;
00165 for (i__ = 1; i__ <= i__1; ++i__) {
00166 i1 = i__ + 1;
00167 y = dl[i__];
00168
00169 i__2 = i__;
00170 for (j = 1; j <= i__2; ++j) {
00171 x = y * a[i__ + j * a_dim1];
00172 if (i__ == nn) {
00173 goto L280;
00174 }
00175
00176 i__3 = nn;
00177 for (k = i1; k <= i__3; ++k) {
00178 /* L260: */
00179 x += a[k + j * a_dim1] * b[k + i__ * b_dim1];
00180 }
00181
00182 L280:
00183 a[i__ + j * a_dim1] = x;
00184 /* L300: */
00185 }
00186 }
00187
00188 goto L1001;
00189 /* .......... SET ERROR -- B IS NOT POSITIVE DEFINITE .......... */
00190 L1000:
00191 *ierr = *n * 7 + 1;
00192 L1001:
00193 return 0;
00194 } /* reduc2_ */
|
|
||||||||||||||||||||||||||||
|
Definition at line 8 of file eis_reduc.c. Referenced by rsg_().
00010 {
00011 /* System generated locals */
00012 integer a_dim1, a_offset, b_dim1, b_offset, i__1, i__2, i__3;
00013
00014 /* Builtin functions */
00015 double sqrt(doublereal);
00016
00017 /* Local variables */
00018 static integer i__, j, k;
00019 static doublereal x, y;
00020 static integer i1, j1, nn;
00021
00022
00023
00024 /* THIS SUBROUTINE IS A TRANSLATION OF THE ALGOL PROCEDURE REDUC1, */
00025 /* NUM. MATH. 11, 99-110(1968) BY MARTIN AND WILKINSON. */
00026 /* HANDBOOK FOR AUTO. COMP., VOL.II-LINEAR ALGEBRA, 303-314(1971). */
00027
00028 /* THIS SUBROUTINE REDUCES THE GENERALIZED SYMMETRIC EIGENPROBLEM */
00029 /* AX=(LAMBDA)BX, WHERE B IS POSITIVE DEFINITE, TO THE STANDARD */
00030 /* SYMMETRIC EIGENPROBLEM USING THE CHOLESKY FACTORIZATION OF B. */
00031
00032 /* ON INPUT */
00033
00034 /* NM MUST BE SET TO THE ROW DIMENSION OF TWO-DIMENSIONAL */
00035 /* ARRAY PARAMETERS AS DECLARED IN THE CALLING PROGRAM */
00036 /* DIMENSION STATEMENT. */
00037
00038 /* N IS THE ORDER OF THE MATRICES A AND B. IF THE CHOLESKY */
00039 /* FACTOR L OF B IS ALREADY AVAILABLE, N SHOULD BE PREFIXED */
00040 /* WITH A MINUS SIGN. */
00041
00042 /* A AND B CONTAIN THE REAL SYMMETRIC INPUT MATRICES. ONLY THE */
00043 /* FULL UPPER TRIANGLES OF THE MATRICES NEED BE SUPPLIED. IF */
00044 /* N IS NEGATIVE, THE STRICT LOWER TRIANGLE OF B CONTAINS, */
00045 /* INSTEAD, THE STRICT LOWER TRIANGLE OF ITS CHOLESKY FACTOR L.
00046 */
00047
00048 /* DL CONTAINS, IF N IS NEGATIVE, THE DIAGONAL ELEMENTS OF L. */
00049
00050 /* ON OUTPUT */
00051
00052 /* A CONTAINS IN ITS FULL LOWER TRIANGLE THE FULL LOWER TRIANGLE */
00053 /* OF THE SYMMETRIC MATRIX DERIVED FROM THE REDUCTION TO THE */
00054 /* STANDARD FORM. THE STRICT UPPER TRIANGLE OF A IS UNALTERED.
00055 */
00056
00057 /* B CONTAINS IN ITS STRICT LOWER TRIANGLE THE STRICT LOWER */
00058 /* TRIANGLE OF ITS CHOLESKY FACTOR L. THE FULL UPPER */
00059 /* TRIANGLE OF B IS UNALTERED. */
00060
00061 /* DL CONTAINS THE DIAGONAL ELEMENTS OF L. */
00062
00063 /* IERR IS SET TO */
00064 /* ZERO FOR NORMAL RETURN, */
00065 /* 7*N+1 IF B IS NOT POSITIVE DEFINITE. */
00066
00067 /* QUESTIONS AND COMMENTS SHOULD BE DIRECTED TO BURTON S. GARBOW, */
00068 /* MATHEMATICS AND COMPUTER SCIENCE DIV, ARGONNE NATIONAL LABORATORY
00069 */
00070
00071 /* THIS VERSION DATED AUGUST 1983. */
00072
00073 /* ------------------------------------------------------------------
00074 */
00075
00076 /* Parameter adjustments */
00077 --dl;
00078 b_dim1 = *nm;
00079 b_offset = b_dim1 + 1;
00080 b -= b_offset;
00081 a_dim1 = *nm;
00082 a_offset = a_dim1 + 1;
00083 a -= a_offset;
00084
00085 /* Function Body */
00086 *ierr = 0;
00087 nn = abs(*n);
00088 if (*n < 0) {
00089 goto L100;
00090 }
00091 /* .......... FORM L IN THE ARRAYS B AND DL .......... */
00092 i__1 = *n;
00093 for (i__ = 1; i__ <= i__1; ++i__) {
00094 i1 = i__ - 1;
00095
00096 i__2 = *n;
00097 for (j = i__; j <= i__2; ++j) {
00098 x = b[i__ + j * b_dim1];
00099 if (i__ == 1) {
00100 goto L40;
00101 }
00102
00103 i__3 = i1;
00104 for (k = 1; k <= i__3; ++k) {
00105 /* L20: */
00106 x -= b[i__ + k * b_dim1] * b[j + k * b_dim1];
00107 }
00108
00109 L40:
00110 if (j != i__) {
00111 goto L60;
00112 }
00113 if (x <= 0.) {
00114 goto L1000;
00115 }
00116 y = sqrt(x);
00117 dl[i__] = y;
00118 goto L80;
00119 L60:
00120 b[j + i__ * b_dim1] = x / y;
00121 L80:
00122 ;
00123 }
00124 }
00125 /* .......... FORM THE TRANSPOSE OF THE UPPER TRIANGLE OF INV(L)*A */
00126 /* IN THE LOWER TRIANGLE OF THE ARRAY A .......... */
00127 L100:
00128 i__2 = nn;
00129 for (i__ = 1; i__ <= i__2; ++i__) {
00130 i1 = i__ - 1;
00131 y = dl[i__];
00132
00133 i__1 = nn;
00134 for (j = i__; j <= i__1; ++j) {
00135 x = a[i__ + j * a_dim1];
00136 if (i__ == 1) {
00137 goto L180;
00138 }
00139
00140 i__3 = i1;
00141 for (k = 1; k <= i__3; ++k) {
00142 /* L160: */
00143 x -= b[i__ + k * b_dim1] * a[j + k * a_dim1];
00144 }
00145
00146 L180:
00147 a[j + i__ * a_dim1] = x / y;
00148 /* L200: */
00149 }
00150 }
00151 /* .......... PRE-MULTIPLY BY INV(L) AND OVERWRITE .......... */
00152 i__1 = nn;
00153 for (j = 1; j <= i__1; ++j) {
00154 j1 = j - 1;
00155
00156 i__2 = nn;
00157 for (i__ = j; i__ <= i__2; ++i__) {
00158 x = a[i__ + j * a_dim1];
00159 if (i__ == j) {
00160 goto L240;
00161 }
00162 i1 = i__ - 1;
00163
00164 i__3 = i1;
00165 for (k = j; k <= i__3; ++k) {
00166 /* L220: */
00167 x -= a[k + j * a_dim1] * b[i__ + k * b_dim1];
00168 }
00169
00170 L240:
00171 if (j == 1) {
00172 goto L280;
00173 }
00174
00175 i__3 = j1;
00176 for (k = 1; k <= i__3; ++k) {
00177 /* L260: */
00178 x -= a[j + k * a_dim1] * b[i__ + k * b_dim1];
00179 }
00180
00181 L280:
00182 a[i__ + j * a_dim1] = x / dl[i__];
00183 /* L300: */
00184 }
00185 }
00186
00187 goto L1001;
00188 /* .......... SET ERROR -- B IS NOT POSITIVE DEFINITE .......... */
00189 L1000:
00190 *ierr = *n * 7 + 1;
00191 L1001:
00192 return 0;
00193 } /* reduc_ */
|
|
||||||||||||||||||||||||||||||||||||||||||||
|
Definition at line 8 of file eis_rg.c. References a, balanc_(), balbak_(), elmhes_(), eltran_(), hqr2_(), and hqr_().
00011 {
00012 /* System generated locals */
00013 integer a_dim1, a_offset, z_dim1, z_offset;
00014
00015 /* Local variables */
00016 extern /* Subroutine */ int balbak_(integer *, integer *, integer *,
00017 integer *, doublereal *, integer *, doublereal *), balanc_(
00018 integer *, integer *, doublereal *, integer *, integer *,
00019 doublereal *), elmhes_(integer *, integer *, integer *, integer *,
00020 doublereal *, integer *), eltran_(integer *, integer *, integer *
00021 , integer *, doublereal *, integer *, doublereal *);
00022 static integer is1, is2;
00023 extern /* Subroutine */ int hqr_(integer *, integer *, integer *, integer
00024 *, doublereal *, doublereal *, doublereal *, integer *), hqr2_(
00025 integer *, integer *, integer *, integer *, doublereal *,
00026 doublereal *, doublereal *, doublereal *, integer *);
00027
00028
00029
00030 /* THIS SUBROUTINE CALLS THE RECOMMENDED SEQUENCE OF */
00031 /* SUBROUTINES FROM THE EIGENSYSTEM SUBROUTINE PACKAGE (EISPACK) */
00032 /* TO FIND THE EIGENVALUES AND EIGENVECTORS (IF DESIRED) */
00033 /* OF A REAL GENERAL MATRIX. */
00034
00035 /* ON INPUT */
00036
00037 /* NM MUST BE SET TO THE ROW DIMENSION OF THE TWO-DIMENSIONAL */
00038 /* ARRAY PARAMETERS AS DECLARED IN THE CALLING PROGRAM */
00039 /* DIMENSION STATEMENT. */
00040
00041 /* N IS THE ORDER OF THE MATRIX A. */
00042
00043 /* A CONTAINS THE REAL GENERAL MATRIX. */
00044
00045 /* MATZ IS AN INTEGER VARIABLE SET EQUAL TO ZERO IF */
00046 /* ONLY EIGENVALUES ARE DESIRED. OTHERWISE IT IS SET TO */
00047 /* ANY NON-ZERO INTEGER FOR BOTH EIGENVALUES AND EIGENVECTORS. */
00048
00049 /* ON OUTPUT */
00050
00051 /* WR AND WI CONTAIN THE REAL AND IMAGINARY PARTS, */
00052 /* RESPECTIVELY, OF THE EIGENVALUES. COMPLEX CONJUGATE */
00053 /* PAIRS OF EIGENVALUES APPEAR CONSECUTIVELY WITH THE */
00054 /* EIGENVALUE HAVING THE POSITIVE IMAGINARY PART FIRST. */
00055
00056 /* Z CONTAINS THE REAL AND IMAGINARY PARTS OF THE EIGENVECTORS */
00057 /* IF MATZ IS NOT ZERO. IF THE J-TH EIGENVALUE IS REAL, THE */
00058 /* J-TH COLUMN OF Z CONTAINS ITS EIGENVECTOR. IF THE J-TH */
00059 /* EIGENVALUE IS COMPLEX WITH POSITIVE IMAGINARY PART, THE */
00060 /* J-TH AND (J+1)-TH COLUMNS OF Z CONTAIN THE REAL AND */
00061 /* IMAGINARY PARTS OF ITS EIGENVECTOR. THE CONJUGATE OF THIS */
00062 /* VECTOR IS THE EIGENVECTOR FOR THE CONJUGATE EIGENVALUE. */
00063
00064 /* IERR IS AN INTEGER OUTPUT VARIABLE SET EQUAL TO AN ERROR */
00065 /* COMPLETION CODE DESCRIBED IN THE DOCUMENTATION FOR HQR */
00066 /* AND HQR2. THE NORMAL COMPLETION CODE IS ZERO. */
00067
00068 /* IV1 AND FV1 ARE TEMPORARY STORAGE ARRAYS. */
00069
00070 /* QUESTIONS AND COMMENTS SHOULD BE DIRECTED TO BURTON S. GARBOW, */
00071 /* MATHEMATICS AND COMPUTER SCIENCE DIV, ARGONNE NATIONAL LABORATORY
00072 */
00073
00074 /* THIS VERSION DATED AUGUST 1983. */
00075
00076 /* ------------------------------------------------------------------
00077 */
00078
00079 /* Parameter adjustments */
00080 --fv1;
00081 --iv1;
00082 z_dim1 = *nm;
00083 z_offset = z_dim1 + 1;
00084 z__ -= z_offset;
00085 --wi;
00086 --wr;
00087 a_dim1 = *nm;
00088 a_offset = a_dim1 + 1;
00089 a -= a_offset;
00090
00091 /* Function Body */
00092 if (*n <= *nm) {
00093 goto L10;
00094 }
00095 *ierr = *n * 10;
00096 goto L50;
00097
00098 L10:
00099 balanc_(nm, n, &a[a_offset], &is1, &is2, &fv1[1]);
00100 elmhes_(nm, n, &is1, &is2, &a[a_offset], &iv1[1]);
00101 if (*matz != 0) {
00102 goto L20;
00103 }
00104 /* .......... FIND EIGENVALUES ONLY .......... */
00105 hqr_(nm, n, &is1, &is2, &a[a_offset], &wr[1], &wi[1], ierr);
00106 goto L50;
00107 /* .......... FIND BOTH EIGENVALUES AND EIGENVECTORS .......... */
00108 L20:
00109 eltran_(nm, n, &is1, &is2, &a[a_offset], &iv1[1], &z__[z_offset]);
00110 hqr2_(nm, n, &is1, &is2, &a[a_offset], &wr[1], &wi[1], &z__[z_offset],
00111 ierr);
00112 if (*ierr != 0) {
00113 goto L50;
00114 }
00115 balbak_(nm, n, &is1, &is2, &fv1[1], n, &z__[z_offset]);
00116 L50:
00117 return 0;
00118 } /* rg_ */
|
|
||||||||||||||||||||||||||||||||||||||||||||
|
Definition at line 12 of file eis_rgg.c. References a, c_b5, qzhes_(), qzit_(), qzval_(), and qzvec_().
00015 {
00016 /* System generated locals */
00017 integer a_dim1, a_offset, b_dim1, b_offset, z_dim1, z_offset;
00018
00019 /* Local variables */
00020 extern /* Subroutine */ int qzit_(integer *, integer *, doublereal *,
00021 doublereal *, doublereal *, logical *, doublereal *, integer *),
00022 qzvec_(integer *, integer *, doublereal *, doublereal *,
00023 doublereal *, doublereal *, doublereal *, doublereal *), qzhes_(
00024 integer *, integer *, doublereal *, doublereal *, logical *,
00025 doublereal *), qzval_(integer *, integer *, doublereal *,
00026 doublereal *, doublereal *, doublereal *, doublereal *, logical *,
00027 doublereal *);
00028 static logical tf;
00029
00030
00031
00032 /* THIS SUBROUTINE CALLS THE RECOMMENDED SEQUENCE OF */
00033 /* SUBROUTINES FROM THE EIGENSYSTEM SUBROUTINE PACKAGE (EISPACK) */
00034 /* TO FIND THE EIGENVALUES AND EIGENVECTORS (IF DESIRED) */
00035 /* FOR THE REAL GENERAL GENERALIZED EIGENPROBLEM AX = (LAMBDA)BX. */
00036
00037 /* ON INPUT */
00038
00039 /* NM MUST BE SET TO THE ROW DIMENSION OF THE TWO-DIMENSIONAL */
00040 /* ARRAY PARAMETERS AS DECLARED IN THE CALLING PROGRAM */
00041 /* DIMENSION STATEMENT. */
00042
00043 /* N IS THE ORDER OF THE MATRICES A AND B. */
00044
00045 /* A CONTAINS A REAL GENERAL MATRIX. */
00046
00047 /* B CONTAINS A REAL GENERAL MATRIX. */
00048
00049 /* MATZ IS AN INTEGER VARIABLE SET EQUAL TO ZERO IF */
00050 /* ONLY EIGENVALUES ARE DESIRED. OTHERWISE IT IS SET TO */
00051 /* ANY NON-ZERO INTEGER FOR BOTH EIGENVALUES AND EIGENVECTORS. */
00052
00053 /* ON OUTPUT */
00054
00055 /* ALFR AND ALFI CONTAIN THE REAL AND IMAGINARY PARTS, */
00056 /* RESPECTIVELY, OF THE NUMERATORS OF THE EIGENVALUES. */
00057
00058 /* BETA CONTAINS THE DENOMINATORS OF THE EIGENVALUES, */
00059 /* WHICH ARE THUS GIVEN BY THE RATIOS (ALFR+I*ALFI)/BETA. */
00060 /* COMPLEX CONJUGATE PAIRS OF EIGENVALUES APPEAR CONSECUTIVELY */
00061 /* WITH THE EIGENVALUE HAVING THE POSITIVE IMAGINARY PART FIRST. */
00062
00063 /* Z CONTAINS THE REAL AND IMAGINARY PARTS OF THE EIGENVECTORS */
00064 /* IF MATZ IS NOT ZERO. IF THE J-TH EIGENVALUE IS REAL, THE */
00065 /* J-TH COLUMN OF Z CONTAINS ITS EIGENVECTOR. IF THE J-TH */
00066 /* EIGENVALUE IS COMPLEX WITH POSITIVE IMAGINARY PART, THE */
00067 /* J-TH AND (J+1)-TH COLUMNS OF Z CONTAIN THE REAL AND */
00068 /* IMAGINARY PARTS OF ITS EIGENVECTOR. THE CONJUGATE OF THIS */
00069 /* VECTOR IS THE EIGENVECTOR FOR THE CONJUGATE EIGENVALUE. */
00070
00071 /* IERR IS AN INTEGER OUTPUT VARIABLE SET EQUAL TO AN ERROR */
00072 /* COMPLETION CODE DESCRIBED IN THE DOCUMENTATION FOR QZIT. */
00073 /* THE NORMAL COMPLETION CODE IS ZERO. */
00074
00075 /* QUESTIONS AND COMMENTS SHOULD BE DIRECTED TO BURTON S. GARBOW, */
00076 /* MATHEMATICS AND COMPUTER SCIENCE DIV, ARGONNE NATIONAL LABORATORY
00077 */
00078
00079 /* THIS VERSION DATED AUGUST 1983. */
00080
00081 /* ------------------------------------------------------------------
00082 */
00083
00084 /* Parameter adjustments */
00085 z_dim1 = *nm;
00086 z_offset = z_dim1 + 1;
00087 z__ -= z_offset;
00088 --beta;
00089 --alfi;
00090 --alfr;
00091 b_dim1 = *nm;
00092 b_offset = b_dim1 + 1;
00093 b -= b_offset;
00094 a_dim1 = *nm;
00095 a_offset = a_dim1 + 1;
00096 a -= a_offset;
00097
00098 /* Function Body */
00099 if (*n <= *nm) {
00100 goto L10;
00101 }
00102 *ierr = *n * 10;
00103 goto L50;
00104
00105 L10:
00106 if (*matz != 0) {
00107 goto L20;
00108 }
00109 /* .......... FIND EIGENVALUES ONLY .......... */
00110 tf = FALSE_;
00111 qzhes_(nm, n, &a[a_offset], &b[b_offset], &tf, &z__[z_offset]);
00112 qzit_(nm, n, &a[a_offset], &b[b_offset], &c_b5, &tf, &z__[z_offset], ierr)
00113 ;
00114 qzval_(nm, n, &a[a_offset], &b[b_offset], &alfr[1], &alfi[1], &beta[1], &
00115 tf, &z__[z_offset]);
00116 goto L50;
00117 /* .......... FIND BOTH EIGENVALUES AND EIGENVECTORS .......... */
00118 L20:
00119 tf = TRUE_;
00120 qzhes_(nm, n, &a[a_offset], &b[b_offset], &tf, &z__[z_offset]);
00121 qzit_(nm, n, &a[a_offset], &b[b_offset], &c_b5, &tf, &z__[z_offset], ierr)
00122 ;
00123 qzval_(nm, n, &a[a_offset], &b[b_offset], &alfr[1], &alfi[1], &beta[1], &
00124 tf, &z__[z_offset]);
00125 if (*ierr != 0) {
00126 goto L50;
00127 }
00128 qzvec_(nm, n, &a[a_offset], &b[b_offset], &alfr[1], &alfi[1], &beta[1], &
00129 z__[z_offset]);
00130 L50:
00131 return 0;
00132 } /* rgg_ */
|
|
||||||||||||||||||||||||||||||||||||||||
|
Definition at line 8 of file eis_rs.c. References a, tql2_(), tqlrat_(), tred1_(), and tred2_(). Referenced by symeig_double(), and symeigval_double().
00011 {
00012 /* System generated locals */
00013 integer a_dim1, a_offset, z_dim1, z_offset;
00014
00015 /* Local variables */
00016 extern /* Subroutine */ int tred1_(integer *, integer *, doublereal *,
00017 doublereal *, doublereal *, doublereal *), tred2_(integer *,
00018 integer *, doublereal *, doublereal *, doublereal *, doublereal *)
00019 , tqlrat_(integer *, doublereal *, doublereal *, integer *),
00020 tql2_(integer *, integer *, doublereal *, doublereal *,
00021 doublereal *, integer *);
00022
00023
00024
00025 /* THIS SUBROUTINE CALLS THE RECOMMENDED SEQUENCE OF */
00026 /* SUBROUTINES FROM THE EIGENSYSTEM SUBROUTINE PACKAGE (EISPACK) */
00027 /* TO FIND THE EIGENVALUES AND EIGENVECTORS (IF DESIRED) */
00028 /* OF A REAL SYMMETRIC MATRIX. */
00029
00030 /* ON INPUT */
00031
00032 /* NM MUST BE SET TO THE ROW DIMENSION OF THE TWO-DIMENSIONAL */
00033 /* ARRAY PARAMETERS AS DECLARED IN THE CALLING PROGRAM */
00034 /* DIMENSION STATEMENT. */
00035
00036 /* N IS THE ORDER OF THE MATRIX A. */
00037
00038 /* A CONTAINS THE REAL SYMMETRIC MATRIX. */
00039
00040 /* MATZ IS AN INTEGER VARIABLE SET EQUAL TO ZERO IF */
00041 /* ONLY EIGENVALUES ARE DESIRED. OTHERWISE IT IS SET TO */
00042 /* ANY NON-ZERO INTEGER FOR BOTH EIGENVALUES AND EIGENVECTORS. */
00043
00044 /* ON OUTPUT */
00045
00046 /* W CONTAINS THE EIGENVALUES IN ASCENDING ORDER. */
00047
00048 /* Z CONTAINS THE EIGENVECTORS IF MATZ IS NOT ZERO. */
00049
00050 /* IERR IS AN INTEGER OUTPUT VARIABLE SET EQUAL TO AN ERROR */
00051 /* COMPLETION CODE DESCRIBED IN THE DOCUMENTATION FOR TQLRAT */
00052 /* AND TQL2. THE NORMAL COMPLETION CODE IS ZERO. */
00053
00054 /* FV1 AND FV2 ARE TEMPORARY STORAGE ARRAYS. */
00055
00056 /* QUESTIONS AND COMMENTS SHOULD BE DIRECTED TO BURTON S. GARBOW, */
00057 /* MATHEMATICS AND COMPUTER SCIENCE DIV, ARGONNE NATIONAL LABORATORY
00058 */
00059
00060 /* THIS VERSION DATED AUGUST 1983. */
00061
00062 /* ------------------------------------------------------------------
00063 */
00064
00065 /* Parameter adjustments */
00066 --fv2;
00067 --fv1;
00068 z_dim1 = *nm;
00069 z_offset = z_dim1 + 1;
00070 z__ -= z_offset;
00071 --w;
00072 a_dim1 = *nm;
00073 a_offset = a_dim1 + 1;
00074 a -= a_offset;
00075
00076 /* Function Body */
00077 if (*n <= *nm) {
00078 goto L10;
00079 }
00080 *ierr = *n * 10;
00081 goto L50;
00082
00083 L10:
00084 if (*matz != 0) {
00085 goto L20;
00086 }
00087 /* .......... FIND EIGENVALUES ONLY .......... */
00088 tred1_(nm, n, &a[a_offset], &w[1], &fv1[1], &fv2[1]);
00089 tqlrat_(n, &w[1], &fv2[1], ierr);
00090 goto L50;
00091 /* .......... FIND BOTH EIGENVALUES AND EIGENVECTORS .......... */
00092 L20:
00093 tred2_(nm, n, &a[a_offset], &w[1], &fv1[1], &z__[z_offset]);
00094 tql2_(nm, n, &w[1], &fv1[1], &z__[z_offset], ierr);
00095 L50:
00096 return 0;
00097 } /* rs_ */
|
|
||||||||||||||||||||||||||||||||||||||||||||
|
Definition at line 8 of file eis_rsb.c. References a, bandr_(), tql2_(), and tqlrat_().
00011 {
00012 /* System generated locals */
00013 integer a_dim1, a_offset, z_dim1, z_offset;
00014
00015 /* Local variables */
00016 extern /* Subroutine */ int bandr_(integer *, integer *, integer *,
00017 doublereal *, doublereal *, doublereal *, doublereal *, logical *,
00018 doublereal *);
00019 static logical tf;
00020 extern /* Subroutine */ int tqlrat_(integer *, doublereal *, doublereal *,
00021 integer *), tql2_(integer *, integer *, doublereal *, doublereal
00022 *, doublereal *, integer *);
00023
00024
00025
00026 /* THIS SUBROUTINE CALLS THE RECOMMENDED SEQUENCE OF */
00027 /* SUBROUTINES FROM THE EIGENSYSTEM SUBROUTINE PACKAGE (EISPACK) */
00028 /* TO FIND THE EIGENVALUES AND EIGENVECTORS (IF DESIRED) */
00029 /* OF A REAL SYMMETRIC BAND MATRIX. */
00030
00031 /* ON INPUT */
00032
00033 /* NM MUST BE SET TO THE ROW DIMENSION OF THE TWO-DIMENSIONAL */
00034 /* ARRAY PARAMETERS AS DECLARED IN THE CALLING PROGRAM */
00035 /* DIMENSION STATEMENT. */
00036
00037 /* N IS THE ORDER OF THE MATRIX A. */
00038
00039 /* MB IS THE HALF BAND WIDTH OF THE MATRIX, DEFINED AS THE */
00040 /* NUMBER OF ADJACENT DIAGONALS, INCLUDING THE PRINCIPAL */
00041 /* DIAGONAL, REQUIRED TO SPECIFY THE NON-ZERO PORTION OF THE */
00042 /* LOWER TRIANGLE OF THE MATRIX. */
00043
00044 /* A CONTAINS THE LOWER TRIANGLE OF THE REAL SYMMETRIC */
00045 /* BAND MATRIX. ITS LOWEST SUBDIAGONAL IS STORED IN THE */
00046 /* LAST N+1-MB POSITIONS OF THE FIRST COLUMN, ITS NEXT */
00047 /* SUBDIAGONAL IN THE LAST N+2-MB POSITIONS OF THE */
00048 /* SECOND COLUMN, FURTHER SUBDIAGONALS SIMILARLY, AND */
00049 /* FINALLY ITS PRINCIPAL DIAGONAL IN THE N POSITIONS */
00050 /* OF THE LAST COLUMN. CONTENTS OF STORAGES NOT PART */
00051 /* OF THE MATRIX ARE ARBITRARY. */
00052
00053 /* MATZ IS AN INTEGER VARIABLE SET EQUAL TO ZERO IF */
00054 /* ONLY EIGENVALUES ARE DESIRED. OTHERWISE IT IS SET TO */
00055 /* ANY NON-ZERO INTEGER FOR BOTH EIGENVALUES AND EIGENVECTORS. */
00056
00057 /* ON OUTPUT */
00058
00059 /* W CONTAINS THE EIGENVALUES IN ASCENDING ORDER. */
00060
00061 /* Z CONTAINS THE EIGENVECTORS IF MATZ IS NOT ZERO. */
00062
00063 /* IERR IS AN INTEGER OUTPUT VARIABLE SET EQUAL TO AN ERROR */
00064 /* COMPLETION CODE DESCRIBED IN THE DOCUMENTATION FOR TQLRAT */
00065 /* AND TQL2. THE NORMAL COMPLETION CODE IS ZERO. */
00066
00067 /* FV1 AND FV2 ARE TEMPORARY STORAGE ARRAYS. */
00068
00069 /* QUESTIONS AND COMMENTS SHOULD BE DIRECTED TO BURTON S. GARBOW, */
00070 /* MATHEMATICS AND COMPUTER SCIENCE DIV, ARGONNE NATIONAL LABORATORY
00071 */
00072
00073 /* THIS VERSION DATED AUGUST 1983. */
00074
00075 /* ------------------------------------------------------------------
00076 */
00077
00078 /* Parameter adjustments */
00079 --fv2;
00080 --fv1;
00081 z_dim1 = *nm;
00082 z_offset = z_dim1 + 1;
00083 z__ -= z_offset;
00084 --w;
00085 a_dim1 = *nm;
00086 a_offset = a_dim1 + 1;
00087 a -= a_offset;
00088
00089 /* Function Body */
00090 if (*n <= *nm) {
00091 goto L5;
00092 }
00093 *ierr = *n * 10;
00094 goto L50;
00095 L5:
00096 if (*mb > 0) {
00097 goto L10;
00098 }
00099 *ierr = *n * 12;
00100 goto L50;
00101 L10:
00102 if (*mb <= *n) {
00103 goto L15;
00104 }
00105 *ierr = *n * 12;
00106 goto L50;
00107
00108 L15:
00109 if (*matz != 0) {
00110 goto L20;
00111 }
00112 /* .......... FIND EIGENVALUES ONLY .......... */
00113 tf = FALSE_;
00114 bandr_(nm, n, mb, &a[a_offset], &w[1], &fv1[1], &fv2[1], &tf, &z__[
00115 z_offset]);
00116 tqlrat_(n, &w[1], &fv2[1], ierr);
00117 goto L50;
00118 /* .......... FIND BOTH EIGENVALUES AND EIGENVECTORS .......... */
00119 L20:
00120 tf = TRUE_;
00121 bandr_(nm, n, mb, &a[a_offset], &w[1], &fv1[1], &fv1[1], &tf, &z__[
00122 z_offset]);
00123 tql2_(nm, n, &w[1], &fv1[1], &z__[z_offset], ierr);
00124 L50:
00125 return 0;
00126 } /* rsb_ */
|
|
||||||||||||||||||||||||||||||||||||||||||||
|
Definition at line 8 of file eis_rsg.c. References a, rebak_(), reduc_(), tql2_(), tqlrat_(), tred1_(), and tred2_().
00011 {
00012 /* System generated locals */
00013 integer a_dim1, a_offset, b_dim1, b_offset, z_dim1, z_offset;
00014
00015 /* Local variables */
00016 extern /* Subroutine */ int tred1_(integer *, integer *, doublereal *,
00017 doublereal *, doublereal *, doublereal *), tred2_(integer *,
00018 integer *, doublereal *, doublereal *, doublereal *, doublereal *)
00019 , rebak_(integer *, integer *, doublereal *, doublereal *,
00020 integer *, doublereal *), reduc_(integer *, integer *, doublereal
00021 *, doublereal *, doublereal *, integer *), tqlrat_(integer *,
00022 doublereal *, doublereal *, integer *), tql2_(integer *, integer *
00023 , doublereal *, doublereal *, doublereal *, integer *);
00024
00025
00026
00027 /* THIS SUBROUTINE CALLS THE RECOMMENDED SEQUENCE OF */
00028 /* SUBROUTINES FROM THE EIGENSYSTEM SUBROUTINE PACKAGE (EISPACK) */
00029 /* TO FIND THE EIGENVALUES AND EIGENVECTORS (IF DESIRED) */
00030 /* FOR THE REAL SYMMETRIC GENERALIZED EIGENPROBLEM AX = (LAMBDA)BX.
00031 */
00032
00033 /* ON INPUT */
00034
00035 /* NM MUST BE SET TO THE ROW DIMENSION OF THE TWO-DIMENSIONAL */
00036 /* ARRAY PARAMETERS AS DECLARED IN THE CALLING PROGRAM */
00037 /* DIMENSION STATEMENT. */
00038
00039 /* N IS THE ORDER OF THE MATRICES A AND B. */
00040
00041 /* A CONTAINS A REAL SYMMETRIC MATRIX. */
00042
00043 /* B CONTAINS A POSITIVE DEFINITE REAL SYMMETRIC MATRIX. */
00044
00045 /* MATZ IS AN INTEGER VARIABLE SET EQUAL TO ZERO IF */
00046 /* ONLY EIGENVALUES ARE DESIRED. OTHERWISE IT IS SET TO */
00047 /* ANY NON-ZERO INTEGER FOR BOTH EIGENVALUES AND EIGENVECTORS. */
00048
00049 /* ON OUTPUT */
00050
00051 /* W CONTAINS THE EIGENVALUES IN ASCENDING ORDER. */
00052
00053 /* Z CONTAINS THE EIGENVECTORS IF MATZ IS NOT ZERO. */
00054
00055 /* IERR IS AN INTEGER OUTPUT VARIABLE SET EQUAL TO AN ERROR */
00056 /* COMPLETION CODE DESCRIBED IN THE DOCUMENTATION FOR TQLRAT */
00057 /* AND TQL2. THE NORMAL COMPLETION CODE IS ZERO. */
00058
00059 /* FV1 AND FV2 ARE TEMPORARY STORAGE ARRAYS. */
00060
00061 /* QUESTIONS AND COMMENTS SHOULD BE DIRECTED TO BURTON S. GARBOW, */
00062 /* MATHEMATICS AND COMPUTER SCIENCE DIV, ARGONNE NATIONAL LABORATORY
00063 */
00064
00065 /* THIS VERSION DATED AUGUST 1983. */
00066
00067 /* ------------------------------------------------------------------
00068 */
00069
00070 /* Parameter adjustments */
00071 --fv2;
00072 --fv1;
00073 z_dim1 = *nm;
00074 z_offset = z_dim1 + 1;
00075 z__ -= z_offset;
00076 --w;
00077 b_dim1 = *nm;
00078 b_offset = b_dim1 + 1;
00079 b -= b_offset;
00080 a_dim1 = *nm;
00081 a_offset = a_dim1 + 1;
00082 a -= a_offset;
00083
00084 /* Function Body */
00085 if (*n <= *nm) {
00086 goto L10;
00087 }
00088 *ierr = *n * 10;
00089 goto L50;
00090
00091 L10:
00092 reduc_(nm, n, &a[a_offset], &b[b_offset], &fv2[1], ierr);
00093 if (*ierr != 0) {
00094 goto L50;
00095 }
00096 if (*matz != 0) {
00097 goto L20;
00098 }
00099 /* .......... FIND EIGENVALUES ONLY .......... */
00100 tred1_(nm, n, &a[a_offset], &w[1], &fv1[1], &fv2[1]);
00101 tqlrat_(n, &w[1], &fv2[1], ierr);
00102 goto L50;
00103 /* .......... FIND BOTH EIGENVALUES AND EIGENVECTORS .......... */
00104 L20:
00105 tred2_(nm, n, &a[a_offset], &w[1], &fv1[1], &z__[z_offset]);
00106 tql2_(nm, n, &w[1], &fv1[1], &z__[z_offset], ierr);
00107 if (*ierr != 0) {
00108 goto L50;
00109 }
00110 rebak_(nm, n, &b[b_offset], &fv2[1], n, &z__[z_offset]);
00111 L50:
00112 return 0;
00113 } /* rsg_ */
|
|
||||||||||||||||||||||||||||||||||||||||||||
|
Definition at line 8 of file eis_rsgab.c. References a, rebak_(), reduc2_(), tql2_(), tqlrat_(), tred1_(), and tred2_().
00011 {
00012 /* System generated locals */
00013 integer a_dim1, a_offset, b_dim1, b_offset, z_dim1, z_offset;
00014
00015 /* Local variables */
00016 extern /* Subroutine */ int tred1_(integer *, integer *, doublereal *,
00017 doublereal *, doublereal *, doublereal *), tred2_(integer *,
00018 integer *, doublereal *, doublereal *, doublereal *, doublereal *)
00019 , rebak_(integer *, integer *, doublereal *, doublereal *,
00020 integer *, doublereal *), reduc2_(integer *, integer *,
00021 doublereal *, doublereal *, doublereal *, integer *), tqlrat_(
00022 integer *, doublereal *, doublereal *, integer *), tql2_(integer *
00023 , integer *, doublereal *, doublereal *, doublereal *, integer *);
00024
00025
00026
00027 /* THIS SUBROUTINE CALLS THE RECOMMENDED SEQUENCE OF */
00028 /* SUBROUTINES FROM THE EIGENSYSTEM SUBROUTINE PACKAGE (EISPACK) */
00029 /* TO FIND THE EIGENVALUES AND EIGENVECTORS (IF DESIRED) */
00030 /* FOR THE REAL SYMMETRIC GENERALIZED EIGENPROBLEM ABX = (LAMBDA)X.
00031 */
00032
00033 /* ON INPUT */
00034
00035 /* NM MUST BE SET TO THE ROW DIMENSION OF THE TWO-DIMENSIONAL */
00036 /* ARRAY PARAMETERS AS DECLARED IN THE CALLING PROGRAM */
00037 /* DIMENSION STATEMENT. */
00038
00039 /* N IS THE ORDER OF THE MATRICES A AND B. */
00040
00041 /* A CONTAINS A REAL SYMMETRIC MATRIX. */
00042
00043 /* B CONTAINS A POSITIVE DEFINITE REAL SYMMETRIC MATRIX. */
00044
00045 /* MATZ IS AN INTEGER VARIABLE SET EQUAL TO ZERO IF */
00046 /* ONLY EIGENVALUES ARE DESIRED. OTHERWISE IT IS SET TO */
00047 /* ANY NON-ZERO INTEGER FOR BOTH EIGENVALUES AND EIGENVECTORS. */
00048
00049 /* ON OUTPUT */
00050
00051 /* W CONTAINS THE EIGENVALUES IN ASCENDING ORDER. */
00052
00053 /* Z CONTAINS THE EIGENVECTORS IF MATZ IS NOT ZERO. */
00054
00055 /* IERR IS AN INTEGER OUTPUT VARIABLE SET EQUAL TO AN ERROR */
00056 /* COMPLETION CODE DESCRIBED IN THE DOCUMENTATION FOR TQLRAT */
00057 /* AND TQL2. THE NORMAL COMPLETION CODE IS ZERO. */
00058
00059 /* FV1 AND FV2 ARE TEMPORARY STORAGE ARRAYS. */
00060
00061 /* QUESTIONS AND COMMENTS SHOULD BE DIRECTED TO BURTON S. GARBOW, */
00062 /* MATHEMATICS AND COMPUTER SCIENCE DIV, ARGONNE NATIONAL LABORATORY
00063 */
00064
00065 /* THIS VERSION DATED AUGUST 1983. */
00066
00067 /* ------------------------------------------------------------------
00068 */
00069
00070 /* Parameter adjustments */
00071 --fv2;
00072 --fv1;
00073 z_dim1 = *nm;
00074 z_offset = z_dim1 + 1;
00075 z__ -= z_offset;
00076 --w;
00077 b_dim1 = *nm;
00078 b_offset = b_dim1 + 1;
00079 b -= b_offset;
00080 a_dim1 = *nm;
00081 a_offset = a_dim1 + 1;
00082 a -= a_offset;
00083
00084 /* Function Body */
00085 if (*n <= *nm) {
00086 goto L10;
00087 }
00088 *ierr = *n * 10;
00089 goto L50;
00090
00091 L10:
00092 reduc2_(nm, n, &a[a_offset], &b[b_offset], &fv2[1], ierr);
00093 if (*ierr != 0) {
00094 goto L50;
00095 }
00096 if (*matz != 0) {
00097 goto L20;
00098 }
00099 /* .......... FIND EIGENVALUES ONLY .......... */
00100 tred1_(nm, n, &a[a_offset], &w[1], &fv1[1], &fv2[1]);
00101 tqlrat_(n, &w[1], &fv2[1], ierr);
00102 goto L50;
00103 /* .......... FIND BOTH EIGENVALUES AND EIGENVECTORS .......... */
00104 L20:
00105 tred2_(nm, n, &a[a_offset], &w[1], &fv1[1], &z__[z_offset]);
00106 tql2_(nm, n, &w[1], &fv1[1], &z__[z_offset], ierr);
00107 if (*ierr != 0) {
00108 goto L50;
00109 }
00110 rebak_(nm, n, &b[b_offset], &fv2[1], n, &z__[z_offset]);
00111 L50:
00112 return 0;
00113 } /* rsgab_ */
|
|
||||||||||||||||||||||||||||||||||||||||||||
|
Definition at line 8 of file eis_rsgba.c. References a, rebakb_(), reduc2_(), tql2_(), tqlrat_(), tred1_(), and tred2_().
00011 {
00012 /* System generated locals */
00013 integer a_dim1, a_offset, b_dim1, b_offset, z_dim1, z_offset;
00014
00015 /* Local variables */
00016 extern /* Subroutine */ int tred1_(integer *, integer *, doublereal *,
00017 doublereal *, doublereal *, doublereal *), tred2_(integer *,
00018 integer *, doublereal *, doublereal *, doublereal *, doublereal *)
00019 , reduc2_(integer *, integer *, doublereal *, doublereal *,
00020 doublereal *, integer *), rebakb_(integer *, integer *,
00021 doublereal *, doublereal *, integer *, doublereal *), tqlrat_(
00022 integer *, doublereal *, doublereal *, integer *), tql2_(integer *
00023 , integer *, doublereal *, doublereal *, doublereal *, integer *);
00024
00025
00026
00027 /* THIS SUBROUTINE CALLS THE RECOMMENDED SEQUENCE OF */
00028 /* SUBROUTINES FROM THE EIGENSYSTEM SUBROUTINE PACKAGE (EISPACK) */
00029 /* TO FIND THE EIGENVALUES AND EIGENVECTORS (IF DESIRED) */
00030 /* FOR THE REAL SYMMETRIC GENERALIZED EIGENPROBLEM BAX = (LAMBDA)X.
00031 */
00032
00033 /* ON INPUT */
00034
00035 /* NM MUST BE SET TO THE ROW DIMENSION OF THE TWO-DIMENSIONAL */
00036 /* ARRAY PARAMETERS AS DECLARED IN THE CALLING PROGRAM */
00037 /* DIMENSION STATEMENT. */
00038
00039 /* N IS THE ORDER OF THE MATRICES A AND B. */
00040
00041 /* A CONTAINS A REAL SYMMETRIC MATRIX. */
00042
00043 /* B CONTAINS A POSITIVE DEFINITE REAL SYMMETRIC MATRIX. */
00044
00045 /* MATZ IS AN INTEGER VARIABLE SET EQUAL TO ZERO IF */
00046 /* ONLY EIGENVALUES ARE DESIRED. OTHERWISE IT IS SET TO */
00047 /* ANY NON-ZERO INTEGER FOR BOTH EIGENVALUES AND EIGENVECTORS. */
00048
00049 /* ON OUTPUT */
00050
00051 /* W CONTAINS THE EIGENVALUES IN ASCENDING ORDER. */
00052
00053 /* Z CONTAINS THE EIGENVECTORS IF MATZ IS NOT ZERO. */
00054
00055 /* IERR IS AN INTEGER OUTPUT VARIABLE SET EQUAL TO AN ERROR */
00056 /* COMPLETION CODE DESCRIBED IN THE DOCUMENTATION FOR TQLRAT */
00057 /* AND TQL2. THE NORMAL COMPLETION CODE IS ZERO. */
00058
00059 /* FV1 AND FV2 ARE TEMPORARY STORAGE ARRAYS. */
00060
00061 /* QUESTIONS AND COMMENTS SHOULD BE DIRECTED TO BURTON S. GARBOW, */
00062 /* MATHEMATICS AND COMPUTER SCIENCE DIV, ARGONNE NATIONAL LABORATORY
00063 */
00064
00065 /* THIS VERSION DATED AUGUST 1983. */
00066
00067 /* ------------------------------------------------------------------
00068 */
00069
00070 /* Parameter adjustments */
00071 --fv2;
00072 --fv1;
00073 z_dim1 = *nm;
00074 z_offset = z_dim1 + 1;
00075 z__ -= z_offset;
00076 --w;
00077 b_dim1 = *nm;
00078 b_offset = b_dim1 + 1;
00079 b -= b_offset;
00080 a_dim1 = *nm;
00081 a_offset = a_dim1 + 1;
00082 a -= a_offset;
00083
00084 /* Function Body */
00085 if (*n <= *nm) {
00086 goto L10;
00087 }
00088 *ierr = *n * 10;
00089 goto L50;
00090
00091 L10:
00092 reduc2_(nm, n, &a[a_offset], &b[b_offset], &fv2[1], ierr);
00093 if (*ierr != 0) {
00094 goto L50;
00095 }
00096 if (*matz != 0) {
00097 goto L20;
00098 }
00099 /* .......... FIND EIGENVALUES ONLY .......... */
00100 tred1_(nm, n, &a[a_offset], &w[1], &fv1[1], &fv2[1]);
00101 tqlrat_(n, &w[1], &fv2[1], ierr);
00102 goto L50;
00103 /* .......... FIND BOTH EIGENVALUES AND EIGENVECTORS .......... */
00104 L20:
00105 tred2_(nm, n, &a[a_offset], &w[1], &fv1[1], &z__[z_offset]);
00106 tql2_(nm, n, &w[1], &fv1[1], &z__[z_offset], ierr);
00107 if (*ierr != 0) {
00108 goto L50;
00109 }
00110 rebakb_(nm, n, &b[b_offset], &fv2[1], n, &z__[z_offset]);
00111 L50:
00112 return 0;
00113 } /* rsgba_ */
|
|
||||||||||||||||||||||||||||||||||||||||
|
Definition at line 8 of file eis_rsm.c. References a, imtqlv_(), tinvit_(), tqlrat_(), trbak1_(), and tred1_().
00011 {
00012 /* System generated locals */
00013 integer a_dim1, a_offset, z_dim1, z_offset;
00014
00015 /* Local variables */
00016 extern /* Subroutine */ int tred1_(integer *, integer *, doublereal *,
00017 doublereal *, doublereal *, doublereal *);
00018 static integer k1, k2, k3, k4, k5, k6, k7, k8;
00019 extern /* Subroutine */ int trbak1_(integer *, integer *, doublereal *,
00020 doublereal *, integer *, doublereal *), tqlrat_(integer *,
00021 doublereal *, doublereal *, integer *), imtqlv_(integer *,
00022 doublereal *, doublereal *, doublereal *, doublereal *, integer *,
00023 integer *, doublereal *), tinvit_(integer *, integer *,
00024 doublereal *, doublereal *, doublereal *, integer *, doublereal *,
00025 integer *, doublereal *, integer *, doublereal *, doublereal *,
00026 doublereal *, doublereal *, doublereal *);
00027
00028
00029
00030 /* THIS SUBROUTINE CALLS THE RECOMMENDED SEQUENCE OF */
00031 /* SUBROUTINES FROM THE EIGENSYSTEM SUBROUTINE PACKAGE (EISPACK) */
00032 /* TO FIND ALL OF THE EIGENVALUES AND SOME OF THE EIGENVECTORS */
00033 /* OF A REAL SYMMETRIC MATRIX. */
00034
00035 /* ON INPUT */
00036
00037 /* NM MUST BE SET TO THE ROW DIMENSION OF THE TWO-DIMENSIONAL */
00038 /* ARRAY PARAMETERS AS DECLARED IN THE CALLING PROGRAM */
00039 /* DIMENSION STATEMENT. */
00040
00041 /* N IS THE ORDER OF THE MATRIX A. */
00042
00043 /* A CONTAINS THE REAL SYMMETRIC MATRIX. */
00044
00045 /* M THE EIGENVECTORS CORRESPONDING TO THE FIRST M EIGENVALUES */
00046 /* ARE TO BE COMPUTED. */
00047 /* IF M = 0 THEN NO EIGENVECTORS ARE COMPUTED. */
00048 /* IF M = N THEN ALL OF THE EIGENVECTORS ARE COMPUTED. */
00049
00050 /* ON OUTPUT */
00051
00052 /* W CONTAINS ALL N EIGENVALUES IN ASCENDING ORDER. */
00053
00054 /* Z CONTAINS THE ORTHONORMAL EIGENVECTORS ASSOCIATED WITH */
00055 /* THE FIRST M EIGENVALUES. */
00056
00057 /* IERR IS AN INTEGER OUTPUT VARIABLE SET EQUAL TO AN ERROR */
00058 /* COMPLETION CODE DESCRIBED IN THE DOCUMENTATION FOR TQLRAT, */
00059 /* IMTQLV AND TINVIT. THE NORMAL COMPLETION CODE IS ZERO. */
00060
00061 /* FWORK IS A TEMPORARY STORAGE ARRAY OF DIMENSION 8*N. */
00062
00063 /* IWORK IS AN INTEGER TEMPORARY STORAGE ARRAY OF DIMENSION N. */
00064
00065 /* QUESTIONS AND COMMENTS SHOULD BE DIRECTED TO BURTON S. GARBOW, */
00066 /* MATHEMATICS AND COMPUTER SCIENCE DIV, ARGONNE NATIONAL LABORATORY
00067 */
00068
00069 /* THIS VERSION DATED AUGUST 1983. */
00070
00071 /* ------------------------------------------------------------------
00072 */
00073
00074 /* Parameter adjustments */
00075 --iwork;
00076 --w;
00077 a_dim1 = *nm;
00078 a_offset = a_dim1 + 1;
00079 a -= a_offset;
00080 z_dim1 = *nm;
00081 z_offset = z_dim1 + 1;
00082 z__ -= z_offset;
00083 --fwork;
00084
00085 /* Function Body */
00086 *ierr = *n * 10;
00087 if (*n > *nm || *m > *nm) {
00088 goto L50;
00089 }
00090 k1 = 1;
00091 k2 = k1 + *n;
00092 k3 = k2 + *n;
00093 k4 = k3 + *n;
00094 k5 = k4 + *n;
00095 k6 = k5 + *n;
00096 k7 = k6 + *n;
00097 k8 = k7 + *n;
00098 if (*m > 0) {
00099 goto L10;
00100 }
00101 /* .......... FIND EIGENVALUES ONLY .......... */
00102 tred1_(nm, n, &a[a_offset], &w[1], &fwork[k1], &fwork[k2]);
00103 tqlrat_(n, &w[1], &fwork[k2], ierr);
00104 goto L50;
00105 /* .......... FIND ALL EIGENVALUES AND M EIGENVECTORS .......... */
00106 L10:
00107 tred1_(nm, n, &a[a_offset], &fwork[k1], &fwork[k2], &fwork[k3]);
00108 imtqlv_(n, &fwork[k1], &fwork[k2], &fwork[k3], &w[1], &iwork[1], ierr, &
00109 fwork[k4]);
00110 tinvit_(nm, n, &fwork[k1], &fwork[k2], &fwork[k3], m, &w[1], &iwork[1], &
00111 z__[z_offset], ierr, &fwork[k4], &fwork[k5], &fwork[k6], &fwork[
00112 k7], &fwork[k8]);
00113 trbak1_(nm, n, &a[a_offset], &fwork[k2], m, &z__[z_offset]);
00114 L50:
00115 return 0;
00116 } /* rsm_ */
|
|
||||||||||||||||||||||||||||||||||||||||||||
|
Definition at line 8 of file eis_rsp.c. References a, tql2_(), tqlrat_(), trbak3_(), and tred3_().
00011 {
00012 /* System generated locals */
00013 integer z_dim1, z_offset, i__1, i__2;
00014
00015 /* Local variables */
00016 extern /* Subroutine */ int tred3_(integer *, integer *, doublereal *,
00017 doublereal *, doublereal *, doublereal *);
00018 static integer i__, j;
00019 extern /* Subroutine */ int trbak3_(integer *, integer *, integer *,
00020 doublereal *, integer *, doublereal *), tqlrat_(integer *,
00021 doublereal *, doublereal *, integer *), tql2_(integer *, integer *
00022 , doublereal *, doublereal *, doublereal *, integer *);
00023
00024
00025
00026 /* THIS SUBROUTINE CALLS THE RECOMMENDED SEQUENCE OF */
00027 /* SUBROUTINES FROM THE EIGENSYSTEM SUBROUTINE PACKAGE (EISPACK) */
00028 /* TO FIND THE EIGENVALUES AND EIGENVECTORS (IF DESIRED) */
00029 /* OF A REAL SYMMETRIC PACKED MATRIX. */
00030
00031 /* ON INPUT */
00032
00033 /* NM MUST BE SET TO THE ROW DIMENSION OF THE TWO-DIMENSIONAL */
00034 /* ARRAY PARAMETERS AS DECLARED IN THE CALLING PROGRAM */
00035 /* DIMENSION STATEMENT. */
00036
00037 /* N IS THE ORDER OF THE MATRIX A. */
00038
00039 /* NV IS AN INTEGER VARIABLE SET EQUAL TO THE */
00040 /* DIMENSION OF THE ARRAY A AS SPECIFIED FOR */
00041 /* A IN THE CALLING PROGRAM. NV MUST NOT BE */
00042 /* LESS THAN N*(N+1)/2. */
00043
00044 /* A CONTAINS THE LOWER TRIANGLE OF THE REAL SYMMETRIC */
00045 /* PACKED MATRIX STORED ROW-WISE. */
00046
00047 /* MATZ IS AN INTEGER VARIABLE SET EQUAL TO ZERO IF */
00048 /* ONLY EIGENVALUES ARE DESIRED. OTHERWISE IT IS SET TO */
00049 /* ANY NON-ZERO INTEGER FOR BOTH EIGENVALUES AND EIGENVECTORS. */
00050
00051 /* ON OUTPUT */
00052
00053 /* W CONTAINS THE EIGENVALUES IN ASCENDING ORDER. */
00054
00055 /* Z CONTAINS THE EIGENVECTORS IF MATZ IS NOT ZERO. */
00056
00057 /* IERR IS AN INTEGER OUTPUT VARIABLE SET EQUAL TO AN ERROR */
00058 /* COMPLETION CODE DESCRIBED IN THE DOCUMENTATION FOR TQLRAT */
00059 /* AND TQL2. THE NORMAL COMPLETION CODE IS ZERO. */
00060
00061 /* FV1 AND FV2 ARE TEMPORARY STORAGE ARRAYS. */
00062
00063 /* QUESTIONS AND COMMENTS SHOULD BE DIRECTED TO BURTON S. GARBOW, */
00064 /* MATHEMATICS AND COMPUTER SCIENCE DIV, ARGONNE NATIONAL LABORATORY
00065 */
00066
00067 /* THIS VERSION DATED AUGUST 1983. */
00068
00069 /* ------------------------------------------------------------------
00070 */
00071
00072 /* Parameter adjustments */
00073 --fv2;
00074 --fv1;
00075 z_dim1 = *nm;
00076 z_offset = z_dim1 + 1;
00077 z__ -= z_offset;
00078 --w;
00079 --a;
00080
00081 /* Function Body */
00082 if (*n <= *nm) {
00083 goto L5;
00084 }
00085 *ierr = *n * 10;
00086 goto L50;
00087 L5:
00088 if (*nv >= *n * (*n + 1) / 2) {
00089 goto L10;
00090 }
00091 *ierr = *n * 20;
00092 goto L50;
00093
00094 L10:
00095 tred3_(n, nv, &a[1], &w[1], &fv1[1], &fv2[1]);
00096 if (*matz != 0) {
00097 goto L20;
00098 }
00099 /* .......... FIND EIGENVALUES ONLY .......... */
00100 tqlrat_(n, &w[1], &fv2[1], ierr);
00101 goto L50;
00102 /* .......... FIND BOTH EIGENVALUES AND EIGENVECTORS .......... */
00103 L20:
00104 i__1 = *n;
00105 for (i__ = 1; i__ <= i__1; ++i__) {
00106
00107 i__2 = *n;
00108 for (j = 1; j <= i__2; ++j) {
00109 z__[j + i__ * z_dim1] = 0.;
00110 /* L30: */
00111 }
00112
00113 z__[i__ + i__ * z_dim1] = 1.;
00114 /* L40: */
00115 }
00116
00117 tql2_(nm, n, &w[1], &fv1[1], &z__[z_offset], ierr);
00118 if (*ierr != 0) {
00119 goto L50;
00120 }
00121 trbak3_(nm, n, nv, &a[1], n, &z__[z_offset]);
00122 L50:
00123 return 0;
00124 } /* rsp_ */
|
|
||||||||||||||||||||||||||||||||
|
Definition at line 8 of file eis_rst.c. References imtql1_(), and imtql2_().
00010 {
00011 /* System generated locals */
00012 integer z_dim1, z_offset, i__1, i__2;
00013
00014 /* Local variables */
00015 static integer i__, j;
00016 extern /* Subroutine */ int imtql1_(integer *, doublereal *, doublereal *,
00017 integer *), imtql2_(integer *, integer *, doublereal *,
00018 doublereal *, doublereal *, integer *);
00019
00020
00021
00022 /* THIS SUBROUTINE CALLS THE RECOMMENDED SEQUENCE OF */
00023 /* SUBROUTINES FROM THE EIGENSYSTEM SUBROUTINE PACKAGE (EISPACK) */
00024 /* TO FIND THE EIGENVALUES AND EIGENVECTORS (IF DESIRED) */
00025 /* OF A REAL SYMMETRIC TRIDIAGONAL MATRIX. */
00026
00027 /* ON INPUT */
00028
00029 /* NM MUST BE SET TO THE ROW DIMENSION OF THE TWO-DIMENSIONAL */
00030 /* ARRAY PARAMETERS AS DECLARED IN THE CALLING PROGRAM */
00031 /* DIMENSION STATEMENT. */
00032
00033 /* N IS THE ORDER OF THE MATRIX. */
00034
00035 /* W CONTAINS THE DIAGONAL ELEMENTS OF THE REAL */
00036 /* SYMMETRIC TRIDIAGONAL MATRIX. */
00037
00038 /* E CONTAINS THE SUBDIAGONAL ELEMENTS OF THE MATRIX IN */
00039 /* ITS LAST N-1 POSITIONS. E(1) IS ARBITRARY. */
00040
00041 /* MATZ IS AN INTEGER VARIABLE SET EQUAL TO ZERO IF */
00042 /* ONLY EIGENVALUES ARE DESIRED. OTHERWISE IT IS SET TO */
00043 /* ANY NON-ZERO INTEGER FOR BOTH EIGENVALUES AND EIGENVECTORS. */
00044
00045 /* ON OUTPUT */
00046
00047 /* W CONTAINS THE EIGENVALUES IN ASCENDING ORDER. */
00048
00049 /* Z CONTAINS THE EIGENVECTORS IF MATZ IS NOT ZERO. */
00050
00051 /* IERR IS AN INTEGER OUTPUT VARIABLE SET EQUAL TO AN ERROR */
00052 /* COMPLETION CODE DESCRIBED IN THE DOCUMENTATION FOR IMTQL1 */
00053 /* AND IMTQL2. THE NORMAL COMPLETION CODE IS ZERO. */
00054
00055 /* QUESTIONS AND COMMENTS SHOULD BE DIRECTED TO BURTON S. GARBOW, */
00056 /* MATHEMATICS AND COMPUTER SCIENCE DIV, ARGONNE NATIONAL LABORATORY
00057 */
00058
00059 /* THIS VERSION DATED AUGUST 1983. */
00060
00061 /* ------------------------------------------------------------------
00062 */
00063
00064 /* Parameter adjustments */
00065 z_dim1 = *nm;
00066 z_offset = z_dim1 + 1;
00067 z__ -= z_offset;
00068 --e;
00069 --w;
00070
00071 /* Function Body */
00072 if (*n <= *nm) {
00073 goto L10;
00074 }
00075 *ierr = *n * 10;
00076 goto L50;
00077
00078 L10:
00079 if (*matz != 0) {
00080 goto L20;
00081 }
00082 /* .......... FIND EIGENVALUES ONLY .......... */
00083 imtql1_(n, &w[1], &e[1], ierr);
00084 goto L50;
00085 /* .......... FIND BOTH EIGENVALUES AND EIGENVECTORS .......... */
00086 L20:
00087 i__1 = *n;
00088 for (i__ = 1; i__ <= i__1; ++i__) {
00089
00090 i__2 = *n;
00091 for (j = 1; j <= i__2; ++j) {
00092 z__[j + i__ * z_dim1] = 0.;
00093 /* L30: */
00094 }
00095
00096 z__[i__ + i__ * z_dim1] = 1.;
00097 /* L40: */
00098 }
00099
00100 imtql2_(nm, n, &w[1], &e[1], &z__[z_offset], ierr);
00101 L50:
00102 return 0;
00103 } /* rst_ */
|
|
||||||||||||||||||||||||||||||||||||
|
Definition at line 8 of file eis_rt.c. References a, figi2_(), figi_(), imtql1_(), and imtql2_().
00010 {
00011 /* System generated locals */
00012 integer a_dim1, a_offset, z_dim1, z_offset;
00013
00014 /* Local variables */
00015 extern /* Subroutine */ int figi_(integer *, integer *, doublereal *,
00016 doublereal *, doublereal *, doublereal *, integer *), figi2_(
00017 integer *, integer *, doublereal *, doublereal *, doublereal *,
00018 doublereal *, integer *), imtql1_(integer *, doublereal *,
00019 doublereal *, integer *), imtql2_(integer *, integer *,
00020 doublereal *, doublereal *, doublereal *, integer *);
00021
00022
00023
00024 /* THIS SUBROUTINE CALLS THE RECOMMENDED SEQUENCE OF */
00025 /* SUBROUTINES FROM THE EIGENSYSTEM SUBROUTINE PACKAGE (EISPACK) */
00026 /* TO FIND THE EIGENVALUES AND EIGENVECTORS (IF DESIRED) */
00027 /* OF A SPECIAL REAL TRIDIAGONAL MATRIX. */
00028
00029 /* ON INPUT */
00030
00031 /* NM MUST BE SET TO THE ROW DIMENSION OF THE TWO-DIMENSIONAL */
00032 /* ARRAY PARAMETERS AS DECLARED IN THE CALLING PROGRAM */
00033 /* DIMENSION STATEMENT. */
00034
00035 /* N IS THE ORDER OF THE MATRIX A. */
00036
00037 /* A CONTAINS THE SPECIAL REAL TRIDIAGONAL MATRIX IN ITS */
00038 /* FIRST THREE COLUMNS. THE SUBDIAGONAL ELEMENTS ARE STORED */
00039 /* IN THE LAST N-1 POSITIONS OF THE FIRST COLUMN, THE */
00040 /* DIAGONAL ELEMENTS IN THE SECOND COLUMN, AND THE SUPERDIAGONAL */
00041 /* ELEMENTS IN THE FIRST N-1 POSITIONS OF THE THIRD COLUMN. */
00042 /* ELEMENTS A(1,1) AND A(N,3) ARE ARBITRARY. */
00043
00044 /* MATZ IS AN INTEGER VARIABLE SET EQUAL TO ZERO IF */
00045 /* ONLY EIGENVALUES ARE DESIRED. OTHERWISE IT IS SET TO */
00046 /* ANY NON-ZERO INTEGER FOR BOTH EIGENVALUES AND EIGENVECTORS. */
00047
00048 /* ON OUTPUT */
00049
00050 /* W CONTAINS THE EIGENVALUES IN ASCENDING ORDER. */
00051
00052 /* Z CONTAINS THE EIGENVECTORS IF MATZ IS NOT ZERO. */
00053
00054 /* IERR IS AN INTEGER OUTPUT VARIABLE SET EQUAL TO AN ERROR */
00055 /* COMPLETION CODE DESCRIBED IN THE DOCUMENTATION FOR IMTQL1 */
00056 /* AND IMTQL2. THE NORMAL COMPLETION CODE IS ZERO. */
00057
00058 /* FV1 IS A TEMPORARY STORAGE ARRAY. */
00059
00060 /* QUESTIONS AND COMMENTS SHOULD BE DIRECTED TO BURTON S. GARBOW, */
00061 /* MATHEMATICS AND COMPUTER SCIENCE DIV, ARGONNE NATIONAL LABORATORY
00062 */
00063
00064 /* THIS VERSION DATED AUGUST 1983. */
00065
00066 /* ------------------------------------------------------------------
00067 */
00068
00069 /* Parameter adjustments */
00070 a_dim1 = *nm;
00071 a_offset = a_dim1 + 1;
00072 a -= a_offset;
00073 --fv1;
00074 z_dim1 = *nm;
00075 z_offset = z_dim1 + 1;
00076 z__ -= z_offset;
00077 --w;
00078
00079 /* Function Body */
00080 if (*n <= *nm) {
00081 goto L10;
00082 }
00083 *ierr = *n * 10;
00084 goto L50;
00085
00086 L10:
00087 if (*matz != 0) {
00088 goto L20;
00089 }
00090 /* .......... FIND EIGENVALUES ONLY .......... */
00091 figi_(nm, n, &a[a_offset], &w[1], &fv1[1], &fv1[1], ierr);
00092 if (*ierr > 0) {
00093 goto L50;
00094 }
00095 imtql1_(n, &w[1], &fv1[1], ierr);
00096 goto L50;
00097 /* .......... FIND BOTH EIGENVALUES AND EIGENVECTORS .......... */
00098 L20:
00099 figi2_(nm, n, &a[a_offset], &w[1], &fv1[1], &z__[z_offset], ierr);
00100 if (*ierr != 0) {
00101 goto L50;
00102 }
00103 imtql2_(nm, n, &w[1], &fv1[1], &z__[z_offset], ierr);
00104 L50:
00105 return 0;
00106 } /* rt_ */
|
|
||||||||||||||||||||||||||||||||||||||||||||||||||||||||
|
Definition at line 12 of file eis_svd.c. References a, abs, c_b47, d_sign(), i1, l, max, pythag_(), scale, and v. Referenced by svd_double().
00015 {
00016 /* System generated locals */
00017 integer a_dim1, a_offset, u_dim1, u_offset, v_dim1, v_offset, i__1, i__2,
00018 i__3;
00019 doublereal d__1, d__2, d__3, d__4;
00020
00021 /* Builtin functions */
00022 double sqrt(doublereal), d_sign(doublereal *, doublereal *);
00023
00024 /* Local variables */
00025 static doublereal c__, f, g, h__;
00026 static integer i__, j, k, l;
00027 static doublereal s, x, y, z__, scale;
00028 static integer i1, k1, l1, ii, kk, ll, mn;
00029 extern doublereal pythag_(doublereal *, doublereal *);
00030 static integer its;
00031 static doublereal tst1, tst2;
00032
00033
00034
00035 /* this subroutine is a translation of the algol procedure svd, */
00036 /* num. math. 14, 403-420(1970) by golub and reinsch. */
00037 /* handbook for auto. comp., vol ii-linear algebra, 134-151(1971). */
00038
00039 /* this subroutine determines the singular value decomposition */
00040 /* t */
00041 /* a=usv of a real m by n rectangular matrix. householder */
00042 /* bidiagonalization and a variant of the qr algorithm are used. */
00043
00044 /* on input */
00045
00046 /* nm must be set to the row dimension of two-dimensional */
00047 /* array parameters as declared in the calling program */
00048 /* dimension statement. note that nm must be at least */
00049 /* as large as the maximum of m and n. */
00050
00051 /* m is the number of rows of a (and u). */
00052
00053 /* n is the number of columns of a, u, and v */
00054
00055 /* a contains the rectangular input matrix to be decomposed. */
00056
00057 /* matu should be set to .true. if the u matrix in the */
00058 /* decomposition is desired, and to .false. otherwise. */
00059
00060 /* matv should be set to .true. if the v matrix in the */
00061 /* decomposition is desired, and to .false. otherwise. */
00062
00063 /* lda, ldu, ldv: are the leading dimensions of matrices */
00064 /* a, u, and v (respectively); must have */
00065 /* lda >= m ; ldu >= m ; ldv >= n */
00066
00067 /* on output */
00068
00069 /* a is unaltered (unless overwritten by u or v). */
00070
00071 /* w contains the n (non-negative) singular values of a (the */
00072 /* diagonal elements of s). they are unordered. if an */
00073 /* error exit is made, the singular values should be correct */
00074 /* for indices ierr+1,ierr+2,...,n. */
00075
00076 /* u contains the matrix u (orthogonal column vectors) of the */
00077 /* decomposition if matu has been set to .true. otherwise */
00078 /* u is used as a temporary array. u may coincide with a. */
00079 /* if an error exit is made, the columns of u corresponding */
00080 /* to indices of correct singular values should be correct. */
00081
00082 /* v contains the matrix v (orthogonal) of the decomposition if */
00083 /* matv has been set to .true. otherwise v is not referenced. */
00084 /* v may also coincide with a if u is not needed. if an error */
00085 /* exit is made, the columns of v corresponding to indices of */
00086 /* correct singular values should be correct. */
00087
00088 /* ierr is set to */
00089 /* zero for normal return, */
00090 /* k if the k-th singular value has not been */
00091 /* determined after 30 iterations. */
00092
00093 /* rv1 is a temporary storage array. */
00094
00095 /* calls pythag for dsqrt(a*a + b*b) . */
00096
00097 /* questions and comments should be directed to burton s. garbow, */
00098 /* mathematics and computer science div, argonne national laboratory
00099 */
00100
00101 /* this version dated august 1983. */
00102
00103 /* ------------------------------------------------------------------
00104 */
00105
00106 /* Parameter adjustments */
00107 --rv1;
00108 --w;
00109 a_dim1 = *lda;
00110 a_offset = a_dim1 + 1;
00111 a -= a_offset;
00112 u_dim1 = *ldu;
00113 u_offset = u_dim1 + 1;
00114 u -= u_offset;
00115 v_dim1 = *ldv;
00116 v_offset = v_dim1 + 1;
00117 if( v != (doublereal *)0 ) v -= v_offset;
00118
00119 /* Function Body */
00120 *ierr = 0;
00121
00122 i__1 = *m;
00123 for (i__ = 1; i__ <= i__1; ++i__) {
00124
00125 i__2 = *n;
00126 for (j = 1; j <= i__2; ++j) {
00127 u[i__ + j * u_dim1] = a[i__ + j * a_dim1];
00128 /* L100: */
00129 }
00130 }
00131 /* .......... householder reduction to bidiagonal form .......... */
00132 g = 0.;
00133 scale = 0.;
00134 x = 0.;
00135
00136 i__2 = *n;
00137 for (i__ = 1; i__ <= i__2; ++i__) {
00138 l = i__ + 1;
00139 rv1[i__] = scale * g;
00140 g = 0.;
00141 s = 0.;
00142 scale = 0.;
00143 if (i__ > *m) {
00144 goto L210;
00145 }
00146
00147 i__1 = *m;
00148 for (k = i__; k <= i__1; ++k) {
00149 /* L120: */
00150 scale += (d__1 = u[k + i__ * u_dim1], abs(d__1));
00151 }
00152
00153 if (scale == 0.) {
00154 goto L210;
00155 }
00156
00157 i__1 = *m;
00158 for (k = i__; k <= i__1; ++k) {
00159 u[k + i__ * u_dim1] /= scale;
00160 /* Computing 2nd power */
00161 d__1 = u[k + i__ * u_dim1];
00162 s += d__1 * d__1;
00163 /* L130: */
00164 }
00165
00166 f = u[i__ + i__ * u_dim1];
00167 d__1 = sqrt(s);
00168 g = -d_sign(&d__1, &f);
00169 h__ = f * g - s;
00170 u[i__ + i__ * u_dim1] = f - g;
00171 if (i__ == *n) {
00172 goto L190;
00173 }
00174
00175 i__1 = *n;
00176 for (j = l; j <= i__1; ++j) {
00177 s = 0.;
00178
00179 i__3 = *m;
00180 for (k = i__; k <= i__3; ++k) {
00181 /* L140: */
00182 s += u[k + i__ * u_dim1] * u[k + j * u_dim1];
00183 }
00184
00185 f = s / h__;
00186
00187 i__3 = *m;
00188 for (k = i__; k <= i__3; ++k) {
00189 u[k + j * u_dim1] += f * u[k + i__ * u_dim1];
00190 /* L150: */
00191 }
00192 }
00193
00194 L190:
00195 i__3 = *m;
00196 for (k = i__; k <= i__3; ++k) {
00197 /* L200: */
00198 u[k + i__ * u_dim1] = scale * u[k + i__ * u_dim1];
00199 }
00200
00201 L210:
00202 w[i__] = scale * g;
00203 g = 0.;
00204 s = 0.;
00205 scale = 0.;
00206 if (i__ > *m || i__ == *n) {
00207 goto L290;
00208 }
00209
00210 i__3 = *n;
00211 for (k = l; k <= i__3; ++k) {
00212 /* L220: */
00213 scale += (d__1 = u[i__ + k * u_dim1], abs(d__1));
00214 }
00215
00216 if (scale == 0.) {
00217 goto L290;
00218 }
00219
00220 i__3 = *n;
00221 for (k = l; k <= i__3; ++k) {
00222 u[i__ + k * u_dim1] /= scale;
00223 /* Computing 2nd power */
00224 d__1 = u[i__ + k * u_dim1];
00225 s += d__1 * d__1;
00226 /* L230: */
00227 }
00228
00229 f = u[i__ + l * u_dim1];
00230 d__1 = sqrt(s);
00231 g = -d_sign(&d__1, &f);
00232 h__ = f * g - s;
00233 u[i__ + l * u_dim1] = f - g;
00234
00235 i__3 = *n;
00236 for (k = l; k <= i__3; ++k) {
00237 /* L240: */
00238 rv1[k] = u[i__ + k * u_dim1] / h__;
00239 }
00240
00241 if (i__ == *m) {
00242 goto L270;
00243 }
00244
00245 i__3 = *m;
00246 for (j = l; j <= i__3; ++j) {
00247 s = 0.;
00248
00249 i__1 = *n;
00250 for (k = l; k <= i__1; ++k) {
00251 /* L250: */
00252 s += u[j + k * u_dim1] * u[i__ + k * u_dim1];
00253 }
00254
00255 i__1 = *n;
00256 for (k = l; k <= i__1; ++k) {
00257 u[j + k * u_dim1] += s * rv1[k];
00258 /* L260: */
00259 }
00260 }
00261
00262 L270:
00263 i__1 = *n;
00264 for (k = l; k <= i__1; ++k) {
00265 /* L280: */
00266 u[i__ + k * u_dim1] = scale * u[i__ + k * u_dim1];
00267 }
00268
00269 L290:
00270 /* Computing MAX */
00271 d__3 = x, d__4 = (d__1 = w[i__], abs(d__1)) + (d__2 = rv1[i__], abs(
00272 d__2));
00273 x = max(d__3,d__4);
00274 /* L300: */
00275 }
00276 /* .......... accumulation of right-hand transformations .......... */
00277 if (! (*matv)) {
00278 goto L410;
00279 }
00280 /* .......... for i=n step -1 until 1 do -- .......... */
00281 i__2 = *n;
00282 for (ii = 1; ii <= i__2; ++ii) {
00283 i__ = *n + 1 - ii;
00284 if (i__ == *n) {
00285 goto L390;
00286 }
00287 if (g == 0.) {
00288 goto L360;
00289 }
00290
00291 i__1 = *n;
00292 for (j = l; j <= i__1; ++j) {
00293 /* .......... double division avoids possible underflow ......
00294 .... */
00295 /* L320: */
00296 v[j + i__ * v_dim1] = u[i__ + j * u_dim1] / u[i__ + l * u_dim1] /
00297 g;
00298 }
00299
00300 i__1 = *n;
00301 for (j = l; j <= i__1; ++j) {
00302 s = 0.;
00303
00304 i__3 = *n;
00305 for (k = l; k <= i__3; ++k) {
00306 /* L340: */
00307 s += u[i__ + k * u_dim1] * v[k + j * v_dim1];
00308 }
00309
00310 i__3 = *n;
00311 for (k = l; k <= i__3; ++k) {
00312 v[k + j * v_dim1] += s * v[k + i__ * v_dim1];
00313 /* L350: */
00314 }
00315 }
00316
00317 L360:
00318 i__3 = *n;
00319 for (j = l; j <= i__3; ++j) {
00320 v[i__ + j * v_dim1] = 0.;
00321 v[j + i__ * v_dim1] = 0.;
00322 /* L380: */
00323 }
00324
00325 L390:
00326 v[i__ + i__ * v_dim1] = 1.;
00327 g = rv1[i__];
00328 l = i__;
00329 /* L400: */
00330 }
00331 /* .......... accumulation of left-hand transformations .......... */
00332 L410:
00333 if (! (*matu)) {
00334 goto L510;
00335 }
00336 /* ..........for i=min(m,n) step -1 until 1 do -- .......... */
00337 mn = *n;
00338 if (*m < *n) {
00339 mn = *m;
00340 }
00341
00342 i__2 = mn;
00343 for (ii = 1; ii <= i__2; ++ii) {
00344 i__ = mn + 1 - ii;
00345 l = i__ + 1;
00346 g = w[i__];
00347 if (i__ == *n) {
00348 goto L430;
00349 }
00350
00351 i__3 = *n;
00352 for (j = l; j <= i__3; ++j) {
00353 /* L420: */
00354 u[i__ + j * u_dim1] = 0.;
00355 }
00356
00357 L430:
00358 if (g == 0.) {
00359 goto L475;
00360 }
00361 if (i__ == mn) {
00362 goto L460;
00363 }
00364
00365 i__3 = *n;
00366 for (j = l; j <= i__3; ++j) {
00367 s = 0.;
00368
00369 i__1 = *m;
00370 for (k = l; k <= i__1; ++k) {
00371 /* L440: */
00372 s += u[k + i__ * u_dim1] * u[k + j * u_dim1];
00373 }
00374 /* .......... double division avoids possible underflow ......
00375 .... */
00376 f = s / u[i__ + i__ * u_dim1] / g;
00377
00378 i__1 = *m;
00379 for (k = i__; k <= i__1; ++k) {
00380 u[k + j * u_dim1] += f * u[k + i__ * u_dim1];
00381 /* L450: */
00382 }
00383 }
00384
00385 L460:
00386 i__1 = *m;
00387 for (j = i__; j <= i__1; ++j) {
00388 /* L470: */
00389 u[j + i__ * u_dim1] /= g;
00390 }
00391
00392 goto L490;
00393
00394 L475:
00395 i__1 = *m;
00396 for (j = i__; j <= i__1; ++j) {
00397 /* L480: */
00398 u[j + i__ * u_dim1] = 0.;
00399 }
00400
00401 L490:
00402 u[i__ + i__ * u_dim1] += 1.;
00403 /* L500: */
00404 }
00405 /* .......... diagonalization of the bidiagonal form .......... */
00406 L510:
00407 tst1 = x;
00408 /* .......... for k=n step -1 until 1 do -- .......... */
00409 i__2 = *n;
00410 for (kk = 1; kk <= i__2; ++kk) {
00411 k1 = *n - kk;
00412 k = k1 + 1;
00413 its = 0;
00414 /* .......... test for splitting. */
00415 /* for l=k step -1 until 1 do -- .......... */
00416 L520:
00417 i__1 = k;
00418 for (ll = 1; ll <= i__1; ++ll) {
00419 l1 = k - ll;
00420 l = l1 + 1;
00421 tst2 = tst1 + (d__1 = rv1[l], abs(d__1));
00422 if (tst2 == tst1) {
00423 goto L565;
00424 }
00425 /* .......... rv1(1) is always zero, so there is no exit */
00426 /* through the bottom of the loop .......... */
00427 tst2 = tst1 + (d__1 = w[l1], abs(d__1));
00428 if (tst2 == tst1) {
00429 goto L540;
00430 }
00431 /* L530: */
00432 }
00433 /* .......... cancellation of rv1(l) if l greater than 1 .........
00434 . */
00435 L540:
00436 c__ = 0.;
00437 s = 1.;
00438
00439 i__1 = k;
00440 for (i__ = l; i__ <= i__1; ++i__) {
00441 f = s * rv1[i__];
00442 rv1[i__] = c__ * rv1[i__];
00443 tst2 = tst1 + abs(f);
00444 if (tst2 == tst1) {
00445 goto L565;
00446 }
00447 g = w[i__];
00448 h__ = pythag_(&f, &g);
00449 w[i__] = h__;
00450 c__ = g / h__;
00451 s = -f / h__;
00452 if (! (*matu)) {
00453 goto L560;
00454 }
00455
00456 i__3 = *m;
00457 for (j = 1; j <= i__3; ++j) {
00458 y = u[j + l1 * u_dim1];
00459 z__ = u[j + i__ * u_dim1];
00460 u[j + l1 * u_dim1] = y * c__ + z__ * s;
00461 u[j + i__ * u_dim1] = -y * s + z__ * c__;
00462 /* L550: */
00463 }
00464
00465 L560:
00466 ;
00467 }
00468 /* .......... test for convergence .......... */
00469 L565:
00470 z__ = w[k];
00471 if (l == k) {
00472 goto L650;
00473 }
00474 /* .......... shift from bottom 2 by 2 minor .......... */
00475 if (its == 30) {
00476 goto L1000;
00477 }
00478 ++its;
00479 x = w[l];
00480 y = w[k1];
00481 g = rv1[k1];
00482 h__ = rv1[k];
00483 f = ((g + z__) / h__ * ((g - z__) / y) + y / h__ - h__ / y) * .5;
00484 g = pythag_(&f, &c_b47);
00485 f = x - z__ / x * z__ + h__ / x * (y / (f + d_sign(&g, &f)) - h__);
00486 /* .......... next qr transformation .......... */
00487 c__ = 1.;
00488 s = 1.;
00489
00490 i__1 = k1;
00491 for (i1 = l; i1 <= i__1; ++i1) {
00492 i__ = i1 + 1;
00493 g = rv1[i__];
00494 y = w[i__];
00495 h__ = s * g;
00496 g = c__ * g;
00497 z__ = pythag_(&f, &h__);
00498 rv1[i1] = z__;
00499 c__ = f / z__;
00500 s = h__ / z__;
00501 f = x * c__ + g * s;
00502 g = -x * s + g * c__;
00503 h__ = y * s;
00504 y *= c__;
00505 if (! (*matv)) {
00506 goto L575;
00507 }
00508
00509 i__3 = *n;
00510 for (j = 1; j <= i__3; ++j) {
00511 x = v[j + i1 * v_dim1];
00512 z__ = v[j + i__ * v_dim1];
00513 v[j + i1 * v_dim1] = x * c__ + z__ * s;
00514 v[j + i__ * v_dim1] = -x * s + z__ * c__;
00515 /* L570: */
00516 }
00517
00518 L575:
00519 z__ = pythag_(&f, &h__);
00520 w[i1] = z__;
00521 /* .......... rotation can be arbitrary if z is zero .........
00522 . */
00523 if (z__ == 0.) {
00524 goto L580;
00525 }
00526 c__ = f / z__;
00527 s = h__ / z__;
00528 L580:
00529 f = c__ * g + s * y;
00530 x = -s * g + c__ * y;
00531 if (! (*matu)) {
00532 goto L600;
00533 }
00534
00535 i__3 = *m;
00536 for (j = 1; j <= i__3; ++j) {
00537 y = u[j + i1 * u_dim1];
00538 z__ = u[j + i__ * u_dim1];
00539 u[j + i1 * u_dim1] = y * c__ + z__ * s;
00540 u[j + i__ * u_dim1] = -y * s + z__ * c__;
00541 /* L590: */
00542 }
00543
00544 L600:
00545 ;
00546 }
00547
00548 rv1[l] = 0.;
00549 rv1[k] = f;
00550 w[k] = x;
00551 goto L520;
00552 /* .......... convergence .......... */
00553 L650:
00554 if (z__ >= 0.) {
00555 goto L700;
00556 }
00557 /* .......... w(k) is made non-negative .......... */
00558 w[k] = -z__;
00559 if (! (*matv)) {
00560 goto L700;
00561 }
00562
00563 i__1 = *n;
00564 for (j = 1; j <= i__1; ++j) {
00565 /* L690: */
00566 v[j + k * v_dim1] = -v[j + k * v_dim1];
00567 }
00568
00569 L700:
00570 ;
00571 }
00572
00573 goto L1001;
00574 /* .......... set error -- no convergence to a */
00575 /* singular value after 30 iterations .......... */
00576 L1000:
00577 *ierr = k;
00578 L1001:
00579 return 0;
00580 } /* svd_ */
|
|
||||||||||||||||||||
|
Definition at line 12 of file eis_tql1.c. References abs, c_b10, d_sign(), l, p, pythag_(), and s2.
00014 {
00015 /* System generated locals */
00016 integer i__1, i__2;
00017 doublereal d__1, d__2;
00018
00019 /* Builtin functions */
00020 double d_sign(doublereal *, doublereal *);
00021
00022 /* Local variables */
00023 static doublereal c__, f, g, h__;
00024 static integer i__, j, l, m;
00025 static doublereal p, r__, s, c2, c3;
00026 static integer l1, l2;
00027 static doublereal s2;
00028 static integer ii;
00029 extern doublereal pythag_(doublereal *, doublereal *);
00030 static doublereal dl1, el1;
00031 static integer mml;
00032 static doublereal tst1, tst2;
00033
00034
00035
00036 /* THIS SUBROUTINE IS A TRANSLATION OF THE ALGOL PROCEDURE TQL1, */
00037 /* NUM. MATH. 11, 293-306(1968) BY BOWDLER, MARTIN, REINSCH, AND */
00038 /* WILKINSON. */
00039 /* HANDBOOK FOR AUTO. COMP., VOL.II-LINEAR ALGEBRA, 227-240(1971). */
00040
00041 /* THIS SUBROUTINE FINDS THE EIGENVALUES OF A SYMMETRIC */
00042 /* TRIDIAGONAL MATRIX BY THE QL METHOD. */
00043
00044 /* ON INPUT */
00045
00046 /* N IS THE ORDER OF THE MATRIX. */
00047
00048 /* D CONTAINS THE DIAGONAL ELEMENTS OF THE INPUT MATRIX. */
00049
00050 /* E CONTAINS THE SUBDIAGONAL ELEMENTS OF THE INPUT MATRIX */
00051 /* IN ITS LAST N-1 POSITIONS. E(1) IS ARBITRARY. */
00052
00053 /* ON OUTPUT */
00054
00055 /* D CONTAINS THE EIGENVALUES IN ASCENDING ORDER. IF AN */
00056 /* ERROR EXIT IS MADE, THE EIGENVALUES ARE CORRECT AND */
00057 /* ORDERED FOR INDICES 1,2,...IERR-1, BUT MAY NOT BE */
00058 /* THE SMALLEST EIGENVALUES. */
00059
00060 /* E HAS BEEN DESTROYED. */
00061
00062 /* IERR IS SET TO */
00063 /* ZERO FOR NORMAL RETURN, */
00064 /* J IF THE J-TH EIGENVALUE HAS NOT BEEN */
00065 /* DETERMINED AFTER 30 ITERATIONS. */
00066
00067 /* CALLS PYTHAG FOR DSQRT(A*A + B*B) . */
00068
00069 /* QUESTIONS AND COMMENTS SHOULD BE DIRECTED TO BURTON S. GARBOW, */
00070 /* MATHEMATICS AND COMPUTER SCIENCE DIV, ARGONNE NATIONAL LABORATORY
00071 */
00072
00073 /* THIS VERSION DATED AUGUST 1983. */
00074
00075 /* ------------------------------------------------------------------
00076 */
00077
00078 /* Parameter adjustments */
00079 --e;
00080 --d__;
00081
00082 /* Function Body */
00083 *ierr = 0;
00084 if (*n == 1) {
00085 goto L1001;
00086 }
00087
00088 i__1 = *n;
00089 for (i__ = 2; i__ <= i__1; ++i__) {
00090 /* L100: */
00091 e[i__ - 1] = e[i__];
00092 }
00093
00094 f = 0.;
00095 tst1 = 0.;
00096 e[*n] = 0.;
00097
00098 i__1 = *n;
00099 for (l = 1; l <= i__1; ++l) {
00100 j = 0;
00101 h__ = (d__1 = d__[l], abs(d__1)) + (d__2 = e[l], abs(d__2));
00102 if (tst1 < h__) {
00103 tst1 = h__;
00104 }
00105 /* .......... LOOK FOR SMALL SUB-DIAGONAL ELEMENT .......... */
00106 i__2 = *n;
00107 for (m = l; m <= i__2; ++m) {
00108 tst2 = tst1 + (d__1 = e[m], abs(d__1));
00109 if (tst2 == tst1) {
00110 goto L120;
00111 }
00112 /* .......... E(N) IS ALWAYS ZERO, SO THERE IS NO EXIT */
00113 /* THROUGH THE BOTTOM OF THE LOOP .......... */
00114 /* L110: */
00115 }
00116
00117 L120:
00118 if (m == l) {
00119 goto L210;
00120 }
00121 L130:
00122 if (j == 30) {
00123 goto L1000;
00124 }
00125 ++j;
00126 /* .......... FORM SHIFT .......... */
00127 l1 = l + 1;
00128 l2 = l1 + 1;
00129 g = d__[l];
00130 p = (d__[l1] - g) / (e[l] * 2.);
00131 r__ = pythag_(&p, &c_b10);
00132 d__[l] = e[l] / (p + d_sign(&r__, &p));
00133 d__[l1] = e[l] * (p + d_sign(&r__, &p));
00134 dl1 = d__[l1];
00135 h__ = g - d__[l];
00136 if (l2 > *n) {
00137 goto L145;
00138 }
00139
00140 i__2 = *n;
00141 for (i__ = l2; i__ <= i__2; ++i__) {
00142 /* L140: */
00143 d__[i__] -= h__;
00144 }
00145
00146 L145:
00147 f += h__;
00148 /* .......... QL TRANSFORMATION .......... */
00149 p = d__[m];
00150 c__ = 1.;
00151 c2 = c__;
00152 el1 = e[l1];
00153 s = 0.;
00154 mml = m - l;
00155 /* .......... FOR I=M-1 STEP -1 UNTIL L DO -- .......... */
00156 i__2 = mml;
00157 for (ii = 1; ii <= i__2; ++ii) {
00158 c3 = c2;
00159 c2 = c__;
00160 s2 = s;
00161 i__ = m - ii;
00162 g = c__ * e[i__];
00163 h__ = c__ * p;
00164 r__ = pythag_(&p, &e[i__]);
00165 e[i__ + 1] = s * r__;
00166 s = e[i__] / r__;
00167 c__ = p / r__;
00168 p = c__ * d__[i__] - s * g;
00169 d__[i__ + 1] = h__ + s * (c__ * g + s * d__[i__]);
00170 /* L200: */
00171 }
00172
00173 p = -s * s2 * c3 * el1 * e[l] / dl1;
00174 e[l] = s * p;
00175 d__[l] = c__ * p;
00176 tst2 = tst1 + (d__1 = e[l], abs(d__1));
00177 if (tst2 > tst1) {
00178 goto L130;
00179 }
00180 L210:
00181 p = d__[l] + f;
00182 /* .......... ORDER EIGENVALUES .......... */
00183 if (l == 1) {
00184 goto L250;
00185 }
00186 /* .......... FOR I=L STEP -1 UNTIL 2 DO -- .......... */
00187 i__2 = l;
00188 for (ii = 2; ii <= i__2; ++ii) {
00189 i__ = l + 2 - ii;
00190 if (p >= d__[i__ - 1]) {
00191 goto L270;
00192 }
00193 d__[i__] = d__[i__ - 1];
00194 /* L230: */
00195 }
00196
00197 L250:
00198 i__ = 1;
00199 L270:
00200 d__[i__] = p;
00201 /* L290: */
00202 }
00203
00204 goto L1001;
00205 /* .......... SET ERROR -- NO CONVERGENCE TO AN */
00206 /* EIGENVALUE AFTER 30 ITERATIONS .......... */
00207 L1000:
00208 *ierr = l;
00209 L1001:
00210 return 0;
00211 } /* tql1_ */
|
|
||||||||||||||||||||||||||||
|
Definition at line 12 of file eis_tql2.c. References abs, c_b10, d_sign(), l, p, pythag_(), and s2. Referenced by ch_(), rs_(), rsb_(), rsg_(), rsgab_(), rsgba_(), and rsp_().
00014 {
00015 /* System generated locals */
00016 integer z_dim1, z_offset, i__1, i__2, i__3;
00017 doublereal d__1, d__2;
00018
00019 /* Builtin functions */
00020 double d_sign(doublereal *, doublereal *);
00021
00022 /* Local variables */
00023 static doublereal c__, f, g, h__;
00024 static integer i__, j, k, l, m;
00025 static doublereal p, r__, s, c2, c3;
00026 static integer l1, l2;
00027 static doublereal s2;
00028 static integer ii;
00029 extern doublereal pythag_(doublereal *, doublereal *);
00030 static doublereal dl1, el1;
00031 static integer mml;
00032 static doublereal tst1, tst2;
00033
00034
00035
00036 /* THIS SUBROUTINE IS A TRANSLATION OF THE ALGOL PROCEDURE TQL2, */
00037 /* NUM. MATH. 11, 293-306(1968) BY BOWDLER, MARTIN, REINSCH, AND */
00038 /* WILKINSON. */
00039 /* HANDBOOK FOR AUTO. COMP., VOL.II-LINEAR ALGEBRA, 227-240(1971). */
00040
00041 /* THIS SUBROUTINE FINDS THE EIGENVALUES AND EIGENVECTORS */
00042 /* OF A SYMMETRIC TRIDIAGONAL MATRIX BY THE QL METHOD. */
00043 /* THE EIGENVECTORS OF A FULL SYMMETRIC MATRIX CAN ALSO */
00044 /* BE FOUND IF TRED2 HAS BEEN USED TO REDUCE THIS */
00045 /* FULL MATRIX TO TRIDIAGONAL FORM. */
00046
00047 /* ON INPUT */
00048
00049 /* NM MUST BE SET TO THE ROW DIMENSION OF TWO-DIMENSIONAL */
00050 /* ARRAY PARAMETERS AS DECLARED IN THE CALLING PROGRAM */
00051 /* DIMENSION STATEMENT. */
00052
00053 /* N IS THE ORDER OF THE MATRIX. */
00054
00055 /* D CONTAINS THE DIAGONAL ELEMENTS OF THE INPUT MATRIX. */
00056
00057 /* E CONTAINS THE SUBDIAGONAL ELEMENTS OF THE INPUT MATRIX */
00058 /* IN ITS LAST N-1 POSITIONS. E(1) IS ARBITRARY. */
00059
00060 /* Z CONTAINS THE TRANSFORMATION MATRIX PRODUCED IN THE */
00061 /* REDUCTION BY TRED2, IF PERFORMED. IF THE EIGENVECTORS */
00062 /* OF THE TRIDIAGONAL MATRIX ARE DESIRED, Z MUST CONTAIN */
00063 /* THE IDENTITY MATRIX. */
00064
00065 /* ON OUTPUT */
00066
00067 /* D CONTAINS THE EIGENVALUES IN ASCENDING ORDER. IF AN */
00068 /* ERROR EXIT IS MADE, THE EIGENVALUES ARE CORRECT BUT */
00069 /* UNORDERED FOR INDICES 1,2,...,IERR-1. */
00070
00071 /* E HAS BEEN DESTROYED. */
00072
00073 /* Z CONTAINS ORTHONORMAL EIGENVECTORS OF THE SYMMETRIC */
00074 /* TRIDIAGONAL (OR FULL) MATRIX. IF AN ERROR EXIT IS MADE, */
00075 /* Z CONTAINS THE EIGENVECTORS ASSOCIATED WITH THE STORED */
00076 /* EIGENVALUES. */
00077
00078 /* IERR IS SET TO */
00079 /* ZERO FOR NORMAL RETURN, */
00080 /* J IF THE J-TH EIGENVALUE HAS NOT BEEN */
00081 /* DETERMINED AFTER 30 ITERATIONS. */
00082
00083 /* CALLS PYTHAG FOR DSQRT(A*A + B*B) . */
00084
00085 /* QUESTIONS AND COMMENTS SHOULD BE DIRECTED TO BURTON S. GARBOW, */
00086 /* MATHEMATICS AND COMPUTER SCIENCE DIV, ARGONNE NATIONAL LABORATORY
00087 */
00088
00089 /* THIS VERSION DATED AUGUST 1983. */
00090
00091 /* ------------------------------------------------------------------
00092 */
00093
00094 /* Parameter adjustments */
00095 z_dim1 = *nm;
00096 z_offset = z_dim1 + 1;
00097 z__ -= z_offset;
00098 --e;
00099 --d__;
00100
00101 /* Function Body */
00102 *ierr = 0;
00103 if (*n == 1) {
00104 goto L1001;
00105 }
00106
00107 i__1 = *n;
00108 for (i__ = 2; i__ <= i__1; ++i__) {
00109 /* L100: */
00110 e[i__ - 1] = e[i__];
00111 }
00112
00113 f = 0.;
00114 tst1 = 0.;
00115 e[*n] = 0.;
00116
00117 i__1 = *n;
00118 for (l = 1; l <= i__1; ++l) {
00119 j = 0;
00120 h__ = (d__1 = d__[l], abs(d__1)) + (d__2 = e[l], abs(d__2));
00121 if (tst1 < h__) {
00122 tst1 = h__;
00123 }
00124 /* .......... LOOK FOR SMALL SUB-DIAGONAL ELEMENT .......... */
00125 i__2 = *n;
00126 for (m = l; m <= i__2; ++m) {
00127 tst2 = tst1 + (d__1 = e[m], abs(d__1));
00128 if (tst2 == tst1) {
00129 goto L120;
00130 }
00131 /* .......... E(N) IS ALWAYS ZERO, SO THERE IS NO EXIT */
00132 /* THROUGH THE BOTTOM OF THE LOOP .......... */
00133 /* L110: */
00134 }
00135
00136 L120:
00137 if (m == l) {
00138 goto L220;
00139 }
00140 L130:
00141 if (j == 30) {
00142 goto L1000;
00143 }
00144 ++j;
00145 /* .......... FORM SHIFT .......... */
00146 l1 = l + 1;
00147 l2 = l1 + 1;
00148 g = d__[l];
00149 p = (d__[l1] - g) / (e[l] * 2.);
00150 r__ = pythag_(&p, &c_b10);
00151 d__[l] = e[l] / (p + d_sign(&r__, &p));
00152 d__[l1] = e[l] * (p + d_sign(&r__, &p));
00153 dl1 = d__[l1];
00154 h__ = g - d__[l];
00155 if (l2 > *n) {
00156 goto L145;
00157 }
00158
00159 i__2 = *n;
00160 for (i__ = l2; i__ <= i__2; ++i__) {
00161 /* L140: */
00162 d__[i__] -= h__;
00163 }
00164
00165 L145:
00166 f += h__;
00167 /* .......... QL TRANSFORMATION .......... */
00168 p = d__[m];
00169 c__ = 1.;
00170 c2 = c__;
00171 el1 = e[l1];
00172 s = 0.;
00173 mml = m - l;
00174 /* .......... FOR I=M-1 STEP -1 UNTIL L DO -- .......... */
00175 i__2 = mml;
00176 for (ii = 1; ii <= i__2; ++ii) {
00177 c3 = c2;
00178 c2 = c__;
00179 s2 = s;
00180 i__ = m - ii;
00181 g = c__ * e[i__];
00182 h__ = c__ * p;
00183 r__ = pythag_(&p, &e[i__]);
00184 e[i__ + 1] = s * r__;
00185 s = e[i__] / r__;
00186 c__ = p / r__;
00187 p = c__ * d__[i__] - s * g;
00188 d__[i__ + 1] = h__ + s * (c__ * g + s * d__[i__]);
00189 /* .......... FORM VECTOR .......... */
00190 i__3 = *n;
00191 for (k = 1; k <= i__3; ++k) {
00192 h__ = z__[k + (i__ + 1) * z_dim1];
00193 z__[k + (i__ + 1) * z_dim1] = s * z__[k + i__ * z_dim1] + c__
00194 * h__;
00195 z__[k + i__ * z_dim1] = c__ * z__[k + i__ * z_dim1] - s * h__;
00196 /* L180: */
00197 }
00198
00199 /* L200: */
00200 }
00201
00202 p = -s * s2 * c3 * el1 * e[l] / dl1;
00203 e[l] = s * p;
00204 d__[l] = c__ * p;
00205 tst2 = tst1 + (d__1 = e[l], abs(d__1));
00206 if (tst2 > tst1) {
00207 goto L130;
00208 }
00209 L220:
00210 d__[l] += f;
00211 /* L240: */
00212 }
00213 /* .......... ORDER EIGENVALUES AND EIGENVECTORS .......... */
00214 i__1 = *n;
00215 for (ii = 2; ii <= i__1; ++ii) {
00216 i__ = ii - 1;
00217 k = i__;
00218 p = d__[i__];
00219
00220 i__2 = *n;
00221 for (j = ii; j <= i__2; ++j) {
00222 if (d__[j] >= p) {
00223 goto L260;
00224 }
00225 k = j;
00226 p = d__[j];
00227 L260:
00228 ;
00229 }
00230
00231 if (k == i__) {
00232 goto L300;
00233 }
00234 d__[k] = d__[i__];
00235 d__[i__] = p;
00236
00237 i__2 = *n;
00238 for (j = 1; j <= i__2; ++j) {
00239 p = z__[j + i__ * z_dim1];
00240 z__[j + i__ * z_dim1] = z__[j + k * z_dim1];
00241 z__[j + k * z_dim1] = p;
00242 /* L280: */
00243 }
00244
00245 L300:
00246 ;
00247 }
00248
00249 goto L1001;
00250 /* .......... SET ERROR -- NO CONVERGENCE TO AN */
00251 /* EIGENVALUE AFTER 30 ITERATIONS .......... */
00252 L1000:
00253 *ierr = l;
00254 L1001:
00255 return 0;
00256 } /* tql2_ */
|
|
||||||||||||||||||||
|
Definition at line 12 of file eis_tqlrat.c. References abs, c_b11, d_sign(), epslon_(), l, p, and pythag_(). Referenced by ch_(), rs_(), rsb_(), rsg_(), rsgab_(), rsgba_(), rsm_(), and rsp_().
00014 {
00015 /* System generated locals */
00016 integer i__1, i__2;
00017 doublereal d__1, d__2;
00018
00019 /* Builtin functions */
00020 double d_sign(doublereal *, doublereal *);
00021
00022 /* Local variables */
00023 static doublereal b, c__, f, g, h__;
00024 static integer i__, j, l, m;
00025 static doublereal p, r__, s, t;
00026 static integer l1, ii;
00027 extern doublereal pythag_(doublereal *, doublereal *), epslon_(doublereal
00028 *);
00029 static integer mml;
00030
00031
00032
00033 /* THIS SUBROUTINE IS A TRANSLATION OF THE ALGOL PROCEDURE TQLRAT, */
00034 /* ALGORITHM 464, COMM. ACM 16, 689(1973) BY REINSCH. */
00035
00036 /* THIS SUBROUTINE FINDS THE EIGENVALUES OF A SYMMETRIC */
00037 /* TRIDIAGONAL MATRIX BY THE RATIONAL QL METHOD. */
00038
00039 /* ON INPUT */
00040
00041 /* N IS THE ORDER OF THE MATRIX. */
00042
00043 /* D CONTAINS THE DIAGONAL ELEMENTS OF THE INPUT MATRIX. */
00044
00045 /* E2 CONTAINS THE SQUARES OF THE SUBDIAGONAL ELEMENTS OF THE */
00046 /* INPUT MATRIX IN ITS LAST N-1 POSITIONS. E2(1) IS ARBITRARY.
00047 */
00048
00049 /* ON OUTPUT */
00050
00051 /* D CONTAINS THE EIGENVALUES IN ASCENDING ORDER. IF AN */
00052 /* ERROR EXIT IS MADE, THE EIGENVALUES ARE CORRECT AND */
00053 /* ORDERED FOR INDICES 1,2,...IERR-1, BUT MAY NOT BE */
00054 /* THE SMALLEST EIGENVALUES. */
00055
00056 /* E2 HAS BEEN DESTROYED. */
00057
00058 /* IERR IS SET TO */
00059 /* ZERO FOR NORMAL RETURN, */
00060 /* J IF THE J-TH EIGENVALUE HAS NOT BEEN */
00061 /* DETERMINED AFTER 30 ITERATIONS. */
00062
00063 /* CALLS PYTHAG FOR DSQRT(A*A + B*B) . */
00064
00065 /* QUESTIONS AND COMMENTS SHOULD BE DIRECTED TO BURTON S. GARBOW, */
00066 /* MATHEMATICS AND COMPUTER SCIENCE DIV, ARGONNE NATIONAL LABORATORY
00067 */
00068
00069 /* THIS VERSION DATED AUGUST 1983. */
00070
00071 /* ------------------------------------------------------------------
00072 */
00073
00074 /* Parameter adjustments */
00075 --e2;
00076 --d__;
00077
00078 /* Function Body */
00079 *ierr = 0;
00080 if (*n == 1) {
00081 goto L1001;
00082 }
00083
00084 i__1 = *n;
00085 for (i__ = 2; i__ <= i__1; ++i__) {
00086 /* L100: */
00087 e2[i__ - 1] = e2[i__];
00088 }
00089
00090 f = 0.;
00091 t = 0.;
00092 e2[*n] = 0.;
00093
00094 i__1 = *n;
00095 for (l = 1; l <= i__1; ++l) {
00096 j = 0;
00097 h__ = (d__1 = d__[l], abs(d__1)) + sqrt(e2[l]);
00098 if (t > h__) {
00099 goto L105;
00100 }
00101 t = h__;
00102 b = epslon_(&t);
00103 c__ = b * b;
00104 /* .......... LOOK FOR SMALL SQUARED SUB-DIAGONAL ELEMENT ........
00105 .. */
00106 L105:
00107 i__2 = *n;
00108 for (m = l; m <= i__2; ++m) {
00109 if (e2[m] <= c__) {
00110 goto L120;
00111 }
00112 /* .......... E2(N) IS ALWAYS ZERO, SO THERE IS NO EXIT */
00113 /* THROUGH THE BOTTOM OF THE LOOP .......... */
00114 /* L110: */
00115 }
00116
00117 L120:
00118 if (m == l) {
00119 goto L210;
00120 }
00121 L130:
00122 if (j == 30) {
00123 goto L1000;
00124 }
00125 ++j;
00126 /* .......... FORM SHIFT .......... */
00127 l1 = l + 1;
00128 s = sqrt(e2[l]);
00129 g = d__[l];
00130 p = (d__[l1] - g) / (s * 2.);
00131 r__ = pythag_(&p, &c_b11);
00132 d__[l] = s / (p + d_sign(&r__, &p));
00133 h__ = g - d__[l];
00134
00135 i__2 = *n;
00136 for (i__ = l1; i__ <= i__2; ++i__) {
00137 /* L140: */
00138 d__[i__] -= h__;
00139 }
00140
00141 f += h__;
00142 /* .......... RATIONAL QL TRANSFORMATION .......... */
00143 g = d__[m];
00144 if (g == 0.) {
00145 g = b;
00146 }
00147 h__ = g;
00148 s = 0.;
00149 mml = m - l;
00150 /* .......... FOR I=M-1 STEP -1 UNTIL L DO -- .......... */
00151 i__2 = mml;
00152 for (ii = 1; ii <= i__2; ++ii) {
00153 i__ = m - ii;
00154 p = g * h__;
00155 r__ = p + e2[i__];
00156 e2[i__ + 1] = s * r__;
00157 s = e2[i__] / r__;
00158 d__[i__ + 1] = h__ + s * (h__ + d__[i__]);
00159 g = d__[i__] - e2[i__] / g;
00160 if (g == 0.) {
00161 g = b;
00162 }
00163 h__ = g * p / r__;
00164 /* L200: */
00165 }
00166
00167 e2[l] = s * g;
00168 d__[l] = h__;
00169 /* .......... GUARD AGAINST UNDERFLOW IN CONVERGENCE TEST ........
00170 .. */
00171 if (h__ == 0.) {
00172 goto L210;
00173 }
00174 if ((d__1 = e2[l], abs(d__1)) <= (d__2 = c__ / h__, abs(d__2))) {
00175 goto L210;
00176 }
00177 e2[l] = h__ * e2[l];
00178 if (e2[l] != 0.) {
00179 goto L130;
00180 }
00181 L210:
00182 p = d__[l] + f;
00183 /* .......... ORDER EIGENVALUES .......... */
00184 if (l == 1) {
00185 goto L250;
00186 }
00187 /* .......... FOR I=L STEP -1 UNTIL 2 DO -- .......... */
00188 i__2 = l;
00189 for (ii = 2; ii <= i__2; ++ii) {
00190 i__ = l + 2 - ii;
00191 if (p >= d__[i__ - 1]) {
00192 goto L270;
00193 }
00194 d__[i__] = d__[i__ - 1];
00195 /* L230: */
00196 }
00197
00198 L250:
00199 i__ = 1;
00200 L270:
00201 d__[i__] = p;
00202 /* L290: */
00203 }
00204
00205 goto L1001;
00206 /* .......... SET ERROR -- NO CONVERGENCE TO AN */
00207 /* EIGENVALUE AFTER 30 ITERATIONS .......... */
00208 L1000:
00209 *ierr = l;
00210 L1001:
00211 return 0;
00212 } /* tqlrat_ */
|
|
||||||||||||||||||||||||||||
|
Definition at line 8 of file eis_trbak1.c. Referenced by rsm_().
00010 {
00011 /* System generated locals */
00012 integer a_dim1, a_offset, z_dim1, z_offset, i__1, i__2, i__3;
00013
00014 /* Local variables */
00015 static integer i__, j, k, l;
00016 static doublereal s;
00017
00018
00019
00020 /* THIS SUBROUTINE IS A TRANSLATION OF THE ALGOL PROCEDURE TRBAK1, */
00021 /* NUM. MATH. 11, 181-195(1968) BY MARTIN, REINSCH, AND WILKINSON. */
00022 /* HANDBOOK FOR AUTO. COMP., VOL.II-LINEAR ALGEBRA, 212-226(1971). */
00023
00024 /* THIS SUBROUTINE FORMS THE EIGENVECTORS OF A REAL SYMMETRIC */
00025 /* MATRIX BY BACK TRANSFORMING THOSE OF THE CORRESPONDING */
00026 /* SYMMETRIC TRIDIAGONAL MATRIX DETERMINED BY TRED1. */
00027
00028 /* ON INPUT */
00029
00030 /* NM MUST BE SET TO THE ROW DIMENSION OF TWO-DIMENSIONAL */
00031 /* ARRAY PARAMETERS AS DECLARED IN THE CALLING PROGRAM */
00032 /* DIMENSION STATEMENT. */
00033
00034 /* N IS THE ORDER OF THE MATRIX. */
00035
00036 /* A CONTAINS INFORMATION ABOUT THE ORTHOGONAL TRANS- */
00037 /* FORMATIONS USED IN THE REDUCTION BY TRED1 */
00038 /* IN ITS STRICT LOWER TRIANGLE. */
00039
00040 /* E CONTAINS THE SUBDIAGONAL ELEMENTS OF THE TRIDIAGONAL */
00041 /* MATRIX IN ITS LAST N-1 POSITIONS. E(1) IS ARBITRARY. */
00042
00043 /* M IS THE NUMBER OF EIGENVECTORS TO BE BACK TRANSFORMED. */
00044
00045 /* Z CONTAINS THE EIGENVECTORS TO BE BACK TRANSFORMED */
00046 /* IN ITS FIRST M COLUMNS. */
00047
00048 /* ON OUTPUT */
00049
00050 /* Z CONTAINS THE TRANSFORMED EIGENVECTORS */
00051 /* IN ITS FIRST M COLUMNS. */
00052
00053 /* NOTE THAT TRBAK1 PRESERVES VECTOR EUCLIDEAN NORMS. */
00054
00055 /* QUESTIONS AND COMMENTS SHOULD BE DIRECTED TO BURTON S. GARBOW, */
00056 /* MATHEMATICS AND COMPUTER SCIENCE DIV, ARGONNE NATIONAL LABORATORY
00057 */
00058
00059 /* THIS VERSION DATED AUGUST 1983. */
00060
00061 /* ------------------------------------------------------------------
00062 */
00063
00064 /* Parameter adjustments */
00065 --e;
00066 a_dim1 = *nm;
00067 a_offset = a_dim1 + 1;
00068 a -= a_offset;
00069 z_dim1 = *nm;
00070 z_offset = z_dim1 + 1;
00071 z__ -= z_offset;
00072
00073 /* Function Body */
00074 if (*m == 0) {
00075 goto L200;
00076 }
00077 if (*n == 1) {
00078 goto L200;
00079 }
00080
00081 i__1 = *n;
00082 for (i__ = 2; i__ <= i__1; ++i__) {
00083 l = i__ - 1;
00084 if (e[i__] == 0.) {
00085 goto L140;
00086 }
00087
00088 i__2 = *m;
00089 for (j = 1; j <= i__2; ++j) {
00090 s = 0.;
00091
00092 i__3 = l;
00093 for (k = 1; k <= i__3; ++k) {
00094 /* L110: */
00095 s += a[i__ + k * a_dim1] * z__[k + j * z_dim1];
00096 }
00097 /* .......... DIVISOR BELOW IS NEGATIVE OF H FORMED IN TRED1.
00098 */
00099 /* DOUBLE DIVISION AVOIDS POSSIBLE UNDERFLOW ......
00100 .... */
00101 s = s / a[i__ + l * a_dim1] / e[i__];
00102
00103 i__3 = l;
00104 for (k = 1; k <= i__3; ++k) {
00105 /* L120: */
00106 z__[k + j * z_dim1] += s * a[i__ + k * a_dim1];
00107 }
00108
00109 /* L130: */
00110 }
00111
00112 L140:
00113 ;
00114 }
00115
00116 L200:
00117 return 0;
00118 } /* trbak1_ */
|
|
||||||||||||||||||||||||||||
|
Definition at line 8 of file eis_trbak3.c. Referenced by rsp_().
00010 {
00011 /* System generated locals */
00012 integer z_dim1, z_offset, i__1, i__2, i__3;
00013
00014 /* Local variables */
00015 static doublereal h__;
00016 static integer i__, j, k, l;
00017 static doublereal s;
00018 static integer ik, iz;
00019
00020
00021
00022 /* THIS SUBROUTINE IS A TRANSLATION OF THE ALGOL PROCEDURE TRBAK3, */
00023 /* NUM. MATH. 11, 181-195(1968) BY MARTIN, REINSCH, AND WILKINSON. */
00024 /* HANDBOOK FOR AUTO. COMP., VOL.II-LINEAR ALGEBRA, 212-226(1971). */
00025
00026 /* THIS SUBROUTINE FORMS THE EIGENVECTORS OF A REAL SYMMETRIC */
00027 /* MATRIX BY BACK TRANSFORMING THOSE OF THE CORRESPONDING */
00028 /* SYMMETRIC TRIDIAGONAL MATRIX DETERMINED BY TRED3. */
00029
00030 /* ON INPUT */
00031
00032 /* NM MUST BE SET TO THE ROW DIMENSION OF TWO-DIMENSIONAL */
00033 /* ARRAY PARAMETERS AS DECLARED IN THE CALLING PROGRAM */
00034 /* DIMENSION STATEMENT. */
00035
00036 /* N IS THE ORDER OF THE MATRIX. */
00037
00038 /* NV MUST BE SET TO THE DIMENSION OF THE ARRAY PARAMETER A */
00039 /* AS DECLARED IN THE CALLING PROGRAM DIMENSION STATEMENT. */
00040
00041 /* A CONTAINS INFORMATION ABOUT THE ORTHOGONAL TRANSFORMATIONS */
00042 /* USED IN THE REDUCTION BY TRED3 IN ITS FIRST */
00043 /* N*(N+1)/2 POSITIONS. */
00044
00045 /* M IS THE NUMBER OF EIGENVECTORS TO BE BACK TRANSFORMED. */
00046
00047 /* Z CONTAINS THE EIGENVECTORS TO BE BACK TRANSFORMED */
00048 /* IN ITS FIRST M COLUMNS. */
00049
00050 /* ON OUTPUT */
00051
00052 /* Z CONTAINS THE TRANSFORMED EIGENVECTORS */
00053 /* IN ITS FIRST M COLUMNS. */
00054
00055 /* NOTE THAT TRBAK3 PRESERVES VECTOR EUCLIDEAN NORMS. */
00056
00057 /* QUESTIONS AND COMMENTS SHOULD BE DIRECTED TO BURTON S. GARBOW, */
00058 /* MATHEMATICS AND COMPUTER SCIENCE DIV, ARGONNE NATIONAL LABORATORY
00059 */
00060
00061 /* THIS VERSION DATED AUGUST 1983. */
00062
00063 /* ------------------------------------------------------------------
00064 */
00065
00066 /* Parameter adjustments */
00067 --a;
00068 z_dim1 = *nm;
00069 z_offset = z_dim1 + 1;
00070 z__ -= z_offset;
00071
00072 /* Function Body */
00073 if (*m == 0) {
00074 goto L200;
00075 }
00076 if (*n == 1) {
00077 goto L200;
00078 }
00079
00080 i__1 = *n;
00081 for (i__ = 2; i__ <= i__1; ++i__) {
00082 l = i__ - 1;
00083 iz = i__ * l / 2;
00084 ik = iz + i__;
00085 h__ = a[ik];
00086 if (h__ == 0.) {
00087 goto L140;
00088 }
00089
00090 i__2 = *m;
00091 for (j = 1; j <= i__2; ++j) {
00092 s = 0.;
00093 ik = iz;
00094
00095 i__3 = l;
00096 for (k = 1; k <= i__3; ++k) {
00097 ++ik;
00098 s += a[ik] * z__[k + j * z_dim1];
00099 /* L110: */
00100 }
00101 /* .......... DOUBLE DIVISION AVOIDS POSSIBLE UNDERFLOW ......
00102 .... */
00103 s = s / h__ / h__;
00104 ik = iz;
00105
00106 i__3 = l;
00107 for (k = 1; k <= i__3; ++k) {
00108 ++ik;
00109 z__[k + j * z_dim1] -= s * a[ik];
00110 /* L120: */
00111 }
00112
00113 /* L130: */
00114 }
00115
00116 L140:
00117 ;
00118 }
00119
00120 L200:
00121 return 0;
00122 } /* trbak3_ */
|
|
||||||||||||||||||||||||||||
|
Definition at line 8 of file eis_tred1.c. References a, abs, d_sign(), l, and scale. Referenced by rs_(), rsg_(), rsgab_(), rsgba_(), and rsm_().
00010 {
00011 /* System generated locals */
00012 integer a_dim1, a_offset, i__1, i__2, i__3;
00013 doublereal d__1;
00014
00015 /* Builtin functions */
00016 double d_sign(doublereal *, doublereal *);
00017
00018 /* Local variables */
00019 static doublereal f, g, h__;
00020 static integer i__, j, k, l;
00021 static doublereal scale;
00022 static integer ii, jp1;
00023
00024
00025
00026 /* THIS SUBROUTINE IS A TRANSLATION OF THE ALGOL PROCEDURE TRED1, */
00027 /* NUM. MATH. 11, 181-195(1968) BY MARTIN, REINSCH, AND WILKINSON. */
00028 /* HANDBOOK FOR AUTO. COMP., VOL.II-LINEAR ALGEBRA, 212-226(1971). */
00029
00030 /* THIS SUBROUTINE REDUCES A REAL SYMMETRIC MATRIX */
00031 /* TO A SYMMETRIC TRIDIAGONAL MATRIX USING */
00032 /* ORTHOGONAL SIMILARITY TRANSFORMATIONS. */
00033
00034 /* ON INPUT */
00035
00036 /* NM MUST BE SET TO THE ROW DIMENSION OF TWO-DIMENSIONAL */
00037 /* ARRAY PARAMETERS AS DECLARED IN THE CALLING PROGRAM */
00038 /* DIMENSION STATEMENT. */
00039
00040 /* N IS THE ORDER OF THE MATRIX. */
00041
00042 /* A CONTAINS THE REAL SYMMETRIC INPUT MATRIX. ONLY THE */
00043 /* LOWER TRIANGLE OF THE MATRIX NEED BE SUPPLIED. */
00044
00045 /* ON OUTPUT */
00046
00047 /* A CONTAINS INFORMATION ABOUT THE ORTHOGONAL TRANS- */
00048 /* FORMATIONS USED IN THE REDUCTION IN ITS STRICT LOWER */
00049 /* TRIANGLE. THE FULL UPPER TRIANGLE OF A IS UNALTERED. */
00050
00051 /* D CONTAINS THE DIAGONAL ELEMENTS OF THE TRIDIAGONAL MATRIX. */
00052
00053 /* E CONTAINS THE SUBDIAGONAL ELEMENTS OF THE TRIDIAGONAL */
00054 /* MATRIX IN ITS LAST N-1 POSITIONS. E(1) IS SET TO ZERO. */
00055
00056 /* E2 CONTAINS THE SQUARES OF THE CORRESPONDING ELEMENTS OF E. */
00057 /* E2 MAY COINCIDE WITH E IF THE SQUARES ARE NOT NEEDED. */
00058
00059 /* QUESTIONS AND COMMENTS SHOULD BE DIRECTED TO BURTON S. GARBOW, */
00060 /* MATHEMATICS AND COMPUTER SCIENCE DIV, ARGONNE NATIONAL LABORATORY
00061 */
00062
00063 /* THIS VERSION DATED AUGUST 1983. */
00064
00065 /* ------------------------------------------------------------------
00066 */
00067
00068 /* Parameter adjustments */
00069 --e2;
00070 --e;
00071 --d__;
00072 a_dim1 = *nm;
00073 a_offset = a_dim1 + 1;
00074 a -= a_offset;
00075
00076 /* Function Body */
00077 i__1 = *n;
00078 for (i__ = 1; i__ <= i__1; ++i__) {
00079 d__[i__] = a[*n + i__ * a_dim1];
00080 a[*n + i__ * a_dim1] = a[i__ + i__ * a_dim1];
00081 /* L100: */
00082 }
00083 /* .......... FOR I=N STEP -1 UNTIL 1 DO -- .......... */
00084 i__1 = *n;
00085 for (ii = 1; ii <= i__1; ++ii) {
00086 i__ = *n + 1 - ii;
00087 l = i__ - 1;
00088 h__ = 0.;
00089 scale = 0.;
00090 if (l < 1) {
00091 goto L130;
00092 }
00093 /* .......... SCALE ROW (ALGOL TOL THEN NOT NEEDED) .......... */
00094 i__2 = l;
00095 for (k = 1; k <= i__2; ++k) {
00096 /* L120: */
00097 scale += (d__1 = d__[k], abs(d__1));
00098 }
00099
00100 if (scale != 0.) {
00101 goto L140;
00102 }
00103
00104 i__2 = l;
00105 for (j = 1; j <= i__2; ++j) {
00106 d__[j] = a[l + j * a_dim1];
00107 a[l + j * a_dim1] = a[i__ + j * a_dim1];
00108 a[i__ + j * a_dim1] = 0.;
00109 /* L125: */
00110 }
00111
00112 L130:
00113 e[i__] = 0.;
00114 e2[i__] = 0.;
00115 goto L300;
00116
00117 L140:
00118 i__2 = l;
00119 for (k = 1; k <= i__2; ++k) {
00120 d__[k] /= scale;
00121 h__ += d__[k] * d__[k];
00122 /* L150: */
00123 }
00124
00125 e2[i__] = scale * scale * h__;
00126 f = d__[l];
00127 d__1 = sqrt(h__);
00128 g = -d_sign(&d__1, &f);
00129 e[i__] = scale * g;
00130 h__ -= f * g;
00131 d__[l] = f - g;
00132 if (l == 1) {
00133 goto L285;
00134 }
00135 /* .......... FORM A*U .......... */
00136 i__2 = l;
00137 for (j = 1; j <= i__2; ++j) {
00138 /* L170: */
00139 e[j] = 0.;
00140 }
00141
00142 i__2 = l;
00143 for (j = 1; j <= i__2; ++j) {
00144 f = d__[j];
00145 g = e[j] + a[j + j * a_dim1] * f;
00146 jp1 = j + 1;
00147 if (l < jp1) {
00148 goto L220;
00149 }
00150
00151 i__3 = l;
00152 for (k = jp1; k <= i__3; ++k) {
00153 g += a[k + j * a_dim1] * d__[k];
00154 e[k] += a[k + j * a_dim1] * f;
00155 /* L200: */
00156 }
00157
00158 L220:
00159 e[j] = g;
00160 /* L240: */
00161 }
00162 /* .......... FORM P .......... */
00163 f = 0.;
00164
00165 i__2 = l;
00166 for (j = 1; j <= i__2; ++j) {
00167 e[j] /= h__;
00168 f += e[j] * d__[j];
00169 /* L245: */
00170 }
00171
00172 h__ = f / (h__ + h__);
00173 /* .......... FORM Q .......... */
00174 i__2 = l;
00175 for (j = 1; j <= i__2; ++j) {
00176 /* L250: */
00177 e[j] -= h__ * d__[j];
00178 }
00179 /* .......... FORM REDUCED A .......... */
00180 i__2 = l;
00181 for (j = 1; j <= i__2; ++j) {
00182 f = d__[j];
00183 g = e[j];
00184
00185 i__3 = l;
00186 for (k = j; k <= i__3; ++k) {
00187 /* L260: */
00188 a[k + j * a_dim1] = a[k + j * a_dim1] - f * e[k] - g * d__[k];
00189 }
00190
00191 /* L280: */
00192 }
00193
00194 L285:
00195 i__2 = l;
00196 for (j = 1; j <= i__2; ++j) {
00197 f = d__[j];
00198 d__[j] = a[l + j * a_dim1];
00199 a[l + j * a_dim1] = a[i__ + j * a_dim1];
00200 a[i__ + j * a_dim1] = f * scale;
00201 /* L290: */
00202 }
00203
00204 L300:
00205 ;
00206 }
00207
00208 return 0;
00209 } /* tred1_ */
|
|
||||||||||||||||||||||||||||
|
Definition at line 8 of file eis_tred2.c. References a, abs, d_sign(), l, and scale. Referenced by rs_(), rsg_(), rsgab_(), and rsgba_().
00010 {
00011 /* System generated locals */
00012 integer a_dim1, a_offset, z_dim1, z_offset, i__1, i__2, i__3;
00013 doublereal d__1;
00014
00015 /* Builtin functions */
00016 double d_sign(doublereal *, doublereal *);
00017
00018 /* Local variables */
00019 static doublereal f, g, h__;
00020 static integer i__, j, k, l;
00021 static doublereal scale, hh;
00022 static integer ii, jp1;
00023
00024
00025
00026 /* THIS SUBROUTINE IS A TRANSLATION OF THE ALGOL PROCEDURE TRED2, */
00027 /* NUM. MATH. 11, 181-195(1968) BY MARTIN, REINSCH, AND WILKINSON. */
00028 /* HANDBOOK FOR AUTO. COMP., VOL.II-LINEAR ALGEBRA, 212-226(1971). */
00029
00030 /* THIS SUBROUTINE REDUCES A REAL SYMMETRIC MATRIX TO A */
00031 /* SYMMETRIC TRIDIAGONAL MATRIX USING AND ACCUMULATING */
00032 /* ORTHOGONAL SIMILARITY TRANSFORMATIONS. */
00033
00034 /* ON INPUT */
00035
00036 /* NM MUST BE SET TO THE ROW DIMENSION OF TWO-DIMENSIONAL */
00037 /* ARRAY PARAMETERS AS DECLARED IN THE CALLING PROGRAM */
00038 /* DIMENSION STATEMENT. */
00039
00040 /* N IS THE ORDER OF THE MATRIX. */
00041
00042 /* A CONTAINS THE REAL SYMMETRIC INPUT MATRIX. ONLY THE */
00043 /* LOWER TRIANGLE OF THE MATRIX NEED BE SUPPLIED. */
00044
00045 /* ON OUTPUT */
00046
00047 /* D CONTAINS THE DIAGONAL ELEMENTS OF THE TRIDIAGONAL MATRIX. */
00048
00049 /* E CONTAINS THE SUBDIAGONAL ELEMENTS OF THE TRIDIAGONAL */
00050 /* MATRIX IN ITS LAST N-1 POSITIONS. E(1) IS SET TO ZERO. */
00051
00052 /* Z CONTAINS THE ORTHOGONAL TRANSFORMATION MATRIX */
00053 /* PRODUCED IN THE REDUCTION. */
00054
00055 /* A AND Z MAY COINCIDE. IF DISTINCT, A IS UNALTERED. */
00056
00057 /* QUESTIONS AND COMMENTS SHOULD BE DIRECTED TO BURTON S. GARBOW, */
00058 /* MATHEMATICS AND COMPUTER SCIENCE DIV, ARGONNE NATIONAL LABORATORY
00059 */
00060
00061 /* THIS VERSION DATED AUGUST 1983. */
00062
00063 /* ------------------------------------------------------------------
00064 */
00065
00066 /* Parameter adjustments */
00067 z_dim1 = *nm;
00068 z_offset = z_dim1 + 1;
00069 z__ -= z_offset;
00070 --e;
00071 --d__;
00072 a_dim1 = *nm;
00073 a_offset = a_dim1 + 1;
00074 a -= a_offset;
00075
00076 /* Function Body */
00077 i__1 = *n;
00078 for (i__ = 1; i__ <= i__1; ++i__) {
00079
00080 i__2 = *n;
00081 for (j = i__; j <= i__2; ++j) {
00082 /* L80: */
00083 z__[j + i__ * z_dim1] = a[j + i__ * a_dim1];
00084 }
00085
00086 d__[i__] = a[*n + i__ * a_dim1];
00087 /* L100: */
00088 }
00089
00090 if (*n == 1) {
00091 goto L510;
00092 }
00093 /* .......... FOR I=N STEP -1 UNTIL 2 DO -- .......... */
00094 i__1 = *n;
00095 for (ii = 2; ii <= i__1; ++ii) {
00096 i__ = *n + 2 - ii;
00097 l = i__ - 1;
00098 h__ = 0.;
00099 scale = 0.;
00100 if (l < 2) {
00101 goto L130;
00102 }
00103 /* .......... SCALE ROW (ALGOL TOL THEN NOT NEEDED) .......... */
00104 i__2 = l;
00105 for (k = 1; k <= i__2; ++k) {
00106 /* L120: */
00107 scale += (d__1 = d__[k], abs(d__1));
00108 }
00109
00110 if (scale != 0.) {
00111 goto L140;
00112 }
00113 L130:
00114 e[i__] = d__[l];
00115
00116 i__2 = l;
00117 for (j = 1; j <= i__2; ++j) {
00118 d__[j] = z__[l + j * z_dim1];
00119 z__[i__ + j * z_dim1] = 0.;
00120 z__[j + i__ * z_dim1] = 0.;
00121 /* L135: */
00122 }
00123
00124 goto L290;
00125
00126 L140:
00127 i__2 = l;
00128 for (k = 1; k <= i__2; ++k) {
00129 d__[k] /= scale;
00130 h__ += d__[k] * d__[k];
00131 /* L150: */
00132 }
00133
00134 f = d__[l];
00135 d__1 = sqrt(h__);
00136 g = -d_sign(&d__1, &f);
00137 e[i__] = scale * g;
00138 h__ -= f * g;
00139 d__[l] = f - g;
00140 /* .......... FORM A*U .......... */
00141 i__2 = l;
00142 for (j = 1; j <= i__2; ++j) {
00143 /* L170: */
00144 e[j] = 0.;
00145 }
00146
00147 i__2 = l;
00148 for (j = 1; j <= i__2; ++j) {
00149 f = d__[j];
00150 z__[j + i__ * z_dim1] = f;
00151 g = e[j] + z__[j + j * z_dim1] * f;
00152 jp1 = j + 1;
00153 if (l < jp1) {
00154 goto L220;
00155 }
00156
00157 i__3 = l;
00158 for (k = jp1; k <= i__3; ++k) {
00159 g += z__[k + j * z_dim1] * d__[k];
00160 e[k] += z__[k + j * z_dim1] * f;
00161 /* L200: */
00162 }
00163
00164 L220:
00165 e[j] = g;
00166 /* L240: */
00167 }
00168 /* .......... FORM P .......... */
00169 f = 0.;
00170
00171 i__2 = l;
00172 for (j = 1; j <= i__2; ++j) {
00173 e[j] /= h__;
00174 f += e[j] * d__[j];
00175 /* L245: */
00176 }
00177
00178 hh = f / (h__ + h__);
00179 /* .......... FORM Q .......... */
00180 i__2 = l;
00181 for (j = 1; j <= i__2; ++j) {
00182 /* L250: */
00183 e[j] -= hh * d__[j];
00184 }
00185 /* .......... FORM REDUCED A .......... */
00186 i__2 = l;
00187 for (j = 1; j <= i__2; ++j) {
00188 f = d__[j];
00189 g = e[j];
00190
00191 i__3 = l;
00192 for (k = j; k <= i__3; ++k) {
00193 /* L260: */
00194 z__[k + j * z_dim1] = z__[k + j * z_dim1] - f * e[k] - g *
00195 d__[k];
00196 }
00197
00198 d__[j] = z__[l + j * z_dim1];
00199 z__[i__ + j * z_dim1] = 0.;
00200 /* L280: */
00201 }
00202
00203 L290:
00204 d__[i__] = h__;
00205 /* L300: */
00206 }
00207 /* .......... ACCUMULATION OF TRANSFORMATION MATRICES .......... */
00208 i__1 = *n;
00209 for (i__ = 2; i__ <= i__1; ++i__) {
00210 l = i__ - 1;
00211 z__[*n + l * z_dim1] = z__[l + l * z_dim1];
00212 z__[l + l * z_dim1] = 1.;
00213 h__ = d__[i__];
00214 if (h__ == 0.) {
00215 goto L380;
00216 }
00217
00218 i__2 = l;
00219 for (k = 1; k <= i__2; ++k) {
00220 /* L330: */
00221 d__[k] = z__[k + i__ * z_dim1] / h__;
00222 }
00223
00224 i__2 = l;
00225 for (j = 1; j <= i__2; ++j) {
00226 g = 0.;
00227
00228 i__3 = l;
00229 for (k = 1; k <= i__3; ++k) {
00230 /* L340: */
00231 g += z__[k + i__ * z_dim1] * z__[k + j * z_dim1];
00232 }
00233
00234 i__3 = l;
00235 for (k = 1; k <= i__3; ++k) {
00236 z__[k + j * z_dim1] -= g * d__[k];
00237 /* L360: */
00238 }
00239 }
00240
00241 L380:
00242 i__3 = l;
00243 for (k = 1; k <= i__3; ++k) {
00244 /* L400: */
00245 z__[k + i__ * z_dim1] = 0.;
00246 }
00247
00248 /* L500: */
00249 }
00250
00251 L510:
00252 i__1 = *n;
00253 for (i__ = 1; i__ <= i__1; ++i__) {
00254 d__[i__] = z__[*n + i__ * z_dim1];
00255 z__[*n + i__ * z_dim1] = 0.;
00256 /* L520: */
00257 }
00258
00259 z__[*n + *n * z_dim1] = 1.;
00260 e[1] = 0.;
00261 return 0;
00262 } /* tred2_ */
|
|
||||||||||||||||||||||||||||
|
Definition at line 8 of file eis_tred3.c. References a, abs, d_sign(), l, and scale. Referenced by rsp_().
00010 {
00011 /* System generated locals */
00012 integer i__1, i__2, i__3;
00013 doublereal d__1;
00014
00015 /* Builtin functions */
00016 double sqrt(doublereal), d_sign(doublereal *, doublereal *);
00017
00018 /* Local variables */
00019 static doublereal f, g, h__;
00020 static integer i__, j, k, l;
00021 static doublereal scale, hh;
00022 static integer ii, jk, iz, jm1;
00023
00024
00025
00026 /* THIS SUBROUTINE IS A TRANSLATION OF THE ALGOL PROCEDURE TRED3, */
00027 /* NUM. MATH. 11, 181-195(1968) BY MARTIN, REINSCH, AND WILKINSON. */
00028 /* HANDBOOK FOR AUTO. COMP., VOL.II-LINEAR ALGEBRA, 212-226(1971). */
00029
00030 /* THIS SUBROUTINE REDUCES A REAL SYMMETRIC MATRIX, STORED AS */
00031 /* A ONE-DIMENSIONAL ARRAY, TO A SYMMETRIC TRIDIAGONAL MATRIX */
00032 /* USING ORTHOGONAL SIMILARITY TRANSFORMATIONS. */
00033
00034 /* ON INPUT */
00035
00036 /* N IS THE ORDER OF THE MATRIX. */
00037
00038 /* NV MUST BE SET TO THE DIMENSION OF THE ARRAY PARAMETER A */
00039 /* AS DECLARED IN THE CALLING PROGRAM DIMENSION STATEMENT. */
00040
00041 /* A CONTAINS THE LOWER TRIANGLE OF THE REAL SYMMETRIC */
00042 /* INPUT MATRIX, STORED ROW-WISE AS A ONE-DIMENSIONAL */
00043 /* ARRAY, IN ITS FIRST N*(N+1)/2 POSITIONS. */
00044
00045 /* ON OUTPUT */
00046
00047 /* A CONTAINS INFORMATION ABOUT THE ORTHOGONAL */
00048 /* TRANSFORMATIONS USED IN THE REDUCTION. */
00049
00050 /* D CONTAINS THE DIAGONAL ELEMENTS OF THE TRIDIAGONAL MATRIX. */
00051
00052 /* E CONTAINS THE SUBDIAGONAL ELEMENTS OF THE TRIDIAGONAL */
00053 /* MATRIX IN ITS LAST N-1 POSITIONS. E(1) IS SET TO ZERO. */
00054
00055 /* E2 CONTAINS THE SQUARES OF THE CORRESPONDING ELEMENTS OF E. */
00056 /* E2 MAY COINCIDE WITH E IF THE SQUARES ARE NOT NEEDED. */
00057
00058 /* QUESTIONS AND COMMENTS SHOULD BE DIRECTED TO BURTON S. GARBOW, */
00059 /* MATHEMATICS AND COMPUTER SCIENCE DIV, ARGONNE NATIONAL LABORATORY
00060 */
00061
00062 /* THIS VERSION DATED AUGUST 1983. */
00063
00064 /* ------------------------------------------------------------------
00065 */
00066
00067 /* .......... FOR I=N STEP -1 UNTIL 1 DO -- .......... */
00068 /* Parameter adjustments */
00069 --e2;
00070 --e;
00071 --d__;
00072 --a;
00073
00074 /* Function Body */
00075 i__1 = *n;
00076 for (ii = 1; ii <= i__1; ++ii) {
00077 i__ = *n + 1 - ii;
00078 l = i__ - 1;
00079 iz = i__ * l / 2;
00080 h__ = 0.;
00081 scale = 0.;
00082 if (l < 1) {
00083 goto L130;
00084 }
00085 /* .......... SCALE ROW (ALGOL TOL THEN NOT NEEDED) .......... */
00086 i__2 = l;
00087 for (k = 1; k <= i__2; ++k) {
00088 ++iz;
00089 d__[k] = a[iz];
00090 scale += (d__1 = d__[k], abs(d__1));
00091 /* L120: */
00092 }
00093
00094 if (scale != 0.) {
00095 goto L140;
00096 }
00097 L130:
00098 e[i__] = 0.;
00099 e2[i__] = 0.;
00100 goto L290;
00101
00102 L140:
00103 i__2 = l;
00104 for (k = 1; k <= i__2; ++k) {
00105 d__[k] /= scale;
00106 h__ += d__[k] * d__[k];
00107 /* L150: */
00108 }
00109
00110 e2[i__] = scale * scale * h__;
00111 f = d__[l];
00112 d__1 = sqrt(h__);
00113 g = -d_sign(&d__1, &f);
00114 e[i__] = scale * g;
00115 h__ -= f * g;
00116 d__[l] = f - g;
00117 a[iz] = scale * d__[l];
00118 if (l == 1) {
00119 goto L290;
00120 }
00121 jk = 1;
00122
00123 i__2 = l;
00124 for (j = 1; j <= i__2; ++j) {
00125 f = d__[j];
00126 g = 0.;
00127 jm1 = j - 1;
00128 if (jm1 < 1) {
00129 goto L220;
00130 }
00131
00132 i__3 = jm1;
00133 for (k = 1; k <= i__3; ++k) {
00134 g += a[jk] * d__[k];
00135 e[k] += a[jk] * f;
00136 ++jk;
00137 /* L200: */
00138 }
00139
00140 L220:
00141 e[j] = g + a[jk] * f;
00142 ++jk;
00143 /* L240: */
00144 }
00145 /* .......... FORM P .......... */
00146 f = 0.;
00147
00148 i__2 = l;
00149 for (j = 1; j <= i__2; ++j) {
00150 e[j] /= h__;
00151 f += e[j] * d__[j];
00152 /* L245: */
00153 }
00154
00155 hh = f / (h__ + h__);
00156 /* .......... FORM Q .......... */
00157 i__2 = l;
00158 for (j = 1; j <= i__2; ++j) {
00159 /* L250: */
00160 e[j] -= hh * d__[j];
00161 }
00162
00163 jk = 1;
00164 /* .......... FORM REDUCED A .......... */
00165 i__2 = l;
00166 for (j = 1; j <= i__2; ++j) {
00167 f = d__[j];
00168 g = e[j];
00169
00170 i__3 = j;
00171 for (k = 1; k <= i__3; ++k) {
00172 a[jk] = a[jk] - f * e[k] - g * d__[k];
00173 ++jk;
00174 /* L260: */
00175 }
00176
00177 /* L280: */
00178 }
00179
00180 L290:
00181 d__[i__] = a[iz + 1];
00182 a[iz + 1] = scale * sqrt(h__);
00183 /* L300: */
00184 }
00185
00186 return 0;
00187 } /* tred3_ */
|
|
||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||
|
Definition at line 12 of file eis_tridib.c. References abs, c_b33, epslon_(), ind, l, m1, m2, max, min, p, q, v, and x0.
00016 {
00017 /* System generated locals */
00018 integer i__1, i__2;
00019 doublereal d__1, d__2, d__3;
00020
00021 /* Local variables */
00022 static integer i__, j, k, l, p, q, r__, s;
00023 static doublereal u, v;
00024 static integer m1, m2;
00025 static doublereal t1, t2, x0, x1;
00026 static integer m22, ii;
00027 static doublereal xu;
00028 extern doublereal epslon_(doublereal *);
00029 static integer isturm, tag;
00030 static doublereal tst1, tst2;
00031
00032
00033
00034 /* THIS SUBROUTINE IS A TRANSLATION OF THE ALGOL PROCEDURE BISECT, */
00035 /* NUM. MATH. 9, 386-393(1967) BY BARTH, MARTIN, AND WILKINSON. */
00036 /* HANDBOOK FOR AUTO. COMP., VOL.II-LINEAR ALGEBRA, 249-256(1971). */
00037
00038 /* THIS SUBROUTINE FINDS THOSE EIGENVALUES OF A TRIDIAGONAL */
00039 /* SYMMETRIC MATRIX BETWEEN SPECIFIED BOUNDARY INDICES, */
00040 /* USING BISECTION. */
00041
00042 /* ON INPUT */
00043
00044 /* N IS THE ORDER OF THE MATRIX. */
00045
00046 /* EPS1 IS AN ABSOLUTE ERROR TOLERANCE FOR THE COMPUTED */
00047 /* EIGENVALUES. IF THE INPUT EPS1 IS NON-POSITIVE, */
00048 /* IT IS RESET FOR EACH SUBMATRIX TO A DEFAULT VALUE, */
00049 /* NAMELY, MINUS THE PRODUCT OF THE RELATIVE MACHINE */
00050 /* PRECISION AND THE 1-NORM OF THE SUBMATRIX. */
00051
00052 /* D CONTAINS THE DIAGONAL ELEMENTS OF THE INPUT MATRIX. */
00053
00054 /* E CONTAINS THE SUBDIAGONAL ELEMENTS OF THE INPUT MATRIX */
00055 /* IN ITS LAST N-1 POSITIONS. E(1) IS ARBITRARY. */
00056
00057 /* E2 CONTAINS THE SQUARES OF THE CORRESPONDING ELEMENTS OF E. */
00058 /* E2(1) IS ARBITRARY. */
00059
00060 /* M11 SPECIFIES THE LOWER BOUNDARY INDEX FOR THE DESIRED */
00061 /* EIGENVALUES. */
00062
00063 /* M SPECIFIES THE NUMBER OF EIGENVALUES DESIRED. THE UPPER */
00064 /* BOUNDARY INDEX M22 IS THEN OBTAINED AS M22=M11+M-1. */
00065
00066 /* ON OUTPUT */
00067
00068 /* EPS1 IS UNALTERED UNLESS IT HAS BEEN RESET TO ITS */
00069 /* (LAST) DEFAULT VALUE. */
00070
00071 /* D AND E ARE UNALTERED. */
00072
00073 /* ELEMENTS OF E2, CORRESPONDING TO ELEMENTS OF E REGARDED */
00074 /* AS NEGLIGIBLE, HAVE BEEN REPLACED BY ZERO CAUSING THE */
00075 /* MATRIX TO SPLIT INTO A DIRECT SUM OF SUBMATRICES. */
00076 /* E2(1) IS ALSO SET TO ZERO. */
00077
00078 /* LB AND UB DEFINE AN INTERVAL CONTAINING EXACTLY THE DESIRED */
00079 /* EIGENVALUES. */
00080
00081 /* W CONTAINS, IN ITS FIRST M POSITIONS, THE EIGENVALUES */
00082 /* BETWEEN INDICES M11 AND M22 IN ASCENDING ORDER. */
00083
00084 /* IND CONTAINS IN ITS FIRST M POSITIONS THE SUBMATRIX INDICES */
00085 /* ASSOCIATED WITH THE CORRESPONDING EIGENVALUES IN W -- */
00086 /* 1 FOR EIGENVALUES BELONGING TO THE FIRST SUBMATRIX FROM */
00087 /* THE TOP, 2 FOR THOSE BELONGING TO THE SECOND SUBMATRIX, ETC..
00088 */
00089
00090 /* IERR IS SET TO */
00091 /* ZERO FOR NORMAL RETURN, */
00092 /* 3*N+1 IF MULTIPLE EIGENVALUES AT INDEX M11 MAKE */
00093 /* UNIQUE SELECTION IMPOSSIBLE, */
00094 /* 3*N+2 IF MULTIPLE EIGENVALUES AT INDEX M22 MAKE */
00095 /* UNIQUE SELECTION IMPOSSIBLE. */
00096
00097 /* RV4 AND RV5 ARE TEMPORARY STORAGE ARRAYS. */
00098
00099 /* NOTE THAT SUBROUTINE TQL1, IMTQL1, OR TQLRAT IS GENERALLY FASTER */
00100 /* THAN TRIDIB, IF MORE THAN N/4 EIGENVALUES ARE TO BE FOUND. */
00101
00102 /* QUESTIONS AND COMMENTS SHOULD BE DIRECTED TO BURTON S. GARBOW, */
00103 /* MATHEMATICS AND COMPUTER SCIENCE DIV, ARGONNE NATIONAL LABORATORY
00104 */
00105
00106 /* THIS VERSION DATED AUGUST 1983. */
00107
00108 /* ------------------------------------------------------------------
00109 */
00110
00111 /* Parameter adjustments */
00112 --rv5;
00113 --rv4;
00114 --e2;
00115 --e;
00116 --d__;
00117 --ind;
00118 --w;
00119
00120 /* Function Body */
00121 *ierr = 0;
00122 tag = 0;
00123 xu = d__[1];
00124 x0 = d__[1];
00125 u = 0.;
00126 /* .......... LOOK FOR SMALL SUB-DIAGONAL ENTRIES AND DETERMINE AN */
00127 /* INTERVAL CONTAINING ALL THE EIGENVALUES .......... */
00128 i__1 = *n;
00129 for (i__ = 1; i__ <= i__1; ++i__) {
00130 x1 = u;
00131 u = 0.;
00132 if (i__ != *n) {
00133 u = (d__1 = e[i__ + 1], abs(d__1));
00134 }
00135 /* Computing MIN */
00136 d__1 = d__[i__] - (x1 + u);
00137 xu = min(d__1,xu);
00138 /* Computing MAX */
00139 d__1 = d__[i__] + (x1 + u);
00140 x0 = max(d__1,x0);
00141 if (i__ == 1) {
00142 goto L20;
00143 }
00144 tst1 = (d__1 = d__[i__], abs(d__1)) + (d__2 = d__[i__ - 1], abs(d__2))
00145 ;
00146 tst2 = tst1 + (d__1 = e[i__], abs(d__1));
00147 if (tst2 > tst1) {
00148 goto L40;
00149 }
00150 L20:
00151 e2[i__] = 0.;
00152 L40:
00153 ;
00154 }
00155
00156 x1 = (doublereal) (*n);
00157 /* Computing MAX */
00158 d__2 = abs(xu), d__3 = abs(x0);
00159 d__1 = max(d__2,d__3);
00160 x1 *= epslon_(&d__1);
00161 xu -= x1;
00162 t1 = xu;
00163 x0 += x1;
00164 t2 = x0;
00165 /* .......... DETERMINE AN INTERVAL CONTAINING EXACTLY */
00166 /* THE DESIRED EIGENVALUES .......... */
00167 p = 1;
00168 q = *n;
00169 m1 = *m11 - 1;
00170 if (m1 == 0) {
00171 goto L75;
00172 }
00173 isturm = 1;
00174 L50:
00175 v = x1;
00176 x1 = xu + (x0 - xu) * .5;
00177 if (x1 == v) {
00178 goto L980;
00179 }
00180 goto L320;
00181 L60:
00182 if ((i__1 = s - m1) < 0) {
00183 goto L65;
00184 } else if (i__1 == 0) {
00185 goto L73;
00186 } else {
00187 goto L70;
00188 }
00189 L65:
00190 xu = x1;
00191 goto L50;
00192 L70:
00193 x0 = x1;
00194 goto L50;
00195 L73:
00196 xu = x1;
00197 t1 = x1;
00198 L75:
00199 m22 = m1 + *m;
00200 if (m22 == *n) {
00201 goto L90;
00202 }
00203 x0 = t2;
00204 isturm = 2;
00205 goto L50;
00206 L80:
00207 if ((i__1 = s - m22) < 0) {
00208 goto L65;
00209 } else if (i__1 == 0) {
00210 goto L85;
00211 } else {
00212 goto L70;
00213 }
00214 L85:
00215 t2 = x1;
00216 L90:
00217 q = 0;
00218 r__ = 0;
00219 /* .......... ESTABLISH AND PROCESS NEXT SUBMATRIX, REFINING */
00220 /* INTERVAL BY THE GERSCHGORIN BOUNDS .......... */
00221 L100:
00222 if (r__ == *m) {
00223 goto L1001;
00224 }
00225 ++tag;
00226 p = q + 1;
00227 xu = d__[p];
00228 x0 = d__[p];
00229 u = 0.;
00230
00231 i__1 = *n;
00232 for (q = p; q <= i__1; ++q) {
00233 x1 = u;
00234 u = 0.;
00235 v = 0.;
00236 if (q == *n) {
00237 goto L110;
00238 }
00239 u = (d__1 = e[q + 1], abs(d__1));
00240 v = e2[q + 1];
00241 L110:
00242 /* Computing MIN */
00243 d__1 = d__[q] - (x1 + u);
00244 xu = min(d__1,xu);
00245 /* Computing MAX */
00246 d__1 = d__[q] + (x1 + u);
00247 x0 = max(d__1,x0);
00248 if (v == 0.) {
00249 goto L140;
00250 }
00251 /* L120: */
00252 }
00253
00254 L140:
00255 /* Computing MAX */
00256 d__2 = abs(xu), d__3 = abs(x0);
00257 d__1 = max(d__2,d__3);
00258 x1 = epslon_(&d__1);
00259 if (*eps1 <= 0.) {
00260 *eps1 = -x1;
00261 }
00262 if (p != q) {
00263 goto L180;
00264 }
00265 /* .......... CHECK FOR ISOLATED ROOT WITHIN INTERVAL .......... */
00266 if (t1 > d__[p] || d__[p] >= t2) {
00267 goto L940;
00268 }
00269 m1 = p;
00270 m2 = p;
00271 rv5[p] = d__[p];
00272 goto L900;
00273 L180:
00274 x1 *= q - p + 1;
00275 /* Computing MAX */
00276 d__1 = t1, d__2 = xu - x1;
00277 *lb = max(d__1,d__2);
00278 /* Computing MIN */
00279 d__1 = t2, d__2 = x0 + x1;
00280 *ub = min(d__1,d__2);
00281 x1 = *lb;
00282 isturm = 3;
00283 goto L320;
00284 L200:
00285 m1 = s + 1;
00286 x1 = *ub;
00287 isturm = 4;
00288 goto L320;
00289 L220:
00290 m2 = s;
00291 if (m1 > m2) {
00292 goto L940;
00293 }
00294 /* .......... FIND ROOTS BY BISECTION .......... */
00295 x0 = *ub;
00296 isturm = 5;
00297
00298 i__1 = m2;
00299 for (i__ = m1; i__ <= i__1; ++i__) {
00300 rv5[i__] = *ub;
00301 rv4[i__] = *lb;
00302 /* L240: */
00303 }
00304 /* .......... LOOP FOR K-TH EIGENVALUE */
00305 /* FOR K=M2 STEP -1 UNTIL M1 DO -- */
00306 /* (-DO- NOT USED TO LEGALIZE -COMPUTED GO TO-) ..........
00307 */
00308 k = m2;
00309 L250:
00310 xu = *lb;
00311 /* .......... FOR I=K STEP -1 UNTIL M1 DO -- .......... */
00312 i__1 = k;
00313 for (ii = m1; ii <= i__1; ++ii) {
00314 i__ = m1 + k - ii;
00315 if (xu >= rv4[i__]) {
00316 goto L260;
00317 }
00318 xu = rv4[i__];
00319 goto L280;
00320 L260:
00321 ;
00322 }
00323
00324 L280:
00325 if (x0 > rv5[k]) {
00326 x0 = rv5[k];
00327 }
00328 /* .......... NEXT BISECTION STEP .......... */
00329 L300:
00330 x1 = (xu + x0) * .5;
00331 if (x0 - xu <= abs(*eps1)) {
00332 goto L420;
00333 }
00334 tst1 = (abs(xu) + abs(x0)) * 2.;
00335 tst2 = tst1 + (x0 - xu);
00336 if (tst2 == tst1) {
00337 goto L420;
00338 }
00339 /* .......... IN-LINE PROCEDURE FOR STURM SEQUENCE .......... */
00340 L320:
00341 s = p - 1;
00342 u = 1.;
00343
00344 i__1 = q;
00345 for (i__ = p; i__ <= i__1; ++i__) {
00346 if (u != 0.) {
00347 goto L325;
00348 }
00349 v = (d__1 = e[i__], abs(d__1)) / epslon_(&c_b33);
00350 if (e2[i__] == 0.) {
00351 v = 0.;
00352 }
00353 goto L330;
00354 L325:
00355 v = e2[i__] / u;
00356 L330:
00357 u = d__[i__] - x1 - v;
00358 if (u < 0.) {
00359 ++s;
00360 }
00361 /* L340: */
00362 }
00363
00364 switch (isturm) {
00365 case 1: goto L60;
00366 case 2: goto L80;
00367 case 3: goto L200;
00368 case 4: goto L220;
00369 case 5: goto L360;
00370 }
00371 /* .......... REFINE INTERVALS .......... */
00372 L360:
00373 if (s >= k) {
00374 goto L400;
00375 }
00376 xu = x1;
00377 if (s >= m1) {
00378 goto L380;
00379 }
00380 rv4[m1] = x1;
00381 goto L300;
00382 L380:
00383 rv4[s + 1] = x1;
00384 if (rv5[s] > x1) {
00385 rv5[s] = x1;
00386 }
00387 goto L300;
00388 L400:
00389 x0 = x1;
00390 goto L300;
00391 /* .......... K-TH EIGENVALUE FOUND .......... */
00392 L420:
00393 rv5[k] = x1;
00394 --k;
00395 if (k >= m1) {
00396 goto L250;
00397 }
00398 /* .......... ORDER EIGENVALUES TAGGED WITH THEIR */
00399 /* SUBMATRIX ASSOCIATIONS .......... */
00400 L900:
00401 s = r__;
00402 r__ = r__ + m2 - m1 + 1;
00403 j = 1;
00404 k = m1;
00405
00406 i__1 = r__;
00407 for (l = 1; l <= i__1; ++l) {
00408 if (j > s) {
00409 goto L910;
00410 }
00411 if (k > m2) {
00412 goto L940;
00413 }
00414 if (rv5[k] >= w[l]) {
00415 goto L915;
00416 }
00417
00418 i__2 = s;
00419 for (ii = j; ii <= i__2; ++ii) {
00420 i__ = l + s - ii;
00421 w[i__ + 1] = w[i__];
00422 ind[i__ + 1] = ind[i__];
00423 /* L905: */
00424 }
00425
00426 L910:
00427 w[l] = rv5[k];
00428 ind[l] = tag;
00429 ++k;
00430 goto L920;
00431 L915:
00432 ++j;
00433 L920:
00434 ;
00435 }
00436
00437 L940:
00438 if (q < *n) {
00439 goto L100;
00440 }
00441 goto L1001;
00442 /* .......... SET ERROR -- INTERVAL CANNOT BE FOUND CONTAINING */
00443 /* EXACTLY THE DESIRED EIGENVALUES .......... */
00444 L980:
00445 *ierr = *n * 3 + isturm;
00446 L1001:
00447 *lb = t1;
00448 *ub = t2;
00449 return 0;
00450 } /* tridib_ */
|
|
||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||
|
Definition at line 12 of file eis_tsturm.c. References abs, c_b26, epslon_(), m1, m2, max, min, p, pythag_(), q, v, and x0.
00017 {
00018 /* System generated locals */
00019 integer z_dim1, z_offset, i__1, i__2, i__3;
00020 doublereal d__1, d__2, d__3, d__4;
00021
00022 /* Builtin functions */
00023 double sqrt(doublereal);
00024
00025 /* Local variables */
00026 static doublereal norm;
00027 static integer i__, j, k, p, q, r__, s;
00028 static doublereal u, v;
00029 static integer group, m1, m2;
00030 static doublereal t1, t2, x0, x1;
00031 static integer ii, jj, ip;
00032 static doublereal uk, xu;
00033 extern doublereal pythag_(doublereal *, doublereal *), epslon_(doublereal
00034 *);
00035 static integer isturm, its;
00036 static doublereal eps2, eps3, eps4, tst1, tst2;
00037
00038
00039
00040 /* THIS SUBROUTINE IS A TRANSLATION OF THE ALGOL PROCEDURE TRISTURM */
00041 /* BY PETERS AND WILKINSON. */
00042 /* HANDBOOK FOR AUTO. COMP., VOL.II-LINEAR ALGEBRA, 418-439(1971). */
00043
00044 /* THIS SUBROUTINE FINDS THOSE EIGENVALUES OF A TRIDIAGONAL */
00045 /* SYMMETRIC MATRIX WHICH LIE IN A SPECIFIED INTERVAL AND THEIR */
00046 /* ASSOCIATED EIGENVECTORS, USING BISECTION AND INVERSE ITERATION. */
00047
00048 /* ON INPUT */
00049
00050 /* NM MUST BE SET TO THE ROW DIMENSION OF TWO-DIMENSIONAL */
00051 /* ARRAY PARAMETERS AS DECLARED IN THE CALLING PROGRAM */
00052 /* DIMENSION STATEMENT. */
00053
00054 /* N IS THE ORDER OF THE MATRIX. */
00055
00056 /* EPS1 IS AN ABSOLUTE ERROR TOLERANCE FOR THE COMPUTED */
00057 /* EIGENVALUES. IT SHOULD BE CHOSEN COMMENSURATE WITH */
00058 /* RELATIVE PERTURBATIONS IN THE MATRIX ELEMENTS OF THE */
00059 /* ORDER OF THE RELATIVE MACHINE PRECISION. IF THE */
00060 /* INPUT EPS1 IS NON-POSITIVE, IT IS RESET FOR EACH */
00061 /* SUBMATRIX TO A DEFAULT VALUE, NAMELY, MINUS THE */
00062 /* PRODUCT OF THE RELATIVE MACHINE PRECISION AND THE */
00063 /* 1-NORM OF THE SUBMATRIX. */
00064
00065 /* D CONTAINS THE DIAGONAL ELEMENTS OF THE INPUT MATRIX. */
00066
00067 /* E CONTAINS THE SUBDIAGONAL ELEMENTS OF THE INPUT MATRIX */
00068 /* IN ITS LAST N-1 POSITIONS. E(1) IS ARBITRARY. */
00069
00070 /* E2 CONTAINS THE SQUARES OF THE CORRESPONDING ELEMENTS OF E. */
00071 /* E2(1) IS ARBITRARY. */
00072
00073 /* LB AND UB DEFINE THE INTERVAL TO BE SEARCHED FOR EIGENVALUES. */
00074 /* IF LB IS NOT LESS THAN UB, NO EIGENVALUES WILL BE FOUND. */
00075
00076 /* MM SHOULD BE SET TO AN UPPER BOUND FOR THE NUMBER OF */
00077 /* EIGENVALUES IN THE INTERVAL. WARNING. IF MORE THAN */
00078 /* MM EIGENVALUES ARE DETERMINED TO LIE IN THE INTERVAL, */
00079 /* AN ERROR RETURN IS MADE WITH NO VALUES OR VECTORS FOUND. */
00080
00081 /* ON OUTPUT */
00082
00083 /* EPS1 IS UNALTERED UNLESS IT HAS BEEN RESET TO ITS */
00084 /* (LAST) DEFAULT VALUE. */
00085
00086 /* D AND E ARE UNALTERED. */
00087
00088 /* ELEMENTS OF E2, CORRESPONDING TO ELEMENTS OF E REGARDED */
00089 /* AS NEGLIGIBLE, HAVE BEEN REPLACED BY ZERO CAUSING THE */
00090 /* MATRIX TO SPLIT INTO A DIRECT SUM OF SUBMATRICES. */
00091 /* E2(1) IS ALSO SET TO ZERO. */
00092
00093 /* M IS THE NUMBER OF EIGENVALUES DETERMINED TO LIE IN (LB,UB). */
00094
00095 /* W CONTAINS THE M EIGENVALUES IN ASCENDING ORDER IF THE MATRIX */
00096 /* DOES NOT SPLIT. IF THE MATRIX SPLITS, THE EIGENVALUES ARE */
00097 /* IN ASCENDING ORDER FOR EACH SUBMATRIX. IF A VECTOR ERROR */
00098 /* EXIT IS MADE, W CONTAINS THOSE VALUES ALREADY FOUND. */
00099
00100 /* Z CONTAINS THE ASSOCIATED SET OF ORTHONORMAL EIGENVECTORS. */
00101 /* IF AN ERROR EXIT IS MADE, Z CONTAINS THOSE VECTORS */
00102 /* ALREADY FOUND. */
00103
00104 /* IERR IS SET TO */
00105 /* ZERO FOR NORMAL RETURN, */
00106 /* 3*N+1 IF M EXCEEDS MM. */
00107 /* 4*N+R IF THE EIGENVECTOR CORRESPONDING TO THE R-TH */
00108 /* EIGENVALUE FAILS TO CONVERGE IN 5 ITERATIONS. */
00109
00110 /* RV1, RV2, RV3, RV4, RV5, AND RV6 ARE TEMPORARY STORAGE ARRAYS.
00111 */
00112
00113 /* THE ALGOL PROCEDURE STURMCNT CONTAINED IN TRISTURM */
00114 /* APPEARS IN TSTURM IN-LINE. */
00115
00116 /* CALLS PYTHAG FOR DSQRT(A*A + B*B) . */
00117
00118 /* QUESTIONS AND COMMENTS SHOULD BE DIRECTED TO BURTON S. GARBOW, */
00119 /* MATHEMATICS AND COMPUTER SCIENCE DIV, ARGONNE NATIONAL LABORATORY
00120 */
00121
00122 /* THIS VERSION DATED AUGUST 1983. */
00123
00124 /* ------------------------------------------------------------------
00125 */
00126
00127 /* Parameter adjustments */
00128 --rv6;
00129 --rv5;
00130 --rv4;
00131 --rv3;
00132 --rv2;
00133 --rv1;
00134 --e2;
00135 --e;
00136 --d__;
00137 z_dim1 = *nm;
00138 z_offset = z_dim1 + 1;
00139 z__ -= z_offset;
00140 --w;
00141
00142 /* Function Body */
00143 *ierr = 0;
00144 t1 = *lb;
00145 t2 = *ub;
00146 /* .......... LOOK FOR SMALL SUB-DIAGONAL ENTRIES .......... */
00147 i__1 = *n;
00148 for (i__ = 1; i__ <= i__1; ++i__) {
00149 if (i__ == 1) {
00150 goto L20;
00151 }
00152 tst1 = (d__1 = d__[i__], abs(d__1)) + (d__2 = d__[i__ - 1], abs(d__2))
00153 ;
00154 tst2 = tst1 + (d__1 = e[i__], abs(d__1));
00155 if (tst2 > tst1) {
00156 goto L40;
00157 }
00158 L20:
00159 e2[i__] = 0.;
00160 L40:
00161 ;
00162 }
00163 /* .......... DETERMINE THE NUMBER OF EIGENVALUES */
00164 /* IN THE INTERVAL .......... */
00165 p = 1;
00166 q = *n;
00167 x1 = *ub;
00168 isturm = 1;
00169 goto L320;
00170 L60:
00171 *m = s;
00172 x1 = *lb;
00173 isturm = 2;
00174 goto L320;
00175 L80:
00176 *m -= s;
00177 if (*m > *mm) {
00178 goto L980;
00179 }
00180 q = 0;
00181 r__ = 0;
00182 /* .......... ESTABLISH AND PROCESS NEXT SUBMATRIX, REFINING */
00183 /* INTERVAL BY THE GERSCHGORIN BOUNDS .......... */
00184 L100:
00185 if (r__ == *m) {
00186 goto L1001;
00187 }
00188 p = q + 1;
00189 xu = d__[p];
00190 x0 = d__[p];
00191 u = 0.;
00192
00193 i__1 = *n;
00194 for (q = p; q <= i__1; ++q) {
00195 x1 = u;
00196 u = 0.;
00197 v = 0.;
00198 if (q == *n) {
00199 goto L110;
00200 }
00201 u = (d__1 = e[q + 1], abs(d__1));
00202 v = e2[q + 1];
00203 L110:
00204 /* Computing MIN */
00205 d__1 = d__[q] - (x1 + u);
00206 xu = min(d__1,xu);
00207 /* Computing MAX */
00208 d__1 = d__[q] + (x1 + u);
00209 x0 = max(d__1,x0);
00210 if (v == 0.) {
00211 goto L140;
00212 }
00213 /* L120: */
00214 }
00215
00216 L140:
00217 /* Computing MAX */
00218 d__2 = abs(xu), d__3 = abs(x0);
00219 d__1 = max(d__2,d__3);
00220 x1 = epslon_(&d__1);
00221 if (*eps1 <= 0.) {
00222 *eps1 = -x1;
00223 }
00224 if (p != q) {
00225 goto L180;
00226 }
00227 /* .......... CHECK FOR ISOLATED ROOT WITHIN INTERVAL .......... */
00228 if (t1 > d__[p] || d__[p] >= t2) {
00229 goto L940;
00230 }
00231 ++r__;
00232
00233 i__1 = *n;
00234 for (i__ = 1; i__ <= i__1; ++i__) {
00235 /* L160: */
00236 z__[i__ + r__ * z_dim1] = 0.;
00237 }
00238
00239 w[r__] = d__[p];
00240 z__[p + r__ * z_dim1] = 1.;
00241 goto L940;
00242 L180:
00243 u = (doublereal) (q - p + 1);
00244 x1 = u * x1;
00245 /* Computing MAX */
00246 d__1 = t1, d__2 = xu - x1;
00247 *lb = max(d__1,d__2);
00248 /* Computing MIN */
00249 d__1 = t2, d__2 = x0 + x1;
00250 *ub = min(d__1,d__2);
00251 x1 = *lb;
00252 isturm = 3;
00253 goto L320;
00254 L200:
00255 m1 = s + 1;
00256 x1 = *ub;
00257 isturm = 4;
00258 goto L320;
00259 L220:
00260 m2 = s;
00261 if (m1 > m2) {
00262 goto L940;
00263 }
00264 /* .......... FIND ROOTS BY BISECTION .......... */
00265 x0 = *ub;
00266 isturm = 5;
00267
00268 i__1 = m2;
00269 for (i__ = m1; i__ <= i__1; ++i__) {
00270 rv5[i__] = *ub;
00271 rv4[i__] = *lb;
00272 /* L240: */
00273 }
00274 /* .......... LOOP FOR K-TH EIGENVALUE */
00275 /* FOR K=M2 STEP -1 UNTIL M1 DO -- */
00276 /* (-DO- NOT USED TO LEGALIZE -COMPUTED GO TO-) ..........
00277 */
00278 k = m2;
00279 L250:
00280 xu = *lb;
00281 /* .......... FOR I=K STEP -1 UNTIL M1 DO -- .......... */
00282 i__1 = k;
00283 for (ii = m1; ii <= i__1; ++ii) {
00284 i__ = m1 + k - ii;
00285 if (xu >= rv4[i__]) {
00286 goto L260;
00287 }
00288 xu = rv4[i__];
00289 goto L280;
00290 L260:
00291 ;
00292 }
00293
00294 L280:
00295 if (x0 > rv5[k]) {
00296 x0 = rv5[k];
00297 }
00298 /* .......... NEXT BISECTION STEP .......... */
00299 L300:
00300 x1 = (xu + x0) * .5;
00301 if (x0 - xu <= abs(*eps1)) {
00302 goto L420;
00303 }
00304 tst1 = (abs(xu) + abs(x0)) * 2.;
00305 tst2 = tst1 + (x0 - xu);
00306 if (tst2 == tst1) {
00307 goto L420;
00308 }
00309 /* .......... IN-LINE PROCEDURE FOR STURM SEQUENCE .......... */
00310 L320:
00311 s = p - 1;
00312 u = 1.;
00313
00314 i__1 = q;
00315 for (i__ = p; i__ <= i__1; ++i__) {
00316 if (u != 0.) {
00317 goto L325;
00318 }
00319 v = (d__1 = e[i__], abs(d__1)) / epslon_(&c_b26);
00320 if (e2[i__] == 0.) {
00321 v = 0.;
00322 }
00323 goto L330;
00324 L325:
00325 v = e2[i__] / u;
00326 L330:
00327 u = d__[i__] - x1 - v;
00328 if (u < 0.) {
00329 ++s;
00330 }
00331 /* L340: */
00332 }
00333
00334 switch (isturm) {
00335 case 1: goto L60;
00336 case 2: goto L80;
00337 case 3: goto L200;
00338 case 4: goto L220;
00339 case 5: goto L360;
00340 }
00341 /* .......... REFINE INTERVALS .......... */
00342 L360:
00343 if (s >= k) {
00344 goto L400;
00345 }
00346 xu = x1;
00347 if (s >= m1) {
00348 goto L380;
00349 }
00350 rv4[m1] = x1;
00351 goto L300;
00352 L380:
00353 rv4[s + 1] = x1;
00354 if (rv5[s] > x1) {
00355 rv5[s] = x1;
00356 }
00357 goto L300;
00358 L400:
00359 x0 = x1;
00360 goto L300;
00361 /* .......... K-TH EIGENVALUE FOUND .......... */
00362 L420:
00363 rv5[k] = x1;
00364 --k;
00365 if (k >= m1) {
00366 goto L250;
00367 }
00368 /* .......... FIND VECTORS BY INVERSE ITERATION .......... */
00369 norm = (d__1 = d__[p], abs(d__1));
00370 ip = p + 1;
00371
00372 i__1 = q;
00373 for (i__ = ip; i__ <= i__1; ++i__) {
00374 /* L500: */
00375 /* Computing MAX */
00376 d__3 = norm, d__4 = (d__1 = d__[i__], abs(d__1)) + (d__2 = e[i__],
00377 abs(d__2));
00378 norm = max(d__3,d__4);
00379 }
00380 /* .......... EPS2 IS THE CRITERION FOR GROUPING, */
00381 /* EPS3 REPLACES ZERO PIVOTS AND EQUAL */
00382 /* ROOTS ARE MODIFIED BY EPS3, */
00383 /* EPS4 IS TAKEN VERY SMALL TO AVOID OVERFLOW .......... */
00384 eps2 = norm * .001;
00385 eps3 = epslon_(&norm);
00386 uk = (doublereal) (q - p + 1);
00387 eps4 = uk * eps3;
00388 uk = eps4 / sqrt(uk);
00389 group = 0;
00390 s = p;
00391
00392 i__1 = m2;
00393 for (k = m1; k <= i__1; ++k) {
00394 ++r__;
00395 its = 1;
00396 w[r__] = rv5[k];
00397 x1 = rv5[k];
00398 /* .......... LOOK FOR CLOSE OR COINCIDENT ROOTS .......... */
00399 if (k == m1) {
00400 goto L520;
00401 }
00402 if (x1 - x0 >= eps2) {
00403 group = -1;
00404 }
00405 ++group;
00406 if (x1 <= x0) {
00407 x1 = x0 + eps3;
00408 }
00409 /* .......... ELIMINATION WITH INTERCHANGES AND */
00410 /* INITIALIZATION OF VECTOR .......... */
00411 L520:
00412 v = 0.;
00413
00414 i__2 = q;
00415 for (i__ = p; i__ <= i__2; ++i__) {
00416 rv6[i__] = uk;
00417 if (i__ == p) {
00418 goto L560;
00419 }
00420 if ((d__1 = e[i__], abs(d__1)) < abs(u)) {
00421 goto L540;
00422 }
00423 xu = u / e[i__];
00424 rv4[i__] = xu;
00425 rv1[i__ - 1] = e[i__];
00426 rv2[i__ - 1] = d__[i__] - x1;
00427 rv3[i__ - 1] = 0.;
00428 if (i__ != q) {
00429 rv3[i__ - 1] = e[i__ + 1];
00430 }
00431 u = v - xu * rv2[i__ - 1];
00432 v = -xu * rv3[i__ - 1];
00433 goto L580;
00434 L540:
00435 xu = e[i__] / u;
00436 rv4[i__] = xu;
00437 rv1[i__ - 1] = u;
00438 rv2[i__ - 1] = v;
00439 rv3[i__ - 1] = 0.;
00440 L560:
00441 u = d__[i__] - x1 - xu * v;
00442 if (i__ != q) {
00443 v = e[i__ + 1];
00444 }
00445 L580:
00446 ;
00447 }
00448
00449 if (u == 0.) {
00450 u = eps3;
00451 }
00452 rv1[q] = u;
00453 rv2[q] = 0.;
00454 rv3[q] = 0.;
00455 /* .......... BACK SUBSTITUTION */
00456 /* FOR I=Q STEP -1 UNTIL P DO -- .......... */
00457 L600:
00458 i__2 = q;
00459 for (ii = p; ii <= i__2; ++ii) {
00460 i__ = p + q - ii;
00461 rv6[i__] = (rv6[i__] - u * rv2[i__] - v * rv3[i__]) / rv1[i__];
00462 v = u;
00463 u = rv6[i__];
00464 /* L620: */
00465 }
00466 /* .......... ORTHOGONALIZE WITH RESPECT TO PREVIOUS */
00467 /* MEMBERS OF GROUP .......... */
00468 if (group == 0) {
00469 goto L700;
00470 }
00471
00472 i__2 = group;
00473 for (jj = 1; jj <= i__2; ++jj) {
00474 j = r__ - group - 1 + jj;
00475 xu = 0.;
00476
00477 i__3 = q;
00478 for (i__ = p; i__ <= i__3; ++i__) {
00479 /* L640: */
00480 xu += rv6[i__] * z__[i__ + j * z_dim1];
00481 }
00482
00483 i__3 = q;
00484 for (i__ = p; i__ <= i__3; ++i__) {
00485 /* L660: */
00486 rv6[i__] -= xu * z__[i__ + j * z_dim1];
00487 }
00488
00489 /* L680: */
00490 }
00491
00492 L700:
00493 norm = 0.;
00494
00495 i__2 = q;
00496 for (i__ = p; i__ <= i__2; ++i__) {
00497 /* L720: */
00498 norm += (d__1 = rv6[i__], abs(d__1));
00499 }
00500
00501 if (norm >= 1.) {
00502 goto L840;
00503 }
00504 /* .......... FORWARD SUBSTITUTION .......... */
00505 if (its == 5) {
00506 goto L960;
00507 }
00508 if (norm != 0.) {
00509 goto L740;
00510 }
00511 rv6[s] = eps4;
00512 ++s;
00513 if (s > q) {
00514 s = p;
00515 }
00516 goto L780;
00517 L740:
00518 xu = eps4 / norm;
00519
00520 i__2 = q;
00521 for (i__ = p; i__ <= i__2; ++i__) {
00522 /* L760: */
00523 rv6[i__] *= xu;
00524 }
00525 /* .......... ELIMINATION OPERATIONS ON NEXT VECTOR */
00526 /* ITERATE .......... */
00527 L780:
00528 i__2 = q;
00529 for (i__ = ip; i__ <= i__2; ++i__) {
00530 u = rv6[i__];
00531 /* .......... IF RV1(I-1) .EQ. E(I), A ROW INTERCHANGE */
00532 /* WAS PERFORMED EARLIER IN THE */
00533 /* TRIANGULARIZATION PROCESS .......... */
00534 if (rv1[i__ - 1] != e[i__]) {
00535 goto L800;
00536 }
00537 u = rv6[i__ - 1];
00538 rv6[i__ - 1] = rv6[i__];
00539 L800:
00540 rv6[i__] = u - rv4[i__] * rv6[i__ - 1];
00541 /* L820: */
00542 }
00543
00544 ++its;
00545 goto L600;
00546 /* .......... NORMALIZE SO THAT SUM OF SQUARES IS */
00547 /* 1 AND EXPAND TO FULL ORDER .......... */
00548 L840:
00549 u = 0.;
00550
00551 i__2 = q;
00552 for (i__ = p; i__ <= i__2; ++i__) {
00553 /* L860: */
00554 u = pythag_(&u, &rv6[i__]);
00555 }
00556
00557 xu = 1. / u;
00558
00559 i__2 = *n;
00560 for (i__ = 1; i__ <= i__2; ++i__) {
00561 /* L880: */
00562 z__[i__ + r__ * z_dim1] = 0.;
00563 }
00564
00565 i__2 = q;
00566 for (i__ = p; i__ <= i__2; ++i__) {
00567 /* L900: */
00568 z__[i__ + r__ * z_dim1] = rv6[i__] * xu;
00569 }
00570
00571 x0 = x1;
00572 /* L920: */
00573 }
00574
00575 L940:
00576 if (q < *n) {
00577 goto L100;
00578 }
00579 goto L1001;
00580 /* .......... SET ERROR -- NON-CONVERGED EIGENVECTOR .......... */
00581 L960:
00582 *ierr = (*n << 2) + r__;
00583 goto L1001;
00584 /* .......... SET ERROR -- UNDERESTIMATE OF NUMBER OF */
00585 /* EIGENVALUES IN INTERVAL .......... */
00586 L980:
00587 *ierr = *n * 3 + 1;
00588 L1001:
00589 *lb = t1;
00590 *ub = t2;
00591 return 0;
00592 } /* tsturm_ */
|
