dlahqr.c
Go to the documentation of this file.
00001 /* dlahqr.f -- translated by f2c (version 20061008).
00002    You must link the resulting object file with libf2c:
00003         on Microsoft Windows system, link with libf2c.lib;
00004         on Linux or Unix systems, link with .../path/to/libf2c.a -lm
00005         or, if you install libf2c.a in a standard place, with -lf2c -lm
00006         -- in that order, at the end of the command line, as in
00007                 cc *.o -lf2c -lm
00008         Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
00009 
00010                 http://www.netlib.org/f2c/libf2c.zip
00011 */
00012 
00013 #include "f2c.h"
00014 #include "blaswrap.h"
00015 
00016 /* Table of constant values */
00017 
00018 static integer c__1 = 1;
00019 
00020 /* Subroutine */ int dlahqr_(logical *wantt, logical *wantz, integer *n, 
00021         integer *ilo, integer *ihi, doublereal *h__, integer *ldh, doublereal 
00022         *wr, doublereal *wi, integer *iloz, integer *ihiz, doublereal *z__, 
00023         integer *ldz, integer *info)
00024 {
00025     /* System generated locals */
00026     integer h_dim1, h_offset, z_dim1, z_offset, i__1, i__2, i__3;
00027     doublereal d__1, d__2, d__3, d__4;
00028 
00029     /* Builtin functions */
00030     double sqrt(doublereal);
00031 
00032     /* Local variables */
00033     integer i__, j, k, l, m;
00034     doublereal s, v[3];
00035     integer i1, i2;
00036     doublereal t1, t2, t3, v2, v3, aa, ab, ba, bb, h11, h12, h21, h22, cs;
00037     integer nh;
00038     doublereal sn;
00039     integer nr;
00040     doublereal tr;
00041     integer nz;
00042     doublereal det, h21s;
00043     integer its;
00044     doublereal ulp, sum, tst, rt1i, rt2i, rt1r, rt2r;
00045     extern /* Subroutine */ int drot_(integer *, doublereal *, integer *, 
00046             doublereal *, integer *, doublereal *, doublereal *), dcopy_(
00047             integer *, doublereal *, integer *, doublereal *, integer *), 
00048             dlanv2_(doublereal *, doublereal *, doublereal *, doublereal *, 
00049             doublereal *, doublereal *, doublereal *, doublereal *, 
00050             doublereal *, doublereal *), dlabad_(doublereal *, doublereal *);
00051     extern doublereal dlamch_(char *);
00052     extern /* Subroutine */ int dlarfg_(integer *, doublereal *, doublereal *, 
00053              integer *, doublereal *);
00054     doublereal safmin, safmax, rtdisc, smlnum;
00055 
00056 
00057 /*  -- LAPACK auxiliary routine (version 3.2) -- */
00058 /*     Univ. of Tennessee, Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd.. */
00059 /*     November 2006 */
00060 
00061 /*     .. Scalar Arguments .. */
00062 /*     .. */
00063 /*     .. Array Arguments .. */
00064 /*     .. */
00065 
00066 /*     Purpose */
00067 /*     ======= */
00068 
00069 /*     DLAHQR is an auxiliary routine called by DHSEQR to update the */
00070 /*     eigenvalues and Schur decomposition already computed by DHSEQR, by */
00071 /*     dealing with the Hessenberg submatrix in rows and columns ILO to */
00072 /*     IHI. */
00073 
00074 /*     Arguments */
00075 /*     ========= */
00076 
00077 /*     WANTT   (input) LOGICAL */
00078 /*          = .TRUE. : the full Schur form T is required; */
00079 /*          = .FALSE.: only eigenvalues are required. */
00080 
00081 /*     WANTZ   (input) LOGICAL */
00082 /*          = .TRUE. : the matrix of Schur vectors Z is required; */
00083 /*          = .FALSE.: Schur vectors are not required. */
00084 
00085 /*     N       (input) INTEGER */
00086 /*          The order of the matrix H.  N >= 0. */
00087 
00088 /*     ILO     (input) INTEGER */
00089 /*     IHI     (input) INTEGER */
00090 /*          It is assumed that H is already upper quasi-triangular in */
00091 /*          rows and columns IHI+1:N, and that H(ILO,ILO-1) = 0 (unless */
00092 /*          ILO = 1). DLAHQR works primarily with the Hessenberg */
00093 /*          submatrix in rows and columns ILO to IHI, but applies */
00094 /*          transformations to all of H if WANTT is .TRUE.. */
00095 /*          1 <= ILO <= max(1,IHI); IHI <= N. */
00096 
00097 /*     H       (input/output) DOUBLE PRECISION array, dimension (LDH,N) */
00098 /*          On entry, the upper Hessenberg matrix H. */
00099 /*          On exit, if INFO is zero and if WANTT is .TRUE., H is upper */
00100 /*          quasi-triangular in rows and columns ILO:IHI, with any */
00101 /*          2-by-2 diagonal blocks in standard form. If INFO is zero */
00102 /*          and WANTT is .FALSE., the contents of H are unspecified on */
00103 /*          exit.  The output state of H if INFO is nonzero is given */
00104 /*          below under the description of INFO. */
00105 
00106 /*     LDH     (input) INTEGER */
00107 /*          The leading dimension of the array H. LDH >= max(1,N). */
00108 
00109 /*     WR      (output) DOUBLE PRECISION array, dimension (N) */
00110 /*     WI      (output) DOUBLE PRECISION array, dimension (N) */
00111 /*          The real and imaginary parts, respectively, of the computed */
00112 /*          eigenvalues ILO to IHI are stored in the corresponding */
00113 /*          elements of WR and WI. If two eigenvalues are computed as a */
00114 /*          complex conjugate pair, they are stored in consecutive */
00115 /*          elements of WR and WI, say the i-th and (i+1)th, with */
00116 /*          WI(i) > 0 and WI(i+1) < 0. If WANTT is .TRUE., the */
00117 /*          eigenvalues are stored in the same order as on the diagonal */
00118 /*          of the Schur form returned in H, with WR(i) = H(i,i), and, if */
00119 /*          H(i:i+1,i:i+1) is a 2-by-2 diagonal block, */
00120 /*          WI(i) = sqrt(H(i+1,i)*H(i,i+1)) and WI(i+1) = -WI(i). */
00121 
00122 /*     ILOZ    (input) INTEGER */
00123 /*     IHIZ    (input) INTEGER */
00124 /*          Specify the rows of Z to which transformations must be */
00125 /*          applied if WANTZ is .TRUE.. */
00126 /*          1 <= ILOZ <= ILO; IHI <= IHIZ <= N. */
00127 
00128 /*     Z       (input/output) DOUBLE PRECISION array, dimension (LDZ,N) */
00129 /*          If WANTZ is .TRUE., on entry Z must contain the current */
00130 /*          matrix Z of transformations accumulated by DHSEQR, and on */
00131 /*          exit Z has been updated; transformations are applied only to */
00132 /*          the submatrix Z(ILOZ:IHIZ,ILO:IHI). */
00133 /*          If WANTZ is .FALSE., Z is not referenced. */
00134 
00135 /*     LDZ     (input) INTEGER */
00136 /*          The leading dimension of the array Z. LDZ >= max(1,N). */
00137 
00138 /*     INFO    (output) INTEGER */
00139 /*           =   0: successful exit */
00140 /*          .GT. 0: If INFO = i, DLAHQR failed to compute all the */
00141 /*                  eigenvalues ILO to IHI in a total of 30 iterations */
00142 /*                  per eigenvalue; elements i+1:ihi of WR and WI */
00143 /*                  contain those eigenvalues which have been */
00144 /*                  successfully computed. */
00145 
00146 /*                  If INFO .GT. 0 and WANTT is .FALSE., then on exit, */
00147 /*                  the remaining unconverged eigenvalues are the */
00148 /*                  eigenvalues of the upper Hessenberg matrix rows */
00149 /*                  and columns ILO thorugh INFO of the final, output */
00150 /*                  value of H. */
00151 
00152 /*                  If INFO .GT. 0 and WANTT is .TRUE., then on exit */
00153 /*          (*)       (initial value of H)*U  = U*(final value of H) */
00154 /*                  where U is an orthognal matrix.    The final */
00155 /*                  value of H is upper Hessenberg and triangular in */
00156 /*                  rows and columns INFO+1 through IHI. */
00157 
00158 /*                  If INFO .GT. 0 and WANTZ is .TRUE., then on exit */
00159 /*                      (final value of Z)  = (initial value of Z)*U */
00160 /*                  where U is the orthogonal matrix in (*) */
00161 /*                  (regardless of the value of WANTT.) */
00162 
00163 /*     Further Details */
00164 /*     =============== */
00165 
00166 /*     02-96 Based on modifications by */
00167 /*     David Day, Sandia National Laboratory, USA */
00168 
00169 /*     12-04 Further modifications by */
00170 /*     Ralph Byers, University of Kansas, USA */
00171 /*     This is a modified version of DLAHQR from LAPACK version 3.0. */
00172 /*     It is (1) more robust against overflow and underflow and */
00173 /*     (2) adopts the more conservative Ahues & Tisseur stopping */
00174 /*     criterion (LAWN 122, 1997). */
00175 
00176 /*     ========================================================= */
00177 
00178 /*     .. Parameters .. */
00179 /*     .. */
00180 /*     .. Local Scalars .. */
00181 /*     .. */
00182 /*     .. Local Arrays .. */
00183 /*     .. */
00184 /*     .. External Functions .. */
00185 /*     .. */
00186 /*     .. External Subroutines .. */
00187 /*     .. */
00188 /*     .. Intrinsic Functions .. */
00189 /*     .. */
00190 /*     .. Executable Statements .. */
00191 
00192     /* Parameter adjustments */
00193     h_dim1 = *ldh;
00194     h_offset = 1 + h_dim1;
00195     h__ -= h_offset;
00196     --wr;
00197     --wi;
00198     z_dim1 = *ldz;
00199     z_offset = 1 + z_dim1;
00200     z__ -= z_offset;
00201 
00202     /* Function Body */
00203     *info = 0;
00204 
00205 /*     Quick return if possible */
00206 
00207     if (*n == 0) {
00208         return 0;
00209     }
00210     if (*ilo == *ihi) {
00211         wr[*ilo] = h__[*ilo + *ilo * h_dim1];
00212         wi[*ilo] = 0.;
00213         return 0;
00214     }
00215 
00216 /*     ==== clear out the trash ==== */
00217     i__1 = *ihi - 3;
00218     for (j = *ilo; j <= i__1; ++j) {
00219         h__[j + 2 + j * h_dim1] = 0.;
00220         h__[j + 3 + j * h_dim1] = 0.;
00221 /* L10: */
00222     }
00223     if (*ilo <= *ihi - 2) {
00224         h__[*ihi + (*ihi - 2) * h_dim1] = 0.;
00225     }
00226 
00227     nh = *ihi - *ilo + 1;
00228     nz = *ihiz - *iloz + 1;
00229 
00230 /*     Set machine-dependent constants for the stopping criterion. */
00231 
00232     safmin = dlamch_("SAFE MINIMUM");
00233     safmax = 1. / safmin;
00234     dlabad_(&safmin, &safmax);
00235     ulp = dlamch_("PRECISION");
00236     smlnum = safmin * ((doublereal) nh / ulp);
00237 
00238 /*     I1 and I2 are the indices of the first row and last column of H */
00239 /*     to which transformations must be applied. If eigenvalues only are */
00240 /*     being computed, I1 and I2 are set inside the main loop. */
00241 
00242     if (*wantt) {
00243         i1 = 1;
00244         i2 = *n;
00245     }
00246 
00247 /*     The main loop begins here. I is the loop index and decreases from */
00248 /*     IHI to ILO in steps of 1 or 2. Each iteration of the loop works */
00249 /*     with the active submatrix in rows and columns L to I. */
00250 /*     Eigenvalues I+1 to IHI have already converged. Either L = ILO or */
00251 /*     H(L,L-1) is negligible so that the matrix splits. */
00252 
00253     i__ = *ihi;
00254 L20:
00255     l = *ilo;
00256     if (i__ < *ilo) {
00257         goto L160;
00258     }
00259 
00260 /*     Perform QR iterations on rows and columns ILO to I until a */
00261 /*     submatrix of order 1 or 2 splits off at the bottom because a */
00262 /*     subdiagonal element has become negligible. */
00263 
00264     for (its = 0; its <= 30; ++its) {
00265 
00266 /*        Look for a single small subdiagonal element. */
00267 
00268         i__1 = l + 1;
00269         for (k = i__; k >= i__1; --k) {
00270             if ((d__1 = h__[k + (k - 1) * h_dim1], abs(d__1)) <= smlnum) {
00271                 goto L40;
00272             }
00273             tst = (d__1 = h__[k - 1 + (k - 1) * h_dim1], abs(d__1)) + (d__2 = 
00274                     h__[k + k * h_dim1], abs(d__2));
00275             if (tst == 0.) {
00276                 if (k - 2 >= *ilo) {
00277                     tst += (d__1 = h__[k - 1 + (k - 2) * h_dim1], abs(d__1));
00278                 }
00279                 if (k + 1 <= *ihi) {
00280                     tst += (d__1 = h__[k + 1 + k * h_dim1], abs(d__1));
00281                 }
00282             }
00283 /*           ==== The following is a conservative small subdiagonal */
00284 /*           .    deflation  criterion due to Ahues & Tisseur (LAWN 122, */
00285 /*           .    1997). It has better mathematical foundation and */
00286 /*           .    improves accuracy in some cases.  ==== */
00287             if ((d__1 = h__[k + (k - 1) * h_dim1], abs(d__1)) <= ulp * tst) {
00288 /* Computing MAX */
00289                 d__3 = (d__1 = h__[k + (k - 1) * h_dim1], abs(d__1)), d__4 = (
00290                         d__2 = h__[k - 1 + k * h_dim1], abs(d__2));
00291                 ab = max(d__3,d__4);
00292 /* Computing MIN */
00293                 d__3 = (d__1 = h__[k + (k - 1) * h_dim1], abs(d__1)), d__4 = (
00294                         d__2 = h__[k - 1 + k * h_dim1], abs(d__2));
00295                 ba = min(d__3,d__4);
00296 /* Computing MAX */
00297                 d__3 = (d__1 = h__[k + k * h_dim1], abs(d__1)), d__4 = (d__2 =
00298                          h__[k - 1 + (k - 1) * h_dim1] - h__[k + k * h_dim1], 
00299                         abs(d__2));
00300                 aa = max(d__3,d__4);
00301 /* Computing MIN */
00302                 d__3 = (d__1 = h__[k + k * h_dim1], abs(d__1)), d__4 = (d__2 =
00303                          h__[k - 1 + (k - 1) * h_dim1] - h__[k + k * h_dim1], 
00304                         abs(d__2));
00305                 bb = min(d__3,d__4);
00306                 s = aa + ab;
00307 /* Computing MAX */
00308                 d__1 = smlnum, d__2 = ulp * (bb * (aa / s));
00309                 if (ba * (ab / s) <= max(d__1,d__2)) {
00310                     goto L40;
00311                 }
00312             }
00313 /* L30: */
00314         }
00315 L40:
00316         l = k;
00317         if (l > *ilo) {
00318 
00319 /*           H(L,L-1) is negligible */
00320 
00321             h__[l + (l - 1) * h_dim1] = 0.;
00322         }
00323 
00324 /*        Exit from loop if a submatrix of order 1 or 2 has split off. */
00325 
00326         if (l >= i__ - 1) {
00327             goto L150;
00328         }
00329 
00330 /*        Now the active submatrix is in rows and columns L to I. If */
00331 /*        eigenvalues only are being computed, only the active submatrix */
00332 /*        need be transformed. */
00333 
00334         if (! (*wantt)) {
00335             i1 = l;
00336             i2 = i__;
00337         }
00338 
00339         if (its == 10) {
00340 
00341 /*           Exceptional shift. */
00342 
00343             s = (d__1 = h__[l + 1 + l * h_dim1], abs(d__1)) + (d__2 = h__[l + 
00344                     2 + (l + 1) * h_dim1], abs(d__2));
00345             h11 = s * .75 + h__[l + l * h_dim1];
00346             h12 = s * -.4375;
00347             h21 = s;
00348             h22 = h11;
00349         } else if (its == 20) {
00350 
00351 /*           Exceptional shift. */
00352 
00353             s = (d__1 = h__[i__ + (i__ - 1) * h_dim1], abs(d__1)) + (d__2 = 
00354                     h__[i__ - 1 + (i__ - 2) * h_dim1], abs(d__2));
00355             h11 = s * .75 + h__[i__ + i__ * h_dim1];
00356             h12 = s * -.4375;
00357             h21 = s;
00358             h22 = h11;
00359         } else {
00360 
00361 /*           Prepare to use Francis' double shift */
00362 /*           (i.e. 2nd degree generalized Rayleigh quotient) */
00363 
00364             h11 = h__[i__ - 1 + (i__ - 1) * h_dim1];
00365             h21 = h__[i__ + (i__ - 1) * h_dim1];
00366             h12 = h__[i__ - 1 + i__ * h_dim1];
00367             h22 = h__[i__ + i__ * h_dim1];
00368         }
00369         s = abs(h11) + abs(h12) + abs(h21) + abs(h22);
00370         if (s == 0.) {
00371             rt1r = 0.;
00372             rt1i = 0.;
00373             rt2r = 0.;
00374             rt2i = 0.;
00375         } else {
00376             h11 /= s;
00377             h21 /= s;
00378             h12 /= s;
00379             h22 /= s;
00380             tr = (h11 + h22) / 2.;
00381             det = (h11 - tr) * (h22 - tr) - h12 * h21;
00382             rtdisc = sqrt((abs(det)));
00383             if (det >= 0.) {
00384 
00385 /*              ==== complex conjugate shifts ==== */
00386 
00387                 rt1r = tr * s;
00388                 rt2r = rt1r;
00389                 rt1i = rtdisc * s;
00390                 rt2i = -rt1i;
00391             } else {
00392 
00393 /*              ==== real shifts (use only one of them)  ==== */
00394 
00395                 rt1r = tr + rtdisc;
00396                 rt2r = tr - rtdisc;
00397                 if ((d__1 = rt1r - h22, abs(d__1)) <= (d__2 = rt2r - h22, abs(
00398                         d__2))) {
00399                     rt1r *= s;
00400                     rt2r = rt1r;
00401                 } else {
00402                     rt2r *= s;
00403                     rt1r = rt2r;
00404                 }
00405                 rt1i = 0.;
00406                 rt2i = 0.;
00407             }
00408         }
00409 
00410 /*        Look for two consecutive small subdiagonal elements. */
00411 
00412         i__1 = l;
00413         for (m = i__ - 2; m >= i__1; --m) {
00414 /*           Determine the effect of starting the double-shift QR */
00415 /*           iteration at row M, and see if this would make H(M,M-1) */
00416 /*           negligible.  (The following uses scaling to avoid */
00417 /*           overflows and most underflows.) */
00418 
00419             h21s = h__[m + 1 + m * h_dim1];
00420             s = (d__1 = h__[m + m * h_dim1] - rt2r, abs(d__1)) + abs(rt2i) + 
00421                     abs(h21s);
00422             h21s = h__[m + 1 + m * h_dim1] / s;
00423             v[0] = h21s * h__[m + (m + 1) * h_dim1] + (h__[m + m * h_dim1] - 
00424                     rt1r) * ((h__[m + m * h_dim1] - rt2r) / s) - rt1i * (rt2i 
00425                     / s);
00426             v[1] = h21s * (h__[m + m * h_dim1] + h__[m + 1 + (m + 1) * h_dim1]
00427                      - rt1r - rt2r);
00428             v[2] = h21s * h__[m + 2 + (m + 1) * h_dim1];
00429             s = abs(v[0]) + abs(v[1]) + abs(v[2]);
00430             v[0] /= s;
00431             v[1] /= s;
00432             v[2] /= s;
00433             if (m == l) {
00434                 goto L60;
00435             }
00436             if ((d__1 = h__[m + (m - 1) * h_dim1], abs(d__1)) * (abs(v[1]) + 
00437                     abs(v[2])) <= ulp * abs(v[0]) * ((d__2 = h__[m - 1 + (m - 
00438                     1) * h_dim1], abs(d__2)) + (d__3 = h__[m + m * h_dim1], 
00439                     abs(d__3)) + (d__4 = h__[m + 1 + (m + 1) * h_dim1], abs(
00440                     d__4)))) {
00441                 goto L60;
00442             }
00443 /* L50: */
00444         }
00445 L60:
00446 
00447 /*        Double-shift QR step */
00448 
00449         i__1 = i__ - 1;
00450         for (k = m; k <= i__1; ++k) {
00451 
00452 /*           The first iteration of this loop determines a reflection G */
00453 /*           from the vector V and applies it from left and right to H, */
00454 /*           thus creating a nonzero bulge below the subdiagonal. */
00455 
00456 /*           Each subsequent iteration determines a reflection G to */
00457 /*           restore the Hessenberg form in the (K-1)th column, and thus */
00458 /*           chases the bulge one step toward the bottom of the active */
00459 /*           submatrix. NR is the order of G. */
00460 
00461 /* Computing MIN */
00462             i__2 = 3, i__3 = i__ - k + 1;
00463             nr = min(i__2,i__3);
00464             if (k > m) {
00465                 dcopy_(&nr, &h__[k + (k - 1) * h_dim1], &c__1, v, &c__1);
00466             }
00467             dlarfg_(&nr, v, &v[1], &c__1, &t1);
00468             if (k > m) {
00469                 h__[k + (k - 1) * h_dim1] = v[0];
00470                 h__[k + 1 + (k - 1) * h_dim1] = 0.;
00471                 if (k < i__ - 1) {
00472                     h__[k + 2 + (k - 1) * h_dim1] = 0.;
00473                 }
00474             } else if (m > l) {
00475 /*               ==== Use the following instead of */
00476 /*               .    H( K, K-1 ) = -H( K, K-1 ) to */
00477 /*               .    avoid a bug when v(2) and v(3) */
00478 /*               .    underflow. ==== */
00479                 h__[k + (k - 1) * h_dim1] *= 1. - t1;
00480             }
00481             v2 = v[1];
00482             t2 = t1 * v2;
00483             if (nr == 3) {
00484                 v3 = v[2];
00485                 t3 = t1 * v3;
00486 
00487 /*              Apply G from the left to transform the rows of the matrix */
00488 /*              in columns K to I2. */
00489 
00490                 i__2 = i2;
00491                 for (j = k; j <= i__2; ++j) {
00492                     sum = h__[k + j * h_dim1] + v2 * h__[k + 1 + j * h_dim1] 
00493                             + v3 * h__[k + 2 + j * h_dim1];
00494                     h__[k + j * h_dim1] -= sum * t1;
00495                     h__[k + 1 + j * h_dim1] -= sum * t2;
00496                     h__[k + 2 + j * h_dim1] -= sum * t3;
00497 /* L70: */
00498                 }
00499 
00500 /*              Apply G from the right to transform the columns of the */
00501 /*              matrix in rows I1 to min(K+3,I). */
00502 
00503 /* Computing MIN */
00504                 i__3 = k + 3;
00505                 i__2 = min(i__3,i__);
00506                 for (j = i1; j <= i__2; ++j) {
00507                     sum = h__[j + k * h_dim1] + v2 * h__[j + (k + 1) * h_dim1]
00508                              + v3 * h__[j + (k + 2) * h_dim1];
00509                     h__[j + k * h_dim1] -= sum * t1;
00510                     h__[j + (k + 1) * h_dim1] -= sum * t2;
00511                     h__[j + (k + 2) * h_dim1] -= sum * t3;
00512 /* L80: */
00513                 }
00514 
00515                 if (*wantz) {
00516 
00517 /*                 Accumulate transformations in the matrix Z */
00518 
00519                     i__2 = *ihiz;
00520                     for (j = *iloz; j <= i__2; ++j) {
00521                         sum = z__[j + k * z_dim1] + v2 * z__[j + (k + 1) * 
00522                                 z_dim1] + v3 * z__[j + (k + 2) * z_dim1];
00523                         z__[j + k * z_dim1] -= sum * t1;
00524                         z__[j + (k + 1) * z_dim1] -= sum * t2;
00525                         z__[j + (k + 2) * z_dim1] -= sum * t3;
00526 /* L90: */
00527                     }
00528                 }
00529             } else if (nr == 2) {
00530 
00531 /*              Apply G from the left to transform the rows of the matrix */
00532 /*              in columns K to I2. */
00533 
00534                 i__2 = i2;
00535                 for (j = k; j <= i__2; ++j) {
00536                     sum = h__[k + j * h_dim1] + v2 * h__[k + 1 + j * h_dim1];
00537                     h__[k + j * h_dim1] -= sum * t1;
00538                     h__[k + 1 + j * h_dim1] -= sum * t2;
00539 /* L100: */
00540                 }
00541 
00542 /*              Apply G from the right to transform the columns of the */
00543 /*              matrix in rows I1 to min(K+3,I). */
00544 
00545                 i__2 = i__;
00546                 for (j = i1; j <= i__2; ++j) {
00547                     sum = h__[j + k * h_dim1] + v2 * h__[j + (k + 1) * h_dim1]
00548                             ;
00549                     h__[j + k * h_dim1] -= sum * t1;
00550                     h__[j + (k + 1) * h_dim1] -= sum * t2;
00551 /* L110: */
00552                 }
00553 
00554                 if (*wantz) {
00555 
00556 /*                 Accumulate transformations in the matrix Z */
00557 
00558                     i__2 = *ihiz;
00559                     for (j = *iloz; j <= i__2; ++j) {
00560                         sum = z__[j + k * z_dim1] + v2 * z__[j + (k + 1) * 
00561                                 z_dim1];
00562                         z__[j + k * z_dim1] -= sum * t1;
00563                         z__[j + (k + 1) * z_dim1] -= sum * t2;
00564 /* L120: */
00565                     }
00566                 }
00567             }
00568 /* L130: */
00569         }
00570 
00571 /* L140: */
00572     }
00573 
00574 /*     Failure to converge in remaining number of iterations */
00575 
00576     *info = i__;
00577     return 0;
00578 
00579 L150:
00580 
00581     if (l == i__) {
00582 
00583 /*        H(I,I-1) is negligible: one eigenvalue has converged. */
00584 
00585         wr[i__] = h__[i__ + i__ * h_dim1];
00586         wi[i__] = 0.;
00587     } else if (l == i__ - 1) {
00588 
00589 /*        H(I-1,I-2) is negligible: a pair of eigenvalues have converged. */
00590 
00591 /*        Transform the 2-by-2 submatrix to standard Schur form, */
00592 /*        and compute and store the eigenvalues. */
00593 
00594         dlanv2_(&h__[i__ - 1 + (i__ - 1) * h_dim1], &h__[i__ - 1 + i__ * 
00595                 h_dim1], &h__[i__ + (i__ - 1) * h_dim1], &h__[i__ + i__ * 
00596                 h_dim1], &wr[i__ - 1], &wi[i__ - 1], &wr[i__], &wi[i__], &cs, 
00597                 &sn);
00598 
00599         if (*wantt) {
00600 
00601 /*           Apply the transformation to the rest of H. */
00602 
00603             if (i2 > i__) {
00604                 i__1 = i2 - i__;
00605                 drot_(&i__1, &h__[i__ - 1 + (i__ + 1) * h_dim1], ldh, &h__[
00606                         i__ + (i__ + 1) * h_dim1], ldh, &cs, &sn);
00607             }
00608             i__1 = i__ - i1 - 1;
00609             drot_(&i__1, &h__[i1 + (i__ - 1) * h_dim1], &c__1, &h__[i1 + i__ *
00610                      h_dim1], &c__1, &cs, &sn);
00611         }
00612         if (*wantz) {
00613 
00614 /*           Apply the transformation to Z. */
00615 
00616             drot_(&nz, &z__[*iloz + (i__ - 1) * z_dim1], &c__1, &z__[*iloz + 
00617                     i__ * z_dim1], &c__1, &cs, &sn);
00618         }
00619     }
00620 
00621 /*     return to start of the main loop with new value of I. */
00622 
00623     i__ = l - 1;
00624     goto L20;
00625 
00626 L160:
00627     return 0;
00628 
00629 /*     End of DLAHQR */
00630 
00631 } /* dlahqr_ */


swiftnav
Author(s):
autogenerated on Sat Jun 8 2019 18:55:46