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