示例#1
0
文件: ztrevc.c 项目: 151706061/ITK
/*<    >*/
/* 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, ftnlen 
        side_len, ftnlen howmny_len)
{
    /* 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 */
    integer i__, j, k, ii, ki, is;
    doublereal ulp;
    logical allv;
    doublereal unfl, ovfl, smin;
    logical over;
    doublereal scale;
    extern logical lsame_(const char *, const char *, ftnlen, ftnlen);
    doublereal remax;
    logical leftv, bothv;
    extern /* Subroutine */ int zgemv_(char *, integer *, integer *, 
            doublecomplex *, doublecomplex *, integer *, doublecomplex *, 
            integer *, doublecomplex *, doublecomplex *, integer *, ftnlen);
    logical somev;
    extern /* Subroutine */ int zcopy_(integer *, doublecomplex *, integer *, 
            doublecomplex *, integer *), dlabad_(doublereal *, doublereal *);
    extern doublereal dlamch_(char *, ftnlen);
    extern /* Subroutine */ int xerbla_(char *, integer *, ftnlen), zdscal_(
            integer *, doublereal *, doublecomplex *, integer *);
    extern integer izamax_(integer *, doublecomplex *, integer *);
    logical rightv;
    extern doublereal dzasum_(integer *, doublecomplex *, integer *);
    doublereal smlnum;
    extern /* Subroutine */ int zlatrs_(char *, char *, char *, char *, 
            integer *, doublecomplex *, integer *, doublecomplex *, 
            doublereal *, doublereal *, integer *, ftnlen, ftnlen, ftnlen, 
            ftnlen);
    (void)side_len;
    (void)howmny_len;

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

/*     .. Scalar Arguments .. */
/*<       CHARACTER          HOWMNY, SIDE >*/
/*<       INTEGER            INFO, LDT, LDVL, LDVR, M, MM, N >*/
/*     .. */
/*     .. Array Arguments .. */
/*<       LOGICAL            SELECT( * ) >*/
/*<       DOUBLE PRECISION   RWORK( * ) >*/
/*<    >*/
/*     .. */

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

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

/*     .. Parameters .. */
/*<       DOUBLE PRECISION   ZERO, ONE >*/
/*<       PARAMETER          ( ZERO = 0.0D+0, ONE = 1.0D+0 ) >*/
/*<       COMPLEX*16         CMZERO, CMONE >*/
/*<    >*/
/*     .. */
/*     .. Local Scalars .. */
/*<       LOGICAL            ALLV, BOTHV, LEFTV, OVER, RIGHTV, SOMEV >*/
/*<       INTEGER            I, II, IS, J, K, KI >*/
/*<       DOUBLE PRECISION   OVFL, REMAX, SCALE, SMIN, SMLNUM, ULP, UNFL >*/
/*<       COMPLEX*16         CDUM >*/
/*     .. */
/*     .. External Functions .. */
/*<       LOGICAL            LSAME >*/
/*<       INTEGER            IZAMAX >*/
/*<       DOUBLE PRECISION   DLAMCH, DZASUM >*/
/*<       EXTERNAL           LSAME, IZAMAX, DLAMCH, DZASUM >*/
/*     .. */
/*     .. External Subroutines .. */
/*<       EXTERNAL           XERBLA, ZCOPY, ZDSCAL, ZGEMV, ZLATRS >*/
/*     .. */
/*     .. Intrinsic Functions .. */
/*<       INTRINSIC          ABS, DBLE, DCMPLX, DCONJG, DIMAG, MAX >*/
/*     .. */
/*     .. Statement Functions .. */
/*<       DOUBLE PRECISION   CABS1 >*/
/*     .. */
/*     .. Statement Function definitions .. */
/*<       CABS1( CDUM ) = ABS( DBLE( CDUM ) ) + ABS( DIMAG( CDUM ) ) >*/
/*     .. */
/*     .. Executable Statements .. */

/*     Decode and test the input parameters */

/*<       BOTHV = LSAME( SIDE, 'B' ) >*/
    /* Parameter adjustments */
    --select;
    t_dim1 = *ldt;
    t_offset = 1 + t_dim1;
    t -= t_offset;
    vl_dim1 = *ldvl;
    vl_offset = 1 + vl_dim1;
    vl -= vl_offset;
    vr_dim1 = *ldvr;
    vr_offset = 1 + vr_dim1;
    vr -= vr_offset;
    --work;
    --rwork;

    /* Function Body */
    bothv = lsame_(side, "B", (ftnlen)1, (ftnlen)1);
/*<       RIGHTV = LSAME( SIDE, 'R' ) .OR. BOTHV >*/
    rightv = lsame_(side, "R", (ftnlen)1, (ftnlen)1) || bothv;
/*<       LEFTV = LSAME( SIDE, 'L' ) .OR. BOTHV >*/
    leftv = lsame_(side, "L", (ftnlen)1, (ftnlen)1) || bothv;

/*<       ALLV = LSAME( HOWMNY, 'A' ) >*/
    allv = lsame_(howmny, "A", (ftnlen)1, (ftnlen)1);
/*<       OVER = LSAME( HOWMNY, 'B' ) >*/
    over = lsame_(howmny, "B", (ftnlen)1, (ftnlen)1);
/*<       SOMEV = LSAME( HOWMNY, 'S' ) >*/
    somev = lsame_(howmny, "S", (ftnlen)1, (ftnlen)1);

/*     Set M to the number of columns required to store the selected */
/*     eigenvectors. */

/*<       IF( SOMEV ) THEN >*/
    if (somev) {
/*<          M = 0 >*/
        *m = 0;
/*<          DO 10 J = 1, N >*/
        i__1 = *n;
        for (j = 1; j <= i__1; ++j) {
/*<    >*/
            if (select[j]) {
                ++(*m);
            }
/*<    10    CONTINUE >*/
/* L10: */
        }
/*<       ELSE >*/
    } else {
/*<          M = N >*/
        *m = *n;
/*<       END IF >*/
    }

/*<       INFO = 0 >*/
    *info = 0;
/*<       IF( .NOT.RIGHTV .AND. .NOT.LEFTV ) THEN >*/
    if (! rightv && ! leftv) {
/*<          INFO = -1 >*/
        *info = -1;
/*<       ELSE IF( .NOT.ALLV .AND. .NOT.OVER .AND. .NOT.SOMEV ) THEN >*/
    } else if (! allv && ! over && ! somev) {
/*<          INFO = -2 >*/
        *info = -2;
/*<       ELSE IF( N.LT.0 ) THEN >*/
    } else if (*n < 0) {
/*<          INFO = -4 >*/
        *info = -4;
/*<       ELSE IF( LDT.LT.MAX( 1, N ) ) THEN >*/
    } else if (*ldt < max(1,*n)) {
/*<          INFO = -6 >*/
        *info = -6;
/*<       ELSE IF( LDVL.LT.1 .OR. ( LEFTV .AND. LDVL.LT.N ) ) THEN >*/
    } else if (*ldvl < 1 || (leftv && *ldvl < *n)) {
/*<          INFO = -8 >*/
        *info = -8;
/*<       ELSE IF( LDVR.LT.1 .OR. ( RIGHTV .AND. LDVR.LT.N ) ) THEN >*/
    } else if (*ldvr < 1 || (rightv && *ldvr < *n)) {
/*<          INFO = -10 >*/
        *info = -10;
/*<       ELSE IF( MM.LT.M ) THEN >*/
    } else if (*mm < *m) {
/*<          INFO = -11 >*/
        *info = -11;
/*<       END IF >*/
    }
/*<       IF( INFO.NE.0 ) THEN >*/
    if (*info != 0) {
/*<          CALL XERBLA( 'ZTREVC', -INFO ) >*/
        i__1 = -(*info);
        xerbla_("ZTREVC", &i__1, (ftnlen)6);
/*<          RETURN >*/
        return 0;
/*<       END IF >*/
    }

/*     Quick return if possible. */

/*<    >*/
    if (*n == 0) {
        return 0;
    }

/*     Set the constants to control overflow. */

/*<       UNFL = DLAMCH( 'Safe minimum' ) >*/
    unfl = dlamch_("Safe minimum", (ftnlen)12);
/*<       OVFL = ONE / UNFL >*/
    ovfl = 1. / unfl;
/*<       CALL DLABAD( UNFL, OVFL ) >*/
    dlabad_(&unfl, &ovfl);
/*<       ULP = DLAMCH( 'Precision' ) >*/
    ulp = dlamch_("Precision", (ftnlen)9);
/*<       SMLNUM = UNFL*( N / ULP ) >*/
    smlnum = unfl * (*n / ulp);

/*     Store the diagonal elements of T in working array WORK. */

/*<       DO 20 I = 1, N >*/
    i__1 = *n;
    for (i__ = 1; i__ <= i__1; ++i__) {
/*<          WORK( I+N ) = T( I, I ) >*/
        i__2 = i__ + *n;
        i__3 = i__ + i__ * t_dim1;
        work[i__2].r = t[i__3].r, work[i__2].i = t[i__3].i;
/*<    20 CONTINUE >*/
/* L20: */
    }

/*     Compute 1-norm of each column of strictly upper triangular */
/*     part of T to control overflow in triangular solver. */

/*<       RWORK( 1 ) = ZERO >*/
    rwork[1] = 0.;
/*<       DO 30 J = 2, N >*/
    i__1 = *n;
    for (j = 2; j <= i__1; ++j) {
/*<          RWORK( J ) = DZASUM( J-1, T( 1, J ), 1 ) >*/
        i__2 = j - 1;
        rwork[j] = dzasum_(&i__2, &t[j * t_dim1 + 1], &c__1);
/*<    30 CONTINUE >*/
/* L30: */
    }

/*<       IF( RIGHTV ) THEN >*/
    if (rightv) {

/*        Compute right eigenvectors. */

/*<          IS = M >*/
        is = *m;
/*<          DO 80 KI = N, 1, -1 >*/
        for (ki = *n; ki >= 1; --ki) {

/*<             IF( SOMEV ) THEN >*/
            if (somev) {
/*<    >*/
                if (! select[ki]) {
                    goto L80;
                }
/*<             END IF >*/
            }
/*<             SMIN = MAX( ULP*( CABS1( T( KI, KI ) ) ), SMLNUM ) >*/
/* Computing MAX */
            i__1 = ki + ki * t_dim1;
            d__3 = ulp * ((d__1 = t[i__1].r, abs(d__1)) + (d__2 = d_imag(&t[
                    ki + ki * t_dim1]), abs(d__2)));
            smin = max(d__3,smlnum);

/*<             WORK( 1 ) = CMONE >*/
            work[1].r = 1., work[1].i = 0.;

/*           Form right-hand side. */

/*<             DO 40 K = 1, KI - 1 >*/
            i__1 = ki - 1;
            for (k = 1; k <= i__1; ++k) {
/*<                WORK( K ) = -T( K, KI ) >*/
                i__2 = k;
                i__3 = k + ki * t_dim1;
                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;
/*<    40       CONTINUE >*/
/* L40: */
            }

/*           Solve the triangular system: */
/*              (T(1:KI-1,1:KI-1) - T(KI,KI))*X = SCALE*WORK. */

/*<             DO 50 K = 1, KI - 1 >*/
            i__1 = ki - 1;
            for (k = 1; k <= i__1; ++k) {
/*<                T( K, K ) = T( K, K ) - T( KI, KI ) >*/
                i__2 = k + k * t_dim1;
                i__3 = k + k * t_dim1;
                i__4 = ki + ki * t_dim1;
                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 = k + k * t_dim1;
                if ((d__1 = t[i__2].r, abs(d__1)) + (d__2 = d_imag(&t[k + k * 
                        t_dim1]), abs(d__2)) < smin) {
                    i__3 = k + k * t_dim1;
                    t[i__3].r = smin, t[i__3].i = 0.;
                }
/*<    50       CONTINUE >*/
/* L50: */
            }

/*<             IF( KI.GT.1 ) THEN >*/
            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, (
                        ftnlen)5, (ftnlen)12, (ftnlen)8, (ftnlen)1);
/*<                WORK( KI ) = SCALE >*/
                i__1 = ki;
                work[i__1].r = scale, work[i__1].i = 0.;
/*<             END IF >*/
            }

/*           Copy the vector x or Q*x to VR and normalize. */

/*<             IF( .NOT.OVER ) THEN >*/
            if (! over) {
/*<                CALL ZCOPY( KI, WORK( 1 ), 1, VR( 1, IS ), 1 ) >*/
                zcopy_(&ki, &work[1], &c__1, &vr[is * vr_dim1 + 1], &c__1);

/*<                II = IZAMAX( KI, VR( 1, IS ), 1 ) >*/
                ii = izamax_(&ki, &vr[is * vr_dim1 + 1], &c__1);
/*<                REMAX = ONE / CABS1( VR( II, IS ) ) >*/
                i__1 = ii + is * vr_dim1;
                remax = 1. / ((d__1 = vr[i__1].r, abs(d__1)) + (d__2 = d_imag(
                        &vr[ii + is * vr_dim1]), abs(d__2)));
/*<                CALL ZDSCAL( KI, REMAX, VR( 1, IS ), 1 ) >*/
                zdscal_(&ki, &remax, &vr[is * vr_dim1 + 1], &c__1);

/*<                DO 60 K = KI + 1, N >*/
                i__1 = *n;
                for (k = ki + 1; k <= i__1; ++k) {
/*<                   VR( K, IS ) = CMZERO >*/
                    i__2 = k + is * vr_dim1;
                    vr[i__2].r = 0., vr[i__2].i = 0.;
/*<    60          CONTINUE >*/
/* L60: */
                }
/*<             ELSE >*/
            } 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[ki * vr_dim1 + 1], &c__1, (
                            ftnlen)1);
                }

/*<                II = IZAMAX( N, VR( 1, KI ), 1 ) >*/
                ii = izamax_(n, &vr[ki * vr_dim1 + 1], &c__1);
/*<                REMAX = ONE / CABS1( VR( II, KI ) ) >*/
                i__1 = ii + ki * vr_dim1;
                remax = 1. / ((d__1 = vr[i__1].r, abs(d__1)) + (d__2 = d_imag(
                        &vr[ii + ki * vr_dim1]), abs(d__2)));
/*<                CALL ZDSCAL( N, REMAX, VR( 1, KI ), 1 ) >*/
                zdscal_(n, &remax, &vr[ki * vr_dim1 + 1], &c__1);
/*<             END IF >*/
            }

/*           Set back the original diagonal elements of T. */

/*<             DO 70 K = 1, KI - 1 >*/
            i__1 = ki - 1;
            for (k = 1; k <= i__1; ++k) {
/*<                T( K, K ) = WORK( K+N ) >*/
                i__2 = k + k * t_dim1;
                i__3 = k + *n;
                t[i__2].r = work[i__3].r, t[i__2].i = work[i__3].i;
/*<    70       CONTINUE >*/
/* L70: */
            }

/*<             IS = IS - 1 >*/
            --is;
/*<    80    CONTINUE >*/
L80:
            ;
        }
/*<       END IF >*/
    }

/*<       IF( LEFTV ) THEN >*/
    if (leftv) {

/*        Compute left eigenvectors. */

/*<          IS = 1 >*/
        is = 1;
/*<          DO 130 KI = 1, N >*/
        i__1 = *n;
        for (ki = 1; ki <= i__1; ++ki) {

/*<             IF( SOMEV ) THEN >*/
            if (somev) {
/*<    >*/
                if (! select[ki]) {
                    goto L130;
                }
/*<             END IF >*/
            }
/*<             SMIN = MAX( ULP*( CABS1( T( KI, KI ) ) ), SMLNUM ) >*/
/* Computing MAX */
            i__2 = ki + ki * t_dim1;
            d__3 = ulp * ((d__1 = t[i__2].r, abs(d__1)) + (d__2 = d_imag(&t[
                    ki + ki * t_dim1]), abs(d__2)));
            smin = max(d__3,smlnum);

/*<             WORK( N ) = CMONE >*/
            i__2 = *n;
            work[i__2].r = 1., work[i__2].i = 0.;

/*           Form right-hand side. */

/*<             DO 90 K = KI + 1, N >*/
            i__2 = *n;
            for (k = ki + 1; k <= i__2; ++k) {
/*<                WORK( K ) = -DCONJG( T( KI, K ) ) >*/
                i__3 = k;
                d_cnjg(&z__2, &t[ki + k * t_dim1]);
                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;
/*<    90       CONTINUE >*/
/* L90: */
            }

/*           Solve the triangular system: */
/*              (T(KI+1:N,KI+1:N) - T(KI,KI))'*X = SCALE*WORK. */

/*<             DO 100 K = KI + 1, N >*/
            i__2 = *n;
            for (k = ki + 1; k <= i__2; ++k) {
/*<                T( K, K ) = T( K, K ) - T( KI, KI ) >*/
                i__3 = k + k * t_dim1;
                i__4 = k + k * t_dim1;
                i__5 = ki + ki * t_dim1;
                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 = k + k * t_dim1;
                if ((d__1 = t[i__3].r, abs(d__1)) + (d__2 = d_imag(&t[k + k * 
                        t_dim1]), abs(d__2)) < smin) {
                    i__4 = k + k * t_dim1;
                    t[i__4].r = smin, t[i__4].i = 0.;
                }
/*<   100       CONTINUE >*/
/* L100: */
            }

/*<             IF( KI.LT.N ) THEN >*/
            if (ki < *n) {
/*<    >*/
                i__2 = *n - ki;
                zlatrs_("Upper", "Conjugate transpose", "Non-unit", "Y", &
                        i__2, &t[ki + 1 + (ki + 1) * t_dim1], ldt, &work[ki + 
                        1], &scale, &rwork[1], info, (ftnlen)5, (ftnlen)19, (
                        ftnlen)8, (ftnlen)1);
/*<                WORK( KI ) = SCALE >*/
                i__2 = ki;
                work[i__2].r = scale, work[i__2].i = 0.;
/*<             END IF >*/
            }

/*           Copy the vector x or Q*x to VL and normalize. */

/*<             IF( .NOT.OVER ) THEN >*/
            if (! over) {
/*<                CALL ZCOPY( N-KI+1, WORK( KI ), 1, VL( KI, IS ), 1 ) >*/
                i__2 = *n - ki + 1;
                zcopy_(&i__2, &work[ki], &c__1, &vl[ki + is * vl_dim1], &c__1)
                        ;

/*<                II = IZAMAX( N-KI+1, VL( KI, IS ), 1 ) + KI - 1 >*/
                i__2 = *n - ki + 1;
                ii = izamax_(&i__2, &vl[ki + is * vl_dim1], &c__1) + ki - 1;
/*<                REMAX = ONE / CABS1( VL( II, IS ) ) >*/
                i__2 = ii + is * vl_dim1;
                remax = 1. / ((d__1 = vl[i__2].r, abs(d__1)) + (d__2 = d_imag(
                        &vl[ii + is * vl_dim1]), abs(d__2)));
/*<                CALL ZDSCAL( N-KI+1, REMAX, VL( KI, IS ), 1 ) >*/
                i__2 = *n - ki + 1;
                zdscal_(&i__2, &remax, &vl[ki + is * vl_dim1], &c__1);

/*<                DO 110 K = 1, KI - 1 >*/
                i__2 = ki - 1;
                for (k = 1; k <= i__2; ++k) {
/*<                   VL( K, IS ) = CMZERO >*/
                    i__3 = k + is * vl_dim1;
                    vl[i__3].r = 0., vl[i__3].i = 0.;
/*<   110          CONTINUE >*/
/* L110: */
                }
/*<             ELSE >*/
            } else {
/*<    >*/
                if (ki < *n) {
                    i__2 = *n - ki;
                    z__1.r = scale, z__1.i = 0.;
                    zgemv_("N", n, &i__2, &c_b2, &vl[(ki + 1) * vl_dim1 + 1], 
                            ldvl, &work[ki + 1], &c__1, &z__1, &vl[ki * 
                            vl_dim1 + 1], &c__1, (ftnlen)1);
                }

/*<                II = IZAMAX( N, VL( 1, KI ), 1 ) >*/
                ii = izamax_(n, &vl[ki * vl_dim1 + 1], &c__1);
/*<                REMAX = ONE / CABS1( VL( II, KI ) ) >*/
                i__2 = ii + ki * vl_dim1;
                remax = 1. / ((d__1 = vl[i__2].r, abs(d__1)) + (d__2 = d_imag(
                        &vl[ii + ki * vl_dim1]), abs(d__2)));
/*<                CALL ZDSCAL( N, REMAX, VL( 1, KI ), 1 ) >*/
                zdscal_(n, &remax, &vl[ki * vl_dim1 + 1], &c__1);
/*<             END IF >*/
            }

/*           Set back the original diagonal elements of T. */

/*<             DO 120 K = KI + 1, N >*/
            i__2 = *n;
            for (k = ki + 1; k <= i__2; ++k) {
/*<                T( K, K ) = WORK( K+N ) >*/
                i__3 = k + k * t_dim1;
                i__4 = k + *n;
                t[i__3].r = work[i__4].r, t[i__3].i = work[i__4].i;
/*<   120       CONTINUE >*/
/* L120: */
            }

/*<             IS = IS + 1 >*/
            ++is;
/*<   130    CONTINUE >*/
L130:
            ;
        }
/*<       END IF >*/
    }

/*<       RETURN >*/
    return 0;

/*     End of ZTREVC */

/*<       END >*/
} /* ztrevc_ */
示例#2
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_ */
示例#3
0
文件: dchkhs.c 项目: zangel/uquad
/* Subroutine */ int dchkhs_(integer *nsizes, integer *nn, integer *ntypes, 
	logical *dotype, integer *iseed, doublereal *thresh, integer *nounit, 
	doublereal *a, integer *lda, doublereal *h__, doublereal *t1, 
	doublereal *t2, doublereal *u, integer *ldu, doublereal *z__, 
	doublereal *uz, doublereal *wr1, doublereal *wi1, doublereal *wr3, 
	doublereal *wi3, doublereal *evectl, doublereal *evectr, doublereal *
	evecty, doublereal *evectx, doublereal *uu, doublereal *tau, 
	doublereal *work, integer *nwork, integer *iwork, logical *select, 
	doublereal *result, 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_9999[] = "(\002 DCHKHS: \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_9998[] = "(\002 DCHKHS: \002,a,\002 Eigenvectors from"
	    " \002,a,\002 incorrectly \002,\002normalized.\002,/\002 Bits of "
	    "error=\002,0p,g10.3,\002,\002,9x,\002N=\002,i6,\002, JTYPE=\002,"
	    "i6,\002, ISEED=(\002,3(i5,\002,\002),i5,\002)\002)";
    static char fmt_9997[] = "(\002 DCHKHS: Selected \002,a,\002 Eigenvector"
	    "s from \002,a,\002 do not match other eigenvectors \002,9x,\002N="
	    "\002,i6,\002, JTYPE=\002,i6,\002, ISEED=(\002,3(i5,\002,\002),i5,"
	    "\002)\002)";

    /* System generated locals */
    integer a_dim1, a_offset, evectl_dim1, evectl_offset, evectr_dim1, 
	    evectr_offset, evectx_dim1, evectx_offset, evecty_dim1, 
	    evecty_offset, h_dim1, h_offset, t1_dim1, t1_offset, t2_dim1, 
	    t2_offset, u_dim1, u_offset, uu_dim1, uu_offset, uz_dim1, 
	    uz_offset, z_dim1, z_offset, i__1, i__2, i__3, i__4;
    doublereal d__1, d__2, d__3, d__4, d__5, d__6;

    /* Builtin functions */
    double sqrt(doublereal);
    integer s_wsfe(cilist *), do_fio(integer *, char *, ftnlen), e_wsfe(void);

    /* Local variables */
    static doublereal cond;
    static integer jcol, nmax;
    static doublereal unfl, ovfl, temp1, temp2;
    static integer i__, j, k, n;
    static logical badnn;
    extern /* Subroutine */ int dget10_(integer *, integer *, doublereal *, 
	    integer *, doublereal *, integer *, doublereal *, doublereal *), 
	    dget22_(char *, char *, char *, integer *, doublereal *, integer *
	    , doublereal *, integer *, doublereal *, doublereal *, doublereal 
	    *, doublereal *), dgemm_(char *, char *, 
	    integer *, integer *, integer *, doublereal *, doublereal *, 
	    integer *, doublereal *, integer *, doublereal *, doublereal *, 
	    integer *);
    static logical match;
    static integer imode;
    static doublereal dumma[6];
    static integer iinfo, nselc;
    static doublereal conds;
    extern /* Subroutine */ int dhst01_(integer *, integer *, integer *, 
	    doublereal *, integer *, doublereal *, integer *, doublereal *, 
	    integer *, doublereal *, integer *, doublereal *);
    static doublereal aninv, anorm;
    extern /* Subroutine */ int dcopy_(integer *, doublereal *, integer *, 
	    doublereal *, integer *);
    static integer nmats, nselr, jsize, nerrs, itype, jtype, ntest, n1;
    static doublereal rtulp;
    extern /* Subroutine */ int dlabad_(doublereal *, doublereal *);
    static integer jj, in;
    extern doublereal dlamch_(char *);
    extern /* Subroutine */ int dgehrd_(integer *, integer *, integer *, 
	    doublereal *, integer *, doublereal *, doublereal *, integer *, 
	    integer *);
    static char adumma[1*1];
    extern /* Subroutine */ int dlatme_(integer *, char *, integer *, 
	    doublereal *, integer *, doublereal *, doublereal *, char *, char 
	    *, char *, char *, doublereal *, integer *, doublereal *, integer 
	    *, integer *, doublereal *, doublereal *, integer *, doublereal *,
	     integer *), dhsein_(char 
	    *, char *, char *, logical *, integer *, doublereal *, integer *, 
	    doublereal *, doublereal *, doublereal *, integer *, doublereal *,
	     integer *, integer *, integer *, doublereal *, integer *, 
	    integer *, integer *);
    static integer idumma[1];
    extern /* Subroutine */ int dlacpy_(char *, integer *, integer *, 
	    doublereal *, integer *, doublereal *, integer *);
    static integer ioldsd[4];
    extern /* Subroutine */ int dlafts_(char *, integer *, integer *, integer 
	    *, integer *, doublereal *, integer *, doublereal *, integer *, 
	    integer *), dlaset_(char *, integer *, integer *, 
	    doublereal *, doublereal *, doublereal *, integer *), 
	    dlasum_(char *, integer *, integer *, integer *), dhseqr_(
	    char *, char *, integer *, integer *, integer *, doublereal *, 
	    integer *, doublereal *, doublereal *, doublereal *, integer *, 
	    doublereal *, integer *, integer *), dlatmr_(
	    integer *, integer *, char *, integer *, char *, doublereal *, 
	    integer *, doublereal *, doublereal *, char *, char *, doublereal 
	    *, integer *, doublereal *, doublereal *, integer *, doublereal *,
	     char *, integer *, integer *, integer *, doublereal *, 
	    doublereal *, char *, doublereal *, integer *, integer *, integer 
	    *), dlatms_(
	    integer *, integer *, char *, integer *, char *, doublereal *, 
	    integer *, doublereal *, doublereal *, integer *, integer *, char 
	    *, doublereal *, integer *, doublereal *, integer *), dorghr_(integer *, integer *, integer *, 
	    doublereal *, integer *, doublereal *, doublereal *, integer *, 
	    integer *), dormhr_(char *, char *, integer *, integer *, integer 
	    *, integer *, doublereal *, integer *, doublereal *, doublereal *,
	     integer *, doublereal *, integer *, integer *), 
	    dtrevc_(char *, char *, logical *, integer *, doublereal *, 
	    integer *, doublereal *, integer *, doublereal *, integer *, 
	    integer *, integer *, doublereal *, integer *), 
	    xerbla_(char *, integer *);
    static doublereal rtunfl, rtovfl, rtulpi, ulpinv;
    static integer mtypes, ntestt, ihi, ilo;
    static doublereal ulp;

    /* Fortran I/O blocks */
    static cilist io___36 = { 0, 0, 0, fmt_9999, 0 };
    static cilist io___39 = { 0, 0, 0, fmt_9999, 0 };
    static cilist io___41 = { 0, 0, 0, fmt_9999, 0 };
    static cilist io___42 = { 0, 0, 0, fmt_9999, 0 };
    static cilist io___43 = { 0, 0, 0, fmt_9999, 0 };
    static cilist io___50 = { 0, 0, 0, fmt_9999, 0 };
    static cilist io___51 = { 0, 0, 0, fmt_9998, 0 };
    static cilist io___52 = { 0, 0, 0, fmt_9999, 0 };
    static cilist io___56 = { 0, 0, 0, fmt_9997, 0 };
    static cilist io___57 = { 0, 0, 0, fmt_9999, 0 };
    static cilist io___58 = { 0, 0, 0, fmt_9998, 0 };
    static cilist io___59 = { 0, 0, 0, fmt_9999, 0 };
    static cilist io___60 = { 0, 0, 0, fmt_9997, 0 };
    static cilist io___61 = { 0, 0, 0, fmt_9999, 0 };
    static cilist io___62 = { 0, 0, 0, fmt_9998, 0 };
    static cilist io___63 = { 0, 0, 0, fmt_9999, 0 };
    static cilist io___64 = { 0, 0, 0, fmt_9998, 0 };
    static cilist io___65 = { 0, 0, 0, fmt_9999, 0 };
    static cilist io___66 = { 0, 0, 0, fmt_9999, 0 };



#define a_ref(a_1,a_2) a[(a_2)*a_dim1 + a_1]
#define h___ref(a_1,a_2) h__[(a_2)*h_dim1 + a_1]
#define u_ref(a_1,a_2) u[(a_2)*u_dim1 + a_1]
#define uu_ref(a_1,a_2) uu[(a_2)*uu_dim1 + a_1]
#define evectl_ref(a_1,a_2) evectl[(a_2)*evectl_dim1 + a_1]
#define evectr_ref(a_1,a_2) evectr[(a_2)*evectr_dim1 + a_1]


/*  -- LAPACK test routine (version 3.0) --   
       Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,   
       Courant Institute, Argonne National Lab, and Rice University   
       October 31, 1999   


    Purpose   
    =======   

       DCHKHS  checks the nonsymmetric eigenvalue problem routines.   

               DGEHRD factors A as  U H U' , where ' means transpose,   
               H is hessenberg, and U is an orthogonal matrix.   

               DORGHR generates the orthogonal matrix U.   

               DORMHR multiplies a matrix by the orthogonal matrix U.   

               DHSEQR factors H as  Z T Z' , where Z is orthogonal and   
               T is "quasi-triangular", and the eigenvalue vector W.   

               DTREVC computes the left and right eigenvector matrices   
               L and R for T.   

               DHSEIN computes the left and right eigenvector matrices   
               Y and X for H, using inverse iteration.   

       When DCHKHS 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, 14   
       tests will be performed:   

       (1)     | A - U H U**T | / ( |A| n ulp )   

       (2)     | I - UU**T | / ( n ulp )   

       (3)     | H - Z T Z**T | / ( |H| n ulp )   

       (4)     | I - ZZ**T | / ( n ulp )   

       (5)     | A - UZ H (UZ)**T | / ( |A| n ulp )   

       (6)     | I - UZ (UZ)**T | / ( n ulp )   

       (7)     | T(Z computed) - T(Z not computed) | / ( |T| ulp )   

       (8)     | W(Z computed) - W(Z not computed) | / ( |W| ulp )   

       (9)     | TR - RW | / ( |T| |R| ulp )   

       (10)    | L**H T - W**H L | / ( |T| |L| ulp )   

       (11)    | HX - XW | / ( |H| |X| ulp )   

       (12)    | Y**H H - W**H Y | / ( |H| |Y| ulp )   

       (13)    | AX - XW | / ( |A| |X| ulp )   

       (14)    | Y**H A - W**H Y | / ( |A| |Y| ulp )   

       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 signs.   
            (ULP = (first number larger than 1) - 1 )   
       (5)  A diagonal matrix with geometrically spaced entries   
            1, ..., ULP  and random signs.   
       (6)  A diagonal matrix with "clustered" entries 1, ULP, ..., ULP   
            and random signs.   

       (7)  Same as (4), but multiplied by SQRT( overflow threshold )   
       (8)  Same as (4), but multiplied by SQRT( underflow threshold )   

       (9)  A matrix of the form  U' T U, where U is orthogonal and   
            T has evenly spaced entries 1, ..., ULP with random signs   
            on the diagonal and random O(1) entries in the upper   
            triangle.   

       (10) A matrix of the form  U' T U, where U is orthogonal and   
            T has geometrically spaced entries 1, ..., ULP with random   
            signs on the diagonal and random O(1) entries in the upper   
            triangle.   

       (11) A matrix of the form  U' T U, where U is orthogonal and   
            T has "clustered" entries 1, ULP,..., ULP with random   
            signs on the diagonal and random O(1) entries in the upper   
            triangle.   

       (12) A matrix of the form  U' T U, where U is orthogonal and   
            T has real or complex conjugate paired eigenvalues randomly   
            chosen from ( ULP, 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 signs 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 signs 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 signs 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 real or complex conjugate paired   
            eigenvalues randomly chosen from ( ULP, 1 ) and random   
            O(1) entries in the upper triangle.   

       (17) Same as (16), but multiplied by SQRT( overflow threshold )   
       (18) Same as (16), but multiplied by SQRT( underflow threshold )   

       (19) Nonsymmetric matrix with random entries chosen from (-1,1).   
       (20) Same as (19), but multiplied by SQRT( overflow threshold )   
       (21) Same as (19), but multiplied by SQRT( underflow threshold )   

    Arguments   
    ==========   

    NSIZES - INTEGER   
             The number of sizes of matrices to use.  If it is zero,   
             DCHKHS does nothing.  It must be at least zero.   
             Not modified.   

    NN     - 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.   
             Not modified.   

    NTYPES - INTEGER   
             The number of elements in DOTYPE.   If it is zero, DCHKHS   
             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. .   
             Not modified.   

    DOTYPE - 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.   
             Not modified.   

    ISEED  - 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 DCHKHS to continue the same random number   
             sequence.   
             Modified.   

    THRESH - 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.   
             Not modified.   

    NOUNIT - INTEGER   
             The FORTRAN unit number for printing out error messages   
             (e.g., if a routine returns IINFO not equal to 0.)   
             Not modified.   

    A      - DOUBLE PRECISION 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.   
             Modified.   

    LDA    - INTEGER   
             The leading dimension of A, H, T1 and T2.  It must be at   
             least 1 and at least max( NN ).   
             Not modified.   

    H      - DOUBLE PRECISION array, dimension (LDA,max(NN))   
             The upper hessenberg matrix computed by DGEHRD.  On exit,   
             H contains the Hessenberg form of the matrix in A.   
             Modified.   

    T1     - DOUBLE PRECISION array, dimension (LDA,max(NN))   
             The Schur (="quasi-triangular") matrix computed by DHSEQR   
             if Z is computed.  On exit, T1 contains the Schur form of   
             the matrix in A.   
             Modified.   

    T2     - DOUBLE PRECISION array, dimension (LDA,max(NN))   
             The Schur matrix computed by DHSEQR when Z is not computed.   
             This should be identical to T1.   
             Modified.   

    LDU    - INTEGER   
             The leading dimension of U, Z, UZ and UU.  It must be at   
             least 1 and at least max( NN ).   
             Not modified.   

    U      - DOUBLE PRECISION array, dimension (LDU,max(NN))   
             The orthogonal matrix computed by DGEHRD.   
             Modified.   

    Z      - DOUBLE PRECISION array, dimension (LDU,max(NN))   
             The orthogonal matrix computed by DHSEQR.   
             Modified.   

    UZ     - DOUBLE PRECISION array, dimension (LDU,max(NN))   
             The product of U times Z.   
             Modified.   

    WR1    - DOUBLE PRECISION array, dimension (max(NN))   
    WI1    - DOUBLE PRECISION array, dimension (max(NN))   
             The real and imaginary parts of the eigenvalues of A,   
             as computed when Z is computed.   
             On exit, WR1 + WI1*i are the eigenvalues of the matrix in A.   
             Modified.   

    WR3    - DOUBLE PRECISION array, dimension (max(NN))   
    WI3    - DOUBLE PRECISION array, dimension (max(NN))   
             Like WR1, WI1, these arrays contain the eigenvalues of A,   
             but those computed when DHSEQR only computes the   
             eigenvalues, i.e., not the Schur vectors and no more of the   
             Schur form than is necessary for computing the   
             eigenvalues.   
             Modified.   

    EVECTL - DOUBLE PRECISION array, dimension (LDU,max(NN))   
             The (upper triangular) left eigenvector matrix for the   
             matrix in T1.  For complex conjugate pairs, the real part   
             is stored in one row and the imaginary part in the next.   
             Modified.   

    EVEZTR - DOUBLE PRECISION array, dimension (LDU,max(NN))   
             The (upper triangular) right eigenvector matrix for the   
             matrix in T1.  For complex conjugate pairs, the real part   
             is stored in one column and the imaginary part in the next.   
             Modified.   

    EVECTY - DOUBLE PRECISION array, dimension (LDU,max(NN))   
             The left eigenvector matrix for the   
             matrix in H.  For complex conjugate pairs, the real part   
             is stored in one row and the imaginary part in the next.   
             Modified.   

    EVECTX - DOUBLE PRECISION array, dimension (LDU,max(NN))   
             The right eigenvector matrix for the   
             matrix in H.  For complex conjugate pairs, the real part   
             is stored in one column and the imaginary part in the next.   
             Modified.   

    UU     - DOUBLE PRECISION array, dimension (LDU,max(NN))   
             Details of the orthogonal matrix computed by DGEHRD.   
             Modified.   

    TAU    - DOUBLE PRECISION array, dimension(max(NN))   
             Further details of the orthogonal matrix computed by DGEHRD.   
             Modified.   

    WORK   - DOUBLE PRECISION array, dimension (NWORK)   
             Workspace.   
             Modified.   

    NWORK  - INTEGER   
             The number of entries in WORK.  NWORK >= 4*NN(j)*NN(j) + 2.   

    IWORK  - INTEGER array, dimension (max(NN))   
             Workspace.   
             Modified.   

    SELECT - LOGICAL array, dimension (max(NN))   
             Workspace.   
             Modified.   

    RESULT - DOUBLE PRECISION array, dimension (14)   
             The values computed by the fourteen tests described above.   
             The values are currently limited to 1/ulp, to avoid   
             overflow.   
             Modified.   

    INFO   - 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: LDU < 1 or LDU < NMAX.   
             -28: NWORK too small.   
             If  DLATMR, SLATMS, or SLATME returns an error code, the   
                 absolute value of it is returned.   
             If 1, then DHSEQR could not find all the shifts.   
             If 2, then the EISPACK code (for small blocks) failed.   
             If >2, then 30*N iterations were not enough to find an   
                 eigenvalue or to decompose the problem.   
             Modified.   

   -----------------------------------------------------------------------   

       Some Local Variables and Parameters:   
       ---- ----- --------- --- ----------   

       ZERO, ONE       Real 0 and 1.   
       MAXTYP          The number of types defined.   
       MTEST           The number of tests defined: care must be taken   
                       that (1) the size of RESULT, (2) the number of   
                       tests actually performed, and (3) MTEST agree.   
       NTEST           The number of tests performed on this matrix   
                       so far.  This should be less than MTEST, and   
                       equal to it by the last test.  It will be less   
                       if any of the routines being tested indicates   
                       that it could not compute the matrices that   
                       would be tested.   
       NMAX            Largest value in NN.   
       NMATS           The number of matrices generated so far.   
       NERRS           The number of tests which have exceeded THRESH   
                       so far (computed by DLAFTS).   
       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.   
       RTOVFL, RTUNFL,   
       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)       Selects whether CONDS is to be 1 or   
                       1/sqrt(ulp).  (0 means irrelevant.)   

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

       Parameter adjustments */
    --nn;
    --dotype;
    --iseed;
    t2_dim1 = *lda;
    t2_offset = 1 + t2_dim1 * 1;
    t2 -= t2_offset;
    t1_dim1 = *lda;
    t1_offset = 1 + t1_dim1 * 1;
    t1 -= t1_offset;
    h_dim1 = *lda;
    h_offset = 1 + h_dim1 * 1;
    h__ -= h_offset;
    a_dim1 = *lda;
    a_offset = 1 + a_dim1 * 1;
    a -= a_offset;
    uu_dim1 = *ldu;
    uu_offset = 1 + uu_dim1 * 1;
    uu -= uu_offset;
    evectx_dim1 = *ldu;
    evectx_offset = 1 + evectx_dim1 * 1;
    evectx -= evectx_offset;
    evecty_dim1 = *ldu;
    evecty_offset = 1 + evecty_dim1 * 1;
    evecty -= evecty_offset;
    evectr_dim1 = *ldu;
    evectr_offset = 1 + evectr_dim1 * 1;
    evectr -= evectr_offset;
    evectl_dim1 = *ldu;
    evectl_offset = 1 + evectl_dim1 * 1;
    evectl -= evectl_offset;
    uz_dim1 = *ldu;
    uz_offset = 1 + uz_dim1 * 1;
    uz -= uz_offset;
    z_dim1 = *ldu;
    z_offset = 1 + z_dim1 * 1;
    z__ -= z_offset;
    u_dim1 = *ldu;
    u_offset = 1 + u_dim1 * 1;
    u -= u_offset;
    --wr1;
    --wi1;
    --wr3;
    --wi3;
    --tau;
    --work;
    --iwork;
    --select;
    --result;

    /* Function Body   

       Check for errors */

    ntestt = 0;
    *info = 0;

    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 (*lda <= 1 || *lda < nmax) {
	*info = -9;
    } else if (*ldu <= 1 || *ldu < nmax) {
	*info = -14;
    } else if ((nmax << 2) * nmax + 2 > *nwork) {
	*info = -28;
    }

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

/*     Quick return if possible */

    if (*nsizes == 0 || *ntypes == 0) {
	return 0;
    }

/*     More important constants */

    unfl = dlamch_("Safe minimum");
    ovfl = dlamch_("Overflow");
    dlabad_(&unfl, &ovfl);
    ulp = dlamch_("Epsilon") * dlamch_("Base");
    ulpinv = 1. / ulp;
    rtunfl = sqrt(unfl);
    rtovfl = sqrt(ovfl);
    rtulp = sqrt(ulp);
    rtulpi = 1. / rtulp;

/*     Loop over sizes, types */

    nerrs = 0;
    nmats = 0;

    i__1 = *nsizes;
    for (jsize = 1; jsize <= i__1; ++jsize) {
	n = nn[jsize];
	if (n == 0) {
	    goto L270;
	}
	n1 = max(1,n);
	aninv = 1. / (doublereal) n1;

	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;
	    }
	    ++nmats;
	    ntest = 0;

/*           Save ISEED in case of an error. */

	    for (j = 1; j <= 4; ++j) {
		ioldsd[j - 1] = iseed[j];
/* L20: */
	    }

/*           Initialize RESULT */

	    for (j = 1; j <= 14; ++j) {
		result[j] = 0.;
/* L30: */
	    }

/*           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 L100;
	    }

	    itype = ktype[jtype - 1];
	    imode = kmode[jtype - 1];

/*           Compute norm */

	    switch (kmagn[jtype - 1]) {
		case 1:  goto L40;
		case 2:  goto L50;
		case 3:  goto L60;
	    }

L40:
	    anorm = 1.;
	    goto L70;

L50:
	    anorm = rtovfl * ulp * aninv;
	    goto L70;

L60:
	    anorm = rtunfl * n * ulpinv;
	    goto L70;

L70:

	    dlaset_("Full", lda, &n, &c_b18, &c_b18, &a[a_offset], lda);
	    iinfo = 0;
	    cond = ulpinv;

/*           Special Matrices */

	    if (itype == 1) {

/*              Zero */

		iinfo = 0;

	    } else if (itype == 2) {

/*              Identity */

		i__3 = n;
		for (jcol = 1; jcol <= i__3; ++jcol) {
		    a_ref(jcol, jcol) = anorm;
/* L80: */
		}

	    } else if (itype == 3) {

/*              Jordan Block */

		i__3 = n;
		for (jcol = 1; jcol <= i__3; ++jcol) {
		    a_ref(jcol, jcol) = anorm;
		    if (jcol > 1) {
			a_ref(jcol, jcol - 1) = 1.;
		    }
/* L90: */
		}

	    } else if (itype == 4) {

/*              Diagonal Matrix, [Eigen]values Specified */

		dlatms_(&n, &n, "S", &iseed[1], "S", &work[1], &imode, &cond, 
			&anorm, &c__0, &c__0, "N", &a[a_offset], lda, &work[n 
			+ 1], &iinfo);

	    } else if (itype == 5) {

/*              Symmetric, eigenvalues specified */

		dlatms_(&n, &n, "S", &iseed[1], "S", &work[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.;
		}

		*(unsigned char *)&adumma[0] = ' ';
		dlatme_(&n, "S", &iseed[1], &work[1], &imode, &cond, &c_b32, 
			adumma, "T", "T", "T", &work[n + 1], &c__4, &conds, &
			n, &n, &anorm, &a[a_offset], lda, &work[(n << 1) + 1],
			 &iinfo);

	    } else if (itype == 7) {

/*              Diagonal, random eigenvalues */

		dlatmr_(&n, &n, "S", &iseed[1], "S", &work[1], &c__6, &c_b32, 
			&c_b32, "T", "N", &work[n + 1], &c__1, &c_b32, &work[(
			n << 1) + 1], &c__1, &c_b32, "N", idumma, &c__0, &
			c__0, &c_b18, &anorm, "NO", &a[a_offset], lda, &iwork[
			1], &iinfo);

	    } else if (itype == 8) {

/*              Symmetric, random eigenvalues */

		dlatmr_(&n, &n, "S", &iseed[1], "S", &work[1], &c__6, &c_b32, 
			&c_b32, "T", "N", &work[n + 1], &c__1, &c_b32, &work[(
			n << 1) + 1], &c__1, &c_b32, "N", idumma, &n, &n, &
			c_b18, &anorm, "NO", &a[a_offset], lda, &iwork[1], &
			iinfo);

	    } else if (itype == 9) {

/*              General, random eigenvalues */

		dlatmr_(&n, &n, "S", &iseed[1], "N", &work[1], &c__6, &c_b32, 
			&c_b32, "T", "N", &work[n + 1], &c__1, &c_b32, &work[(
			n << 1) + 1], &c__1, &c_b32, "N", idumma, &n, &n, &
			c_b18, &anorm, "NO", &a[a_offset], lda, &iwork[1], &
			iinfo);

	    } else if (itype == 10) {

/*              Triangular, random eigenvalues */

		dlatmr_(&n, &n, "S", &iseed[1], "N", &work[1], &c__6, &c_b32, 
			&c_b32, "T", "N", &work[n + 1], &c__1, &c_b32, &work[(
			n << 1) + 1], &c__1, &c_b32, "N", idumma, &n, &c__0, &
			c_b18, &anorm, "NO", &a[a_offset], lda, &iwork[1], &
			iinfo);

	    } else {

		iinfo = 1;
	    }

	    if (iinfo != 0) {
		io___36.ciunit = *nounit;
		s_wsfe(&io___36);
		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;
	    }

L100:

/*           Call DGEHRD to compute H and U, do tests. */

	    dlacpy_(" ", &n, &n, &a[a_offset], lda, &h__[h_offset], lda);

	    ntest = 1;

	    ilo = 1;
	    ihi = n;

	    i__3 = *nwork - n;
	    dgehrd_(&n, &ilo, &ihi, &h__[h_offset], lda, &work[1], &work[n + 
		    1], &i__3, &iinfo);

	    if (iinfo != 0) {
		result[1] = ulpinv;
		io___39.ciunit = *nounit;
		s_wsfe(&io___39);
		do_fio(&c__1, "DGEHRD", (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 L250;
	    }

	    i__3 = n - 1;
	    for (j = 1; j <= i__3; ++j) {
		uu_ref(j + 1, j) = 0.;
		i__4 = n;
		for (i__ = j + 2; i__ <= i__4; ++i__) {
		    u_ref(i__, j) = h___ref(i__, j);
		    uu_ref(i__, j) = h___ref(i__, j);
		    h___ref(i__, j) = 0.;
/* L110: */
		}
/* L120: */
	    }
	    dcopy_(&n, &work[1], &c__1, &tau[1], &c__1);
	    i__3 = *nwork - n;
	    dorghr_(&n, &ilo, &ihi, &u[u_offset], ldu, &work[1], &work[n + 1],
		     &i__3, &iinfo);
	    ntest = 2;

	    dhst01_(&n, &ilo, &ihi, &a[a_offset], lda, &h__[h_offset], lda, &
		    u[u_offset], ldu, &work[1], nwork, &result[1]);

/*           Call DHSEQR to compute T1, T2 and Z, do tests.   

             Eigenvalues only (WR3,WI3) */

	    dlacpy_(" ", &n, &n, &h__[h_offset], lda, &t2[t2_offset], lda);
	    ntest = 3;
	    result[3] = ulpinv;

	    dhseqr_("E", "N", &n, &ilo, &ihi, &t2[t2_offset], lda, &wr3[1], &
		    wi3[1], &uz[uz_offset], ldu, &work[1], nwork, &iinfo);
	    if (iinfo != 0) {
		io___41.ciunit = *nounit;
		s_wsfe(&io___41);
		do_fio(&c__1, "DHSEQR(E)", (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();
		if (iinfo <= n + 2) {
		    *info = abs(iinfo);
		    goto L250;
		}
	    }

/*           Eigenvalues (WR1,WI1) and Full Schur Form (T2) */

	    dlacpy_(" ", &n, &n, &h__[h_offset], lda, &t2[t2_offset], lda);

	    dhseqr_("S", "N", &n, &ilo, &ihi, &t2[t2_offset], lda, &wr1[1], &
		    wi1[1], &uz[uz_offset], ldu, &work[1], nwork, &iinfo);
	    if (iinfo != 0 && iinfo <= n + 2) {
		io___42.ciunit = *nounit;
		s_wsfe(&io___42);
		do_fio(&c__1, "DHSEQR(S)", (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);
		goto L250;
	    }

/*           Eigenvalues (WR1,WI1), Schur Form (T1), and Schur vectors   
             (UZ) */

	    dlacpy_(" ", &n, &n, &h__[h_offset], lda, &t1[t1_offset], lda);
	    dlacpy_(" ", &n, &n, &u[u_offset], ldu, &uz[uz_offset], lda);

	    dhseqr_("S", "V", &n, &ilo, &ihi, &t1[t1_offset], lda, &wr1[1], &
		    wi1[1], &uz[uz_offset], ldu, &work[1], nwork, &iinfo);
	    if (iinfo != 0 && iinfo <= n + 2) {
		io___43.ciunit = *nounit;
		s_wsfe(&io___43);
		do_fio(&c__1, "DHSEQR(V)", (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);
		goto L250;
	    }

/*           Compute Z = U' UZ */

	    dgemm_("T", "N", &n, &n, &n, &c_b32, &u[u_offset], ldu, &uz[
		    uz_offset], ldu, &c_b18, &z__[z_offset], ldu);
	    ntest = 8;

/*           Do Tests 3: | H - Z T Z' | / ( |H| n ulp )   
                  and 4: | I - Z Z' | / ( n ulp ) */

	    dhst01_(&n, &ilo, &ihi, &h__[h_offset], lda, &t1[t1_offset], lda, 
		    &z__[z_offset], ldu, &work[1], nwork, &result[3]);

/*           Do Tests 5: | A - UZ T (UZ)' | / ( |A| n ulp )   
                  and 6: | I - UZ (UZ)' | / ( n ulp ) */

	    dhst01_(&n, &ilo, &ihi, &a[a_offset], lda, &t1[t1_offset], lda, &
		    uz[uz_offset], ldu, &work[1], nwork, &result[5]);

/*           Do Test 7: | T2 - T1 | / ( |T| n ulp ) */

	    dget10_(&n, &n, &t2[t2_offset], lda, &t1[t1_offset], lda, &work[1]
		    , &result[7]);

/*           Do Test 8: | W3 - W1 | / ( max(|W1|,|W3|) ulp ) */

	    temp1 = 0.;
	    temp2 = 0.;
	    i__3 = n;
	    for (j = 1; j <= i__3; ++j) {
/* Computing MAX */
		d__5 = temp1, d__6 = (d__1 = wr1[j], abs(d__1)) + (d__2 = wi1[
			j], abs(d__2)), d__5 = max(d__5,d__6), d__6 = (d__3 = 
			wr3[j], abs(d__3)) + (d__4 = wi3[j], abs(d__4));
		temp1 = max(d__5,d__6);
/* Computing MAX */
		d__3 = temp2, d__4 = (d__1 = wr1[j] - wr3[j], abs(d__1)) + (
			d__2 = wr1[j] - wr3[j], abs(d__2));
		temp2 = max(d__3,d__4);
/* L130: */
	    }

/* Computing MAX */
	    d__1 = unfl, d__2 = ulp * max(temp1,temp2);
	    result[8] = temp2 / max(d__1,d__2);

/*           Compute the Left and Right Eigenvectors of T   

             Compute the Right eigenvector Matrix: */

	    ntest = 9;
	    result[9] = ulpinv;

/*           Select last max(N/4,1) real, max(N/4,1) complex eigenvectors */

	    nselc = 0;
	    nselr = 0;
	    j = n;
L140:
	    if (wi1[j] == 0.) {
/* Computing MAX */
		i__3 = n / 4;
		if (nselr < max(i__3,1)) {
		    ++nselr;
		    select[j] = TRUE_;
		} else {
		    select[j] = FALSE_;
		}
		--j;
	    } else {
/* Computing MAX */
		i__3 = n / 4;
		if (nselc < max(i__3,1)) {
		    ++nselc;
		    select[j] = TRUE_;
		    select[j - 1] = FALSE_;
		} else {
		    select[j] = FALSE_;
		    select[j - 1] = FALSE_;
		}
		j += -2;
	    }
	    if (j > 0) {
		goto L140;
	    }

	    dtrevc_("Right", "All", &select[1], &n, &t1[t1_offset], lda, 
		    dumma, ldu, &evectr[evectr_offset], ldu, &n, &in, &work[1]
		    , &iinfo);
	    if (iinfo != 0) {
		io___50.ciunit = *nounit;
		s_wsfe(&io___50);
		do_fio(&c__1, "DTREVC(R,A)", (ftnlen)11);
		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 L250;
	    }

/*           Test 9:  | TR - RW | / ( |T| |R| ulp ) */

	    dget22_("N", "N", "N", &n, &t1[t1_offset], lda, &evectr[
		    evectr_offset], ldu, &wr1[1], &wi1[1], &work[1], dumma);
	    result[9] = dumma[0];
	    if (dumma[1] > *thresh) {
		io___51.ciunit = *nounit;
		s_wsfe(&io___51);
		do_fio(&c__1, "Right", (ftnlen)5);
		do_fio(&c__1, "DTREVC", (ftnlen)6);
		do_fio(&c__1, (char *)&dumma[1], (ftnlen)sizeof(doublereal));
		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();
	    }

/*           Compute selected right eigenvectors and confirm that   
             they agree with previous right eigenvectors */

	    dtrevc_("Right", "Some", &select[1], &n, &t1[t1_offset], lda, 
		    dumma, ldu, &evectl[evectl_offset], ldu, &n, &in, &work[1]
		    , &iinfo);
	    if (iinfo != 0) {
		io___52.ciunit = *nounit;
		s_wsfe(&io___52);
		do_fio(&c__1, "DTREVC(R,S)", (ftnlen)11);
		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 L250;
	    }

	    k = 1;
	    match = TRUE_;
	    i__3 = n;
	    for (j = 1; j <= i__3; ++j) {
		if (select[j] && wi1[j] == 0.) {
		    i__4 = n;
		    for (jj = 1; jj <= i__4; ++jj) {
			if (evectr_ref(jj, j) != evectl_ref(jj, k)) {
			    match = FALSE_;
			    goto L180;
			}
/* L150: */
		    }
		    ++k;
		} else if (select[j] && wi1[j] != 0.) {
		    i__4 = n;
		    for (jj = 1; jj <= i__4; ++jj) {
			if (evectr_ref(jj, j) != evectl_ref(jj, k) || 
				evectr_ref(jj, j + 1) != evectl_ref(jj, k + 1)
				) {
			    match = FALSE_;
			    goto L180;
			}
/* L160: */
		    }
		    k += 2;
		}
/* L170: */
	    }
L180:
	    if (! match) {
		io___56.ciunit = *nounit;
		s_wsfe(&io___56);
		do_fio(&c__1, "Right", (ftnlen)5);
		do_fio(&c__1, "DTREVC", (ftnlen)6);
		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();
	    }

/*           Compute the Left eigenvector Matrix: */

	    ntest = 10;
	    result[10] = ulpinv;
	    dtrevc_("Left", "All", &select[1], &n, &t1[t1_offset], lda, &
		    evectl[evectl_offset], ldu, dumma, ldu, &n, &in, &work[1],
		     &iinfo);
	    if (iinfo != 0) {
		io___57.ciunit = *nounit;
		s_wsfe(&io___57);
		do_fio(&c__1, "DTREVC(L,A)", (ftnlen)11);
		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 L250;
	    }

/*           Test 10:  | LT - WL | / ( |T| |L| ulp ) */

	    dget22_("Trans", "N", "Conj", &n, &t1[t1_offset], lda, &evectl[
		    evectl_offset], ldu, &wr1[1], &wi1[1], &work[1], &dumma[2]
		    );
	    result[10] = dumma[2];
	    if (dumma[3] > *thresh) {
		io___58.ciunit = *nounit;
		s_wsfe(&io___58);
		do_fio(&c__1, "Left", (ftnlen)4);
		do_fio(&c__1, "DTREVC", (ftnlen)6);
		do_fio(&c__1, (char *)&dumma[3], (ftnlen)sizeof(doublereal));
		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();
	    }

/*           Compute selected left eigenvectors and confirm that   
             they agree with previous left eigenvectors */

	    dtrevc_("Left", "Some", &select[1], &n, &t1[t1_offset], lda, &
		    evectr[evectr_offset], ldu, dumma, ldu, &n, &in, &work[1],
		     &iinfo);
	    if (iinfo != 0) {
		io___59.ciunit = *nounit;
		s_wsfe(&io___59);
		do_fio(&c__1, "DTREVC(L,S)", (ftnlen)11);
		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 L250;
	    }

	    k = 1;
	    match = TRUE_;
	    i__3 = n;
	    for (j = 1; j <= i__3; ++j) {
		if (select[j] && wi1[j] == 0.) {
		    i__4 = n;
		    for (jj = 1; jj <= i__4; ++jj) {
			if (evectl_ref(jj, j) != evectr_ref(jj, k)) {
			    match = FALSE_;
			    goto L220;
			}
/* L190: */
		    }
		    ++k;
		} else if (select[j] && wi1[j] != 0.) {
		    i__4 = n;
		    for (jj = 1; jj <= i__4; ++jj) {
			if (evectl_ref(jj, j) != evectr_ref(jj, k) || 
				evectl_ref(jj, j + 1) != evectr_ref(jj, k + 1)
				) {
			    match = FALSE_;
			    goto L220;
			}
/* L200: */
		    }
		    k += 2;
		}
/* L210: */
	    }
L220:
	    if (! match) {
		io___60.ciunit = *nounit;
		s_wsfe(&io___60);
		do_fio(&c__1, "Left", (ftnlen)4);
		do_fio(&c__1, "DTREVC", (ftnlen)6);
		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();
	    }

/*           Call DHSEIN for Right eigenvectors of H, do test 11 */

	    ntest = 11;
	    result[11] = ulpinv;
	    i__3 = n;
	    for (j = 1; j <= i__3; ++j) {
		select[j] = TRUE_;
/* L230: */
	    }

	    dhsein_("Right", "Qr", "Ninitv", &select[1], &n, &h__[h_offset], 
		    lda, &wr3[1], &wi3[1], dumma, ldu, &evectx[evectx_offset],
		     ldu, &n1, &in, &work[1], &iwork[1], &iwork[1], &iinfo);
	    if (iinfo != 0) {
		io___61.ciunit = *nounit;
		s_wsfe(&io___61);
		do_fio(&c__1, "DHSEIN(R)", (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);
		if (iinfo < 0) {
		    goto L250;
		}
	    } else {

/*              Test 11:  | HX - XW | / ( |H| |X| ulp )   

                          (from inverse iteration) */

		dget22_("N", "N", "N", &n, &h__[h_offset], lda, &evectx[
			evectx_offset], ldu, &wr3[1], &wi3[1], &work[1], 
			dumma);
		if (dumma[0] < ulpinv) {
		    result[11] = dumma[0] * aninv;
		}
		if (dumma[1] > *thresh) {
		    io___62.ciunit = *nounit;
		    s_wsfe(&io___62);
		    do_fio(&c__1, "Right", (ftnlen)5);
		    do_fio(&c__1, "DHSEIN", (ftnlen)6);
		    do_fio(&c__1, (char *)&dumma[1], (ftnlen)sizeof(
			    doublereal));
		    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();
		}
	    }

/*           Call DHSEIN for Left eigenvectors of H, do test 12 */

	    ntest = 12;
	    result[12] = ulpinv;
	    i__3 = n;
	    for (j = 1; j <= i__3; ++j) {
		select[j] = TRUE_;
/* L240: */
	    }

	    dhsein_("Left", "Qr", "Ninitv", &select[1], &n, &h__[h_offset], 
		    lda, &wr3[1], &wi3[1], &evecty[evecty_offset], ldu, dumma,
		     ldu, &n1, &in, &work[1], &iwork[1], &iwork[1], &iinfo);
	    if (iinfo != 0) {
		io___63.ciunit = *nounit;
		s_wsfe(&io___63);
		do_fio(&c__1, "DHSEIN(L)", (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);
		if (iinfo < 0) {
		    goto L250;
		}
	    } else {

/*              Test 12:  | YH - WY | / ( |H| |Y| ulp )   

                          (from inverse iteration) */

		dget22_("C", "N", "C", &n, &h__[h_offset], lda, &evecty[
			evecty_offset], ldu, &wr3[1], &wi3[1], &work[1], &
			dumma[2]);
		if (dumma[2] < ulpinv) {
		    result[12] = dumma[2] * aninv;
		}
		if (dumma[3] > *thresh) {
		    io___64.ciunit = *nounit;
		    s_wsfe(&io___64);
		    do_fio(&c__1, "Left", (ftnlen)4);
		    do_fio(&c__1, "DHSEIN", (ftnlen)6);
		    do_fio(&c__1, (char *)&dumma[3], (ftnlen)sizeof(
			    doublereal));
		    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();
		}
	    }

/*           Call DORMHR for Right eigenvectors of A, do test 13 */

	    ntest = 13;
	    result[13] = ulpinv;

	    dormhr_("Left", "No transpose", &n, &n, &ilo, &ihi, &uu[uu_offset]
		    , ldu, &tau[1], &evectx[evectx_offset], ldu, &work[1], 
		    nwork, &iinfo);
	    if (iinfo != 0) {
		io___65.ciunit = *nounit;
		s_wsfe(&io___65);
		do_fio(&c__1, "DORMHR(R)", (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);
		if (iinfo < 0) {
		    goto L250;
		}
	    } else {

/*              Test 13:  | AX - XW | / ( |A| |X| ulp )   

                          (from inverse iteration) */

		dget22_("N", "N", "N", &n, &a[a_offset], lda, &evectx[
			evectx_offset], ldu, &wr3[1], &wi3[1], &work[1], 
			dumma);
		if (dumma[0] < ulpinv) {
		    result[13] = dumma[0] * aninv;
		}
	    }

/*           Call DORMHR for Left eigenvectors of A, do test 14 */

	    ntest = 14;
	    result[14] = ulpinv;

	    dormhr_("Left", "No transpose", &n, &n, &ilo, &ihi, &uu[uu_offset]
		    , ldu, &tau[1], &evecty[evecty_offset], ldu, &work[1], 
		    nwork, &iinfo);
	    if (iinfo != 0) {
		io___66.ciunit = *nounit;
		s_wsfe(&io___66);
		do_fio(&c__1, "DORMHR(L)", (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);
		if (iinfo < 0) {
		    goto L250;
		}
	    } else {

/*              Test 14:  | YA - WY | / ( |A| |Y| ulp )   

                          (from inverse iteration) */

		dget22_("C", "N", "C", &n, &a[a_offset], lda, &evecty[
			evecty_offset], ldu, &wr3[1], &wi3[1], &work[1], &
			dumma[2]);
		if (dumma[2] < ulpinv) {
		    result[14] = dumma[2] * aninv;
		}
	    }

/*           End of Loop -- Check for RESULT(j) > THRESH */

L250:

	    ntestt += ntest;
	    dlafts_("DHS", &n, &n, &jtype, &ntest, &result[1], ioldsd, thresh,
		     nounit, &nerrs);

L260:
	    ;
	}
L270:
	;
    }

/*     Summary */

    dlasum_("DHS", nounit, &nerrs, &ntestt);

    return 0;


/*     End of DCHKHS */

} /* dchkhs_ */
示例#4
0
/* Subroutine */ int dgelsx_(integer *m, integer *n, integer *nrhs, 
	doublereal *a, integer *lda, doublereal *b, integer *ldb, integer *
	jpvt, doublereal *rcond, integer *rank, doublereal *work, 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   
       March 31, 1993   


    Purpose   
    =======   

    This routine is deprecated and has been replaced by routine DGELSY.   

    DGELSX computes the minimum-norm solution to a real linear least   
    squares problem:   
        minimize || A * X - B ||   
    using a complete orthogonal factorization of A.  A is an M-by-N   
    matrix which may be rank-deficient.   

    Several right hand side vectors b and solution vectors x can be   
    handled in a single call; they are stored as the columns of the   
    M-by-NRHS right hand side matrix B and the N-by-NRHS solution   
    matrix X.   

    The routine first computes a QR factorization with column pivoting:   
        A * P = Q * [ R11 R12 ]   
                    [  0  R22 ]   
    with R11 defined as the largest leading submatrix whose estimated   
    condition number is less than 1/RCOND.  The order of R11, RANK,   
    is the effective rank of A.   

    Then, R22 is considered to be negligible, and R12 is annihilated   
    by orthogonal transformations from the right, arriving at the   
    complete orthogonal factorization:   
       A * P = Q * [ T11 0 ] * Z   
                   [  0  0 ]   
    The minimum-norm solution is then   
       X = P * Z' [ inv(T11)*Q1'*B ]   
                  [        0       ]   
    where Q1 consists of the first RANK columns of Q.   

    Arguments   
    =========   

    M       (input) INTEGER   
            The number of rows of the matrix A.  M >= 0.   

    N       (input) INTEGER   
            The number of columns of the matrix A.  N >= 0.   

    NRHS    (input) INTEGER   
            The number of right hand sides, i.e., the number of   
            columns of matrices B and X. NRHS >= 0.   

    A       (input/output) DOUBLE PRECISION array, dimension (LDA,N)   
            On entry, the M-by-N matrix A.   
            On exit, A has been overwritten by details of its   
            complete orthogonal factorization.   

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

    B       (input/output) DOUBLE PRECISION array, dimension (LDB,NRHS)   
            On entry, the M-by-NRHS right hand side matrix B.   
            On exit, the N-by-NRHS solution matrix X.   
            If m >= n and RANK = n, the residual sum-of-squares for   
            the solution in the i-th column is given by the sum of   
            squares of elements N+1:M in that column.   

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

    JPVT    (input/output) INTEGER array, dimension (N)   
            On entry, if JPVT(i) .ne. 0, the i-th column of A is an   
            initial column, otherwise it is a free column.  Before   
            the QR factorization of A, all initial columns are   
            permuted to the leading positions; only the remaining   
            free columns are moved as a result of column pivoting   
            during the factorization.   
            On exit, if JPVT(i) = k, then the i-th column of A*P   
            was the k-th column of A.   

    RCOND   (input) DOUBLE PRECISION   
            RCOND is used to determine the effective rank of A, which   
            is defined as the order of the largest leading triangular   
            submatrix R11 in the QR factorization with pivoting of A,   
            whose estimated condition number < 1/RCOND.   

    RANK    (output) INTEGER   
            The effective rank of A, i.e., the order of the submatrix   
            R11.  This is the same as the order of the submatrix T11   
            in the complete orthogonal factorization of A.   

    WORK    (workspace) DOUBLE PRECISION array, dimension   
                        (max( min(M,N)+3*N, 2*min(M,N)+NRHS )),   

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

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


       Parameter adjustments */
    /* Table of constant values */
    static integer c__0 = 0;
    static doublereal c_b13 = 0.;
    static integer c__2 = 2;
    static integer c__1 = 1;
    static doublereal c_b36 = 1.;
    
    /* System generated locals */
    integer a_dim1, a_offset, b_dim1, b_offset, i__1, i__2;
    doublereal d__1;
    /* Local variables */
    static doublereal anrm, bnrm, smin, smax;
    static integer i__, j, k, iascl, ibscl, ismin, ismax;
    static doublereal c1, c2;
    extern /* Subroutine */ int dtrsm_(char *, char *, char *, char *, 
	    integer *, integer *, doublereal *, doublereal *, integer *, 
	    doublereal *, integer *), dlaic1_(
	    integer *, integer *, doublereal *, doublereal *, doublereal *, 
	    doublereal *, doublereal *, doublereal *, doublereal *);
    static doublereal s1, s2, t1, t2;
    extern /* Subroutine */ int dorm2r_(char *, char *, integer *, integer *, 
	    integer *, doublereal *, integer *, doublereal *, doublereal *, 
	    integer *, doublereal *, integer *), dlabad_(
	    doublereal *, doublereal *);
    extern doublereal dlamch_(char *), dlange_(char *, integer *, 
	    integer *, doublereal *, integer *, doublereal *);
    static integer mn;
    extern /* Subroutine */ int dlascl_(char *, integer *, integer *, 
	    doublereal *, doublereal *, integer *, integer *, doublereal *, 
	    integer *, integer *), dgeqpf_(integer *, integer *, 
	    doublereal *, integer *, integer *, doublereal *, doublereal *, 
	    integer *), dlaset_(char *, integer *, integer *, doublereal *, 
	    doublereal *, doublereal *, integer *), xerbla_(char *, 
	    integer *);
    static doublereal bignum;
    extern /* Subroutine */ int dlatzm_(char *, integer *, integer *, 
	    doublereal *, integer *, doublereal *, doublereal *, doublereal *,
	     integer *, doublereal *);
    static doublereal sminpr, smaxpr, smlnum;
    extern /* Subroutine */ int dtzrqf_(integer *, integer *, doublereal *, 
	    integer *, doublereal *, integer *);
#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]


    a_dim1 = *lda;
    a_offset = 1 + a_dim1 * 1;
    a -= a_offset;
    b_dim1 = *ldb;
    b_offset = 1 + b_dim1 * 1;
    b -= b_offset;
    --jpvt;
    --work;

    /* Function Body */
    mn = min(*m,*n);
    ismin = mn + 1;
    ismax = (mn << 1) + 1;

/*     Test the input arguments. */

    *info = 0;
    if (*m < 0) {
	*info = -1;
    } else if (*n < 0) {
	*info = -2;
    } else if (*nrhs < 0) {
	*info = -3;
    } else if (*lda < max(1,*m)) {
	*info = -5;
    } else /* if(complicated condition) */ {
/* Computing MAX */
	i__1 = max(1,*m);
	if (*ldb < max(i__1,*n)) {
	    *info = -7;
	}
    }

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

/*     Quick return if possible   

   Computing MIN */
    i__1 = min(*m,*n);
    if (min(i__1,*nrhs) == 0) {
	*rank = 0;
	return 0;
    }

/*     Get machine parameters */

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

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

    anrm = dlange_("M", m, n, &a[a_offset], lda, &work[1]);
    iascl = 0;
    if (anrm > 0. && anrm < smlnum) {

/*        Scale matrix norm up to SMLNUM */

	dlascl_("G", &c__0, &c__0, &anrm, &smlnum, m, n, &a[a_offset], lda, 
		info);
	iascl = 1;
    } else if (anrm > bignum) {

/*        Scale matrix norm down to BIGNUM */

	dlascl_("G", &c__0, &c__0, &anrm, &bignum, m, n, &a[a_offset], lda, 
		info);
	iascl = 2;
    } else if (anrm == 0.) {

/*        Matrix all zero. Return zero solution. */

	i__1 = max(*m,*n);
	dlaset_("F", &i__1, nrhs, &c_b13, &c_b13, &b[b_offset], ldb);
	*rank = 0;
	goto L100;
    }

    bnrm = dlange_("M", m, nrhs, &b[b_offset], ldb, &work[1]);
    ibscl = 0;
    if (bnrm > 0. && bnrm < smlnum) {

/*        Scale matrix norm up to SMLNUM */

	dlascl_("G", &c__0, &c__0, &bnrm, &smlnum, m, nrhs, &b[b_offset], ldb,
		 info);
	ibscl = 1;
    } else if (bnrm > bignum) {

/*        Scale matrix norm down to BIGNUM */

	dlascl_("G", &c__0, &c__0, &bnrm, &bignum, m, nrhs, &b[b_offset], ldb,
		 info);
	ibscl = 2;
    }

/*     Compute QR factorization with column pivoting of A:   
          A * P = Q * R */

    dgeqpf_(m, n, &a[a_offset], lda, &jpvt[1], &work[1], &work[mn + 1], info);

/*     workspace 3*N. Details of Householder rotations stored   
       in WORK(1:MN).   

       Determine RANK using incremental condition estimation */

    work[ismin] = 1.;
    work[ismax] = 1.;
    smax = (d__1 = a_ref(1, 1), abs(d__1));
    smin = smax;
    if ((d__1 = a_ref(1, 1), abs(d__1)) == 0.) {
	*rank = 0;
	i__1 = max(*m,*n);
	dlaset_("F", &i__1, nrhs, &c_b13, &c_b13, &b[b_offset], ldb);
	goto L100;
    } else {
	*rank = 1;
    }

L10:
    if (*rank < mn) {
	i__ = *rank + 1;
	dlaic1_(&c__2, rank, &work[ismin], &smin, &a_ref(1, i__), &a_ref(i__, 
		i__), &sminpr, &s1, &c1);
	dlaic1_(&c__1, rank, &work[ismax], &smax, &a_ref(1, i__), &a_ref(i__, 
		i__), &smaxpr, &s2, &c2);

	if (smaxpr * *rcond <= sminpr) {
	    i__1 = *rank;
	    for (i__ = 1; i__ <= i__1; ++i__) {
		work[ismin + i__ - 1] = s1 * work[ismin + i__ - 1];
		work[ismax + i__ - 1] = s2 * work[ismax + i__ - 1];
/* L20: */
	    }
	    work[ismin + *rank] = c1;
	    work[ismax + *rank] = c2;
	    smin = sminpr;
	    smax = smaxpr;
	    ++(*rank);
	    goto L10;
	}
    }

/*     Logically partition R = [ R11 R12 ]   
                               [  0  R22 ]   
       where R11 = R(1:RANK,1:RANK)   

       [R11,R12] = [ T11, 0 ] * Y */

    if (*rank < *n) {
	dtzrqf_(rank, n, &a[a_offset], lda, &work[mn + 1], info);
    }

/*     Details of Householder rotations stored in WORK(MN+1:2*MN)   

       B(1:M,1:NRHS) := Q' * B(1:M,1:NRHS) */

    dorm2r_("Left", "Transpose", m, nrhs, &mn, &a[a_offset], lda, &work[1], &
	    b[b_offset], ldb, &work[(mn << 1) + 1], info);

/*     workspace NRHS   

       B(1:RANK,1:NRHS) := inv(T11) * B(1:RANK,1:NRHS) */

    dtrsm_("Left", "Upper", "No transpose", "Non-unit", rank, nrhs, &c_b36, &
	    a[a_offset], lda, &b[b_offset], ldb);

    i__1 = *n;
    for (i__ = *rank + 1; i__ <= i__1; ++i__) {
	i__2 = *nrhs;
	for (j = 1; j <= i__2; ++j) {
	    b_ref(i__, j) = 0.;
/* L30: */
	}
/* L40: */
    }

/*     B(1:N,1:NRHS) := Y' * B(1:N,1:NRHS) */

    if (*rank < *n) {
	i__1 = *rank;
	for (i__ = 1; i__ <= i__1; ++i__) {
	    i__2 = *n - *rank + 1;
	    dlatzm_("Left", &i__2, nrhs, &a_ref(i__, *rank + 1), lda, &work[
		    mn + i__], &b_ref(i__, 1), &b_ref(*rank + 1, 1), ldb, &
		    work[(mn << 1) + 1]);
/* L50: */
	}
    }

/*     workspace NRHS   

       B(1:N,1:NRHS) := P * B(1:N,1:NRHS) */

    i__1 = *nrhs;
    for (j = 1; j <= i__1; ++j) {
	i__2 = *n;
	for (i__ = 1; i__ <= i__2; ++i__) {
	    work[(mn << 1) + i__] = 1.;
/* L60: */
	}
	i__2 = *n;
	for (i__ = 1; i__ <= i__2; ++i__) {
	    if (work[(mn << 1) + i__] == 1.) {
		if (jpvt[i__] != i__) {
		    k = i__;
		    t1 = b_ref(k, j);
		    t2 = b_ref(jpvt[k], j);
L70:
		    b_ref(jpvt[k], j) = t1;
		    work[(mn << 1) + k] = 0.;
		    t1 = t2;
		    k = jpvt[k];
		    t2 = b_ref(jpvt[k], j);
		    if (jpvt[k] != i__) {
			goto L70;
		    }
		    b_ref(i__, j) = t1;
		    work[(mn << 1) + k] = 0.;
		}
	    }
/* L80: */
	}
/* L90: */
    }

/*     Undo scaling */

    if (iascl == 1) {
	dlascl_("G", &c__0, &c__0, &anrm, &smlnum, n, nrhs, &b[b_offset], ldb,
		 info);
	dlascl_("U", &c__0, &c__0, &smlnum, &anrm, rank, rank, &a[a_offset], 
		lda, info);
    } else if (iascl == 2) {
	dlascl_("G", &c__0, &c__0, &anrm, &bignum, n, nrhs, &b[b_offset], ldb,
		 info);
	dlascl_("U", &c__0, &c__0, &bignum, &anrm, rank, rank, &a[a_offset], 
		lda, info);
    }
    if (ibscl == 1) {
	dlascl_("G", &c__0, &c__0, &smlnum, &bnrm, n, nrhs, &b[b_offset], ldb,
		 info);
    } else if (ibscl == 2) {
	dlascl_("G", &c__0, &c__0, &bignum, &bnrm, n, nrhs, &b[b_offset], ldb,
		 info);
    }

L100:

    return 0;

/*     End of DGELSX */

} /* dgelsx_ */
示例#5
0
doublereal dqrt12_(integer *m, integer *n, doublereal *a, integer *lda, 
	doublereal *s, doublereal *work, integer *lwork)
{
    /* System generated locals */
    integer a_dim1, a_offset, i__1, i__2;
    doublereal ret_val;

    /* Local variables */
    integer i__, j, mn, iscl, info;
    doublereal anrm;
    extern doublereal dnrm2_(integer *, doublereal *, integer *), dasum_(
	    integer *, doublereal *, integer *);
    extern /* Subroutine */ int daxpy_(integer *, doublereal *, doublereal *, 
	    integer *, doublereal *, integer *), dgebd2_(integer *, integer *, 
	     doublereal *, integer *, doublereal *, doublereal *, doublereal *
, doublereal *, doublereal *, integer *);
    doublereal dummy[1];
    extern /* Subroutine */ int dlabad_(doublereal *, doublereal *);
    extern doublereal dlamch_(char *), dlange_(char *, integer *, 
	    integer *, doublereal *, integer *, doublereal *);
    extern /* Subroutine */ int dlascl_(char *, integer *, integer *, 
	    doublereal *, doublereal *, integer *, integer *, doublereal *, 
	    integer *, integer *), dlaset_(char *, integer *, integer 
	    *, doublereal *, doublereal *, doublereal *, integer *), 
	    xerbla_(char *, integer *), dbdsqr_(char *, integer *, 
	    integer *, integer *, integer *, doublereal *, doublereal *, 
	    doublereal *, integer *, doublereal *, integer *, doublereal *, 
	    integer *, doublereal *, integer *);
    doublereal bignum, smlnum, nrmsvl;


/*  -- LAPACK test routine (version 3.1.1) -- */
/*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/*     January 2007 */

/*     .. Scalar Arguments .. */
/*     .. */
/*     .. Array Arguments .. */
/*     .. */

/*  Purpose */
/*  ======= */

/*  DQRT12 computes the singular values `svlues' of the upper trapezoid */
/*  of A(1:M,1:N) and returns the ratio */

/*       || s - svlues||/(||svlues||*eps*max(M,N)) */

/*  Arguments */
/*  ========= */

/*  M       (input) INTEGER */
/*          The number of rows of the matrix A. */

/*  N       (input) INTEGER */
/*          The number of columns of the matrix A. */

/*  A       (input) DOUBLE PRECISION array, dimension (LDA,N) */
/*          The M-by-N matrix A. Only the upper trapezoid is referenced. */

/*  LDA     (input) INTEGER */
/*          The leading dimension of the array A. */

/*  S       (input) DOUBLE PRECISION array, dimension (min(M,N)) */
/*          The singular values of the matrix A. */

/*  WORK    (workspace) DOUBLE PRECISION array, dimension (LWORK) */

/*  LWORK   (input) INTEGER */
/*          The length of the array WORK. LWORK >= max(M*N + 4*min(M,N) + */
/*          max(M,N), M*N+2*MIN( M, N )+4*N). */

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

/*     .. Parameters .. */
/*     .. */
/*     .. Local Scalars .. */
/*     .. */
/*     .. External Functions .. */
/*     .. */
/*     .. External Subroutines .. */
/*     .. */
/*     .. Intrinsic Functions .. */
/*     .. */
/*     .. Local Arrays .. */
/*     .. */
/*     .. Executable Statements .. */

    /* Parameter adjustments */
    a_dim1 = *lda;
    a_offset = 1 + a_dim1;
    a -= a_offset;
    --s;
    --work;

    /* Function Body */
    ret_val = 0.;

/*     Test that enough workspace is supplied */

/* Computing MAX */
    i__1 = *m * *n + (min(*m,*n) << 2) + max(*m,*n), i__2 = *m * *n + (min(*m,
	    *n) << 1) + (*n << 2);
    if (*lwork < max(i__1,i__2)) {
	xerbla_("DQRT12", &c__7);
	return ret_val;
    }

/*     Quick return if possible */

    mn = min(*m,*n);
    if ((doublereal) mn <= 0.) {
	return ret_val;
    }

    nrmsvl = dnrm2_(&mn, &s[1], &c__1);

/*     Copy upper triangle of A into work */

    dlaset_("Full", m, n, &c_b6, &c_b6, &work[1], m);
    i__1 = *n;
    for (j = 1; j <= i__1; ++j) {
	i__2 = min(j,*m);
	for (i__ = 1; i__ <= i__2; ++i__) {
	    work[(j - 1) * *m + i__] = a[i__ + j * a_dim1];
/* L10: */
	}
/* L20: */
    }

/*     Get machine parameters */

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

/*     Scale work if max entry outside range [SMLNUM,BIGNUM] */

    anrm = dlange_("M", m, n, &work[1], m, dummy);
    iscl = 0;
    if (anrm > 0. && anrm < smlnum) {

/*        Scale matrix norm up to SMLNUM */

	dlascl_("G", &c__0, &c__0, &anrm, &smlnum, m, n, &work[1], m, &info);
	iscl = 1;
    } else if (anrm > bignum) {

/*        Scale matrix norm down to BIGNUM */

	dlascl_("G", &c__0, &c__0, &anrm, &bignum, m, n, &work[1], m, &info);
	iscl = 1;
    }

    if (anrm != 0.) {

/*        Compute SVD of work */

	dgebd2_(m, n, &work[1], m, &work[*m * *n + 1], &work[*m * *n + mn + 1]
, &work[*m * *n + (mn << 1) + 1], &work[*m * *n + mn * 3 + 1], 
		 &work[*m * *n + (mn << 2) + 1], &info);
	dbdsqr_("Upper", &mn, &c__0, &c__0, &c__0, &work[*m * *n + 1], &work[*
		m * *n + mn + 1], dummy, &mn, dummy, &c__1, dummy, &mn, &work[
		*m * *n + (mn << 1) + 1], &info);

	if (iscl == 1) {
	    if (anrm > bignum) {
		dlascl_("G", &c__0, &c__0, &bignum, &anrm, &mn, &c__1, &work[*
			m * *n + 1], &mn, &info);
	    }
	    if (anrm < smlnum) {
		dlascl_("G", &c__0, &c__0, &smlnum, &anrm, &mn, &c__1, &work[*
			m * *n + 1], &mn, &info);
	    }
	}

    } else {

	i__1 = mn;
	for (i__ = 1; i__ <= i__1; ++i__) {
	    work[*m * *n + i__] = 0.;
/* L30: */
	}
    }

/*     Compare s and singular values of work */

    daxpy_(&mn, &c_b33, &s[1], &c__1, &work[*m * *n + 1], &c__1);
    ret_val = dasum_(&mn, &work[*m * *n + 1], &c__1) / (dlamch_("Epsilon") * (doublereal) max(*m,*n));
    if (nrmsvl != 0.) {
	ret_val /= nrmsvl;
    }

    return ret_val;

/*     End of DQRT12 */

} /* dqrt12_ */
示例#6
0
/* Subroutine */ int zdrges_(integer *nsizes, integer *nn, integer *ntypes, 
	logical *dotype, integer *iseed, doublereal *thresh, integer *nounit, 
	doublecomplex *a, integer *lda, doublecomplex *b, doublecomplex *s, 
	doublecomplex *t, doublecomplex *q, integer *ldq, doublecomplex *z__, 
	doublecomplex *alpha, doublecomplex *beta, doublecomplex *work, 
	integer *lwork, doublereal *rwork, doublereal *result, logical *bwork, 
	 integer *info)
{
    /* Initialized data */

    static integer kclass[26] = { 1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,2,2,2,2,2,2,2,
	    2,2,2,3 };
    static integer kbmagn[26] = { 1,1,1,1,1,1,1,1,3,2,3,2,2,3,1,1,1,1,1,1,1,3,
	    2,3,2,1 };
    static integer ktrian[26] = { 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,1,1,1,1,1,1,
	    1,1,1,1 };
    static logical lasign[26] = { FALSE_,FALSE_,FALSE_,FALSE_,FALSE_,FALSE_,
	    TRUE_,FALSE_,TRUE_,TRUE_,FALSE_,FALSE_,TRUE_,TRUE_,TRUE_,FALSE_,
	    TRUE_,FALSE_,FALSE_,FALSE_,TRUE_,TRUE_,TRUE_,TRUE_,TRUE_,FALSE_ };
    static logical lbsign[26] = { FALSE_,FALSE_,FALSE_,FALSE_,FALSE_,FALSE_,
	    FALSE_,TRUE_,FALSE_,FALSE_,TRUE_,TRUE_,FALSE_,FALSE_,TRUE_,FALSE_,
	    TRUE_,FALSE_,FALSE_,FALSE_,FALSE_,FALSE_,FALSE_,FALSE_,FALSE_,
	    FALSE_ };
    static integer kz1[6] = { 0,1,2,1,3,3 };
    static integer kz2[6] = { 0,0,1,2,1,1 };
    static integer kadd[6] = { 0,0,0,0,3,2 };
    static integer katype[26] = { 0,1,0,1,2,3,4,1,4,4,1,1,4,4,4,2,4,5,8,7,9,4,
	    4,4,4,0 };
    static integer kbtype[26] = { 0,0,1,1,2,-3,1,4,1,1,4,4,1,1,-4,2,-4,8,8,8,
	    8,8,8,8,8,0 };
    static integer kazero[26] = { 1,1,1,1,1,1,2,1,2,2,1,1,2,2,3,1,3,5,5,5,5,3,
	    3,3,3,1 };
    static integer kbzero[26] = { 1,1,1,1,1,1,1,2,1,1,2,2,1,1,4,1,4,6,6,6,6,4,
	    4,4,4,1 };
    static integer kamagn[26] = { 1,1,1,1,1,1,1,1,2,3,2,3,2,3,1,1,1,1,1,1,1,2,
	    3,3,2,1 };

    /* Format strings */
    static char fmt_9999[] = "(\002 ZDRGES: \002,a,\002 returned INFO=\002,i"
	    "6,\002.\002,/9x,\002N=\002,i6,\002, JTYPE=\002,i6,\002, ISEED="
	    "(\002,4(i4,\002,\002),i5,\002)\002)";
    static char fmt_9998[] = "(\002 ZDRGES: S not in Schur form at eigenvalu"
	    "e \002,i6,\002.\002,/9x,\002N=\002,i6,\002, JTYPE=\002,i6,\002, "
	    "ISEED=(\002,3(i5,\002,\002),i5,\002)\002)";
    static char fmt_9997[] = "(/1x,a3,\002 -- Complex Generalized Schur from"
	    " problem \002,\002driver\002)";
    static char fmt_9996[] = "(\002 Matrix types (see ZDRGES for details):"
	    " \002)";
    static char fmt_9995[] = "(\002 Special Matrices:\002,23x,\002(J'=transp"
	    "osed Jordan block)\002,/\002   1=(0,0)  2=(I,0)  3=(0,I)  4=(I,I"
	    ")  5=(J',J')  \002,\0026=(diag(J',I), diag(I,J'))\002,/\002 Diag"
	    "onal Matrices:  ( \002,\002D=diag(0,1,2,...) )\002,/\002   7=(D,"
	    "I)   9=(large*D, small*I\002,\002)  11=(large*I, small*D)  13=(l"
	    "arge*D, large*I)\002,/\002   8=(I,D)  10=(small*D, large*I)  12="
	    "(small*I, large*D) \002,\002 14=(small*D, small*I)\002,/\002  15"
	    "=(D, reversed D)\002)";
    static char fmt_9994[] = "(\002 Matrices Rotated by Random \002,a,\002 M"
	    "atrices U, V:\002,/\002  16=Transposed Jordan Blocks            "
	    " 19=geometric \002,\002alpha, beta=0,1\002,/\002  17=arithm. alp"
	    "ha&beta             \002,\002      20=arithmetic alpha, beta=0,"
	    "1\002,/\002  18=clustered \002,\002alpha, beta=0,1            21"
	    "=random alpha, beta=0,1\002,/\002 Large & Small Matrices:\002,"
	    "/\002  22=(large, small)   \002,\00223=(small,large)    24=(smal"
	    "l,small)    25=(large,large)\002,/\002  26=random O(1) matrices"
	    ".\002)";
    static char fmt_9993[] = "(/\002 Tests performed:  (S is Schur, T is tri"
	    "angular, \002,\002Q and Z are \002,a,\002,\002,/19x,\002l and r "
	    "are the appropriate left and right\002,/19x,\002eigenvectors, re"
	    "sp., a is alpha, b is beta, and\002,/19x,a,\002 means \002,a,"
	    "\002.)\002,/\002 Without ordering: \002,/\002  1 = | A - Q S "
	    "Z\002,a,\002 | / ( |A| n ulp )      2 = | B - Q T Z\002,a,\002 |"
	    " / ( |B| n ulp )\002,/\002  3 = | I - QQ\002,a,\002 | / ( n ulp "
	    ")             4 = | I - ZZ\002,a,\002 | / ( n ulp )\002,/\002  5"
	    " = A is in Schur form S\002,/\002  6 = difference between (alpha"
	    ",beta)\002,\002 and diagonals of (S,T)\002,/\002 With ordering:"
	    " \002,/\002  7 = | (A,B) - Q (S,T) Z\002,a,\002 | / ( |(A,B)| n "
	    "ulp )\002,/\002  8 = | I - QQ\002,a,\002 | / ( n ulp )          "
	    "   9 = | I - ZZ\002,a,\002 | / ( n ulp )\002,/\002 10 = A is in "
	    "Schur form S\002,/\002 11 = difference between (alpha,beta) and "
	    "diagonals\002,\002 of (S,T)\002,/\002 12 = SDIM is the correct n"
	    "umber of \002,\002selected eigenvalues\002,/)";
    static char fmt_9992[] = "(\002 Matrix order=\002,i5,\002, type=\002,i2"
	    ",\002, seed=\002,4(i4,\002,\002),\002 result \002,i2,\002 is\002"
	    ",0p,f8.2)";
    static char fmt_9991[] = "(\002 Matrix order=\002,i5,\002, type=\002,i2"
	    ",\002, seed=\002,4(i4,\002,\002),\002 result \002,i2,\002 is\002"
	    ",1p,d10.3)";

    /* System generated locals */
    integer a_dim1, a_offset, b_dim1, b_offset, q_dim1, q_offset, s_dim1, 
	    s_offset, t_dim1, t_offset, z_dim1, z_offset, i__1, i__2, i__3, 
	    i__4, i__5, i__6, i__7, i__8, i__9, i__10, i__11;
    doublereal d__1, d__2, d__3, d__4, d__5, d__6, d__7, d__8, d__9, d__10, 
	    d__11, d__12, d__13, d__14, d__15, d__16;
    doublecomplex z__1, z__2, z__3, z__4;

    /* Local variables */
    integer i__, j, n, n1, jc, nb, in, jr;
    doublereal ulp;
    integer iadd, sdim, nmax, rsub;
    char sort[1];
    doublereal temp1, temp2;
    logical badnn;
    integer iinfo;
    doublereal rmagn[4];
    doublecomplex ctemp;
    extern /* Subroutine */ int zget51_(integer *, integer *, doublecomplex *, 
	     integer *, doublecomplex *, integer *, doublecomplex *, integer *
, doublecomplex *, integer *, doublecomplex *, doublereal *, 
	    doublereal *), zgges_(char *, char *, char *, L_fp, integer *, 
	    doublecomplex *, integer *, doublecomplex *, integer *, integer *, 
	     doublecomplex *, doublecomplex *, doublecomplex *, integer *, 
	    doublecomplex *, integer *, doublecomplex *, integer *, 
	    doublereal *, logical *, integer *);
    integer nmats, jsize;
    extern /* Subroutine */ int zget54_(integer *, doublecomplex *, integer *, 
	     doublecomplex *, integer *, doublecomplex *, integer *, 
	    doublecomplex *, integer *, doublecomplex *, integer *, 
	    doublecomplex *, integer *, doublecomplex *, doublereal *);
    integer nerrs, jtype, ntest, isort;
    extern /* Subroutine */ int dlabad_(doublereal *, doublereal *), zlatm4_(
	    integer *, integer *, integer *, integer *, logical *, doublereal 
	    *, doublereal *, doublereal *, integer *, integer *, 
	    doublecomplex *, integer *);
    logical ilabad;
    extern doublereal dlamch_(char *);
    extern /* Subroutine */ int zunm2r_(char *, char *, integer *, integer *, 
	    integer *, doublecomplex *, integer *, doublecomplex *, 
	    doublecomplex *, integer *, doublecomplex *, integer *);
    doublereal safmin, safmax;
    integer knteig, ioldsd[4];
    extern integer ilaenv_(integer *, char *, char *, integer *, integer *, 
	    integer *, integer *);
    extern /* Subroutine */ int alasvm_(char *, integer *, integer *, integer 
	    *, integer *), xerbla_(char *, integer *), 
	    zlarfg_(integer *, doublecomplex *, doublecomplex *, integer *, 
	    doublecomplex *);
    extern /* Double Complex */ void zlarnd_(doublecomplex *, integer *, 
	    integer *);
    extern /* Subroutine */ int zlacpy_(char *, integer *, integer *, 
	    doublecomplex *, integer *, doublecomplex *, integer *), 
	    zlaset_(char *, integer *, integer *, doublecomplex *, 
	    doublecomplex *, doublecomplex *, integer *);
    extern logical zlctes_(doublecomplex *, doublecomplex *);
    integer minwrk, maxwrk;
    doublereal ulpinv;
    integer mtypes, ntestt;

    /* Fortran I/O blocks */
    static cilist io___41 = { 0, 0, 0, fmt_9999, 0 };
    static cilist io___47 = { 0, 0, 0, fmt_9999, 0 };
    static cilist io___51 = { 0, 0, 0, fmt_9998, 0 };
    static cilist io___53 = { 0, 0, 0, fmt_9997, 0 };
    static cilist io___54 = { 0, 0, 0, fmt_9996, 0 };
    static cilist io___55 = { 0, 0, 0, fmt_9995, 0 };
    static cilist io___56 = { 0, 0, 0, fmt_9994, 0 };
    static cilist io___57 = { 0, 0, 0, fmt_9993, 0 };
    static cilist io___58 = { 0, 0, 0, fmt_9992, 0 };
    static cilist io___59 = { 0, 0, 0, fmt_9991, 0 };



/*  -- LAPACK test routine (version 3.1.1) -- */
/*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/*     February 2007 */

/*     .. Scalar Arguments .. */
/*     .. */
/*     .. Array Arguments .. */
/*     .. */

/*  Purpose */
/*  ======= */

/*  ZDRGES checks the nonsymmetric generalized eigenvalue (Schur form) */
/*  problem driver ZGGES. */

/*  ZGGES factors A and B as Q*S*Z'  and Q*T*Z' , where ' means conjugate */
/*  transpose, S and T are  upper triangular (i.e., in generalized Schur */
/*  form), and Q and Z are unitary. It also computes the generalized */
/*  eigenvalues (alpha(j),beta(j)), j=1,...,n.  Thus, */
/*  w(j) = alpha(j)/beta(j) is a root of the characteristic equation */

/*                  det( A - w(j) B ) = 0 */

/*  Optionally it also reorder the eigenvalues so that a selected */
/*  cluster of eigenvalues appears in the leading diagonal block of the */
/*  Schur forms. */

/*  When ZDRGES 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, a pair of matrices (A, B) will be generated */
/*  and used for testing. For each matrix pair, the following 13 tests */
/*  will be performed and compared with the threshhold THRESH except */
/*  the tests (5), (11) and (13). */


/*  (1)   | A - Q S Z' | / ( |A| n ulp ) (no sorting of eigenvalues) */


/*  (2)   | B - Q T Z' | / ( |B| n ulp ) (no sorting of eigenvalues) */


/*  (3)   | I - QQ' | / ( n ulp ) (no sorting of eigenvalues) */


/*  (4)   | I - ZZ' | / ( n ulp ) (no sorting of eigenvalues) */

/*  (5)   if A is in Schur form (i.e. triangular form) (no sorting of */
/*        eigenvalues) */

/*  (6)   if eigenvalues = diagonal elements of the Schur form (S, T), */
/*        i.e., test the maximum over j of D(j)  where: */

/*                      |alpha(j) - S(j,j)|        |beta(j) - T(j,j)| */
/*            D(j) = ------------------------ + ----------------------- */
/*                   max(|alpha(j)|,|S(j,j)|)   max(|beta(j)|,|T(j,j)|) */

/*        (no sorting of eigenvalues) */

/*  (7)   | (A,B) - Q (S,T) Z' | / ( |(A,B)| n ulp ) */
/*        (with sorting of eigenvalues). */

/*  (8)   | I - QQ' | / ( n ulp ) (with sorting of eigenvalues). */

/*  (9)   | I - ZZ' | / ( n ulp ) (with sorting of eigenvalues). */

/*  (10)  if A is in Schur form (i.e. quasi-triangular form) */
/*        (with sorting of eigenvalues). */

/*  (11)  if eigenvalues = diagonal elements of the Schur form (S, T), */
/*        i.e. test the maximum over j of D(j)  where: */

/*                      |alpha(j) - S(j,j)|        |beta(j) - T(j,j)| */
/*            D(j) = ------------------------ + ----------------------- */
/*                   max(|alpha(j)|,|S(j,j)|)   max(|beta(j)|,|T(j,j)|) */

/*        (with sorting of eigenvalues). */

/*  (12)  if sorting worked and SDIM is the number of eigenvalues */
/*        which were CELECTed. */

/*  Test Matrices */
/*  ============= */

/*  The sizes of the test matrices 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)  ( 0, 0 )         (a pair of zero matrices) */

/*  (2)  ( I, 0 )         (an identity and a zero matrix) */

/*  (3)  ( 0, I )         (an identity and a zero matrix) */

/*  (4)  ( I, I )         (a pair of identity matrices) */

/*          t   t */
/*  (5)  ( J , J  )       (a pair of transposed Jordan blocks) */

/*                                      t                ( I   0  ) */
/*  (6)  ( X, Y )         where  X = ( J   0  )  and Y = (      t ) */
/*                                   ( 0   I  )          ( 0   J  ) */
/*                        and I is a k x k identity and J a (k+1)x(k+1) */
/*                        Jordan block; k=(N-1)/2 */

/*  (7)  ( D, I )         where D is diag( 0, 1,..., N-1 ) (a diagonal */
/*                        matrix with those diagonal entries.) */
/*  (8)  ( I, D ) */

/*  (9)  ( big*D, small*I ) where "big" is near overflow and small=1/big */

/*  (10) ( small*D, big*I ) */

/*  (11) ( big*I, small*D ) */

/*  (12) ( small*I, big*D ) */

/*  (13) ( big*D, big*I ) */

/*  (14) ( small*D, small*I ) */

/*  (15) ( D1, D2 )        where D1 is diag( 0, 0, 1, ..., N-3, 0 ) and */
/*                         D2 is diag( 0, N-3, N-4,..., 1, 0, 0 ) */
/*            t   t */
/*  (16) Q ( J , J ) Z     where Q and Z are random orthogonal matrices. */

/*  (17) Q ( T1, T2 ) Z    where T1 and T2 are upper triangular matrices */
/*                         with random O(1) entries above the diagonal */
/*                         and diagonal entries diag(T1) = */
/*                         ( 0, 0, 1, ..., N-3, 0 ) and diag(T2) = */
/*                         ( 0, N-3, N-4,..., 1, 0, 0 ) */

/*  (18) Q ( T1, T2 ) Z    diag(T1) = ( 0, 0, 1, 1, s, ..., s, 0 ) */
/*                         diag(T2) = ( 0, 1, 0, 1,..., 1, 0 ) */
/*                         s = machine precision. */

/*  (19) Q ( T1, T2 ) Z    diag(T1)=( 0,0,1,1, 1-d, ..., 1-(N-5)*d=s, 0 ) */
/*                         diag(T2) = ( 0, 1, 0, 1, ..., 1, 0 ) */

/*                                                         N-5 */
/*  (20) Q ( T1, T2 ) Z    diag(T1)=( 0, 0, 1, 1, a, ..., a   =s, 0 ) */
/*                         diag(T2) = ( 0, 1, 0, 1, ..., 1, 0, 0 ) */

/*  (21) Q ( T1, T2 ) Z    diag(T1)=( 0, 0, 1, r1, r2, ..., r(N-4), 0 ) */
/*                         diag(T2) = ( 0, 1, 0, 1, ..., 1, 0, 0 ) */
/*                         where r1,..., r(N-4) are random. */

/*  (22) Q ( big*T1, small*T2 ) Z    diag(T1) = ( 0, 0, 1, ..., N-3, 0 ) */
/*                                   diag(T2) = ( 0, 1, ..., 1, 0, 0 ) */

/*  (23) Q ( small*T1, big*T2 ) Z    diag(T1) = ( 0, 0, 1, ..., N-3, 0 ) */
/*                                   diag(T2) = ( 0, 1, ..., 1, 0, 0 ) */

/*  (24) Q ( small*T1, small*T2 ) Z  diag(T1) = ( 0, 0, 1, ..., N-3, 0 ) */
/*                                   diag(T2) = ( 0, 1, ..., 1, 0, 0 ) */

/*  (25) Q ( big*T1, big*T2 ) Z      diag(T1) = ( 0, 0, 1, ..., N-3, 0 ) */
/*                                   diag(T2) = ( 0, 1, ..., 1, 0, 0 ) */

/*  (26) Q ( T1, T2 ) Z     where T1 and T2 are random upper-triangular */
/*                          matrices. */


/*  Arguments */
/*  ========= */

/*  NSIZES  (input) INTEGER */
/*          The number of sizes of matrices to use.  If it is zero, */
/*          DDRGES does nothing.  NSIZES >= 0. */

/*  NN      (input) INTEGER array, dimension (NSIZES) */
/*          An array containing the sizes to be used for the matrices. */
/*          Zero values will be skipped.  NN >= 0. */

/*  NTYPES  (input) INTEGER */
/*          The number of elements in DOTYPE.   If it is zero, DDRGES */
/*          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 on input. */
/*          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 DDRGES 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.  THRESH >= 0. */

/*  NOUNIT  (input) INTEGER */
/*          The FORTRAN unit number for printing out error messages */
/*          (e.g., if a routine returns IINFO not equal to 0.) */

/*  A       (input/workspace) COMPLEX*16 array, dimension(LDA, max(NN)) */
/*          Used to hold the original A matrix.  Used as input only */
/*          if NTYPES=MAXTYP+1, DOTYPE(1:MAXTYP)=.FALSE., and */
/*          DOTYPE(MAXTYP+1)=.TRUE. */

/*  LDA     (input) INTEGER */
/*          The leading dimension of A, B, S, and T. */
/*          It must be at least 1 and at least max( NN ). */

/*  B       (input/workspace) COMPLEX*16 array, dimension(LDA, max(NN)) */
/*          Used to hold the original B matrix.  Used as input only */
/*          if NTYPES=MAXTYP+1, DOTYPE(1:MAXTYP)=.FALSE., and */
/*          DOTYPE(MAXTYP+1)=.TRUE. */

/*  S       (workspace) COMPLEX*16 array, dimension (LDA, max(NN)) */
/*          The Schur form matrix computed from A by ZGGES.  On exit, S */
/*          contains the Schur form matrix corresponding to the matrix */
/*          in A. */

/*  T       (workspace) COMPLEX*16 array, dimension (LDA, max(NN)) */
/*          The upper triangular matrix computed from B by ZGGES. */

/*  Q       (workspace) COMPLEX*16 array, dimension (LDQ, max(NN)) */
/*          The (left) orthogonal matrix computed by ZGGES. */

/*  LDQ     (input) INTEGER */
/*          The leading dimension of Q and Z. It must */
/*          be at least 1 and at least max( NN ). */

/*  Z       (workspace) COMPLEX*16 array, dimension( LDQ, max(NN) ) */
/*          The (right) orthogonal matrix computed by ZGGES. */

/*  ALPHA   (workspace) COMPLEX*16 array, dimension (max(NN)) */
/*  BETA    (workspace) COMPLEX*16 array, dimension (max(NN)) */
/*          The generalized eigenvalues of (A,B) computed by ZGGES. */
/*          ALPHA(k) / BETA(k) is the k-th generalized eigenvalue of A */
/*          and B. */

/*  WORK    (workspace) COMPLEX*16 array, dimension (LWORK) */

/*  LWORK   (input) INTEGER */
/*          The dimension of the array WORK.  LWORK >= 3*N*N. */

/*  RWORK   (workspace) DOUBLE PRECISION array, dimension ( 8*N ) */
/*          Real workspace. */

/*  RESULT  (output) DOUBLE PRECISION array, dimension (15) */
/*          The values computed by the tests described above. */
/*          The values are currently limited to 1/ulp, to avoid overflow. */

/*  BWORK   (workspace) LOGICAL array, dimension (N) */

/*  INFO    (output) INTEGER */
/*          = 0:  successful exit */
/*          < 0:  if INFO = -i, the i-th argument had an illegal value. */
/*          > 0:  A routine returned an error code.  INFO is the */
/*                absolute value of the INFO value returned. */

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

/*     .. Parameters .. */
/*     .. */
/*     .. Local Scalars .. */
/*     .. */
/*     .. Local Arrays .. */
/*     .. */
/*     .. External Functions .. */
/*     .. */
/*     .. External Subroutines .. */
/*     .. */
/*     .. Intrinsic Functions .. */
/*     .. */
/*     .. Statement Functions .. */
/*     .. */
/*     .. Statement Function definitions .. */
/*     .. */
/*     .. Data statements .. */
    /* Parameter adjustments */
    --nn;
    --dotype;
    --iseed;
    t_dim1 = *lda;
    t_offset = 1 + t_dim1;
    t -= t_offset;
    s_dim1 = *lda;
    s_offset = 1 + s_dim1;
    s -= s_offset;
    b_dim1 = *lda;
    b_offset = 1 + b_dim1;
    b -= b_offset;
    a_dim1 = *lda;
    a_offset = 1 + a_dim1;
    a -= a_offset;
    z_dim1 = *ldq;
    z_offset = 1 + z_dim1;
    z__ -= z_offset;
    q_dim1 = *ldq;
    q_offset = 1 + q_dim1;
    q -= q_offset;
    --alpha;
    --beta;
    --work;
    --rwork;
    --result;
    --bwork;

    /* Function Body */
/*     .. */
/*     .. Executable Statements .. */

/*     Check for errors */

    *info = 0;

    badnn = FALSE_;
    nmax = 1;
    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: */
    }

    if (*nsizes < 0) {
	*info = -1;
    } else if (badnn) {
	*info = -2;
    } else if (*ntypes < 0) {
	*info = -3;
    } else if (*thresh < 0.) {
	*info = -6;
    } else if (*lda <= 1 || *lda < nmax) {
	*info = -9;
    } else if (*ldq <= 1 || *ldq < nmax) {
	*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. */

    minwrk = 1;
    if (*info == 0 && *lwork >= 1) {
	minwrk = nmax * 3 * nmax;
/* Computing MAX */
	i__1 = 1, i__2 = ilaenv_(&c__1, "ZGEQRF", " ", &nmax, &nmax, &c_n1, &
		c_n1), i__1 = max(i__1,i__2), i__2 = 
		ilaenv_(&c__1, "ZUNMQR", "LC", &nmax, &nmax, &nmax, &c_n1), i__1 = max(i__1,i__2), i__2 = ilaenv_(&
		c__1, "ZUNGQR", " ", &nmax, &nmax, &nmax, &c_n1);
	nb = max(i__1,i__2);
/* Computing MAX */
	i__1 = nmax + nmax * nb, i__2 = nmax * 3 * nmax;
	maxwrk = max(i__1,i__2);
	work[1].r = (doublereal) maxwrk, work[1].i = 0.;
    }

    if (*lwork < minwrk) {
	*info = -19;
    }

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

/*     Quick return if possible */

    if (*nsizes == 0 || *ntypes == 0) {
	return 0;
    }

    ulp = dlamch_("Precision");
    safmin = dlamch_("Safe minimum");
    safmin /= ulp;
    safmax = 1. / safmin;
    dlabad_(&safmin, &safmax);
    ulpinv = 1. / ulp;

/*     The values RMAGN(2:3) depend on N, see below. */

    rmagn[0] = 0.;
    rmagn[1] = 1.;

/*     Loop over matrix sizes */

    ntestt = 0;
    nerrs = 0;
    nmats = 0;

    i__1 = *nsizes;
    for (jsize = 1; jsize <= i__1; ++jsize) {
	n = nn[jsize];
	n1 = max(1,n);
	rmagn[2] = safmax * ulp / (doublereal) n1;
	rmagn[3] = safmin * ulpinv * (doublereal) n1;

	if (*nsizes != 1) {
	    mtypes = min(26,*ntypes);
	} else {
	    mtypes = min(27,*ntypes);
	}

/*        Loop over matrix types */

	i__2 = mtypes;
	for (jtype = 1; jtype <= i__2; ++jtype) {
	    if (! dotype[jtype]) {
		goto L180;
	    }
	    ++nmats;
	    ntest = 0;

/*           Save ISEED in case of an error. */

	    for (j = 1; j <= 4; ++j) {
		ioldsd[j - 1] = iseed[j];
/* L20: */
	    }

/*           Initialize RESULT */

	    for (j = 1; j <= 13; ++j) {
		result[j] = 0.;
/* L30: */
	    }

/*           Generate test matrices A and B */

/*           Description of control parameters: */

/*           KZLASS: =1 means w/o rotation, =2 means w/ rotation, */
/*                   =3 means random. */
/*           KATYPE: the "type" to be passed to ZLATM4 for computing A. */
/*           KAZERO: the pattern of zeros on the diagonal for A: */
/*                   =1: ( xxx ), =2: (0, xxx ) =3: ( 0, 0, xxx, 0 ), */
/*                   =4: ( 0, xxx, 0, 0 ), =5: ( 0, 0, 1, xxx, 0 ), */
/*                   =6: ( 0, 1, 0, xxx, 0 ).  (xxx means a string of */
/*                   non-zero entries.) */
/*           KAMAGN: the magnitude of the matrix: =0: zero, =1: O(1), */
/*                   =2: large, =3: small. */
/*           LASIGN: .TRUE. if the diagonal elements of A are to be */
/*                   multiplied by a random magnitude 1 number. */
/*           KBTYPE, KBZERO, KBMAGN, LBSIGN: the same, but for B. */
/*           KTRIAN: =0: don't fill in the upper triangle, =1: do. */
/*           KZ1, KZ2, KADD: used to implement KAZERO and KBZERO. */
/*           RMAGN: used to implement KAMAGN and KBMAGN. */

	    if (mtypes > 26) {
		goto L110;
	    }
	    iinfo = 0;
	    if (kclass[jtype - 1] < 3) {

/*              Generate A (w/o rotation) */

		if ((i__3 = katype[jtype - 1], abs(i__3)) == 3) {
		    in = ((n - 1) / 2 << 1) + 1;
		    if (in != n) {
			zlaset_("Full", &n, &n, &c_b1, &c_b1, &a[a_offset], 
				lda);
		    }
		} else {
		    in = n;
		}
		zlatm4_(&katype[jtype - 1], &in, &kz1[kazero[jtype - 1] - 1], 
			&kz2[kazero[jtype - 1] - 1], &lasign[jtype - 1], &
			rmagn[kamagn[jtype - 1]], &ulp, &rmagn[ktrian[jtype - 
			1] * kamagn[jtype - 1]], &c__2, &iseed[1], &a[
			a_offset], lda);
		iadd = kadd[kazero[jtype - 1] - 1];
		if (iadd > 0 && iadd <= n) {
		    i__3 = iadd + iadd * a_dim1;
		    i__4 = kamagn[jtype - 1];
		    a[i__3].r = rmagn[i__4], a[i__3].i = 0.;
		}

/*              Generate B (w/o rotation) */

		if ((i__3 = kbtype[jtype - 1], abs(i__3)) == 3) {
		    in = ((n - 1) / 2 << 1) + 1;
		    if (in != n) {
			zlaset_("Full", &n, &n, &c_b1, &c_b1, &b[b_offset], 
				lda);
		    }
		} else {
		    in = n;
		}
		zlatm4_(&kbtype[jtype - 1], &in, &kz1[kbzero[jtype - 1] - 1], 
			&kz2[kbzero[jtype - 1] - 1], &lbsign[jtype - 1], &
			rmagn[kbmagn[jtype - 1]], &c_b29, &rmagn[ktrian[jtype 
			- 1] * kbmagn[jtype - 1]], &c__2, &iseed[1], &b[
			b_offset], lda);
		iadd = kadd[kbzero[jtype - 1] - 1];
		if (iadd != 0 && iadd <= n) {
		    i__3 = iadd + iadd * b_dim1;
		    i__4 = kbmagn[jtype - 1];
		    b[i__3].r = rmagn[i__4], b[i__3].i = 0.;
		}

		if (kclass[jtype - 1] == 2 && n > 0) {

/*                 Include rotations */

/*                 Generate Q, Z as Householder transformations times */
/*                 a diagonal matrix. */

		    i__3 = n - 1;
		    for (jc = 1; jc <= i__3; ++jc) {
			i__4 = n;
			for (jr = jc; jr <= i__4; ++jr) {
			    i__5 = jr + jc * q_dim1;
			    zlarnd_(&z__1, &c__3, &iseed[1]);
			    q[i__5].r = z__1.r, q[i__5].i = z__1.i;
			    i__5 = jr + jc * z_dim1;
			    zlarnd_(&z__1, &c__3, &iseed[1]);
			    z__[i__5].r = z__1.r, z__[i__5].i = z__1.i;
/* L40: */
			}
			i__4 = n + 1 - jc;
			zlarfg_(&i__4, &q[jc + jc * q_dim1], &q[jc + 1 + jc * 
				q_dim1], &c__1, &work[jc]);
			i__4 = (n << 1) + jc;
			i__5 = jc + jc * q_dim1;
			d__2 = q[i__5].r;
			d__1 = d_sign(&c_b29, &d__2);
			work[i__4].r = d__1, work[i__4].i = 0.;
			i__4 = jc + jc * q_dim1;
			q[i__4].r = 1., q[i__4].i = 0.;
			i__4 = n + 1 - jc;
			zlarfg_(&i__4, &z__[jc + jc * z_dim1], &z__[jc + 1 + 
				jc * z_dim1], &c__1, &work[n + jc]);
			i__4 = n * 3 + jc;
			i__5 = jc + jc * z_dim1;
			d__2 = z__[i__5].r;
			d__1 = d_sign(&c_b29, &d__2);
			work[i__4].r = d__1, work[i__4].i = 0.;
			i__4 = jc + jc * z_dim1;
			z__[i__4].r = 1., z__[i__4].i = 0.;
/* L50: */
		    }
		    zlarnd_(&z__1, &c__3, &iseed[1]);
		    ctemp.r = z__1.r, ctemp.i = z__1.i;
		    i__3 = n + n * q_dim1;
		    q[i__3].r = 1., q[i__3].i = 0.;
		    i__3 = n;
		    work[i__3].r = 0., work[i__3].i = 0.;
		    i__3 = n * 3;
		    d__1 = z_abs(&ctemp);
		    z__1.r = ctemp.r / d__1, z__1.i = ctemp.i / d__1;
		    work[i__3].r = z__1.r, work[i__3].i = z__1.i;
		    zlarnd_(&z__1, &c__3, &iseed[1]);
		    ctemp.r = z__1.r, ctemp.i = z__1.i;
		    i__3 = n + n * z_dim1;
		    z__[i__3].r = 1., z__[i__3].i = 0.;
		    i__3 = n << 1;
		    work[i__3].r = 0., work[i__3].i = 0.;
		    i__3 = n << 2;
		    d__1 = z_abs(&ctemp);
		    z__1.r = ctemp.r / d__1, z__1.i = ctemp.i / d__1;
		    work[i__3].r = z__1.r, work[i__3].i = z__1.i;

/*                 Apply the diagonal matrices */

		    i__3 = n;
		    for (jc = 1; jc <= i__3; ++jc) {
			i__4 = n;
			for (jr = 1; jr <= i__4; ++jr) {
			    i__5 = jr + jc * a_dim1;
			    i__6 = (n << 1) + jr;
			    d_cnjg(&z__3, &work[n * 3 + jc]);
			    z__2.r = work[i__6].r * z__3.r - work[i__6].i * 
				    z__3.i, z__2.i = work[i__6].r * z__3.i + 
				    work[i__6].i * z__3.r;
			    i__7 = jr + jc * a_dim1;
			    z__1.r = z__2.r * a[i__7].r - z__2.i * a[i__7].i, 
				    z__1.i = z__2.r * a[i__7].i + z__2.i * a[
				    i__7].r;
			    a[i__5].r = z__1.r, a[i__5].i = z__1.i;
			    i__5 = jr + jc * b_dim1;
			    i__6 = (n << 1) + jr;
			    d_cnjg(&z__3, &work[n * 3 + jc]);
			    z__2.r = work[i__6].r * z__3.r - work[i__6].i * 
				    z__3.i, z__2.i = work[i__6].r * z__3.i + 
				    work[i__6].i * z__3.r;
			    i__7 = jr + jc * b_dim1;
			    z__1.r = z__2.r * b[i__7].r - z__2.i * b[i__7].i, 
				    z__1.i = z__2.r * b[i__7].i + z__2.i * b[
				    i__7].r;
			    b[i__5].r = z__1.r, b[i__5].i = z__1.i;
/* L60: */
			}
/* L70: */
		    }
		    i__3 = n - 1;
		    zunm2r_("L", "N", &n, &n, &i__3, &q[q_offset], ldq, &work[
			    1], &a[a_offset], lda, &work[(n << 1) + 1], &
			    iinfo);
		    if (iinfo != 0) {
			goto L100;
		    }
		    i__3 = n - 1;
		    zunm2r_("R", "C", &n, &n, &i__3, &z__[z_offset], ldq, &
			    work[n + 1], &a[a_offset], lda, &work[(n << 1) + 
			    1], &iinfo);
		    if (iinfo != 0) {
			goto L100;
		    }
		    i__3 = n - 1;
		    zunm2r_("L", "N", &n, &n, &i__3, &q[q_offset], ldq, &work[
			    1], &b[b_offset], lda, &work[(n << 1) + 1], &
			    iinfo);
		    if (iinfo != 0) {
			goto L100;
		    }
		    i__3 = n - 1;
		    zunm2r_("R", "C", &n, &n, &i__3, &z__[z_offset], ldq, &
			    work[n + 1], &b[b_offset], lda, &work[(n << 1) + 
			    1], &iinfo);
		    if (iinfo != 0) {
			goto L100;
		    }
		}
	    } else {

/*              Random matrices */

		i__3 = n;
		for (jc = 1; jc <= i__3; ++jc) {
		    i__4 = n;
		    for (jr = 1; jr <= i__4; ++jr) {
			i__5 = jr + jc * a_dim1;
			i__6 = kamagn[jtype - 1];
			zlarnd_(&z__2, &c__4, &iseed[1]);
			z__1.r = rmagn[i__6] * z__2.r, z__1.i = rmagn[i__6] * 
				z__2.i;
			a[i__5].r = z__1.r, a[i__5].i = z__1.i;
			i__5 = jr + jc * b_dim1;
			i__6 = kbmagn[jtype - 1];
			zlarnd_(&z__2, &c__4, &iseed[1]);
			z__1.r = rmagn[i__6] * z__2.r, z__1.i = rmagn[i__6] * 
				z__2.i;
			b[i__5].r = z__1.r, b[i__5].i = z__1.i;
/* L80: */
		    }
/* L90: */
		}
	    }

L100:

	    if (iinfo != 0) {
		io___41.ciunit = *nounit;
		s_wsfe(&io___41);
		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;
	    }

L110:

	    for (i__ = 1; i__ <= 13; ++i__) {
		result[i__] = -1.;
/* L120: */
	    }

/*           Test with and without sorting of eigenvalues */

	    for (isort = 0; isort <= 1; ++isort) {
		if (isort == 0) {
		    *(unsigned char *)sort = 'N';
		    rsub = 0;
		} else {
		    *(unsigned char *)sort = 'S';
		    rsub = 5;
		}

/*              Call ZGGES to compute H, T, Q, Z, alpha, and beta. */

		zlacpy_("Full", &n, &n, &a[a_offset], lda, &s[s_offset], lda);
		zlacpy_("Full", &n, &n, &b[b_offset], lda, &t[t_offset], lda);
		ntest = rsub + 1 + isort;
		result[rsub + 1 + isort] = ulpinv;
		zgges_("V", "V", sort, (L_fp)zlctes_, &n, &s[s_offset], lda, &
			t[t_offset], lda, &sdim, &alpha[1], &beta[1], &q[
			q_offset], ldq, &z__[z_offset], ldq, &work[1], lwork, 
			&rwork[1], &bwork[1], &iinfo);
		if (iinfo != 0 && iinfo != n + 2) {
		    result[rsub + 1 + isort] = ulpinv;
		    io___47.ciunit = *nounit;
		    s_wsfe(&io___47);
		    do_fio(&c__1, "ZGGES", (ftnlen)5);
		    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 L160;
		}

		ntest = rsub + 4;

/*              Do tests 1--4 (or tests 7--9 when reordering ) */

		if (isort == 0) {
		    zget51_(&c__1, &n, &a[a_offset], lda, &s[s_offset], lda, &
			    q[q_offset], ldq, &z__[z_offset], ldq, &work[1], &
			    rwork[1], &result[1]);
		    zget51_(&c__1, &n, &b[b_offset], lda, &t[t_offset], lda, &
			    q[q_offset], ldq, &z__[z_offset], ldq, &work[1], &
			    rwork[1], &result[2]);
		} else {
		    zget54_(&n, &a[a_offset], lda, &b[b_offset], lda, &s[
			    s_offset], lda, &t[t_offset], lda, &q[q_offset], 
			    ldq, &z__[z_offset], ldq, &work[1], &result[rsub 
			    + 2]);
		}

		zget51_(&c__3, &n, &b[b_offset], lda, &t[t_offset], lda, &q[
			q_offset], ldq, &q[q_offset], ldq, &work[1], &rwork[1]
, &result[rsub + 3]);
		zget51_(&c__3, &n, &b[b_offset], lda, &t[t_offset], lda, &z__[
			z_offset], ldq, &z__[z_offset], ldq, &work[1], &rwork[
			1], &result[rsub + 4]);

/*              Do test 5 and 6 (or Tests 10 and 11 when reordering): */
/*              check Schur form of A and compare eigenvalues with */
/*              diagonals. */

		ntest = rsub + 6;
		temp1 = 0.;

		i__3 = n;
		for (j = 1; j <= i__3; ++j) {
		    ilabad = FALSE_;
		    i__4 = j;
		    i__5 = j + j * s_dim1;
		    z__2.r = alpha[i__4].r - s[i__5].r, z__2.i = alpha[i__4]
			    .i - s[i__5].i;
		    z__1.r = z__2.r, z__1.i = z__2.i;
		    i__6 = j;
		    i__7 = j + j * t_dim1;
		    z__4.r = beta[i__6].r - t[i__7].r, z__4.i = beta[i__6].i 
			    - t[i__7].i;
		    z__3.r = z__4.r, z__3.i = z__4.i;
/* Computing MAX */
		    i__8 = j;
		    i__9 = j + j * s_dim1;
		    d__13 = safmin, d__14 = (d__1 = alpha[i__8].r, abs(d__1)) 
			    + (d__2 = d_imag(&alpha[j]), abs(d__2)), d__13 = 
			    max(d__13,d__14), d__14 = (d__3 = s[i__9].r, abs(
			    d__3)) + (d__4 = d_imag(&s[j + j * s_dim1]), abs(
			    d__4));
/* Computing MAX */
		    i__10 = j;
		    i__11 = j + j * t_dim1;
		    d__15 = safmin, d__16 = (d__5 = beta[i__10].r, abs(d__5)) 
			    + (d__6 = d_imag(&beta[j]), abs(d__6)), d__15 = 
			    max(d__15,d__16), d__16 = (d__7 = t[i__11].r, abs(
			    d__7)) + (d__8 = d_imag(&t[j + j * t_dim1]), abs(
			    d__8));
		    temp2 = (((d__9 = z__1.r, abs(d__9)) + (d__10 = d_imag(&
			    z__1), abs(d__10))) / max(d__13,d__14) + ((d__11 =
			     z__3.r, abs(d__11)) + (d__12 = d_imag(&z__3), 
			    abs(d__12))) / max(d__15,d__16)) / ulp;

		    if (j < n) {
			i__4 = j + 1 + j * s_dim1;
			if (s[i__4].r != 0. || s[i__4].i != 0.) {
			    ilabad = TRUE_;
			    result[rsub + 5] = ulpinv;
			}
		    }
		    if (j > 1) {
			i__4 = j + (j - 1) * s_dim1;
			if (s[i__4].r != 0. || s[i__4].i != 0.) {
			    ilabad = TRUE_;
			    result[rsub + 5] = ulpinv;
			}
		    }
		    temp1 = max(temp1,temp2);
		    if (ilabad) {
			io___51.ciunit = *nounit;
			s_wsfe(&io___51);
			do_fio(&c__1, (char *)&j, (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();
		    }
/* L130: */
		}
		result[rsub + 6] = temp1;

		if (isort >= 1) {

/*                 Do test 12 */

		    ntest = 12;
		    result[12] = 0.;
		    knteig = 0;
		    i__3 = n;
		    for (i__ = 1; i__ <= i__3; ++i__) {
			if (zlctes_(&alpha[i__], &beta[i__])) {
			    ++knteig;
			}
/* L140: */
		    }
		    if (sdim != knteig) {
			result[13] = ulpinv;
		    }
		}

/* L150: */
	    }

/*           End of Loop -- Check for RESULT(j) > THRESH */

L160:

	    ntestt += ntest;

/*           Print out tests which fail. */

	    i__3 = ntest;
	    for (jr = 1; jr <= i__3; ++jr) {
		if (result[jr] >= *thresh) {

/*                 If this is the first test to fail, */
/*                 print a header to the data file. */

		    if (nerrs == 0) {
			io___53.ciunit = *nounit;
			s_wsfe(&io___53);
			do_fio(&c__1, "ZGS", (ftnlen)3);
			e_wsfe();

/*                    Matrix types */

			io___54.ciunit = *nounit;
			s_wsfe(&io___54);
			e_wsfe();
			io___55.ciunit = *nounit;
			s_wsfe(&io___55);
			e_wsfe();
			io___56.ciunit = *nounit;
			s_wsfe(&io___56);
			do_fio(&c__1, "Unitary", (ftnlen)7);
			e_wsfe();

/*                    Tests performed */

			io___57.ciunit = *nounit;
			s_wsfe(&io___57);
			do_fio(&c__1, "unitary", (ftnlen)7);
			do_fio(&c__1, "'", (ftnlen)1);
			do_fio(&c__1, "transpose", (ftnlen)9);
			for (j = 1; j <= 8; ++j) {
			    do_fio(&c__1, "'", (ftnlen)1);
			}
			e_wsfe();

		    }
		    ++nerrs;
		    if (result[jr] < 1e4) {
			io___58.ciunit = *nounit;
			s_wsfe(&io___58);
			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));
			do_fio(&c__1, (char *)&jr, (ftnlen)sizeof(integer));
			do_fio(&c__1, (char *)&result[jr], (ftnlen)sizeof(
				doublereal));
			e_wsfe();
		    } else {
			io___59.ciunit = *nounit;
			s_wsfe(&io___59);
			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));
			do_fio(&c__1, (char *)&jr, (ftnlen)sizeof(integer));
			do_fio(&c__1, (char *)&result[jr], (ftnlen)sizeof(
				doublereal));
			e_wsfe();
		    }
		}
/* L170: */
	    }

L180:
	    ;
	}
/* L190: */
    }

/*     Summary */

    alasvm_("ZGS", nounit, &nerrs, &ntestt, &c__0);

    work[1].r = (doublereal) maxwrk, work[1].i = 0.;

    return 0;







/*     End of ZDRGES */

} /* zdrges_ */
示例#7
0
/* Subroutine */ int dget31_(doublereal *rmax, integer *lmax, integer *ninfo,
                             integer *knt)
{
    /* Initialized data */

    static logical ltrans[2] = { FALSE_,TRUE_ };

    /* System generated locals */
    doublereal d__1, d__2, d__3, d__4, d__5, d__6, d__7, d__8, d__9, d__10,
               d__11, d__12, d__13;

    /* Builtin functions */
    double sqrt(doublereal);

    /* Local variables */
    doublereal a[4]	/* was [2][2] */, b[4]	/* was [2][2] */, x[4]	/*
	    was [2][2] */, d1, d2, ca;
    integer ia, ib, na;
    doublereal wi;
    integer nw;
    doublereal wr;
    integer id1, id2, ica;
    doublereal den, vab[3], vca[5], vdd[4], eps;
    integer iwi;
    doublereal res, tmp;
    integer iwr;
    doublereal vwi[4], vwr[4];
    integer info;
    doublereal unfl, smin, scale;
    integer ismin;
    doublereal vsmin[4], xnorm;
    extern /* Subroutine */ int dlaln2_(logical *, integer *, integer *,
                                        doublereal *, doublereal *, doublereal *, integer *, doublereal *,
                                        doublereal *, doublereal *, integer *, doublereal *, doublereal *
                                        , doublereal *, integer *, doublereal *, doublereal *, integer *),
                                        dlabad_(doublereal *, doublereal *);
    extern doublereal dlamch_(char *);
    doublereal bignum;
    integer itrans;
    doublereal smlnum;


    /*  -- LAPACK test routine (version 3.1) -- */
    /*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
    /*     November 2006 */

    /*     .. Scalar Arguments .. */
    /*     .. */
    /*     .. Array Arguments .. */
    /*     .. */

    /*  Purpose */
    /*  ======= */

    /*  DGET31 tests DLALN2, a routine for solving */

    /*     (ca A - w D)X = sB */

    /*  where A is an NA by NA matrix (NA=1 or 2 only), w is a real (NW=1) or */
    /*  complex (NW=2) constant, ca is a real constant, D is an NA by NA real */
    /*  diagonal matrix, and B is an NA by NW matrix (when NW=2 the second */
    /*  column of B contains the imaginary part of the solution).  The code */
    /*  returns X and s, where s is a scale factor, less than or equal to 1, */
    /*  which is chosen to avoid overflow in X. */

    /*  If any singular values of ca A-w D are less than another input */
    /*  parameter SMIN, they are perturbed up to SMIN. */

    /*  The test condition is that the scaled residual */

    /*      norm( (ca A-w D)*X - s*B ) / */
    /*            ( max( ulp*norm(ca A-w D), SMIN )*norm(X) ) */

    /*  should be on the order of 1.  Here, ulp is the machine precision. */
    /*  Also, it is verified that SCALE is less than or equal to 1, and that */
    /*  XNORM = infinity-norm(X). */

    /*  Arguments */
    /*  ========== */

    /*  RMAX    (output) DOUBLE PRECISION */
    /*          Value of the largest test ratio. */

    /*  LMAX    (output) INTEGER */
    /*          Example number where largest test ratio achieved. */

    /*  NINFO   (output) INTEGER array, dimension (3) */
    /*          NINFO(1) = number of examples with INFO less than 0 */
    /*          NINFO(2) = number of examples with INFO greater than 0 */

    /*  KNT     (output) INTEGER */
    /*          Total number of examples tested. */

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

    /*     .. Parameters .. */
    /*     .. */
    /*     .. Local Scalars .. */
    /*     .. */
    /*     .. Local Arrays .. */
    /*     .. */
    /*     .. External Functions .. */
    /*     .. */
    /*     .. External Subroutines .. */
    /*     .. */
    /*     .. Intrinsic Functions .. */
    /*     .. */
    /*     .. Data statements .. */
    /* Parameter adjustments */
    --ninfo;

    /* Function Body */
    /*     .. */
    /*     .. Executable Statements .. */

    /*     Get machine parameters */

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

    /*     Set up test case parameters */

    vsmin[0] = smlnum;
    vsmin[1] = eps;
    vsmin[2] = .01;
    vsmin[3] = 1. / eps;
    vab[0] = sqrt(smlnum);
    vab[1] = 1.;
    vab[2] = sqrt(bignum);
    vwr[0] = 0.;
    vwr[1] = .5;
    vwr[2] = 2.;
    vwr[3] = 1.;
    vwi[0] = smlnum;
    vwi[1] = eps;
    vwi[2] = 1.;
    vwi[3] = 2.;
    vdd[0] = sqrt(smlnum);
    vdd[1] = 1.;
    vdd[2] = 2.;
    vdd[3] = sqrt(bignum);
    vca[0] = 0.;
    vca[1] = sqrt(smlnum);
    vca[2] = eps;
    vca[3] = .5;
    vca[4] = 1.;

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

    /*     Begin test loop */

    for (id1 = 1; id1 <= 4; ++id1) {
        d1 = vdd[id1 - 1];
        for (id2 = 1; id2 <= 4; ++id2) {
            d2 = vdd[id2 - 1];
            for (ica = 1; ica <= 5; ++ica) {
                ca = vca[ica - 1];
                for (itrans = 0; itrans <= 1; ++itrans) {
                    for (ismin = 1; ismin <= 4; ++ismin) {
                        smin = vsmin[ismin - 1];

                        na = 1;
                        nw = 1;
                        for (ia = 1; ia <= 3; ++ia) {
                            a[0] = vab[ia - 1];
                            for (ib = 1; ib <= 3; ++ib) {
                                b[0] = vab[ib - 1];
                                for (iwr = 1; iwr <= 4; ++iwr) {
                                    if (d1 == 1. && d2 == 1. && ca == 1.) {
                                        wr = vwr[iwr - 1] * a[0];
                                    } else {
                                        wr = vwr[iwr - 1];
                                    }
                                    wi = 0.;
                                    dlaln2_(&ltrans[itrans], &na, &nw, &smin,
                                            &ca, a, &c__2, &d1, &d2, b, &c__2,
                                            &wr, &wi, x, &c__2, &scale, &
                                            xnorm, &info);
                                    if (info < 0) {
                                        ++ninfo[1];
                                    }
                                    if (info > 0) {
                                        ++ninfo[2];
                                    }
                                    res = (d__1 = (ca * a[0] - wr * d1) * x[0]
                                                  - scale * b[0], abs(d__1));
                                    if (info == 0) {
                                        /* Computing MAX */
                                        d__2 = eps * (d__1 = (ca * a[0] - wr *
                                                              d1) * x[0], abs(d__1));
                                        den = max(d__2,smlnum);
                                    } else {
                                        /* Computing MAX */
                                        d__1 = smin * abs(x[0]);
                                        den = max(d__1,smlnum);
                                    }
                                    res /= den;
                                    if (abs(x[0]) < unfl && abs(b[0]) <=
                                            smlnum * (d__1 = ca * a[0] - wr *
                                                             d1, abs(d__1))) {
                                        res = 0.;
                                    }
                                    if (scale > 1.) {
                                        res += 1. / eps;
                                    }
                                    res += (d__1 = xnorm - abs(x[0]), abs(
                                                d__1)) / max(smlnum,xnorm) / eps;
                                    if (info != 0 && info != 1) {
                                        res += 1. / eps;
                                    }
                                    ++(*knt);
                                    if (res > *rmax) {
                                        *lmax = *knt;
                                        *rmax = res;
                                    }
                                    /* L10: */
                                }
                                /* L20: */
                            }
                            /* L30: */
                        }

                        na = 1;
                        nw = 2;
                        for (ia = 1; ia <= 3; ++ia) {
                            a[0] = vab[ia - 1];
                            for (ib = 1; ib <= 3; ++ib) {
                                b[0] = vab[ib - 1];
                                b[2] = vab[ib - 1] * -.5;
                                for (iwr = 1; iwr <= 4; ++iwr) {
                                    if (d1 == 1. && d2 == 1. && ca == 1.) {
                                        wr = vwr[iwr - 1] * a[0];
                                    } else {
                                        wr = vwr[iwr - 1];
                                    }
                                    for (iwi = 1; iwi <= 4; ++iwi) {
                                        if (d1 == 1. && d2 == 1. && ca == 1.)
                                        {
                                            wi = vwi[iwi - 1] * a[0];
                                        } else {
                                            wi = vwi[iwi - 1];
                                        }
                                        dlaln2_(&ltrans[itrans], &na, &nw, &
                                                smin, &ca, a, &c__2, &d1, &d2,
                                                b, &c__2, &wr, &wi, x, &c__2,
                                                &scale, &xnorm, &info);
                                        if (info < 0) {
                                            ++ninfo[1];
                                        }
                                        if (info > 0) {
                                            ++ninfo[2];
                                        }
                                        res = (d__1 = (ca * a[0] - wr * d1) *
                                                      x[0] + wi * d1 * x[2] - scale
                                                      * b[0], abs(d__1));
                                        res += (d__1 = -wi * d1 * x[0] + (ca *
                                                                          a[0] - wr * d1) * x[2] -
                                                       scale * b[2], abs(d__1));
                                        if (info == 0) {
                                            /* Computing MAX */
                                            /* Computing MAX */
                                            d__4 = (d__1 = ca * a[0] - wr *
                                                           d1, abs(d__1)), d__5 = (
                                                                   d__2 = d1 * wi, abs(d__2))
                                                                                  ;
                                            d__3 = eps * (max(d__4,d__5) * (
                                                              abs(x[0]) + abs(x[2])));
                                            den = max(d__3,smlnum);
                                        } else {
                                            /* Computing MAX */
                                            d__1 = smin * (abs(x[0]) + abs(x[
                                                                               2]));
                                            den = max(d__1,smlnum);
                                        }
                                        res /= den;
                                        if (abs(x[0]) < unfl && abs(x[2]) <
                                                unfl && abs(b[0]) <= smlnum *
                                                (d__1 = ca * a[0] - wr * d1,
                                                 abs(d__1))) {
                                            res = 0.;
                                        }
                                        if (scale > 1.) {
                                            res += 1. / eps;
                                        }
                                        res += (d__1 = xnorm - abs(x[0]) -
                                                       abs(x[2]), abs(d__1)) / max(
                                                   smlnum,xnorm) / eps;
                                        if (info != 0 && info != 1) {
                                            res += 1. / eps;
                                        }
                                        ++(*knt);
                                        if (res > *rmax) {
                                            *lmax = *knt;
                                            *rmax = res;
                                        }
                                        /* L40: */
                                    }
                                    /* L50: */
                                }
                                /* L60: */
                            }
                            /* L70: */
                        }

                        na = 2;
                        nw = 1;
                        for (ia = 1; ia <= 3; ++ia) {
                            a[0] = vab[ia - 1];
                            a[2] = vab[ia - 1] * -3.;
                            a[1] = vab[ia - 1] * -7.;
                            a[3] = vab[ia - 1] * 21.;
                            for (ib = 1; ib <= 3; ++ib) {
                                b[0] = vab[ib - 1];
                                b[1] = vab[ib - 1] * -2.;
                                for (iwr = 1; iwr <= 4; ++iwr) {
                                    if (d1 == 1. && d2 == 1. && ca == 1.) {
                                        wr = vwr[iwr - 1] * a[0];
                                    } else {
                                        wr = vwr[iwr - 1];
                                    }
                                    wi = 0.;
                                    dlaln2_(&ltrans[itrans], &na, &nw, &smin,
                                            &ca, a, &c__2, &d1, &d2, b, &c__2,
                                            &wr, &wi, x, &c__2, &scale, &
                                            xnorm, &info);
                                    if (info < 0) {
                                        ++ninfo[1];
                                    }
                                    if (info > 0) {
                                        ++ninfo[2];
                                    }
                                    if (itrans == 1) {
                                        tmp = a[2];
                                        a[2] = a[1];
                                        a[1] = tmp;
                                    }
                                    res = (d__1 = (ca * a[0] - wr * d1) * x[0]
                                                  + ca * a[2] * x[1] - scale * b[0]
                                                  , abs(d__1));
                                    res += (d__1 = ca * a[1] * x[0] + (ca * a[
                                                                           3] - wr * d2) * x[1] - scale * b[
                                                       1], abs(d__1));
                                    if (info == 0) {
                                        /* Computing MAX */
                                        /* Computing MAX */
                                        d__6 = (d__1 = ca * a[0] - wr * d1,
                                                abs(d__1)) + (d__2 = ca * a[2]
                                                                     , abs(d__2)), d__7 = (d__3 =
                                                                             ca * a[1], abs(d__3)) + (d__4
                                                                                     = ca * a[3] - wr * d2, abs(
                                                                                             d__4));
                                        /* Computing MAX */
                                        d__8 = abs(x[0]), d__9 = abs(x[1]);
                                        d__5 = eps * (max(d__6,d__7) * max(
                                                          d__8,d__9));
                                        den = max(d__5,smlnum);
                                    } else {
                                        /* Computing MAX */
                                        /* Computing MAX */
                                        /* Computing MAX */
                                        d__8 = (d__1 = ca * a[0] - wr * d1,
                                                abs(d__1)) + (d__2 = ca * a[2]
                                                                     , abs(d__2)), d__9 = (d__3 =
                                                                             ca * a[1], abs(d__3)) + (d__4
                                                                                     = ca * a[3] - wr * d2, abs(
                                                                                             d__4));
                                        d__6 = smin / eps, d__7 = max(d__8,
                                                                      d__9);
                                        /* Computing MAX */
                                        d__10 = abs(x[0]), d__11 = abs(x[1]);
                                        d__5 = eps * (max(d__6,d__7) * max(
                                                          d__10,d__11));
                                        den = max(d__5,smlnum);
                                    }
                                    res /= den;
                                    if (abs(x[0]) < unfl && abs(x[1]) < unfl
                                            && abs(b[0]) + abs(b[1]) <=
                                            smlnum * ((d__1 = ca * a[0] - wr *
                                                              d1, abs(d__1)) + (d__2 = ca * a[
                                                                          2], abs(d__2)) + (d__3 = ca * a[1]
                                                                                  , abs(d__3)) + (d__4 = ca * a[3]
                                                                                          - wr * d2, abs(d__4)))) {
                                        res = 0.;
                                    }
                                    if (scale > 1.) {
                                        res += 1. / eps;
                                    }
                                    /* Computing MAX */
                                    d__2 = abs(x[0]), d__3 = abs(x[1]);
                                    res += (d__1 = xnorm - max(d__2,d__3),
                                            abs(d__1)) / max(smlnum,xnorm) /
                                           eps;
                                    if (info != 0 && info != 1) {
                                        res += 1. / eps;
                                    }
                                    ++(*knt);
                                    if (res > *rmax) {
                                        *lmax = *knt;
                                        *rmax = res;
                                    }
                                    /* L80: */
                                }
                                /* L90: */
                            }
                            /* L100: */
                        }

                        na = 2;
                        nw = 2;
                        for (ia = 1; ia <= 3; ++ia) {
                            a[0] = vab[ia - 1] * 2.;
                            a[2] = vab[ia - 1] * -3.;
                            a[1] = vab[ia - 1] * -7.;
                            a[3] = vab[ia - 1] * 21.;
                            for (ib = 1; ib <= 3; ++ib) {
                                b[0] = vab[ib - 1];
                                b[1] = vab[ib - 1] * -2.;
                                b[2] = vab[ib - 1] * 4.;
                                b[3] = vab[ib - 1] * -7.;
                                for (iwr = 1; iwr <= 4; ++iwr) {
                                    if (d1 == 1. && d2 == 1. && ca == 1.) {
                                        wr = vwr[iwr - 1] * a[0];
                                    } else {
                                        wr = vwr[iwr - 1];
                                    }
                                    for (iwi = 1; iwi <= 4; ++iwi) {
                                        if (d1 == 1. && d2 == 1. && ca == 1.)
                                        {
                                            wi = vwi[iwi - 1] * a[0];
                                        } else {
                                            wi = vwi[iwi - 1];
                                        }
                                        dlaln2_(&ltrans[itrans], &na, &nw, &
                                                smin, &ca, a, &c__2, &d1, &d2,
                                                b, &c__2, &wr, &wi, x, &c__2,
                                                &scale, &xnorm, &info);
                                        if (info < 0) {
                                            ++ninfo[1];
                                        }
                                        if (info > 0) {
                                            ++ninfo[2];
                                        }
                                        if (itrans == 1) {
                                            tmp = a[2];
                                            a[2] = a[1];
                                            a[1] = tmp;
                                        }
                                        res = (d__1 = (ca * a[0] - wr * d1) *
                                                      x[0] + ca * a[2] * x[1] + wi *
                                                      d1 * x[2] - scale * b[0],
                                               abs(d__1));
                                        res += (d__1 = (ca * a[0] - wr * d1) *
                                                       x[2] + ca * a[2] * x[3] - wi
                                                       * d1 * x[0] - scale * b[2],
                                                abs(d__1));
                                        res += (d__1 = ca * a[1] * x[0] + (ca
                                                                           * a[3] - wr * d2) * x[1] + wi
                                                       * d2 * x[3] - scale * b[1],
                                                abs(d__1));
                                        res += (d__1 = ca * a[1] * x[2] + (ca
                                                                           * a[3] - wr * d2) * x[3] - wi
                                                       * d2 * x[1] - scale * b[3],
                                                abs(d__1));
                                        if (info == 0) {
                                            /* Computing MAX */
                                            /* Computing MAX */
                                            d__8 = (d__1 = ca * a[0] - wr *
                                                           d1, abs(d__1)) + (d__2 =
                                                                                 ca * a[2], abs(d__2)) + (
                                                       d__3 = wi * d1, abs(d__3))
                                                   , d__9 = (d__4 = ca * a[1]
                                                                    , abs(d__4)) + (d__5 = ca
                                                                                    * a[3] - wr * d2, abs(
                                                                                            d__5)) + (d__6 = wi * d2,
                                                                                                    abs(d__6));
                                            /* Computing MAX */
                                            d__10 = abs(x[0]) + abs(x[1]),
                                            d__11 = abs(x[2]) + abs(x[
                                                                        3]);
                                            d__7 = eps * (max(d__8,d__9) *
                                                          max(d__10,d__11));
                                            den = max(d__7,smlnum);
                                        } else {
                                            /* Computing MAX */
                                            /* Computing MAX */
                                            /* Computing MAX */
                                            d__10 = (d__1 = ca * a[0] - wr *
                                                            d1, abs(d__1)) + (d__2 =
                                                                                  ca * a[2], abs(d__2)) + (
                                                        d__3 = wi * d1, abs(d__3))
                                                    , d__11 = (d__4 = ca * a[
                                                                          1], abs(d__4)) + (d__5 =
                                                                                  ca * a[3] - wr * d2, abs(
                                                                                          d__5)) + (d__6 = wi * d2,
                                                                                                  abs(d__6));
                                            d__8 = smin / eps, d__9 = max(
                                                                          d__10,d__11);
                                            /* Computing MAX */
                                            d__12 = abs(x[0]) + abs(x[1]),
                                            d__13 = abs(x[2]) + abs(x[
                                                                        3]);
                                            d__7 = eps * (max(d__8,d__9) *
                                                          max(d__12,d__13));
                                            den = max(d__7,smlnum);
                                        }
                                        res /= den;
                                        if (abs(x[0]) < unfl && abs(x[1]) <
                                                unfl && abs(x[2]) < unfl &&
                                                abs(x[3]) < unfl && abs(b[0])
                                                + abs(b[1]) <= smlnum * ((
                                                                             d__1 = ca * a[0] - wr * d1,
                                                                             abs(d__1)) + (d__2 = ca * a[2]
                                                                                     , abs(d__2)) + (d__3 = ca * a[
                                                                                             1], abs(d__3)) + (d__4 = ca *
                                                                                                     a[3] - wr * d2, abs(d__4)) + (
                                                                             d__5 = wi * d2, abs(d__5)) + (
                                                                             d__6 = wi * d1, abs(d__6)))) {
                                            res = 0.;
                                        }
                                        if (scale > 1.) {
                                            res += 1. / eps;
                                        }
                                        /* Computing MAX */
                                        d__2 = abs(x[0]) + abs(x[2]), d__3 =
                                                   abs(x[1]) + abs(x[3]);
                                        res += (d__1 = xnorm - max(d__2,d__3),
                                                abs(d__1)) / max(smlnum,
                                                                 xnorm) / eps;
                                        if (info != 0 && info != 1) {
                                            res += 1. / eps;
                                        }
                                        ++(*knt);
                                        if (res > *rmax) {
                                            *lmax = *knt;
                                            *rmax = res;
                                        }
                                        /* L110: */
                                    }
                                    /* L120: */
                                }
                                /* L130: */
                            }
                            /* L140: */
                        }
                        /* L150: */
                    }
                    /* L160: */
                }
                /* L170: */
            }
            /* L180: */
        }
        /* L190: */
    }

    return 0;

    /*     End of DGET31 */

} /* dget31_ */
示例#8
0
/* Subroutine */ int ztgevc_(char *side, char *howmny, logical *select,
                             integer *n, doublecomplex *s, integer *lds, doublecomplex *p, integer
                             *ldp, doublecomplex *vl, integer *ldvl, doublecomplex *vr, integer *
                             ldvr, integer *mm, integer *m, doublecomplex *work, doublereal *rwork,
                             integer *info)
{
    /* System generated locals */
    integer p_dim1, p_offset, s_dim1, s_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, d__6;
    doublecomplex z__1, z__2, z__3, z__4;

    /* Local variables */
    doublecomplex d__;
    integer i__, j;
    doublecomplex ca, cb;
    integer je, im, jr;
    doublereal big;
    logical lsa, lsb;
    doublereal ulp;
    doublecomplex sum;
    integer ibeg, ieig, iend;
    doublereal dmin__;
    integer isrc;
    doublereal temp;
    doublecomplex suma, sumb;
    doublereal xmax, scale;
    logical ilall;
    integer iside;
    doublereal sbeta;
    doublereal small;
    logical compl;
    doublereal anorm, bnorm;
    logical compr;
    logical ilbbad;
    doublereal acoefa, bcoefa, acoeff;
    doublecomplex bcoeff;
    logical ilback;
    doublereal ascale, bscale;
    doublecomplex salpha;
    doublereal safmin;
    doublereal bignum;
    logical ilcomp;
    integer ihwmny;

    /*  -- LAPACK routine (version 3.2) -- */
    /*     November 2006 */

    /*  Purpose */
    /*  ======= */

    /*  ZTGEVC computes some or all of the right and/or left eigenvectors of */
    /*  a pair of complex matrices (S,P), where S and P are upper triangular. */
    /*  Matrix pairs of this type are produced by the generalized Schur */
    /*  factorization of a complex matrix pair (A,B): */

    /*     A = Q*S*Z**H,  B = Q*P*Z**H */

    /*  as computed by ZGGHRD + ZHGEQZ. */

    /*  The right eigenvector x and the left eigenvector y of (S,P) */
    /*  corresponding to an eigenvalue w are defined by: */

    /*     S*x = w*P*x,  (y**H)*S = w*(y**H)*P, */

    /*  where y**H denotes the conjugate tranpose of y. */
    /*  The eigenvalues are not input to this routine, but are computed */
    /*  directly from the diagonal elements of S and P. */

    /*  This routine returns the matrices X and/or Y of right and left */
    /*  eigenvectors of (S,P), or the products Z*X and/or Q*Y, */
    /*  where Z and Q are input matrices. */
    /*  If Q and Z are the unitary factors from the generalized Schur */
    /*  factorization of a matrix pair (A,B), then Z*X and Q*Y */
    /*  are the matrices of right and left eigenvectors of (A,B). */

    /*  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, */
    /*                 backtransformed by the matrices 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.  The eigenvector corresponding to the j-th */
    /*          Not referenced if HOWMNY = 'A' or 'B'. */

    /*  N       (input) INTEGER */
    /*          The order of the matrices S and P.  N >= 0. */

    /*  S       (input) COMPLEX*16 array, dimension (LDS,N) */
    /*          The upper triangular matrix S from a generalized Schur */
    /*          factorization, as computed by ZHGEQZ. */

    /*  LDS     (input) INTEGER */
    /*          The leading dimension of array S.  LDS >= max(1,N). */

    /*  P       (input) COMPLEX*16 array, dimension (LDP,N) */
    /*          The upper triangular matrix P from a generalized Schur */
    /*          factorization, as computed by ZHGEQZ.  P must have real */
    /*          diagonal elements. */

    /*  LDP     (input) INTEGER */
    /*          The leading dimension of array P.  LDP >= 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 left Schur vectors returned by ZHGEQZ). */
    /*          On exit, if SIDE = 'L' or 'B', VL contains: */
    /*          if HOWMNY = 'A', the matrix Y of left eigenvectors of (S,P); */
    /*          if HOWMNY = 'B', the matrix Q*Y; */
    /*          if HOWMNY = 'S', the left eigenvectors of (S,P) specified by */
    /*                      SELECT, stored consecutively in the columns of */
    /*                      VL, in the same order as their eigenvalues. */
    /*          Not referenced if SIDE = 'R'. */

    /*  LDVL    (input) INTEGER */
    /*          The leading dimension of array VL.  LDVL >= 1, and if */
    /*          SIDE = 'L' or 'l' or 'B' or 'b', LDVL >= N. */

    /*  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 Z */
    /*          of right Schur vectors returned by ZHGEQZ). */
    /*          On exit, if SIDE = 'R' or 'B', VR contains: */
    /*          if HOWMNY = 'A', the matrix X of right eigenvectors of (S,P); */
    /*          if HOWMNY = 'B', the matrix Z*X; */
    /*          if HOWMNY = 'S', the right eigenvectors of (S,P) specified by */
    /*                      SELECT, stored consecutively in the columns of */
    /*                      VR, in the same order as their eigenvalues. */
    /*          Not referenced if SIDE = 'L'. */

    /*  LDVR    (input) INTEGER */
    /*          The leading dimension of the array VR.  LDVR >= 1, and if */
    /*          SIDE = 'R' or 'B', LDVR >= N. */

    /*  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 (2*N) */

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

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

    /*     Decode and Test the input parameters */

    /* Parameter adjustments */
    --select;
    s_dim1 = *lds;
    s_offset = 1 + s_dim1;
    s -= s_offset;
    p_dim1 = *ldp;
    p_offset = 1 + p_dim1;
    p -= p_offset;
    vl_dim1 = *ldvl;
    vl_offset = 1 + vl_dim1;
    vl -= vl_offset;
    vr_dim1 = *ldvr;
    vr_offset = 1 + vr_dim1;
    vr -= vr_offset;
    --work;
    --rwork;

    /* Function Body */
    if (lsame_(howmny, "A")) {
        ihwmny = 1;
        ilall = TRUE_;
        ilback = FALSE_;
    } else if (lsame_(howmny, "S")) {
        ihwmny = 2;
        ilall = FALSE_;
        ilback = FALSE_;
    } else if (lsame_(howmny, "B")) {
        ihwmny = 3;
        ilall = TRUE_;
        ilback = TRUE_;
    } else {
        ihwmny = -1;
    }

    if (lsame_(side, "R")) {
        iside = 1;
        compl = FALSE_;
        compr = TRUE_;
    } else if (lsame_(side, "L")) {
        iside = 2;
        compl = TRUE_;
        compr = FALSE_;
    } else if (lsame_(side, "B")) {
        iside = 3;
        compl = TRUE_;
        compr = TRUE_;
    } else {
        iside = -1;
    }

    *info = 0;
    if (iside < 0) {
        *info = -1;
    } else if (ihwmny < 0) {
        *info = -2;
    } else if (*n < 0) {
        *info = -4;
    } else if (*lds < max(1,*n)) {
        *info = -6;
    } else if (*ldp < max(1,*n)) {
        *info = -8;
    }
    if (*info != 0) {
        i__1 = -(*info);
        xerbla_("ZTGEVC", &i__1);
        return 0;
    }

    /*     Count the number of eigenvectors */

    if (! ilall) {
        im = 0;
        i__1 = *n;
        for (j = 1; j <= i__1; ++j) {
            if (select[j]) {
                ++im;
            }
        }
    } else {
        im = *n;
    }

    /*     Check diagonal of B */

    ilbbad = FALSE_;
    i__1 = *n;
    for (j = 1; j <= i__1; ++j) {
        if (d_imag(&p[j + j * p_dim1]) != 0.) {
            ilbbad = TRUE_;
        }
    }

    if (ilbbad) {
        *info = -7;
    } else if (compl && *ldvl < *n || *ldvl < 1) {
        *info = -10;
    } else if (compr && *ldvr < *n || *ldvr < 1) {
        *info = -12;
    } else if (*mm < im) {
        *info = -13;
    }
    if (*info != 0) {
        i__1 = -(*info);
        xerbla_("ZTGEVC", &i__1);
        return 0;
    }

    /*     Quick return if possible */

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

    /*     Machine Constants */

    safmin = dlamch_("Safe minimum");
    big = 1. / safmin;
    dlabad_(&safmin, &big);
    ulp = dlamch_("Epsilon") * dlamch_("Base");
    small = safmin * *n / ulp;
    big = 1. / small;
    bignum = 1. / (safmin * *n);

    /*     Compute the 1-norm of each column of the strictly upper triangular */
    /*     part of A and B to check for possible overflow in the triangular */
    /*     solver. */

    i__1 = s_dim1 + 1;
    anorm = (d__1 = s[i__1].r, abs(d__1)) + (d__2 = d_imag(&s[s_dim1 + 1]),
            abs(d__2));
    i__1 = p_dim1 + 1;
    bnorm = (d__1 = p[i__1].r, abs(d__1)) + (d__2 = d_imag(&p[p_dim1 + 1]),
            abs(d__2));
    rwork[1] = 0.;
    rwork[*n + 1] = 0.;
    i__1 = *n;
    for (j = 2; j <= i__1; ++j) {
        rwork[j] = 0.;
        rwork[*n + j] = 0.;
        i__2 = j - 1;
        for (i__ = 1; i__ <= i__2; ++i__) {
            i__3 = i__ + j * s_dim1;
            rwork[j] += (d__1 = s[i__3].r, abs(d__1)) + (d__2 = d_imag(&s[i__
                        + j * s_dim1]), abs(d__2));
            i__3 = i__ + j * p_dim1;
            rwork[*n + j] += (d__1 = p[i__3].r, abs(d__1)) + (d__2 = d_imag(&
                             p[i__ + j * p_dim1]), abs(d__2));
        }
        /* Computing MAX */
        i__2 = j + j * s_dim1;
        d__3 = anorm, d__4 = rwork[j] + ((d__1 = s[i__2].r, abs(d__1)) + (
                                             d__2 = d_imag(&s[j + j * s_dim1]), abs(d__2)));
        anorm = max(d__3,d__4);
        /* Computing MAX */
        i__2 = j + j * p_dim1;
        d__3 = bnorm, d__4 = rwork[*n + j] + ((d__1 = p[i__2].r, abs(d__1)) +
                                              (d__2 = d_imag(&p[j + j * p_dim1]), abs(d__2)));
        bnorm = max(d__3,d__4);
    }

    ascale = 1. / max(anorm,safmin);
    bscale = 1. / max(bnorm,safmin);

    /*     Left eigenvectors */

    if (compl) {
        ieig = 0;

        /*        Main loop over eigenvalues */

        i__1 = *n;
        for (je = 1; je <= i__1; ++je) {
            if (ilall) {
                ilcomp = TRUE_;
            } else {
                ilcomp = select[je];
            }
            if (ilcomp) {
                ++ieig;

                i__2 = je + je * s_dim1;
                i__3 = je + je * p_dim1;
                if ((d__2 = s[i__2].r, abs(d__2)) + (d__3 = d_imag(&s[je + je
                                                     * s_dim1]), abs(d__3)) <= safmin && (d__1 = p[i__3].r,
                                                             abs(d__1)) <= safmin) {

                    /*                 Singular matrix pencil -- return unit eigenvector */

                    i__2 = *n;
                    for (jr = 1; jr <= i__2; ++jr) {
                        i__3 = jr + ieig * vl_dim1;
                        vl[i__3].r = 0., vl[i__3].i = 0.;
                    }
                    i__2 = ieig + ieig * vl_dim1;
                    vl[i__2].r = 1., vl[i__2].i = 0.;
                    goto L140;
                }

                /*              Non-singular eigenvalue: */
                /*              Compute coefficients  a  and  b  in */
                /*                   H */
                /*                 y  ( a A - b B ) = 0 */

                /* Computing MAX */
                i__2 = je + je * s_dim1;
                i__3 = je + je * p_dim1;
                d__4 = ((d__2 = s[i__2].r, abs(d__2)) + (d__3 = d_imag(&s[je
                        + je * s_dim1]), abs(d__3))) * ascale, d__5 = (d__1 =
                                    p[i__3].r, abs(d__1)) * bscale, d__4 = max(d__4,d__5);
                temp = 1. / max(d__4,safmin);
                i__2 = je + je * s_dim1;
                z__2.r = temp * s[i__2].r, z__2.i = temp * s[i__2].i;
                z__1.r = ascale * z__2.r, z__1.i = ascale * z__2.i;
                salpha.r = z__1.r, salpha.i = z__1.i;
                i__2 = je + je * p_dim1;
                sbeta = temp * p[i__2].r * bscale;
                acoeff = sbeta * ascale;
                z__1.r = bscale * salpha.r, z__1.i = bscale * salpha.i;
                bcoeff.r = z__1.r, bcoeff.i = z__1.i;

                /*              Scale to avoid underflow */

                lsa = abs(sbeta) >= safmin && abs(acoeff) < small;
                lsb = (d__1 = salpha.r, abs(d__1)) + (d__2 = d_imag(&salpha),
                                                      abs(d__2)) >= safmin && (d__3 = bcoeff.r, abs(d__3))
                      + (d__4 = d_imag(&bcoeff), abs(d__4)) < small;

                scale = 1.;
                if (lsa) {
                    scale = small / abs(sbeta) * min(anorm,big);
                }
                if (lsb) {
                    /* Computing MAX */
                    d__3 = scale, d__4 = small / ((d__1 = salpha.r, abs(d__1))
                                                  + (d__2 = d_imag(&salpha), abs(d__2))) * min(
                                             bnorm,big);
                    scale = max(d__3,d__4);
                }
                if (lsa || lsb) {
                    /* Computing MIN */
                    /* Computing MAX */
                    d__5 = 1., d__6 = abs(acoeff), d__5 = max(d__5,d__6),
                    d__6 = (d__1 = bcoeff.r, abs(d__1)) + (d__2 =
                            d_imag(&bcoeff), abs(d__2));
                    d__3 = scale, d__4 = 1. / (safmin * max(d__5,d__6));
                    scale = min(d__3,d__4);
                    if (lsa) {
                        acoeff = ascale * (scale * sbeta);
                    } else {
                        acoeff = scale * acoeff;
                    }
                    if (lsb) {
                        z__2.r = scale * salpha.r, z__2.i = scale * salpha.i;
                        z__1.r = bscale * z__2.r, z__1.i = bscale * z__2.i;
                        bcoeff.r = z__1.r, bcoeff.i = z__1.i;
                    } else {
                        z__1.r = scale * bcoeff.r, z__1.i = scale * bcoeff.i;
                        bcoeff.r = z__1.r, bcoeff.i = z__1.i;
                    }
                }

                acoefa = abs(acoeff);
                bcoefa = (d__1 = bcoeff.r, abs(d__1)) + (d__2 = d_imag(&
                         bcoeff), abs(d__2));
                xmax = 1.;
                i__2 = *n;
                for (jr = 1; jr <= i__2; ++jr) {
                    i__3 = jr;
                    work[i__3].r = 0., work[i__3].i = 0.;
                }
                i__2 = je;
                work[i__2].r = 1., work[i__2].i = 0.;
                /* Computing MAX */
                d__1 = ulp * acoefa * anorm, d__2 = ulp * bcoefa * bnorm,
                d__1 = max(d__1,d__2);
                dmin__ = max(d__1,safmin);

                /*                                              H */
                /*              Triangular solve of  (a A - b B)  y = 0 */

                /*                                      H */
                /*              (rowwise in  (a A - b B) , or columnwise in a A - b B) */

                i__2 = *n;
                for (j = je + 1; j <= i__2; ++j) {

                    /*                 Compute */
                    /*                       j-1 */
                    /*                 SUM = sum  conjg( a*S(k,j) - b*P(k,j) )*x(k) */
                    /*                       k=je */
                    /*                 (Scale if necessary) */

                    temp = 1. / xmax;
                    if (acoefa * rwork[j] + bcoefa * rwork[*n + j] > bignum *
                            temp) {
                        i__3 = j - 1;
                        for (jr = je; jr <= i__3; ++jr) {
                            i__4 = jr;
                            i__5 = jr;
                            z__1.r = temp * work[i__5].r, z__1.i = temp *
                                                                   work[i__5].i;
                            work[i__4].r = z__1.r, work[i__4].i = z__1.i;
                        }
                        xmax = 1.;
                    }
                    suma.r = 0., suma.i = 0.;
                    sumb.r = 0., sumb.i = 0.;

                    i__3 = j - 1;
                    for (jr = je; jr <= i__3; ++jr) {
                        d_cnjg(&z__3, &s[jr + j * s_dim1]);
                        i__4 = jr;
                        z__2.r = z__3.r * work[i__4].r - z__3.i * work[i__4]
                                 .i, z__2.i = z__3.r * work[i__4].i + z__3.i *
                                              work[i__4].r;
                        z__1.r = suma.r + z__2.r, z__1.i = suma.i + z__2.i;
                        suma.r = z__1.r, suma.i = z__1.i;
                        d_cnjg(&z__3, &p[jr + j * p_dim1]);
                        i__4 = jr;
                        z__2.r = z__3.r * work[i__4].r - z__3.i * work[i__4]
                                 .i, z__2.i = z__3.r * work[i__4].i + z__3.i *
                                              work[i__4].r;
                        z__1.r = sumb.r + z__2.r, z__1.i = sumb.i + z__2.i;
                        sumb.r = z__1.r, sumb.i = z__1.i;
                    }
                    z__2.r = acoeff * suma.r, z__2.i = acoeff * suma.i;
                    d_cnjg(&z__4, &bcoeff);
                    z__3.r = z__4.r * sumb.r - z__4.i * sumb.i, z__3.i =
                                 z__4.r * sumb.i + z__4.i * sumb.r;
                    z__1.r = z__2.r - z__3.r, z__1.i = z__2.i - z__3.i;
                    sum.r = z__1.r, sum.i = z__1.i;

                    /*                 Form x(j) = - SUM / conjg( a*S(j,j) - b*P(j,j) ) */

                    /*                 with scaling and perturbation of the denominator */

                    i__3 = j + j * s_dim1;
                    z__3.r = acoeff * s[i__3].r, z__3.i = acoeff * s[i__3].i;
                    i__4 = j + j * p_dim1;
                    z__4.r = bcoeff.r * p[i__4].r - bcoeff.i * p[i__4].i,
                         z__4.i = bcoeff.r * p[i__4].i + bcoeff.i * p[i__4]
                                  .r;
                    z__2.r = z__3.r - z__4.r, z__2.i = z__3.i - z__4.i;
                    d_cnjg(&z__1, &z__2);
                    d__.r = z__1.r, d__.i = z__1.i;
                    if ((d__1 = d__.r, abs(d__1)) + (d__2 = d_imag(&d__), abs(
                                                         d__2)) <= dmin__) {
                        z__1.r = dmin__, z__1.i = 0.;
                        d__.r = z__1.r, d__.i = z__1.i;
                    }

                    if ((d__1 = d__.r, abs(d__1)) + (d__2 = d_imag(&d__), abs(
                                                         d__2)) < 1.) {
                        if ((d__1 = sum.r, abs(d__1)) + (d__2 = d_imag(&sum),
                                                         abs(d__2)) >= bignum * ((d__3 = d__.r, abs(
                                                                 d__3)) + (d__4 = d_imag(&d__), abs(d__4)))) {
                            temp = 1. / ((d__1 = sum.r, abs(d__1)) + (d__2 =
                                             d_imag(&sum), abs(d__2)));
                            i__3 = j - 1;
                            for (jr = je; jr <= i__3; ++jr) {
                                i__4 = jr;
                                i__5 = jr;
                                z__1.r = temp * work[i__5].r, z__1.i = temp *
                                                                       work[i__5].i;
                                work[i__4].r = z__1.r, work[i__4].i = z__1.i;
                            }
                            xmax = temp * xmax;
                            z__1.r = temp * sum.r, z__1.i = temp * sum.i;
                            sum.r = z__1.r, sum.i = z__1.i;
                        }
                    }
                    i__3 = j;
                    z__2.r = -sum.r, z__2.i = -sum.i;
                    zladiv_(&z__1, &z__2, &d__);
                    work[i__3].r = z__1.r, work[i__3].i = z__1.i;
                    /* Computing MAX */
                    i__3 = j;
                    d__3 = xmax, d__4 = (d__1 = work[i__3].r, abs(d__1)) + (
                                            d__2 = d_imag(&work[j]), abs(d__2));
                    xmax = max(d__3,d__4);
                }

                /*              Back transform eigenvector if HOWMNY='B'. */

                if (ilback) {
                    i__2 = *n + 1 - je;
                    zgemv_("N", n, &i__2, &c_b2, &vl[je * vl_dim1 + 1], ldvl,
                           &work[je], &c__1, &c_b1, &work[*n + 1], &c__1);
                    isrc = 2;
                    ibeg = 1;
                } else {
                    isrc = 1;
                    ibeg = je;
                }

                /*              Copy and scale eigenvector into column of VL */

                xmax = 0.;
                i__2 = *n;
                for (jr = ibeg; jr <= i__2; ++jr) {
                    /* Computing MAX */
                    i__3 = (isrc - 1) * *n + jr;
                    d__3 = xmax, d__4 = (d__1 = work[i__3].r, abs(d__1)) + (
                                            d__2 = d_imag(&work[(isrc - 1) * *n + jr]), abs(
                                                d__2));
                    xmax = max(d__3,d__4);
                }

                if (xmax > safmin) {
                    temp = 1. / xmax;
                    i__2 = *n;
                    for (jr = ibeg; jr <= i__2; ++jr) {
                        i__3 = jr + ieig * vl_dim1;
                        i__4 = (isrc - 1) * *n + jr;
                        z__1.r = temp * work[i__4].r, z__1.i = temp * work[
                                i__4].i;
                        vl[i__3].r = z__1.r, vl[i__3].i = z__1.i;
                    }
                } else {
                    ibeg = *n + 1;
                }

                i__2 = ibeg - 1;
                for (jr = 1; jr <= i__2; ++jr) {
                    i__3 = jr + ieig * vl_dim1;
                    vl[i__3].r = 0., vl[i__3].i = 0.;
                }

            }
L140:
            ;
        }
    }

    /*     Right eigenvectors */

    if (compr) {
        ieig = im + 1;

        /*        Main loop over eigenvalues */

        for (je = *n; je >= 1; --je) {
            if (ilall) {
                ilcomp = TRUE_;
            } else {
                ilcomp = select[je];
            }
            if (ilcomp) {
                --ieig;

                i__1 = je + je * s_dim1;
                i__2 = je + je * p_dim1;
                if ((d__2 = s[i__1].r, abs(d__2)) + (d__3 = d_imag(&s[je + je
                                                     * s_dim1]), abs(d__3)) <= safmin && (d__1 = p[i__2].r,
                                                             abs(d__1)) <= safmin) {

                    /*                 Singular matrix pencil -- return unit eigenvector */

                    i__1 = *n;
                    for (jr = 1; jr <= i__1; ++jr) {
                        i__2 = jr + ieig * vr_dim1;
                        vr[i__2].r = 0., vr[i__2].i = 0.;
                    }
                    i__1 = ieig + ieig * vr_dim1;
                    vr[i__1].r = 1., vr[i__1].i = 0.;
                    goto L250;
                }

                /*              Non-singular eigenvalue: */
                /*              Compute coefficients  a  and  b  in */

                /*              ( a A - b B ) x  = 0 */

                /* Computing MAX */
                i__1 = je + je * s_dim1;
                i__2 = je + je * p_dim1;
                d__4 = ((d__2 = s[i__1].r, abs(d__2)) + (d__3 = d_imag(&s[je
                        + je * s_dim1]), abs(d__3))) * ascale, d__5 = (d__1 =
                                    p[i__2].r, abs(d__1)) * bscale, d__4 = max(d__4,d__5);
                temp = 1. / max(d__4,safmin);
                i__1 = je + je * s_dim1;
                z__2.r = temp * s[i__1].r, z__2.i = temp * s[i__1].i;
                z__1.r = ascale * z__2.r, z__1.i = ascale * z__2.i;
                salpha.r = z__1.r, salpha.i = z__1.i;
                i__1 = je + je * p_dim1;
                sbeta = temp * p[i__1].r * bscale;
                acoeff = sbeta * ascale;
                z__1.r = bscale * salpha.r, z__1.i = bscale * salpha.i;
                bcoeff.r = z__1.r, bcoeff.i = z__1.i;

                /*              Scale to avoid underflow */

                lsa = abs(sbeta) >= safmin && abs(acoeff) < small;
                lsb = (d__1 = salpha.r, abs(d__1)) + (d__2 = d_imag(&salpha),
                                                      abs(d__2)) >= safmin && (d__3 = bcoeff.r, abs(d__3))
                      + (d__4 = d_imag(&bcoeff), abs(d__4)) < small;

                scale = 1.;
                if (lsa) {
                    scale = small / abs(sbeta) * min(anorm,big);
                }
                if (lsb) {
                    /* Computing MAX */
                    d__3 = scale, d__4 = small / ((d__1 = salpha.r, abs(d__1))
                                                  + (d__2 = d_imag(&salpha), abs(d__2))) * min(
                                             bnorm,big);
                    scale = max(d__3,d__4);
                }
                if (lsa || lsb) {
                    /* Computing MIN */
                    /* Computing MAX */
                    d__5 = 1., d__6 = abs(acoeff), d__5 = max(d__5,d__6),
                    d__6 = (d__1 = bcoeff.r, abs(d__1)) + (d__2 =
                            d_imag(&bcoeff), abs(d__2));
                    d__3 = scale, d__4 = 1. / (safmin * max(d__5,d__6));
                    scale = min(d__3,d__4);
                    if (lsa) {
                        acoeff = ascale * (scale * sbeta);
                    } else {
                        acoeff = scale * acoeff;
                    }
                    if (lsb) {
                        z__2.r = scale * salpha.r, z__2.i = scale * salpha.i;
                        z__1.r = bscale * z__2.r, z__1.i = bscale * z__2.i;
                        bcoeff.r = z__1.r, bcoeff.i = z__1.i;
                    } else {
                        z__1.r = scale * bcoeff.r, z__1.i = scale * bcoeff.i;
                        bcoeff.r = z__1.r, bcoeff.i = z__1.i;
                    }
                }

                acoefa = abs(acoeff);
                bcoefa = (d__1 = bcoeff.r, abs(d__1)) + (d__2 = d_imag(&
                         bcoeff), abs(d__2));
                xmax = 1.;
                i__1 = *n;
                for (jr = 1; jr <= i__1; ++jr) {
                    i__2 = jr;
                    work[i__2].r = 0., work[i__2].i = 0.;
                }
                i__1 = je;
                work[i__1].r = 1., work[i__1].i = 0.;
                /* Computing MAX */
                d__1 = ulp * acoefa * anorm, d__2 = ulp * bcoefa * bnorm,
                d__1 = max(d__1,d__2);
                dmin__ = max(d__1,safmin);

                /*              Triangular solve of  (a A - b B) x = 0  (columnwise) */

                /*              WORK(1:j-1) contains sums w, */
                /*              WORK(j+1:JE) contains x */

                i__1 = je - 1;
                for (jr = 1; jr <= i__1; ++jr) {
                    i__2 = jr;
                    i__3 = jr + je * s_dim1;
                    z__2.r = acoeff * s[i__3].r, z__2.i = acoeff * s[i__3].i;
                    i__4 = jr + je * p_dim1;
                    z__3.r = bcoeff.r * p[i__4].r - bcoeff.i * p[i__4].i,
                         z__3.i = bcoeff.r * p[i__4].i + bcoeff.i * p[i__4]
                                  .r;
                    z__1.r = z__2.r - z__3.r, z__1.i = z__2.i - z__3.i;
                    work[i__2].r = z__1.r, work[i__2].i = z__1.i;
                }
                i__1 = je;
                work[i__1].r = 1., work[i__1].i = 0.;

                for (j = je - 1; j >= 1; --j) {

                    /*                 Form x(j) := - w(j) / d */
                    /*                 with scaling and perturbation of the denominator */

                    i__1 = j + j * s_dim1;
                    z__2.r = acoeff * s[i__1].r, z__2.i = acoeff * s[i__1].i;
                    i__2 = j + j * p_dim1;
                    z__3.r = bcoeff.r * p[i__2].r - bcoeff.i * p[i__2].i,
                         z__3.i = bcoeff.r * p[i__2].i + bcoeff.i * p[i__2]
                                  .r;
                    z__1.r = z__2.r - z__3.r, z__1.i = z__2.i - z__3.i;
                    d__.r = z__1.r, d__.i = z__1.i;
                    if ((d__1 = d__.r, abs(d__1)) + (d__2 = d_imag(&d__), abs(
                                                         d__2)) <= dmin__) {
                        z__1.r = dmin__, z__1.i = 0.;
                        d__.r = z__1.r, d__.i = z__1.i;
                    }

                    if ((d__1 = d__.r, abs(d__1)) + (d__2 = d_imag(&d__), abs(
                                                         d__2)) < 1.) {
                        i__1 = j;
                        if ((d__1 = work[i__1].r, abs(d__1)) + (d__2 = d_imag(
                                &work[j]), abs(d__2)) >= bignum * ((d__3 =
                                            d__.r, abs(d__3)) + (d__4 = d_imag(&d__), abs(
                                                        d__4)))) {
                            i__1 = j;
                            temp = 1. / ((d__1 = work[i__1].r, abs(d__1)) + (
                                             d__2 = d_imag(&work[j]), abs(d__2)));
                            i__1 = je;
                            for (jr = 1; jr <= i__1; ++jr) {
                                i__2 = jr;
                                i__3 = jr;
                                z__1.r = temp * work[i__3].r, z__1.i = temp *
                                                                       work[i__3].i;
                                work[i__2].r = z__1.r, work[i__2].i = z__1.i;
                            }
                        }
                    }

                    i__1 = j;
                    i__2 = j;
                    z__2.r = -work[i__2].r, z__2.i = -work[i__2].i;
                    zladiv_(&z__1, &z__2, &d__);
                    work[i__1].r = z__1.r, work[i__1].i = z__1.i;

                    if (j > 1) {

                        /*                    w = w + x(j)*(a S(*,j) - b P(*,j) ) with scaling */

                        i__1 = j;
                        if ((d__1 = work[i__1].r, abs(d__1)) + (d__2 = d_imag(
                                &work[j]), abs(d__2)) > 1.) {
                            i__1 = j;
                            temp = 1. / ((d__1 = work[i__1].r, abs(d__1)) + (
                                             d__2 = d_imag(&work[j]), abs(d__2)));
                            if (acoefa * rwork[j] + bcoefa * rwork[*n + j] >=
                                    bignum * temp) {
                                i__1 = je;
                                for (jr = 1; jr <= i__1; ++jr) {
                                    i__2 = jr;
                                    i__3 = jr;
                                    z__1.r = temp * work[i__3].r, z__1.i =
                                                 temp * work[i__3].i;
                                    work[i__2].r = z__1.r, work[i__2].i =
                                                       z__1.i;
                                }
                            }
                        }

                        i__1 = j;
                        z__1.r = acoeff * work[i__1].r, z__1.i = acoeff *
                                 work[i__1].i;
                        ca.r = z__1.r, ca.i = z__1.i;
                        i__1 = j;
                        z__1.r = bcoeff.r * work[i__1].r - bcoeff.i * work[
                                     i__1].i, z__1.i = bcoeff.r * work[i__1].i +
                                                       bcoeff.i * work[i__1].r;
                        cb.r = z__1.r, cb.i = z__1.i;
                        i__1 = j - 1;
                        for (jr = 1; jr <= i__1; ++jr) {
                            i__2 = jr;
                            i__3 = jr;
                            i__4 = jr + j * s_dim1;
                            z__3.r = ca.r * s[i__4].r - ca.i * s[i__4].i,
                                 z__3.i = ca.r * s[i__4].i + ca.i * s[i__4]
                                          .r;
                            z__2.r = work[i__3].r + z__3.r, z__2.i = work[
                                         i__3].i + z__3.i;
                            i__5 = jr + j * p_dim1;
                            z__4.r = cb.r * p[i__5].r - cb.i * p[i__5].i,
                                 z__4.i = cb.r * p[i__5].i + cb.i * p[i__5]
                                          .r;
                            z__1.r = z__2.r - z__4.r, z__1.i = z__2.i -
                                                               z__4.i;
                            work[i__2].r = z__1.r, work[i__2].i = z__1.i;
                        }
                    }
                }

                /*              Back transform eigenvector if HOWMNY='B'. */

                if (ilback) {
                    zgemv_("N", n, &je, &c_b2, &vr[vr_offset], ldvr, &work[1],
                           &c__1, &c_b1, &work[*n + 1], &c__1);
                    isrc = 2;
                    iend = *n;
                } else {
                    isrc = 1;
                    iend = je;
                }

                /*              Copy and scale eigenvector into column of VR */

                xmax = 0.;
                i__1 = iend;
                for (jr = 1; jr <= i__1; ++jr) {
                    /* Computing MAX */
                    i__2 = (isrc - 1) * *n + jr;
                    d__3 = xmax, d__4 = (d__1 = work[i__2].r, abs(d__1)) + (
                                            d__2 = d_imag(&work[(isrc - 1) * *n + jr]), abs(
                                                d__2));
                    xmax = max(d__3,d__4);
                }

                if (xmax > safmin) {
                    temp = 1. / xmax;
                    i__1 = iend;
                    for (jr = 1; jr <= i__1; ++jr) {
                        i__2 = jr + ieig * vr_dim1;
                        i__3 = (isrc - 1) * *n + jr;
                        z__1.r = temp * work[i__3].r, z__1.i = temp * work[
                                i__3].i;
                        vr[i__2].r = z__1.r, vr[i__2].i = z__1.i;
                    }
                } else {
                    iend = 0;
                }

                i__1 = *n;
                for (jr = iend + 1; jr <= i__1; ++jr) {
                    i__2 = jr + ieig * vr_dim1;
                    vr[i__2].r = 0., vr[i__2].i = 0.;
                }

            }
L250:
            ;
        }
    }

    return 0;

    /*     End of ZTGEVC */

} /* ztgevc_ */
示例#9
0
/* Subroutine */ int dchkbd_(integer *nsizes, integer *mval, integer *nval, 
	integer *ntypes, logical *dotype, integer *nrhs, integer *iseed, 
	doublereal *thresh, doublereal *a, integer *lda, doublereal *bd, 
	doublereal *be, doublereal *s1, doublereal *s2, doublereal *x, 
	integer *ldx, doublereal *y, doublereal *z__, doublereal *q, integer *
	ldq, doublereal *pt, integer *ldpt, doublereal *u, doublereal *vt, 
	doublereal *work, integer *lwork, integer *iwork, integer *nout, 
	integer *info)
{
    /* Initialized data */

    static integer ktype[16] = { 1,2,4,4,4,4,4,6,6,6,6,6,9,9,9,10 };
    static integer kmagn[16] = { 1,1,1,1,1,2,3,1,1,1,2,3,1,2,3,0 };
    static integer kmode[16] = { 0,0,4,3,1,4,4,4,3,1,4,4,0,0,0,0 };

    /* Format strings */
    static char fmt_9998[] = "(\002 DCHKBD: \002,a,\002 returned INFO=\002,i"
	    "6,\002.\002,/9x,\002M=\002,i6,\002, N=\002,i6,\002, JTYPE=\002,i"
	    "6,\002, ISEED=(\002,3(i5,\002,\002),i5,\002)\002)";
    static char fmt_9999[] = "(\002 M=\002,i5,\002, N=\002,i5,\002, type "
	    "\002,i2,\002, seed=\002,4(i4,\002,\002),\002 test(\002,i2,\002)"
	    "=\002,g11.4)";

    /* System generated locals */
    integer a_dim1, a_offset, pt_dim1, pt_offset, q_dim1, q_offset, u_dim1, 
	    u_offset, vt_dim1, vt_offset, x_dim1, x_offset, y_dim1, y_offset, 
	    z_dim1, z_offset, i__1, i__2, i__3, i__4, i__5, i__6, i__7;
    doublereal d__1, d__2, d__3, d__4, d__5, d__6, d__7;

    /* Builtin functions */
    /* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);
    double log(doublereal), sqrt(doublereal), exp(doublereal);
    integer s_wsfe(cilist *), do_fio(integer *, char *, ftnlen), e_wsfe(void);

    /* Local variables */
    integer i__, j, m, n, mq;
    doublereal dum[1], ulp, cond;
    integer jcol;
    char path[3];
    integer idum[1], mmax, nmax;
    doublereal unfl, ovfl;
    char uplo[1];
    doublereal temp1, temp2;
    extern /* Subroutine */ int dbdt01_(integer *, integer *, integer *, 
	    doublereal *, integer *, doublereal *, integer *, doublereal *, 
	    doublereal *, doublereal *, integer *, doublereal *, doublereal *)
	    , dbdt02_(integer *, integer *, doublereal *, integer *, 
	    doublereal *, integer *, doublereal *, integer *, doublereal *, 
	    doublereal *);
    logical badmm;
    extern /* Subroutine */ int dbdt03_(char *, integer *, integer *, 
	    doublereal *, doublereal *, doublereal *, integer *, doublereal *, 
	     doublereal *, integer *, doublereal *, doublereal *);
    logical badnn;
    integer nfail;
    extern /* Subroutine */ int dgemm_(char *, char *, integer *, integer *, 
	    integer *, doublereal *, doublereal *, integer *, doublereal *, 
	    integer *, doublereal *, doublereal *, integer *);
    integer imode;
    doublereal dumma[1];
    integer iinfo;
    extern /* Subroutine */ int dort01_(char *, integer *, integer *, 
	    doublereal *, integer *, doublereal *, integer *, doublereal *);
    doublereal anorm;
    integer mnmin;
    extern /* Subroutine */ int dcopy_(integer *, doublereal *, integer *, 
	    doublereal *, integer *);
    integer mnmax, jsize, itype, jtype, ntest;
    extern /* Subroutine */ int dlahd2_(integer *, char *);
    integer log2ui;
    extern /* Subroutine */ int dlabad_(doublereal *, doublereal *);
    logical bidiag;
    extern /* Subroutine */ int dbdsdc_(char *, char *, integer *, doublereal 
	    *, doublereal *, doublereal *, integer *, doublereal *, integer *, 
	     doublereal *, integer *, doublereal *, integer *, integer *), dgebrd_(integer *, integer *, doublereal *, 
	    integer *, doublereal *, doublereal *, doublereal *, doublereal *, 
	     doublereal *, integer *, integer *);
    extern doublereal dlamch_(char *), dlarnd_(integer *, integer *);
    extern /* Subroutine */ int dlacpy_(char *, integer *, integer *, 
	    doublereal *, integer *, doublereal *, integer *), 
	    dlaset_(char *, integer *, integer *, doublereal *, doublereal *, 
	    doublereal *, integer *);
    integer ioldsd[4];
    extern /* Subroutine */ int dbdsqr_(char *, integer *, integer *, integer 
	    *, integer *, doublereal *, doublereal *, doublereal *, integer *, 
	     doublereal *, integer *, doublereal *, integer *, doublereal *, 
	    integer *), dorgbr_(char *, integer *, integer *, integer 
	    *, doublereal *, integer *, doublereal *, doublereal *, integer *, 
	     integer *), xerbla_(char *, integer *), alasum_(
	    char *, integer *, integer *, integer *, integer *), 
	    dlatmr_(integer *, integer *, char *, integer *, char *, 
	    doublereal *, integer *, doublereal *, doublereal *, char *, char 
	    *, doublereal *, integer *, doublereal *, doublereal *, integer *, 
	     doublereal *, char *, integer *, integer *, integer *, 
	    doublereal *, doublereal *, char *, doublereal *, integer *, 
	    integer *, integer *), dlatms_(integer *, integer *, char *, integer *, char *, 
	    doublereal *, integer *, doublereal *, doublereal *, integer *, 
	    integer *, char *, doublereal *, integer *, doublereal *, integer 
	    *);
    doublereal amninv;
    integer minwrk;
    doublereal rtunfl, rtovfl, ulpinv, result[19];
    integer mtypes;

    /* Fortran I/O blocks */
    static cilist io___39 = { 0, 0, 0, fmt_9998, 0 };
    static cilist io___40 = { 0, 0, 0, fmt_9998, 0 };
    static cilist io___42 = { 0, 0, 0, fmt_9998, 0 };
    static cilist io___43 = { 0, 0, 0, fmt_9998, 0 };
    static cilist io___44 = { 0, 0, 0, fmt_9998, 0 };
    static cilist io___45 = { 0, 0, 0, fmt_9998, 0 };
    static cilist io___51 = { 0, 0, 0, fmt_9998, 0 };
    static cilist io___52 = { 0, 0, 0, fmt_9998, 0 };
    static cilist io___53 = { 0, 0, 0, fmt_9999, 0 };



/*  -- LAPACK test routine (version 3.1) -- */
/*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/*     November 2006 */

/*     .. Scalar Arguments .. */
/*     .. */
/*     .. Array Arguments .. */
/*     .. */

/*  Purpose */
/*  ======= */

/*  DCHKBD checks the singular value decomposition (SVD) routines. */

/*  DGEBRD reduces a real general m by n matrix A to upper or lower */
/*  bidiagonal form B by an orthogonal transformation:  Q' * A * P = B */
/*  (or A = Q * B * P').  The matrix B is upper bidiagonal if m >= n */
/*  and lower bidiagonal if m < n. */

/*  DORGBR generates the orthogonal matrices Q and P' from DGEBRD. */
/*  Note that Q and P are not necessarily square. */

/*  DBDSQR computes the singular value decomposition of the bidiagonal */
/*  matrix B as B = U S V'.  It is called three times to compute */
/*     1)  B = U S1 V', where S1 is the diagonal matrix of singular */
/*         values and the columns of the matrices U and V are the left */
/*         and right singular vectors, respectively, of B. */
/*     2)  Same as 1), but the singular values are stored in S2 and the */
/*         singular vectors are not computed. */
/*     3)  A = (UQ) S (P'V'), the SVD of the original matrix A. */
/*  In addition, DBDSQR has an option to apply the left orthogonal matrix */
/*  U to a matrix X, useful in least squares applications. */

/*  DBDSDC computes the singular value decomposition of the bidiagonal */
/*  matrix B as B = U S V' using divide-and-conquer. It is called twice */
/*  to compute */
/*     1) B = U S1 V', where S1 is the diagonal matrix of singular */
/*         values and the columns of the matrices U and V are the left */
/*         and right singular vectors, respectively, of B. */
/*     2) Same as 1), but the singular values are stored in S2 and the */
/*         singular vectors are not computed. */

/*  For each pair of matrix dimensions (M,N) and each selected matrix */
/*  type, an M by N matrix A and an M by NRHS matrix X are generated. */
/*  The problem dimensions are as follows */
/*     A:          M x N */
/*     Q:          M x min(M,N) (but M x M if NRHS > 0) */
/*     P:          min(M,N) x N */
/*     B:          min(M,N) x min(M,N) */
/*     U, V:       min(M,N) x min(M,N) */
/*     S1, S2      diagonal, order min(M,N) */
/*     X:          M x NRHS */

/*  For each generated matrix, 14 tests are performed: */

/*  Test DGEBRD and DORGBR */

/*  (1)   | A - Q B PT | / ( |A| max(M,N) ulp ), PT = P' */

/*  (2)   | I - Q' Q | / ( M ulp ) */

/*  (3)   | I - PT PT' | / ( N ulp ) */

/*  Test DBDSQR on bidiagonal matrix B */

/*  (4)   | B - U S1 VT | / ( |B| min(M,N) ulp ), VT = V' */

/*  (5)   | Y - U Z | / ( |Y| max(min(M,N),k) ulp ), where Y = Q' X */
/*                                                   and   Z = U' Y. */
/*  (6)   | I - U' U | / ( min(M,N) ulp ) */

/*  (7)   | I - VT VT' | / ( min(M,N) ulp ) */

/*  (8)   S1 contains min(M,N) nonnegative values in decreasing order. */
/*        (Return 0 if true, 1/ULP if false.) */

/*  (9)   | S1 - S2 | / ( |S1| ulp ), where S2 is computed without */
/*                                    computing U and V. */

/*  (10)  0 if the true singular values of B are within THRESH of */
/*        those in S1.  2*THRESH if they are not.  (Tested using */
/*        DSVDCH) */

/*  Test DBDSQR on matrix A */

/*  (11)  | A - (QU) S (VT PT) | / ( |A| max(M,N) ulp ) */

/*  (12)  | X - (QU) Z | / ( |X| max(M,k) ulp ) */

/*  (13)  | I - (QU)'(QU) | / ( M ulp ) */

/*  (14)  | I - (VT PT) (PT'VT') | / ( N ulp ) */

/*  Test DBDSDC on bidiagonal matrix B */

/*  (15)  | B - U S1 VT | / ( |B| min(M,N) ulp ), VT = V' */

/*  (16)  | I - U' U | / ( min(M,N) ulp ) */

/*  (17)  | I - VT VT' | / ( min(M,N) ulp ) */

/*  (18)  S1 contains min(M,N) nonnegative values in decreasing order. */
/*        (Return 0 if true, 1/ULP if false.) */

/*  (19)  | S1 - S2 | / ( |S1| ulp ), where S2 is computed without */
/*                                    computing U and V. */
/*  The possible matrix types are */

/*  (1)  The zero matrix. */
/*  (2)  The identity matrix. */

/*  (3)  A diagonal matrix with evenly spaced entries */
/*       1, ..., ULP  and random signs. */
/*       (ULP = (first number larger than 1) - 1 ) */
/*  (4)  A diagonal matrix with geometrically spaced entries */
/*       1, ..., ULP  and random signs. */
/*  (5)  A diagonal matrix with "clustered" entries 1, ULP, ..., ULP */
/*       and random signs. */

/*  (6)  Same as (3), but multiplied by SQRT( overflow threshold ) */
/*  (7)  Same as (3), but multiplied by SQRT( underflow threshold ) */

/*  (8)  A matrix of the form  U D V, where U and V are orthogonal and */
/*       D has evenly spaced entries 1, ..., ULP with random signs */
/*       on the diagonal. */

/*  (9)  A matrix of the form  U D V, where U and V are orthogonal and */
/*       D has geometrically spaced entries 1, ..., ULP with random */
/*       signs on the diagonal. */

/*  (10) A matrix of the form  U D V, where U and V are orthogonal and */
/*       D has "clustered" entries 1, ULP,..., ULP with random */
/*       signs on the diagonal. */

/*  (11) Same as (8), but multiplied by SQRT( overflow threshold ) */
/*  (12) Same as (8), but multiplied by SQRT( underflow threshold ) */

/*  (13) Rectangular matrix with random entries chosen from (-1,1). */
/*  (14) Same as (13), but multiplied by SQRT( overflow threshold ) */
/*  (15) Same as (13), but multiplied by SQRT( underflow threshold ) */

/*  Special case: */
/*  (16) A bidiagonal matrix with random entries chosen from a */
/*       logarithmic distribution on [ulp^2,ulp^(-2)]  (I.e., each */
/*       entry is  e^x, where x is chosen uniformly on */
/*       [ 2 log(ulp), -2 log(ulp) ] .)  For *this* type: */
/*       (a) DGEBRD is not called to reduce it to bidiagonal form. */
/*       (b) the bidiagonal is  min(M,N) x min(M,N); if M<N, the */
/*           matrix will be lower bidiagonal, otherwise upper. */
/*       (c) only tests 5--8 and 14 are performed. */

/*  A subset of the full set of matrix types may be selected through */
/*  the logical array DOTYPE. */

/*  Arguments */
/*  ========== */

/*  NSIZES  (input) INTEGER */
/*          The number of values of M and N contained in the vectors */
/*          MVAL and NVAL.  The matrix sizes are used in pairs (M,N). */

/*  MVAL    (input) INTEGER array, dimension (NM) */
/*          The values of the matrix row dimension M. */

/*  NVAL    (input) INTEGER array, dimension (NM) */
/*          The values of the matrix column dimension N. */

/*  NTYPES  (input) INTEGER */
/*          The number of elements in DOTYPE.   If it is zero, DCHKBD */
/*          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 matrices are in A and B. */
/*          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 (m,n), a matrix */
/*          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. */

/*  NRHS    (input) INTEGER */
/*          The number of columns in the "right-hand side" matrices X, Y, */
/*          and Z, used in testing DBDSQR.  If NRHS = 0, then the */
/*          operations on the right-hand side will not be tested. */
/*          NRHS must be at least 0. */

/*  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 values of ISEED are changed on exit, and can be */
/*          used in the next call to DCHKBD to continue the same random */
/*          number sequence. */

/*  THRESH  (input) DOUBLE PRECISION */
/*          The threshold value for the test ratios.  A result is */
/*          included in the output file if RESULT >= THRESH.  To have */
/*          every test ratio printed, use THRESH = 0.  Note that the */
/*          expected value of the test ratios is O(1), so THRESH should */
/*          be a reasonably small multiple of 1, e.g., 10 or 100. */

/*  A       (workspace) DOUBLE PRECISION array, dimension (LDA,NMAX) */
/*          where NMAX is the maximum value of N in NVAL. */

/*  LDA     (input) INTEGER */
/*          The leading dimension of the array A.  LDA >= max(1,MMAX), */
/*          where MMAX is the maximum value of M in MVAL. */

/*  BD      (workspace) DOUBLE PRECISION array, dimension */
/*                      (max(min(MVAL(j),NVAL(j)))) */

/*  BE      (workspace) DOUBLE PRECISION array, dimension */
/*                      (max(min(MVAL(j),NVAL(j)))) */

/*  S1      (workspace) DOUBLE PRECISION array, dimension */
/*                      (max(min(MVAL(j),NVAL(j)))) */

/*  S2      (workspace) DOUBLE PRECISION array, dimension */
/*                      (max(min(MVAL(j),NVAL(j)))) */

/*  X       (workspace) DOUBLE PRECISION array, dimension (LDX,NRHS) */

/*  LDX     (input) INTEGER */
/*          The leading dimension of the arrays X, Y, and Z. */
/*          LDX >= max(1,MMAX) */

/*  Y       (workspace) DOUBLE PRECISION array, dimension (LDX,NRHS) */

/*  Z       (workspace) DOUBLE PRECISION array, dimension (LDX,NRHS) */

/*  Q       (workspace) DOUBLE PRECISION array, dimension (LDQ,MMAX) */

/*  LDQ     (input) INTEGER */
/*          The leading dimension of the array Q.  LDQ >= max(1,MMAX). */

/*  PT      (workspace) DOUBLE PRECISION array, dimension (LDPT,NMAX) */

/*  LDPT    (input) INTEGER */
/*          The leading dimension of the arrays PT, U, and V. */
/*          LDPT >= max(1, max(min(MVAL(j),NVAL(j)))). */

/*  U       (workspace) DOUBLE PRECISION array, dimension */
/*                      (LDPT,max(min(MVAL(j),NVAL(j)))) */

/*  V       (workspace) DOUBLE PRECISION array, dimension */
/*                      (LDPT,max(min(MVAL(j),NVAL(j)))) */

/*  WORK    (workspace) DOUBLE PRECISION array, dimension (LWORK) */

/*  LWORK   (input) INTEGER */
/*          The number of entries in WORK.  This must be at least */
/*          3(M+N) and  M(M + max(M,N,k) + 1) + N*min(M,N)  for all */
/*          pairs  (M,N)=(MM(j),NN(j)) */

/*  IWORK   (workspace) INTEGER array, dimension at least 8*min(M,N) */

/*  NOUT    (input) INTEGER */
/*          The FORTRAN unit number for printing out error messages */
/*          (e.g., if a routine returns IINFO not equal to 0.) */

/*  INFO    (output) INTEGER */
/*          If 0, then everything ran OK. */
/*           -1: NSIZES < 0 */
/*           -2: Some MM(j) < 0 */
/*           -3: Some NN(j) < 0 */
/*           -4: NTYPES < 0 */
/*           -6: NRHS  < 0 */
/*           -8: THRESH < 0 */
/*          -11: LDA < 1 or LDA < MMAX, where MMAX is max( MM(j) ). */
/*          -17: LDB < 1 or LDB < MMAX. */
/*          -21: LDQ < 1 or LDQ < MMAX. */
/*          -23: LDPT< 1 or LDPT< MNMAX. */
/*          -27: LWORK too small. */
/*          If  DLATMR, SLATMS, DGEBRD, DORGBR, or DBDSQR, */
/*              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. */
/*     NTEST           The number of tests performed, or which can */
/*                     be performed so far, for the current matrix. */
/*     MMAX            Largest value in NN. */
/*     NMAX            Largest value in NN. */
/*     MNMIN           min(MM(j), NN(j)) (the dimension of the bidiagonal */
/*                     matrix.) */
/*     MNMAX           The maximum value of MNMIN for j=1,...,NSIZES. */
/*     NFAIL           The number of tests which have exceeded THRESH */
/*     COND, IMODE     Values to be passed to the matrix generators. */
/*     ANORM           Norm of A; passed to matrix generators. */

/*     OVFL, UNFL      Overflow and underflow thresholds. */
/*     RTOVFL, RTUNFL  Square roots of the previous 2 values. */
/*     ULP, ULPINV     Finest relative precision and its inverse. */

/*             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) ) */

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

/*     .. Parameters .. */
/*     .. */
/*     .. Local Scalars .. */
/*     .. */
/*     .. Local Arrays .. */
/*     .. */
/*     .. External Functions .. */
/*     .. */
/*     .. External Subroutines .. */
/*     .. */
/*     .. Intrinsic Functions .. */
/*     .. */
/*     .. Scalars in Common .. */
/*     .. */
/*     .. Common blocks .. */
/*     .. */
/*     .. Data statements .. */
    /* Parameter adjustments */
    --mval;
    --nval;
    --dotype;
    --iseed;
    a_dim1 = *lda;
    a_offset = 1 + a_dim1;
    a -= a_offset;
    --bd;
    --be;
    --s1;
    --s2;
    z_dim1 = *ldx;
    z_offset = 1 + z_dim1;
    z__ -= z_offset;
    y_dim1 = *ldx;
    y_offset = 1 + y_dim1;
    y -= y_offset;
    x_dim1 = *ldx;
    x_offset = 1 + x_dim1;
    x -= x_offset;
    q_dim1 = *ldq;
    q_offset = 1 + q_dim1;
    q -= q_offset;
    vt_dim1 = *ldpt;
    vt_offset = 1 + vt_dim1;
    vt -= vt_offset;
    u_dim1 = *ldpt;
    u_offset = 1 + u_dim1;
    u -= u_offset;
    pt_dim1 = *ldpt;
    pt_offset = 1 + pt_dim1;
    pt -= pt_offset;
    --work;
    --iwork;

    /* Function Body */
/*     .. */
/*     .. Executable Statements .. */

/*     Check for errors */

    *info = 0;

    badmm = FALSE_;
    badnn = FALSE_;
    mmax = 1;
    nmax = 1;
    mnmax = 1;
    minwrk = 1;
    i__1 = *nsizes;
    for (j = 1; j <= i__1; ++j) {
/* Computing MAX */
	i__2 = mmax, i__3 = mval[j];
	mmax = max(i__2,i__3);
	if (mval[j] < 0) {
	    badmm = TRUE_;
	}
/* Computing MAX */
	i__2 = nmax, i__3 = nval[j];
	nmax = max(i__2,i__3);
	if (nval[j] < 0) {
	    badnn = TRUE_;
	}
/* Computing MAX */
/* Computing MIN */
	i__4 = mval[j], i__5 = nval[j];
	i__2 = mnmax, i__3 = min(i__4,i__5);
	mnmax = max(i__2,i__3);
/* Computing MAX */
/* Computing MAX */
	i__4 = mval[j], i__5 = nval[j], i__4 = max(i__4,i__5);
/* Computing MIN */
	i__6 = nval[j], i__7 = mval[j];
	i__2 = minwrk, i__3 = (mval[j] + nval[j]) * 3, i__2 = max(i__2,i__3), 
		i__3 = mval[j] * (mval[j] + max(i__4,*nrhs) + 1) + nval[j] * 
		min(i__6,i__7);
	minwrk = max(i__2,i__3);
/* L10: */
    }

/*     Check for errors */

    if (*nsizes < 0) {
	*info = -1;
    } else if (badmm) {
	*info = -2;
    } else if (badnn) {
	*info = -3;
    } else if (*ntypes < 0) {
	*info = -4;
    } else if (*nrhs < 0) {
	*info = -6;
    } else if (*lda < mmax) {
	*info = -11;
    } else if (*ldx < mmax) {
	*info = -17;
    } else if (*ldq < mmax) {
	*info = -21;
    } else if (*ldpt < mnmax) {
	*info = -23;
    } else if (minwrk > *lwork) {
	*info = -27;
    }

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

/*     Initialize constants */

    s_copy(path, "Double precision", (ftnlen)1, (ftnlen)16);
    s_copy(path + 1, "BD", (ftnlen)2, (ftnlen)2);
    nfail = 0;
    ntest = 0;
    unfl = dlamch_("Safe minimum");
    ovfl = dlamch_("Overflow");
    dlabad_(&unfl, &ovfl);
    ulp = dlamch_("Precision");
    ulpinv = 1. / ulp;
    log2ui = (integer) (log(ulpinv) / log(2.));
    rtunfl = sqrt(unfl);
    rtovfl = sqrt(ovfl);
    infoc_1.infot = 0;

/*     Loop over sizes, types */

    i__1 = *nsizes;
    for (jsize = 1; jsize <= i__1; ++jsize) {
	m = mval[jsize];
	n = nval[jsize];
	mnmin = min(m,n);
/* Computing MAX */
	i__2 = max(m,n);
	amninv = 1. / max(i__2,1);

	if (*nsizes != 1) {
	    mtypes = min(16,*ntypes);
	} else {
	    mtypes = min(17,*ntypes);
	}

	i__2 = mtypes;
	for (jtype = 1; jtype <= i__2; ++jtype) {
	    if (! dotype[jtype]) {
		goto L190;
	    }

	    for (j = 1; j <= 4; ++j) {
		ioldsd[j - 1] = iseed[j];
/* L20: */
	    }

	    for (j = 1; j <= 14; ++j) {
		result[j - 1] = -1.;
/* L30: */
	    }

	    *(unsigned char *)uplo = ' ';

/*           Compute "A" */

/*           Control parameters: */

/*           KMAGN  KMODE        KTYPE */
/*       =1  O(1)   clustered 1  zero */
/*       =2  large  clustered 2  identity */
/*       =3  small  exponential  (none) */
/*       =4         arithmetic   diagonal, (w/ eigenvalues) */
/*       =5         random       symmetric, w/ eigenvalues */
/*       =6                      nonsymmetric, w/ singular values */
/*       =7                      random diagonal */
/*       =8                      random symmetric */
/*       =9                      random nonsymmetric */
/*       =10                     random bidiagonal (log. distrib.) */

	    if (mtypes > 16) {
		goto L100;
	    }

	    itype = ktype[jtype - 1];
	    imode = kmode[jtype - 1];

/*           Compute norm */

	    switch (kmagn[jtype - 1]) {
		case 1:  goto L40;
		case 2:  goto L50;
		case 3:  goto L60;
	    }

L40:
	    anorm = 1.;
	    goto L70;

L50:
	    anorm = rtovfl * ulp * amninv;
	    goto L70;

L60:
	    anorm = rtunfl * max(m,n) * ulpinv;
	    goto L70;

L70:

	    dlaset_("Full", lda, &n, &c_b20, &c_b20, &a[a_offset], lda);
	    iinfo = 0;
	    cond = ulpinv;

	    bidiag = FALSE_;
	    if (itype == 1) {

/*              Zero matrix */

		iinfo = 0;

	    } else if (itype == 2) {

/*              Identity */

		i__3 = mnmin;
		for (jcol = 1; jcol <= i__3; ++jcol) {
		    a[jcol + jcol * a_dim1] = anorm;
/* L80: */
		}

	    } else if (itype == 4) {

/*              Diagonal Matrix, [Eigen]values Specified */

		dlatms_(&mnmin, &mnmin, "S", &iseed[1], "N", &work[1], &imode, 
			 &cond, &anorm, &c__0, &c__0, "N", &a[a_offset], lda, 
			&work[mnmin + 1], &iinfo);

	    } else if (itype == 5) {

/*              Symmetric, eigenvalues specified */

		dlatms_(&mnmin, &mnmin, "S", &iseed[1], "S", &work[1], &imode, 
			 &cond, &anorm, &m, &n, "N", &a[a_offset], lda, &work[
			mnmin + 1], &iinfo);

	    } else if (itype == 6) {

/*              Nonsymmetric, singular values specified */

		dlatms_(&m, &n, "S", &iseed[1], "N", &work[1], &imode, &cond, 
			&anorm, &m, &n, "N", &a[a_offset], lda, &work[mnmin + 
			1], &iinfo);

	    } else if (itype == 7) {

/*              Diagonal, random entries */

		dlatmr_(&mnmin, &mnmin, "S", &iseed[1], "N", &work[1], &c__6, 
			&c_b37, &c_b37, "T", "N", &work[mnmin + 1], &c__1, &
			c_b37, &work[(mnmin << 1) + 1], &c__1, &c_b37, "N", &
			iwork[1], &c__0, &c__0, &c_b20, &anorm, "NO", &a[
			a_offset], lda, &iwork[1], &iinfo);

	    } else if (itype == 8) {

/*              Symmetric, random entries */

		dlatmr_(&mnmin, &mnmin, "S", &iseed[1], "S", &work[1], &c__6, 
			&c_b37, &c_b37, "T", "N", &work[mnmin + 1], &c__1, &
			c_b37, &work[m + mnmin + 1], &c__1, &c_b37, "N", &
			iwork[1], &m, &n, &c_b20, &anorm, "NO", &a[a_offset], 
			lda, &iwork[1], &iinfo);

	    } else if (itype == 9) {

/*              Nonsymmetric, random entries */

		dlatmr_(&m, &n, "S", &iseed[1], "N", &work[1], &c__6, &c_b37, 
			&c_b37, "T", "N", &work[mnmin + 1], &c__1, &c_b37, &
			work[m + mnmin + 1], &c__1, &c_b37, "N", &iwork[1], &
			m, &n, &c_b20, &anorm, "NO", &a[a_offset], lda, &
			iwork[1], &iinfo);

	    } else if (itype == 10) {

/*              Bidiagonal, random entries */

		temp1 = log(ulp) * -2.;
		i__3 = mnmin;
		for (j = 1; j <= i__3; ++j) {
		    bd[j] = exp(temp1 * dlarnd_(&c__2, &iseed[1]));
		    if (j < mnmin) {
			be[j] = exp(temp1 * dlarnd_(&c__2, &iseed[1]));
		    }
/* L90: */
		}

		iinfo = 0;
		bidiag = TRUE_;
		if (m >= n) {
		    *(unsigned char *)uplo = 'U';
		} else {
		    *(unsigned char *)uplo = 'L';
		}
	    } else {
		iinfo = 1;
	    }

	    if (iinfo == 0) {

/*              Generate Right-Hand Side */

		if (bidiag) {
		    dlatmr_(&mnmin, nrhs, "S", &iseed[1], "N", &work[1], &
			    c__6, &c_b37, &c_b37, "T", "N", &work[mnmin + 1], 
			    &c__1, &c_b37, &work[(mnmin << 1) + 1], &c__1, &
			    c_b37, "N", &iwork[1], &mnmin, nrhs, &c_b20, &
			    c_b37, "NO", &y[y_offset], ldx, &iwork[1], &iinfo);
		} else {
		    dlatmr_(&m, nrhs, "S", &iseed[1], "N", &work[1], &c__6, &
			    c_b37, &c_b37, "T", "N", &work[m + 1], &c__1, &
			    c_b37, &work[(m << 1) + 1], &c__1, &c_b37, "N", &
			    iwork[1], &m, nrhs, &c_b20, &c_b37, "NO", &x[
			    x_offset], ldx, &iwork[1], &iinfo);
		}
	    }

/*           Error Exit */

	    if (iinfo != 0) {
		io___39.ciunit = *nout;
		s_wsfe(&io___39);
		do_fio(&c__1, "Generator", (ftnlen)9);
		do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer));
		do_fio(&c__1, (char *)&m, (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;
	    }

L100:

/*           Call DGEBRD and DORGBR to compute B, Q, and P, do tests. */

	    if (! bidiag) {

/*              Compute transformations to reduce A to bidiagonal form: */
/*              B := Q' * A * P. */

		dlacpy_(" ", &m, &n, &a[a_offset], lda, &q[q_offset], ldq);
		i__3 = *lwork - (mnmin << 1);
		dgebrd_(&m, &n, &q[q_offset], ldq, &bd[1], &be[1], &work[1], &
			work[mnmin + 1], &work[(mnmin << 1) + 1], &i__3, &
			iinfo);

/*              Check error code from DGEBRD. */

		if (iinfo != 0) {
		    io___40.ciunit = *nout;
		    s_wsfe(&io___40);
		    do_fio(&c__1, "DGEBRD", (ftnlen)6);
		    do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer));
		    do_fio(&c__1, (char *)&m, (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;
		}

		dlacpy_(" ", &m, &n, &q[q_offset], ldq, &pt[pt_offset], ldpt);
		if (m >= n) {
		    *(unsigned char *)uplo = 'U';
		} else {
		    *(unsigned char *)uplo = 'L';
		}

/*              Generate Q */

		mq = m;
		if (*nrhs <= 0) {
		    mq = mnmin;
		}
		i__3 = *lwork - (mnmin << 1);
		dorgbr_("Q", &m, &mq, &n, &q[q_offset], ldq, &work[1], &work[(
			mnmin << 1) + 1], &i__3, &iinfo);

/*              Check error code from DORGBR. */

		if (iinfo != 0) {
		    io___42.ciunit = *nout;
		    s_wsfe(&io___42);
		    do_fio(&c__1, "DORGBR(Q)", (ftnlen)9);
		    do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer));
		    do_fio(&c__1, (char *)&m, (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;
		}

/*              Generate P' */

		i__3 = *lwork - (mnmin << 1);
		dorgbr_("P", &mnmin, &n, &m, &pt[pt_offset], ldpt, &work[
			mnmin + 1], &work[(mnmin << 1) + 1], &i__3, &iinfo);

/*              Check error code from DORGBR. */

		if (iinfo != 0) {
		    io___43.ciunit = *nout;
		    s_wsfe(&io___43);
		    do_fio(&c__1, "DORGBR(P)", (ftnlen)9);
		    do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer));
		    do_fio(&c__1, (char *)&m, (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;
		}

/*              Apply Q' to an M by NRHS matrix X:  Y := Q' * X. */

		dgemm_("Transpose", "No transpose", &m, nrhs, &m, &c_b37, &q[
			q_offset], ldq, &x[x_offset], ldx, &c_b20, &y[
			y_offset], ldx);

/*              Test 1:  Check the decomposition A := Q * B * PT */
/*                   2:  Check the orthogonality of Q */
/*                   3:  Check the orthogonality of PT */

		dbdt01_(&m, &n, &c__1, &a[a_offset], lda, &q[q_offset], ldq, &
			bd[1], &be[1], &pt[pt_offset], ldpt, &work[1], result)
			;
		dort01_("Columns", &m, &mq, &q[q_offset], ldq, &work[1], 
			lwork, &result[1]);
		dort01_("Rows", &mnmin, &n, &pt[pt_offset], ldpt, &work[1], 
			lwork, &result[2]);
	    }

/*           Use DBDSQR to form the SVD of the bidiagonal matrix B: */
/*           B := U * S1 * VT, and compute Z = U' * Y. */

	    dcopy_(&mnmin, &bd[1], &c__1, &s1[1], &c__1);
	    if (mnmin > 0) {
		i__3 = mnmin - 1;
		dcopy_(&i__3, &be[1], &c__1, &work[1], &c__1);
	    }
	    dlacpy_(" ", &m, nrhs, &y[y_offset], ldx, &z__[z_offset], ldx);
	    dlaset_("Full", &mnmin, &mnmin, &c_b20, &c_b37, &u[u_offset], 
		    ldpt);
	    dlaset_("Full", &mnmin, &mnmin, &c_b20, &c_b37, &vt[vt_offset], 
		    ldpt);

	    dbdsqr_(uplo, &mnmin, &mnmin, &mnmin, nrhs, &s1[1], &work[1], &vt[
		    vt_offset], ldpt, &u[u_offset], ldpt, &z__[z_offset], ldx, 
		     &work[mnmin + 1], &iinfo);

/*           Check error code from DBDSQR. */

	    if (iinfo != 0) {
		io___44.ciunit = *nout;
		s_wsfe(&io___44);
		do_fio(&c__1, "DBDSQR(vects)", (ftnlen)13);
		do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer));
		do_fio(&c__1, (char *)&m, (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);
		if (iinfo < 0) {
		    return 0;
		} else {
		    result[3] = ulpinv;
		    goto L170;
		}
	    }

/*           Use DBDSQR to compute only the singular values of the */
/*           bidiagonal matrix B;  U, VT, and Z should not be modified. */

	    dcopy_(&mnmin, &bd[1], &c__1, &s2[1], &c__1);
	    if (mnmin > 0) {
		i__3 = mnmin - 1;
		dcopy_(&i__3, &be[1], &c__1, &work[1], &c__1);
	    }

	    dbdsqr_(uplo, &mnmin, &c__0, &c__0, &c__0, &s2[1], &work[1], &vt[
		    vt_offset], ldpt, &u[u_offset], ldpt, &z__[z_offset], ldx, 
		     &work[mnmin + 1], &iinfo);

/*           Check error code from DBDSQR. */

	    if (iinfo != 0) {
		io___45.ciunit = *nout;
		s_wsfe(&io___45);
		do_fio(&c__1, "DBDSQR(values)", (ftnlen)14);
		do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer));
		do_fio(&c__1, (char *)&m, (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);
		if (iinfo < 0) {
		    return 0;
		} else {
		    result[8] = ulpinv;
		    goto L170;
		}
	    }

/*           Test 4:  Check the decomposition B := U * S1 * VT */
/*                5:  Check the computation Z := U' * Y */
/*                6:  Check the orthogonality of U */
/*                7:  Check the orthogonality of VT */

	    dbdt03_(uplo, &mnmin, &c__1, &bd[1], &be[1], &u[u_offset], ldpt, &
		    s1[1], &vt[vt_offset], ldpt, &work[1], &result[3]);
	    dbdt02_(&mnmin, nrhs, &y[y_offset], ldx, &z__[z_offset], ldx, &u[
		    u_offset], ldpt, &work[1], &result[4]);
	    dort01_("Columns", &mnmin, &mnmin, &u[u_offset], ldpt, &work[1], 
		    lwork, &result[5]);
	    dort01_("Rows", &mnmin, &mnmin, &vt[vt_offset], ldpt, &work[1], 
		    lwork, &result[6]);

/*           Test 8:  Check that the singular values are sorted in */
/*                    non-increasing order and are non-negative */

	    result[7] = 0.;
	    i__3 = mnmin - 1;
	    for (i__ = 1; i__ <= i__3; ++i__) {
		if (s1[i__] < s1[i__ + 1]) {
		    result[7] = ulpinv;
		}
		if (s1[i__] < 0.) {
		    result[7] = ulpinv;
		}
/* L110: */
	    }
	    if (mnmin >= 1) {
		if (s1[mnmin] < 0.) {
		    result[7] = ulpinv;
		}
	    }

/*           Test 9:  Compare DBDSQR with and without singular vectors */

	    temp2 = 0.;

	    i__3 = mnmin;
	    for (j = 1; j <= i__3; ++j) {
/* Computing MAX */
/* Computing MAX */
		d__6 = (d__1 = s1[j], abs(d__1)), d__7 = (d__2 = s2[j], abs(
			d__2));
		d__4 = sqrt(unfl) * max(s1[1],1.), d__5 = ulp * max(d__6,d__7)
			;
		temp1 = (d__3 = s1[j] - s2[j], abs(d__3)) / max(d__4,d__5);
		temp2 = max(temp1,temp2);
/* L120: */
	    }

	    result[8] = temp2;

/*           Test 10:  Sturm sequence test of singular values */
/*                     Go up by factors of two until it succeeds */

	    temp1 = *thresh * (.5 - ulp);

	    i__3 = log2ui;
	    for (j = 0; j <= i__3; ++j) {
/*               CALL DSVDCH( MNMIN, BD, BE, S1, TEMP1, IINFO ) */
		if (iinfo == 0) {
		    goto L140;
		}
		temp1 *= 2.;
/* L130: */
	    }

L140:
	    result[9] = temp1;

/*           Use DBDSQR to form the decomposition A := (QU) S (VT PT) */
/*           from the bidiagonal form A := Q B PT. */

	    if (! bidiag) {
		dcopy_(&mnmin, &bd[1], &c__1, &s2[1], &c__1);
		if (mnmin > 0) {
		    i__3 = mnmin - 1;
		    dcopy_(&i__3, &be[1], &c__1, &work[1], &c__1);
		}

		dbdsqr_(uplo, &mnmin, &n, &m, nrhs, &s2[1], &work[1], &pt[
			pt_offset], ldpt, &q[q_offset], ldq, &y[y_offset], 
			ldx, &work[mnmin + 1], &iinfo);

/*              Test 11:  Check the decomposition A := Q*U * S2 * VT*PT */
/*                   12:  Check the computation Z := U' * Q' * X */
/*                   13:  Check the orthogonality of Q*U */
/*                   14:  Check the orthogonality of VT*PT */

		dbdt01_(&m, &n, &c__0, &a[a_offset], lda, &q[q_offset], ldq, &
			s2[1], dumma, &pt[pt_offset], ldpt, &work[1], &result[
			10]);
		dbdt02_(&m, nrhs, &x[x_offset], ldx, &y[y_offset], ldx, &q[
			q_offset], ldq, &work[1], &result[11]);
		dort01_("Columns", &m, &mq, &q[q_offset], ldq, &work[1], 
			lwork, &result[12]);
		dort01_("Rows", &mnmin, &n, &pt[pt_offset], ldpt, &work[1], 
			lwork, &result[13]);
	    }

/*           Use DBDSDC to form the SVD of the bidiagonal matrix B: */
/*           B := U * S1 * VT */

	    dcopy_(&mnmin, &bd[1], &c__1, &s1[1], &c__1);
	    if (mnmin > 0) {
		i__3 = mnmin - 1;
		dcopy_(&i__3, &be[1], &c__1, &work[1], &c__1);
	    }
	    dlaset_("Full", &mnmin, &mnmin, &c_b20, &c_b37, &u[u_offset], 
		    ldpt);
	    dlaset_("Full", &mnmin, &mnmin, &c_b20, &c_b37, &vt[vt_offset], 
		    ldpt);

	    dbdsdc_(uplo, "I", &mnmin, &s1[1], &work[1], &u[u_offset], ldpt, &
		    vt[vt_offset], ldpt, dum, idum, &work[mnmin + 1], &iwork[
		    1], &iinfo);

/*           Check error code from DBDSDC. */

	    if (iinfo != 0) {
		io___51.ciunit = *nout;
		s_wsfe(&io___51);
		do_fio(&c__1, "DBDSDC(vects)", (ftnlen)13);
		do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer));
		do_fio(&c__1, (char *)&m, (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);
		if (iinfo < 0) {
		    return 0;
		} else {
		    result[14] = ulpinv;
		    goto L170;
		}
	    }

/*           Use DBDSDC to compute only the singular values of the */
/*           bidiagonal matrix B;  U and VT should not be modified. */

	    dcopy_(&mnmin, &bd[1], &c__1, &s2[1], &c__1);
	    if (mnmin > 0) {
		i__3 = mnmin - 1;
		dcopy_(&i__3, &be[1], &c__1, &work[1], &c__1);
	    }

	    dbdsdc_(uplo, "N", &mnmin, &s2[1], &work[1], dum, &c__1, dum, &
		    c__1, dum, idum, &work[mnmin + 1], &iwork[1], &iinfo);

/*           Check error code from DBDSDC. */

	    if (iinfo != 0) {
		io___52.ciunit = *nout;
		s_wsfe(&io___52);
		do_fio(&c__1, "DBDSDC(values)", (ftnlen)14);
		do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer));
		do_fio(&c__1, (char *)&m, (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);
		if (iinfo < 0) {
		    return 0;
		} else {
		    result[17] = ulpinv;
		    goto L170;
		}
	    }

/*           Test 15:  Check the decomposition B := U * S1 * VT */
/*                16:  Check the orthogonality of U */
/*                17:  Check the orthogonality of VT */

	    dbdt03_(uplo, &mnmin, &c__1, &bd[1], &be[1], &u[u_offset], ldpt, &
		    s1[1], &vt[vt_offset], ldpt, &work[1], &result[14]);
	    dort01_("Columns", &mnmin, &mnmin, &u[u_offset], ldpt, &work[1], 
		    lwork, &result[15]);
	    dort01_("Rows", &mnmin, &mnmin, &vt[vt_offset], ldpt, &work[1], 
		    lwork, &result[16]);

/*           Test 18:  Check that the singular values are sorted in */
/*                     non-increasing order and are non-negative */

	    result[17] = 0.;
	    i__3 = mnmin - 1;
	    for (i__ = 1; i__ <= i__3; ++i__) {
		if (s1[i__] < s1[i__ + 1]) {
		    result[17] = ulpinv;
		}
		if (s1[i__] < 0.) {
		    result[17] = ulpinv;
		}
/* L150: */
	    }
	    if (mnmin >= 1) {
		if (s1[mnmin] < 0.) {
		    result[17] = ulpinv;
		}
	    }

/*           Test 19:  Compare DBDSQR with and without singular vectors */

	    temp2 = 0.;

	    i__3 = mnmin;
	    for (j = 1; j <= i__3; ++j) {
/* Computing MAX */
/* Computing MAX */
		d__4 = abs(s1[1]), d__5 = abs(s2[1]);
		d__2 = sqrt(unfl) * max(s1[1],1.), d__3 = ulp * max(d__4,d__5)
			;
		temp1 = (d__1 = s1[j] - s2[j], abs(d__1)) / max(d__2,d__3);
		temp2 = max(temp1,temp2);
/* L160: */
	    }

	    result[18] = temp2;

/*           End of Loop -- Check for RESULT(j) > THRESH */

L170:
	    for (j = 1; j <= 19; ++j) {
		if (result[j - 1] >= *thresh) {
		    if (nfail == 0) {
			dlahd2_(nout, path);
		    }
		    io___53.ciunit = *nout;
		    s_wsfe(&io___53);
		    do_fio(&c__1, (char *)&m, (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))
			    ;
		    do_fio(&c__1, (char *)&j, (ftnlen)sizeof(integer));
		    do_fio(&c__1, (char *)&result[j - 1], (ftnlen)sizeof(
			    doublereal));
		    e_wsfe();
		    ++nfail;
		}
/* L180: */
	    }
	    if (! bidiag) {
		ntest += 19;
	    } else {
		ntest += 5;
	    }

L190:
	    ;
	}
/* L200: */
    }

/*     Summary */

    alasum_(path, nout, &nfail, &ntest, &c__0);

    return 0;

/*     End of DCHKBD */


} /* dchkbd_ */
示例#10
0
/* Subroutine */ int dtbt06_(doublereal *rcond, doublereal *rcondc, char *
	uplo, char *diag, integer *n, integer *kd, doublereal *ab, integer *
	ldab, doublereal *work, doublereal *rat)
{
    /* System generated locals */
    integer ab_dim1, ab_offset;
    doublereal d__1, d__2;

    /* Local variables */
    doublereal eps, rmin, rmax, anorm;
    doublereal bignum, smlnum;


/*  -- LAPACK test routine (version 3.1) -- */
/*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/*     November 2006 */

/*     .. Scalar Arguments .. */
/*     .. */
/*     .. Array Arguments .. */
/*     .. */

/*  Purpose */
/*  ======= */

/*  DTBT06 computes a test ratio comparing RCOND (the reciprocal */
/*  condition number of a triangular matrix A) and RCONDC, the estimate */
/*  computed by DTBCON.  Information about the triangular matrix A is */
/*  used if one estimate is zero and the other is non-zero to decide if */
/*  underflow in the estimate is justified. */

/*  Arguments */
/*  ========= */

/*  RCOND   (input) DOUBLE PRECISION */
/*          The estimate of the reciprocal condition number obtained by */
/*          forming the explicit inverse of the matrix A and computing */
/*          RCOND = 1/( norm(A) * norm(inv(A)) ). */

/*  RCONDC  (input) DOUBLE PRECISION */
/*          The estimate of the reciprocal condition number computed by */
/*          DTBCON. */

/*  UPLO    (input) CHARACTER */
/*          Specifies whether the matrix A is upper or lower triangular. */
/*          = 'U':  Upper triangular */
/*          = 'L':  Lower triangular */

/*  DIAG    (input) CHARACTER */
/*          Specifies whether or not the matrix A is unit triangular. */
/*          = 'N':  Non-unit triangular */
/*          = 'U':  Unit triangular */

/*  N       (input) INTEGER */
/*          The order of the matrix A.  N >= 0. */

/*  KD      (input) INTEGER */
/*          The number of superdiagonals or subdiagonals of the */
/*          triangular band matrix A.  KD >= 0. */

/*  AB      (input) DOUBLE PRECISION array, dimension (LDAB,N) */
/*          The upper or lower triangular band matrix A, stored in the */
/*          first kd+1 rows of the array. The j-th column of A is stored */
/*          in the j-th column of the array AB as follows: */
/*          if UPLO = 'U', AB(kd+1+i-j,j) = A(i,j) for max(1,j-kd)<=i<=j; */
/*          if UPLO = 'L', AB(1+i-j,j)    = A(i,j) for j<=i<=min(n,j+kd). */

/*  LDAB    (input) INTEGER */
/*          The leading dimension of the array AB.  LDAB >= KD+1. */

/*  WORK    (workspace) DOUBLE PRECISION array, dimension (N) */

/*  RAT     (output) DOUBLE PRECISION */
/*          The test ratio.  If both RCOND and RCONDC are nonzero, */
/*             RAT = MAX( RCOND, RCONDC )/MIN( RCOND, RCONDC ) - 1. */
/*          If RAT = 0, the two estimates are exactly the same. */

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

/*     .. Parameters .. */
/*     .. */
/*     .. Local Scalars .. */
/*     .. */
/*     .. External Functions .. */
/*     .. */
/*     .. Intrinsic Functions .. */
/*     .. */
/*     .. External Subroutines .. */
/*     .. */
/*     .. Executable Statements .. */

    /* Parameter adjustments */
    ab_dim1 = *ldab;
    ab_offset = 1 + ab_dim1;
    ab -= ab_offset;
    --work;

    /* Function Body */
    eps = dlamch_("Epsilon");
    rmax = max(*rcond,*rcondc);
    rmin = min(*rcond,*rcondc);

/*     Do the easy cases first. */

    if (rmin < 0.) {

/*        Invalid value for RCOND or RCONDC, return 1/EPS. */

	*rat = 1. / eps;

    } else if (rmin > 0.) {

/*        Both estimates are positive, return RMAX/RMIN - 1. */

	*rat = rmax / rmin - 1.;

    } else if (rmax == 0.) {

/*        Both estimates zero. */

	*rat = 0.;

    } else {

/*        One estimate is zero, the other is non-zero.  If the matrix is */
/*        ill-conditioned, return the nonzero estimate multiplied by */
/*        1/EPS; if the matrix is badly scaled, return the nonzero */
/*        estimate multiplied by BIGNUM/TMAX, where TMAX is the maximum */
/*        element in absolute value in A. */

	smlnum = dlamch_("Safe minimum");
	bignum = 1. / smlnum;
	dlabad_(&smlnum, &bignum);
	anorm = dlantb_("M", uplo, diag, n, kd, &ab[ab_offset], ldab, &work[1]
);

/* Computing MIN */
	d__1 = bignum / max(1.,anorm), d__2 = 1. / eps;
	*rat = rmax * min(d__1,d__2);
    }

    return 0;

/*     End of DTBT06 */

} /* dtbt06_ */
示例#11
0
文件: dlaqrb.f.c 项目: cadarso/tensor
/* Subroutine */ int dlaqrb_(logical *wantt, integer *n, integer *ilo, 
	integer *ihi, doublereal *h__, integer *ldh, doublereal *wr, 
	doublereal *wi, doublereal *z__, integer *info)
{
    /* System generated locals */
    integer h_dim1, h_offset, i__1, i__2, i__3, i__4;
    doublereal d__1, d__2;

    /* Local variables */
    static integer i__, j, k, l, m;
    static doublereal s, v[3];
    static integer i1, i2;
    static doublereal t1, t2, t3, v1, v2, v3, h00, h10, h11, h12, h21, h22, 
	    h33, h44;
    static integer nh;
    static doublereal cs;
    static integer nr;
    static doublereal sn, h33s, h44s;
    static integer itn, its;
    static doublereal ulp, sum, tst1, h43h34, unfl, ovfl;
    extern /* Subroutine */ int drot_(integer *, doublereal *, integer *, 
	    doublereal *, integer *, doublereal *, doublereal *);
    static doublereal work[1];
    extern /* Subroutine */ int dcopy_(integer *, doublereal *, integer *, 
	    doublereal *, integer *), dlanv2_(doublereal *, doublereal *, 
	    doublereal *, doublereal *, doublereal *, doublereal *, 
	    doublereal *, doublereal *, doublereal *, doublereal *), dlabad_(
	    doublereal *, doublereal *);
    extern doublereal dlamch_(char *, ftnlen);
    extern /* Subroutine */ int dlarfg_(integer *, doublereal *, doublereal *,
	     integer *, doublereal *);
    extern doublereal dlanhs_(char *, integer *, doublereal *, integer *, 
	    doublereal *, ftnlen);
    static doublereal smlnum;


/*     %------------------% */
/*     | Scalar Arguments | */
/*     %------------------% */


/*     %-----------------% */
/*     | Array Arguments | */
/*     %-----------------% */


/*     %------------% */
/*     | Parameters | */
/*     %------------% */


/*     %------------------------% */
/*     | Local Scalars & Arrays | */
/*     %------------------------% */


/*     %--------------------% */
/*     | External Functions | */
/*     %--------------------% */


/*     %----------------------% */
/*     | External Subroutines | */
/*     %----------------------% */


/*     %-----------------------% */
/*     | Executable Statements | */
/*     %-----------------------% */

    /* Parameter adjustments */
    h_dim1 = *ldh;
    h_offset = 1 + h_dim1;
    h__ -= h_offset;
    --wr;
    --wi;
    --z__;

    /* Function Body */
    *info = 0;

/*     %--------------------------% */
/*     | Quick return if possible | */
/*     %--------------------------% */

    if (*n == 0) {
	return 0;
    }
    if (*ilo == *ihi) {
	wr[*ilo] = h__[*ilo + *ilo * h_dim1];
	wi[*ilo] = 0.;
	return 0;
    }

/*     %---------------------------------------------% */
/*     | Initialize the vector of last components of | */
/*     | the Schur vectors for accumulation.         | */
/*     %---------------------------------------------% */

    i__1 = *n - 1;
    for (j = 1; j <= i__1; ++j) {
	z__[j] = 0.;
/* L5: */
    }
    z__[*n] = 1.;

    nh = *ihi - *ilo + 1;

/*     %-------------------------------------------------------------% */
/*     | Set machine-dependent constants for the stopping criterion. | */
/*     | If norm(H) <= sqrt(OVFL), overflow should not occur.        | */
/*     %-------------------------------------------------------------% */

    unfl = dlamch_("safe minimum", (ftnlen)12);
    ovfl = 1. / unfl;
    dlabad_(&unfl, &ovfl);
    ulp = dlamch_("precision", (ftnlen)9);
    smlnum = unfl * (nh / ulp);

/*     %---------------------------------------------------------------% */
/*     | I1 and I2 are the indices of the first row and last column    | */
/*     | of H to which transformations must be applied. If eigenvalues | */
/*     | only are computed, I1 and I2 are set inside the main loop.    | */
/*     | Zero out H(J+2,J) = ZERO for J=1:N if WANTT = .TRUE.          | */
/*     | else H(J+2,J) for J=ILO:IHI-ILO-1 if WANTT = .FALSE.          | */
/*     %---------------------------------------------------------------% */

    if (*wantt) {
	i1 = 1;
	i2 = *n;
	i__1 = i2 - 2;
	for (i__ = 1; i__ <= i__1; ++i__) {
	    h__[i1 + i__ + 1 + i__ * h_dim1] = 0.;
/* L8: */
	}
    } else {
	i__1 = *ihi - *ilo - 1;
	for (i__ = 1; i__ <= i__1; ++i__) {
	    h__[*ilo + i__ + 1 + (*ilo + i__ - 1) * h_dim1] = 0.;
/* L9: */
	}
    }

/*     %---------------------------------------------------% */
/*     | ITN is the total number of QR iterations allowed. | */
/*     %---------------------------------------------------% */

    itn = nh * 30;

/*     ------------------------------------------------------------------ */
/*     The main loop begins here. I is the loop index and decreases from */
/*     IHI to ILO in steps of 1 or 2. Each iteration of the loop works */
/*     with the active submatrix in rows and columns L to I. */
/*     Eigenvalues I+1 to IHI have already converged. Either L = ILO or */
/*     H(L,L-1) is negligible so that the matrix splits. */
/*     ------------------------------------------------------------------ */

    i__ = *ihi;
L10:
    l = *ilo;
    if (i__ < *ilo) {
	goto L150;
    }
/*     %--------------------------------------------------------------% */
/*     | Perform QR iterations on rows and columns ILO to I until a   | */
/*     | submatrix of order 1 or 2 splits off at the bottom because a | */
/*     | subdiagonal element has become negligible.                   | */
/*     %--------------------------------------------------------------% */
    i__1 = itn;
    for (its = 0; its <= i__1; ++its) {

/*        %----------------------------------------------% */
/*        | Look for a single small subdiagonal element. | */
/*        %----------------------------------------------% */

	i__2 = l + 1;
	for (k = i__; k >= i__2; --k) {
	    tst1 = (d__1 = h__[k - 1 + (k - 1) * h_dim1], abs(d__1)) + (d__2 =
		     h__[k + k * h_dim1], abs(d__2));
	    if (tst1 == 0.) {
		i__3 = i__ - l + 1;
		tst1 = dlanhs_("1", &i__3, &h__[l + l * h_dim1], ldh, work, (
			ftnlen)1);
	    }
/* Computing MAX */
	    d__2 = ulp * tst1;
	    if ((d__1 = h__[k + (k - 1) * h_dim1], abs(d__1)) <= max(d__2,
		    smlnum)) {
		goto L30;
	    }
/* L20: */
	}
L30:
	l = k;
	if (l > *ilo) {

/*           %------------------------% */
/*           | H(L,L-1) is negligible | */
/*           %------------------------% */

	    h__[l + (l - 1) * h_dim1] = 0.;
	}

/*        %-------------------------------------------------------------% */
/*        | Exit from loop if a submatrix of order 1 or 2 has split off | */
/*        %-------------------------------------------------------------% */

	if (l >= i__ - 1) {
	    goto L140;
	}

/*        %---------------------------------------------------------% */
/*        | Now the active submatrix is in rows and columns L to I. | */
/*        | If eigenvalues only are being computed, only the active | */
/*        | submatrix need be transformed.                          | */
/*        %---------------------------------------------------------% */

	if (! (*wantt)) {
	    i1 = l;
	    i2 = i__;
	}

	if (its == 10 || its == 20) {

/*           %-------------------% */
/*           | Exceptional shift | */
/*           %-------------------% */

	    s = (d__1 = h__[i__ + (i__ - 1) * h_dim1], abs(d__1)) + (d__2 = 
		    h__[i__ - 1 + (i__ - 2) * h_dim1], abs(d__2));
	    h44 = s * .75;
	    h33 = h44;
	    h43h34 = s * -.4375 * s;

	} else {

/*           %-----------------------------------------% */
/*           | Prepare to use Wilkinson's double shift | */
/*           %-----------------------------------------% */

	    h44 = h__[i__ + i__ * h_dim1];
	    h33 = h__[i__ - 1 + (i__ - 1) * h_dim1];
	    h43h34 = h__[i__ + (i__ - 1) * h_dim1] * h__[i__ - 1 + i__ * 
		    h_dim1];
	}

/*        %-----------------------------------------------------% */
/*        | Look for two consecutive small subdiagonal elements | */
/*        %-----------------------------------------------------% */

	i__2 = l;
	for (m = i__ - 2; m >= i__2; --m) {

/*           %---------------------------------------------------------% */
/*           | Determine the effect of starting the double-shift QR    | */
/*           | iteration at row M, and see if this would make H(M,M-1) | */
/*           | negligible.                                             | */
/*           %---------------------------------------------------------% */

	    h11 = h__[m + m * h_dim1];
	    h22 = h__[m + 1 + (m + 1) * h_dim1];
	    h21 = h__[m + 1 + m * h_dim1];
	    h12 = h__[m + (m + 1) * h_dim1];
	    h44s = h44 - h11;
	    h33s = h33 - h11;
	    v1 = (h33s * h44s - h43h34) / h21 + h12;
	    v2 = h22 - h11 - h33s - h44s;
	    v3 = h__[m + 2 + (m + 1) * h_dim1];
	    s = abs(v1) + abs(v2) + abs(v3);
	    v1 /= s;
	    v2 /= s;
	    v3 /= s;
	    v[0] = v1;
	    v[1] = v2;
	    v[2] = v3;
	    if (m == l) {
		goto L50;
	    }
	    h00 = h__[m - 1 + (m - 1) * h_dim1];
	    h10 = h__[m + (m - 1) * h_dim1];
	    tst1 = abs(v1) * (abs(h00) + abs(h11) + abs(h22));
	    if (abs(h10) * (abs(v2) + abs(v3)) <= ulp * tst1) {
		goto L50;
	    }
/* L40: */
	}
L50:

/*        %----------------------% */
/*        | Double-shift QR step | */
/*        %----------------------% */

	i__2 = i__ - 1;
	for (k = m; k <= i__2; ++k) {

/*           ------------------------------------------------------------ */
/*           The first iteration of this loop determines a reflection G */
/*           from the vector V and applies it from left and right to H, */
/*           thus creating a nonzero bulge below the subdiagonal. */

/*           Each subsequent iteration determines a reflection G to */
/*           restore the Hessenberg form in the (K-1)th column, and thus */
/*           chases the bulge one step toward the bottom of the active */
/*           submatrix. NR is the order of G. */
/*           ------------------------------------------------------------ */

/* Computing MIN */
	    i__3 = 3, i__4 = i__ - k + 1;
	    nr = min(i__3,i__4);
	    if (k > m) {
		dcopy_(&nr, &h__[k + (k - 1) * h_dim1], &c__1, v, &c__1);
	    }
	    dlarfg_(&nr, v, &v[1], &c__1, &t1);
	    if (k > m) {
		h__[k + (k - 1) * h_dim1] = v[0];
		h__[k + 1 + (k - 1) * h_dim1] = 0.;
		if (k < i__ - 1) {
		    h__[k + 2 + (k - 1) * h_dim1] = 0.;
		}
	    } else if (m > l) {
		h__[k + (k - 1) * h_dim1] = -h__[k + (k - 1) * h_dim1];
	    }
	    v2 = v[1];
	    t2 = t1 * v2;
	    if (nr == 3) {
		v3 = v[2];
		t3 = t1 * v3;

/*              %------------------------------------------------% */
/*              | Apply G from the left to transform the rows of | */
/*              | the matrix in columns K to I2.                 | */
/*              %------------------------------------------------% */

		i__3 = i2;
		for (j = k; j <= i__3; ++j) {
		    sum = h__[k + j * h_dim1] + v2 * h__[k + 1 + j * h_dim1] 
			    + v3 * h__[k + 2 + j * h_dim1];
		    h__[k + j * h_dim1] -= sum * t1;
		    h__[k + 1 + j * h_dim1] -= sum * t2;
		    h__[k + 2 + j * h_dim1] -= sum * t3;
/* L60: */
		}

/*              %----------------------------------------------------% */
/*              | Apply G from the right to transform the columns of | */
/*              | the matrix in rows I1 to min(K+3,I).               | */
/*              %----------------------------------------------------% */

/* Computing MIN */
		i__4 = k + 3;
		i__3 = min(i__4,i__);
		for (j = i1; j <= i__3; ++j) {
		    sum = h__[j + k * h_dim1] + v2 * h__[j + (k + 1) * h_dim1]
			     + v3 * h__[j + (k + 2) * h_dim1];
		    h__[j + k * h_dim1] -= sum * t1;
		    h__[j + (k + 1) * h_dim1] -= sum * t2;
		    h__[j + (k + 2) * h_dim1] -= sum * t3;
/* L70: */
		}

/*              %----------------------------------% */
/*              | Accumulate transformations for Z | */
/*              %----------------------------------% */

		sum = z__[k] + v2 * z__[k + 1] + v3 * z__[k + 2];
		z__[k] -= sum * t1;
		z__[k + 1] -= sum * t2;
		z__[k + 2] -= sum * t3;
	    } else if (nr == 2) {

/*              %------------------------------------------------% */
/*              | Apply G from the left to transform the rows of | */
/*              | the matrix in columns K to I2.                 | */
/*              %------------------------------------------------% */

		i__3 = i2;
		for (j = k; j <= i__3; ++j) {
		    sum = h__[k + j * h_dim1] + v2 * h__[k + 1 + j * h_dim1];
		    h__[k + j * h_dim1] -= sum * t1;
		    h__[k + 1 + j * h_dim1] -= sum * t2;
/* L90: */
		}

/*              %----------------------------------------------------% */
/*              | Apply G from the right to transform the columns of | */
/*              | the matrix in rows I1 to min(K+3,I).               | */
/*              %----------------------------------------------------% */

		i__3 = i__;
		for (j = i1; j <= i__3; ++j) {
		    sum = h__[j + k * h_dim1] + v2 * h__[j + (k + 1) * h_dim1]
			    ;
		    h__[j + k * h_dim1] -= sum * t1;
		    h__[j + (k + 1) * h_dim1] -= sum * t2;
/* L100: */
		}

/*              %----------------------------------% */
/*              | Accumulate transformations for Z | */
/*              %----------------------------------% */

		sum = z__[k] + v2 * z__[k + 1];
		z__[k] -= sum * t1;
		z__[k + 1] -= sum * t2;
	    }
/* L120: */
	}
/* L130: */
    }

/*     %-------------------------------------------------------% */
/*     | Failure to converge in remaining number of iterations | */
/*     %-------------------------------------------------------% */

    *info = i__;
    return 0;
L140:
    if (l == i__) {

/*        %------------------------------------------------------% */
/*        | H(I,I-1) is negligible: one eigenvalue has converged | */
/*        %------------------------------------------------------% */

	wr[i__] = h__[i__ + i__ * h_dim1];
	wi[i__] = 0.;
    } else if (l == i__ - 1) {

/*        %--------------------------------------------------------% */
/*        | H(I-1,I-2) is negligible;                              | */
/*        | a pair of eigenvalues have converged.                  | */
/*        |                                                        | */
/*        | Transform the 2-by-2 submatrix to standard Schur form, | */
/*        | and compute and store the eigenvalues.                 | */
/*        %--------------------------------------------------------% */

	dlanv2_(&h__[i__ - 1 + (i__ - 1) * h_dim1], &h__[i__ - 1 + i__ * 
		h_dim1], &h__[i__ + (i__ - 1) * h_dim1], &h__[i__ + i__ * 
		h_dim1], &wr[i__ - 1], &wi[i__ - 1], &wr[i__], &wi[i__], &cs, 
		&sn);
	if (*wantt) {

/*           %-----------------------------------------------------% */
/*           | Apply the transformation to the rest of H and to Z, | */
/*           | as required.                                        | */
/*           %-----------------------------------------------------% */

	    if (i2 > i__) {
		i__1 = i2 - i__;
		drot_(&i__1, &h__[i__ - 1 + (i__ + 1) * h_dim1], ldh, &h__[
			i__ + (i__ + 1) * h_dim1], ldh, &cs, &sn);
	    }
	    i__1 = i__ - i1 - 1;
	    drot_(&i__1, &h__[i1 + (i__ - 1) * h_dim1], &c__1, &h__[i1 + i__ *
		     h_dim1], &c__1, &cs, &sn);
	    sum = cs * z__[i__ - 1] + sn * z__[i__];
	    z__[i__] = cs * z__[i__] - sn * z__[i__ - 1];
	    z__[i__ - 1] = sum;
	}
    }

/*     %---------------------------------------------------------% */
/*     | Decrement number of remaining iterations, and return to | */
/*     | start of the main loop with new value of I.             | */
/*     %---------------------------------------------------------% */

    itn -= its;
    i__ = l - 1;
    goto L10;
L150:
    return 0;

/*     %---------------% */
/*     | End of dlaqrb | */
/*     %---------------% */

} /* dlaqrb_ */
示例#12
0
/* Subroutine */ int zgeesx_(char *jobvs, char *sort, L_fp select, char *
	sense, integer *n, doublecomplex *a, integer *lda, integer *sdim, 
	doublecomplex *w, doublecomplex *vs, integer *ldvs, doublereal *
	rconde, doublereal *rcondv, doublecomplex *work, integer *lwork, 
	doublereal *rwork, 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   
    =======   

    ZGEESX computes for an N-by-N complex nonsymmetric matrix A, the   
    eigenvalues, the Schur form T, and, optionally, the matrix of Schur   
    vectors Z.  This gives the Schur factorization A = Z*T*(Z**H).   

    Optionally, it also orders the eigenvalues on the diagonal of the   
    Schur form so that selected eigenvalues are at the top left;   
    computes a reciprocal condition number for the average of the   
    selected eigenvalues (RCONDE); and computes a reciprocal condition   
    number for the right invariant subspace corresponding to the   
    selected eigenvalues (RCONDV).  The leading columns of Z form an   
    orthonormal basis for this invariant subspace.   

    For further explanation of the reciprocal condition numbers RCONDE   
    and RCONDV, see Section 4.10 of the LAPACK Users' Guide (where   
    these quantities are called s and sep respectively).   

    A complex matrix is in Schur form if it is upper triangular.   

    Arguments   
    =========   

    JOBVS   (input) CHARACTER*1   
            = 'N': Schur vectors are not computed;   
            = 'V': Schur vectors are computed.   

    SORT    (input) CHARACTER*1   
            Specifies whether or not to order the eigenvalues on the   
            diagonal of the Schur form.   
            = 'N': Eigenvalues are not ordered;   
            = 'S': Eigenvalues are ordered (see SELECT).   

    SELECT  (input) LOGICAL FUNCTION of one COMPLEX*16 argument   
            SELECT must be declared EXTERNAL in the calling subroutine.   
            If SORT = 'S', SELECT is used to select eigenvalues to order   
            to the top left of the Schur form.   
            If SORT = 'N', SELECT is not referenced.   
            An eigenvalue W(j) is selected if SELECT(W(j)) is true.   

    SENSE   (input) CHARACTER*1   
            Determines which reciprocal condition numbers are computed.   
            = 'N': None are computed;   
            = 'E': Computed for average of selected eigenvalues only;   
            = 'V': Computed for selected right invariant subspace only;   
            = 'B': Computed for both.   
            If SENSE = 'E', 'V' or 'B', SORT must equal 'S'.   

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

    A       (input/output) COMPLEX*16 array, dimension (LDA, N)   
            On entry, the N-by-N matrix A.   
            On exit, A is overwritten by its Schur form T.   

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

    SDIM    (output) INTEGER   
            If SORT = 'N', SDIM = 0.   
            If SORT = 'S', SDIM = number of eigenvalues for which   
                           SELECT is true.   

    W       (output) COMPLEX*16 array, dimension (N)   
            W contains the computed eigenvalues, in the same order   
            that they appear on the diagonal of the output Schur form T.   

    VS      (output) COMPLEX*16 array, dimension (LDVS,N)   
            If JOBVS = 'V', VS contains the unitary matrix Z of Schur   
            vectors.   
            If JOBVS = 'N', VS is not referenced.   

    LDVS    (input) INTEGER   
            The leading dimension of the array VS.  LDVS >= 1, and if   
            JOBVS = 'V', LDVS >= N.   

    RCONDE  (output) DOUBLE PRECISION   
            If SENSE = 'E' or 'B', RCONDE contains the reciprocal   
            condition number for the average of the selected eigenvalues.   
            Not referenced if SENSE = 'N' or 'V'.   

    RCONDV  (output) DOUBLE PRECISION   
            If SENSE = 'V' or 'B', RCONDV contains the reciprocal   
            condition number for the selected right invariant subspace.   
            Not referenced if SENSE = 'N' or 'E'.   

    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).   
            Also, if SENSE = 'E' or 'V' or 'B', LWORK >= 2*SDIM*(N-SDIM),   
            where SDIM is the number of selected eigenvalues computed by   
            this routine.  Note that 2*SDIM*(N-SDIM) <= N*N/2.   
            For good performance, LWORK must generally be larger.   

    RWORK   (workspace) DOUBLE PRECISION array, dimension (N)   

    BWORK   (workspace) LOGICAL array, dimension (N)   
            Not referenced if SORT = 'N'.   

    INFO    (output) INTEGER   
            = 0: successful exit   
            < 0: if INFO = -i, the i-th argument had an illegal value.   
            > 0: if INFO = i, and i is   
               <= N: the QR algorithm failed to compute all the   
                     eigenvalues; elements 1:ILO-1 and i+1:N of W   
                     contain those eigenvalues which have converged; if   
                     JOBVS = 'V', VS contains the transformation which   
                     reduces A to its partially converged Schur form.   
               = N+1: the eigenvalues could not be reordered because some   
                     eigenvalues were too close to separate (the problem   
                     is very ill-conditioned);   
               = N+2: after reordering, roundoff changed values of some   
                     complex eigenvalues so that leading eigenvalues in   
                     the Schur form no longer satisfy SELECT=.TRUE.  This   
                     could also be caused by underflow due to scaling.   

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


       Test the input arguments   

       Parameter adjustments */
    /* Table of constant values */
    static integer c__1 = 1;
    static integer c__0 = 0;
    static integer c__8 = 8;
    static integer c_n1 = -1;
    static integer c__4 = 4;
    
    /* System generated locals */
    integer a_dim1, a_offset, vs_dim1, vs_offset, i__1, i__2, i__3, i__4;
    /* Builtin functions */
    double sqrt(doublereal);
    /* Local variables */
    static integer ibal, maxb;
    static doublereal anrm;
    static integer ierr, itau, iwrk, i__, k, icond, ieval;
    extern logical lsame_(char *, char *);
    extern /* Subroutine */ int zcopy_(integer *, doublecomplex *, integer *, 
	    doublecomplex *, integer *), dlabad_(doublereal *, doublereal *);
    static logical scalea;
    extern doublereal dlamch_(char *);
    static doublereal cscale;
    extern /* Subroutine */ int dlascl_(char *, integer *, integer *, 
	    doublereal *, doublereal *, integer *, integer *, doublereal *, 
	    integer *, integer *), zgebak_(char *, char *, integer *, 
	    integer *, integer *, doublereal *, integer *, doublecomplex *, 
	    integer *, integer *), zgebal_(char *, integer *, 
	    doublecomplex *, integer *, integer *, integer *, doublereal *, 
	    integer *), xerbla_(char *, integer *);
    extern integer ilaenv_(integer *, char *, char *, integer *, integer *, 
	    integer *, integer *, ftnlen, ftnlen);
    extern doublereal zlange_(char *, integer *, integer *, doublecomplex *, 
	    integer *, doublereal *);
    static doublereal bignum;
    extern /* Subroutine */ int zgehrd_(integer *, integer *, integer *, 
	    doublecomplex *, integer *, doublecomplex *, doublecomplex *, 
	    integer *, integer *), zlascl_(char *, integer *, integer *, 
	    doublereal *, doublereal *, integer *, integer *, doublecomplex *,
	     integer *, integer *);
    static logical wantsb, wantse;
    extern /* Subroutine */ int zlacpy_(char *, integer *, integer *, 
	    doublecomplex *, integer *, doublecomplex *, integer *);
    static integer minwrk, maxwrk;
    static logical wantsn;
    static doublereal smlnum;
    extern /* Subroutine */ int zhseqr_(char *, char *, integer *, integer *, 
	    integer *, doublecomplex *, integer *, doublecomplex *, 
	    doublecomplex *, integer *, doublecomplex *, integer *, integer *);
    static integer hswork;
    extern /* Subroutine */ int zunghr_(integer *, integer *, integer *, 
	    doublecomplex *, integer *, doublecomplex *, doublecomplex *, 
	    integer *, integer *);
    static logical wantst, wantsv, wantvs;
    extern /* Subroutine */ int ztrsen_(char *, char *, logical *, integer *, 
	    doublecomplex *, integer *, doublecomplex *, integer *, 
	    doublecomplex *, integer *, doublereal *, doublereal *, 
	    doublecomplex *, integer *, integer *);
    static integer ihi, ilo;
    static doublereal dum[1], eps;


    a_dim1 = *lda;
    a_offset = 1 + a_dim1 * 1;
    a -= a_offset;
    --w;
    vs_dim1 = *ldvs;
    vs_offset = 1 + vs_dim1 * 1;
    vs -= vs_offset;
    --work;
    --rwork;
    --bwork;

    /* Function Body */
    *info = 0;
    wantvs = lsame_(jobvs, "V");
    wantst = lsame_(sort, "S");
    wantsn = lsame_(sense, "N");
    wantse = lsame_(sense, "E");
    wantsv = lsame_(sense, "V");
    wantsb = lsame_(sense, "B");
    if (! wantvs && ! lsame_(jobvs, "N")) {
	*info = -1;
    } else if (! wantst && ! lsame_(sort, "N")) {
	*info = -2;
    } else if (! (wantsn || wantse || wantsv || wantsb) || ! wantst && ! 
	    wantsn) {
	*info = -4;
    } else if (*n < 0) {
	*info = -5;
    } else if (*lda < max(1,*n)) {
	*info = -7;
    } else if (*ldvs < 1 || wantvs && *ldvs < *n) {
	*info = -11;
    }

/*     Compute workspace   
        (Note: Comments in the code beginning "Workspace:" describe the   
         minimal amount of real workspace needed at that point in the   
         code, as well as the preferred amount for good performance.   
         CWorkspace refers to complex workspace, and RWorkspace to real   
         workspace. NB refers to the optimal block size for the   
         immediately following subroutine, as returned by ILAENV.   
         HSWORK refers to the workspace preferred by ZHSEQR, as   
         calculated below. HSWORK is computed assuming ILO=1 and IHI=N,   
         the worst case.   
         If SENSE = 'E', 'V' or 'B', then the amount of workspace needed   
         depends on SDIM, which is computed by the routine ZTRSEN later   
         in the code.) */

    minwrk = 1;
    if (*info == 0 && *lwork >= 1) {
	maxwrk = *n + *n * ilaenv_(&c__1, "ZGEHRD", " ", n, &c__1, n, &c__0, (
		ftnlen)6, (ftnlen)1);
/* Computing MAX */
	i__1 = 1, i__2 = *n << 1;
	minwrk = max(i__1,i__2);
	if (! wantvs) {
/* Computing MAX */
	    i__1 = ilaenv_(&c__8, "ZHSEQR", "SN", n, &c__1, n, &c_n1, (ftnlen)
		    6, (ftnlen)2);
	    maxb = max(i__1,2);
/* Computing MIN   
   Computing MAX */
	    i__3 = 2, i__4 = ilaenv_(&c__4, "ZHSEQR", "SN", n, &c__1, n, &
		    c_n1, (ftnlen)6, (ftnlen)2);
	    i__1 = min(maxb,*n), i__2 = max(i__3,i__4);
	    k = min(i__1,i__2);
/* Computing MAX */
	    i__1 = k * (k + 2), i__2 = *n << 1;
	    hswork = max(i__1,i__2);
/* Computing MAX */
	    i__1 = max(maxwrk,hswork);
	    maxwrk = max(i__1,1);
	} else {
/* Computing MAX */
	    i__1 = maxwrk, i__2 = *n + (*n - 1) * ilaenv_(&c__1, "ZUNGHR", 
		    " ", n, &c__1, n, &c_n1, (ftnlen)6, (ftnlen)1);
	    maxwrk = max(i__1,i__2);
/* Computing MAX */
	    i__1 = ilaenv_(&c__8, "ZHSEQR", "SV", n, &c__1, n, &c_n1, (ftnlen)
		    6, (ftnlen)2);
	    maxb = max(i__1,2);
/* Computing MIN   
   Computing MAX */
	    i__3 = 2, i__4 = ilaenv_(&c__4, "ZHSEQR", "SV", n, &c__1, n, &
		    c_n1, (ftnlen)6, (ftnlen)2);
	    i__1 = min(maxb,*n), i__2 = max(i__3,i__4);
	    k = min(i__1,i__2);
/* Computing MAX */
	    i__1 = k * (k + 2), i__2 = *n << 1;
	    hswork = max(i__1,i__2);
/* Computing MAX */
	    i__1 = max(maxwrk,hswork);
	    maxwrk = max(i__1,1);
	}
	work[1].r = (doublereal) maxwrk, work[1].i = 0.;
    }
    if (*lwork < minwrk) {
	*info = -15;
    }
    if (*info != 0) {
	i__1 = -(*info);
	xerbla_("ZGEESX", &i__1);
	return 0;
    }

/*     Quick return if possible */

    if (*n == 0) {
	*sdim = 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 = zlange_("M", n, n, &a[a_offset], lda, dum);
    scalea = FALSE_;
    if (anrm > 0. && anrm < smlnum) {
	scalea = TRUE_;
	cscale = smlnum;
    } else if (anrm > bignum) {
	scalea = TRUE_;
	cscale = bignum;
    }
    if (scalea) {
	zlascl_("G", &c__0, &c__0, &anrm, &cscale, n, n, &a[a_offset], lda, &
		ierr);
    }


/*     Permute the matrix to make it more nearly triangular   
       (CWorkspace: none)   
       (RWorkspace: need N) */

    ibal = 1;
    zgebal_("P", n, &a[a_offset], lda, &ilo, &ihi, &rwork[ibal], &ierr);

/*     Reduce to upper Hessenberg form   
       (CWorkspace: need 2*N, prefer N+N*NB)   
       (RWorkspace: none) */

    itau = 1;
    iwrk = *n + itau;
    i__1 = *lwork - iwrk + 1;
    zgehrd_(n, &ilo, &ihi, &a[a_offset], lda, &work[itau], &work[iwrk], &i__1,
	     &ierr);

    if (wantvs) {

/*        Copy Householder vectors to VS */

	zlacpy_("L", n, n, &a[a_offset], lda, &vs[vs_offset], ldvs)
		;

/*        Generate unitary matrix in VS   
          (CWorkspace: need 2*N-1, prefer N+(N-1)*NB)   
          (RWorkspace: none) */

	i__1 = *lwork - iwrk + 1;
	zunghr_(n, &ilo, &ihi, &vs[vs_offset], ldvs, &work[itau], &work[iwrk],
		 &i__1, &ierr);
    }

    *sdim = 0;

/*     Perform QR iteration, accumulating Schur vectors in VS if desired   
       (CWorkspace: need 1, prefer HSWORK (see comments) )   
       (RWorkspace: none) */

    iwrk = itau;
    i__1 = *lwork - iwrk + 1;
    zhseqr_("S", jobvs, n, &ilo, &ihi, &a[a_offset], lda, &w[1], &vs[
	    vs_offset], ldvs, &work[iwrk], &i__1, &ieval);
    if (ieval > 0) {
	*info = ieval;
    }

/*     Sort eigenvalues if desired */

    if (wantst && *info == 0) {
	if (scalea) {
	    zlascl_("G", &c__0, &c__0, &cscale, &anrm, n, &c__1, &w[1], n, &
		    ierr);
	}
	i__1 = *n;
	for (i__ = 1; i__ <= i__1; ++i__) {
	    bwork[i__] = (*select)(&w[i__]);
/* L10: */
	}

/*        Reorder eigenvalues, transform Schur vectors, and compute   
          reciprocal condition numbers   
          (CWorkspace: if SENSE is not 'N', need 2*SDIM*(N-SDIM)   
                       otherwise, need none )   
          (RWorkspace: none) */

	i__1 = *lwork - iwrk + 1;
	ztrsen_(sense, jobvs, &bwork[1], n, &a[a_offset], lda, &vs[vs_offset],
		 ldvs, &w[1], sdim, rconde, rcondv, &work[iwrk], &i__1, &
		icond);
	if (! wantsn) {
/* Computing MAX */
	    i__1 = maxwrk, i__2 = (*sdim << 1) * (*n - *sdim);
	    maxwrk = max(i__1,i__2);
	}
	if (icond == -14) {

/*           Not enough complex workspace */

	    *info = -15;
	}
    }

    if (wantvs) {

/*        Undo balancing   
          (CWorkspace: none)   
          (RWorkspace: need N) */

	zgebak_("P", "R", n, &ilo, &ihi, &rwork[ibal], n, &vs[vs_offset], 
		ldvs, &ierr);
    }

    if (scalea) {

/*        Undo scaling for the Schur form of A */

	zlascl_("U", &c__0, &c__0, &cscale, &anrm, n, n, &a[a_offset], lda, &
		ierr);
	i__1 = *lda + 1;
	zcopy_(n, &a[a_offset], &i__1, &w[1], &c__1);
	if ((wantsv || wantsb) && *info == 0) {
	    dum[0] = *rcondv;
	    dlascl_("G", &c__0, &c__0, &cscale, &anrm, &c__1, &c__1, dum, &
		    c__1, &ierr);
	    *rcondv = dum[0];
	}
    }

    work[1].r = (doublereal) maxwrk, work[1].i = 0.;
    return 0;

/*     End of ZGEESX */

} /* zgeesx_ */
示例#13
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_ */
示例#14
0
/* Subroutine */ int zggevx_(char *balanc, char *jobvl, char *jobvr, char *
	sense, integer *n, doublecomplex *a, integer *lda, doublecomplex *b, 
	integer *ldb, doublecomplex *alpha, doublecomplex *beta, 
	doublecomplex *vl, integer *ldvl, doublecomplex *vr, integer *ldvr, 
	integer *ilo, integer *ihi, doublereal *lscale, doublereal *rscale, 
	doublereal *abnrm, doublereal *bbnrm, doublereal *rconde, doublereal *
	rcondv, doublecomplex *work, integer *lwork, doublereal *rwork, 
	integer *iwork, logical *bwork, integer *info)
{
    /* 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;

    /* Local variables */
    integer i__, j, m, jc, in, jr;
    doublereal eps;
    logical ilv;
    doublereal anrm, bnrm;
    integer ierr, itau;
    doublereal temp;
    logical ilvl, ilvr;
    integer iwrk, iwrk1;
    integer icols;
    logical noscl;
    integer irows;
    logical ilascl, ilbscl;
    logical ldumma[1];
    char chtemp[1];
    doublereal bignum;
    integer ijobvl;
    integer ijobvr;
    logical wantsb;
    doublereal anrmto;
    logical wantse;
    doublereal bnrmto;
    integer minwrk;
    integer maxwrk;
    logical wantsn;
    doublereal smlnum;
    logical lquery, wantsv;

/*  -- LAPACK driver routine (version 3.2) -- */
/*     November 2006 */

/*  Purpose */
/*  ======= */

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

/*  Optionally, it also computes a balancing transformation to improve */
/*  the conditioning of the eigenvalues and eigenvectors (ILO, IHI, */
/*  LSCALE, RSCALE, ABNRM, and BBNRM), reciprocal condition numbers for */
/*  the eigenvalues (RCONDE), and reciprocal condition numbers for the */
/*  right eigenvectors (RCONDV). */

/*  A generalized eigenvalue for a pair of matrices (A,B) is a scalar */
/*  lambda or a ratio alpha/beta = lambda, such that A - lambda*B is */
/*  singular. It is usually represented as the pair (alpha,beta), as */
/*  there is a reasonable interpretation for beta=0, and even for both */
/*  being zero. */

/*  The right eigenvector v(j) corresponding to the eigenvalue lambda(j) */
/*  of (A,B) satisfies */
/*                   A * v(j) = lambda(j) * B * v(j) . */
/*  The left eigenvector u(j) corresponding to the eigenvalue lambda(j) */
/*  of (A,B) satisfies */
/*                   u(j)**H * A  = lambda(j) * u(j)**H * B. */
/*  where u(j)**H is the conjugate-transpose of u(j). */

/*  Arguments */
/*  ========= */

/*  BALANC  (input) CHARACTER*1 */
/*          Specifies the balance option to be performed: */
/*          = 'N':  do not diagonally scale or permute; */
/*          = 'P':  permute only; */
/*          = 'S':  scale only; */
/*          = 'B':  both permute and scale. */
/*          Computed reciprocal condition numbers will be for the */
/*          matrices after permuting and/or balancing. Permuting does */
/*          not change condition numbers (in exact arithmetic), but */
/*          balancing does. */

/*  JOBVL   (input) CHARACTER*1 */
/*          = 'N':  do not compute the left generalized eigenvectors; */
/*          = 'V':  compute the left generalized eigenvectors. */

/*  JOBVR   (input) CHARACTER*1 */
/*          = 'N':  do not compute the right generalized eigenvectors; */
/*          = 'V':  compute the right generalized eigenvectors. */

/*  SENSE   (input) CHARACTER*1 */
/*          Determines which reciprocal condition numbers are computed. */
/*          = 'N': none are computed; */
/*          = 'E': computed for eigenvalues only; */
/*          = 'V': computed for eigenvectors only; */
/*          = 'B': computed for eigenvalues and eigenvectors. */

/*  N       (input) INTEGER */
/*          The order of the matrices A, B, VL, and VR.  N >= 0. */

/*  A       (input/output) COMPLEX*16 array, dimension (LDA, N) */
/*          On entry, the matrix A in the pair (A,B). */
/*          On exit, A has been overwritten. If JOBVL='V' or JOBVR='V' */
/*          or both, then A contains the first part of the complex Schur */
/*          form of the "balanced" versions of the input A and B. */

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

/*  B       (input/output) COMPLEX*16 array, dimension (LDB, N) */
/*          On entry, the matrix B in the pair (A,B). */
/*          On exit, B has been overwritten. If JOBVL='V' or JOBVR='V' */
/*          or both, then B contains the second part of the complex */
/*          Schur form of the "balanced" versions of the input A and B. */

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

/*  ALPHA   (output) COMPLEX*16 array, dimension (N) */
/*  BETA    (output) COMPLEX*16 array, dimension (N) */
/*          eigenvalues. */

/*          Note: the quotient ALPHA(j)/BETA(j) ) may easily over- or */
/*          underflow, and BETA(j) may even be zero.  Thus, the user */
/*          should avoid naively computing the ratio ALPHA/BETA. */
/*          However, ALPHA will be always less than and usually */
/*          comparable with norm(A) in magnitude, and BETA always less */
/*          than and usually comparable with norm(B). */

/*  VL      (output) COMPLEX*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. */

/*  ILO     (output) INTEGER */
/*  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 */
/*          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 */
/*          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 */
/*          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 eigenvalues, stored in consecutive elements of the array. */
/*          If SENSE = 'N' or 'V', RCONDE is not referenced. */

/*  RCONDV  (output) DOUBLE PRECISION array, dimension (N) */
/*          If JOB = 'V' or 'B', the estimated reciprocal condition */
/*          numbers of the eigenvectors, stored in consecutive elements */
/*          of the array. If the eigenvalues cannot be reordered to */
/*          compute RCONDV(j), RCONDV(j) is set to 0; this can only occur */
/*          when the true value would be very small anyway. */
/*          If SENSE = 'N' or 'E', RCONDV is not referenced. */

/*  WORK    (workspace/output) COMPLEX*16 array, dimension (MAX(1,LWORK)) */
/*          On exit, if INFO = 0, WORK(1) returns the optimal LWORK. */

/*  LWORK   (input) INTEGER */
/*          The dimension of the array WORK. LWORK >= max(1,2*N). */
/*          If SENSE = 'E', LWORK >= max(1,4*N). */
/*          If SENSE = 'V' or 'B', LWORK >= max(1,2*N*N+2*N). */

/*          If LWORK = -1, then a workspace query is assumed; the routine */
/*          only calculates the optimal size of the WORK array, returns */
/*          this value as the first entry of the WORK array, and no error */
/*          message related to LWORK is issued by XERBLA. */

/*  RWORK   (workspace) REAL array, dimension (lrwork) */
/*          lrwork must be at least max(1,6*N) if BALANC = 'S' or 'B', */
/*          and at least max(1,2*N) otherwise. */
/*          Real workspace. */

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

/*  BWORK   (workspace) LOGICAL array, dimension (N) */
/*          If SENSE = 'N', BWORK is not referenced. */

/*  INFO    (output) INTEGER */
/*          = 0:  successful exit */
/*          < 0:  if INFO = -i, the i-th argument had an illegal value. */
/*                The QZ iteration failed.  No eigenvectors have been */
/*                calculated, but ALPHA(j) and BETA(j) should be correct */
/*          > N:  =N+1: other than QZ iteration failed in ZHGEQZ. */
/*                =N+2: error return from ZTGEVC. */

/*  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 */
    a_dim1 = *lda;
    a_offset = 1 + a_dim1;
    a -= a_offset;
    b_dim1 = *ldb;
    b_offset = 1 + b_dim1;
    b -= b_offset;
    --alpha;
    --beta;
    vl_dim1 = *ldvl;
    vl_offset = 1 + vl_dim1;
    vl -= vl_offset;
    vr_dim1 = *ldvr;
    vr_offset = 1 + vr_dim1;
    vr -= vr_offset;
    --lscale;
    --rscale;
    --rconde;
    --rcondv;
    --work;
    --rwork;
    --iwork;
    --bwork;

    /* Function Body */
    if (lsame_(jobvl, "N")) {
	ijobvl = 1;
	ilvl = FALSE_;
    } else if (lsame_(jobvl, "V")) {
	ijobvl = 2;
	ilvl = TRUE_;
    } else {
	ijobvl = -1;
	ilvl = FALSE_;
    }

    if (lsame_(jobvr, "N")) {
	ijobvr = 1;
	ilvr = FALSE_;
    } else if (lsame_(jobvr, "V")) {
	ijobvr = 2;
	ilvr = TRUE_;
    } else {
	ijobvr = -1;
	ilvr = FALSE_;
    }
    ilv = ilvl || ilvr;

    noscl = lsame_(balanc, "N") || lsame_(balanc, "P");
    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 (! (noscl || lsame_(balanc, "S") || lsame_(
	    balanc, "B"))) {
	*info = -1;
    } else if (ijobvl <= 0) {
	*info = -2;
    } else if (ijobvr <= 0) {
	*info = -3;
    } else if (! (wantsn || wantse || wantsb || wantsv)) {
	*info = -4;
    } else if (*n < 0) {
	*info = -5;
    } else if (*lda < max(1,*n)) {
	*info = -7;
    } else if (*ldb < max(1,*n)) {
	*info = -9;
    } else if (*ldvl < 1 || ilvl && *ldvl < *n) {
	*info = -13;
    } else if (*ldvr < 1 || ilvr && *ldvr < *n) {
	*info = -15;
    }

/*     Compute workspace */
/*      (Note: Comments in the code beginning "Workspace:" describe the */
/*       minimal amount of workspace needed at that point in the code, */
/*       as well as the preferred amount for good performance. */
/*       NB refers to the optimal block size for the immediately */
/*       following subroutine, as returned by ILAENV. The workspace is */
/*       computed assuming ILO = 1 and IHI = N, the worst case.) */

    if (*info == 0) {
	if (*n == 0) {
	    minwrk = 1;
	    maxwrk = 1;
	} else {
	    minwrk = *n << 1;
	    if (wantse) {
		minwrk = *n << 2;
	    } else if (wantsv || wantsb) {
		minwrk = (*n << 1) * (*n + 1);
	    }
	    maxwrk = minwrk;
/* Computing MAX */
	    i__1 = maxwrk, i__2 = *n + *n * ilaenv_(&c__1, "ZGEQRF", " ", n, &
		    c__1, n, &c__0);
	    maxwrk = max(i__1,i__2);
/* Computing MAX */
	    i__1 = maxwrk, i__2 = *n + *n * ilaenv_(&c__1, "ZUNMQR", " ", n, &
		    c__1, n, &c__0);
	    maxwrk = max(i__1,i__2);
	    if (ilvl) {
/* Computing MAX */
		i__1 = maxwrk, i__2 = *n + *n * ilaenv_(&c__1, "ZUNGQR", 
			" ", n, &c__1, n, &c__0);
		maxwrk = max(i__1,i__2);
	    }
	}
	work[1].r = (doublereal) maxwrk, work[1].i = 0.;

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

    if (*info != 0) {
	i__1 = -(*info);
	xerbla_("ZGGEVX", &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 = 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 and/or balance the matrix pair (A,B) */
/*     (Real Workspace: need 6*N if BALANC = 'S' or 'B', 1 otherwise) */

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

/*     Compute ABNRM and BBNRM */

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

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

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

    irows = *ihi + 1 - *ilo;
    if (ilv || ! wantsn) {
	icols = *n + 1 - *ilo;
    } else {
	icols = irows;
    }
    itau = 1;
    iwrk = itau + irows;
    i__1 = *lwork + 1 - iwrk;
    zgeqrf_(&irows, &icols, &b[*ilo + *ilo * b_dim1], ldb, &work[itau], &work[
	    iwrk], &i__1, &ierr);

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

    i__1 = *lwork + 1 - iwrk;
    zunmqr_("L", "C", &irows, &icols, &irows, &b[*ilo + *ilo * b_dim1], ldb, &
	    work[itau], &a[*ilo + *ilo * a_dim1], lda, &work[iwrk], &i__1, &
	    ierr);

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

    if (ilvl) {
	zlaset_("Full", n, n, &c_b1, &c_b2, &vl[vl_offset], ldvl);
	if (irows > 1) {
	    i__1 = irows - 1;
	    i__2 = irows - 1;
	    zlacpy_("L", &i__1, &i__2, &b[*ilo + 1 + *ilo * b_dim1], ldb, &vl[
		    *ilo + 1 + *ilo * vl_dim1], ldvl);
	}
	i__1 = *lwork + 1 - iwrk;
	zungqr_(&irows, &irows, &irows, &vl[*ilo + *ilo * vl_dim1], ldvl, &
		work[itau], &work[iwrk], &i__1, &ierr);
    }

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

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

    if (ilv || ! wantsn) {

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

	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[*ilo + *ilo * a_dim1], 
		lda, &b[*ilo + *ilo * b_dim1], ldb, &vl[vl_offset], ldvl, &vr[
		vr_offset], ldvr, &ierr);
    }

/*     Perform QZ algorithm (Compute eigenvalues, and optionally, the */
/*     Schur forms and Schur vectors) */
/*     (Complex Workspace: need N) */
/*     (Real Workspace: need N) */

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

    i__1 = *lwork + 1 - iwrk;
    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[1], &ierr);
    if (ierr != 0) {
	if (ierr > 0 && ierr <= *n) {
	    *info = ierr;
	} else if (ierr > *n && ierr <= *n << 1) {
	    *info = ierr - *n;
	} else {
	    *info = *n + 1;
	}
	goto L90;
    }

/*     Compute Eigenvectors and estimate condition numbers if desired */
/*     ZTGEVC: (Complex Workspace: need 2*N ) */
/*             (Real Workspace:    need 2*N ) */
/*     ZTGSNA: (Complex Workspace: need 2*N*N if SENSE='V' or 'B') */
/*             (Integer Workspace: need N+2 ) */

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

	    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[1], &ierr);
	    if (ierr != 0) {
		*info = *n + 2;
		goto L90;
	    }
	}

	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 */
/*           re-calculate eigenvectors and estimate the condition numbers */
/*           one at a time. */

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

		i__2 = *n;
		for (j = 1; j <= i__2; ++j) {
		    bwork[j] = FALSE_;
		}
		bwork[i__] = TRUE_;

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

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

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

	    }
	}
    }

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

    if (ilvl) {
	zggbak_(balanc, "L", n, ilo, ihi, &lscale[1], &rscale[1], n, &vl[
		vl_offset], ldvl, &ierr);

	i__1 = *n;
	for (jc = 1; jc <= i__1; ++jc) {
	    temp = 0.;
	    i__2 = *n;
	    for (jr = 1; jr <= i__2; ++jr) {
/* Computing MAX */
		i__3 = jr + jc * vl_dim1;
		d__3 = temp, d__4 = (d__1 = vl[i__3].r, abs(d__1)) + (d__2 = 
			d_imag(&vl[jr + jc * vl_dim1]), abs(d__2));
		temp = max(d__3,d__4);
	    }
	    if (temp < smlnum) {
		goto L50;
	    }
	    temp = 1. / temp;
	    i__2 = *n;
	    for (jr = 1; jr <= i__2; ++jr) {
		i__3 = jr + jc * vl_dim1;
		i__4 = jr + jc * vl_dim1;
		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;
	    }
L50:
	    ;
	}
    }

    if (ilvr) {
	zggbak_(balanc, "R", n, ilo, ihi, &lscale[1], &rscale[1], n, &vr[
		vr_offset], ldvr, &ierr);
	i__1 = *n;
	for (jc = 1; jc <= i__1; ++jc) {
	    temp = 0.;
	    i__2 = *n;
	    for (jr = 1; jr <= i__2; ++jr) {
/* Computing MAX */
		i__3 = jr + jc * vr_dim1;
		d__3 = temp, d__4 = (d__1 = vr[i__3].r, abs(d__1)) + (d__2 = 
			d_imag(&vr[jr + jc * vr_dim1]), abs(d__2));
		temp = max(d__3,d__4);
	    }
	    if (temp < smlnum) {
		goto L80;
	    }
	    temp = 1. / temp;
	    i__2 = *n;
	    for (jr = 1; jr <= i__2; ++jr) {
		i__3 = jr + jc * vr_dim1;
		i__4 = jr + jc * vr_dim1;
		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;
	    }
L80:
	    ;
	}
    }

/*     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);
    }

L90:
    work[1].r = (doublereal) maxwrk, work[1].i = 0.;

    return 0;

/*     End of ZGGEVX */

} /* zggevx_ */
示例#15
0
/* Subroutine */ int dgels_(char *trans, integer *m, integer *n, integer *
	nrhs, doublereal *a, integer *lda, doublereal *b, integer *ldb, 
	doublereal *work, integer *lwork, integer *info)
{
    /* System generated locals */
    integer a_dim1, a_offset, b_dim1, b_offset, i__1, i__2;

    /* Local variables */
    integer i__, j, nb, mn;
    doublereal anrm, bnrm;
    integer brow;
    logical tpsd;
    integer iascl, ibscl;
    extern logical lsame_(char *, char *);
    integer wsize;
    doublereal rwork[1];
    extern /* Subroutine */ int dlabad_(doublereal *, doublereal *);
    extern doublereal dlamch_(char *), dlange_(char *, integer *, 
	    integer *, doublereal *, integer *, doublereal *);
    extern /* Subroutine */ int dgelqf_(integer *, integer *, doublereal *, 
	    integer *, doublereal *, doublereal *, integer *, integer *), 
	    dlascl_(char *, integer *, integer *, doublereal *, doublereal *, 
	    integer *, integer *, doublereal *, integer *, integer *),
	     dgeqrf_(integer *, integer *, doublereal *, integer *, 
	    doublereal *, doublereal *, integer *, integer *), dlaset_(char *, 
	     integer *, integer *, doublereal *, doublereal *, doublereal *, 
	    integer *), xerbla_(char *, integer *);
    extern integer ilaenv_(integer *, char *, char *, integer *, integer *, 
	    integer *, integer *);
    integer scllen;
    doublereal bignum;
    extern /* Subroutine */ int dormlq_(char *, char *, integer *, integer *, 
	    integer *, doublereal *, integer *, doublereal *, doublereal *, 
	    integer *, doublereal *, integer *, integer *), 
	    dormqr_(char *, char *, integer *, integer *, integer *, 
	    doublereal *, integer *, doublereal *, doublereal *, integer *, 
	    doublereal *, integer *, integer *);
    doublereal smlnum;
    logical lquery;
    extern /* Subroutine */ int dtrtrs_(char *, char *, char *, integer *, 
	    integer *, doublereal *, integer *, doublereal *, integer *, 
	    integer *);


/*  -- LAPACK driver routine (version 3.1) -- */
/*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/*     November 2006 */

/*     .. Scalar Arguments .. */
/*     .. */
/*     .. Array Arguments .. */
/*     .. */

/*  Purpose */
/*  ======= */

/*  DGELS solves overdetermined or underdetermined real linear systems */
/*  involving an M-by-N matrix A, or its transpose, using a QR or LQ */
/*  factorization of A.  It is assumed that A has full rank. */

/*  The following options are provided: */

/*  1. If TRANS = 'N' and m >= n:  find the least squares solution of */
/*     an overdetermined system, i.e., solve the least squares problem */
/*                  minimize || B - A*X ||. */

/*  2. If TRANS = 'N' and m < n:  find the minimum norm solution of */
/*     an underdetermined system A * X = B. */

/*  3. If TRANS = 'T' and m >= n:  find the minimum norm solution of */
/*     an undetermined system A**T * X = B. */

/*  4. If TRANS = 'T' and m < n:  find the least squares solution of */
/*     an overdetermined system, i.e., solve the least squares problem */
/*                  minimize || B - A**T * X ||. */

/*  Several right hand side vectors b and solution vectors x can be */
/*  handled in a single call; they are stored as the columns of the */
/*  M-by-NRHS right hand side matrix B and the N-by-NRHS solution */
/*  matrix X. */

/*  Arguments */
/*  ========= */

/*  TRANS   (input) CHARACTER*1 */
/*          = 'N': the linear system involves A; */
/*          = 'T': the linear system involves A**T. */

/*  M       (input) INTEGER */
/*          The number of rows of the matrix A.  M >= 0. */

/*  N       (input) INTEGER */
/*          The number of columns of the matrix A.  N >= 0. */

/*  NRHS    (input) INTEGER */
/*          The number of right hand sides, i.e., the number of */
/*          columns of the matrices B and X. NRHS >=0. */

/*  A       (input/output) DOUBLE PRECISION array, dimension (LDA,N) */
/*          On entry, the M-by-N matrix A. */
/*          On exit, */
/*            if M >= N, A is overwritten by details of its QR */
/*                       factorization as returned by DGEQRF; */
/*            if M <  N, A is overwritten by details of its LQ */
/*                       factorization as returned by DGELQF. */

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

/*  B       (input/output) DOUBLE PRECISION array, dimension (LDB,NRHS) */
/*          On entry, the matrix B of right hand side vectors, stored */
/*          columnwise; B is M-by-NRHS if TRANS = 'N', or N-by-NRHS */
/*          if TRANS = 'T'. */
/*          On exit, if INFO = 0, B is overwritten by the solution */
/*          vectors, stored columnwise: */
/*          if TRANS = 'N' and m >= n, rows 1 to n of B contain the least */
/*          squares solution vectors; the residual sum of squares for the */
/*          solution in each column is given by the sum of squares of */
/*          elements N+1 to M in that column; */
/*          if TRANS = 'N' and m < n, rows 1 to N of B contain the */
/*          minimum norm solution vectors; */
/*          if TRANS = 'T' and m >= n, rows 1 to M of B contain the */
/*          minimum norm solution vectors; */
/*          if TRANS = 'T' and m < n, rows 1 to M of B contain the */
/*          least squares solution vectors; the residual sum of squares */
/*          for the solution in each column is given by the sum of */
/*          squares of elements M+1 to N in that column. */

/*  LDB     (input) INTEGER */
/*          The leading dimension of the array B. LDB >= MAX(1,M,N). */

/*  WORK    (workspace/output) DOUBLE PRECISION array, dimension (MAX(1,LWORK)) */
/*          On exit, if INFO = 0, WORK(1) returns the optimal LWORK. */

/*  LWORK   (input) INTEGER */
/*          The dimension of the array WORK. */
/*          LWORK >= max( 1, MN + max( MN, NRHS ) ). */
/*          For optimal performance, */
/*          LWORK >= max( 1, MN + max( MN, NRHS )*NB ). */
/*          where MN = min(M,N) and NB is the optimum block size. */

/*          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 */
/*          > 0:  if INFO =  i, the i-th diagonal element of the */
/*                triangular factor of A is zero, so that A does not have */
/*                full rank; the least squares solution could not be */
/*                computed. */

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

/*     .. Parameters .. */
/*     .. */
/*     .. Local Scalars .. */
/*     .. */
/*     .. Local Arrays .. */
/*     .. */
/*     .. External Functions .. */
/*     .. */
/*     .. External Subroutines .. */
/*     .. */
/*     .. Intrinsic Functions .. */
/*     .. */
/*     .. Executable Statements .. */

/*     Test the input arguments. */

    /* Parameter adjustments */
    a_dim1 = *lda;
    a_offset = 1 + a_dim1;
    a -= a_offset;
    b_dim1 = *ldb;
    b_offset = 1 + b_dim1;
    b -= b_offset;
    --work;

    /* Function Body */
    *info = 0;
    mn = min(*m,*n);
    lquery = *lwork == -1;
    if (! (lsame_(trans, "N") || lsame_(trans, "T"))) {
	*info = -1;
    } else if (*m < 0) {
	*info = -2;
    } else if (*n < 0) {
	*info = -3;
    } else if (*nrhs < 0) {
	*info = -4;
    } else if (*lda < max(1,*m)) {
	*info = -6;
    } else /* if(complicated condition) */ {
/* Computing MAX */
	i__1 = max(1,*m);
	if (*ldb < max(i__1,*n)) {
	    *info = -8;
	} else /* if(complicated condition) */ {
/* Computing MAX */
	    i__1 = 1, i__2 = mn + max(mn,*nrhs);
	    if (*lwork < max(i__1,i__2) && ! lquery) {
		*info = -10;
	    }
	}
    }

/*     Figure out optimal block size */

    if (*info == 0 || *info == -10) {

	tpsd = TRUE_;
	if (lsame_(trans, "N")) {
	    tpsd = FALSE_;
	}

	if (*m >= *n) {
	    nb = ilaenv_(&c__1, "DGEQRF", " ", m, n, &c_n1, &c_n1);
	    if (tpsd) {
/* Computing MAX */
		i__1 = nb, i__2 = ilaenv_(&c__1, "DORMQR", "LN", m, nrhs, n, &
			c_n1);
		nb = max(i__1,i__2);
	    } else {
/* Computing MAX */
		i__1 = nb, i__2 = ilaenv_(&c__1, "DORMQR", "LT", m, nrhs, n, &
			c_n1);
		nb = max(i__1,i__2);
	    }
	} else {
	    nb = ilaenv_(&c__1, "DGELQF", " ", m, n, &c_n1, &c_n1);
	    if (tpsd) {
/* Computing MAX */
		i__1 = nb, i__2 = ilaenv_(&c__1, "DORMLQ", "LT", n, nrhs, m, &
			c_n1);
		nb = max(i__1,i__2);
	    } else {
/* Computing MAX */
		i__1 = nb, i__2 = ilaenv_(&c__1, "DORMLQ", "LN", n, nrhs, m, &
			c_n1);
		nb = max(i__1,i__2);
	    }
	}

/* Computing MAX */
	i__1 = 1, i__2 = mn + max(mn,*nrhs) * nb;
	wsize = max(i__1,i__2);
	work[1] = (doublereal) wsize;

    }

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

/*     Quick return if possible */

/* Computing MIN */
    i__1 = min(*m,*n);
    if (min(i__1,*nrhs) == 0) {
	i__1 = max(*m,*n);
	dlaset_("Full", &i__1, nrhs, &c_b33, &c_b33, &b[b_offset], ldb);
	return 0;
    }

/*     Get machine parameters */

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

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

    anrm = dlange_("M", m, n, &a[a_offset], lda, rwork);
    iascl = 0;
    if (anrm > 0. && anrm < smlnum) {

/*        Scale matrix norm up to SMLNUM */

	dlascl_("G", &c__0, &c__0, &anrm, &smlnum, m, n, &a[a_offset], lda, 
		info);
	iascl = 1;
    } else if (anrm > bignum) {

/*        Scale matrix norm down to BIGNUM */

	dlascl_("G", &c__0, &c__0, &anrm, &bignum, m, n, &a[a_offset], lda, 
		info);
	iascl = 2;
    } else if (anrm == 0.) {

/*        Matrix all zero. Return zero solution. */

	i__1 = max(*m,*n);
	dlaset_("F", &i__1, nrhs, &c_b33, &c_b33, &b[b_offset], ldb);
	goto L50;
    }

    brow = *m;
    if (tpsd) {
	brow = *n;
    }
    bnrm = dlange_("M", &brow, nrhs, &b[b_offset], ldb, rwork);
    ibscl = 0;
    if (bnrm > 0. && bnrm < smlnum) {

/*        Scale matrix norm up to SMLNUM */

	dlascl_("G", &c__0, &c__0, &bnrm, &smlnum, &brow, nrhs, &b[b_offset], 
		ldb, info);
	ibscl = 1;
    } else if (bnrm > bignum) {

/*        Scale matrix norm down to BIGNUM */

	dlascl_("G", &c__0, &c__0, &bnrm, &bignum, &brow, nrhs, &b[b_offset], 
		ldb, info);
	ibscl = 2;
    }

    if (*m >= *n) {

/*        compute QR factorization of A */

	i__1 = *lwork - mn;
	dgeqrf_(m, n, &a[a_offset], lda, &work[1], &work[mn + 1], &i__1, info)
		;

/*        workspace at least N, optimally N*NB */

	if (! tpsd) {

/*           Least-Squares Problem min || A * X - B || */

/*           B(1:M,1:NRHS) := Q' * B(1:M,1:NRHS) */

	    i__1 = *lwork - mn;
	    dormqr_("Left", "Transpose", m, nrhs, n, &a[a_offset], lda, &work[
		    1], &b[b_offset], ldb, &work[mn + 1], &i__1, info);

/*           workspace at least NRHS, optimally NRHS*NB */

/*           B(1:N,1:NRHS) := inv(R) * B(1:N,1:NRHS) */

	    dtrtrs_("Upper", "No transpose", "Non-unit", n, nrhs, &a[a_offset]
, lda, &b[b_offset], ldb, info);

	    if (*info > 0) {
		return 0;
	    }

	    scllen = *n;

	} else {

/*           Overdetermined system of equations A' * X = B */

/*           B(1:N,1:NRHS) := inv(R') * B(1:N,1:NRHS) */

	    dtrtrs_("Upper", "Transpose", "Non-unit", n, nrhs, &a[a_offset], 
		    lda, &b[b_offset], ldb, info);

	    if (*info > 0) {
		return 0;
	    }

/*           B(N+1:M,1:NRHS) = ZERO */

	    i__1 = *nrhs;
	    for (j = 1; j <= i__1; ++j) {
		i__2 = *m;
		for (i__ = *n + 1; i__ <= i__2; ++i__) {
		    b[i__ + j * b_dim1] = 0.;
/* L10: */
		}
/* L20: */
	    }

/*           B(1:M,1:NRHS) := Q(1:N,:) * B(1:N,1:NRHS) */

	    i__1 = *lwork - mn;
	    dormqr_("Left", "No transpose", m, nrhs, n, &a[a_offset], lda, &
		    work[1], &b[b_offset], ldb, &work[mn + 1], &i__1, info);

/*           workspace at least NRHS, optimally NRHS*NB */

	    scllen = *m;

	}

    } else {

/*        Compute LQ factorization of A */

	i__1 = *lwork - mn;
	dgelqf_(m, n, &a[a_offset], lda, &work[1], &work[mn + 1], &i__1, info)
		;

/*        workspace at least M, optimally M*NB. */

	if (! tpsd) {

/*           underdetermined system of equations A * X = B */

/*           B(1:M,1:NRHS) := inv(L) * B(1:M,1:NRHS) */

	    dtrtrs_("Lower", "No transpose", "Non-unit", m, nrhs, &a[a_offset]
, lda, &b[b_offset], ldb, info);

	    if (*info > 0) {
		return 0;
	    }

/*           B(M+1:N,1:NRHS) = 0 */

	    i__1 = *nrhs;
	    for (j = 1; j <= i__1; ++j) {
		i__2 = *n;
		for (i__ = *m + 1; i__ <= i__2; ++i__) {
		    b[i__ + j * b_dim1] = 0.;
/* L30: */
		}
/* L40: */
	    }

/*           B(1:N,1:NRHS) := Q(1:N,:)' * B(1:M,1:NRHS) */

	    i__1 = *lwork - mn;
	    dormlq_("Left", "Transpose", n, nrhs, m, &a[a_offset], lda, &work[
		    1], &b[b_offset], ldb, &work[mn + 1], &i__1, info);

/*           workspace at least NRHS, optimally NRHS*NB */

	    scllen = *n;

	} else {

/*           overdetermined system min || A' * X - B || */

/*           B(1:N,1:NRHS) := Q * B(1:N,1:NRHS) */

	    i__1 = *lwork - mn;
	    dormlq_("Left", "No transpose", n, nrhs, m, &a[a_offset], lda, &
		    work[1], &b[b_offset], ldb, &work[mn + 1], &i__1, info);

/*           workspace at least NRHS, optimally NRHS*NB */

/*           B(1:M,1:NRHS) := inv(L') * B(1:M,1:NRHS) */

	    dtrtrs_("Lower", "Transpose", "Non-unit", m, nrhs, &a[a_offset], 
		    lda, &b[b_offset], ldb, info);

	    if (*info > 0) {
		return 0;
	    }

	    scllen = *m;

	}

    }

/*     Undo scaling */

    if (iascl == 1) {
	dlascl_("G", &c__0, &c__0, &anrm, &smlnum, &scllen, nrhs, &b[b_offset]
, ldb, info);
    } else if (iascl == 2) {
	dlascl_("G", &c__0, &c__0, &anrm, &bignum, &scllen, nrhs, &b[b_offset]
, ldb, info);
    }
    if (ibscl == 1) {
	dlascl_("G", &c__0, &c__0, &smlnum, &bnrm, &scllen, nrhs, &b[b_offset]
, ldb, info);
    } else if (ibscl == 2) {
	dlascl_("G", &c__0, &c__0, &bignum, &bnrm, &scllen, nrhs, &b[b_offset]
, ldb, info);
    }

L50:
    work[1] = (doublereal) wsize;

    return 0;

/*     End of DGELS */

} /* dgels_ */
示例#16
0
/* Subroutine */ int zgetc2_(integer *n, doublecomplex *a, integer *lda, 
	integer *ipiv, integer *jpiv, integer *info)
{
    /* System generated locals */
    integer a_dim1, a_offset, i__1, i__2, i__3;
    doublereal d__1;
    doublecomplex z__1;

    /* Local variables */
    integer i__, j, ip, jp;
    doublereal eps;
    integer ipv, jpv;
    doublereal smin, xmax;
    doublereal bignum, smlnum;

/*  -- LAPACK auxiliary routine (version 3.2) -- */
/*     November 2006 */

/*  Purpose */
/*  ======= */

/*  ZGETC2 computes an LU factorization, using complete pivoting, of the */
/*  n-by-n matrix A. The factorization has the form A = P * L * U * Q, */
/*  where P and Q are permutation matrices, L is lower triangular with */
/*  unit diagonal elements and U is upper triangular. */

/*  This is a level 1 BLAS version of the algorithm. */

/*  Arguments */
/*  ========= */

/*  N       (input) INTEGER */
/*          The order of the matrix A. N >= 0. */

/*  A       (input/output) COMPLEX*16 array, dimension (LDA, N) */
/*          On entry, the n-by-n matrix to be factored. */
/*          On exit, the factors L and U from the factorization */
/*          A = P*L*U*Q; the unit diagonal elements of L are not stored. */
/*          If U(k, k) appears to be less than SMIN, U(k, k) is given the */
/*          value of SMIN, giving a nonsingular perturbed system. */

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

/*  IPIV    (output) INTEGER array, dimension (N). */
/*          The pivot indices; for 1 <= i <= N, row i of the */
/*          matrix has been interchanged with row IPIV(i). */

/*  JPIV    (output) INTEGER array, dimension (N). */
/*          The pivot indices; for 1 <= j <= N, column j of the */
/*          matrix has been interchanged with column JPIV(j). */

/*  INFO    (output) INTEGER */
/*           = 0: successful exit */
/*           > 0: if INFO = k, U(k, k) is likely to produce overflow if */
/*                one tries to solve for x in Ax = b. So U is perturbed */
/*                to avoid the overflow. */

/*  Further Details */
/*  =============== */

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

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

/*     Set constants to control overflow */

    /* Parameter adjustments */
    a_dim1 = *lda;
    a_offset = 1 + a_dim1;
    a -= a_offset;
    --ipiv;
    --jpiv;

    /* Function Body */
    *info = 0;
    eps = dlamch_("P");
    smlnum = dlamch_("S") / eps;
    bignum = 1. / smlnum;
    dlabad_(&smlnum, &bignum);

/*     Factorize A using complete pivoting. */
/*     Set pivots less than SMIN to SMIN */

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

/*        Find max element in matrix A */

	xmax = 0.;
	i__2 = *n;
	for (ip = i__; ip <= i__2; ++ip) {
	    i__3 = *n;
	    for (jp = i__; jp <= i__3; ++jp) {
		if (z_abs(&a[ip + jp * a_dim1]) >= xmax) {
		    xmax = z_abs(&a[ip + jp * a_dim1]);
		    ipv = ip;
		    jpv = jp;
		}
	    }
	}
	if (i__ == 1) {
/* Computing MAX */
	    d__1 = eps * xmax;
	    smin = max(d__1,smlnum);
	}

/*        Swap rows */

	if (ipv != i__) {
	    zswap_(n, &a[ipv + a_dim1], lda, &a[i__ + a_dim1], lda);
	}
	ipiv[i__] = ipv;

/*        Swap columns */

	if (jpv != i__) {
	    zswap_(n, &a[jpv * a_dim1 + 1], &c__1, &a[i__ * a_dim1 + 1], &
		    c__1);
	}
	jpiv[i__] = jpv;

/*        Check for singularity */

	if (z_abs(&a[i__ + i__ * a_dim1]) < smin) {
	    *info = i__;
	    i__2 = i__ + i__ * a_dim1;
	    z__1.r = smin, z__1.i = 0.;
	    a[i__2].r = z__1.r, a[i__2].i = z__1.i;
	}
	i__2 = *n;
	for (j = i__ + 1; j <= i__2; ++j) {
	    i__3 = j + i__ * a_dim1;
	    z_div(&z__1, &a[j + i__ * a_dim1], &a[i__ + i__ * a_dim1]);
	    a[i__3].r = z__1.r, a[i__3].i = z__1.i;
	}
	i__2 = *n - i__;
	i__3 = *n - i__;
	zgeru_(&i__2, &i__3, &c_b10, &a[i__ + 1 + i__ * a_dim1], &c__1, &a[
		i__ + (i__ + 1) * a_dim1], lda, &a[i__ + 1 + (i__ + 1) * 
		a_dim1], lda);
    }

    if (z_abs(&a[*n + *n * a_dim1]) < smin) {
	*info = *n;
	i__1 = *n + *n * a_dim1;
	z__1.r = smin, z__1.i = 0.;
	a[i__1].r = z__1.r, a[i__1].i = z__1.i;
    }
    return 0;

/*     End of ZGETC2 */

} /* zgetc2_ */
示例#17
0
/* Subroutine */ int dgetc2_(integer *n, doublereal *a, integer *lda, integer
                             *ipiv, integer *jpiv, integer *info)
{
    /* System generated locals */
    integer a_dim1, a_offset, i__1, i__2, i__3;
    doublereal d__1;

    /* Local variables */
    static integer i__, j, ip, jp;
    static doublereal eps;
    static integer ipv, jpv;
    extern /* Subroutine */ int dger_(integer *, integer *, doublereal *,
                                      doublereal *, integer *, doublereal *, integer *, doublereal *,
                                      integer *);
    static doublereal smin, xmax;
    extern /* Subroutine */ int dswap_(integer *, doublereal *, integer *,
                                       doublereal *, integer *), dlabad_(doublereal *, doublereal *);
    extern doublereal dlamch_(char *, ftnlen);
    static doublereal bignum, smlnum;


    /*  -- LAPACK auxiliary routine (version 3.0) -- */
    /*     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., */
    /*     Courant Institute, Argonne National Lab, and Rice University */
    /*     June 30, 1999 */

    /*     .. Scalar Arguments .. */
    /*     .. */
    /*     .. Array Arguments .. */
    /*     .. */

    /*  Purpose */
    /*  ======= */

    /*  DGETC2 computes an LU factorization with complete pivoting of the */
    /*  n-by-n matrix A. The factorization has the form A = P * L * U * Q, */
    /*  where P and Q are permutation matrices, L is lower triangular with */
    /*  unit diagonal elements and U is upper triangular. */

    /*  This is the Level 2 BLAS algorithm. */

    /*  Arguments */
    /*  ========= */

    /*  N       (input) INTEGER */
    /*          The order of the matrix A. N >= 0. */

    /*  A       (input/output) DOUBLE PRECISION array, dimension (LDA, N) */
    /*          On entry, the n-by-n matrix A to be factored. */
    /*          On exit, the factors L and U from the factorization */
    /*          A = P*L*U*Q; the unit diagonal elements of L are not stored. */
    /*          If U(k, k) appears to be less than SMIN, U(k, k) is given the */
    /*          value of SMIN, i.e., giving a nonsingular perturbed system. */

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

    /*  IPIV    (output) INTEGER array, dimension(N). */
    /*          The pivot indices; for 1 <= i <= N, row i of the */
    /*          matrix has been interchanged with row IPIV(i). */

    /*  JPIV    (output) INTEGER array, dimension(N). */
    /*          The pivot indices; for 1 <= j <= N, column j of the */
    /*          matrix has been interchanged with column JPIV(j). */

    /*  INFO    (output) INTEGER */
    /*           = 0: successful exit */
    /*           > 0: if INFO = k, U(k, k) is likely to produce owerflow if */
    /*                we try to solve for x in Ax = b. So U is perturbed to */
    /*                avoid the overflow. */

    /*  Further Details */
    /*  =============== */

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

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

    /*     .. Parameters .. */
    /*     .. */
    /*     .. Local Scalars .. */
    /*     .. */
    /*     .. External Subroutines .. */
    /*     .. */
    /*     .. External Functions .. */
    /*     .. */
    /*     .. Intrinsic Functions .. */
    /*     .. */
    /*     .. Executable Statements .. */

    /*     Set constants to control overflow */

    /* Parameter adjustments */
    a_dim1 = *lda;
    a_offset = 1 + a_dim1;
    a -= a_offset;
    --ipiv;
    --jpiv;

    /* Function Body */
    *info = 0;
    eps = dlamch_("P", (ftnlen)1);
    smlnum = dlamch_("S", (ftnlen)1) / eps;
    bignum = 1. / smlnum;
    dlabad_(&smlnum, &bignum);

    /*     Factorize A using complete pivoting. */
    /*     Set pivots less than SMIN to SMIN. */

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

        /*        Find max element in matrix A */

        xmax = 0.;
        i__2 = *n;
        for (ip = i__; ip <= i__2; ++ip) {
            i__3 = *n;
            for (jp = i__; jp <= i__3; ++jp) {
                if ((d__1 = a[ip + jp * a_dim1], abs(d__1)) >= xmax) {
                    xmax = (d__1 = a[ip + jp * a_dim1], abs(d__1));
                    ipv = ip;
                    jpv = jp;
                }
                /* L10: */
            }
            /* L20: */
        }
        if (i__ == 1) {
            /* Computing MAX */
            d__1 = eps * xmax;
            smin = max(d__1,smlnum);
        }

        /*        Swap rows */

        if (ipv != i__) {
            dswap_(n, &a[ipv + a_dim1], lda, &a[i__ + a_dim1], lda);
        }
        ipiv[i__] = ipv;

        /*        Swap columns */

        if (jpv != i__) {
            dswap_(n, &a[jpv * a_dim1 + 1], &c__1, &a[i__ * a_dim1 + 1], &
                   c__1);
        }
        jpiv[i__] = jpv;

        /*        Check for singularity */

        if ((d__1 = a[i__ + i__ * a_dim1], abs(d__1)) < smin) {
            *info = i__;
            a[i__ + i__ * a_dim1] = smin;
        }
        i__2 = *n;
        for (j = i__ + 1; j <= i__2; ++j) {
            a[j + i__ * a_dim1] /= a[i__ + i__ * a_dim1];
            /* L30: */
        }
        i__2 = *n - i__;
        i__3 = *n - i__;
        dger_(&i__2, &i__3, &c_b10, &a[i__ + 1 + i__ * a_dim1], &c__1, &a[i__
                + (i__ + 1) * a_dim1], lda, &a[i__ + 1 + (i__ + 1) * a_dim1],
              lda);
        /* L40: */
    }

    if ((d__1 = a[*n + *n * a_dim1], abs(d__1)) < smin) {
        *info = *n;
        a[*n + *n * a_dim1] = smin;
    }

    return 0;

    /*     End of DGETC2 */

} /* dgetc2_ */
示例#18
0
/* Subroutine */ int dlahqr_(logical *wantt, logical *wantz, integer *n, 
	integer *ilo, integer *ihi, doublereal *h__, integer *ldh, doublereal 
	*wr, doublereal *wi, integer *iloz, integer *ihiz, doublereal *z__, 
	integer *ldz, integer *info)
{
    /* System generated locals */
    integer h_dim1, h_offset, z_dim1, z_offset, i__1, i__2, i__3;
    doublereal d__1, d__2, d__3, d__4;

    /* Builtin functions */
    double sqrt(doublereal);

    /* Local variables */
    integer i__, j, k, l, m;
    doublereal s, v[3];
    integer i1, i2;
    doublereal t1, t2, t3, v2, v3, aa, ab, ba, bb, h11, h12, h21, h22, cs;
    integer nh;
    doublereal sn;
    integer nr;
    doublereal tr;
    integer nz;
    doublereal det, h21s;
    integer its;
    doublereal ulp, sum, tst, rt1i, rt2i, rt1r, rt2r;
    extern /* Subroutine */ int drot_(integer *, doublereal *, integer *, 
	    doublereal *, integer *, doublereal *, doublereal *), dcopy_(
	    integer *, doublereal *, integer *, doublereal *, integer *), 
	    dlanv2_(doublereal *, doublereal *, doublereal *, doublereal *, 
	    doublereal *, doublereal *, doublereal *, doublereal *, 
	    doublereal *, doublereal *), dlabad_(doublereal *, doublereal *);
    extern doublereal dlamch_(char *);
    extern /* Subroutine */ int dlarfg_(integer *, doublereal *, doublereal *, 
	     integer *, doublereal *);
    doublereal safmin, safmax, rtdisc, smlnum;


/*  -- LAPACK auxiliary routine (version 3.1) -- */
/*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/*     November 2006 */

/*     .. Scalar Arguments .. */
/*     .. */
/*     .. Array Arguments .. */
/*     .. */

/*     Purpose */
/*     ======= */

/*     DLAHQR is an auxiliary routine called by DHSEQR to update the */
/*     eigenvalues and Schur decomposition already computed by DHSEQR, by */
/*     dealing with the Hessenberg submatrix in rows and columns ILO to */
/*     IHI. */

/*     Arguments */
/*     ========= */

/*     WANTT   (input) LOGICAL */
/*          = .TRUE. : the full Schur form T is required; */
/*          = .FALSE.: only eigenvalues are required. */

/*     WANTZ   (input) LOGICAL */
/*          = .TRUE. : the matrix of Schur vectors Z is required; */
/*          = .FALSE.: Schur vectors are not required. */

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

/*     ILO     (input) INTEGER */
/*     IHI     (input) INTEGER */
/*          It is assumed that H is already upper quasi-triangular in */
/*          rows and columns IHI+1:N, and that H(ILO,ILO-1) = 0 (unless */
/*          ILO = 1). DLAHQR works primarily with the Hessenberg */
/*          submatrix in rows and columns ILO to IHI, but applies */
/*          transformations to all of H if WANTT is .TRUE.. */
/*          1 <= ILO <= max(1,IHI); IHI <= N. */

/*     H       (input/output) DOUBLE PRECISION array, dimension (LDH,N) */
/*          On entry, the upper Hessenberg matrix H. */
/*          On exit, if INFO is zero and if WANTT is .TRUE., H is upper */
/*          quasi-triangular in rows and columns ILO:IHI, with any */
/*          2-by-2 diagonal blocks in standard form. If INFO is zero */
/*          and WANTT is .FALSE., the contents of H are unspecified on */
/*          exit.  The output state of H if INFO is nonzero is given */
/*          below under the description of INFO. */

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

/*     WR      (output) DOUBLE PRECISION array, dimension (N) */
/*     WI      (output) DOUBLE PRECISION array, dimension (N) */
/*          The real and imaginary parts, respectively, of the computed */
/*          eigenvalues ILO to IHI are stored in the corresponding */
/*          elements of WR and WI. If two eigenvalues are computed as a */
/*          complex conjugate pair, they are stored in consecutive */
/*          elements of WR and WI, say the i-th and (i+1)th, with */
/*          WI(i) > 0 and WI(i+1) < 0. If WANTT is .TRUE., the */
/*          eigenvalues are stored in the same order as on the diagonal */
/*          of the Schur form returned in H, with WR(i) = H(i,i), and, if */
/*          H(i:i+1,i:i+1) is a 2-by-2 diagonal block, */
/*          WI(i) = sqrt(H(i+1,i)*H(i,i+1)) and WI(i+1) = -WI(i). */

/*     ILOZ    (input) INTEGER */
/*     IHIZ    (input) INTEGER */
/*          Specify the rows of Z to which transformations must be */
/*          applied if WANTZ is .TRUE.. */
/*          1 <= ILOZ <= ILO; IHI <= IHIZ <= N. */

/*     Z       (input/output) DOUBLE PRECISION array, dimension (LDZ,N) */
/*          If WANTZ is .TRUE., on entry Z must contain the current */
/*          matrix Z of transformations accumulated by DHSEQR, and on */
/*          exit Z has been updated; transformations are applied only to */
/*          the submatrix Z(ILOZ:IHIZ,ILO:IHI). */
/*          If WANTZ is .FALSE., Z is not referenced. */

/*     LDZ     (input) INTEGER */
/*          The leading dimension of the array Z. LDZ >= max(1,N). */

/*     INFO    (output) INTEGER */
/*           =   0: successful exit */
/*          .GT. 0: If INFO = i, DLAHQR failed to compute all the */
/*                  eigenvalues ILO to IHI in a total of 30 iterations */
/*                  per eigenvalue; elements i+1:ihi of WR and WI */
/*                  contain those eigenvalues which have been */
/*                  successfully computed. */

/*                  If INFO .GT. 0 and WANTT is .FALSE., then on exit, */
/*                  the remaining unconverged eigenvalues are the */
/*                  eigenvalues of the upper Hessenberg matrix rows */
/*                  and columns ILO thorugh INFO of the final, output */
/*                  value of H. */

/*                  If INFO .GT. 0 and WANTT is .TRUE., then on exit */
/*          (*)       (initial value of H)*U  = U*(final value of H) */
/*                  where U is an orthognal matrix.    The final */
/*                  value of H is upper Hessenberg and triangular in */
/*                  rows and columns INFO+1 through IHI. */

/*                  If INFO .GT. 0 and WANTZ is .TRUE., then on exit */
/*                      (final value of Z)  = (initial value of Z)*U */
/*                  where U is the orthogonal matrix in (*) */
/*                  (regardless of the value of WANTT.) */

/*     Further Details */
/*     =============== */

/*     02-96 Based on modifications by */
/*     David Day, Sandia National Laboratory, USA */

/*     12-04 Further modifications by */
/*     Ralph Byers, University of Kansas, USA */

/*       This is a modified version of DLAHQR from LAPACK version 3.0. */
/*       It is (1) more robust against overflow and underflow and */
/*       (2) adopts the more conservative Ahues & Tisseur stopping */
/*       criterion (LAWN 122, 1997). */

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

/*     .. Parameters .. */
/*     .. */
/*     .. Local Scalars .. */
/*     .. */
/*     .. Local Arrays .. */
/*     .. */
/*     .. External Functions .. */
/*     .. */
/*     .. External Subroutines .. */
/*     .. */
/*     .. Intrinsic Functions .. */
/*     .. */
/*     .. Executable Statements .. */

    /* Parameter adjustments */
    h_dim1 = *ldh;
    h_offset = 1 + h_dim1;
    h__ -= h_offset;
    --wr;
    --wi;
    z_dim1 = *ldz;
    z_offset = 1 + z_dim1;
    z__ -= z_offset;

    /* Function Body */
    *info = 0;

/*     Quick return if possible */

    if (*n == 0) {
	return 0;
    }
    if (*ilo == *ihi) {
	wr[*ilo] = h__[*ilo + *ilo * h_dim1];
	wi[*ilo] = 0.;
	return 0;
    }

/*     ==== clear out the trash ==== */
    i__1 = *ihi - 3;
    for (j = *ilo; j <= i__1; ++j) {
	h__[j + 2 + j * h_dim1] = 0.;
	h__[j + 3 + j * h_dim1] = 0.;
/* L10: */
    }
    if (*ilo <= *ihi - 2) {
	h__[*ihi + (*ihi - 2) * h_dim1] = 0.;
    }

    nh = *ihi - *ilo + 1;
    nz = *ihiz - *iloz + 1;

/*     Set machine-dependent constants for the stopping criterion. */

    safmin = dlamch_("SAFE MINIMUM");
    safmax = 1. / safmin;
    dlabad_(&safmin, &safmax);
    ulp = dlamch_("PRECISION");
    smlnum = safmin * ((doublereal) nh / ulp);

/*     I1 and I2 are the indices of the first row and last column of H */
/*     to which transformations must be applied. If eigenvalues only are */
/*     being computed, I1 and I2 are set inside the main loop. */

    if (*wantt) {
	i1 = 1;
	i2 = *n;
    }

/*     The main loop begins here. I is the loop index and decreases from */
/*     IHI to ILO in steps of 1 or 2. Each iteration of the loop works */
/*     with the active submatrix in rows and columns L to I. */
/*     Eigenvalues I+1 to IHI have already converged. Either L = ILO or */
/*     H(L,L-1) is negligible so that the matrix splits. */

    i__ = *ihi;
L20:
    l = *ilo;
    if (i__ < *ilo) {
	goto L160;
    }

/*     Perform QR iterations on rows and columns ILO to I until a */
/*     submatrix of order 1 or 2 splits off at the bottom because a */
/*     subdiagonal element has become negligible. */

    for (its = 0; its <= 30; ++its) {

/*        Look for a single small subdiagonal element. */

	i__1 = l + 1;
	for (k = i__; k >= i__1; --k) {
	    if ((d__1 = h__[k + (k - 1) * h_dim1], abs(d__1)) <= smlnum) {
		goto L40;
	    }
	    tst = (d__1 = h__[k - 1 + (k - 1) * h_dim1], abs(d__1)) + (d__2 = 
		    h__[k + k * h_dim1], abs(d__2));
	    if (tst == 0.) {
		if (k - 2 >= *ilo) {
		    tst += (d__1 = h__[k - 1 + (k - 2) * h_dim1], abs(d__1));
		}
		if (k + 1 <= *ihi) {
		    tst += (d__1 = h__[k + 1 + k * h_dim1], abs(d__1));
		}
	    }
/*           ==== The following is a conservative small subdiagonal */
/*           .    deflation  criterion due to Ahues & Tisseur (LAWN 122, */
/*           .    1997). It has better mathematical foundation and */
/*           .    improves accuracy in some cases.  ==== */
	    if ((d__1 = h__[k + (k - 1) * h_dim1], abs(d__1)) <= ulp * tst) {
/* Computing MAX */
		d__3 = (d__1 = h__[k + (k - 1) * h_dim1], abs(d__1)), d__4 = (
			d__2 = h__[k - 1 + k * h_dim1], abs(d__2));
		ab = max(d__3,d__4);
/* Computing MIN */
		d__3 = (d__1 = h__[k + (k - 1) * h_dim1], abs(d__1)), d__4 = (
			d__2 = h__[k - 1 + k * h_dim1], abs(d__2));
		ba = min(d__3,d__4);
/* Computing MAX */
		d__3 = (d__1 = h__[k + k * h_dim1], abs(d__1)), d__4 = (d__2 =
			 h__[k - 1 + (k - 1) * h_dim1] - h__[k + k * h_dim1], 
			abs(d__2));
		aa = max(d__3,d__4);
/* Computing MIN */
		d__3 = (d__1 = h__[k + k * h_dim1], abs(d__1)), d__4 = (d__2 =
			 h__[k - 1 + (k - 1) * h_dim1] - h__[k + k * h_dim1], 
			abs(d__2));
		bb = min(d__3,d__4);
		s = aa + ab;
/* Computing MAX */
		d__1 = smlnum, d__2 = ulp * (bb * (aa / s));
		if (ba * (ab / s) <= max(d__1,d__2)) {
		    goto L40;
		}
	    }
/* L30: */
	}
L40:
	l = k;
	if (l > *ilo) {

/*           H(L,L-1) is negligible */

	    h__[l + (l - 1) * h_dim1] = 0.;
	}

/*        Exit from loop if a submatrix of order 1 or 2 has split off. */

	if (l >= i__ - 1) {
	    goto L150;
	}

/*        Now the active submatrix is in rows and columns L to I. If */
/*        eigenvalues only are being computed, only the active submatrix */
/*        need be transformed. */

	if (! (*wantt)) {
	    i1 = l;
	    i2 = i__;
	}

	if (its == 10 || its == 20) {

/*           Exceptional shift. */

	    h11 = s * .75 + h__[i__ + i__ * h_dim1];
	    h12 = s * -.4375;
	    h21 = s;
	    h22 = h11;
	} else {

/*           Prepare to use Francis' double shift */
/*           (i.e. 2nd degree generalized Rayleigh quotient) */

	    h11 = h__[i__ - 1 + (i__ - 1) * h_dim1];
	    h21 = h__[i__ + (i__ - 1) * h_dim1];
	    h12 = h__[i__ - 1 + i__ * h_dim1];
	    h22 = h__[i__ + i__ * h_dim1];
	}
	s = abs(h11) + abs(h12) + abs(h21) + abs(h22);
	if (s == 0.) {
	    rt1r = 0.;
	    rt1i = 0.;
	    rt2r = 0.;
	    rt2i = 0.;
	} else {
	    h11 /= s;
	    h21 /= s;
	    h12 /= s;
	    h22 /= s;
	    tr = (h11 + h22) / 2.;
	    det = (h11 - tr) * (h22 - tr) - h12 * h21;
	    rtdisc = sqrt((abs(det)));
	    if (det >= 0.) {

/*              ==== complex conjugate shifts ==== */

		rt1r = tr * s;
		rt2r = rt1r;
		rt1i = rtdisc * s;
		rt2i = -rt1i;
	    } else {

/*              ==== real shifts (use only one of them)  ==== */

		rt1r = tr + rtdisc;
		rt2r = tr - rtdisc;
		if ((d__1 = rt1r - h22, abs(d__1)) <= (d__2 = rt2r - h22, abs(
			d__2))) {
		    rt1r *= s;
		    rt2r = rt1r;
		} else {
		    rt2r *= s;
		    rt1r = rt2r;
		}
		rt1i = 0.;
		rt2i = 0.;
	    }
	}

/*        Look for two consecutive small subdiagonal elements. */

	i__1 = l;
	for (m = i__ - 2; m >= i__1; --m) {
/*           Determine the effect of starting the double-shift QR */
/*           iteration at row M, and see if this would make H(M,M-1) */
/*           negligible.  (The following uses scaling to avoid */
/*           overflows and most underflows.) */

	    h21s = h__[m + 1 + m * h_dim1];
	    s = (d__1 = h__[m + m * h_dim1] - rt2r, abs(d__1)) + abs(rt2i) + 
		    abs(h21s);
	    h21s = h__[m + 1 + m * h_dim1] / s;
	    v[0] = h21s * h__[m + (m + 1) * h_dim1] + (h__[m + m * h_dim1] - 
		    rt1r) * ((h__[m + m * h_dim1] - rt2r) / s) - rt1i * (rt2i 
		    / s);
	    v[1] = h21s * (h__[m + m * h_dim1] + h__[m + 1 + (m + 1) * h_dim1]
		     - rt1r - rt2r);
	    v[2] = h21s * h__[m + 2 + (m + 1) * h_dim1];
	    s = abs(v[0]) + abs(v[1]) + abs(v[2]);
	    v[0] /= s;
	    v[1] /= s;
	    v[2] /= s;
	    if (m == l) {
		goto L60;
	    }
	    if ((d__1 = h__[m + (m - 1) * h_dim1], abs(d__1)) * (abs(v[1]) + 
		    abs(v[2])) <= ulp * abs(v[0]) * ((d__2 = h__[m - 1 + (m - 
		    1) * h_dim1], abs(d__2)) + (d__3 = h__[m + m * h_dim1], 
		    abs(d__3)) + (d__4 = h__[m + 1 + (m + 1) * h_dim1], abs(
		    d__4)))) {
		goto L60;
	    }
/* L50: */
	}
L60:

/*        Double-shift QR step */

	i__1 = i__ - 1;
	for (k = m; k <= i__1; ++k) {

/*           The first iteration of this loop determines a reflection G */
/*           from the vector V and applies it from left and right to H, */
/*           thus creating a nonzero bulge below the subdiagonal. */

/*           Each subsequent iteration determines a reflection G to */
/*           restore the Hessenberg form in the (K-1)th column, and thus */
/*           chases the bulge one step toward the bottom of the active */
/*           submatrix. NR is the order of G. */

/* Computing MIN */
	    i__2 = 3, i__3 = i__ - k + 1;
	    nr = min(i__2,i__3);
	    if (k > m) {
		dcopy_(&nr, &h__[k + (k - 1) * h_dim1], &c__1, v, &c__1);
	    }
	    dlarfg_(&nr, v, &v[1], &c__1, &t1);
	    if (k > m) {
		h__[k + (k - 1) * h_dim1] = v[0];
		h__[k + 1 + (k - 1) * h_dim1] = 0.;
		if (k < i__ - 1) {
		    h__[k + 2 + (k - 1) * h_dim1] = 0.;
		}
	    } else if (m > l) {
		h__[k + (k - 1) * h_dim1] = -h__[k + (k - 1) * h_dim1];
	    }
	    v2 = v[1];
	    t2 = t1 * v2;
	    if (nr == 3) {
		v3 = v[2];
		t3 = t1 * v3;

/*              Apply G from the left to transform the rows of the matrix */
/*              in columns K to I2. */

		i__2 = i2;
		for (j = k; j <= i__2; ++j) {
		    sum = h__[k + j * h_dim1] + v2 * h__[k + 1 + j * h_dim1] 
			    + v3 * h__[k + 2 + j * h_dim1];
		    h__[k + j * h_dim1] -= sum * t1;
		    h__[k + 1 + j * h_dim1] -= sum * t2;
		    h__[k + 2 + j * h_dim1] -= sum * t3;
/* L70: */
		}

/*              Apply G from the right to transform the columns of the */
/*              matrix in rows I1 to min(K+3,I). */

/* Computing MIN */
		i__3 = k + 3;
		i__2 = min(i__3,i__);
		for (j = i1; j <= i__2; ++j) {
		    sum = h__[j + k * h_dim1] + v2 * h__[j + (k + 1) * h_dim1]
			     + v3 * h__[j + (k + 2) * h_dim1];
		    h__[j + k * h_dim1] -= sum * t1;
		    h__[j + (k + 1) * h_dim1] -= sum * t2;
		    h__[j + (k + 2) * h_dim1] -= sum * t3;
/* L80: */
		}

		if (*wantz) {

/*                 Accumulate transformations in the matrix Z */

		    i__2 = *ihiz;
		    for (j = *iloz; j <= i__2; ++j) {
			sum = z__[j + k * z_dim1] + v2 * z__[j + (k + 1) * 
				z_dim1] + v3 * z__[j + (k + 2) * z_dim1];
			z__[j + k * z_dim1] -= sum * t1;
			z__[j + (k + 1) * z_dim1] -= sum * t2;
			z__[j + (k + 2) * z_dim1] -= sum * t3;
/* L90: */
		    }
		}
	    } else if (nr == 2) {

/*              Apply G from the left to transform the rows of the matrix */
/*              in columns K to I2. */

		i__2 = i2;
		for (j = k; j <= i__2; ++j) {
		    sum = h__[k + j * h_dim1] + v2 * h__[k + 1 + j * h_dim1];
		    h__[k + j * h_dim1] -= sum * t1;
		    h__[k + 1 + j * h_dim1] -= sum * t2;
/* L100: */
		}

/*              Apply G from the right to transform the columns of the */
/*              matrix in rows I1 to min(K+3,I). */

		i__2 = i__;
		for (j = i1; j <= i__2; ++j) {
		    sum = h__[j + k * h_dim1] + v2 * h__[j + (k + 1) * h_dim1]
			    ;
		    h__[j + k * h_dim1] -= sum * t1;
		    h__[j + (k + 1) * h_dim1] -= sum * t2;
/* L110: */
		}

		if (*wantz) {

/*                 Accumulate transformations in the matrix Z */

		    i__2 = *ihiz;
		    for (j = *iloz; j <= i__2; ++j) {
			sum = z__[j + k * z_dim1] + v2 * z__[j + (k + 1) * 
				z_dim1];
			z__[j + k * z_dim1] -= sum * t1;
			z__[j + (k + 1) * z_dim1] -= sum * t2;
/* L120: */
		    }
		}
	    }
/* L130: */
	}

/* L140: */
    }

/*     Failure to converge in remaining number of iterations */

    *info = i__;
    return 0;

L150:

    if (l == i__) {

/*        H(I,I-1) is negligible: one eigenvalue has converged. */

	wr[i__] = h__[i__ + i__ * h_dim1];
	wi[i__] = 0.;
    } else if (l == i__ - 1) {

/*        H(I-1,I-2) is negligible: a pair of eigenvalues have converged. */

/*        Transform the 2-by-2 submatrix to standard Schur form, */
/*        and compute and store the eigenvalues. */

	dlanv2_(&h__[i__ - 1 + (i__ - 1) * h_dim1], &h__[i__ - 1 + i__ * 
		h_dim1], &h__[i__ + (i__ - 1) * h_dim1], &h__[i__ + i__ * 
		h_dim1], &wr[i__ - 1], &wi[i__ - 1], &wr[i__], &wi[i__], &cs, 
		&sn);

	if (*wantt) {

/*           Apply the transformation to the rest of H. */

	    if (i2 > i__) {
		i__1 = i2 - i__;
		drot_(&i__1, &h__[i__ - 1 + (i__ + 1) * h_dim1], ldh, &h__[
			i__ + (i__ + 1) * h_dim1], ldh, &cs, &sn);
	    }
	    i__1 = i__ - i1 - 1;
	    drot_(&i__1, &h__[i1 + (i__ - 1) * h_dim1], &c__1, &h__[i1 + i__ *
		     h_dim1], &c__1, &cs, &sn);
	}
	if (*wantz) {

/*           Apply the transformation to Z. */

	    drot_(&nz, &z__[*iloz + (i__ - 1) * z_dim1], &c__1, &z__[*iloz + 
		    i__ * z_dim1], &c__1, &cs, &sn);
	}
    }

/*     return to start of the main loop with new value of I. */

    i__ = l - 1;
    goto L20;

L160:
    return 0;

/*     End of DLAHQR */

} /* dlahqr_ */
示例#19
0
文件: ddrvsx.c 项目: zangel/uquad
/* Subroutine */ int ddrvsx_(integer *nsizes, integer *nn, integer *ntypes, 
	logical *dotype, integer *iseed, doublereal *thresh, integer *niunit, 
	integer *nounit, doublereal *a, integer *lda, doublereal *h__, 
	doublereal *ht, doublereal *wr, doublereal *wi, doublereal *wrt, 
	doublereal *wit, doublereal *wrtmp, doublereal *witmp, doublereal *vs,
	 integer *ldvs, doublereal *vs1, doublereal *result, doublereal *work,
	 integer *lwork, integer *iwork, logical *bwork, 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_9991[] = "(\002 DDRVSX: \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 -- Real Schur Form Decomposition "
	    "Expert \002,\002Driver\002,/\002 Matrix types (see DDRVSX for de"
	    "tails):\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,/\002"
	    " 12=Well-cond., random complex \002,\002         \002,\002 17=Il"
	    "l-cond., large rand. complx \002,/\002 13=Ill-condi\002,\002tion"
	    "ed, evenly spaced.     \002,\002 18=Ill-cond., small rand.\002"
	    ",\002 complx \002)";
    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 ( A denotes A on input and T denotes A on output)"
	    "\002,//\002 1 = 0 if T in Schur form (no sort), \002,\002  1/ulp"
	    " otherwise\002,/\002 2 = | A - VS T transpose(VS) | / ( n |A| ul"
	    "p ) (no sort)\002,/\002 3 = | I - VS transpose(VS) | / ( n ulp )"
	    " (no sort) \002,/\002 4 = 0 if WR+sqrt(-1)*WI are eigenvalues of"
	    " T (no sort),\002,\002  1/ulp otherwise\002,/\002 5 = 0 if T sam"
	    "e no matter if VS computed (no sort),\002,\002  1/ulp otherwis"
	    "e\002,/\002 6 = 0 if WR, WI same no matter if VS computed (no so"
	    "rt)\002,\002,  1/ulp otherwise\002)";
    static char fmt_9994[] = "(\002 7 = 0 if T in Schur form (sort), \002"
	    ",\002  1/ulp otherwise\002,/\002 8 = | A - VS T transpose(VS) | "
	    "/ ( n |A| ulp ) (sort)\002,/\002 9 = | I - VS transpose(VS) | / "
	    "( n ulp ) (sort) \002,/\002 10 = 0 if WR+sqrt(-1)*WI are eigenva"
	    "lues of T (sort),\002,\002  1/ulp otherwise\002,/\002 11 = 0 if "
	    "T same no matter what else computed (sort),\002,\002  1/ulp othe"
	    "rwise\002,/\002 12 = 0 if WR, WI same no matter what else comput"
	    "ed \002,\002(sort), 1/ulp otherwise\002,/\002 13 = 0 if sorting "
	    "succesful, 1/ulp otherwise\002,/\002 14 = 0 if RCONDE same no ma"
	    "tter what else computed,\002,\002 1/ulp otherwise\002,/\002 15 ="
	    " 0 if RCONDv same no matter what else computed,\002,\002 1/ulp o"
	    "therwise\002,/\002 16 = | RCONDE - RCONDE(precomputed) | / cond("
	    "RCONDE),\002,/\002 17 = | RCONDV - RCONDV(precomputed) | / cond("
	    "RCONDV),\002)";
    static char fmt_9993[] = "(\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)";
    static char fmt_9992[] = "(\002 N=\002,i5,\002, input example =\002,i3"
	    ",\002,  test(\002,i2,\002)=\002,g10.3)";

    /* System generated locals */
    integer a_dim1, a_offset, h_dim1, h_offset, ht_dim1, ht_offset, vs_dim1, 
	    vs_offset, vs1_dim1, vs1_offset, i__1, i__2, i__3, i__4;

    /* 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),
	     s_rsle(cilist *), do_lio(integer *, integer *, char *, ftnlen), 
	    e_rsle(void);

    /* Local variables */
    static doublereal cond;
    static integer jcol;
    static char path[3];
    static integer nmax;
    static doublereal unfl, ovfl;
    static integer i__, j, n;
    static logical badnn;
    static integer nfail;
    extern /* Subroutine */ int dget24_(logical *, integer *, doublereal *, 
	    integer *, integer *, integer *, doublereal *, integer *, 
	    doublereal *, doublereal *, doublereal *, doublereal *, 
	    doublereal *, doublereal *, doublereal *, doublereal *, 
	    doublereal *, integer *, doublereal *, doublereal *, doublereal *,
	     integer *, integer *, doublereal *, doublereal *, integer *, 
	    integer *, logical *, integer *);
    static integer imode, iinfo;
    static doublereal conds, anorm;
    static integer islct[20], nslct, jsize, nerrs, itype, jtype, ntest;
    static doublereal rtulp;
    extern /* Subroutine */ int dlabad_(doublereal *, doublereal *);
    extern doublereal dlamch_(char *);
    static doublereal rcdein;
    static char adumma[1*1];
    extern /* Subroutine */ int dlatme_(integer *, char *, integer *, 
	    doublereal *, integer *, doublereal *, doublereal *, char *, char 
	    *, char *, char *, doublereal *, integer *, doublereal *, integer 
	    *, integer *, doublereal *, doublereal *, integer *, doublereal *,
	     integer *);
    static integer idumma[1], ioldsd[4];
    extern /* Subroutine */ int dlaset_(char *, integer *, integer *, 
	    doublereal *, doublereal *, doublereal *, integer *), 
	    xerbla_(char *, integer *), dlatmr_(integer *, integer *, 
	    char *, integer *, char *, doublereal *, integer *, doublereal *, 
	    doublereal *, char *, char *, doublereal *, integer *, doublereal 
	    *, doublereal *, integer *, doublereal *, char *, integer *, 
	    integer *, integer *, doublereal *, doublereal *, char *, 
	    doublereal *, integer *, integer *, integer *), dlatms_(integer *, integer *, 
	    char *, integer *, char *, doublereal *, integer *, doublereal *, 
	    doublereal *, integer *, integer *, char *, doublereal *, integer 
	    *, doublereal *, integer *);
    static doublereal rcdvin;
    extern /* Subroutine */ int dlasum_(char *, integer *, integer *, integer 
	    *);
    static integer ntestf;
    static doublereal ulpinv;
    static integer nnwork;
    static doublereal rtulpi;
    static integer mtypes, ntestt, iwk;
    static doublereal ulp;

    /* Fortran I/O blocks */
    static cilist io___32 = { 0, 0, 0, fmt_9991, 0 };
    static cilist io___41 = { 0, 0, 0, fmt_9999, 0 };
    static cilist io___42 = { 0, 0, 0, fmt_9998, 0 };
    static cilist io___43 = { 0, 0, 0, fmt_9997, 0 };
    static cilist io___44 = { 0, 0, 0, fmt_9996, 0 };
    static cilist io___45 = { 0, 0, 0, fmt_9995, 0 };
    static cilist io___46 = { 0, 0, 0, fmt_9994, 0 };
    static cilist io___47 = { 0, 0, 0, fmt_9993, 0 };
    static cilist io___48 = { 0, 0, 1, 0, 0 };
    static cilist io___49 = { 0, 0, 0, 0, 0 };
    static cilist io___51 = { 0, 0, 0, 0, 0 };
    static cilist io___52 = { 0, 0, 0, 0, 0 };
    static cilist io___53 = { 0, 0, 0, fmt_9999, 0 };
    static cilist io___54 = { 0, 0, 0, fmt_9998, 0 };
    static cilist io___55 = { 0, 0, 0, fmt_9997, 0 };
    static cilist io___56 = { 0, 0, 0, fmt_9996, 0 };
    static cilist io___57 = { 0, 0, 0, fmt_9995, 0 };
    static cilist io___58 = { 0, 0, 0, fmt_9994, 0 };
    static cilist io___59 = { 0, 0, 0, fmt_9992, 0 };



#define a_ref(a_1,a_2) a[(a_2)*a_dim1 + a_1]


/*  -- 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   
    =======   

       DDRVSX checks the nonsymmetric eigenvalue (Schur form) problem   
       expert driver DGEESX.   

       DDRVSX uses both test matrices generated randomly depending on   
       data supplied in the calling sequence, as well as on data   
       read from an input file and including precomputed condition   
       numbers to which it compares the ones it computes.   

       When DDRVSX 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, 15   
       tests will be performed:   

       (1)     0 if T is in Schur form, 1/ulp otherwise   
              (no sorting of eigenvalues)   

       (2)     | A - VS T VS' | / ( n |A| ulp )   

         Here VS is the matrix of Schur eigenvectors, and T is in Schur   
         form  (no sorting of eigenvalues).   

       (3)     | I - VS VS' | / ( n ulp ) (no sorting of eigenvalues).   

       (4)     0     if WR+sqrt(-1)*WI are eigenvalues of T   
               1/ulp otherwise   
               (no sorting of eigenvalues)   

       (5)     0     if T(with VS) = T(without VS),   
               1/ulp otherwise   
               (no sorting of eigenvalues)   

       (6)     0     if eigenvalues(with VS) = eigenvalues(without VS),   
               1/ulp otherwise   
               (no sorting of eigenvalues)   

       (7)     0 if T is in Schur form, 1/ulp otherwise   
               (with sorting of eigenvalues)   

       (8)     | A - VS T VS' | / ( n |A| ulp )   

         Here VS is the matrix of Schur eigenvectors, and T is in Schur   
         form  (with sorting of eigenvalues).   

       (9)     | I - VS VS' | / ( n ulp ) (with sorting of eigenvalues).   

       (10)    0     if WR+sqrt(-1)*WI are eigenvalues of T   
               1/ulp otherwise   
               If workspace sufficient, also compare WR, WI with and   
               without reciprocal condition numbers   
               (with sorting of eigenvalues)   

       (11)    0     if T(with VS) = T(without VS),   
               1/ulp otherwise   
               If workspace sufficient, also compare T with and without   
               reciprocal condition numbers   
               (with sorting of eigenvalues)   

       (12)    0     if eigenvalues(with VS) = eigenvalues(without VS),   
               1/ulp otherwise   
               If workspace sufficient, also compare VS with and without   
               reciprocal condition numbers   
               (with sorting of eigenvalues)   

       (13)    if sorting worked and SDIM is the number of   
               eigenvalues which were SELECTed   
               If workspace sufficient, also compare SDIM with and   
               without reciprocal condition numbers   

       (14)    if RCONDE the same no matter if VS and/or RCONDV computed   

       (15)    if RCONDV the same no matter if VS and/or RCONDE 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 signs.   
            (ULP = (first number larger than 1) - 1 )   
       (5)  A diagonal matrix with geometrically spaced entries   
            1, ..., ULP  and random signs.   
       (6)  A diagonal matrix with "clustered" entries 1, ULP, ..., ULP   
            and random signs.   

       (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 orthogonal and   
            T has evenly spaced entries 1, ..., ULP with random signs   
            on the diagonal and random O(1) entries in the upper   
            triangle.   

       (10) A matrix of the form  U' T U, where U is orthogonal and   
            T has geometrically spaced entries 1, ..., ULP with random   
            signs on the diagonal and random O(1) entries in the upper   
            triangle.   

       (11) A matrix of the form  U' T U, where U is orthogonal and   
            T has "clustered" entries 1, ULP,..., ULP with random   
            signs on the diagonal and random O(1) entries in the upper   
            triangle.   

       (12) A matrix of the form  U' T U, where U is orthogonal and   
            T has real or complex conjugate paired eigenvalues randomly   
            chosen from ( ULP, 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 signs 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 signs 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 signs 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 real or complex conjugate paired   
            eigenvalues randomly chosen from ( ULP, 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 (-1,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   

       In addition, an input file will be read from logical unit number   
       NIUNIT. The file contains matrices along with precomputed   
       eigenvalues and reciprocal condition numbers for the eigenvalue   
       average and right invariant subspace. For these matrices, in   
       addition to tests (1) to (15) we will compute the following two   
       tests:   

      (16)  |RCONDE - RCDEIN| / cond(RCONDE)   

         RCONDE is the reciprocal average eigenvalue condition number   
         computed by DGEESX 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.   

      (17)  |RCONDV - RCDVIN| / cond(RCONDV)   

         RCONDV is the reciprocal right invariant subspace condition   
         number computed by DGEESX 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.   

    Arguments   
    =========   

    NSIZES  (input) INTEGER   
            The number of sizes of matrices to use.  NSIZES must be at   
            least zero. If it is zero, no randomly generated matrices   
            are tested, but any test matrices read from NIUNIT will be   
            tested.   

    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. NTYPES must be at least   
            zero. If it is zero, no randomly generated test matrices   
            are tested, but and test matrices read from NIUNIT will be   
            tested. 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 DDRVSX 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.   

    NIUNIT  (input) INTEGER   
            The FORTRAN unit number for reading in the data file of   
            problems to solve.   

    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) DOUBLE PRECISION 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) DOUBLE PRECISION array, dimension (LDA, max(NN))   
            Another copy of the test matrix A, modified by DGEESX.   

    HT      (workspace) DOUBLE PRECISION array, dimension (LDA, max(NN))   
            Yet another copy of the test matrix A, modified by DGEESX.   

    WR      (workspace) DOUBLE PRECISION array, dimension (max(NN))   
    WI      (workspace) DOUBLE PRECISION array, dimension (max(NN))   
            The real and imaginary parts of the eigenvalues of A.   
            On exit, WR + WI*i are the eigenvalues of the matrix in A.   

    WRT     (workspace) DOUBLE PRECISION array, dimension (max(NN))   
    WIT     (workspace) DOUBLE PRECISION array, dimension (max(NN))   
            Like WR, WI, these arrays contain the eigenvalues of A,   
            but those computed when DGEESX only computes a partial   
            eigendecomposition, i.e. not Schur vectors   

    WRTMP   (workspace) DOUBLE PRECISION array, dimension (max(NN))   
    WITMP   (workspace) DOUBLE PRECISION array, dimension (max(NN))   
            More temporary storage for eigenvalues.   

    VS      (workspace) DOUBLE PRECISION array, dimension (LDVS, max(NN))   
            VS holds the computed Schur vectors.   

    LDVS    (input) INTEGER   
            Leading dimension of VS. Must be at least max(1,max(NN)).   

    VS1     (workspace) DOUBLE PRECISION array, dimension (LDVS, max(NN))   
            VS1 holds another copy of the computed Schur vectors.   

    RESULT  (output) DOUBLE PRECISION array, dimension (17)   
            The values computed by the 17 tests described above.   
            The values are currently limited to 1/ulp, to avoid overflow.   

    WORK    (workspace) DOUBLE PRECISION array, dimension (LWORK)   

    LWORK   (input) INTEGER   
            The number of entries in WORK.  This must be at least   
            max(3*NN(j),2*NN(j)**2) for all j.   

    IWORK   (workspace) INTEGER array, dimension (max(NN)*max(NN))   

    INFO    (output) INTEGER   
            If 0,  successful exit.   
              <0,  input parameter -INFO is incorrect   
              >0,  DLATMR, SLATMS, SLATME or DGET24 returned an error   
                   code and INFO is its absolute value   

   -----------------------------------------------------------------------   

       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;
    ht_dim1 = *lda;
    ht_offset = 1 + ht_dim1 * 1;
    ht -= ht_offset;
    h_dim1 = *lda;
    h_offset = 1 + h_dim1 * 1;
    h__ -= h_offset;
    a_dim1 = *lda;
    a_offset = 1 + a_dim1 * 1;
    a -= a_offset;
    --wr;
    --wi;
    --wrt;
    --wit;
    --wrtmp;
    --witmp;
    vs1_dim1 = *ldvs;
    vs1_offset = 1 + vs1_dim1 * 1;
    vs1 -= vs1_offset;
    vs_dim1 = *ldvs;
    vs_offset = 1 + vs_dim1 * 1;
    vs -= vs_offset;
    --result;
    --work;
    --iwork;
    --bwork;

    /* Function Body */

    s_copy(path, "Double precision", (ftnlen)1, (ftnlen)16);
    s_copy(path + 1, "SX", (ftnlen)2, (ftnlen)2);

/*     Check for errors */

    ntestt = 0;
    ntestf = 0;
    *info = 0;

/*     Important constants */

    badnn = FALSE_;

/*     12 is the largest dimension in the input file of precomputed   
       problems */

    nmax = 12;
    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 (*niunit <= 0) {
	*info = -7;
    } else if (*nounit <= 0) {
	*info = -8;
    } else if (*lda < 1 || *lda < nmax) {
	*info = -10;
    } else if (*ldvs < 1 || *ldvs < nmax) {
	*info = -20;
    } else /* if(complicated condition) */ {
/* Computing MAX   
   Computing 2nd power */
	i__3 = nmax;
	i__1 = nmax * 3, i__2 = i__3 * i__3 << 1;
	if (max(i__1,i__2) > *lwork) {
	    *info = -24;
	}
    }

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

/*     If nothing to do check on NIUNIT */

    if (*nsizes == 0 || *ntypes == 0) {
	goto L150;
    }

/*     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 L130;
	    }

/*           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:

	    dlaset_("Full", lda, &n, &c_b18, &c_b18, &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) {
		    a_ref(jcol, jcol) = anorm;
/* L70: */
		}

	    } else if (itype == 3) {

/*              Jordan Block */

		i__3 = n;
		for (jcol = 1; jcol <= i__3; ++jcol) {
		    a_ref(jcol, jcol) = anorm;
		    if (jcol > 1) {
			a_ref(jcol, jcol - 1) = 1.;
		    }
/* L80: */
		}

	    } else if (itype == 4) {

/*              Diagonal Matrix, [Eigen]values Specified */

		dlatms_(&n, &n, "S", &iseed[1], "S", &work[1], &imode, &cond, 
			&anorm, &c__0, &c__0, "N", &a[a_offset], lda, &work[n 
			+ 1], &iinfo);

	    } else if (itype == 5) {

/*              Symmetric, eigenvalues specified */

		dlatms_(&n, &n, "S", &iseed[1], "S", &work[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.;
		}

		*(unsigned char *)&adumma[0] = ' ';
		dlatme_(&n, "S", &iseed[1], &work[1], &imode, &cond, &c_b32, 
			adumma, "T", "T", "T", &work[n + 1], &c__4, &conds, &
			n, &n, &anorm, &a[a_offset], lda, &work[(n << 1) + 1],
			 &iinfo);

	    } else if (itype == 7) {

/*              Diagonal, random eigenvalues */

		dlatmr_(&n, &n, "S", &iseed[1], "S", &work[1], &c__6, &c_b32, 
			&c_b32, "T", "N", &work[n + 1], &c__1, &c_b32, &work[(
			n << 1) + 1], &c__1, &c_b32, "N", idumma, &c__0, &
			c__0, &c_b18, &anorm, "NO", &a[a_offset], lda, &iwork[
			1], &iinfo);

	    } else if (itype == 8) {

/*              Symmetric, random eigenvalues */

		dlatmr_(&n, &n, "S", &iseed[1], "S", &work[1], &c__6, &c_b32, 
			&c_b32, "T", "N", &work[n + 1], &c__1, &c_b32, &work[(
			n << 1) + 1], &c__1, &c_b32, "N", idumma, &n, &n, &
			c_b18, &anorm, "NO", &a[a_offset], lda, &iwork[1], &
			iinfo);

	    } else if (itype == 9) {

/*              General, random eigenvalues */

		dlatmr_(&n, &n, "S", &iseed[1], "N", &work[1], &c__6, &c_b32, 
			&c_b32, "T", "N", &work[n + 1], &c__1, &c_b32, &work[(
			n << 1) + 1], &c__1, &c_b32, "N", idumma, &n, &n, &
			c_b18, &anorm, "NO", &a[a_offset], lda, &iwork[1], &
			iinfo);
		if (n >= 4) {
		    dlaset_("Full", &c__2, &n, &c_b18, &c_b18, &a[a_offset], 
			    lda);
		    i__3 = n - 3;
		    dlaset_("Full", &i__3, &c__1, &c_b18, &c_b18, &a_ref(3, 1)
			    , lda);
		    i__3 = n - 3;
		    dlaset_("Full", &i__3, &c__2, &c_b18, &c_b18, &a_ref(3, n 
			    - 1), lda);
		    dlaset_("Full", &c__1, &n, &c_b18, &c_b18, &a_ref(n, 1), 
			    lda);
		}

	    } else if (itype == 10) {

/*              Triangular, random eigenvalues */

		dlatmr_(&n, &n, "S", &iseed[1], "N", &work[1], &c__6, &c_b32, 
			&c_b32, "T", "N", &work[n + 1], &c__1, &c_b32, &work[(
			n << 1) + 1], &c__1, &c_b32, "N", idumma, &n, &c__0, &
			c_b18, &anorm, "NO", &a[a_offset], lda, &iwork[1], &
			iinfo);

	    } else {

		iinfo = 1;
	    }

	    if (iinfo != 0) {
		io___32.ciunit = *nounit;
		s_wsfe(&io___32);
		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 * 3;
		} else {
/* Computing MAX */
		    i__3 = n * 3, i__4 = (n << 1) * n;
		    nnwork = max(i__3,i__4);
		}
		nnwork = max(nnwork,1);

		dget24_(&c_false, &jtype, thresh, ioldsd, nounit, &n, &a[
			a_offset], lda, &h__[h_offset], &ht[ht_offset], &wr[1]
			, &wi[1], &wrt[1], &wit[1], &wrtmp[1], &witmp[1], &vs[
			vs_offset], ldvs, &vs1[vs1_offset], &rcdein, &rcdvin, 
			&nslct, islct, &result[1], &work[1], &nnwork, &iwork[
			1], &bwork[1], info);

/*              Check for RESULT(j) > THRESH */

		ntest = 0;
		nfail = 0;
		for (j = 1; j <= 15; ++j) {
		    if (result[j] >= 0.) {
			++ntest;
		    }
		    if (result[j] >= *thresh) {
			++nfail;
		    }
/* L100: */
		}

		if (nfail > 0) {
		    ++ntestf;
		}
		if (ntestf == 1) {
		    io___41.ciunit = *nounit;
		    s_wsfe(&io___41);
		    do_fio(&c__1, path, (ftnlen)3);
		    e_wsfe();
		    io___42.ciunit = *nounit;
		    s_wsfe(&io___42);
		    e_wsfe();
		    io___43.ciunit = *nounit;
		    s_wsfe(&io___43);
		    e_wsfe();
		    io___44.ciunit = *nounit;
		    s_wsfe(&io___44);
		    e_wsfe();
		    io___45.ciunit = *nounit;
		    s_wsfe(&io___45);
		    do_fio(&c__1, (char *)&(*thresh), (ftnlen)sizeof(
			    doublereal));
		    e_wsfe();
		    io___46.ciunit = *nounit;
		    s_wsfe(&io___46);
		    e_wsfe();
		    ntestf = 2;
		}

		for (j = 1; j <= 15; ++j) {
		    if (result[j] >= *thresh) {
			io___47.ciunit = *nounit;
			s_wsfe(&io___47);
			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();
		    }
/* L110: */
		}

		nerrs += nfail;
		ntestt += ntest;

/* L120: */
	    }
L130:
	    ;
	}
/* L140: */
    }

L150:

/*     Read in data from file to check accuracy of condition estimation   
       Read input data until N=0 */

    jtype = 0;
L160:
    io___48.ciunit = *niunit;
    i__1 = s_rsle(&io___48);
    if (i__1 != 0) {
	goto L200;
    }
    i__1 = do_lio(&c__3, &c__1, (char *)&n, (ftnlen)sizeof(integer));
    if (i__1 != 0) {
	goto L200;
    }
    i__1 = do_lio(&c__3, &c__1, (char *)&nslct, (ftnlen)sizeof(integer));
    if (i__1 != 0) {
	goto L200;
    }
    i__1 = e_rsle();
    if (i__1 != 0) {
	goto L200;
    }
    if (n == 0) {
	goto L200;
    }
    ++jtype;
    iseed[1] = jtype;
    if (nslct > 0) {
	io___49.ciunit = *niunit;
	s_rsle(&io___49);
	i__1 = nslct;
	for (i__ = 1; i__ <= i__1; ++i__) {
	    do_lio(&c__3, &c__1, (char *)&islct[i__ - 1], (ftnlen)sizeof(
		    integer));
	}
	e_rsle();
    }
    i__1 = n;
    for (i__ = 1; i__ <= i__1; ++i__) {
	io___51.ciunit = *niunit;
	s_rsle(&io___51);
	i__2 = n;
	for (j = 1; j <= i__2; ++j) {
	    do_lio(&c__5, &c__1, (char *)&a_ref(i__, j), (ftnlen)sizeof(
		    doublereal));
	}
	e_rsle();
/* L170: */
    }
    io___52.ciunit = *niunit;
    s_rsle(&io___52);
    do_lio(&c__5, &c__1, (char *)&rcdein, (ftnlen)sizeof(doublereal));
    do_lio(&c__5, &c__1, (char *)&rcdvin, (ftnlen)sizeof(doublereal));
    e_rsle();

    dget24_(&c_true, &c__22, thresh, &iseed[1], nounit, &n, &a[a_offset], lda,
	     &h__[h_offset], &ht[ht_offset], &wr[1], &wi[1], &wrt[1], &wit[1],
	     &wrtmp[1], &witmp[1], &vs[vs_offset], ldvs, &vs1[vs1_offset], &
	    rcdein, &rcdvin, &nslct, islct, &result[1], &work[1], lwork, &
	    iwork[1], &bwork[1], info);

/*     Check for RESULT(j) > THRESH */

    ntest = 0;
    nfail = 0;
    for (j = 1; j <= 17; ++j) {
	if (result[j] >= 0.) {
	    ++ntest;
	}
	if (result[j] >= *thresh) {
	    ++nfail;
	}
/* L180: */
    }

    if (nfail > 0) {
	++ntestf;
    }
    if (ntestf == 1) {
	io___53.ciunit = *nounit;
	s_wsfe(&io___53);
	do_fio(&c__1, path, (ftnlen)3);
	e_wsfe();
	io___54.ciunit = *nounit;
	s_wsfe(&io___54);
	e_wsfe();
	io___55.ciunit = *nounit;
	s_wsfe(&io___55);
	e_wsfe();
	io___56.ciunit = *nounit;
	s_wsfe(&io___56);
	e_wsfe();
	io___57.ciunit = *nounit;
	s_wsfe(&io___57);
	do_fio(&c__1, (char *)&(*thresh), (ftnlen)sizeof(doublereal));
	e_wsfe();
	io___58.ciunit = *nounit;
	s_wsfe(&io___58);
	e_wsfe();
	ntestf = 2;
    }
    for (j = 1; j <= 17; ++j) {
	if (result[j] >= *thresh) {
	    io___59.ciunit = *nounit;
	    s_wsfe(&io___59);
	    do_fio(&c__1, (char *)&n, (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();
	}
/* L190: */
    }

    nerrs += nfail;
    ntestt += ntest;
    goto L160;
L200:

/*     Summary */

    dlasum_(path, nounit, &nerrs, &ntestt);



    return 0;

/*     End of DDRVSX */

} /* ddrvsx_ */
示例#20
0
文件: dtrt03.c 项目: zangel/uquad
/* Subroutine */ int dtrt03_(char *uplo, char *trans, char *diag, integer *n, 
	integer *nrhs, doublereal *a, integer *lda, doublereal *scale, 
	doublereal *cnorm, doublereal *tscal, doublereal *x, integer *ldx, 
	doublereal *b, integer *ldb, doublereal *work, doublereal *resid)
{
    /* System generated locals */
    integer a_dim1, a_offset, b_dim1, b_offset, x_dim1, x_offset, i__1;
    doublereal d__1, d__2, d__3;

    /* Local variables */
    static integer j;
    extern /* Subroutine */ int dscal_(integer *, doublereal *, doublereal *, 
	    integer *);
    extern logical lsame_(char *, char *);
    static doublereal xscal;
    extern /* Subroutine */ int dcopy_(integer *, doublereal *, integer *, 
	    doublereal *, integer *), daxpy_(integer *, doublereal *, 
	    doublereal *, integer *, doublereal *, integer *), dtrmv_(char *, 
	    char *, char *, integer *, doublereal *, integer *, doublereal *, 
	    integer *);
    static doublereal tnorm, xnorm;
    extern /* Subroutine */ int dlabad_(doublereal *, doublereal *);
    extern doublereal dlamch_(char *);
    static integer ix;
    extern integer idamax_(integer *, doublereal *, integer *);
    static doublereal bignum, smlnum, eps, err;


#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 x_ref(a_1,a_2) x[(a_2)*x_dim1 + a_1]


/*  -- LAPACK test routine (version 3.0) --   
       Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,   
       Courant Institute, Argonne National Lab, and Rice University   
       February 29, 1992   


    Purpose   
    =======   

    DTRT03 computes the residual for the solution to a scaled triangular   
    system of equations A*x = s*b  or  A'*x = s*b.   
    Here A is a triangular matrix, A' is the transpose of A, s is a   
    scalar, and x and b are N by NRHS matrices.  The test ratio is the   
    maximum over the number of right hand sides of   
       norm(s*b - op(A)*x) / ( norm(op(A)) * norm(x) * EPS ),   
    where op(A) denotes A or A' and EPS is the machine epsilon.   

    Arguments   
    =========   

    UPLO    (input) CHARACTER*1   
            Specifies whether the matrix A is upper or lower triangular.   
            = 'U':  Upper triangular   
            = 'L':  Lower triangular   

    TRANS   (input) CHARACTER*1   
            Specifies the operation applied to A.   
            = 'N':  A *x = s*b  (No transpose)   
            = 'T':  A'*x = s*b  (Transpose)   
            = 'C':  A'*x = s*b  (Conjugate transpose = Transpose)   

    DIAG    (input) CHARACTER*1   
            Specifies whether or not the matrix A is unit triangular.   
            = 'N':  Non-unit triangular   
            = 'U':  Unit triangular   

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

    NRHS    (input) INTEGER   
            The number of right hand sides, i.e., the number of columns   
            of the matrices X and B.  NRHS >= 0.   

    A       (input) DOUBLE PRECISION array, dimension (LDA,N)   
            The triangular matrix A.  If UPLO = 'U', the leading n by n   
            upper triangular part of the array A contains the upper   
            triangular matrix, and the strictly lower triangular part of   
            A is not referenced.  If UPLO = 'L', the leading n by n lower   
            triangular part of the array A contains the lower triangular   
            matrix, and the strictly upper triangular part of A is not   
            referenced.  If DIAG = 'U', the diagonal elements of A are   
            also not referenced and are assumed to be 1.   

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

    SCALE   (input) DOUBLE PRECISION   
            The scaling factor s used in solving the triangular system.   

    CNORM   (input) DOUBLE PRECISION array, dimension (N)   
            The 1-norms of the columns of A, not counting the diagonal.   

    TSCAL   (input) DOUBLE PRECISION   
            The scaling factor used in computing the 1-norms in CNORM.   
            CNORM actually contains the column norms of TSCAL*A.   

    X       (input) DOUBLE PRECISION array, dimension (LDX,NRHS)   
            The computed solution vectors for the system of linear   
            equations.   

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

    B       (input) DOUBLE PRECISION array, dimension (LDB,NRHS)   
            The right hand side vectors for the system of linear   
            equations.   

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

    WORK    (workspace) DOUBLE PRECISION array, dimension (N)   

    RESID   (output) DOUBLE PRECISION   
            The maximum over the number of right hand sides of   
            norm(op(A)*x - s*b) / ( norm(op(A)) * norm(x) * EPS ).   

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


       Quick exit if N = 0   

       Parameter adjustments */
    a_dim1 = *lda;
    a_offset = 1 + a_dim1 * 1;
    a -= a_offset;
    --cnorm;
    x_dim1 = *ldx;
    x_offset = 1 + x_dim1 * 1;
    x -= x_offset;
    b_dim1 = *ldb;
    b_offset = 1 + b_dim1 * 1;
    b -= b_offset;
    --work;

    /* Function Body */
    if (*n <= 0 || *nrhs <= 0) {
	*resid = 0.;
	return 0;
    }
    eps = dlamch_("Epsilon");
    smlnum = dlamch_("Safe minimum");
    bignum = 1. / smlnum;
    dlabad_(&smlnum, &bignum);

/*     Compute the norm of the triangular matrix A using the column   
       norms already computed by DLATRS. */

    tnorm = 0.;
    if (lsame_(diag, "N")) {
	i__1 = *n;
	for (j = 1; j <= i__1; ++j) {
/* Computing MAX */
	    d__2 = tnorm, d__3 = *tscal * (d__1 = a_ref(j, j), abs(d__1)) + 
		    cnorm[j];
	    tnorm = max(d__2,d__3);
/* L10: */
	}
    } else {
	i__1 = *n;
	for (j = 1; j <= i__1; ++j) {
/* Computing MAX */
	    d__1 = tnorm, d__2 = *tscal + cnorm[j];
	    tnorm = max(d__1,d__2);
/* L20: */
	}
    }

/*     Compute the maximum over the number of right hand sides of   
          norm(op(A)*x - s*b) / ( norm(op(A)) * norm(x) * EPS ). */

    *resid = 0.;
    i__1 = *nrhs;
    for (j = 1; j <= i__1; ++j) {
	dcopy_(n, &x_ref(1, j), &c__1, &work[1], &c__1);
	ix = idamax_(n, &work[1], &c__1);
/* Computing MAX */
	d__2 = 1., d__3 = (d__1 = x_ref(ix, j), abs(d__1));
	xnorm = max(d__2,d__3);
	xscal = 1. / xnorm / (doublereal) (*n);
	dscal_(n, &xscal, &work[1], &c__1);
	dtrmv_(uplo, trans, diag, n, &a[a_offset], lda, &work[1], &c__1);
	d__1 = -(*scale) * xscal;
	daxpy_(n, &d__1, &b_ref(1, j), &c__1, &work[1], &c__1);
	ix = idamax_(n, &work[1], &c__1);
	err = *tscal * (d__1 = work[ix], abs(d__1));
	ix = idamax_(n, &x_ref(1, j), &c__1);
	xnorm = (d__1 = x_ref(ix, j), abs(d__1));
	if (err * smlnum <= xnorm) {
	    if (xnorm > 0.) {
		err /= xnorm;
	    }
	} else {
	    if (err > 0.) {
		err = 1. / eps;
	    }
	}
	if (err * smlnum <= tnorm) {
	    if (tnorm > 0.) {
		err /= tnorm;
	    }
	} else {
	    if (err > 0.) {
		err = 1. / eps;
	    }
	}
	*resid = max(*resid,err);
/* L30: */
    }

    return 0;

/*     End of DTRT03 */

} /* dtrt03_ */
示例#21
0
/* Subroutine */ int zgels_(char *trans, integer *m, integer *n, integer *
	nrhs, doublecomplex *a, integer *lda, doublecomplex *b, integer *ldb, 
	doublecomplex *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   
    =======   

    ZGELS solves overdetermined or underdetermined complex linear systems   
    involving an M-by-N matrix A, or its conjugate-transpose, using a QR   
    or LQ factorization of A.  It is assumed that A has full rank.   

    The following options are provided:   

    1. If TRANS = 'N' and m >= n:  find the least squares solution of   
       an overdetermined system, i.e., solve the least squares problem   
                    minimize || B - A*X ||.   

    2. If TRANS = 'N' and m < n:  find the minimum norm solution of   
       an underdetermined system A * X = B.   

    3. If TRANS = 'C' and m >= n:  find the minimum norm solution of   
       an undetermined system A**H * X = B.   

    4. If TRANS = 'C' and m < n:  find the least squares solution of   
       an overdetermined system, i.e., solve the least squares problem   
                    minimize || B - A**H * X ||.   

    Several right hand side vectors b and solution vectors x can be   
    handled in a single call; they are stored as the columns of the   
    M-by-NRHS right hand side matrix B and the N-by-NRHS solution   
    matrix X.   

    Arguments   
    =========   

    TRANS   (input) CHARACTER   
            = 'N': the linear system involves A;   
            = 'C': the linear system involves A**H.   

    M       (input) INTEGER   
            The number of rows of the matrix A.  M >= 0.   

    N       (input) INTEGER   
            The number of columns of the matrix A.  N >= 0.   

    NRHS    (input) INTEGER   
            The number of right hand sides, i.e., the number of   
            columns of the matrices B and X. NRHS >= 0.   

    A       (input/output) COMPLEX*16 array, dimension (LDA,N)   
            On entry, the M-by-N matrix A.   
              if M >= N, A is overwritten by details of its QR   
                         factorization as returned by ZGEQRF;   
              if M <  N, A is overwritten by details of its LQ   
                         factorization as returned by ZGELQF.   

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

    B       (input/output) COMPLEX*16 array, dimension (LDB,NRHS)   
            On entry, the matrix B of right hand side vectors, stored   
            columnwise; B is M-by-NRHS if TRANS = 'N', or N-by-NRHS   
            if TRANS = 'C'.   
            On exit, B is overwritten by the solution vectors, stored   
            columnwise:   
            if TRANS = 'N' and m >= n, rows 1 to n of B contain the least   
            squares solution vectors; the residual sum of squares for the   
            solution in each column is given by the sum of squares of   
            elements N+1 to M in that column;   
            if TRANS = 'N' and m < n, rows 1 to N of B contain the   
            minimum norm solution vectors;   
            if TRANS = 'C' and m >= n, rows 1 to M of B contain the   
            minimum norm solution vectors;   
            if TRANS = 'C' and m < n, rows 1 to M of B contain the   
            least squares solution vectors; the residual sum of squares   
            for the solution in each column is given by the sum of   
            squares of elements M+1 to N in that column.   

    LDB     (input) INTEGER   
            The leading dimension of the array B. LDB >= MAX(1,M,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, MN + max( MN, NRHS ) ).   
            For optimal performance,   
            LWORK >= max( 1, MN + max( MN, NRHS )*NB ).   
            where MN = min(M,N) and NB is the optimum block size.   

            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   

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


       Test 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_n1 = -1;
    static integer c__0 = 0;
    
    /* System generated locals */
    integer a_dim1, a_offset, b_dim1, b_offset, i__1, i__2, i__3;
    doublereal d__1;
    /* Local variables */
    static doublereal anrm, bnrm;
    static integer brow;
    static logical tpsd;
    static integer i__, j, iascl, ibscl;
    extern logical lsame_(char *, char *);
    static integer wsize;
    static doublereal rwork[1];
    extern /* Subroutine */ int ztrsm_(char *, char *, char *, char *, 
	    integer *, integer *, doublecomplex *, doublecomplex *, integer *,
	     doublecomplex *, integer *), 
	    dlabad_(doublereal *, doublereal *);
    static integer nb;
    extern doublereal dlamch_(char *);
    static integer mn;
    extern /* Subroutine */ int xerbla_(char *, integer *);
    extern integer ilaenv_(integer *, char *, char *, integer *, integer *, 
	    integer *, integer *, ftnlen, ftnlen);
    static integer scllen;
    static doublereal bignum;
    extern doublereal zlange_(char *, integer *, integer *, doublecomplex *, 
	    integer *, doublereal *);
    extern /* Subroutine */ int zgelqf_(integer *, integer *, doublecomplex *,
	     integer *, doublecomplex *, doublecomplex *, integer *, integer *
	    ), zlascl_(char *, integer *, integer *, doublereal *, doublereal 
	    *, integer *, integer *, doublecomplex *, integer *, integer *), zgeqrf_(integer *, integer *, doublecomplex *, integer *,
	     doublecomplex *, doublecomplex *, integer *, integer *), zlaset_(
	    char *, integer *, integer *, doublecomplex *, doublecomplex *, 
	    doublecomplex *, integer *);
    static doublereal smlnum;
    static logical lquery;
    extern /* Subroutine */ int zunmlq_(char *, char *, integer *, integer *, 
	    integer *, doublecomplex *, integer *, doublecomplex *, 
	    doublecomplex *, integer *, doublecomplex *, integer *, integer *), zunmqr_(char *, char *, integer *, integer *, 
	    integer *, doublecomplex *, integer *, doublecomplex *, 
	    doublecomplex *, integer *, doublecomplex *, integer *, integer *);
#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)]


    a_dim1 = *lda;
    a_offset = 1 + a_dim1 * 1;
    a -= a_offset;
    b_dim1 = *ldb;
    b_offset = 1 + b_dim1 * 1;
    b -= b_offset;
    --work;

    /* Function Body */
    *info = 0;
    mn = min(*m,*n);
    lquery = *lwork == -1;
    if (! (lsame_(trans, "N") || lsame_(trans, "C"))) {
	*info = -1;
    } else if (*m < 0) {
	*info = -2;
    } else if (*n < 0) {
	*info = -3;
    } else if (*nrhs < 0) {
	*info = -4;
    } else if (*lda < max(1,*m)) {
	*info = -6;
    } else /* if(complicated condition) */ {
/* Computing MAX */
	i__1 = max(1,*m);
	if (*ldb < max(i__1,*n)) {
	    *info = -8;
	} else /* if(complicated condition) */ {
/* Computing MAX */
	    i__1 = 1, i__2 = mn + max(mn,*nrhs);
	    if (*lwork < max(i__1,i__2) && ! lquery) {
		*info = -10;
	    }
	}
    }

/*     Figure out optimal block size */

    if (*info == 0 || *info == -10) {

	tpsd = TRUE_;
	if (lsame_(trans, "N")) {
	    tpsd = FALSE_;
	}

	if (*m >= *n) {
	    nb = ilaenv_(&c__1, "ZGEQRF", " ", m, n, &c_n1, &c_n1, (ftnlen)6, 
		    (ftnlen)1);
	    if (tpsd) {
/* Computing MAX */
		i__1 = nb, i__2 = ilaenv_(&c__1, "ZUNMQR", "LN", m, nrhs, n, &
			c_n1, (ftnlen)6, (ftnlen)2);
		nb = max(i__1,i__2);
	    } else {
/* Computing MAX */
		i__1 = nb, i__2 = ilaenv_(&c__1, "ZUNMQR", "LC", m, nrhs, n, &
			c_n1, (ftnlen)6, (ftnlen)2);
		nb = max(i__1,i__2);
	    }
	} else {
	    nb = ilaenv_(&c__1, "ZGELQF", " ", m, n, &c_n1, &c_n1, (ftnlen)6, 
		    (ftnlen)1);
	    if (tpsd) {
/* Computing MAX */
		i__1 = nb, i__2 = ilaenv_(&c__1, "ZUNMLQ", "LC", n, nrhs, m, &
			c_n1, (ftnlen)6, (ftnlen)2);
		nb = max(i__1,i__2);
	    } else {
/* Computing MAX */
		i__1 = nb, i__2 = ilaenv_(&c__1, "ZUNMLQ", "LN", n, nrhs, m, &
			c_n1, (ftnlen)6, (ftnlen)2);
		nb = max(i__1,i__2);
	    }
	}

/* Computing MAX */
	i__1 = 1, i__2 = mn + max(mn,*nrhs) * nb;
	wsize = max(i__1,i__2);
	d__1 = (doublereal) wsize;
	work[1].r = d__1, work[1].i = 0.;

    }

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

/*     Quick return if possible   

   Computing MIN */
    i__1 = min(*m,*n);
    if (min(i__1,*nrhs) == 0) {
	i__1 = max(*m,*n);
	zlaset_("Full", &i__1, nrhs, &c_b1, &c_b1, &b[b_offset], ldb);
	return 0;
    }

/*     Get machine parameters */

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

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

    anrm = zlange_("M", m, n, &a[a_offset], lda, rwork);
    iascl = 0;
    if (anrm > 0. && anrm < smlnum) {

/*        Scale matrix norm up to SMLNUM */

	zlascl_("G", &c__0, &c__0, &anrm, &smlnum, m, n, &a[a_offset], lda, 
		info);
	iascl = 1;
    } else if (anrm > bignum) {

/*        Scale matrix norm down to BIGNUM */

	zlascl_("G", &c__0, &c__0, &anrm, &bignum, m, n, &a[a_offset], lda, 
		info);
	iascl = 2;
    } else if (anrm == 0.) {

/*        Matrix all zero. Return zero solution. */

	i__1 = max(*m,*n);
	zlaset_("F", &i__1, nrhs, &c_b1, &c_b1, &b[b_offset], ldb);
	goto L50;
    }

    brow = *m;
    if (tpsd) {
	brow = *n;
    }
    bnrm = zlange_("M", &brow, nrhs, &b[b_offset], ldb, rwork);
    ibscl = 0;
    if (bnrm > 0. && bnrm < smlnum) {

/*        Scale matrix norm up to SMLNUM */

	zlascl_("G", &c__0, &c__0, &bnrm, &smlnum, &brow, nrhs, &b[b_offset], 
		ldb, info);
	ibscl = 1;
    } else if (bnrm > bignum) {

/*        Scale matrix norm down to BIGNUM */

	zlascl_("G", &c__0, &c__0, &bnrm, &bignum, &brow, nrhs, &b[b_offset], 
		ldb, info);
	ibscl = 2;
    }

    if (*m >= *n) {

/*        compute QR factorization of A */

	i__1 = *lwork - mn;
	zgeqrf_(m, n, &a[a_offset], lda, &work[1], &work[mn + 1], &i__1, info)
		;

/*        workspace at least N, optimally N*NB */

	if (! tpsd) {

/*           Least-Squares Problem min || A * X - B ||   

             B(1:M,1:NRHS) := Q' * B(1:M,1:NRHS) */

	    i__1 = *lwork - mn;
	    zunmqr_("Left", "Conjugate transpose", m, nrhs, n, &a[a_offset], 
		    lda, &work[1], &b[b_offset], ldb, &work[mn + 1], &i__1, 
		    info);

/*           workspace at least NRHS, optimally NRHS*NB   

             B(1:N,1:NRHS) := inv(R) * B(1:N,1:NRHS) */

	    ztrsm_("Left", "Upper", "No transpose", "Non-unit", n, nrhs, &
		    c_b2, &a[a_offset], lda, &b[b_offset], ldb);

	    scllen = *n;

	} else {

/*           Overdetermined system of equations A' * X = B   

             B(1:N,1:NRHS) := inv(R') * B(1:N,1:NRHS) */

	    ztrsm_("Left", "Upper", "Conjugate transpose", "Non-unit", n, 
		    nrhs, &c_b2, &a[a_offset], lda, &b[b_offset], ldb);

/*           B(N+1:M,1:NRHS) = ZERO */

	    i__1 = *nrhs;
	    for (j = 1; j <= i__1; ++j) {
		i__2 = *m;
		for (i__ = *n + 1; i__ <= i__2; ++i__) {
		    i__3 = b_subscr(i__, j);
		    b[i__3].r = 0., b[i__3].i = 0.;
/* L10: */
		}
/* L20: */
	    }

/*           B(1:M,1:NRHS) := Q(1:N,:) * B(1:N,1:NRHS) */

	    i__1 = *lwork - mn;
	    zunmqr_("Left", "No transpose", m, nrhs, n, &a[a_offset], lda, &
		    work[1], &b[b_offset], ldb, &work[mn + 1], &i__1, info);

/*           workspace at least NRHS, optimally NRHS*NB */

	    scllen = *m;

	}

    } else {

/*        Compute LQ factorization of A */

	i__1 = *lwork - mn;
	zgelqf_(m, n, &a[a_offset], lda, &work[1], &work[mn + 1], &i__1, info)
		;

/*        workspace at least M, optimally M*NB. */

	if (! tpsd) {

/*           underdetermined system of equations A * X = B   

             B(1:M,1:NRHS) := inv(L) * B(1:M,1:NRHS) */

	    ztrsm_("Left", "Lower", "No transpose", "Non-unit", m, nrhs, &
		    c_b2, &a[a_offset], lda, &b[b_offset], ldb);

/*           B(M+1:N,1:NRHS) = 0 */

	    i__1 = *nrhs;
	    for (j = 1; j <= i__1; ++j) {
		i__2 = *n;
		for (i__ = *m + 1; i__ <= i__2; ++i__) {
		    i__3 = b_subscr(i__, j);
		    b[i__3].r = 0., b[i__3].i = 0.;
/* L30: */
		}
/* L40: */
	    }

/*           B(1:N,1:NRHS) := Q(1:N,:)' * B(1:M,1:NRHS) */

	    i__1 = *lwork - mn;
	    zunmlq_("Left", "Conjugate transpose", n, nrhs, m, &a[a_offset], 
		    lda, &work[1], &b[b_offset], ldb, &work[mn + 1], &i__1, 
		    info);

/*           workspace at least NRHS, optimally NRHS*NB */

	    scllen = *n;

	} else {

/*           overdetermined system min || A' * X - B ||   

             B(1:N,1:NRHS) := Q * B(1:N,1:NRHS) */

	    i__1 = *lwork - mn;
	    zunmlq_("Left", "No transpose", n, nrhs, m, &a[a_offset], lda, &
		    work[1], &b[b_offset], ldb, &work[mn + 1], &i__1, info);

/*           workspace at least NRHS, optimally NRHS*NB   

             B(1:M,1:NRHS) := inv(L') * B(1:M,1:NRHS) */

	    ztrsm_("Left", "Lower", "Conjugate transpose", "Non-unit", m, 
		    nrhs, &c_b2, &a[a_offset], lda, &b[b_offset], ldb);

	    scllen = *m;

	}

    }

/*     Undo scaling */

    if (iascl == 1) {
	zlascl_("G", &c__0, &c__0, &anrm, &smlnum, &scllen, nrhs, &b[b_offset]
		, ldb, info);
    } else if (iascl == 2) {
	zlascl_("G", &c__0, &c__0, &anrm, &bignum, &scllen, nrhs, &b[b_offset]
		, ldb, info);
    }
    if (ibscl == 1) {
	zlascl_("G", &c__0, &c__0, &smlnum, &bnrm, &scllen, nrhs, &b[b_offset]
		, ldb, info);
    } else if (ibscl == 2) {
	zlascl_("G", &c__0, &c__0, &bignum, &bnrm, &scllen, nrhs, &b[b_offset]
		, ldb, info);
    }

L50:
    d__1 = (doublereal) wsize;
    work[1].r = d__1, work[1].i = 0.;

    return 0;

/*     End of ZGELS */

} /* zgels_ */
示例#22
0
/* Subroutine */ int zlatb4_(char *path, integer *imat, integer *m, integer *
                             n, char *type__, integer *kl, integer *ku, doublereal *anorm, integer
                             *mode, doublereal *cndnum, char *dist)
{
    /* Initialized data */

    static logical first = TRUE_;

    /* System generated locals */
    integer i__1;

    /* Builtin functions */
    double sqrt(doublereal);
    /* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);

    /* Local variables */
    char c2[2];
    integer mat;
    static doublereal eps, badc1, badc2, large, small;
    extern /* Subroutine */ int dlabad_(doublereal *, doublereal *);
    extern doublereal dlamch_(char *);
    extern logical lsamen_(integer *, char *, char *);


    /*  -- LAPACK test routine (version 3.1) -- */
    /*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
    /*     November 2006 */

    /*     .. Scalar Arguments .. */
    /*     .. */

    /*  Purpose */
    /*  ======= */

    /*  ZLATB4 sets parameters for the matrix generator based on the type of */
    /*  matrix to be generated. */

    /*  Arguments */
    /*  ========= */

    /*  PATH    (input) CHARACTER*3 */
    /*          The LAPACK path name. */

    /*  IMAT    (input) INTEGER */
    /*          An integer key describing which matrix to generate for this */
    /*          path. */

    /*  M       (input) INTEGER */
    /*          The number of rows in the matrix to be generated. */

    /*  N       (input) INTEGER */
    /*          The number of columns in the matrix to be generated. */

    /*  TYPE    (output) CHARACTER*1 */
    /*          The type of the matrix to be generated: */
    /*          = 'S':  symmetric matrix */
    /*          = 'P':  symmetric positive (semi)definite matrix */
    /*          = 'N':  nonsymmetric matrix */

    /*  KL      (output) INTEGER */
    /*          The lower band width of the matrix to be generated. */

    /*  KU      (output) INTEGER */
    /*          The upper band width of the matrix to be generated. */

    /*  ANORM   (output) DOUBLE PRECISION */
    /*          The desired norm of the matrix to be generated.  The diagonal */
    /*          matrix of singular values or eigenvalues is scaled by this */
    /*          value. */

    /*  MODE    (output) INTEGER */
    /*          A key indicating how to choose the vector of eigenvalues. */

    /*  CNDNUM  (output) DOUBLE PRECISION */
    /*          The desired condition number. */

    /*  DIST    (output) CHARACTER*1 */
    /*          The type of distribution to be used by the random number */
    /*          generator. */

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

    /*     .. Parameters .. */
    /*     .. */
    /*     .. Local Scalars .. */
    /*     .. */
    /*     .. External Functions .. */
    /*     .. */
    /*     .. Intrinsic Functions .. */
    /*     .. */
    /*     .. External Subroutines .. */
    /*     .. */
    /*     .. Save statement .. */
    /*     .. */
    /*     .. Data statements .. */
    /*     .. */
    /*     .. Executable Statements .. */

    /*     Set some constants for use in the subroutine. */

    if (first) {
        first = FALSE_;
        eps = dlamch_("Precision");
        badc2 = .1 / eps;
        badc1 = sqrt(badc2);
        small = dlamch_("Safe minimum");
        large = 1. / small;

        /*        If it looks like we're on a Cray, take the square root of */
        /*        SMALL and LARGE to avoid overflow and underflow problems. */

        dlabad_(&small, &large);
        small = small / eps * .25;
        large = 1. / small;
    }

    s_copy(c2, path + 1, (ftnlen)2, (ftnlen)2);

    /*     Set some parameters we don't plan to change. */

    *(unsigned char *)dist = 'S';
    *mode = 3;

    /*     xQR, xLQ, xQL, xRQ:  Set parameters to generate a general */
    /*                          M x N matrix. */

    if (lsamen_(&c__2, c2, "QR") || lsamen_(&c__2, c2,
                                            "LQ") || lsamen_(&c__2, c2, "QL") || lsamen_(&c__2, c2, "RQ")) {

        /*        Set TYPE, the type of matrix to be generated. */

        *(unsigned char *)type__ = 'N';

        /*        Set the lower and upper bandwidths. */

        if (*imat == 1) {
            *kl = 0;
            *ku = 0;
        } else if (*imat == 2) {
            *kl = 0;
            /* Computing MAX */
            i__1 = *n - 1;
            *ku = max(i__1,0);
        } else if (*imat == 3) {
            /* Computing MAX */
            i__1 = *m - 1;
            *kl = max(i__1,0);
            *ku = 0;
        } else {
            /* Computing MAX */
            i__1 = *m - 1;
            *kl = max(i__1,0);
            /* Computing MAX */
            i__1 = *n - 1;
            *ku = max(i__1,0);
        }

        /*        Set the condition number and norm. */

        if (*imat == 5) {
            *cndnum = badc1;
        } else if (*imat == 6) {
            *cndnum = badc2;
        } else {
            *cndnum = 2.;
        }

        if (*imat == 7) {
            *anorm = small;
        } else if (*imat == 8) {
            *anorm = large;
        } else {
            *anorm = 1.;
        }

    } else if (lsamen_(&c__2, c2, "GE")) {

        /*        xGE:  Set parameters to generate a general M x N matrix. */

        /*        Set TYPE, the type of matrix to be generated. */

        *(unsigned char *)type__ = 'N';

        /*        Set the lower and upper bandwidths. */

        if (*imat == 1) {
            *kl = 0;
            *ku = 0;
        } else if (*imat == 2) {
            *kl = 0;
            /* Computing MAX */
            i__1 = *n - 1;
            *ku = max(i__1,0);
        } else if (*imat == 3) {
            /* Computing MAX */
            i__1 = *m - 1;
            *kl = max(i__1,0);
            *ku = 0;
        } else {
            /* Computing MAX */
            i__1 = *m - 1;
            *kl = max(i__1,0);
            /* Computing MAX */
            i__1 = *n - 1;
            *ku = max(i__1,0);
        }

        /*        Set the condition number and norm. */

        if (*imat == 8) {
            *cndnum = badc1;
        } else if (*imat == 9) {
            *cndnum = badc2;
        } else {
            *cndnum = 2.;
        }

        if (*imat == 10) {
            *anorm = small;
        } else if (*imat == 11) {
            *anorm = large;
        } else {
            *anorm = 1.;
        }

    } else if (lsamen_(&c__2, c2, "GB")) {

        /*        xGB:  Set parameters to generate a general banded matrix. */

        /*        Set TYPE, the type of matrix to be generated. */

        *(unsigned char *)type__ = 'N';

        /*        Set the condition number and norm. */

        if (*imat == 5) {
            *cndnum = badc1;
        } else if (*imat == 6) {
            *cndnum = badc2 * .1;
        } else {
            *cndnum = 2.;
        }

        if (*imat == 7) {
            *anorm = small;
        } else if (*imat == 8) {
            *anorm = large;
        } else {
            *anorm = 1.;
        }

    } else if (lsamen_(&c__2, c2, "GT")) {

        /*        xGT:  Set parameters to generate a general tridiagonal matrix. */

        /*        Set TYPE, the type of matrix to be generated. */

        *(unsigned char *)type__ = 'N';

        /*        Set the lower and upper bandwidths. */

        if (*imat == 1) {
            *kl = 0;
        } else {
            *kl = 1;
        }
        *ku = *kl;

        /*        Set the condition number and norm. */

        if (*imat == 3) {
            *cndnum = badc1;
        } else if (*imat == 4) {
            *cndnum = badc2;
        } else {
            *cndnum = 2.;
        }

        if (*imat == 5 || *imat == 11) {
            *anorm = small;
        } else if (*imat == 6 || *imat == 12) {
            *anorm = large;
        } else {
            *anorm = 1.;
        }

    } else if (lsamen_(&c__2, c2, "PO") || lsamen_(&
               c__2, c2, "PP") || lsamen_(&c__2, c2, "HE") || lsamen_(&c__2, c2, "HP") || lsamen_(&c__2, c2, "SY") ||
               lsamen_(&c__2, c2, "SP")) {

        /*        xPO, xPP, xHE, xHP, xSY, xSP: Set parameters to generate a */
        /*        symmetric or Hermitian matrix. */

        /*        Set TYPE, the type of matrix to be generated. */

        *(unsigned char *)type__ = *(unsigned char *)c2;

        /*        Set the lower and upper bandwidths. */

        if (*imat == 1) {
            *kl = 0;
        } else {
            /* Computing MAX */
            i__1 = *n - 1;
            *kl = max(i__1,0);
        }
        *ku = *kl;

        /*        Set the condition number and norm. */

        if (*imat == 6) {
            *cndnum = badc1;
        } else if (*imat == 7) {
            *cndnum = badc2;
        } else {
            *cndnum = 2.;
        }

        if (*imat == 8) {
            *anorm = small;
        } else if (*imat == 9) {
            *anorm = large;
        } else {
            *anorm = 1.;
        }

    } else if (lsamen_(&c__2, c2, "PB")) {

        /*        xPB:  Set parameters to generate a symmetric band matrix. */

        /*        Set TYPE, the type of matrix to be generated. */

        *(unsigned char *)type__ = 'P';

        /*        Set the norm and condition number. */

        if (*imat == 5) {
            *cndnum = badc1;
        } else if (*imat == 6) {
            *cndnum = badc2;
        } else {
            *cndnum = 2.;
        }

        if (*imat == 7) {
            *anorm = small;
        } else if (*imat == 8) {
            *anorm = large;
        } else {
            *anorm = 1.;
        }

    } else if (lsamen_(&c__2, c2, "PT")) {

        /*        xPT:  Set parameters to generate a symmetric positive definite */
        /*        tridiagonal matrix. */

        *(unsigned char *)type__ = 'P';
        if (*imat == 1) {
            *kl = 0;
        } else {
            *kl = 1;
        }
        *ku = *kl;

        /*        Set the condition number and norm. */

        if (*imat == 3) {
            *cndnum = badc1;
        } else if (*imat == 4) {
            *cndnum = badc2;
        } else {
            *cndnum = 2.;
        }

        if (*imat == 5 || *imat == 11) {
            *anorm = small;
        } else if (*imat == 6 || *imat == 12) {
            *anorm = large;
        } else {
            *anorm = 1.;
        }

    } else if (lsamen_(&c__2, c2, "TR") || lsamen_(&
               c__2, c2, "TP")) {

        /*        xTR, xTP:  Set parameters to generate a triangular matrix */

        /*        Set TYPE, the type of matrix to be generated. */

        *(unsigned char *)type__ = 'N';

        /*        Set the lower and upper bandwidths. */

        mat = abs(*imat);
        if (mat == 1 || mat == 7) {
            *kl = 0;
            *ku = 0;
        } else if (*imat < 0) {
            /* Computing MAX */
            i__1 = *n - 1;
            *kl = max(i__1,0);
            *ku = 0;
        } else {
            *kl = 0;
            /* Computing MAX */
            i__1 = *n - 1;
            *ku = max(i__1,0);
        }

        /*        Set the condition number and norm. */

        if (mat == 3 || mat == 9) {
            *cndnum = badc1;
        } else if (mat == 4 || mat == 10) {
            *cndnum = badc2;
        } else {
            *cndnum = 2.;
        }

        if (mat == 5) {
            *anorm = small;
        } else if (mat == 6) {
            *anorm = large;
        } else {
            *anorm = 1.;
        }

    } else if (lsamen_(&c__2, c2, "TB")) {

        /*        xTB:  Set parameters to generate a triangular band matrix. */

        /*        Set TYPE, the type of matrix to be generated. */

        *(unsigned char *)type__ = 'N';

        /*        Set the norm and condition number. */

        if (*imat == 2 || *imat == 8) {
            *cndnum = badc1;
        } else if (*imat == 3 || *imat == 9) {
            *cndnum = badc2;
        } else {
            *cndnum = 2.;
        }

        if (*imat == 4) {
            *anorm = small;
        } else if (*imat == 5) {
            *anorm = large;
        } else {
            *anorm = 1.;
        }
    }
    if (*n <= 1) {
        *cndnum = 1.;
    }

    return 0;

    /*     End of ZLATB4 */

} /* zlatb4_ */
示例#23
0
/* Subroutine */ int zlatrs_(char *uplo, char *trans, char *diag, char *
	normin, integer *n, doublecomplex *a, integer *lda, doublecomplex *x, 
	doublereal *scale, doublereal *cnorm, integer *info)
{
    /* System generated locals */
    integer a_dim1, a_offset, i__1, i__2, i__3, i__4, i__5;
    doublereal d__1, d__2, d__3, d__4;
    doublecomplex z__1, z__2, z__3, z__4;

    /* Local variables */
    integer i__, j;
    doublereal xj, rec, tjj;
    integer jinc;
    doublereal xbnd;
    integer imax;
    doublereal tmax;
    doublecomplex tjjs;
    doublereal xmax, grow;
    doublereal tscal;
    doublecomplex uscal;
    integer jlast;
    doublecomplex csumj;
    logical upper;
    doublereal bignum;
    logical notran;
    integer jfirst;
    doublereal smlnum;
    logical nounit;

/*  -- LAPACK auxiliary routine (version 3.2) -- */
/*     November 2006 */

/*  Purpose */
/*  ======= */

/*  ZLATRS solves one of the triangular systems */

/*     A * x = s*b,  A**T * x = s*b,  or  A**H * x = s*b, */

/*  with scaling to prevent overflow.  Here A is an upper or lower */
/*  triangular matrix, A**T denotes the transpose of A, A**H denotes the */
/*  conjugate transpose of A, x and b are n-element vectors, and s is a */
/*  scaling factor, usually less than or equal to 1, chosen so that the */
/*  components of x will be less than the overflow threshold.  If the */
/*  unscaled problem will not cause overflow, the Level 2 BLAS routine */
/*  ZTRSV is called. If the matrix A is singular (A(j,j) = 0 for some j), */
/*  then s is set to 0 and a non-trivial solution to A*x = 0 is returned. */

/*  Arguments */
/*  ========= */

/*  UPLO    (input) CHARACTER*1 */
/*          Specifies whether the matrix A is upper or lower triangular. */
/*          = 'U':  Upper triangular */
/*          = 'L':  Lower triangular */

/*  TRANS   (input) CHARACTER*1 */
/*          Specifies the operation applied to A. */
/*          = 'N':  Solve A * x = s*b     (No transpose) */
/*          = 'T':  Solve A**T * x = s*b  (Transpose) */
/*          = 'C':  Solve A**H * x = s*b  (Conjugate transpose) */

/*  DIAG    (input) CHARACTER*1 */
/*          Specifies whether or not the matrix A is unit triangular. */
/*          = 'N':  Non-unit triangular */
/*          = 'U':  Unit triangular */

/*  NORMIN  (input) CHARACTER*1 */
/*          Specifies whether CNORM has been set or not. */
/*          = 'Y':  CNORM contains the column norms on entry */
/*          = 'N':  CNORM is not set on entry.  On exit, the norms will */
/*                  be computed and stored in CNORM. */

/*  N       (input) INTEGER */
/*          The order of the matrix A.  N >= 0. */

/*  A       (input) COMPLEX*16 array, dimension (LDA,N) */
/*          The triangular matrix A.  If UPLO = 'U', the leading n by n */
/*          upper triangular part of the array A contains the upper */
/*          triangular matrix, and the strictly lower triangular part of */
/*          A is not referenced.  If UPLO = 'L', the leading n by n lower */
/*          triangular part of the array A contains the lower triangular */
/*          matrix, and the strictly upper triangular part of A is not */
/*          referenced.  If DIAG = 'U', the diagonal elements of A are */
/*          also not referenced and are assumed to be 1. */

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

/*  X       (input/output) COMPLEX*16 array, dimension (N) */
/*          On entry, the right hand side b of the triangular system. */
/*          On exit, X is overwritten by the solution vector x. */

/*  SCALE   (output) DOUBLE PRECISION */
/*          The scaling factor s for the triangular system */
/*             A * x = s*b,  A**T * x = s*b,  or  A**H * x = s*b. */
/*          If SCALE = 0, the matrix A is singular or badly scaled, and */
/*          the vector x is an exact or approximate solution to A*x = 0. */

/*  CNORM   (input or output) DOUBLE PRECISION array, dimension (N) */

/*          If NORMIN = 'Y', CNORM is an input argument and CNORM(j) */
/*          contains the norm of the off-diagonal part of the j-th column */
/*          of A.  If TRANS = 'N', CNORM(j) must be greater than or equal */
/*          to the infinity-norm, and if TRANS = 'T' or 'C', CNORM(j) */
/*          must be greater than or equal to the 1-norm. */

/*          If NORMIN = 'N', CNORM is an output argument and CNORM(j) */
/*          returns the 1-norm of the offdiagonal part of the j-th column */
/*          of A. */

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

/*  Further Details */
/*  ======= ======= */

/*  A rough bound on x is computed; if that is less than overflow, ZTRSV */
/*  is called, otherwise, specific code is used which checks for possible */
/*  overflow or divide-by-zero at every operation. */

/*  A columnwise scheme is used for solving A*x = b.  The basic algorithm */
/*  if A is lower triangular is */

/*       x[1:n] := b[1:n] */
/*            x(j) := x(j) / A(j,j) */
/*            x[j+1:n] := x[j+1:n] - x(j) * A[j+1:n,j] */
/*       end */

/*  Define bounds on the components of x after j iterations of the loop: */
/*     M(j) = bound on x[1:j] */
/*     G(j) = bound on x[j+1:n] */

/*  Then for iteration j+1 we have */
/*     M(j+1) <= G(j) / | A(j+1,j+1) | */
/*     G(j+1) <= G(j) + M(j+1) * | A[j+2:n,j+1] | */
/*            <= G(j) ( 1 + CNORM(j+1) / | A(j+1,j+1) | ) */

/*  where CNORM(j+1) is greater than or equal to the infinity-norm of */
/*  column j+1 of A, not counting the diagonal.  Hence */

/*     G(j) <= G(0) product ( 1 + CNORM(i) / | A(i,i) | ) */
/*                  1<=i<=j */
/*  and */

/*     |x(j)| <= ( G(0) / |A(j,j)| ) product ( 1 + CNORM(i) / |A(i,i)| ) */
/*                                   1<=i< j */

/*  Since |x(j)| <= M(j), we use the Level 2 BLAS routine ZTRSV if the */
/*  max(underflow, 1/overflow). */

/*  The bound on x(j) is also used to determine when a step in the */
/*  columnwise method can be performed without fear of overflow.  If */
/*  the computed bound is greater than a large constant, x is scaled to */
/*  prevent overflow, but if the bound overflows, x is set to 0, x(j) to */
/*  1, and scale to 0, and a non-trivial solution to A*x = 0 is found. */

/*  Similarly, a row-wise scheme is used to solve A**T *x = b  or */
/*  A**H *x = b.  The basic algorithm for A upper triangular is */

/*            x(j) := ( b(j) - A[1:j-1,j]' * x[1:j-1] ) / A(j,j) */
/*       end */

/*  We simultaneously compute two bounds */
/*       G(j) = bound on ( b(i) - A[1:i-1,i]' * x[1:i-1] ), 1<=i<=j */
/*       M(j) = bound on x(i), 1<=i<=j */

/*  add the constraint G(j) >= G(j-1) and M(j) >= M(j-1) for j >= 1. */
/*  Then the bound on x(j) is */

/*       M(j) <= M(j-1) * ( 1 + CNORM(j) ) / | A(j,j) | */

/*            <= M(0) * product ( ( 1 + CNORM(i) ) / |A(i,i)| ) */
/*                      1<=i<=j */

/*  and we can safely call ZTRSV if 1/M(n) and 1/G(n) are both greater */
/*  than max(underflow, 1/overflow). */

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

    /* Parameter adjustments */
    a_dim1 = *lda;
    a_offset = 1 + a_dim1;
    a -= a_offset;
    --x;
    --cnorm;

    /* Function Body */
    *info = 0;
    upper = lsame_(uplo, "U");
    notran = lsame_(trans, "N");
    nounit = lsame_(diag, "N");

/*     Test the input parameters. */

    if (! upper && ! lsame_(uplo, "L")) {
	*info = -1;
    } else if (! notran && ! lsame_(trans, "T") && ! 
	    lsame_(trans, "C")) {
	*info = -2;
    } else if (! nounit && ! lsame_(diag, "U")) {
	*info = -3;
    } else if (! lsame_(normin, "Y") && ! lsame_(normin, 
	     "N")) {
	*info = -4;
    } else if (*n < 0) {
	*info = -5;
    } else if (*lda < max(1,*n)) {
	*info = -7;
    }
    if (*info != 0) {
	i__1 = -(*info);
	xerbla_("ZLATRS", &i__1);
	return 0;
    }

/*     Quick return if possible */

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

/*     Determine machine dependent parameters to control overflow. */

    smlnum = dlamch_("Safe minimum");
    bignum = 1. / smlnum;
    dlabad_(&smlnum, &bignum);
    smlnum /= dlamch_("Precision");
    bignum = 1. / smlnum;
    *scale = 1.;

    if (lsame_(normin, "N")) {

/*        Compute the 1-norm of each column, not including the diagonal. */

	if (upper) {

/*           A is upper triangular. */

	    i__1 = *n;
	    for (j = 1; j <= i__1; ++j) {
		i__2 = j - 1;
		cnorm[j] = dzasum_(&i__2, &a[j * a_dim1 + 1], &c__1);
	    }
	} else {

/*           A is lower triangular. */

	    i__1 = *n - 1;
	    for (j = 1; j <= i__1; ++j) {
		i__2 = *n - j;
		cnorm[j] = dzasum_(&i__2, &a[j + 1 + j * a_dim1], &c__1);
	    }
	    cnorm[*n] = 0.;
	}
    }

/*     Scale the column norms by TSCAL if the maximum element in CNORM is */
/*     greater than BIGNUM/2. */

    imax = idamax_(n, &cnorm[1], &c__1);
    tmax = cnorm[imax];
    if (tmax <= bignum * .5) {
	tscal = 1.;
    } else {
	tscal = .5 / (smlnum * tmax);
	dscal_(n, &tscal, &cnorm[1], &c__1);
    }

/*     Compute a bound on the computed solution vector to see if the */
/*     Level 2 BLAS routine ZTRSV can be used. */

    xmax = 0.;
    i__1 = *n;
    for (j = 1; j <= i__1; ++j) {
/* Computing MAX */
	i__2 = j;
	d__3 = xmax, d__4 = (d__1 = x[i__2].r / 2., abs(d__1)) + (d__2 = 
		d_imag(&x[j]) / 2., abs(d__2));
	xmax = max(d__3,d__4);
    }
    xbnd = xmax;

    if (notran) {

/*        Compute the growth in A * x = b. */

	if (upper) {
	    jfirst = *n;
	    jlast = 1;
	    jinc = -1;
	} else {
	    jfirst = 1;
	    jlast = *n;
	    jinc = 1;
	}

	if (tscal != 1.) {
	    grow = 0.;
	    goto L60;
	}

	if (nounit) {

/*           A is non-unit triangular. */

/*           Compute GROW = 1/G(j) and XBND = 1/M(j). */

	    grow = .5 / max(xbnd,smlnum);
	    xbnd = grow;
	    i__1 = jlast;
	    i__2 = jinc;
	    for (j = jfirst; i__2 < 0 ? j >= i__1 : j <= i__1; j += i__2) {

/*              Exit the loop if the growth factor is too small. */

		if (grow <= smlnum) {
		    goto L60;
		}

		i__3 = j + j * a_dim1;
		tjjs.r = a[i__3].r, tjjs.i = a[i__3].i;
		tjj = (d__1 = tjjs.r, abs(d__1)) + (d__2 = d_imag(&tjjs), abs(
			d__2));

		if (tjj >= smlnum) {

/*                 M(j) = G(j-1) / abs(A(j,j)) */

/* Computing MIN */
		    d__1 = xbnd, d__2 = min(1.,tjj) * grow;
		    xbnd = min(d__1,d__2);
		} else {

/*                 M(j) could overflow, set XBND to 0. */

		    xbnd = 0.;
		}

		if (tjj + cnorm[j] >= smlnum) {

/*                 G(j) = G(j-1)*( 1 + CNORM(j) / abs(A(j,j)) ) */

		    grow *= tjj / (tjj + cnorm[j]);
		} else {

/*                 G(j) could overflow, set GROW to 0. */

		    grow = 0.;
		}
	    }
	    grow = xbnd;
	} else {

/*           A is unit triangular. */

/* Computing MIN */
	    d__1 = 1., d__2 = .5 / max(xbnd,smlnum);
	    grow = min(d__1,d__2);
	    i__2 = jlast;
	    i__1 = jinc;
	    for (j = jfirst; i__1 < 0 ? j >= i__2 : j <= i__2; j += i__1) {

/*              Exit the loop if the growth factor is too small. */

		if (grow <= smlnum) {
		    goto L60;
		}

/*              G(j) = G(j-1)*( 1 + CNORM(j) ) */

		grow *= 1. / (cnorm[j] + 1.);
	    }
	}
L60:

	;
    } else {

/*        Compute the growth in A**T * x = b  or  A**H * x = b. */

	if (upper) {
	    jfirst = 1;
	    jlast = *n;
	    jinc = 1;
	} else {
	    jfirst = *n;
	    jlast = 1;
	    jinc = -1;
	}

	if (tscal != 1.) {
	    grow = 0.;
	    goto L90;
	}

	if (nounit) {

/*           A is non-unit triangular. */

/*           Compute GROW = 1/G(j) and XBND = 1/M(j). */

	    grow = .5 / max(xbnd,smlnum);
	    xbnd = grow;
	    i__1 = jlast;
	    i__2 = jinc;
	    for (j = jfirst; i__2 < 0 ? j >= i__1 : j <= i__1; j += i__2) {

/*              Exit the loop if the growth factor is too small. */

		if (grow <= smlnum) {
		    goto L90;
		}

/*              G(j) = max( G(j-1), M(j-1)*( 1 + CNORM(j) ) ) */

		xj = cnorm[j] + 1.;
/* Computing MIN */
		d__1 = grow, d__2 = xbnd / xj;
		grow = min(d__1,d__2);

		i__3 = j + j * a_dim1;
		tjjs.r = a[i__3].r, tjjs.i = a[i__3].i;
		tjj = (d__1 = tjjs.r, abs(d__1)) + (d__2 = d_imag(&tjjs), abs(
			d__2));

		if (tjj >= smlnum) {

/*                 M(j) = M(j-1)*( 1 + CNORM(j) ) / abs(A(j,j)) */

		    if (xj > tjj) {
			xbnd *= tjj / xj;
		    }
		} else {

/*                 M(j) could overflow, set XBND to 0. */

		    xbnd = 0.;
		}
	    }
	    grow = min(grow,xbnd);
	} else {

/*           A is unit triangular. */

/* Computing MIN */
	    d__1 = 1., d__2 = .5 / max(xbnd,smlnum);
	    grow = min(d__1,d__2);
	    i__2 = jlast;
	    i__1 = jinc;
	    for (j = jfirst; i__1 < 0 ? j >= i__2 : j <= i__2; j += i__1) {

/*              Exit the loop if the growth factor is too small. */

		if (grow <= smlnum) {
		    goto L90;
		}

/*              G(j) = ( 1 + CNORM(j) )*G(j-1) */

		xj = cnorm[j] + 1.;
		grow /= xj;
	    }
	}
L90:
	;
    }

    if (grow * tscal > smlnum) {

/*        Use the Level 2 BLAS solve if the reciprocal of the bound on */
/*        elements of X is not too small. */

	ztrsv_(uplo, trans, diag, n, &a[a_offset], lda, &x[1], &c__1);
    } else {

/*        Use a Level 1 BLAS solve, scaling intermediate results. */

	if (xmax > bignum * .5) {

/*           Scale X so that its components are less than or equal to */
/*           BIGNUM in absolute value. */

	    *scale = bignum * .5 / xmax;
	    zdscal_(n, scale, &x[1], &c__1);
	    xmax = bignum;
	} else {
	    xmax *= 2.;
	}

	if (notran) {

/*           Solve A * x = b */

	    i__1 = jlast;
	    i__2 = jinc;
	    for (j = jfirst; i__2 < 0 ? j >= i__1 : j <= i__1; j += i__2) {

/*              Compute x(j) = b(j) / A(j,j), scaling x if necessary. */

		i__3 = j;
		xj = (d__1 = x[i__3].r, abs(d__1)) + (d__2 = d_imag(&x[j]), 
			abs(d__2));
		if (nounit) {
		    i__3 = j + j * a_dim1;
		    z__1.r = tscal * a[i__3].r, z__1.i = tscal * a[i__3].i;
		    tjjs.r = z__1.r, tjjs.i = z__1.i;
		} else {
		    tjjs.r = tscal, tjjs.i = 0.;
		    if (tscal == 1.) {
			goto L110;
		    }
		}
		tjj = (d__1 = tjjs.r, abs(d__1)) + (d__2 = d_imag(&tjjs), abs(
			d__2));
		if (tjj > smlnum) {

/*                    abs(A(j,j)) > SMLNUM: */

		    if (tjj < 1.) {
			if (xj > tjj * bignum) {

/*                          Scale x by 1/b(j). */

			    rec = 1. / xj;
			    zdscal_(n, &rec, &x[1], &c__1);
			    *scale *= rec;
			    xmax *= rec;
			}
		    }
		    i__3 = j;
		    zladiv_(&z__1, &x[j], &tjjs);
		    x[i__3].r = z__1.r, x[i__3].i = z__1.i;
		    i__3 = j;
		    xj = (d__1 = x[i__3].r, abs(d__1)) + (d__2 = d_imag(&x[j])
			    , abs(d__2));
		} else if (tjj > 0.) {

/*                    0 < abs(A(j,j)) <= SMLNUM: */

		    if (xj > tjj * bignum) {

/*                       Scale x by (1/abs(x(j)))*abs(A(j,j))*BIGNUM */
/*                       to avoid overflow when dividing by A(j,j). */

			rec = tjj * bignum / xj;
			if (cnorm[j] > 1.) {

/*                          Scale by 1/CNORM(j) to avoid overflow when */
/*                          multiplying x(j) times column j. */

			    rec /= cnorm[j];
			}
			zdscal_(n, &rec, &x[1], &c__1);
			*scale *= rec;
			xmax *= rec;
		    }
		    i__3 = j;
		    zladiv_(&z__1, &x[j], &tjjs);
		    x[i__3].r = z__1.r, x[i__3].i = z__1.i;
		    i__3 = j;
		    xj = (d__1 = x[i__3].r, abs(d__1)) + (d__2 = d_imag(&x[j])
			    , abs(d__2));
		} else {

/*                    A(j,j) = 0:  Set x(1:n) = 0, x(j) = 1, and */
/*                    scale = 0, and compute a solution to A*x = 0. */

		    i__3 = *n;
		    for (i__ = 1; i__ <= i__3; ++i__) {
			i__4 = i__;
			x[i__4].r = 0., x[i__4].i = 0.;
		    }
		    i__3 = j;
		    x[i__3].r = 1., x[i__3].i = 0.;
		    xj = 1.;
		    *scale = 0.;
		    xmax = 0.;
		}
L110:

/*              Scale x if necessary to avoid overflow when adding a */
/*              multiple of column j of A. */

		if (xj > 1.) {
		    rec = 1. / xj;
		    if (cnorm[j] > (bignum - xmax) * rec) {

/*                    Scale x by 1/(2*abs(x(j))). */

			rec *= .5;
			zdscal_(n, &rec, &x[1], &c__1);
			*scale *= rec;
		    }
		} else if (xj * cnorm[j] > bignum - xmax) {

/*                 Scale x by 1/2. */

		    zdscal_(n, &c_b36, &x[1], &c__1);
		    *scale *= .5;
		}

		if (upper) {
		    if (j > 1) {

/*                    Compute the update */
/*                       x(1:j-1) := x(1:j-1) - x(j) * A(1:j-1,j) */

			i__3 = j - 1;
			i__4 = j;
			z__2.r = -x[i__4].r, z__2.i = -x[i__4].i;
			z__1.r = tscal * z__2.r, z__1.i = tscal * z__2.i;
			zaxpy_(&i__3, &z__1, &a[j * a_dim1 + 1], &c__1, &x[1], 
				 &c__1);
			i__3 = j - 1;
			i__ = izamax_(&i__3, &x[1], &c__1);
			i__3 = i__;
			xmax = (d__1 = x[i__3].r, abs(d__1)) + (d__2 = d_imag(
				&x[i__]), abs(d__2));
		    }
		} else {
		    if (j < *n) {

/*                    Compute the update */
/*                       x(j+1:n) := x(j+1:n) - x(j) * A(j+1:n,j) */

			i__3 = *n - j;
			i__4 = j;
			z__2.r = -x[i__4].r, z__2.i = -x[i__4].i;
			z__1.r = tscal * z__2.r, z__1.i = tscal * z__2.i;
			zaxpy_(&i__3, &z__1, &a[j + 1 + j * a_dim1], &c__1, &
				x[j + 1], &c__1);
			i__3 = *n - j;
			i__ = j + izamax_(&i__3, &x[j + 1], &c__1);
			i__3 = i__;
			xmax = (d__1 = x[i__3].r, abs(d__1)) + (d__2 = d_imag(
				&x[i__]), abs(d__2));
		    }
		}
	    }

	} else if (lsame_(trans, "T")) {

/*           Solve A**T * x = b */

	    i__2 = jlast;
	    i__1 = jinc;
	    for (j = jfirst; i__1 < 0 ? j >= i__2 : j <= i__2; j += i__1) {

/*              Compute x(j) = b(j) - sum A(k,j)*x(k). */
/*                                    k<>j */

		i__3 = j;
		xj = (d__1 = x[i__3].r, abs(d__1)) + (d__2 = d_imag(&x[j]), 
			abs(d__2));
		uscal.r = tscal, uscal.i = 0.;
		rec = 1. / max(xmax,1.);
		if (cnorm[j] > (bignum - xj) * rec) {

/*                 If x(j) could overflow, scale x by 1/(2*XMAX). */

		    rec *= .5;
		    if (nounit) {
			i__3 = j + j * a_dim1;
			z__1.r = tscal * a[i__3].r, z__1.i = tscal * a[i__3]
				.i;
			tjjs.r = z__1.r, tjjs.i = z__1.i;
		    } else {
			tjjs.r = tscal, tjjs.i = 0.;
		    }
		    tjj = (d__1 = tjjs.r, abs(d__1)) + (d__2 = d_imag(&tjjs), 
			    abs(d__2));
		    if (tjj > 1.) {

/*                       Divide by A(j,j) when scaling x if A(j,j) > 1. */

/* Computing MIN */
			d__1 = 1., d__2 = rec * tjj;
			rec = min(d__1,d__2);
			zladiv_(&z__1, &uscal, &tjjs);
			uscal.r = z__1.r, uscal.i = z__1.i;
		    }
		    if (rec < 1.) {
			zdscal_(n, &rec, &x[1], &c__1);
			*scale *= rec;
			xmax *= rec;
		    }
		}

		csumj.r = 0., csumj.i = 0.;
		if (uscal.r == 1. && uscal.i == 0.) {

/*                 If the scaling needed for A in the dot product is 1, */
/*                 call ZDOTU to perform the dot product. */

		    if (upper) {
			i__3 = j - 1;
			zdotu_(&z__1, &i__3, &a[j * a_dim1 + 1], &c__1, &x[1], 
				 &c__1);
			csumj.r = z__1.r, csumj.i = z__1.i;
		    } else if (j < *n) {
			i__3 = *n - j;
			zdotu_(&z__1, &i__3, &a[j + 1 + j * a_dim1], &c__1, &
				x[j + 1], &c__1);
			csumj.r = z__1.r, csumj.i = z__1.i;
		    }
		} else {

/*                 Otherwise, use in-line code for the dot product. */

		    if (upper) {
			i__3 = j - 1;
			for (i__ = 1; i__ <= i__3; ++i__) {
			    i__4 = i__ + j * a_dim1;
			    z__3.r = a[i__4].r * uscal.r - a[i__4].i * 
				    uscal.i, z__3.i = a[i__4].r * uscal.i + a[
				    i__4].i * uscal.r;
			    i__5 = i__;
			    z__2.r = z__3.r * x[i__5].r - z__3.i * x[i__5].i, 
				    z__2.i = z__3.r * x[i__5].i + z__3.i * x[
				    i__5].r;
			    z__1.r = csumj.r + z__2.r, z__1.i = csumj.i + 
				    z__2.i;
			    csumj.r = z__1.r, csumj.i = z__1.i;
			}
		    } else if (j < *n) {
			i__3 = *n;
			for (i__ = j + 1; i__ <= i__3; ++i__) {
			    i__4 = i__ + j * a_dim1;
			    z__3.r = a[i__4].r * uscal.r - a[i__4].i * 
				    uscal.i, z__3.i = a[i__4].r * uscal.i + a[
				    i__4].i * uscal.r;
			    i__5 = i__;
			    z__2.r = z__3.r * x[i__5].r - z__3.i * x[i__5].i, 
				    z__2.i = z__3.r * x[i__5].i + z__3.i * x[
				    i__5].r;
			    z__1.r = csumj.r + z__2.r, z__1.i = csumj.i + 
				    z__2.i;
			    csumj.r = z__1.r, csumj.i = z__1.i;
			}
		    }
		}

		z__1.r = tscal, z__1.i = 0.;
		if (uscal.r == z__1.r && uscal.i == z__1.i) {

/*                 Compute x(j) := ( x(j) - CSUMJ ) / A(j,j) if 1/A(j,j) */
/*                 was not used to scale the dotproduct. */

		    i__3 = j;
		    i__4 = j;
		    z__1.r = x[i__4].r - csumj.r, z__1.i = x[i__4].i - 
			    csumj.i;
		    x[i__3].r = z__1.r, x[i__3].i = z__1.i;
		    i__3 = j;
		    xj = (d__1 = x[i__3].r, abs(d__1)) + (d__2 = d_imag(&x[j])
			    , abs(d__2));
		    if (nounit) {
			i__3 = j + j * a_dim1;
			z__1.r = tscal * a[i__3].r, z__1.i = tscal * a[i__3]
				.i;
			tjjs.r = z__1.r, tjjs.i = z__1.i;
		    } else {
			tjjs.r = tscal, tjjs.i = 0.;
			if (tscal == 1.) {
			    goto L160;
			}
		    }

/*                    Compute x(j) = x(j) / A(j,j), scaling if necessary. */

		    tjj = (d__1 = tjjs.r, abs(d__1)) + (d__2 = d_imag(&tjjs), 
			    abs(d__2));
		    if (tjj > smlnum) {

/*                       abs(A(j,j)) > SMLNUM: */

			if (tjj < 1.) {
			    if (xj > tjj * bignum) {

/*                             Scale X by 1/abs(x(j)). */

				rec = 1. / xj;
				zdscal_(n, &rec, &x[1], &c__1);
				*scale *= rec;
				xmax *= rec;
			    }
			}
			i__3 = j;
			zladiv_(&z__1, &x[j], &tjjs);
			x[i__3].r = z__1.r, x[i__3].i = z__1.i;
		    } else if (tjj > 0.) {

/*                       0 < abs(A(j,j)) <= SMLNUM: */

			if (xj > tjj * bignum) {

/*                          Scale x by (1/abs(x(j)))*abs(A(j,j))*BIGNUM. */

			    rec = tjj * bignum / xj;
			    zdscal_(n, &rec, &x[1], &c__1);
			    *scale *= rec;
			    xmax *= rec;
			}
			i__3 = j;
			zladiv_(&z__1, &x[j], &tjjs);
			x[i__3].r = z__1.r, x[i__3].i = z__1.i;
		    } else {

/*                       A(j,j) = 0:  Set x(1:n) = 0, x(j) = 1, and */
/*                       scale = 0 and compute a solution to A**T *x = 0. */

			i__3 = *n;
			for (i__ = 1; i__ <= i__3; ++i__) {
			    i__4 = i__;
			    x[i__4].r = 0., x[i__4].i = 0.;
			}
			i__3 = j;
			x[i__3].r = 1., x[i__3].i = 0.;
			*scale = 0.;
			xmax = 0.;
		    }
L160:
		    ;
		} else {

/*                 Compute x(j) := x(j) / A(j,j) - CSUMJ if the dot */
/*                 product has already been divided by 1/A(j,j). */

		    i__3 = j;
		    zladiv_(&z__2, &x[j], &tjjs);
		    z__1.r = z__2.r - csumj.r, z__1.i = z__2.i - csumj.i;
		    x[i__3].r = z__1.r, x[i__3].i = z__1.i;
		}
/* Computing MAX */
		i__3 = j;
		d__3 = xmax, d__4 = (d__1 = x[i__3].r, abs(d__1)) + (d__2 = 
			d_imag(&x[j]), abs(d__2));
		xmax = max(d__3,d__4);
	    }

	} else {

/*           Solve A**H * x = b */

	    i__1 = jlast;
	    i__2 = jinc;
	    for (j = jfirst; i__2 < 0 ? j >= i__1 : j <= i__1; j += i__2) {

/*              Compute x(j) = b(j) - sum A(k,j)*x(k). */
/*                                    k<>j */

		i__3 = j;
		xj = (d__1 = x[i__3].r, abs(d__1)) + (d__2 = d_imag(&x[j]), 
			abs(d__2));
		uscal.r = tscal, uscal.i = 0.;
		rec = 1. / max(xmax,1.);
		if (cnorm[j] > (bignum - xj) * rec) {

/*                 If x(j) could overflow, scale x by 1/(2*XMAX). */

		    rec *= .5;
		    if (nounit) {
			d_cnjg(&z__2, &a[j + j * a_dim1]);
			z__1.r = tscal * z__2.r, z__1.i = tscal * z__2.i;
			tjjs.r = z__1.r, tjjs.i = z__1.i;
		    } else {
			tjjs.r = tscal, tjjs.i = 0.;
		    }
		    tjj = (d__1 = tjjs.r, abs(d__1)) + (d__2 = d_imag(&tjjs), 
			    abs(d__2));
		    if (tjj > 1.) {

/*                       Divide by A(j,j) when scaling x if A(j,j) > 1. */

/* Computing MIN */
			d__1 = 1., d__2 = rec * tjj;
			rec = min(d__1,d__2);
			zladiv_(&z__1, &uscal, &tjjs);
			uscal.r = z__1.r, uscal.i = z__1.i;
		    }
		    if (rec < 1.) {
			zdscal_(n, &rec, &x[1], &c__1);
			*scale *= rec;
			xmax *= rec;
		    }
		}

		csumj.r = 0., csumj.i = 0.;
		if (uscal.r == 1. && uscal.i == 0.) {

/*                 If the scaling needed for A in the dot product is 1, */
/*                 call ZDOTC to perform the dot product. */

		    if (upper) {
			i__3 = j - 1;
			zdotc_(&z__1, &i__3, &a[j * a_dim1 + 1], &c__1, &x[1], 
				 &c__1);
			csumj.r = z__1.r, csumj.i = z__1.i;
		    } else if (j < *n) {
			i__3 = *n - j;
			zdotc_(&z__1, &i__3, &a[j + 1 + j * a_dim1], &c__1, &
				x[j + 1], &c__1);
			csumj.r = z__1.r, csumj.i = z__1.i;
		    }
		} else {

/*                 Otherwise, use in-line code for the dot product. */

		    if (upper) {
			i__3 = j - 1;
			for (i__ = 1; i__ <= i__3; ++i__) {
			    d_cnjg(&z__4, &a[i__ + j * a_dim1]);
			    z__3.r = z__4.r * uscal.r - z__4.i * uscal.i, 
				    z__3.i = z__4.r * uscal.i + z__4.i * 
				    uscal.r;
			    i__4 = i__;
			    z__2.r = z__3.r * x[i__4].r - z__3.i * x[i__4].i, 
				    z__2.i = z__3.r * x[i__4].i + z__3.i * x[
				    i__4].r;
			    z__1.r = csumj.r + z__2.r, z__1.i = csumj.i + 
				    z__2.i;
			    csumj.r = z__1.r, csumj.i = z__1.i;
			}
		    } else if (j < *n) {
			i__3 = *n;
			for (i__ = j + 1; i__ <= i__3; ++i__) {
			    d_cnjg(&z__4, &a[i__ + j * a_dim1]);
			    z__3.r = z__4.r * uscal.r - z__4.i * uscal.i, 
				    z__3.i = z__4.r * uscal.i + z__4.i * 
				    uscal.r;
			    i__4 = i__;
			    z__2.r = z__3.r * x[i__4].r - z__3.i * x[i__4].i, 
				    z__2.i = z__3.r * x[i__4].i + z__3.i * x[
				    i__4].r;
			    z__1.r = csumj.r + z__2.r, z__1.i = csumj.i + 
				    z__2.i;
			    csumj.r = z__1.r, csumj.i = z__1.i;
			}
		    }
		}

		z__1.r = tscal, z__1.i = 0.;
		if (uscal.r == z__1.r && uscal.i == z__1.i) {

/*                 Compute x(j) := ( x(j) - CSUMJ ) / A(j,j) if 1/A(j,j) */
/*                 was not used to scale the dotproduct. */

		    i__3 = j;
		    i__4 = j;
		    z__1.r = x[i__4].r - csumj.r, z__1.i = x[i__4].i - 
			    csumj.i;
		    x[i__3].r = z__1.r, x[i__3].i = z__1.i;
		    i__3 = j;
		    xj = (d__1 = x[i__3].r, abs(d__1)) + (d__2 = d_imag(&x[j])
			    , abs(d__2));
		    if (nounit) {
			d_cnjg(&z__2, &a[j + j * a_dim1]);
			z__1.r = tscal * z__2.r, z__1.i = tscal * z__2.i;
			tjjs.r = z__1.r, tjjs.i = z__1.i;
		    } else {
			tjjs.r = tscal, tjjs.i = 0.;
			if (tscal == 1.) {
			    goto L210;
			}
		    }

/*                    Compute x(j) = x(j) / A(j,j), scaling if necessary. */

		    tjj = (d__1 = tjjs.r, abs(d__1)) + (d__2 = d_imag(&tjjs), 
			    abs(d__2));
		    if (tjj > smlnum) {

/*                       abs(A(j,j)) > SMLNUM: */

			if (tjj < 1.) {
			    if (xj > tjj * bignum) {

/*                             Scale X by 1/abs(x(j)). */

				rec = 1. / xj;
				zdscal_(n, &rec, &x[1], &c__1);
				*scale *= rec;
				xmax *= rec;
			    }
			}
			i__3 = j;
			zladiv_(&z__1, &x[j], &tjjs);
			x[i__3].r = z__1.r, x[i__3].i = z__1.i;
		    } else if (tjj > 0.) {

/*                       0 < abs(A(j,j)) <= SMLNUM: */

			if (xj > tjj * bignum) {

/*                          Scale x by (1/abs(x(j)))*abs(A(j,j))*BIGNUM. */

			    rec = tjj * bignum / xj;
			    zdscal_(n, &rec, &x[1], &c__1);
			    *scale *= rec;
			    xmax *= rec;
			}
			i__3 = j;
			zladiv_(&z__1, &x[j], &tjjs);
			x[i__3].r = z__1.r, x[i__3].i = z__1.i;
		    } else {

/*                       A(j,j) = 0:  Set x(1:n) = 0, x(j) = 1, and */
/*                       scale = 0 and compute a solution to A**H *x = 0. */

			i__3 = *n;
			for (i__ = 1; i__ <= i__3; ++i__) {
			    i__4 = i__;
			    x[i__4].r = 0., x[i__4].i = 0.;
			}
			i__3 = j;
			x[i__3].r = 1., x[i__3].i = 0.;
			*scale = 0.;
			xmax = 0.;
		    }
L210:
		    ;
		} else {

/*                 Compute x(j) := x(j) / A(j,j) - CSUMJ if the dot */
/*                 product has already been divided by 1/A(j,j). */

		    i__3 = j;
		    zladiv_(&z__2, &x[j], &tjjs);
		    z__1.r = z__2.r - csumj.r, z__1.i = z__2.i - csumj.i;
		    x[i__3].r = z__1.r, x[i__3].i = z__1.i;
		}
/* Computing MAX */
		i__3 = j;
		d__3 = xmax, d__4 = (d__1 = x[i__3].r, abs(d__1)) + (d__2 = 
			d_imag(&x[j]), abs(d__2));
		xmax = max(d__3,d__4);
	    }
	}
	*scale /= tscal;
    }

/*     Scale the column norms by 1/TSCAL for return. */

    if (tscal != 1.) {
	d__1 = 1. / tscal;
	dscal_(n, &d__1, &cnorm[1], &c__1);
    }

    return 0;

/*     End of ZLATRS */

} /* zlatrs_ */
示例#24
0
/* Subroutine */
int ztgevc_(char *side, char *howmny, logical *select, integer *n, doublecomplex *s, integer *lds, doublecomplex *p, integer *ldp, doublecomplex *vl, integer *ldvl, doublecomplex *vr, integer * ldvr, integer *mm, integer *m, doublecomplex *work, doublereal *rwork, integer *info)
{
    /* System generated locals */
    integer p_dim1, p_offset, s_dim1, s_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, d__6;
    doublecomplex z__1, z__2, z__3, z__4;
    /* Builtin functions */
    double d_imag(doublecomplex *);
    void d_cnjg(doublecomplex *, doublecomplex *);
    /* Local variables */
    doublecomplex d__;
    integer i__, j;
    doublecomplex ca, cb;
    integer je, im, jr;
    doublereal big;
    logical lsa, lsb;
    doublereal ulp;
    doublecomplex sum;
    integer ibeg, ieig, iend;
    doublereal dmin__;
    integer isrc;
    doublereal temp;
    doublecomplex suma, sumb;
    doublereal xmax, scale;
    logical ilall;
    integer iside;
    doublereal sbeta;
    extern logical lsame_(char *, char *);
    doublereal small;
    logical compl;
    doublereal anorm, bnorm;
    logical compr;
    extern /* Subroutine */
    int zgemv_(char *, integer *, integer *, doublecomplex *, doublecomplex *, integer *, doublecomplex *, integer *, doublecomplex *, doublecomplex *, integer *), dlabad_(doublereal *, doublereal *);
    logical ilbbad;
    doublereal acoefa, bcoefa, acoeff;
    doublecomplex bcoeff;
    logical ilback;
    doublereal ascale, bscale;
    extern doublereal dlamch_(char *);
    doublecomplex salpha;
    doublereal safmin;
    extern /* Subroutine */
    int xerbla_(char *, integer *);
    doublereal bignum;
    logical ilcomp;
    extern /* Double Complex */
    VOID zladiv_(doublecomplex *, doublecomplex *, doublecomplex *);
    integer ihwmny;
    /* -- LAPACK computational routine (version 3.4.0) -- */
    /* -- LAPACK is a software package provided by Univ. of Tennessee, -- */
    /* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */
    /* November 2011 */
    /* .. Scalar Arguments .. */
    /* .. */
    /* .. Array Arguments .. */
    /* .. */
    /* ===================================================================== */
    /* .. Parameters .. */
    /* .. */
    /* .. Local Scalars .. */
    /* .. */
    /* .. External Functions .. */
    /* .. */
    /* .. External Subroutines .. */
    /* .. */
    /* .. Intrinsic Functions .. */
    /* .. */
    /* .. Statement Functions .. */
    /* .. */
    /* .. Statement Function definitions .. */
    /* .. */
    /* .. Executable Statements .. */
    /* Decode and Test the input parameters */
    /* Parameter adjustments */
    --select;
    s_dim1 = *lds;
    s_offset = 1 + s_dim1;
    s -= s_offset;
    p_dim1 = *ldp;
    p_offset = 1 + p_dim1;
    p -= p_offset;
    vl_dim1 = *ldvl;
    vl_offset = 1 + vl_dim1;
    vl -= vl_offset;
    vr_dim1 = *ldvr;
    vr_offset = 1 + vr_dim1;
    vr -= vr_offset;
    --work;
    --rwork;
    /* Function Body */
    if (lsame_(howmny, "A"))
    {
        ihwmny = 1;
        ilall = TRUE_;
        ilback = FALSE_;
    }
    else if (lsame_(howmny, "S"))
    {
        ihwmny = 2;
        ilall = FALSE_;
        ilback = FALSE_;
    }
    else if (lsame_(howmny, "B"))
    {
        ihwmny = 3;
        ilall = TRUE_;
        ilback = TRUE_;
    }
    else
    {
        ihwmny = -1;
    }
    if (lsame_(side, "R"))
    {
        iside = 1;
        compl = FALSE_;
        compr = TRUE_;
    }
    else if (lsame_(side, "L"))
    {
        iside = 2;
        compl = TRUE_;
        compr = FALSE_;
    }
    else if (lsame_(side, "B"))
    {
        iside = 3;
        compl = TRUE_;
        compr = TRUE_;
    }
    else
    {
        iside = -1;
    }
    *info = 0;
    if (iside < 0)
    {
        *info = -1;
    }
    else if (ihwmny < 0)
    {
        *info = -2;
    }
    else if (*n < 0)
    {
        *info = -4;
    }
    else if (*lds < max(1,*n))
    {
        *info = -6;
    }
    else if (*ldp < max(1,*n))
    {
        *info = -8;
    }
    if (*info != 0)
    {
        i__1 = -(*info);
        xerbla_("ZTGEVC", &i__1);
        return 0;
    }
    /* Count the number of eigenvectors */
    if (! ilall)
    {
        im = 0;
        i__1 = *n;
        for (j = 1;
                j <= i__1;
                ++j)
        {
            if (select[j])
            {
                ++im;
            }
            /* L10: */
        }
    }
    else
    {
        im = *n;
    }
    /* Check diagonal of B */
    ilbbad = FALSE_;
    i__1 = *n;
    for (j = 1;
            j <= i__1;
            ++j)
    {
        if (d_imag(&p[j + j * p_dim1]) != 0.)
        {
            ilbbad = TRUE_;
        }
        /* L20: */
    }
    if (ilbbad)
    {
        *info = -7;
    }
    else if (compl && *ldvl < *n || *ldvl < 1)
    {
        *info = -10;
    }
    else if (compr && *ldvr < *n || *ldvr < 1)
    {
        *info = -12;
    }
    else if (*mm < im)
    {
        *info = -13;
    }
    if (*info != 0)
    {
        i__1 = -(*info);
        xerbla_("ZTGEVC", &i__1);
        return 0;
    }
    /* Quick return if possible */
    *m = im;
    if (*n == 0)
    {
        return 0;
    }
    /* Machine Constants */
    safmin = dlamch_("Safe minimum");
    big = 1. / safmin;
    dlabad_(&safmin, &big);
    ulp = dlamch_("Epsilon") * dlamch_("Base");
    small = safmin * *n / ulp;
    big = 1. / small;
    bignum = 1. / (safmin * *n);
    /* Compute the 1-norm of each column of the strictly upper triangular */
    /* part of A and B to check for possible overflow in the triangular */
    /* solver. */
    i__1 = s_dim1 + 1;
    anorm = (d__1 = s[i__1].r, abs(d__1)) + (d__2 = d_imag(&s[s_dim1 + 1]), abs(d__2));
    i__1 = p_dim1 + 1;
    bnorm = (d__1 = p[i__1].r, abs(d__1)) + (d__2 = d_imag(&p[p_dim1 + 1]), abs(d__2));
    rwork[1] = 0.;
    rwork[*n + 1] = 0.;
    i__1 = *n;
    for (j = 2;
            j <= i__1;
            ++j)
    {
        rwork[j] = 0.;
        rwork[*n + j] = 0.;
        i__2 = j - 1;
        for (i__ = 1;
                i__ <= i__2;
                ++i__)
        {
            i__3 = i__ + j * s_dim1;
            rwork[j] += (d__1 = s[i__3].r, abs(d__1)) + (d__2 = d_imag(&s[i__ + j * s_dim1]), abs(d__2));
            i__3 = i__ + j * p_dim1;
            rwork[*n + j] += (d__1 = p[i__3].r, abs(d__1)) + (d__2 = d_imag(& p[i__ + j * p_dim1]), abs(d__2));
            /* L30: */
        }
        /* Computing MAX */
        i__2 = j + j * s_dim1;
        d__3 = anorm;
        d__4 = rwork[j] + ((d__1 = s[i__2].r, abs(d__1)) + ( d__2 = d_imag(&s[j + j * s_dim1]), abs(d__2))); // , expr subst
        anorm = max(d__3,d__4);
        /* Computing MAX */
        i__2 = j + j * p_dim1;
        d__3 = bnorm;
        d__4 = rwork[*n + j] + ((d__1 = p[i__2].r, abs(d__1)) + (d__2 = d_imag(&p[j + j * p_dim1]), abs(d__2))); // , expr subst
        bnorm = max(d__3,d__4);
        /* L40: */
    }
    ascale = 1. / max(anorm,safmin);
    bscale = 1. / max(bnorm,safmin);
    /* Left eigenvectors */
    if (compl)
    {
        ieig = 0;
        /* Main loop over eigenvalues */
        i__1 = *n;
        for (je = 1;
                je <= i__1;
                ++je)
        {
            if (ilall)
            {
                ilcomp = TRUE_;
            }
            else
            {
                ilcomp = select[je];
            }
            if (ilcomp)
            {
                ++ieig;
                i__2 = je + je * s_dim1;
                i__3 = je + je * p_dim1;
                if ((d__2 = s[i__2].r, abs(d__2)) + (d__3 = d_imag(&s[je + je * s_dim1]), abs(d__3)) <= safmin && (d__1 = p[i__3].r, abs(d__1)) <= safmin)
                {
                    /* Singular matrix pencil -- return unit eigenvector */
                    i__2 = *n;
                    for (jr = 1;
                            jr <= i__2;
                            ++jr)
                    {
                        i__3 = jr + ieig * vl_dim1;
                        vl[i__3].r = 0.;
                        vl[i__3].i = 0.; // , expr subst
                        /* L50: */
                    }
                    i__2 = ieig + ieig * vl_dim1;
                    vl[i__2].r = 1.;
                    vl[i__2].i = 0.; // , expr subst
                    goto L140;
                }
                /* Non-singular eigenvalue: */
                /* Compute coefficients a and b in */
                /* H */
                /* y ( a A - b B ) = 0 */
                /* Computing MAX */
                i__2 = je + je * s_dim1;
                i__3 = je + je * p_dim1;
                d__4 = ((d__2 = s[i__2].r, abs(d__2)) + (d__3 = d_imag(&s[je + je * s_dim1]), abs(d__3))) * ascale;
                d__5 = (d__1 = p[i__3].r, abs(d__1)) * bscale;
                d__4 = max(d__4,d__5); // ; expr subst
                temp = 1. / max(d__4,safmin);
                i__2 = je + je * s_dim1;
                z__2.r = temp * s[i__2].r;
                z__2.i = temp * s[i__2].i; // , expr subst
                z__1.r = ascale * z__2.r;
                z__1.i = ascale * z__2.i; // , expr subst
                salpha.r = z__1.r;
                salpha.i = z__1.i; // , expr subst
                i__2 = je + je * p_dim1;
                sbeta = temp * p[i__2].r * bscale;
                acoeff = sbeta * ascale;
                z__1.r = bscale * salpha.r;
                z__1.i = bscale * salpha.i; // , expr subst
                bcoeff.r = z__1.r;
                bcoeff.i = z__1.i; // , expr subst
                /* Scale to avoid underflow */
                lsa = abs(sbeta) >= safmin && abs(acoeff) < small;
                lsb = (d__1 = salpha.r, abs(d__1)) + (d__2 = d_imag(&salpha), abs(d__2)) >= safmin && (d__3 = bcoeff.r, abs(d__3)) + (d__4 = d_imag(&bcoeff), abs(d__4)) < small;
                scale = 1.;
                if (lsa)
                {
                    scale = small / abs(sbeta) * min(anorm,big);
                }
                if (lsb)
                {
                    /* Computing MAX */
                    d__3 = scale;
                    d__4 = small / ((d__1 = salpha.r, abs(d__1)) + (d__2 = d_imag(&salpha), abs(d__2))) * min( bnorm,big); // , expr subst
                    scale = max(d__3,d__4);
                }
                if (lsa || lsb)
                {
                    /* Computing MIN */
                    /* Computing MAX */
                    d__5 = 1., d__6 = abs(acoeff);
                    d__5 = max(d__5,d__6);
                    d__6 = (d__1 = bcoeff.r, abs(d__1)) + (d__2 = d_imag(&bcoeff), abs(d__2)); // ; expr subst
                    d__3 = scale;
                    d__4 = 1. / (safmin * max(d__5,d__6)); // , expr subst
                    scale = min(d__3,d__4);
                    if (lsa)
                    {
                        acoeff = ascale * (scale * sbeta);
                    }
                    else
                    {
                        acoeff = scale * acoeff;
                    }
                    if (lsb)
                    {
                        z__2.r = scale * salpha.r;
                        z__2.i = scale * salpha.i; // , expr subst
                        z__1.r = bscale * z__2.r;
                        z__1.i = bscale * z__2.i; // , expr subst
                        bcoeff.r = z__1.r;
                        bcoeff.i = z__1.i; // , expr subst
                    }
                    else
                    {
                        z__1.r = scale * bcoeff.r;
                        z__1.i = scale * bcoeff.i; // , expr subst
                        bcoeff.r = z__1.r;
                        bcoeff.i = z__1.i; // , expr subst
                    }
                }
                acoefa = abs(acoeff);
                bcoefa = (d__1 = bcoeff.r, abs(d__1)) + (d__2 = d_imag(& bcoeff), abs(d__2));
                xmax = 1.;
                i__2 = *n;
                for (jr = 1;
                        jr <= i__2;
                        ++jr)
                {
                    i__3 = jr;
                    work[i__3].r = 0.;
                    work[i__3].i = 0.; // , expr subst
                    /* L60: */
                }
                i__2 = je;
                work[i__2].r = 1.;
                work[i__2].i = 0.; // , expr subst
                /* Computing MAX */
                d__1 = ulp * acoefa * anorm;
                d__2 = ulp * bcoefa * bnorm;
                d__1 = max(d__1,d__2); // ; expr subst
                dmin__ = max(d__1,safmin);
                /* H */
                /* Triangular solve of (a A - b B) y = 0 */
                /* H */
                /* (rowwise in (a A - b B) , or columnwise in a A - b B) */
                i__2 = *n;
                for (j = je + 1;
                        j <= i__2;
                        ++j)
                {
                    /* Compute */
                    /* j-1 */
                    /* SUM = sum conjg( a*S(k,j) - b*P(k,j) )*x(k) */
                    /* k=je */
                    /* (Scale if necessary) */
                    temp = 1. / xmax;
                    if (acoefa * rwork[j] + bcoefa * rwork[*n + j] > bignum * temp)
                    {
                        i__3 = j - 1;
                        for (jr = je;
                                jr <= i__3;
                                ++jr)
                        {
                            i__4 = jr;
                            i__5 = jr;
                            z__1.r = temp * work[i__5].r;
                            z__1.i = temp * work[i__5].i; // , expr subst
                            work[i__4].r = z__1.r;
                            work[i__4].i = z__1.i; // , expr subst
                            /* L70: */
                        }
                        xmax = 1.;
                    }
                    suma.r = 0.;
                    suma.i = 0.; // , expr subst
                    sumb.r = 0.;
                    sumb.i = 0.; // , expr subst
                    i__3 = j - 1;
                    for (jr = je;
                            jr <= i__3;
                            ++jr)
                    {
                        d_cnjg(&z__3, &s[jr + j * s_dim1]);
                        i__4 = jr;
                        z__2.r = z__3.r * work[i__4].r - z__3.i * work[i__4] .i;
                        z__2.i = z__3.r * work[i__4].i + z__3.i * work[i__4].r; // , expr subst
                        z__1.r = suma.r + z__2.r;
                        z__1.i = suma.i + z__2.i; // , expr subst
                        suma.r = z__1.r;
                        suma.i = z__1.i; // , expr subst
                        d_cnjg(&z__3, &p[jr + j * p_dim1]);
                        i__4 = jr;
                        z__2.r = z__3.r * work[i__4].r - z__3.i * work[i__4] .i;
                        z__2.i = z__3.r * work[i__4].i + z__3.i * work[i__4].r; // , expr subst
                        z__1.r = sumb.r + z__2.r;
                        z__1.i = sumb.i + z__2.i; // , expr subst
                        sumb.r = z__1.r;
                        sumb.i = z__1.i; // , expr subst
                        /* L80: */
                    }
                    z__2.r = acoeff * suma.r;
                    z__2.i = acoeff * suma.i; // , expr subst
                    d_cnjg(&z__4, &bcoeff);
                    z__3.r = z__4.r * sumb.r - z__4.i * sumb.i;
                    z__3.i = z__4.r * sumb.i + z__4.i * sumb.r; // , expr subst
                    z__1.r = z__2.r - z__3.r;
                    z__1.i = z__2.i - z__3.i; // , expr subst
                    sum.r = z__1.r;
                    sum.i = z__1.i; // , expr subst
                    /* Form x(j) = - SUM / conjg( a*S(j,j) - b*P(j,j) ) */
                    /* with scaling and perturbation of the denominator */
                    i__3 = j + j * s_dim1;
                    z__3.r = acoeff * s[i__3].r;
                    z__3.i = acoeff * s[i__3].i; // , expr subst
                    i__4 = j + j * p_dim1;
                    z__4.r = bcoeff.r * p[i__4].r - bcoeff.i * p[i__4].i;
                    z__4.i = bcoeff.r * p[i__4].i + bcoeff.i * p[i__4] .r; // , expr subst
                    z__2.r = z__3.r - z__4.r;
                    z__2.i = z__3.i - z__4.i; // , expr subst
                    d_cnjg(&z__1, &z__2);
                    d__.r = z__1.r;
                    d__.i = z__1.i; // , expr subst
                    if ((d__1 = d__.r, abs(d__1)) + (d__2 = d_imag(&d__), abs( d__2)) <= dmin__)
                    {
                        z__1.r = dmin__;
                        z__1.i = 0.; // , expr subst
                        d__.r = z__1.r;
                        d__.i = z__1.i; // , expr subst
                    }
                    if ((d__1 = d__.r, abs(d__1)) + (d__2 = d_imag(&d__), abs( d__2)) < 1.)
                    {
                        if ((d__1 = sum.r, abs(d__1)) + (d__2 = d_imag(&sum), abs(d__2)) >= bignum * ((d__3 = d__.r, abs( d__3)) + (d__4 = d_imag(&d__), abs(d__4))))
                        {
                            temp = 1. / ((d__1 = sum.r, abs(d__1)) + (d__2 = d_imag(&sum), abs(d__2)));
                            i__3 = j - 1;
                            for (jr = je;
                                    jr <= i__3;
                                    ++jr)
                            {
                                i__4 = jr;
                                i__5 = jr;
                                z__1.r = temp * work[i__5].r;
                                z__1.i = temp * work[i__5].i; // , expr subst
                                work[i__4].r = z__1.r;
                                work[i__4].i = z__1.i; // , expr subst
                                /* L90: */
                            }
                            xmax = temp * xmax;
                            z__1.r = temp * sum.r;
                            z__1.i = temp * sum.i; // , expr subst
                            sum.r = z__1.r;
                            sum.i = z__1.i; // , expr subst
                        }
                    }
                    i__3 = j;
                    z__2.r = -sum.r;
                    z__2.i = -sum.i; // , expr subst
                    zladiv_(&z__1, &z__2, &d__);
                    work[i__3].r = z__1.r;
                    work[i__3].i = z__1.i; // , expr subst
                    /* Computing MAX */
                    i__3 = j;
                    d__3 = xmax;
                    d__4 = (d__1 = work[i__3].r, abs(d__1)) + ( d__2 = d_imag(&work[j]), abs(d__2)); // , expr subst
                    xmax = max(d__3,d__4);
                    /* L100: */
                }
                /* Back transform eigenvector if HOWMNY='B'. */
                if (ilback)
                {
                    i__2 = *n + 1 - je;
                    zgemv_("N", n, &i__2, &c_b2, &vl[je * vl_dim1 + 1], ldvl, &work[je], &c__1, &c_b1, &work[*n + 1], &c__1);
                    isrc = 2;
                    ibeg = 1;
                }
                else
                {
                    isrc = 1;
                    ibeg = je;
                }
                /* Copy and scale eigenvector into column of VL */
                xmax = 0.;
                i__2 = *n;
                for (jr = ibeg;
                        jr <= i__2;
                        ++jr)
                {
                    /* Computing MAX */
                    i__3 = (isrc - 1) * *n + jr;
                    d__3 = xmax;
                    d__4 = (d__1 = work[i__3].r, abs(d__1)) + ( d__2 = d_imag(&work[(isrc - 1) * *n + jr]), abs( d__2)); // , expr subst
                    xmax = max(d__3,d__4);
                    /* L110: */
                }
                if (xmax > safmin)
                {
                    temp = 1. / xmax;
                    i__2 = *n;
                    for (jr = ibeg;
                            jr <= i__2;
                            ++jr)
                    {
                        i__3 = jr + ieig * vl_dim1;
                        i__4 = (isrc - 1) * *n + jr;
                        z__1.r = temp * work[i__4].r;
                        z__1.i = temp * work[ i__4].i; // , expr subst
                        vl[i__3].r = z__1.r;
                        vl[i__3].i = z__1.i; // , expr subst
                        /* L120: */
                    }
                }
                else
                {
                    ibeg = *n + 1;
                }
                i__2 = ibeg - 1;
                for (jr = 1;
                        jr <= i__2;
                        ++jr)
                {
                    i__3 = jr + ieig * vl_dim1;
                    vl[i__3].r = 0.;
                    vl[i__3].i = 0.; // , expr subst
                    /* L130: */
                }
            }
L140:
            ;
        }
    }
    /* Right eigenvectors */
    if (compr)
    {
        ieig = im + 1;
        /* Main loop over eigenvalues */
        for (je = *n;
                je >= 1;
                --je)
        {
            if (ilall)
            {
                ilcomp = TRUE_;
            }
            else
            {
                ilcomp = select[je];
            }
            if (ilcomp)
            {
                --ieig;
                i__1 = je + je * s_dim1;
                i__2 = je + je * p_dim1;
                if ((d__2 = s[i__1].r, abs(d__2)) + (d__3 = d_imag(&s[je + je * s_dim1]), abs(d__3)) <= safmin && (d__1 = p[i__2].r, abs(d__1)) <= safmin)
                {
                    /* Singular matrix pencil -- return unit eigenvector */
                    i__1 = *n;
                    for (jr = 1;
                            jr <= i__1;
                            ++jr)
                    {
                        i__2 = jr + ieig * vr_dim1;
                        vr[i__2].r = 0.;
                        vr[i__2].i = 0.; // , expr subst
                        /* L150: */
                    }
                    i__1 = ieig + ieig * vr_dim1;
                    vr[i__1].r = 1.;
                    vr[i__1].i = 0.; // , expr subst
                    goto L250;
                }
                /* Non-singular eigenvalue: */
                /* Compute coefficients a and b in */
                /* ( a A - b B ) x = 0 */
                /* Computing MAX */
                i__1 = je + je * s_dim1;
                i__2 = je + je * p_dim1;
                d__4 = ((d__2 = s[i__1].r, abs(d__2)) + (d__3 = d_imag(&s[je + je * s_dim1]), abs(d__3))) * ascale;
                d__5 = (d__1 = p[i__2].r, abs(d__1)) * bscale;
                d__4 = max(d__4,d__5); // ; expr subst
                temp = 1. / max(d__4,safmin);
                i__1 = je + je * s_dim1;
                z__2.r = temp * s[i__1].r;
                z__2.i = temp * s[i__1].i; // , expr subst
                z__1.r = ascale * z__2.r;
                z__1.i = ascale * z__2.i; // , expr subst
                salpha.r = z__1.r;
                salpha.i = z__1.i; // , expr subst
                i__1 = je + je * p_dim1;
                sbeta = temp * p[i__1].r * bscale;
                acoeff = sbeta * ascale;
                z__1.r = bscale * salpha.r;
                z__1.i = bscale * salpha.i; // , expr subst
                bcoeff.r = z__1.r;
                bcoeff.i = z__1.i; // , expr subst
                /* Scale to avoid underflow */
                lsa = abs(sbeta) >= safmin && abs(acoeff) < small;
                lsb = (d__1 = salpha.r, abs(d__1)) + (d__2 = d_imag(&salpha), abs(d__2)) >= safmin && (d__3 = bcoeff.r, abs(d__3)) + (d__4 = d_imag(&bcoeff), abs(d__4)) < small;
                scale = 1.;
                if (lsa)
                {
                    scale = small / abs(sbeta) * min(anorm,big);
                }
                if (lsb)
                {
                    /* Computing MAX */
                    d__3 = scale;
                    d__4 = small / ((d__1 = salpha.r, abs(d__1)) + (d__2 = d_imag(&salpha), abs(d__2))) * min( bnorm,big); // , expr subst
                    scale = max(d__3,d__4);
                }
                if (lsa || lsb)
                {
                    /* Computing MIN */
                    /* Computing MAX */
                    d__5 = 1., d__6 = abs(acoeff);
                    d__5 = max(d__5,d__6);
                    d__6 = (d__1 = bcoeff.r, abs(d__1)) + (d__2 = d_imag(&bcoeff), abs(d__2)); // ; expr subst
                    d__3 = scale;
                    d__4 = 1. / (safmin * max(d__5,d__6)); // , expr subst
                    scale = min(d__3,d__4);
                    if (lsa)
                    {
                        acoeff = ascale * (scale * sbeta);
                    }
                    else
                    {
                        acoeff = scale * acoeff;
                    }
                    if (lsb)
                    {
                        z__2.r = scale * salpha.r;
                        z__2.i = scale * salpha.i; // , expr subst
                        z__1.r = bscale * z__2.r;
                        z__1.i = bscale * z__2.i; // , expr subst
                        bcoeff.r = z__1.r;
                        bcoeff.i = z__1.i; // , expr subst
                    }
                    else
                    {
                        z__1.r = scale * bcoeff.r;
                        z__1.i = scale * bcoeff.i; // , expr subst
                        bcoeff.r = z__1.r;
                        bcoeff.i = z__1.i; // , expr subst
                    }
                }
                acoefa = abs(acoeff);
                bcoefa = (d__1 = bcoeff.r, abs(d__1)) + (d__2 = d_imag(& bcoeff), abs(d__2));
                xmax = 1.;
                i__1 = *n;
                for (jr = 1;
                        jr <= i__1;
                        ++jr)
                {
                    i__2 = jr;
                    work[i__2].r = 0.;
                    work[i__2].i = 0.; // , expr subst
                    /* L160: */
                }
                i__1 = je;
                work[i__1].r = 1.;
                work[i__1].i = 0.; // , expr subst
                /* Computing MAX */
                d__1 = ulp * acoefa * anorm;
                d__2 = ulp * bcoefa * bnorm;
                d__1 = max(d__1,d__2); // ; expr subst
                dmin__ = max(d__1,safmin);
                /* Triangular solve of (a A - b B) x = 0 (columnwise) */
                /* WORK(1:j-1) contains sums w, */
                /* WORK(j+1:JE) contains x */
                i__1 = je - 1;
                for (jr = 1;
                        jr <= i__1;
                        ++jr)
                {
                    i__2 = jr;
                    i__3 = jr + je * s_dim1;
                    z__2.r = acoeff * s[i__3].r;
                    z__2.i = acoeff * s[i__3].i; // , expr subst
                    i__4 = jr + je * p_dim1;
                    z__3.r = bcoeff.r * p[i__4].r - bcoeff.i * p[i__4].i;
                    z__3.i = bcoeff.r * p[i__4].i + bcoeff.i * p[i__4] .r; // , expr subst
                    z__1.r = z__2.r - z__3.r;
                    z__1.i = z__2.i - z__3.i; // , expr subst
                    work[i__2].r = z__1.r;
                    work[i__2].i = z__1.i; // , expr subst
                    /* L170: */
                }
                i__1 = je;
                work[i__1].r = 1.;
                work[i__1].i = 0.; // , expr subst
                for (j = je - 1;
                        j >= 1;
                        --j)
                {
                    /* Form x(j) := - w(j) / d */
                    /* with scaling and perturbation of the denominator */
                    i__1 = j + j * s_dim1;
                    z__2.r = acoeff * s[i__1].r;
                    z__2.i = acoeff * s[i__1].i; // , expr subst
                    i__2 = j + j * p_dim1;
                    z__3.r = bcoeff.r * p[i__2].r - bcoeff.i * p[i__2].i;
                    z__3.i = bcoeff.r * p[i__2].i + bcoeff.i * p[i__2] .r; // , expr subst
                    z__1.r = z__2.r - z__3.r;
                    z__1.i = z__2.i - z__3.i; // , expr subst
                    d__.r = z__1.r;
                    d__.i = z__1.i; // , expr subst
                    if ((d__1 = d__.r, abs(d__1)) + (d__2 = d_imag(&d__), abs( d__2)) <= dmin__)
                    {
                        z__1.r = dmin__;
                        z__1.i = 0.; // , expr subst
                        d__.r = z__1.r;
                        d__.i = z__1.i; // , expr subst
                    }
                    if ((d__1 = d__.r, abs(d__1)) + (d__2 = d_imag(&d__), abs( d__2)) < 1.)
                    {
                        i__1 = j;
                        if ((d__1 = work[i__1].r, abs(d__1)) + (d__2 = d_imag( &work[j]), abs(d__2)) >= bignum * ((d__3 = d__.r, abs(d__3)) + (d__4 = d_imag(&d__), abs( d__4))))
                        {
                            i__1 = j;
                            temp = 1. / ((d__1 = work[i__1].r, abs(d__1)) + ( d__2 = d_imag(&work[j]), abs(d__2)));
                            i__1 = je;
                            for (jr = 1;
                                    jr <= i__1;
                                    ++jr)
                            {
                                i__2 = jr;
                                i__3 = jr;
                                z__1.r = temp * work[i__3].r;
                                z__1.i = temp * work[i__3].i; // , expr subst
                                work[i__2].r = z__1.r;
                                work[i__2].i = z__1.i; // , expr subst
                                /* L180: */
                            }
                        }
                    }
                    i__1 = j;
                    i__2 = j;
                    z__2.r = -work[i__2].r;
                    z__2.i = -work[i__2].i; // , expr subst
                    zladiv_(&z__1, &z__2, &d__);
                    work[i__1].r = z__1.r;
                    work[i__1].i = z__1.i; // , expr subst
                    if (j > 1)
                    {
                        /* w = w + x(j)*(a S(*,j) - b P(*,j) ) with scaling */
                        i__1 = j;
                        if ((d__1 = work[i__1].r, abs(d__1)) + (d__2 = d_imag( &work[j]), abs(d__2)) > 1.)
                        {
                            i__1 = j;
                            temp = 1. / ((d__1 = work[i__1].r, abs(d__1)) + ( d__2 = d_imag(&work[j]), abs(d__2)));
                            if (acoefa * rwork[j] + bcoefa * rwork[*n + j] >= bignum * temp)
                            {
                                i__1 = je;
                                for (jr = 1;
                                        jr <= i__1;
                                        ++jr)
                                {
                                    i__2 = jr;
                                    i__3 = jr;
                                    z__1.r = temp * work[i__3].r;
                                    z__1.i = temp * work[i__3].i; // , expr subst
                                    work[i__2].r = z__1.r;
                                    work[i__2].i = z__1.i; // , expr subst
                                    /* L190: */
                                }
                            }
                        }
                        i__1 = j;
                        z__1.r = acoeff * work[i__1].r;
                        z__1.i = acoeff * work[i__1].i; // , expr subst
                        ca.r = z__1.r;
                        ca.i = z__1.i; // , expr subst
                        i__1 = j;
                        z__1.r = bcoeff.r * work[i__1].r - bcoeff.i * work[ i__1].i;
                        z__1.i = bcoeff.r * work[i__1].i + bcoeff.i * work[i__1].r; // , expr subst
                        cb.r = z__1.r;
                        cb.i = z__1.i; // , expr subst
                        i__1 = j - 1;
                        for (jr = 1;
                                jr <= i__1;
                                ++jr)
                        {
                            i__2 = jr;
                            i__3 = jr;
                            i__4 = jr + j * s_dim1;
                            z__3.r = ca.r * s[i__4].r - ca.i * s[i__4].i;
                            z__3.i = ca.r * s[i__4].i + ca.i * s[i__4] .r; // , expr subst
                            z__2.r = work[i__3].r + z__3.r;
                            z__2.i = work[ i__3].i + z__3.i; // , expr subst
                            i__5 = jr + j * p_dim1;
                            z__4.r = cb.r * p[i__5].r - cb.i * p[i__5].i;
                            z__4.i = cb.r * p[i__5].i + cb.i * p[i__5] .r; // , expr subst
                            z__1.r = z__2.r - z__4.r;
                            z__1.i = z__2.i - z__4.i; // , expr subst
                            work[i__2].r = z__1.r;
                            work[i__2].i = z__1.i; // , expr subst
                            /* L200: */
                        }
                    }
                    /* L210: */
                }
                /* Back transform eigenvector if HOWMNY='B'. */
                if (ilback)
                {
                    zgemv_("N", n, &je, &c_b2, &vr[vr_offset], ldvr, &work[1], &c__1, &c_b1, &work[*n + 1], &c__1);
                    isrc = 2;
                    iend = *n;
                }
                else
                {
                    isrc = 1;
                    iend = je;
                }
                /* Copy and scale eigenvector into column of VR */
                xmax = 0.;
                i__1 = iend;
                for (jr = 1;
                        jr <= i__1;
                        ++jr)
                {
                    /* Computing MAX */
                    i__2 = (isrc - 1) * *n + jr;
                    d__3 = xmax;
                    d__4 = (d__1 = work[i__2].r, abs(d__1)) + ( d__2 = d_imag(&work[(isrc - 1) * *n + jr]), abs( d__2)); // , expr subst
                    xmax = max(d__3,d__4);
                    /* L220: */
                }
                if (xmax > safmin)
                {
                    temp = 1. / xmax;
                    i__1 = iend;
                    for (jr = 1;
                            jr <= i__1;
                            ++jr)
                    {
                        i__2 = jr + ieig * vr_dim1;
                        i__3 = (isrc - 1) * *n + jr;
                        z__1.r = temp * work[i__3].r;
                        z__1.i = temp * work[ i__3].i; // , expr subst
                        vr[i__2].r = z__1.r;
                        vr[i__2].i = z__1.i; // , expr subst
                        /* L230: */
                    }
                }
                else
                {
                    iend = 0;
                }
                i__1 = *n;
                for (jr = iend + 1;
                        jr <= i__1;
                        ++jr)
                {
                    i__2 = jr + ieig * vr_dim1;
                    vr[i__2].r = 0.;
                    vr[i__2].i = 0.; // , expr subst
                    /* L240: */
                }
            }
L250:
            ;
        }
    }
    return 0;
    /* End of ZTGEVC */
}
示例#25
0
/* Subroutine */ int znaitr_(integer *ido, char *bmat, integer *n, integer *k,
	 integer *np, integer *nb, doublecomplex *resid, doublereal *rnorm, 
	doublecomplex *v, integer *ldv, doublecomplex *h__, integer *ldh, 
	integer *ipntr, doublecomplex *workd, integer *info, ftnlen bmat_len)
{
    /* Initialized data */

    static logical first = TRUE_;

    /* System generated locals */
    integer h_dim1, h_offset, v_dim1, v_offset, i__1, i__2, i__3;
    doublereal d__1, d__2, d__3, d__4;
    doublecomplex z__1;

    /* Builtin functions */
    double d_imag(doublecomplex *), sqrt(doublereal);

    /* Local variables */
    static integer i__, j;
    static real t0, t1, t2, t3, t4, t5;
    static integer jj, ipj, irj, ivj;
    static doublereal ulp, tst1;
    static integer ierr, iter;
    static doublereal unfl, ovfl;
    static integer itry;
    static doublereal temp1;
    static logical orth1, orth2, step3, step4;
    static doublereal betaj;
    static integer infol;
    static doublecomplex cnorm;
    extern /* Double Complex */ VOID zdotc_(doublecomplex *, integer *, 
	    doublecomplex *, integer *, doublecomplex *, integer *);
    static doublereal rtemp[2];
    extern /* Subroutine */ int zgemv_(char *, integer *, integer *, 
	    doublecomplex *, doublecomplex *, integer *, doublecomplex *, 
	    integer *, doublecomplex *, doublecomplex *, integer *, ftnlen);
    static doublereal wnorm;
    extern /* Subroutine */ int dvout_(integer *, integer *, doublereal *, 
	    integer *, char *, ftnlen), zcopy_(integer *, doublecomplex *, 
	    integer *, doublecomplex *, integer *), ivout_(integer *, integer 
	    *, integer *, integer *, char *, ftnlen), zaxpy_(integer *, 
	    doublecomplex *, doublecomplex *, integer *, doublecomplex *, 
	    integer *), zmout_(integer *, integer *, integer *, doublecomplex 
	    *, integer *, integer *, char *, ftnlen), zvout_(integer *, 
	    integer *, doublecomplex *, integer *, char *, ftnlen);
    extern doublereal dlapy2_(doublereal *, doublereal *);
    extern /* Subroutine */ int dlabad_(doublereal *, doublereal *);
    extern doublereal dznrm2_(integer *, doublecomplex *, integer *);
    static doublereal rnorm1;
    extern /* Subroutine */ int zgetv0_(integer *, char *, integer *, logical 
	    *, integer *, integer *, doublecomplex *, integer *, 
	    doublecomplex *, doublereal *, integer *, doublecomplex *, 
	    integer *, ftnlen);
    extern doublereal dlamch_(char *, ftnlen);
    extern /* Subroutine */ int second_(real *), zdscal_(integer *, 
	    doublereal *, doublecomplex *, integer *);
    static logical rstart;
    static integer msglvl;
    static doublereal smlnum;
    extern doublereal zlanhs_(char *, integer *, doublecomplex *, integer *, 
	    doublecomplex *, ftnlen);
    extern /* Subroutine */ int zlascl_(char *, integer *, integer *, 
	    doublereal *, doublereal *, integer *, integer *, doublecomplex *,
	     integer *, integer *, ftnlen);


/*     %----------------------------------------------------% */
/*     | Include files for debugging and timing information | */
/*     %----------------------------------------------------% */


/* \SCCS Information: @(#) */
/* FILE: debug.h   SID: 2.3   DATE OF SID: 11/16/95   RELEASE: 2 */

/*     %---------------------------------% */
/*     | See debug.doc for documentation | */
/*     %---------------------------------% */

/*     %------------------% */
/*     | Scalar Arguments | */
/*     %------------------% */

/*     %--------------------------------% */
/*     | See stat.doc for documentation | */
/*     %--------------------------------% */

/* \SCCS Information: @(#) */
/* FILE: stat.h   SID: 2.2   DATE OF SID: 11/16/95   RELEASE: 2 */



/*     %-----------------% */
/*     | Array Arguments | */
/*     %-----------------% */


/*     %------------% */
/*     | Parameters | */
/*     %------------% */


/*     %--------------% */
/*     | Local Arrays | */
/*     %--------------% */


/*     %---------------% */
/*     | Local Scalars | */
/*     %---------------% */



/*     %----------------------% */
/*     | External Subroutines | */
/*     %----------------------% */


/*     %--------------------% */
/*     | External Functions | */
/*     %--------------------% */


/*     %---------------------% */
/*     | Intrinsic Functions | */
/*     %---------------------% */


/*     %-----------------% */
/*     | Data statements | */
/*     %-----------------% */

    /* Parameter adjustments */
    --workd;
    --resid;
    v_dim1 = *ldv;
    v_offset = 1 + v_dim1;
    v -= v_offset;
    h_dim1 = *ldh;
    h_offset = 1 + h_dim1;
    h__ -= h_offset;
    --ipntr;

    /* Function Body */

/*     %-----------------------% */
/*     | Executable Statements | */
/*     %-----------------------% */

    if (first) {

/*        %-----------------------------------------% */
/*        | Set machine-dependent constants for the | */
/*        | the splitting and deflation criterion.  | */
/*        | If norm(H) <= sqrt(OVFL),               | */
/*        | overflow should not occur.              | */
/*        | REFERENCE: LAPACK subroutine zlahqr     | */
/*        %-----------------------------------------% */

	unfl = dlamch_("safe minimum", (ftnlen)12);
	z__1.r = 1. / unfl, z__1.i = 0. / unfl;
	ovfl = z__1.r;
	dlabad_(&unfl, &ovfl);
	ulp = dlamch_("precision", (ftnlen)9);
	smlnum = unfl * (*n / ulp);
	first = FALSE_;
    }

    if (*ido == 0) {

/*        %-------------------------------% */
/*        | Initialize timing statistics  | */
/*        | & message level for debugging | */
/*        %-------------------------------% */

	second_(&t0);
	msglvl = debug_1.mcaitr;

/*        %------------------------------% */
/*        | Initial call to this routine | */
/*        %------------------------------% */

	*info = 0;
	step3 = FALSE_;
	step4 = FALSE_;
	rstart = FALSE_;
	orth1 = FALSE_;
	orth2 = FALSE_;
	j = *k + 1;
	ipj = 1;
	irj = ipj + *n;
	ivj = irj + *n;
    }

/*     %-------------------------------------------------% */
/*     | When in reverse communication mode one of:      | */
/*     | STEP3, STEP4, ORTH1, ORTH2, RSTART              | */
/*     | will be .true. when ....                        | */
/*     | STEP3: return from computing OP*v_{j}.          | */
/*     | STEP4: return from computing B-norm of OP*v_{j} | */
/*     | ORTH1: return from computing B-norm of r_{j+1}  | */
/*     | ORTH2: return from computing B-norm of          | */
/*     |        correction to the residual vector.       | */
/*     | RSTART: return from OP computations needed by   | */
/*     |         zgetv0.                                 | */
/*     %-------------------------------------------------% */

    if (step3) {
	goto L50;
    }
    if (step4) {
	goto L60;
    }
    if (orth1) {
	goto L70;
    }
    if (orth2) {
	goto L90;
    }
    if (rstart) {
	goto L30;
    }

/*     %-----------------------------% */
/*     | Else this is the first step | */
/*     %-----------------------------% */

/*     %--------------------------------------------------------------% */
/*     |                                                              | */
/*     |        A R N O L D I     I T E R A T I O N     L O O P       | */
/*     |                                                              | */
/*     | Note:  B*r_{j-1} is already in WORKD(1:N)=WORKD(IPJ:IPJ+N-1) | */
/*     %--------------------------------------------------------------% */
L1000:

    if (msglvl > 1) {
	ivout_(&debug_1.logfil, &c__1, &j, &debug_1.ndigit, "_naitr: generat"
		"ing Arnoldi vector number", (ftnlen)40);
	dvout_(&debug_1.logfil, &c__1, rnorm, &debug_1.ndigit, "_naitr: B-no"
		"rm of the current residual is", (ftnlen)41);
    }

/*        %---------------------------------------------------% */
/*        | STEP 1: Check if the B norm of j-th residual      | */
/*        | vector is zero. Equivalent to determine whether   | */
/*        | an exact j-step Arnoldi factorization is present. | */
/*        %---------------------------------------------------% */

    betaj = *rnorm;
    if (*rnorm > 0.) {
	goto L40;
    }

/*           %---------------------------------------------------% */
/*           | Invariant subspace found, generate a new starting | */
/*           | vector which is orthogonal to the current Arnoldi | */
/*           | basis and continue the iteration.                 | */
/*           %---------------------------------------------------% */

    if (msglvl > 0) {
	ivout_(&debug_1.logfil, &c__1, &j, &debug_1.ndigit, "_naitr: ****** "
		"RESTART AT STEP ******", (ftnlen)37);
    }

/*           %---------------------------------------------% */
/*           | ITRY is the loop variable that controls the | */
/*           | maximum amount of times that a restart is   | */
/*           | attempted. NRSTRT is used by stat.h         | */
/*           %---------------------------------------------% */

    betaj = 0.;
    ++timing_1.nrstrt;
    itry = 1;
L20:
    rstart = TRUE_;
    *ido = 0;
L30:

/*           %--------------------------------------% */
/*           | If in reverse communication mode and | */
/*           | RSTART = .true. flow returns here.   | */
/*           %--------------------------------------% */

    zgetv0_(ido, bmat, &itry, &c_false, n, &j, &v[v_offset], ldv, &resid[1], 
	    rnorm, &ipntr[1], &workd[1], &ierr, (ftnlen)1);
    if (*ido != 99) {
	goto L9000;
    }
    if (ierr < 0) {
	++itry;
	if (itry <= 3) {
	    goto L20;
	}

/*              %------------------------------------------------% */
/*              | Give up after several restart attempts.        | */
/*              | Set INFO to the size of the invariant subspace | */
/*              | which spans OP and exit.                       | */
/*              %------------------------------------------------% */

	*info = j - 1;
	second_(&t1);
	timing_1.tcaitr += t1 - t0;
	*ido = 99;
	goto L9000;
    }

L40:

/*        %---------------------------------------------------------% */
/*        | STEP 2:  v_{j} = r_{j-1}/rnorm and p_{j} = p_{j}/rnorm  | */
/*        | Note that p_{j} = B*r_{j-1}. In order to avoid overflow | */
/*        | when reciprocating a small RNORM, test against lower    | */
/*        | machine bound.                                          | */
/*        %---------------------------------------------------------% */

    zcopy_(n, &resid[1], &c__1, &v[j * v_dim1 + 1], &c__1);
    if (*rnorm >= unfl) {
	temp1 = 1. / *rnorm;
	zdscal_(n, &temp1, &v[j * v_dim1 + 1], &c__1);
	zdscal_(n, &temp1, &workd[ipj], &c__1);
    } else {

/*            %-----------------------------------------% */
/*            | To scale both v_{j} and p_{j} carefully | */
/*            | use LAPACK routine zlascl               | */
/*            %-----------------------------------------% */

	zlascl_("General", &i__, &i__, rnorm, &c_b27, n, &c__1, &v[j * v_dim1 
		+ 1], n, &infol, (ftnlen)7);
	zlascl_("General", &i__, &i__, rnorm, &c_b27, n, &c__1, &workd[ipj], 
		n, &infol, (ftnlen)7);
    }

/*        %------------------------------------------------------% */
/*        | STEP 3:  r_{j} = OP*v_{j}; Note that p_{j} = B*v_{j} | */
/*        | Note that this is not quite yet r_{j}. See STEP 4    | */
/*        %------------------------------------------------------% */

    step3 = TRUE_;
    ++timing_1.nopx;
    second_(&t2);
    zcopy_(n, &v[j * v_dim1 + 1], &c__1, &workd[ivj], &c__1);
    ipntr[1] = ivj;
    ipntr[2] = irj;
    ipntr[3] = ipj;
    *ido = 1;

/*        %-----------------------------------% */
/*        | Exit in order to compute OP*v_{j} | */
/*        %-----------------------------------% */

    goto L9000;
L50:

/*        %----------------------------------% */
/*        | Back from reverse communication; | */
/*        | WORKD(IRJ:IRJ+N-1) := OP*v_{j}   | */
/*        | if step3 = .true.                | */
/*        %----------------------------------% */

    second_(&t3);
    timing_1.tmvopx += t3 - t2;
    step3 = FALSE_;

/*        %------------------------------------------% */
/*        | Put another copy of OP*v_{j} into RESID. | */
/*        %------------------------------------------% */

    zcopy_(n, &workd[irj], &c__1, &resid[1], &c__1);

/*        %---------------------------------------% */
/*        | STEP 4:  Finish extending the Arnoldi | */
/*        |          factorization to length j.   | */
/*        %---------------------------------------% */

    second_(&t2);
    if (*(unsigned char *)bmat == 'G') {
	++timing_1.nbx;
	step4 = TRUE_;
	ipntr[1] = irj;
	ipntr[2] = ipj;
	*ido = 2;

/*           %-------------------------------------% */
/*           | Exit in order to compute B*OP*v_{j} | */
/*           %-------------------------------------% */

	goto L9000;
    } else if (*(unsigned char *)bmat == 'I') {
	zcopy_(n, &resid[1], &c__1, &workd[ipj], &c__1);
    }
L60:

/*        %----------------------------------% */
/*        | Back from reverse communication; | */
/*        | WORKD(IPJ:IPJ+N-1) := B*OP*v_{j} | */
/*        | if step4 = .true.                | */
/*        %----------------------------------% */

    if (*(unsigned char *)bmat == 'G') {
	second_(&t3);
	timing_1.tmvbx += t3 - t2;
    }

    step4 = FALSE_;

/*        %-------------------------------------% */
/*        | The following is needed for STEP 5. | */
/*        | Compute the B-norm of OP*v_{j}.     | */
/*        %-------------------------------------% */

    if (*(unsigned char *)bmat == 'G') {
	zdotc_(&z__1, n, &resid[1], &c__1, &workd[ipj], &c__1);
	cnorm.r = z__1.r, cnorm.i = z__1.i;
	d__1 = cnorm.r;
	d__2 = d_imag(&cnorm);
	wnorm = sqrt(dlapy2_(&d__1, &d__2));
    } else if (*(unsigned char *)bmat == 'I') {
	wnorm = dznrm2_(n, &resid[1], &c__1);
    }

/*        %-----------------------------------------% */
/*        | Compute the j-th residual corresponding | */
/*        | to the j step factorization.            | */
/*        | Use Classical Gram Schmidt and compute: | */
/*        | w_{j} <-  V_{j}^T * B * OP * v_{j}      | */
/*        | r_{j} <-  OP*v_{j} - V_{j} * w_{j}      | */
/*        %-----------------------------------------% */


/*        %------------------------------------------% */
/*        | Compute the j Fourier coefficients w_{j} | */
/*        | WORKD(IPJ:IPJ+N-1) contains B*OP*v_{j}.  | */
/*        %------------------------------------------% */

    zgemv_("C", n, &j, &c_b1, &v[v_offset], ldv, &workd[ipj], &c__1, &c_b2, &
	    h__[j * h_dim1 + 1], &c__1, (ftnlen)1);

/*        %--------------------------------------% */
/*        | Orthogonalize r_{j} against V_{j}.   | */
/*        | RESID contains OP*v_{j}. See STEP 3. | */
/*        %--------------------------------------% */

    z__1.r = -1., z__1.i = -0.;
    zgemv_("N", n, &j, &z__1, &v[v_offset], ldv, &h__[j * h_dim1 + 1], &c__1, 
	    &c_b1, &resid[1], &c__1, (ftnlen)1);

    if (j > 1) {
	i__1 = j + (j - 1) * h_dim1;
	z__1.r = betaj, z__1.i = 0.;
	h__[i__1].r = z__1.r, h__[i__1].i = z__1.i;
    }

    second_(&t4);

    orth1 = TRUE_;

    second_(&t2);
    if (*(unsigned char *)bmat == 'G') {
	++timing_1.nbx;
	zcopy_(n, &resid[1], &c__1, &workd[irj], &c__1);
	ipntr[1] = irj;
	ipntr[2] = ipj;
	*ido = 2;

/*           %----------------------------------% */
/*           | Exit in order to compute B*r_{j} | */
/*           %----------------------------------% */

	goto L9000;
    } else if (*(unsigned char *)bmat == 'I') {
	zcopy_(n, &resid[1], &c__1, &workd[ipj], &c__1);
    }
L70:

/*        %---------------------------------------------------% */
/*        | Back from reverse communication if ORTH1 = .true. | */
/*        | WORKD(IPJ:IPJ+N-1) := B*r_{j}.                    | */
/*        %---------------------------------------------------% */

    if (*(unsigned char *)bmat == 'G') {
	second_(&t3);
	timing_1.tmvbx += t3 - t2;
    }

    orth1 = FALSE_;

/*        %------------------------------% */
/*        | Compute the B-norm of r_{j}. | */
/*        %------------------------------% */

    if (*(unsigned char *)bmat == 'G') {
	zdotc_(&z__1, n, &resid[1], &c__1, &workd[ipj], &c__1);
	cnorm.r = z__1.r, cnorm.i = z__1.i;
	d__1 = cnorm.r;
	d__2 = d_imag(&cnorm);
	*rnorm = sqrt(dlapy2_(&d__1, &d__2));
    } else if (*(unsigned char *)bmat == 'I') {
	*rnorm = dznrm2_(n, &resid[1], &c__1);
    }

/*        %-----------------------------------------------------------% */
/*        | STEP 5: Re-orthogonalization / Iterative refinement phase | */
/*        | Maximum NITER_ITREF tries.                                | */
/*        |                                                           | */
/*        |          s      = V_{j}^T * B * r_{j}                     | */
/*        |          r_{j}  = r_{j} - V_{j}*s                         | */
/*        |          alphaj = alphaj + s_{j}                          | */
/*        |                                                           | */
/*        | The stopping criteria used for iterative refinement is    | */
/*        | discussed in Parlett's book SEP, page 107 and in Gragg &  | */
/*        | Reichel ACM TOMS paper; Algorithm 686, Dec. 1990.         | */
/*        | Determine if we need to correct the residual. The goal is | */
/*        | to enforce ||v(:,1:j)^T * r_{j}|| .le. eps * || r_{j} ||  | */
/*        | The following test determines whether the sine of the     | */
/*        | angle between  OP*x and the computed residual is less     | */
/*        | than or equal to 0.717.                                   | */
/*        %-----------------------------------------------------------% */

    if (*rnorm > wnorm * .717f) {
	goto L100;
    }

    iter = 0;
    ++timing_1.nrorth;

/*        %---------------------------------------------------% */
/*        | Enter the Iterative refinement phase. If further  | */
/*        | refinement is necessary, loop back here. The loop | */
/*        | variable is ITER. Perform a step of Classical     | */
/*        | Gram-Schmidt using all the Arnoldi vectors V_{j}  | */
/*        %---------------------------------------------------% */

L80:

    if (msglvl > 2) {
	rtemp[0] = wnorm;
	rtemp[1] = *rnorm;
	dvout_(&debug_1.logfil, &c__2, rtemp, &debug_1.ndigit, "_naitr: re-o"
		"rthogonalization; wnorm and rnorm are", (ftnlen)49);
	zvout_(&debug_1.logfil, &j, &h__[j * h_dim1 + 1], &debug_1.ndigit, 
		"_naitr: j-th column of H", (ftnlen)24);
    }

/*        %----------------------------------------------------% */
/*        | Compute V_{j}^T * B * r_{j}.                       | */
/*        | WORKD(IRJ:IRJ+J-1) = v(:,1:J)'*WORKD(IPJ:IPJ+N-1). | */
/*        %----------------------------------------------------% */

    zgemv_("C", n, &j, &c_b1, &v[v_offset], ldv, &workd[ipj], &c__1, &c_b2, &
	    workd[irj], &c__1, (ftnlen)1);

/*        %---------------------------------------------% */
/*        | Compute the correction to the residual:     | */
/*        | r_{j} = r_{j} - V_{j} * WORKD(IRJ:IRJ+J-1). | */
/*        | The correction to H is v(:,1:J)*H(1:J,1:J)  | */
/*        | + v(:,1:J)*WORKD(IRJ:IRJ+J-1)*e'_j.         | */
/*        %---------------------------------------------% */

    z__1.r = -1., z__1.i = -0.;
    zgemv_("N", n, &j, &z__1, &v[v_offset], ldv, &workd[irj], &c__1, &c_b1, &
	    resid[1], &c__1, (ftnlen)1);
    zaxpy_(&j, &c_b1, &workd[irj], &c__1, &h__[j * h_dim1 + 1], &c__1);

    orth2 = TRUE_;
    second_(&t2);
    if (*(unsigned char *)bmat == 'G') {
	++timing_1.nbx;
	zcopy_(n, &resid[1], &c__1, &workd[irj], &c__1);
	ipntr[1] = irj;
	ipntr[2] = ipj;
	*ido = 2;

/*           %-----------------------------------% */
/*           | Exit in order to compute B*r_{j}. | */
/*           | r_{j} is the corrected residual.  | */
/*           %-----------------------------------% */

	goto L9000;
    } else if (*(unsigned char *)bmat == 'I') {
	zcopy_(n, &resid[1], &c__1, &workd[ipj], &c__1);
    }
L90:

/*        %---------------------------------------------------% */
/*        | Back from reverse communication if ORTH2 = .true. | */
/*        %---------------------------------------------------% */

    if (*(unsigned char *)bmat == 'G') {
	second_(&t3);
	timing_1.tmvbx += t3 - t2;
    }

/*        %-----------------------------------------------------% */
/*        | Compute the B-norm of the corrected residual r_{j}. | */
/*        %-----------------------------------------------------% */

    if (*(unsigned char *)bmat == 'G') {
	zdotc_(&z__1, n, &resid[1], &c__1, &workd[ipj], &c__1);
	cnorm.r = z__1.r, cnorm.i = z__1.i;
	d__1 = cnorm.r;
	d__2 = d_imag(&cnorm);
	rnorm1 = sqrt(dlapy2_(&d__1, &d__2));
    } else if (*(unsigned char *)bmat == 'I') {
	rnorm1 = dznrm2_(n, &resid[1], &c__1);
    }

    if (msglvl > 0 && iter > 0) {
	ivout_(&debug_1.logfil, &c__1, &j, &debug_1.ndigit, "_naitr: Iterati"
		"ve refinement for Arnoldi residual", (ftnlen)49);
	if (msglvl > 2) {
	    rtemp[0] = *rnorm;
	    rtemp[1] = rnorm1;
	    dvout_(&debug_1.logfil, &c__2, rtemp, &debug_1.ndigit, "_naitr: "
		    "iterative refinement ; rnorm and rnorm1 are", (ftnlen)51);
	}
    }

/*        %-----------------------------------------% */
/*        | Determine if we need to perform another | */
/*        | step of re-orthogonalization.           | */
/*        %-----------------------------------------% */

    if (rnorm1 > *rnorm * .717f) {

/*           %---------------------------------------% */
/*           | No need for further refinement.       | */
/*           | The cosine of the angle between the   | */
/*           | corrected residual vector and the old | */
/*           | residual vector is greater than 0.717 | */
/*           | In other words the corrected residual | */
/*           | and the old residual vector share an  | */
/*           | angle of less than arcCOS(0.717)      | */
/*           %---------------------------------------% */

	*rnorm = rnorm1;

    } else {

/*           %-------------------------------------------% */
/*           | Another step of iterative refinement step | */
/*           | is required. NITREF is used by stat.h     | */
/*           %-------------------------------------------% */

	++timing_1.nitref;
	*rnorm = rnorm1;
	++iter;
	if (iter <= 1) {
	    goto L80;
	}

/*           %-------------------------------------------------% */
/*           | Otherwise RESID is numerically in the span of V | */
/*           %-------------------------------------------------% */

	i__1 = *n;
	for (jj = 1; jj <= i__1; ++jj) {
	    i__2 = jj;
	    resid[i__2].r = 0., resid[i__2].i = 0.;
/* L95: */
	}
	*rnorm = 0.;
    }

/*        %----------------------------------------------% */
/*        | Branch here directly if iterative refinement | */
/*        | wasn't necessary or after at most NITER_REF  | */
/*        | steps of iterative refinement.               | */
/*        %----------------------------------------------% */

L100:

    rstart = FALSE_;
    orth2 = FALSE_;

    second_(&t5);
    timing_1.titref += t5 - t4;

/*        %------------------------------------% */
/*        | STEP 6: Update  j = j+1;  Continue | */
/*        %------------------------------------% */

    ++j;
    if (j > *k + *np) {
	second_(&t1);
	timing_1.tcaitr += t1 - t0;
	*ido = 99;
	i__1 = *k + *np - 1;
	for (i__ = max(1,*k); i__ <= i__1; ++i__) {

/*              %--------------------------------------------% */
/*              | Check for splitting and deflation.         | */
/*              | Use a standard test as in the QR algorithm | */
/*              | REFERENCE: LAPACK subroutine zlahqr        | */
/*              %--------------------------------------------% */

	    i__2 = i__ + i__ * h_dim1;
	    d__1 = h__[i__2].r;
	    d__2 = d_imag(&h__[i__ + i__ * h_dim1]);
	    i__3 = i__ + 1 + (i__ + 1) * h_dim1;
	    d__3 = h__[i__3].r;
	    d__4 = d_imag(&h__[i__ + 1 + (i__ + 1) * h_dim1]);
	    tst1 = dlapy2_(&d__1, &d__2) + dlapy2_(&d__3, &d__4);
	    if (tst1 == 0.) {
		i__2 = *k + *np;
		tst1 = zlanhs_("1", &i__2, &h__[h_offset], ldh, &workd[*n + 1]
			, (ftnlen)1);
	    }
	    i__2 = i__ + 1 + i__ * h_dim1;
	    d__1 = h__[i__2].r;
	    d__2 = d_imag(&h__[i__ + 1 + i__ * h_dim1]);
/* Computing MAX */
	    d__3 = ulp * tst1;
	    if (dlapy2_(&d__1, &d__2) <= max(d__3,smlnum)) {
		i__3 = i__ + 1 + i__ * h_dim1;
		h__[i__3].r = 0., h__[i__3].i = 0.;
	    }
/* L110: */
	}

	if (msglvl > 2) {
	    i__1 = *k + *np;
	    i__2 = *k + *np;
	    zmout_(&debug_1.logfil, &i__1, &i__2, &h__[h_offset], ldh, &
		    debug_1.ndigit, "_naitr: Final upper Hessenberg matrix H"
		    " of order K+NP", (ftnlen)53);
	}

	goto L9000;
    }

/*        %--------------------------------------------------------% */
/*        | Loop back to extend the factorization by another step. | */
/*        %--------------------------------------------------------% */

    goto L1000;

/*     %---------------------------------------------------------------% */
/*     |                                                               | */
/*     |  E N D     O F     M A I N     I T E R A T I O N     L O O P  | */
/*     |                                                               | */
/*     %---------------------------------------------------------------% */

L9000:
    return 0;

/*     %---------------% */
/*     | End of znaitr | */
/*     %---------------% */

} /* znaitr_ */
示例#26
0
/* Subroutine */ int dgelsd_(integer *m, integer *n, integer *nrhs, 
	doublereal *a, integer *lda, doublereal *b, integer *ldb, doublereal *
	s, doublereal *rcond, integer *rank, doublereal *work, integer *lwork,
	 integer *iwork, integer *info)
{
    /* System generated locals */
    integer a_dim1, a_offset, b_dim1, b_offset, i__1, i__2, i__3, i__4;

    /* Builtin functions */
    double log(doublereal);

    /* Local variables */
    static doublereal anrm, bnrm;
    static integer itau, nlvl, iascl, ibscl;
    static doublereal sfmin;
    static integer minmn, maxmn, itaup, itauq, mnthr, nwork;
    extern /* Subroutine */ int dlabad_(doublereal *, doublereal *);
    static integer ie, il;
    extern /* Subroutine */ int dgebrd_(integer *, integer *, doublereal *, 
	    integer *, doublereal *, doublereal *, doublereal *, doublereal *,
	     doublereal *, integer *, integer *);
    extern doublereal dlamch_(char *);
    static integer mm;
    extern doublereal dlange_(char *, integer *, integer *, doublereal *, 
	    integer *, doublereal *);
    extern /* Subroutine */ int dgelqf_(integer *, integer *, doublereal *, 
	    integer *, doublereal *, doublereal *, integer *, integer *), 
	    dlalsd_(char *, integer *, integer *, integer *, doublereal *, 
	    doublereal *, doublereal *, integer *, doublereal *, integer *, 
	    doublereal *, integer *, integer *), dlascl_(char *, 
	    integer *, integer *, doublereal *, doublereal *, integer *, 
	    integer *, doublereal *, integer *, integer *), dgeqrf_(
	    integer *, integer *, doublereal *, integer *, doublereal *, 
	    doublereal *, integer *, integer *), dlacpy_(char *, integer *, 
	    integer *, doublereal *, integer *, doublereal *, integer *), dlaset_(char *, integer *, integer *, doublereal *, 
	    doublereal *, doublereal *, integer *), xerbla_(char *, 
	    integer *);
    extern integer ilaenv_(integer *, char *, char *, integer *, integer *, 
	    integer *, integer *, ftnlen, ftnlen);
    static doublereal bignum;
    extern /* Subroutine */ int dormbr_(char *, char *, char *, integer *, 
	    integer *, integer *, doublereal *, integer *, doublereal *, 
	    doublereal *, integer *, doublereal *, integer *, integer *);
    static integer wlalsd;
    extern /* Subroutine */ int dormlq_(char *, char *, integer *, integer *, 
	    integer *, doublereal *, integer *, doublereal *, doublereal *, 
	    integer *, doublereal *, integer *, integer *);
    static integer ldwork;
    extern /* Subroutine */ int dormqr_(char *, char *, integer *, integer *, 
	    integer *, doublereal *, integer *, doublereal *, doublereal *, 
	    integer *, doublereal *, integer *, integer *);
    static integer minwrk, maxwrk;
    static doublereal smlnum;
    static logical lquery;
    static integer smlsiz;
    static doublereal eps;


#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]


/*  -- LAPACK driver routine (version 3.0) --   
       Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,   
       Courant Institute, Argonne National Lab, and Rice University   
       October 31, 1999   


    Purpose   
    =======   

    DGELSD computes the minimum-norm solution to a real linear least   
    squares problem:   
        minimize 2-norm(| b - A*x |)   
    using the singular value decomposition (SVD) of A. A is an M-by-N   
    matrix which may be rank-deficient.   

    Several right hand side vectors b and solution vectors x can be   
    handled in a single call; they are stored as the columns of the   
    M-by-NRHS right hand side matrix B and the N-by-NRHS solution   
    matrix X.   

    The problem is solved in three steps:   
    (1) Reduce the coefficient matrix A to bidiagonal form with   
        Householder transformations, reducing the original problem   
        into a "bidiagonal least squares problem" (BLS)   
    (2) Solve the BLS using a divide and conquer approach.   
    (3) Apply back all the Householder tranformations to solve   
        the original least squares problem.   

    The effective rank of A is determined by treating as zero those   
    singular values which are less than RCOND times the largest singular   
    value.   

    The divide and conquer algorithm makes very mild assumptions about   
    floating point arithmetic. It will work on machines with a guard   
    digit in add/subtract, or on those binary machines without guard   
    digits which subtract like the Cray X-MP, Cray Y-MP, Cray C-90, or   
    Cray-2. It could conceivably fail on hexadecimal or decimal machines   
    without guard digits, but we know of none.   

    Arguments   
    =========   

    M       (input) INTEGER   
            The number of rows of A. M >= 0.   

    N       (input) INTEGER   
            The number of columns of A. N >= 0.   

    NRHS    (input) INTEGER   
            The number of right hand sides, i.e., the number of columns   
            of the matrices B and X. NRHS >= 0.   

    A       (input) DOUBLE PRECISION array, dimension (LDA,N)   
            On entry, the M-by-N matrix A.   
            On exit, A has been destroyed.   

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

    B       (input/output) DOUBLE PRECISION array, dimension (LDB,NRHS)   
            On entry, the M-by-NRHS right hand side matrix B.   
            On exit, B is overwritten by the N-by-NRHS solution   
            matrix X.  If m >= n and RANK = n, the residual   
            sum-of-squares for the solution in the i-th column is given   
            by the sum of squares of elements n+1:m in that column.   

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

    S       (output) DOUBLE PRECISION array, dimension (min(M,N))   
            The singular values of A in decreasing order.   
            The condition number of A in the 2-norm = S(1)/S(min(m,n)).   

    RCOND   (input) DOUBLE PRECISION   
            RCOND is used to determine the effective rank of A.   
            Singular values S(i) <= RCOND*S(1) are treated as zero.   
            If RCOND < 0, machine precision is used instead.   

    RANK    (output) INTEGER   
            The effective rank of A, i.e., the number of singular values   
            which are greater than RCOND*S(1).   

    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 must be at least 1.   
            The exact minimum amount of workspace needed depends on M,   
            N and NRHS. As long as LWORK is at least   
                12*N + 2*N*SMLSIZ + 8*N*NLVL + N*NRHS + (SMLSIZ+1)**2,   
            if M is greater than or equal to N or   
                12*M + 2*M*SMLSIZ + 8*M*NLVL + M*NRHS + (SMLSIZ+1)**2,   
            if M is less than N, the code will execute correctly.   
            SMLSIZ is returned by ILAENV and is equal to the maximum   
            size of the subproblems at the bottom of the computation   
            tree (usually about 25), and   
               NLVL = MAX( 0, INT( LOG_2( MIN( M,N )/(SMLSIZ+1) ) ) + 1 )   
            For good performance, LWORK should 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.   

    IWORK   (workspace) INTEGER array, dimension (LIWORK)   
            LIWORK >= 3 * MINMN * NLVL + 11 * MINMN,   
            where MINMN = MIN( M,N ).   

    INFO    (output) INTEGER   
            = 0:  successful exit   
            < 0:  if INFO = -i, the i-th argument had an illegal value.   
            > 0:  the algorithm for computing the SVD failed to converge;   
                  if INFO = i, i off-diagonal elements of an intermediate   
                  bidiagonal form did not converge to zero.   

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

    Based on contributions by   
       Ming Gu and Ren-Cang Li, Computer Science Division, University of   
         California at Berkeley, USA   
       Osni Marques, LBNL/NERSC, USA   

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


       Test the input arguments.   

       Parameter adjustments */
    a_dim1 = *lda;
    a_offset = 1 + a_dim1 * 1;
    a -= a_offset;
    b_dim1 = *ldb;
    b_offset = 1 + b_dim1 * 1;
    b -= b_offset;
    --s;
    --work;
    --iwork;

    /* Function Body */
    *info = 0;
    minmn = min(*m,*n);
    maxmn = max(*m,*n);
    mnthr = ilaenv_(&c__6, "DGELSD", " ", m, n, nrhs, &c_n1, (ftnlen)6, (
	    ftnlen)1);
    lquery = *lwork == -1;
    if (*m < 0) {
	*info = -1;
    } else if (*n < 0) {
	*info = -2;
    } else if (*nrhs < 0) {
	*info = -3;
    } else if (*lda < max(1,*m)) {
	*info = -5;
    } else if (*ldb < max(1,maxmn)) {
	*info = -7;
    }

    smlsiz = ilaenv_(&c__9, "DGELSD", " ", &c__0, &c__0, &c__0, &c__0, (
	    ftnlen)6, (ftnlen)1);

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

    minwrk = 1;
    minmn = max(1,minmn);
/* Computing MAX */
    i__1 = (integer) (log((doublereal) minmn / (doublereal) (smlsiz + 1)) / 
	    log(2.)) + 1;
    nlvl = max(i__1,0);

    if (*info == 0) {
	maxwrk = 0;
	mm = *m;
	if (*m >= *n && *m >= mnthr) {

/*           Path 1a - overdetermined, with many more rows than columns. */

	    mm = *n;
/* Computing MAX */
	    i__1 = maxwrk, i__2 = *n + *n * ilaenv_(&c__1, "DGEQRF", " ", m, 
		    n, &c_n1, &c_n1, (ftnlen)6, (ftnlen)1);
	    maxwrk = max(i__1,i__2);
/* Computing MAX */
	    i__1 = maxwrk, i__2 = *n + *nrhs * ilaenv_(&c__1, "DORMQR", "LT", 
		    m, nrhs, n, &c_n1, (ftnlen)6, (ftnlen)2);
	    maxwrk = max(i__1,i__2);
	}
	if (*m >= *n) {

/*           Path 1 - overdetermined or exactly determined.   

   Computing MAX */
	    i__1 = maxwrk, i__2 = *n * 3 + (mm + *n) * ilaenv_(&c__1, "DGEBRD"
		    , " ", &mm, n, &c_n1, &c_n1, (ftnlen)6, (ftnlen)1);
	    maxwrk = max(i__1,i__2);
/* Computing MAX */
	    i__1 = maxwrk, i__2 = *n * 3 + *nrhs * ilaenv_(&c__1, "DORMBR", 
		    "QLT", &mm, nrhs, n, &c_n1, (ftnlen)6, (ftnlen)3);
	    maxwrk = max(i__1,i__2);
/* Computing MAX */
	    i__1 = maxwrk, i__2 = *n * 3 + (*n - 1) * ilaenv_(&c__1, "DORMBR",
		     "PLN", n, nrhs, n, &c_n1, (ftnlen)6, (ftnlen)3);
	    maxwrk = max(i__1,i__2);
/* Computing 2nd power */
	    i__1 = smlsiz + 1;
	    wlalsd = *n * 9 + (*n << 1) * smlsiz + (*n << 3) * nlvl + *n * *
		    nrhs + i__1 * i__1;
/* Computing MAX */
	    i__1 = maxwrk, i__2 = *n * 3 + wlalsd;
	    maxwrk = max(i__1,i__2);
/* Computing MAX */
	    i__1 = *n * 3 + mm, i__2 = *n * 3 + *nrhs, i__1 = max(i__1,i__2), 
		    i__2 = *n * 3 + wlalsd;
	    minwrk = max(i__1,i__2);
	}
	if (*n > *m) {
/* Computing 2nd power */
	    i__1 = smlsiz + 1;
	    wlalsd = *m * 9 + (*m << 1) * smlsiz + (*m << 3) * nlvl + *m * *
		    nrhs + i__1 * i__1;
	    if (*n >= mnthr) {

/*              Path 2a - underdetermined, with many more columns   
                than rows. */

		maxwrk = *m + *m * ilaenv_(&c__1, "DGELQF", " ", m, n, &c_n1, 
			&c_n1, (ftnlen)6, (ftnlen)1);
/* Computing MAX */
		i__1 = maxwrk, i__2 = *m * *m + (*m << 2) + (*m << 1) * 
			ilaenv_(&c__1, "DGEBRD", " ", m, m, &c_n1, &c_n1, (
			ftnlen)6, (ftnlen)1);
		maxwrk = max(i__1,i__2);
/* Computing MAX */
		i__1 = maxwrk, i__2 = *m * *m + (*m << 2) + *nrhs * ilaenv_(&
			c__1, "DORMBR", "QLT", m, nrhs, m, &c_n1, (ftnlen)6, (
			ftnlen)3);
		maxwrk = max(i__1,i__2);
/* Computing MAX */
		i__1 = maxwrk, i__2 = *m * *m + (*m << 2) + (*m - 1) * 
			ilaenv_(&c__1, "DORMBR", "PLN", m, nrhs, m, &c_n1, (
			ftnlen)6, (ftnlen)3);
		maxwrk = max(i__1,i__2);
		if (*nrhs > 1) {
/* Computing MAX */
		    i__1 = maxwrk, i__2 = *m * *m + *m + *m * *nrhs;
		    maxwrk = max(i__1,i__2);
		} else {
/* Computing MAX */
		    i__1 = maxwrk, i__2 = *m * *m + (*m << 1);
		    maxwrk = max(i__1,i__2);
		}
/* Computing MAX */
		i__1 = maxwrk, i__2 = *m + *nrhs * ilaenv_(&c__1, "DORMLQ", 
			"LT", n, nrhs, m, &c_n1, (ftnlen)6, (ftnlen)2);
		maxwrk = max(i__1,i__2);
/* Computing MAX */
		i__1 = maxwrk, i__2 = *m * *m + (*m << 2) + wlalsd;
		maxwrk = max(i__1,i__2);
	    } else {

/*              Path 2 - remaining underdetermined cases. */

		maxwrk = *m * 3 + (*n + *m) * ilaenv_(&c__1, "DGEBRD", " ", m,
			 n, &c_n1, &c_n1, (ftnlen)6, (ftnlen)1);
/* Computing MAX */
		i__1 = maxwrk, i__2 = *m * 3 + *nrhs * ilaenv_(&c__1, "DORMBR"
			, "QLT", m, nrhs, n, &c_n1, (ftnlen)6, (ftnlen)3);
		maxwrk = max(i__1,i__2);
/* Computing MAX */
		i__1 = maxwrk, i__2 = *m * 3 + *m * ilaenv_(&c__1, "DORMBR", 
			"PLN", n, nrhs, m, &c_n1, (ftnlen)6, (ftnlen)3);
		maxwrk = max(i__1,i__2);
/* Computing MAX */
		i__1 = maxwrk, i__2 = *m * 3 + wlalsd;
		maxwrk = max(i__1,i__2);
	    }
/* Computing MAX */
	    i__1 = *m * 3 + *nrhs, i__2 = *m * 3 + *m, i__1 = max(i__1,i__2), 
		    i__2 = *m * 3 + wlalsd;
	    minwrk = max(i__1,i__2);
	}
	minwrk = min(minwrk,maxwrk);
	work[1] = (doublereal) maxwrk;
	if (*lwork < minwrk && ! lquery) {
	    *info = -12;
	}
    }

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

/*     Quick return if possible. */

    if (*m == 0 || *n == 0) {
	*rank = 0;
	return 0;
    }

/*     Get machine parameters. */

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

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

    anrm = dlange_("M", m, n, &a[a_offset], lda, &work[1]);
    iascl = 0;
    if (anrm > 0. && anrm < smlnum) {

/*        Scale matrix norm up to SMLNUM. */

	dlascl_("G", &c__0, &c__0, &anrm, &smlnum, m, n, &a[a_offset], lda, 
		info);
	iascl = 1;
    } else if (anrm > bignum) {

/*        Scale matrix norm down to BIGNUM. */

	dlascl_("G", &c__0, &c__0, &anrm, &bignum, m, n, &a[a_offset], lda, 
		info);
	iascl = 2;
    } else if (anrm == 0.) {

/*        Matrix all zero. Return zero solution. */

	i__1 = max(*m,*n);
	dlaset_("F", &i__1, nrhs, &c_b82, &c_b82, &b[b_offset], ldb);
	dlaset_("F", &minmn, &c__1, &c_b82, &c_b82, &s[1], &c__1);
	*rank = 0;
	goto L10;
    }

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

    bnrm = dlange_("M", m, nrhs, &b[b_offset], ldb, &work[1]);
    ibscl = 0;
    if (bnrm > 0. && bnrm < smlnum) {

/*        Scale matrix norm up to SMLNUM. */

	dlascl_("G", &c__0, &c__0, &bnrm, &smlnum, m, nrhs, &b[b_offset], ldb,
		 info);
	ibscl = 1;
    } else if (bnrm > bignum) {

/*        Scale matrix norm down to BIGNUM. */

	dlascl_("G", &c__0, &c__0, &bnrm, &bignum, m, nrhs, &b[b_offset], ldb,
		 info);
	ibscl = 2;
    }

/*     If M < N make sure certain entries of B are zero. */

    if (*m < *n) {
	i__1 = *n - *m;
	dlaset_("F", &i__1, nrhs, &c_b82, &c_b82, &b_ref(*m + 1, 1), ldb);
    }

/*     Overdetermined case. */

    if (*m >= *n) {

/*        Path 1 - overdetermined or exactly determined. */

	mm = *m;
	if (*m >= mnthr) {

/*           Path 1a - overdetermined, with many more rows than columns. */

	    mm = *n;
	    itau = 1;
	    nwork = itau + *n;

/*           Compute A=Q*R.   
             (Workspace: need 2*N, prefer N+N*NB) */

	    i__1 = *lwork - nwork + 1;
	    dgeqrf_(m, n, &a[a_offset], lda, &work[itau], &work[nwork], &i__1,
		     info);

/*           Multiply B by transpose(Q).   
             (Workspace: need N+NRHS, prefer N+NRHS*NB) */

	    i__1 = *lwork - nwork + 1;
	    dormqr_("L", "T", m, nrhs, n, &a[a_offset], lda, &work[itau], &b[
		    b_offset], ldb, &work[nwork], &i__1, info);

/*           Zero out below R. */

	    if (*n > 1) {
		i__1 = *n - 1;
		i__2 = *n - 1;
		dlaset_("L", &i__1, &i__2, &c_b82, &c_b82, &a_ref(2, 1), lda);
	    }
	}

	ie = 1;
	itauq = ie + *n;
	itaup = itauq + *n;
	nwork = itaup + *n;

/*        Bidiagonalize R in A.   
          (Workspace: need 3*N+MM, prefer 3*N+(MM+N)*NB) */

	i__1 = *lwork - nwork + 1;
	dgebrd_(&mm, n, &a[a_offset], lda, &s[1], &work[ie], &work[itauq], &
		work[itaup], &work[nwork], &i__1, info);

/*        Multiply B by transpose of left bidiagonalizing vectors of R.   
          (Workspace: need 3*N+NRHS, prefer 3*N+NRHS*NB) */

	i__1 = *lwork - nwork + 1;
	dormbr_("Q", "L", "T", &mm, nrhs, n, &a[a_offset], lda, &work[itauq], 
		&b[b_offset], ldb, &work[nwork], &i__1, info);

/*        Solve the bidiagonal least squares problem. */

	dlalsd_("U", &smlsiz, n, nrhs, &s[1], &work[ie], &b[b_offset], ldb, 
		rcond, rank, &work[nwork], &iwork[1], info);
	if (*info != 0) {
	    goto L10;
	}

/*        Multiply B by right bidiagonalizing vectors of R. */

	i__1 = *lwork - nwork + 1;
	dormbr_("P", "L", "N", n, nrhs, n, &a[a_offset], lda, &work[itaup], &
		b[b_offset], ldb, &work[nwork], &i__1, info);

    } else /* if(complicated condition) */ {
/* Computing MAX */
	i__1 = *m, i__2 = (*m << 1) - 4, i__1 = max(i__1,i__2), i__1 = max(
		i__1,*nrhs), i__2 = *n - *m * 3;
	if (*n >= mnthr && *lwork >= (*m << 2) + *m * *m + max(i__1,i__2)) {

/*        Path 2a - underdetermined, with many more columns than rows   
          and sufficient workspace for an efficient algorithm. */

	    ldwork = *m;
/* Computing MAX   
   Computing MAX */
	    i__3 = *m, i__4 = (*m << 1) - 4, i__3 = max(i__3,i__4), i__3 = 
		    max(i__3,*nrhs), i__4 = *n - *m * 3;
	    i__1 = (*m << 2) + *m * *lda + max(i__3,i__4), i__2 = *m * *lda + 
		    *m + *m * *nrhs;
	    if (*lwork >= max(i__1,i__2)) {
		ldwork = *lda;
	    }
	    itau = 1;
	    nwork = *m + 1;

/*        Compute A=L*Q.   
          (Workspace: need 2*M, prefer M+M*NB) */

	    i__1 = *lwork - nwork + 1;
	    dgelqf_(m, n, &a[a_offset], lda, &work[itau], &work[nwork], &i__1,
		     info);
	    il = nwork;

/*        Copy L to WORK(IL), zeroing out above its diagonal. */

	    dlacpy_("L", m, m, &a[a_offset], lda, &work[il], &ldwork);
	    i__1 = *m - 1;
	    i__2 = *m - 1;
	    dlaset_("U", &i__1, &i__2, &c_b82, &c_b82, &work[il + ldwork], &
		    ldwork);
	    ie = il + ldwork * *m;
	    itauq = ie + *m;
	    itaup = itauq + *m;
	    nwork = itaup + *m;

/*        Bidiagonalize L in WORK(IL).   
          (Workspace: need M*M+5*M, prefer M*M+4*M+2*M*NB) */

	    i__1 = *lwork - nwork + 1;
	    dgebrd_(m, m, &work[il], &ldwork, &s[1], &work[ie], &work[itauq], 
		    &work[itaup], &work[nwork], &i__1, info);

/*        Multiply B by transpose of left bidiagonalizing vectors of L.   
          (Workspace: need M*M+4*M+NRHS, prefer M*M+4*M+NRHS*NB) */

	    i__1 = *lwork - nwork + 1;
	    dormbr_("Q", "L", "T", m, nrhs, m, &work[il], &ldwork, &work[
		    itauq], &b[b_offset], ldb, &work[nwork], &i__1, info);

/*        Solve the bidiagonal least squares problem. */

	    dlalsd_("U", &smlsiz, m, nrhs, &s[1], &work[ie], &b[b_offset], 
		    ldb, rcond, rank, &work[nwork], &iwork[1], info);
	    if (*info != 0) {
		goto L10;
	    }

/*        Multiply B by right bidiagonalizing vectors of L. */

	    i__1 = *lwork - nwork + 1;
	    dormbr_("P", "L", "N", m, nrhs, m, &work[il], &ldwork, &work[
		    itaup], &b[b_offset], ldb, &work[nwork], &i__1, info);

/*        Zero out below first M rows of B. */

	    i__1 = *n - *m;
	    dlaset_("F", &i__1, nrhs, &c_b82, &c_b82, &b_ref(*m + 1, 1), ldb);
	    nwork = itau + *m;

/*        Multiply transpose(Q) by B.   
          (Workspace: need M+NRHS, prefer M+NRHS*NB) */

	    i__1 = *lwork - nwork + 1;
	    dormlq_("L", "T", n, nrhs, m, &a[a_offset], lda, &work[itau], &b[
		    b_offset], ldb, &work[nwork], &i__1, info);

	} else {

/*        Path 2 - remaining underdetermined cases. */

	    ie = 1;
	    itauq = ie + *m;
	    itaup = itauq + *m;
	    nwork = itaup + *m;

/*        Bidiagonalize A.   
          (Workspace: need 3*M+N, prefer 3*M+(M+N)*NB) */

	    i__1 = *lwork - nwork + 1;
	    dgebrd_(m, n, &a[a_offset], lda, &s[1], &work[ie], &work[itauq], &
		    work[itaup], &work[nwork], &i__1, info);

/*        Multiply B by transpose of left bidiagonalizing vectors.   
          (Workspace: need 3*M+NRHS, prefer 3*M+NRHS*NB) */

	    i__1 = *lwork - nwork + 1;
	    dormbr_("Q", "L", "T", m, nrhs, n, &a[a_offset], lda, &work[itauq]
		    , &b[b_offset], ldb, &work[nwork], &i__1, info);

/*        Solve the bidiagonal least squares problem. */

	    dlalsd_("L", &smlsiz, m, nrhs, &s[1], &work[ie], &b[b_offset], 
		    ldb, rcond, rank, &work[nwork], &iwork[1], info);
	    if (*info != 0) {
		goto L10;
	    }

/*        Multiply B by right bidiagonalizing vectors of A. */

	    i__1 = *lwork - nwork + 1;
	    dormbr_("P", "L", "N", n, nrhs, m, &a[a_offset], lda, &work[itaup]
		    , &b[b_offset], ldb, &work[nwork], &i__1, info);

	}
    }

/*     Undo scaling. */

    if (iascl == 1) {
	dlascl_("G", &c__0, &c__0, &anrm, &smlnum, n, nrhs, &b[b_offset], ldb,
		 info);
	dlascl_("G", &c__0, &c__0, &smlnum, &anrm, &minmn, &c__1, &s[1], &
		minmn, info);
    } else if (iascl == 2) {
	dlascl_("G", &c__0, &c__0, &anrm, &bignum, n, nrhs, &b[b_offset], ldb,
		 info);
	dlascl_("G", &c__0, &c__0, &bignum, &anrm, &minmn, &c__1, &s[1], &
		minmn, info);
    }
    if (ibscl == 1) {
	dlascl_("G", &c__0, &c__0, &smlnum, &bnrm, n, nrhs, &b[b_offset], ldb,
		 info);
    } else if (ibscl == 2) {
	dlascl_("G", &c__0, &c__0, &bignum, &bnrm, n, nrhs, &b[b_offset], ldb,
		 info);
    }

L10:
    work[1] = (doublereal) maxwrk;
    return 0;

/*     End of DGELSD */

} /* dgelsd_ */
示例#27
0
文件: dlatb9.c 项目: kstraube/hysim
/* Subroutine */ int dlatb9_(char *path, integer *imat, integer *m, integer *
	p, integer *n, char *type__, integer *kla, integer *kua, integer *klb, 
	 integer *kub, doublereal *anorm, doublereal *bnorm, integer *modea, 
	integer *modeb, doublereal *cndnma, doublereal *cndnmb, char *dista, 
	char *distb)
{
    /* Initialized data */

    static logical first = TRUE_;

    /* System generated locals */
    integer i__1;

    /* Builtin functions */
    double sqrt(doublereal);

    /* Local variables */
    static doublereal eps, badc1, badc2, large, small;
    extern /* Subroutine */ int dlabad_(doublereal *, doublereal *);
    extern doublereal dlamch_(char *);
    extern logical lsamen_(integer *, char *, char *);


/*  -- LAPACK test routine (version 3.1) -- */
/*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/*     November 2006 */

/*     .. Scalar Arguments .. */
/*     .. */

/*  Purpose */
/*  ======= */

/*  DLATB9 sets parameters for the matrix generator based on the type of */
/*  matrix to be generated. */

/*  Arguments */
/*  ========= */

/*  PATH    (input) CHARACTER*3 */
/*          The LAPACK path name. */

/*  IMAT    (input) INTEGER */
/*          An integer key describing which matrix to generate for this */
/*          path. */

/*  M       (input) INTEGER */
/*          The number of rows in the matrix to be generated. */

/*  N       (input) INTEGER */
/*          The number of columns in the matrix to be generated. */

/*  TYPE    (output) CHARACTER*1 */
/*          The type of the matrix to be generated: */
/*          = 'S':  symmetric matrix; */
/*          = 'P':  symmetric positive (semi)definite matrix; */
/*          = 'N':  nonsymmetric matrix. */

/*  KL      (output) INTEGER */
/*          The lower band width of the matrix to be generated. */

/*  KU      (output) INTEGER */
/*          The upper band width of the matrix to be generated. */

/*  ANORM   (output) DOUBLE PRECISION */
/*          The desired norm of the matrix to be generated.  The diagonal */
/*          matrix of singular values or eigenvalues is scaled by this */
/*          value. */

/*  MODE    (output) INTEGER */
/*          A key indicating how to choose the vector of eigenvalues. */

/*  CNDNUM  (output) DOUBLE PRECISION */
/*          The desired condition number. */

/*  DIST    (output) CHARACTER*1 */
/*          The type of distribution to be used by the random number */
/*          generator. */

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

/*     .. Parameters .. */
/*     .. */
/*     .. Local Scalars .. */
/*     .. */
/*     .. External Functions .. */
/*     .. */
/*     .. Intrinsic Functions .. */
/*     .. */
/*     .. External Subroutines .. */
/*     .. */
/*     .. Save statement .. */
/*     .. */
/*     .. Data statements .. */
/*     .. */
/*     .. Executable Statements .. */

/*     Set some constants for use in the subroutine. */

    if (first) {
	first = FALSE_;
	eps = dlamch_("Precision");
	badc2 = .1 / eps;
	badc1 = sqrt(badc2);
	small = dlamch_("Safe minimum");
	large = 1. / small;

/*        If it looks like we're on a Cray, take the square root of */
/*        SMALL and LARGE to avoid overflow and underflow problems. */

	dlabad_(&small, &large);
	small = small / eps * .25;
	large = 1. / small;
    }

/*     Set some parameters we don't plan to change. */

    *(unsigned char *)type__ = 'N';
    *(unsigned char *)dista = 'S';
    *(unsigned char *)distb = 'S';
    *modea = 3;
    *modeb = 4;

/*     Set the lower and upper bandwidths. */

    if (lsamen_(&c__3, path, "GRQ") || lsamen_(&c__3, 
	    path, "LSE") || lsamen_(&c__3, path, "GSV")) {

/*        A: M by N, B: P by N */

	if (*imat == 1) {

/*           A: diagonal, B: upper triangular */

	    *kla = 0;
	    *kua = 0;
	    *klb = 0;
/* Computing MAX */
	    i__1 = *n - 1;
	    *kub = max(i__1,0);

	} else if (*imat == 2) {

/*           A: upper triangular, B: upper triangular */

	    *kla = 0;
/* Computing MAX */
	    i__1 = *n - 1;
	    *kua = max(i__1,0);
	    *klb = 0;
/* Computing MAX */
	    i__1 = *n - 1;
	    *kub = max(i__1,0);

	} else if (*imat == 3) {

/*           A: lower triangular, B: upper triangular */

/* Computing MAX */
	    i__1 = *m - 1;
	    *kla = max(i__1,0);
	    *kua = 0;
	    *klb = 0;
/* Computing MAX */
	    i__1 = *n - 1;
	    *kub = max(i__1,0);

	} else {

/*           A: general dense, B: general dense */

/* Computing MAX */
	    i__1 = *m - 1;
	    *kla = max(i__1,0);
/* Computing MAX */
	    i__1 = *n - 1;
	    *kua = max(i__1,0);
/* Computing MAX */
	    i__1 = *p - 1;
	    *klb = max(i__1,0);
/* Computing MAX */
	    i__1 = *n - 1;
	    *kub = max(i__1,0);

	}

    } else if (lsamen_(&c__3, path, "GQR") || lsamen_(&
	    c__3, path, "GLM")) {

/*        A: N by M, B: N by P */

	if (*imat == 1) {

/*           A: diagonal, B: lower triangular */

	    *kla = 0;
	    *kua = 0;
/* Computing MAX */
	    i__1 = *n - 1;
	    *klb = max(i__1,0);
	    *kub = 0;
	} else if (*imat == 2) {

/*           A: lower triangular, B: diagonal */

/* Computing MAX */
	    i__1 = *n - 1;
	    *kla = max(i__1,0);
	    *kua = 0;
	    *klb = 0;
	    *kub = 0;

	} else if (*imat == 3) {

/*           A: lower triangular, B: upper triangular */

/* Computing MAX */
	    i__1 = *n - 1;
	    *kla = max(i__1,0);
	    *kua = 0;
	    *klb = 0;
/* Computing MAX */
	    i__1 = *p - 1;
	    *kub = max(i__1,0);

	} else {

/*           A: general dense, B: general dense */

/* Computing MAX */
	    i__1 = *n - 1;
	    *kla = max(i__1,0);
/* Computing MAX */
	    i__1 = *m - 1;
	    *kua = max(i__1,0);
/* Computing MAX */
	    i__1 = *n - 1;
	    *klb = max(i__1,0);
/* Computing MAX */
	    i__1 = *p - 1;
	    *kub = max(i__1,0);
	}

    }

/*     Set the condition number and norm. */

    *cndnma = 100.;
    *cndnmb = 10.;
    if (lsamen_(&c__3, path, "GQR") || lsamen_(&c__3, 
	    path, "GRQ") || lsamen_(&c__3, path, "GSV")) {
	if (*imat == 5) {
	    *cndnma = badc1;
	    *cndnmb = badc1;
	} else if (*imat == 6) {
	    *cndnma = badc2;
	    *cndnmb = badc2;
	} else if (*imat == 7) {
	    *cndnma = badc1;
	    *cndnmb = badc2;
	} else if (*imat == 8) {
	    *cndnma = badc2;
	    *cndnmb = badc1;
	}
    }

    *anorm = 10.;
    *bnorm = 1e3;
    if (lsamen_(&c__3, path, "GQR") || lsamen_(&c__3, 
	    path, "GRQ")) {
	if (*imat == 7) {
	    *anorm = small;
	    *bnorm = large;
	} else if (*imat == 8) {
	    *anorm = large;
	    *bnorm = small;
	}
    }

    if (*n <= 1) {
	*cndnma = 1.;
	*cndnmb = 1.;
    }

    return 0;

/*     End of DLATB9 */

} /* dlatb9_ */
示例#28
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_ */
示例#29
0
/* Subroutine */ int dgesc2_(integer *n, doublereal *a, integer *lda, 
	doublereal *rhs, integer *ipiv, integer *jpiv, doublereal *scale)
{
    /* System generated locals */
    integer a_dim1, a_offset, i__1, i__2;
    doublereal d__1, d__2;

    /* Local variables */
    integer i__, j;
    doublereal eps, temp;
    extern /* Subroutine */ int dscal_(integer *, doublereal *, doublereal *, 
	    integer *), dlabad_(doublereal *, doublereal *);
    extern doublereal dlamch_(char *);
    extern integer idamax_(integer *, doublereal *, integer *);
    doublereal bignum;
    extern /* Subroutine */ int dlaswp_(integer *, doublereal *, integer *, 
	    integer *, integer *, integer *, integer *);
    doublereal smlnum;


/*  -- LAPACK auxiliary routine (version 3.1) -- */
/*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/*     November 2006 */

/*     .. Scalar Arguments .. */
/*     .. */
/*     .. Array Arguments .. */
/*     .. */

/*  Purpose */
/*  ======= */

/*  DGESC2 solves a system of linear equations */

/*            A * X = scale* RHS */

/*  with a general N-by-N matrix A using the LU factorization with */
/*  complete pivoting computed by DGETC2. */

/*  Arguments */
/*  ========= */

/*  N       (input) INTEGER */
/*          The order of the matrix A. */

/*  A       (input) DOUBLE PRECISION array, dimension (LDA,N) */
/*          On entry, the  LU part of the factorization of the n-by-n */
/*          matrix A computed by DGETC2:  A = P * L * U * Q */

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

/*  RHS     (input/output) DOUBLE PRECISION array, dimension (N). */
/*          On entry, the right hand side vector b. */
/*          On exit, the solution vector X. */

/*  IPIV    (input) INTEGER array, dimension (N). */
/*          The pivot indices; for 1 <= i <= N, row i of the */
/*          matrix has been interchanged with row IPIV(i). */

/*  JPIV    (input) INTEGER array, dimension (N). */
/*          The pivot indices; for 1 <= j <= N, column j of the */
/*          matrix has been interchanged with column JPIV(j). */

/*  SCALE    (output) DOUBLE PRECISION */
/*           On exit, SCALE contains the scale factor. SCALE is chosen */
/*           0 <= SCALE <= 1 to prevent owerflow in the solution. */

/*  Further Details */
/*  =============== */

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

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

/*     .. Parameters .. */
/*     .. */
/*     .. Local Scalars .. */
/*     .. */
/*     .. External Subroutines .. */
/*     .. */
/*     .. External Functions .. */
/*     .. */
/*     .. Intrinsic Functions .. */
/*     .. */
/*     .. Executable Statements .. */

/*      Set constant to control owerflow */

    /* Parameter adjustments */
    a_dim1 = *lda;
    a_offset = 1 + a_dim1;
    a -= a_offset;
    --rhs;
    --ipiv;
    --jpiv;

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

/*     Apply permutations IPIV to RHS */

    i__1 = *n - 1;
    dlaswp_(&c__1, &rhs[1], lda, &c__1, &i__1, &ipiv[1], &c__1);

/*     Solve for L part */

    i__1 = *n - 1;
    for (i__ = 1; i__ <= i__1; ++i__) {
	i__2 = *n;
	for (j = i__ + 1; j <= i__2; ++j) {
	    rhs[j] -= a[j + i__ * a_dim1] * rhs[i__];
/* L10: */
	}
/* L20: */
    }

/*     Solve for U part */

    *scale = 1.;

/*     Check for scaling */

    i__ = idamax_(n, &rhs[1], &c__1);
    if (smlnum * 2. * (d__1 = rhs[i__], abs(d__1)) > (d__2 = a[*n + *n * 
	    a_dim1], abs(d__2))) {
	temp = .5 / (d__1 = rhs[i__], abs(d__1));
	dscal_(n, &temp, &rhs[1], &c__1);
	*scale *= temp;
    }

    for (i__ = *n; i__ >= 1; --i__) {
	temp = 1. / a[i__ + i__ * a_dim1];
	rhs[i__] *= temp;
	i__1 = *n;
	for (j = i__ + 1; j <= i__1; ++j) {
	    rhs[i__] -= rhs[j] * (a[i__ + j * a_dim1] * temp);
/* L30: */
	}
/* L40: */
    }

/*     Apply permutations JPIV to the solution (RHS) */

    i__1 = *n - 1;
    dlaswp_(&c__1, &rhs[1], lda, &c__1, &i__1, &jpiv[1], &c_n1);
    return 0;

/*     End of DGESC2 */

} /* dgesc2_ */
示例#30
0
/* Subroutine */ int dget32_(doublereal *rmax, integer *lmax, integer *ninfo, 
	integer *knt)
{
    /* Initialized data */

    static integer itval[32]	/* was [2][2][8] */ = { 8,4,2,1,4,8,1,2,2,1,8,
	    4,1,2,4,8,9,4,2,1,4,9,1,2,2,1,9,4,1,2,4,9 };

    /* System generated locals */
    doublereal d__1, d__2;

    /* Local variables */
    doublereal b[4]	/* was [2][2] */, x[4]	/* was [2][2] */;
    integer n1, n2, ib;
    doublereal tl[4]	/* was [2][2] */, tr[4]	/* was [2][2] */;
    integer ib1, ib2, ib3;
    doublereal den, val[3], eps;
    integer itl;
    doublereal res, sgn;
    integer itr;
    doublereal tmp;
    integer info, isgn;
    doublereal tnrm, xnrm, scale, xnorm;
    extern /* Subroutine */ int dlasy2_(logical *, logical *, integer *, 
	    integer *, integer *, doublereal *, integer *, doublereal *, 
	    integer *, doublereal *, integer *, doublereal *, doublereal *, 
	    integer *, doublereal *, integer *), dlabad_(doublereal *, 
	    doublereal *);
    extern doublereal dlamch_(char *);
    doublereal bignum;
    integer itranl, itlscl;
    logical ltranl;
    integer itranr, itrscl;
    logical ltranr;
    doublereal smlnum;


/*  -- LAPACK test routine (version 3.1) -- */
/*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/*     November 2006 */

/*     .. Scalar Arguments .. */
/*     .. */

/*  Purpose */
/*  ======= */

/*  DGET32 tests DLASY2, a routine for solving */

/*          op(TL)*X + ISGN*X*op(TR) = SCALE*B */

/*  where TL is N1 by N1, TR is N2 by N2, and N1,N2 =1 or 2 only. */
/*  X and B are N1 by N2, op() is an optional transpose, an */
/*  ISGN = 1 or -1. SCALE is chosen less than or equal to 1 to */
/*  avoid overflow in X. */

/*  The test condition is that the scaled residual */

/*  norm( op(TL)*X + ISGN*X*op(TR) = SCALE*B ) */
/*       / ( max( ulp*norm(TL), ulp*norm(TR)) * norm(X), SMLNUM ) */

/*  should be on the order of 1. Here, ulp is the machine precision. */
/*  Also, it is verified that SCALE is less than or equal to 1, and */
/*  that XNORM = infinity-norm(X). */

/*  Arguments */
/*  ========== */

/*  RMAX    (output) DOUBLE PRECISION */
/*          Value of the largest test ratio. */

/*  LMAX    (output) INTEGER */
/*          Example number where largest test ratio achieved. */

/*  NINFO   (output) INTEGER */
/*          Number of examples returned with INFO.NE.0. */

/*  KNT     (output) INTEGER */
/*          Total number of examples tested. */

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

/*     .. Parameters .. */
/*     .. */
/*     .. Local Scalars .. */
/*     .. */
/*     .. Local Arrays .. */
/*     .. */
/*     .. External Functions .. */
/*     .. */
/*     .. External Subroutines .. */
/*     .. */
/*     .. Intrinsic Functions .. */
/*     .. */
/*     .. Data statements .. */
/*     .. */
/*     .. Executable Statements .. */

/*     Get machine parameters */

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

/*     Set up test case parameters */

    val[0] = sqrt(smlnum);
    val[1] = 1.;
    val[2] = sqrt(bignum);

    *knt = 0;
    *ninfo = 0;
    *lmax = 0;
    *rmax = 0.;

/*     Begin test loop */

    for (itranl = 0; itranl <= 1; ++itranl) {
	for (itranr = 0; itranr <= 1; ++itranr) {
	    for (isgn = -1; isgn <= 1; isgn += 2) {
		sgn = (doublereal) isgn;
		ltranl = itranl == 1;
		ltranr = itranr == 1;

		n1 = 1;
		n2 = 1;
		for (itl = 1; itl <= 3; ++itl) {
		    for (itr = 1; itr <= 3; ++itr) {
			for (ib = 1; ib <= 3; ++ib) {
			    tl[0] = val[itl - 1];
			    tr[0] = val[itr - 1];
			    b[0] = val[ib - 1];
			    ++(*knt);
			    dlasy2_(&ltranl, &ltranr, &isgn, &n1, &n2, tl, &
				    c__2, tr, &c__2, b, &c__2, &scale, x, &
				    c__2, &xnorm, &info);
			    if (info != 0) {
				++(*ninfo);
			    }
			    res = (d__1 = (tl[0] + sgn * tr[0]) * x[0] - 
				    scale * b[0], abs(d__1));
			    if (info == 0) {
/* Computing MAX */
				d__1 = eps * ((abs(tr[0]) + abs(tl[0])) * abs(
					x[0]));
				den = max(d__1,smlnum);
			    } else {
/* Computing MAX */
				d__1 = abs(x[0]);
				den = smlnum * max(d__1,1.);
			    }
			    res /= den;
			    if (scale > 1.) {
				res += 1. / eps;
			    }
			    res += (d__1 = xnorm - abs(x[0]), abs(d__1)) / 
				    max(smlnum,xnorm) / eps;
			    if (info != 0 && info != 1) {
				res += 1. / eps;
			    }
			    if (res > *rmax) {
				*lmax = *knt;
				*rmax = res;
			    }
/* L10: */
			}
/* L20: */
		    }
/* L30: */
		}

		n1 = 2;
		n2 = 1;
		for (itl = 1; itl <= 8; ++itl) {
		    for (itlscl = 1; itlscl <= 3; ++itlscl) {
			for (itr = 1; itr <= 3; ++itr) {
			    for (ib1 = 1; ib1 <= 3; ++ib1) {
				for (ib2 = 1; ib2 <= 3; ++ib2) {
				    b[0] = val[ib1 - 1];
				    b[1] = val[ib2 - 1] * -4.;
				    tl[0] = itval[((itl << 1) + 1 << 1) - 6] *
					     val[itlscl - 1];
				    tl[1] = itval[((itl << 1) + 1 << 1) - 5] *
					     val[itlscl - 1];
				    tl[2] = itval[((itl << 1) + 2 << 1) - 6] *
					     val[itlscl - 1];
				    tl[3] = itval[((itl << 1) + 2 << 1) - 5] *
					     val[itlscl - 1];
				    tr[0] = val[itr - 1];
				    ++(*knt);
				    dlasy2_(&ltranl, &ltranr, &isgn, &n1, &n2, 
					     tl, &c__2, tr, &c__2, b, &c__2, &
					    scale, x, &c__2, &xnorm, &info);
				    if (info != 0) {
					++(*ninfo);
				    }
				    if (ltranl) {
					tmp = tl[2];
					tl[2] = tl[1];
					tl[1] = tmp;
				    }
				    res = (d__1 = (tl[0] + sgn * tr[0]) * x[0]
					     + tl[2] * x[1] - scale * b[0], 
					    abs(d__1));
				    res += (d__1 = (tl[3] + sgn * tr[0]) * x[
					    1] + tl[1] * x[0] - scale * b[1], 
					    abs(d__1));
				    tnrm = abs(tr[0]) + abs(tl[0]) + abs(tl[2]
					    ) + abs(tl[1]) + abs(tl[3]);
/* Computing MAX */
				    d__1 = abs(x[0]), d__2 = abs(x[1]);
				    xnrm = max(d__1,d__2);
/* Computing MAX */
				    d__1 = smlnum, d__2 = smlnum * xnrm, d__1 
					    = max(d__1,d__2), d__2 = tnrm * 
					    eps * xnrm;
				    den = max(d__1,d__2);
				    res /= den;
				    if (scale > 1.) {
					res += 1. / eps;
				    }
				    res += (d__1 = xnorm - xnrm, abs(d__1)) / 
					    max(smlnum,xnorm) / eps;
				    if (res > *rmax) {
					*lmax = *knt;
					*rmax = res;
				    }
/* L40: */
				}
/* L50: */
			    }
/* L60: */
			}
/* L70: */
		    }
/* L80: */
		}

		n1 = 1;
		n2 = 2;
		for (itr = 1; itr <= 8; ++itr) {
		    for (itrscl = 1; itrscl <= 3; ++itrscl) {
			for (itl = 1; itl <= 3; ++itl) {
			    for (ib1 = 1; ib1 <= 3; ++ib1) {
				for (ib2 = 1; ib2 <= 3; ++ib2) {
				    b[0] = val[ib1 - 1];
				    b[2] = val[ib2 - 1] * -2.;
				    tr[0] = itval[((itr << 1) + 1 << 1) - 6] *
					     val[itrscl - 1];
				    tr[1] = itval[((itr << 1) + 1 << 1) - 5] *
					     val[itrscl - 1];
				    tr[2] = itval[((itr << 1) + 2 << 1) - 6] *
					     val[itrscl - 1];
				    tr[3] = itval[((itr << 1) + 2 << 1) - 5] *
					     val[itrscl - 1];
				    tl[0] = val[itl - 1];
				    ++(*knt);
				    dlasy2_(&ltranl, &ltranr, &isgn, &n1, &n2, 
					     tl, &c__2, tr, &c__2, b, &c__2, &
					    scale, x, &c__2, &xnorm, &info);
				    if (info != 0) {
					++(*ninfo);
				    }
				    if (ltranr) {
					tmp = tr[2];
					tr[2] = tr[1];
					tr[1] = tmp;
				    }
				    tnrm = abs(tl[0]) + abs(tr[0]) + abs(tr[2]
					    ) + abs(tr[3]) + abs(tr[1]);
				    xnrm = abs(x[0]) + abs(x[2]);
				    res = (d__1 = (tl[0] + sgn * tr[0]) * x[0]
					     + sgn * tr[1] * x[2] - scale * b[
					    0], abs(d__1));
				    res += (d__1 = (tl[0] + sgn * tr[3]) * x[
					    2] + sgn * tr[2] * x[0] - scale * 
					    b[2], abs(d__1));
/* Computing MAX */
				    d__1 = smlnum, d__2 = smlnum * xnrm, d__1 
					    = max(d__1,d__2), d__2 = tnrm * 
					    eps * xnrm;
				    den = max(d__1,d__2);
				    res /= den;
				    if (scale > 1.) {
					res += 1. / eps;
				    }
				    res += (d__1 = xnorm - xnrm, abs(d__1)) / 
					    max(smlnum,xnorm) / eps;
				    if (res > *rmax) {
					*lmax = *knt;
					*rmax = res;
				    }
/* L90: */
				}
/* L100: */
			    }
/* L110: */
			}
/* L120: */
		    }
/* L130: */
		}

		n1 = 2;
		n2 = 2;
		for (itr = 1; itr <= 8; ++itr) {
		    for (itrscl = 1; itrscl <= 3; ++itrscl) {
			for (itl = 1; itl <= 8; ++itl) {
			    for (itlscl = 1; itlscl <= 3; ++itlscl) {
				for (ib1 = 1; ib1 <= 3; ++ib1) {
				    for (ib2 = 1; ib2 <= 3; ++ib2) {
					for (ib3 = 1; ib3 <= 3; ++ib3) {
					    b[0] = val[ib1 - 1];
					    b[1] = val[ib2 - 1] * -4.;
					    b[2] = val[ib3 - 1] * -2.;
/* Computing MIN */
					    d__1 = val[ib1 - 1], d__2 = val[
						    ib2 - 1], d__1 = min(d__1,
						    d__2), d__2 = val[ib3 - 1]
						    ;
					    b[3] = min(d__1,d__2) * 8.;
					    tr[0] = itval[((itr << 1) + 1 << 
						    1) - 6] * val[itrscl - 1];
					    tr[1] = itval[((itr << 1) + 1 << 
						    1) - 5] * val[itrscl - 1];
					    tr[2] = itval[((itr << 1) + 2 << 
						    1) - 6] * val[itrscl - 1];
					    tr[3] = itval[((itr << 1) + 2 << 
						    1) - 5] * val[itrscl - 1];
					    tl[0] = itval[((itl << 1) + 1 << 
						    1) - 6] * val[itlscl - 1];
					    tl[1] = itval[((itl << 1) + 1 << 
						    1) - 5] * val[itlscl - 1];
					    tl[2] = itval[((itl << 1) + 2 << 
						    1) - 6] * val[itlscl - 1];
					    tl[3] = itval[((itl << 1) + 2 << 
						    1) - 5] * val[itlscl - 1];
					    ++(*knt);
					    dlasy2_(&ltranl, &ltranr, &isgn, &
						    n1, &n2, tl, &c__2, tr, &
						    c__2, b, &c__2, &scale, x, 
						     &c__2, &xnorm, &info);
					    if (info != 0) {
			  ++(*ninfo);
					    }
					    if (ltranr) {
			  tmp = tr[2];
			  tr[2] = tr[1];
			  tr[1] = tmp;
					    }
					    if (ltranl) {
			  tmp = tl[2];
			  tl[2] = tl[1];
			  tl[1] = tmp;
					    }
					    tnrm = abs(tr[0]) + abs(tr[1]) + 
						    abs(tr[2]) + abs(tr[3]) + 
						    abs(tl[0]) + abs(tl[1]) + 
						    abs(tl[2]) + abs(tl[3]);
/* Computing MAX */
					    d__1 = abs(x[0]) + abs(x[2]), 
						    d__2 = abs(x[1]) + abs(x[
						    3]);
					    xnrm = max(d__1,d__2);
					    res = (d__1 = (tl[0] + sgn * tr[0]
						    ) * x[0] + sgn * tr[1] * 
						    x[2] + tl[2] * x[1] - 
						    scale * b[0], abs(d__1));
					    res += (d__1 = tl[0] * x[2] + sgn 
						    * tr[2] * x[0] + sgn * tr[
						    3] * x[2] + tl[2] * x[3] 
						    - scale * b[2], abs(d__1))
						    ;
					    res += (d__1 = tl[1] * x[0] + sgn 
						    * tr[0] * x[1] + sgn * tr[
						    1] * x[3] + tl[3] * x[1] 
						    - scale * b[1], abs(d__1))
						    ;
					    res += (d__1 = (tl[3] + sgn * tr[
						    3]) * x[3] + sgn * tr[2] *
						     x[1] + tl[1] * x[2] - 
						    scale * b[3], abs(d__1));
/* Computing MAX */
					    d__1 = smlnum, d__2 = smlnum * 
						    xnrm, d__1 = max(d__1,
						    d__2), d__2 = tnrm * eps *
						     xnrm;
					    den = max(d__1,d__2);
					    res /= den;
					    if (scale > 1.) {
			  res += 1. / eps;
					    }
					    res += (d__1 = xnorm - xnrm, abs(
						    d__1)) / max(smlnum,xnorm)
						     / eps;
					    if (res > *rmax) {
			  *lmax = *knt;
			  *rmax = res;
					    }
/* L140: */
					}
/* L150: */
				    }
/* L160: */
				}
/* L170: */
			    }
/* L180: */
			}
/* L190: */
		    }
/* L200: */
		}
/* L210: */
	    }
/* L220: */
	}
/* L230: */
    }

    return 0;

/*     End of DGET32 */

} /* dget32_ */