Пример #1
0
/* 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_ */
Пример #2
0
/* Subroutine */ int ztgsna_(char *job, char *howmny, logical *select, 
	integer *n, doublecomplex *a, integer *lda, doublecomplex *b, integer 
	*ldb, doublecomplex *vl, integer *ldvl, doublecomplex *vr, integer *
	ldvr, doublereal *s, doublereal *dif, integer *mm, integer *m, 
	doublecomplex *work, integer *lwork, integer *iwork, 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   
    =======   

    ZTGSNA estimates reciprocal condition numbers for specified   
    eigenvalues and/or eigenvectors of a matrix pair (A, B).   

    (A, B) must be in generalized Schur canonical form, that is, A and   
    B are both upper triangular.   

    Arguments   
    =========   

    JOB     (input) CHARACTER*1   
            Specifies whether condition numbers are required for   
            eigenvalues (S) or eigenvectors (DIF):   
            = 'E': for eigenvalues only (S);   
            = 'V': for eigenvectors only (DIF);   
            = 'B': for both eigenvalues and eigenvectors (S and DIF).   

    HOWMNY  (input) CHARACTER*1   
            = 'A': compute condition numbers for all eigenpairs;   
            = 'S': compute condition numbers for selected eigenpairs   
                   specified by the array SELECT.   

    SELECT  (input) LOGICAL array, dimension (N)   
            If HOWMNY = 'S', SELECT specifies the eigenpairs for which   
            condition numbers are required. To select condition numbers   
            for the corresponding j-th eigenvalue and/or eigenvector,   
            SELECT(j) must be set to .TRUE..   
            If HOWMNY = 'A', SELECT is not referenced.   

    N       (input) INTEGER   
            The order of the square matrix pair (A, B). N >= 0.   

    A       (input) COMPLEX*16 array, dimension (LDA,N)   
            The upper triangular matrix A in the pair (A,B).   

    LDA     (input) INTEGER   
            The leading dimension of the array A. LDA >= max(1,N).   

    B       (input) COMPLEX*16 array, dimension (LDB,N)   
            The upper triangular matrix B in the pair (A, B).   

    LDB     (input) INTEGER   
            The leading dimension of the array B. LDB >= max(1,N).   

    VL      (input) COMPLEX*16 array, dimension (LDVL,M)   
            IF JOB = 'E' or 'B', VL must contain left eigenvectors of   
            (A, B), corresponding to the eigenpairs specified by HOWMNY   
            and SELECT.  The eigenvectors must be stored in consecutive   
            columns of VL, as returned by ZTGEVC.   
            If JOB = 'V', VL is not referenced.   

    LDVL    (input) INTEGER   
            The leading dimension of the array VL. LDVL >= 1; and   
            If JOB = 'E' or 'B', LDVL >= N.   

    VR      (input) COMPLEX*16 array, dimension (LDVR,M)   
            IF JOB = 'E' or 'B', VR must contain right eigenvectors of   
            (A, B), corresponding to the eigenpairs specified by HOWMNY   
            and SELECT.  The eigenvectors must be stored in consecutive   
            columns of VR, as returned by ZTGEVC.   
            If JOB = 'V', VR is not referenced.   

    LDVR    (input) INTEGER   
            The leading dimension of the array VR. LDVR >= 1;   
            If JOB = 'E' or 'B', LDVR >= N.   

    S       (output) DOUBLE PRECISION array, dimension (MM)   
            If JOB = 'E' or 'B', the reciprocal condition numbers of the   
            selected eigenvalues, stored in consecutive elements of the   
            array.   
            If JOB = 'V', S is not referenced.   

    DIF     (output) DOUBLE PRECISION array, dimension (MM)   
            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 DIF(j),   
            DIF(j) is set to 0; this can only occur when the true value   
            would be very small anyway.   
            For each eigenvalue/vector specified by SELECT, DIF stores   
            a Frobenius norm-based estimate of Difl.   
            If JOB = 'E', DIF is not referenced.   

    MM      (input) INTEGER   
            The number of elements in the arrays S and DIF. MM >= M.   

    M       (output) INTEGER   
            The number of elements of the arrays S and DIF used to store   
            the specified condition numbers; for each selected eigenvalue   
            one element is used. If HOWMNY = 'A', M is set to N.   

    WORK    (workspace/output) COMPLEX*16 array, dimension (LWORK)   
            If JOB = 'E', WORK is not referenced.  Otherwise,   
            on exit, if INFO = 0, WORK(1) returns the optimal LWORK.   

    LWORK  (input) INTEGER   
            The dimension of the array WORK. LWORK >= 1.   
            If JOB = 'V' or 'B', LWORK >= 2*N*N.   

    IWORK   (workspace) INTEGER array, dimension (N+2)   
            If JOB = 'E', IWORK is not referenced.   

    INFO    (output) INTEGER   
            = 0: Successful exit   
            < 0: If INFO = -i, the i-th argument had an illegal value   

    Further Details   
    ===============   

    The reciprocal of the condition number of the i-th generalized   
    eigenvalue w = (a, b) is defined as   

            S(I) = (|v'Au|**2 + |v'Bu|**2)**(1/2) / (norm(u)*norm(v))   

    where u and v are the right and left eigenvectors of (A, B)   
    corresponding to w; |z| denotes the absolute value of the complex   
    number, and norm(u) denotes the 2-norm of the vector u. The pair   
    (a, b) corresponds to an eigenvalue w = a/b (= v'Au/v'Bu) of the   
    matrix pair (A, B). If both a and b equal zero, then (A,B) is   
    singular and S(I) = -1 is returned.   

    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(A, B) / S(I),   

    where EPS is the machine precision.   

    The reciprocal of the condition number of the right eigenvector u   
    and left eigenvector v corresponding to the generalized eigenvalue w   
    is defined as follows. Suppose   

                     (A, B) = ( a   *  ) ( b  *  )  1   
                              ( 0  A22 ),( 0 B22 )  n-1   
                                1  n-1     1 n-1   

    Then the reciprocal condition number DIF(I) is   

            Difl[(a, b), (A22, B22)]  = sigma-min( Zl )   

    where sigma-min(Zl) denotes the smallest singular value of   

           Zl = [ kron(a, In-1) -kron(1, A22) ]   
                [ kron(b, In-1) -kron(1, B22) ].   

    Here In-1 is the identity matrix of size n-1 and X' is the conjugate   
    transpose of X. kron(X, Y) is the Kronecker product between the   
    matrices X and Y.   

    We approximate the smallest singular value of Zl with an upper   
    bound. This is done by ZLATDF.   

    An approximate error bound for a computed eigenvector VL(i) or   
    VR(i) is given by   

                        EPS * norm(A, B) / DIF(i).   

    See ref. [2-3] for more details and further references.   

    Based on contributions by   
       Bo Kagstrom and Peter Poromaa, Department of Computing Science,   
       Umea University, S-901 87 Umea, Sweden.   

    References   
    ==========   

    [1] B. Kagstrom; A Direct Method for Reordering Eigenvalues in the   
        Generalized Real Schur Form of a Regular Matrix Pair (A, B), in   
        M.S. Moonen et al (eds), Linear Algebra for Large Scale and   
        Real-Time Applications, Kluwer Academic Publ. 1993, pp 195-218.   

    [2] B. Kagstrom and P. Poromaa; Computing Eigenspaces with Specified   
        Eigenvalues of a Regular Matrix Pair (A, B) and Condition   
        Estimation: Theory, Algorithms and Software, Report   
        UMINF - 94.04, Department of Computing Science, Umea University,   
        S-901 87 Umea, Sweden, 1994. Also as LAPACK Working Note 87.   
        To appear in Numerical Algorithms, 1996.   

    [3] B. Kagstrom and P. Poromaa, LAPACK-Style Algorithms and Software   
        for Solving the Generalized Sylvester Equation and Estimating the   
        Separation between Regular Matrix Pairs, Report UMINF - 93.23,   
        Department of Computing Science, Umea University, S-901 87 Umea,   
        Sweden, December 1993, Revised April 1994, Also as LAPACK Working   
        Note 75.   
        To appear in ACM Trans. on Math. Software, Vol 22, No 1, 1996.   

    =====================================================================   


       Decode and test the input parameters   

       Parameter adjustments */
    /* Table of constant values */
    static integer c__1 = 1;
    static doublecomplex c_b19 = {1.,0.};
    static doublecomplex c_b20 = {0.,0.};
    static logical c_false = FALSE_;
    static integer c__3 = 3;
    
    /* System generated locals */
    integer a_dim1, a_offset, b_dim1, b_offset, vl_dim1, vl_offset, vr_dim1, 
	    vr_offset, i__1, i__2;
    doublereal d__1, d__2;
    doublecomplex z__1;
    /* Builtin functions */
    double z_abs(doublecomplex *);
    /* Local variables */
    static doublereal cond;
    static integer ierr, ifst;
    static doublereal lnrm;
    static doublecomplex yhax, yhbx;
    static integer ilst;
    static doublereal rnrm;
    static integer i__, k;
    static doublereal scale;
    extern logical lsame_(char *, char *);
    extern /* Double Complex */ VOID zdotc_(doublecomplex *, integer *, 
	    doublecomplex *, integer *, doublecomplex *, integer *);
    static integer lwmin;
    extern /* Subroutine */ int zgemv_(char *, integer *, integer *, 
	    doublecomplex *, doublecomplex *, integer *, doublecomplex *, 
	    integer *, doublecomplex *, doublecomplex *, integer *);
    static logical wants;
    static integer llwrk, n1, n2;
    static doublecomplex dummy[1];
    extern doublereal dlapy2_(doublereal *, doublereal *);
    extern /* Subroutine */ int dlabad_(doublereal *, doublereal *);
    static doublecomplex dummy1[1];
    extern doublereal dznrm2_(integer *, doublecomplex *, integer *), dlamch_(
	    char *);
    static integer ks;
    extern /* Subroutine */ int xerbla_(char *, integer *);
    static doublereal bignum;
    static logical wantbh, wantdf, somcon;
    extern /* Subroutine */ int zlacpy_(char *, integer *, integer *, 
	    doublecomplex *, integer *, doublecomplex *, integer *), 
	    ztgexc_(logical *, logical *, integer *, doublecomplex *, integer 
	    *, doublecomplex *, integer *, doublecomplex *, integer *, 
	    doublecomplex *, integer *, integer *, integer *, integer *);
    static doublereal smlnum;
    static logical lquery;
    extern /* Subroutine */ int ztgsyl_(char *, integer *, integer *, integer 
	    *, doublecomplex *, integer *, doublecomplex *, integer *, 
	    doublecomplex *, integer *, doublecomplex *, integer *, 
	    doublecomplex *, integer *, doublecomplex *, integer *, 
	    doublereal *, doublereal *, doublecomplex *, integer *, integer *,
	     integer *);
    static doublereal eps;
#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;
    --s;
    --dif;
    --work;
    --iwork;

    /* Function Body */
    wantbh = lsame_(job, "B");
    wants = lsame_(job, "E") || wantbh;
    wantdf = lsame_(job, "V") || wantbh;

    somcon = lsame_(howmny, "S");

    *info = 0;
    lquery = *lwork == -1;

    if (lsame_(job, "V") || lsame_(job, "B")) {
/* Computing MAX */
	i__1 = 1, i__2 = (*n << 1) * *n;
	lwmin = max(i__1,i__2);
    } else {
	lwmin = 1;
    }

    if (! wants && ! wantdf) {
	*info = -1;
    } else if (! lsame_(howmny, "A") && ! somcon) {
	*info = -2;
    } else if (*n < 0) {
	*info = -4;
    } else if (*lda < max(1,*n)) {
	*info = -6;
    } else if (*ldb < max(1,*n)) {
	*info = -8;
    } else if (wants && *ldvl < *n) {
	*info = -10;
    } else if (wants && *ldvr < *n) {
	*info = -12;
    } else {

/*        Set M to the number of eigenpairs for which condition numbers   
          are required, and test MM. */

	if (somcon) {
	    *m = 0;
	    i__1 = *n;
	    for (k = 1; k <= i__1; ++k) {
		if (select[k]) {
		    ++(*m);
		}
/* L10: */
	    }
	} else {
	    *m = *n;
	}

	if (*mm < *m) {
	    *info = -15;
	} else if (*lwork < lwmin && ! lquery) {
	    *info = -18;
	}
    }

    if (*info == 0) {
	work[1].r = (doublereal) lwmin, work[1].i = 0.;
    }

    if (*info != 0) {
	i__1 = -(*info);
	xerbla_("ZTGSNA", &i__1);
	return 0;
    } else if (lquery) {
	return 0;
    }

/*     Quick return if possible */

    if (*n == 0) {
	return 0;
    }

/*     Get machine constants */

    eps = dlamch_("P");
    smlnum = dlamch_("S") / eps;
    bignum = 1. / smlnum;
    dlabad_(&smlnum, &bignum);
    llwrk = *lwork - (*n << 1) * *n;
    ks = 0;
    i__1 = *n;
    for (k = 1; k <= i__1; ++k) {

/*        Determine whether condition numbers are required for the k-th   
          eigenpair. */

	if (somcon) {
	    if (! select[k]) {
		goto L20;
	    }
	}

	++ks;

	if (wants) {

/*           Compute the reciprocal condition number of the k-th   
             eigenvalue. */

	    rnrm = dznrm2_(n, &vr_ref(1, ks), &c__1);
	    lnrm = dznrm2_(n, &vl_ref(1, ks), &c__1);
	    zgemv_("N", n, n, &c_b19, &a[a_offset], lda, &vr_ref(1, ks), &
		    c__1, &c_b20, &work[1], &c__1);
	    zdotc_(&z__1, n, &work[1], &c__1, &vl_ref(1, ks), &c__1);
	    yhax.r = z__1.r, yhax.i = z__1.i;
	    zgemv_("N", n, n, &c_b19, &b[b_offset], ldb, &vr_ref(1, ks), &
		    c__1, &c_b20, &work[1], &c__1);
	    zdotc_(&z__1, n, &work[1], &c__1, &vl_ref(1, ks), &c__1);
	    yhbx.r = z__1.r, yhbx.i = z__1.i;
	    d__1 = z_abs(&yhax);
	    d__2 = z_abs(&yhbx);
	    cond = dlapy2_(&d__1, &d__2);
	    if (cond == 0.) {
		s[ks] = -1.;
	    } else {
		s[ks] = cond / (rnrm * lnrm);
	    }
	}

	if (wantdf) {
	    if (*n == 1) {
		d__1 = z_abs(&a_ref(1, 1));
		d__2 = z_abs(&b_ref(1, 1));
		dif[ks] = dlapy2_(&d__1, &d__2);
		goto L20;
	    }

/*           Estimate the reciprocal condition number of the k-th   
             eigenvectors.   

             Copy the matrix (A, B) to the array WORK and move the   
             (k,k)th pair to the (1,1) position. */

	    zlacpy_("Full", n, n, &a[a_offset], lda, &work[1], n);
	    zlacpy_("Full", n, n, &b[b_offset], ldb, &work[*n * *n + 1], n);
	    ifst = k;
	    ilst = 1;

	    ztgexc_(&c_false, &c_false, n, &work[1], n, &work[*n * *n + 1], n,
		     dummy, &c__1, dummy1, &c__1, &ifst, &ilst, &ierr);

	    if (ierr > 0) {

/*              Ill-conditioned problem - swap rejected. */

		dif[ks] = 0.;
	    } else {

/*              Reordering successful, solve generalized Sylvester   
                equation for R and L,   
                           A22 * R - L * A11 = A12   
                           B22 * R - L * B11 = B12,   
                and compute estimate of Difl[(A11,B11), (A22, B22)]. */

		n1 = 1;
		n2 = *n - n1;
		i__ = *n * *n + 1;
		ztgsyl_("N", &c__3, &n2, &n1, &work[*n * n1 + n1 + 1], n, &
			work[1], n, &work[n1 + 1], n, &work[*n * n1 + n1 + 
			i__], n, &work[i__], n, &work[n1 + i__], n, &scale, &
			dif[ks], &work[(*n * *n << 1) + 1], &llwrk, &iwork[1],
			 &ierr);
	    }
	}

L20:
	;
    }
    work[1].r = (doublereal) lwmin, work[1].i = 0.;
    return 0;

/*     End of ZTGSNA */

} /* ztgsna_ */
Пример #3
0
/* Subroutine */ int dggevx_(char *balanc, char *jobvl, char *jobvr, char *
	sense, integer *n, doublereal *a, integer *lda, doublereal *b, 
	integer *ldb, doublereal *alphar, doublereal *alphai, doublereal *
	beta, doublereal *vl, integer *ldvl, doublereal *vr, integer *ldvr, 
	integer *ilo, integer *ihi, doublereal *lscale, doublereal *rscale, 
	doublereal *abnrm, doublereal *bbnrm, doublereal *rconde, doublereal *
	rcondv, doublereal *work, integer *lwork, 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   
    =======   

    DGGEVX computes for a pair of N-by-N real nonsymmetric matrices (A,B)   
    the generalized eigenvalues, and optionally, the left and/or right   
    generalized eigenvectors.   

    Optionally also, it 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) DOUBLE PRECISION 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 real 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) DOUBLE PRECISION 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 real Schur   
            form of the "balanced" versions of the input A and B.   

    LDB     (input) INTEGER   
            The leading dimension of B.  LDB >= max(1,N).   

    ALPHAR  (output) DOUBLE PRECISION array, dimension (N)   
    ALPHAI  (output) DOUBLE PRECISION array, dimension (N)   
    BETA    (output) DOUBLE PRECISION array, dimension (N)   
            On exit, (ALPHAR(j) + ALPHAI(j)*i)/BETA(j), j=1,...,N, will   
            be the generalized eigenvalues.  If ALPHAI(j) is zero, then   
            the j-th eigenvalue is real; if positive, then the j-th and   
            (j+1)-st eigenvalues are a complex conjugate pair, with   
            ALPHAI(j+1) negative.   

            Note: the quotients ALPHAR(j)/BETA(j) and ALPHAI(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, ALPHAR and ALPHAI 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) DOUBLE PRECISION array, dimension (LDVL,N)   
            If JOBVL = 'V', the left eigenvectors u(j) are stored one   
            after another in the columns of VL, in the same order as   
            their eigenvalues. If the j-th eigenvalue is real, then   
            u(j) = VL(:,j), the j-th column of VL. If the j-th and   
            (j+1)-th eigenvalues form a complex conjugate pair, then   
            u(j) = VL(:,j)+i*VL(:,j+1) and u(j+1) = VL(:,j)-i*VL(:,j+1).   
            Each eigenvector will be scaled so the largest component 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) DOUBLE PRECISION array, dimension (LDVR,N)   
            If JOBVR = 'V', the right eigenvectors v(j) are stored one   
            after another in the columns of VR, in the same order as   
            their eigenvalues. If the j-th eigenvalue is real, then   
            v(j) = VR(:,j), the j-th column of VR. If the j-th and   
            (j+1)-th eigenvalues form a complex conjugate pair, then   
            v(j) = VR(:,j)+i*VR(:,j+1) and v(j+1) = VR(:,j)-i*VR(:,j+1).   
            Each eigenvector will be scaled so the largest component 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) DOUBLE PRECISION 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) DOUBLE PRECISION 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) DOUBLE PRECISION   
            The one-norm of the balanced matrix A.   

    BBNRM   (output) DOUBLE PRECISION   
            The one-norm of the balanced matrix B.   

    RCONDE  (output) DOUBLE PRECISION array, dimension (N)   
            If SENSE = 'E' or 'B', the reciprocal condition numbers of   
            the selected eigenvalues, stored in consecutive elements of   
            the array. For a complex conjugate pair of eigenvalues two   
            consecutive elements of RCONDE are set to the same value.   
            Thus RCONDE(j), RCONDV(j), and the j-th columns of VL and VR   
            all correspond to the same eigenpair (but not in general the   
            j-th eigenpair, unless all eigenpairs are selected).   
            If SENSE = 'V', RCONDE is not referenced.   

    RCONDV  (output) DOUBLE PRECISION array, dimension (N)   
            If SENSE = 'V' or 'B', the estimated reciprocal condition   
            numbers of the selected eigenvectors, stored in consecutive   
            elements of the array. For a complex eigenvector two   
            consecutive elements of RCONDV are set to the same value. 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.   

    WORK    (workspace/output) DOUBLE PRECISION 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,6*N).   
            If SENSE = 'E', LWORK >= 12*N.   
            If SENSE = 'V' or 'B', LWORK >= 2*N*N+12*N+16.   

            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.   

    IWORK   (workspace) INTEGER array, dimension (N+6)   
            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 ALPHAR(j), ALPHAI(j), and BETA(j)   
                  should be correct for j=INFO+1,...,N.   
            > N:  =N+1: other than QZ iteration failed in DHGEQZ.   
                  =N+2: error return from DTGEVC.   

    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 integer c__1 = 1;
    static integer c__0 = 0;
    static doublereal c_b47 = 0.;
    static doublereal c_b48 = 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;
    doublereal d__1, d__2, d__3, d__4;
    /* Builtin functions */
    double sqrt(doublereal);
    /* Local variables */
    static logical pair;
    static doublereal anrm, bnrm;
    static integer ierr, itau;
    static doublereal temp;
    static logical ilvl, ilvr;
    static integer iwrk, iwrk1, i__, j, m;
    extern logical lsame_(char *, char *);
    static integer icols, irows;
    extern /* Subroutine */ int dlabad_(doublereal *, doublereal *);
    static integer jc;
    extern /* Subroutine */ int dggbak_(char *, char *, integer *, integer *, 
	    integer *, doublereal *, doublereal *, integer *, doublereal *, 
	    integer *, integer *), dggbal_(char *, integer *, 
	    doublereal *, integer *, doublereal *, integer *, integer *, 
	    integer *, doublereal *, doublereal *, doublereal *, integer *);
    static integer in;
    extern doublereal dlamch_(char *);
    static integer mm;
    extern doublereal dlange_(char *, integer *, integer *, doublereal *, 
	    integer *, doublereal *);
    static integer jr;
    extern /* Subroutine */ int dgghrd_(char *, char *, integer *, integer *, 
	    integer *, doublereal *, integer *, doublereal *, integer *, 
	    doublereal *, integer *, doublereal *, integer *, integer *), dlascl_(char *, integer *, integer *, doublereal 
	    *, doublereal *, integer *, integer *, doublereal *, integer *, 
	    integer *);
    static logical ilascl, ilbscl;
    extern /* Subroutine */ int dgeqrf_(integer *, integer *, doublereal *, 
	    integer *, doublereal *, doublereal *, integer *, integer *), 
	    dlacpy_(char *, integer *, integer *, doublereal *, integer *, 
	    doublereal *, integer *);
    static logical ldumma[1];
    static char chtemp[1];
    static doublereal bignum;
    extern /* Subroutine */ int dhgeqz_(char *, char *, char *, integer *, 
	    integer *, integer *, doublereal *, integer *, doublereal *, 
	    integer *, doublereal *, doublereal *, doublereal *, doublereal *,
	     integer *, doublereal *, integer *, doublereal *, integer *, 
	    integer *), dlaset_(char *, integer *, 
	    integer *, doublereal *, doublereal *, doublereal *, integer *);
    static integer ijobvl;
    extern /* Subroutine */ int dtgevc_(char *, char *, logical *, integer *, 
	    doublereal *, integer *, doublereal *, integer *, doublereal *, 
	    integer *, doublereal *, integer *, integer *, integer *, 
	    doublereal *, integer *), dtgsna_(char *, char *, 
	    logical *, integer *, doublereal *, integer *, doublereal *, 
	    integer *, doublereal *, integer *, doublereal *, integer *, 
	    doublereal *, doublereal *, integer *, integer *, doublereal *, 
	    integer *, integer *, integer *), xerbla_(char *, 
	    integer *);
    extern integer ilaenv_(integer *, char *, char *, integer *, integer *, 
	    integer *, integer *, ftnlen, ftnlen);
    static integer ijobvr;
    static logical wantsb;
    extern /* Subroutine */ int dorgqr_(integer *, integer *, integer *, 
	    doublereal *, integer *, doublereal *, doublereal *, integer *, 
	    integer *);
    static doublereal anrmto;
    static logical wantse;
    static doublereal bnrmto;
    extern /* Subroutine */ int dormqr_(char *, char *, integer *, integer *, 
	    integer *, doublereal *, integer *, doublereal *, doublereal *, 
	    integer *, doublereal *, integer *, integer *);
    static integer minwrk, maxwrk;
    static logical wantsn;
    static doublereal smlnum;
    static logical lquery, wantsv;
    static doublereal eps;
    static logical ilv;
#define a_ref(a_1,a_2) a[(a_2)*a_dim1 + a_1]
#define b_ref(a_1,a_2) b[(a_2)*b_dim1 + a_1]
#define vl_ref(a_1,a_2) vl[(a_2)*vl_dim1 + a_1]
#define vr_ref(a_1,a_2) vr[(a_2)*vr_dim1 + a_1]


    a_dim1 = *lda;
    a_offset = 1 + a_dim1 * 1;
    a -= a_offset;
    b_dim1 = *ldb;
    b_offset = 1 + b_dim1 * 1;
    b -= b_offset;
    --alphar;
    --alphai;
    --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;
    --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 = -14;
    } else if (*ldvr < 1 || ilvr && *ldvr < *n) {
	*info = -16;
    }

/*     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 * 5 + *n * ilaenv_(&c__1, "DGEQRF", " ", n, &c__1, n, &
		c__0, (ftnlen)6, (ftnlen)1);
/* Computing MAX */
	i__1 = 1, i__2 = *n * 6;
	minwrk = max(i__1,i__2);
	if (wantse) {
/* Computing MAX */
	    i__1 = 1, i__2 = *n * 12;
	    minwrk = max(i__1,i__2);
	} else if (wantsv || wantsb) {
	    minwrk = (*n << 1) * *n + *n * 12 + 16;
/* Computing MAX */
	    i__1 = maxwrk, i__2 = (*n << 1) * *n + *n * 12 + 16;
	    maxwrk = max(i__1,i__2);
	}
	work[1] = (doublereal) maxwrk;
    }

    if (*lwork < minwrk && ! lquery) {
	*info = -26;
    }

    if (*info != 0) {
	i__1 = -(*info);
	xerbla_("DGGEVX", &i__1);
	return 0;
    } else if (lquery) {
	return 0;
    }

/*     Quick return if possible */

    if (*n == 0) {
	return 0;
    }


/*     Get machine constants */

    eps = dlamch_("P");
    smlnum = dlamch_("S");
    bignum = 1. / smlnum;
    dlabad_(&smlnum, &bignum);
    smlnum = sqrt(smlnum) / eps;
    bignum = 1. / smlnum;

/*     Scale A if max element outside range [SMLNUM,BIGNUM] */

    anrm = dlange_("M", n, n, &a[a_offset], lda, &work[1]);
    ilascl = FALSE_;
    if (anrm > 0. && anrm < smlnum) {
	anrmto = smlnum;
	ilascl = TRUE_;
    } else if (anrm > bignum) {
	anrmto = bignum;
	ilascl = TRUE_;
    }
    if (ilascl) {
	dlascl_("G", &c__0, &c__0, &anrm, &anrmto, n, n, &a[a_offset], lda, &
		ierr);
    }

/*     Scale B if max element outside range [SMLNUM,BIGNUM] */

    bnrm = dlange_("M", n, n, &b[b_offset], ldb, &work[1]);
    ilbscl = FALSE_;
    if (bnrm > 0. && bnrm < smlnum) {
	bnrmto = smlnum;
	ilbscl = TRUE_;
    } else if (bnrm > bignum) {
	bnrmto = bignum;
	ilbscl = TRUE_;
    }
    if (ilbscl) {
	dlascl_("G", &c__0, &c__0, &bnrm, &bnrmto, n, n, &b[b_offset], ldb, &
		ierr);
    }

/*     Permute and/or balance the matrix pair (A,B)   
       (Workspace: need 6*N) */

    dggbal_(balanc, n, &a[a_offset], lda, &b[b_offset], ldb, ilo, ihi, &
	    lscale[1], &rscale[1], &work[1], &ierr);

/*     Compute ABNRM and BBNRM */

    *abnrm = dlange_("1", n, n, &a[a_offset], lda, &work[1]);
    if (ilascl) {
	work[1] = *abnrm;
	dlascl_("G", &c__0, &c__0, &anrmto, &anrm, &c__1, &c__1, &work[1], &
		c__1, &ierr);
	*abnrm = work[1];
    }

    *bbnrm = dlange_("1", n, n, &b[b_offset], ldb, &work[1]);
    if (ilbscl) {
	work[1] = *bbnrm;
	dlascl_("G", &c__0, &c__0, &bnrmto, &bnrm, &c__1, &c__1, &work[1], &
		c__1, &ierr);
	*bbnrm = work[1];
    }

/*     Reduce B to triangular form (QR decomposition of B)   
       (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;
    dgeqrf_(&irows, &icols, &b_ref(*ilo, *ilo), ldb, &work[itau], &work[iwrk],
	     &i__1, &ierr);

/*     Apply the orthogonal transformation to A   
       (Workspace: need N, prefer N*NB) */

    i__1 = *lwork + 1 - iwrk;
    dormqr_("L", "T", &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) {
	dlaset_("Full", n, n, &c_b47, &c_b48, &vl[vl_offset], ldvl)
		;
	i__1 = irows - 1;
	i__2 = irows - 1;
	dlacpy_("L", &i__1, &i__2, &b_ref(*ilo + 1, *ilo), ldb, &vl_ref(*ilo 
		+ 1, *ilo), ldvl);
	i__1 = *lwork + 1 - iwrk;
	dorgqr_(&irows, &irows, &irows, &vl_ref(*ilo, *ilo), ldvl, &work[itau]
		, &work[iwrk], &i__1, &ierr);
    }

    if (ilvr) {
	dlaset_("Full", n, n, &c_b47, &c_b48, &vr[vr_offset], ldvr)
		;
    }

/*     Reduce to generalized Hessenberg form   
       (Workspace: none needed) */

    if (ilv || ! wantsn) {

/*        Eigenvectors requested -- work on whole matrix. */

	dgghrd_(jobvl, jobvr, n, ilo, ihi, &a[a_offset], lda, &b[b_offset], 
		ldb, &vl[vl_offset], ldvl, &vr[vr_offset], ldvr, &ierr);
    } else {
	dgghrd_("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)   
       (Workspace: need N) */

    if (ilv || ! wantsn) {
	*(unsigned char *)chtemp = 'S';
    } else {
	*(unsigned char *)chtemp = 'E';
    }

    dhgeqz_(chtemp, jobvl, jobvr, n, ilo, ihi, &a[a_offset], lda, &b[b_offset]
	    , ldb, &alphar[1], &alphai[1], &beta[1], &vl[vl_offset], ldvl, &
	    vr[vr_offset], ldvr, &work[1], lwork, &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 L130;
    }

/*     Compute Eigenvectors and estimate condition numbers if desired   
       (Workspace: DTGEVC: need 6*N   
                   DTGSNA: need 2*N*(N+2)+16 if SENSE = 'V' or 'B',   
                           need N otherwise ) */

    if (ilv || ! wantsn) {
	if (ilv) {
	    if (ilvl) {
		if (ilvr) {
		    *(unsigned char *)chtemp = 'B';
		} else {
		    *(unsigned char *)chtemp = 'L';
		}
	    } else {
		*(unsigned char *)chtemp = 'R';
	    }

	    dtgevc_(chtemp, "B", ldumma, n, &a[a_offset], lda, &b[b_offset], 
		    ldb, &vl[vl_offset], ldvl, &vr[vr_offset], ldvr, n, &in, &
		    work[1], &ierr);
	    if (ierr != 0) {
		*info = *n + 2;
		goto L130;
	    }
	}

	if (! wantsn) {

/*           compute eigenvectors (DTGEVC) and estimate condition   
             numbers (DTGSNA). 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 recalculate   
             eigenvectors and estimate one condition numbers at a time. */

	    pair = FALSE_;
	    i__1 = *n;
	    for (i__ = 1; i__ <= i__1; ++i__) {

		if (pair) {
		    pair = FALSE_;
		    goto L20;
		}
		mm = 1;
		if (i__ < *n) {
		    if (a_ref(i__ + 1, i__) != 0.) {
			pair = TRUE_;
			mm = 2;
		    }
		}

		i__2 = *n;
		for (j = 1; j <= i__2; ++j) {
		    bwork[j] = FALSE_;
/* L10: */
		}
		if (mm == 1) {
		    bwork[i__] = TRUE_;
		} else if (mm == 2) {
		    bwork[i__] = TRUE_;
		    bwork[i__ + 1] = TRUE_;
		}

		iwrk = mm * *n + 1;
		iwrk1 = iwrk + mm * *n;

/*              Compute a pair of left and right eigenvectors.   
                (compute workspace: need up to 4*N + 6*N) */

		if (wantse || wantsb) {
		    dtgevc_("B", "S", &bwork[1], n, &a[a_offset], lda, &b[
			    b_offset], ldb, &work[1], n, &work[iwrk], n, &mm, 
			    &m, &work[iwrk1], &ierr);
		    if (ierr != 0) {
			*info = *n + 2;
			goto L130;
		    }
		}

		i__2 = *lwork - iwrk1 + 1;
		dtgsna_(sense, "S", &bwork[1], n, &a[a_offset], lda, &b[
			b_offset], ldb, &work[1], n, &work[iwrk], n, &rconde[
			i__], &rcondv[i__], &mm, &m, &work[iwrk1], &i__2, &
			iwork[1], &ierr);

L20:
		;
	    }
	}
    }

/*     Undo balancing on VL and VR and normalization   
       (Workspace: none needed) */

    if (ilvl) {
	dggbak_(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) {
	    if (alphai[jc] < 0.) {
		goto L70;
	    }
	    temp = 0.;
	    if (alphai[jc] == 0.) {
		i__2 = *n;
		for (jr = 1; jr <= i__2; ++jr) {
/* Computing MAX */
		    d__2 = temp, d__3 = (d__1 = vl_ref(jr, jc), abs(d__1));
		    temp = max(d__2,d__3);
/* L30: */
		}
	    } else {
		i__2 = *n;
		for (jr = 1; jr <= i__2; ++jr) {
/* Computing MAX */
		    d__3 = temp, d__4 = (d__1 = vl_ref(jr, jc), abs(d__1)) + (
			    d__2 = vl_ref(jr, jc + 1), abs(d__2));
		    temp = max(d__3,d__4);
/* L40: */
		}
	    }
	    if (temp < smlnum) {
		goto L70;
	    }
	    temp = 1. / temp;
	    if (alphai[jc] == 0.) {
		i__2 = *n;
		for (jr = 1; jr <= i__2; ++jr) {
		    vl_ref(jr, jc) = vl_ref(jr, jc) * temp;
/* L50: */
		}
	    } else {
		i__2 = *n;
		for (jr = 1; jr <= i__2; ++jr) {
		    vl_ref(jr, jc) = vl_ref(jr, jc) * temp;
		    vl_ref(jr, jc + 1) = vl_ref(jr, jc + 1) * temp;
/* L60: */
		}
	    }
L70:
	    ;
	}
    }
    if (ilvr) {
	dggbak_(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) {
	    if (alphai[jc] < 0.) {
		goto L120;
	    }
	    temp = 0.;
	    if (alphai[jc] == 0.) {
		i__2 = *n;
		for (jr = 1; jr <= i__2; ++jr) {
/* Computing MAX */
		    d__2 = temp, d__3 = (d__1 = vr_ref(jr, jc), abs(d__1));
		    temp = max(d__2,d__3);
/* L80: */
		}
	    } else {
		i__2 = *n;
		for (jr = 1; jr <= i__2; ++jr) {
/* Computing MAX */
		    d__3 = temp, d__4 = (d__1 = vr_ref(jr, jc), abs(d__1)) + (
			    d__2 = vr_ref(jr, jc + 1), abs(d__2));
		    temp = max(d__3,d__4);
/* L90: */
		}
	    }
	    if (temp < smlnum) {
		goto L120;
	    }
	    temp = 1. / temp;
	    if (alphai[jc] == 0.) {
		i__2 = *n;
		for (jr = 1; jr <= i__2; ++jr) {
		    vr_ref(jr, jc) = vr_ref(jr, jc) * temp;
/* L100: */
		}
	    } else {
		i__2 = *n;
		for (jr = 1; jr <= i__2; ++jr) {
		    vr_ref(jr, jc) = vr_ref(jr, jc) * temp;
		    vr_ref(jr, jc + 1) = vr_ref(jr, jc + 1) * temp;
/* L110: */
		}
	    }
L120:
	    ;
	}
    }

/*     Undo scaling if necessary */

    if (ilascl) {
	dlascl_("G", &c__0, &c__0, &anrmto, &anrm, n, &c__1, &alphar[1], n, &
		ierr);
	dlascl_("G", &c__0, &c__0, &anrmto, &anrm, n, &c__1, &alphai[1], n, &
		ierr);
    }

    if (ilbscl) {
	dlascl_("G", &c__0, &c__0, &bnrmto, &bnrm, n, &c__1, &beta[1], n, &
		ierr);
    }

L130:
    work[1] = (doublereal) maxwrk;

    return 0;

/*     End of DGGEVX */

} /* dggevx_ */
Пример #4
0
/* 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_ */
Пример #5
0
/* 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_ */
Пример #6
0
/* Subroutine */ int zchkgk_(integer *nin, integer *nout)
{
    /* Format strings */
    static char fmt_9999[] = "(1x,\002.. test output of ZGGBAK .. \002)";
    static char fmt_9998[] = "(\002 value of largest test error             "
	    "     =\002,d12.3)";
    static char fmt_9997[] = "(\002 example number where ZGGBAL info is not "
	    "0    =\002,i4)";
    static char fmt_9996[] = "(\002 example number where ZGGBAK(L) info is n"
	    "ot 0 =\002,i4)";
    static char fmt_9995[] = "(\002 example number where ZGGBAK(R) info is n"
	    "ot 0 =\002,i4)";
    static char fmt_9994[] = "(\002 example number having largest error     "
	    "     =\002,i4)";
    static char fmt_9992[] = "(\002 number of examples where info is not 0  "
	    "     =\002,i4)";
    static char fmt_9991[] = "(\002 total number of examples tested         "
	    "     =\002,i4)";

    /* System generated locals */
    integer i__1, i__2, i__3, i__4;
    doublereal d__1, d__2, d__3, d__4;
    doublecomplex z__1, z__2;

    /* Builtin functions */
    integer s_rsle(cilist *), do_lio(integer *, integer *, char *, ftnlen), 
	    e_rsle(void);
    double d_imag(doublecomplex *);
    integer s_wsfe(cilist *), e_wsfe(void), do_fio(integer *, char *, ftnlen);

    /* Local variables */
    static integer info, lmax[4];
    static doublereal rmax, vmax;
    static doublecomplex work[2500]	/* was [50][50] */, a[2500]	/* 
	    was [50][50] */, b[2500]	/* was [50][50] */, e[2500]	/* 
	    was [50][50] */, f[2500]	/* was [50][50] */;
    static integer i__, j, m, n, ninfo;
    static doublereal anorm, bnorm;
    extern /* Subroutine */ int zgemm_(char *, char *, integer *, integer *, 
	    integer *, doublecomplex *, doublecomplex *, integer *, 
	    doublecomplex *, integer *, doublecomplex *, doublecomplex *, 
	    integer *);
    static doublereal rwork[300];
    static doublecomplex af[2500]	/* was [50][50] */, bf[2500]	/* 
	    was [50][50] */;
    extern doublereal dlamch_(char *);
    static doublecomplex vl[2500]	/* was [50][50] */;
    static doublereal lscale[50];
    extern /* Subroutine */ int zggbak_(char *, char *, integer *, integer *, 
	    integer *, doublereal *, doublereal *, integer *, doublecomplex *,
	     integer *, integer *), zggbal_(char *, integer *,
	     doublecomplex *, integer *, doublecomplex *, integer *, integer *
	    , integer *, doublereal *, doublereal *, doublereal *, integer *);
    static doublecomplex vr[2500]	/* was [50][50] */;
    static doublereal rscale[50];
    extern doublereal zlange_(char *, integer *, integer *, doublecomplex *, 
	    integer *, doublereal *);
    extern /* Subroutine */ int zlacpy_(char *, integer *, integer *, 
	    doublecomplex *, integer *, doublecomplex *, integer *);
    static integer ihi, ilo;
    static doublereal eps;
    static doublecomplex vlf[2500]	/* was [50][50] */;
    static integer knt;
    static doublecomplex vrf[2500]	/* was [50][50] */;

    /* Fortran I/O blocks */
    static cilist io___6 = { 0, 0, 0, 0, 0 };
    static cilist io___10 = { 0, 0, 0, 0, 0 };
    static cilist io___13 = { 0, 0, 0, 0, 0 };
    static cilist io___15 = { 0, 0, 0, 0, 0 };
    static cilist io___17 = { 0, 0, 0, 0, 0 };
    static cilist io___35 = { 0, 0, 0, fmt_9999, 0 };
    static cilist io___36 = { 0, 0, 0, fmt_9998, 0 };
    static cilist io___37 = { 0, 0, 0, fmt_9997, 0 };
    static cilist io___38 = { 0, 0, 0, fmt_9996, 0 };
    static cilist io___39 = { 0, 0, 0, fmt_9995, 0 };
    static cilist io___40 = { 0, 0, 0, fmt_9994, 0 };
    static cilist io___41 = { 0, 0, 0, fmt_9992, 0 };
    static cilist io___42 = { 0, 0, 0, fmt_9991, 0 };



#define a_subscr(a_1,a_2) (a_2)*50 + a_1 - 51
#define a_ref(a_1,a_2) a[a_subscr(a_1,a_2)]
#define b_subscr(a_1,a_2) (a_2)*50 + a_1 - 51
#define b_ref(a_1,a_2) b[b_subscr(a_1,a_2)]
#define e_subscr(a_1,a_2) (a_2)*50 + a_1 - 51
#define e_ref(a_1,a_2) e[e_subscr(a_1,a_2)]
#define f_subscr(a_1,a_2) (a_2)*50 + a_1 - 51
#define f_ref(a_1,a_2) f[f_subscr(a_1,a_2)]
#define vl_subscr(a_1,a_2) (a_2)*50 + a_1 - 51
#define vl_ref(a_1,a_2) vl[vl_subscr(a_1,a_2)]
#define vr_subscr(a_1,a_2) (a_2)*50 + a_1 - 51
#define vr_ref(a_1,a_2) vr[vr_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   
    =======   

    ZCHKGK tests ZGGBAK, a routine for backward balancing  of   
    a matrix pair (A, B).   

    Arguments   
    =========   

    NIN     (input) INTEGER   
            The logical unit number for input.  NIN > 0.   

    NOUT    (input) INTEGER   
            The logical unit number for output.  NOUT > 0.   

    ===================================================================== */


    lmax[0] = 0;
    lmax[1] = 0;
    lmax[2] = 0;
    lmax[3] = 0;
    ninfo = 0;
    knt = 0;
    rmax = 0.;

    eps = dlamch_("Precision");

L10:
    io___6.ciunit = *nin;
    s_rsle(&io___6);
    do_lio(&c__3, &c__1, (char *)&n, (ftnlen)sizeof(integer));
    do_lio(&c__3, &c__1, (char *)&m, (ftnlen)sizeof(integer));
    e_rsle();
    if (n == 0) {
	goto L100;
    }

    i__1 = n;
    for (i__ = 1; i__ <= i__1; ++i__) {
	io___10.ciunit = *nin;
	s_rsle(&io___10);
	i__2 = n;
	for (j = 1; j <= i__2; ++j) {
	    do_lio(&c__7, &c__1, (char *)&a_ref(i__, j), (ftnlen)sizeof(
		    doublecomplex));
	}
	e_rsle();
/* L20: */
    }

    i__1 = n;
    for (i__ = 1; i__ <= i__1; ++i__) {
	io___13.ciunit = *nin;
	s_rsle(&io___13);
	i__2 = n;
	for (j = 1; j <= i__2; ++j) {
	    do_lio(&c__7, &c__1, (char *)&b_ref(i__, j), (ftnlen)sizeof(
		    doublecomplex));
	}
	e_rsle();
/* L30: */
    }

    i__1 = n;
    for (i__ = 1; i__ <= i__1; ++i__) {
	io___15.ciunit = *nin;
	s_rsle(&io___15);
	i__2 = m;
	for (j = 1; j <= i__2; ++j) {
	    do_lio(&c__7, &c__1, (char *)&vl_ref(i__, j), (ftnlen)sizeof(
		    doublecomplex));
	}
	e_rsle();
/* L40: */
    }

    i__1 = n;
    for (i__ = 1; i__ <= i__1; ++i__) {
	io___17.ciunit = *nin;
	s_rsle(&io___17);
	i__2 = m;
	for (j = 1; j <= i__2; ++j) {
	    do_lio(&c__7, &c__1, (char *)&vr_ref(i__, j), (ftnlen)sizeof(
		    doublecomplex));
	}
	e_rsle();
/* L50: */
    }

    ++knt;

    anorm = zlange_("M", &n, &n, a, &c__50, rwork);
    bnorm = zlange_("M", &n, &n, b, &c__50, rwork);

    zlacpy_("FULL", &n, &n, a, &c__50, af, &c__50);
    zlacpy_("FULL", &n, &n, b, &c__50, bf, &c__50);

    zggbal_("B", &n, a, &c__50, b, &c__50, &ilo, &ihi, lscale, rscale, rwork, 
	    &info);
    if (info != 0) {
	++ninfo;
	lmax[0] = knt;
    }

    zlacpy_("FULL", &n, &m, vl, &c__50, vlf, &c__50);
    zlacpy_("FULL", &n, &m, vr, &c__50, vrf, &c__50);

    zggbak_("B", "L", &n, &ilo, &ihi, lscale, rscale, &m, vl, &c__50, &info);
    if (info != 0) {
	++ninfo;
	lmax[1] = knt;
    }

    zggbak_("B", "R", &n, &ilo, &ihi, lscale, rscale, &m, vr, &c__50, &info);
    if (info != 0) {
	++ninfo;
	lmax[2] = knt;
    }

/*     Test of ZGGBAK   

       Check tilde(VL)'*A*tilde(VR) - VL'*tilde(A)*VR   
       where tilde(A) denotes the transformed matrix. */

    zgemm_("N", "N", &n, &m, &n, &c_b2, af, &c__50, vr, &c__50, &c_b1, work, &
	    c__50);
    zgemm_("C", "N", &m, &m, &n, &c_b2, vl, &c__50, work, &c__50, &c_b1, e, &
	    c__50);

    zgemm_("N", "N", &n, &m, &n, &c_b2, a, &c__50, vrf, &c__50, &c_b1, work, &
	    c__50);
    zgemm_("C", "N", &m, &m, &n, &c_b2, vlf, &c__50, work, &c__50, &c_b1, f, &
	    c__50);

    vmax = 0.;
    i__1 = m;
    for (j = 1; j <= i__1; ++j) {
	i__2 = m;
	for (i__ = 1; i__ <= i__2; ++i__) {
	    i__3 = e_subscr(i__, j);
	    i__4 = f_subscr(i__, j);
	    z__2.r = e[i__3].r - f[i__4].r, z__2.i = e[i__3].i - f[i__4].i;
	    z__1.r = z__2.r, z__1.i = z__2.i;
/* Computing MAX */
	    d__3 = vmax, d__4 = (d__1 = z__1.r, abs(d__1)) + (d__2 = d_imag(&
		    z__1), abs(d__2));
	    vmax = max(d__3,d__4);
/* L60: */
	}
/* L70: */
    }
    vmax /= eps * max(anorm,bnorm);
    if (vmax > rmax) {
	lmax[3] = knt;
	rmax = vmax;
    }

/*     Check tilde(VL)'*B*tilde(VR) - VL'*tilde(B)*VR */

    zgemm_("N", "N", &n, &m, &n, &c_b2, bf, &c__50, vr, &c__50, &c_b1, work, &
	    c__50);
    zgemm_("C", "N", &m, &m, &n, &c_b2, vl, &c__50, work, &c__50, &c_b1, e, &
	    c__50);

    zgemm_("n", "n", &n, &m, &n, &c_b2, b, &c__50, vrf, &c__50, &c_b1, work, &
	    c__50);
    zgemm_("C", "N", &m, &m, &n, &c_b2, vlf, &c__50, work, &c__50, &c_b1, f, &
	    c__50);

    vmax = 0.;
    i__1 = m;
    for (j = 1; j <= i__1; ++j) {
	i__2 = m;
	for (i__ = 1; i__ <= i__2; ++i__) {
	    i__3 = e_subscr(i__, j);
	    i__4 = f_subscr(i__, j);
	    z__2.r = e[i__3].r - f[i__4].r, z__2.i = e[i__3].i - f[i__4].i;
	    z__1.r = z__2.r, z__1.i = z__2.i;
/* Computing MAX */
	    d__3 = vmax, d__4 = (d__1 = z__1.r, abs(d__1)) + (d__2 = d_imag(&
		    z__1), abs(d__2));
	    vmax = max(d__3,d__4);
/* L80: */
	}
/* L90: */
    }
    vmax /= eps * max(anorm,bnorm);
    if (vmax > rmax) {
	lmax[3] = knt;
	rmax = vmax;
    }

    goto L10;

L100:

    io___35.ciunit = *nout;
    s_wsfe(&io___35);
    e_wsfe();

    io___36.ciunit = *nout;
    s_wsfe(&io___36);
    do_fio(&c__1, (char *)&rmax, (ftnlen)sizeof(doublereal));
    e_wsfe();
    io___37.ciunit = *nout;
    s_wsfe(&io___37);
    do_fio(&c__1, (char *)&lmax[0], (ftnlen)sizeof(integer));
    e_wsfe();
    io___38.ciunit = *nout;
    s_wsfe(&io___38);
    do_fio(&c__1, (char *)&lmax[1], (ftnlen)sizeof(integer));
    e_wsfe();
    io___39.ciunit = *nout;
    s_wsfe(&io___39);
    do_fio(&c__1, (char *)&lmax[2], (ftnlen)sizeof(integer));
    e_wsfe();
    io___40.ciunit = *nout;
    s_wsfe(&io___40);
    do_fio(&c__1, (char *)&lmax[3], (ftnlen)sizeof(integer));
    e_wsfe();
    io___41.ciunit = *nout;
    s_wsfe(&io___41);
    do_fio(&c__1, (char *)&ninfo, (ftnlen)sizeof(integer));
    e_wsfe();
    io___42.ciunit = *nout;
    s_wsfe(&io___42);
    do_fio(&c__1, (char *)&knt, (ftnlen)sizeof(integer));
    e_wsfe();

    return 0;

/*     End of ZCHKGK */

} /* zchkgk_ */
Пример #7
0
/* Subroutine */ int shsein_(char *side, char *eigsrc, char *initv, logical *
	select, integer *n, real *h__, integer *ldh, real *wr, real *wi, real 
	*vl, integer *ldvl, real *vr, integer *ldvr, integer *mm, integer *m, 
	real *work, 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   
    =======   

    SHSEIN uses inverse iteration to find specified right and/or left   
    eigenvectors of a real 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 (WR,WI):   
            = 'Q': the eigenvalues were found using SHSEQR; 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 SHSEIN 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, SHSEIN 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/output) LOGICAL array, dimension (N)   
            Specifies the eigenvectors to be computed. To select the   
            real eigenvector corresponding to a real eigenvalue WR(j),   
            SELECT(j) must be set to .TRUE.. To select the complex   
            eigenvector corresponding to a complex eigenvalue   
            (WR(j),WI(j)), with complex conjugate (WR(j+1),WI(j+1)),   
            either SELECT(j) or SELECT(j+1) or both must be set to   
            .TRUE.; then on exit SELECT(j) is .TRUE. and SELECT(j+1) is   
            .FALSE..   

    N       (input) INTEGER   
            The order of the matrix H.  N >= 0.   

    H       (input) REAL array, dimension (LDH,N)   
            The upper Hessenberg matrix H.   

    LDH     (input) INTEGER   
            The leading dimension of the array H.  LDH >= max(1,N).   

    WR      (input/output) REAL array, dimension (N)   
    WI      (input) REAL array, dimension (N)   
            On entry, the real and imaginary parts of the eigenvalues of   
            H; a complex conjugate pair of eigenvalues must be stored in   
            consecutive elements of WR and WI.   
            On exit, WR may have been altered since close eigenvalues   
            are perturbed slightly in searching for independent   
            eigenvectors.   

    VL      (input/output) REAL 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(s) 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. A   
            complex eigenvector corresponding to a complex eigenvalue is   
            stored in two consecutive columns, the first holding the real   
            part and the second the imaginary part.   
            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) REAL 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(s) 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. A   
            complex eigenvector corresponding to a complex eigenvalue is   
            stored in two consecutive columns, the first holding the real   
            part and the second the imaginary part.   
            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; each selected real eigenvector   
            occupies one column and each selected complex eigenvector   
            occupies two columns.   

    WORK    (workspace) REAL array, dimension ((N+2)*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 the i-th and (i+1)th   
            columns of VL hold a complex eigenvector, then IFAILL(i) and   
            IFAILL(i+1) are set to the same value.   
            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 the i-th and (i+1)th   
            columns of VR hold a complex eigenvector, then IFAILR(i) and   
            IFAILR(i+1) are set to the same value.   
            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;
    real r__1, r__2;
    /* Local variables */
    static logical pair;
    static real unfl;
    static integer i__, k;
    extern logical lsame_(char *, char *);
    static integer iinfo;
    static logical leftv, bothv;
    static real hnorm;
    static integer kl, kr;
    extern doublereal slamch_(char *);
    extern /* Subroutine */ int slaein_(logical *, logical *, integer *, real 
	    *, integer *, real *, real *, real *, real *, real *, integer *, 
	    real *, real *, real *, real *, integer *), xerbla_(char *, 
	    integer *);
    static real bignum;
    extern doublereal slanhs_(char *, integer *, real *, integer *, real *);
    static logical noinit;
    static integer ldwork;
    static logical rightv, fromqr;
    static real smlnum;
    static integer kln, ksi;
    static real wki;
    static integer ksr;
    static real ulp, wkr, eps3;
#define h___ref(a_1,a_2) h__[(a_2)*h_dim1 + a_1]
#define vl_ref(a_1,a_2) vl[(a_2)*vl_dim1 + a_1]
#define vr_ref(a_1,a_2) vr[(a_2)*vr_dim1 + a_1]


    --select;
    h_dim1 = *ldh;
    h_offset = 1 + h_dim1 * 1;
    h__ -= h_offset;
    --wr;
    --wi;
    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;
    --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, and standardize the array SELECT. */

    *m = 0;
    pair = FALSE_;
    i__1 = *n;
    for (k = 1; k <= i__1; ++k) {
	if (pair) {
	    pair = FALSE_;
	    select[k] = FALSE_;
	} else {
	    if (wi[k] == 0.f) {
		if (select[k]) {
		    ++(*m);
		}
	    } else {
		pair = TRUE_;
		if (select[k] || select[k + 1]) {
		    select[k] = TRUE_;
		    *m += 2;
		}
	    }
	}
/* 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 = -11;
    } else if (*ldvr < 1 || rightv && *ldvr < *n) {
	*info = -13;
    } else if (*mm < *m) {
	*info = -14;
    }
    if (*info != 0) {
	i__1 = -(*info);
	xerbla_("SHSEIN", &i__1);
	return 0;
    }

/*     Quick return if possible. */

    if (*n == 0) {
	return 0;
    }

/*     Set machine-dependent constants. */

    unfl = slamch_("Safe minimum");
    ulp = slamch_("Precision");
    smlnum = unfl * (*n / ulp);
    bignum = (1.f - ulp) / smlnum;

    ldwork = *n + 1;

    kl = 1;
    kln = 0;
    if (fromqr) {
	kr = 0;
    } else {
	kr = *n;
    }
    ksr = 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__) {
		    if (h___ref(i__, i__ - 1) == 0.f) {
			goto L30;
		    }
/* L20: */
		}
L30:
		kl = i__;
		if (k > kr) {
		    i__2 = *n - 1;
		    for (i__ = k; i__ <= i__2; ++i__) {
			if (h___ref(i__ + 1, i__) == 0.f) {
			    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 = slanhs_("I", &i__2, &h___ref(kl, kl), ldh, &work[1]);
		if (hnorm > 0.f) {
		    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. */

	    wkr = wr[k];
	    wki = wi[k];
L60:
	    i__2 = kl;
	    for (i__ = k - 1; i__ >= i__2; --i__) {
		if (select[i__] && (r__1 = wr[i__] - wkr, dabs(r__1)) + (r__2 
			= wi[i__] - wki, dabs(r__2)) < eps3) {
		    wkr += eps3;
		    goto L60;
		}
/* L70: */
	    }
	    wr[k] = wkr;

	    pair = wki != 0.f;
	    if (pair) {
		ksi = ksr + 1;
	    } else {
		ksi = ksr;
	    }
	    if (leftv) {

/*              Compute left eigenvector. */

		i__2 = *n - kl + 1;
		slaein_(&c_false, &noinit, &i__2, &h___ref(kl, kl), ldh, &wkr,
			 &wki, &vl_ref(kl, ksr), &vl_ref(kl, ksi), &work[1], &
			ldwork, &work[*n * *n + *n + 1], &eps3, &smlnum, &
			bignum, &iinfo);
		if (iinfo > 0) {
		    if (pair) {
			*info += 2;
		    } else {
			++(*info);
		    }
		    ifaill[ksr] = k;
		    ifaill[ksi] = k;
		} else {
		    ifaill[ksr] = 0;
		    ifaill[ksi] = 0;
		}
		i__2 = kl - 1;
		for (i__ = 1; i__ <= i__2; ++i__) {
		    vl_ref(i__, ksr) = 0.f;
/* L80: */
		}
		if (pair) {
		    i__2 = kl - 1;
		    for (i__ = 1; i__ <= i__2; ++i__) {
			vl_ref(i__, ksi) = 0.f;
/* L90: */
		    }
		}
	    }
	    if (rightv) {

/*              Compute right eigenvector. */

		slaein_(&c_true, &noinit, &kr, &h__[h_offset], ldh, &wkr, &
			wki, &vr_ref(1, ksr), &vr_ref(1, ksi), &work[1], &
			ldwork, &work[*n * *n + *n + 1], &eps3, &smlnum, &
			bignum, &iinfo);
		if (iinfo > 0) {
		    if (pair) {
			*info += 2;
		    } else {
			++(*info);
		    }
		    ifailr[ksr] = k;
		    ifailr[ksi] = k;
		} else {
		    ifailr[ksr] = 0;
		    ifailr[ksi] = 0;
		}
		i__2 = *n;
		for (i__ = kr + 1; i__ <= i__2; ++i__) {
		    vr_ref(i__, ksr) = 0.f;
/* L100: */
		}
		if (pair) {
		    i__2 = *n;
		    for (i__ = kr + 1; i__ <= i__2; ++i__) {
			vr_ref(i__, ksi) = 0.f;
/* L110: */
		    }
		}
	    }

	    if (pair) {
		ksr += 2;
	    } else {
		++ksr;
	    }
	}
/* L120: */
    }

    return 0;

/*     End of SHSEIN */

} /* shsein_ */
Пример #8
0
/* 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_ */
Пример #9
0
/* Subroutine */ int sggev_(char *jobvl, char *jobvr, integer *n, real *a, 
	integer *lda, real *b, integer *ldb, real *alphar, real *alphai, real 
	*beta, real *vl, integer *ldvl, real *vr, integer *ldvr, real *work, 
	integer *lwork, 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   
    =======   

    SGGEV computes for a pair of N-by-N real 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 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   
    =========   

    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) REAL 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) REAL 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).   

    ALPHAR  (output) REAL array, dimension (N)   
    ALPHAI  (output) REAL array, dimension (N)   
    BETA    (output) REAL array, dimension (N)   
            On exit, (ALPHAR(j) + ALPHAI(j)*i)/BETA(j), j=1,...,N, will   
            be the generalized eigenvalues.  If ALPHAI(j) is zero, then   
            the j-th eigenvalue is real; if positive, then the j-th and   
            (j+1)-st eigenvalues are a complex conjugate pair, with   
            ALPHAI(j+1) negative.   

            Note: the quotients ALPHAR(j)/BETA(j) and ALPHAI(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, ALPHAR and ALPHAI 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) REAL array, dimension (LDVL,N)   
            If JOBVL = 'V', the left eigenvectors u(j) are stored one   
            after another in the columns of VL, in the same order as   
            their eigenvalues. If the j-th eigenvalue is real, then   
            u(j) = VL(:,j), the j-th column of VL. If the j-th and   
            (j+1)-th eigenvalues form a complex conjugate pair, then   
            u(j) = VL(:,j)+i*VL(:,j+1) and u(j+1) = VL(:,j)-i*VL(:,j+1).   
            Each eigenvector will be scaled so the largest component 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) REAL array, dimension (LDVR,N)   
            If JOBVR = 'V', the right eigenvectors v(j) are stored one   
            after another in the columns of VR, in the same order as   
            their eigenvalues. If the j-th eigenvalue is real, then   
            v(j) = VR(:,j), the j-th column of VR. If the j-th and   
            (j+1)-th eigenvalues form a complex conjugate pair, then   
            v(j) = VR(:,j)+i*VR(:,j+1) and v(j+1) = VR(:,j)-i*VR(:,j+1).   
            Each eigenvector will be scaled so the largest component 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) REAL 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,8*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.   

    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 ALPHAR(j), ALPHAI(j), and BETA(j)   
                  should be correct for j=INFO+1,...,N.   
            > N:  =N+1: other than QZ iteration failed in SHGEQZ.   
                  =N+2: error return from STGEVC.   

    =====================================================================   


       Decode the input arguments   

       Parameter adjustments */
    /* Table of constant values */
    static integer c__1 = 1;
    static integer c__0 = 0;
    static real c_b26 = 0.f;
    static real c_b27 = 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;
    real r__1, r__2, r__3, r__4;
    /* Builtin functions */
    double sqrt(doublereal);
    /* 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, irows, jc;
    extern /* Subroutine */ int slabad_(real *, real *);
    static integer in, jr;
    extern /* Subroutine */ int sggbak_(char *, char *, integer *, integer *, 
	    integer *, real *, real *, integer *, real *, integer *, integer *
	    ), sggbal_(char *, integer *, real *, integer *, 
	    real *, integer *, integer *, integer *, real *, real *, real *, 
	    integer *);
    static logical ilascl, ilbscl;
    extern doublereal slamch_(char *), slange_(char *, integer *, 
	    integer *, real *, integer *, real *);
    extern /* Subroutine */ int xerbla_(char *, integer *), sgghrd_(
	    char *, char *, integer *, integer *, integer *, real *, integer *
	    , real *, integer *, real *, integer *, real *, integer *, 
	    integer *);
    static logical ldumma[1];
    static char chtemp[1];
    static real bignum;
    extern /* Subroutine */ int slascl_(char *, integer *, integer *, real *, 
	    real *, integer *, integer *, real *, integer *, integer *);
    extern integer ilaenv_(integer *, char *, char *, integer *, integer *, 
	    integer *, integer *, ftnlen, ftnlen);
    static integer ijobvl, iright;
    extern /* Subroutine */ int sgeqrf_(integer *, integer *, real *, integer 
	    *, real *, real *, integer *, integer *);
    static integer ijobvr;
    extern /* Subroutine */ int slacpy_(char *, integer *, integer *, real *, 
	    integer *, real *, integer *), slaset_(char *, integer *, 
	    integer *, real *, real *, real *, integer *), stgevc_(
	    char *, char *, logical *, integer *, real *, integer *, real *, 
	    integer *, real *, integer *, real *, integer *, integer *, 
	    integer *, real *, integer *);
    static real anrmto, bnrmto;
    extern /* Subroutine */ int shgeqz_(char *, char *, char *, integer *, 
	    integer *, integer *, real *, integer *, real *, integer *, real *
	    , real *, real *, real *, integer *, real *, integer *, real *, 
	    integer *, integer *);
    static integer minwrk, maxwrk;
    static real smlnum;
    extern /* Subroutine */ int sorgqr_(integer *, integer *, integer *, real 
	    *, integer *, real *, real *, integer *, integer *);
    static logical lquery;
    extern /* Subroutine */ int sormqr_(char *, char *, integer *, integer *, 
	    integer *, real *, integer *, real *, real *, integer *, real *, 
	    integer *, integer *);
    static integer ihi, ilo;
    static real eps;
    static logical ilv;
#define a_ref(a_1,a_2) a[(a_2)*a_dim1 + a_1]
#define b_ref(a_1,a_2) b[(a_2)*b_dim1 + a_1]
#define vl_ref(a_1,a_2) vl[(a_2)*vl_dim1 + a_1]
#define vr_ref(a_1,a_2) vr[(a_2)*vr_dim1 + a_1]


    a_dim1 = *lda;
    a_offset = 1 + a_dim1 * 1;
    a -= a_offset;
    b_dim1 = *ldb;
    b_offset = 1 + b_dim1 * 1;
    b -= b_offset;
    --alphar;
    --alphai;
    --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;

    /* 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 = -12;
    } else if (*ldvr < 1 || ilvr && *ldvr < *n) {
	*info = -14;
    }

/*     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 * 7 + *n * ilaenv_(&c__1, "SGEQRF", " ", n, &c__1, n, &
		c__0, (ftnlen)6, (ftnlen)1);
/* Computing MAX */
	i__1 = 1, i__2 = *n << 3;
	minwrk = max(i__1,i__2);
	work[1] = (real) maxwrk;
    }

    if (*lwork < minwrk && ! lquery) {
	*info = -16;
    }

    if (*info != 0) {
	i__1 = -(*info);
	xerbla_("SGGEV ", &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 = slange_("M", n, n, &a[a_offset], lda, &work[1]);
    ilascl = FALSE_;
    if (anrm > 0.f && anrm < smlnum) {
	anrmto = smlnum;
	ilascl = TRUE_;
    } else if (anrm > bignum) {
	anrmto = bignum;
	ilascl = TRUE_;
    }
    if (ilascl) {
	slascl_("G", &c__0, &c__0, &anrm, &anrmto, n, n, &a[a_offset], lda, &
		ierr);
    }

/*     Scale B if max element outside range [SMLNUM,BIGNUM] */

    bnrm = slange_("M", n, n, &b[b_offset], ldb, &work[1]);
    ilbscl = FALSE_;
    if (bnrm > 0.f && bnrm < smlnum) {
	bnrmto = smlnum;
	ilbscl = TRUE_;
    } else if (bnrm > bignum) {
	bnrmto = bignum;
	ilbscl = TRUE_;
    }
    if (ilbscl) {
	slascl_("G", &c__0, &c__0, &bnrm, &bnrmto, n, n, &b[b_offset], ldb, &
		ierr);
    }

/*     Permute the matrices A, B to isolate eigenvalues if possible   
       (Workspace: need 6*N) */

    ileft = 1;
    iright = *n + 1;
    iwrk = iright + *n;
    sggbal_("P", n, &a[a_offset], lda, &b[b_offset], ldb, &ilo, &ihi, &work[
	    ileft], &work[iright], &work[iwrk], &ierr);

/*     Reduce B to triangular form (QR decomposition of B)   
       (Workspace: need N, prefer N*NB) */

    irows = ihi + 1 - ilo;
    if (ilv) {
	icols = *n + 1 - ilo;
    } else {
	icols = irows;
    }
    itau = iwrk;
    iwrk = itau + irows;
    i__1 = *lwork + 1 - iwrk;
    sgeqrf_(&irows, &icols, &b_ref(ilo, ilo), ldb, &work[itau], &work[iwrk], &
	    i__1, &ierr);

/*     Apply the orthogonal transformation to matrix A   
       (Workspace: need N, prefer N*NB) */

    i__1 = *lwork + 1 - iwrk;
    sormqr_("L", "T", &irows, &icols, &irows, &b_ref(ilo, ilo), ldb, &work[
	    itau], &a_ref(ilo, ilo), lda, &work[iwrk], &i__1, &ierr);

/*     Initialize VL   
       (Workspace: need N, prefer N*NB) */

    if (ilvl) {
	slaset_("Full", n, n, &c_b26, &c_b27, &vl[vl_offset], ldvl)
		;
	i__1 = irows - 1;
	i__2 = irows - 1;
	slacpy_("L", &i__1, &i__2, &b_ref(ilo + 1, ilo), ldb, &vl_ref(ilo + 1,
		 ilo), ldvl);
	i__1 = *lwork + 1 - iwrk;
	sorgqr_(&irows, &irows, &irows, &vl_ref(ilo, ilo), ldvl, &work[itau], 
		&work[iwrk], &i__1, &ierr);
    }

/*     Initialize VR */

    if (ilvr) {
	slaset_("Full", n, n, &c_b26, &c_b27, &vr[vr_offset], ldvr)
		;
    }

/*     Reduce to generalized Hessenberg form   
       (Workspace: none needed) */

    if (ilv) {

/*        Eigenvectors requested -- work on whole matrix. */

	sgghrd_(jobvl, jobvr, n, &ilo, &ihi, &a[a_offset], lda, &b[b_offset], 
		ldb, &vl[vl_offset], ldvl, &vr[vr_offset], ldvr, &ierr);
    } else {
	sgghrd_("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)   
       (Workspace: need N) */

    iwrk = itau;
    if (ilv) {
	*(unsigned char *)chtemp = 'S';
    } else {
	*(unsigned char *)chtemp = 'E';
    }
    i__1 = *lwork + 1 - iwrk;
    shgeqz_(chtemp, jobvl, jobvr, n, &ilo, &ihi, &a[a_offset], lda, &b[
	    b_offset], ldb, &alphar[1], &alphai[1], &beta[1], &vl[vl_offset], 
	    ldvl, &vr[vr_offset], ldvr, &work[iwrk], &i__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 L110;
    }

/*     Compute Eigenvectors   
       (Workspace: need 6*N) */

    if (ilv) {
	if (ilvl) {
	    if (ilvr) {
		*(unsigned char *)chtemp = 'B';
	    } else {
		*(unsigned char *)chtemp = 'L';
	    }
	} else {
	    *(unsigned char *)chtemp = 'R';
	}
	stgevc_(chtemp, "B", ldumma, n, &a[a_offset], lda, &b[b_offset], ldb, 
		&vl[vl_offset], ldvl, &vr[vr_offset], ldvr, n, &in, &work[
		iwrk], &ierr);
	if (ierr != 0) {
	    *info = *n + 2;
	    goto L110;
	}

/*        Undo balancing on VL and VR and normalization   
          (Workspace: none needed) */

	if (ilvl) {
	    sggbak_("P", "L", n, &ilo, &ihi, &work[ileft], &work[iright], n, &
		    vl[vl_offset], ldvl, &ierr);
	    i__1 = *n;
	    for (jc = 1; jc <= i__1; ++jc) {
		if (alphai[jc] < 0.f) {
		    goto L50;
		}
		temp = 0.f;
		if (alphai[jc] == 0.f) {
		    i__2 = *n;
		    for (jr = 1; jr <= i__2; ++jr) {
/* Computing MAX */
			r__2 = temp, r__3 = (r__1 = vl_ref(jr, jc), dabs(r__1)
				);
			temp = dmax(r__2,r__3);
/* L10: */
		    }
		} else {
		    i__2 = *n;
		    for (jr = 1; jr <= i__2; ++jr) {
/* Computing MAX */
			r__3 = temp, r__4 = (r__1 = vl_ref(jr, jc), dabs(r__1)
				) + (r__2 = vl_ref(jr, jc + 1), dabs(r__2));
			temp = dmax(r__3,r__4);
/* L20: */
		    }
		}
		if (temp < smlnum) {
		    goto L50;
		}
		temp = 1.f / temp;
		if (alphai[jc] == 0.f) {
		    i__2 = *n;
		    for (jr = 1; jr <= i__2; ++jr) {
			vl_ref(jr, jc) = vl_ref(jr, jc) * temp;
/* L30: */
		    }
		} else {
		    i__2 = *n;
		    for (jr = 1; jr <= i__2; ++jr) {
			vl_ref(jr, jc) = vl_ref(jr, jc) * temp;
			vl_ref(jr, jc + 1) = vl_ref(jr, jc + 1) * temp;
/* L40: */
		    }
		}
L50:
		;
	    }
	}
	if (ilvr) {
	    sggbak_("P", "R", n, &ilo, &ihi, &work[ileft], &work[iright], n, &
		    vr[vr_offset], ldvr, &ierr);
	    i__1 = *n;
	    for (jc = 1; jc <= i__1; ++jc) {
		if (alphai[jc] < 0.f) {
		    goto L100;
		}
		temp = 0.f;
		if (alphai[jc] == 0.f) {
		    i__2 = *n;
		    for (jr = 1; jr <= i__2; ++jr) {
/* Computing MAX */
			r__2 = temp, r__3 = (r__1 = vr_ref(jr, jc), dabs(r__1)
				);
			temp = dmax(r__2,r__3);
/* L60: */
		    }
		} else {
		    i__2 = *n;
		    for (jr = 1; jr <= i__2; ++jr) {
/* Computing MAX */
			r__3 = temp, r__4 = (r__1 = vr_ref(jr, jc), dabs(r__1)
				) + (r__2 = vr_ref(jr, jc + 1), dabs(r__2));
			temp = dmax(r__3,r__4);
/* L70: */
		    }
		}
		if (temp < smlnum) {
		    goto L100;
		}
		temp = 1.f / temp;
		if (alphai[jc] == 0.f) {
		    i__2 = *n;
		    for (jr = 1; jr <= i__2; ++jr) {
			vr_ref(jr, jc) = vr_ref(jr, jc) * temp;
/* L80: */
		    }
		} else {
		    i__2 = *n;
		    for (jr = 1; jr <= i__2; ++jr) {
			vr_ref(jr, jc) = vr_ref(jr, jc) * temp;
			vr_ref(jr, jc + 1) = vr_ref(jr, jc + 1) * temp;
/* L90: */
		    }
		}
L100:
		;
	    }
	}

/*        End of eigenvector calculation */

    }

/*     Undo scaling if necessary */

    if (ilascl) {
	slascl_("G", &c__0, &c__0, &anrmto, &anrm, n, &c__1, &alphar[1], n, &
		ierr);
	slascl_("G", &c__0, &c__0, &anrmto, &anrm, n, &c__1, &alphai[1], n, &
		ierr);
    }

    if (ilbscl) {
	slascl_("G", &c__0, &c__0, &bnrmto, &bnrm, n, &c__1, &beta[1], n, &
		ierr);
    }

L110:

    work[1] = (real) maxwrk;

    return 0;

/*     End of SGGEV */

} /* sggev_ */
Пример #10
0
/* Subroutine */ int ztrsna_(char *job, char *howmny, logical *select, 
	integer *n, doublecomplex *t, integer *ldt, doublecomplex *vl, 
	integer *ldvl, doublecomplex *vr, integer *ldvr, doublereal *s, 
	doublereal *sep, integer *mm, integer *m, doublecomplex *work, 
	integer *ldwork, 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   
       September 30, 1994   


    Purpose   
    =======   

    ZTRSNA estimates reciprocal condition numbers for specified   
    eigenvalues and/or right eigenvectors of a complex upper triangular   
    matrix T (or of any matrix Q*T*Q**H with Q unitary).   

    Arguments   
    =========   

    JOB     (input) CHARACTER*1   
            Specifies whether condition numbers are required for   
            eigenvalues (S) or eigenvectors (SEP):   
            = 'E': for eigenvalues only (S);   
            = 'V': for eigenvectors only (SEP);   
            = 'B': for both eigenvalues and eigenvectors (S and SEP).   

    HOWMNY  (input) CHARACTER*1   
            = 'A': compute condition numbers for all eigenpairs;   
            = 'S': compute condition numbers for selected eigenpairs   
                   specified by the array SELECT.   

    SELECT  (input) LOGICAL array, dimension (N)   
            If HOWMNY = 'S', SELECT specifies the eigenpairs for which   
            condition numbers are required. To select condition numbers   
            for the j-th eigenpair, SELECT(j) must be set to .TRUE..   
            If HOWMNY = 'A', SELECT is not referenced.   

    N       (input) INTEGER   
            The order of the matrix T. N >= 0.   

    T       (input) COMPLEX*16 array, dimension (LDT,N)   
            The upper triangular matrix T.   

    LDT     (input) INTEGER   
            The leading dimension of the array T. LDT >= max(1,N).   

    VL      (input) COMPLEX*16 array, dimension (LDVL,M)   
            If JOB = 'E' or 'B', VL must contain left eigenvectors of T   
            (or of any Q*T*Q**H with Q unitary), corresponding to the   
            eigenpairs specified by HOWMNY and SELECT. The eigenvectors   
            must be stored in consecutive columns of VL, as returned by   
            ZHSEIN or ZTREVC.   
            If JOB = 'V', VL is not referenced.   

    LDVL    (input) INTEGER   
            The leading dimension of the array VL.   
            LDVL >= 1; and if JOB = 'E' or 'B', LDVL >= N.   

    VR      (input) COMPLEX*16 array, dimension (LDVR,M)   
            If JOB = 'E' or 'B', VR must contain right eigenvectors of T   
            (or of any Q*T*Q**H with Q unitary), corresponding to the   
            eigenpairs specified by HOWMNY and SELECT. The eigenvectors   
            must be stored in consecutive columns of VR, as returned by   
            ZHSEIN or ZTREVC.   
            If JOB = 'V', VR is not referenced.   

    LDVR    (input) INTEGER   
            The leading dimension of the array VR.   
            LDVR >= 1; and if JOB = 'E' or 'B', LDVR >= N.   

    S       (output) DOUBLE PRECISION array, dimension (MM)   
            If JOB = 'E' or 'B', the reciprocal condition numbers of the   
            selected eigenvalues, stored in consecutive elements of the   
            array. Thus S(j), SEP(j), and the j-th columns of VL and VR   
            all correspond to the same eigenpair (but not in general the   
            j-th eigenpair, unless all eigenpairs are selected).   
            If JOB = 'V', S is not referenced.   

    SEP     (output) DOUBLE PRECISION array, dimension (MM)   
            If JOB = 'V' or 'B', the estimated reciprocal condition   
            numbers of the selected eigenvectors, stored in consecutive   
            elements of the array.   
            If JOB = 'E', SEP is not referenced.   

    MM      (input) INTEGER   
            The number of elements in the arrays S (if JOB = 'E' or 'B')   
             and/or SEP (if JOB = 'V' or 'B'). MM >= M.   

    M       (output) INTEGER   
            The number of elements of the arrays S and/or SEP actually   
            used to store the estimated condition numbers.   
            If HOWMNY = 'A', M is set to N.   

    WORK    (workspace) COMPLEX*16 array, dimension (LDWORK,N+1)   
            If JOB = 'E', WORK is not referenced.   

    LDWORK  (input) INTEGER   
            The leading dimension of the array WORK.   
            LDWORK >= 1; and if JOB = 'V' or 'B', LDWORK >= N.   

    RWORK   (workspace) DOUBLE PRECISION array, dimension (N)   
            If JOB = 'E', RWORK is not referenced.   

    INFO    (output) INTEGER   
            = 0: successful exit   
            < 0: if INFO = -i, the i-th argument had an illegal value   

    Further Details   
    ===============   

    The reciprocal of the condition number of an eigenvalue lambda is   
    defined as   

            S(lambda) = |v'*u| / (norm(u)*norm(v))   

    where u and v are the right and left eigenvectors of T corresponding   
    to lambda; v' denotes the conjugate transpose of v, and norm(u)   
    denotes the Euclidean norm. These reciprocal condition numbers always   
    lie between zero (very badly conditioned) and one (very well   
    conditioned). If n = 1, S(lambda) is defined to be 1.   

    An approximate error bound for a computed eigenvalue W(i) is given by   

                        EPS * norm(T) / S(i)   

    where EPS is the machine precision.   

    The reciprocal of the condition number of the right eigenvector u   
    corresponding to lambda is defined as follows. Suppose   

                T = ( lambda  c  )   
                    (   0    T22 )   

    Then the reciprocal condition number is   

            SEP( lambda, T22 ) = sigma-min( T22 - lambda*I )   

    where sigma-min denotes the smallest singular value. We approximate   
    the smallest singular value by the reciprocal of an estimate of the   
    one-norm of the inverse of T22 - lambda*I. If n = 1, SEP(1) is   
    defined to be abs(T(1,1)).   

    An approximate error bound for a computed right eigenvector VR(i)   
    is given by   

                        EPS * norm(T) / SEP(i)   

    =====================================================================   


       Decode and test the input parameters   

       Parameter adjustments */
    /* Table of constant values */
    static integer c__1 = 1;
    
    /* System generated locals */
    integer t_dim1, t_offset, vl_dim1, vl_offset, vr_dim1, vr_offset, 
	    work_dim1, work_offset, i__1, i__2, i__3, i__4, i__5;
    doublereal d__1, d__2;
    doublecomplex z__1;
    /* Builtin functions */
    double z_abs(doublecomplex *), d_imag(doublecomplex *);
    /* Local variables */
    static integer kase, ierr;
    static doublecomplex prod;
    static doublereal lnrm, rnrm;
    static integer i__, j, k;
    static doublereal scale;
    extern logical lsame_(char *, char *);
    extern /* Double Complex */ VOID zdotc_(doublecomplex *, integer *, 
	    doublecomplex *, integer *, doublecomplex *, integer *);
    static doublecomplex dummy[1];
    static logical wants;
    static doublereal xnorm;
    extern /* Subroutine */ int dlabad_(doublereal *, doublereal *);
    extern doublereal dznrm2_(integer *, doublecomplex *, integer *), dlamch_(
	    char *);
    static integer ks, ix;
    extern /* Subroutine */ int xerbla_(char *, integer *);
    static doublereal bignum;
    static logical wantbh;
    extern /* Subroutine */ int zlacon_(integer *, doublecomplex *, 
	    doublecomplex *, doublereal *, integer *);
    extern integer izamax_(integer *, doublecomplex *, integer *);
    static logical somcon;
    extern /* Subroutine */ int zdrscl_(integer *, doublereal *, 
	    doublecomplex *, integer *);
    static char normin[1];
    extern /* Subroutine */ int zlacpy_(char *, integer *, integer *, 
	    doublecomplex *, integer *, doublecomplex *, integer *);
    static doublereal smlnum;
    static logical wantsp;
    extern /* Subroutine */ int zlatrs_(char *, char *, char *, char *, 
	    integer *, doublecomplex *, integer *, doublecomplex *, 
	    doublereal *, doublereal *, integer *), ztrexc_(char *, integer *, doublecomplex *, integer *, 
	    doublecomplex *, integer *, integer *, integer *, integer *);
    static doublereal eps, est;
#define work_subscr(a_1,a_2) (a_2)*work_dim1 + a_1
#define work_ref(a_1,a_2) work[work_subscr(a_1,a_2)]
#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;
    --s;
    --sep;
    work_dim1 = *ldwork;
    work_offset = 1 + work_dim1 * 1;
    work -= work_offset;
    --rwork;

    /* Function Body */
    wantbh = lsame_(job, "B");
    wants = lsame_(job, "E") || wantbh;
    wantsp = lsame_(job, "V") || wantbh;

    somcon = lsame_(howmny, "S");

/*     Set M to the number of eigenpairs for which condition numbers are   
       to be computed. */

    if (somcon) {
	*m = 0;
	i__1 = *n;
	for (j = 1; j <= i__1; ++j) {
	    if (select[j]) {
		++(*m);
	    }
/* L10: */
	}
    } else {
	*m = *n;
    }

    *info = 0;
    if (! wants && ! wantsp) {
	*info = -1;
    } else if (! lsame_(howmny, "A") && ! somcon) {
	*info = -2;
    } else if (*n < 0) {
	*info = -4;
    } else if (*ldt < max(1,*n)) {
	*info = -6;
    } else if (*ldvl < 1 || wants && *ldvl < *n) {
	*info = -8;
    } else if (*ldvr < 1 || wants && *ldvr < *n) {
	*info = -10;
    } else if (*mm < *m) {
	*info = -13;
    } else if (*ldwork < 1 || wantsp && *ldwork < *n) {
	*info = -16;
    }
    if (*info != 0) {
	i__1 = -(*info);
	xerbla_("ZTRSNA", &i__1);
	return 0;
    }

/*     Quick return if possible */

    if (*n == 0) {
	return 0;
    }

    if (*n == 1) {
	if (somcon) {
	    if (! select[1]) {
		return 0;
	    }
	}
	if (wants) {
	    s[1] = 1.;
	}
	if (wantsp) {
	    sep[1] = z_abs(&t_ref(1, 1));
	}
	return 0;
    }

/*     Get machine constants */

    eps = dlamch_("P");
    smlnum = dlamch_("S") / eps;
    bignum = 1. / smlnum;
    dlabad_(&smlnum, &bignum);

    ks = 1;
    i__1 = *n;
    for (k = 1; k <= i__1; ++k) {

	if (somcon) {
	    if (! select[k]) {
		goto L50;
	    }
	}

	if (wants) {

/*           Compute the reciprocal condition number of the k-th   
             eigenvalue. */

	    zdotc_(&z__1, n, &vr_ref(1, ks), &c__1, &vl_ref(1, ks), &c__1);
	    prod.r = z__1.r, prod.i = z__1.i;
	    rnrm = dznrm2_(n, &vr_ref(1, ks), &c__1);
	    lnrm = dznrm2_(n, &vl_ref(1, ks), &c__1);
	    s[ks] = z_abs(&prod) / (rnrm * lnrm);

	}

	if (wantsp) {

/*           Estimate the reciprocal condition number of the k-th   
             eigenvector.   

             Copy the matrix T to the array WORK and swap the k-th   
             diagonal element to the (1,1) position. */

	    zlacpy_("Full", n, n, &t[t_offset], ldt, &work[work_offset], 
		    ldwork);
	    ztrexc_("No Q", n, &work[work_offset], ldwork, dummy, &c__1, &k, &
		    c__1, &ierr);

/*           Form  C = T22 - lambda*I in WORK(2:N,2:N). */

	    i__2 = *n;
	    for (i__ = 2; i__ <= i__2; ++i__) {
		i__3 = work_subscr(i__, i__);
		i__4 = work_subscr(i__, i__);
		i__5 = work_subscr(1, 1);
		z__1.r = work[i__4].r - work[i__5].r, z__1.i = work[i__4].i - 
			work[i__5].i;
		work[i__3].r = z__1.r, work[i__3].i = z__1.i;
/* L20: */
	    }

/*           Estimate a lower bound for the 1-norm of inv(C'). The 1st   
             and (N+1)th columns of WORK are used to store work vectors. */

	    sep[ks] = 0.;
	    est = 0.;
	    kase = 0;
	    *(unsigned char *)normin = 'N';
L30:
	    i__2 = *n - 1;
	    zlacon_(&i__2, &work_ref(1, *n + 1), &work[work_offset], &est, &
		    kase);

	    if (kase != 0) {
		if (kase == 1) {

/*                 Solve C'*x = scale*b */

		    i__2 = *n - 1;
		    zlatrs_("Upper", "Conjugate transpose", "Nonunit", normin,
			     &i__2, &work_ref(2, 2), ldwork, &work[
			    work_offset], &scale, &rwork[1], &ierr);
		} else {

/*                 Solve C*x = scale*b */

		    i__2 = *n - 1;
		    zlatrs_("Upper", "No transpose", "Nonunit", normin, &i__2,
			     &work_ref(2, 2), ldwork, &work[work_offset], &
			    scale, &rwork[1], &ierr);
		}
		*(unsigned char *)normin = 'Y';
		if (scale != 1.) {

/*                 Multiply by 1/SCALE if doing so will not cause   
                   overflow. */

		    i__2 = *n - 1;
		    ix = izamax_(&i__2, &work[work_offset], &c__1);
		    i__2 = work_subscr(ix, 1);
		    xnorm = (d__1 = work[i__2].r, abs(d__1)) + (d__2 = d_imag(
			    &work_ref(ix, 1)), abs(d__2));
		    if (scale < xnorm * smlnum || scale == 0.) {
			goto L40;
		    }
		    zdrscl_(n, &scale, &work[work_offset], &c__1);
		}
		goto L30;
	    }

	    sep[ks] = 1. / max(est,smlnum);
	}

L40:
	++ks;
L50:
	;
    }
    return 0;

/*     End of ZTRSNA */

} /* ztrsna_ */
Пример #11
0
/* 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_ */
Пример #12
0
/* Subroutine */ int zggev_(char *jobvl, char *jobvr, integer *n, 
	doublecomplex *a, integer *lda, doublecomplex *b, integer *ldb, 
	doublecomplex *alpha, doublecomplex *beta, doublecomplex *vl, integer 
	*ldvl, doublecomplex *vr, integer *ldvr, doublecomplex *work, integer 
	*lwork, doublereal *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   
    =======   

    ZGGEV 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*16 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*16 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*16 array, dimension (N)   
    BETA    (output) COMPLEX*16 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*16 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*16 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*16 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) DOUBLE PRECISION 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 DHGEQZ,   
                  =N+2: error return from DTGEVC.   

    =====================================================================   


       Decode the input arguments   

       Parameter adjustments */
    /* Table of constant values */
    static doublecomplex c_b1 = {0.,0.};
    static doublecomplex c_b2 = {1.,0.};
    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;
    doublereal d__1, d__2, d__3, d__4;
    doublecomplex z__1;
    /* Builtin functions */
    double sqrt(doublereal), d_imag(doublecomplex *);
    /* Local variables */
    static doublereal anrm, bnrm;
    static integer ierr, itau;
    static doublereal temp;
    static logical ilvl, ilvr;
    static integer iwrk;
    extern logical lsame_(char *, char *);
    static integer ileft, icols, irwrk, irows;
    extern /* Subroutine */ int dlabad_(doublereal *, doublereal *);
    static integer jc, in;
    extern doublereal dlamch_(char *);
    static integer jr;
    extern /* Subroutine */ int zggbak_(char *, char *, integer *, integer *, 
	    integer *, doublereal *, doublereal *, integer *, doublecomplex *,
	     integer *, integer *), zggbal_(char *, integer *,
	     doublecomplex *, integer *, doublecomplex *, integer *, integer *
	    , integer *, doublereal *, doublereal *, doublereal *, integer *);
    static logical ilascl, ilbscl;
    extern /* Subroutine */ int xerbla_(char *, integer *);
    extern integer ilaenv_(integer *, char *, char *, integer *, integer *, 
	    integer *, integer *, ftnlen, ftnlen);
    static logical ldumma[1];
    static char chtemp[1];
    static doublereal bignum;
    extern doublereal zlange_(char *, integer *, integer *, doublecomplex *, 
	    integer *, doublereal *);
    static integer ijobvl, iright;
    extern /* Subroutine */ int zgghrd_(char *, char *, integer *, integer *, 
	    integer *, doublecomplex *, integer *, doublecomplex *, integer *,
	     doublecomplex *, integer *, doublecomplex *, integer *, integer *
	    ), zlascl_(char *, integer *, integer *, 
	    doublereal *, doublereal *, integer *, integer *, doublecomplex *,
	     integer *, integer *);
    static integer ijobvr;
    extern /* Subroutine */ int zgeqrf_(integer *, integer *, doublecomplex *,
	     integer *, doublecomplex *, doublecomplex *, integer *, integer *
	    );
    static doublereal anrmto;
    static integer lwkmin;
    static doublereal bnrmto;
    extern /* Subroutine */ int zlacpy_(char *, integer *, integer *, 
	    doublecomplex *, integer *, doublecomplex *, integer *), 
	    zlaset_(char *, integer *, integer *, doublecomplex *, 
	    doublecomplex *, doublecomplex *, integer *), ztgevc_(
	    char *, char *, logical *, integer *, doublecomplex *, integer *, 
	    doublecomplex *, integer *, doublecomplex *, integer *, 
	    doublecomplex *, integer *, integer *, integer *, doublecomplex *,
	     doublereal *, integer *), zhgeqz_(char *, char *,
	     char *, integer *, integer *, integer *, doublecomplex *, 
	    integer *, doublecomplex *, integer *, doublecomplex *, 
	    doublecomplex *, doublecomplex *, integer *, doublecomplex *, 
	    integer *, doublecomplex *, integer *, doublereal *, integer *);
    static doublereal smlnum;
    static integer lwkopt;
    static logical lquery;
    extern /* Subroutine */ int zungqr_(integer *, integer *, integer *, 
	    doublecomplex *, integer *, doublecomplex *, doublecomplex *, 
	    integer *, integer *), zunmqr_(char *, char *, integer *, integer 
	    *, integer *, doublecomplex *, integer *, doublecomplex *, 
	    doublecomplex *, integer *, doublecomplex *, integer *, integer *);
    static integer ihi, ilo;
    static doublereal 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, "ZGEQRF", " ", 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 = (doublereal) lwkopt, work[1].i = 0.;
    }

    if (*lwork < lwkmin && ! lquery) {
	*info = -15;
    }

    if (*info != 0) {
	i__1 = -(*info);
	xerbla_("ZGGEV ", &i__1);
	return 0;
    } else if (lquery) {
	return 0;
    }

/*     Quick return if possible */

    work[1].r = (doublereal) lwkopt, work[1].i = 0.;
    if (*n == 0) {
	return 0;
    }

/*     Get machine constants */

    eps = dlamch_("E") * dlamch_("B");
    smlnum = dlamch_("S");
    bignum = 1. / smlnum;
    dlabad_(&smlnum, &bignum);
    smlnum = sqrt(smlnum) / eps;
    bignum = 1. / smlnum;

/*     Scale A if max element outside range [SMLNUM,BIGNUM] */

    anrm = zlange_("M", n, n, &a[a_offset], lda, &rwork[1]);
    ilascl = FALSE_;
    if (anrm > 0. && anrm < smlnum) {
	anrmto = smlnum;
	ilascl = TRUE_;
    } else if (anrm > bignum) {
	anrmto = bignum;
	ilascl = TRUE_;
    }
    if (ilascl) {
	zlascl_("G", &c__0, &c__0, &anrm, &anrmto, n, n, &a[a_offset], lda, &
		ierr);
    }

/*     Scale B if max element outside range [SMLNUM,BIGNUM] */

    bnrm = zlange_("M", n, n, &b[b_offset], ldb, &rwork[1]);
    ilbscl = FALSE_;
    if (bnrm > 0. && bnrm < smlnum) {
	bnrmto = smlnum;
	ilbscl = TRUE_;
    } else if (bnrm > bignum) {
	bnrmto = bignum;
	ilbscl = TRUE_;
    }
    if (ilbscl) {
	zlascl_("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;
    zggbal_("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;
    zgeqrf_(&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;
    zunmqr_("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) {
	zlaset_("Full", n, n, &c_b1, &c_b2, &vl[vl_offset], ldvl);
	i__1 = irows - 1;
	i__2 = irows - 1;
	zlacpy_("L", &i__1, &i__2, &b_ref(ilo + 1, ilo), ldb, &vl_ref(ilo + 1,
		 ilo), ldvl);
	i__1 = *lwork + 1 - iwrk;
	zungqr_(&irows, &irows, &irows, &vl_ref(ilo, ilo), ldvl, &work[itau], 
		&work[iwrk], &i__1, &ierr);
    }

/*     Initialize VR */

    if (ilvr) {
	zlaset_("Full", n, n, &c_b1, &c_b2, &vr[vr_offset], ldvr);
    }

/*     Reduce to generalized Hessenberg form */

    if (ilv) {

/*        Eigenvectors requested -- work on whole matrix. */

	zgghrd_(jobvl, jobvr, n, &ilo, &ihi, &a[a_offset], lda, &b[b_offset], 
		ldb, &vl[vl_offset], ldvl, &vr[vr_offset], ldvr, &ierr);
    } else {
	zgghrd_("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;
    zhgeqz_(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';
	}

	ztgevc_(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) {
	    zggbak_("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.;
		i__2 = *n;
		for (jr = 1; jr <= i__2; ++jr) {
/* Computing MAX */
		    i__3 = vl_subscr(jr, jc);
		    d__3 = temp, d__4 = (d__1 = vl[i__3].r, abs(d__1)) + (
			    d__2 = d_imag(&vl_ref(jr, jc)), abs(d__2));
		    temp = max(d__3,d__4);
/* L10: */
		}
		if (temp < smlnum) {
		    goto L30;
		}
		temp = 1. / temp;
		i__2 = *n;
		for (jr = 1; jr <= i__2; ++jr) {
		    i__3 = vl_subscr(jr, jc);
		    i__4 = vl_subscr(jr, jc);
		    z__1.r = temp * vl[i__4].r, z__1.i = temp * vl[i__4].i;
		    vl[i__3].r = z__1.r, vl[i__3].i = z__1.i;
/* L20: */
		}
L30:
		;
	    }
	}
	if (ilvr) {
	    zggbak_("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.;
		i__2 = *n;
		for (jr = 1; jr <= i__2; ++jr) {
/* Computing MAX */
		    i__3 = vr_subscr(jr, jc);
		    d__3 = temp, d__4 = (d__1 = vr[i__3].r, abs(d__1)) + (
			    d__2 = d_imag(&vr_ref(jr, jc)), abs(d__2));
		    temp = max(d__3,d__4);
/* L40: */
		}
		if (temp < smlnum) {
		    goto L60;
		}
		temp = 1. / temp;
		i__2 = *n;
		for (jr = 1; jr <= i__2; ++jr) {
		    i__3 = vr_subscr(jr, jc);
		    i__4 = vr_subscr(jr, jc);
		    z__1.r = temp * vr[i__4].r, z__1.i = temp * vr[i__4].i;
		    vr[i__3].r = z__1.r, vr[i__3].i = z__1.i;
/* L50: */
		}
L60:
		;
	    }
	}
    }

/*     Undo scaling if necessary */

    if (ilascl) {
	zlascl_("G", &c__0, &c__0, &anrmto, &anrm, n, &c__1, &alpha[1], n, &
		ierr);
    }

    if (ilbscl) {
	zlascl_("G", &c__0, &c__0, &bnrmto, &bnrm, n, &c__1, &beta[1], n, &
		ierr);
    }

L70:
    work[1].r = (doublereal) lwkopt, work[1].i = 0.;

    return 0;

/*     End of ZGGEV */

} /* zggev_ */