/* sget23.f -- translated by f2c (version 20061008). You must link the resulting object file with libf2c: on Microsoft Windows system, link with libf2c.lib; on Linux or Unix systems, link with .../path/to/libf2c.a -lm or, if you install libf2c.a in a standard place, with -lf2c -lm -- in that order, at the end of the command line, as in cc *.o -lf2c -lm Source for libf2c is in /netlib/f2c/libf2c.zip, e.g., http://www.netlib.org/f2c/libf2c.zip */ #include "f2c.h" #include "blaswrap.h" /* Table of constant values */ static integer c__1 = 1; static integer c__4 = 4; /* Subroutine */ int sget23_(logical *comp, char *balanc, integer *jtype, real *thresh, integer *iseed, integer *nounit, integer *n, real *a, integer *lda, real *h__, real *wr, real *wi, real *wr1, real *wi1, real *vl, integer *ldvl, real *vr, integer *ldvr, real *lre, integer * ldlre, real *rcondv, real *rcndv1, real *rcdvin, real *rconde, real * rcnde1, real *rcdein, real *scale, real *scale1, real *result, real * work, integer *lwork, integer *iwork, integer *info) { /* Initialized data */ static char sens[1*2] = "N" "V"; /* Format strings */ static char fmt_9998[] = "(\002 SGET23: \002,a,\002 returned INFO=\002,i" "6,\002.\002,/9x,\002N=\002,i6,\002, JTYPE=\002,i6,\002, BALANC = " "\002,a,\002, ISEED=(\002,3(i5,\002,\002),i5,\002)\002)"; static char fmt_9999[] = "(\002 SGET23: \002,a,\002 returned INFO=\002,i" "6,\002.\002,/9x,\002N=\002,i6,\002, INPUT EXAMPLE NUMBER = \002," "i4)"; /* System generated locals */ integer a_dim1, a_offset, h_dim1, h_offset, lre_dim1, lre_offset, vl_dim1, vl_offset, vr_dim1, vr_offset, i__1, i__2, i__3; real r__1, r__2, r__3, r__4, r__5; /* Builtin functions */ integer s_wsfe(cilist *), do_fio(integer *, char *, ftnlen), e_wsfe(void); /* Local variables */ integer i__, j; real v; integer jj, ihi, ilo; real dum[1], eps, res[2], tol, ulp, vmx; integer ihi1, ilo1, kmin; real vmax, tnrm, vrmx, vtst; extern doublereal snrm2_(integer *, real *, integer *); logical balok, nobal; real abnrm; extern logical lsame_(char *, char *); integer iinfo; extern /* Subroutine */ int sget22_(char *, char *, char *, integer *, real *, integer *, real *, integer *, real *, real *, real *, real *); char sense[1]; integer isens; real vimin, tolin, vrmin, abnrm1; extern doublereal slapy2_(real *, real *), slamch_(char *); extern /* Subroutine */ int xerbla_(char *, integer *), slacpy_( char *, integer *, integer *, real *, integer *, real *, integer * ); integer isensm; extern /* Subroutine */ int sgeevx_(char *, char *, char *, char *, integer *, real *, integer *, real *, real *, real *, integer *, real *, integer *, integer *, integer *, real *, real *, real *, real *, real *, integer *, integer *, integer *); real smlnum, ulpinv; /* Fortran I/O blocks */ static cilist io___14 = { 0, 0, 0, fmt_9998, 0 }; static cilist io___15 = { 0, 0, 0, fmt_9999, 0 }; static cilist io___28 = { 0, 0, 0, fmt_9998, 0 }; static cilist io___29 = { 0, 0, 0, fmt_9999, 0 }; static cilist io___30 = { 0, 0, 0, fmt_9998, 0 }; static cilist io___31 = { 0, 0, 0, fmt_9999, 0 }; static cilist io___32 = { 0, 0, 0, fmt_9998, 0 }; static cilist io___33 = { 0, 0, 0, fmt_9999, 0 }; static cilist io___34 = { 0, 0, 0, fmt_9999, 0 }; /* -- LAPACK test routine (version 3.1) -- */ /* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ /* November 2006 */ /* .. Scalar Arguments .. */ /* .. */ /* .. Array Arguments .. */ /* .. */ /* Purpose */ /* ======= */ /* SGET23 checks the nonsymmetric eigenvalue problem driver SGEEVX. */ /* If COMP = .FALSE., the first 8 of the following tests will be */ /* performed on the input matrix A, and also test 9 if LWORK is */ /* sufficiently large. */ /* if COMP is .TRUE. all 11 tests will be performed. */ /* (1) | A * VR - VR * W | / ( n |A| ulp ) */ /* Here VR is the matrix of unit right eigenvectors. */ /* W is a block diagonal matrix, with a 1x1 block for each */ /* real eigenvalue and a 2x2 block for each complex conjugate */ /* pair. If eigenvalues j and j+1 are a complex conjugate pair, */ /* so WR(j) = WR(j+1) = wr and WI(j) = - WI(j+1) = wi, then the */ /* 2 x 2 block corresponding to the pair will be: */ /* ( wr wi ) */ /* ( -wi wr ) */ /* Such a block multiplying an n x 2 matrix ( ur ui ) on the */ /* right will be the same as multiplying ur + i*ui by wr + i*wi. */ /* (2) | A**H * VL - VL * W**H | / ( n |A| ulp ) */ /* Here VL is the matrix of unit left eigenvectors, A**H is the */ /* conjugate transpose of A, and W is as above. */ /* (3) | |VR(i)| - 1 | / ulp and largest component real */ /* VR(i) denotes the i-th column of VR. */ /* (4) | |VL(i)| - 1 | / ulp and largest component real */ /* VL(i) denotes the i-th column of VL. */ /* (5) 0 if W(full) = W(partial), 1/ulp otherwise */ /* W(full) denotes the eigenvalues computed when VR, VL, RCONDV */ /* and RCONDE are also computed, and W(partial) denotes the */ /* eigenvalues computed when only some of VR, VL, RCONDV, and */ /* RCONDE are computed. */ /* (6) 0 if VR(full) = VR(partial), 1/ulp otherwise */ /* VR(full) denotes the right eigenvectors computed when VL, RCONDV */ /* and RCONDE are computed, and VR(partial) denotes the result */ /* when only some of VL and RCONDV are computed. */ /* (7) 0 if VL(full) = VL(partial), 1/ulp otherwise */ /* VL(full) denotes the left eigenvectors computed when VR, RCONDV */ /* and RCONDE are computed, and VL(partial) denotes the result */ /* when only some of VR and RCONDV are computed. */ /* (8) 0 if SCALE, ILO, IHI, ABNRM (full) = */ /* SCALE, ILO, IHI, ABNRM (partial) */ /* 1/ulp otherwise */ /* SCALE, ILO, IHI and ABNRM describe how the matrix is balanced. */ /* (full) is when VR, VL, RCONDE and RCONDV are also computed, and */ /* (partial) is when some are not computed. */ /* (9) 0 if RCONDV(full) = RCONDV(partial), 1/ulp otherwise */ /* RCONDV(full) denotes the reciprocal condition numbers of the */ /* right eigenvectors computed when VR, VL and RCONDE are also */ /* computed. RCONDV(partial) denotes the reciprocal condition */ /* numbers when only some of VR, VL and RCONDE are computed. */ /* (10) |RCONDV - RCDVIN| / cond(RCONDV) */ /* RCONDV is the reciprocal right eigenvector condition number */ /* computed by SGEEVX and RCDVIN (the precomputed true value) */ /* is supplied as input. cond(RCONDV) is the condition number of */ /* RCONDV, and takes errors in computing RCONDV into account, so */ /* that the resulting quantity should be O(ULP). cond(RCONDV) is */ /* essentially given by norm(A)/RCONDE. */ /* (11) |RCONDE - RCDEIN| / cond(RCONDE) */ /* RCONDE is the reciprocal eigenvalue condition number */ /* computed by SGEEVX and RCDEIN (the precomputed true value) */ /* is supplied as input. cond(RCONDE) is the condition number */ /* of RCONDE, and takes errors in computing RCONDE into account, */ /* so that the resulting quantity should be O(ULP). cond(RCONDE) */ /* is essentially given by norm(A)/RCONDV. */ /* Arguments */ /* ========= */ /* COMP (input) LOGICAL */ /* COMP describes which input tests to perform: */ /* = .FALSE. if the computed condition numbers are not to */ /* be tested against RCDVIN and RCDEIN */ /* = .TRUE. if they are to be compared */ /* BALANC (input) CHARACTER */ /* Describes the balancing option to be tested. */ /* = 'N' for no permuting or diagonal scaling */ /* = 'P' for permuting but no diagonal scaling */ /* = 'S' for no permuting but diagonal scaling */ /* = 'B' for permuting and diagonal scaling */ /* JTYPE (input) INTEGER */ /* Type of input matrix. Used to label output if error occurs. */ /* THRESH (input) REAL */ /* A test will count as "failed" if the "error", computed as */ /* described above, exceeds THRESH. Note that the error */ /* is scaled to be O(1), so THRESH should be a reasonably */ /* small multiple of 1, e.g., 10 or 100. In particular, */ /* it should not depend on the precision (single vs. double) */ /* or the size of the matrix. It must be at least zero. */ /* ISEED (input) INTEGER array, dimension (4) */ /* If COMP = .FALSE., the random number generator seed */ /* used to produce matrix. */ /* If COMP = .TRUE., ISEED(1) = the number of the example. */ /* Used to label output if error occurs. */ /* NOUNIT (input) INTEGER */ /* The FORTRAN unit number for printing out error messages */ /* (e.g., if a routine returns INFO not equal to 0.) */ /* N (input) INTEGER */ /* The dimension of A. N must be at least 0. */ /* A (input/output) REAL array, dimension (LDA,N) */ /* Used to hold the matrix whose eigenvalues are to be */ /* computed. */ /* LDA (input) INTEGER */ /* The leading dimension of A, and H. LDA must be at */ /* least 1 and at least N. */ /* H (workspace) REAL array, dimension (LDA,N) */ /* Another copy of the test matrix A, modified by SGEEVX. */ /* WR (workspace) REAL array, dimension (N) */ /* WI (workspace) REAL array, dimension (N) */ /* The real and imaginary parts of the eigenvalues of A. */ /* On exit, WR + WI*i are the eigenvalues of the matrix in A. */ /* WR1 (workspace) REAL array, dimension (N) */ /* WI1 (workspace) REAL array, dimension (N) */ /* Like WR, WI, these arrays contain the eigenvalues of A, */ /* but those computed when SGEEVX only computes a partial */ /* eigendecomposition, i.e. not the eigenvalues and left */ /* and right eigenvectors. */ /* VL (workspace) REAL array, dimension (LDVL,N) */ /* VL holds the computed left eigenvectors. */ /* LDVL (input) INTEGER */ /* Leading dimension of VL. Must be at least max(1,N). */ /* VR (workspace) REAL array, dimension (LDVR,N) */ /* VR holds the computed right eigenvectors. */ /* LDVR (input) INTEGER */ /* Leading dimension of VR. Must be at least max(1,N). */ /* LRE (workspace) REAL array, dimension (LDLRE,N) */ /* LRE holds the computed right or left eigenvectors. */ /* LDLRE (input) INTEGER */ /* Leading dimension of LRE. Must be at least max(1,N). */ /* RCONDV (workspace) REAL array, dimension (N) */ /* RCONDV holds the computed reciprocal condition numbers */ /* for eigenvectors. */ /* RCNDV1 (workspace) REAL array, dimension (N) */ /* RCNDV1 holds more computed reciprocal condition numbers */ /* for eigenvectors. */ /* RCDVIN (input) REAL array, dimension (N) */ /* When COMP = .TRUE. RCDVIN holds the precomputed reciprocal */ /* condition numbers for eigenvectors to be compared with */ /* RCONDV. */ /* RCONDE (workspace) REAL array, dimension (N) */ /* RCONDE holds the computed reciprocal condition numbers */ /* for eigenvalues. */ /* RCNDE1 (workspace) REAL array, dimension (N) */ /* RCNDE1 holds more computed reciprocal condition numbers */ /* for eigenvalues. */ /* RCDEIN (input) REAL array, dimension (N) */ /* When COMP = .TRUE. RCDEIN holds the precomputed reciprocal */ /* condition numbers for eigenvalues to be compared with */ /* RCONDE. */ /* SCALE (workspace) REAL array, dimension (N) */ /* Holds information describing balancing of matrix. */ /* SCALE1 (workspace) REAL array, dimension (N) */ /* Holds information describing balancing of matrix. */ /* RESULT (output) REAL array, dimension (11) */ /* The values computed by the 11 tests described above. */ /* The values are currently limited to 1/ulp, to avoid */ /* overflow. */ /* WORK (workspace) REAL array, dimension (LWORK) */ /* LWORK (input) INTEGER */ /* The number of entries in WORK. This must be at least */ /* 3*N, and 6*N+N**2 if tests 9, 10 or 11 are to be performed. */ /* IWORK (workspace) INTEGER array, dimension (2*N) */ /* INFO (output) INTEGER */ /* If 0, successful exit. */ /* If <0, input parameter -INFO had an incorrect value. */ /* If >0, SGEEVX returned an error code, the absolute */ /* value of which is returned. */ /* ===================================================================== */ /* .. Parameters .. */ /* .. */ /* .. Local Scalars .. */ /* .. */ /* .. Local Arrays .. */ /* .. */ /* .. External Functions .. */ /* .. */ /* .. External Subroutines .. */ /* .. */ /* .. Intrinsic Functions .. */ /* .. */ /* .. Data statements .. */ /* Parameter adjustments */ --iseed; h_dim1 = *lda; h_offset = 1 + h_dim1; h__ -= h_offset; a_dim1 = *lda; a_offset = 1 + a_dim1; a -= a_offset; --wr; --wi; --wr1; --wi1; vl_dim1 = *ldvl; vl_offset = 1 + vl_dim1; vl -= vl_offset; vr_dim1 = *ldvr; vr_offset = 1 + vr_dim1; vr -= vr_offset; lre_dim1 = *ldlre; lre_offset = 1 + lre_dim1; lre -= lre_offset; --rcondv; --rcndv1; --rcdvin; --rconde; --rcnde1; --rcdein; --scale; --scale1; --result; --work; --iwork; /* Function Body */ /* .. */ /* .. Executable Statements .. */ /* Check for errors */ nobal = lsame_(balanc, "N"); balok = nobal || lsame_(balanc, "P") || lsame_( balanc, "S") || lsame_(balanc, "B"); *info = 0; if (! balok) { *info = -2; } else if (*thresh < 0.f) { *info = -4; } else if (*nounit <= 0) { *info = -6; } else if (*n < 0) { *info = -7; } else if (*lda < 1 || *lda < *n) { *info = -9; } else if (*ldvl < 1 || *ldvl < *n) { *info = -16; } else if (*ldvr < 1 || *ldvr < *n) { *info = -18; } else if (*ldlre < 1 || *ldlre < *n) { *info = -20; } else if (*lwork < *n * 3 || *comp && *lwork < *n * 6 + *n * *n) { *info = -31; } if (*info != 0) { i__1 = -(*info); xerbla_("SGET23", &i__1); return 0; } /* Quick return if nothing to do */ for (i__ = 1; i__ <= 11; ++i__) { result[i__] = -1.f; /* L10: */ } if (*n == 0) { return 0; } /* More Important constants */ ulp = slamch_("Precision"); smlnum = slamch_("S"); ulpinv = 1.f / ulp; /* Compute eigenvalues and eigenvectors, and test them */ if (*lwork >= *n * 6 + *n * *n) { *(unsigned char *)sense = 'B'; isensm = 2; } else { *(unsigned char *)sense = 'E'; isensm = 1; } slacpy_("F", n, n, &a[a_offset], lda, &h__[h_offset], lda); sgeevx_(balanc, "V", "V", sense, n, &h__[h_offset], lda, &wr[1], &wi[1], & vl[vl_offset], ldvl, &vr[vr_offset], ldvr, &ilo, &ihi, &scale[1], &abnrm, &rconde[1], &rcondv[1], &work[1], lwork, &iwork[1], & iinfo); if (iinfo != 0) { result[1] = ulpinv; if (*jtype != 22) { io___14.ciunit = *nounit; s_wsfe(&io___14); do_fio(&c__1, "SGEEVX1", (ftnlen)7); do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer)); do_fio(&c__1, (char *)&(*n), (ftnlen)sizeof(integer)); do_fio(&c__1, (char *)&(*jtype), (ftnlen)sizeof(integer)); do_fio(&c__1, balanc, (ftnlen)1); do_fio(&c__4, (char *)&iseed[1], (ftnlen)sizeof(integer)); e_wsfe(); } else { io___15.ciunit = *nounit; s_wsfe(&io___15); do_fio(&c__1, "SGEEVX1", (ftnlen)7); do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer)); do_fio(&c__1, (char *)&(*n), (ftnlen)sizeof(integer)); do_fio(&c__1, (char *)&iseed[1], (ftnlen)sizeof(integer)); e_wsfe(); } *info = abs(iinfo); return 0; } /* Do Test (1) */ sget22_("N", "N", "N", n, &a[a_offset], lda, &vr[vr_offset], ldvr, &wr[1], &wi[1], &work[1], res); result[1] = res[0]; /* Do Test (2) */ sget22_("T", "N", "T", n, &a[a_offset], lda, &vl[vl_offset], ldvl, &wr[1], &wi[1], &work[1], res); result[2] = res[0]; /* Do Test (3) */ i__1 = *n; for (j = 1; j <= i__1; ++j) { tnrm = 1.f; if (wi[j] == 0.f) { tnrm = snrm2_(n, &vr[j * vr_dim1 + 1], &c__1); } else if (wi[j] > 0.f) { r__1 = snrm2_(n, &vr[j * vr_dim1 + 1], &c__1); r__2 = snrm2_(n, &vr[(j + 1) * vr_dim1 + 1], &c__1); tnrm = slapy2_(&r__1, &r__2); } /* Computing MAX */ /* Computing MIN */ r__4 = ulpinv, r__5 = (r__1 = tnrm - 1.f, dabs(r__1)) / ulp; r__2 = result[3], r__3 = dmin(r__4,r__5); result[3] = dmax(r__2,r__3); if (wi[j] > 0.f) { vmx = 0.f; vrmx = 0.f; i__2 = *n; for (jj = 1; jj <= i__2; ++jj) { vtst = slapy2_(&vr[jj + j * vr_dim1], &vr[jj + (j + 1) * vr_dim1]); if (vtst > vmx) { vmx = vtst; } if (vr[jj + (j + 1) * vr_dim1] == 0.f && (r__1 = vr[jj + j * vr_dim1], dabs(r__1)) > vrmx) { vrmx = (r__2 = vr[jj + j * vr_dim1], dabs(r__2)); } /* L20: */ } if (vrmx / vmx < 1.f - ulp * 2.f) { result[3] = ulpinv; } } /* L30: */ } /* Do Test (4) */ i__1 = *n; for (j = 1; j <= i__1; ++j) { tnrm = 1.f; if (wi[j] == 0.f) { tnrm = snrm2_(n, &vl[j * vl_dim1 + 1], &c__1); } else if (wi[j] > 0.f) { r__1 = snrm2_(n, &vl[j * vl_dim1 + 1], &c__1); r__2 = snrm2_(n, &vl[(j + 1) * vl_dim1 + 1], &c__1); tnrm = slapy2_(&r__1, &r__2); } /* Computing MAX */ /* Computing MIN */ r__4 = ulpinv, r__5 = (r__1 = tnrm - 1.f, dabs(r__1)) / ulp; r__2 = result[4], r__3 = dmin(r__4,r__5); result[4] = dmax(r__2,r__3); if (wi[j] > 0.f) { vmx = 0.f; vrmx = 0.f; i__2 = *n; for (jj = 1; jj <= i__2; ++jj) { vtst = slapy2_(&vl[jj + j * vl_dim1], &vl[jj + (j + 1) * vl_dim1]); if (vtst > vmx) { vmx = vtst; } if (vl[jj + (j + 1) * vl_dim1] == 0.f && (r__1 = vl[jj + j * vl_dim1], dabs(r__1)) > vrmx) { vrmx = (r__2 = vl[jj + j * vl_dim1], dabs(r__2)); } /* L40: */ } if (vrmx / vmx < 1.f - ulp * 2.f) { result[4] = ulpinv; } } /* L50: */ } /* Test for all options of computing condition numbers */ i__1 = isensm; for (isens = 1; isens <= i__1; ++isens) { *(unsigned char *)sense = *(unsigned char *)&sens[isens - 1]; /* Compute eigenvalues only, and test them */ slacpy_("F", n, n, &a[a_offset], lda, &h__[h_offset], lda); sgeevx_(balanc, "N", "N", sense, n, &h__[h_offset], lda, &wr1[1], & wi1[1], dum, &c__1, dum, &c__1, &ilo1, &ihi1, &scale1[1], & abnrm1, &rcnde1[1], &rcndv1[1], &work[1], lwork, &iwork[1], & iinfo); if (iinfo != 0) { result[1] = ulpinv; if (*jtype != 22) { io___28.ciunit = *nounit; s_wsfe(&io___28); do_fio(&c__1, "SGEEVX2", (ftnlen)7); do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer)); do_fio(&c__1, (char *)&(*n), (ftnlen)sizeof(integer)); do_fio(&c__1, (char *)&(*jtype), (ftnlen)sizeof(integer)); do_fio(&c__1, balanc, (ftnlen)1); do_fio(&c__4, (char *)&iseed[1], (ftnlen)sizeof(integer)); e_wsfe(); } else { io___29.ciunit = *nounit; s_wsfe(&io___29); do_fio(&c__1, "SGEEVX2", (ftnlen)7); do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer)); do_fio(&c__1, (char *)&(*n), (ftnlen)sizeof(integer)); do_fio(&c__1, (char *)&iseed[1], (ftnlen)sizeof(integer)); e_wsfe(); } *info = abs(iinfo); goto L190; } /* Do Test (5) */ i__2 = *n; for (j = 1; j <= i__2; ++j) { if (wr[j] != wr1[j] || wi[j] != wi1[j]) { result[5] = ulpinv; } /* L60: */ } /* Do Test (8) */ if (! nobal) { i__2 = *n; for (j = 1; j <= i__2; ++j) { if (scale[j] != scale1[j]) { result[8] = ulpinv; } /* L70: */ } if (ilo != ilo1) { result[8] = ulpinv; } if (ihi != ihi1) { result[8] = ulpinv; } if (abnrm != abnrm1) { result[8] = ulpinv; } } /* Do Test (9) */ if (isens == 2 && *n > 1) { i__2 = *n; for (j = 1; j <= i__2; ++j) { if (rcondv[j] != rcndv1[j]) { result[9] = ulpinv; } /* L80: */ } } /* Compute eigenvalues and right eigenvectors, and test them */ slacpy_("F", n, n, &a[a_offset], lda, &h__[h_offset], lda); sgeevx_(balanc, "N", "V", sense, n, &h__[h_offset], lda, &wr1[1], & wi1[1], dum, &c__1, &lre[lre_offset], ldlre, &ilo1, &ihi1, & scale1[1], &abnrm1, &rcnde1[1], &rcndv1[1], &work[1], lwork, & iwork[1], &iinfo); if (iinfo != 0) { result[1] = ulpinv; if (*jtype != 22) { io___30.ciunit = *nounit; s_wsfe(&io___30); do_fio(&c__1, "SGEEVX3", (ftnlen)7); do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer)); do_fio(&c__1, (char *)&(*n), (ftnlen)sizeof(integer)); do_fio(&c__1, (char *)&(*jtype), (ftnlen)sizeof(integer)); do_fio(&c__1, balanc, (ftnlen)1); do_fio(&c__4, (char *)&iseed[1], (ftnlen)sizeof(integer)); e_wsfe(); } else { io___31.ciunit = *nounit; s_wsfe(&io___31); do_fio(&c__1, "SGEEVX3", (ftnlen)7); do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer)); do_fio(&c__1, (char *)&(*n), (ftnlen)sizeof(integer)); do_fio(&c__1, (char *)&iseed[1], (ftnlen)sizeof(integer)); e_wsfe(); } *info = abs(iinfo); goto L190; } /* Do Test (5) again */ i__2 = *n; for (j = 1; j <= i__2; ++j) { if (wr[j] != wr1[j] || wi[j] != wi1[j]) { result[5] = ulpinv; } /* L90: */ } /* Do Test (6) */ i__2 = *n; for (j = 1; j <= i__2; ++j) { i__3 = *n; for (jj = 1; jj <= i__3; ++jj) { if (vr[j + jj * vr_dim1] != lre[j + jj * lre_dim1]) { result[6] = ulpinv; } /* L100: */ } /* L110: */ } /* Do Test (8) again */ if (! nobal) { i__2 = *n; for (j = 1; j <= i__2; ++j) { if (scale[j] != scale1[j]) { result[8] = ulpinv; } /* L120: */ } if (ilo != ilo1) { result[8] = ulpinv; } if (ihi != ihi1) { result[8] = ulpinv; } if (abnrm != abnrm1) { result[8] = ulpinv; } } /* Do Test (9) again */ if (isens == 2 && *n > 1) { i__2 = *n; for (j = 1; j <= i__2; ++j) { if (rcondv[j] != rcndv1[j]) { result[9] = ulpinv; } /* L130: */ } } /* Compute eigenvalues and left eigenvectors, and test them */ slacpy_("F", n, n, &a[a_offset], lda, &h__[h_offset], lda); sgeevx_(balanc, "V", "N", sense, n, &h__[h_offset], lda, &wr1[1], & wi1[1], &lre[lre_offset], ldlre, dum, &c__1, &ilo1, &ihi1, & scale1[1], &abnrm1, &rcnde1[1], &rcndv1[1], &work[1], lwork, & iwork[1], &iinfo); if (iinfo != 0) { result[1] = ulpinv; if (*jtype != 22) { io___32.ciunit = *nounit; s_wsfe(&io___32); do_fio(&c__1, "SGEEVX4", (ftnlen)7); do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer)); do_fio(&c__1, (char *)&(*n), (ftnlen)sizeof(integer)); do_fio(&c__1, (char *)&(*jtype), (ftnlen)sizeof(integer)); do_fio(&c__1, balanc, (ftnlen)1); do_fio(&c__4, (char *)&iseed[1], (ftnlen)sizeof(integer)); e_wsfe(); } else { io___33.ciunit = *nounit; s_wsfe(&io___33); do_fio(&c__1, "SGEEVX4", (ftnlen)7); do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer)); do_fio(&c__1, (char *)&(*n), (ftnlen)sizeof(integer)); do_fio(&c__1, (char *)&iseed[1], (ftnlen)sizeof(integer)); e_wsfe(); } *info = abs(iinfo); goto L190; } /* Do Test (5) again */ i__2 = *n; for (j = 1; j <= i__2; ++j) { if (wr[j] != wr1[j] || wi[j] != wi1[j]) { result[5] = ulpinv; } /* L140: */ } /* Do Test (7) */ i__2 = *n; for (j = 1; j <= i__2; ++j) { i__3 = *n; for (jj = 1; jj <= i__3; ++jj) { if (vl[j + jj * vl_dim1] != lre[j + jj * lre_dim1]) { result[7] = ulpinv; } /* L150: */ } /* L160: */ } /* Do Test (8) again */ if (! nobal) { i__2 = *n; for (j = 1; j <= i__2; ++j) { if (scale[j] != scale1[j]) { result[8] = ulpinv; } /* L170: */ } if (ilo != ilo1) { result[8] = ulpinv; } if (ihi != ihi1) { result[8] = ulpinv; } if (abnrm != abnrm1) { result[8] = ulpinv; } } /* Do Test (9) again */ if (isens == 2 && *n > 1) { i__2 = *n; for (j = 1; j <= i__2; ++j) { if (rcondv[j] != rcndv1[j]) { result[9] = ulpinv; } /* L180: */ } } L190: /* L200: */ ; } /* If COMP, compare condition numbers to precomputed ones */ if (*comp) { slacpy_("F", n, n, &a[a_offset], lda, &h__[h_offset], lda); sgeevx_("N", "V", "V", "B", n, &h__[h_offset], lda, &wr[1], &wi[1], & vl[vl_offset], ldvl, &vr[vr_offset], ldvr, &ilo, &ihi, &scale[ 1], &abnrm, &rconde[1], &rcondv[1], &work[1], lwork, &iwork[1] , &iinfo); if (iinfo != 0) { result[1] = ulpinv; io___34.ciunit = *nounit; s_wsfe(&io___34); do_fio(&c__1, "SGEEVX5", (ftnlen)7); do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer)); do_fio(&c__1, (char *)&(*n), (ftnlen)sizeof(integer)); do_fio(&c__1, (char *)&iseed[1], (ftnlen)sizeof(integer)); e_wsfe(); *info = abs(iinfo); goto L250; } /* Sort eigenvalues and condition numbers lexicographically */ /* to compare with inputs */ i__1 = *n - 1; for (i__ = 1; i__ <= i__1; ++i__) { kmin = i__; vrmin = wr[i__]; vimin = wi[i__]; i__2 = *n; for (j = i__ + 1; j <= i__2; ++j) { if (wr[j] < vrmin) { kmin = j; vrmin = wr[j]; vimin = wi[j]; } /* L210: */ } wr[kmin] = wr[i__]; wi[kmin] = wi[i__]; wr[i__] = vrmin; wi[i__] = vimin; vrmin = rconde[kmin]; rconde[kmin] = rconde[i__]; rconde[i__] = vrmin; vrmin = rcondv[kmin]; rcondv[kmin] = rcondv[i__]; rcondv[i__] = vrmin; /* L220: */ } /* Compare condition numbers for eigenvectors */ /* taking their condition numbers into account */ result[10] = 0.f; eps = dmax(5.9605e-8f,ulp); /* Computing MAX */ r__1 = (real) (*n) * eps * abnrm; v = dmax(r__1,smlnum); if (abnrm == 0.f) { v = 1.f; } i__1 = *n; for (i__ = 1; i__ <= i__1; ++i__) { if (v > rcondv[i__] * rconde[i__]) { tol = rcondv[i__]; } else { tol = v / rconde[i__]; } if (v > rcdvin[i__] * rcdein[i__]) { tolin = rcdvin[i__]; } else { tolin = v / rcdein[i__]; } /* Computing MAX */ r__1 = tol, r__2 = smlnum / eps; tol = dmax(r__1,r__2); /* Computing MAX */ r__1 = tolin, r__2 = smlnum / eps; tolin = dmax(r__1,r__2); if (eps * (rcdvin[i__] - tolin) > rcondv[i__] + tol) { vmax = 1.f / eps; } else if (rcdvin[i__] - tolin > rcondv[i__] + tol) { vmax = (rcdvin[i__] - tolin) / (rcondv[i__] + tol); } else if (rcdvin[i__] + tolin < eps * (rcondv[i__] - tol)) { vmax = 1.f / eps; } else if (rcdvin[i__] + tolin < rcondv[i__] - tol) { vmax = (rcondv[i__] - tol) / (rcdvin[i__] + tolin); } else { vmax = 1.f; } result[10] = dmax(result[10],vmax); /* L230: */ } /* Compare condition numbers for eigenvalues */ /* taking their condition numbers into account */ result[11] = 0.f; i__1 = *n; for (i__ = 1; i__ <= i__1; ++i__) { if (v > rcondv[i__]) { tol = 1.f; } else { tol = v / rcondv[i__]; } if (v > rcdvin[i__]) { tolin = 1.f; } else { tolin = v / rcdvin[i__]; } /* Computing MAX */ r__1 = tol, r__2 = smlnum / eps; tol = dmax(r__1,r__2); /* Computing MAX */ r__1 = tolin, r__2 = smlnum / eps; tolin = dmax(r__1,r__2); if (eps * (rcdein[i__] - tolin) > rconde[i__] + tol) { vmax = 1.f / eps; } else if (rcdein[i__] - tolin > rconde[i__] + tol) { vmax = (rcdein[i__] - tolin) / (rconde[i__] + tol); } else if (rcdein[i__] + tolin < eps * (rconde[i__] - tol)) { vmax = 1.f / eps; } else if (rcdein[i__] + tolin < rconde[i__] - tol) { vmax = (rconde[i__] - tol) / (rcdein[i__] + tolin); } else { vmax = 1.f; } result[11] = dmax(result[11],vmax); /* L240: */ } L250: ; } return 0; /* End of SGET23 */ } /* sget23_ */