/* Subroutine */ int ztrevc_(char *side, char *howmny, logical *select, integer *n, doublecomplex *t, integer *ldt, doublecomplex *vl, integer *ldvl, doublecomplex *vr, integer *ldvr, integer *mm, integer *m, doublecomplex *work, doublereal *rwork, integer *info) { /* -- LAPACK routine (version 3.0) -- Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., Courant Institute, Argonne National Lab, and Rice University June 30, 1999 Purpose ======= ZTREVC computes some or all of the right and/or left eigenvectors of a complex upper triangular matrix T. The right eigenvector x and the left eigenvector y of T corresponding to an eigenvalue w are defined by: T*x = w*x, y'*T = w*y' where y' denotes the conjugate transpose of the vector y. If all eigenvectors are requested, the routine may either return the matrices X and/or Y of right or left eigenvectors of T, or the products Q*X and/or Q*Y, where Q is an input unitary matrix. If T was obtained from the Schur factorization of an original matrix A = Q*T*Q', then Q*X and Q*Y are the matrices of right or left eigenvectors of A. Arguments ========= SIDE (input) CHARACTER*1 = 'R': compute right eigenvectors only; = 'L': compute left eigenvectors only; = 'B': compute both right and left eigenvectors. HOWMNY (input) CHARACTER*1 = 'A': compute all right and/or left eigenvectors; = 'B': compute all right and/or left eigenvectors, and backtransform them using the input matrices supplied in VR and/or VL; = 'S': compute selected right and/or left eigenvectors, specified by the logical array SELECT. SELECT (input) LOGICAL array, dimension (N) If HOWMNY = 'S', SELECT specifies the eigenvectors to be computed. If HOWMNY = 'A' or 'B', SELECT is not referenced. To select the eigenvector corresponding to the j-th eigenvalue, SELECT(j) must be set to .TRUE.. N (input) INTEGER The order of the matrix T. N >= 0. T (input/output) COMPLEX*16 array, dimension (LDT,N) The upper triangular matrix T. T is modified, but restored on exit. LDT (input) INTEGER The leading dimension of the array T. LDT >= max(1,N). VL (input/output) COMPLEX*16 array, dimension (LDVL,MM) On entry, if SIDE = 'L' or 'B' and HOWMNY = 'B', VL must contain an N-by-N matrix Q (usually the unitary matrix Q of Schur vectors returned by ZHSEQR). On exit, if SIDE = 'L' or 'B', VL contains: if HOWMNY = 'A', the matrix Y of left eigenvectors of T; VL is lower triangular. The i-th column VL(i) of VL is the eigenvector corresponding to T(i,i). if HOWMNY = 'B', the matrix Q*Y; if HOWMNY = 'S', the left eigenvectors of T specified by SELECT, stored consecutively in the columns of VL, in the same order as their eigenvalues. If SIDE = 'R', VL is not referenced. LDVL (input) INTEGER The leading dimension of the array VL. LDVL >= max(1,N) if SIDE = 'L' or 'B'; LDVL >= 1 otherwise. VR (input/output) COMPLEX*16 array, dimension (LDVR,MM) On entry, if SIDE = 'R' or 'B' and HOWMNY = 'B', VR must contain an N-by-N matrix Q (usually the unitary matrix Q of Schur vectors returned by ZHSEQR). On exit, if SIDE = 'R' or 'B', VR contains: if HOWMNY = 'A', the matrix X of right eigenvectors of T; VR is upper triangular. The i-th column VR(i) of VR is the eigenvector corresponding to T(i,i). if HOWMNY = 'B', the matrix Q*X; if HOWMNY = 'S', the right eigenvectors of T specified by SELECT, stored consecutively in the columns of VR, in the same order as their eigenvalues. If SIDE = 'L', VR is not referenced. LDVR (input) INTEGER The leading dimension of the array VR. LDVR >= max(1,N) if SIDE = 'R' or 'B'; LDVR >= 1 otherwise. MM (input) INTEGER The number of columns in the arrays VL and/or VR. MM >= M. M (output) INTEGER The number of columns in the arrays VL and/or VR actually used to store the eigenvectors. If HOWMNY = 'A' or 'B', M is set to N. Each selected eigenvector occupies one column. WORK (workspace) COMPLEX*16 array, dimension (2*N) RWORK (workspace) DOUBLE PRECISION array, dimension (N) INFO (output) INTEGER = 0: successful exit < 0: if INFO = -i, the i-th argument had an illegal value Further Details =============== The algorithm used in this program is basically backward (forward) substitution, with scaling to make the the code robust against possible overflow. Each eigenvector is normalized so that the element of largest magnitude has magnitude 1; here the magnitude of a complex number (x,y) is taken to be |x| + |y|. ===================================================================== Decode and test the input parameters Parameter adjustments */ /* Table of constant values */ static doublecomplex c_b2 = {1.,0.}; static integer c__1 = 1; /* System generated locals */ integer t_dim1, t_offset, vl_dim1, vl_offset, vr_dim1, vr_offset, i__1, i__2, i__3, i__4, i__5; doublereal d__1, d__2, d__3; doublecomplex z__1, z__2; /* Builtin functions */ double d_imag(doublecomplex *); void d_cnjg(doublecomplex *, doublecomplex *); /* Local variables */ static logical allv; static doublereal unfl, ovfl, smin; static logical over; static integer i__, j, k; static doublereal scale; extern logical lsame_(char *, char *); static doublereal remax; static logical leftv, bothv; extern /* Subroutine */ int zgemv_(char *, integer *, integer *, doublecomplex *, doublecomplex *, integer *, doublecomplex *, integer *, doublecomplex *, doublecomplex *, integer *); static logical somev; extern /* Subroutine */ int zcopy_(integer *, doublecomplex *, integer *, doublecomplex *, integer *), dlabad_(doublereal *, doublereal *); static integer ii, ki; extern doublereal dlamch_(char *); static integer is; extern /* Subroutine */ int xerbla_(char *, integer *), zdscal_( integer *, doublereal *, doublecomplex *, integer *); extern integer izamax_(integer *, doublecomplex *, integer *); static logical rightv; extern doublereal dzasum_(integer *, doublecomplex *, integer *); static doublereal smlnum; extern /* Subroutine */ int zlatrs_(char *, char *, char *, char *, integer *, doublecomplex *, integer *, doublecomplex *, doublereal *, doublereal *, integer *); static doublereal ulp; #define t_subscr(a_1,a_2) (a_2)*t_dim1 + a_1 #define t_ref(a_1,a_2) t[t_subscr(a_1,a_2)] #define vl_subscr(a_1,a_2) (a_2)*vl_dim1 + a_1 #define vl_ref(a_1,a_2) vl[vl_subscr(a_1,a_2)] #define vr_subscr(a_1,a_2) (a_2)*vr_dim1 + a_1 #define vr_ref(a_1,a_2) vr[vr_subscr(a_1,a_2)] --select; t_dim1 = *ldt; t_offset = 1 + t_dim1 * 1; t -= t_offset; vl_dim1 = *ldvl; vl_offset = 1 + vl_dim1 * 1; vl -= vl_offset; vr_dim1 = *ldvr; vr_offset = 1 + vr_dim1 * 1; vr -= vr_offset; --work; --rwork; /* Function Body */ bothv = lsame_(side, "B"); rightv = lsame_(side, "R") || bothv; leftv = lsame_(side, "L") || bothv; allv = lsame_(howmny, "A"); over = lsame_(howmny, "B"); somev = lsame_(howmny, "S"); /* Set M to the number of columns required to store the selected eigenvectors. */ if (somev) { *m = 0; i__1 = *n; for (j = 1; j <= i__1; ++j) { if (select[j]) { ++(*m); } /* L10: */ } } else { *m = *n; } *info = 0; if (! rightv && ! leftv) { *info = -1; } else if (! allv && ! over && ! somev) { *info = -2; } else if (*n < 0) { *info = -4; } else if (*ldt < max(1,*n)) { *info = -6; } else if (*ldvl < 1 || leftv && *ldvl < *n) { *info = -8; } else if (*ldvr < 1 || rightv && *ldvr < *n) { *info = -10; } else if (*mm < *m) { *info = -11; } if (*info != 0) { i__1 = -(*info); xerbla_("ZTREVC", &i__1); return 0; } /* Quick return if possible. */ if (*n == 0) { return 0; } /* Set the constants to control overflow. */ unfl = dlamch_("Safe minimum"); ovfl = 1. / unfl; dlabad_(&unfl, &ovfl); ulp = dlamch_("Precision"); smlnum = unfl * (*n / ulp); /* Store the diagonal elements of T in working array WORK. */ i__1 = *n; for (i__ = 1; i__ <= i__1; ++i__) { i__2 = i__ + *n; i__3 = t_subscr(i__, i__); work[i__2].r = t[i__3].r, work[i__2].i = t[i__3].i; /* L20: */ } /* Compute 1-norm of each column of strictly upper triangular part of T to control overflow in triangular solver. */ rwork[1] = 0.; i__1 = *n; for (j = 2; j <= i__1; ++j) { i__2 = j - 1; rwork[j] = dzasum_(&i__2, &t_ref(1, j), &c__1); /* L30: */ } if (rightv) { /* Compute right eigenvectors. */ is = *m; for (ki = *n; ki >= 1; --ki) { if (somev) { if (! select[ki]) { goto L80; } } /* Computing MAX */ i__1 = t_subscr(ki, ki); d__3 = ulp * ((d__1 = t[i__1].r, abs(d__1)) + (d__2 = d_imag(& t_ref(ki, ki)), abs(d__2))); smin = max(d__3,smlnum); work[1].r = 1., work[1].i = 0.; /* Form right-hand side. */ i__1 = ki - 1; for (k = 1; k <= i__1; ++k) { i__2 = k; i__3 = t_subscr(k, ki); z__1.r = -t[i__3].r, z__1.i = -t[i__3].i; work[i__2].r = z__1.r, work[i__2].i = z__1.i; /* L40: */ } /* Solve the triangular system: (T(1:KI-1,1:KI-1) - T(KI,KI))*X = SCALE*WORK. */ i__1 = ki - 1; for (k = 1; k <= i__1; ++k) { i__2 = t_subscr(k, k); i__3 = t_subscr(k, k); i__4 = t_subscr(ki, ki); z__1.r = t[i__3].r - t[i__4].r, z__1.i = t[i__3].i - t[i__4] .i; t[i__2].r = z__1.r, t[i__2].i = z__1.i; i__2 = t_subscr(k, k); if ((d__1 = t[i__2].r, abs(d__1)) + (d__2 = d_imag(&t_ref(k, k)), abs(d__2)) < smin) { i__3 = t_subscr(k, k); t[i__3].r = smin, t[i__3].i = 0.; } /* L50: */ } if (ki > 1) { i__1 = ki - 1; zlatrs_("Upper", "No transpose", "Non-unit", "Y", &i__1, &t[ t_offset], ldt, &work[1], &scale, &rwork[1], info); i__1 = ki; work[i__1].r = scale, work[i__1].i = 0.; } /* Copy the vector x or Q*x to VR and normalize. */ if (! over) { zcopy_(&ki, &work[1], &c__1, &vr_ref(1, is), &c__1); ii = izamax_(&ki, &vr_ref(1, is), &c__1); i__1 = vr_subscr(ii, is); remax = 1. / ((d__1 = vr[i__1].r, abs(d__1)) + (d__2 = d_imag( &vr_ref(ii, is)), abs(d__2))); zdscal_(&ki, &remax, &vr_ref(1, is), &c__1); i__1 = *n; for (k = ki + 1; k <= i__1; ++k) { i__2 = vr_subscr(k, is); vr[i__2].r = 0., vr[i__2].i = 0.; /* L60: */ } } else { if (ki > 1) { i__1 = ki - 1; z__1.r = scale, z__1.i = 0.; zgemv_("N", n, &i__1, &c_b2, &vr[vr_offset], ldvr, &work[ 1], &c__1, &z__1, &vr_ref(1, ki), &c__1); } ii = izamax_(n, &vr_ref(1, ki), &c__1); i__1 = vr_subscr(ii, ki); remax = 1. / ((d__1 = vr[i__1].r, abs(d__1)) + (d__2 = d_imag( &vr_ref(ii, ki)), abs(d__2))); zdscal_(n, &remax, &vr_ref(1, ki), &c__1); } /* Set back the original diagonal elements of T. */ i__1 = ki - 1; for (k = 1; k <= i__1; ++k) { i__2 = t_subscr(k, k); i__3 = k + *n; t[i__2].r = work[i__3].r, t[i__2].i = work[i__3].i; /* L70: */ } --is; L80: ; } } if (leftv) { /* Compute left eigenvectors. */ is = 1; i__1 = *n; for (ki = 1; ki <= i__1; ++ki) { if (somev) { if (! select[ki]) { goto L130; } } /* Computing MAX */ i__2 = t_subscr(ki, ki); d__3 = ulp * ((d__1 = t[i__2].r, abs(d__1)) + (d__2 = d_imag(& t_ref(ki, ki)), abs(d__2))); smin = max(d__3,smlnum); i__2 = *n; work[i__2].r = 1., work[i__2].i = 0.; /* Form right-hand side. */ i__2 = *n; for (k = ki + 1; k <= i__2; ++k) { i__3 = k; d_cnjg(&z__2, &t_ref(ki, k)); z__1.r = -z__2.r, z__1.i = -z__2.i; work[i__3].r = z__1.r, work[i__3].i = z__1.i; /* L90: */ } /* Solve the triangular system: (T(KI+1:N,KI+1:N) - T(KI,KI))'*X = SCALE*WORK. */ i__2 = *n; for (k = ki + 1; k <= i__2; ++k) { i__3 = t_subscr(k, k); i__4 = t_subscr(k, k); i__5 = t_subscr(ki, ki); z__1.r = t[i__4].r - t[i__5].r, z__1.i = t[i__4].i - t[i__5] .i; t[i__3].r = z__1.r, t[i__3].i = z__1.i; i__3 = t_subscr(k, k); if ((d__1 = t[i__3].r, abs(d__1)) + (d__2 = d_imag(&t_ref(k, k)), abs(d__2)) < smin) { i__4 = t_subscr(k, k); t[i__4].r = smin, t[i__4].i = 0.; } /* L100: */ } if (ki < *n) { i__2 = *n - ki; zlatrs_("Upper", "Conjugate transpose", "Non-unit", "Y", & i__2, &t_ref(ki + 1, ki + 1), ldt, &work[ki + 1], & scale, &rwork[1], info); i__2 = ki; work[i__2].r = scale, work[i__2].i = 0.; } /* Copy the vector x or Q*x to VL and normalize. */ if (! over) { i__2 = *n - ki + 1; zcopy_(&i__2, &work[ki], &c__1, &vl_ref(ki, is), &c__1); i__2 = *n - ki + 1; ii = izamax_(&i__2, &vl_ref(ki, is), &c__1) + ki - 1; i__2 = vl_subscr(ii, is); remax = 1. / ((d__1 = vl[i__2].r, abs(d__1)) + (d__2 = d_imag( &vl_ref(ii, is)), abs(d__2))); i__2 = *n - ki + 1; zdscal_(&i__2, &remax, &vl_ref(ki, is), &c__1); i__2 = ki - 1; for (k = 1; k <= i__2; ++k) { i__3 = vl_subscr(k, is); vl[i__3].r = 0., vl[i__3].i = 0.; /* L110: */ } } else { if (ki < *n) { i__2 = *n - ki; z__1.r = scale, z__1.i = 0.; zgemv_("N", n, &i__2, &c_b2, &vl_ref(1, ki + 1), ldvl, & work[ki + 1], &c__1, &z__1, &vl_ref(1, ki), &c__1); } ii = izamax_(n, &vl_ref(1, ki), &c__1); i__2 = vl_subscr(ii, ki); remax = 1. / ((d__1 = vl[i__2].r, abs(d__1)) + (d__2 = d_imag( &vl_ref(ii, ki)), abs(d__2))); zdscal_(n, &remax, &vl_ref(1, ki), &c__1); } /* Set back the original diagonal elements of T. */ i__2 = *n; for (k = ki + 1; k <= i__2; ++k) { i__3 = t_subscr(k, k); i__4 = k + *n; t[i__3].r = work[i__4].r, t[i__3].i = work[i__4].i; /* L120: */ } ++is; L130: ; } } return 0; /* End of ZTREVC */ } /* ztrevc_ */
/* Subroutine */ int cgegv_(char *jobvl, char *jobvr, integer *n, complex *a, integer *lda, complex *b, integer *ldb, complex *alpha, complex *beta, complex *vl, integer *ldvl, complex *vr, integer *ldvr, complex * work, integer *lwork, real *rwork, integer *info) { /* -- LAPACK driver routine (version 3.0) -- Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., Courant Institute, Argonne National Lab, and Rice University June 30, 1999 Purpose ======= This routine is deprecated and has been replaced by routine CGGEV. CGEGV computes for a pair of N-by-N complex nonsymmetric matrices A and B, the generalized eigenvalues (alpha, beta), and optionally, the left and/or right generalized eigenvectors (VL and VR). A generalized eigenvalue for a pair of matrices (A,B) is, roughly speaking, a scalar w or a ratio alpha/beta = w, such that A - w*B is singular. It is usually represented as the pair (alpha,beta), as there is a reasonable interpretation for beta=0, and even for both being zero. A good beginning reference is the book, "Matrix Computations", by G. Golub & C. van Loan (Johns Hopkins U. Press) A right generalized eigenvector corresponding to a generalized eigenvalue w for a pair of matrices (A,B) is a vector r such that (A - w B) r = 0 . A left generalized eigenvector is a vector l such that l**H * (A - w B) = 0, where l**H is the conjugate-transpose of l. Note: this routine performs "full balancing" on A and B -- see "Further Details", below. Arguments ========= JOBVL (input) CHARACTER*1 = 'N': do not compute the left generalized eigenvectors; = 'V': compute the left generalized eigenvectors. JOBVR (input) CHARACTER*1 = 'N': do not compute the right generalized eigenvectors; = 'V': compute the right generalized eigenvectors. N (input) INTEGER The order of the matrices A, B, VL, and VR. N >= 0. A (input/output) COMPLEX array, dimension (LDA, N) On entry, the first of the pair of matrices whose generalized eigenvalues and (optionally) generalized eigenvectors are to be computed. On exit, the contents will have been destroyed. (For a description of the contents of A on exit, see "Further Details", below.) LDA (input) INTEGER The leading dimension of A. LDA >= max(1,N). B (input/output) COMPLEX array, dimension (LDB, N) On entry, the second of the pair of matrices whose generalized eigenvalues and (optionally) generalized eigenvectors are to be computed. On exit, the contents will have been destroyed. (For a description of the contents of B on exit, see "Further Details", below.) LDB (input) INTEGER The leading dimension of B. LDB >= max(1,N). ALPHA (output) COMPLEX array, dimension (N) BETA (output) COMPLEX array, dimension (N) On exit, ALPHA(j)/BETA(j), j=1,...,N, will be the generalized eigenvalues. Note: the quotients ALPHA(j)/BETA(j) may easily over- or underflow, and BETA(j) may even be zero. Thus, the user should avoid naively computing the ratio alpha/beta. However, ALPHA will be always less than and usually comparable with norm(A) in magnitude, and BETA always less than and usually comparable with norm(B). VL (output) COMPLEX array, dimension (LDVL,N) If JOBVL = 'V', the left generalized eigenvectors. (See "Purpose", above.) Each eigenvector will be scaled so the largest component will have abs(real part) + abs(imag. part) = 1, *except* that for eigenvalues with alpha=beta=0, a zero vector will be returned as the corresponding eigenvector. Not referenced if JOBVL = 'N'. LDVL (input) INTEGER The leading dimension of the matrix VL. LDVL >= 1, and if JOBVL = 'V', LDVL >= N. VR (output) COMPLEX array, dimension (LDVR,N) If JOBVR = 'V', the right generalized eigenvectors. (See "Purpose", above.) Each eigenvector will be scaled so the largest component will have abs(real part) + abs(imag. part) = 1, *except* that for eigenvalues with alpha=beta=0, a zero vector will be returned as the corresponding eigenvector. Not referenced if JOBVR = 'N'. LDVR (input) INTEGER The leading dimension of the matrix VR. LDVR >= 1, and if JOBVR = 'V', LDVR >= N. WORK (workspace/output) COMPLEX array, dimension (LWORK) On exit, if INFO = 0, WORK(1) returns the optimal LWORK. LWORK (input) INTEGER The dimension of the array WORK. LWORK >= max(1,2*N). For good performance, LWORK must generally be larger. To compute the optimal value of LWORK, call ILAENV to get blocksizes (for CGEQRF, CUNMQR, and CUNGQR.) Then compute: NB -- MAX of the blocksizes for CGEQRF, CUNMQR, and CUNGQR; The optimal LWORK is MAX( 2*N, N*(NB+1) ). If LWORK = -1, then a workspace query is assumed; the routine only calculates the optimal size of the WORK array, returns this value as the first entry of the WORK array, and no error message related to LWORK is issued by XERBLA. RWORK (workspace/output) REAL array, dimension (8*N) INFO (output) INTEGER = 0: successful exit < 0: if INFO = -i, the i-th argument had an illegal value. =1,...,N: The QZ iteration failed. No eigenvectors have been calculated, but ALPHA(j) and BETA(j) should be correct for j=INFO+1,...,N. > N: errors that usually indicate LAPACK problems: =N+1: error return from CGGBAL =N+2: error return from CGEQRF =N+3: error return from CUNMQR =N+4: error return from CUNGQR =N+5: error return from CGGHRD =N+6: error return from CHGEQZ (other than failed iteration) =N+7: error return from CTGEVC =N+8: error return from CGGBAK (computing VL) =N+9: error return from CGGBAK (computing VR) =N+10: error return from CLASCL (various calls) Further Details =============== Balancing --------- This driver calls CGGBAL to both permute and scale rows and columns of A and B. The permutations PL and PR are chosen so that PL*A*PR and PL*B*R will be upper triangular except for the diagonal blocks A(i:j,i:j) and B(i:j,i:j), with i and j as close together as possible. The diagonal scaling matrices DL and DR are chosen so that the pair DL*PL*A*PR*DR, DL*PL*B*PR*DR have elements close to one (except for the elements that start out zero.) After the eigenvalues and eigenvectors of the balanced matrices have been computed, CGGBAK transforms the eigenvectors back to what they would have been (in perfect arithmetic) if they had not been balanced. Contents of A and B on Exit -------- -- - --- - -- ---- If any eigenvectors are computed (either JOBVL='V' or JOBVR='V' or both), then on exit the arrays A and B will contain the complex Schur form[*] of the "balanced" versions of A and B. If no eigenvectors are computed, then only the diagonal blocks will be correct. [*] In other words, upper triangular form. ===================================================================== Decode the input arguments Parameter adjustments */ /* Table of constant values */ static complex c_b1 = {0.f,0.f}; static complex c_b2 = {1.f,0.f}; static integer c__1 = 1; static integer c_n1 = -1; static real c_b29 = 1.f; /* System generated locals */ integer a_dim1, a_offset, b_dim1, b_offset, vl_dim1, vl_offset, vr_dim1, vr_offset, i__1, i__2, i__3, i__4; real r__1, r__2, r__3, r__4; complex q__1, q__2; /* Builtin functions */ double r_imag(complex *); /* Local variables */ static real absb, anrm, bnrm; static integer itau; static real temp; static logical ilvl, ilvr; static integer lopt; static real anrm1, anrm2, bnrm1, bnrm2, absai, scale, absar, sbeta; extern logical lsame_(char *, char *); static integer ileft, iinfo, icols, iwork, irows, jc; extern /* Subroutine */ int cggbak_(char *, char *, integer *, integer *, integer *, real *, real *, integer *, complex *, integer *, integer *), cggbal_(char *, integer *, complex *, integer *, complex *, integer *, integer *, integer *, real *, real *, real *, integer *); static integer nb, in; extern doublereal clange_(char *, integer *, integer *, complex *, integer *, real *); static integer jr; extern /* Subroutine */ int cgghrd_(char *, char *, integer *, integer *, integer *, complex *, integer *, complex *, integer *, complex *, integer *, complex *, integer *, integer *); static real salfai; extern /* Subroutine */ int clascl_(char *, integer *, integer *, real *, real *, integer *, integer *, complex *, integer *, integer *), cgeqrf_(integer *, integer *, complex *, integer *, complex *, complex *, integer *, integer *); static real salfar; extern doublereal slamch_(char *); extern /* Subroutine */ int clacpy_(char *, integer *, integer *, complex *, integer *, complex *, integer *), claset_(char *, integer *, integer *, complex *, complex *, complex *, integer *); static real safmin; extern /* Subroutine */ int ctgevc_(char *, char *, logical *, integer *, complex *, integer *, complex *, integer *, complex *, integer *, complex *, integer *, integer *, integer *, complex *, real *, integer *); static real safmax; static char chtemp[1]; static logical ldumma[1]; extern /* Subroutine */ int chgeqz_(char *, char *, char *, integer *, integer *, integer *, complex *, integer *, complex *, integer *, complex *, complex *, complex *, integer *, complex *, integer *, complex *, integer *, real *, integer *), xerbla_(char *, integer *); extern integer ilaenv_(integer *, char *, char *, integer *, integer *, integer *, integer *, ftnlen, ftnlen); static integer ijobvl, iright; static logical ilimit; static integer ijobvr; extern /* Subroutine */ int cungqr_(integer *, integer *, integer *, complex *, integer *, complex *, complex *, integer *, integer *); static integer lwkmin, nb1, nb2, nb3; extern /* Subroutine */ int cunmqr_(char *, char *, integer *, integer *, integer *, complex *, integer *, complex *, complex *, integer *, complex *, integer *, integer *); static integer irwork, lwkopt; static logical lquery; static integer ihi, ilo; static real eps; static logical ilv; #define a_subscr(a_1,a_2) (a_2)*a_dim1 + a_1 #define a_ref(a_1,a_2) a[a_subscr(a_1,a_2)] #define b_subscr(a_1,a_2) (a_2)*b_dim1 + a_1 #define b_ref(a_1,a_2) b[b_subscr(a_1,a_2)] #define vl_subscr(a_1,a_2) (a_2)*vl_dim1 + a_1 #define vl_ref(a_1,a_2) vl[vl_subscr(a_1,a_2)] #define vr_subscr(a_1,a_2) (a_2)*vr_dim1 + a_1 #define vr_ref(a_1,a_2) vr[vr_subscr(a_1,a_2)] a_dim1 = *lda; a_offset = 1 + a_dim1 * 1; a -= a_offset; b_dim1 = *ldb; b_offset = 1 + b_dim1 * 1; b -= b_offset; --alpha; --beta; vl_dim1 = *ldvl; vl_offset = 1 + vl_dim1 * 1; vl -= vl_offset; vr_dim1 = *ldvr; vr_offset = 1 + vr_dim1 * 1; vr -= vr_offset; --work; --rwork; /* Function Body */ if (lsame_(jobvl, "N")) { ijobvl = 1; ilvl = FALSE_; } else if (lsame_(jobvl, "V")) { ijobvl = 2; ilvl = TRUE_; } else { ijobvl = -1; ilvl = FALSE_; } if (lsame_(jobvr, "N")) { ijobvr = 1; ilvr = FALSE_; } else if (lsame_(jobvr, "V")) { ijobvr = 2; ilvr = TRUE_; } else { ijobvr = -1; ilvr = FALSE_; } ilv = ilvl || ilvr; /* Test the input arguments Computing MAX */ i__1 = *n << 1; lwkmin = max(i__1,1); lwkopt = lwkmin; work[1].r = (real) lwkopt, work[1].i = 0.f; lquery = *lwork == -1; *info = 0; if (ijobvl <= 0) { *info = -1; } else if (ijobvr <= 0) { *info = -2; } else if (*n < 0) { *info = -3; } else if (*lda < max(1,*n)) { *info = -5; } else if (*ldb < max(1,*n)) { *info = -7; } else if (*ldvl < 1 || ilvl && *ldvl < *n) { *info = -11; } else if (*ldvr < 1 || ilvr && *ldvr < *n) { *info = -13; } else if (*lwork < lwkmin && ! lquery) { *info = -15; } if (*info == 0) { nb1 = ilaenv_(&c__1, "CGEQRF", " ", n, n, &c_n1, &c_n1, (ftnlen)6, ( ftnlen)1); nb2 = ilaenv_(&c__1, "CUNMQR", " ", n, n, n, &c_n1, (ftnlen)6, ( ftnlen)1); nb3 = ilaenv_(&c__1, "CUNGQR", " ", n, n, n, &c_n1, (ftnlen)6, ( ftnlen)1); /* Computing MAX */ i__1 = max(nb1,nb2); nb = max(i__1,nb3); /* Computing MAX */ i__1 = *n << 1, i__2 = *n * (nb + 1); lopt = max(i__1,i__2); work[1].r = (real) lopt, work[1].i = 0.f; } if (*info != 0) { i__1 = -(*info); xerbla_("CGEGV ", &i__1); return 0; } else if (lquery) { return 0; } /* Quick return if possible */ if (*n == 0) { return 0; } /* Get machine constants */ eps = slamch_("E") * slamch_("B"); safmin = slamch_("S"); safmin += safmin; safmax = 1.f / safmin; /* Scale A */ anrm = clange_("M", n, n, &a[a_offset], lda, &rwork[1]); anrm1 = anrm; anrm2 = 1.f; if (anrm < 1.f) { if (safmax * anrm < 1.f) { anrm1 = safmin; anrm2 = safmax * anrm; } } if (anrm > 0.f) { clascl_("G", &c_n1, &c_n1, &anrm, &c_b29, n, n, &a[a_offset], lda, & iinfo); if (iinfo != 0) { *info = *n + 10; return 0; } } /* Scale B */ bnrm = clange_("M", n, n, &b[b_offset], ldb, &rwork[1]); bnrm1 = bnrm; bnrm2 = 1.f; if (bnrm < 1.f) { if (safmax * bnrm < 1.f) { bnrm1 = safmin; bnrm2 = safmax * bnrm; } } if (bnrm > 0.f) { clascl_("G", &c_n1, &c_n1, &bnrm, &c_b29, n, n, &b[b_offset], ldb, & iinfo); if (iinfo != 0) { *info = *n + 10; return 0; } } /* Permute the matrix to make it more nearly triangular Also "balance" the matrix. */ ileft = 1; iright = *n + 1; irwork = iright + *n; cggbal_("P", n, &a[a_offset], lda, &b[b_offset], ldb, &ilo, &ihi, &rwork[ ileft], &rwork[iright], &rwork[irwork], &iinfo); if (iinfo != 0) { *info = *n + 1; goto L80; } /* Reduce B to triangular form, and initialize VL and/or VR */ irows = ihi + 1 - ilo; if (ilv) { icols = *n + 1 - ilo; } else { icols = irows; } itau = 1; iwork = itau + irows; i__1 = *lwork + 1 - iwork; cgeqrf_(&irows, &icols, &b_ref(ilo, ilo), ldb, &work[itau], &work[iwork], &i__1, &iinfo); if (iinfo >= 0) { /* Computing MAX */ i__3 = iwork; i__1 = lwkopt, i__2 = (integer) work[i__3].r + iwork - 1; lwkopt = max(i__1,i__2); } if (iinfo != 0) { *info = *n + 2; goto L80; } i__1 = *lwork + 1 - iwork; cunmqr_("L", "C", &irows, &icols, &irows, &b_ref(ilo, ilo), ldb, &work[ itau], &a_ref(ilo, ilo), lda, &work[iwork], &i__1, &iinfo); if (iinfo >= 0) { /* Computing MAX */ i__3 = iwork; i__1 = lwkopt, i__2 = (integer) work[i__3].r + iwork - 1; lwkopt = max(i__1,i__2); } if (iinfo != 0) { *info = *n + 3; goto L80; } if (ilvl) { claset_("Full", n, n, &c_b1, &c_b2, &vl[vl_offset], ldvl); i__1 = irows - 1; i__2 = irows - 1; clacpy_("L", &i__1, &i__2, &b_ref(ilo + 1, ilo), ldb, &vl_ref(ilo + 1, ilo), ldvl); i__1 = *lwork + 1 - iwork; cungqr_(&irows, &irows, &irows, &vl_ref(ilo, ilo), ldvl, &work[itau], &work[iwork], &i__1, &iinfo); if (iinfo >= 0) { /* Computing MAX */ i__3 = iwork; i__1 = lwkopt, i__2 = (integer) work[i__3].r + iwork - 1; lwkopt = max(i__1,i__2); } if (iinfo != 0) { *info = *n + 4; goto L80; } } if (ilvr) { claset_("Full", n, n, &c_b1, &c_b2, &vr[vr_offset], ldvr); } /* Reduce to generalized Hessenberg form */ if (ilv) { /* Eigenvectors requested -- work on whole matrix. */ cgghrd_(jobvl, jobvr, n, &ilo, &ihi, &a[a_offset], lda, &b[b_offset], ldb, &vl[vl_offset], ldvl, &vr[vr_offset], ldvr, &iinfo); } else { cgghrd_("N", "N", &irows, &c__1, &irows, &a_ref(ilo, ilo), lda, & b_ref(ilo, ilo), ldb, &vl[vl_offset], ldvl, &vr[vr_offset], ldvr, &iinfo); } if (iinfo != 0) { *info = *n + 5; goto L80; } /* Perform QZ algorithm */ iwork = itau; if (ilv) { *(unsigned char *)chtemp = 'S'; } else { *(unsigned char *)chtemp = 'E'; } i__1 = *lwork + 1 - iwork; chgeqz_(chtemp, jobvl, jobvr, n, &ilo, &ihi, &a[a_offset], lda, &b[ b_offset], ldb, &alpha[1], &beta[1], &vl[vl_offset], ldvl, &vr[ vr_offset], ldvr, &work[iwork], &i__1, &rwork[irwork], &iinfo); if (iinfo >= 0) { /* Computing MAX */ i__3 = iwork; i__1 = lwkopt, i__2 = (integer) work[i__3].r + iwork - 1; lwkopt = max(i__1,i__2); } if (iinfo != 0) { if (iinfo > 0 && iinfo <= *n) { *info = iinfo; } else if (iinfo > *n && iinfo <= *n << 1) { *info = iinfo - *n; } else { *info = *n + 6; } goto L80; } if (ilv) { /* Compute Eigenvectors */ if (ilvl) { if (ilvr) { *(unsigned char *)chtemp = 'B'; } else { *(unsigned char *)chtemp = 'L'; } } else { *(unsigned char *)chtemp = 'R'; } ctgevc_(chtemp, "B", ldumma, n, &a[a_offset], lda, &b[b_offset], ldb, &vl[vl_offset], ldvl, &vr[vr_offset], ldvr, n, &in, &work[ iwork], &rwork[irwork], &iinfo); if (iinfo != 0) { *info = *n + 7; goto L80; } /* Undo balancing on VL and VR, rescale */ if (ilvl) { cggbak_("P", "L", n, &ilo, &ihi, &rwork[ileft], &rwork[iright], n, &vl[vl_offset], ldvl, &iinfo); if (iinfo != 0) { *info = *n + 8; goto L80; } i__1 = *n; for (jc = 1; jc <= i__1; ++jc) { temp = 0.f; i__2 = *n; for (jr = 1; jr <= i__2; ++jr) { /* Computing MAX */ i__3 = vl_subscr(jr, jc); r__3 = temp, r__4 = (r__1 = vl[i__3].r, dabs(r__1)) + ( r__2 = r_imag(&vl_ref(jr, jc)), dabs(r__2)); temp = dmax(r__3,r__4); /* L10: */ } if (temp < safmin) { goto L30; } temp = 1.f / temp; i__2 = *n; for (jr = 1; jr <= i__2; ++jr) { i__3 = vl_subscr(jr, jc); i__4 = vl_subscr(jr, jc); q__1.r = temp * vl[i__4].r, q__1.i = temp * vl[i__4].i; vl[i__3].r = q__1.r, vl[i__3].i = q__1.i; /* L20: */ } L30: ; } } if (ilvr) { cggbak_("P", "R", n, &ilo, &ihi, &rwork[ileft], &rwork[iright], n, &vr[vr_offset], ldvr, &iinfo); if (iinfo != 0) { *info = *n + 9; goto L80; } i__1 = *n; for (jc = 1; jc <= i__1; ++jc) { temp = 0.f; i__2 = *n; for (jr = 1; jr <= i__2; ++jr) { /* Computing MAX */ i__3 = vr_subscr(jr, jc); r__3 = temp, r__4 = (r__1 = vr[i__3].r, dabs(r__1)) + ( r__2 = r_imag(&vr_ref(jr, jc)), dabs(r__2)); temp = dmax(r__3,r__4); /* L40: */ } if (temp < safmin) { goto L60; } temp = 1.f / temp; i__2 = *n; for (jr = 1; jr <= i__2; ++jr) { i__3 = vr_subscr(jr, jc); i__4 = vr_subscr(jr, jc); q__1.r = temp * vr[i__4].r, q__1.i = temp * vr[i__4].i; vr[i__3].r = q__1.r, vr[i__3].i = q__1.i; /* L50: */ } L60: ; } } /* End of eigenvector calculation */ } /* Undo scaling in alpha, beta Note: this does not give the alpha and beta for the unscaled problem. Un-scaling is limited to avoid underflow in alpha and beta if they are significant. */ i__1 = *n; for (jc = 1; jc <= i__1; ++jc) { i__2 = jc; absar = (r__1 = alpha[i__2].r, dabs(r__1)); absai = (r__1 = r_imag(&alpha[jc]), dabs(r__1)); i__2 = jc; absb = (r__1 = beta[i__2].r, dabs(r__1)); i__2 = jc; salfar = anrm * alpha[i__2].r; salfai = anrm * r_imag(&alpha[jc]); i__2 = jc; sbeta = bnrm * beta[i__2].r; ilimit = FALSE_; scale = 1.f; /* Check for significant underflow in imaginary part of ALPHA Computing MAX */ r__1 = safmin, r__2 = eps * absar, r__1 = max(r__1,r__2), r__2 = eps * absb; if (dabs(salfai) < safmin && absai >= dmax(r__1,r__2)) { ilimit = TRUE_; /* Computing MAX */ r__1 = safmin, r__2 = anrm2 * absai; scale = safmin / anrm1 / dmax(r__1,r__2); } /* Check for significant underflow in real part of ALPHA Computing MAX */ r__1 = safmin, r__2 = eps * absai, r__1 = max(r__1,r__2), r__2 = eps * absb; if (dabs(salfar) < safmin && absar >= dmax(r__1,r__2)) { ilimit = TRUE_; /* Computing MAX Computing MAX */ r__3 = safmin, r__4 = anrm2 * absar; r__1 = scale, r__2 = safmin / anrm1 / dmax(r__3,r__4); scale = dmax(r__1,r__2); } /* Check for significant underflow in BETA Computing MAX */ r__1 = safmin, r__2 = eps * absar, r__1 = max(r__1,r__2), r__2 = eps * absai; if (dabs(sbeta) < safmin && absb >= dmax(r__1,r__2)) { ilimit = TRUE_; /* Computing MAX Computing MAX */ r__3 = safmin, r__4 = bnrm2 * absb; r__1 = scale, r__2 = safmin / bnrm1 / dmax(r__3,r__4); scale = dmax(r__1,r__2); } /* Check for possible overflow when limiting scaling */ if (ilimit) { /* Computing MAX */ r__1 = dabs(salfar), r__2 = dabs(salfai), r__1 = max(r__1,r__2), r__2 = dabs(sbeta); temp = scale * safmin * dmax(r__1,r__2); if (temp > 1.f) { scale /= temp; } if (scale < 1.f) { ilimit = FALSE_; } } /* Recompute un-scaled ALPHA, BETA if necessary. */ if (ilimit) { i__2 = jc; salfar = scale * alpha[i__2].r * anrm; salfai = scale * r_imag(&alpha[jc]) * anrm; i__2 = jc; q__2.r = scale * beta[i__2].r, q__2.i = scale * beta[i__2].i; q__1.r = bnrm * q__2.r, q__1.i = bnrm * q__2.i; sbeta = q__1.r; } i__2 = jc; q__1.r = salfar, q__1.i = salfai; alpha[i__2].r = q__1.r, alpha[i__2].i = q__1.i; i__2 = jc; beta[i__2].r = sbeta, beta[i__2].i = 0.f; /* L70: */ } L80: work[1].r = (real) lwkopt, work[1].i = 0.f; return 0; /* End of CGEGV */ } /* cgegv_ */
/* Subroutine */ int zhsein_(char *side, char *eigsrc, char *initv, logical * select, integer *n, doublecomplex *h__, integer *ldh, doublecomplex * w, doublecomplex *vl, integer *ldvl, doublecomplex *vr, integer *ldvr, integer *mm, integer *m, doublecomplex *work, doublereal *rwork, integer *ifaill, integer *ifailr, integer *info) { /* -- LAPACK routine (version 3.0) -- Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., Courant Institute, Argonne National Lab, and Rice University September 30, 1994 Purpose ======= ZHSEIN uses inverse iteration to find specified right and/or left eigenvectors of a complex upper Hessenberg matrix H. The right eigenvector x and the left eigenvector y of the matrix H corresponding to an eigenvalue w are defined by: H * x = w * x, y**h * H = w * y**h where y**h denotes the conjugate transpose of the vector y. Arguments ========= SIDE (input) CHARACTER*1 = 'R': compute right eigenvectors only; = 'L': compute left eigenvectors only; = 'B': compute both right and left eigenvectors. EIGSRC (input) CHARACTER*1 Specifies the source of eigenvalues supplied in W: = 'Q': the eigenvalues were found using ZHSEQR; thus, if H has zero subdiagonal elements, and so is block-triangular, then the j-th eigenvalue can be assumed to be an eigenvalue of the block containing the j-th row/column. This property allows ZHSEIN to perform inverse iteration on just one diagonal block. = 'N': no assumptions are made on the correspondence between eigenvalues and diagonal blocks. In this case, ZHSEIN must always perform inverse iteration using the whole matrix H. INITV (input) CHARACTER*1 = 'N': no initial vectors are supplied; = 'U': user-supplied initial vectors are stored in the arrays VL and/or VR. SELECT (input) LOGICAL array, dimension (N) Specifies the eigenvectors to be computed. To select the eigenvector corresponding to the eigenvalue W(j), SELECT(j) must be set to .TRUE.. N (input) INTEGER The order of the matrix H. N >= 0. H (input) COMPLEX*16 array, dimension (LDH,N) The upper Hessenberg matrix H. LDH (input) INTEGER The leading dimension of the array H. LDH >= max(1,N). W (input/output) COMPLEX*16 array, dimension (N) On entry, the eigenvalues of H. On exit, the real parts of W may have been altered since close eigenvalues are perturbed slightly in searching for independent eigenvectors. VL (input/output) COMPLEX*16 array, dimension (LDVL,MM) On entry, if INITV = 'U' and SIDE = 'L' or 'B', VL must contain starting vectors for the inverse iteration for the left eigenvectors; the starting vector for each eigenvector must be in the same column in which the eigenvector will be stored. On exit, if SIDE = 'L' or 'B', the left eigenvectors specified by SELECT will be stored consecutively in the columns of VL, in the same order as their eigenvalues. If SIDE = 'R', VL is not referenced. LDVL (input) INTEGER The leading dimension of the array VL. LDVL >= max(1,N) if SIDE = 'L' or 'B'; LDVL >= 1 otherwise. VR (input/output) COMPLEX*16 array, dimension (LDVR,MM) On entry, if INITV = 'U' and SIDE = 'R' or 'B', VR must contain starting vectors for the inverse iteration for the right eigenvectors; the starting vector for each eigenvector must be in the same column in which the eigenvector will be stored. On exit, if SIDE = 'R' or 'B', the right eigenvectors specified by SELECT will be stored consecutively in the columns of VR, in the same order as their eigenvalues. If SIDE = 'L', VR is not referenced. LDVR (input) INTEGER The leading dimension of the array VR. LDVR >= max(1,N) if SIDE = 'R' or 'B'; LDVR >= 1 otherwise. MM (input) INTEGER The number of columns in the arrays VL and/or VR. MM >= M. M (output) INTEGER The number of columns in the arrays VL and/or VR required to store the eigenvectors (= the number of .TRUE. elements in SELECT). WORK (workspace) COMPLEX*16 array, dimension (N*N) RWORK (workspace) DOUBLE PRECISION array, dimension (N) IFAILL (output) INTEGER array, dimension (MM) If SIDE = 'L' or 'B', IFAILL(i) = j > 0 if the left eigenvector in the i-th column of VL (corresponding to the eigenvalue w(j)) failed to converge; IFAILL(i) = 0 if the eigenvector converged satisfactorily. If SIDE = 'R', IFAILL is not referenced. IFAILR (output) INTEGER array, dimension (MM) If SIDE = 'R' or 'B', IFAILR(i) = j > 0 if the right eigenvector in the i-th column of VR (corresponding to the eigenvalue w(j)) failed to converge; IFAILR(i) = 0 if the eigenvector converged satisfactorily. If SIDE = 'L', IFAILR is not referenced. INFO (output) INTEGER = 0: successful exit < 0: if INFO = -i, the i-th argument had an illegal value > 0: if INFO = i, i is the number of eigenvectors which failed to converge; see IFAILL and IFAILR for further details. Further Details =============== Each eigenvector is normalized so that the element of largest magnitude has magnitude 1; here the magnitude of a complex number (x,y) is taken to be |x|+|y|. ===================================================================== Decode and test the input parameters. Parameter adjustments */ /* Table of constant values */ static logical c_false = FALSE_; static logical c_true = TRUE_; /* System generated locals */ integer h_dim1, h_offset, vl_dim1, vl_offset, vr_dim1, vr_offset, i__1, i__2, i__3; doublereal d__1, d__2; doublecomplex z__1, z__2; /* Builtin functions */ double d_imag(doublecomplex *); /* Local variables */ static doublereal unfl; static integer i__, k; extern logical lsame_(char *, char *); static integer iinfo; static logical leftv, bothv; static doublereal hnorm; static integer kl; extern doublereal dlamch_(char *); static integer kr, ks; static doublecomplex wk; extern /* Subroutine */ int xerbla_(char *, integer *), zlaein_( logical *, logical *, integer *, doublecomplex *, integer *, doublecomplex *, doublecomplex *, doublecomplex *, integer *, doublereal *, doublereal *, doublereal *, integer *); extern doublereal zlanhs_(char *, integer *, doublecomplex *, integer *, doublereal *); static logical noinit; static integer ldwork; static logical rightv, fromqr; static doublereal smlnum; static integer kln; static doublereal ulp, eps3; #define h___subscr(a_1,a_2) (a_2)*h_dim1 + a_1 #define h___ref(a_1,a_2) h__[h___subscr(a_1,a_2)] #define vl_subscr(a_1,a_2) (a_2)*vl_dim1 + a_1 #define vl_ref(a_1,a_2) vl[vl_subscr(a_1,a_2)] #define vr_subscr(a_1,a_2) (a_2)*vr_dim1 + a_1 #define vr_ref(a_1,a_2) vr[vr_subscr(a_1,a_2)] --select; h_dim1 = *ldh; h_offset = 1 + h_dim1 * 1; h__ -= h_offset; --w; vl_dim1 = *ldvl; vl_offset = 1 + vl_dim1 * 1; vl -= vl_offset; vr_dim1 = *ldvr; vr_offset = 1 + vr_dim1 * 1; vr -= vr_offset; --work; --rwork; --ifaill; --ifailr; /* Function Body */ bothv = lsame_(side, "B"); rightv = lsame_(side, "R") || bothv; leftv = lsame_(side, "L") || bothv; fromqr = lsame_(eigsrc, "Q"); noinit = lsame_(initv, "N"); /* Set M to the number of columns required to store the selected eigenvectors. */ *m = 0; i__1 = *n; for (k = 1; k <= i__1; ++k) { if (select[k]) { ++(*m); } /* L10: */ } *info = 0; if (! rightv && ! leftv) { *info = -1; } else if (! fromqr && ! lsame_(eigsrc, "N")) { *info = -2; } else if (! noinit && ! lsame_(initv, "U")) { *info = -3; } else if (*n < 0) { *info = -5; } else if (*ldh < max(1,*n)) { *info = -7; } else if (*ldvl < 1 || leftv && *ldvl < *n) { *info = -10; } else if (*ldvr < 1 || rightv && *ldvr < *n) { *info = -12; } else if (*mm < *m) { *info = -13; } if (*info != 0) { i__1 = -(*info); xerbla_("ZHSEIN", &i__1); return 0; } /* Quick return if possible. */ if (*n == 0) { return 0; } /* Set machine-dependent constants. */ unfl = dlamch_("Safe minimum"); ulp = dlamch_("Precision"); smlnum = unfl * (*n / ulp); ldwork = *n; kl = 1; kln = 0; if (fromqr) { kr = 0; } else { kr = *n; } ks = 1; i__1 = *n; for (k = 1; k <= i__1; ++k) { if (select[k]) { /* Compute eigenvector(s) corresponding to W(K). */ if (fromqr) { /* If affiliation of eigenvalues is known, check whether the matrix splits. Determine KL and KR such that 1 <= KL <= K <= KR <= N and H(KL,KL-1) and H(KR+1,KR) are zero (or KL = 1 or KR = N). Then inverse iteration can be performed with the submatrix H(KL:N,KL:N) for a left eigenvector, and with the submatrix H(1:KR,1:KR) for a right eigenvector. */ i__2 = kl + 1; for (i__ = k; i__ >= i__2; --i__) { i__3 = h___subscr(i__, i__ - 1); if (h__[i__3].r == 0. && h__[i__3].i == 0.) { goto L30; } /* L20: */ } L30: kl = i__; if (k > kr) { i__2 = *n - 1; for (i__ = k; i__ <= i__2; ++i__) { i__3 = h___subscr(i__ + 1, i__); if (h__[i__3].r == 0. && h__[i__3].i == 0.) { goto L50; } /* L40: */ } L50: kr = i__; } } if (kl != kln) { kln = kl; /* Compute infinity-norm of submatrix H(KL:KR,KL:KR) if it has not ben computed before. */ i__2 = kr - kl + 1; hnorm = zlanhs_("I", &i__2, &h___ref(kl, kl), ldh, &rwork[1]); if (hnorm > 0.) { eps3 = hnorm * ulp; } else { eps3 = smlnum; } } /* Perturb eigenvalue if it is close to any previous selected eigenvalues affiliated to the submatrix H(KL:KR,KL:KR). Close roots are modified by EPS3. */ i__2 = k; wk.r = w[i__2].r, wk.i = w[i__2].i; L60: i__2 = kl; for (i__ = k - 1; i__ >= i__2; --i__) { i__3 = i__; z__2.r = w[i__3].r - wk.r, z__2.i = w[i__3].i - wk.i; z__1.r = z__2.r, z__1.i = z__2.i; if (select[i__] && (d__1 = z__1.r, abs(d__1)) + (d__2 = d_imag(&z__1), abs(d__2)) < eps3) { z__1.r = wk.r + eps3, z__1.i = wk.i; wk.r = z__1.r, wk.i = z__1.i; goto L60; } /* L70: */ } i__2 = k; w[i__2].r = wk.r, w[i__2].i = wk.i; if (leftv) { /* Compute left eigenvector. */ i__2 = *n - kl + 1; zlaein_(&c_false, &noinit, &i__2, &h___ref(kl, kl), ldh, &wk, &vl_ref(kl, ks), &work[1], &ldwork, &rwork[1], &eps3, &smlnum, &iinfo); if (iinfo > 0) { ++(*info); ifaill[ks] = k; } else { ifaill[ks] = 0; } i__2 = kl - 1; for (i__ = 1; i__ <= i__2; ++i__) { i__3 = vl_subscr(i__, ks); vl[i__3].r = 0., vl[i__3].i = 0.; /* L80: */ } } if (rightv) { /* Compute right eigenvector. */ zlaein_(&c_true, &noinit, &kr, &h__[h_offset], ldh, &wk, & vr_ref(1, ks), &work[1], &ldwork, &rwork[1], &eps3, & smlnum, &iinfo); if (iinfo > 0) { ++(*info); ifailr[ks] = k; } else { ifailr[ks] = 0; } i__2 = *n; for (i__ = kr + 1; i__ <= i__2; ++i__) { i__3 = vr_subscr(i__, ks); vr[i__3].r = 0., vr[i__3].i = 0.; /* L90: */ } } ++ks; } /* L100: */ } return 0; /* End of ZHSEIN */ } /* zhsein_ */
/* Subroutine */ int cggevx_(char *balanc, char *jobvl, char *jobvr, char * sense, integer *n, complex *a, integer *lda, complex *b, integer *ldb, complex *alpha, complex *beta, complex *vl, integer *ldvl, complex * vr, integer *ldvr, integer *ilo, integer *ihi, real *lscale, real * rscale, real *abnrm, real *bbnrm, real *rconde, real *rcondv, complex *work, integer *lwork, real *rwork, integer *iwork, logical *bwork, integer *info) { /* -- LAPACK driver routine (version 3.0) -- Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., Courant Institute, Argonne National Lab, and Rice University June 30, 1999 Purpose ======= CGGEVX computes for a pair of N-by-N complex nonsymmetric matrices (A,B) the generalized eigenvalues, and optionally, the left and/or right generalized eigenvectors. Optionally, it also computes a balancing transformation to improve the conditioning of the eigenvalues and eigenvectors (ILO, IHI, LSCALE, RSCALE, ABNRM, and BBNRM), reciprocal condition numbers for the eigenvalues (RCONDE), and reciprocal condition numbers for the right eigenvectors (RCONDV). A generalized eigenvalue for a pair of matrices (A,B) is a scalar lambda or a ratio alpha/beta = lambda, such that A - lambda*B is singular. It is usually represented as the pair (alpha,beta), as there is a reasonable interpretation for beta=0, and even for both being zero. The right eigenvector v(j) corresponding to the eigenvalue lambda(j) of (A,B) satisfies A * v(j) = lambda(j) * B * v(j) . The left eigenvector u(j) corresponding to the eigenvalue lambda(j) of (A,B) satisfies u(j)**H * A = lambda(j) * u(j)**H * B. where u(j)**H is the conjugate-transpose of u(j). Arguments ========= BALANC (input) CHARACTER*1 Specifies the balance option to be performed: = 'N': do not diagonally scale or permute; = 'P': permute only; = 'S': scale only; = 'B': both permute and scale. Computed reciprocal condition numbers will be for the matrices after permuting and/or balancing. Permuting does not change condition numbers (in exact arithmetic), but balancing does. JOBVL (input) CHARACTER*1 = 'N': do not compute the left generalized eigenvectors; = 'V': compute the left generalized eigenvectors. JOBVR (input) CHARACTER*1 = 'N': do not compute the right generalized eigenvectors; = 'V': compute the right generalized eigenvectors. SENSE (input) CHARACTER*1 Determines which reciprocal condition numbers are computed. = 'N': none are computed; = 'E': computed for eigenvalues only; = 'V': computed for eigenvectors only; = 'B': computed for eigenvalues and eigenvectors. N (input) INTEGER The order of the matrices A, B, VL, and VR. N >= 0. A (input/output) COMPLEX array, dimension (LDA, N) On entry, the matrix A in the pair (A,B). On exit, A has been overwritten. If JOBVL='V' or JOBVR='V' or both, then A contains the first part of the complex Schur form of the "balanced" versions of the input A and B. LDA (input) INTEGER The leading dimension of A. LDA >= max(1,N). B (input/output) COMPLEX array, dimension (LDB, N) On entry, the matrix B in the pair (A,B). On exit, B has been overwritten. If JOBVL='V' or JOBVR='V' or both, then B contains the second part of the complex Schur form of the "balanced" versions of the input A and B. LDB (input) INTEGER The leading dimension of B. LDB >= max(1,N). ALPHA (output) COMPLEX array, dimension (N) BETA (output) COMPLEX array, dimension (N) On exit, ALPHA(j)/BETA(j), j=1,...,N, will be the generalized eigenvalues. Note: the quotient ALPHA(j)/BETA(j) ) may easily over- or underflow, and BETA(j) may even be zero. Thus, the user should avoid naively computing the ratio ALPHA/BETA. However, ALPHA will be always less than and usually comparable with norm(A) in magnitude, and BETA always less than and usually comparable with norm(B). VL (output) COMPLEX array, dimension (LDVL,N) If JOBVL = 'V', the left generalized eigenvectors u(j) are stored one after another in the columns of VL, in the same order as their eigenvalues. Each eigenvector will be scaled so the largest component will have abs(real part) + abs(imag. part) = 1. Not referenced if JOBVL = 'N'. LDVL (input) INTEGER The leading dimension of the matrix VL. LDVL >= 1, and if JOBVL = 'V', LDVL >= N. VR (output) COMPLEX array, dimension (LDVR,N) If JOBVR = 'V', the right generalized eigenvectors v(j) are stored one after another in the columns of VR, in the same order as their eigenvalues. Each eigenvector will be scaled so the largest component will have abs(real part) + abs(imag. part) = 1. Not referenced if JOBVR = 'N'. LDVR (input) INTEGER The leading dimension of the matrix VR. LDVR >= 1, and if JOBVR = 'V', LDVR >= N. ILO,IHI (output) INTEGER ILO and IHI are integer values such that on exit A(i,j) = 0 and B(i,j) = 0 if i > j and j = 1,...,ILO-1 or i = IHI+1,...,N. If BALANC = 'N' or 'S', ILO = 1 and IHI = N. LSCALE (output) REAL array, dimension (N) Details of the permutations and scaling factors applied to the left side of A and B. If PL(j) is the index of the row interchanged with row j, and DL(j) is the scaling factor applied to row j, then LSCALE(j) = PL(j) for j = 1,...,ILO-1 = DL(j) for j = ILO,...,IHI = PL(j) for j = IHI+1,...,N. The order in which the interchanges are made is N to IHI+1, then 1 to ILO-1. RSCALE (output) REAL array, dimension (N) Details of the permutations and scaling factors applied to the right side of A and B. If PR(j) is the index of the column interchanged with column j, and DR(j) is the scaling factor applied to column j, then RSCALE(j) = PR(j) for j = 1,...,ILO-1 = DR(j) for j = ILO,...,IHI = PR(j) for j = IHI+1,...,N The order in which the interchanges are made is N to IHI+1, then 1 to ILO-1. ABNRM (output) REAL The one-norm of the balanced matrix A. BBNRM (output) REAL The one-norm of the balanced matrix B. RCONDE (output) REAL array, dimension (N) If SENSE = 'E' or 'B', the reciprocal condition numbers of the selected eigenvalues, stored in consecutive elements of the array. If SENSE = 'V', RCONDE is not referenced. RCONDV (output) REAL array, dimension (N) If JOB = 'V' or 'B', the estimated reciprocal condition numbers of the selected eigenvectors, stored in consecutive elements of the array. If the eigenvalues cannot be reordered to compute RCONDV(j), RCONDV(j) is set to 0; this can only occur when the true value would be very small anyway. If SENSE = 'E', RCONDV is not referenced. Not referenced if JOB = 'E'. WORK (workspace/output) COMPLEX array, dimension (LWORK) On exit, if INFO = 0, WORK(1) returns the optimal LWORK. LWORK (input) INTEGER The dimension of the array WORK. LWORK >= max(1,2*N). If SENSE = 'N' or 'E', LWORK >= 2*N. If SENSE = 'V' or 'B', LWORK >= 2*N*N+2*N. If LWORK = -1, then a workspace query is assumed; the routine only calculates the optimal size of the WORK array, returns this value as the first entry of the WORK array, and no error message related to LWORK is issued by XERBLA. RWORK (workspace) REAL array, dimension (6*N) Real workspace. IWORK (workspace) INTEGER array, dimension (N+2) If SENSE = 'E', IWORK is not referenced. BWORK (workspace) LOGICAL array, dimension (N) If SENSE = 'N', BWORK is not referenced. INFO (output) INTEGER = 0: successful exit < 0: if INFO = -i, the i-th argument had an illegal value. = 1,...,N: The QZ iteration failed. No eigenvectors have been calculated, but ALPHA(j) and BETA(j) should be correct for j=INFO+1,...,N. > N: =N+1: other than QZ iteration failed in CHGEQZ. =N+2: error return from CTGEVC. Further Details =============== Balancing a matrix pair (A,B) includes, first, permuting rows and columns to isolate eigenvalues, second, applying diagonal similarity transformation to the rows and columns to make the rows and columns as close in norm as possible. The computed reciprocal condition numbers correspond to the balanced matrix. Permuting rows and columns will not change the condition numbers (in exact arithmetic) but diagonal scaling will. For further explanation of balancing, see section 4.11.1.2 of LAPACK Users' Guide. An approximate error bound on the chordal distance between the i-th computed generalized eigenvalue w and the corresponding exact eigenvalue lambda is chord(w, lambda) <= EPS * norm(ABNRM, BBNRM) / RCONDE(I) An approximate error bound for the angle between the i-th computed eigenvector VL(i) or VR(i) is given by EPS * norm(ABNRM, BBNRM) / DIF(i). For further explanation of the reciprocal condition numbers RCONDE and RCONDV, see section 4.11 of LAPACK User's Guide. ===================================================================== Decode the input arguments Parameter adjustments */ /* Table of constant values */ static complex c_b1 = {0.f,0.f}; static complex c_b2 = {1.f,0.f}; static integer c__1 = 1; static integer c__0 = 0; /* System generated locals */ integer a_dim1, a_offset, b_dim1, b_offset, vl_dim1, vl_offset, vr_dim1, vr_offset, i__1, i__2, i__3, i__4; real r__1, r__2, r__3, r__4; complex q__1; /* Builtin functions */ double sqrt(doublereal), r_imag(complex *); /* Local variables */ static real anrm, bnrm; static integer ierr, itau; static real temp; static logical ilvl, ilvr; static integer iwrk, iwrk1, i__, j, m; extern logical lsame_(char *, char *); static integer icols, irows, jc; extern /* Subroutine */ int cggbak_(char *, char *, integer *, integer *, integer *, real *, real *, integer *, complex *, integer *, integer *), cggbal_(char *, integer *, complex *, integer *, complex *, integer *, integer *, integer *, real *, real *, real *, integer *), slabad_(real *, real *); static integer in; extern doublereal clange_(char *, integer *, integer *, complex *, integer *, real *); static integer jr; extern /* Subroutine */ int cgghrd_(char *, char *, integer *, integer *, integer *, complex *, integer *, complex *, integer *, complex *, integer *, complex *, integer *, integer *), clascl_(char *, integer *, integer *, real *, real *, integer *, integer *, complex *, integer *, integer *); static logical ilascl, ilbscl; extern /* Subroutine */ int cgeqrf_(integer *, integer *, complex *, integer *, complex *, complex *, integer *, integer *), clacpy_( char *, integer *, integer *, complex *, integer *, complex *, integer *), claset_(char *, integer *, integer *, complex *, complex *, complex *, integer *); static logical ldumma[1]; static char chtemp[1]; static real bignum; extern /* Subroutine */ int chgeqz_(char *, char *, char *, integer *, integer *, integer *, complex *, integer *, complex *, integer *, complex *, complex *, complex *, integer *, complex *, integer *, complex *, integer *, real *, integer *), ctgevc_(char *, char *, logical *, integer *, complex *, integer * , complex *, integer *, complex *, integer *, complex *, integer * , integer *, integer *, complex *, real *, integer *); static integer ijobvl; extern /* Subroutine */ int ctgsna_(char *, char *, logical *, integer *, complex *, integer *, complex *, integer *, complex *, integer *, complex *, integer *, real *, real *, integer *, integer *, complex *, integer *, integer *, integer *), slascl_(char *, integer *, integer *, real *, real *, integer *, integer *, real *, integer *, integer *), xerbla_(char *, integer *); extern integer ilaenv_(integer *, char *, char *, integer *, integer *, integer *, integer *, ftnlen, ftnlen); extern doublereal slamch_(char *); static integer ijobvr; static logical wantsb; extern /* Subroutine */ int cungqr_(integer *, integer *, integer *, complex *, integer *, complex *, complex *, integer *, integer *); static real anrmto; static logical wantse; static real bnrmto; extern /* Subroutine */ int cunmqr_(char *, char *, integer *, integer *, integer *, complex *, integer *, complex *, complex *, integer *, complex *, integer *, integer *); static integer minwrk, maxwrk; static logical wantsn; static real smlnum; static logical lquery, wantsv; static real eps; static logical ilv; #define a_subscr(a_1,a_2) (a_2)*a_dim1 + a_1 #define a_ref(a_1,a_2) a[a_subscr(a_1,a_2)] #define b_subscr(a_1,a_2) (a_2)*b_dim1 + a_1 #define b_ref(a_1,a_2) b[b_subscr(a_1,a_2)] #define vl_subscr(a_1,a_2) (a_2)*vl_dim1 + a_1 #define vl_ref(a_1,a_2) vl[vl_subscr(a_1,a_2)] #define vr_subscr(a_1,a_2) (a_2)*vr_dim1 + a_1 #define vr_ref(a_1,a_2) vr[vr_subscr(a_1,a_2)] a_dim1 = *lda; a_offset = 1 + a_dim1 * 1; a -= a_offset; b_dim1 = *ldb; b_offset = 1 + b_dim1 * 1; b -= b_offset; --alpha; --beta; vl_dim1 = *ldvl; vl_offset = 1 + vl_dim1 * 1; vl -= vl_offset; vr_dim1 = *ldvr; vr_offset = 1 + vr_dim1 * 1; vr -= vr_offset; --lscale; --rscale; --rconde; --rcondv; --work; --rwork; --iwork; --bwork; /* Function Body */ if (lsame_(jobvl, "N")) { ijobvl = 1; ilvl = FALSE_; } else if (lsame_(jobvl, "V")) { ijobvl = 2; ilvl = TRUE_; } else { ijobvl = -1; ilvl = FALSE_; } if (lsame_(jobvr, "N")) { ijobvr = 1; ilvr = FALSE_; } else if (lsame_(jobvr, "V")) { ijobvr = 2; ilvr = TRUE_; } else { ijobvr = -1; ilvr = FALSE_; } ilv = ilvl || ilvr; wantsn = lsame_(sense, "N"); wantse = lsame_(sense, "E"); wantsv = lsame_(sense, "V"); wantsb = lsame_(sense, "B"); /* Test the input arguments */ *info = 0; lquery = *lwork == -1; if (! (lsame_(balanc, "N") || lsame_(balanc, "S") || lsame_(balanc, "P") || lsame_(balanc, "B"))) { *info = -1; } else if (ijobvl <= 0) { *info = -2; } else if (ijobvr <= 0) { *info = -3; } else if (! (wantsn || wantse || wantsb || wantsv)) { *info = -4; } else if (*n < 0) { *info = -5; } else if (*lda < max(1,*n)) { *info = -7; } else if (*ldb < max(1,*n)) { *info = -9; } else if (*ldvl < 1 || ilvl && *ldvl < *n) { *info = -13; } else if (*ldvr < 1 || ilvr && *ldvr < *n) { *info = -15; } /* Compute workspace (Note: Comments in the code beginning "Workspace:" describe the minimal amount of workspace needed at that point in the code, as well as the preferred amount for good performance. NB refers to the optimal block size for the immediately following subroutine, as returned by ILAENV. The workspace is computed assuming ILO = 1 and IHI = N, the worst case.) */ minwrk = 1; if (*info == 0 && (*lwork >= 1 || lquery)) { maxwrk = *n + *n * ilaenv_(&c__1, "CGEQRF", " ", n, &c__1, n, &c__0, ( ftnlen)6, (ftnlen)1); if (wantse) { /* Computing MAX */ i__1 = 1, i__2 = *n << 1; minwrk = max(i__1,i__2); } else if (wantsv || wantsb) { minwrk = (*n << 1) * *n + (*n << 1); /* Computing MAX */ i__1 = maxwrk, i__2 = (*n << 1) * *n + (*n << 1); maxwrk = max(i__1,i__2); } work[1].r = (real) maxwrk, work[1].i = 0.f; } if (*lwork < minwrk && ! lquery) { *info = -25; } if (*info != 0) { i__1 = -(*info); xerbla_("CGGEVX", &i__1); return 0; } else if (lquery) { return 0; } /* Quick return if possible */ if (*n == 0) { return 0; } /* Get machine constants */ eps = slamch_("P"); smlnum = slamch_("S"); bignum = 1.f / smlnum; slabad_(&smlnum, &bignum); smlnum = sqrt(smlnum) / eps; bignum = 1.f / smlnum; /* Scale A if max element outside range [SMLNUM,BIGNUM] */ anrm = clange_("M", n, n, &a[a_offset], lda, &rwork[1]); ilascl = FALSE_; if (anrm > 0.f && anrm < smlnum) { anrmto = smlnum; ilascl = TRUE_; } else if (anrm > bignum) { anrmto = bignum; ilascl = TRUE_; } if (ilascl) { clascl_("G", &c__0, &c__0, &anrm, &anrmto, n, n, &a[a_offset], lda, & ierr); } /* Scale B if max element outside range [SMLNUM,BIGNUM] */ bnrm = clange_("M", n, n, &b[b_offset], ldb, &rwork[1]); ilbscl = FALSE_; if (bnrm > 0.f && bnrm < smlnum) { bnrmto = smlnum; ilbscl = TRUE_; } else if (bnrm > bignum) { bnrmto = bignum; ilbscl = TRUE_; } if (ilbscl) { clascl_("G", &c__0, &c__0, &bnrm, &bnrmto, n, n, &b[b_offset], ldb, & ierr); } /* Permute and/or balance the matrix pair (A,B) (Real Workspace: need 6*N) */ cggbal_(balanc, n, &a[a_offset], lda, &b[b_offset], ldb, ilo, ihi, & lscale[1], &rscale[1], &rwork[1], &ierr); /* Compute ABNRM and BBNRM */ *abnrm = clange_("1", n, n, &a[a_offset], lda, &rwork[1]); if (ilascl) { rwork[1] = *abnrm; slascl_("G", &c__0, &c__0, &anrmto, &anrm, &c__1, &c__1, &rwork[1], & c__1, &ierr); *abnrm = rwork[1]; } *bbnrm = clange_("1", n, n, &b[b_offset], ldb, &rwork[1]); if (ilbscl) { rwork[1] = *bbnrm; slascl_("G", &c__0, &c__0, &bnrmto, &bnrm, &c__1, &c__1, &rwork[1], & c__1, &ierr); *bbnrm = rwork[1]; } /* Reduce B to triangular form (QR decomposition of B) (Complex Workspace: need N, prefer N*NB ) */ irows = *ihi + 1 - *ilo; if (ilv || ! wantsn) { icols = *n + 1 - *ilo; } else { icols = irows; } itau = 1; iwrk = itau + irows; i__1 = *lwork + 1 - iwrk; cgeqrf_(&irows, &icols, &b_ref(*ilo, *ilo), ldb, &work[itau], &work[iwrk], &i__1, &ierr); /* Apply the unitary transformation to A (Complex Workspace: need N, prefer N*NB) */ i__1 = *lwork + 1 - iwrk; cunmqr_("L", "C", &irows, &icols, &irows, &b_ref(*ilo, *ilo), ldb, &work[ itau], &a_ref(*ilo, *ilo), lda, &work[iwrk], &i__1, &ierr); /* Initialize VL and/or VR (Workspace: need N, prefer N*NB) */ if (ilvl) { claset_("Full", n, n, &c_b1, &c_b2, &vl[vl_offset], ldvl); i__1 = irows - 1; i__2 = irows - 1; clacpy_("L", &i__1, &i__2, &b_ref(*ilo + 1, *ilo), ldb, &vl_ref(*ilo + 1, *ilo), ldvl); i__1 = *lwork + 1 - iwrk; cungqr_(&irows, &irows, &irows, &vl_ref(*ilo, *ilo), ldvl, &work[itau] , &work[iwrk], &i__1, &ierr); } if (ilvr) { claset_("Full", n, n, &c_b1, &c_b2, &vr[vr_offset], ldvr); } /* Reduce to generalized Hessenberg form (Workspace: none needed) */ if (ilv || ! wantsn) { /* Eigenvectors requested -- work on whole matrix. */ cgghrd_(jobvl, jobvr, n, ilo, ihi, &a[a_offset], lda, &b[b_offset], ldb, &vl[vl_offset], ldvl, &vr[vr_offset], ldvr, &ierr); } else { cgghrd_("N", "N", &irows, &c__1, &irows, &a_ref(*ilo, *ilo), lda, & b_ref(*ilo, *ilo), ldb, &vl[vl_offset], ldvl, &vr[vr_offset], ldvr, &ierr); } /* Perform QZ algorithm (Compute eigenvalues, and optionally, the Schur forms and Schur vectors) (Complex Workspace: need N) (Real Workspace: need N) */ iwrk = itau; if (ilv || ! wantsn) { *(unsigned char *)chtemp = 'S'; } else { *(unsigned char *)chtemp = 'E'; } i__1 = *lwork + 1 - iwrk; chgeqz_(chtemp, jobvl, jobvr, n, ilo, ihi, &a[a_offset], lda, &b[b_offset] , ldb, &alpha[1], &beta[1], &vl[vl_offset], ldvl, &vr[vr_offset], ldvr, &work[iwrk], &i__1, &rwork[1], &ierr); if (ierr != 0) { if (ierr > 0 && ierr <= *n) { *info = ierr; } else if (ierr > *n && ierr <= *n << 1) { *info = ierr - *n; } else { *info = *n + 1; } goto L90; } /* Compute Eigenvectors and estimate condition numbers if desired CTGEVC: (Complex Workspace: need 2*N ) (Real Workspace: need 2*N ) CTGSNA: (Complex Workspace: need 2*N*N if SENSE='V' or 'B') (Integer Workspace: need N+2 ) */ if (ilv || ! wantsn) { if (ilv) { if (ilvl) { if (ilvr) { *(unsigned char *)chtemp = 'B'; } else { *(unsigned char *)chtemp = 'L'; } } else { *(unsigned char *)chtemp = 'R'; } ctgevc_(chtemp, "B", ldumma, n, &a[a_offset], lda, &b[b_offset], ldb, &vl[vl_offset], ldvl, &vr[vr_offset], ldvr, n, &in, & work[iwrk], &rwork[1], &ierr); if (ierr != 0) { *info = *n + 2; goto L90; } } if (! wantsn) { /* compute eigenvectors (STGEVC) and estimate condition numbers (STGSNA). Note that the definition of the condition number is not invariant under transformation (u,v) to (Q*u, Z*v), where (u,v) are eigenvectors of the generalized Schur form (S,T), Q and Z are orthogonal matrices. In order to avoid using extra 2*N*N workspace, we have to re-calculate eigenvectors and estimate the condition numbers one at a time. */ i__1 = *n; for (i__ = 1; i__ <= i__1; ++i__) { i__2 = *n; for (j = 1; j <= i__2; ++j) { bwork[j] = FALSE_; /* L10: */ } bwork[i__] = TRUE_; iwrk = *n + 1; iwrk1 = iwrk + *n; if (wantse || wantsb) { ctgevc_("B", "S", &bwork[1], n, &a[a_offset], lda, &b[ b_offset], ldb, &work[1], n, &work[iwrk], n, & c__1, &m, &work[iwrk1], &rwork[1], &ierr); if (ierr != 0) { *info = *n + 2; goto L90; } } i__2 = *lwork - iwrk1 + 1; ctgsna_(sense, "S", &bwork[1], n, &a[a_offset], lda, &b[ b_offset], ldb, &work[1], n, &work[iwrk], n, &rconde[ i__], &rcondv[i__], &c__1, &m, &work[iwrk1], &i__2, & iwork[1], &ierr); /* L20: */ } } } /* Undo balancing on VL and VR and normalization (Workspace: none needed) */ if (ilvl) { cggbak_(balanc, "L", n, ilo, ihi, &lscale[1], &rscale[1], n, &vl[ vl_offset], ldvl, &ierr); i__1 = *n; for (jc = 1; jc <= i__1; ++jc) { temp = 0.f; i__2 = *n; for (jr = 1; jr <= i__2; ++jr) { /* Computing MAX */ i__3 = vl_subscr(jr, jc); r__3 = temp, r__4 = (r__1 = vl[i__3].r, dabs(r__1)) + (r__2 = r_imag(&vl_ref(jr, jc)), dabs(r__2)); temp = dmax(r__3,r__4); /* L30: */ } if (temp < smlnum) { goto L50; } temp = 1.f / temp; i__2 = *n; for (jr = 1; jr <= i__2; ++jr) { i__3 = vl_subscr(jr, jc); i__4 = vl_subscr(jr, jc); q__1.r = temp * vl[i__4].r, q__1.i = temp * vl[i__4].i; vl[i__3].r = q__1.r, vl[i__3].i = q__1.i; /* L40: */ } L50: ; } } if (ilvr) { cggbak_(balanc, "R", n, ilo, ihi, &lscale[1], &rscale[1], n, &vr[ vr_offset], ldvr, &ierr); i__1 = *n; for (jc = 1; jc <= i__1; ++jc) { temp = 0.f; i__2 = *n; for (jr = 1; jr <= i__2; ++jr) { /* Computing MAX */ i__3 = vr_subscr(jr, jc); r__3 = temp, r__4 = (r__1 = vr[i__3].r, dabs(r__1)) + (r__2 = r_imag(&vr_ref(jr, jc)), dabs(r__2)); temp = dmax(r__3,r__4); /* L60: */ } if (temp < smlnum) { goto L80; } temp = 1.f / temp; i__2 = *n; for (jr = 1; jr <= i__2; ++jr) { i__3 = vr_subscr(jr, jc); i__4 = vr_subscr(jr, jc); q__1.r = temp * vr[i__4].r, q__1.i = temp * vr[i__4].i; vr[i__3].r = q__1.r, vr[i__3].i = q__1.i; /* L70: */ } L80: ; } } /* Undo scaling if necessary */ if (ilascl) { clascl_("G", &c__0, &c__0, &anrmto, &anrm, n, &c__1, &alpha[1], n, & ierr); } if (ilbscl) { clascl_("G", &c__0, &c__0, &bnrmto, &bnrm, n, &c__1, &beta[1], n, & ierr); } L90: work[1].r = (real) maxwrk, work[1].i = 0.f; return 0; /* End of CGGEVX */ } /* cggevx_ */
/* Subroutine */ int zdrvev_(integer *nsizes, integer *nn, integer *ntypes, logical *dotype, integer *iseed, doublereal *thresh, integer *nounit, doublecomplex *a, integer *lda, doublecomplex *h__, doublecomplex *w, doublecomplex *w1, doublecomplex *vl, integer *ldvl, doublecomplex * vr, integer *ldvr, doublecomplex *lre, integer *ldlre, doublereal * result, doublecomplex *work, integer *nwork, doublereal *rwork, integer *iwork, integer *info) { /* Initialized data */ static integer ktype[21] = { 1,2,3,4,4,4,4,4,6,6,6,6,6,6,6,6,6,6,9,9,9 }; static integer kmagn[21] = { 1,1,1,1,1,1,2,3,1,1,1,1,1,1,1,1,2,3,1,2,3 }; static integer kmode[21] = { 0,0,0,4,3,1,4,4,4,3,1,5,4,3,1,5,5,5,4,3,1 }; static integer kconds[21] = { 0,0,0,0,0,0,0,0,1,1,1,1,2,2,2,2,2,2,0,0,0 }; /* Format strings */ static char fmt_9993[] = "(\002 ZDRVEV: \002,a,\002 returned INFO=\002,i" "6,\002.\002,/9x,\002N=\002,i6,\002, JTYPE=\002,i6,\002, ISEED=" "(\002,3(i5,\002,\002),i5,\002)\002)"; static char fmt_9999[] = "(/1x,a3,\002 -- Complex Eigenvalue-Eigenvect" "or \002,\002Decomposition Driver\002,/\002 Matrix types (see ZDR" "VEV for details): \002)"; static char fmt_9998[] = "(/\002 Special Matrices:\002,/\002 1=Zero mat" "rix. \002,\002 \002,\002 5=Diagonal: geom" "etr. spaced entries.\002,/\002 2=Identity matrix. " " \002,\002 6=Diagona\002,\002l: clustered entries.\002," "/\002 3=Transposed Jordan block. \002,\002 \002,\002 " " 7=Diagonal: large, evenly spaced.\002,/\002 \002,\0024=Diagona" "l: evenly spaced entries. \002,\002 8=Diagonal: s\002,\002ma" "ll, evenly spaced.\002)"; static char fmt_9997[] = "(\002 Dense, Non-Symmetric Matrices:\002,/\002" " 9=Well-cond., ev\002,\002enly spaced eigenvals.\002,\002 14=Il" "l-cond., geomet. spaced e\002,\002igenals.\002,/\002 10=Well-con" "d., geom. spaced eigenvals. \002,\002 15=Ill-conditioned, cluste" "red e.vals.\002,/\002 11=Well-cond\002,\002itioned, clustered e." "vals. \002,\002 16=Ill-cond., random comp\002,\002lex \002,a6," "/\002 12=Well-cond., random complex \002,a6,\002 \002,\002 17=" "Ill-cond., large rand. complx \002,a4,/\002 13=Ill-condi\002," "\002tioned, evenly spaced. \002,\002 18=Ill-cond., small ran" "d.\002,\002 complx \002,a4)"; static char fmt_9996[] = "(\002 19=Matrix with random O(1) entries. " " \002,\002 21=Matrix \002,\002with small random entries.\002," "/\002 20=Matrix with large ran\002,\002dom entries. \002,/)"; static char fmt_9995[] = "(\002 Tests performed with test threshold =" "\002,f8.2,//\002 1 = | A VR - VR W | / ( n |A| ulp ) \002,/\002 " "2 = | conj-trans(A) VL - VL conj-trans(W) | /\002,\002 ( n |A| u" "lp ) \002,/\002 3 = | |VR(i)| - 1 | / ulp \002,/\002 4 = | |VL(i" ")| - 1 | / ulp \002,/\002 5 = 0 if W same no matter if VR or VL " "computed,\002,\002 1/ulp otherwise\002,/\002 6 = 0 if VR same no" " matter if VL computed,\002,\002 1/ulp otherwise\002,/\002 7 = " "0 if VL same no matter if VR computed,\002,\002 1/ulp otherwis" "e\002,/)"; static char fmt_9994[] = "(\002 N=\002,i5,\002, IWK=\002,i2,\002, seed" "=\002,4(i4,\002,\002),\002 type \002,i2,\002, test(\002,i2,\002)=" "\002,g10.3)"; /* System generated locals */ integer a_dim1, a_offset, h_dim1, h_offset, lre_dim1, lre_offset, vl_dim1, vl_offset, vr_dim1, vr_offset, i__1, i__2, i__3, i__4, i__5, i__6; doublereal d__1, d__2, d__3, d__4, d__5; doublecomplex z__1; /* Builtin functions Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen); double sqrt(doublereal); integer s_wsfe(cilist *), do_fio(integer *, char *, ftnlen), e_wsfe(void); double z_abs(doublecomplex *), d_imag(doublecomplex *); /* Local variables */ static doublereal cond; static integer jcol; static char path[3]; static integer nmax; static doublereal unfl, ovfl, tnrm, vrmx, vtst; static integer j, n; static logical badnn; static integer nfail, imode, iinfo; static doublereal conds, anorm; extern /* Subroutine */ int zget22_(char *, char *, char *, integer *, doublecomplex *, integer *, doublecomplex *, integer *, doublecomplex *, doublecomplex *, doublereal *, doublereal *), zgeev_(char *, char *, integer *, doublecomplex *, integer *, doublecomplex *, doublecomplex *, integer *, doublecomplex *, integer *, doublecomplex *, integer *, doublereal *, integer *); static integer jsize, nerrs, itype, jtype, ntest; static doublereal rtulp; extern /* Subroutine */ int dlabad_(doublereal *, doublereal *); extern doublereal dznrm2_(integer *, doublecomplex *, integer *); static integer jj; extern doublereal dlamch_(char *); static integer idumma[1]; extern /* Subroutine */ int xerbla_(char *, integer *); static integer ioldsd[4]; extern /* Subroutine */ int dlasum_(char *, integer *, integer *, integer *), zlatme_(integer *, char *, integer *, doublecomplex *, integer *, doublereal *, doublecomplex *, char *, char *, char *, char *, doublereal *, integer *, doublereal *, integer *, integer *, doublereal *, doublecomplex *, integer *, doublecomplex *, integer *), zlacpy_(char *, integer *, integer *, doublecomplex *, integer *, doublecomplex *, integer *); static integer ntestf; extern /* Subroutine */ int zlaset_(char *, integer *, integer *, doublecomplex *, doublecomplex *, doublecomplex *, integer *), zlatmr_(integer *, integer *, char *, integer *, char *, doublecomplex *, integer *, doublereal *, doublecomplex *, char *, char *, doublecomplex *, integer *, doublereal *, doublecomplex * , integer *, doublereal *, char *, integer *, integer *, integer * , doublereal *, doublereal *, char *, doublecomplex *, integer *, integer *, integer *), zlatms_(integer *, integer *, char *, integer *, char *, doublereal *, integer *, doublereal *, doublereal *, integer *, integer *, char *, doublecomplex *, integer *, doublecomplex *, integer *); static doublereal ulpinv; static integer nnwork, mtypes, ntestt; static doublereal rtulpi; static doublecomplex dum[1]; static doublereal res[2]; static integer iwk; static doublereal ulp, vmx; /* Fortran I/O blocks */ static cilist io___31 = { 0, 0, 0, fmt_9993, 0 }; static cilist io___34 = { 0, 0, 0, fmt_9993, 0 }; static cilist io___42 = { 0, 0, 0, fmt_9993, 0 }; static cilist io___43 = { 0, 0, 0, fmt_9993, 0 }; static cilist io___44 = { 0, 0, 0, fmt_9993, 0 }; static cilist io___47 = { 0, 0, 0, fmt_9999, 0 }; static cilist io___48 = { 0, 0, 0, fmt_9998, 0 }; static cilist io___49 = { 0, 0, 0, fmt_9997, 0 }; static cilist io___50 = { 0, 0, 0, fmt_9996, 0 }; static cilist io___51 = { 0, 0, 0, fmt_9995, 0 }; static cilist io___52 = { 0, 0, 0, fmt_9994, 0 }; #define a_subscr(a_1,a_2) (a_2)*a_dim1 + a_1 #define a_ref(a_1,a_2) a[a_subscr(a_1,a_2)] #define vl_subscr(a_1,a_2) (a_2)*vl_dim1 + a_1 #define vl_ref(a_1,a_2) vl[vl_subscr(a_1,a_2)] #define vr_subscr(a_1,a_2) (a_2)*vr_dim1 + a_1 #define vr_ref(a_1,a_2) vr[vr_subscr(a_1,a_2)] #define lre_subscr(a_1,a_2) (a_2)*lre_dim1 + a_1 #define lre_ref(a_1,a_2) lre[lre_subscr(a_1,a_2)] /* -- LAPACK test routine (version 3.0) -- Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., Courant Institute, Argonne National Lab, and Rice University September 30, 1994 Purpose ======= ZDRVEV checks the nonsymmetric eigenvalue problem driver ZGEEV. When ZDRVEV is called, a number of matrix "sizes" ("n's") and a number of matrix "types" are specified. For each size ("n") and each type of matrix, one matrix will be generated and used to test the nonsymmetric eigenroutines. For each matrix, 7 tests will be performed: (1) | A * VR - VR * W | / ( n |A| ulp ) Here VR is the matrix of unit right eigenvectors. W is a diagonal matrix with diagonal entries W(j). (2) | A**H * VL - VL * W**H | / ( n |A| ulp ) Here VL is the matrix of unit left eigenvectors, A**H is the conjugate-transpose of A, and W is as above. (3) | |VR(i)| - 1 | / ulp and whether largest component real VR(i) denotes the i-th column of VR. (4) | |VL(i)| - 1 | / ulp and whether largest component real VL(i) denotes the i-th column of VL. (5) W(full) = W(partial) W(full) denotes the eigenvalues computed when both VR and VL are also computed, and W(partial) denotes the eigenvalues computed when only W, only W and VR, or only W and VL are computed. (6) VR(full) = VR(partial) VR(full) denotes the right eigenvectors computed when both VR and VL are computed, and VR(partial) denotes the result when only VR is computed. (7) VL(full) = VL(partial) VL(full) denotes the left eigenvectors computed when both VR and VL are also computed, and VL(partial) denotes the result when only VL is computed. The "sizes" are specified by an array NN(1:NSIZES); the value of each element NN(j) specifies one size. The "types" are specified by a logical array DOTYPE( 1:NTYPES ); if DOTYPE(j) is .TRUE., then matrix type "j" will be generated. Currently, the list of possible types is: (1) The zero matrix. (2) The identity matrix. (3) A (transposed) Jordan block, with 1's on the diagonal. (4) A diagonal matrix with evenly spaced entries 1, ..., ULP and random complex angles. (ULP = (first number larger than 1) - 1 ) (5) A diagonal matrix with geometrically spaced entries 1, ..., ULP and random complex angles. (6) A diagonal matrix with "clustered" entries 1, ULP, ..., ULP and random complex angles. (7) Same as (4), but multiplied by a constant near the overflow threshold (8) Same as (4), but multiplied by a constant near the underflow threshold (9) A matrix of the form U' T U, where U is unitary and T has evenly spaced entries 1, ..., ULP with random complex angles on the diagonal and random O(1) entries in the upper triangle. (10) A matrix of the form U' T U, where U is unitary and T has geometrically spaced entries 1, ..., ULP with random complex angles on the diagonal and random O(1) entries in the upper triangle. (11) A matrix of the form U' T U, where U is unitary and T has "clustered" entries 1, ULP,..., ULP with random complex angles on the diagonal and random O(1) entries in the upper triangle. (12) A matrix of the form U' T U, where U is unitary and T has complex eigenvalues randomly chosen from ULP < |z| < 1 and random O(1) entries in the upper triangle. (13) A matrix of the form X' T X, where X has condition SQRT( ULP ) and T has evenly spaced entries 1, ..., ULP with random complex angles on the diagonal and random O(1) entries in the upper triangle. (14) A matrix of the form X' T X, where X has condition SQRT( ULP ) and T has geometrically spaced entries 1, ..., ULP with random complex angles on the diagonal and random O(1) entries in the upper triangle. (15) A matrix of the form X' T X, where X has condition SQRT( ULP ) and T has "clustered" entries 1, ULP,..., ULP with random complex angles on the diagonal and random O(1) entries in the upper triangle. (16) A matrix of the form X' T X, where X has condition SQRT( ULP ) and T has complex eigenvalues randomly chosen from ULP < |z| < 1 and random O(1) entries in the upper triangle. (17) Same as (16), but multiplied by a constant near the overflow threshold (18) Same as (16), but multiplied by a constant near the underflow threshold (19) Nonsymmetric matrix with random entries chosen from |z| < 1 If N is at least 4, all entries in first two rows and last row, and first column and last two columns are zero. (20) Same as (19), but multiplied by a constant near the overflow threshold (21) Same as (19), but multiplied by a constant near the underflow threshold Arguments ========== NSIZES (input) INTEGER The number of sizes of matrices to use. If it is zero, ZDRVEV does nothing. It must be at least zero. NN (input) INTEGER array, dimension (NSIZES) An array containing the sizes to be used for the matrices. Zero values will be skipped. The values must be at least zero. NTYPES (input) INTEGER The number of elements in DOTYPE. If it is zero, ZDRVEV does nothing. It must be at least zero. If it is MAXTYP+1 and NSIZES is 1, then an additional type, MAXTYP+1 is defined, which is to use whatever matrix is in A. This is only useful if DOTYPE(1:MAXTYP) is .FALSE. and DOTYPE(MAXTYP+1) is .TRUE. . DOTYPE (input) LOGICAL array, dimension (NTYPES) If DOTYPE(j) is .TRUE., then for each size in NN a matrix of that size and of type j will be generated. If NTYPES is smaller than the maximum number of types defined (PARAMETER MAXTYP), then types NTYPES+1 through MAXTYP will not be generated. If NTYPES is larger than MAXTYP, DOTYPE(MAXTYP+1) through DOTYPE(NTYPES) will be ignored. ISEED (input/output) INTEGER array, dimension (4) On entry ISEED specifies the seed of the random number generator. The array elements should be between 0 and 4095; if not they will be reduced mod 4096. Also, ISEED(4) must be odd. The random number generator uses a linear congruential sequence limited to small integers, and so should produce machine independent random numbers. The values of ISEED are changed on exit, and can be used in the next call to ZDRVEV to continue the same random number sequence. THRESH (input) DOUBLE PRECISION A test will count as "failed" if the "error", computed as described above, exceeds THRESH. Note that the error is scaled to be O(1), so THRESH should be a reasonably small multiple of 1, e.g., 10 or 100. In particular, it should not depend on the precision (single vs. double) or the size of the matrix. It must be at least zero. NOUNIT (input) INTEGER The FORTRAN unit number for printing out error messages (e.g., if a routine returns INFO not equal to 0.) A (workspace) COMPLEX*16 array, dimension (LDA, max(NN)) Used to hold the matrix whose eigenvalues are to be computed. On exit, A contains the last matrix actually used. LDA (input) INTEGER The leading dimension of A, and H. LDA must be at least 1 and at least max(NN). H (workspace) COMPLEX*16 array, dimension (LDA, max(NN)) Another copy of the test matrix A, modified by ZGEEV. W (workspace) COMPLEX*16 array, dimension (max(NN)) The eigenvalues of A. On exit, W are the eigenvalues of the matrix in A. W1 (workspace) COMPLEX*16 array, dimension (max(NN)) Like W, this array contains the eigenvalues of A, but those computed when ZGEEV only computes a partial eigendecomposition, i.e. not the eigenvalues and left and right eigenvectors. VL (workspace) COMPLEX*16 array, dimension (LDVL, max(NN)) VL holds the computed left eigenvectors. LDVL (input) INTEGER Leading dimension of VL. Must be at least max(1,max(NN)). VR (workspace) COMPLEX*16 array, dimension (LDVR, max(NN)) VR holds the computed right eigenvectors. LDVR (input) INTEGER Leading dimension of VR. Must be at least max(1,max(NN)). LRE (workspace) COMPLEX*16 array, dimension (LDLRE, max(NN)) LRE holds the computed right or left eigenvectors. LDLRE (input) INTEGER Leading dimension of LRE. Must be at least max(1,max(NN)). RESULT (output) DOUBLE PRECISION array, dimension (7) The values computed by the seven tests described above. The values are currently limited to 1/ulp, to avoid overflow. WORK (workspace) COMPLEX*16 array, dimension (NWORK) NWORK (input) INTEGER The number of entries in WORK. This must be at least 5*NN(j)+2*NN(j)**2 for all j. RWORK (workspace) DOUBLE PRECISION array, dimension (2*max(NN)) IWORK (workspace) INTEGER array, dimension (max(NN)) INFO (output) INTEGER If 0, then everything ran OK. -1: NSIZES < 0 -2: Some NN(j) < 0 -3: NTYPES < 0 -6: THRESH < 0 -9: LDA < 1 or LDA < NMAX, where NMAX is max( NN(j) ). -14: LDVL < 1 or LDVL < NMAX, where NMAX is max( NN(j) ). -16: LDVR < 1 or LDVR < NMAX, where NMAX is max( NN(j) ). -18: LDLRE < 1 or LDLRE < NMAX, where NMAX is max( NN(j) ). -21: NWORK too small. If ZLATMR, CLATMS, CLATME or ZGEEV returns an error code, the absolute value of it is returned. ----------------------------------------------------------------------- Some Local Variables and Parameters: ---- ----- --------- --- ---------- ZERO, ONE Real 0 and 1. MAXTYP The number of types defined. NMAX Largest value in NN. NERRS The number of tests which have exceeded THRESH COND, CONDS, IMODE Values to be passed to the matrix generators. ANORM Norm of A; passed to matrix generators. OVFL, UNFL Overflow and underflow thresholds. ULP, ULPINV Finest relative precision and its inverse. RTULP, RTULPI Square roots of the previous 4 values. The following four arrays decode JTYPE: KTYPE(j) The general type (1-10) for type "j". KMODE(j) The MODE value to be passed to the matrix generator for type "j". KMAGN(j) The order of magnitude ( O(1), O(overflow^(1/2) ), O(underflow^(1/2) ) KCONDS(j) Selectw whether CONDS is to be 1 or 1/sqrt(ulp). (0 means irrelevant.) ===================================================================== Parameter adjustments */ --nn; --dotype; --iseed; h_dim1 = *lda; h_offset = 1 + h_dim1 * 1; h__ -= h_offset; a_dim1 = *lda; a_offset = 1 + a_dim1 * 1; a -= a_offset; --w; --w1; vl_dim1 = *ldvl; vl_offset = 1 + vl_dim1 * 1; vl -= vl_offset; vr_dim1 = *ldvr; vr_offset = 1 + vr_dim1 * 1; vr -= vr_offset; lre_dim1 = *ldlre; lre_offset = 1 + lre_dim1 * 1; lre -= lre_offset; --result; --work; --rwork; --iwork; /* Function Body */ s_copy(path, "Zomplex precision", (ftnlen)1, (ftnlen)17); s_copy(path + 1, "EV", (ftnlen)2, (ftnlen)2); /* Check for errors */ ntestt = 0; ntestf = 0; *info = 0; /* Important constants */ badnn = FALSE_; nmax = 0; i__1 = *nsizes; for (j = 1; j <= i__1; ++j) { /* Computing MAX */ i__2 = nmax, i__3 = nn[j]; nmax = max(i__2,i__3); if (nn[j] < 0) { badnn = TRUE_; } /* L10: */ } /* Check for errors */ if (*nsizes < 0) { *info = -1; } else if (badnn) { *info = -2; } else if (*ntypes < 0) { *info = -3; } else if (*thresh < 0.) { *info = -6; } else if (*nounit <= 0) { *info = -7; } else if (*lda < 1 || *lda < nmax) { *info = -9; } else if (*ldvl < 1 || *ldvl < nmax) { *info = -14; } else if (*ldvr < 1 || *ldvr < nmax) { *info = -16; } else if (*ldlre < 1 || *ldlre < nmax) { *info = -28; } else /* if(complicated condition) */ { /* Computing 2nd power */ i__1 = nmax; if (nmax * 5 + (i__1 * i__1 << 1) > *nwork) { *info = -21; } } if (*info != 0) { i__1 = -(*info); xerbla_("ZDRVEV", &i__1); return 0; } /* Quick return if nothing to do */ if (*nsizes == 0 || *ntypes == 0) { return 0; } /* More Important constants */ unfl = dlamch_("Safe minimum"); ovfl = 1. / unfl; dlabad_(&unfl, &ovfl); ulp = dlamch_("Precision"); ulpinv = 1. / ulp; rtulp = sqrt(ulp); rtulpi = 1. / rtulp; /* Loop over sizes, types */ nerrs = 0; i__1 = *nsizes; for (jsize = 1; jsize <= i__1; ++jsize) { n = nn[jsize]; if (*nsizes != 1) { mtypes = min(21,*ntypes); } else { mtypes = min(22,*ntypes); } i__2 = mtypes; for (jtype = 1; jtype <= i__2; ++jtype) { if (! dotype[jtype]) { goto L260; } /* Save ISEED in case of an error. */ for (j = 1; j <= 4; ++j) { ioldsd[j - 1] = iseed[j]; /* L20: */ } /* Compute "A" Control parameters: KMAGN KCONDS KMODE KTYPE =1 O(1) 1 clustered 1 zero =2 large large clustered 2 identity =3 small exponential Jordan =4 arithmetic diagonal, (w/ eigenvalues) =5 random log symmetric, w/ eigenvalues =6 random general, w/ eigenvalues =7 random diagonal =8 random symmetric =9 random general =10 random triangular */ if (mtypes > 21) { goto L90; } itype = ktype[jtype - 1]; imode = kmode[jtype - 1]; /* Compute norm */ switch (kmagn[jtype - 1]) { case 1: goto L30; case 2: goto L40; case 3: goto L50; } L30: anorm = 1.; goto L60; L40: anorm = ovfl * ulp; goto L60; L50: anorm = unfl * ulpinv; goto L60; L60: zlaset_("Full", lda, &n, &c_b1, &c_b1, &a[a_offset], lda); iinfo = 0; cond = ulpinv; /* Special Matrices -- Identity & Jordan block Zero */ if (itype == 1) { iinfo = 0; } else if (itype == 2) { /* Identity */ i__3 = n; for (jcol = 1; jcol <= i__3; ++jcol) { i__4 = a_subscr(jcol, jcol); z__1.r = anorm, z__1.i = 0.; a[i__4].r = z__1.r, a[i__4].i = z__1.i; /* L70: */ } } else if (itype == 3) { /* Jordan Block */ i__3 = n; for (jcol = 1; jcol <= i__3; ++jcol) { i__4 = a_subscr(jcol, jcol); z__1.r = anorm, z__1.i = 0.; a[i__4].r = z__1.r, a[i__4].i = z__1.i; if (jcol > 1) { i__4 = a_subscr(jcol, jcol - 1); a[i__4].r = 1., a[i__4].i = 0.; } /* L80: */ } } else if (itype == 4) { /* Diagonal Matrix, [Eigen]values Specified */ zlatms_(&n, &n, "S", &iseed[1], "H", &rwork[1], &imode, &cond, &anorm, &c__0, &c__0, "N", &a[a_offset], lda, &work[ n + 1], &iinfo); } else if (itype == 5) { /* Hermitian, eigenvalues specified */ zlatms_(&n, &n, "S", &iseed[1], "H", &rwork[1], &imode, &cond, &anorm, &n, &n, "N", &a[a_offset], lda, &work[n + 1], &iinfo); } else if (itype == 6) { /* General, eigenvalues specified */ if (kconds[jtype - 1] == 1) { conds = 1.; } else if (kconds[jtype - 1] == 2) { conds = rtulpi; } else { conds = 0.; } zlatme_(&n, "D", &iseed[1], &work[1], &imode, &cond, &c_b2, " ", "T", "T", "T", &rwork[1], &c__4, &conds, &n, &n, &anorm, &a[a_offset], lda, &work[(n << 1) + 1], & iinfo); } else if (itype == 7) { /* Diagonal, random eigenvalues */ zlatmr_(&n, &n, "D", &iseed[1], "N", &work[1], &c__6, &c_b38, &c_b2, "T", "N", &work[n + 1], &c__1, &c_b38, &work[( n << 1) + 1], &c__1, &c_b38, "N", idumma, &c__0, & c__0, &c_b48, &anorm, "NO", &a[a_offset], lda, &iwork[ 1], &iinfo); } else if (itype == 8) { /* Symmetric, random eigenvalues */ zlatmr_(&n, &n, "D", &iseed[1], "H", &work[1], &c__6, &c_b38, &c_b2, "T", "N", &work[n + 1], &c__1, &c_b38, &work[( n << 1) + 1], &c__1, &c_b38, "N", idumma, &n, &n, & c_b48, &anorm, "NO", &a[a_offset], lda, &iwork[1], & iinfo); } else if (itype == 9) { /* General, random eigenvalues */ zlatmr_(&n, &n, "D", &iseed[1], "N", &work[1], &c__6, &c_b38, &c_b2, "T", "N", &work[n + 1], &c__1, &c_b38, &work[( n << 1) + 1], &c__1, &c_b38, "N", idumma, &n, &n, & c_b48, &anorm, "NO", &a[a_offset], lda, &iwork[1], & iinfo); if (n >= 4) { zlaset_("Full", &c__2, &n, &c_b1, &c_b1, &a[a_offset], lda); i__3 = n - 3; zlaset_("Full", &i__3, &c__1, &c_b1, &c_b1, &a_ref(3, 1), lda); i__3 = n - 3; zlaset_("Full", &i__3, &c__2, &c_b1, &c_b1, &a_ref(3, n - 1), lda); zlaset_("Full", &c__1, &n, &c_b1, &c_b1, &a_ref(n, 1), lda); } } else if (itype == 10) { /* Triangular, random eigenvalues */ zlatmr_(&n, &n, "D", &iseed[1], "N", &work[1], &c__6, &c_b38, &c_b2, "T", "N", &work[n + 1], &c__1, &c_b38, &work[( n << 1) + 1], &c__1, &c_b38, "N", idumma, &n, &c__0, & c_b48, &anorm, "NO", &a[a_offset], lda, &iwork[1], & iinfo); } else { iinfo = 1; } if (iinfo != 0) { io___31.ciunit = *nounit; s_wsfe(&io___31); do_fio(&c__1, "Generator", (ftnlen)9); do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer)); do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer)); do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer)); do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer)); e_wsfe(); *info = abs(iinfo); return 0; } L90: /* Test for minimal and generous workspace */ for (iwk = 1; iwk <= 2; ++iwk) { if (iwk == 1) { nnwork = n << 1; } else { /* Computing 2nd power */ i__3 = n; nnwork = n * 5 + (i__3 * i__3 << 1); } nnwork = max(nnwork,1); /* Initialize RESULT */ for (j = 1; j <= 7; ++j) { result[j] = -1.; /* L100: */ } /* Compute eigenvalues and eigenvectors, and test them */ zlacpy_("F", &n, &n, &a[a_offset], lda, &h__[h_offset], lda); zgeev_("V", "V", &n, &h__[h_offset], lda, &w[1], &vl[ vl_offset], ldvl, &vr[vr_offset], ldvr, &work[1], & nnwork, &rwork[1], &iinfo); if (iinfo != 0) { result[1] = ulpinv; io___34.ciunit = *nounit; s_wsfe(&io___34); do_fio(&c__1, "ZGEEV1", (ftnlen)6); do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer)); do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer)); do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer)); do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer)) ; e_wsfe(); *info = abs(iinfo); goto L220; } /* Do Test (1) */ zget22_("N", "N", "N", &n, &a[a_offset], lda, &vr[vr_offset], ldvr, &w[1], &work[1], &rwork[1], res); result[1] = res[0]; /* Do Test (2) */ zget22_("C", "N", "C", &n, &a[a_offset], lda, &vl[vl_offset], ldvl, &w[1], &work[1], &rwork[1], res); result[2] = res[0]; /* Do Test (3) */ i__3 = n; for (j = 1; j <= i__3; ++j) { tnrm = dznrm2_(&n, &vr_ref(1, j), &c__1); /* Computing MAX Computing MIN */ d__4 = ulpinv, d__5 = (d__1 = tnrm - 1., abs(d__1)) / ulp; d__2 = result[3], d__3 = min(d__4,d__5); result[3] = max(d__2,d__3); vmx = 0.; vrmx = 0.; i__4 = n; for (jj = 1; jj <= i__4; ++jj) { vtst = z_abs(&vr_ref(jj, j)); if (vtst > vmx) { vmx = vtst; } i__5 = vr_subscr(jj, j); if (d_imag(&vr_ref(jj, j)) == 0. && (d__1 = vr[i__5] .r, abs(d__1)) > vrmx) { i__6 = vr_subscr(jj, j); vrmx = (d__2 = vr[i__6].r, abs(d__2)); } /* L110: */ } if (vrmx / vmx < 1. - ulp * 2.) { result[3] = ulpinv; } /* L120: */ } /* Do Test (4) */ i__3 = n; for (j = 1; j <= i__3; ++j) { tnrm = dznrm2_(&n, &vl_ref(1, j), &c__1); /* Computing MAX Computing MIN */ d__4 = ulpinv, d__5 = (d__1 = tnrm - 1., abs(d__1)) / ulp; d__2 = result[4], d__3 = min(d__4,d__5); result[4] = max(d__2,d__3); vmx = 0.; vrmx = 0.; i__4 = n; for (jj = 1; jj <= i__4; ++jj) { vtst = z_abs(&vl_ref(jj, j)); if (vtst > vmx) { vmx = vtst; } i__5 = vl_subscr(jj, j); if (d_imag(&vl_ref(jj, j)) == 0. && (d__1 = vl[i__5] .r, abs(d__1)) > vrmx) { i__6 = vl_subscr(jj, j); vrmx = (d__2 = vl[i__6].r, abs(d__2)); } /* L130: */ } if (vrmx / vmx < 1. - ulp * 2.) { result[4] = ulpinv; } /* L140: */ } /* Compute eigenvalues only, and test them */ zlacpy_("F", &n, &n, &a[a_offset], lda, &h__[h_offset], lda); zgeev_("N", "N", &n, &h__[h_offset], lda, &w1[1], dum, &c__1, dum, &c__1, &work[1], &nnwork, &rwork[1], &iinfo); if (iinfo != 0) { result[1] = ulpinv; io___42.ciunit = *nounit; s_wsfe(&io___42); do_fio(&c__1, "ZGEEV2", (ftnlen)6); do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer)); do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer)); do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer)); do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer)) ; e_wsfe(); *info = abs(iinfo); goto L220; } /* Do Test (5) */ i__3 = n; for (j = 1; j <= i__3; ++j) { i__4 = j; i__5 = j; if (w[i__4].r != w1[i__5].r || w[i__4].i != w1[i__5].i) { result[5] = ulpinv; } /* L150: */ } /* Compute eigenvalues and right eigenvectors, and test them */ zlacpy_("F", &n, &n, &a[a_offset], lda, &h__[h_offset], lda); zgeev_("N", "V", &n, &h__[h_offset], lda, &w1[1], dum, &c__1, &lre[lre_offset], ldlre, &work[1], &nnwork, &rwork[1], &iinfo); if (iinfo != 0) { result[1] = ulpinv; io___43.ciunit = *nounit; s_wsfe(&io___43); do_fio(&c__1, "ZGEEV3", (ftnlen)6); do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer)); do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer)); do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer)); do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer)) ; e_wsfe(); *info = abs(iinfo); goto L220; } /* Do Test (5) again */ i__3 = n; for (j = 1; j <= i__3; ++j) { i__4 = j; i__5 = j; if (w[i__4].r != w1[i__5].r || w[i__4].i != w1[i__5].i) { result[5] = ulpinv; } /* L160: */ } /* Do Test (6) */ i__3 = n; for (j = 1; j <= i__3; ++j) { i__4 = n; for (jj = 1; jj <= i__4; ++jj) { i__5 = vr_subscr(j, jj); i__6 = lre_subscr(j, jj); if (vr[i__5].r != lre[i__6].r || vr[i__5].i != lre[ i__6].i) { result[6] = ulpinv; } /* L170: */ } /* L180: */ } /* Compute eigenvalues and left eigenvectors, and test them */ zlacpy_("F", &n, &n, &a[a_offset], lda, &h__[h_offset], lda); zgeev_("V", "N", &n, &h__[h_offset], lda, &w1[1], &lre[ lre_offset], ldlre, dum, &c__1, &work[1], &nnwork, & rwork[1], &iinfo); if (iinfo != 0) { result[1] = ulpinv; io___44.ciunit = *nounit; s_wsfe(&io___44); do_fio(&c__1, "ZGEEV4", (ftnlen)6); do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer)); do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer)); do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer)); do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer)) ; e_wsfe(); *info = abs(iinfo); goto L220; } /* Do Test (5) again */ i__3 = n; for (j = 1; j <= i__3; ++j) { i__4 = j; i__5 = j; if (w[i__4].r != w1[i__5].r || w[i__4].i != w1[i__5].i) { result[5] = ulpinv; } /* L190: */ } /* Do Test (7) */ i__3 = n; for (j = 1; j <= i__3; ++j) { i__4 = n; for (jj = 1; jj <= i__4; ++jj) { i__5 = vl_subscr(j, jj); i__6 = lre_subscr(j, jj); if (vl[i__5].r != lre[i__6].r || vl[i__5].i != lre[ i__6].i) { result[7] = ulpinv; } /* L200: */ } /* L210: */ } /* End of Loop -- Check for RESULT(j) > THRESH */ L220: ntest = 0; nfail = 0; for (j = 1; j <= 7; ++j) { if (result[j] >= 0.) { ++ntest; } if (result[j] >= *thresh) { ++nfail; } /* L230: */ } if (nfail > 0) { ++ntestf; } if (ntestf == 1) { io___47.ciunit = *nounit; s_wsfe(&io___47); do_fio(&c__1, path, (ftnlen)3); e_wsfe(); io___48.ciunit = *nounit; s_wsfe(&io___48); e_wsfe(); io___49.ciunit = *nounit; s_wsfe(&io___49); e_wsfe(); io___50.ciunit = *nounit; s_wsfe(&io___50); e_wsfe(); io___51.ciunit = *nounit; s_wsfe(&io___51); do_fio(&c__1, (char *)&(*thresh), (ftnlen)sizeof( doublereal)); e_wsfe(); ntestf = 2; } for (j = 1; j <= 7; ++j) { if (result[j] >= *thresh) { io___52.ciunit = *nounit; s_wsfe(&io___52); do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer)); do_fio(&c__1, (char *)&iwk, (ftnlen)sizeof(integer)); do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof( integer)); do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer)) ; do_fio(&c__1, (char *)&j, (ftnlen)sizeof(integer)); do_fio(&c__1, (char *)&result[j], (ftnlen)sizeof( doublereal)); e_wsfe(); } /* L240: */ } nerrs += nfail; ntestt += ntest; /* L250: */ } L260: ; } /* L270: */ } /* Summary */ dlasum_(path, nounit, &nerrs, &ntestt); return 0; /* End of ZDRVEV */ } /* zdrvev_ */
/* Subroutine */ int zget23_(logical *comp, integer *isrt, char *balanc, integer *jtype, doublereal *thresh, integer *iseed, integer *nounit, integer *n, doublecomplex *a, integer *lda, doublecomplex *h__, doublecomplex *w, doublecomplex *w1, doublecomplex *vl, integer *ldvl, doublecomplex *vr, integer *ldvr, doublecomplex *lre, integer *ldlre, doublereal *rcondv, doublereal *rcndv1, doublereal *rcdvin, doublereal *rconde, doublereal *rcnde1, doublereal *rcdein, doublereal *scale, doublereal *scale1, doublereal *result, doublecomplex *work, integer *lwork, doublereal *rwork, integer *info) { /* Initialized data */ static char sens[1*2] = "N" "V"; /* Format strings */ static char fmt_9998[] = "(\002 ZGET23: \002,a,\002 returned INFO=\002,i" "6,\002.\002,/9x,\002N=\002,i6,\002, JTYPE=\002,i6,\002, BALANC = " "\002,a,\002, ISEED=(\002,3(i5,\002,\002),i5,\002)\002)"; static char fmt_9999[] = "(\002 ZGET23: \002,a,\002 returned INFO=\002,i" "6,\002.\002,/9x,\002N=\002,i6,\002, INPUT EXAMPLE NUMBER = \002," "i4)"; /* System generated locals */ integer a_dim1, a_offset, h_dim1, h_offset, lre_dim1, lre_offset, vl_dim1, vl_offset, vr_dim1, vr_offset, i__1, i__2, i__3, i__4, i__5; doublereal d__1, d__2, d__3, d__4, d__5; /* Builtin functions */ integer s_wsfe(cilist *), do_fio(integer *, char *, ftnlen), e_wsfe(void); double z_abs(doublecomplex *), d_imag(doublecomplex *); /* Local variables */ static doublecomplex cdum[1]; static integer kmin; static doublecomplex ctmp; static doublereal vmax, tnrm, vrmx, vtst; static integer i__, j; static doublereal v; static logical balok, nobal; static doublereal abnrm; extern logical lsame_(char *, char *); static integer iinfo; static char sense[1]; extern /* Subroutine */ int zget22_(char *, char *, char *, integer *, doublecomplex *, integer *, doublecomplex *, integer *, doublecomplex *, doublecomplex *, doublereal *, doublereal *); static integer isens; static doublereal tolin, abnrm1; extern doublereal dznrm2_(integer *, doublecomplex *, integer *); static integer jj; extern doublereal dlamch_(char *); extern /* Subroutine */ int xerbla_(char *, integer *); static integer isensm; static doublereal vricmp; extern /* Subroutine */ int zlacpy_(char *, integer *, integer *, doublecomplex *, integer *, doublecomplex *, integer *); static doublereal vrimin; extern /* Subroutine */ int zgeevx_(char *, char *, char *, char *, integer *, doublecomplex *, integer *, doublecomplex *, doublecomplex *, integer *, doublecomplex *, integer *, integer *, integer *, doublereal *, doublereal *, doublereal *, doublereal * , doublecomplex *, integer *, doublereal *, integer *); static doublereal smlnum, ulpinv; static integer ihi, ilo; static doublereal eps, res[2], tol, ulp, vmx; static integer ihi1, ilo1; /* Fortran I/O blocks */ static cilist io___14 = { 0, 0, 0, fmt_9998, 0 }; static cilist io___15 = { 0, 0, 0, fmt_9999, 0 }; static cilist io___28 = { 0, 0, 0, fmt_9998, 0 }; static cilist io___29 = { 0, 0, 0, fmt_9999, 0 }; static cilist io___30 = { 0, 0, 0, fmt_9998, 0 }; static cilist io___31 = { 0, 0, 0, fmt_9999, 0 }; static cilist io___32 = { 0, 0, 0, fmt_9998, 0 }; static cilist io___33 = { 0, 0, 0, fmt_9999, 0 }; static cilist io___34 = { 0, 0, 0, fmt_9999, 0 }; #define vl_subscr(a_1,a_2) (a_2)*vl_dim1 + a_1 #define vl_ref(a_1,a_2) vl[vl_subscr(a_1,a_2)] #define vr_subscr(a_1,a_2) (a_2)*vr_dim1 + a_1 #define vr_ref(a_1,a_2) vr[vr_subscr(a_1,a_2)] #define lre_subscr(a_1,a_2) (a_2)*lre_dim1 + a_1 #define lre_ref(a_1,a_2) lre[lre_subscr(a_1,a_2)] /* -- LAPACK test routine (version 3.0) -- Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., Courant Institute, Argonne National Lab, and Rice University September 30, 1994 Purpose ======= ZGET23 checks the nonsymmetric eigenvalue problem driver CGEEVX. If COMP = .FALSE., the first 8 of the following tests will be performed on the input matrix A, and also test 9 if LWORK is sufficiently large. if COMP is .TRUE. all 11 tests will be performed. (1) | A * VR - VR * W | / ( n |A| ulp ) Here VR is the matrix of unit right eigenvectors. W is a diagonal matrix with diagonal entries W(j). (2) | A**H * VL - VL * W**H | / ( n |A| ulp ) Here VL is the matrix of unit left eigenvectors, A**H is the conjugate transpose of A, and W is as above. (3) | |VR(i)| - 1 | / ulp and largest component real VR(i) denotes the i-th column of VR. (4) | |VL(i)| - 1 | / ulp and largest component real VL(i) denotes the i-th column of VL. (5) 0 if W(full) = W(partial), 1/ulp otherwise W(full) denotes the eigenvalues computed when VR, VL, RCONDV and RCONDE are also computed, and W(partial) denotes the eigenvalues computed when only some of VR, VL, RCONDV, and RCONDE are computed. (6) 0 if VR(full) = VR(partial), 1/ulp otherwise VR(full) denotes the right eigenvectors computed when VL, RCONDV and RCONDE are computed, and VR(partial) denotes the result when only some of VL and RCONDV are computed. (7) 0 if VL(full) = VL(partial), 1/ulp otherwise VL(full) denotes the left eigenvectors computed when VR, RCONDV and RCONDE are computed, and VL(partial) denotes the result when only some of VR and RCONDV are computed. (8) 0 if SCALE, ILO, IHI, ABNRM (full) = SCALE, ILO, IHI, ABNRM (partial) 1/ulp otherwise SCALE, ILO, IHI and ABNRM describe how the matrix is balanced. (full) is when VR, VL, RCONDE and RCONDV are also computed, and (partial) is when some are not computed. (9) 0 if RCONDV(full) = RCONDV(partial), 1/ulp otherwise RCONDV(full) denotes the reciprocal condition numbers of the right eigenvectors computed when VR, VL and RCONDE are also computed. RCONDV(partial) denotes the reciprocal condition numbers when only some of VR, VL and RCONDE are computed. (10) |RCONDV - RCDVIN| / cond(RCONDV) RCONDV is the reciprocal right eigenvector condition number computed by ZGEEVX and RCDVIN (the precomputed true value) is supplied as input. cond(RCONDV) is the condition number of RCONDV, and takes errors in computing RCONDV into account, so that the resulting quantity should be O(ULP). cond(RCONDV) is essentially given by norm(A)/RCONDE. (11) |RCONDE - RCDEIN| / cond(RCONDE) RCONDE is the reciprocal eigenvalue condition number computed by ZGEEVX and RCDEIN (the precomputed true value) is supplied as input. cond(RCONDE) is the condition number of RCONDE, and takes errors in computing RCONDE into account, so that the resulting quantity should be O(ULP). cond(RCONDE) is essentially given by norm(A)/RCONDV. Arguments ========= COMP (input) LOGICAL COMP describes which input tests to perform: = .FALSE. if the computed condition numbers are not to be tested against RCDVIN and RCDEIN = .TRUE. if they are to be compared ISRT (input) INTEGER If COMP = .TRUE., ISRT indicates in how the eigenvalues corresponding to values in RCDVIN and RCDEIN are ordered: = 0 means the eigenvalues are sorted by increasing real part = 1 means the eigenvalues are sorted by increasing imaginary part If COMP = .FALSE., ISRT is not referenced. BALANC (input) CHARACTER Describes the balancing option to be tested. = 'N' for no permuting or diagonal scaling = 'P' for permuting but no diagonal scaling = 'S' for no permuting but diagonal scaling = 'B' for permuting and diagonal scaling JTYPE (input) INTEGER Type of input matrix. Used to label output if error occurs. THRESH (input) DOUBLE PRECISION A test will count as "failed" if the "error", computed as described above, exceeds THRESH. Note that the error is scaled to be O(1), so THRESH should be a reasonably small multiple of 1, e.g., 10 or 100. In particular, it should not depend on the precision (single vs. double) or the size of the matrix. It must be at least zero. ISEED (input) INTEGER array, dimension (4) If COMP = .FALSE., the random number generator seed used to produce matrix. If COMP = .TRUE., ISEED(1) = the number of the example. Used to label output if error occurs. NOUNIT (input) INTEGER The FORTRAN unit number for printing out error messages (e.g., if a routine returns INFO not equal to 0.) N (input) INTEGER The dimension of A. N must be at least 0. A (input/output) COMPLEX*16 array, dimension (LDA,N) Used to hold the matrix whose eigenvalues are to be computed. LDA (input) INTEGER The leading dimension of A, and H. LDA must be at least 1 and at least N. H (workspace) COMPLEX*16 array, dimension (LDA,N) Another copy of the test matrix A, modified by ZGEEVX. W (workspace) COMPLEX*16 array, dimension (N) Contains the eigenvalues of A. W1 (workspace) COMPLEX*16 array, dimension (N) Like W, this array contains the eigenvalues of A, but those computed when ZGEEVX only computes a partial eigendecomposition, i.e. not the eigenvalues and left and right eigenvectors. VL (workspace) COMPLEX*16 array, dimension (LDVL,N) VL holds the computed left eigenvectors. LDVL (input) INTEGER Leading dimension of VL. Must be at least max(1,N). VR (workspace) COMPLEX*16 array, dimension (LDVR,N) VR holds the computed right eigenvectors. LDVR (input) INTEGER Leading dimension of VR. Must be at least max(1,N). LRE (workspace) COMPLEX*16 array, dimension (LDLRE,N) LRE holds the computed right or left eigenvectors. LDLRE (input) INTEGER Leading dimension of LRE. Must be at least max(1,N). RCONDV (workspace) DOUBLE PRECISION array, dimension (N) RCONDV holds the computed reciprocal condition numbers for eigenvectors. RCNDV1 (workspace) DOUBLE PRECISION array, dimension (N) RCNDV1 holds more computed reciprocal condition numbers for eigenvectors. RCDVIN (input) DOUBLE PRECISION array, dimension (N) When COMP = .TRUE. RCDVIN holds the precomputed reciprocal condition numbers for eigenvectors to be compared with RCONDV. RCONDE (workspace) DOUBLE PRECISION array, dimension (N) RCONDE holds the computed reciprocal condition numbers for eigenvalues. RCNDE1 (workspace) DOUBLE PRECISION array, dimension (N) RCNDE1 holds more computed reciprocal condition numbers for eigenvalues. RCDEIN (input) DOUBLE PRECISION array, dimension (N) When COMP = .TRUE. RCDEIN holds the precomputed reciprocal condition numbers for eigenvalues to be compared with RCONDE. SCALE (workspace) DOUBLE PRECISION array, dimension (N) Holds information describing balancing of matrix. SCALE1 (workspace) DOUBLE PRECISION array, dimension (N) Holds information describing balancing of matrix. RESULT (output) DOUBLE PRECISION array, dimension (11) The values computed by the 11 tests described above. The values are currently limited to 1/ulp, to avoid overflow. WORK (workspace) COMPLEX*16 array, dimension (LWORK) LWORK (input) INTEGER The number of entries in WORK. This must be at least 2*N, and 2*N+N**2 if tests 9, 10 or 11 are to be performed. RWORK (workspace) DOUBLE PRECISION array, dimension (2*N) INFO (output) INTEGER If 0, successful exit. If <0, input parameter -INFO had an incorrect value. If >0, ZGEEVX returned an error code, the absolute value of which is returned. ===================================================================== Parameter adjustments */ --iseed; h_dim1 = *lda; h_offset = 1 + h_dim1 * 1; h__ -= h_offset; a_dim1 = *lda; a_offset = 1 + a_dim1 * 1; a -= a_offset; --w; --w1; vl_dim1 = *ldvl; vl_offset = 1 + vl_dim1 * 1; vl -= vl_offset; vr_dim1 = *ldvr; vr_offset = 1 + vr_dim1 * 1; vr -= vr_offset; lre_dim1 = *ldlre; lre_offset = 1 + lre_dim1 * 1; lre -= lre_offset; --rcondv; --rcndv1; --rcdvin; --rconde; --rcnde1; --rcdein; --scale; --scale1; --result; --work; --rwork; /* Function Body Check for errors */ nobal = lsame_(balanc, "N"); balok = nobal || lsame_(balanc, "P") || lsame_( balanc, "S") || lsame_(balanc, "B"); *info = 0; if (*isrt != 0 && *isrt != 1) { *info = -2; } else if (! balok) { *info = -3; } else if (*thresh < 0.) { *info = -5; } else if (*nounit <= 0) { *info = -7; } else if (*n < 0) { *info = -8; } else if (*lda < 1 || *lda < *n) { *info = -10; } else if (*ldvl < 1 || *ldvl < *n) { *info = -15; } else if (*ldvr < 1 || *ldvr < *n) { *info = -17; } else if (*ldlre < 1 || *ldlre < *n) { *info = -19; } else if (*lwork < *n << 1 || *comp && *lwork < (*n << 1) + *n * *n) { *info = -30; } if (*info != 0) { i__1 = -(*info); xerbla_("ZGET23", &i__1); return 0; } /* Quick return if nothing to do */ for (i__ = 1; i__ <= 11; ++i__) { result[i__] = -1.; /* L10: */ } if (*n == 0) { return 0; } /* More Important constants */ ulp = dlamch_("Precision"); smlnum = dlamch_("S"); ulpinv = 1. / ulp; /* Compute eigenvalues and eigenvectors, and test them */ if (*lwork >= (*n << 1) + *n * *n) { *(unsigned char *)sense = 'B'; isensm = 2; } else { *(unsigned char *)sense = 'E'; isensm = 1; } zlacpy_("F", n, n, &a[a_offset], lda, &h__[h_offset], lda); zgeevx_(balanc, "V", "V", sense, n, &h__[h_offset], lda, &w[1], &vl[ vl_offset], ldvl, &vr[vr_offset], ldvr, &ilo, &ihi, &scale[1], & abnrm, &rconde[1], &rcondv[1], &work[1], lwork, &rwork[1], &iinfo); if (iinfo != 0) { result[1] = ulpinv; if (*jtype != 22) { io___14.ciunit = *nounit; s_wsfe(&io___14); do_fio(&c__1, "ZGEEVX1", (ftnlen)7); do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer)); do_fio(&c__1, (char *)&(*n), (ftnlen)sizeof(integer)); do_fio(&c__1, (char *)&(*jtype), (ftnlen)sizeof(integer)); do_fio(&c__1, balanc, (ftnlen)1); do_fio(&c__4, (char *)&iseed[1], (ftnlen)sizeof(integer)); e_wsfe(); } else { io___15.ciunit = *nounit; s_wsfe(&io___15); do_fio(&c__1, "ZGEEVX1", (ftnlen)7); do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer)); do_fio(&c__1, (char *)&(*n), (ftnlen)sizeof(integer)); do_fio(&c__1, (char *)&iseed[1], (ftnlen)sizeof(integer)); e_wsfe(); } *info = abs(iinfo); return 0; } /* Do Test (1) */ zget22_("N", "N", "N", n, &a[a_offset], lda, &vr[vr_offset], ldvr, &w[1], &work[1], &rwork[1], res); result[1] = res[0]; /* Do Test (2) */ zget22_("C", "N", "C", n, &a[a_offset], lda, &vl[vl_offset], ldvl, &w[1], &work[1], &rwork[1], res); result[2] = res[0]; /* Do Test (3) */ i__1 = *n; for (j = 1; j <= i__1; ++j) { tnrm = dznrm2_(n, &vr_ref(1, j), &c__1); /* Computing MAX Computing MIN */ d__4 = ulpinv, d__5 = (d__1 = tnrm - 1., abs(d__1)) / ulp; d__2 = result[3], d__3 = min(d__4,d__5); result[3] = max(d__2,d__3); vmx = 0.; vrmx = 0.; i__2 = *n; for (jj = 1; jj <= i__2; ++jj) { vtst = z_abs(&vr_ref(jj, j)); if (vtst > vmx) { vmx = vtst; } i__3 = vr_subscr(jj, j); if (d_imag(&vr_ref(jj, j)) == 0. && (d__1 = vr[i__3].r, abs(d__1)) > vrmx) { i__4 = vr_subscr(jj, j); vrmx = (d__2 = vr[i__4].r, abs(d__2)); } /* L20: */ } if (vrmx / vmx < 1. - ulp * 2.) { result[3] = ulpinv; } /* L30: */ } /* Do Test (4) */ i__1 = *n; for (j = 1; j <= i__1; ++j) { tnrm = dznrm2_(n, &vl_ref(1, j), &c__1); /* Computing MAX Computing MIN */ d__4 = ulpinv, d__5 = (d__1 = tnrm - 1., abs(d__1)) / ulp; d__2 = result[4], d__3 = min(d__4,d__5); result[4] = max(d__2,d__3); vmx = 0.; vrmx = 0.; i__2 = *n; for (jj = 1; jj <= i__2; ++jj) { vtst = z_abs(&vl_ref(jj, j)); if (vtst > vmx) { vmx = vtst; } i__3 = vl_subscr(jj, j); if (d_imag(&vl_ref(jj, j)) == 0. && (d__1 = vl[i__3].r, abs(d__1)) > vrmx) { i__4 = vl_subscr(jj, j); vrmx = (d__2 = vl[i__4].r, abs(d__2)); } /* L40: */ } if (vrmx / vmx < 1. - ulp * 2.) { result[4] = ulpinv; } /* L50: */ } /* Test for all options of computing condition numbers */ i__1 = isensm; for (isens = 1; isens <= i__1; ++isens) { *(unsigned char *)sense = *(unsigned char *)&sens[isens - 1]; /* Compute eigenvalues only, and test them */ zlacpy_("F", n, n, &a[a_offset], lda, &h__[h_offset], lda); zgeevx_(balanc, "N", "N", sense, n, &h__[h_offset], lda, &w1[1], cdum, &c__1, cdum, &c__1, &ilo1, &ihi1, &scale1[1], &abnrm1, & rcnde1[1], &rcndv1[1], &work[1], lwork, &rwork[1], &iinfo); if (iinfo != 0) { result[1] = ulpinv; if (*jtype != 22) { io___28.ciunit = *nounit; s_wsfe(&io___28); do_fio(&c__1, "ZGEEVX2", (ftnlen)7); do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer)); do_fio(&c__1, (char *)&(*n), (ftnlen)sizeof(integer)); do_fio(&c__1, (char *)&(*jtype), (ftnlen)sizeof(integer)); do_fio(&c__1, balanc, (ftnlen)1); do_fio(&c__4, (char *)&iseed[1], (ftnlen)sizeof(integer)); e_wsfe(); } else { io___29.ciunit = *nounit; s_wsfe(&io___29); do_fio(&c__1, "ZGEEVX2", (ftnlen)7); do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer)); do_fio(&c__1, (char *)&(*n), (ftnlen)sizeof(integer)); do_fio(&c__1, (char *)&iseed[1], (ftnlen)sizeof(integer)); e_wsfe(); } *info = abs(iinfo); goto L190; } /* Do Test (5) */ i__2 = *n; for (j = 1; j <= i__2; ++j) { i__3 = j; i__4 = j; if (w[i__3].r != w1[i__4].r || w[i__3].i != w1[i__4].i) { result[5] = ulpinv; } /* L60: */ } /* Do Test (8) */ if (! nobal) { i__2 = *n; for (j = 1; j <= i__2; ++j) { if (scale[j] != scale1[j]) { result[8] = ulpinv; } /* L70: */ } if (ilo != ilo1) { result[8] = ulpinv; } if (ihi != ihi1) { result[8] = ulpinv; } if (abnrm != abnrm1) { result[8] = ulpinv; } } /* Do Test (9) */ if (isens == 2 && *n > 1) { i__2 = *n; for (j = 1; j <= i__2; ++j) { if (rcondv[j] != rcndv1[j]) { result[9] = ulpinv; } /* L80: */ } } /* Compute eigenvalues and right eigenvectors, and test them */ zlacpy_("F", n, n, &a[a_offset], lda, &h__[h_offset], lda); zgeevx_(balanc, "N", "V", sense, n, &h__[h_offset], lda, &w1[1], cdum, &c__1, &lre[lre_offset], ldlre, &ilo1, &ihi1, &scale1[1], & abnrm1, &rcnde1[1], &rcndv1[1], &work[1], lwork, &rwork[1], & iinfo); if (iinfo != 0) { result[1] = ulpinv; if (*jtype != 22) { io___30.ciunit = *nounit; s_wsfe(&io___30); do_fio(&c__1, "ZGEEVX3", (ftnlen)7); do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer)); do_fio(&c__1, (char *)&(*n), (ftnlen)sizeof(integer)); do_fio(&c__1, (char *)&(*jtype), (ftnlen)sizeof(integer)); do_fio(&c__1, balanc, (ftnlen)1); do_fio(&c__4, (char *)&iseed[1], (ftnlen)sizeof(integer)); e_wsfe(); } else { io___31.ciunit = *nounit; s_wsfe(&io___31); do_fio(&c__1, "ZGEEVX3", (ftnlen)7); do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer)); do_fio(&c__1, (char *)&(*n), (ftnlen)sizeof(integer)); do_fio(&c__1, (char *)&iseed[1], (ftnlen)sizeof(integer)); e_wsfe(); } *info = abs(iinfo); goto L190; } /* Do Test (5) again */ i__2 = *n; for (j = 1; j <= i__2; ++j) { i__3 = j; i__4 = j; if (w[i__3].r != w1[i__4].r || w[i__3].i != w1[i__4].i) { result[5] = ulpinv; } /* L90: */ } /* Do Test (6) */ i__2 = *n; for (j = 1; j <= i__2; ++j) { i__3 = *n; for (jj = 1; jj <= i__3; ++jj) { i__4 = vr_subscr(j, jj); i__5 = lre_subscr(j, jj); if (vr[i__4].r != lre[i__5].r || vr[i__4].i != lre[i__5].i) { result[6] = ulpinv; } /* L100: */ } /* L110: */ } /* Do Test (8) again */ if (! nobal) { i__2 = *n; for (j = 1; j <= i__2; ++j) { if (scale[j] != scale1[j]) { result[8] = ulpinv; } /* L120: */ } if (ilo != ilo1) { result[8] = ulpinv; } if (ihi != ihi1) { result[8] = ulpinv; } if (abnrm != abnrm1) { result[8] = ulpinv; } } /* Do Test (9) again */ if (isens == 2 && *n > 1) { i__2 = *n; for (j = 1; j <= i__2; ++j) { if (rcondv[j] != rcndv1[j]) { result[9] = ulpinv; } /* L130: */ } } /* Compute eigenvalues and left eigenvectors, and test them */ zlacpy_("F", n, n, &a[a_offset], lda, &h__[h_offset], lda); zgeevx_(balanc, "V", "N", sense, n, &h__[h_offset], lda, &w1[1], &lre[ lre_offset], ldlre, cdum, &c__1, &ilo1, &ihi1, &scale1[1], & abnrm1, &rcnde1[1], &rcndv1[1], &work[1], lwork, &rwork[1], & iinfo); if (iinfo != 0) { result[1] = ulpinv; if (*jtype != 22) { io___32.ciunit = *nounit; s_wsfe(&io___32); do_fio(&c__1, "ZGEEVX4", (ftnlen)7); do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer)); do_fio(&c__1, (char *)&(*n), (ftnlen)sizeof(integer)); do_fio(&c__1, (char *)&(*jtype), (ftnlen)sizeof(integer)); do_fio(&c__1, balanc, (ftnlen)1); do_fio(&c__4, (char *)&iseed[1], (ftnlen)sizeof(integer)); e_wsfe(); } else { io___33.ciunit = *nounit; s_wsfe(&io___33); do_fio(&c__1, "ZGEEVX4", (ftnlen)7); do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer)); do_fio(&c__1, (char *)&(*n), (ftnlen)sizeof(integer)); do_fio(&c__1, (char *)&iseed[1], (ftnlen)sizeof(integer)); e_wsfe(); } *info = abs(iinfo); goto L190; } /* Do Test (5) again */ i__2 = *n; for (j = 1; j <= i__2; ++j) { i__3 = j; i__4 = j; if (w[i__3].r != w1[i__4].r || w[i__3].i != w1[i__4].i) { result[5] = ulpinv; } /* L140: */ } /* Do Test (7) */ i__2 = *n; for (j = 1; j <= i__2; ++j) { i__3 = *n; for (jj = 1; jj <= i__3; ++jj) { i__4 = vl_subscr(j, jj); i__5 = lre_subscr(j, jj); if (vl[i__4].r != lre[i__5].r || vl[i__4].i != lre[i__5].i) { result[7] = ulpinv; } /* L150: */ } /* L160: */ } /* Do Test (8) again */ if (! nobal) { i__2 = *n; for (j = 1; j <= i__2; ++j) { if (scale[j] != scale1[j]) { result[8] = ulpinv; } /* L170: */ } if (ilo != ilo1) { result[8] = ulpinv; } if (ihi != ihi1) { result[8] = ulpinv; } if (abnrm != abnrm1) { result[8] = ulpinv; } } /* Do Test (9) again */ if (isens == 2 && *n > 1) { i__2 = *n; for (j = 1; j <= i__2; ++j) { if (rcondv[j] != rcndv1[j]) { result[9] = ulpinv; } /* L180: */ } } L190: /* L200: */ ; } /* If COMP, compare condition numbers to precomputed ones */ if (*comp) { zlacpy_("F", n, n, &a[a_offset], lda, &h__[h_offset], lda); zgeevx_("N", "V", "V", "B", n, &h__[h_offset], lda, &w[1], &vl[ vl_offset], ldvl, &vr[vr_offset], ldvr, &ilo, &ihi, &scale[1], &abnrm, &rconde[1], &rcondv[1], &work[1], lwork, &rwork[1], & iinfo); if (iinfo != 0) { result[1] = ulpinv; io___34.ciunit = *nounit; s_wsfe(&io___34); do_fio(&c__1, "ZGEEVX5", (ftnlen)7); do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer)); do_fio(&c__1, (char *)&(*n), (ftnlen)sizeof(integer)); do_fio(&c__1, (char *)&iseed[1], (ftnlen)sizeof(integer)); e_wsfe(); *info = abs(iinfo); goto L250; } /* Sort eigenvalues and condition numbers lexicographically to compare with inputs */ i__1 = *n - 1; for (i__ = 1; i__ <= i__1; ++i__) { kmin = i__; if (*isrt == 0) { i__2 = i__; vrimin = w[i__2].r; } else { vrimin = d_imag(&w[i__]); } i__2 = *n; for (j = i__ + 1; j <= i__2; ++j) { if (*isrt == 0) { i__3 = j; vricmp = w[i__3].r; } else { vricmp = d_imag(&w[j]); } if (vricmp < vrimin) { kmin = j; vrimin = vricmp; } /* L210: */ } i__2 = kmin; ctmp.r = w[i__2].r, ctmp.i = w[i__2].i; i__2 = kmin; i__3 = i__; w[i__2].r = w[i__3].r, w[i__2].i = w[i__3].i; i__2 = i__; w[i__2].r = ctmp.r, w[i__2].i = ctmp.i; vrimin = rconde[kmin]; rconde[kmin] = rconde[i__]; rconde[i__] = vrimin; vrimin = rcondv[kmin]; rcondv[kmin] = rcondv[i__]; rcondv[i__] = vrimin; /* L220: */ } /* Compare condition numbers for eigenvectors taking their condition numbers into account */ result[10] = 0.; eps = max(5.9605e-8,ulp); /* Computing MAX */ d__1 = (doublereal) (*n) * eps * abnrm; v = max(d__1,smlnum); if (abnrm == 0.) { v = 1.; } i__1 = *n; for (i__ = 1; i__ <= i__1; ++i__) { if (v > rcondv[i__] * rconde[i__]) { tol = rcondv[i__]; } else { tol = v / rconde[i__]; } if (v > rcdvin[i__] * rcdein[i__]) { tolin = rcdvin[i__]; } else { tolin = v / rcdein[i__]; } /* Computing MAX */ d__1 = tol, d__2 = smlnum / eps; tol = max(d__1,d__2); /* Computing MAX */ d__1 = tolin, d__2 = smlnum / eps; tolin = max(d__1,d__2); if (eps * (rcdvin[i__] - tolin) > rcondv[i__] + tol) { vmax = 1. / eps; } else if (rcdvin[i__] - tolin > rcondv[i__] + tol) { vmax = (rcdvin[i__] - tolin) / (rcondv[i__] + tol); } else if (rcdvin[i__] + tolin < eps * (rcondv[i__] - tol)) { vmax = 1. / eps; } else if (rcdvin[i__] + tolin < rcondv[i__] - tol) { vmax = (rcondv[i__] - tol) / (rcdvin[i__] + tolin); } else { vmax = 1.; } result[10] = max(result[10],vmax); /* L230: */ } /* Compare condition numbers for eigenvalues taking their condition numbers into account */ result[11] = 0.; i__1 = *n; for (i__ = 1; i__ <= i__1; ++i__) { if (v > rcondv[i__]) { tol = 1.; } else { tol = v / rcondv[i__]; } if (v > rcdvin[i__]) { tolin = 1.; } else { tolin = v / rcdvin[i__]; } /* Computing MAX */ d__1 = tol, d__2 = smlnum / eps; tol = max(d__1,d__2); /* Computing MAX */ d__1 = tolin, d__2 = smlnum / eps; tolin = max(d__1,d__2); if (eps * (rcdein[i__] - tolin) > rconde[i__] + tol) { vmax = 1. / eps; } else if (rcdein[i__] - tolin > rconde[i__] + tol) { vmax = (rcdein[i__] - tolin) / (rconde[i__] + tol); } else if (rcdein[i__] + tolin < eps * (rconde[i__] - tol)) { vmax = 1. / eps; } else if (rcdein[i__] + tolin < rconde[i__] - tol) { vmax = (rconde[i__] - tol) / (rcdein[i__] + tolin); } else { vmax = 1.; } result[11] = max(result[11],vmax); /* L240: */ } L250: ; } return 0; /* End of ZGET23 */ } /* zget23_ */
/* Subroutine */ int cggev_(char *jobvl, char *jobvr, integer *n, complex *a, integer *lda, complex *b, integer *ldb, complex *alpha, complex *beta, complex *vl, integer *ldvl, complex *vr, integer *ldvr, complex * work, integer *lwork, real *rwork, integer *info) { /* -- LAPACK driver routine (version 3.0) -- Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., Courant Institute, Argonne National Lab, and Rice University June 30, 1999 Purpose ======= CGGEV computes for a pair of N-by-N complex nonsymmetric matrices (A,B), the generalized eigenvalues, and optionally, the left and/or right generalized eigenvectors. A generalized eigenvalue for a pair of matrices (A,B) is a scalar lambda or a ratio alpha/beta = lambda, such that A - lambda*B is singular. It is usually represented as the pair (alpha,beta), as there is a reasonable interpretation for beta=0, and even for both being zero. The right generalized eigenvector v(j) corresponding to the generalized eigenvalue lambda(j) of (A,B) satisfies A * v(j) = lambda(j) * B * v(j). The left generalized eigenvector u(j) corresponding to the generalized eigenvalues lambda(j) of (A,B) satisfies u(j)**H * A = lambda(j) * u(j)**H * B where u(j)**H is the conjugate-transpose of u(j). Arguments ========= JOBVL (input) CHARACTER*1 = 'N': do not compute the left generalized eigenvectors; = 'V': compute the left generalized eigenvectors. JOBVR (input) CHARACTER*1 = 'N': do not compute the right generalized eigenvectors; = 'V': compute the right generalized eigenvectors. N (input) INTEGER The order of the matrices A, B, VL, and VR. N >= 0. A (input/output) COMPLEX array, dimension (LDA, N) On entry, the matrix A in the pair (A,B). On exit, A has been overwritten. LDA (input) INTEGER The leading dimension of A. LDA >= max(1,N). B (input/output) COMPLEX array, dimension (LDB, N) On entry, the matrix B in the pair (A,B). On exit, B has been overwritten. LDB (input) INTEGER The leading dimension of B. LDB >= max(1,N). ALPHA (output) COMPLEX array, dimension (N) BETA (output) COMPLEX array, dimension (N) On exit, ALPHA(j)/BETA(j), j=1,...,N, will be the generalized eigenvalues. Note: the quotients ALPHA(j)/BETA(j) may easily over- or underflow, and BETA(j) may even be zero. Thus, the user should avoid naively computing the ratio alpha/beta. However, ALPHA will be always less than and usually comparable with norm(A) in magnitude, and BETA always less than and usually comparable with norm(B). VL (output) COMPLEX array, dimension (LDVL,N) If JOBVL = 'V', the left generalized eigenvectors u(j) are stored one after another in the columns of VL, in the same order as their eigenvalues. Each eigenvector will be scaled so the largest component will have abs(real part) + abs(imag. part) = 1. Not referenced if JOBVL = 'N'. LDVL (input) INTEGER The leading dimension of the matrix VL. LDVL >= 1, and if JOBVL = 'V', LDVL >= N. VR (output) COMPLEX array, dimension (LDVR,N) If JOBVR = 'V', the right generalized eigenvectors v(j) are stored one after another in the columns of VR, in the same order as their eigenvalues. Each eigenvector will be scaled so the largest component will have abs(real part) + abs(imag. part) = 1. Not referenced if JOBVR = 'N'. LDVR (input) INTEGER The leading dimension of the matrix VR. LDVR >= 1, and if JOBVR = 'V', LDVR >= N. WORK (workspace/output) COMPLEX array, dimension (LWORK) On exit, if INFO = 0, WORK(1) returns the optimal LWORK. LWORK (input) INTEGER The dimension of the array WORK. LWORK >= max(1,2*N). For good performance, LWORK must generally be larger. If LWORK = -1, then a workspace query is assumed; the routine only calculates the optimal size of the WORK array, returns this value as the first entry of the WORK array, and no error message related to LWORK is issued by XERBLA. RWORK (workspace/output) REAL array, dimension (8*N) INFO (output) INTEGER = 0: successful exit < 0: if INFO = -i, the i-th argument had an illegal value. =1,...,N: The QZ iteration failed. No eigenvectors have been calculated, but ALPHA(j) and BETA(j) should be correct for j=INFO+1,...,N. > N: =N+1: other then QZ iteration failed in SHGEQZ, =N+2: error return from STGEVC. ===================================================================== Decode the input arguments Parameter adjustments */ /* Table of constant values */ static complex c_b1 = {0.f,0.f}; static complex c_b2 = {1.f,0.f}; static integer c__1 = 1; static integer c__0 = 0; /* System generated locals */ integer a_dim1, a_offset, b_dim1, b_offset, vl_dim1, vl_offset, vr_dim1, vr_offset, i__1, i__2, i__3, i__4; real r__1, r__2, r__3, r__4; complex q__1; /* Builtin functions */ double sqrt(doublereal), r_imag(complex *); /* Local variables */ static real anrm, bnrm; static integer ierr, itau; static real temp; static logical ilvl, ilvr; static integer iwrk; extern logical lsame_(char *, char *); static integer ileft, icols, irwrk, irows, jc; extern /* Subroutine */ int cggbak_(char *, char *, integer *, integer *, integer *, real *, real *, integer *, complex *, integer *, integer *), cggbal_(char *, integer *, complex *, integer *, complex *, integer *, integer *, integer *, real *, real *, real *, integer *), slabad_(real *, real *); static integer in; extern doublereal clange_(char *, integer *, integer *, complex *, integer *, real *); static integer jr; extern /* Subroutine */ int cgghrd_(char *, char *, integer *, integer *, integer *, complex *, integer *, complex *, integer *, complex *, integer *, complex *, integer *, integer *), clascl_(char *, integer *, integer *, real *, real *, integer *, integer *, complex *, integer *, integer *); static logical ilascl, ilbscl; extern /* Subroutine */ int cgeqrf_(integer *, integer *, complex *, integer *, complex *, complex *, integer *, integer *), clacpy_( char *, integer *, integer *, complex *, integer *, complex *, integer *), claset_(char *, integer *, integer *, complex *, complex *, complex *, integer *), ctgevc_(char *, char *, logical *, integer *, complex *, integer *, complex *, integer *, complex *, integer *, complex *, integer *, integer *, integer *, complex *, real *, integer *), xerbla_(char *, integer *); static logical ldumma[1]; static char chtemp[1]; static real bignum; extern /* Subroutine */ int chgeqz_(char *, char *, char *, integer *, integer *, integer *, complex *, integer *, complex *, integer *, complex *, complex *, complex *, integer *, complex *, integer *, complex *, integer *, real *, integer *); extern integer ilaenv_(integer *, char *, char *, integer *, integer *, integer *, integer *, ftnlen, ftnlen); extern doublereal slamch_(char *); static integer ijobvl, iright, ijobvr; extern /* Subroutine */ int cungqr_(integer *, integer *, integer *, complex *, integer *, complex *, complex *, integer *, integer *); static real anrmto; static integer lwkmin; static real bnrmto; extern /* Subroutine */ int cunmqr_(char *, char *, integer *, integer *, integer *, complex *, integer *, complex *, complex *, integer *, complex *, integer *, integer *); static real smlnum; static integer lwkopt; static logical lquery; static integer ihi, ilo; static real eps; static logical ilv; #define a_subscr(a_1,a_2) (a_2)*a_dim1 + a_1 #define a_ref(a_1,a_2) a[a_subscr(a_1,a_2)] #define b_subscr(a_1,a_2) (a_2)*b_dim1 + a_1 #define b_ref(a_1,a_2) b[b_subscr(a_1,a_2)] #define vl_subscr(a_1,a_2) (a_2)*vl_dim1 + a_1 #define vl_ref(a_1,a_2) vl[vl_subscr(a_1,a_2)] #define vr_subscr(a_1,a_2) (a_2)*vr_dim1 + a_1 #define vr_ref(a_1,a_2) vr[vr_subscr(a_1,a_2)] a_dim1 = *lda; a_offset = 1 + a_dim1 * 1; a -= a_offset; b_dim1 = *ldb; b_offset = 1 + b_dim1 * 1; b -= b_offset; --alpha; --beta; vl_dim1 = *ldvl; vl_offset = 1 + vl_dim1 * 1; vl -= vl_offset; vr_dim1 = *ldvr; vr_offset = 1 + vr_dim1 * 1; vr -= vr_offset; --work; --rwork; /* Function Body */ if (lsame_(jobvl, "N")) { ijobvl = 1; ilvl = FALSE_; } else if (lsame_(jobvl, "V")) { ijobvl = 2; ilvl = TRUE_; } else { ijobvl = -1; ilvl = FALSE_; } if (lsame_(jobvr, "N")) { ijobvr = 1; ilvr = FALSE_; } else if (lsame_(jobvr, "V")) { ijobvr = 2; ilvr = TRUE_; } else { ijobvr = -1; ilvr = FALSE_; } ilv = ilvl || ilvr; /* Test the input arguments */ *info = 0; lquery = *lwork == -1; if (ijobvl <= 0) { *info = -1; } else if (ijobvr <= 0) { *info = -2; } else if (*n < 0) { *info = -3; } else if (*lda < max(1,*n)) { *info = -5; } else if (*ldb < max(1,*n)) { *info = -7; } else if (*ldvl < 1 || ilvl && *ldvl < *n) { *info = -11; } else if (*ldvr < 1 || ilvr && *ldvr < *n) { *info = -13; } /* Compute workspace (Note: Comments in the code beginning "Workspace:" describe the minimal amount of workspace needed at that point in the code, as well as the preferred amount for good performance. NB refers to the optimal block size for the immediately following subroutine, as returned by ILAENV. The workspace is computed assuming ILO = 1 and IHI = N, the worst case.) */ lwkmin = 1; if (*info == 0 && (*lwork >= 1 || lquery)) { lwkopt = *n + *n * ilaenv_(&c__1, "CGEQRF", " ", n, &c__1, n, &c__0, ( ftnlen)6, (ftnlen)1); /* Computing MAX */ i__1 = 1, i__2 = *n << 1; lwkmin = max(i__1,i__2); work[1].r = (real) lwkopt, work[1].i = 0.f; } if (*lwork < lwkmin && ! lquery) { *info = -15; } if (*info != 0) { i__1 = -(*info); xerbla_("CGGEV ", &i__1); return 0; } else if (lquery) { return 0; } /* Quick return if possible */ work[1].r = (real) lwkopt, work[1].i = 0.f; if (*n == 0) { return 0; } /* Get machine constants */ eps = slamch_("E") * slamch_("B"); smlnum = slamch_("S"); bignum = 1.f / smlnum; slabad_(&smlnum, &bignum); smlnum = sqrt(smlnum) / eps; bignum = 1.f / smlnum; /* Scale A if max element outside range [SMLNUM,BIGNUM] */ anrm = clange_("M", n, n, &a[a_offset], lda, &rwork[1]); ilascl = FALSE_; if (anrm > 0.f && anrm < smlnum) { anrmto = smlnum; ilascl = TRUE_; } else if (anrm > bignum) { anrmto = bignum; ilascl = TRUE_; } if (ilascl) { clascl_("G", &c__0, &c__0, &anrm, &anrmto, n, n, &a[a_offset], lda, & ierr); } /* Scale B if max element outside range [SMLNUM,BIGNUM] */ bnrm = clange_("M", n, n, &b[b_offset], ldb, &rwork[1]); ilbscl = FALSE_; if (bnrm > 0.f && bnrm < smlnum) { bnrmto = smlnum; ilbscl = TRUE_; } else if (bnrm > bignum) { bnrmto = bignum; ilbscl = TRUE_; } if (ilbscl) { clascl_("G", &c__0, &c__0, &bnrm, &bnrmto, n, n, &b[b_offset], ldb, & ierr); } /* Permute the matrices A, B to isolate eigenvalues if possible (Real Workspace: need 6*N) */ ileft = 1; iright = *n + 1; irwrk = iright + *n; cggbal_("P", n, &a[a_offset], lda, &b[b_offset], ldb, &ilo, &ihi, &rwork[ ileft], &rwork[iright], &rwork[irwrk], &ierr); /* Reduce B to triangular form (QR decomposition of B) (Complex Workspace: need N, prefer N*NB) */ irows = ihi + 1 - ilo; if (ilv) { icols = *n + 1 - ilo; } else { icols = irows; } itau = 1; iwrk = itau + irows; i__1 = *lwork + 1 - iwrk; cgeqrf_(&irows, &icols, &b_ref(ilo, ilo), ldb, &work[itau], &work[iwrk], & i__1, &ierr); /* Apply the orthogonal transformation to matrix A (Complex Workspace: need N, prefer N*NB) */ i__1 = *lwork + 1 - iwrk; cunmqr_("L", "C", &irows, &icols, &irows, &b_ref(ilo, ilo), ldb, &work[ itau], &a_ref(ilo, ilo), lda, &work[iwrk], &i__1, &ierr); /* Initialize VL (Complex Workspace: need N, prefer N*NB) */ if (ilvl) { claset_("Full", n, n, &c_b1, &c_b2, &vl[vl_offset], ldvl); i__1 = irows - 1; i__2 = irows - 1; clacpy_("L", &i__1, &i__2, &b_ref(ilo + 1, ilo), ldb, &vl_ref(ilo + 1, ilo), ldvl); i__1 = *lwork + 1 - iwrk; cungqr_(&irows, &irows, &irows, &vl_ref(ilo, ilo), ldvl, &work[itau], &work[iwrk], &i__1, &ierr); } /* Initialize VR */ if (ilvr) { claset_("Full", n, n, &c_b1, &c_b2, &vr[vr_offset], ldvr); } /* Reduce to generalized Hessenberg form */ if (ilv) { /* Eigenvectors requested -- work on whole matrix. */ cgghrd_(jobvl, jobvr, n, &ilo, &ihi, &a[a_offset], lda, &b[b_offset], ldb, &vl[vl_offset], ldvl, &vr[vr_offset], ldvr, &ierr); } else { cgghrd_("N", "N", &irows, &c__1, &irows, &a_ref(ilo, ilo), lda, & b_ref(ilo, ilo), ldb, &vl[vl_offset], ldvl, &vr[vr_offset], ldvr, &ierr); } /* Perform QZ algorithm (Compute eigenvalues, and optionally, the Schur form and Schur vectors) (Complex Workspace: need N) (Real Workspace: need N) */ iwrk = itau; if (ilv) { *(unsigned char *)chtemp = 'S'; } else { *(unsigned char *)chtemp = 'E'; } i__1 = *lwork + 1 - iwrk; chgeqz_(chtemp, jobvl, jobvr, n, &ilo, &ihi, &a[a_offset], lda, &b[ b_offset], ldb, &alpha[1], &beta[1], &vl[vl_offset], ldvl, &vr[ vr_offset], ldvr, &work[iwrk], &i__1, &rwork[irwrk], &ierr); if (ierr != 0) { if (ierr > 0 && ierr <= *n) { *info = ierr; } else if (ierr > *n && ierr <= *n << 1) { *info = ierr - *n; } else { *info = *n + 1; } goto L70; } /* Compute Eigenvectors (Real Workspace: need 2*N) (Complex Workspace: need 2*N) */ if (ilv) { if (ilvl) { if (ilvr) { *(unsigned char *)chtemp = 'B'; } else { *(unsigned char *)chtemp = 'L'; } } else { *(unsigned char *)chtemp = 'R'; } ctgevc_(chtemp, "B", ldumma, n, &a[a_offset], lda, &b[b_offset], ldb, &vl[vl_offset], ldvl, &vr[vr_offset], ldvr, n, &in, &work[ iwrk], &rwork[irwrk], &ierr); if (ierr != 0) { *info = *n + 2; goto L70; } /* Undo balancing on VL and VR and normalization (Workspace: none needed) */ if (ilvl) { cggbak_("P", "L", n, &ilo, &ihi, &rwork[ileft], &rwork[iright], n, &vl[vl_offset], ldvl, &ierr); i__1 = *n; for (jc = 1; jc <= i__1; ++jc) { temp = 0.f; i__2 = *n; for (jr = 1; jr <= i__2; ++jr) { /* Computing MAX */ i__3 = vl_subscr(jr, jc); r__3 = temp, r__4 = (r__1 = vl[i__3].r, dabs(r__1)) + ( r__2 = r_imag(&vl_ref(jr, jc)), dabs(r__2)); temp = dmax(r__3,r__4); /* L10: */ } if (temp < smlnum) { goto L30; } temp = 1.f / temp; i__2 = *n; for (jr = 1; jr <= i__2; ++jr) { i__3 = vl_subscr(jr, jc); i__4 = vl_subscr(jr, jc); q__1.r = temp * vl[i__4].r, q__1.i = temp * vl[i__4].i; vl[i__3].r = q__1.r, vl[i__3].i = q__1.i; /* L20: */ } L30: ; } } if (ilvr) { cggbak_("P", "R", n, &ilo, &ihi, &rwork[ileft], &rwork[iright], n, &vr[vr_offset], ldvr, &ierr); i__1 = *n; for (jc = 1; jc <= i__1; ++jc) { temp = 0.f; i__2 = *n; for (jr = 1; jr <= i__2; ++jr) { /* Computing MAX */ i__3 = vr_subscr(jr, jc); r__3 = temp, r__4 = (r__1 = vr[i__3].r, dabs(r__1)) + ( r__2 = r_imag(&vr_ref(jr, jc)), dabs(r__2)); temp = dmax(r__3,r__4); /* L40: */ } if (temp < smlnum) { goto L60; } temp = 1.f / temp; i__2 = *n; for (jr = 1; jr <= i__2; ++jr) { i__3 = vr_subscr(jr, jc); i__4 = vr_subscr(jr, jc); q__1.r = temp * vr[i__4].r, q__1.i = temp * vr[i__4].i; vr[i__3].r = q__1.r, vr[i__3].i = q__1.i; /* L50: */ } L60: ; } } } /* Undo scaling if necessary */ if (ilascl) { clascl_("G", &c__0, &c__0, &anrmto, &anrm, n, &c__1, &alpha[1], n, & ierr); } if (ilbscl) { clascl_("G", &c__0, &c__0, &bnrmto, &bnrm, n, &c__1, &beta[1], n, & ierr); } L70: work[1].r = (real) lwkopt, work[1].i = 0.f; return 0; /* End of CGGEV */ } /* cggev_ */
/* Subroutine */ int ctgevc_(char *side, char *howmny, logical *select, integer *n, complex *a, integer *lda, complex *b, integer *ldb, complex *vl, integer *ldvl, complex *vr, integer *ldvr, integer *mm, integer *m, complex *work, real *rwork, integer *info) { /* -- LAPACK routine (version 3.0) -- Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., Courant Institute, Argonne National Lab, and Rice University June 30, 1999 Purpose ======= CTGEVC computes some or all of the right and/or left generalized eigenvectors of a pair of complex upper triangular matrices (A,B). The right generalized eigenvector x and the left generalized eigenvector y of (A,B) corresponding to a generalized eigenvalue w are defined by: (A - wB) * x = 0 and y**H * (A - wB) = 0 where y**H denotes the conjugate tranpose of y. If an eigenvalue w is determined by zero diagonal elements of both A and B, a unit vector is returned as the corresponding eigenvector. If all eigenvectors are requested, the routine may either return the matrices X and/or Y of right or left eigenvectors of (A,B), or the products Z*X and/or Q*Y, where Z and Q are input unitary matrices. If (A,B) was obtained from the generalized Schur factorization of an original pair of matrices (A0,B0) = (Q*A*Z**H,Q*B*Z**H), then Z*X and Q*Y are the matrices of right or left eigenvectors of A. Arguments ========= SIDE (input) CHARACTER*1 = 'R': compute right eigenvectors only; = 'L': compute left eigenvectors only; = 'B': compute both right and left eigenvectors. HOWMNY (input) CHARACTER*1 = 'A': compute all right and/or left eigenvectors; = 'B': compute all right and/or left eigenvectors, and backtransform them using the input matrices supplied in VR and/or VL; = 'S': compute selected right and/or left eigenvectors, specified by the logical array SELECT. SELECT (input) LOGICAL array, dimension (N) If HOWMNY='S', SELECT specifies the eigenvectors to be computed. If HOWMNY='A' or 'B', SELECT is not referenced. To select the eigenvector corresponding to the j-th eigenvalue, SELECT(j) must be set to .TRUE.. N (input) INTEGER The order of the matrices A and B. N >= 0. A (input) COMPLEX array, dimension (LDA,N) The upper triangular matrix A. LDA (input) INTEGER The leading dimension of array A. LDA >= max(1,N). B (input) COMPLEX array, dimension (LDB,N) The upper triangular matrix B. B must have real diagonal elements. LDB (input) INTEGER The leading dimension of array B. LDB >= max(1,N). VL (input/output) COMPLEX array, dimension (LDVL,MM) On entry, if SIDE = 'L' or 'B' and HOWMNY = 'B', VL must contain an N-by-N matrix Q (usually the unitary matrix Q of left Schur vectors returned by CHGEQZ). On exit, if SIDE = 'L' or 'B', VL contains: if HOWMNY = 'A', the matrix Y of left eigenvectors of (A,B); if HOWMNY = 'B', the matrix Q*Y; if HOWMNY = 'S', the left eigenvectors of (A,B) specified by SELECT, stored consecutively in the columns of VL, in the same order as their eigenvalues. If SIDE = 'R', VL is not referenced. LDVL (input) INTEGER The leading dimension of array VL. LDVL >= max(1,N) if SIDE = 'L' or 'B'; LDVL >= 1 otherwise. VR (input/output) COMPLEX array, dimension (LDVR,MM) On entry, if SIDE = 'R' or 'B' and HOWMNY = 'B', VR must contain an N-by-N matrix Q (usually the unitary matrix Z of right Schur vectors returned by CHGEQZ). On exit, if SIDE = 'R' or 'B', VR contains: if HOWMNY = 'A', the matrix X of right eigenvectors of (A,B); if HOWMNY = 'B', the matrix Z*X; if HOWMNY = 'S', the right eigenvectors of (A,B) specified by SELECT, stored consecutively in the columns of VR, in the same order as their eigenvalues. If SIDE = 'L', VR is not referenced. LDVR (input) INTEGER The leading dimension of the array VR. LDVR >= max(1,N) if SIDE = 'R' or 'B'; LDVR >= 1 otherwise. MM (input) INTEGER The number of columns in the arrays VL and/or VR. MM >= M. M (output) INTEGER The number of columns in the arrays VL and/or VR actually used to store the eigenvectors. If HOWMNY = 'A' or 'B', M is set to N. Each selected eigenvector occupies one column. WORK (workspace) COMPLEX array, dimension (2*N) RWORK (workspace) REAL array, dimension (2*N) INFO (output) INTEGER = 0: successful exit. < 0: if INFO = -i, the i-th argument had an illegal value. ===================================================================== Decode and Test the input parameters Parameter adjustments */ /* Table of constant values */ static complex c_b1 = {0.f,0.f}; static complex c_b2 = {1.f,0.f}; static integer c__1 = 1; /* System generated locals */ integer a_dim1, a_offset, b_dim1, b_offset, vl_dim1, vl_offset, vr_dim1, vr_offset, i__1, i__2, i__3, i__4, i__5; real r__1, r__2, r__3, r__4, r__5, r__6; complex q__1, q__2, q__3, q__4; /* Builtin functions */ double r_imag(complex *); void r_cnjg(complex *, complex *); /* Local variables */ static integer ibeg, ieig, iend; static real dmin__; static integer isrc; static real temp; static complex suma, sumb; static real xmax; static complex d__; static integer i__, j; static real scale; static logical ilall; static integer iside; static real sbeta; extern logical lsame_(char *, char *); extern /* Subroutine */ int cgemv_(char *, integer *, integer *, complex * , complex *, integer *, complex *, integer *, complex *, complex * , integer *); static real small; static logical compl; static real anorm, bnorm; static logical compr; static complex ca, cb; static logical ilbbad; static real acoefa; static integer je; static real bcoefa, acoeff; static complex bcoeff; static logical ilback; static integer im; extern /* Subroutine */ int slabad_(real *, real *); static real ascale, bscale; static integer jr; extern /* Complex */ VOID cladiv_(complex *, complex *, complex *); extern doublereal slamch_(char *); static complex salpha; static real safmin; extern /* Subroutine */ int xerbla_(char *, integer *); static real bignum; static logical ilcomp; static integer ihwmny; static real big; static logical lsa, lsb; static real ulp; static complex sum; #define a_subscr(a_1,a_2) (a_2)*a_dim1 + a_1 #define a_ref(a_1,a_2) a[a_subscr(a_1,a_2)] #define b_subscr(a_1,a_2) (a_2)*b_dim1 + a_1 #define b_ref(a_1,a_2) b[b_subscr(a_1,a_2)] #define vl_subscr(a_1,a_2) (a_2)*vl_dim1 + a_1 #define vl_ref(a_1,a_2) vl[vl_subscr(a_1,a_2)] #define vr_subscr(a_1,a_2) (a_2)*vr_dim1 + a_1 #define vr_ref(a_1,a_2) vr[vr_subscr(a_1,a_2)] --select; a_dim1 = *lda; a_offset = 1 + a_dim1 * 1; a -= a_offset; b_dim1 = *ldb; b_offset = 1 + b_dim1 * 1; b -= b_offset; vl_dim1 = *ldvl; vl_offset = 1 + vl_dim1 * 1; vl -= vl_offset; vr_dim1 = *ldvr; vr_offset = 1 + vr_dim1 * 1; vr -= vr_offset; --work; --rwork; /* Function Body */ if (lsame_(howmny, "A")) { ihwmny = 1; ilall = TRUE_; ilback = FALSE_; } else if (lsame_(howmny, "S")) { ihwmny = 2; ilall = FALSE_; ilback = FALSE_; } else if (lsame_(howmny, "B") || lsame_(howmny, "T")) { ihwmny = 3; ilall = TRUE_; ilback = TRUE_; } else { ihwmny = -1; } if (lsame_(side, "R")) { iside = 1; compl = FALSE_; compr = TRUE_; } else if (lsame_(side, "L")) { iside = 2; compl = TRUE_; compr = FALSE_; } else if (lsame_(side, "B")) { iside = 3; compl = TRUE_; compr = TRUE_; } else { iside = -1; } *info = 0; if (iside < 0) { *info = -1; } else if (ihwmny < 0) { *info = -2; } else if (*n < 0) { *info = -4; } else if (*lda < max(1,*n)) { *info = -6; } else if (*ldb < max(1,*n)) { *info = -8; } if (*info != 0) { i__1 = -(*info); xerbla_("CTGEVC", &i__1); return 0; } /* Count the number of eigenvectors */ if (! ilall) { im = 0; i__1 = *n; for (j = 1; j <= i__1; ++j) { if (select[j]) { ++im; } /* L10: */ } } else { im = *n; } /* Check diagonal of B */ ilbbad = FALSE_; i__1 = *n; for (j = 1; j <= i__1; ++j) { if (r_imag(&b_ref(j, j)) != 0.f) { ilbbad = TRUE_; } /* L20: */ } if (ilbbad) { *info = -7; } else if (compl && *ldvl < *n || *ldvl < 1) { *info = -10; } else if (compr && *ldvr < *n || *ldvr < 1) { *info = -12; } else if (*mm < im) { *info = -13; } if (*info != 0) { i__1 = -(*info); xerbla_("CTGEVC", &i__1); return 0; } /* Quick return if possible */ *m = im; if (*n == 0) { return 0; } /* Machine Constants */ safmin = slamch_("Safe minimum"); big = 1.f / safmin; slabad_(&safmin, &big); ulp = slamch_("Epsilon") * slamch_("Base"); small = safmin * *n / ulp; big = 1.f / small; bignum = 1.f / (safmin * *n); /* Compute the 1-norm of each column of the strictly upper triangular part of A and B to check for possible overflow in the triangular solver. */ i__1 = a_subscr(1, 1); anorm = (r__1 = a[i__1].r, dabs(r__1)) + (r__2 = r_imag(&a_ref(1, 1)), dabs(r__2)); i__1 = b_subscr(1, 1); bnorm = (r__1 = b[i__1].r, dabs(r__1)) + (r__2 = r_imag(&b_ref(1, 1)), dabs(r__2)); rwork[1] = 0.f; rwork[*n + 1] = 0.f; i__1 = *n; for (j = 2; j <= i__1; ++j) { rwork[j] = 0.f; rwork[*n + j] = 0.f; i__2 = j - 1; for (i__ = 1; i__ <= i__2; ++i__) { i__3 = a_subscr(i__, j); rwork[j] += (r__1 = a[i__3].r, dabs(r__1)) + (r__2 = r_imag(& a_ref(i__, j)), dabs(r__2)); i__3 = b_subscr(i__, j); rwork[*n + j] += (r__1 = b[i__3].r, dabs(r__1)) + (r__2 = r_imag(& b_ref(i__, j)), dabs(r__2)); /* L30: */ } /* Computing MAX */ i__2 = a_subscr(j, j); r__3 = anorm, r__4 = rwork[j] + ((r__1 = a[i__2].r, dabs(r__1)) + ( r__2 = r_imag(&a_ref(j, j)), dabs(r__2))); anorm = dmax(r__3,r__4); /* Computing MAX */ i__2 = b_subscr(j, j); r__3 = bnorm, r__4 = rwork[*n + j] + ((r__1 = b[i__2].r, dabs(r__1)) + (r__2 = r_imag(&b_ref(j, j)), dabs(r__2))); bnorm = dmax(r__3,r__4); /* L40: */ } ascale = 1.f / dmax(anorm,safmin); bscale = 1.f / dmax(bnorm,safmin); /* Left eigenvectors */ if (compl) { ieig = 0; /* Main loop over eigenvalues */ i__1 = *n; for (je = 1; je <= i__1; ++je) { if (ilall) { ilcomp = TRUE_; } else { ilcomp = select[je]; } if (ilcomp) { ++ieig; i__2 = a_subscr(je, je); i__3 = b_subscr(je, je); if ((r__2 = a[i__2].r, dabs(r__2)) + (r__3 = r_imag(&a_ref(je, je)), dabs(r__3)) <= safmin && (r__1 = b[i__3].r, dabs(r__1)) <= safmin) { /* Singular matrix pencil -- return unit eigenvector */ i__2 = *n; for (jr = 1; jr <= i__2; ++jr) { i__3 = vl_subscr(jr, ieig); vl[i__3].r = 0.f, vl[i__3].i = 0.f; /* L50: */ } i__2 = vl_subscr(ieig, ieig); vl[i__2].r = 1.f, vl[i__2].i = 0.f; goto L140; } /* Non-singular eigenvalue: Compute coefficients a and b in H y ( a A - b B ) = 0 Computing MAX */ i__2 = a_subscr(je, je); i__3 = b_subscr(je, je); r__4 = ((r__2 = a[i__2].r, dabs(r__2)) + (r__3 = r_imag(& a_ref(je, je)), dabs(r__3))) * ascale, r__5 = (r__1 = b[i__3].r, dabs(r__1)) * bscale, r__4 = max(r__4,r__5) ; temp = 1.f / dmax(r__4,safmin); i__2 = a_subscr(je, je); q__2.r = temp * a[i__2].r, q__2.i = temp * a[i__2].i; q__1.r = ascale * q__2.r, q__1.i = ascale * q__2.i; salpha.r = q__1.r, salpha.i = q__1.i; i__2 = b_subscr(je, je); sbeta = temp * b[i__2].r * bscale; acoeff = sbeta * ascale; q__1.r = bscale * salpha.r, q__1.i = bscale * salpha.i; bcoeff.r = q__1.r, bcoeff.i = q__1.i; /* Scale to avoid underflow */ lsa = dabs(sbeta) >= safmin && dabs(acoeff) < small; lsb = (r__1 = salpha.r, dabs(r__1)) + (r__2 = r_imag(&salpha), dabs(r__2)) >= safmin && (r__3 = bcoeff.r, dabs(r__3) ) + (r__4 = r_imag(&bcoeff), dabs(r__4)) < small; scale = 1.f; if (lsa) { scale = small / dabs(sbeta) * dmin(anorm,big); } if (lsb) { /* Computing MAX */ r__3 = scale, r__4 = small / ((r__1 = salpha.r, dabs(r__1) ) + (r__2 = r_imag(&salpha), dabs(r__2))) * dmin( bnorm,big); scale = dmax(r__3,r__4); } if (lsa || lsb) { /* Computing MIN Computing MAX */ r__5 = 1.f, r__6 = dabs(acoeff), r__5 = max(r__5,r__6), r__6 = (r__1 = bcoeff.r, dabs(r__1)) + (r__2 = r_imag(&bcoeff), dabs(r__2)); r__3 = scale, r__4 = 1.f / (safmin * dmax(r__5,r__6)); scale = dmin(r__3,r__4); if (lsa) { acoeff = ascale * (scale * sbeta); } else { acoeff = scale * acoeff; } if (lsb) { q__2.r = scale * salpha.r, q__2.i = scale * salpha.i; q__1.r = bscale * q__2.r, q__1.i = bscale * q__2.i; bcoeff.r = q__1.r, bcoeff.i = q__1.i; } else { q__1.r = scale * bcoeff.r, q__1.i = scale * bcoeff.i; bcoeff.r = q__1.r, bcoeff.i = q__1.i; } } acoefa = dabs(acoeff); bcoefa = (r__1 = bcoeff.r, dabs(r__1)) + (r__2 = r_imag(& bcoeff), dabs(r__2)); xmax = 1.f; i__2 = *n; for (jr = 1; jr <= i__2; ++jr) { i__3 = jr; work[i__3].r = 0.f, work[i__3].i = 0.f; /* L60: */ } i__2 = je; work[i__2].r = 1.f, work[i__2].i = 0.f; /* Computing MAX */ r__1 = ulp * acoefa * anorm, r__2 = ulp * bcoefa * bnorm, r__1 = max(r__1,r__2); dmin__ = dmax(r__1,safmin); /* H Triangular solve of (a A - b B) y = 0 H (rowwise in (a A - b B) , or columnwise in a A - b B) */ i__2 = *n; for (j = je + 1; j <= i__2; ++j) { /* Compute j-1 SUM = sum conjg( a*A(k,j) - b*B(k,j) )*x(k) k=je (Scale if necessary) */ temp = 1.f / xmax; if (acoefa * rwork[j] + bcoefa * rwork[*n + j] > bignum * temp) { i__3 = j - 1; for (jr = je; jr <= i__3; ++jr) { i__4 = jr; i__5 = jr; q__1.r = temp * work[i__5].r, q__1.i = temp * work[i__5].i; work[i__4].r = q__1.r, work[i__4].i = q__1.i; /* L70: */ } xmax = 1.f; } suma.r = 0.f, suma.i = 0.f; sumb.r = 0.f, sumb.i = 0.f; i__3 = j - 1; for (jr = je; jr <= i__3; ++jr) { r_cnjg(&q__3, &a_ref(jr, j)); i__4 = jr; q__2.r = q__3.r * work[i__4].r - q__3.i * work[i__4] .i, q__2.i = q__3.r * work[i__4].i + q__3.i * work[i__4].r; q__1.r = suma.r + q__2.r, q__1.i = suma.i + q__2.i; suma.r = q__1.r, suma.i = q__1.i; r_cnjg(&q__3, &b_ref(jr, j)); i__4 = jr; q__2.r = q__3.r * work[i__4].r - q__3.i * work[i__4] .i, q__2.i = q__3.r * work[i__4].i + q__3.i * work[i__4].r; q__1.r = sumb.r + q__2.r, q__1.i = sumb.i + q__2.i; sumb.r = q__1.r, sumb.i = q__1.i; /* L80: */ } q__2.r = acoeff * suma.r, q__2.i = acoeff * suma.i; r_cnjg(&q__4, &bcoeff); q__3.r = q__4.r * sumb.r - q__4.i * sumb.i, q__3.i = q__4.r * sumb.i + q__4.i * sumb.r; q__1.r = q__2.r - q__3.r, q__1.i = q__2.i - q__3.i; sum.r = q__1.r, sum.i = q__1.i; /* Form x(j) = - SUM / conjg( a*A(j,j) - b*B(j,j) ) with scaling and perturbation of the denominator */ i__3 = a_subscr(j, j); q__3.r = acoeff * a[i__3].r, q__3.i = acoeff * a[i__3].i; i__4 = b_subscr(j, j); q__4.r = bcoeff.r * b[i__4].r - bcoeff.i * b[i__4].i, q__4.i = bcoeff.r * b[i__4].i + bcoeff.i * b[i__4] .r; q__2.r = q__3.r - q__4.r, q__2.i = q__3.i - q__4.i; r_cnjg(&q__1, &q__2); d__.r = q__1.r, d__.i = q__1.i; if ((r__1 = d__.r, dabs(r__1)) + (r__2 = r_imag(&d__), dabs(r__2)) <= dmin__) { q__1.r = dmin__, q__1.i = 0.f; d__.r = q__1.r, d__.i = q__1.i; } if ((r__1 = d__.r, dabs(r__1)) + (r__2 = r_imag(&d__), dabs(r__2)) < 1.f) { if ((r__1 = sum.r, dabs(r__1)) + (r__2 = r_imag(&sum), dabs(r__2)) >= bignum * ((r__3 = d__.r, dabs( r__3)) + (r__4 = r_imag(&d__), dabs(r__4)))) { temp = 1.f / ((r__1 = sum.r, dabs(r__1)) + (r__2 = r_imag(&sum), dabs(r__2))); i__3 = j - 1; for (jr = je; jr <= i__3; ++jr) { i__4 = jr; i__5 = jr; q__1.r = temp * work[i__5].r, q__1.i = temp * work[i__5].i; work[i__4].r = q__1.r, work[i__4].i = q__1.i; /* L90: */ } xmax = temp * xmax; q__1.r = temp * sum.r, q__1.i = temp * sum.i; sum.r = q__1.r, sum.i = q__1.i; } } i__3 = j; q__2.r = -sum.r, q__2.i = -sum.i; cladiv_(&q__1, &q__2, &d__); work[i__3].r = q__1.r, work[i__3].i = q__1.i; /* Computing MAX */ i__3 = j; r__3 = xmax, r__4 = (r__1 = work[i__3].r, dabs(r__1)) + ( r__2 = r_imag(&work[j]), dabs(r__2)); xmax = dmax(r__3,r__4); /* L100: */ } /* Back transform eigenvector if HOWMNY='B'. */ if (ilback) { i__2 = *n + 1 - je; cgemv_("N", n, &i__2, &c_b2, &vl_ref(1, je), ldvl, &work[ je], &c__1, &c_b1, &work[*n + 1], &c__1); isrc = 2; ibeg = 1; } else { isrc = 1; ibeg = je; } /* Copy and scale eigenvector into column of VL */ xmax = 0.f; i__2 = *n; for (jr = ibeg; jr <= i__2; ++jr) { /* Computing MAX */ i__3 = (isrc - 1) * *n + jr; r__3 = xmax, r__4 = (r__1 = work[i__3].r, dabs(r__1)) + ( r__2 = r_imag(&work[(isrc - 1) * *n + jr]), dabs( r__2)); xmax = dmax(r__3,r__4); /* L110: */ } if (xmax > safmin) { temp = 1.f / xmax; i__2 = *n; for (jr = ibeg; jr <= i__2; ++jr) { i__3 = vl_subscr(jr, ieig); i__4 = (isrc - 1) * *n + jr; q__1.r = temp * work[i__4].r, q__1.i = temp * work[ i__4].i; vl[i__3].r = q__1.r, vl[i__3].i = q__1.i; /* L120: */ } } else { ibeg = *n + 1; } i__2 = ibeg - 1; for (jr = 1; jr <= i__2; ++jr) { i__3 = vl_subscr(jr, ieig); vl[i__3].r = 0.f, vl[i__3].i = 0.f; /* L130: */ } } L140: ; } } /* Right eigenvectors */ if (compr) { ieig = im + 1; /* Main loop over eigenvalues */ for (je = *n; je >= 1; --je) { if (ilall) { ilcomp = TRUE_; } else { ilcomp = select[je]; } if (ilcomp) { --ieig; i__1 = a_subscr(je, je); i__2 = b_subscr(je, je); if ((r__2 = a[i__1].r, dabs(r__2)) + (r__3 = r_imag(&a_ref(je, je)), dabs(r__3)) <= safmin && (r__1 = b[i__2].r, dabs(r__1)) <= safmin) { /* Singular matrix pencil -- return unit eigenvector */ i__1 = *n; for (jr = 1; jr <= i__1; ++jr) { i__2 = vr_subscr(jr, ieig); vr[i__2].r = 0.f, vr[i__2].i = 0.f; /* L150: */ } i__1 = vr_subscr(ieig, ieig); vr[i__1].r = 1.f, vr[i__1].i = 0.f; goto L250; } /* Non-singular eigenvalue: Compute coefficients a and b in ( a A - b B ) x = 0 Computing MAX */ i__1 = a_subscr(je, je); i__2 = b_subscr(je, je); r__4 = ((r__2 = a[i__1].r, dabs(r__2)) + (r__3 = r_imag(& a_ref(je, je)), dabs(r__3))) * ascale, r__5 = (r__1 = b[i__2].r, dabs(r__1)) * bscale, r__4 = max(r__4,r__5) ; temp = 1.f / dmax(r__4,safmin); i__1 = a_subscr(je, je); q__2.r = temp * a[i__1].r, q__2.i = temp * a[i__1].i; q__1.r = ascale * q__2.r, q__1.i = ascale * q__2.i; salpha.r = q__1.r, salpha.i = q__1.i; i__1 = b_subscr(je, je); sbeta = temp * b[i__1].r * bscale; acoeff = sbeta * ascale; q__1.r = bscale * salpha.r, q__1.i = bscale * salpha.i; bcoeff.r = q__1.r, bcoeff.i = q__1.i; /* Scale to avoid underflow */ lsa = dabs(sbeta) >= safmin && dabs(acoeff) < small; lsb = (r__1 = salpha.r, dabs(r__1)) + (r__2 = r_imag(&salpha), dabs(r__2)) >= safmin && (r__3 = bcoeff.r, dabs(r__3) ) + (r__4 = r_imag(&bcoeff), dabs(r__4)) < small; scale = 1.f; if (lsa) { scale = small / dabs(sbeta) * dmin(anorm,big); } if (lsb) { /* Computing MAX */ r__3 = scale, r__4 = small / ((r__1 = salpha.r, dabs(r__1) ) + (r__2 = r_imag(&salpha), dabs(r__2))) * dmin( bnorm,big); scale = dmax(r__3,r__4); } if (lsa || lsb) { /* Computing MIN Computing MAX */ r__5 = 1.f, r__6 = dabs(acoeff), r__5 = max(r__5,r__6), r__6 = (r__1 = bcoeff.r, dabs(r__1)) + (r__2 = r_imag(&bcoeff), dabs(r__2)); r__3 = scale, r__4 = 1.f / (safmin * dmax(r__5,r__6)); scale = dmin(r__3,r__4); if (lsa) { acoeff = ascale * (scale * sbeta); } else { acoeff = scale * acoeff; } if (lsb) { q__2.r = scale * salpha.r, q__2.i = scale * salpha.i; q__1.r = bscale * q__2.r, q__1.i = bscale * q__2.i; bcoeff.r = q__1.r, bcoeff.i = q__1.i; } else { q__1.r = scale * bcoeff.r, q__1.i = scale * bcoeff.i; bcoeff.r = q__1.r, bcoeff.i = q__1.i; } } acoefa = dabs(acoeff); bcoefa = (r__1 = bcoeff.r, dabs(r__1)) + (r__2 = r_imag(& bcoeff), dabs(r__2)); xmax = 1.f; i__1 = *n; for (jr = 1; jr <= i__1; ++jr) { i__2 = jr; work[i__2].r = 0.f, work[i__2].i = 0.f; /* L160: */ } i__1 = je; work[i__1].r = 1.f, work[i__1].i = 0.f; /* Computing MAX */ r__1 = ulp * acoefa * anorm, r__2 = ulp * bcoefa * bnorm, r__1 = max(r__1,r__2); dmin__ = dmax(r__1,safmin); /* Triangular solve of (a A - b B) x = 0 (columnwise) WORK(1:j-1) contains sums w, WORK(j+1:JE) contains x */ i__1 = je - 1; for (jr = 1; jr <= i__1; ++jr) { i__2 = jr; i__3 = a_subscr(jr, je); q__2.r = acoeff * a[i__3].r, q__2.i = acoeff * a[i__3].i; i__4 = b_subscr(jr, je); q__3.r = bcoeff.r * b[i__4].r - bcoeff.i * b[i__4].i, q__3.i = bcoeff.r * b[i__4].i + bcoeff.i * b[i__4] .r; q__1.r = q__2.r - q__3.r, q__1.i = q__2.i - q__3.i; work[i__2].r = q__1.r, work[i__2].i = q__1.i; /* L170: */ } i__1 = je; work[i__1].r = 1.f, work[i__1].i = 0.f; for (j = je - 1; j >= 1; --j) { /* Form x(j) := - w(j) / d with scaling and perturbation of the denominator */ i__1 = a_subscr(j, j); q__2.r = acoeff * a[i__1].r, q__2.i = acoeff * a[i__1].i; i__2 = b_subscr(j, j); q__3.r = bcoeff.r * b[i__2].r - bcoeff.i * b[i__2].i, q__3.i = bcoeff.r * b[i__2].i + bcoeff.i * b[i__2] .r; q__1.r = q__2.r - q__3.r, q__1.i = q__2.i - q__3.i; d__.r = q__1.r, d__.i = q__1.i; if ((r__1 = d__.r, dabs(r__1)) + (r__2 = r_imag(&d__), dabs(r__2)) <= dmin__) { q__1.r = dmin__, q__1.i = 0.f; d__.r = q__1.r, d__.i = q__1.i; } if ((r__1 = d__.r, dabs(r__1)) + (r__2 = r_imag(&d__), dabs(r__2)) < 1.f) { i__1 = j; if ((r__1 = work[i__1].r, dabs(r__1)) + (r__2 = r_imag(&work[j]), dabs(r__2)) >= bignum * (( r__3 = d__.r, dabs(r__3)) + (r__4 = r_imag(& d__), dabs(r__4)))) { i__1 = j; temp = 1.f / ((r__1 = work[i__1].r, dabs(r__1)) + (r__2 = r_imag(&work[j]), dabs(r__2))); i__1 = je; for (jr = 1; jr <= i__1; ++jr) { i__2 = jr; i__3 = jr; q__1.r = temp * work[i__3].r, q__1.i = temp * work[i__3].i; work[i__2].r = q__1.r, work[i__2].i = q__1.i; /* L180: */ } } } i__1 = j; i__2 = j; q__2.r = -work[i__2].r, q__2.i = -work[i__2].i; cladiv_(&q__1, &q__2, &d__); work[i__1].r = q__1.r, work[i__1].i = q__1.i; if (j > 1) { /* w = w + x(j)*(a A(*,j) - b B(*,j) ) with scaling */ i__1 = j; if ((r__1 = work[i__1].r, dabs(r__1)) + (r__2 = r_imag(&work[j]), dabs(r__2)) > 1.f) { i__1 = j; temp = 1.f / ((r__1 = work[i__1].r, dabs(r__1)) + (r__2 = r_imag(&work[j]), dabs(r__2))); if (acoefa * rwork[j] + bcoefa * rwork[*n + j] >= bignum * temp) { i__1 = je; for (jr = 1; jr <= i__1; ++jr) { i__2 = jr; i__3 = jr; q__1.r = temp * work[i__3].r, q__1.i = temp * work[i__3].i; work[i__2].r = q__1.r, work[i__2].i = q__1.i; /* L190: */ } } } i__1 = j; q__1.r = acoeff * work[i__1].r, q__1.i = acoeff * work[i__1].i; ca.r = q__1.r, ca.i = q__1.i; i__1 = j; q__1.r = bcoeff.r * work[i__1].r - bcoeff.i * work[ i__1].i, q__1.i = bcoeff.r * work[i__1].i + bcoeff.i * work[i__1].r; cb.r = q__1.r, cb.i = q__1.i; i__1 = j - 1; for (jr = 1; jr <= i__1; ++jr) { i__2 = jr; i__3 = jr; i__4 = a_subscr(jr, j); q__3.r = ca.r * a[i__4].r - ca.i * a[i__4].i, q__3.i = ca.r * a[i__4].i + ca.i * a[i__4] .r; q__2.r = work[i__3].r + q__3.r, q__2.i = work[ i__3].i + q__3.i; i__5 = b_subscr(jr, j); q__4.r = cb.r * b[i__5].r - cb.i * b[i__5].i, q__4.i = cb.r * b[i__5].i + cb.i * b[i__5] .r; q__1.r = q__2.r - q__4.r, q__1.i = q__2.i - q__4.i; work[i__2].r = q__1.r, work[i__2].i = q__1.i; /* L200: */ } } /* L210: */ } /* Back transform eigenvector if HOWMNY='B'. */ if (ilback) { cgemv_("N", n, &je, &c_b2, &vr[vr_offset], ldvr, &work[1], &c__1, &c_b1, &work[*n + 1], &c__1); isrc = 2; iend = *n; } else { isrc = 1; iend = je; } /* Copy and scale eigenvector into column of VR */ xmax = 0.f; i__1 = iend; for (jr = 1; jr <= i__1; ++jr) { /* Computing MAX */ i__2 = (isrc - 1) * *n + jr; r__3 = xmax, r__4 = (r__1 = work[i__2].r, dabs(r__1)) + ( r__2 = r_imag(&work[(isrc - 1) * *n + jr]), dabs( r__2)); xmax = dmax(r__3,r__4); /* L220: */ } if (xmax > safmin) { temp = 1.f / xmax; i__1 = iend; for (jr = 1; jr <= i__1; ++jr) { i__2 = vr_subscr(jr, ieig); i__3 = (isrc - 1) * *n + jr; q__1.r = temp * work[i__3].r, q__1.i = temp * work[ i__3].i; vr[i__2].r = q__1.r, vr[i__2].i = q__1.i; /* L230: */ } } else { iend = 0; } i__1 = *n; for (jr = iend + 1; jr <= i__1; ++jr) { i__2 = vr_subscr(jr, ieig); vr[i__2].r = 0.f, vr[i__2].i = 0.f; /* L240: */ } } L250: ; } } return 0; /* End of CTGEVC */ } /* ctgevc_ */