chgeqz.c
Go to the documentation of this file.
00001 /* chgeqz.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 complex c_b1 = {0.f,0.f};
00019 static complex c_b2 = {1.f,0.f};
00020 static integer c__1 = 1;
00021 static integer c__2 = 2;
00022 
00023 /* Subroutine */ int chgeqz_(char *job, char *compq, char *compz, integer *n, 
00024         integer *ilo, integer *ihi, complex *h__, integer *ldh, complex *t, 
00025         integer *ldt, complex *alpha, complex *beta, complex *q, integer *ldq, 
00026          complex *z__, integer *ldz, complex *work, integer *lwork, real *
00027         rwork, integer *info)
00028 {
00029     /* System generated locals */
00030     integer h_dim1, h_offset, q_dim1, q_offset, t_dim1, t_offset, z_dim1, 
00031             z_offset, i__1, i__2, i__3, i__4, i__5, i__6;
00032     real r__1, r__2, r__3, r__4, r__5, r__6;
00033     complex q__1, q__2, q__3, q__4, q__5, q__6;
00034 
00035     /* Builtin functions */
00036     double c_abs(complex *);
00037     void r_cnjg(complex *, complex *);
00038     double r_imag(complex *);
00039     void c_div(complex *, complex *, complex *), pow_ci(complex *, complex *, 
00040             integer *), c_sqrt(complex *, complex *);
00041 
00042     /* Local variables */
00043     real c__;
00044     integer j;
00045     complex s, t1;
00046     integer jc, in;
00047     complex u12;
00048     integer jr;
00049     complex ad11, ad12, ad21, ad22;
00050     integer jch;
00051     logical ilq, ilz;
00052     real ulp;
00053     complex abi22;
00054     real absb, atol, btol, temp;
00055     extern /* Subroutine */ int crot_(integer *, complex *, integer *, 
00056             complex *, integer *, real *, complex *);
00057     real temp2;
00058     extern /* Subroutine */ int cscal_(integer *, complex *, complex *, 
00059             integer *);
00060     extern logical lsame_(char *, char *);
00061     complex ctemp;
00062     integer iiter, ilast, jiter;
00063     real anorm, bnorm;
00064     integer maxit;
00065     complex shift;
00066     real tempr;
00067     complex ctemp2, ctemp3;
00068     logical ilazr2;
00069     real ascale, bscale;
00070     complex signbc;
00071     extern doublereal slamch_(char *), clanhs_(char *, integer *, 
00072             complex *, integer *, real *);
00073     extern /* Subroutine */ int claset_(char *, integer *, integer *, complex 
00074             *, complex *, complex *, integer *), clartg_(complex *, 
00075             complex *, real *, complex *, complex *);
00076     real safmin;
00077     extern /* Subroutine */ int xerbla_(char *, integer *);
00078     complex eshift;
00079     logical ilschr;
00080     integer icompq, ilastm;
00081     complex rtdisc;
00082     integer ischur;
00083     logical ilazro;
00084     integer icompz, ifirst, ifrstm, istart;
00085     logical lquery;
00086 
00087 
00088 /*  -- LAPACK routine (version 3.2) -- */
00089 /*  -- LAPACK is a software package provided by Univ. of Tennessee,    -- */
00090 /*  -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */
00091 /*     November 2006 */
00092 
00093 /*     .. Scalar Arguments .. */
00094 /*     .. */
00095 /*     .. Array Arguments .. */
00096 /*     .. */
00097 
00098 /*  Purpose */
00099 /*  ======= */
00100 
00101 /*  CHGEQZ computes the eigenvalues of a complex matrix pair (H,T), */
00102 /*  where H is an upper Hessenberg matrix and T is upper triangular, */
00103 /*  using the single-shift QZ method. */
00104 /*  Matrix pairs of this type are produced by the reduction to */
00105 /*  generalized upper Hessenberg form of a complex matrix pair (A,B): */
00106 
00107 /*     A = Q1*H*Z1**H,  B = Q1*T*Z1**H, */
00108 
00109 /*  as computed by CGGHRD. */
00110 
00111 /*  If JOB='S', then the Hessenberg-triangular pair (H,T) is */
00112 /*  also reduced to generalized Schur form, */
00113 
00114 /*     H = Q*S*Z**H,  T = Q*P*Z**H, */
00115 
00116 /*  where Q and Z are unitary matrices and S and P are upper triangular. */
00117 
00118 /*  Optionally, the unitary matrix Q from the generalized Schur */
00119 /*  factorization may be postmultiplied into an input matrix Q1, and the */
00120 /*  unitary matrix Z may be postmultiplied into an input matrix Z1. */
00121 /*  If Q1 and Z1 are the unitary matrices from CGGHRD that reduced */
00122 /*  the matrix pair (A,B) to generalized Hessenberg form, then the output */
00123 /*  matrices Q1*Q and Z1*Z are the unitary factors from the generalized */
00124 /*  Schur factorization of (A,B): */
00125 
00126 /*     A = (Q1*Q)*S*(Z1*Z)**H,  B = (Q1*Q)*P*(Z1*Z)**H. */
00127 
00128 /*  To avoid overflow, eigenvalues of the matrix pair (H,T) */
00129 /*  (equivalently, of (A,B)) are computed as a pair of complex values */
00130 /*  (alpha,beta).  If beta is nonzero, lambda = alpha / beta is an */
00131 /*  eigenvalue of the generalized nonsymmetric eigenvalue problem (GNEP) */
00132 /*     A*x = lambda*B*x */
00133 /*  and if alpha is nonzero, mu = beta / alpha is an eigenvalue of the */
00134 /*  alternate form of the GNEP */
00135 /*     mu*A*y = B*y. */
00136 /*  The values of alpha and beta for the i-th eigenvalue can be read */
00137 /*  directly from the generalized Schur form:  alpha = S(i,i), */
00138 /*  beta = P(i,i). */
00139 
00140 /*  Ref: C.B. Moler & G.W. Stewart, "An Algorithm for Generalized Matrix */
00141 /*       Eigenvalue Problems", SIAM J. Numer. Anal., 10(1973), */
00142 /*       pp. 241--256. */
00143 
00144 /*  Arguments */
00145 /*  ========= */
00146 
00147 /*  JOB     (input) CHARACTER*1 */
00148 /*          = 'E': Compute eigenvalues only; */
00149 /*          = 'S': Computer eigenvalues and the Schur form. */
00150 
00151 /*  COMPQ   (input) CHARACTER*1 */
00152 /*          = 'N': Left Schur vectors (Q) are not computed; */
00153 /*          = 'I': Q is initialized to the unit matrix and the matrix Q */
00154 /*                 of left Schur vectors of (H,T) is returned; */
00155 /*          = 'V': Q must contain a unitary matrix Q1 on entry and */
00156 /*                 the product Q1*Q is returned. */
00157 
00158 /*  COMPZ   (input) CHARACTER*1 */
00159 /*          = 'N': Right Schur vectors (Z) are not computed; */
00160 /*          = 'I': Q is initialized to the unit matrix and the matrix Z */
00161 /*                 of right Schur vectors of (H,T) is returned; */
00162 /*          = 'V': Z must contain a unitary matrix Z1 on entry and */
00163 /*                 the product Z1*Z is returned. */
00164 
00165 /*  N       (input) INTEGER */
00166 /*          The order of the matrices H, T, Q, and Z.  N >= 0. */
00167 
00168 /*  ILO     (input) INTEGER */
00169 /*  IHI     (input) INTEGER */
00170 /*          ILO and IHI mark the rows and columns of H which are in */
00171 /*          Hessenberg form.  It is assumed that A is already upper */
00172 /*          triangular in rows and columns 1:ILO-1 and IHI+1:N. */
00173 /*          If N > 0, 1 <= ILO <= IHI <= N; if N = 0, ILO=1 and IHI=0. */
00174 
00175 /*  H       (input/output) COMPLEX array, dimension (LDH, N) */
00176 /*          On entry, the N-by-N upper Hessenberg matrix H. */
00177 /*          On exit, if JOB = 'S', H contains the upper triangular */
00178 /*          matrix S from the generalized Schur factorization. */
00179 /*          If JOB = 'E', the diagonal of H matches that of S, but */
00180 /*          the rest of H is unspecified. */
00181 
00182 /*  LDH     (input) INTEGER */
00183 /*          The leading dimension of the array H.  LDH >= max( 1, N ). */
00184 
00185 /*  T       (input/output) COMPLEX array, dimension (LDT, N) */
00186 /*          On entry, the N-by-N upper triangular matrix T. */
00187 /*          On exit, if JOB = 'S', T contains the upper triangular */
00188 /*          matrix P from the generalized Schur factorization. */
00189 /*          If JOB = 'E', the diagonal of T matches that of P, but */
00190 /*          the rest of T is unspecified. */
00191 
00192 /*  LDT     (input) INTEGER */
00193 /*          The leading dimension of the array T.  LDT >= max( 1, N ). */
00194 
00195 /*  ALPHA   (output) COMPLEX array, dimension (N) */
00196 /*          The complex scalars alpha that define the eigenvalues of */
00197 /*          GNEP.  ALPHA(i) = S(i,i) in the generalized Schur */
00198 /*          factorization. */
00199 
00200 /*  BETA    (output) COMPLEX array, dimension (N) */
00201 /*          The real non-negative scalars beta that define the */
00202 /*          eigenvalues of GNEP.  BETA(i) = P(i,i) in the generalized */
00203 /*          Schur factorization. */
00204 
00205 /*          Together, the quantities alpha = ALPHA(j) and beta = BETA(j) */
00206 /*          represent the j-th eigenvalue of the matrix pair (A,B), in */
00207 /*          one of the forms lambda = alpha/beta or mu = beta/alpha. */
00208 /*          Since either lambda or mu may overflow, they should not, */
00209 /*          in general, be computed. */
00210 
00211 /*  Q       (input/output) COMPLEX array, dimension (LDQ, N) */
00212 /*          On entry, if COMPZ = 'V', the unitary matrix Q1 used in the */
00213 /*          reduction of (A,B) to generalized Hessenberg form. */
00214 /*          On exit, if COMPZ = 'I', the unitary matrix of left Schur */
00215 /*          vectors of (H,T), and if COMPZ = 'V', the unitary matrix of */
00216 /*          left Schur vectors of (A,B). */
00217 /*          Not referenced if COMPZ = 'N'. */
00218 
00219 /*  LDQ     (input) INTEGER */
00220 /*          The leading dimension of the array Q.  LDQ >= 1. */
00221 /*          If COMPQ='V' or 'I', then LDQ >= N. */
00222 
00223 /*  Z       (input/output) COMPLEX array, dimension (LDZ, N) */
00224 /*          On entry, if COMPZ = 'V', the unitary matrix Z1 used in the */
00225 /*          reduction of (A,B) to generalized Hessenberg form. */
00226 /*          On exit, if COMPZ = 'I', the unitary matrix of right Schur */
00227 /*          vectors of (H,T), and if COMPZ = 'V', the unitary matrix of */
00228 /*          right Schur vectors of (A,B). */
00229 /*          Not referenced if COMPZ = 'N'. */
00230 
00231 /*  LDZ     (input) INTEGER */
00232 /*          The leading dimension of the array Z.  LDZ >= 1. */
00233 /*          If COMPZ='V' or 'I', then LDZ >= N. */
00234 
00235 /*  WORK    (workspace/output) COMPLEX array, dimension (MAX(1,LWORK)) */
00236 /*          On exit, if INFO >= 0, WORK(1) returns the optimal LWORK. */
00237 
00238 /*  LWORK   (input) INTEGER */
00239 /*          The dimension of the array WORK.  LWORK >= max(1,N). */
00240 
00241 /*          If LWORK = -1, then a workspace query is assumed; the routine */
00242 /*          only calculates the optimal size of the WORK array, returns */
00243 /*          this value as the first entry of the WORK array, and no error */
00244 /*          message related to LWORK is issued by XERBLA. */
00245 
00246 /*  RWORK   (workspace) REAL array, dimension (N) */
00247 
00248 /*  INFO    (output) INTEGER */
00249 /*          = 0: successful exit */
00250 /*          < 0: if INFO = -i, the i-th argument had an illegal value */
00251 /*          = 1,...,N: the QZ iteration did not converge.  (H,T) is not */
00252 /*                     in Schur form, but ALPHA(i) and BETA(i), */
00253 /*                     i=INFO+1,...,N should be correct. */
00254 /*          = N+1,...,2*N: the shift calculation failed.  (H,T) is not */
00255 /*                     in Schur form, but ALPHA(i) and BETA(i), */
00256 /*                     i=INFO-N+1,...,N should be correct. */
00257 
00258 /*  Further Details */
00259 /*  =============== */
00260 
00261 /*  We assume that complex ABS works as long as its value is less than */
00262 /*  overflow. */
00263 
00264 /*  ===================================================================== */
00265 
00266 /*     .. Parameters .. */
00267 /*     .. */
00268 /*     .. Local Scalars .. */
00269 /*     .. */
00270 /*     .. External Functions .. */
00271 /*     .. */
00272 /*     .. External Subroutines .. */
00273 /*     .. */
00274 /*     .. Intrinsic Functions .. */
00275 /*     .. */
00276 /*     .. Statement Functions .. */
00277 /*     .. */
00278 /*     .. Statement Function definitions .. */
00279 /*     .. */
00280 /*     .. Executable Statements .. */
00281 
00282 /*     Decode JOB, COMPQ, COMPZ */
00283 
00284     /* Parameter adjustments */
00285     h_dim1 = *ldh;
00286     h_offset = 1 + h_dim1;
00287     h__ -= h_offset;
00288     t_dim1 = *ldt;
00289     t_offset = 1 + t_dim1;
00290     t -= t_offset;
00291     --alpha;
00292     --beta;
00293     q_dim1 = *ldq;
00294     q_offset = 1 + q_dim1;
00295     q -= q_offset;
00296     z_dim1 = *ldz;
00297     z_offset = 1 + z_dim1;
00298     z__ -= z_offset;
00299     --work;
00300     --rwork;
00301 
00302     /* Function Body */
00303     if (lsame_(job, "E")) {
00304         ilschr = FALSE_;
00305         ischur = 1;
00306     } else if (lsame_(job, "S")) {
00307         ilschr = TRUE_;
00308         ischur = 2;
00309     } else {
00310         ischur = 0;
00311     }
00312 
00313     if (lsame_(compq, "N")) {
00314         ilq = FALSE_;
00315         icompq = 1;
00316     } else if (lsame_(compq, "V")) {
00317         ilq = TRUE_;
00318         icompq = 2;
00319     } else if (lsame_(compq, "I")) {
00320         ilq = TRUE_;
00321         icompq = 3;
00322     } else {
00323         icompq = 0;
00324     }
00325 
00326     if (lsame_(compz, "N")) {
00327         ilz = FALSE_;
00328         icompz = 1;
00329     } else if (lsame_(compz, "V")) {
00330         ilz = TRUE_;
00331         icompz = 2;
00332     } else if (lsame_(compz, "I")) {
00333         ilz = TRUE_;
00334         icompz = 3;
00335     } else {
00336         icompz = 0;
00337     }
00338 
00339 /*     Check Argument Values */
00340 
00341     *info = 0;
00342     i__1 = max(1,*n);
00343     work[1].r = (real) i__1, work[1].i = 0.f;
00344     lquery = *lwork == -1;
00345     if (ischur == 0) {
00346         *info = -1;
00347     } else if (icompq == 0) {
00348         *info = -2;
00349     } else if (icompz == 0) {
00350         *info = -3;
00351     } else if (*n < 0) {
00352         *info = -4;
00353     } else if (*ilo < 1) {
00354         *info = -5;
00355     } else if (*ihi > *n || *ihi < *ilo - 1) {
00356         *info = -6;
00357     } else if (*ldh < *n) {
00358         *info = -8;
00359     } else if (*ldt < *n) {
00360         *info = -10;
00361     } else if (*ldq < 1 || ilq && *ldq < *n) {
00362         *info = -14;
00363     } else if (*ldz < 1 || ilz && *ldz < *n) {
00364         *info = -16;
00365     } else if (*lwork < max(1,*n) && ! lquery) {
00366         *info = -18;
00367     }
00368     if (*info != 0) {
00369         i__1 = -(*info);
00370         xerbla_("CHGEQZ", &i__1);
00371         return 0;
00372     } else if (lquery) {
00373         return 0;
00374     }
00375 
00376 /*     Quick return if possible */
00377 
00378 /*     WORK( 1 ) = CMPLX( 1 ) */
00379     if (*n <= 0) {
00380         work[1].r = 1.f, work[1].i = 0.f;
00381         return 0;
00382     }
00383 
00384 /*     Initialize Q and Z */
00385 
00386     if (icompq == 3) {
00387         claset_("Full", n, n, &c_b1, &c_b2, &q[q_offset], ldq);
00388     }
00389     if (icompz == 3) {
00390         claset_("Full", n, n, &c_b1, &c_b2, &z__[z_offset], ldz);
00391     }
00392 
00393 /*     Machine Constants */
00394 
00395     in = *ihi + 1 - *ilo;
00396     safmin = slamch_("S");
00397     ulp = slamch_("E") * slamch_("B");
00398     anorm = clanhs_("F", &in, &h__[*ilo + *ilo * h_dim1], ldh, &rwork[1]);
00399     bnorm = clanhs_("F", &in, &t[*ilo + *ilo * t_dim1], ldt, &rwork[1]);
00400 /* Computing MAX */
00401     r__1 = safmin, r__2 = ulp * anorm;
00402     atol = dmax(r__1,r__2);
00403 /* Computing MAX */
00404     r__1 = safmin, r__2 = ulp * bnorm;
00405     btol = dmax(r__1,r__2);
00406     ascale = 1.f / dmax(safmin,anorm);
00407     bscale = 1.f / dmax(safmin,bnorm);
00408 
00409 
00410 /*     Set Eigenvalues IHI+1:N */
00411 
00412     i__1 = *n;
00413     for (j = *ihi + 1; j <= i__1; ++j) {
00414         absb = c_abs(&t[j + j * t_dim1]);
00415         if (absb > safmin) {
00416             i__2 = j + j * t_dim1;
00417             q__2.r = t[i__2].r / absb, q__2.i = t[i__2].i / absb;
00418             r_cnjg(&q__1, &q__2);
00419             signbc.r = q__1.r, signbc.i = q__1.i;
00420             i__2 = j + j * t_dim1;
00421             t[i__2].r = absb, t[i__2].i = 0.f;
00422             if (ilschr) {
00423                 i__2 = j - 1;
00424                 cscal_(&i__2, &signbc, &t[j * t_dim1 + 1], &c__1);
00425                 cscal_(&j, &signbc, &h__[j * h_dim1 + 1], &c__1);
00426             } else {
00427                 i__2 = j + j * h_dim1;
00428                 i__3 = j + j * h_dim1;
00429                 q__1.r = h__[i__3].r * signbc.r - h__[i__3].i * signbc.i, 
00430                         q__1.i = h__[i__3].r * signbc.i + h__[i__3].i * 
00431                         signbc.r;
00432                 h__[i__2].r = q__1.r, h__[i__2].i = q__1.i;
00433             }
00434             if (ilz) {
00435                 cscal_(n, &signbc, &z__[j * z_dim1 + 1], &c__1);
00436             }
00437         } else {
00438             i__2 = j + j * t_dim1;
00439             t[i__2].r = 0.f, t[i__2].i = 0.f;
00440         }
00441         i__2 = j;
00442         i__3 = j + j * h_dim1;
00443         alpha[i__2].r = h__[i__3].r, alpha[i__2].i = h__[i__3].i;
00444         i__2 = j;
00445         i__3 = j + j * t_dim1;
00446         beta[i__2].r = t[i__3].r, beta[i__2].i = t[i__3].i;
00447 /* L10: */
00448     }
00449 
00450 /*     If IHI < ILO, skip QZ steps */
00451 
00452     if (*ihi < *ilo) {
00453         goto L190;
00454     }
00455 
00456 /*     MAIN QZ ITERATION LOOP */
00457 
00458 /*     Initialize dynamic indices */
00459 
00460 /*     Eigenvalues ILAST+1:N have been found. */
00461 /*        Column operations modify rows IFRSTM:whatever */
00462 /*        Row operations modify columns whatever:ILASTM */
00463 
00464 /*     If only eigenvalues are being computed, then */
00465 /*        IFRSTM is the row of the last splitting row above row ILAST; */
00466 /*        this is always at least ILO. */
00467 /*     IITER counts iterations since the last eigenvalue was found, */
00468 /*        to tell when to use an extraordinary shift. */
00469 /*     MAXIT is the maximum number of QZ sweeps allowed. */
00470 
00471     ilast = *ihi;
00472     if (ilschr) {
00473         ifrstm = 1;
00474         ilastm = *n;
00475     } else {
00476         ifrstm = *ilo;
00477         ilastm = *ihi;
00478     }
00479     iiter = 0;
00480     eshift.r = 0.f, eshift.i = 0.f;
00481     maxit = (*ihi - *ilo + 1) * 30;
00482 
00483     i__1 = maxit;
00484     for (jiter = 1; jiter <= i__1; ++jiter) {
00485 
00486 /*        Check for too many iterations. */
00487 
00488         if (jiter > maxit) {
00489             goto L180;
00490         }
00491 
00492 /*        Split the matrix if possible. */
00493 
00494 /*        Two tests: */
00495 /*           1: H(j,j-1)=0  or  j=ILO */
00496 /*           2: T(j,j)=0 */
00497 
00498 /*        Special case: j=ILAST */
00499 
00500         if (ilast == *ilo) {
00501             goto L60;
00502         } else {
00503             i__2 = ilast + (ilast - 1) * h_dim1;
00504             if ((r__1 = h__[i__2].r, dabs(r__1)) + (r__2 = r_imag(&h__[ilast 
00505                     + (ilast - 1) * h_dim1]), dabs(r__2)) <= atol) {
00506                 i__2 = ilast + (ilast - 1) * h_dim1;
00507                 h__[i__2].r = 0.f, h__[i__2].i = 0.f;
00508                 goto L60;
00509             }
00510         }
00511 
00512         if (c_abs(&t[ilast + ilast * t_dim1]) <= btol) {
00513             i__2 = ilast + ilast * t_dim1;
00514             t[i__2].r = 0.f, t[i__2].i = 0.f;
00515             goto L50;
00516         }
00517 
00518 /*        General case: j<ILAST */
00519 
00520         i__2 = *ilo;
00521         for (j = ilast - 1; j >= i__2; --j) {
00522 
00523 /*           Test 1: for H(j,j-1)=0 or j=ILO */
00524 
00525             if (j == *ilo) {
00526                 ilazro = TRUE_;
00527             } else {
00528                 i__3 = j + (j - 1) * h_dim1;
00529                 if ((r__1 = h__[i__3].r, dabs(r__1)) + (r__2 = r_imag(&h__[j 
00530                         + (j - 1) * h_dim1]), dabs(r__2)) <= atol) {
00531                     i__3 = j + (j - 1) * h_dim1;
00532                     h__[i__3].r = 0.f, h__[i__3].i = 0.f;
00533                     ilazro = TRUE_;
00534                 } else {
00535                     ilazro = FALSE_;
00536                 }
00537             }
00538 
00539 /*           Test 2: for T(j,j)=0 */
00540 
00541             if (c_abs(&t[j + j * t_dim1]) < btol) {
00542                 i__3 = j + j * t_dim1;
00543                 t[i__3].r = 0.f, t[i__3].i = 0.f;
00544 
00545 /*              Test 1a: Check for 2 consecutive small subdiagonals in A */
00546 
00547                 ilazr2 = FALSE_;
00548                 if (! ilazro) {
00549                     i__3 = j + (j - 1) * h_dim1;
00550                     i__4 = j + 1 + j * h_dim1;
00551                     i__5 = j + j * h_dim1;
00552                     if (((r__1 = h__[i__3].r, dabs(r__1)) + (r__2 = r_imag(&
00553                             h__[j + (j - 1) * h_dim1]), dabs(r__2))) * (
00554                             ascale * ((r__3 = h__[i__4].r, dabs(r__3)) + (
00555                             r__4 = r_imag(&h__[j + 1 + j * h_dim1]), dabs(
00556                             r__4)))) <= ((r__5 = h__[i__5].r, dabs(r__5)) + (
00557                             r__6 = r_imag(&h__[j + j * h_dim1]), dabs(r__6))) 
00558                             * (ascale * atol)) {
00559                         ilazr2 = TRUE_;
00560                     }
00561                 }
00562 
00563 /*              If both tests pass (1 & 2), i.e., the leading diagonal */
00564 /*              element of B in the block is zero, split a 1x1 block off */
00565 /*              at the top. (I.e., at the J-th row/column) The leading */
00566 /*              diagonal element of the remainder can also be zero, so */
00567 /*              this may have to be done repeatedly. */
00568 
00569                 if (ilazro || ilazr2) {
00570                     i__3 = ilast - 1;
00571                     for (jch = j; jch <= i__3; ++jch) {
00572                         i__4 = jch + jch * h_dim1;
00573                         ctemp.r = h__[i__4].r, ctemp.i = h__[i__4].i;
00574                         clartg_(&ctemp, &h__[jch + 1 + jch * h_dim1], &c__, &
00575                                 s, &h__[jch + jch * h_dim1]);
00576                         i__4 = jch + 1 + jch * h_dim1;
00577                         h__[i__4].r = 0.f, h__[i__4].i = 0.f;
00578                         i__4 = ilastm - jch;
00579                         crot_(&i__4, &h__[jch + (jch + 1) * h_dim1], ldh, &
00580                                 h__[jch + 1 + (jch + 1) * h_dim1], ldh, &c__, 
00581                                 &s);
00582                         i__4 = ilastm - jch;
00583                         crot_(&i__4, &t[jch + (jch + 1) * t_dim1], ldt, &t[
00584                                 jch + 1 + (jch + 1) * t_dim1], ldt, &c__, &s);
00585                         if (ilq) {
00586                             r_cnjg(&q__1, &s);
00587                             crot_(n, &q[jch * q_dim1 + 1], &c__1, &q[(jch + 1)
00588                                      * q_dim1 + 1], &c__1, &c__, &q__1);
00589                         }
00590                         if (ilazr2) {
00591                             i__4 = jch + (jch - 1) * h_dim1;
00592                             i__5 = jch + (jch - 1) * h_dim1;
00593                             q__1.r = c__ * h__[i__5].r, q__1.i = c__ * h__[
00594                                     i__5].i;
00595                             h__[i__4].r = q__1.r, h__[i__4].i = q__1.i;
00596                         }
00597                         ilazr2 = FALSE_;
00598                         i__4 = jch + 1 + (jch + 1) * t_dim1;
00599                         if ((r__1 = t[i__4].r, dabs(r__1)) + (r__2 = r_imag(&
00600                                 t[jch + 1 + (jch + 1) * t_dim1]), dabs(r__2)) 
00601                                 >= btol) {
00602                             if (jch + 1 >= ilast) {
00603                                 goto L60;
00604                             } else {
00605                                 ifirst = jch + 1;
00606                                 goto L70;
00607                             }
00608                         }
00609                         i__4 = jch + 1 + (jch + 1) * t_dim1;
00610                         t[i__4].r = 0.f, t[i__4].i = 0.f;
00611 /* L20: */
00612                     }
00613                     goto L50;
00614                 } else {
00615 
00616 /*                 Only test 2 passed -- chase the zero to T(ILAST,ILAST) */
00617 /*                 Then process as in the case T(ILAST,ILAST)=0 */
00618 
00619                     i__3 = ilast - 1;
00620                     for (jch = j; jch <= i__3; ++jch) {
00621                         i__4 = jch + (jch + 1) * t_dim1;
00622                         ctemp.r = t[i__4].r, ctemp.i = t[i__4].i;
00623                         clartg_(&ctemp, &t[jch + 1 + (jch + 1) * t_dim1], &
00624                                 c__, &s, &t[jch + (jch + 1) * t_dim1]);
00625                         i__4 = jch + 1 + (jch + 1) * t_dim1;
00626                         t[i__4].r = 0.f, t[i__4].i = 0.f;
00627                         if (jch < ilastm - 1) {
00628                             i__4 = ilastm - jch - 1;
00629                             crot_(&i__4, &t[jch + (jch + 2) * t_dim1], ldt, &
00630                                     t[jch + 1 + (jch + 2) * t_dim1], ldt, &
00631                                     c__, &s);
00632                         }
00633                         i__4 = ilastm - jch + 2;
00634                         crot_(&i__4, &h__[jch + (jch - 1) * h_dim1], ldh, &
00635                                 h__[jch + 1 + (jch - 1) * h_dim1], ldh, &c__, 
00636                                 &s);
00637                         if (ilq) {
00638                             r_cnjg(&q__1, &s);
00639                             crot_(n, &q[jch * q_dim1 + 1], &c__1, &q[(jch + 1)
00640                                      * q_dim1 + 1], &c__1, &c__, &q__1);
00641                         }
00642                         i__4 = jch + 1 + jch * h_dim1;
00643                         ctemp.r = h__[i__4].r, ctemp.i = h__[i__4].i;
00644                         clartg_(&ctemp, &h__[jch + 1 + (jch - 1) * h_dim1], &
00645                                 c__, &s, &h__[jch + 1 + jch * h_dim1]);
00646                         i__4 = jch + 1 + (jch - 1) * h_dim1;
00647                         h__[i__4].r = 0.f, h__[i__4].i = 0.f;
00648                         i__4 = jch + 1 - ifrstm;
00649                         crot_(&i__4, &h__[ifrstm + jch * h_dim1], &c__1, &h__[
00650                                 ifrstm + (jch - 1) * h_dim1], &c__1, &c__, &s)
00651                                 ;
00652                         i__4 = jch - ifrstm;
00653                         crot_(&i__4, &t[ifrstm + jch * t_dim1], &c__1, &t[
00654                                 ifrstm + (jch - 1) * t_dim1], &c__1, &c__, &s)
00655                                 ;
00656                         if (ilz) {
00657                             crot_(n, &z__[jch * z_dim1 + 1], &c__1, &z__[(jch 
00658                                     - 1) * z_dim1 + 1], &c__1, &c__, &s);
00659                         }
00660 /* L30: */
00661                     }
00662                     goto L50;
00663                 }
00664             } else if (ilazro) {
00665 
00666 /*              Only test 1 passed -- work on J:ILAST */
00667 
00668                 ifirst = j;
00669                 goto L70;
00670             }
00671 
00672 /*           Neither test passed -- try next J */
00673 
00674 /* L40: */
00675         }
00676 
00677 /*        (Drop-through is "impossible") */
00678 
00679         *info = (*n << 1) + 1;
00680         goto L210;
00681 
00682 /*        T(ILAST,ILAST)=0 -- clear H(ILAST,ILAST-1) to split off a */
00683 /*        1x1 block. */
00684 
00685 L50:
00686         i__2 = ilast + ilast * h_dim1;
00687         ctemp.r = h__[i__2].r, ctemp.i = h__[i__2].i;
00688         clartg_(&ctemp, &h__[ilast + (ilast - 1) * h_dim1], &c__, &s, &h__[
00689                 ilast + ilast * h_dim1]);
00690         i__2 = ilast + (ilast - 1) * h_dim1;
00691         h__[i__2].r = 0.f, h__[i__2].i = 0.f;
00692         i__2 = ilast - ifrstm;
00693         crot_(&i__2, &h__[ifrstm + ilast * h_dim1], &c__1, &h__[ifrstm + (
00694                 ilast - 1) * h_dim1], &c__1, &c__, &s);
00695         i__2 = ilast - ifrstm;
00696         crot_(&i__2, &t[ifrstm + ilast * t_dim1], &c__1, &t[ifrstm + (ilast - 
00697                 1) * t_dim1], &c__1, &c__, &s);
00698         if (ilz) {
00699             crot_(n, &z__[ilast * z_dim1 + 1], &c__1, &z__[(ilast - 1) * 
00700                     z_dim1 + 1], &c__1, &c__, &s);
00701         }
00702 
00703 /*        H(ILAST,ILAST-1)=0 -- Standardize B, set ALPHA and BETA */
00704 
00705 L60:
00706         absb = c_abs(&t[ilast + ilast * t_dim1]);
00707         if (absb > safmin) {
00708             i__2 = ilast + ilast * t_dim1;
00709             q__2.r = t[i__2].r / absb, q__2.i = t[i__2].i / absb;
00710             r_cnjg(&q__1, &q__2);
00711             signbc.r = q__1.r, signbc.i = q__1.i;
00712             i__2 = ilast + ilast * t_dim1;
00713             t[i__2].r = absb, t[i__2].i = 0.f;
00714             if (ilschr) {
00715                 i__2 = ilast - ifrstm;
00716                 cscal_(&i__2, &signbc, &t[ifrstm + ilast * t_dim1], &c__1);
00717                 i__2 = ilast + 1 - ifrstm;
00718                 cscal_(&i__2, &signbc, &h__[ifrstm + ilast * h_dim1], &c__1);
00719             } else {
00720                 i__2 = ilast + ilast * h_dim1;
00721                 i__3 = ilast + ilast * h_dim1;
00722                 q__1.r = h__[i__3].r * signbc.r - h__[i__3].i * signbc.i, 
00723                         q__1.i = h__[i__3].r * signbc.i + h__[i__3].i * 
00724                         signbc.r;
00725                 h__[i__2].r = q__1.r, h__[i__2].i = q__1.i;
00726             }
00727             if (ilz) {
00728                 cscal_(n, &signbc, &z__[ilast * z_dim1 + 1], &c__1);
00729             }
00730         } else {
00731             i__2 = ilast + ilast * t_dim1;
00732             t[i__2].r = 0.f, t[i__2].i = 0.f;
00733         }
00734         i__2 = ilast;
00735         i__3 = ilast + ilast * h_dim1;
00736         alpha[i__2].r = h__[i__3].r, alpha[i__2].i = h__[i__3].i;
00737         i__2 = ilast;
00738         i__3 = ilast + ilast * t_dim1;
00739         beta[i__2].r = t[i__3].r, beta[i__2].i = t[i__3].i;
00740 
00741 /*        Go to next block -- exit if finished. */
00742 
00743         --ilast;
00744         if (ilast < *ilo) {
00745             goto L190;
00746         }
00747 
00748 /*        Reset counters */
00749 
00750         iiter = 0;
00751         eshift.r = 0.f, eshift.i = 0.f;
00752         if (! ilschr) {
00753             ilastm = ilast;
00754             if (ifrstm > ilast) {
00755                 ifrstm = *ilo;
00756             }
00757         }
00758         goto L160;
00759 
00760 /*        QZ step */
00761 
00762 /*        This iteration only involves rows/columns IFIRST:ILAST.  We */
00763 /*        assume IFIRST < ILAST, and that the diagonal of B is non-zero. */
00764 
00765 L70:
00766         ++iiter;
00767         if (! ilschr) {
00768             ifrstm = ifirst;
00769         }
00770 
00771 /*        Compute the Shift. */
00772 
00773 /*        At this point, IFIRST < ILAST, and the diagonal elements of */
00774 /*        T(IFIRST:ILAST,IFIRST,ILAST) are larger than BTOL (in */
00775 /*        magnitude) */
00776 
00777         if (iiter / 10 * 10 != iiter) {
00778 
00779 /*           The Wilkinson shift (AEP p.512), i.e., the eigenvalue of */
00780 /*           the bottom-right 2x2 block of A inv(B) which is nearest to */
00781 /*           the bottom-right element. */
00782 
00783 /*           We factor B as U*D, where U has unit diagonals, and */
00784 /*           compute (A*inv(D))*inv(U). */
00785 
00786             i__2 = ilast - 1 + ilast * t_dim1;
00787             q__2.r = bscale * t[i__2].r, q__2.i = bscale * t[i__2].i;
00788             i__3 = ilast + ilast * t_dim1;
00789             q__3.r = bscale * t[i__3].r, q__3.i = bscale * t[i__3].i;
00790             c_div(&q__1, &q__2, &q__3);
00791             u12.r = q__1.r, u12.i = q__1.i;
00792             i__2 = ilast - 1 + (ilast - 1) * h_dim1;
00793             q__2.r = ascale * h__[i__2].r, q__2.i = ascale * h__[i__2].i;
00794             i__3 = ilast - 1 + (ilast - 1) * t_dim1;
00795             q__3.r = bscale * t[i__3].r, q__3.i = bscale * t[i__3].i;
00796             c_div(&q__1, &q__2, &q__3);
00797             ad11.r = q__1.r, ad11.i = q__1.i;
00798             i__2 = ilast + (ilast - 1) * h_dim1;
00799             q__2.r = ascale * h__[i__2].r, q__2.i = ascale * h__[i__2].i;
00800             i__3 = ilast - 1 + (ilast - 1) * t_dim1;
00801             q__3.r = bscale * t[i__3].r, q__3.i = bscale * t[i__3].i;
00802             c_div(&q__1, &q__2, &q__3);
00803             ad21.r = q__1.r, ad21.i = q__1.i;
00804             i__2 = ilast - 1 + ilast * h_dim1;
00805             q__2.r = ascale * h__[i__2].r, q__2.i = ascale * h__[i__2].i;
00806             i__3 = ilast + ilast * t_dim1;
00807             q__3.r = bscale * t[i__3].r, q__3.i = bscale * t[i__3].i;
00808             c_div(&q__1, &q__2, &q__3);
00809             ad12.r = q__1.r, ad12.i = q__1.i;
00810             i__2 = ilast + ilast * h_dim1;
00811             q__2.r = ascale * h__[i__2].r, q__2.i = ascale * h__[i__2].i;
00812             i__3 = ilast + ilast * t_dim1;
00813             q__3.r = bscale * t[i__3].r, q__3.i = bscale * t[i__3].i;
00814             c_div(&q__1, &q__2, &q__3);
00815             ad22.r = q__1.r, ad22.i = q__1.i;
00816             q__2.r = u12.r * ad21.r - u12.i * ad21.i, q__2.i = u12.r * ad21.i 
00817                     + u12.i * ad21.r;
00818             q__1.r = ad22.r - q__2.r, q__1.i = ad22.i - q__2.i;
00819             abi22.r = q__1.r, abi22.i = q__1.i;
00820 
00821             q__2.r = ad11.r + abi22.r, q__2.i = ad11.i + abi22.i;
00822             q__1.r = q__2.r * .5f, q__1.i = q__2.i * .5f;
00823             t1.r = q__1.r, t1.i = q__1.i;
00824             pow_ci(&q__4, &t1, &c__2);
00825             q__5.r = ad12.r * ad21.r - ad12.i * ad21.i, q__5.i = ad12.r * 
00826                     ad21.i + ad12.i * ad21.r;
00827             q__3.r = q__4.r + q__5.r, q__3.i = q__4.i + q__5.i;
00828             q__6.r = ad11.r * ad22.r - ad11.i * ad22.i, q__6.i = ad11.r * 
00829                     ad22.i + ad11.i * ad22.r;
00830             q__2.r = q__3.r - q__6.r, q__2.i = q__3.i - q__6.i;
00831             c_sqrt(&q__1, &q__2);
00832             rtdisc.r = q__1.r, rtdisc.i = q__1.i;
00833             q__1.r = t1.r - abi22.r, q__1.i = t1.i - abi22.i;
00834             q__2.r = t1.r - abi22.r, q__2.i = t1.i - abi22.i;
00835             temp = q__1.r * rtdisc.r + r_imag(&q__2) * r_imag(&rtdisc);
00836             if (temp <= 0.f) {
00837                 q__1.r = t1.r + rtdisc.r, q__1.i = t1.i + rtdisc.i;
00838                 shift.r = q__1.r, shift.i = q__1.i;
00839             } else {
00840                 q__1.r = t1.r - rtdisc.r, q__1.i = t1.i - rtdisc.i;
00841                 shift.r = q__1.r, shift.i = q__1.i;
00842             }
00843         } else {
00844 
00845 /*           Exceptional shift.  Chosen for no particularly good reason. */
00846 
00847             i__2 = ilast - 1 + ilast * h_dim1;
00848             q__4.r = ascale * h__[i__2].r, q__4.i = ascale * h__[i__2].i;
00849             i__3 = ilast - 1 + (ilast - 1) * t_dim1;
00850             q__5.r = bscale * t[i__3].r, q__5.i = bscale * t[i__3].i;
00851             c_div(&q__3, &q__4, &q__5);
00852             r_cnjg(&q__2, &q__3);
00853             q__1.r = eshift.r + q__2.r, q__1.i = eshift.i + q__2.i;
00854             eshift.r = q__1.r, eshift.i = q__1.i;
00855             shift.r = eshift.r, shift.i = eshift.i;
00856         }
00857 
00858 /*        Now check for two consecutive small subdiagonals. */
00859 
00860         i__2 = ifirst + 1;
00861         for (j = ilast - 1; j >= i__2; --j) {
00862             istart = j;
00863             i__3 = j + j * h_dim1;
00864             q__2.r = ascale * h__[i__3].r, q__2.i = ascale * h__[i__3].i;
00865             i__4 = j + j * t_dim1;
00866             q__4.r = bscale * t[i__4].r, q__4.i = bscale * t[i__4].i;
00867             q__3.r = shift.r * q__4.r - shift.i * q__4.i, q__3.i = shift.r * 
00868                     q__4.i + shift.i * q__4.r;
00869             q__1.r = q__2.r - q__3.r, q__1.i = q__2.i - q__3.i;
00870             ctemp.r = q__1.r, ctemp.i = q__1.i;
00871             temp = (r__1 = ctemp.r, dabs(r__1)) + (r__2 = r_imag(&ctemp), 
00872                     dabs(r__2));
00873             i__3 = j + 1 + j * h_dim1;
00874             temp2 = ascale * ((r__1 = h__[i__3].r, dabs(r__1)) + (r__2 = 
00875                     r_imag(&h__[j + 1 + j * h_dim1]), dabs(r__2)));
00876             tempr = dmax(temp,temp2);
00877             if (tempr < 1.f && tempr != 0.f) {
00878                 temp /= tempr;
00879                 temp2 /= tempr;
00880             }
00881             i__3 = j + (j - 1) * h_dim1;
00882             if (((r__1 = h__[i__3].r, dabs(r__1)) + (r__2 = r_imag(&h__[j + (
00883                     j - 1) * h_dim1]), dabs(r__2))) * temp2 <= temp * atol) {
00884                 goto L90;
00885             }
00886 /* L80: */
00887         }
00888 
00889         istart = ifirst;
00890         i__2 = ifirst + ifirst * h_dim1;
00891         q__2.r = ascale * h__[i__2].r, q__2.i = ascale * h__[i__2].i;
00892         i__3 = ifirst + ifirst * t_dim1;
00893         q__4.r = bscale * t[i__3].r, q__4.i = bscale * t[i__3].i;
00894         q__3.r = shift.r * q__4.r - shift.i * q__4.i, q__3.i = shift.r * 
00895                 q__4.i + shift.i * q__4.r;
00896         q__1.r = q__2.r - q__3.r, q__1.i = q__2.i - q__3.i;
00897         ctemp.r = q__1.r, ctemp.i = q__1.i;
00898 L90:
00899 
00900 /*        Do an implicit-shift QZ sweep. */
00901 
00902 /*        Initial Q */
00903 
00904         i__2 = istart + 1 + istart * h_dim1;
00905         q__1.r = ascale * h__[i__2].r, q__1.i = ascale * h__[i__2].i;
00906         ctemp2.r = q__1.r, ctemp2.i = q__1.i;
00907         clartg_(&ctemp, &ctemp2, &c__, &s, &ctemp3);
00908 
00909 /*        Sweep */
00910 
00911         i__2 = ilast - 1;
00912         for (j = istart; j <= i__2; ++j) {
00913             if (j > istart) {
00914                 i__3 = j + (j - 1) * h_dim1;
00915                 ctemp.r = h__[i__3].r, ctemp.i = h__[i__3].i;
00916                 clartg_(&ctemp, &h__[j + 1 + (j - 1) * h_dim1], &c__, &s, &
00917                         h__[j + (j - 1) * h_dim1]);
00918                 i__3 = j + 1 + (j - 1) * h_dim1;
00919                 h__[i__3].r = 0.f, h__[i__3].i = 0.f;
00920             }
00921 
00922             i__3 = ilastm;
00923             for (jc = j; jc <= i__3; ++jc) {
00924                 i__4 = j + jc * h_dim1;
00925                 q__2.r = c__ * h__[i__4].r, q__2.i = c__ * h__[i__4].i;
00926                 i__5 = j + 1 + jc * h_dim1;
00927                 q__3.r = s.r * h__[i__5].r - s.i * h__[i__5].i, q__3.i = s.r *
00928                          h__[i__5].i + s.i * h__[i__5].r;
00929                 q__1.r = q__2.r + q__3.r, q__1.i = q__2.i + q__3.i;
00930                 ctemp.r = q__1.r, ctemp.i = q__1.i;
00931                 i__4 = j + 1 + jc * h_dim1;
00932                 r_cnjg(&q__4, &s);
00933                 q__3.r = -q__4.r, q__3.i = -q__4.i;
00934                 i__5 = j + jc * h_dim1;
00935                 q__2.r = q__3.r * h__[i__5].r - q__3.i * h__[i__5].i, q__2.i =
00936                          q__3.r * h__[i__5].i + q__3.i * h__[i__5].r;
00937                 i__6 = j + 1 + jc * h_dim1;
00938                 q__5.r = c__ * h__[i__6].r, q__5.i = c__ * h__[i__6].i;
00939                 q__1.r = q__2.r + q__5.r, q__1.i = q__2.i + q__5.i;
00940                 h__[i__4].r = q__1.r, h__[i__4].i = q__1.i;
00941                 i__4 = j + jc * h_dim1;
00942                 h__[i__4].r = ctemp.r, h__[i__4].i = ctemp.i;
00943                 i__4 = j + jc * t_dim1;
00944                 q__2.r = c__ * t[i__4].r, q__2.i = c__ * t[i__4].i;
00945                 i__5 = j + 1 + jc * t_dim1;
00946                 q__3.r = s.r * t[i__5].r - s.i * t[i__5].i, q__3.i = s.r * t[
00947                         i__5].i + s.i * t[i__5].r;
00948                 q__1.r = q__2.r + q__3.r, q__1.i = q__2.i + q__3.i;
00949                 ctemp2.r = q__1.r, ctemp2.i = q__1.i;
00950                 i__4 = j + 1 + jc * t_dim1;
00951                 r_cnjg(&q__4, &s);
00952                 q__3.r = -q__4.r, q__3.i = -q__4.i;
00953                 i__5 = j + jc * t_dim1;
00954                 q__2.r = q__3.r * t[i__5].r - q__3.i * t[i__5].i, q__2.i = 
00955                         q__3.r * t[i__5].i + q__3.i * t[i__5].r;
00956                 i__6 = j + 1 + jc * t_dim1;
00957                 q__5.r = c__ * t[i__6].r, q__5.i = c__ * t[i__6].i;
00958                 q__1.r = q__2.r + q__5.r, q__1.i = q__2.i + q__5.i;
00959                 t[i__4].r = q__1.r, t[i__4].i = q__1.i;
00960                 i__4 = j + jc * t_dim1;
00961                 t[i__4].r = ctemp2.r, t[i__4].i = ctemp2.i;
00962 /* L100: */
00963             }
00964             if (ilq) {
00965                 i__3 = *n;
00966                 for (jr = 1; jr <= i__3; ++jr) {
00967                     i__4 = jr + j * q_dim1;
00968                     q__2.r = c__ * q[i__4].r, q__2.i = c__ * q[i__4].i;
00969                     r_cnjg(&q__4, &s);
00970                     i__5 = jr + (j + 1) * q_dim1;
00971                     q__3.r = q__4.r * q[i__5].r - q__4.i * q[i__5].i, q__3.i =
00972                              q__4.r * q[i__5].i + q__4.i * q[i__5].r;
00973                     q__1.r = q__2.r + q__3.r, q__1.i = q__2.i + q__3.i;
00974                     ctemp.r = q__1.r, ctemp.i = q__1.i;
00975                     i__4 = jr + (j + 1) * q_dim1;
00976                     q__3.r = -s.r, q__3.i = -s.i;
00977                     i__5 = jr + j * q_dim1;
00978                     q__2.r = q__3.r * q[i__5].r - q__3.i * q[i__5].i, q__2.i =
00979                              q__3.r * q[i__5].i + q__3.i * q[i__5].r;
00980                     i__6 = jr + (j + 1) * q_dim1;
00981                     q__4.r = c__ * q[i__6].r, q__4.i = c__ * q[i__6].i;
00982                     q__1.r = q__2.r + q__4.r, q__1.i = q__2.i + q__4.i;
00983                     q[i__4].r = q__1.r, q[i__4].i = q__1.i;
00984                     i__4 = jr + j * q_dim1;
00985                     q[i__4].r = ctemp.r, q[i__4].i = ctemp.i;
00986 /* L110: */
00987                 }
00988             }
00989 
00990             i__3 = j + 1 + (j + 1) * t_dim1;
00991             ctemp.r = t[i__3].r, ctemp.i = t[i__3].i;
00992             clartg_(&ctemp, &t[j + 1 + j * t_dim1], &c__, &s, &t[j + 1 + (j + 
00993                     1) * t_dim1]);
00994             i__3 = j + 1 + j * t_dim1;
00995             t[i__3].r = 0.f, t[i__3].i = 0.f;
00996 
00997 /* Computing MIN */
00998             i__4 = j + 2;
00999             i__3 = min(i__4,ilast);
01000             for (jr = ifrstm; jr <= i__3; ++jr) {
01001                 i__4 = jr + (j + 1) * h_dim1;
01002                 q__2.r = c__ * h__[i__4].r, q__2.i = c__ * h__[i__4].i;
01003                 i__5 = jr + j * h_dim1;
01004                 q__3.r = s.r * h__[i__5].r - s.i * h__[i__5].i, q__3.i = s.r *
01005                          h__[i__5].i + s.i * h__[i__5].r;
01006                 q__1.r = q__2.r + q__3.r, q__1.i = q__2.i + q__3.i;
01007                 ctemp.r = q__1.r, ctemp.i = q__1.i;
01008                 i__4 = jr + j * h_dim1;
01009                 r_cnjg(&q__4, &s);
01010                 q__3.r = -q__4.r, q__3.i = -q__4.i;
01011                 i__5 = jr + (j + 1) * h_dim1;
01012                 q__2.r = q__3.r * h__[i__5].r - q__3.i * h__[i__5].i, q__2.i =
01013                          q__3.r * h__[i__5].i + q__3.i * h__[i__5].r;
01014                 i__6 = jr + j * h_dim1;
01015                 q__5.r = c__ * h__[i__6].r, q__5.i = c__ * h__[i__6].i;
01016                 q__1.r = q__2.r + q__5.r, q__1.i = q__2.i + q__5.i;
01017                 h__[i__4].r = q__1.r, h__[i__4].i = q__1.i;
01018                 i__4 = jr + (j + 1) * h_dim1;
01019                 h__[i__4].r = ctemp.r, h__[i__4].i = ctemp.i;
01020 /* L120: */
01021             }
01022             i__3 = j;
01023             for (jr = ifrstm; jr <= i__3; ++jr) {
01024                 i__4 = jr + (j + 1) * t_dim1;
01025                 q__2.r = c__ * t[i__4].r, q__2.i = c__ * t[i__4].i;
01026                 i__5 = jr + j * t_dim1;
01027                 q__3.r = s.r * t[i__5].r - s.i * t[i__5].i, q__3.i = s.r * t[
01028                         i__5].i + s.i * t[i__5].r;
01029                 q__1.r = q__2.r + q__3.r, q__1.i = q__2.i + q__3.i;
01030                 ctemp.r = q__1.r, ctemp.i = q__1.i;
01031                 i__4 = jr + j * t_dim1;
01032                 r_cnjg(&q__4, &s);
01033                 q__3.r = -q__4.r, q__3.i = -q__4.i;
01034                 i__5 = jr + (j + 1) * t_dim1;
01035                 q__2.r = q__3.r * t[i__5].r - q__3.i * t[i__5].i, q__2.i = 
01036                         q__3.r * t[i__5].i + q__3.i * t[i__5].r;
01037                 i__6 = jr + j * t_dim1;
01038                 q__5.r = c__ * t[i__6].r, q__5.i = c__ * t[i__6].i;
01039                 q__1.r = q__2.r + q__5.r, q__1.i = q__2.i + q__5.i;
01040                 t[i__4].r = q__1.r, t[i__4].i = q__1.i;
01041                 i__4 = jr + (j + 1) * t_dim1;
01042                 t[i__4].r = ctemp.r, t[i__4].i = ctemp.i;
01043 /* L130: */
01044             }
01045             if (ilz) {
01046                 i__3 = *n;
01047                 for (jr = 1; jr <= i__3; ++jr) {
01048                     i__4 = jr + (j + 1) * z_dim1;
01049                     q__2.r = c__ * z__[i__4].r, q__2.i = c__ * z__[i__4].i;
01050                     i__5 = jr + j * z_dim1;
01051                     q__3.r = s.r * z__[i__5].r - s.i * z__[i__5].i, q__3.i = 
01052                             s.r * z__[i__5].i + s.i * z__[i__5].r;
01053                     q__1.r = q__2.r + q__3.r, q__1.i = q__2.i + q__3.i;
01054                     ctemp.r = q__1.r, ctemp.i = q__1.i;
01055                     i__4 = jr + j * z_dim1;
01056                     r_cnjg(&q__4, &s);
01057                     q__3.r = -q__4.r, q__3.i = -q__4.i;
01058                     i__5 = jr + (j + 1) * z_dim1;
01059                     q__2.r = q__3.r * z__[i__5].r - q__3.i * z__[i__5].i, 
01060                             q__2.i = q__3.r * z__[i__5].i + q__3.i * z__[i__5]
01061                             .r;
01062                     i__6 = jr + j * z_dim1;
01063                     q__5.r = c__ * z__[i__6].r, q__5.i = c__ * z__[i__6].i;
01064                     q__1.r = q__2.r + q__5.r, q__1.i = q__2.i + q__5.i;
01065                     z__[i__4].r = q__1.r, z__[i__4].i = q__1.i;
01066                     i__4 = jr + (j + 1) * z_dim1;
01067                     z__[i__4].r = ctemp.r, z__[i__4].i = ctemp.i;
01068 /* L140: */
01069                 }
01070             }
01071 /* L150: */
01072         }
01073 
01074 L160:
01075 
01076 /* L170: */
01077         ;
01078     }
01079 
01080 /*     Drop-through = non-convergence */
01081 
01082 L180:
01083     *info = ilast;
01084     goto L210;
01085 
01086 /*     Successful completion of all QZ steps */
01087 
01088 L190:
01089 
01090 /*     Set Eigenvalues 1:ILO-1 */
01091 
01092     i__1 = *ilo - 1;
01093     for (j = 1; j <= i__1; ++j) {
01094         absb = c_abs(&t[j + j * t_dim1]);
01095         if (absb > safmin) {
01096             i__2 = j + j * t_dim1;
01097             q__2.r = t[i__2].r / absb, q__2.i = t[i__2].i / absb;
01098             r_cnjg(&q__1, &q__2);
01099             signbc.r = q__1.r, signbc.i = q__1.i;
01100             i__2 = j + j * t_dim1;
01101             t[i__2].r = absb, t[i__2].i = 0.f;
01102             if (ilschr) {
01103                 i__2 = j - 1;
01104                 cscal_(&i__2, &signbc, &t[j * t_dim1 + 1], &c__1);
01105                 cscal_(&j, &signbc, &h__[j * h_dim1 + 1], &c__1);
01106             } else {
01107                 i__2 = j + j * h_dim1;
01108                 i__3 = j + j * h_dim1;
01109                 q__1.r = h__[i__3].r * signbc.r - h__[i__3].i * signbc.i, 
01110                         q__1.i = h__[i__3].r * signbc.i + h__[i__3].i * 
01111                         signbc.r;
01112                 h__[i__2].r = q__1.r, h__[i__2].i = q__1.i;
01113             }
01114             if (ilz) {
01115                 cscal_(n, &signbc, &z__[j * z_dim1 + 1], &c__1);
01116             }
01117         } else {
01118             i__2 = j + j * t_dim1;
01119             t[i__2].r = 0.f, t[i__2].i = 0.f;
01120         }
01121         i__2 = j;
01122         i__3 = j + j * h_dim1;
01123         alpha[i__2].r = h__[i__3].r, alpha[i__2].i = h__[i__3].i;
01124         i__2 = j;
01125         i__3 = j + j * t_dim1;
01126         beta[i__2].r = t[i__3].r, beta[i__2].i = t[i__3].i;
01127 /* L200: */
01128     }
01129 
01130 /*     Normal Termination */
01131 
01132     *info = 0;
01133 
01134 /*     Exit (other than argument error) -- return optimal workspace size */
01135 
01136 L210:
01137     q__1.r = (real) (*n), q__1.i = 0.f;
01138     work[1].r = q__1.r, work[1].i = q__1.i;
01139     return 0;
01140 
01141 /*     End of CHGEQZ */
01142 
01143 } /* chgeqz_ */


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