/* Subroutine */ int cla_lin_berr__(integer *n, integer *nz, integer *nrhs, 
	complex *res, real *ayb, real *berr)
{
    /* System generated locals */
    integer ayb_dim1, ayb_offset, res_dim1, res_offset, i__1, i__2, i__3, 
	    i__4;
    real r__1, r__2, r__3;
    complex q__1, q__2, q__3;

    /* Local variables */
    integer i__, j;
    real tmp, safe1;

/*     -- LAPACK routine (version 3.2.1)                                 -- */
/*     -- Contributed by James Demmel, Deaglan Halligan, Yozo Hida and -- */
/*     -- Jason Riedy of Univ. of California Berkeley.                 -- */
/*     -- April 2009                                                   -- */

/*     -- LAPACK is a software package provided by Univ. of Tennessee, -- */
/*     -- Univ. of California Berkeley and NAG Ltd.                    -- */

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

/*     CLA_LIN_BERR computes componentwise relative backward error from */
/*     the formula */
/*         max(i) ( abs(R(i)) / ( abs(op(A_s))*abs(Y) + abs(B_s) )(i) ) */
/*     where abs(Z) is the componentwise absolute value of the matrix */
/*     or vector Z. */

/*     N       (input) INTEGER */
/*     The number of linear equations, i.e., the order of the */
/*     matrix A.  N >= 0. */

/*     NZ      (input) INTEGER */
/*     We add (NZ+1)*SLAMCH( 'Safe minimum' ) to R(i) in the numerator to */
/*     guard against spuriously zero residuals. Default value is N. */

/*     NRHS    (input) INTEGER */
/*     The number of right hand sides, i.e., the number of columns */
/*     of the matrices AYB, RES, and BERR.  NRHS >= 0. */

/*     RES    (input) DOUBLE PRECISION array, dimension (N,NRHS) */
/*     The residual matrix, i.e., the matrix R in the relative backward */
/*     error formula above. */

/*     AYB    (input) DOUBLE PRECISION array, dimension (N, NRHS) */
/*     The denominator in the relative backward error formula above, i.e., */
/*     the matrix abs(op(A_s))*abs(Y) + abs(B_s). The matrices A, Y, and B */
/*     are from iterative refinement (see cla_gerfsx_extended.f). */

/*     RES    (output) COMPLEX array, dimension (NRHS) */
/*     The componentwise relative backward error from the formula above. */

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

/*     Adding SAFE1 to the numerator guards against spuriously zero */
/*     residuals.  A similar safeguard is in the CLA_yyAMV routine used */
/*     to compute AYB. */

    /* Parameter adjustments */
    --berr;
    ayb_dim1 = *n;
    ayb_offset = 1 + ayb_dim1;
    ayb -= ayb_offset;
    res_dim1 = *n;
    res_offset = 1 + res_dim1;
    res -= res_offset;

    /* Function Body */
    safe1 = slamch_("Safe minimum");
    safe1 = (*nz + 1) * safe1;
    i__1 = *nrhs;
    for (j = 1; j <= i__1; ++j) {
	berr[j] = 0.f;
	i__2 = *n;
	for (i__ = 1; i__ <= i__2; ++i__) {
	    if (ayb[i__ + j * ayb_dim1] != 0.f) {
		i__3 = i__ + j * res_dim1;
		r__3 = (r__1 = res[i__3].r, dabs(r__1)) + (r__2 = r_imag(&res[
			i__ + j * res_dim1]), dabs(r__2));
		q__3.r = r__3, q__3.i = 0.f;
		q__2.r = safe1 + q__3.r, q__2.i = q__3.i;
		i__4 = i__ + j * ayb_dim1;
		q__1.r = q__2.r / ayb[i__4], q__1.i = q__2.i / ayb[i__4];
		tmp = q__1.r;
/* Computing MAX */
		r__1 = berr[j];
		berr[j] = dmax(r__1,tmp);
	    }

/*     If AYB is exactly 0.0 (and if computed by CLA_yyAMV), then we know */
/*     the true residual also must be exactly 0.0. */

	}
    }
    return 0;
} /* cla_lin_berr__ */
示例#2
0
/* Subroutine */ int sget07_(char *trans, integer *n, integer *nrhs, real *a, 
	integer *lda, real *b, integer *ldb, real *x, integer *ldx, real *
	xact, integer *ldxact, real *ferr, logical *chkferr, real *berr, real 
	*reslts)
{
    /* System generated locals */
    integer a_dim1, a_offset, b_dim1, b_offset, x_dim1, x_offset, xact_dim1, 
	    xact_offset, i__1, i__2, i__3;
    real r__1, r__2, r__3;

    /* Local variables */
    integer i__, j, k;
    real eps, tmp, diff, axbi;
    integer imax;
    real unfl, ovfl;
    real xnorm;
    real errbnd;
    logical notran;


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

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

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

/*  SGET07 tests the error bounds from iterative refinement for the */
/*  computed solution to a system of equations op(A)*X = B, where A is a */
/*  general n by n matrix and op(A) = A or A**T, depending on TRANS. */

/*  RESLTS(1) = test of the error bound */
/*            = norm(X - XACT) / ( norm(X) * FERR ) */

/*  A large value is returned if this ratio is not less than one. */

/*  RESLTS(2) = residual from the iterative refinement routine */
/*            = the maximum of BERR / ( (n+1)*EPS + (*) ), where */
/*              (*) = (n+1)*UNFL / (min_i (abs(op(A))*abs(X) +abs(b))_i ) */

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

/*  TRANS   (input) CHARACTER*1 */
/*          Specifies the form of the system of equations. */
/*          = 'N':  A * X = B     (No transpose) */
/*          = 'T':  A**T * X = B  (Transpose) */
/*          = 'C':  A**H * X = B  (Conjugate transpose = Transpose) */

/*  N       (input) INTEGER */
/*          The number of rows of the matrices X and XACT.  N >= 0. */

/*  NRHS    (input) INTEGER */
/*          The number of columns of the matrices X and XACT.  NRHS >= 0. */

/*  A       (input) REAL array, dimension (LDA,N) */
/*          The original n by n matrix A. */

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

/*  B       (input) REAL 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). */

/*  X       (input) REAL array, dimension (LDX,NRHS) */
/*          The computed solution vectors.  Each vector is stored as a */
/*          column of the matrix X. */

/*  LDX     (input) INTEGER */
/*          The leading dimension of the array X.  LDX >= max(1,N). */

/*  XACT    (input) REAL array, dimension (LDX,NRHS) */
/*          The exact solution vectors.  Each vector is stored as a */
/*          column of the matrix XACT. */

/*  LDXACT  (input) INTEGER */
/*          The leading dimension of the array XACT.  LDXACT >= max(1,N). */

/*  FERR    (input) REAL array, dimension (NRHS) */
/*          The estimated forward error bounds for each solution vector */
/*          X.  If XTRUE is the true solution, FERR bounds the magnitude */
/*          of the largest entry in (X - XTRUE) divided by the magnitude */
/*          of the largest entry in X. */

/*  CHKFERR (input) LOGICAL */
/*          Set to .TRUE. to check FERR, .FALSE. not to check FERR. */
/*          When the test system is ill-conditioned, the "true" */
/*          solution in XACT may be incorrect. */

/*  BERR    (input) REAL array, dimension (NRHS) */
/*          The componentwise relative backward error of each solution */
/*          vector (i.e., the smallest relative change in any entry of A */
/*          or B that makes X an exact solution). */

/*  RESLTS  (output) REAL array, dimension (2) */
/*          The maximum over the NRHS solution vectors of the ratios: */
/*          RESLTS(1) = norm(X - XACT) / ( norm(X) * FERR ) */
/*          RESLTS(2) = BERR / ( (n+1)*EPS + (*) ) */

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

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

/*     Quick exit if N = 0 or NRHS = 0. */

    /* Parameter adjustments */
    a_dim1 = *lda;
    a_offset = 1 + a_dim1;
    a -= a_offset;
    b_dim1 = *ldb;
    b_offset = 1 + b_dim1;
    b -= b_offset;
    x_dim1 = *ldx;
    x_offset = 1 + x_dim1;
    x -= x_offset;
    xact_dim1 = *ldxact;
    xact_offset = 1 + xact_dim1;
    xact -= xact_offset;
    --ferr;
    --berr;
    --reslts;

    /* Function Body */
    if (*n <= 0 || *nrhs <= 0) {
	reslts[1] = 0.f;
	reslts[2] = 0.f;
	return 0;
    }

    eps = slamch_("Epsilon");
    unfl = slamch_("Safe minimum");
    ovfl = 1.f / unfl;
    notran = lsame_(trans, "N");

/*     Test 1:  Compute the maximum of */
/*        norm(X - XACT) / ( norm(X) * FERR ) */
/*     over all the vectors X and XACT using the infinity-norm. */

    errbnd = 0.f;
    if (*chkferr) {
	i__1 = *nrhs;
	for (j = 1; j <= i__1; ++j) {
	    imax = isamax_(n, &x[j * x_dim1 + 1], &c__1);
/* Computing MAX */
	    r__2 = (r__1 = x[imax + j * x_dim1], dabs(r__1));
	    xnorm = dmax(r__2,unfl);
	    diff = 0.f;
	    i__2 = *n;
	    for (i__ = 1; i__ <= i__2; ++i__) {
/* Computing MAX */
		r__2 = diff, r__3 = (r__1 = x[i__ + j * x_dim1] - xact[i__ + 
			j * xact_dim1], dabs(r__1));
		diff = dmax(r__2,r__3);
/* L10: */
	    }

	    if (xnorm > 1.f) {
		goto L20;
	    } else if (diff <= ovfl * xnorm) {
		goto L20;
	    } else {
		errbnd = 1.f / eps;
		goto L30;
	    }

L20:
	    if (diff / xnorm <= ferr[j]) {
/* Computing MAX */
		r__1 = errbnd, r__2 = diff / xnorm / ferr[j];
		errbnd = dmax(r__1,r__2);
	    } else {
		errbnd = 1.f / eps;
	    }
L30:
	    ;
	}
    }
    reslts[1] = errbnd;

/*     Test 2:  Compute the maximum of BERR / ( (n+1)*EPS + (*) ), where */
/*     (*) = (n+1)*UNFL / (min_i (abs(op(A))*abs(X) +abs(b))_i ) */

    i__1 = *nrhs;
    for (k = 1; k <= i__1; ++k) {
	i__2 = *n;
	for (i__ = 1; i__ <= i__2; ++i__) {
	    tmp = (r__1 = b[i__ + k * b_dim1], dabs(r__1));
	    if (notran) {
		i__3 = *n;
		for (j = 1; j <= i__3; ++j) {
		    tmp += (r__1 = a[i__ + j * a_dim1], dabs(r__1)) * (r__2 = 
			    x[j + k * x_dim1], dabs(r__2));
/* L40: */
		}
	    } else {
		i__3 = *n;
		for (j = 1; j <= i__3; ++j) {
		    tmp += (r__1 = a[j + i__ * a_dim1], dabs(r__1)) * (r__2 = 
			    x[j + k * x_dim1], dabs(r__2));
/* L50: */
		}
	    }
	    if (i__ == 1) {
		axbi = tmp;
	    } else {
		axbi = dmin(axbi,tmp);
	    }
/* L60: */
	}
/* Computing MAX */
	r__1 = axbi, r__2 = (*n + 1) * unfl;
	tmp = berr[k] / ((*n + 1) * eps + (*n + 1) * unfl / dmax(r__1,r__2));
	if (k == 1) {
	    reslts[2] = tmp;
	} else {
	    reslts[2] = dmax(reslts[2],tmp);
	}
/* L70: */
    }

    return 0;

/*     End of SGET07 */

} /* sget07_ */
示例#3
0
文件: cdrvbd.c 项目: zangel/uquad
/* Subroutine */ int cdrvbd_(integer *nsizes, integer *mm, integer *nn, 
	integer *ntypes, logical *dotype, integer *iseed, real *thresh, 
	complex *a, integer *lda, complex *u, integer *ldu, complex *vt, 
	integer *ldvt, complex *asav, complex *usav, complex *vtsav, real *s, 
	real *ssav, real *e, complex *work, integer *lwork, real *rwork, 
	integer *iwork, integer *nounit, integer *info)
{
    /* Initialized data */

    static char cjob[1*4] = "N" "O" "S" "A";

    /* Format strings */
    static char fmt_9996[] = "(\002 CDRVBD: \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_9995[] = "(\002 CDRVBD: \002,a,\002 returned INFO=\002,i"
	    "6,\002.\002,/9x,\002M=\002,i6,\002, N=\002,i6,\002, JTYPE=\002,i"
	    "6,\002, LSWORK=\002,i6,/9x,\002ISEED=(\002,3(i5,\002,\002),i5"
	    ",\002)\002)";
    static char fmt_9999[] = "(\002 SVD -- Complex Singular Value Decomposit"
	    "ion Driver \002,/\002 Matrix types (see CDRVBD for details):\002"
	    ",//\002 1 = Zero matrix\002,/\002 2 = Identity matrix\002,/\002 "
	    "3 = Evenly spaced singular values near 1\002,/\002 4 = Evenly sp"
	    "aced singular values near underflow\002,/\002 5 = Evenly spaced "
	    "singular values near overflow\002,//\002 Tests performed: ( A is"
	    " dense, U and V are unitary,\002,/19x,\002 S is an array, and Up"
	    "artial, VTpartial, and\002,/19x,\002 Spartial are partially comp"
	    "uted U, VT and S),\002,/)";
    static char fmt_9998[] = "(\002 Tests performed with Test Threshold ="
	    " \002,f8.2,/\002 CGESVD: \002,/\002 1 = | A - U diag(S) VT | / ("
	    " |A| max(M,N) ulp ) \002,/\002 2 = | I - U**T U | / ( M ulp )"
	    " \002,/\002 3 = | I - VT VT**T | / ( N ulp ) \002,/\002 4 = 0 if"
	    " S contains min(M,N) nonnegative values in\002,\002 decreasing o"
	    "rder, else 1/ulp\002,/\002 5 = | U - Upartial | / ( M ulp )\002,/"
	    "\002 6 = | VT - VTpartial | / ( N ulp )\002,/\002 7 = | S - Spar"
	    "tial | / ( min(M,N) ulp |S| )\002,/\002 CGESDD: \002,/\002 8 = |"
	    " A - U diag(S) VT | / ( |A| max(M,N) ulp ) \002,/\002 9 = | I - "
	    "U**T U | / ( M ulp ) \002,/\00210 = | I - VT VT**T | / ( N ulp ) "
	    "\002,/\00211 = 0 if S contains min(M,N) nonnegative values in"
	    "\002,\002 decreasing order, else 1/ulp\002,/\00212 = | U - Upart"
	    "ial | / ( M ulp )\002,/\00213 = | VT - VTpartial | / ( N ulp "
	    ")\002,/\00214 = | S - Spartial | / ( min(M,N) ulp |S| )\002,//)";
    static char fmt_9997[] = "(\002 M=\002,i5,\002, N=\002,i5,\002, type "
	    "\002,i1,\002, IWS=\002,i1,\002, seed=\002,4(i4,\002,\002),\002 t"
	    "est(\002,i1,\002)=\002,g11.4)";

    /* System generated locals */
    integer a_dim1, a_offset, asav_dim1, asav_offset, u_dim1, u_offset, 
	    usav_dim1, usav_offset, vt_dim1, vt_offset, vtsav_dim1, 
	    vtsav_offset, i__1, i__2, i__3, i__4, i__5, i__6, i__7, i__8, 
	    i__9, i__10, i__11, i__12, i__13, i__14;
    real r__1, r__2, r__3;

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

    /* Local variables */
    static char jobq[1], jobu[1];
    static integer mmax, nmax;
    static real unfl, ovfl;
    static integer ijvt, i__, j, m, n;
    extern /* Subroutine */ int cbdt01_(integer *, integer *, integer *, 
	    complex *, integer *, complex *, integer *, real *, real *, 
	    complex *, integer *, complex *, real *, real *);
    static logical badmm, badnn;
    static integer nfail, iinfo;
    extern /* Subroutine */ int cunt01_(char *, integer *, integer *, complex 
	    *, integer *, complex *, integer *, real *, real *);
    static real anorm;
    extern /* Subroutine */ int cunt03_(char *, integer *, integer *, integer 
	    *, integer *, complex *, integer *, complex *, integer *, complex 
	    *, integer *, real *, real *, integer *);
    static integer mnmin, mnmax;
    static char jobvt[1];
    static integer iwspc, jsize, nerrs, jtype, ntest, iwtmp;
    extern /* Subroutine */ int cgesdd_(char *, integer *, integer *, complex 
	    *, integer *, real *, complex *, integer *, complex *, integer *, 
	    complex *, integer *, real *, integer *, integer *);
    extern doublereal slamch_(char *);
    extern /* Subroutine */ int cgesvd_(char *, char *, integer *, integer *, 
	    complex *, integer *, real *, complex *, integer *, complex *, 
	    integer *, complex *, integer *, real *, integer *), clacpy_(char *, integer *, integer *, complex *, integer 
	    *, complex *, integer *), claset_(char *, integer *, 
	    integer *, complex *, complex *, complex *, integer *);
    static integer ioldsd[4];
    extern /* Subroutine */ int xerbla_(char *, integer *), alasvm_(
	    char *, integer *, integer *, integer *, integer *), 
	    clatms_(integer *, integer *, char *, integer *, char *, real *, 
	    integer *, real *, real *, integer *, integer *, char *, complex *
	    , integer *, complex *, integer *);
    static integer ntestf, minwrk;
    static real ulpinv, result[14];
    static integer lswork, mtypes, ntestt;
    static real dif, div;
    static integer ijq, iju;
    static real ulp;

    /* Fortran I/O blocks */
    static cilist io___27 = { 0, 0, 0, fmt_9996, 0 };
    static cilist io___32 = { 0, 0, 0, fmt_9995, 0 };
    static cilist io___39 = { 0, 0, 0, fmt_9995, 0 };
    static cilist io___43 = { 0, 0, 0, fmt_9999, 0 };
    static cilist io___44 = { 0, 0, 0, fmt_9998, 0 };
    static cilist io___45 = { 0, 0, 0, fmt_9997, 0 };



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

    CDRVBD checks the singular value decomposition (SVD) driver CGESVD   
    and CGESDD.   
    CGESVD and CGESDD factors A = U diag(S) VT, where U and VT are   
    unitary and diag(S) is diagonal with the entries of the array S on   
    its diagonal. The entries of S are the singular values, nonnegative   
    and stored in decreasing order.  U and VT can be optionally not   
    computed, overwritten on A, or computed partially.   

    A is M by N. Let MNMIN = min( M, N ). S has dimension MNMIN.   
    U can be M by M or M by MNMIN. VT can be N by N or MNMIN by N.   

    When CDRVBD is called, a number of matrix "sizes" (M's and N's)   
    and a number of matrix "types" are specified.  For each size (M,N)   
    and each type of matrix, and for the minimal workspace as well as   
    workspace adequate to permit blocking, an  M x N  matrix "A" will be   
    generated and used to test the SVD routines.  For each matrix, A will   
    be factored as A = U diag(S) VT and the following 12 tests computed:   

    Test for CGESVD:   

    (1)   | A - U diag(S) VT | / ( |A| max(M,N) ulp )   

    (2)   | I - U'U | / ( M ulp )   

    (3)   | I - VT VT' | / ( N ulp )   

    (4)   S contains MNMIN nonnegative values in decreasing order.   
          (Return 0 if true, 1/ULP if false.)   

    (5)   | U - Upartial | / ( M ulp ) where Upartial is a partially   
          computed U.   

    (6)   | VT - VTpartial | / ( N ulp ) where VTpartial is a partially   
          computed VT.   

    (7)   | S - Spartial | / ( MNMIN ulp |S| ) where Spartial is the   
          vector of singular values from the partial SVD   

    Test for CGESDD:   

    (1)   | A - U diag(S) VT | / ( |A| max(M,N) ulp )   

    (2)   | I - U'U | / ( M ulp )   

    (3)   | I - VT VT' | / ( N ulp )   

    (4)   S contains MNMIN nonnegative values in decreasing order.   
          (Return 0 if true, 1/ULP if false.)   

    (5)   | U - Upartial | / ( M ulp ) where Upartial is a partially   
          computed U.   

    (6)   | VT - VTpartial | / ( N ulp ) where VTpartial is a partially   
          computed VT.   

    (7)   | S - Spartial | / ( MNMIN ulp |S| ) where Spartial is the   
          vector of singular values from the partial SVD   

    The "sizes" are specified by the arrays MM(1:NSIZES) and   
    NN(1:NSIZES); the value of each element pair (MM(j),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 matrix of the form  U D V, where U and V are unitary and   
         D has evenly spaced entries 1, ..., ULP with random signs   
         on the diagonal.   
    (4)  Same as (3), but multiplied by the underflow-threshold / ULP.   
    (5)  Same as (3), but multiplied by the overflow-threshold * ULP.   

    Arguments   
    ==========   

    NSIZES  (input) INTEGER   
            The number of sizes of matrices to use.  If it is zero,   
            CDRVBD does nothing.  It must be at least zero.   

    MM      (input) INTEGER array, dimension (NSIZES)   
            An array containing the matrix "heights" to be used.  For   
            each j=1,...,NSIZES, if MM(j) is zero, then MM(j) and NN(j)   
            will be ignored.  The MM(j) values must be at least zero.   

    NN      (input) INTEGER array, dimension (NSIZES)   
            An array containing the matrix "widths" to be used.  For   
            each j=1,...,NSIZES, if NN(j) is zero, then MM(j) and NN(j)   
            will be ignored.  The NN(j) values must be at least zero.   

    NTYPES  (input) INTEGER   
            The number of elements in DOTYPE.   If it is zero, CDRVBD   
            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.   

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

    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.   

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

    A       (output) COMPLEX array, dimension (LDA,max(NN))   
            Used to hold the matrix whose singular values are to be   
            computed.  On exit, A contains the last matrix actually   
            used.   

    LDA     (input) INTEGER   
            The leading dimension of A.  It must be at   
            least 1 and at least max( MM ).   

    U       (output) COMPLEX array, dimension (LDU,max(MM))   
            Used to hold the computed matrix of right singular vectors.   
            On exit, U contains the last such vectors actually computed.   

    LDU     (input) INTEGER   
            The leading dimension of U.  It must be at   
            least 1 and at least max( MM ).   

    VT      (output) COMPLEX array, dimension (LDVT,max(NN))   
            Used to hold the computed matrix of left singular vectors.   
            On exit, VT contains the last such vectors actually computed.   

    LDVT    (input) INTEGER   
            The leading dimension of VT.  It must be at   
            least 1 and at least max( NN ).   

    ASAV    (output) COMPLEX array, dimension (LDA,max(NN))   
            Used to hold a different copy of the matrix whose singular   
            values are to be computed.  On exit, A contains the last   
            matrix actually used.   

    USAV    (output) COMPLEX array, dimension (LDU,max(MM))   
            Used to hold a different copy of the computed matrix of   
            right singular vectors. On exit, USAV contains the last such   
            vectors actually computed.   

    VTSAV   (output) COMPLEX array, dimension (LDVT,max(NN))   
            Used to hold a different copy of the computed matrix of   
            left singular vectors. On exit, VTSAV contains the last such   
            vectors actually computed.   

    S       (output) REAL array, dimension (max(min(MM,NN)))   
            Contains the computed singular values.   

    SSAV    (output) REAL array, dimension (max(min(MM,NN)))   
            Contains another copy of the computed singular values.   

    E       (output) REAL array, dimension (max(min(MM,NN)))   
            Workspace for CGESVD.   

    WORK    (workspace) COMPLEX array, dimension (LWORK)   

    LWORK   (input) INTEGER   
            The number of entries in WORK.  This must be at least   
            MAX(3*MIN(M,N)+MAX(M,N)**2,5*MIN(M,N),3*MAX(M,N)) for all   
            pairs  (M,N)=(MM(j),NN(j))   

    RWORK   (workspace) REAL array,   
                        dimension ( 5*max(max(MM,NN)) )   

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

    RESULT  (output) REAL array, dimension (7)   
            The values computed by the 7 tests described above.   
            The values are currently limited to 1/ULP, to avoid   
            overflow.   

    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   
             -7: THRESH < 0   
            -10: LDA < 1 or LDA < MMAX, where MMAX is max( MM(j) ).   
            -12: LDU < 1 or LDU < MMAX.   
            -14: LDVT < 1 or LDVT < NMAX, where NMAX is max( NN(j) ).   
            -21: LWORK too small.   
            If  CLATMS, or CGESVD returns an error code, the   
                absolute value of it is returned.   

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

       Parameter adjustments */
    --mm;
    --nn;
    --dotype;
    --iseed;
    asav_dim1 = *lda;
    asav_offset = 1 + asav_dim1 * 1;
    asav -= asav_offset;
    a_dim1 = *lda;
    a_offset = 1 + a_dim1 * 1;
    a -= a_offset;
    usav_dim1 = *ldu;
    usav_offset = 1 + usav_dim1 * 1;
    usav -= usav_offset;
    u_dim1 = *ldu;
    u_offset = 1 + u_dim1 * 1;
    u -= u_offset;
    vtsav_dim1 = *ldvt;
    vtsav_offset = 1 + vtsav_dim1 * 1;
    vtsav -= vtsav_offset;
    vt_dim1 = *ldvt;
    vt_offset = 1 + vt_dim1 * 1;
    vt -= vt_offset;
    --s;
    --ssav;
    --e;
    --work;
    --rwork;
    --iwork;

    /* Function Body   

       Check for errors */

    *info = 0;

/*     Important constants */

    nerrs = 0;
    ntestt = 0;
    ntestf = 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 = mm[j];
	mmax = max(i__2,i__3);
	if (mm[j] < 0) {
	    badmm = TRUE_;
	}
/* Computing MAX */
	i__2 = nmax, i__3 = nn[j];
	nmax = max(i__2,i__3);
	if (nn[j] < 0) {
	    badnn = TRUE_;
	}
/* Computing MAX   
   Computing MIN */
	i__4 = mm[j], i__5 = nn[j];
	i__2 = mnmax, i__3 = min(i__4,i__5);
	mnmax = max(i__2,i__3);
/* Computing MAX   
   Computing MAX   
   Computing MIN */
	i__6 = mm[j], i__7 = nn[j];
/* Computing MAX */
	i__9 = mm[j], i__10 = nn[j];
/* Computing 2nd power */
	i__8 = max(i__9,i__10);
/* Computing MIN */
	i__11 = mm[j], i__12 = nn[j];
/* Computing MAX */
	i__13 = mm[j], i__14 = nn[j];
	i__4 = min(i__6,i__7) * 3 + i__8 * i__8, i__5 = min(i__11,i__12) * 5, 
		i__4 = max(i__4,i__5), i__5 = max(i__13,i__14) * 3;
	i__2 = minwrk, i__3 = max(i__4,i__5);
	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 (*lda < max(1,mmax)) {
	*info = -10;
    } else if (*ldu < max(1,mmax)) {
	*info = -12;
    } else if (*ldvt < max(1,nmax)) {
	*info = -14;
    } else if (minwrk > *lwork) {
	*info = -21;
    }

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

/*     Quick return if nothing to do */

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

/*     More Important constants */

    unfl = slamch_("S");
    ovfl = 1.f / unfl;
    ulp = slamch_("E");
    ulpinv = 1.f / ulp;

/*     Loop over sizes, types */

    nerrs = 0;

    i__1 = *nsizes;
    for (jsize = 1; jsize <= i__1; ++jsize) {
	m = mm[jsize];
	n = nn[jsize];
	mnmin = min(m,n);

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

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

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

/*           Compute "A" */

	    if (mtypes > 5) {
		goto L50;
	    }

	    if (jtype == 1) {

/*              Zero matrix */

		claset_("Full", &m, &n, &c_b1, &c_b1, &a[a_offset], lda);
		i__3 = min(m,n);
		for (i__ = 1; i__ <= i__3; ++i__) {
		    s[i__] = 0.f;
/* L30: */
		}

	    } else if (jtype == 2) {

/*              Identity matrix */

		claset_("Full", &m, &n, &c_b1, &c_b2, &a[a_offset], lda);
		i__3 = min(m,n);
		for (i__ = 1; i__ <= i__3; ++i__) {
		    s[i__] = 1.f;
/* L40: */
		}

	    } else {

/*              (Scaled) random matrix */

		if (jtype == 3) {
		    anorm = 1.f;
		}
		if (jtype == 4) {
		    anorm = unfl / ulp;
		}
		if (jtype == 5) {
		    anorm = ovfl * ulp;
		}
		r__1 = (real) mnmin;
		i__3 = m - 1;
		i__4 = n - 1;
		clatms_(&m, &n, "U", &iseed[1], "N", &s[1], &c__4, &r__1, &
			anorm, &i__3, &i__4, "N", &a[a_offset], lda, &work[1],
			 &iinfo);
		if (iinfo != 0) {
		    io___27.ciunit = *nounit;
		    s_wsfe(&io___27);
		    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;
		}
	    }

L50:
	    clacpy_("F", &m, &n, &a[a_offset], lda, &asav[asav_offset], lda);

/*           Do for minimal and adequate (for blocking) workspace */

	    for (iwspc = 1; iwspc <= 4; ++iwspc) {

/*              Test for CGESVD */

		iwtmp = (min(m,n) << 1) + max(m,n);
		lswork = iwtmp + (iwspc - 1) * (*lwork - iwtmp) / 3;
		lswork = min(lswork,*lwork);
		lswork = max(lswork,1);
		if (iwspc == 4) {
		    lswork = *lwork;
		}

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

/*              Factorize A */

		if (iwspc > 1) {
		    clacpy_("F", &m, &n, &asav[asav_offset], lda, &a[a_offset]
			    , lda);
		}
		cgesvd_("A", "A", &m, &n, &a[a_offset], lda, &ssav[1], &usav[
			usav_offset], ldu, &vtsav[vtsav_offset], ldvt, &work[
			1], &lswork, &rwork[1], &iinfo);
		if (iinfo != 0) {
		    io___32.ciunit = *nounit;
		    s_wsfe(&io___32);
		    do_fio(&c__1, "GESVD", (ftnlen)5);
		    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__1, (char *)&lswork, (ftnlen)sizeof(integer));
		    do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer))
			    ;
		    e_wsfe();
		    *info = abs(iinfo);
		    return 0;
		}

/*              Do tests 1--4 */

		cbdt01_(&m, &n, &c__0, &asav[asav_offset], lda, &usav[
			usav_offset], ldu, &ssav[1], &e[1], &vtsav[
			vtsav_offset], ldvt, &work[1], &rwork[1], result);
		if (m != 0 && n != 0) {
		    cunt01_("Columns", &mnmin, &m, &usav[usav_offset], ldu, &
			    work[1], lwork, &rwork[1], &result[1]);
		    cunt01_("Rows", &mnmin, &n, &vtsav[vtsav_offset], ldvt, &
			    work[1], lwork, &rwork[1], &result[2]);
		}
		result[3] = 0.f;
		i__3 = mnmin - 1;
		for (i__ = 1; i__ <= i__3; ++i__) {
		    if (ssav[i__] < ssav[i__ + 1]) {
			result[3] = ulpinv;
		    }
		    if (ssav[i__] < 0.f) {
			result[3] = ulpinv;
		    }
/* L70: */
		}
		if (mnmin >= 1) {
		    if (ssav[mnmin] < 0.f) {
			result[3] = ulpinv;
		    }
		}

/*              Do partial SVDs, comparing to SSAV, USAV, and VTSAV */

		result[4] = 0.f;
		result[5] = 0.f;
		result[6] = 0.f;
		for (iju = 0; iju <= 3; ++iju) {
		    for (ijvt = 0; ijvt <= 3; ++ijvt) {
			if (iju == 3 && ijvt == 3 || iju == 1 && ijvt == 1) {
			    goto L90;
			}
			*(unsigned char *)jobu = *(unsigned char *)&cjob[iju];
			*(unsigned char *)jobvt = *(unsigned char *)&cjob[
				ijvt];
			clacpy_("F", &m, &n, &asav[asav_offset], lda, &a[
				a_offset], lda);
			cgesvd_(jobu, jobvt, &m, &n, &a[a_offset], lda, &s[1],
				 &u[u_offset], ldu, &vt[vt_offset], ldvt, &
				work[1], &lswork, &rwork[1], &iinfo);

/*                    Compare U */

			dif = 0.f;
			if (m > 0 && n > 0) {
			    if (iju == 1) {
				cunt03_("C", &m, &mnmin, &m, &mnmin, &usav[
					usav_offset], ldu, &a[a_offset], lda, 
					&work[1], lwork, &rwork[1], &dif, &
					iinfo);
			    } else if (iju == 2) {
				cunt03_("C", &m, &mnmin, &m, &mnmin, &usav[
					usav_offset], ldu, &u[u_offset], ldu, 
					&work[1], lwork, &rwork[1], &dif, &
					iinfo);
			    } else if (iju == 3) {
				cunt03_("C", &m, &m, &m, &mnmin, &usav[
					usav_offset], ldu, &u[u_offset], ldu, 
					&work[1], lwork, &rwork[1], &dif, &
					iinfo);
			    }
			}
			result[4] = dmax(result[4],dif);

/*                    Compare VT */

			dif = 0.f;
			if (m > 0 && n > 0) {
			    if (ijvt == 1) {
				cunt03_("R", &n, &mnmin, &n, &mnmin, &vtsav[
					vtsav_offset], ldvt, &a[a_offset], 
					lda, &work[1], lwork, &rwork[1], &dif,
					 &iinfo);
			    } else if (ijvt == 2) {
				cunt03_("R", &n, &mnmin, &n, &mnmin, &vtsav[
					vtsav_offset], ldvt, &vt[vt_offset], 
					ldvt, &work[1], lwork, &rwork[1], &
					dif, &iinfo);
			    } else if (ijvt == 3) {
				cunt03_("R", &n, &n, &n, &mnmin, &vtsav[
					vtsav_offset], ldvt, &vt[vt_offset], 
					ldvt, &work[1], lwork, &rwork[1], &
					dif, &iinfo);
			    }
			}
			result[5] = dmax(result[5],dif);

/*                    Compare S */

			dif = 0.f;
/* Computing MAX */
			r__1 = (real) mnmin * ulp * s[1], r__2 = slamch_(
				"Safe minimum");
			div = dmax(r__1,r__2);
			i__3 = mnmin - 1;
			for (i__ = 1; i__ <= i__3; ++i__) {
			    if (ssav[i__] < ssav[i__ + 1]) {
				dif = ulpinv;
			    }
			    if (ssav[i__] < 0.f) {
				dif = ulpinv;
			    }
/* Computing MAX */
			    r__2 = dif, r__3 = (r__1 = ssav[i__] - s[i__], 
				    dabs(r__1)) / div;
			    dif = dmax(r__2,r__3);
/* L80: */
			}
			result[6] = dmax(result[6],dif);
L90:
			;
		    }
/* L100: */
		}

/*              Test for CGESDD */

		iwtmp = (mnmin << 1) * mnmin + (mnmin << 1) + max(m,n);
		lswork = iwtmp + (iwspc - 1) * (*lwork - iwtmp) / 3;
		lswork = min(lswork,*lwork);
		lswork = max(lswork,1);
		if (iwspc == 4) {
		    lswork = *lwork;
		}

/*              Factorize A */

		clacpy_("F", &m, &n, &asav[asav_offset], lda, &a[a_offset], 
			lda);
		cgesdd_("A", &m, &n, &a[a_offset], lda, &ssav[1], &usav[
			usav_offset], ldu, &vtsav[vtsav_offset], ldvt, &work[
			1], &lswork, &rwork[1], &iwork[1], &iinfo);
		if (iinfo != 0) {
		    io___39.ciunit = *nounit;
		    s_wsfe(&io___39);
		    do_fio(&c__1, "GESDD", (ftnlen)5);
		    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__1, (char *)&lswork, (ftnlen)sizeof(integer));
		    do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer))
			    ;
		    e_wsfe();
		    *info = abs(iinfo);
		    return 0;
		}

/*              Do tests 1--4 */

		cbdt01_(&m, &n, &c__0, &asav[asav_offset], lda, &usav[
			usav_offset], ldu, &ssav[1], &e[1], &vtsav[
			vtsav_offset], ldvt, &work[1], &rwork[1], &result[7]);
		if (m != 0 && n != 0) {
		    cunt01_("Columns", &mnmin, &m, &usav[usav_offset], ldu, &
			    work[1], lwork, &rwork[1], &result[8]);
		    cunt01_("Rows", &mnmin, &n, &vtsav[vtsav_offset], ldvt, &
			    work[1], lwork, &rwork[1], &result[9]);
		}
		result[10] = 0.f;
		i__3 = mnmin - 1;
		for (i__ = 1; i__ <= i__3; ++i__) {
		    if (ssav[i__] < ssav[i__ + 1]) {
			result[10] = ulpinv;
		    }
		    if (ssav[i__] < 0.f) {
			result[10] = ulpinv;
		    }
/* L110: */
		}
		if (mnmin >= 1) {
		    if (ssav[mnmin] < 0.f) {
			result[10] = ulpinv;
		    }
		}

/*              Do partial SVDs, comparing to SSAV, USAV, and VTSAV */

		result[11] = 0.f;
		result[12] = 0.f;
		result[13] = 0.f;
		for (ijq = 0; ijq <= 2; ++ijq) {
		    *(unsigned char *)jobq = *(unsigned char *)&cjob[ijq];
		    clacpy_("F", &m, &n, &asav[asav_offset], lda, &a[a_offset]
			    , lda);
		    cgesdd_(jobq, &m, &n, &a[a_offset], lda, &s[1], &u[
			    u_offset], ldu, &vt[vt_offset], ldvt, &work[1], &
			    lswork, &rwork[1], &iwork[1], &iinfo);

/*                 Compare U */

		    dif = 0.f;
		    if (m > 0 && n > 0) {
			if (ijq == 1) {
			    if (m >= n) {
				cunt03_("C", &m, &mnmin, &m, &mnmin, &usav[
					usav_offset], ldu, &a[a_offset], lda, 
					&work[1], lwork, &rwork[1], &dif, &
					iinfo);
			    } else {
				cunt03_("C", &m, &mnmin, &m, &mnmin, &usav[
					usav_offset], ldu, &u[u_offset], ldu, 
					&work[1], lwork, &rwork[1], &dif, &
					iinfo);
			    }
			} else if (ijq == 2) {
			    cunt03_("C", &m, &mnmin, &m, &mnmin, &usav[
				    usav_offset], ldu, &u[u_offset], ldu, &
				    work[1], lwork, &rwork[1], &dif, &iinfo);
			}
		    }
		    result[11] = dmax(result[11],dif);

/*                 Compare VT */

		    dif = 0.f;
		    if (m > 0 && n > 0) {
			if (ijq == 1) {
			    if (m >= n) {
				cunt03_("R", &n, &mnmin, &n, &mnmin, &vtsav[
					vtsav_offset], ldvt, &vt[vt_offset], 
					ldvt, &work[1], lwork, &rwork[1], &
					dif, &iinfo);
			    } else {
				cunt03_("R", &n, &mnmin, &n, &mnmin, &vtsav[
					vtsav_offset], ldvt, &a[a_offset], 
					lda, &work[1], lwork, &rwork[1], &dif,
					 &iinfo);
			    }
			} else if (ijq == 2) {
			    cunt03_("R", &n, &mnmin, &n, &mnmin, &vtsav[
				    vtsav_offset], ldvt, &vt[vt_offset], ldvt,
				     &work[1], lwork, &rwork[1], &dif, &iinfo);
			}
		    }
		    result[12] = dmax(result[12],dif);

/*                 Compare S */

		    dif = 0.f;
/* Computing MAX */
		    r__1 = (real) mnmin * ulp * s[1], r__2 = slamch_("Safe m"
			    "inimum");
		    div = dmax(r__1,r__2);
		    i__3 = mnmin - 1;
		    for (i__ = 1; i__ <= i__3; ++i__) {
			if (ssav[i__] < ssav[i__ + 1]) {
			    dif = ulpinv;
			}
			if (ssav[i__] < 0.f) {
			    dif = ulpinv;
			}
/* Computing MAX */
			r__2 = dif, r__3 = (r__1 = ssav[i__] - s[i__], dabs(
				r__1)) / div;
			dif = dmax(r__2,r__3);
/* L120: */
		    }
		    result[13] = dmax(result[13],dif);
/* L130: */
		}

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

		ntest = 0;
		nfail = 0;
		for (j = 1; j <= 14; ++j) {
		    if (result[j - 1] >= 0.f) {
			++ntest;
		    }
		    if (result[j - 1] >= *thresh) {
			++nfail;
		    }
/* L140: */
		}

		if (nfail > 0) {
		    ++ntestf;
		}
		if (ntestf == 1) {
		    io___43.ciunit = *nounit;
		    s_wsfe(&io___43);
		    e_wsfe();
		    io___44.ciunit = *nounit;
		    s_wsfe(&io___44);
		    do_fio(&c__1, (char *)&(*thresh), (ftnlen)sizeof(real));
		    e_wsfe();
		    ntestf = 2;
		}

		for (j = 1; j <= 14; ++j) {
		    if (result[j - 1] >= *thresh) {
			io___45.ciunit = *nounit;
			s_wsfe(&io___45);
			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__1, (char *)&iwspc, (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(
				real));
			e_wsfe();
		    }
/* L150: */
		}

		nerrs += nfail;
		ntestt += ntest;

/* L160: */
	    }

L170:
	    ;
	}
/* L180: */
    }

/*     Summary */

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


    return 0;

/*     End of CDRVBD */

} /* cdrvbd_ */
示例#4
0
文件: sget31.c 项目: zangel/uquad
/* Subroutine */ int sget31_(real *rmax, integer *lmax, integer *ninfo, 
	integer *knt)
{
    /* Initialized data */

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

    /* System generated locals */
    real r__1, r__2, r__3, r__4, r__5, r__6, r__7, r__8, r__9, r__10, r__11, 
	    r__12, r__13, r__14, r__15, r__16, r__17;

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

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


#define a_ref(a_1,a_2) a[(a_2)*2 + a_1 - 3]
#define b_ref(a_1,a_2) b[(a_2)*2 + a_1 - 3]
#define x_ref(a_1,a_2) x[(a_2)*2 + a_1 - 3]


/*  -- LAPACK test 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   
    =======   

    SGET31 tests SLALN2, 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) REAL   
            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.   

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

       Parameter adjustments */
    --ninfo;

    /* Function Body   

       Get machine parameters */

    eps = slamch_("P");
    unfl = slamch_("U");
    smlnum = slamch_("S") / eps;
    bignum = 1.f / smlnum;
    slabad_(&smlnum, &bignum);

/*     Set up test case parameters */

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

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

/*     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_ref(1, 1) = vab[ia - 1];
			    for (ib = 1; ib <= 3; ++ib) {
				b_ref(1, 1) = vab[ib - 1];
				for (iwr = 1; iwr <= 4; ++iwr) {
				    if (d1 == 1.f && d2 == 1.f && ca == 1.f) {
					wr = vwr[iwr - 1] * a_ref(1, 1);
				    } else {
					wr = vwr[iwr - 1];
				    }
				    wi = 0.f;
				    slaln2_(&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 = (r__1 = (ca * a_ref(1, 1) - wr * d1)
					     * x_ref(1, 1) - scale * b_ref(1, 
					    1), dabs(r__1));
				    if (info == 0) {
/* Computing MAX */
					r__2 = eps * (r__1 = (ca * a_ref(1, 1)
						 - wr * d1) * x_ref(1, 1), 
						dabs(r__1));
					den = dmax(r__2,smlnum);
				    } else {
/* Computing MAX */
					r__2 = smin * (r__1 = x_ref(1, 1), 
						dabs(r__1));
					den = dmax(r__2,smlnum);
				    }
				    res /= den;
				    if ((r__1 = x_ref(1, 1), dabs(r__1)) < 
					    unfl && (r__3 = b_ref(1, 1), dabs(
					    r__3)) <= smlnum * (r__2 = ca * 
					    a_ref(1, 1) - wr * d1, dabs(r__2))
					    ) {
					res = 0.f;
				    }
				    if (scale > 1.f) {
					res += 1.f / eps;
				    }
				    res += (r__2 = xnorm - (r__1 = x_ref(1, 1)
					    , dabs(r__1)), dabs(r__2)) / dmax(
					    smlnum,xnorm) / eps;
				    if (info != 0 && info != 1) {
					res += 1.f / eps;
				    }
				    ++(*knt);
				    if (res > *rmax) {
					*lmax = *knt;
					*rmax = res;
				    }
/* L10: */
				}
/* L20: */
			    }
/* L30: */
			}

			na = 1;
			nw = 2;
			for (ia = 1; ia <= 3; ++ia) {
			    a_ref(1, 1) = vab[ia - 1];
			    for (ib = 1; ib <= 3; ++ib) {
				b_ref(1, 1) = vab[ib - 1];
				b_ref(1, 2) = vab[ib - 1] * -.5f;
				for (iwr = 1; iwr <= 4; ++iwr) {
				    if (d1 == 1.f && d2 == 1.f && ca == 1.f) {
					wr = vwr[iwr - 1] * a_ref(1, 1);
				    } else {
					wr = vwr[iwr - 1];
				    }
				    for (iwi = 1; iwi <= 4; ++iwi) {
					if (d1 == 1.f && d2 == 1.f && ca == 
						1.f) {
					    wi = vwi[iwi - 1] * a_ref(1, 1);
					} else {
					    wi = vwi[iwi - 1];
					}
					slaln2_(&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 = (r__1 = (ca * a_ref(1, 1) - wr *
						 d1) * x_ref(1, 1) + wi * d1 *
						 x_ref(1, 2) - scale * b_ref(
						1, 1), dabs(r__1));
					res += (r__1 = -wi * d1 * x_ref(1, 1) 
						+ (ca * a_ref(1, 1) - wr * d1)
						 * x_ref(1, 2) - scale * 
						b_ref(1, 2), dabs(r__1));
					if (info == 0) {
/* Computing MAX   
   Computing MAX */
					    r__6 = (r__3 = ca * a_ref(1, 1) - 
						    wr * d1, dabs(r__3)), 
						    r__7 = (r__4 = d1 * wi, 
						    dabs(r__4));
					    r__5 = eps * (dmax(r__6,r__7) * ((
						    r__1 = x_ref(1, 1), dabs(
						    r__1)) + (r__2 = x_ref(1, 
						    2), dabs(r__2))));
					    den = dmax(r__5,smlnum);
					} else {
/* Computing MAX */
					    r__3 = smin * ((r__1 = x_ref(1, 1)
						    , dabs(r__1)) + (r__2 = 
						    x_ref(1, 2), dabs(r__2)));
					    den = dmax(r__3,smlnum);
					}
					res /= den;
					if ((r__1 = x_ref(1, 1), dabs(r__1)) <
						 unfl && (r__2 = x_ref(1, 2), 
						dabs(r__2)) < unfl && (r__4 = 
						b_ref(1, 1), dabs(r__4)) <= 
						smlnum * (r__3 = ca * a_ref(1,
						 1) - wr * d1, dabs(r__3))) {
					    res = 0.f;
					}
					if (scale > 1.f) {
					    res += 1.f / eps;
					}
					res += (r__3 = xnorm - (r__1 = x_ref(
						1, 1), dabs(r__1)) - (r__2 = 
						x_ref(1, 2), dabs(r__2)), 
						dabs(r__3)) / dmax(smlnum,
						xnorm) / eps;
					if (info != 0 && info != 1) {
					    res += 1.f / eps;
					}
					++(*knt);
					if (res > *rmax) {
					    *lmax = *knt;
					    *rmax = res;
					}
/* L40: */
				    }
/* L50: */
				}
/* L60: */
			    }
/* L70: */
			}

			na = 2;
			nw = 1;
			for (ia = 1; ia <= 3; ++ia) {
			    a_ref(1, 1) = vab[ia - 1];
			    a_ref(1, 2) = vab[ia - 1] * -3.f;
			    a_ref(2, 1) = vab[ia - 1] * -7.f;
			    a_ref(2, 2) = vab[ia - 1] * 21.f;
			    for (ib = 1; ib <= 3; ++ib) {
				b_ref(1, 1) = vab[ib - 1];
				b_ref(2, 1) = vab[ib - 1] * -2.f;
				for (iwr = 1; iwr <= 4; ++iwr) {
				    if (d1 == 1.f && d2 == 1.f && ca == 1.f) {
					wr = vwr[iwr - 1] * a_ref(1, 1);
				    } else {
					wr = vwr[iwr - 1];
				    }
				    wi = 0.f;
				    slaln2_(&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_ref(1, 2);
					a_ref(1, 2) = a_ref(2, 1);
					a_ref(2, 1) = tmp;
				    }
				    res = (r__1 = (ca * a_ref(1, 1) - wr * d1)
					     * x_ref(1, 1) + ca * a_ref(1, 2) 
					    * x_ref(2, 1) - scale * b_ref(1, 
					    1), dabs(r__1));
				    res += (r__1 = ca * a_ref(2, 1) * x_ref(1,
					     1) + (ca * a_ref(2, 2) - wr * d2)
					     * x_ref(2, 1) - scale * b_ref(2, 
					    1), dabs(r__1));
				    if (info == 0) {
/* Computing MAX   
   Computing MAX */
					r__8 = (r__1 = ca * a_ref(1, 1) - wr *
						 d1, dabs(r__1)) + (r__2 = ca 
						* a_ref(1, 2), dabs(r__2)), 
						r__9 = (r__3 = ca * a_ref(2, 
						1), dabs(r__3)) + (r__4 = ca *
						 a_ref(2, 2) - wr * d2, dabs(
						r__4));
/* Computing MAX */
					r__10 = (r__5 = x_ref(1, 1), dabs(
						r__5)), r__11 = (r__6 = x_ref(
						2, 1), dabs(r__6));
					r__7 = eps * (dmax(r__8,r__9) * dmax(
						r__10,r__11));
					den = dmax(r__7,smlnum);
				    } else {
/* Computing MAX   
   Computing MAX   
   Computing MAX */
					r__10 = (r__1 = ca * a_ref(1, 1) - wr 
						* d1, dabs(r__1)) + (r__2 = 
						ca * a_ref(1, 2), dabs(r__2)),
						 r__11 = (r__3 = ca * a_ref(2,
						 1), dabs(r__3)) + (r__4 = ca 
						* a_ref(2, 2) - wr * d2, dabs(
						r__4));
					r__8 = smin / eps, r__9 = dmax(r__10,
						r__11);
/* Computing MAX */
					r__12 = (r__5 = x_ref(1, 1), dabs(
						r__5)), r__13 = (r__6 = x_ref(
						2, 1), dabs(r__6));
					r__7 = eps * (dmax(r__8,r__9) * dmax(
						r__12,r__13));
					den = dmax(r__7,smlnum);
				    }
				    res /= den;
				    if ((r__1 = x_ref(1, 1), dabs(r__1)) < 
					    unfl && (r__2 = x_ref(2, 1), dabs(
					    r__2)) < unfl && (r__3 = b_ref(1, 
					    1), dabs(r__3)) + (r__4 = b_ref(2,
					     1), dabs(r__4)) <= smlnum * ((
					    r__5 = ca * a_ref(1, 1) - wr * d1,
					     dabs(r__5)) + (r__6 = ca * a_ref(
					    1, 2), dabs(r__6)) + (r__7 = ca * 
					    a_ref(2, 1), dabs(r__7)) + (r__8 =
					     ca * a_ref(2, 2) - wr * d2, dabs(
					    r__8)))) {
					res = 0.f;
				    }
				    if (scale > 1.f) {
					res += 1.f / eps;
				    }
/* Computing MAX */
				    r__4 = (r__1 = x_ref(1, 1), dabs(r__1)), 
					    r__5 = (r__2 = x_ref(2, 1), dabs(
					    r__2));
				    res += (r__3 = xnorm - dmax(r__4,r__5), 
					    dabs(r__3)) / dmax(smlnum,xnorm) /
					     eps;
				    if (info != 0 && info != 1) {
					res += 1.f / eps;
				    }
				    ++(*knt);
				    if (res > *rmax) {
					*lmax = *knt;
					*rmax = res;
				    }
/* L80: */
				}
/* L90: */
			    }
/* L100: */
			}

			na = 2;
			nw = 2;
			for (ia = 1; ia <= 3; ++ia) {
			    a_ref(1, 1) = vab[ia - 1] * 2.f;
			    a_ref(1, 2) = vab[ia - 1] * -3.f;
			    a_ref(2, 1) = vab[ia - 1] * -7.f;
			    a_ref(2, 2) = vab[ia - 1] * 21.f;
			    for (ib = 1; ib <= 3; ++ib) {
				b_ref(1, 1) = vab[ib - 1];
				b_ref(2, 1) = vab[ib - 1] * -2.f;
				b_ref(1, 2) = vab[ib - 1] * 4.f;
				b_ref(2, 2) = vab[ib - 1] * -7.f;
				for (iwr = 1; iwr <= 4; ++iwr) {
				    if (d1 == 1.f && d2 == 1.f && ca == 1.f) {
					wr = vwr[iwr - 1] * a_ref(1, 1);
				    } else {
					wr = vwr[iwr - 1];
				    }
				    for (iwi = 1; iwi <= 4; ++iwi) {
					if (d1 == 1.f && d2 == 1.f && ca == 
						1.f) {
					    wi = vwi[iwi - 1] * a_ref(1, 1);
					} else {
					    wi = vwi[iwi - 1];
					}
					slaln2_(&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_ref(1, 2);
					    a_ref(1, 2) = a_ref(2, 1);
					    a_ref(2, 1) = tmp;
					}
					res = (r__1 = (ca * a_ref(1, 1) - wr *
						 d1) * x_ref(1, 1) + ca * 
						a_ref(1, 2) * x_ref(2, 1) + 
						wi * d1 * x_ref(1, 2) - scale 
						* b_ref(1, 1), dabs(r__1));
					res += (r__1 = (ca * a_ref(1, 1) - wr 
						* d1) * x_ref(1, 2) + ca * 
						a_ref(1, 2) * x_ref(2, 2) - 
						wi * d1 * x_ref(1, 1) - scale 
						* b_ref(1, 2), dabs(r__1));
					res += (r__1 = ca * a_ref(2, 1) * 
						x_ref(1, 1) + (ca * a_ref(2, 
						2) - wr * d2) * x_ref(2, 1) + 
						wi * d2 * x_ref(2, 2) - scale 
						* b_ref(2, 1), dabs(r__1));
					res += (r__1 = ca * a_ref(2, 1) * 
						x_ref(1, 2) + (ca * a_ref(2, 
						2) - wr * d2) * x_ref(2, 2) - 
						wi * d2 * x_ref(2, 1) - scale 
						* b_ref(2, 2), dabs(r__1));
					if (info == 0) {
/* Computing MAX   
   Computing MAX */
					    r__12 = (r__1 = ca * a_ref(1, 1) 
						    - wr * d1, dabs(r__1)) + (
						    r__2 = ca * a_ref(1, 2), 
						    dabs(r__2)) + (r__3 = wi *
						     d1, dabs(r__3)), r__13 = 
						    (r__4 = ca * a_ref(2, 1), 
						    dabs(r__4)) + (r__5 = ca *
						     a_ref(2, 2) - wr * d2, 
						    dabs(r__5)) + (r__6 = wi *
						     d2, dabs(r__6));
/* Computing MAX */
					    r__14 = (r__7 = x_ref(1, 1), dabs(
						    r__7)) + (r__8 = x_ref(2, 
						    1), dabs(r__8)), r__15 = (
						    r__9 = x_ref(1, 2), dabs(
						    r__9)) + (r__10 = x_ref(2,
						     2), dabs(r__10));
					    r__11 = eps * (dmax(r__12,r__13) *
						     dmax(r__14,r__15));
					    den = dmax(r__11,smlnum);
					} else {
/* Computing MAX   
   Computing MAX   
   Computing MAX */
					    r__14 = (r__1 = ca * a_ref(1, 1) 
						    - wr * d1, dabs(r__1)) + (
						    r__2 = ca * a_ref(1, 2), 
						    dabs(r__2)) + (r__3 = wi *
						     d1, dabs(r__3)), r__15 = 
						    (r__4 = ca * a_ref(2, 1), 
						    dabs(r__4)) + (r__5 = ca *
						     a_ref(2, 2) - wr * d2, 
						    dabs(r__5)) + (r__6 = wi *
						     d2, dabs(r__6));
					    r__12 = smin / eps, r__13 = dmax(
						    r__14,r__15);
/* Computing MAX */
					    r__16 = (r__7 = x_ref(1, 1), dabs(
						    r__7)) + (r__8 = x_ref(2, 
						    1), dabs(r__8)), r__17 = (
						    r__9 = x_ref(1, 2), dabs(
						    r__9)) + (r__10 = x_ref(2,
						     2), dabs(r__10));
					    r__11 = eps * (dmax(r__12,r__13) *
						     dmax(r__16,r__17));
					    den = dmax(r__11,smlnum);
					}
					res /= den;
					if ((r__1 = x_ref(1, 1), dabs(r__1)) <
						 unfl && (r__2 = x_ref(2, 1), 
						dabs(r__2)) < unfl && (r__3 = 
						x_ref(1, 2), dabs(r__3)) < 
						unfl && (r__4 = x_ref(2, 2), 
						dabs(r__4)) < unfl && (r__5 = 
						b_ref(1, 1), dabs(r__5)) + (
						r__6 = b_ref(2, 1), dabs(r__6)
						) <= smlnum * ((r__7 = ca * 
						a_ref(1, 1) - wr * d1, dabs(
						r__7)) + (r__8 = ca * a_ref(1,
						 2), dabs(r__8)) + (r__9 = ca 
						* a_ref(2, 1), dabs(r__9)) + (
						r__10 = ca * a_ref(2, 2) - wr 
						* d2, dabs(r__10)) + (r__11 = 
						wi * d2, dabs(r__11)) + (
						r__12 = wi * d1, dabs(r__12)))
						) {
					    res = 0.f;
					}
					if (scale > 1.f) {
					    res += 1.f / eps;
					}
/* Computing MAX */
					r__6 = (r__1 = x_ref(1, 1), dabs(r__1)
						) + (r__2 = x_ref(1, 2), dabs(
						r__2)), r__7 = (r__3 = x_ref(
						2, 1), dabs(r__3)) + (r__4 = 
						x_ref(2, 2), dabs(r__4));
					res += (r__5 = xnorm - dmax(r__6,r__7)
						, dabs(r__5)) / dmax(smlnum,
						xnorm) / eps;
					if (info != 0 && info != 1) {
					    res += 1.f / eps;
					}
					++(*knt);
					if (res > *rmax) {
					    *lmax = *knt;
					    *rmax = res;
					}
/* L110: */
				    }
/* L120: */
				}
/* L130: */
			    }
/* L140: */
			}
/* L150: */
		    }
/* L160: */
		}
/* L170: */
	    }
/* L180: */
	}
/* L190: */
    }

    return 0;

/*     End of SGET31 */

} /* sget31_ */
示例#5
0
/* Subroutine */ int cdrvgb_(logical *dotype, integer *nn, integer *nval, 
	integer *nrhs, real *thresh, logical *tsterr, complex *a, integer *la, 
	 complex *afb, integer *lafb, complex *asav, complex *b, complex *
	bsav, complex *x, complex *xact, real *s, complex *work, real *rwork, 
	integer *iwork, integer *nout)
{
    /* Initialized data */

    static integer iseedy[4] = { 1988,1989,1990,1991 };
    static char transs[1*3] = "N" "T" "C";
    static char facts[1*3] = "F" "N" "E";
    static char equeds[1*4] = "N" "R" "C" "B";

    /* Format strings */
    static char fmt_9999[] = "(\002 *** In CDRVGB, LA=\002,i5,\002 is too sm"
	    "all for N=\002,i5,\002, KU=\002,i5,\002, KL=\002,i5,/\002 ==> In"
	    "crease LA to at least \002,i5)";
    static char fmt_9998[] = "(\002 *** In CDRVGB, LAFB=\002,i5,\002 is too "
	    "small for N=\002,i5,\002, KU=\002,i5,\002, KL=\002,i5,/\002 ==> "
	    "Increase LAFB to at least \002,i5)";
    static char fmt_9997[] = "(1x,a,\002, N=\002,i5,\002, KL=\002,i5,\002, K"
	    "U=\002,i5,\002, type \002,i1,\002, test(\002,i1,\002)=\002,g12.5)"
	    ;
    static char fmt_9995[] = "(1x,a,\002( '\002,a1,\002','\002,a1,\002',\002"
	    ",i5,\002,\002,i5,\002,\002,i5,\002,...), EQUED='\002,a1,\002', t"
	    "ype \002,i1,\002, test(\002,i1,\002)=\002,g12.5)";
    static char fmt_9996[] = "(1x,a,\002( '\002,a1,\002','\002,a1,\002',\002"
	    ",i5,\002,\002,i5,\002,\002,i5,\002,...), type \002,i1,\002, test("
	    "\002,i1,\002)=\002,g12.5)";

    /* System generated locals */
    address a__1[2];
    integer i__1, i__2, i__3, i__4, i__5, i__6, i__7, i__8, i__9, i__10, 
	    i__11[2];
    real r__1, r__2;
    char ch__1[2];

    /* Builtin functions */
    /* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);
    integer s_wsfe(cilist *), do_fio(integer *, char *, ftnlen), e_wsfe(void);
    /* Subroutine */ int s_cat(char *, char **, integer *, integer *, ftnlen);
    double c_abs(complex *);

    /* Local variables */
    integer i__, j, k, n, i1, i2, k1, nb, in, kl, ku, nt, lda, ldb, ikl, nkl, 
	    iku, nku;
    char fact[1];
    integer ioff, mode;
    real amax;
    char path[3];
    integer imat, info;
    char dist[1];
    real rdum[1];
    char type__[1];
    integer nrun, ldafb;
    extern /* Subroutine */ int cgbt01_(integer *, integer *, integer *, 
	    integer *, complex *, integer *, complex *, integer *, integer *, 
	    complex *, real *), cgbt02_(char *, integer *, integer *, integer 
	    *, integer *, integer *, complex *, integer *, complex *, integer 
	    *, complex *, integer *, real *), cgbt05_(char *, integer 
	    *, integer *, integer *, integer *, complex *, integer *, complex 
	    *, integer *, complex *, integer *, complex *, integer *, real *, 
	    real *, real *);
    integer ifact;
    extern /* Subroutine */ int cget04_(integer *, integer *, complex *, 
	    integer *, complex *, integer *, real *, real *);
    integer nfail, iseed[4], nfact;
    extern logical lsame_(char *, char *);
    char equed[1];
    integer nbmin;
    real rcond, roldc;
    extern /* Subroutine */ int cgbsv_(integer *, integer *, integer *, 
	    integer *, complex *, integer *, integer *, complex *, integer *, 
	    integer *);
    integer nimat;
    real roldi;
    extern doublereal sget06_(real *, real *);
    real anorm;
    integer itran;
    logical equil;
    real roldo;
    char trans[1];
    integer izero, nerrs;
    logical zerot;
    char xtype[1];
    extern /* Subroutine */ int clatb4_(char *, integer *, integer *, integer 
	    *, char *, integer *, integer *, real *, integer *, real *, char *
), aladhd_(integer *, char *);
    extern doublereal clangb_(char *, integer *, integer *, integer *, 
	    complex *, integer *, real *), clange_(char *, integer *, 
	    integer *, complex *, integer *, real *);
    extern /* Subroutine */ int claqgb_(integer *, integer *, integer *, 
	    integer *, complex *, integer *, real *, real *, real *, real *, 
	    real *, char *), alaerh_(char *, char *, integer *, 
	    integer *, char *, integer *, integer *, integer *, integer *, 
	    integer *, integer *, integer *, integer *, integer *);
    logical prefac;
    real colcnd;
    extern doublereal clantb_(char *, char *, char *, integer *, integer *, 
	    complex *, integer *, real *);
    extern /* Subroutine */ int cgbequ_(integer *, integer *, integer *, 
	    integer *, complex *, integer *, real *, real *, real *, real *, 
	    real *, integer *);
    real rcondc;
    extern doublereal slamch_(char *);
    logical nofact;
    extern /* Subroutine */ int cgbtrf_(integer *, integer *, integer *, 
	    integer *, complex *, integer *, integer *, integer *);
    integer iequed;
    extern /* Subroutine */ int clacpy_(char *, integer *, integer *, complex 
	    *, integer *, complex *, integer *);
    real rcondi;
    extern /* Subroutine */ int clarhs_(char *, char *, char *, char *, 
	    integer *, integer *, integer *, integer *, integer *, complex *, 
	    integer *, complex *, integer *, complex *, integer *, integer *, 
	    integer *), claset_(char *, 
	    integer *, integer *, complex *, complex *, complex *, integer *), alasvm_(char *, integer *, integer *, integer *, integer 
	    *);
    real cndnum, anormi, rcondo, ainvnm;
    extern /* Subroutine */ int cgbtrs_(char *, integer *, integer *, integer 
	    *, integer *, complex *, integer *, integer *, complex *, integer 
	    *, integer *), clatms_(integer *, integer *, char *, 
	    integer *, char *, real *, integer *, real *, real *, integer *, 
	    integer *, char *, complex *, integer *, complex *, integer *);
    logical trfcon;
    real anormo, rowcnd;
    extern /* Subroutine */ int cgbsvx_(char *, char *, integer *, integer *, 
	    integer *, integer *, complex *, integer *, complex *, integer *, 
	    integer *, char *, real *, real *, complex *, integer *, complex *
, integer *, real *, real *, real *, complex *, real *, integer *), xlaenv_(integer *, integer *);
    real anrmpv;
    extern /* Subroutine */ int cerrvx_(char *, integer *);
    real result[7], rpvgrw;

    /* Fortran I/O blocks */
    static cilist io___26 = { 0, 0, 0, fmt_9999, 0 };
    static cilist io___27 = { 0, 0, 0, fmt_9998, 0 };
    static cilist io___65 = { 0, 0, 0, fmt_9997, 0 };
    static cilist io___73 = { 0, 0, 0, fmt_9995, 0 };
    static cilist io___74 = { 0, 0, 0, fmt_9996, 0 };
    static cilist io___75 = { 0, 0, 0, fmt_9995, 0 };
    static cilist io___76 = { 0, 0, 0, fmt_9996, 0 };
    static cilist io___77 = { 0, 0, 0, fmt_9995, 0 };
    static cilist io___78 = { 0, 0, 0, fmt_9996, 0 };
    static cilist io___79 = { 0, 0, 0, fmt_9995, 0 };
    static cilist io___80 = { 0, 0, 0, fmt_9996, 0 };



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

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

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

/*  CDRVGB tests the driver routines CGBSV and -SVX. */

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

/*  DOTYPE  (input) LOGICAL array, dimension (NTYPES) */
/*          The matrix types to be used for testing.  Matrices of type j */
/*          (for 1 <= j <= NTYPES) are used for testing if DOTYPE(j) = */
/*          .TRUE.; if DOTYPE(j) = .FALSE., then type j is not used. */

/*  NN      (input) INTEGER */
/*          The number of values of N contained in the vector NVAL. */

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

/*  NRHS    (input) INTEGER */
/*          The number of right hand side vectors to be generated for */
/*          each linear system. */

/*  THRESH  (input) REAL */
/*          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. */

/*  TSTERR  (input) LOGICAL */
/*          Flag that indicates whether error exits are to be tested. */

/*  A       (workspace) COMPLEX array, dimension (LA) */

/*  LA      (input) INTEGER */
/*          The length of the array A.  LA >= (2*NMAX-1)*NMAX */
/*          where NMAX is the largest entry in NVAL. */

/*  AFB     (workspace) COMPLEX array, dimension (LAFB) */

/*  LAFB    (input) INTEGER */
/*          The length of the array AFB.  LAFB >= (3*NMAX-2)*NMAX */
/*          where NMAX is the largest entry in NVAL. */

/*  ASAV    (workspace) COMPLEX array, dimension (LA) */

/*  B       (workspace) COMPLEX array, dimension (NMAX*NRHS) */

/*  BSAV    (workspace) COMPLEX array, dimension (NMAX*NRHS) */

/*  X       (workspace) COMPLEX array, dimension (NMAX*NRHS) */

/*  XACT    (workspace) COMPLEX array, dimension (NMAX*NRHS) */

/*  S       (workspace) REAL array, dimension (2*NMAX) */

/*  WORK    (workspace) COMPLEX array, dimension */
/*                      (NMAX*max(3,NRHS,NMAX)) */

/*  RWORK   (workspace) REAL array, dimension */
/*                      (max(NMAX,2*NRHS)) */

/*  IWORK   (workspace) INTEGER array, dimension (NMAX) */

/*  NOUT    (input) INTEGER */
/*          The unit number for output. */

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

/*     .. Parameters .. */
/*     .. */
/*     .. Local Scalars .. */
/*     .. */
/*     .. Local Arrays .. */
/*     .. */
/*     .. External Functions .. */
/*     .. */
/*     .. External Subroutines .. */
/*     .. */
/*     .. Intrinsic Functions .. */
/*     .. */
/*     .. Scalars in Common .. */
/*     .. */
/*     .. Common blocks .. */
/*     .. */
/*     .. Data statements .. */
    /* Parameter adjustments */
    --iwork;
    --rwork;
    --work;
    --s;
    --xact;
    --x;
    --bsav;
    --b;
    --asav;
    --afb;
    --a;
    --nval;
    --dotype;

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

/*     Initialize constants and the random number seed. */

    s_copy(path, "Complex precision", (ftnlen)1, (ftnlen)17);
    s_copy(path + 1, "GB", (ftnlen)2, (ftnlen)2);
    nrun = 0;
    nfail = 0;
    nerrs = 0;
    for (i__ = 1; i__ <= 4; ++i__) {
	iseed[i__ - 1] = iseedy[i__ - 1];
/* L10: */
    }

/*     Test the error exits */

    if (*tsterr) {
	cerrvx_(path, nout);
    }
    infoc_1.infot = 0;

/*     Set the block size and minimum block size for testing. */

    nb = 1;
    nbmin = 2;
    xlaenv_(&c__1, &nb);
    xlaenv_(&c__2, &nbmin);

/*     Do for each value of N in NVAL */

    i__1 = *nn;
    for (in = 1; in <= i__1; ++in) {
	n = nval[in];
	ldb = max(n,1);
	*(unsigned char *)xtype = 'N';

/*        Set limits on the number of loop iterations. */

/* Computing MAX */
	i__2 = 1, i__3 = min(n,4);
	nkl = max(i__2,i__3);
	if (n == 0) {
	    nkl = 1;
	}
	nku = nkl;
	nimat = 8;
	if (n <= 0) {
	    nimat = 1;
	}

	i__2 = nkl;
	for (ikl = 1; ikl <= i__2; ++ikl) {

/*           Do for KL = 0, N-1, (3N-1)/4, and (N+1)/4. This order makes */
/*           it easier to skip redundant values for small values of N. */

	    if (ikl == 1) {
		kl = 0;
	    } else if (ikl == 2) {
/* Computing MAX */
		i__3 = n - 1;
		kl = max(i__3,0);
	    } else if (ikl == 3) {
		kl = (n * 3 - 1) / 4;
	    } else if (ikl == 4) {
		kl = (n + 1) / 4;
	    }
	    i__3 = nku;
	    for (iku = 1; iku <= i__3; ++iku) {

/*              Do for KU = 0, N-1, (3N-1)/4, and (N+1)/4. This order */
/*              makes it easier to skip redundant values for small */
/*              values of N. */

		if (iku == 1) {
		    ku = 0;
		} else if (iku == 2) {
/* Computing MAX */
		    i__4 = n - 1;
		    ku = max(i__4,0);
		} else if (iku == 3) {
		    ku = (n * 3 - 1) / 4;
		} else if (iku == 4) {
		    ku = (n + 1) / 4;
		}

/*              Check that A and AFB are big enough to generate this */
/*              matrix. */

		lda = kl + ku + 1;
		ldafb = (kl << 1) + ku + 1;
		if (lda * n > *la || ldafb * n > *lafb) {
		    if (nfail == 0 && nerrs == 0) {
			aladhd_(nout, path);
		    }
		    if (lda * n > *la) {
			io___26.ciunit = *nout;
			s_wsfe(&io___26);
			do_fio(&c__1, (char *)&(*la), (ftnlen)sizeof(integer))
				;
			do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
			do_fio(&c__1, (char *)&kl, (ftnlen)sizeof(integer));
			do_fio(&c__1, (char *)&ku, (ftnlen)sizeof(integer));
			i__4 = n * (kl + ku + 1);
			do_fio(&c__1, (char *)&i__4, (ftnlen)sizeof(integer));
			e_wsfe();
			++nerrs;
		    }
		    if (ldafb * n > *lafb) {
			io___27.ciunit = *nout;
			s_wsfe(&io___27);
			do_fio(&c__1, (char *)&(*lafb), (ftnlen)sizeof(
				integer));
			do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
			do_fio(&c__1, (char *)&kl, (ftnlen)sizeof(integer));
			do_fio(&c__1, (char *)&ku, (ftnlen)sizeof(integer));
			i__4 = n * ((kl << 1) + ku + 1);
			do_fio(&c__1, (char *)&i__4, (ftnlen)sizeof(integer));
			e_wsfe();
			++nerrs;
		    }
		    goto L130;
		}

		i__4 = nimat;
		for (imat = 1; imat <= i__4; ++imat) {

/*                 Do the tests only if DOTYPE( IMAT ) is true. */

		    if (! dotype[imat]) {
			goto L120;
		    }

/*                 Skip types 2, 3, or 4 if the matrix is too small. */

		    zerot = imat >= 2 && imat <= 4;
		    if (zerot && n < imat - 1) {
			goto L120;
		    }

/*                 Set up parameters with CLATB4 and generate a */
/*                 test matrix with CLATMS. */

		    clatb4_(path, &imat, &n, &n, type__, &kl, &ku, &anorm, &
			    mode, &cndnum, dist);
		    rcondc = 1.f / cndnum;

		    s_copy(srnamc_1.srnamt, "CLATMS", (ftnlen)32, (ftnlen)6);
		    clatms_(&n, &n, dist, iseed, type__, &rwork[1], &mode, &
			    cndnum, &anorm, &kl, &ku, "Z", &a[1], &lda, &work[
			    1], &info);

/*                 Check the error code from CLATMS. */

		    if (info != 0) {
			alaerh_(path, "CLATMS", &info, &c__0, " ", &n, &n, &
				kl, &ku, &c_n1, &imat, &nfail, &nerrs, nout);
			goto L120;
		    }

/*                 For types 2, 3, and 4, zero one or more columns of */
/*                 the matrix to test that INFO is returned correctly. */

		    izero = 0;
		    if (zerot) {
			if (imat == 2) {
			    izero = 1;
			} else if (imat == 3) {
			    izero = n;
			} else {
			    izero = n / 2 + 1;
			}
			ioff = (izero - 1) * lda;
			if (imat < 4) {
/* Computing MAX */
			    i__5 = 1, i__6 = ku + 2 - izero;
			    i1 = max(i__5,i__6);
/* Computing MIN */
			    i__5 = kl + ku + 1, i__6 = ku + 1 + (n - izero);
			    i2 = min(i__5,i__6);
			    i__5 = i2;
			    for (i__ = i1; i__ <= i__5; ++i__) {
				i__6 = ioff + i__;
				a[i__6].r = 0.f, a[i__6].i = 0.f;
/* L20: */
			    }
			} else {
			    i__5 = n;
			    for (j = izero; j <= i__5; ++j) {
/* Computing MAX */
				i__6 = 1, i__7 = ku + 2 - j;
/* Computing MIN */
				i__9 = kl + ku + 1, i__10 = ku + 1 + (n - j);
				i__8 = min(i__9,i__10);
				for (i__ = max(i__6,i__7); i__ <= i__8; ++i__)
					 {
				    i__6 = ioff + i__;
				    a[i__6].r = 0.f, a[i__6].i = 0.f;
/* L30: */
				}
				ioff += lda;
/* L40: */
			    }
			}
		    }

/*                 Save a copy of the matrix A in ASAV. */

		    i__5 = kl + ku + 1;
		    clacpy_("Full", &i__5, &n, &a[1], &lda, &asav[1], &lda);

		    for (iequed = 1; iequed <= 4; ++iequed) {
			*(unsigned char *)equed = *(unsigned char *)&equeds[
				iequed - 1];
			if (iequed == 1) {
			    nfact = 3;
			} else {
			    nfact = 1;
			}

			i__5 = nfact;
			for (ifact = 1; ifact <= i__5; ++ifact) {
			    *(unsigned char *)fact = *(unsigned char *)&facts[
				    ifact - 1];
			    prefac = lsame_(fact, "F");
			    nofact = lsame_(fact, "N");
			    equil = lsame_(fact, "E");

			    if (zerot) {
				if (prefac) {
				    goto L100;
				}
				rcondo = 0.f;
				rcondi = 0.f;

			    } else if (! nofact) {

/*                          Compute the condition number for comparison */
/*                          with the value returned by SGESVX (FACT = */
/*                          'N' reuses the condition number from the */
/*                          previous iteration with FACT = 'F'). */

				i__8 = kl + ku + 1;
				clacpy_("Full", &i__8, &n, &asav[1], &lda, &
					afb[kl + 1], &ldafb);
				if (equil || iequed > 1) {

/*                             Compute row and column scale factors to */
/*                             equilibrate the matrix A. */

				    cgbequ_(&n, &n, &kl, &ku, &afb[kl + 1], &
					    ldafb, &s[1], &s[n + 1], &rowcnd, 
					    &colcnd, &amax, &info);
				    if (info == 0 && n > 0) {
					if (lsame_(equed, "R")) {
					    rowcnd = 0.f;
					    colcnd = 1.f;
					} else if (lsame_(equed, "C")) {
					    rowcnd = 1.f;
					    colcnd = 0.f;
					} else if (lsame_(equed, "B")) {
					    rowcnd = 0.f;
					    colcnd = 0.f;
					}

/*                                Equilibrate the matrix. */

					claqgb_(&n, &n, &kl, &ku, &afb[kl + 1]
, &ldafb, &s[1], &s[n + 1], &
						rowcnd, &colcnd, &amax, equed);
				    }
				}

/*                          Save the condition number of the */
/*                          non-equilibrated system for use in CGET04. */

				if (equil) {
				    roldo = rcondo;
				    roldi = rcondi;
				}

/*                          Compute the 1-norm and infinity-norm of A. */

				anormo = clangb_("1", &n, &kl, &ku, &afb[kl + 
					1], &ldafb, &rwork[1]);
				anormi = clangb_("I", &n, &kl, &ku, &afb[kl + 
					1], &ldafb, &rwork[1]);

/*                          Factor the matrix A. */

				cgbtrf_(&n, &n, &kl, &ku, &afb[1], &ldafb, &
					iwork[1], &info);

/*                          Form the inverse of A. */

				claset_("Full", &n, &n, &c_b48, &c_b49, &work[
					1], &ldb);
				s_copy(srnamc_1.srnamt, "CGBTRS", (ftnlen)32, 
					(ftnlen)6);
				cgbtrs_("No transpose", &n, &kl, &ku, &n, &
					afb[1], &ldafb, &iwork[1], &work[1], &
					ldb, &info);

/*                          Compute the 1-norm condition number of A. */

				ainvnm = clange_("1", &n, &n, &work[1], &ldb, 
					&rwork[1]);
				if (anormo <= 0.f || ainvnm <= 0.f) {
				    rcondo = 1.f;
				} else {
				    rcondo = 1.f / anormo / ainvnm;
				}

/*                          Compute the infinity-norm condition number */
/*                          of A. */

				ainvnm = clange_("I", &n, &n, &work[1], &ldb, 
					&rwork[1]);
				if (anormi <= 0.f || ainvnm <= 0.f) {
				    rcondi = 1.f;
				} else {
				    rcondi = 1.f / anormi / ainvnm;
				}
			    }

			    for (itran = 1; itran <= 3; ++itran) {

/*                          Do for each value of TRANS. */

				*(unsigned char *)trans = *(unsigned char *)&
					transs[itran - 1];
				if (itran == 1) {
				    rcondc = rcondo;
				} else {
				    rcondc = rcondi;
				}

/*                          Restore the matrix A. */

				i__8 = kl + ku + 1;
				clacpy_("Full", &i__8, &n, &asav[1], &lda, &a[
					1], &lda);

/*                          Form an exact solution and set the right hand */
/*                          side. */

				s_copy(srnamc_1.srnamt, "CLARHS", (ftnlen)32, 
					(ftnlen)6);
				clarhs_(path, xtype, "Full", trans, &n, &n, &
					kl, &ku, nrhs, &a[1], &lda, &xact[1], 
					&ldb, &b[1], &ldb, iseed, &info);
				*(unsigned char *)xtype = 'C';
				clacpy_("Full", &n, nrhs, &b[1], &ldb, &bsav[
					1], &ldb);

				if (nofact && itran == 1) {

/*                             --- Test CGBSV  --- */

/*                             Compute the LU factorization of the matrix */
/*                             and solve the system. */

				    i__8 = kl + ku + 1;
				    clacpy_("Full", &i__8, &n, &a[1], &lda, &
					    afb[kl + 1], &ldafb);
				    clacpy_("Full", &n, nrhs, &b[1], &ldb, &x[
					    1], &ldb);

				    s_copy(srnamc_1.srnamt, "CGBSV ", (ftnlen)
					    32, (ftnlen)6);
				    cgbsv_(&n, &kl, &ku, nrhs, &afb[1], &
					    ldafb, &iwork[1], &x[1], &ldb, &
					    info);

/*                             Check error code from CGBSV . */

				    if (info != izero) {
					alaerh_(path, "CGBSV ", &info, &izero, 
						 " ", &n, &n, &kl, &ku, nrhs, 
						&imat, &nfail, &nerrs, nout);
				    }

/*                             Reconstruct matrix from factors and */
/*                             compute residual. */

				    cgbt01_(&n, &n, &kl, &ku, &a[1], &lda, &
					    afb[1], &ldafb, &iwork[1], &work[
					    1], result);
				    nt = 1;
				    if (izero == 0) {

/*                                Compute residual of the computed */
/*                                solution. */

					clacpy_("Full", &n, nrhs, &b[1], &ldb, 
						 &work[1], &ldb);
					cgbt02_("No transpose", &n, &n, &kl, &
						ku, nrhs, &a[1], &lda, &x[1], 
						&ldb, &work[1], &ldb, &result[
						1]);

/*                                Check solution from generated exact */
/*                                solution. */

					cget04_(&n, nrhs, &x[1], &ldb, &xact[
						1], &ldb, &rcondc, &result[2])
						;
					nt = 3;
				    }

/*                             Print information about the tests that did */
/*                             not pass the threshold. */

				    i__8 = nt;
				    for (k = 1; k <= i__8; ++k) {
					if (result[k - 1] >= *thresh) {
					    if (nfail == 0 && nerrs == 0) {
			  aladhd_(nout, path);
					    }
					    io___65.ciunit = *nout;
					    s_wsfe(&io___65);
					    do_fio(&c__1, "CGBSV ", (ftnlen)6)
						    ;
					    do_fio(&c__1, (char *)&n, (ftnlen)
						    sizeof(integer));
					    do_fio(&c__1, (char *)&kl, (
						    ftnlen)sizeof(integer));
					    do_fio(&c__1, (char *)&ku, (
						    ftnlen)sizeof(integer));
					    do_fio(&c__1, (char *)&imat, (
						    ftnlen)sizeof(integer));
					    do_fio(&c__1, (char *)&k, (ftnlen)
						    sizeof(integer));
					    do_fio(&c__1, (char *)&result[k - 
						    1], (ftnlen)sizeof(real));
					    e_wsfe();
					    ++nfail;
					}
/* L50: */
				    }
				    nrun += nt;
				}

/*                          --- Test CGBSVX --- */

				if (! prefac) {
				    i__8 = (kl << 1) + ku + 1;
				    claset_("Full", &i__8, &n, &c_b48, &c_b48, 
					     &afb[1], &ldafb);
				}
				claset_("Full", &n, nrhs, &c_b48, &c_b48, &x[
					1], &ldb);
				if (iequed > 1 && n > 0) {

/*                             Equilibrate the matrix if FACT = 'F' and */
/*                             EQUED = 'R', 'C', or 'B'. */

				    claqgb_(&n, &n, &kl, &ku, &a[1], &lda, &s[
					    1], &s[n + 1], &rowcnd, &colcnd, &
					    amax, equed);
				}

/*                          Solve the system and compute the condition */
/*                          number and error bounds using CGBSVX. */

				s_copy(srnamc_1.srnamt, "CGBSVX", (ftnlen)32, 
					(ftnlen)6);
				cgbsvx_(fact, trans, &n, &kl, &ku, nrhs, &a[1]
, &lda, &afb[1], &ldafb, &iwork[1], 
					equed, &s[1], &s[ldb + 1], &b[1], &
					ldb, &x[1], &ldb, &rcond, &rwork[1], &
					rwork[*nrhs + 1], &work[1], &rwork[(*
					nrhs << 1) + 1], &info);

/*                          Check the error code from CGBSVX. */

				if (info != izero) {
/* Writing concatenation */
				    i__11[0] = 1, a__1[0] = fact;
				    i__11[1] = 1, a__1[1] = trans;
				    s_cat(ch__1, a__1, i__11, &c__2, (ftnlen)
					    2);
				    alaerh_(path, "CGBSVX", &info, &izero, 
					    ch__1, &n, &n, &kl, &ku, nrhs, &
					    imat, &nfail, &nerrs, nout);
				}
/*                          Compare RWORK(2*NRHS+1) from CGBSVX with the */
/*                          computed reciprocal pivot growth RPVGRW */

				if (info != 0) {
				    anrmpv = 0.f;
				    i__8 = info;
				    for (j = 1; j <= i__8; ++j) {
/* Computing MAX */
					i__6 = ku + 2 - j;
/* Computing MIN */
					i__9 = n + ku + 1 - j, i__10 = kl + 
						ku + 1;
					i__7 = min(i__9,i__10);
					for (i__ = max(i__6,1); i__ <= i__7; 
						++i__) {
/* Computing MAX */
					    r__1 = anrmpv, r__2 = c_abs(&a[
						    i__ + (j - 1) * lda]);
					    anrmpv = dmax(r__1,r__2);
/* L60: */
					}
/* L70: */
				    }
/* Computing MIN */
				    i__7 = info - 1, i__6 = kl + ku;
				    i__8 = min(i__7,i__6);
/* Computing MAX */
				    i__9 = 1, i__10 = kl + ku + 2 - info;
				    rpvgrw = clantb_("M", "U", "N", &info, &
					    i__8, &afb[max(i__9, i__10)], &
					    ldafb, rdum);
				    if (rpvgrw == 0.f) {
					rpvgrw = 1.f;
				    } else {
					rpvgrw = anrmpv / rpvgrw;
				    }
				} else {
				    i__8 = kl + ku;
				    rpvgrw = clantb_("M", "U", "N", &n, &i__8, 
					     &afb[1], &ldafb, rdum);
				    if (rpvgrw == 0.f) {
					rpvgrw = 1.f;
				    } else {
					rpvgrw = clangb_("M", &n, &kl, &ku, &
						a[1], &lda, rdum) /
						 rpvgrw;
				    }
				}
/* Computing MAX */
				r__2 = rwork[(*nrhs << 1) + 1];
				result[6] = (r__1 = rpvgrw - rwork[(*nrhs << 
					1) + 1], dabs(r__1)) / dmax(r__2,
					rpvgrw) / slamch_("E");

				if (! prefac) {

/*                             Reconstruct matrix from factors and */
/*                             compute residual. */

				    cgbt01_(&n, &n, &kl, &ku, &a[1], &lda, &
					    afb[1], &ldafb, &iwork[1], &work[
					    1], result);
				    k1 = 1;
				} else {
				    k1 = 2;
				}

				if (info == 0) {
				    trfcon = FALSE_;

/*                             Compute residual of the computed solution. */

				    clacpy_("Full", &n, nrhs, &bsav[1], &ldb, 
					    &work[1], &ldb);
				    cgbt02_(trans, &n, &n, &kl, &ku, nrhs, &
					    asav[1], &lda, &x[1], &ldb, &work[
					    1], &ldb, &result[1]);

/*                             Check solution from generated exact */
/*                             solution. */

				    if (nofact || prefac && lsame_(equed, 
					    "N")) {
					cget04_(&n, nrhs, &x[1], &ldb, &xact[
						1], &ldb, &rcondc, &result[2])
						;
				    } else {
					if (itran == 1) {
					    roldc = roldo;
					} else {
					    roldc = roldi;
					}
					cget04_(&n, nrhs, &x[1], &ldb, &xact[
						1], &ldb, &roldc, &result[2]);
				    }

/*                             Check the error bounds from iterative */
/*                             refinement. */

				    cgbt05_(trans, &n, &kl, &ku, nrhs, &asav[
					    1], &lda, &bsav[1], &ldb, &x[1], &
					    ldb, &xact[1], &ldb, &rwork[1], &
					    rwork[*nrhs + 1], &result[3]);
				} else {
				    trfcon = TRUE_;
				}

/*                          Compare RCOND from CGBSVX with the computed */
/*                          value in RCONDC. */

				result[5] = sget06_(&rcond, &rcondc);

/*                          Print information about the tests that did */
/*                          not pass the threshold. */

				if (! trfcon) {
				    for (k = k1; k <= 7; ++k) {
					if (result[k - 1] >= *thresh) {
					    if (nfail == 0 && nerrs == 0) {
			  aladhd_(nout, path);
					    }
					    if (prefac) {
			  io___73.ciunit = *nout;
			  s_wsfe(&io___73);
			  do_fio(&c__1, "CGBSVX", (ftnlen)6);
			  do_fio(&c__1, fact, (ftnlen)1);
			  do_fio(&c__1, trans, (ftnlen)1);
			  do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
			  do_fio(&c__1, (char *)&kl, (ftnlen)sizeof(integer));
			  do_fio(&c__1, (char *)&ku, (ftnlen)sizeof(integer));
			  do_fio(&c__1, equed, (ftnlen)1);
			  do_fio(&c__1, (char *)&imat, (ftnlen)sizeof(integer)
				  );
			  do_fio(&c__1, (char *)&k, (ftnlen)sizeof(integer));
			  do_fio(&c__1, (char *)&result[k - 1], (ftnlen)
				  sizeof(real));
			  e_wsfe();
					    } else {
			  io___74.ciunit = *nout;
			  s_wsfe(&io___74);
			  do_fio(&c__1, "CGBSVX", (ftnlen)6);
			  do_fio(&c__1, fact, (ftnlen)1);
			  do_fio(&c__1, trans, (ftnlen)1);
			  do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
			  do_fio(&c__1, (char *)&kl, (ftnlen)sizeof(integer));
			  do_fio(&c__1, (char *)&ku, (ftnlen)sizeof(integer));
			  do_fio(&c__1, (char *)&imat, (ftnlen)sizeof(integer)
				  );
			  do_fio(&c__1, (char *)&k, (ftnlen)sizeof(integer));
			  do_fio(&c__1, (char *)&result[k - 1], (ftnlen)
				  sizeof(real));
			  e_wsfe();
					    }
					    ++nfail;
					}
/* L80: */
				    }
				    nrun = nrun + 7 - k1;
				} else {
				    if (result[0] >= *thresh && ! prefac) {
					if (nfail == 0 && nerrs == 0) {
					    aladhd_(nout, path);
					}
					if (prefac) {
					    io___75.ciunit = *nout;
					    s_wsfe(&io___75);
					    do_fio(&c__1, "CGBSVX", (ftnlen)6)
						    ;
					    do_fio(&c__1, fact, (ftnlen)1);
					    do_fio(&c__1, trans, (ftnlen)1);
					    do_fio(&c__1, (char *)&n, (ftnlen)
						    sizeof(integer));
					    do_fio(&c__1, (char *)&kl, (
						    ftnlen)sizeof(integer));
					    do_fio(&c__1, (char *)&ku, (
						    ftnlen)sizeof(integer));
					    do_fio(&c__1, equed, (ftnlen)1);
					    do_fio(&c__1, (char *)&imat, (
						    ftnlen)sizeof(integer));
					    do_fio(&c__1, (char *)&c__1, (
						    ftnlen)sizeof(integer));
					    do_fio(&c__1, (char *)&result[0], 
						    (ftnlen)sizeof(real));
					    e_wsfe();
					} else {
					    io___76.ciunit = *nout;
					    s_wsfe(&io___76);
					    do_fio(&c__1, "CGBSVX", (ftnlen)6)
						    ;
					    do_fio(&c__1, fact, (ftnlen)1);
					    do_fio(&c__1, trans, (ftnlen)1);
					    do_fio(&c__1, (char *)&n, (ftnlen)
						    sizeof(integer));
					    do_fio(&c__1, (char *)&kl, (
						    ftnlen)sizeof(integer));
					    do_fio(&c__1, (char *)&ku, (
						    ftnlen)sizeof(integer));
					    do_fio(&c__1, (char *)&imat, (
						    ftnlen)sizeof(integer));
					    do_fio(&c__1, (char *)&c__1, (
						    ftnlen)sizeof(integer));
					    do_fio(&c__1, (char *)&result[0], 
						    (ftnlen)sizeof(real));
					    e_wsfe();
					}
					++nfail;
					++nrun;
				    }
				    if (result[5] >= *thresh) {
					if (nfail == 0 && nerrs == 0) {
					    aladhd_(nout, path);
					}
					if (prefac) {
					    io___77.ciunit = *nout;
					    s_wsfe(&io___77);
					    do_fio(&c__1, "CGBSVX", (ftnlen)6)
						    ;
					    do_fio(&c__1, fact, (ftnlen)1);
					    do_fio(&c__1, trans, (ftnlen)1);
					    do_fio(&c__1, (char *)&n, (ftnlen)
						    sizeof(integer));
					    do_fio(&c__1, (char *)&kl, (
						    ftnlen)sizeof(integer));
					    do_fio(&c__1, (char *)&ku, (
						    ftnlen)sizeof(integer));
					    do_fio(&c__1, equed, (ftnlen)1);
					    do_fio(&c__1, (char *)&imat, (
						    ftnlen)sizeof(integer));
					    do_fio(&c__1, (char *)&c__6, (
						    ftnlen)sizeof(integer));
					    do_fio(&c__1, (char *)&result[5], 
						    (ftnlen)sizeof(real));
					    e_wsfe();
					} else {
					    io___78.ciunit = *nout;
					    s_wsfe(&io___78);
					    do_fio(&c__1, "CGBSVX", (ftnlen)6)
						    ;
					    do_fio(&c__1, fact, (ftnlen)1);
					    do_fio(&c__1, trans, (ftnlen)1);
					    do_fio(&c__1, (char *)&n, (ftnlen)
						    sizeof(integer));
					    do_fio(&c__1, (char *)&kl, (
						    ftnlen)sizeof(integer));
					    do_fio(&c__1, (char *)&ku, (
						    ftnlen)sizeof(integer));
					    do_fio(&c__1, (char *)&imat, (
						    ftnlen)sizeof(integer));
					    do_fio(&c__1, (char *)&c__6, (
						    ftnlen)sizeof(integer));
					    do_fio(&c__1, (char *)&result[5], 
						    (ftnlen)sizeof(real));
					    e_wsfe();
					}
					++nfail;
					++nrun;
				    }
				    if (result[6] >= *thresh) {
					if (nfail == 0 && nerrs == 0) {
					    aladhd_(nout, path);
					}
					if (prefac) {
					    io___79.ciunit = *nout;
					    s_wsfe(&io___79);
					    do_fio(&c__1, "CGBSVX", (ftnlen)6)
						    ;
					    do_fio(&c__1, fact, (ftnlen)1);
					    do_fio(&c__1, trans, (ftnlen)1);
					    do_fio(&c__1, (char *)&n, (ftnlen)
						    sizeof(integer));
					    do_fio(&c__1, (char *)&kl, (
						    ftnlen)sizeof(integer));
					    do_fio(&c__1, (char *)&ku, (
						    ftnlen)sizeof(integer));
					    do_fio(&c__1, equed, (ftnlen)1);
					    do_fio(&c__1, (char *)&imat, (
						    ftnlen)sizeof(integer));
					    do_fio(&c__1, (char *)&c__7, (
						    ftnlen)sizeof(integer));
					    do_fio(&c__1, (char *)&result[6], 
						    (ftnlen)sizeof(real));
					    e_wsfe();
					} else {
					    io___80.ciunit = *nout;
					    s_wsfe(&io___80);
					    do_fio(&c__1, "CGBSVX", (ftnlen)6)
						    ;
					    do_fio(&c__1, fact, (ftnlen)1);
					    do_fio(&c__1, trans, (ftnlen)1);
					    do_fio(&c__1, (char *)&n, (ftnlen)
						    sizeof(integer));
					    do_fio(&c__1, (char *)&kl, (
						    ftnlen)sizeof(integer));
					    do_fio(&c__1, (char *)&ku, (
						    ftnlen)sizeof(integer));
					    do_fio(&c__1, (char *)&imat, (
						    ftnlen)sizeof(integer));
					    do_fio(&c__1, (char *)&c__7, (
						    ftnlen)sizeof(integer));
					    do_fio(&c__1, (char *)&result[6], 
						    (ftnlen)sizeof(real));
					    e_wsfe();
					}
					++nfail;
					++nrun;
				    }
				}
/* L90: */
			    }
L100:
			    ;
			}
/* L110: */
		    }
L120:
		    ;
		}
L130:
		;
	    }
/* L140: */
	}
/* L150: */
    }

/*     Print a summary of the results. */

    alasvm_(path, nout, &nfail, &nrun, &nerrs);


    return 0;

/*     End of CDRVGB */

} /* cdrvgb_ */
示例#6
0
/* Subroutine */ int cgbcon_(char *norm, integer *n, integer *kl, integer *ku, 
	 complex *ab, integer *ldab, integer *ipiv, real *anorm, real *rcond, 
	complex *work, real *rwork, integer *info)
{
    /* System generated locals */
    integer ab_dim1, ab_offset, i__1, i__2, i__3;
    real r__1, r__2;
    complex q__1, q__2;

    /* Builtin functions */
    double r_imag(complex *);

    /* Local variables */
    integer j;
    complex t;
    integer kd, lm, jp, ix, kase, kase1;
    real scale;
    extern /* Complex */ VOID cdotc_(complex *, integer *, complex *, integer 
	    *, complex *, integer *);
    extern logical lsame_(char *, char *);
    integer isave[3];
    extern /* Subroutine */ int caxpy_(integer *, complex *, complex *, 
	    integer *, complex *, integer *);
    logical lnoti;
    extern /* Subroutine */ int clacn2_(integer *, complex *, complex *, real 
	    *, integer *, integer *);
    extern integer icamax_(integer *, complex *, integer *);
    extern doublereal slamch_(char *);
    extern /* Subroutine */ int clatbs_(char *, char *, char *, char *, 
	    integer *, integer *, complex *, integer *, complex *, real *, 
	    real *, integer *), xerbla_(char *
, integer *);
    real ainvnm;
    extern /* Subroutine */ int csrscl_(integer *, real *, complex *, integer 
	    *);
    logical onenrm;
    char normin[1];
    real smlnum;


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

/*     Modified to call CLACN2 in place of CLACON, 10 Feb 03, SJH. */

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

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

/*  CGBCON estimates the reciprocal of the condition number of a complex */
/*  general band matrix A, in either the 1-norm or the infinity-norm, */
/*  using the LU factorization computed by CGBTRF. */

/*  An estimate is obtained for norm(inv(A)), and the reciprocal of the */
/*  condition number is computed as */
/*     RCOND = 1 / ( norm(A) * norm(inv(A)) ). */

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

/*  NORM    (input) CHARACTER*1 */
/*          Specifies whether the 1-norm condition number or the */
/*          infinity-norm condition number is required: */
/*          = '1' or 'O':  1-norm; */
/*          = 'I':         Infinity-norm. */

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

/*  KL      (input) INTEGER */
/*          The number of subdiagonals within the band of A.  KL >= 0. */

/*  KU      (input) INTEGER */
/*          The number of superdiagonals within the band of A.  KU >= 0. */

/*  AB      (input) COMPLEX array, dimension (LDAB,N) */
/*          Details of the LU factorization of the band matrix A, as */
/*          computed by CGBTRF.  U is stored as an upper triangular band */
/*          matrix with KL+KU superdiagonals in rows 1 to KL+KU+1, and */
/*          the multipliers used during the factorization are stored in */
/*          rows KL+KU+2 to 2*KL+KU+1. */

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

/*  IPIV    (input) INTEGER array, dimension (N) */
/*          The pivot indices; for 1 <= i <= N, row i of the matrix was */
/*          interchanged with row IPIV(i). */

/*  ANORM   (input) REAL */
/*          If NORM = '1' or 'O', the 1-norm of the original matrix A. */
/*          If NORM = 'I', the infinity-norm of the original matrix A. */

/*  RCOND   (output) REAL */
/*          The reciprocal of the condition number of the matrix A, */
/*          computed as RCOND = 1/(norm(A) * norm(inv(A))). */

/*  WORK    (workspace) COMPLEX array, dimension (2*N) */

/*  RWORK   (workspace) REAL array, dimension (N) */

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

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

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

/*     Test the input parameters. */

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

    /* Function Body */
    *info = 0;
    onenrm = *(unsigned char *)norm == '1' || lsame_(norm, "O");
    if (! onenrm && ! lsame_(norm, "I")) {
	*info = -1;
    } else if (*n < 0) {
	*info = -2;
    } else if (*kl < 0) {
	*info = -3;
    } else if (*ku < 0) {
	*info = -4;
    } else if (*ldab < (*kl << 1) + *ku + 1) {
	*info = -6;
    } else if (*anorm < 0.f) {
	*info = -8;
    }
    if (*info != 0) {
	i__1 = -(*info);
	xerbla_("CGBCON", &i__1);
	return 0;
    }

/*     Quick return if possible */

    *rcond = 0.f;
    if (*n == 0) {
	*rcond = 1.f;
	return 0;
    } else if (*anorm == 0.f) {
	return 0;
    }

    smlnum = slamch_("Safe minimum");

/*     Estimate the norm of inv(A). */

    ainvnm = 0.f;
    *(unsigned char *)normin = 'N';
    if (onenrm) {
	kase1 = 1;
    } else {
	kase1 = 2;
    }
    kd = *kl + *ku + 1;
    lnoti = *kl > 0;
    kase = 0;
L10:
    clacn2_(n, &work[*n + 1], &work[1], &ainvnm, &kase, isave);
    if (kase != 0) {
	if (kase == kase1) {

/*           Multiply by inv(L). */

	    if (lnoti) {
		i__1 = *n - 1;
		for (j = 1; j <= i__1; ++j) {
/* Computing MIN */
		    i__2 = *kl, i__3 = *n - j;
		    lm = min(i__2,i__3);
		    jp = ipiv[j];
		    i__2 = jp;
		    t.r = work[i__2].r, t.i = work[i__2].i;
		    if (jp != j) {
			i__2 = jp;
			i__3 = j;
			work[i__2].r = work[i__3].r, work[i__2].i = work[i__3]
				.i;
			i__2 = j;
			work[i__2].r = t.r, work[i__2].i = t.i;
		    }
		    q__1.r = -t.r, q__1.i = -t.i;
		    caxpy_(&lm, &q__1, &ab[kd + 1 + j * ab_dim1], &c__1, &
			    work[j + 1], &c__1);
/* L20: */
		}
	    }

/*           Multiply by inv(U). */

	    i__1 = *kl + *ku;
	    clatbs_("Upper", "No transpose", "Non-unit", normin, n, &i__1, &
		    ab[ab_offset], ldab, &work[1], &scale, &rwork[1], info);
	} else {

/*           Multiply by inv(U'). */

	    i__1 = *kl + *ku;
	    clatbs_("Upper", "Conjugate transpose", "Non-unit", normin, n, &
		    i__1, &ab[ab_offset], ldab, &work[1], &scale, &rwork[1], 
		    info);

/*           Multiply by inv(L'). */

	    if (lnoti) {
		for (j = *n - 1; j >= 1; --j) {
/* Computing MIN */
		    i__1 = *kl, i__2 = *n - j;
		    lm = min(i__1,i__2);
		    i__1 = j;
		    i__2 = j;
		    cdotc_(&q__2, &lm, &ab[kd + 1 + j * ab_dim1], &c__1, &
			    work[j + 1], &c__1);
		    q__1.r = work[i__2].r - q__2.r, q__1.i = work[i__2].i - 
			    q__2.i;
		    work[i__1].r = q__1.r, work[i__1].i = q__1.i;
		    jp = ipiv[j];
		    if (jp != j) {
			i__1 = jp;
			t.r = work[i__1].r, t.i = work[i__1].i;
			i__1 = jp;
			i__2 = j;
			work[i__1].r = work[i__2].r, work[i__1].i = work[i__2]
				.i;
			i__1 = j;
			work[i__1].r = t.r, work[i__1].i = t.i;
		    }
/* L30: */
		}
	    }
	}

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

	*(unsigned char *)normin = 'Y';
	if (scale != 1.f) {
	    ix = icamax_(n, &work[1], &c__1);
	    i__1 = ix;
	    if (scale < ((r__1 = work[i__1].r, dabs(r__1)) + (r__2 = r_imag(&
		    work[ix]), dabs(r__2))) * smlnum || scale == 0.f) {
		goto L40;
	    }
	    csrscl_(n, &scale, &work[1], &c__1);
	}
	goto L10;
    }

/*     Compute the estimate of the reciprocal condition number. */

    if (ainvnm != 0.f) {
	*rcond = 1.f / ainvnm / *anorm;
    }

L40:
    return 0;

/*     End of CGBCON */

} /* cgbcon_ */
示例#7
0
文件: ctgsja.c 项目: dacap/loseface
/* Subroutine */ int ctgsja_(char *jobu, char *jobv, char *jobq, integer *m, 
	integer *p, integer *n, integer *k, integer *l, complex *a, integer *
	lda, complex *b, integer *ldb, real *tola, real *tolb, real *alpha, 
	real *beta, complex *u, integer *ldu, complex *v, integer *ldv, 
	complex *q, integer *ldq, complex *work, integer *ncycle, integer *
	info)
{
    /* System generated locals */
    integer a_dim1, a_offset, b_dim1, b_offset, q_dim1, q_offset, u_dim1, 
	    u_offset, v_dim1, v_offset, i__1, i__2, i__3, i__4;
    real r__1;
    complex q__1;

    /* Builtin functions */
    void r_cnjg(complex *, complex *);

    /* Local variables */
    integer i__, j;
    real a1, b1, a3, b3;
    complex a2, b2;
    real csq, csu, csv;
    complex snq;
    real rwk;
    complex snu, snv;
    extern /* Subroutine */ int crot_(integer *, complex *, integer *, 
	    complex *, integer *, real *, complex *);
    real gamma;
    extern logical lsame_(char *, char *);
    extern /* Subroutine */ int ccopy_(integer *, complex *, integer *, 
	    complex *, integer *);
    logical initq, initu, initv, wantq, upper;
    real error, ssmin;
    logical wantu, wantv;
    extern /* Subroutine */ int clags2_(logical *, real *, complex *, real *, 
	    real *, complex *, real *, real *, complex *, real *, complex *, 
	    real *, complex *), clapll_(integer *, complex *, integer *, 
	    complex *, integer *, real *), csscal_(integer *, real *, complex 
	    *, integer *);
    integer kcycle;
    extern /* Subroutine */ int claset_(char *, integer *, integer *, complex 
	    *, complex *, complex *, integer *), xerbla_(char *, 
	    integer *), slartg_(real *, real *, real *, real *, real *
);


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

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

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

/*  CTGSJA computes the generalized singular value decomposition (GSVD) */
/*  of two complex upper triangular (or trapezoidal) matrices A and B. */

/*  On entry, it is assumed that matrices A and B have the following */
/*  forms, which may be obtained by the preprocessing subroutine CGGSVP */
/*  from a general M-by-N matrix A and P-by-N matrix B: */

/*               N-K-L  K    L */
/*     A =    K ( 0    A12  A13 ) if M-K-L >= 0; */
/*            L ( 0     0   A23 ) */
/*        M-K-L ( 0     0    0  ) */

/*             N-K-L  K    L */
/*     A =  K ( 0    A12  A13 ) if M-K-L < 0; */
/*        M-K ( 0     0   A23 ) */

/*             N-K-L  K    L */
/*     B =  L ( 0     0   B13 ) */
/*        P-L ( 0     0    0  ) */

/*  where the K-by-K matrix A12 and L-by-L matrix B13 are nonsingular */
/*  upper triangular; A23 is L-by-L upper triangular if M-K-L >= 0, */
/*  otherwise A23 is (M-K)-by-L upper trapezoidal. */

/*  On exit, */

/*         U'*A*Q = D1*( 0 R ),    V'*B*Q = D2*( 0 R ), */

/*  where U, V and Q are unitary matrices, Z' denotes the conjugate */
/*  transpose of Z, R is a nonsingular upper triangular matrix, and D1 */
/*  and D2 are ``diagonal'' matrices, which are of the following */
/*  structures: */

/*  If M-K-L >= 0, */

/*                      K  L */
/*         D1 =     K ( I  0 ) */
/*                  L ( 0  C ) */
/*              M-K-L ( 0  0 ) */

/*                     K  L */
/*         D2 = L   ( 0  S ) */
/*              P-L ( 0  0 ) */

/*                 N-K-L  K    L */
/*    ( 0 R ) = K (  0   R11  R12 ) K */
/*              L (  0    0   R22 ) L */

/*  where */

/*    C = diag( ALPHA(K+1), ... , ALPHA(K+L) ), */
/*    S = diag( BETA(K+1),  ... , BETA(K+L) ), */
/*    C**2 + S**2 = I. */

/*    R is stored in A(1:K+L,N-K-L+1:N) on exit. */

/*  If M-K-L < 0, */

/*                 K M-K K+L-M */
/*      D1 =   K ( I  0    0   ) */
/*           M-K ( 0  C    0   ) */

/*                   K M-K K+L-M */
/*      D2 =   M-K ( 0  S    0   ) */
/*           K+L-M ( 0  0    I   ) */
/*             P-L ( 0  0    0   ) */

/*                 N-K-L  K   M-K  K+L-M */
/* ( 0 R ) =    K ( 0    R11  R12  R13  ) */
/*            M-K ( 0     0   R22  R23  ) */
/*          K+L-M ( 0     0    0   R33  ) */

/*  where */
/*  C = diag( ALPHA(K+1), ... , ALPHA(M) ), */
/*  S = diag( BETA(K+1),  ... , BETA(M) ), */
/*  C**2 + S**2 = I. */

/*  R = ( R11 R12 R13 ) is stored in A(1:M, N-K-L+1:N) and R33 is stored */
/*      (  0  R22 R23 ) */
/*  in B(M-K+1:L,N+M-K-L+1:N) on exit. */

/*  The computation of the unitary transformation matrices U, V or Q */
/*  is optional.  These matrices may either be formed explicitly, or they */
/*  may be postmultiplied into input matrices U1, V1, or Q1. */

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

/*  JOBU    (input) CHARACTER*1 */
/*          = 'U':  U must contain a unitary matrix U1 on entry, and */
/*                  the product U1*U is returned; */
/*          = 'I':  U is initialized to the unit matrix, and the */
/*                  unitary matrix U is returned; */
/*          = 'N':  U is not computed. */

/*  JOBV    (input) CHARACTER*1 */
/*          = 'V':  V must contain a unitary matrix V1 on entry, and */
/*                  the product V1*V is returned; */
/*          = 'I':  V is initialized to the unit matrix, and the */
/*                  unitary matrix V is returned; */
/*          = 'N':  V is not computed. */

/*  JOBQ    (input) CHARACTER*1 */
/*          = 'Q':  Q must contain a unitary matrix Q1 on entry, and */
/*                  the product Q1*Q is returned; */
/*          = 'I':  Q is initialized to the unit matrix, and the */
/*                  unitary matrix Q is returned; */
/*          = 'N':  Q is not computed. */

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

/*  P       (input) INTEGER */
/*          The number of rows of the matrix B.  P >= 0. */

/*  N       (input) INTEGER */
/*          The number of columns of the matrices A and B.  N >= 0. */

/*  K       (input) INTEGER */
/*  L       (input) INTEGER */
/*          K and L specify the subblocks in the input matrices A and B: */
/*          A23 = A(K+1:MIN(K+L,M),N-L+1:N) and B13 = B(1:L,,N-L+1:N) */
/*          of A and B, whose GSVD is going to be computed by CTGSJA. */
/*          See Further details. */

/*  A       (input/output) COMPLEX array, dimension (LDA,N) */
/*          On entry, the M-by-N matrix A. */
/*          On exit, A(N-K+1:N,1:MIN(K+L,M) ) contains the triangular */
/*          matrix R or part of R.  See Purpose for details. */

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

/*  B       (input/output) COMPLEX array, dimension (LDB,N) */
/*          On entry, the P-by-N matrix B. */
/*          On exit, if necessary, B(M-K+1:L,N+M-K-L+1:N) contains */
/*          a part of R.  See Purpose for details. */

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

/*  TOLA    (input) REAL */
/*  TOLB    (input) REAL */
/*          TOLA and TOLB are the convergence criteria for the Jacobi- */
/*          Kogbetliantz iteration procedure. Generally, they are the */
/*          same as used in the preprocessing step, say */
/*              TOLA = MAX(M,N)*norm(A)*MACHEPS, */
/*              TOLB = MAX(P,N)*norm(B)*MACHEPS. */

/*  ALPHA   (output) REAL array, dimension (N) */
/*  BETA    (output) REAL array, dimension (N) */
/*          On exit, ALPHA and BETA contain the generalized singular */
/*          value pairs of A and B; */
/*            ALPHA(1:K) = 1, */
/*            BETA(1:K)  = 0, */
/*          and if M-K-L >= 0, */
/*            ALPHA(K+1:K+L) = diag(C), */
/*            BETA(K+1:K+L)  = diag(S), */
/*          or if M-K-L < 0, */
/*            ALPHA(K+1:M)= C, ALPHA(M+1:K+L)= 0 */
/*            BETA(K+1:M) = S, BETA(M+1:K+L) = 1. */
/*          Furthermore, if K+L < N, */
/*            ALPHA(K+L+1:N) = 0 */
/*            BETA(K+L+1:N)  = 0. */

/*  U       (input/output) COMPLEX array, dimension (LDU,M) */
/*          On entry, if JOBU = 'U', U must contain a matrix U1 (usually */
/*          the unitary matrix returned by CGGSVP). */
/*          On exit, */
/*          if JOBU = 'I', U contains the unitary matrix U; */
/*          if JOBU = 'U', U contains the product U1*U. */
/*          If JOBU = 'N', U is not referenced. */

/*  LDU     (input) INTEGER */
/*          The leading dimension of the array U. LDU >= max(1,M) if */
/*          JOBU = 'U'; LDU >= 1 otherwise. */

/*  V       (input/output) COMPLEX array, dimension (LDV,P) */
/*          On entry, if JOBV = 'V', V must contain a matrix V1 (usually */
/*          the unitary matrix returned by CGGSVP). */
/*          On exit, */
/*          if JOBV = 'I', V contains the unitary matrix V; */
/*          if JOBV = 'V', V contains the product V1*V. */
/*          If JOBV = 'N', V is not referenced. */

/*  LDV     (input) INTEGER */
/*          The leading dimension of the array V. LDV >= max(1,P) if */
/*          JOBV = 'V'; LDV >= 1 otherwise. */

/*  Q       (input/output) COMPLEX array, dimension (LDQ,N) */
/*          On entry, if JOBQ = 'Q', Q must contain a matrix Q1 (usually */
/*          the unitary matrix returned by CGGSVP). */
/*          On exit, */
/*          if JOBQ = 'I', Q contains the unitary matrix Q; */
/*          if JOBQ = 'Q', Q contains the product Q1*Q. */
/*          If JOBQ = 'N', Q is not referenced. */

/*  LDQ     (input) INTEGER */
/*          The leading dimension of the array Q. LDQ >= max(1,N) if */
/*          JOBQ = 'Q'; LDQ >= 1 otherwise. */

/*  WORK    (workspace) COMPLEX array, dimension (2*N) */

/*  NCYCLE  (output) INTEGER */
/*          The number of cycles required for convergence. */

/*  INFO    (output) INTEGER */
/*          = 0:  successful exit */
/*          < 0:  if INFO = -i, the i-th argument had an illegal value. */
/*          = 1:  the procedure does not converge after MAXIT cycles. */

/*  Internal Parameters */
/*  =================== */

/*  MAXIT   INTEGER */
/*          MAXIT specifies the total loops that the iterative procedure */
/*          may take. If after MAXIT cycles, the routine fails to */
/*          converge, we return INFO = 1. */

/*  Further Details */
/*  =============== */

/*  CTGSJA essentially uses a variant of Kogbetliantz algorithm to reduce */
/*  min(L,M-K)-by-L triangular (or trapezoidal) matrix A23 and L-by-L */
/*  matrix B13 to the form: */

/*           U1'*A13*Q1 = C1*R1; V1'*B13*Q1 = S1*R1, */

/*  where U1, V1 and Q1 are unitary matrix, and Z' is the conjugate */
/*  transpose of Z.  C1 and S1 are diagonal matrices satisfying */

/*                C1**2 + S1**2 = I, */

/*  and R1 is an L-by-L nonsingular upper triangular matrix. */

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

/*     .. Parameters .. */
/*     .. */
/*     .. Local Scalars .. */

/*     .. */
/*     .. External Functions .. */
/*     .. */
/*     .. External Subroutines .. */
/*     .. */
/*     .. Intrinsic Functions .. */
/*     .. */
/*     .. Executable Statements .. */

/*     Decode and test the input parameters */

    /* 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;
    u_dim1 = *ldu;
    u_offset = 1 + u_dim1;
    u -= u_offset;
    v_dim1 = *ldv;
    v_offset = 1 + v_dim1;
    v -= v_offset;
    q_dim1 = *ldq;
    q_offset = 1 + q_dim1;
    q -= q_offset;
    --work;

    /* Function Body */
    initu = lsame_(jobu, "I");
    wantu = initu || lsame_(jobu, "U");

    initv = lsame_(jobv, "I");
    wantv = initv || lsame_(jobv, "V");

    initq = lsame_(jobq, "I");
    wantq = initq || lsame_(jobq, "Q");

    *info = 0;
    if (! (initu || wantu || lsame_(jobu, "N"))) {
	*info = -1;
    } else if (! (initv || wantv || lsame_(jobv, "N"))) 
	    {
	*info = -2;
    } else if (! (initq || wantq || lsame_(jobq, "N"))) 
	    {
	*info = -3;
    } else if (*m < 0) {
	*info = -4;
    } else if (*p < 0) {
	*info = -5;
    } else if (*n < 0) {
	*info = -6;
    } else if (*lda < max(1,*m)) {
	*info = -10;
    } else if (*ldb < max(1,*p)) {
	*info = -12;
    } else if (*ldu < 1 || wantu && *ldu < *m) {
	*info = -18;
    } else if (*ldv < 1 || wantv && *ldv < *p) {
	*info = -20;
    } else if (*ldq < 1 || wantq && *ldq < *n) {
	*info = -22;
    }
    if (*info != 0) {
	i__1 = -(*info);
	xerbla_("CTGSJA", &i__1);
	return 0;
    }

/*     Initialize U, V and Q, if necessary */

    if (initu) {
	claset_("Full", m, m, &c_b1, &c_b2, &u[u_offset], ldu);
    }
    if (initv) {
	claset_("Full", p, p, &c_b1, &c_b2, &v[v_offset], ldv);
    }
    if (initq) {
	claset_("Full", n, n, &c_b1, &c_b2, &q[q_offset], ldq);
    }

/*     Loop until convergence */

    upper = FALSE_;
    for (kcycle = 1; kcycle <= 40; ++kcycle) {

	upper = ! upper;

	i__1 = *l - 1;
	for (i__ = 1; i__ <= i__1; ++i__) {
	    i__2 = *l;
	    for (j = i__ + 1; j <= i__2; ++j) {

		a1 = 0.f;
		a2.r = 0.f, a2.i = 0.f;
		a3 = 0.f;
		if (*k + i__ <= *m) {
		    i__3 = *k + i__ + (*n - *l + i__) * a_dim1;
		    a1 = a[i__3].r;
		}
		if (*k + j <= *m) {
		    i__3 = *k + j + (*n - *l + j) * a_dim1;
		    a3 = a[i__3].r;
		}

		i__3 = i__ + (*n - *l + i__) * b_dim1;
		b1 = b[i__3].r;
		i__3 = j + (*n - *l + j) * b_dim1;
		b3 = b[i__3].r;

		if (upper) {
		    if (*k + i__ <= *m) {
			i__3 = *k + i__ + (*n - *l + j) * a_dim1;
			a2.r = a[i__3].r, a2.i = a[i__3].i;
		    }
		    i__3 = i__ + (*n - *l + j) * b_dim1;
		    b2.r = b[i__3].r, b2.i = b[i__3].i;
		} else {
		    if (*k + j <= *m) {
			i__3 = *k + j + (*n - *l + i__) * a_dim1;
			a2.r = a[i__3].r, a2.i = a[i__3].i;
		    }
		    i__3 = j + (*n - *l + i__) * b_dim1;
		    b2.r = b[i__3].r, b2.i = b[i__3].i;
		}

		clags2_(&upper, &a1, &a2, &a3, &b1, &b2, &b3, &csu, &snu, &
			csv, &snv, &csq, &snq);

/*              Update (K+I)-th and (K+J)-th rows of matrix A: U'*A */

		if (*k + j <= *m) {
		    r_cnjg(&q__1, &snu);
		    crot_(l, &a[*k + j + (*n - *l + 1) * a_dim1], lda, &a[*k 
			    + i__ + (*n - *l + 1) * a_dim1], lda, &csu, &q__1)
			    ;
		}

/*              Update I-th and J-th rows of matrix B: V'*B */

		r_cnjg(&q__1, &snv);
		crot_(l, &b[j + (*n - *l + 1) * b_dim1], ldb, &b[i__ + (*n - *
			l + 1) * b_dim1], ldb, &csv, &q__1);

/*              Update (N-L+I)-th and (N-L+J)-th columns of matrices */
/*              A and B: A*Q and B*Q */

/* Computing MIN */
		i__4 = *k + *l;
		i__3 = min(i__4,*m);
		crot_(&i__3, &a[(*n - *l + j) * a_dim1 + 1], &c__1, &a[(*n - *
			l + i__) * a_dim1 + 1], &c__1, &csq, &snq);

		crot_(l, &b[(*n - *l + j) * b_dim1 + 1], &c__1, &b[(*n - *l + 
			i__) * b_dim1 + 1], &c__1, &csq, &snq);

		if (upper) {
		    if (*k + i__ <= *m) {
			i__3 = *k + i__ + (*n - *l + j) * a_dim1;
			a[i__3].r = 0.f, a[i__3].i = 0.f;
		    }
		    i__3 = i__ + (*n - *l + j) * b_dim1;
		    b[i__3].r = 0.f, b[i__3].i = 0.f;
		} else {
		    if (*k + j <= *m) {
			i__3 = *k + j + (*n - *l + i__) * a_dim1;
			a[i__3].r = 0.f, a[i__3].i = 0.f;
		    }
		    i__3 = j + (*n - *l + i__) * b_dim1;
		    b[i__3].r = 0.f, b[i__3].i = 0.f;
		}

/*              Ensure that the diagonal elements of A and B are real. */

		if (*k + i__ <= *m) {
		    i__3 = *k + i__ + (*n - *l + i__) * a_dim1;
		    i__4 = *k + i__ + (*n - *l + i__) * a_dim1;
		    r__1 = a[i__4].r;
		    a[i__3].r = r__1, a[i__3].i = 0.f;
		}
		if (*k + j <= *m) {
		    i__3 = *k + j + (*n - *l + j) * a_dim1;
		    i__4 = *k + j + (*n - *l + j) * a_dim1;
		    r__1 = a[i__4].r;
		    a[i__3].r = r__1, a[i__3].i = 0.f;
		}
		i__3 = i__ + (*n - *l + i__) * b_dim1;
		i__4 = i__ + (*n - *l + i__) * b_dim1;
		r__1 = b[i__4].r;
		b[i__3].r = r__1, b[i__3].i = 0.f;
		i__3 = j + (*n - *l + j) * b_dim1;
		i__4 = j + (*n - *l + j) * b_dim1;
		r__1 = b[i__4].r;
		b[i__3].r = r__1, b[i__3].i = 0.f;

/*              Update unitary matrices U, V, Q, if desired. */

		if (wantu && *k + j <= *m) {
		    crot_(m, &u[(*k + j) * u_dim1 + 1], &c__1, &u[(*k + i__) *
			     u_dim1 + 1], &c__1, &csu, &snu);
		}

		if (wantv) {
		    crot_(p, &v[j * v_dim1 + 1], &c__1, &v[i__ * v_dim1 + 1], 
			    &c__1, &csv, &snv);
		}

		if (wantq) {
		    crot_(n, &q[(*n - *l + j) * q_dim1 + 1], &c__1, &q[(*n - *
			    l + i__) * q_dim1 + 1], &c__1, &csq, &snq);
		}

/* L10: */
	    }
/* L20: */
	}

	if (! upper) {

/*           The matrices A13 and B13 were lower triangular at the start */
/*           of the cycle, and are now upper triangular. */

/*           Convergence test: test the parallelism of the corresponding */
/*           rows of A and B. */

	    error = 0.f;
/* Computing MIN */
	    i__2 = *l, i__3 = *m - *k;
	    i__1 = min(i__2,i__3);
	    for (i__ = 1; i__ <= i__1; ++i__) {
		i__2 = *l - i__ + 1;
		ccopy_(&i__2, &a[*k + i__ + (*n - *l + i__) * a_dim1], lda, &
			work[1], &c__1);
		i__2 = *l - i__ + 1;
		ccopy_(&i__2, &b[i__ + (*n - *l + i__) * b_dim1], ldb, &work[*
			l + 1], &c__1);
		i__2 = *l - i__ + 1;
		clapll_(&i__2, &work[1], &c__1, &work[*l + 1], &c__1, &ssmin);
		error = dmax(error,ssmin);
/* L30: */
	    }

	    if (dabs(error) <= dmin(*tola,*tolb)) {
		goto L50;
	    }
	}

/*        End of cycle loop */

/* L40: */
    }

/*     The algorithm has not converged after MAXIT cycles. */

    *info = 1;
    goto L100;

L50:

/*     If ERROR <= MIN(TOLA,TOLB), then the algorithm has converged. */
/*     Compute the generalized singular value pairs (ALPHA, BETA), and */
/*     set the triangular matrix R to array A. */

    i__1 = *k;
    for (i__ = 1; i__ <= i__1; ++i__) {
	alpha[i__] = 1.f;
	beta[i__] = 0.f;
/* L60: */
    }

/* Computing MIN */
    i__2 = *l, i__3 = *m - *k;
    i__1 = min(i__2,i__3);
    for (i__ = 1; i__ <= i__1; ++i__) {

	i__2 = *k + i__ + (*n - *l + i__) * a_dim1;
	a1 = a[i__2].r;
	i__2 = i__ + (*n - *l + i__) * b_dim1;
	b1 = b[i__2].r;

	if (a1 != 0.f) {
	    gamma = b1 / a1;

	    if (gamma < 0.f) {
		i__2 = *l - i__ + 1;
		csscal_(&i__2, &c_b39, &b[i__ + (*n - *l + i__) * b_dim1], 
			ldb);
		if (wantv) {
		    csscal_(p, &c_b39, &v[i__ * v_dim1 + 1], &c__1);
		}
	    }

	    r__1 = dabs(gamma);
	    slartg_(&r__1, &c_b42, &beta[*k + i__], &alpha[*k + i__], &rwk);

	    if (alpha[*k + i__] >= beta[*k + i__]) {
		i__2 = *l - i__ + 1;
		r__1 = 1.f / alpha[*k + i__];
		csscal_(&i__2, &r__1, &a[*k + i__ + (*n - *l + i__) * a_dim1], 
			 lda);
	    } else {
		i__2 = *l - i__ + 1;
		r__1 = 1.f / beta[*k + i__];
		csscal_(&i__2, &r__1, &b[i__ + (*n - *l + i__) * b_dim1], ldb)
			;
		i__2 = *l - i__ + 1;
		ccopy_(&i__2, &b[i__ + (*n - *l + i__) * b_dim1], ldb, &a[*k 
			+ i__ + (*n - *l + i__) * a_dim1], lda);
	    }

	} else {
	    alpha[*k + i__] = 0.f;
	    beta[*k + i__] = 1.f;
	    i__2 = *l - i__ + 1;
	    ccopy_(&i__2, &b[i__ + (*n - *l + i__) * b_dim1], ldb, &a[*k + 
		    i__ + (*n - *l + i__) * a_dim1], lda);
	}
/* L70: */
    }

/*     Post-assignment */

    i__1 = *k + *l;
    for (i__ = *m + 1; i__ <= i__1; ++i__) {
	alpha[i__] = 0.f;
	beta[i__] = 1.f;
/* L80: */
    }

    if (*k + *l < *n) {
	i__1 = *n;
	for (i__ = *k + *l + 1; i__ <= i__1; ++i__) {
	    alpha[i__] = 0.f;
	    beta[i__] = 0.f;
/* L90: */
	}
    }

L100:
    *ncycle = kcycle;

    return 0;

/*     End of CTGSJA */

} /* ctgsja_ */
示例#8
0
/* Subroutine */ int cpbrfs_(char *uplo, integer *n, integer *kd, integer *
	nrhs, complex *ab, integer *ldab, complex *afb, integer *ldafb, 
	complex *b, integer *ldb, complex *x, integer *ldx, real *ferr, real *
	berr, complex *work, real *rwork, integer *info)
{
/*  -- LAPACK routine (version 2.0) --   
       Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,   
       Courant Institute, Argonne National Lab, and Rice University   
       September 30, 1994   


    Purpose   
    =======   

    CPBRFS improves the computed solution to a system of linear   
    equations when the coefficient matrix is Hermitian positive definite 
  
    and banded, and provides error bounds and backward error estimates   
    for the solution.   

    Arguments   
    =========   

    UPLO    (input) CHARACTER*1   
            = 'U':  Upper triangle of A is stored;   
            = 'L':  Lower triangle of A is stored.   

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

    KD      (input) INTEGER   
            The number of superdiagonals of the matrix A if UPLO = 'U',   
            or the number of subdiagonals if UPLO = 'L'.  KD >= 0.   

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

    AB      (input) REAL array, dimension (LDAB,N)   
            The upper or lower triangle of the Hermitian 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.   

    AFB     (input) COMPLEX array, dimension (LDAFB,N)   
            The triangular factor U or L from the Cholesky factorization 
  
            A = U**H*U or A = L*L**H of the band matrix A as computed by 
  
            CPBTRF, in the same storage format as A (see AB).   

    LDAFB   (input) INTEGER   
            The leading dimension of the array AFB.  LDAFB >= KD+1.   

    B       (input) COMPLEX array, dimension (LDB,NRHS)   
            The right hand side matrix B.   

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

    X       (input/output) COMPLEX array, dimension (LDX,NRHS)   
            On entry, the solution matrix X, as computed by CPBTRS.   
            On exit, the improved solution matrix X.   

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

    FERR    (output) REAL array, dimension (NRHS)   
            The estimated forward error bound for each solution vector   
            X(j) (the j-th column of the solution matrix X).   
            If XTRUE is the true solution corresponding to X(j), FERR(j) 
  
            is an estimated upper bound for the magnitude of the largest 
  
            element in (X(j) - XTRUE) divided by the magnitude of the   
            largest element in X(j).  The estimate is as reliable as   
            the estimate for RCOND, and is almost always a slight   
            overestimate of the true error.   

    BERR    (output) REAL array, dimension (NRHS)   
            The componentwise relative backward error of each solution   
            vector X(j) (i.e., the smallest relative change in   
            any element of A or B that makes X(j) an exact solution).   

    WORK    (workspace) COMPLEX array, dimension (2*N)   

    RWORK   (workspace) REAL array, dimension (N)   

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

    Internal Parameters   
    ===================   

    ITMAX is the maximum number of steps of iterative refinement.   

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


       Test the input parameters.   

    
   Parameter adjustments   
       Function Body */
    /* Table of constant values */
    static complex c_b1 = {1.f,0.f};
    static integer c__1 = 1;
    
    /* System generated locals */
    integer ab_dim1, ab_offset, afb_dim1, afb_offset, b_dim1, b_offset, 
	    x_dim1, x_offset, i__1, i__2, i__3, i__4, i__5;
    real r__1, r__2, r__3, r__4;
    complex q__1;
    /* Builtin functions */
    double r_imag(complex *);
    /* Local variables */
    static integer kase;
    static real safe1, safe2;
    static integer i, j, k, l;
    static real s;
    extern /* Subroutine */ int chbmv_(char *, integer *, integer *, complex *
	    , complex *, integer *, complex *, integer *, complex *, complex *
	    , integer *);
    extern logical lsame_(char *, char *);
    extern /* Subroutine */ int ccopy_(integer *, complex *, integer *, 
	    complex *, integer *), caxpy_(integer *, complex *, complex *, 
	    integer *, complex *, integer *);
    static integer count;
    static logical upper;
    extern /* Subroutine */ int clacon_(integer *, complex *, complex *, real 
	    *, integer *);
    static real xk;
    extern doublereal slamch_(char *);
    static integer nz;
    static real safmin;
    extern /* Subroutine */ int xerbla_(char *, integer *), cpbtrs_(
	    char *, integer *, integer *, integer *, complex *, integer *, 
	    complex *, integer *, integer *);
    static real lstres, eps;



#define FERR(I) ferr[(I)-1]
#define BERR(I) berr[(I)-1]
#define WORK(I) work[(I)-1]
#define RWORK(I) rwork[(I)-1]

#define AB(I,J) ab[(I)-1 + ((J)-1)* ( *ldab)]
#define AFB(I,J) afb[(I)-1 + ((J)-1)* ( *ldafb)]
#define B(I,J) b[(I)-1 + ((J)-1)* ( *ldb)]
#define X(I,J) x[(I)-1 + ((J)-1)* ( *ldx)]

    *info = 0;
    upper = lsame_(uplo, "U");
    if (! upper && ! lsame_(uplo, "L")) {
	*info = -1;
    } else if (*n < 0) {
	*info = -2;
    } else if (*kd < 0) {
	*info = -3;
    } else if (*nrhs < 0) {
	*info = -4;
    } else if (*ldab < *kd + 1) {
	*info = -6;
    } else if (*ldafb < *kd + 1) {
	*info = -8;
    } else if (*ldb < max(1,*n)) {
	*info = -10;
    } else if (*ldx < max(1,*n)) {
	*info = -12;
    }
    if (*info != 0) {
	i__1 = -(*info);
	xerbla_("CPBRFS", &i__1);
	return 0;
    }

/*     Quick return if possible */

    if (*n == 0 || *nrhs == 0) {
	i__1 = *nrhs;
	for (j = 1; j <= *nrhs; ++j) {
	    FERR(j) = 0.f;
	    BERR(j) = 0.f;
/* L10: */
	}
	return 0;
    }

/*     NZ = maximum number of nonzero elements in each row of A, plus 1   

   Computing MIN */
    i__1 = *n + 1, i__2 = (*kd << 1) + 2;
    nz = min(i__1,i__2);
    eps = slamch_("Epsilon");
    safmin = slamch_("Safe minimum");
    safe1 = nz * safmin;
    safe2 = safe1 / eps;

/*     Do for each right hand side */

    i__1 = *nrhs;
    for (j = 1; j <= *nrhs; ++j) {

	count = 1;
	lstres = 3.f;
L20:

/*        Loop until stopping criterion is satisfied.   

          Compute residual R = B - A * X */

	ccopy_(n, &B(1,j), &c__1, &WORK(1), &c__1);
	q__1.r = -1.f, q__1.i = 0.f;
	chbmv_(uplo, n, kd, &q__1, &AB(1,1), ldab, &X(1,j), &
		c__1, &c_b1, &WORK(1), &c__1);

/*        Compute componentwise relative backward error from formula 
  

          max(i) ( abs(R(i)) / ( abs(A)*abs(X) + abs(B) )(i) )   

          where abs(Z) is the componentwise absolute value of the matr
ix   
          or vector Z.  If the i-th component of the denominator is le
ss   
          than SAFE2, then SAFE1 is added to the i-th components of th
e   
          numerator and denominator before dividing. */

	i__2 = *n;
	for (i = 1; i <= *n; ++i) {
	    i__3 = i + j * b_dim1;
	    RWORK(i) = (r__1 = B(i,j).r, dabs(r__1)) + (r__2 = r_imag(&B(i,j)), dabs(r__2));
/* L30: */
	}

/*        Compute abs(A)*abs(X) + abs(B). */

	if (upper) {
	    i__2 = *n;
	    for (k = 1; k <= *n; ++k) {
		s = 0.f;
		i__3 = k + j * x_dim1;
		xk = (r__1 = X(k,j).r, dabs(r__1)) + (r__2 = r_imag(&X(k,j)), dabs(r__2));
		l = *kd + 1 - k;
/* Computing MAX */
		i__3 = 1, i__4 = k - *kd;
		i__5 = k - 1;
		for (i = max(1,k-*kd); i <= k-1; ++i) {
		    i__3 = l + i + k * ab_dim1;
		    RWORK(i) += ((r__1 = AB(l+i,k).r, dabs(r__1)) + (r__2 = 
			    r_imag(&AB(l+i,k)), dabs(r__2))) * 
			    xk;
		    i__3 = l + i + k * ab_dim1;
		    i__4 = i + j * x_dim1;
		    s += ((r__1 = AB(l+i,k).r, dabs(r__1)) + (r__2 = r_imag(&
			    AB(l+i,k)), dabs(r__2))) * ((r__3 = 
			    X(i,j).r, dabs(r__3)) + (r__4 = r_imag(&X(i,j)), dabs(r__4)));
/* L40: */
		}
		i__5 = *kd + 1 + k * ab_dim1;
		RWORK(k) = RWORK(k) + (r__1 = AB(*kd+1,k).r, dabs(r__1)) * xk + 
			s;
/* L50: */
	    }
	} else {
	    i__2 = *n;
	    for (k = 1; k <= *n; ++k) {
		s = 0.f;
		i__5 = k + j * x_dim1;
		xk = (r__1 = X(k,j).r, dabs(r__1)) + (r__2 = r_imag(&X(k,j)), dabs(r__2));
		i__5 = k * ab_dim1 + 1;
		RWORK(k) += (r__1 = AB(1,k).r, dabs(r__1)) * xk;
		l = 1 - k;
/* Computing MIN */
		i__3 = *n, i__4 = k + *kd;
		i__5 = min(i__3,i__4);
		for (i = k + 1; i <= min(*n,k+*kd); ++i) {
		    i__3 = l + i + k * ab_dim1;
		    RWORK(i) += ((r__1 = AB(l+i,k).r, dabs(r__1)) + (r__2 = 
			    r_imag(&AB(l+i,k)), dabs(r__2))) * 
			    xk;
		    i__3 = l + i + k * ab_dim1;
		    i__4 = i + j * x_dim1;
		    s += ((r__1 = AB(l+i,k).r, dabs(r__1)) + (r__2 = r_imag(&
			    AB(l+i,k)), dabs(r__2))) * ((r__3 = 
			    X(i,j).r, dabs(r__3)) + (r__4 = r_imag(&X(i,j)), dabs(r__4)));
/* L60: */
		}
		RWORK(k) += s;
/* L70: */
	    }
	}
	s = 0.f;
	i__2 = *n;
	for (i = 1; i <= *n; ++i) {
	    if (RWORK(i) > safe2) {
/* Computing MAX */
		i__5 = i;
		r__3 = s, r__4 = ((r__1 = WORK(i).r, dabs(r__1)) + (r__2 = 
			r_imag(&WORK(i)), dabs(r__2))) / RWORK(i);
		s = dmax(r__3,r__4);
	    } else {
/* Computing MAX */
		i__5 = i;
		r__3 = s, r__4 = ((r__1 = WORK(i).r, dabs(r__1)) + (r__2 = 
			r_imag(&WORK(i)), dabs(r__2)) + safe1) / (RWORK(i) + 
			safe1);
		s = dmax(r__3,r__4);
	    }
/* L80: */
	}
	BERR(j) = s;

/*        Test stopping criterion. Continue iterating if   
             1) The residual BERR(J) is larger than machine epsilon, a
nd   
             2) BERR(J) decreased by at least a factor of 2 during the
   
                last iteration, and   
             3) At most ITMAX iterations tried. */

	if (BERR(j) > eps && BERR(j) * 2.f <= lstres && count <= 5) {

/*           Update solution and try again. */

	    cpbtrs_(uplo, n, kd, &c__1, &AFB(1,1), ldafb, &WORK(1), n, 
		    info);
	    caxpy_(n, &c_b1, &WORK(1), &c__1, &X(1,j), &c__1);
	    lstres = BERR(j);
	    ++count;
	    goto L20;
	}

/*        Bound error from formula   

          norm(X - XTRUE) / norm(X) .le. FERR =   
          norm( abs(inv(A))*   
             ( abs(R) + NZ*EPS*( abs(A)*abs(X)+abs(B) ))) / norm(X)   

          where   
            norm(Z) is the magnitude of the largest component of Z   
            inv(A) is the inverse of A   
            abs(Z) is the componentwise absolute value of the matrix o
r   
               vector Z   
            NZ is the maximum number of nonzeros in any row of A, plus
 1   
            EPS is machine epsilon   

          The i-th component of abs(R)+NZ*EPS*(abs(A)*abs(X)+abs(B)) 
  
          is incremented by SAFE1 if the i-th component of   
          abs(A)*abs(X) + abs(B) is less than SAFE2.   

          Use CLACON to estimate the infinity-norm of the matrix   
             inv(A) * diag(W),   
          where W = abs(R) + NZ*EPS*( abs(A)*abs(X)+abs(B) ))) */

	i__2 = *n;
	for (i = 1; i <= *n; ++i) {
	    if (RWORK(i) > safe2) {
		i__5 = i;
		RWORK(i) = (r__1 = WORK(i).r, dabs(r__1)) + (r__2 = r_imag(
			&WORK(i)), dabs(r__2)) + nz * eps * RWORK(i);
	    } else {
		i__5 = i;
		RWORK(i) = (r__1 = WORK(i).r, dabs(r__1)) + (r__2 = r_imag(
			&WORK(i)), dabs(r__2)) + nz * eps * RWORK(i) + safe1;
	    }
/* L90: */
	}

	kase = 0;
L100:
	clacon_(n, &WORK(*n + 1), &WORK(1), &FERR(j), &kase);
	if (kase != 0) {
	    if (kase == 1) {

/*              Multiply by diag(W)*inv(A'). */

		cpbtrs_(uplo, n, kd, &c__1, &AFB(1,1), ldafb, &WORK(1),
			 n, info);
		i__2 = *n;
		for (i = 1; i <= *n; ++i) {
		    i__5 = i;
		    i__3 = i;
		    i__4 = i;
		    q__1.r = RWORK(i) * WORK(i).r, q__1.i = RWORK(i) 
			    * WORK(i).i;
		    WORK(i).r = q__1.r, WORK(i).i = q__1.i;
/* L110: */
		}
	    } else if (kase == 2) {

/*              Multiply by inv(A)*diag(W). */

		i__2 = *n;
		for (i = 1; i <= *n; ++i) {
		    i__5 = i;
		    i__3 = i;
		    i__4 = i;
		    q__1.r = RWORK(i) * WORK(i).r, q__1.i = RWORK(i) 
			    * WORK(i).i;
		    WORK(i).r = q__1.r, WORK(i).i = q__1.i;
/* L120: */
		}
		cpbtrs_(uplo, n, kd, &c__1, &AFB(1,1), ldafb, &WORK(1),
			 n, info);
	    }
	    goto L100;
	}

/*        Normalize error. */

	lstres = 0.f;
	i__2 = *n;
	for (i = 1; i <= *n; ++i) {
/* Computing MAX */
	    i__5 = i + j * x_dim1;
	    r__3 = lstres, r__4 = (r__1 = X(i,j).r, dabs(r__1)) + (r__2 = 
		    r_imag(&X(i,j)), dabs(r__2));
	    lstres = dmax(r__3,r__4);
/* L130: */
	}
	if (lstres != 0.f) {
	    FERR(j) /= lstres;
	}

/* L140: */
    }

    return 0;

/*     End of CPBRFS */

} /* cpbrfs_ */
示例#9
0
文件: sasum.c 项目: toastpp/toastpp
real sasum_(integer *n, real *sx, integer *incx)
{


    /* System generated locals */
    integer i__1, i__2;
    real ret_val, r__1, r__2, r__3, r__4, r__5, r__6;

    /* Local variables */
    integer i, m, nincx;
    real stemp;
    integer mp1;


/*     takes the sum of the absolute values.   
       uses unrolled loops for increment equal to one.   
       jack dongarra, linpack, 3/11/78.   
       modified 3/93 to return if incx .le. 0.   
       modified 12/3/93, array(1) declarations changed to array(*)   


    
   Parameter adjustments   
       Function Body */
#define SX(I) sx[(I)-1]


    ret_val = 0.f;
    stemp = 0.f;
    if (*n <= 0 || *incx <= 0) {
	return ret_val;
    }
    if (*incx == 1) {
	goto L20;
    }

/*        code for increment not equal to 1 */

    nincx = *n * *incx;
    i__1 = nincx;
    i__2 = *incx;
    for (i = 1; *incx < 0 ? i >= nincx : i <= nincx; i += *incx) {
	stemp += (r__1 = SX(i), dabs(r__1));
/* L10: */
    }
    ret_val = stemp;
    return ret_val;

/*        code for increment equal to 1   


          clean-up loop */

L20:
    m = *n % 6;
    if (m == 0) {
	goto L40;
    }
    i__2 = m;
    for (i = 1; i <= m; ++i) {
	stemp += (r__1 = SX(i), dabs(r__1));
/* L30: */
    }
    if (*n < 6) {
	goto L60;
    }
L40:
    mp1 = m + 1;
    i__2 = *n;
    for (i = mp1; i <= *n; i += 6) {
	stemp = stemp + (r__1 = SX(i), dabs(r__1)) + (r__2 = SX(i + 1), dabs(
		r__2)) + (r__3 = SX(i + 2), dabs(r__3)) + (r__4 = SX(i + 3), 
		dabs(r__4)) + (r__5 = SX(i + 4), dabs(r__5)) + (r__6 = SX(i + 
		5), dabs(r__6));
/* L50: */
    }
L60:
    ret_val = stemp;
    return ret_val;
} /* sasum_ */
示例#10
0
/* Subroutine */ int slasq3_(integer *i0, integer *n0, real *z__, integer *pp, 
	 real *dmin__, real *sigma, real *desig, real *qmax, integer *nfail, 
	integer *iter, integer *ndiv, logical *ieee, integer *ttype, real *
	dmin1, real *dmin2, real *dn, real *dn1, real *dn2, real *g, real *
	tau)
{
    /* System generated locals */
    integer i__1;
    real r__1, r__2;

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

    /* Local variables */
    real s, t;
    integer j4, nn;
    real eps, tol;
    integer n0in, ipn4;
    real tol2, temp;
    extern /* Subroutine */ int slasq4_(integer *, integer *, real *, integer 
	    *, integer *, real *, real *, real *, real *, real *, real *, 
	    real *, integer *, real *), slasq5_(integer *, integer *, real *, 
	    integer *, real *, real *, real *, real *, real *, real *, real *, 
	     logical *), slasq6_(integer *, integer *, real *, integer *, 
	    real *, real *, real *, real *, real *, real *);
    extern doublereal slamch_(char *);
    extern logical sisnan_(real *);


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

/*  -- Contributed by Osni Marques of the Lawrence Berkeley National   -- */
/*  -- Laboratory and Beresford Parlett of the Univ. of California at  -- */
/*  -- Berkeley                                                        -- */
/*  -- November 2008                                                   -- */

/*  -- LAPACK is a software package provided by Univ. of Tennessee,    -- */
/*  -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */

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

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

/*  SLASQ3 checks for deflation, computes a shift (TAU) and calls dqds. */
/*  In case of failure it changes shifts, and tries again until output */
/*  is positive. */

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

/*  I0     (input) INTEGER */
/*         First index. */

/*  N0     (input) INTEGER */
/*         Last index. */

/*  Z      (input) REAL array, dimension ( 4*N ) */
/*         Z holds the qd array. */

/*  PP     (input/output) INTEGER */
/*         PP=0 for ping, PP=1 for pong. */
/*         PP=2 indicates that flipping was applied to the Z array */
/*         and that the initial tests for deflation should not be */
/*         performed. */

/*  DMIN   (output) REAL */
/*         Minimum value of d. */

/*  SIGMA  (output) REAL */
/*         Sum of shifts used in current segment. */

/*  DESIG  (input/output) REAL */
/*         Lower order part of SIGMA */

/*  QMAX   (input) REAL */
/*         Maximum value of q. */

/*  NFAIL  (output) INTEGER */
/*         Number of times shift was too big. */

/*  ITER   (output) INTEGER */
/*         Number of iterations. */

/*  NDIV   (output) INTEGER */
/*         Number of divisions. */

/*  IEEE   (input) LOGICAL */
/*         Flag for IEEE or non IEEE arithmetic (passed to SLASQ5). */

/*  TTYPE  (input/output) INTEGER */
/*         Shift type. */

/*  DMIN1, DMIN2, DN, DN1, DN2, G, TAU (input/output) REAL */
/*         These are passed as arguments in order to save their values */
/*         between calls to SLASQ3. */

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

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

    /* Parameter adjustments */
    --z__;

    /* Function Body */
    n0in = *n0;
    eps = slamch_("Precision");
    tol = eps * 100.f;
/* Computing 2nd power */
    r__1 = tol;
    tol2 = r__1 * r__1;

/*     Check for deflation. */

L10:

    if (*n0 < *i0) {
	return 0;
    }
    if (*n0 == *i0) {
	goto L20;
    }
    nn = (*n0 << 2) + *pp;
    if (*n0 == *i0 + 1) {
	goto L40;
    }

/*     Check whether E(N0-1) is negligible, 1 eigenvalue. */

    if (z__[nn - 5] > tol2 * (*sigma + z__[nn - 3]) && z__[nn - (*pp << 1) - 
	    4] > tol2 * z__[nn - 7]) {
	goto L30;
    }

L20:

    z__[(*n0 << 2) - 3] = z__[(*n0 << 2) + *pp - 3] + *sigma;
    --(*n0);
    goto L10;

/*     Check  whether E(N0-2) is negligible, 2 eigenvalues. */

L30:

    if (z__[nn - 9] > tol2 * *sigma && z__[nn - (*pp << 1) - 8] > tol2 * z__[
	    nn - 11]) {
	goto L50;
    }

L40:

    if (z__[nn - 3] > z__[nn - 7]) {
	s = z__[nn - 3];
	z__[nn - 3] = z__[nn - 7];
	z__[nn - 7] = s;
    }
    if (z__[nn - 5] > z__[nn - 3] * tol2) {
	t = (z__[nn - 7] - z__[nn - 3] + z__[nn - 5]) * .5f;
	s = z__[nn - 3] * (z__[nn - 5] / t);
	if (s <= t) {
	    s = z__[nn - 3] * (z__[nn - 5] / (t * (sqrt(s / t + 1.f) + 1.f)));
	} else {
	    s = z__[nn - 3] * (z__[nn - 5] / (t + sqrt(t) * sqrt(t + s)));
	}
	t = z__[nn - 7] + (s + z__[nn - 5]);
	z__[nn - 3] *= z__[nn - 7] / t;
	z__[nn - 7] = t;
    }
    z__[(*n0 << 2) - 7] = z__[nn - 7] + *sigma;
    z__[(*n0 << 2) - 3] = z__[nn - 3] + *sigma;
    *n0 += -2;
    goto L10;

L50:
    if (*pp == 2) {
	*pp = 0;
    }

/*     Reverse the qd-array, if warranted. */

    if (*dmin__ <= 0.f || *n0 < n0in) {
	if (z__[(*i0 << 2) + *pp - 3] * 1.5f < z__[(*n0 << 2) + *pp - 3]) {
	    ipn4 = *i0 + *n0 << 2;
	    i__1 = *i0 + *n0 - 1 << 1;
	    for (j4 = *i0 << 2; j4 <= i__1; j4 += 4) {
		temp = z__[j4 - 3];
		z__[j4 - 3] = z__[ipn4 - j4 - 3];
		z__[ipn4 - j4 - 3] = temp;
		temp = z__[j4 - 2];
		z__[j4 - 2] = z__[ipn4 - j4 - 2];
		z__[ipn4 - j4 - 2] = temp;
		temp = z__[j4 - 1];
		z__[j4 - 1] = z__[ipn4 - j4 - 5];
		z__[ipn4 - j4 - 5] = temp;
		temp = z__[j4];
		z__[j4] = z__[ipn4 - j4 - 4];
		z__[ipn4 - j4 - 4] = temp;
/* L60: */
	    }
	    if (*n0 - *i0 <= 4) {
		z__[(*n0 << 2) + *pp - 1] = z__[(*i0 << 2) + *pp - 1];
		z__[(*n0 << 2) - *pp] = z__[(*i0 << 2) - *pp];
	    }
/* Computing MIN */
	    r__1 = *dmin2, r__2 = z__[(*n0 << 2) + *pp - 1];
	    *dmin2 = dmin(r__1,r__2);
/* Computing MIN */
	    r__1 = z__[(*n0 << 2) + *pp - 1], r__2 = z__[(*i0 << 2) + *pp - 1]
		    , r__1 = min(r__1,r__2), r__2 = z__[(*i0 << 2) + *pp + 3];
	    z__[(*n0 << 2) + *pp - 1] = dmin(r__1,r__2);
/* Computing MIN */
	    r__1 = z__[(*n0 << 2) - *pp], r__2 = z__[(*i0 << 2) - *pp], r__1 =
		     min(r__1,r__2), r__2 = z__[(*i0 << 2) - *pp + 4];
	    z__[(*n0 << 2) - *pp] = dmin(r__1,r__2);
/* Computing MAX */
	    r__1 = *qmax, r__2 = z__[(*i0 << 2) + *pp - 3], r__1 = max(r__1,
		    r__2), r__2 = z__[(*i0 << 2) + *pp + 1];
	    *qmax = dmax(r__1,r__2);
	    *dmin__ = -0.f;
	}
    }

/*     Choose a shift. */

    slasq4_(i0, n0, &z__[1], pp, &n0in, dmin__, dmin1, dmin2, dn, dn1, dn2, 
	    tau, ttype, g);

/*     Call dqds until DMIN > 0. */

L70:

    slasq5_(i0, n0, &z__[1], pp, tau, dmin__, dmin1, dmin2, dn, dn1, dn2, 
	    ieee);

    *ndiv += *n0 - *i0 + 2;
    ++(*iter);

/*     Check status. */

    if (*dmin__ >= 0.f && *dmin1 > 0.f) {

/*        Success. */

	goto L90;

    } else if (*dmin__ < 0.f && *dmin1 > 0.f && z__[(*n0 - 1 << 2) - *pp] < 
	    tol * (*sigma + *dn1) && dabs(*dn) < tol * *sigma) {

/*        Convergence hidden by negative DN. */

	z__[(*n0 - 1 << 2) - *pp + 2] = 0.f;
	*dmin__ = 0.f;
	goto L90;
    } else if (*dmin__ < 0.f) {

/*        TAU too big. Select new TAU and try again. */

	++(*nfail);
	if (*ttype < -22) {

/*           Failed twice. Play it safe. */

	    *tau = 0.f;
	} else if (*dmin1 > 0.f) {

/*           Late failure. Gives excellent shift. */

	    *tau = (*tau + *dmin__) * (1.f - eps * 2.f);
	    *ttype += -11;
	} else {

/*           Early failure. Divide by 4. */

	    *tau *= .25f;
	    *ttype += -12;
	}
	goto L70;
    } else if (sisnan_(dmin__)) {

/*        NaN. */

	if (*tau == 0.f) {
	    goto L80;
	} else {
	    *tau = 0.f;
	    goto L70;
	}
    } else {

/*        Possible underflow. Play it safe. */

	goto L80;
    }

/*     Risk of underflow. */

L80:
    slasq6_(i0, n0, &z__[1], pp, dmin__, dmin1, dmin2, dn, dn1, dn2);
    *ndiv += *n0 - *i0 + 2;
    ++(*iter);
    *tau = 0.f;

L90:
    if (*tau < *sigma) {
	*desig += *tau;
	t = *sigma + *desig;
	*desig -= t - *sigma;
    } else {
	t = *sigma + *tau;
	*desig = *sigma - (t - *tau) + *desig;
    }
    *sigma = t;

    return 0;

/*     End of SLASQ3 */

} /* slasq3_ */
示例#11
0
/* DECK CHIDI */
/* Subroutine */ int chidi_(complex *a, integer *lda, integer *n, integer *
	kpvt, real *det, integer *inert, complex *work, integer *job)
{
    /* System generated locals */
    integer a_dim1, a_offset, i__1, i__2;
    real r__1;
    complex q__1, q__2, q__3;

    /* Local variables */
    static real d__;
    static integer j, k;
    static real t, ak;
    static integer jb, ks, km1;
    static real ten, akp1;
    static complex temp, akkp1;
    extern /* Complex */ void cdotc_(complex *, integer *, complex *, integer 
	    *, complex *, integer *);
    static logical nodet;
    extern /* Subroutine */ int ccopy_(integer *, complex *, integer *, 
	    complex *, integer *), cswap_(integer *, complex *, integer *, 
	    complex *, integer *), caxpy_(integer *, complex *, complex *, 
	    integer *, complex *, integer *);
    static integer kstep;
    static logical noert, noinv;

/* ***BEGIN PROLOGUE  CHIDI */
/* ***PURPOSE  Compute the determinant, inertia and inverse of a complex */
/*            Hermitian matrix using the factors obtained from CHIFA. */
/* ***LIBRARY   SLATEC (LINPACK) */
/* ***CATEGORY  D2D1A, D3D1A */
/* ***TYPE      COMPLEX (SSIDI-S, DSISI-D, CHIDI-C, CSIDI-C) */
/* ***KEYWORDS  DETERMINANT, HERMITIAN, INVERSE, LINEAR ALGEBRA, LINPACK, */
/*             MATRIX */
/* ***AUTHOR  Bunch, J., (UCSD) */
/* ***DESCRIPTION */

/*     CHIDI computes the determinant, inertia and inverse */
/*     of a complex Hermitian matrix using the factors from CHIFA. */

/*     On Entry */

/*        A       COMPLEX(LDA,N) */
/*                the output from CHIFA. */

/*        LDA     INTEGER */
/*                the leading dimension of the array A. */

/*        N       INTEGER */
/*                the order of the matrix A. */

/*        KVPT    INTEGER(N) */
/*                the pivot vector from CHIFA. */

/*        WORK    COMPLEX(N) */
/*                work vector.  Contents destroyed. */

/*        JOB     INTEGER */
/*                JOB has the decimal expansion  ABC  where */
/*                   if  C .NE. 0, the inverse is computed, */
/*                   if  B .NE. 0, the determinant is computed, */
/*                   if  A .NE. 0, the inertia is computed. */

/*                For example, JOB = 111  gives all three. */

/*     On Return */

/*        Variables not requested by JOB are not used. */

/*        A      contains the upper triangle of the inverse of */
/*               the original matrix.  The strict lower triangle */
/*               is never referenced. */

/*        DET    REAL(2) */
/*               determinant of original matrix. */
/*               Determinant = DET(1) * 10.0**DET(2) */
/*               with 1.0 .LE. ABS(DET(1)) .LT. 10.0 */
/*               or DET(1) = 0.0. */

/*        INERT  INTEGER(3) */
/*               the inertia of the original matrix. */
/*               INERT(1)  =  number of positive eigenvalues. */
/*               INERT(2)  =  number of negative eigenvalues. */
/*               INERT(3)  =  number of zero eigenvalues. */

/*     Error Condition */

/*        A division by zero may occur if the inverse is requested */
/*        and  CHICO  has set RCOND .EQ. 0.0 */
/*        or  CHIFA  has set  INFO .NE. 0 . */

/* ***REFERENCES  J. J. Dongarra, J. R. Bunch, C. B. Moler, and G. W. */
/*                 Stewart, LINPACK Users' Guide, SIAM, 1979. */
/* ***ROUTINES CALLED  CAXPY, CCOPY, CDOTC, CSWAP */
/* ***REVISION HISTORY  (YYMMDD) */
/*   780814  DATE WRITTEN */
/*   890531  Changed all specific intrinsics to generic.  (WRB) */
/*   890831  Modified array declarations.  (WRB) */
/*   891107  Modified routine equivalence list.  (WRB) */
/*   891107  REVISION DATE from Version 3.2 */
/*   891214  Prologue converted to Version 4.0 format.  (BAB) */
/*   900326  Removed duplicate information from DESCRIPTION section. */
/*           (WRB) */
/*   920501  Reformatted the REFERENCES section.  (WRB) */
/* ***END PROLOGUE  CHIDI */

/* ***FIRST EXECUTABLE STATEMENT  CHIDI */
    /* Parameter adjustments */
    a_dim1 = *lda;
    a_offset = 1 + a_dim1;
    a -= a_offset;
    --kpvt;
    --det;
    --inert;
    --work;

    /* Function Body */
    noinv = *job % 10 == 0;
    nodet = *job % 100 / 10 == 0;
    noert = *job % 1000 / 100 == 0;

    if (nodet && noert) {
	goto L140;
    }
    if (noert) {
	goto L10;
    }
    inert[1] = 0;
    inert[2] = 0;
    inert[3] = 0;
L10:
    if (nodet) {
	goto L20;
    }
    det[1] = 1.f;
    det[2] = 0.f;
    ten = 10.f;
L20:
    t = 0.f;
    i__1 = *n;
    for (k = 1; k <= i__1; ++k) {
	i__2 = k + k * a_dim1;
	d__ = a[i__2].r;

/*           CHECK IF 1 BY 1 */

	if (kpvt[k] > 0) {
	    goto L50;
	}

/*              2 BY 2 BLOCK */
/*              USE DET (D  S)  =  (D/T * C - T) * T  ,  T = ABS(S) */
/*                      (S  C) */
/*              TO AVOID UNDERFLOW/OVERFLOW TROUBLES. */
/*              TAKE TWO PASSES THROUGH SCALING.  USE  T  FOR FLAG. */

	if (t != 0.f) {
	    goto L30;
	}
	t = c_abs(&a[k + (k + 1) * a_dim1]);
	i__2 = k + 1 + (k + 1) * a_dim1;
	d__ = d__ / t * a[i__2].r - t;
	goto L40;
L30:
	d__ = t;
	t = 0.f;
L40:
L50:

	if (noert) {
	    goto L60;
	}
	if (d__ > 0.f) {
	    ++inert[1];
	}
	if (d__ < 0.f) {
	    ++inert[2];
	}
	if (d__ == 0.f) {
	    ++inert[3];
	}
L60:

	if (nodet) {
	    goto L120;
	}
	det[1] = d__ * det[1];
	if (det[1] == 0.f) {
	    goto L110;
	}
L70:
	if (dabs(det[1]) >= 1.f) {
	    goto L80;
	}
	det[1] = ten * det[1];
	det[2] += -1.f;
	goto L70;
L80:
L90:
	if (dabs(det[1]) < ten) {
	    goto L100;
	}
	det[1] /= ten;
	det[2] += 1.f;
	goto L90;
L100:
L110:
L120:
/* L130: */
	;
    }
L140:

/*     COMPUTE INVERSE(A) */

    if (noinv) {
	goto L270;
    }
    k = 1;
L150:
    if (k > *n) {
	goto L260;
    }
    km1 = k - 1;
    if (kpvt[k] < 0) {
	goto L180;
    }

/*              1 BY 1 */

    i__1 = k + k * a_dim1;
    i__2 = k + k * a_dim1;
    r__1 = 1.f / a[i__2].r;
    q__1.r = r__1, q__1.i = 0.f;
    a[i__1].r = q__1.r, a[i__1].i = q__1.i;
    if (km1 < 1) {
	goto L170;
    }
    ccopy_(&km1, &a[k * a_dim1 + 1], &c__1, &work[1], &c__1);
    i__1 = km1;
    for (j = 1; j <= i__1; ++j) {
	i__2 = j + k * a_dim1;
	cdotc_(&q__1, &j, &a[j * a_dim1 + 1], &c__1, &work[1], &c__1);
	a[i__2].r = q__1.r, a[i__2].i = q__1.i;
	i__2 = j - 1;
	caxpy_(&i__2, &work[j], &a[j * a_dim1 + 1], &c__1, &a[k * a_dim1 + 1],
		 &c__1);
/* L160: */
    }
    i__1 = k + k * a_dim1;
    i__2 = k + k * a_dim1;
    cdotc_(&q__3, &km1, &work[1], &c__1, &a[k * a_dim1 + 1], &c__1);
    r__1 = q__3.r;
    q__2.r = r__1, q__2.i = 0.f;
    q__1.r = a[i__2].r + q__2.r, q__1.i = a[i__2].i + q__2.i;
    a[i__1].r = q__1.r, a[i__1].i = q__1.i;
L170:
    kstep = 1;
    goto L220;
L180:

/*              2 BY 2 */

    t = c_abs(&a[k + (k + 1) * a_dim1]);
    i__1 = k + k * a_dim1;
    ak = a[i__1].r / t;
    i__1 = k + 1 + (k + 1) * a_dim1;
    akp1 = a[i__1].r / t;
    i__1 = k + (k + 1) * a_dim1;
    q__1.r = a[i__1].r / t, q__1.i = a[i__1].i / t;
    akkp1.r = q__1.r, akkp1.i = q__1.i;
    d__ = t * (ak * akp1 - 1.f);
    i__1 = k + k * a_dim1;
    r__1 = akp1 / d__;
    q__1.r = r__1, q__1.i = 0.f;
    a[i__1].r = q__1.r, a[i__1].i = q__1.i;
    i__1 = k + 1 + (k + 1) * a_dim1;
    r__1 = ak / d__;
    q__1.r = r__1, q__1.i = 0.f;
    a[i__1].r = q__1.r, a[i__1].i = q__1.i;
    i__1 = k + (k + 1) * a_dim1;
    q__2.r = -akkp1.r, q__2.i = -akkp1.i;
    q__1.r = q__2.r / d__, q__1.i = q__2.i / d__;
    a[i__1].r = q__1.r, a[i__1].i = q__1.i;
    if (km1 < 1) {
	goto L210;
    }
    ccopy_(&km1, &a[(k + 1) * a_dim1 + 1], &c__1, &work[1], &c__1);
    i__1 = km1;
    for (j = 1; j <= i__1; ++j) {
	i__2 = j + (k + 1) * a_dim1;
	cdotc_(&q__1, &j, &a[j * a_dim1 + 1], &c__1, &work[1], &c__1);
	a[i__2].r = q__1.r, a[i__2].i = q__1.i;
	i__2 = j - 1;
	caxpy_(&i__2, &work[j], &a[j * a_dim1 + 1], &c__1, &a[(k + 1) * 
		a_dim1 + 1], &c__1);
/* L190: */
    }
    i__1 = k + 1 + (k + 1) * a_dim1;
    i__2 = k + 1 + (k + 1) * a_dim1;
    cdotc_(&q__3, &km1, &work[1], &c__1, &a[(k + 1) * a_dim1 + 1], &c__1);
    r__1 = q__3.r;
    q__2.r = r__1, q__2.i = 0.f;
    q__1.r = a[i__2].r + q__2.r, q__1.i = a[i__2].i + q__2.i;
    a[i__1].r = q__1.r, a[i__1].i = q__1.i;
    i__1 = k + (k + 1) * a_dim1;
    i__2 = k + (k + 1) * a_dim1;
    cdotc_(&q__2, &km1, &a[k * a_dim1 + 1], &c__1, &a[(k + 1) * a_dim1 + 1], &
	    c__1);
    q__1.r = a[i__2].r + q__2.r, q__1.i = a[i__2].i + q__2.i;
    a[i__1].r = q__1.r, a[i__1].i = q__1.i;
    ccopy_(&km1, &a[k * a_dim1 + 1], &c__1, &work[1], &c__1);
    i__1 = km1;
    for (j = 1; j <= i__1; ++j) {
	i__2 = j + k * a_dim1;
	cdotc_(&q__1, &j, &a[j * a_dim1 + 1], &c__1, &work[1], &c__1);
	a[i__2].r = q__1.r, a[i__2].i = q__1.i;
	i__2 = j - 1;
	caxpy_(&i__2, &work[j], &a[j * a_dim1 + 1], &c__1, &a[k * a_dim1 + 1],
		 &c__1);
/* L200: */
    }
    i__1 = k + k * a_dim1;
    i__2 = k + k * a_dim1;
    cdotc_(&q__3, &km1, &work[1], &c__1, &a[k * a_dim1 + 1], &c__1);
    r__1 = q__3.r;
    q__2.r = r__1, q__2.i = 0.f;
    q__1.r = a[i__2].r + q__2.r, q__1.i = a[i__2].i + q__2.i;
    a[i__1].r = q__1.r, a[i__1].i = q__1.i;
L210:
    kstep = 2;
L220:

/*           SWAP */

    ks = (i__1 = kpvt[k], abs(i__1));
    if (ks == k) {
	goto L250;
    }
    cswap_(&ks, &a[ks * a_dim1 + 1], &c__1, &a[k * a_dim1 + 1], &c__1);
    i__1 = k;
    for (jb = ks; jb <= i__1; ++jb) {
	j = k + ks - jb;
	r_cnjg(&q__1, &a[j + k * a_dim1]);
	temp.r = q__1.r, temp.i = q__1.i;
	i__2 = j + k * a_dim1;
	r_cnjg(&q__1, &a[ks + j * a_dim1]);
	a[i__2].r = q__1.r, a[i__2].i = q__1.i;
	i__2 = ks + j * a_dim1;
	a[i__2].r = temp.r, a[i__2].i = temp.i;
/* L230: */
    }
    if (kstep == 1) {
	goto L240;
    }
    i__1 = ks + (k + 1) * a_dim1;
    temp.r = a[i__1].r, temp.i = a[i__1].i;
    i__1 = ks + (k + 1) * a_dim1;
    i__2 = k + (k + 1) * a_dim1;
    a[i__1].r = a[i__2].r, a[i__1].i = a[i__2].i;
    i__1 = k + (k + 1) * a_dim1;
    a[i__1].r = temp.r, a[i__1].i = temp.i;
L240:
L250:
    k += kstep;
    goto L150;
L260:
L270:
    return 0;
} /* chidi_ */
示例#12
0
/* Subroutine */ int ssterf_(integer *n, real *d__, real *e, 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   
    =======   

    SSTERF computes all eigenvalues of a symmetric tridiagonal matrix   
    using the Pal-Walker-Kahan variant of the QL or QR algorithm.   

    Arguments   
    =========   

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

    D       (input/output) REAL array, dimension (N)   
            On entry, the n diagonal elements of the tridiagonal matrix.   
            On exit, if INFO = 0, the eigenvalues in ascending order.   

    E       (input/output) REAL array, dimension (N-1)   
            On entry, the (n-1) subdiagonal elements of the tridiagonal   
            matrix.   
            On exit, E has been destroyed.   

    INFO    (output) INTEGER   
            = 0:  successful exit   
            < 0:  if INFO = -i, the i-th argument had an illegal value   
            > 0:  the algorithm failed to find all of the eigenvalues in   
                  a total of 30*N iterations; if INFO = i, then i   
                  elements of E have not converged to zero.   

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


       Test the input parameters.   

       Parameter adjustments */
    /* Table of constant values */
    static integer c__0 = 0;
    static integer c__1 = 1;
    static real c_b32 = 1.f;
    
    /* System generated locals */
    integer i__1;
    real r__1, r__2, r__3;
    /* Builtin functions */
    double sqrt(doublereal), r_sign(real *, real *);
    /* Local variables */
    static real oldc;
    static integer lend, jtot;
    extern /* Subroutine */ int slae2_(real *, real *, real *, real *, real *)
	    ;
    static real c__;
    static integer i__, l, m;
    static real p, gamma, r__, s, alpha, sigma, anorm;
    static integer l1;
    static real bb;
    extern doublereal slapy2_(real *, real *);
    static integer iscale;
    static real oldgam;
    extern doublereal slamch_(char *);
    static real safmin;
    extern /* Subroutine */ int xerbla_(char *, integer *);
    static real safmax;
    extern /* Subroutine */ int slascl_(char *, integer *, integer *, real *, 
	    real *, integer *, integer *, real *, integer *, integer *);
    static integer lendsv;
    static real ssfmin;
    static integer nmaxit;
    static real ssfmax;
    extern doublereal slanst_(char *, integer *, real *, real *);
    extern /* Subroutine */ int slasrt_(char *, integer *, real *, integer *);
    static real rt1, rt2, eps, rte;
    static integer lsv;
    static real eps2;


    --e;
    --d__;

    /* Function Body */
    *info = 0;

/*     Quick return if possible */

    if (*n < 0) {
	*info = -1;
	i__1 = -(*info);
	xerbla_("SSTERF", &i__1);
	return 0;
    }
    if (*n <= 1) {
	return 0;
    }

/*     Determine the unit roundoff for this environment. */

    eps = slamch_("E");
/* Computing 2nd power */
    r__1 = eps;
    eps2 = r__1 * r__1;
    safmin = slamch_("S");
    safmax = 1.f / safmin;
    ssfmax = sqrt(safmax) / 3.f;
    ssfmin = sqrt(safmin) / eps2;

/*     Compute the eigenvalues of the tridiagonal matrix. */

    nmaxit = *n * 30;
    sigma = 0.f;
    jtot = 0;

/*     Determine where the matrix splits and choose QL or QR iteration   
       for each block, according to whether top or bottom diagonal   
       element is smaller. */

    l1 = 1;

L10:
    if (l1 > *n) {
	goto L170;
    }
    if (l1 > 1) {
	e[l1 - 1] = 0.f;
    }
    i__1 = *n - 1;
    for (m = l1; m <= i__1; ++m) {
	if ((r__3 = e[m], dabs(r__3)) <= sqrt((r__1 = d__[m], dabs(r__1))) * 
		sqrt((r__2 = d__[m + 1], dabs(r__2))) * eps) {
	    e[m] = 0.f;
	    goto L30;
	}
/* L20: */
    }
    m = *n;

L30:
    l = l1;
    lsv = l;
    lend = m;
    lendsv = lend;
    l1 = m + 1;
    if (lend == l) {
	goto L10;
    }

/*     Scale submatrix in rows and columns L to LEND */

    i__1 = lend - l + 1;
    anorm = slanst_("I", &i__1, &d__[l], &e[l]);
    iscale = 0;
    if (anorm > ssfmax) {
	iscale = 1;
	i__1 = lend - l + 1;
	slascl_("G", &c__0, &c__0, &anorm, &ssfmax, &i__1, &c__1, &d__[l], n, 
		info);
	i__1 = lend - l;
	slascl_("G", &c__0, &c__0, &anorm, &ssfmax, &i__1, &c__1, &e[l], n, 
		info);
    } else if (anorm < ssfmin) {
	iscale = 2;
	i__1 = lend - l + 1;
	slascl_("G", &c__0, &c__0, &anorm, &ssfmin, &i__1, &c__1, &d__[l], n, 
		info);
	i__1 = lend - l;
	slascl_("G", &c__0, &c__0, &anorm, &ssfmin, &i__1, &c__1, &e[l], n, 
		info);
    }

    i__1 = lend - 1;
    for (i__ = l; i__ <= i__1; ++i__) {
/* Computing 2nd power */
	r__1 = e[i__];
	e[i__] = r__1 * r__1;
/* L40: */
    }

/*     Choose between QL and QR iteration */

    if ((r__1 = d__[lend], dabs(r__1)) < (r__2 = d__[l], dabs(r__2))) {
	lend = lsv;
	l = lendsv;
    }

    if (lend >= l) {

/*        QL Iteration   

          Look for small subdiagonal element. */

L50:
	if (l != lend) {
	    i__1 = lend - 1;
	    for (m = l; m <= i__1; ++m) {
		if ((r__2 = e[m], dabs(r__2)) <= eps2 * (r__1 = d__[m] * d__[
			m + 1], dabs(r__1))) {
		    goto L70;
		}
/* L60: */
	    }
	}
	m = lend;

L70:
	if (m < lend) {
	    e[m] = 0.f;
	}
	p = d__[l];
	if (m == l) {
	    goto L90;
	}

/*        If remaining matrix is 2 by 2, use SLAE2 to compute its   
          eigenvalues. */

	if (m == l + 1) {
	    rte = sqrt(e[l]);
	    slae2_(&d__[l], &rte, &d__[l + 1], &rt1, &rt2);
	    d__[l] = rt1;
	    d__[l + 1] = rt2;
	    e[l] = 0.f;
	    l += 2;
	    if (l <= lend) {
		goto L50;
	    }
	    goto L150;
	}

	if (jtot == nmaxit) {
	    goto L150;
	}
	++jtot;

/*        Form shift. */

	rte = sqrt(e[l]);
	sigma = (d__[l + 1] - p) / (rte * 2.f);
	r__ = slapy2_(&sigma, &c_b32);
	sigma = p - rte / (sigma + r_sign(&r__, &sigma));

	c__ = 1.f;
	s = 0.f;
	gamma = d__[m] - sigma;
	p = gamma * gamma;

/*        Inner loop */

	i__1 = l;
	for (i__ = m - 1; i__ >= i__1; --i__) {
	    bb = e[i__];
	    r__ = p + bb;
	    if (i__ != m - 1) {
		e[i__ + 1] = s * r__;
	    }
	    oldc = c__;
	    c__ = p / r__;
	    s = bb / r__;
	    oldgam = gamma;
	    alpha = d__[i__];
	    gamma = c__ * (alpha - sigma) - s * oldgam;
	    d__[i__ + 1] = oldgam + (alpha - gamma);
	    if (c__ != 0.f) {
		p = gamma * gamma / c__;
	    } else {
		p = oldc * bb;
	    }
/* L80: */
	}

	e[l] = s * p;
	d__[l] = sigma + gamma;
	goto L50;

/*        Eigenvalue found. */

L90:
	d__[l] = p;

	++l;
	if (l <= lend) {
	    goto L50;
	}
	goto L150;

    } else {

/*        QR Iteration   

          Look for small superdiagonal element. */

L100:
	i__1 = lend + 1;
	for (m = l; m >= i__1; --m) {
	    if ((r__2 = e[m - 1], dabs(r__2)) <= eps2 * (r__1 = d__[m] * d__[
		    m - 1], dabs(r__1))) {
		goto L120;
	    }
/* L110: */
	}
	m = lend;

L120:
	if (m > lend) {
	    e[m - 1] = 0.f;
	}
	p = d__[l];
	if (m == l) {
	    goto L140;
	}

/*        If remaining matrix is 2 by 2, use SLAE2 to compute its   
          eigenvalues. */

	if (m == l - 1) {
	    rte = sqrt(e[l - 1]);
	    slae2_(&d__[l], &rte, &d__[l - 1], &rt1, &rt2);
	    d__[l] = rt1;
	    d__[l - 1] = rt2;
	    e[l - 1] = 0.f;
	    l += -2;
	    if (l >= lend) {
		goto L100;
	    }
	    goto L150;
	}

	if (jtot == nmaxit) {
	    goto L150;
	}
	++jtot;

/*        Form shift. */

	rte = sqrt(e[l - 1]);
	sigma = (d__[l - 1] - p) / (rte * 2.f);
	r__ = slapy2_(&sigma, &c_b32);
	sigma = p - rte / (sigma + r_sign(&r__, &sigma));

	c__ = 1.f;
	s = 0.f;
	gamma = d__[m] - sigma;
	p = gamma * gamma;

/*        Inner loop */

	i__1 = l - 1;
	for (i__ = m; i__ <= i__1; ++i__) {
	    bb = e[i__];
	    r__ = p + bb;
	    if (i__ != m) {
		e[i__ - 1] = s * r__;
	    }
	    oldc = c__;
	    c__ = p / r__;
	    s = bb / r__;
	    oldgam = gamma;
	    alpha = d__[i__ + 1];
	    gamma = c__ * (alpha - sigma) - s * oldgam;
	    d__[i__] = oldgam + (alpha - gamma);
	    if (c__ != 0.f) {
		p = gamma * gamma / c__;
	    } else {
		p = oldc * bb;
	    }
/* L130: */
	}

	e[l - 1] = s * p;
	d__[l] = sigma + gamma;
	goto L100;

/*        Eigenvalue found. */

L140:
	d__[l] = p;

	--l;
	if (l >= lend) {
	    goto L100;
	}
	goto L150;

    }

/*     Undo scaling if necessary */

L150:
    if (iscale == 1) {
	i__1 = lendsv - lsv + 1;
	slascl_("G", &c__0, &c__0, &ssfmax, &anorm, &i__1, &c__1, &d__[lsv], 
		n, info);
    }
    if (iscale == 2) {
	i__1 = lendsv - lsv + 1;
	slascl_("G", &c__0, &c__0, &ssfmin, &anorm, &i__1, &c__1, &d__[lsv], 
		n, info);
    }

/*     Check for no convergence to an eigenvalue after a total   
       of N*MAXIT iterations. */

    if (jtot < nmaxit) {
	goto L10;
    }
    i__1 = *n - 1;
    for (i__ = 1; i__ <= i__1; ++i__) {
	if (e[i__] != 0.f) {
	    ++(*info);
	}
/* L160: */
    }
    goto L180;

/*     Sort eigenvalues in increasing order. */

L170:
    slasrt_("I", n, &d__[1], info);

L180:
    return 0;

/*     End of SSTERF */

} /* ssterf_ */
示例#13
0
/* Subroutine */ int cgecon_(char *norm, integer *n, complex *a, integer *lda, 
	 real *anorm, real *rcond, complex *work, real *rwork, integer *info)
{
    /* System generated locals */
    integer a_dim1, a_offset, i__1;
    real r__1, r__2;

    /* Builtin functions */
    double r_imag(complex *);

    /* Local variables */
    real sl;
    integer ix;
    real su;
    integer kase, kase1;
    real scale;
    extern logical lsame_(char *, char *);
    integer isave[3];
    extern /* Subroutine */ int clacn2_(integer *, complex *, complex *, real 
	    *, integer *, integer *);
    extern integer icamax_(integer *, complex *, integer *);
    extern doublereal slamch_(char *);
    extern /* Subroutine */ int xerbla_(char *, integer *);
    real ainvnm;
    extern /* Subroutine */ int clatrs_(char *, char *, char *, char *, 
	    integer *, complex *, integer *, complex *, real *, real *, 
	    integer *), csrscl_(integer *, 
	    real *, complex *, integer *);
    logical onenrm;
    char normin[1];
    real smlnum;


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

/*     Modified to call CLACN2 in place of CLACON, 10 Feb 03, SJH. */

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

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

/*  CGECON estimates the reciprocal of the condition number of a general */
/*  complex matrix A, in either the 1-norm or the infinity-norm, using */
/*  the LU factorization computed by CGETRF. */

/*  An estimate is obtained for norm(inv(A)), and the reciprocal of the */
/*  condition number is computed as */
/*     RCOND = 1 / ( norm(A) * norm(inv(A)) ). */

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

/*  NORM    (input) CHARACTER*1 */
/*          Specifies whether the 1-norm condition number or the */
/*          infinity-norm condition number is required: */
/*          = '1' or 'O':  1-norm; */
/*          = 'I':         Infinity-norm. */

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

/*  A       (input) COMPLEX array, dimension (LDA,N) */
/*          The factors L and U from the factorization A = P*L*U */
/*          as computed by CGETRF. */

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

/*  ANORM   (input) REAL */
/*          If NORM = '1' or 'O', the 1-norm of the original matrix A. */
/*          If NORM = 'I', the infinity-norm of the original matrix A. */

/*  RCOND   (output) REAL */
/*          The reciprocal of the condition number of the matrix A, */
/*          computed as RCOND = 1/(norm(A) * norm(inv(A))). */

/*  WORK    (workspace) COMPLEX array, dimension (2*N) */

/*  RWORK   (workspace) REAL array, dimension (2*N) */

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

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

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

/*     Test the input parameters. */

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

    /* Function Body */
    *info = 0;
    onenrm = *(unsigned char *)norm == '1' || lsame_(norm, "O");
    if (! onenrm && ! lsame_(norm, "I")) {
	*info = -1;
    } else if (*n < 0) {
	*info = -2;
    } else if (*lda < max(1,*n)) {
	*info = -4;
    } else if (*anorm < 0.f) {
	*info = -5;
    }
    if (*info != 0) {
	i__1 = -(*info);
	xerbla_("CGECON", &i__1);
	return 0;
    }

/*     Quick return if possible */

    *rcond = 0.f;
    if (*n == 0) {
	*rcond = 1.f;
	return 0;
    } else if (*anorm == 0.f) {
	return 0;
    }

    smlnum = slamch_("Safe minimum");

/*     Estimate the norm of inv(A). */

    ainvnm = 0.f;
    *(unsigned char *)normin = 'N';
    if (onenrm) {
	kase1 = 1;
    } else {
	kase1 = 2;
    }
    kase = 0;
L10:
    clacn2_(n, &work[*n + 1], &work[1], &ainvnm, &kase, isave);
    if (kase != 0) {
	if (kase == kase1) {

/*           Multiply by inv(L). */

	    clatrs_("Lower", "No transpose", "Unit", normin, n, &a[a_offset], 
		    lda, &work[1], &sl, &rwork[1], info);

/*           Multiply by inv(U). */

	    clatrs_("Upper", "No transpose", "Non-unit", normin, n, &a[
		    a_offset], lda, &work[1], &su, &rwork[*n + 1], info);
	} else {

/*           Multiply by inv(U'). */

	    clatrs_("Upper", "Conjugate transpose", "Non-unit", normin, n, &a[
		    a_offset], lda, &work[1], &su, &rwork[*n + 1], info);

/*           Multiply by inv(L'). */

	    clatrs_("Lower", "Conjugate transpose", "Unit", normin, n, &a[
		    a_offset], lda, &work[1], &sl, &rwork[1], info);
	}

/*        Divide X by 1/(SL*SU) if doing so will not cause overflow. */

	scale = sl * su;
	*(unsigned char *)normin = 'Y';
	if (scale != 1.f) {
	    ix = icamax_(n, &work[1], &c__1);
	    i__1 = ix;
	    if (scale < ((r__1 = work[i__1].r, dabs(r__1)) + (r__2 = r_imag(&
		    work[ix]), dabs(r__2))) * smlnum || scale == 0.f) {
		goto L20;
	    }
	    csrscl_(n, &scale, &work[1], &c__1);
	}
	goto L10;
    }

/*     Compute the estimate of the reciprocal condition number. */

    if (ainvnm != 0.f) {
	*rcond = 1.f / ainvnm / *anorm;
    }

L20:
    return 0;

/*     End of CGECON */

} /* cgecon_ */
示例#14
0
/* Subroutine */ int slassq_(integer *n, real *x, integer *incx, real *scale, 
	real *sumsq)
{
    /* System generated locals */
    integer i__1, i__2;
    real r__1;

    /* Local variables */
    integer ix;
    real absxi;

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

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

/*  SLASSQ  returns the values  scl  and  smsq  such that */

/*  where  x( i ) = X( 1 + ( i - 1 )*INCX ). The value of  sumsq  is */
/*  assumed to be non-negative and  scl  returns the value */

/*     scl = max( scale, abs( x( i ) ) ). */

/*  scale and sumsq must be supplied in SCALE and SUMSQ and */
/*  scl and smsq are overwritten on SCALE and SUMSQ respectively. */

/*  The routine makes only one pass through the vector x. */

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

/*  N       (input) INTEGER */
/*          The number of elements to be used from the vector X. */

/*  X       (input) REAL array, dimension (N) */
/*          The vector for which a scaled sum of squares is computed. */
/*             x( i )  = X( 1 + ( i - 1 )*INCX ), 1 <= i <= n. */

/*  INCX    (input) INTEGER */
/*          The increment between successive values of the vector X. */
/*          INCX > 0. */

/*  SCALE   (input/output) REAL */
/*          On entry, the value  scale  in the equation above. */
/*          On exit, SCALE is overwritten with  scl , the scaling factor */
/*          for the sum of squares. */

/*  SUMSQ   (input/output) REAL */
/*          On entry, the value  sumsq  in the equation above. */
/*          On exit, SUMSQ is overwritten with  smsq , the basic sum of */
/*          squares from which  scl  has been factored out. */

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

    /* Parameter adjustments */
    --x;

    /* Function Body */
    if (*n > 0) {
	i__1 = (*n - 1) * *incx + 1;
	i__2 = *incx;
	for (ix = 1; i__2 < 0 ? ix >= i__1 : ix <= i__1; ix += i__2) {
	    if (x[ix] != 0.f) {
		absxi = (r__1 = x[ix], dabs(r__1));
		if (*scale < absxi) {
/* Computing 2nd power */
		    r__1 = *scale / absxi;
		    *sumsq = *sumsq * (r__1 * r__1) + 1;
		    *scale = absxi;
		} else {
/* Computing 2nd power */
		    r__1 = absxi / *scale;
		    *sumsq += r__1 * r__1;
		}
	    }
	}
    }
    return 0;

/*     End of SLASSQ */

} /* slassq_ */
示例#15
0
/* Subroutine */ int cpot05_(char *uplo, integer *n, integer *nrhs, complex *
	a, integer *lda, complex *b, integer *ldb, complex *x, integer *ldx, 
	complex *xact, integer *ldxact, real *ferr, real *berr, real *reslts)
{
    /* System generated locals */
    integer a_dim1, a_offset, b_dim1, b_offset, x_dim1, x_offset, xact_dim1, 
	    xact_offset, i__1, i__2, i__3, i__4, i__5;
    real r__1, r__2, r__3, r__4;
    complex q__1, q__2;

    /* Builtin functions */
    double r_imag(complex *);

    /* Local variables */
    integer i__, j, k;
    real eps, tmp, diff, axbi;
    integer imax;
    real unfl, ovfl;
    extern logical lsame_(char *, char *);
    logical upper;
    real xnorm;
    extern integer icamax_(integer *, complex *, integer *);
    extern doublereal slamch_(char *);
    real errbnd;


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

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

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

/*  CPOT05 tests the error bounds from iterative refinement for the */
/*  computed solution to a system of equations A*X = B, where A is a */
/*  Hermitian n by n matrix. */

/*  RESLTS(1) = test of the error bound */
/*            = norm(X - XACT) / ( norm(X) * FERR ) */

/*  A large value is returned if this ratio is not less than one. */

/*  RESLTS(2) = residual from the iterative refinement routine */
/*            = the maximum of BERR / ( (n+1)*EPS + (*) ), where */
/*              (*) = (n+1)*UNFL / (min_i (abs(A)*abs(X) +abs(b))_i ) */

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

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

/*  N       (input) INTEGER */
/*          The number of rows of the matrices X, B, and XACT, and the */
/*          order of the matrix A.  N >= 0. */

/*  NRHS    (input) INTEGER */
/*          The number of columns of the matrices X, B, and XACT. */
/*          NRHS >= 0. */

/*  A       (input) COMPLEX array, dimension (LDA,N) */
/*          The Hermitian matrix A.  If UPLO = 'U', the leading n by n */
/*          upper triangular part of A contains the upper triangular part */
/*          of the matrix A, and the strictly lower triangular part of A */
/*          is not referenced.  If UPLO = 'L', the leading n by n lower */
/*          triangular part of A contains the lower triangular part of */
/*          the matrix A, and the strictly upper triangular part of A is */
/*          not referenced. */

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

/*  B       (input) COMPLEX 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). */

/*  X       (input) COMPLEX array, dimension (LDX,NRHS) */
/*          The computed solution vectors.  Each vector is stored as a */
/*          column of the matrix X. */

/*  LDX     (input) INTEGER */
/*          The leading dimension of the array X.  LDX >= max(1,N). */

/*  XACT    (input) COMPLEX array, dimension (LDX,NRHS) */
/*          The exact solution vectors.  Each vector is stored as a */
/*          column of the matrix XACT. */

/*  LDXACT  (input) INTEGER */
/*          The leading dimension of the array XACT.  LDXACT >= max(1,N). */

/*  FERR    (input) REAL array, dimension (NRHS) */
/*          The estimated forward error bounds for each solution vector */
/*          X.  If XTRUE is the true solution, FERR bounds the magnitude */
/*          of the largest entry in (X - XTRUE) divided by the magnitude */
/*          of the largest entry in X. */

/*  BERR    (input) REAL array, dimension (NRHS) */
/*          The componentwise relative backward error of each solution */
/*          vector (i.e., the smallest relative change in any entry of A */
/*          or B that makes X an exact solution). */

/*  RESLTS  (output) REAL array, dimension (2) */
/*          The maximum over the NRHS solution vectors of the ratios: */
/*          RESLTS(1) = norm(X - XACT) / ( norm(X) * FERR ) */
/*          RESLTS(2) = BERR / ( (n+1)*EPS + (*) ) */

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

/*     .. Parameters .. */
/*     .. */
/*     .. Local Scalars .. */
/*     .. */
/*     .. External Functions .. */
/*     .. */
/*     .. Intrinsic Functions .. */
/*     .. */
/*     .. Statement Functions .. */
/*     .. */
/*     .. Statement Function definitions .. */
/*     .. */
/*     .. Executable Statements .. */

/*     Quick exit if N = 0 or NRHS = 0. */

    /* Parameter adjustments */
    a_dim1 = *lda;
    a_offset = 1 + a_dim1;
    a -= a_offset;
    b_dim1 = *ldb;
    b_offset = 1 + b_dim1;
    b -= b_offset;
    x_dim1 = *ldx;
    x_offset = 1 + x_dim1;
    x -= x_offset;
    xact_dim1 = *ldxact;
    xact_offset = 1 + xact_dim1;
    xact -= xact_offset;
    --ferr;
    --berr;
    --reslts;

    /* Function Body */
    if (*n <= 0 || *nrhs <= 0) {
	reslts[1] = 0.f;
	reslts[2] = 0.f;
	return 0;
    }

    eps = slamch_("Epsilon");
    unfl = slamch_("Safe minimum");
    ovfl = 1.f / unfl;
    upper = lsame_(uplo, "U");

/*     Test 1:  Compute the maximum of */
/*        norm(X - XACT) / ( norm(X) * FERR ) */
/*     over all the vectors X and XACT using the infinity-norm. */

    errbnd = 0.f;
    i__1 = *nrhs;
    for (j = 1; j <= i__1; ++j) {
	imax = icamax_(n, &x[j * x_dim1 + 1], &c__1);
/* Computing MAX */
	i__2 = imax + j * x_dim1;
	r__3 = (r__1 = x[i__2].r, dabs(r__1)) + (r__2 = r_imag(&x[imax + j * 
		x_dim1]), dabs(r__2));
	xnorm = dmax(r__3,unfl);
	diff = 0.f;
	i__2 = *n;
	for (i__ = 1; i__ <= i__2; ++i__) {
	    i__3 = i__ + j * x_dim1;
	    i__4 = i__ + j * xact_dim1;
	    q__2.r = x[i__3].r - xact[i__4].r, q__2.i = x[i__3].i - xact[i__4]
		    .i;
	    q__1.r = q__2.r, q__1.i = q__2.i;
/* Computing MAX */
	    r__3 = diff, r__4 = (r__1 = q__1.r, dabs(r__1)) + (r__2 = r_imag(&
		    q__1), dabs(r__2));
	    diff = dmax(r__3,r__4);
/* L10: */
	}

	if (xnorm > 1.f) {
	    goto L20;
	} else if (diff <= ovfl * xnorm) {
	    goto L20;
	} else {
	    errbnd = 1.f / eps;
	    goto L30;
	}

L20:
	if (diff / xnorm <= ferr[j]) {
/* Computing MAX */
	    r__1 = errbnd, r__2 = diff / xnorm / ferr[j];
	    errbnd = dmax(r__1,r__2);
	} else {
	    errbnd = 1.f / eps;
	}
L30:
	;
    }
    reslts[1] = errbnd;

/*     Test 2:  Compute the maximum of BERR / ( (n+1)*EPS + (*) ), where */
/*     (*) = (n+1)*UNFL / (min_i (abs(A)*abs(X) +abs(b))_i ) */

    i__1 = *nrhs;
    for (k = 1; k <= i__1; ++k) {
	i__2 = *n;
	for (i__ = 1; i__ <= i__2; ++i__) {
	    i__3 = i__ + k * b_dim1;
	    tmp = (r__1 = b[i__3].r, dabs(r__1)) + (r__2 = r_imag(&b[i__ + k *
		     b_dim1]), dabs(r__2));
	    if (upper) {
		i__3 = i__ - 1;
		for (j = 1; j <= i__3; ++j) {
		    i__4 = j + i__ * a_dim1;
		    i__5 = j + k * x_dim1;
		    tmp += ((r__1 = a[i__4].r, dabs(r__1)) + (r__2 = r_imag(&
			    a[j + i__ * a_dim1]), dabs(r__2))) * ((r__3 = x[
			    i__5].r, dabs(r__3)) + (r__4 = r_imag(&x[j + k * 
			    x_dim1]), dabs(r__4)));
/* L40: */
		}
		i__3 = i__ + i__ * a_dim1;
		i__4 = i__ + k * x_dim1;
		tmp += (r__1 = a[i__3].r, dabs(r__1)) * ((r__2 = x[i__4].r, 
			dabs(r__2)) + (r__3 = r_imag(&x[i__ + k * x_dim1]), 
			dabs(r__3)));
		i__3 = *n;
		for (j = i__ + 1; j <= i__3; ++j) {
		    i__4 = i__ + j * a_dim1;
		    i__5 = j + k * x_dim1;
		    tmp += ((r__1 = a[i__4].r, dabs(r__1)) + (r__2 = r_imag(&
			    a[i__ + j * a_dim1]), dabs(r__2))) * ((r__3 = x[
			    i__5].r, dabs(r__3)) + (r__4 = r_imag(&x[j + k * 
			    x_dim1]), dabs(r__4)));
/* L50: */
		}
	    } else {
		i__3 = i__ - 1;
		for (j = 1; j <= i__3; ++j) {
		    i__4 = i__ + j * a_dim1;
		    i__5 = j + k * x_dim1;
		    tmp += ((r__1 = a[i__4].r, dabs(r__1)) + (r__2 = r_imag(&
			    a[i__ + j * a_dim1]), dabs(r__2))) * ((r__3 = x[
			    i__5].r, dabs(r__3)) + (r__4 = r_imag(&x[j + k * 
			    x_dim1]), dabs(r__4)));
/* L60: */
		}
		i__3 = i__ + i__ * a_dim1;
		i__4 = i__ + k * x_dim1;
		tmp += (r__1 = a[i__3].r, dabs(r__1)) * ((r__2 = x[i__4].r, 
			dabs(r__2)) + (r__3 = r_imag(&x[i__ + k * x_dim1]), 
			dabs(r__3)));
		i__3 = *n;
		for (j = i__ + 1; j <= i__3; ++j) {
		    i__4 = j + i__ * a_dim1;
		    i__5 = j + k * x_dim1;
		    tmp += ((r__1 = a[i__4].r, dabs(r__1)) + (r__2 = r_imag(&
			    a[j + i__ * a_dim1]), dabs(r__2))) * ((r__3 = x[
			    i__5].r, dabs(r__3)) + (r__4 = r_imag(&x[j + k * 
			    x_dim1]), dabs(r__4)));
/* L70: */
		}
	    }
	    if (i__ == 1) {
		axbi = tmp;
	    } else {
		axbi = dmin(axbi,tmp);
	    }
/* L80: */
	}
/* Computing MAX */
	r__1 = axbi, r__2 = (*n + 1) * unfl;
	tmp = berr[k] / ((*n + 1) * eps + (*n + 1) * unfl / dmax(r__1,r__2));
	if (k == 1) {
	    reslts[2] = tmp;
	} else {
	    reslts[2] = dmax(reslts[2],tmp);
	}
/* L90: */
    }

    return 0;

/*     End of CPOT05 */

} /* cpot05_ */
示例#16
0
文件: qc25c.c 项目: pyal/eos_cpp
/* Subroutine */ int qc25c_(E_fp f, real *a, real *b, real *c__, real *result,
	 real *abserr, integer *krul, integer *neval)
{
    /* Initialized data */

    static real x[11] = { (float).9914448613738104,(float).9659258262890683,(
	    float).9238795325112868,(float).8660254037844386,(float)
	    .7933533402912352,(float).7071067811865475,(float)
	    .6087614290087206,(float).5,(float).3826834323650898,(float)
	    .2588190451025208,(float).1305261922200516 };

    /* System generated locals */
    real r__1;

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

    /* Local variables */
    real fval[25], res12, res24;
    extern /* Subroutine */ int qk15w_(E_fp, E_fp, real *, real *, real *, 
	    real *, integer *, real *, real *, real *, real *, real *, real *)
	    ;
    integer isym;
    real amom0, amom1, amom2, cheb12[13], cheb24[25];
    integer i__, k;
    extern /* Subroutine */ int qcheb_(real *, real *, real *, real *);
    real u, hlgth, centr;
    extern doublereal qwgtc_(real *x, real *c__, real *p2, real *p3, real *p4, 
							 integer *kp);
    real p2, p3, p4, cc;
    integer kp;
    real resabs, resasc, ak22;

/* ***begin prologue  qc25c */
/* ***date written   810101   (yymmdd) */
/* ***revision date  830518   (yymmdd) */
/* ***category no.  h2a2a2,j4 */
/* ***keywords  25-point clenshaw-curtis integration */
/* ***author  piessens,robert,appl. math. & progr. div. - k.u.leuven */
/*           de doncker,elise,appl. math. & progr. div. - k.u.leuven */
/* ***purpose  to compute i = integral of f*w over (a,b) with */
/*            error estimate, where w(x) = 1/(x-c) */
/* ***description */

/*        integration rules for the computation of cauchy */
/*        principal value integrals */
/*        standard fortran subroutine */
/*        real version */

/*        parameters */
/*           f      - real */
/*                    function subprogram defining the integrand function */
/*                    f(x). the actual name for f needs to be declared */
/*                    e x t e r n a l  in the driver program. */

/*           a      - real */
/*                    left end point of the integration interval */

/*           b      - real */
/*                    right end point of the integration interval, b.gt.a */

/*           c      - real */
/*                    parameter in the weight function */

/*           result - real */
/*                    approximation to the integral */
/*                    result is computed by using a generalized */
/*                    clenshaw-curtis method if c lies within ten percent */
/*                    of the integration interval. in the other case the */
/*                    15-point kronrod rule obtained by optimal addition */
/*                    of abscissae to the 7-point gauss rule, is applied. */

/*           abserr - real */
/*                    estimate of the modulus of the absolute error, */
/*                    which should equal or exceed abs(i-result) */

/*           krul   - integer */
/*                    key which is decreased by 1 if the 15-point */
/*                    gauss-kronrod scheme has been used */

/*           neval  - integer */
/*                    number of integrand evaluations */

/* ***references  (none) */
/* ***routines called  qcheb,qk15w,qwgtc */
/* ***end prologue  qc25c */




/*           the vector x contains the values cos(k*pi/24), */
/*           k = 1, ..., 11, to be used for the chebyshev series */
/*           expansion of f */


/*           list of major variables */
/*           ---------------------- */
/*           fval   - value of the function f at the points */
/*                    cos(k*pi/24),  k = 0, ..., 24 */
/*           cheb12 - chebyshev series expansion coefficients, */
/*                    for the function f, of degree 12 */
/*           cheb24 - chebyshev series expansion coefficients, */
/*                    for the function f, of degree 24 */
/*           res12  - approximation to the integral corresponding */
/*                    to the use of cheb12 */
/*           res24  - approximation to the integral corresponding */
/*                    to the use of cheb24 */
/*           qwgtc - external function subprogram defining */
/*                    the weight function */
/*           hlgth  - half-length of the interval */
/*           centr  - mid point of the interval */


/*           check the position of c. */

/* ***first executable statement  qc25c */
    cc = ((float)2. * *c__ - *b - *a) / (*b - *a);
    if (dabs(cc) < (float)1.1) {
	goto L10;
    }

/*           apply the 15-point gauss-kronrod scheme. */

    --(*krul);
    qk15w_((E_fp)f, (E_fp)qwgtc_, c__, &p2, &p3, &p4, &kp, a, b, result, 
	    abserr, &resabs, &resasc);
    *neval = 15;
    if (resasc == *abserr) {
	++(*krul);
    }
    goto L50;

/*           use the generalized clenshaw-curtis method. */

L10:
    hlgth = (*b - *a) * (float).5;
    centr = (*b + *a) * (float).5;
    *neval = 25;
    r__1 = hlgth + centr;
    fval[0] = (*f)(&r__1) * (float).5;
    fval[12] = (*f)(&centr);
    r__1 = centr - hlgth;
    fval[24] = (*f)(&r__1) * (float).5;
    for (i__ = 2; i__ <= 12; ++i__) {
	u = hlgth * x[i__ - 2];
	isym = 26 - i__;
	r__1 = u + centr;
	fval[i__ - 1] = (*f)(&r__1);
	r__1 = centr - u;
	fval[isym - 1] = (*f)(&r__1);
/* L20: */
    }

/*           compute the chebyshev series expansion. */

    qcheb_(x, fval, cheb12, cheb24);

/*           the modified chebyshev moments are computed */
/*           by forward recursion, using amom0 and amom1 */
/*           as starting values. */

    amom0 = log((r__1 = ((float)1. - cc) / (cc + (float)1.), dabs(r__1)));
    amom1 = cc * amom0 + (float)2.;
    res12 = cheb12[0] * amom0 + cheb12[1] * amom1;
    res24 = cheb24[0] * amom0 + cheb24[1] * amom1;
    for (k = 3; k <= 13; ++k) {
	amom2 = cc * (float)2. * amom1 - amom0;
	ak22 = (real) ((k - 2) * (k - 2));
	if (k / 2 << 1 == k) {
	    amom2 -= (float)4. / (ak22 - (float)1.);
	}
	res12 += cheb12[k - 1] * amom2;
	res24 += cheb24[k - 1] * amom2;
	amom0 = amom1;
	amom1 = amom2;
/* L30: */
    }
    for (k = 14; k <= 25; ++k) {
	amom2 = cc * (float)2. * amom1 - amom0;
	ak22 = (real) ((k - 2) * (k - 2));
	if (k / 2 << 1 == k) {
	    amom2 -= (float)4. / (ak22 - (float)1.);
	}
	res24 += cheb24[k - 1] * amom2;
	amom0 = amom1;
	amom1 = amom2;
/* L40: */
    }
    *result = res24;
    *abserr = (r__1 = res24 - res12, dabs(r__1));
L50:
    return 0;
} /* qc25c_ */
示例#17
0
/* Subroutine */ int sgebal_(char *job, integer *n, real *a, integer *lda, 
	integer *ilo, integer *ihi, real *scale, integer *info, ftnlen 
	job_len)
{
    /* System generated locals */
    integer a_dim1, a_offset, i__1, i__2;
    real r__1, r__2;

    /* Local variables */
    static real c__, f, g;
    static integer i__, j, k, l, m;
    static real r__, s, ca, ra;
    static integer ica, ira, iexc;
    extern logical lsame_(char *, char *, ftnlen, ftnlen);
    extern /* Subroutine */ int sscal_(integer *, real *, real *, integer *), 
	    sswap_(integer *, real *, integer *, real *, integer *);
    static real sfmin1, sfmin2, sfmax1, sfmax2;
    extern doublereal slamch_(char *, ftnlen);
    extern /* Subroutine */ int xerbla_(char *, integer *, ftnlen);
    extern integer isamax_(integer *, real *, integer *);
    static logical noconv;


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

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

/*  SGEBAL balances a general real matrix A.  This involves, first, */
/*  permuting A by a similarity transformation to isolate eigenvalues */
/*  in the first 1 to ILO-1 and last IHI+1 to N elements on the */
/*  diagonal; and second, applying a diagonal similarity transformation */
/*  to rows and columns ILO to IHI to make the rows and columns as */
/*  close in norm as possible.  Both steps are optional. */

/*  Balancing may reduce the 1-norm of the matrix, and improve the */
/*  accuracy of the computed eigenvalues and/or eigenvectors. */

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

/*  JOB     (input) CHARACTER*1 */
/*          Specifies the operations to be performed on A: */
/*          = 'N':  none:  simply set ILO = 1, IHI = N, SCALE(I) = 1.0 */
/*                  for i = 1,...,N; */
/*          = 'P':  permute only; */
/*          = 'S':  scale only; */
/*          = 'B':  both permute and scale. */

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

/*  A       (input/output) REAL array, dimension (LDA,N) */
/*          On entry, the input matrix A. */
/*          On exit,  A is overwritten by the balanced matrix. */
/*          If JOB = 'N', A is not referenced. */
/*          See Further Details. */

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

/*  ILO     (output) INTEGER */
/*  IHI     (output) INTEGER */
/*          ILO and IHI are set to integers such that on exit */
/*          A(i,j) = 0 if i > j and j = 1,...,ILO-1 or I = IHI+1,...,N. */
/*          If JOB = 'N' or 'S', ILO = 1 and IHI = N. */

/*  SCALE   (output) REAL array, dimension (N) */
/*          Details of the permutations and scaling factors applied to */
/*          A.  If P(j) is the index of the row and column interchanged */
/*          with row and column j and D(j) is the scaling factor */
/*          applied to row and column j, then */
/*          SCALE(j) = P(j)    for j = 1,...,ILO-1 */
/*                   = D(j)    for j = ILO,...,IHI */
/*                   = P(j)    for j = IHI+1,...,N. */
/*          The order in which the interchanges are made is N to IHI+1, */
/*          then 1 to ILO-1. */

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

/*  Further Details */
/*  =============== */

/*  The permutations consist of row and column interchanges which put */
/*  the matrix in the form */

/*             ( T1   X   Y  ) */
/*     P A P = (  0   B   Z  ) */
/*             (  0   0   T2 ) */

/*  where T1 and T2 are upper triangular matrices whose eigenvalues lie */
/*  along the diagonal.  The column indices ILO and IHI mark the starting */
/*  and ending columns of the submatrix B. Balancing consists of applying */
/*  a diagonal similarity transformation inv(D) * B * D to make the */
/*  1-norms of each row of B and its corresponding column nearly equal. */
/*  The output matrix is */

/*     ( T1     X*D          Y    ) */
/*     (  0  inv(D)*B*D  inv(D)*Z ). */
/*     (  0      0           T2   ) */

/*  Information about the permutations P and the diagonal matrix D is */
/*  returned in the vector SCALE. */

/*  This subroutine is based on the EISPACK routine BALANC. */

/*  Modified by Tzu-Yi Chen, Computer Science Division, University of */
/*    California at Berkeley, USA */

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

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

/*     Test the input parameters */

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

    /* Function Body */
    *info = 0;
    if (! lsame_(job, "N", (ftnlen)1, (ftnlen)1) && ! lsame_(job, "P", (
	    ftnlen)1, (ftnlen)1) && ! lsame_(job, "S", (ftnlen)1, (ftnlen)1) 
	    && ! lsame_(job, "B", (ftnlen)1, (ftnlen)1)) {
	*info = -1;
    } else if (*n < 0) {
	*info = -2;
    } else if (*lda < max(1,*n)) {
	*info = -4;
    }
    if (*info != 0) {
	i__1 = -(*info);
	xerbla_("SGEBAL", &i__1, (ftnlen)6);
	return 0;
    }

    k = 1;
    l = *n;

    if (*n == 0) {
	goto L210;
    }

    if (lsame_(job, "N", (ftnlen)1, (ftnlen)1)) {
	i__1 = *n;
	for (i__ = 1; i__ <= i__1; ++i__) {
	    scale[i__] = 1.f;
/* L10: */
	}
	goto L210;
    }

    if (lsame_(job, "S", (ftnlen)1, (ftnlen)1)) {
	goto L120;
    }

/*     Permutation to isolate eigenvalues if possible */

    goto L50;

/*     Row and column exchange. */

L20:
    scale[m] = (real) j;
    if (j == m) {
	goto L30;
    }

    sswap_(&l, &a[j * a_dim1 + 1], &c__1, &a[m * a_dim1 + 1], &c__1);
    i__1 = *n - k + 1;
    sswap_(&i__1, &a[j + k * a_dim1], lda, &a[m + k * a_dim1], lda);

L30:
    switch (iexc) {
	case 1:  goto L40;
	case 2:  goto L80;
    }

/*     Search for rows isolating an eigenvalue and push them down. */

L40:
    if (l == 1) {
	goto L210;
    }
    --l;

L50:
    for (j = l; j >= 1; --j) {

	i__1 = l;
	for (i__ = 1; i__ <= i__1; ++i__) {
	    if (i__ == j) {
		goto L60;
	    }
	    if (a[j + i__ * a_dim1] != 0.f) {
		goto L70;
	    }
L60:
	    ;
	}

	m = l;
	iexc = 1;
	goto L20;
L70:
	;
    }

    goto L90;

/*     Search for columns isolating an eigenvalue and push them left. */

L80:
    ++k;

L90:
    i__1 = l;
    for (j = k; j <= i__1; ++j) {

	i__2 = l;
	for (i__ = k; i__ <= i__2; ++i__) {
	    if (i__ == j) {
		goto L100;
	    }
	    if (a[i__ + j * a_dim1] != 0.f) {
		goto L110;
	    }
L100:
	    ;
	}

	m = k;
	iexc = 2;
	goto L20;
L110:
	;
    }

L120:
    i__1 = l;
    for (i__ = k; i__ <= i__1; ++i__) {
	scale[i__] = 1.f;
/* L130: */
    }

    if (lsame_(job, "P", (ftnlen)1, (ftnlen)1)) {
	goto L210;
    }

/*     Balance the submatrix in rows K to L. */

/*     Iterative loop for norm reduction */

    sfmin1 = slamch_("S", (ftnlen)1) / slamch_("P", (ftnlen)1);
    sfmax1 = 1.f / sfmin1;
    sfmin2 = sfmin1 * 8.f;
    sfmax2 = 1.f / sfmin2;
L140:
    noconv = FALSE_;

    i__1 = l;
    for (i__ = k; i__ <= i__1; ++i__) {
	c__ = 0.f;
	r__ = 0.f;

	i__2 = l;
	for (j = k; j <= i__2; ++j) {
	    if (j == i__) {
		goto L150;
	    }
	    c__ += (r__1 = a[j + i__ * a_dim1], dabs(r__1));
	    r__ += (r__1 = a[i__ + j * a_dim1], dabs(r__1));
L150:
	    ;
	}
	ica = isamax_(&l, &a[i__ * a_dim1 + 1], &c__1);
	ca = (r__1 = a[ica + i__ * a_dim1], dabs(r__1));
	i__2 = *n - k + 1;
	ira = isamax_(&i__2, &a[i__ + k * a_dim1], lda);
	ra = (r__1 = a[i__ + (ira + k - 1) * a_dim1], dabs(r__1));

/*        Guard against zero C or R due to underflow. */

	if (c__ == 0.f || r__ == 0.f) {
	    goto L200;
	}
	g = r__ / 8.f;
	f = 1.f;
	s = c__ + r__;
L160:
/* Computing MAX */
	r__1 = max(f,c__);
/* Computing MIN */
	r__2 = min(r__,g);
	if (c__ >= g || dmax(r__1,ca) >= sfmax2 || dmin(r__2,ra) <= sfmin2) {
	    goto L170;
	}
	f *= 8.f;
	c__ *= 8.f;
	ca *= 8.f;
	r__ /= 8.f;
	g /= 8.f;
	ra /= 8.f;
	goto L160;

L170:
	g = c__ / 8.f;
L180:
/* Computing MIN */
	r__1 = min(f,c__), r__1 = min(r__1,g);
	if (g < r__ || dmax(r__,ra) >= sfmax2 || dmin(r__1,ca) <= sfmin2) {
	    goto L190;
	}
	f /= 8.f;
	c__ /= 8.f;
	g /= 8.f;
	ca /= 8.f;
	r__ *= 8.f;
	ra *= 8.f;
	goto L180;

/*        Now balance. */

L190:
	if (c__ + r__ >= s * .95f) {
	    goto L200;
	}
	if (f < 1.f && scale[i__] < 1.f) {
	    if (f * scale[i__] <= sfmin1) {
		goto L200;
	    }
	}
	if (f > 1.f && scale[i__] > 1.f) {
	    if (scale[i__] >= sfmax1 / f) {
		goto L200;
	    }
	}
	g = 1.f / f;
	scale[i__] *= f;
	noconv = TRUE_;

	i__2 = *n - k + 1;
	sscal_(&i__2, &g, &a[i__ + k * a_dim1], lda);
	sscal_(&l, &f, &a[i__ * a_dim1 + 1], &c__1);

L200:
	;
    }

    if (noconv) {
	goto L140;
    }

L210:
    *ilo = k;
    *ihi = l;

    return 0;

/*     End of SGEBAL */

} /* sgebal_ */
示例#18
0
/* Subroutine */ int clatps_(char *uplo, char *trans, char *diag, char *
	normin, integer *n, complex *ap, complex *x, real *scale, real *cnorm,
	 integer *info)
{
/*  -- LAPACK auxiliary routine (version 3.0) --   
       Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,   
       Courant Institute, Argonne National Lab, and Rice University   
       October 31, 1992   


    Purpose   
    =======   

    CLATPS 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, where A is an upper or lower   
    triangular matrix stored in packed form.  Here 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 CTPSV 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.   

    AP      (input) COMPLEX array, dimension (N*(N+1)/2)   
            The upper or lower triangular matrix A, packed columnwise in   
            a linear array.  The j-th column of A is stored in the array   
            AP as follows:   
            if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j;   
            if UPLO = 'L', AP(i + (j-1)*(2n-j)/2) = A(i,j) for j<=i<=n.   

    X       (input/output) COMPLEX 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) REAL   
            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) REAL 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, CTPSV   
    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]   
         for j = 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]   
    Initially, let M(0) = 0 and G(0) = max{x(i), i=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 CTPSV if the   
    reciprocal of the largest M(j), j=1,..,n, is larger than   
    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   

         for j = 1, ..., n   
              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   

    The initial values are G(0) = 0, M(0) = max{b(i), i=1,..,n}, and we   
    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 CTPSV if 1/M(n) and 1/G(n) are both greater   
    than max(underflow, 1/overflow).   

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


       Parameter adjustments */
    /* Table of constant values */
    static integer c__1 = 1;
    static real c_b36 = .5f;
    
    /* System generated locals */
    integer i__1, i__2, i__3, i__4, i__5;
    real r__1, r__2, r__3, r__4;
    complex q__1, q__2, q__3, q__4;
    /* Builtin functions */
    double r_imag(complex *);
    void r_cnjg(complex *, complex *);
    /* Local variables */
    static integer jinc, jlen;
    static real xbnd;
    static integer imax;
    static real tmax;
    static complex tjjs;
    static real xmax, grow;
    static integer i__, j;
    extern /* Complex */ VOID cdotc_(complex *, integer *, complex *, integer 
	    *, complex *, integer *);
    extern logical lsame_(char *, char *);
    extern /* Subroutine */ int sscal_(integer *, real *, real *, integer *);
    static real tscal;
    static complex uscal;
    static integer jlast;
    extern /* Complex */ VOID cdotu_(complex *, integer *, complex *, integer 
	    *, complex *, integer *);
    static complex csumj;
    extern /* Subroutine */ int caxpy_(integer *, complex *, complex *, 
	    integer *, complex *, integer *);
    static logical upper;
    extern /* Subroutine */ int ctpsv_(char *, char *, char *, integer *, 
	    complex *, complex *, integer *), slabad_(
	    real *, real *);
    static integer ip;
    static real xj;
    extern integer icamax_(integer *, complex *, integer *);
    extern /* Complex */ VOID cladiv_(complex *, complex *, complex *);
    extern doublereal slamch_(char *);
    extern /* Subroutine */ int csscal_(integer *, real *, complex *, integer 
	    *), xerbla_(char *, integer *);
    static real bignum;
    extern integer isamax_(integer *, real *, integer *);
    extern doublereal scasum_(integer *, complex *, integer *);
    static logical notran;
    static integer jfirst;
    static real smlnum;
    static logical nounit;
    static real rec, tjj;


    --cnorm;
    --x;
    --ap;

    /* 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;
    }
    if (*info != 0) {
	i__1 = -(*info);
	xerbla_("CLATPS", &i__1);
	return 0;
    }

/*     Quick return if possible */

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

/*     Determine machine dependent parameters to control overflow. */

    smlnum = slamch_("Safe minimum");
    bignum = 1.f / smlnum;
    slabad_(&smlnum, &bignum);
    smlnum /= slamch_("Precision");
    bignum = 1.f / smlnum;
    *scale = 1.f;

    if (lsame_(normin, "N")) {

/*        Compute the 1-norm of each column, not including the diagonal. */

	if (upper) {

/*           A is upper triangular. */

	    ip = 1;
	    i__1 = *n;
	    for (j = 1; j <= i__1; ++j) {
		i__2 = j - 1;
		cnorm[j] = scasum_(&i__2, &ap[ip], &c__1);
		ip += j;
/* L10: */
	    }
	} else {

/*           A is lower triangular. */

	    ip = 1;
	    i__1 = *n - 1;
	    for (j = 1; j <= i__1; ++j) {
		i__2 = *n - j;
		cnorm[j] = scasum_(&i__2, &ap[ip + 1], &c__1);
		ip = ip + *n - j + 1;
/* L20: */
	    }
	    cnorm[*n] = 0.f;
	}
    }

/*     Scale the column norms by TSCAL if the maximum element in CNORM is   
       greater than BIGNUM/2. */

    imax = isamax_(n, &cnorm[1], &c__1);
    tmax = cnorm[imax];
    if (tmax <= bignum * .5f) {
	tscal = 1.f;
    } else {
	tscal = .5f / (smlnum * tmax);
	sscal_(n, &tscal, &cnorm[1], &c__1);
    }

/*     Compute a bound on the computed solution vector to see if the   
       Level 2 BLAS routine CTPSV can be used. */

    xmax = 0.f;
    i__1 = *n;
    for (j = 1; j <= i__1; ++j) {
/* Computing MAX */
	i__2 = j;
	r__3 = xmax, r__4 = (r__1 = x[i__2].r / 2.f, dabs(r__1)) + (r__2 = 
		r_imag(&x[j]) / 2.f, dabs(r__2));
	xmax = dmax(r__3,r__4);
/* L30: */
    }
    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.f) {
	    grow = 0.f;
	    goto L60;
	}

	if (nounit) {

/*           A is non-unit triangular.   

             Compute GROW = 1/G(j) and XBND = 1/M(j).   
             Initially, G(0) = max{x(i), i=1,...,n}. */

	    grow = .5f / dmax(xbnd,smlnum);
	    xbnd = grow;
	    ip = jfirst * (jfirst + 1) / 2;
	    jlen = *n;
	    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 = ip;
		tjjs.r = ap[i__3].r, tjjs.i = ap[i__3].i;
		tjj = (r__1 = tjjs.r, dabs(r__1)) + (r__2 = r_imag(&tjjs), 
			dabs(r__2));

		if (tjj >= smlnum) {

/*                 M(j) = G(j-1) / abs(A(j,j))   

   Computing MIN */
		    r__1 = xbnd, r__2 = dmin(1.f,tjj) * grow;
		    xbnd = dmin(r__1,r__2);
		} else {

/*                 M(j) could overflow, set XBND to 0. */

		    xbnd = 0.f;
		}

		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.f;
		}
		ip += jinc * jlen;
		--jlen;
/* L40: */
	    }
	    grow = xbnd;
	} else {

/*           A is unit triangular.   

             Compute GROW = 1/G(j), where G(0) = max{x(i), i=1,...,n}.   

   Computing MIN */
	    r__1 = 1.f, r__2 = .5f / dmax(xbnd,smlnum);
	    grow = dmin(r__1,r__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.f / (cnorm[j] + 1.f);
/* L50: */
	    }
	}
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.f) {
	    grow = 0.f;
	    goto L90;
	}

	if (nounit) {

/*           A is non-unit triangular.   

             Compute GROW = 1/G(j) and XBND = 1/M(j).   
             Initially, M(0) = max{x(i), i=1,...,n}. */

	    grow = .5f / dmax(xbnd,smlnum);
	    xbnd = grow;
	    ip = jfirst * (jfirst + 1) / 2;
	    jlen = 1;
	    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.f;
/* Computing MIN */
		r__1 = grow, r__2 = xbnd / xj;
		grow = dmin(r__1,r__2);

		i__3 = ip;
		tjjs.r = ap[i__3].r, tjjs.i = ap[i__3].i;
		tjj = (r__1 = tjjs.r, dabs(r__1)) + (r__2 = r_imag(&tjjs), 
			dabs(r__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.f;
		}
		++jlen;
		ip += jinc * jlen;
/* L70: */
	    }
	    grow = dmin(grow,xbnd);
	} else {

/*           A is unit triangular.   

             Compute GROW = 1/G(j), where G(0) = max{x(i), i=1,...,n}.   

   Computing MIN */
	    r__1 = 1.f, r__2 = .5f / dmax(xbnd,smlnum);
	    grow = dmin(r__1,r__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.f;
		grow /= xj;
/* L80: */
	    }
	}
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. */

	ctpsv_(uplo, trans, diag, n, &ap[1], &x[1], &c__1);
    } else {

/*        Use a Level 1 BLAS solve, scaling intermediate results. */

	if (xmax > bignum * .5f) {

/*           Scale X so that its components are less than or equal to   
             BIGNUM in absolute value. */

	    *scale = bignum * .5f / xmax;
	    csscal_(n, scale, &x[1], &c__1);
	    xmax = bignum;
	} else {
	    xmax *= 2.f;
	}

	if (notran) {

/*           Solve A * x = b */

	    ip = jfirst * (jfirst + 1) / 2;
	    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 = (r__1 = x[i__3].r, dabs(r__1)) + (r__2 = r_imag(&x[j]), 
			dabs(r__2));
		if (nounit) {
		    i__3 = ip;
		    q__1.r = tscal * ap[i__3].r, q__1.i = tscal * ap[i__3].i;
		    tjjs.r = q__1.r, tjjs.i = q__1.i;
		} else {
		    tjjs.r = tscal, tjjs.i = 0.f;
		    if (tscal == 1.f) {
			goto L105;
		    }
		}
		tjj = (r__1 = tjjs.r, dabs(r__1)) + (r__2 = r_imag(&tjjs), 
			dabs(r__2));
		if (tjj > smlnum) {

/*                    abs(A(j,j)) > SMLNUM: */

		    if (tjj < 1.f) {
			if (xj > tjj * bignum) {

/*                          Scale x by 1/b(j). */

			    rec = 1.f / xj;
			    csscal_(n, &rec, &x[1], &c__1);
			    *scale *= rec;
			    xmax *= rec;
			}
		    }
		    i__3 = j;
		    cladiv_(&q__1, &x[j], &tjjs);
		    x[i__3].r = q__1.r, x[i__3].i = q__1.i;
		    i__3 = j;
		    xj = (r__1 = x[i__3].r, dabs(r__1)) + (r__2 = r_imag(&x[j]
			    ), dabs(r__2));
		} else if (tjj > 0.f) {

/*                    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.f) {

/*                          Scale by 1/CNORM(j) to avoid overflow when   
                            multiplying x(j) times column j. */

			    rec /= cnorm[j];
			}
			csscal_(n, &rec, &x[1], &c__1);
			*scale *= rec;
			xmax *= rec;
		    }
		    i__3 = j;
		    cladiv_(&q__1, &x[j], &tjjs);
		    x[i__3].r = q__1.r, x[i__3].i = q__1.i;
		    i__3 = j;
		    xj = (r__1 = x[i__3].r, dabs(r__1)) + (r__2 = r_imag(&x[j]
			    ), dabs(r__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.f, x[i__4].i = 0.f;
/* L100: */
		    }
		    i__3 = j;
		    x[i__3].r = 1.f, x[i__3].i = 0.f;
		    xj = 1.f;
		    *scale = 0.f;
		    xmax = 0.f;
		}
L105:

/*              Scale x if necessary to avoid overflow when adding a   
                multiple of column j of A. */

		if (xj > 1.f) {
		    rec = 1.f / xj;
		    if (cnorm[j] > (bignum - xmax) * rec) {

/*                    Scale x by 1/(2*abs(x(j))). */

			rec *= .5f;
			csscal_(n, &rec, &x[1], &c__1);
			*scale *= rec;
		    }
		} else if (xj * cnorm[j] > bignum - xmax) {

/*                 Scale x by 1/2. */

		    csscal_(n, &c_b36, &x[1], &c__1);
		    *scale *= .5f;
		}

		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;
			q__2.r = -x[i__4].r, q__2.i = -x[i__4].i;
			q__1.r = tscal * q__2.r, q__1.i = tscal * q__2.i;
			caxpy_(&i__3, &q__1, &ap[ip - j + 1], &c__1, &x[1], &
				c__1);
			i__3 = j - 1;
			i__ = icamax_(&i__3, &x[1], &c__1);
			i__3 = i__;
			xmax = (r__1 = x[i__3].r, dabs(r__1)) + (r__2 = 
				r_imag(&x[i__]), dabs(r__2));
		    }
		    ip -= j;
		} 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;
			q__2.r = -x[i__4].r, q__2.i = -x[i__4].i;
			q__1.r = tscal * q__2.r, q__1.i = tscal * q__2.i;
			caxpy_(&i__3, &q__1, &ap[ip + 1], &c__1, &x[j + 1], &
				c__1);
			i__3 = *n - j;
			i__ = j + icamax_(&i__3, &x[j + 1], &c__1);
			i__3 = i__;
			xmax = (r__1 = x[i__3].r, dabs(r__1)) + (r__2 = 
				r_imag(&x[i__]), dabs(r__2));
		    }
		    ip = ip + *n - j + 1;
		}
/* L110: */
	    }

	} else if (lsame_(trans, "T")) {

/*           Solve A**T * x = b */

	    ip = jfirst * (jfirst + 1) / 2;
	    jlen = 1;
	    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 = (r__1 = x[i__3].r, dabs(r__1)) + (r__2 = r_imag(&x[j]), 
			dabs(r__2));
		uscal.r = tscal, uscal.i = 0.f;
		rec = 1.f / dmax(xmax,1.f);
		if (cnorm[j] > (bignum - xj) * rec) {

/*                 If x(j) could overflow, scale x by 1/(2*XMAX). */

		    rec *= .5f;
		    if (nounit) {
			i__3 = ip;
			q__1.r = tscal * ap[i__3].r, q__1.i = tscal * ap[i__3]
				.i;
			tjjs.r = q__1.r, tjjs.i = q__1.i;
		    } else {
			tjjs.r = tscal, tjjs.i = 0.f;
		    }
		    tjj = (r__1 = tjjs.r, dabs(r__1)) + (r__2 = r_imag(&tjjs),
			     dabs(r__2));
		    if (tjj > 1.f) {

/*                       Divide by A(j,j) when scaling x if A(j,j) > 1.   

   Computing MIN */
			r__1 = 1.f, r__2 = rec * tjj;
			rec = dmin(r__1,r__2);
			cladiv_(&q__1, &uscal, &tjjs);
			uscal.r = q__1.r, uscal.i = q__1.i;
		    }
		    if (rec < 1.f) {
			csscal_(n, &rec, &x[1], &c__1);
			*scale *= rec;
			xmax *= rec;
		    }
		}

		csumj.r = 0.f, csumj.i = 0.f;
		if (uscal.r == 1.f && uscal.i == 0.f) {

/*                 If the scaling needed for A in the dot product is 1,   
                   call CDOTU to perform the dot product. */

		    if (upper) {
			i__3 = j - 1;
			cdotu_(&q__1, &i__3, &ap[ip - j + 1], &c__1, &x[1], &
				c__1);
			csumj.r = q__1.r, csumj.i = q__1.i;
		    } else if (j < *n) {
			i__3 = *n - j;
			cdotu_(&q__1, &i__3, &ap[ip + 1], &c__1, &x[j + 1], &
				c__1);
			csumj.r = q__1.r, csumj.i = q__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 = ip - j + i__;
			    q__3.r = ap[i__4].r * uscal.r - ap[i__4].i * 
				    uscal.i, q__3.i = ap[i__4].r * uscal.i + 
				    ap[i__4].i * uscal.r;
			    i__5 = i__;
			    q__2.r = q__3.r * x[i__5].r - q__3.i * x[i__5].i, 
				    q__2.i = q__3.r * x[i__5].i + q__3.i * x[
				    i__5].r;
			    q__1.r = csumj.r + q__2.r, q__1.i = csumj.i + 
				    q__2.i;
			    csumj.r = q__1.r, csumj.i = q__1.i;
/* L120: */
			}
		    } else if (j < *n) {
			i__3 = *n - j;
			for (i__ = 1; i__ <= i__3; ++i__) {
			    i__4 = ip + i__;
			    q__3.r = ap[i__4].r * uscal.r - ap[i__4].i * 
				    uscal.i, q__3.i = ap[i__4].r * uscal.i + 
				    ap[i__4].i * uscal.r;
			    i__5 = j + i__;
			    q__2.r = q__3.r * x[i__5].r - q__3.i * x[i__5].i, 
				    q__2.i = q__3.r * x[i__5].i + q__3.i * x[
				    i__5].r;
			    q__1.r = csumj.r + q__2.r, q__1.i = csumj.i + 
				    q__2.i;
			    csumj.r = q__1.r, csumj.i = q__1.i;
/* L130: */
			}
		    }
		}

		q__1.r = tscal, q__1.i = 0.f;
		if (uscal.r == q__1.r && uscal.i == q__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;
		    q__1.r = x[i__4].r - csumj.r, q__1.i = x[i__4].i - 
			    csumj.i;
		    x[i__3].r = q__1.r, x[i__3].i = q__1.i;
		    i__3 = j;
		    xj = (r__1 = x[i__3].r, dabs(r__1)) + (r__2 = r_imag(&x[j]
			    ), dabs(r__2));
		    if (nounit) {

/*                    Compute x(j) = x(j) / A(j,j), scaling if necessary. */

			i__3 = ip;
			q__1.r = tscal * ap[i__3].r, q__1.i = tscal * ap[i__3]
				.i;
			tjjs.r = q__1.r, tjjs.i = q__1.i;
		    } else {
			tjjs.r = tscal, tjjs.i = 0.f;
			if (tscal == 1.f) {
			    goto L145;
			}
		    }
		    tjj = (r__1 = tjjs.r, dabs(r__1)) + (r__2 = r_imag(&tjjs),
			     dabs(r__2));
		    if (tjj > smlnum) {

/*                       abs(A(j,j)) > SMLNUM: */

			if (tjj < 1.f) {
			    if (xj > tjj * bignum) {

/*                             Scale X by 1/abs(x(j)). */

				rec = 1.f / xj;
				csscal_(n, &rec, &x[1], &c__1);
				*scale *= rec;
				xmax *= rec;
			    }
			}
			i__3 = j;
			cladiv_(&q__1, &x[j], &tjjs);
			x[i__3].r = q__1.r, x[i__3].i = q__1.i;
		    } else if (tjj > 0.f) {

/*                       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;
			    csscal_(n, &rec, &x[1], &c__1);
			    *scale *= rec;
			    xmax *= rec;
			}
			i__3 = j;
			cladiv_(&q__1, &x[j], &tjjs);
			x[i__3].r = q__1.r, x[i__3].i = q__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.f, x[i__4].i = 0.f;
/* L140: */
			}
			i__3 = j;
			x[i__3].r = 1.f, x[i__3].i = 0.f;
			*scale = 0.f;
			xmax = 0.f;
		    }
L145:
		    ;
		} 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;
		    cladiv_(&q__2, &x[j], &tjjs);
		    q__1.r = q__2.r - csumj.r, q__1.i = q__2.i - csumj.i;
		    x[i__3].r = q__1.r, x[i__3].i = q__1.i;
		}
/* Computing MAX */
		i__3 = j;
		r__3 = xmax, r__4 = (r__1 = x[i__3].r, dabs(r__1)) + (r__2 = 
			r_imag(&x[j]), dabs(r__2));
		xmax = dmax(r__3,r__4);
		++jlen;
		ip += jinc * jlen;
/* L150: */
	    }

	} else {

/*           Solve A**H * x = b */

	    ip = jfirst * (jfirst + 1) / 2;
	    jlen = 1;
	    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 = (r__1 = x[i__3].r, dabs(r__1)) + (r__2 = r_imag(&x[j]), 
			dabs(r__2));
		uscal.r = tscal, uscal.i = 0.f;
		rec = 1.f / dmax(xmax,1.f);
		if (cnorm[j] > (bignum - xj) * rec) {

/*                 If x(j) could overflow, scale x by 1/(2*XMAX). */

		    rec *= .5f;
		    if (nounit) {
			r_cnjg(&q__2, &ap[ip]);
			q__1.r = tscal * q__2.r, q__1.i = tscal * q__2.i;
			tjjs.r = q__1.r, tjjs.i = q__1.i;
		    } else {
			tjjs.r = tscal, tjjs.i = 0.f;
		    }
		    tjj = (r__1 = tjjs.r, dabs(r__1)) + (r__2 = r_imag(&tjjs),
			     dabs(r__2));
		    if (tjj > 1.f) {

/*                       Divide by A(j,j) when scaling x if A(j,j) > 1.   

   Computing MIN */
			r__1 = 1.f, r__2 = rec * tjj;
			rec = dmin(r__1,r__2);
			cladiv_(&q__1, &uscal, &tjjs);
			uscal.r = q__1.r, uscal.i = q__1.i;
		    }
		    if (rec < 1.f) {
			csscal_(n, &rec, &x[1], &c__1);
			*scale *= rec;
			xmax *= rec;
		    }
		}

		csumj.r = 0.f, csumj.i = 0.f;
		if (uscal.r == 1.f && uscal.i == 0.f) {

/*                 If the scaling needed for A in the dot product is 1,   
                   call CDOTC to perform the dot product. */

		    if (upper) {
			i__3 = j - 1;
			cdotc_(&q__1, &i__3, &ap[ip - j + 1], &c__1, &x[1], &
				c__1);
			csumj.r = q__1.r, csumj.i = q__1.i;
		    } else if (j < *n) {
			i__3 = *n - j;
			cdotc_(&q__1, &i__3, &ap[ip + 1], &c__1, &x[j + 1], &
				c__1);
			csumj.r = q__1.r, csumj.i = q__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__) {
			    r_cnjg(&q__4, &ap[ip - j + i__]);
			    q__3.r = q__4.r * uscal.r - q__4.i * uscal.i, 
				    q__3.i = q__4.r * uscal.i + q__4.i * 
				    uscal.r;
			    i__4 = i__;
			    q__2.r = q__3.r * x[i__4].r - q__3.i * x[i__4].i, 
				    q__2.i = q__3.r * x[i__4].i + q__3.i * x[
				    i__4].r;
			    q__1.r = csumj.r + q__2.r, q__1.i = csumj.i + 
				    q__2.i;
			    csumj.r = q__1.r, csumj.i = q__1.i;
/* L160: */
			}
		    } else if (j < *n) {
			i__3 = *n - j;
			for (i__ = 1; i__ <= i__3; ++i__) {
			    r_cnjg(&q__4, &ap[ip + i__]);
			    q__3.r = q__4.r * uscal.r - q__4.i * uscal.i, 
				    q__3.i = q__4.r * uscal.i + q__4.i * 
				    uscal.r;
			    i__4 = j + i__;
			    q__2.r = q__3.r * x[i__4].r - q__3.i * x[i__4].i, 
				    q__2.i = q__3.r * x[i__4].i + q__3.i * x[
				    i__4].r;
			    q__1.r = csumj.r + q__2.r, q__1.i = csumj.i + 
				    q__2.i;
			    csumj.r = q__1.r, csumj.i = q__1.i;
/* L170: */
			}
		    }
		}

		q__1.r = tscal, q__1.i = 0.f;
		if (uscal.r == q__1.r && uscal.i == q__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;
		    q__1.r = x[i__4].r - csumj.r, q__1.i = x[i__4].i - 
			    csumj.i;
		    x[i__3].r = q__1.r, x[i__3].i = q__1.i;
		    i__3 = j;
		    xj = (r__1 = x[i__3].r, dabs(r__1)) + (r__2 = r_imag(&x[j]
			    ), dabs(r__2));
		    if (nounit) {

/*                    Compute x(j) = x(j) / A(j,j), scaling if necessary. */

			r_cnjg(&q__2, &ap[ip]);
			q__1.r = tscal * q__2.r, q__1.i = tscal * q__2.i;
			tjjs.r = q__1.r, tjjs.i = q__1.i;
		    } else {
			tjjs.r = tscal, tjjs.i = 0.f;
			if (tscal == 1.f) {
			    goto L185;
			}
		    }
		    tjj = (r__1 = tjjs.r, dabs(r__1)) + (r__2 = r_imag(&tjjs),
			     dabs(r__2));
		    if (tjj > smlnum) {

/*                       abs(A(j,j)) > SMLNUM: */

			if (tjj < 1.f) {
			    if (xj > tjj * bignum) {

/*                             Scale X by 1/abs(x(j)). */

				rec = 1.f / xj;
				csscal_(n, &rec, &x[1], &c__1);
				*scale *= rec;
				xmax *= rec;
			    }
			}
			i__3 = j;
			cladiv_(&q__1, &x[j], &tjjs);
			x[i__3].r = q__1.r, x[i__3].i = q__1.i;
		    } else if (tjj > 0.f) {

/*                       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;
			    csscal_(n, &rec, &x[1], &c__1);
			    *scale *= rec;
			    xmax *= rec;
			}
			i__3 = j;
			cladiv_(&q__1, &x[j], &tjjs);
			x[i__3].r = q__1.r, x[i__3].i = q__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.f, x[i__4].i = 0.f;
/* L180: */
			}
			i__3 = j;
			x[i__3].r = 1.f, x[i__3].i = 0.f;
			*scale = 0.f;
			xmax = 0.f;
		    }
L185:
		    ;
		} 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;
		    cladiv_(&q__2, &x[j], &tjjs);
		    q__1.r = q__2.r - csumj.r, q__1.i = q__2.i - csumj.i;
		    x[i__3].r = q__1.r, x[i__3].i = q__1.i;
		}
/* Computing MAX */
		i__3 = j;
		r__3 = xmax, r__4 = (r__1 = x[i__3].r, dabs(r__1)) + (r__2 = 
			r_imag(&x[j]), dabs(r__2));
		xmax = dmax(r__3,r__4);
		++jlen;
		ip += jinc * jlen;
/* L190: */
	    }
	}
	*scale /= tscal;
    }

/*     Scale the column norms by 1/TSCAL for return. */

    if (tscal != 1.f) {
	r__1 = 1.f / tscal;
	sscal_(n, &r__1, &cnorm[1], &c__1);
    }

    return 0;

/*     End of CLATPS */

} /* clatps_ */
示例#19
0
文件: sget07.c 项目: zangel/uquad
/* Subroutine */ int sget07_(char *trans, integer *n, integer *nrhs, real *a, 
	integer *lda, real *b, integer *ldb, real *x, integer *ldx, real *
	xact, integer *ldxact, real *ferr, real *berr, real *reslts)
{
    /* System generated locals */
    integer a_dim1, a_offset, b_dim1, b_offset, x_dim1, x_offset, xact_dim1, 
	    xact_offset, i__1, i__2, i__3;
    real r__1, r__2, r__3;

    /* Local variables */
    static real diff, axbi;
    static integer imax;
    static real unfl, ovfl;
    static integer i__, j, k;
    extern logical lsame_(char *, char *);
    static real xnorm;
    extern doublereal slamch_(char *);
    static real errbnd;
    extern integer isamax_(integer *, real *, integer *);
    static logical notran;
    static real eps, tmp;


#define xact_ref(a_1,a_2) xact[(a_2)*xact_dim1 + a_1]
#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   
    =======   

    SGET07 tests the error bounds from iterative refinement for the   
    computed solution to a system of equations op(A)*X = B, where A is a   
    general n by n matrix and op(A) = A or A**T, depending on TRANS.   

    RESLTS(1) = test of the error bound   
              = norm(X - XACT) / ( norm(X) * FERR )   

    A large value is returned if this ratio is not less than one.   

    RESLTS(2) = residual from the iterative refinement routine   
              = the maximum of BERR / ( (n+1)*EPS + (*) ), where   
                (*) = (n+1)*UNFL / (min_i (abs(op(A))*abs(X) +abs(b))_i )   

    Arguments   
    =========   

    TRANS   (input) CHARACTER*1   
            Specifies the form of the system of equations.   
            = 'N':  A * X = B     (No transpose)   
            = 'T':  A**T * X = B  (Transpose)   
            = 'C':  A**H * X = B  (Conjugate transpose = Transpose)   

    N       (input) INTEGER   
            The number of rows of the matrices X and XACT.  N >= 0.   

    NRHS    (input) INTEGER   
            The number of columns of the matrices X and XACT.  NRHS >= 0.   

    A       (input) REAL array, dimension (LDA,N)   
            The original n by n matrix A.   

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

    B       (input) REAL 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).   

    X       (input) REAL array, dimension (LDX,NRHS)   
            The computed solution vectors.  Each vector is stored as a   
            column of the matrix X.   

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

    XACT    (input) REAL array, dimension (LDX,NRHS)   
            The exact solution vectors.  Each vector is stored as a   
            column of the matrix XACT.   

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

    FERR    (input) REAL array, dimension (NRHS)   
            The estimated forward error bounds for each solution vector   
            X.  If XTRUE is the true solution, FERR bounds the magnitude   
            of the largest entry in (X - XTRUE) divided by the magnitude   
            of the largest entry in X.   

    BERR    (input) REAL array, dimension (NRHS)   
            The componentwise relative backward error of each solution   
            vector (i.e., the smallest relative change in any entry of A   
            or B that makes X an exact solution).   

    RESLTS  (output) REAL array, dimension (2)   
            The maximum over the NRHS solution vectors of the ratios:   
            RESLTS(1) = norm(X - XACT) / ( norm(X) * FERR )   
            RESLTS(2) = BERR / ( (n+1)*EPS + (*) )   

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


       Quick exit if N = 0 or NRHS = 0.   

       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;
    x_dim1 = *ldx;
    x_offset = 1 + x_dim1 * 1;
    x -= x_offset;
    xact_dim1 = *ldxact;
    xact_offset = 1 + xact_dim1 * 1;
    xact -= xact_offset;
    --ferr;
    --berr;
    --reslts;

    /* Function Body */
    if (*n <= 0 || *nrhs <= 0) {
	reslts[1] = 0.f;
	reslts[2] = 0.f;
	return 0;
    }

    eps = slamch_("Epsilon");
    unfl = slamch_("Safe minimum");
    ovfl = 1.f / unfl;
    notran = lsame_(trans, "N");

/*     Test 1:  Compute the maximum of   
          norm(X - XACT) / ( norm(X) * FERR )   
       over all the vectors X and XACT using the infinity-norm. */

    errbnd = 0.f;
    i__1 = *nrhs;
    for (j = 1; j <= i__1; ++j) {
	imax = isamax_(n, &x_ref(1, j), &c__1);
/* Computing MAX */
	r__2 = (r__1 = x_ref(imax, j), dabs(r__1));
	xnorm = dmax(r__2,unfl);
	diff = 0.f;
	i__2 = *n;
	for (i__ = 1; i__ <= i__2; ++i__) {
/* Computing MAX */
	    r__2 = diff, r__3 = (r__1 = x_ref(i__, j) - xact_ref(i__, j), 
		    dabs(r__1));
	    diff = dmax(r__2,r__3);
/* L10: */
	}

	if (xnorm > 1.f) {
	    goto L20;
	} else if (diff <= ovfl * xnorm) {
	    goto L20;
	} else {
	    errbnd = 1.f / eps;
	    goto L30;
	}

L20:
	if (diff / xnorm <= ferr[j]) {
/* Computing MAX */
	    r__1 = errbnd, r__2 = diff / xnorm / ferr[j];
	    errbnd = dmax(r__1,r__2);
	} else {
	    errbnd = 1.f / eps;
	}
L30:
	;
    }
    reslts[1] = errbnd;

/*     Test 2:  Compute the maximum of BERR / ( (n+1)*EPS + (*) ), where   
       (*) = (n+1)*UNFL / (min_i (abs(op(A))*abs(X) +abs(b))_i ) */

    i__1 = *nrhs;
    for (k = 1; k <= i__1; ++k) {
	i__2 = *n;
	for (i__ = 1; i__ <= i__2; ++i__) {
	    tmp = (r__1 = b_ref(i__, k), dabs(r__1));
	    if (notran) {
		i__3 = *n;
		for (j = 1; j <= i__3; ++j) {
		    tmp += (r__1 = a_ref(i__, j), dabs(r__1)) * (r__2 = x_ref(
			    j, k), dabs(r__2));
/* L40: */
		}
	    } else {
		i__3 = *n;
		for (j = 1; j <= i__3; ++j) {
		    tmp += (r__1 = a_ref(j, i__), dabs(r__1)) * (r__2 = x_ref(
			    j, k), dabs(r__2));
/* L50: */
		}
	    }
	    if (i__ == 1) {
		axbi = tmp;
	    } else {
		axbi = dmin(axbi,tmp);
	    }
/* L60: */
	}
/* Computing MAX */
	r__1 = axbi, r__2 = (*n + 1) * unfl;
	tmp = berr[k] / ((*n + 1) * eps + (*n + 1) * unfl / dmax(r__1,r__2));
	if (k == 1) {
	    reslts[2] = tmp;
	} else {
	    reslts[2] = dmax(reslts[2],tmp);
	}
/* L70: */
    }

    return 0;

/*     End of SGET07 */

} /* sget07_ */
示例#20
0
/* Subroutine */ int sstebz_(char *range, char *order, integer *n, real *vl, 
	real *vu, integer *il, integer *iu, real *abstol, real *d, real *e, 
	integer *m, integer *nsplit, real *w, integer *iblock, integer *
	isplit, real *work, integer *iwork, integer *info)
{
/*  -- LAPACK routine (version 2.0) --   
       Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,   
       Courant Institute, Argonne National Lab, and Rice University   
       September 30, 1994   


    Purpose   
    =======   

    SSTEBZ computes the eigenvalues of a symmetric tridiagonal   
    matrix T.  The user may ask for all eigenvalues, all eigenvalues   
    in the half-open interval (VL, VU], or the IL-th through IU-th   
    eigenvalues.   

    To avoid overflow, the matrix must be scaled so that its   
    largest element is no greater than overflow**(1/2) *   
    underflow**(1/4) in absolute value, and for greatest   
    accuracy, it should not be much smaller than that.   

    See W. Kahan "Accurate Eigenvalues of a Symmetric Tridiagonal   
    VISMatrix", Report CS41, Computer Science Dept., Stanford   
    University, July 21, 1966.   

    Arguments   
    =========   

    RANGE   (input) CHARACTER   
            = 'A': ("All")   all eigenvalues will be found.   
            = 'V': ("Value") all eigenvalues in the half-open interval   
                             (VL, VU] will be found.   
            = 'I': ("Index") the IL-th through IU-th eigenvalues (of the 
  
                             entire matrix) will be found.   

    ORDER   (input) CHARACTER   
            = 'B': ("By Block") the eigenvalues will be grouped by   
                                split-off block (see IBLOCK, ISPLIT) and 
  
                                ordered from smallest to largest within   
                                the block.   
            = 'E': ("Entire matrix")   
                                the eigenvalues for the entire matrix   
                                will be ordered from smallest to   
                                largest.   

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

    VL      (input) REAL   
    VU      (input) REAL   
            If RANGE='V', the lower and upper bounds of the interval to   
            be searched for eigenvalues.  Eigenvalues less than or equal 
  
            to VL, or greater than VU, will not be returned.  VL < VU.   
            Not referenced if RANGE = 'A' or 'I'.   

    IL      (input) INTEGER   
    IU      (input) INTEGER   
            If RANGE='I', the indices (in ascending order) of the   
            smallest and largest eigenvalues to be returned.   
            1 <= IL <= IU <= N, if N > 0; IL = 1 and IU = 0 if N = 0.   
            Not referenced if RANGE = 'A' or 'V'.   

    ABSTOL  (input) REAL   
            The absolute tolerance for the eigenvalues.  An eigenvalue   
            (or cluster) is considered to be located if it has been   
            determined to lie in an interval whose width is ABSTOL or   
            less.  If ABSTOL is less than or equal to zero, then ULP*|T| 
  
            will be used, where |T| means the 1-norm of T.   

            Eigenvalues will be computed most accurately when ABSTOL is   
            set to twice the underflow threshold 2*SLAMCH('S'), not zero. 
  

    D       (input) REAL array, dimension (N)   
            The n diagonal elements of the tridiagonal matrix T.   

    E       (input) REAL array, dimension (N-1)   
            The (n-1) off-diagonal elements of the tridiagonal matrix T. 
  

    M       (output) INTEGER   
            The actual number of eigenvalues found. 0 <= M <= N.   
            (See also the description of INFO=2,3.)   

    NSPLIT  (output) INTEGER   
            The number of diagonal blocks in the matrix T.   
            1 <= NSPLIT <= N.   

    W       (output) REAL array, dimension (N)   
            On exit, the first M elements of W will contain the   
            eigenvalues.  (SSTEBZ may use the remaining N-M elements as   
            workspace.)   

    IBLOCK  (output) INTEGER array, dimension (N)   
            At each row/column j where E(j) is zero or small, the   
            matrix T is considered to split into a block diagonal   
            matrix.  On exit, if INFO = 0, IBLOCK(i) specifies to which   
            block (from 1 to the number of blocks) the eigenvalue W(i)   
            belongs.  (SSTEBZ may use the remaining N-M elements as   
            workspace.)   

    ISPLIT  (output) INTEGER array, dimension (N)   
            The splitting points, at which T breaks up into submatrices. 
  
            The first submatrix consists of rows/columns 1 to ISPLIT(1), 
  
            the second of rows/columns ISPLIT(1)+1 through ISPLIT(2),   
            etc., and the NSPLIT-th consists of rows/columns   
            ISPLIT(NSPLIT-1)+1 through ISPLIT(NSPLIT)=N.   
            (Only the first NSPLIT elements will actually be used, but   
            since the user cannot know a priori what value NSPLIT will   
            have, N words must be reserved for ISPLIT.)   

    WORK    (workspace) REAL array, dimension (4*N)   

    IWORK   (workspace) INTEGER array, dimension (3*N)   

    INFO    (output) INTEGER   
            = 0:  successful exit   
            < 0:  if INFO = -i, the i-th argument had an illegal value   
            > 0:  some or all of the eigenvalues failed to converge or   
                  were not computed:   
                  =1 or 3: Bisection failed to converge for some   
                          eigenvalues; these eigenvalues are flagged by a 
  
                          negative block number.  The effect is that the 
  
                          eigenvalues may not be as accurate as the   
                          absolute and relative tolerances.  This is   
                          generally caused by unexpectedly inaccurate   
                          arithmetic.   
                  =2 or 3: RANGE='I' only: Not all of the eigenvalues   
                          IL:IU were found.   
                          Effect: M < IU+1-IL   
                          Cause:  non-monotonic arithmetic, causing the   
                                  Sturm sequence to be non-monotonic.   
                          Cure:   recalculate, using RANGE='A', and pick 
  
                                  out eigenvalues IL:IU.  In some cases, 
  
                                  increasing the PARAMETER "FUDGE" may   
                                  make things work.   
                  = 4:    RANGE='I', and the Gershgorin interval   
                          initially used was too small.  No eigenvalues   
                          were computed.   
                          Probable cause: your machine has sloppy   
                                          floating-point arithmetic.   
                          Cure: Increase the PARAMETER "FUDGE",   
                                recompile, and try again.   

    Internal Parameters   
    ===================   

    RELFAC  REAL, default = 2.0e0   
            The relative tolerance.  An interval (a,b] lies within   
            "relative tolerance" if  b-a < RELFAC*ulp*max(|a|,|b|),   
            where "ulp" is the machine precision (distance from 1 to   
            the next larger floating point number.)   

    FUDGE   REAL, default = 2   
            A "fudge factor" to widen the Gershgorin intervals.  Ideally, 
  
            a value of 1 should work, but on machines with sloppy   
            arithmetic, this needs to be larger.  The default for   
            publicly released versions should be large enough to handle   
            the worst machine around.  Note that this has no effect   
            on accuracy of the solution.   

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


    
   Parameter adjustments   
       Function Body */
    /* Table of constant values */
    static integer c__1 = 1;
    static integer c_n1 = -1;
    static integer c__3 = 3;
    static integer c__2 = 2;
    static integer c__0 = 0;
    
    /* System generated locals */
    integer i__1, i__2, i__3;
    real r__1, r__2, r__3, r__4, r__5;
    /* Builtin functions */
    double sqrt(doublereal), log(doublereal);
    /* Local variables */
    static integer iend, ioff, iout, itmp1, j, jdisc;
    extern logical lsame_(char *, char *);
    static integer iinfo;
    static real atoli;
    static integer iwoff;
    static real bnorm;
    static integer itmax;
    static real wkill, rtoli, tnorm;
    static integer ib, jb, ie, je, nb;
    static real gl;
    static integer im, in, ibegin;
    static real gu;
    static integer iw;
    static real wl;
    static integer irange, idiscl;
    extern doublereal slamch_(char *);
    static real safemn, wu;
    static integer idumma[1];
    extern integer ilaenv_(integer *, char *, char *, integer *, integer *, 
	    integer *, integer *, ftnlen, ftnlen);
    extern /* Subroutine */ int xerbla_(char *, integer *);
    static integer idiscu;
    extern /* Subroutine */ int slaebz_(integer *, integer *, integer *, 
	    integer *, integer *, integer *, real *, real *, real *, real *, 
	    real *, real *, integer *, real *, real *, integer *, integer *, 
	    real *, integer *, integer *);
    static integer iorder;
    static logical ncnvrg;
    static real pivmin;
    static logical toofew;
    static integer nwl;
    static real ulp, wlu, wul;
    static integer nwu;
    static real tmp1, tmp2;



#define IDUMMA(I) idumma[(I)]
#define IWORK(I) iwork[(I)-1]
#define WORK(I) work[(I)-1]
#define ISPLIT(I) isplit[(I)-1]
#define IBLOCK(I) iblock[(I)-1]
#define W(I) w[(I)-1]
#define E(I) e[(I)-1]
#define D(I) d[(I)-1]


    *info = 0;

/*     Decode RANGE */

    if (lsame_(range, "A")) {
	irange = 1;
    } else if (lsame_(range, "V")) {
	irange = 2;
    } else if (lsame_(range, "I")) {
	irange = 3;
    } else {
	irange = 0;
    }

/*     Decode ORDER */

    if (lsame_(order, "B")) {
	iorder = 2;
    } else if (lsame_(order, "E")) {
	iorder = 1;
    } else {
	iorder = 0;
    }

/*     Check for Errors */

    if (irange <= 0) {
	*info = -1;
    } else if (iorder <= 0) {
	*info = -2;
    } else if (*n < 0) {
	*info = -3;
    } else if (irange == 2 && *vl >= *vu) {
	*info = -5;
    } else if (irange == 3 && (*il < 1 || *il > max(1,*n))) {
	*info = -6;
    } else if (irange == 3 && (*iu < min(*n,*il) || *iu > *n)) {
	*info = -7;
    }

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

/*     Initialize error flags */

    *info = 0;
    ncnvrg = FALSE_;
    toofew = FALSE_;

/*     Quick return if possible */

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

/*     Simplifications: */

    if (irange == 3 && *il == 1 && *iu == *n) {
	irange = 1;
    }

/*     Get machine constants   
       NB is the minimum vector length for vector bisection, or 0   
       if only scalar is to be done. */

    safemn = slamch_("S");
    ulp = slamch_("P");
    rtoli = ulp * 2.f;
    nb = ilaenv_(&c__1, "SSTEBZ", " ", n, &c_n1, &c_n1, &c_n1, 6L, 1L);
    if (nb <= 1) {
	nb = 0;
    }

/*     Special Case when N=1 */

    if (*n == 1) {
	*nsplit = 1;
	ISPLIT(1) = 1;
	if (irange == 2 && (*vl >= D(1) || *vu < D(1))) {
	    *m = 0;
	} else {
	    W(1) = D(1);
	    IBLOCK(1) = 1;
	    *m = 1;
	}
	return 0;
    }

/*     Compute Splitting Points */

    *nsplit = 1;
    WORK(*n) = 0.f;
    pivmin = 1.f;

    i__1 = *n;
    for (j = 2; j <= *n; ++j) {
/* Computing 2nd power */
	r__1 = E(j - 1);
	tmp1 = r__1 * r__1;
/* Computing 2nd power */
	r__2 = ulp;
	if ((r__1 = D(j) * D(j - 1), dabs(r__1)) * (r__2 * r__2) + safemn > 
		tmp1) {
	    ISPLIT(*nsplit) = j - 1;
	    ++(*nsplit);
	    WORK(j - 1) = 0.f;
	} else {
	    WORK(j - 1) = tmp1;
	    pivmin = dmax(pivmin,tmp1);
	}
/* L10: */
    }
    ISPLIT(*nsplit) = *n;
    pivmin *= safemn;

/*     Compute Interval and ATOLI */

    if (irange == 3) {

/*        RANGE='I': Compute the interval containing eigenvalues   
                     IL through IU.   

          Compute Gershgorin interval for entire (split) matrix   
          and use it as the initial interval */

	gu = D(1);
	gl = D(1);
	tmp1 = 0.f;

	i__1 = *n - 1;
	for (j = 1; j <= *n-1; ++j) {
	    tmp2 = sqrt(WORK(j));
/* Computing MAX */
	    r__1 = gu, r__2 = D(j) + tmp1 + tmp2;
	    gu = dmax(r__1,r__2);
/* Computing MIN */
	    r__1 = gl, r__2 = D(j) - tmp1 - tmp2;
	    gl = dmin(r__1,r__2);
	    tmp1 = tmp2;
/* L20: */
	}

/* Computing MAX */
	r__1 = gu, r__2 = D(*n) + tmp1;
	gu = dmax(r__1,r__2);
/* Computing MIN */
	r__1 = gl, r__2 = D(*n) - tmp1;
	gl = dmin(r__1,r__2);
/* Computing MAX */
	r__1 = dabs(gl), r__2 = dabs(gu);
	tnorm = dmax(r__1,r__2);
	gl = gl - tnorm * 2.f * ulp * *n - pivmin * 4.f;
	gu = gu + tnorm * 2.f * ulp * *n + pivmin * 2.f;

/*        Compute Iteration parameters */

	itmax = (integer) ((log(tnorm + pivmin) - log(pivmin)) / log(2.f)) + 
		2;
	if (*abstol <= 0.f) {
	    atoli = ulp * tnorm;
	} else {
	    atoli = *abstol;
	}

	WORK(*n + 1) = gl;
	WORK(*n + 2) = gl;
	WORK(*n + 3) = gu;
	WORK(*n + 4) = gu;
	WORK(*n + 5) = gl;
	WORK(*n + 6) = gu;
	IWORK(1) = -1;
	IWORK(2) = -1;
	IWORK(3) = *n + 1;
	IWORK(4) = *n + 1;
	IWORK(5) = *il - 1;
	IWORK(6) = *iu;

	slaebz_(&c__3, &itmax, n, &c__2, &c__2, &nb, &atoli, &rtoli, &pivmin, 
		&D(1), &E(1), &WORK(1), &IWORK(5), &WORK(*n + 1), &WORK(*n + 
		5), &iout, &IWORK(1), &W(1), &IBLOCK(1), &iinfo);

	if (IWORK(6) == *iu) {
	    wl = WORK(*n + 1);
	    wlu = WORK(*n + 3);
	    nwl = IWORK(1);
	    wu = WORK(*n + 4);
	    wul = WORK(*n + 2);
	    nwu = IWORK(4);
	} else {
	    wl = WORK(*n + 2);
	    wlu = WORK(*n + 4);
	    nwl = IWORK(2);
	    wu = WORK(*n + 3);
	    wul = WORK(*n + 1);
	    nwu = IWORK(3);
	}

	if (nwl < 0 || nwl >= *n || nwu < 1 || nwu > *n) {
	    *info = 4;
	    return 0;
	}
    } else {

/*        RANGE='A' or 'V' -- Set ATOLI   

   Computing MAX */
	r__3 = dabs(D(1)) + dabs(E(1)), r__4 = (r__1 = D(*n), dabs(r__1)) + (
		r__2 = E(*n - 1), dabs(r__2));
	tnorm = dmax(r__3,r__4);

	i__1 = *n - 1;
	for (j = 2; j <= *n-1; ++j) {
/* Computing MAX */
	    r__4 = tnorm, r__5 = (r__1 = D(j), dabs(r__1)) + (r__2 = E(j - 1),
		     dabs(r__2)) + (r__3 = E(j), dabs(r__3));
	    tnorm = dmax(r__4,r__5);
/* L30: */
	}

	if (*abstol <= 0.f) {
	    atoli = ulp * tnorm;
	} else {
	    atoli = *abstol;
	}

	if (irange == 2) {
	    wl = *vl;
	    wu = *vu;
	}
    }

/*     Find Eigenvalues -- Loop Over Blocks and recompute NWL and NWU.   
       NWL accumulates the number of eigenvalues .le. WL,   
       NWU accumulates the number of eigenvalues .le. WU */

    *m = 0;
    iend = 0;
    *info = 0;
    nwl = 0;
    nwu = 0;

    i__1 = *nsplit;
    for (jb = 1; jb <= *nsplit; ++jb) {
	ioff = iend;
	ibegin = ioff + 1;
	iend = ISPLIT(jb);
	in = iend - ioff;

	if (in == 1) {

/*           Special Case -- IN=1 */

	    if (irange == 1 || wl >= D(ibegin) - pivmin) {
		++nwl;
	    }
	    if (irange == 1 || wu >= D(ibegin) - pivmin) {
		++nwu;
	    }
	    if (irange == 1 || wl < D(ibegin) - pivmin && wu >= D(ibegin) - 
		    pivmin) {
		++(*m);
		W(*m) = D(ibegin);
		IBLOCK(*m) = jb;
	    }
	} else {

/*           General Case -- IN > 1   

             Compute Gershgorin Interval   
             and use it as the initial interval */

	    gu = D(ibegin);
	    gl = D(ibegin);
	    tmp1 = 0.f;

	    i__2 = iend - 1;
	    for (j = ibegin; j <= iend-1; ++j) {
		tmp2 = (r__1 = E(j), dabs(r__1));
/* Computing MAX */
		r__1 = gu, r__2 = D(j) + tmp1 + tmp2;
		gu = dmax(r__1,r__2);
/* Computing MIN */
		r__1 = gl, r__2 = D(j) - tmp1 - tmp2;
		gl = dmin(r__1,r__2);
		tmp1 = tmp2;
/* L40: */
	    }

/* Computing MAX */
	    r__1 = gu, r__2 = D(iend) + tmp1;
	    gu = dmax(r__1,r__2);
/* Computing MIN */
	    r__1 = gl, r__2 = D(iend) - tmp1;
	    gl = dmin(r__1,r__2);
/* Computing MAX */
	    r__1 = dabs(gl), r__2 = dabs(gu);
	    bnorm = dmax(r__1,r__2);
	    gl = gl - bnorm * 2.f * ulp * in - pivmin * 2.f;
	    gu = gu + bnorm * 2.f * ulp * in + pivmin * 2.f;

/*           Compute ATOLI for the current submatrix */

	    if (*abstol <= 0.f) {
/* Computing MAX */
		r__1 = dabs(gl), r__2 = dabs(gu);
		atoli = ulp * dmax(r__1,r__2);
	    } else {
		atoli = *abstol;
	    }

	    if (irange > 1) {
		if (gu < wl) {
		    nwl += in;
		    nwu += in;
		    goto L70;
		}
		gl = dmax(gl,wl);
		gu = dmin(gu,wu);
		if (gl >= gu) {
		    goto L70;
		}
	    }

/*           Set Up Initial Interval */

	    WORK(*n + 1) = gl;
	    WORK(*n + in + 1) = gu;
	    slaebz_(&c__1, &c__0, &in, &in, &c__1, &nb, &atoli, &rtoli, &
		    pivmin, &D(ibegin), &E(ibegin), &WORK(ibegin), idumma, &
		    WORK(*n + 1), &WORK(*n + (in << 1) + 1), &im, &IWORK(1), &
		    W(*m + 1), &IBLOCK(*m + 1), &iinfo);

	    nwl += IWORK(1);
	    nwu += IWORK(in + 1);
	    iwoff = *m - IWORK(1);

/*           Compute Eigenvalues */

	    itmax = (integer) ((log(gu - gl + pivmin) - log(pivmin)) / log(
		    2.f)) + 2;
	    slaebz_(&c__2, &itmax, &in, &in, &c__1, &nb, &atoli, &rtoli, &
		    pivmin, &D(ibegin), &E(ibegin), &WORK(ibegin), idumma, &
		    WORK(*n + 1), &WORK(*n + (in << 1) + 1), &iout, &IWORK(1),
		     &W(*m + 1), &IBLOCK(*m + 1), &iinfo);

/*           Copy Eigenvalues Into W and IBLOCK   
             Use -JB for block number for unconverged eigenvalues.
 */

	    i__2 = iout;
	    for (j = 1; j <= iout; ++j) {
		tmp1 = (WORK(j + *n) + WORK(j + in + *n)) * .5f;

/*              Flag non-convergence. */

		if (j > iout - iinfo) {
		    ncnvrg = TRUE_;
		    ib = -jb;
		} else {
		    ib = jb;
		}
		i__3 = IWORK(j + in) + iwoff;
		for (je = IWORK(j) + 1 + iwoff; je <= IWORK(j+in)+iwoff; ++je) {
		    W(je) = tmp1;
		    IBLOCK(je) = ib;
/* L50: */
		}
/* L60: */
	    }

	    *m += im;
	}
L70:
	;
    }

/*     If RANGE='I', then (WL,WU) contains eigenvalues NWL+1,...,NWU   
       If NWL+1 < IL or NWU > IU, discard extra eigenvalues. */

    if (irange == 3) {
	im = 0;
	idiscl = *il - 1 - nwl;
	idiscu = nwu - *iu;

	if (idiscl > 0 || idiscu > 0) {
	    i__1 = *m;
	    for (je = 1; je <= *m; ++je) {
		if (W(je) <= wlu && idiscl > 0) {
		    --idiscl;
		} else if (W(je) >= wul && idiscu > 0) {
		    --idiscu;
		} else {
		    ++im;
		    W(im) = W(je);
		    IBLOCK(im) = IBLOCK(je);
		}
/* L80: */
	    }
	    *m = im;
	}
	if (idiscl > 0 || idiscu > 0) {

/*           Code to deal with effects of bad arithmetic:   
             Some low eigenvalues to be discarded are not in (WL,W
LU],   
             or high eigenvalues to be discarded are not in (WUL,W
U]   
             so just kill off the smallest IDISCL/largest IDISCU 
  
             eigenvalues, by simply finding the smallest/largest 
  
             eigenvalue(s).   

             (If N(w) is monotone non-decreasing, this should neve
r   
                 happen.) */

	    if (idiscl > 0) {
		wkill = wu;
		i__1 = idiscl;
		for (jdisc = 1; jdisc <= idiscl; ++jdisc) {
		    iw = 0;
		    i__2 = *m;
		    for (je = 1; je <= *m; ++je) {
			if (IBLOCK(je) != 0 && (W(je) < wkill || iw == 0)) {
			    iw = je;
			    wkill = W(je);
			}
/* L90: */
		    }
		    IBLOCK(iw) = 0;
/* L100: */
		}
	    }
	    if (idiscu > 0) {

		wkill = wl;
		i__1 = idiscu;
		for (jdisc = 1; jdisc <= idiscu; ++jdisc) {
		    iw = 0;
		    i__2 = *m;
		    for (je = 1; je <= *m; ++je) {
			if (IBLOCK(je) != 0 && (W(je) > wkill || iw == 0)) {
			    iw = je;
			    wkill = W(je);
			}
/* L110: */
		    }
		    IBLOCK(iw) = 0;
/* L120: */
		}
	    }
	    im = 0;
	    i__1 = *m;
	    for (je = 1; je <= *m; ++je) {
		if (IBLOCK(je) != 0) {
		    ++im;
		    W(im) = W(je);
		    IBLOCK(im) = IBLOCK(je);
		}
/* L130: */
	    }
	    *m = im;
	}
	if (idiscl < 0 || idiscu < 0) {
	    toofew = TRUE_;
	}
    }

/*     If ORDER='B', do nothing -- the eigenvalues are already sorted   
          by block.   
       If ORDER='E', sort the eigenvalues from smallest to largest */

    if (iorder == 1 && *nsplit > 1) {
	i__1 = *m - 1;
	for (je = 1; je <= *m-1; ++je) {
	    ie = 0;
	    tmp1 = W(je);
	    i__2 = *m;
	    for (j = je + 1; j <= *m; ++j) {
		if (W(j) < tmp1) {
		    ie = j;
		    tmp1 = W(j);
		}
/* L140: */
	    }

	    if (ie != 0) {
		itmp1 = IBLOCK(ie);
		W(ie) = W(je);
		IBLOCK(ie) = IBLOCK(je);
		W(je) = tmp1;
		IBLOCK(je) = itmp1;
	    }
/* L150: */
	}
    }

    *info = 0;
    if (ncnvrg) {
	++(*info);
    }
    if (toofew) {
	*info += 2;
    }
    return 0;

/*     End of SSTEBZ */

} /* sstebz_ */
示例#21
0
/* Subroutine */ int slaed0_(integer *icompq, integer *qsiz, integer *n, real 
	*d, real *e, real *q, integer *ldq, real *qstore, integer *ldqs, real 
	*work, integer *iwork, integer *info)
{
/*  -- LAPACK routine (version 2.0) --   
       Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,   
       Courant Institute, Argonne National Lab, and Rice University   
       September 30, 1994   


    Purpose   
    =======   

    SLAED0 computes all eigenvalues and corresponding eigenvectors of a   
    symmetric tridiagonal matrix using the divide and conquer method.   

    Arguments   
    =========   

    ICOMPQ  (input) INTEGER   
            = 0:  Compute eigenvalues only.   
            = 1:  Compute eigenvectors of original dense symmetric matrix 
  
                  also.  On entry, Q contains the orthogonal matrix used 
  
                  to reduce the original matrix to tridiagonal form.   
            = 2:  Compute eigenvalues and eigenvectors of tridiagonal   
                  matrix.   

    QSIZ   (input) INTEGER   
           The dimension of the orthogonal matrix used to reduce   
           the full matrix to tridiagonal form.  QSIZ >= N if ICOMPQ = 1. 
  

    N      (input) INTEGER   
           The dimension of the symmetric tridiagonal matrix.  N >= 0.   

    D      (input/output) REAL array, dimension (N)   
           On entry, the main diagonal of the tridiagonal matrix.   
           On exit, its eigenvalues.   

    E      (input) REAL array, dimension (N-1)   
           The off-diagonal elements of the tridiagonal matrix.   
           On exit, E has been destroyed.   

    Q      (input/output) REAL array, dimension (LDQ, N)   
           On entry, Q must contain an N-by-N orthogonal matrix.   
           If ICOMPQ = 0    Q is not referenced.   
           If ICOMPQ = 1    On entry, Q is a subset of the columns of the 
  
                            orthogonal matrix used to reduce the full   
                            matrix to tridiagonal form corresponding to   
                            the subset of the full matrix which is being 
  
                            decomposed at this time.   
           If ICOMPQ = 2    On entry, Q will be the identity matrix.   
                            On exit, Q contains the eigenvectors of the   
                            tridiagonal matrix.   

    LDQ    (input) INTEGER   
           The leading dimension of the array Q.  If eigenvectors are   
           desired, then  LDQ >= max(1,N).  In any case,  LDQ >= 1.   

    QSTORE (workspace) REAL array, dimension (LDQS, N)   
           Referenced only when ICOMPQ = 1.  Used to store parts of   
           the eigenvector matrix when the updating matrix multiplies   
           take place.   

    LDQS   (input) INTEGER   
           The leading dimension of the array QSTORE.  If ICOMPQ = 1,   
           then  LDQS >= max(1,N).  In any case,  LDQS >= 1.   

    WORK   (workspace) REAL array,   
                                  dimension (1 + 3*N + 2*N*lg N + 2*N**2) 
  
                          ( lg( N ) = smallest integer k   
                                      such that 2^k >= N )   

    IWORK  (workspace) INTEGER array,   
           If ICOMPQ = 0 or 1, the dimension of IWORK must be at least   
                          6 + 6*N + 5*N*lg N.   
                          ( lg( N ) = smallest integer k   
                                      such that 2^k >= N )   
           If ICOMPQ = 2, the dimension of IWORK must be at least   
                          2 + 5*N.   

    INFO   (output) INTEGER   
            = 0:  successful exit.   
            < 0:  if INFO = -i, the i-th argument had an illegal value.   
            > 0:  The algorithm failed to compute an eigenvalue while   
                  working on the submatrix lying in rows and columns   
                  INFO/(N+1) through mod(INFO,N+1).   

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


       Test the input parameters.   

    
   Parameter adjustments   
       Function Body */
    /* Table of constant values */
    static integer c__2 = 2;
    static real c_b16 = 1.f;
    static real c_b17 = 0.f;
    static integer c__1 = 1;
    
    /* System generated locals */
    integer q_dim1, q_offset, qstore_dim1, qstore_offset, i__1, i__2;
    real r__1;
    /* Builtin functions */
    double log(doublereal);
    integer pow_ii(integer *, integer *);
    /* Local variables */
    static real temp;
    static integer curr, i, j, k;
    extern /* Subroutine */ int sgemm_(char *, char *, integer *, integer *, 
	    integer *, real *, real *, integer *, real *, integer *, real *, 
	    real *, integer *);
    static integer iperm, indxq, iwrem;
    extern /* Subroutine */ int scopy_(integer *, real *, integer *, real *, 
	    integer *);
    static integer iqptr, tlvls;
    extern /* Subroutine */ int slaed1_(integer *, real *, real *, integer *, 
	    integer *, real *, integer *, real *, integer *, integer *), 
	    slaed7_(integer *, integer *, integer *, integer *, integer *, 
	    integer *, real *, real *, integer *, integer *, real *, integer *
	    , real *, integer *, integer *, integer *, integer *, integer *, 
	    real *, real *, integer *, integer *);
    static integer iq, igivcl;
    extern /* Subroutine */ int xerbla_(char *, integer *);
    static integer igivnm, submat;
    extern /* Subroutine */ int slacpy_(char *, integer *, integer *, real *, 
	    integer *, real *, integer *);
    static integer curprb, subpbs, igivpt, curlvl, matsiz, iprmpt;
    extern /* Subroutine */ int ssteqr_(char *, integer *, real *, real *, 
	    real *, integer *, real *, integer *);
    static integer lgn, msd2, smm1, spm1, spm2;



#define D(I) d[(I)-1]
#define E(I) e[(I)-1]
#define WORK(I) work[(I)-1]
#define IWORK(I) iwork[(I)-1]

#define Q(I,J) q[(I)-1 + ((J)-1)* ( *ldq)]
#define QSTORE(I,J) qstore[(I)-1 + ((J)-1)* ( *ldqs)]

    *info = 0;

    if (*icompq < 0 || *icompq > 2) {
	*info = -1;
    } else if (*icompq == 1 && *qsiz < max(0,*n)) {
	*info = -2;
    } else if (*n < 0) {
	*info = -3;
    } else if (*ldq < max(1,*n)) {
	*info = -7;
    } else if (*ldqs < max(1,*n)) {
	*info = -9;
    }
    if (*info != 0) {
	i__1 = -(*info);
	xerbla_("SLAED0", &i__1);
	return 0;
    }

/*     Quick return if possible */

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

/*     Determine the size and placement of the submatrices, and save in   
       the leading elements of IWORK. */

    IWORK(1) = *n;
    subpbs = 1;
    tlvls = 0;
L10:
    if (IWORK(subpbs) > 25) {
	for (j = subpbs; j >= 1; --j) {
	    IWORK(j * 2) = (IWORK(j) + 1) / 2;
	    IWORK((j << 1) - 1) = IWORK(j) / 2;
/* L20: */
	}
	++tlvls;
	subpbs <<= 1;
	goto L10;
    }
    i__1 = subpbs;
    for (j = 2; j <= subpbs; ++j) {
	IWORK(j) += IWORK(j - 1);
/* L30: */
    }

/*     Divide the matrix into SUBPBS submatrices of size at most SMLSIZ+1 
  
       using rank-1 modifications (cuts). */

    spm1 = subpbs - 1;
    i__1 = spm1;
    for (i = 1; i <= spm1; ++i) {
	submat = IWORK(i) + 1;
	smm1 = submat - 1;
	D(smm1) -= (r__1 = E(smm1), dabs(r__1));
	D(submat) -= (r__1 = E(smm1), dabs(r__1));
/* L40: */
    }

    indxq = (*n << 2) + 3;
    if (*icompq != 2) {

/*        Set up workspaces for eigenvalues only/accumulate new vector
s   
          routine */

	temp = log((real) (*n)) / log(2.f);
	lgn = (integer) temp;
	if (pow_ii(&c__2, &lgn) < *n) {
	    ++lgn;
	}
	if (pow_ii(&c__2, &lgn) < *n) {
	    ++lgn;
	}
	iprmpt = indxq + *n + 1;
	iperm = iprmpt + *n * lgn;
	iqptr = iperm + *n * lgn;
	igivpt = iqptr + *n + 2;
	igivcl = igivpt + *n * lgn;

	igivnm = 1;
	iq = igivnm + (*n << 1) * lgn;
/* Computing 2nd power */
	i__1 = *n;
	iwrem = iq + i__1 * i__1 + 1;

/*        Initialize pointers */

	i__1 = subpbs;
	for (i = 0; i <= subpbs; ++i) {
	    IWORK(iprmpt + i) = 1;
	    IWORK(igivpt + i) = 1;
/* L50: */
	}
	IWORK(iqptr) = 1;
    }

/*     Solve each submatrix eigenproblem at the bottom of the divide and 
  
       conquer tree. */

    curr = 0;
    i__1 = spm1;
    for (i = 0; i <= spm1; ++i) {
	if (i == 0) {
	    submat = 1;
	    matsiz = IWORK(1);
	} else {
	    submat = IWORK(i) + 1;
	    matsiz = IWORK(i + 1) - IWORK(i);
	}
	if (*icompq == 2) {
	    ssteqr_("I", &matsiz, &D(submat), &E(submat), &Q(submat,submat), ldq, &WORK(1), info);
	    if (*info != 0) {
		goto L130;
	    }
	} else {
	    ssteqr_("I", &matsiz, &D(submat), &E(submat), &WORK(iq - 1 + 
		    IWORK(iqptr + curr)), &matsiz, &WORK(1), info);
	    if (*info != 0) {
		goto L130;
	    }
	    if (*icompq == 1) {
		sgemm_("N", "N", qsiz, &matsiz, &matsiz, &c_b16, &Q(1,submat), ldq, &WORK(iq - 1 + IWORK(iqptr + curr)),
			 &matsiz, &c_b17, &QSTORE(1,submat), 
			ldqs);
	    }
/* Computing 2nd power */
	    i__2 = matsiz;
	    IWORK(iqptr + curr + 1) = IWORK(iqptr + curr) + i__2 * i__2;
	    ++curr;
	}
	k = 1;
	i__2 = IWORK(i + 1);
	for (j = submat; j <= IWORK(i+1); ++j) {
	    IWORK(indxq + j) = k;
	    ++k;
/* L60: */
	}
/* L70: */
    }

/*     Successively merge eigensystems of adjacent submatrices   
       into eigensystem for the corresponding larger matrix.   

       while ( SUBPBS > 1 ) */

    curlvl = 1;
L80:
    if (subpbs > 1) {
	spm2 = subpbs - 2;
	i__1 = spm2;
	for (i = 0; i <= spm2; i += 2) {
	    if (i == 0) {
		submat = 1;
		matsiz = IWORK(2);
		msd2 = IWORK(1);
		curprb = 0;
	    } else {
		submat = IWORK(i) + 1;
		matsiz = IWORK(i + 2) - IWORK(i);
		msd2 = matsiz / 2;
		++curprb;
	    }

/*     Merge lower order eigensystems (of size MSD2 and MATSIZ - M
SD2)   
       into an eigensystem of size MATSIZ.   
       SLAED1 is used only for the full eigensystem of a tridiagon
al   
       matrix.   
       SLAED7 handles the cases in which eigenvalues only or eigen
values   
       and eigenvectors of a full symmetric matrix (which was redu
ced to   
       tridiagonal form) are desired. */

	    if (*icompq == 2) {
		slaed1_(&matsiz, &D(submat), &Q(submat,submat), 
			ldq, &IWORK(indxq + submat), &E(submat + msd2 - 1), &
			msd2, &WORK(1), &IWORK(subpbs + 1), info);
	    } else {
		slaed7_(icompq, &matsiz, qsiz, &tlvls, &curlvl, &curprb, &D(
			submat), &QSTORE(1,submat), ldqs, &
			IWORK(indxq + submat), &E(submat + msd2 - 1), &msd2, &
			WORK(iq), &IWORK(iqptr), &IWORK(iprmpt), &IWORK(iperm)
			, &IWORK(igivpt), &IWORK(igivcl), &WORK(igivnm), &
			WORK(iwrem), &IWORK(subpbs + 1), info);
	    }
	    if (*info != 0) {
		goto L130;
	    }
	    IWORK(i / 2 + 1) = IWORK(i + 2);
/* L90: */
	}
	subpbs /= 2;
	++curlvl;
	goto L80;
    }

/*     end while   

       Re-merge the eigenvalues/vectors which were deflated at the final 
  
       merge step. */

    if (*icompq == 1) {
	i__1 = *n;
	for (i = 1; i <= *n; ++i) {
	    j = IWORK(indxq + i);
	    WORK(i) = D(j);
	    scopy_(qsiz, &QSTORE(1,j), &c__1, &Q(1,i), &c__1);
/* L100: */
	}
	scopy_(n, &WORK(1), &c__1, &D(1), &c__1);
    } else if (*icompq == 2) {
	i__1 = *n;
	for (i = 1; i <= *n; ++i) {
	    j = IWORK(indxq + i);
	    WORK(i) = D(j);
	    scopy_(n, &Q(1,j), &c__1, &WORK(*n * i + 1), &c__1);
/* L110: */
	}
	scopy_(n, &WORK(1), &c__1, &D(1), &c__1);
	slacpy_("A", n, n, &WORK(*n + 1), n, &Q(1,1), ldq);
    } else {
	i__1 = *n;
	for (i = 1; i <= *n; ++i) {
	    j = IWORK(indxq + i);
	    WORK(i) = D(j);
/* L120: */
	}
	scopy_(n, &WORK(1), &c__1, &D(1), &c__1);
    }
    goto L140;

L130:
    *info = submat * (*n + 1) + submat + matsiz - 1;

L140:
    return 0;

/*     End of SLAED0 */

} /* slaed0_ */
示例#22
0
/* Subroutine */ int slaev2_(real *a, real *b, real *c__, real *rt1, real *
	rt2, real *cs1, real *sn1)
{
    /* System generated locals */
    real r__1;

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

    /* Local variables */
    static real ab, df, cs, ct, tb, sm, tn, rt, adf, acs;
    static integer sgn1, sgn2;
    static real acmn, acmx;


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

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

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

/*  SLAEV2 computes the eigendecomposition of a 2-by-2 symmetric matrix */
/*     [  A   B  ] */
/*     [  B   C  ]. */
/*  On return, RT1 is the eigenvalue of larger absolute value, RT2 is the */
/*  eigenvalue of smaller absolute value, and (CS1,SN1) is the unit right */
/*  eigenvector for RT1, giving the decomposition */

/*     [ CS1  SN1 ] [  A   B  ] [ CS1 -SN1 ]  =  [ RT1  0  ] */
/*     [-SN1  CS1 ] [  B   C  ] [ SN1  CS1 ]     [  0  RT2 ]. */

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

/*  A       (input) REAL */
/*          The (1,1) element of the 2-by-2 matrix. */

/*  B       (input) REAL */
/*          The (1,2) element and the conjugate of the (2,1) element of */
/*          the 2-by-2 matrix. */

/*  C       (input) REAL */
/*          The (2,2) element of the 2-by-2 matrix. */

/*  RT1     (output) REAL */
/*          The eigenvalue of larger absolute value. */

/*  RT2     (output) REAL */
/*          The eigenvalue of smaller absolute value. */

/*  CS1     (output) REAL */
/*  SN1     (output) REAL */
/*          The vector (CS1, SN1) is a unit right eigenvector for RT1. */

/*  Further Details */
/*  =============== */

/*  RT1 is accurate to a few ulps barring over/underflow. */

/*  RT2 may be inaccurate if there is massive cancellation in the */
/*  determinant A*C-B*B; higher precision or correctly rounded or */
/*  correctly truncated arithmetic would be needed to compute RT2 */
/*  accurately in all cases. */

/*  CS1 and SN1 are accurate to a few ulps barring over/underflow. */

/*  Overflow is possible only if RT1 is within a factor of 5 of overflow. */
/*  Underflow is harmless if the input data is 0 or exceeds */
/*     underflow_threshold / macheps. */

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

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

/*     Compute the eigenvalues */

    sm = *a + *c__;
    df = *a - *c__;
    adf = dabs(df);
    tb = *b + *b;
    ab = dabs(tb);
    if (dabs(*a) > dabs(*c__)) {
	acmx = *a;
	acmn = *c__;
    } else {
	acmx = *c__;
	acmn = *a;
    }
    if (adf > ab) {
/* Computing 2nd power */
	r__1 = ab / adf;
	rt = adf * sqrt(r__1 * r__1 + 1.f);
    } else if (adf < ab) {
/* Computing 2nd power */
	r__1 = adf / ab;
	rt = ab * sqrt(r__1 * r__1 + 1.f);
    } else {

/*        Includes case AB=ADF=0 */

	rt = ab * sqrt(2.f);
    }
    if (sm < 0.f) {
	*rt1 = (sm - rt) * .5f;
	sgn1 = -1;

/*        Order of execution important. */
/*        To get fully accurate smaller eigenvalue, */
/*        next line needs to be executed in higher precision. */

	*rt2 = acmx / *rt1 * acmn - *b / *rt1 * *b;
    } else if (sm > 0.f) {
	*rt1 = (sm + rt) * .5f;
	sgn1 = 1;

/*        Order of execution important. */
/*        To get fully accurate smaller eigenvalue, */
/*        next line needs to be executed in higher precision. */

	*rt2 = acmx / *rt1 * acmn - *b / *rt1 * *b;
    } else {

/*        Includes case RT1 = RT2 = 0 */

	*rt1 = rt * .5f;
	*rt2 = rt * -.5f;
	sgn1 = 1;
    }

/*     Compute the eigenvector */

    if (df >= 0.f) {
	cs = df + rt;
	sgn2 = 1;
    } else {
	cs = df - rt;
	sgn2 = -1;
    }
    acs = dabs(cs);
    if (acs > ab) {
	ct = -tb / cs;
	*sn1 = 1.f / sqrt(ct * ct + 1.f);
	*cs1 = ct * *sn1;
    } else {
	if (ab == 0.f) {
	    *cs1 = 1.f;
	    *sn1 = 0.f;
	} else {
	    tn = -cs / tb;
	    *cs1 = 1.f / sqrt(tn * tn + 1.f);
	    *sn1 = tn * *cs1;
	}
    }
    if (sgn1 == sgn2) {
	tn = *cs1;
	*cs1 = -(*sn1);
	*sn1 = tn;
    }
    return 0;

/*     End of SLAEV2 */

} /* slaev2_ */
示例#23
0
文件: slacon.c 项目: dacap/loseface
/* Subroutine */ int slacon_(integer *n, real *v, real *x, integer *isgn, 
	real *est, integer *kase)
{
    /* System generated locals */
    integer i__1;
    real r__1;

    /* Builtin functions */
    double r_sign(real *, real *);
    integer i_nint(real *);

    /* Local variables */
    static integer i__, j, iter;
    static real temp;
    static integer jump, jlast;
    extern doublereal sasum_(integer *, real *, integer *);
    extern /* Subroutine */ int scopy_(integer *, real *, integer *, real *, 
	    integer *);
    extern integer isamax_(integer *, real *, integer *);
    static real altsgn, estold;


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

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

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

/*  SLACON estimates the 1-norm of a square, real matrix A. */
/*  Reverse communication is used for evaluating matrix-vector products. */

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

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

/*  V      (workspace) REAL array, dimension (N) */
/*         On the final return, V = A*W,  where  EST = norm(V)/norm(W) */
/*         (W is not returned). */

/*  X      (input/output) REAL array, dimension (N) */
/*         On an intermediate return, X should be overwritten by */
/*               A * X,   if KASE=1, */
/*               A' * X,  if KASE=2, */
/*         and SLACON must be re-called with all the other parameters */
/*         unchanged. */

/*  ISGN   (workspace) INTEGER array, dimension (N) */

/*  EST    (input/output) REAL */
/*         On entry with KASE = 1 or 2 and JUMP = 3, EST should be */
/*         unchanged from the previous call to SLACON. */
/*         On exit, EST is an estimate (a lower bound) for norm(A). */

/*  KASE   (input/output) INTEGER */
/*         On the initial call to SLACON, KASE should be 0. */
/*         On an intermediate return, KASE will be 1 or 2, indicating */
/*         whether X should be overwritten by A * X  or A' * X. */
/*         On the final return from SLACON, KASE will again be 0. */

/*  Further Details */
/*  ======= ======= */

/*  Contributed by Nick Higham, University of Manchester. */
/*  Originally named SONEST, dated March 16, 1988. */

/*  Reference: N.J. Higham, "FORTRAN codes for estimating the one-norm of */
/*  a real or complex matrix, with applications to condition estimation", */
/*  ACM Trans. Math. Soft., vol. 14, no. 4, pp. 381-396, December 1988. */

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

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

    /* Parameter adjustments */
    --isgn;
    --x;
    --v;

    /* Function Body */
    if (*kase == 0) {
	i__1 = *n;
	for (i__ = 1; i__ <= i__1; ++i__) {
	    x[i__] = 1.f / (real) (*n);
/* L10: */
	}
	*kase = 1;
	jump = 1;
	return 0;
    }

    switch (jump) {
	case 1:  goto L20;
	case 2:  goto L40;
	case 3:  goto L70;
	case 4:  goto L110;
	case 5:  goto L140;
    }

/*     ................ ENTRY   (JUMP = 1) */
/*     FIRST ITERATION.  X HAS BEEN OVERWRITTEN BY A*X. */

L20:
    if (*n == 1) {
	v[1] = x[1];
	*est = dabs(v[1]);
/*        ... QUIT */
	goto L150;
    }
    *est = sasum_(n, &x[1], &c__1);

    i__1 = *n;
    for (i__ = 1; i__ <= i__1; ++i__) {
	x[i__] = r_sign(&c_b11, &x[i__]);
	isgn[i__] = i_nint(&x[i__]);
/* L30: */
    }
    *kase = 2;
    jump = 2;
    return 0;

/*     ................ ENTRY   (JUMP = 2) */
/*     FIRST ITERATION.  X HAS BEEN OVERWRITTEN BY TRANSPOSE(A)*X. */

L40:
    j = isamax_(n, &x[1], &c__1);
    iter = 2;

/*     MAIN LOOP - ITERATIONS 2,3,...,ITMAX. */

L50:
    i__1 = *n;
    for (i__ = 1; i__ <= i__1; ++i__) {
	x[i__] = 0.f;
/* L60: */
    }
    x[j] = 1.f;
    *kase = 1;
    jump = 3;
    return 0;

/*     ................ ENTRY   (JUMP = 3) */
/*     X HAS BEEN OVERWRITTEN BY A*X. */

L70:
    scopy_(n, &x[1], &c__1, &v[1], &c__1);
    estold = *est;
    *est = sasum_(n, &v[1], &c__1);
    i__1 = *n;
    for (i__ = 1; i__ <= i__1; ++i__) {
	r__1 = r_sign(&c_b11, &x[i__]);
	if (i_nint(&r__1) != isgn[i__]) {
	    goto L90;
	}
/* L80: */
    }
/*     REPEATED SIGN VECTOR DETECTED, HENCE ALGORITHM HAS CONVERGED. */
    goto L120;

L90:
/*     TEST FOR CYCLING. */
    if (*est <= estold) {
	goto L120;
    }

    i__1 = *n;
    for (i__ = 1; i__ <= i__1; ++i__) {
	x[i__] = r_sign(&c_b11, &x[i__]);
	isgn[i__] = i_nint(&x[i__]);
/* L100: */
    }
    *kase = 2;
    jump = 4;
    return 0;

/*     ................ ENTRY   (JUMP = 4) */
/*     X HAS BEEN OVERWRITTEN BY TRANSPOSE(A)*X. */

L110:
    jlast = j;
    j = isamax_(n, &x[1], &c__1);
    if (x[jlast] != (r__1 = x[j], dabs(r__1)) && iter < 5) {
	++iter;
	goto L50;
    }

/*     ITERATION COMPLETE.  FINAL STAGE. */

L120:
    altsgn = 1.f;
    i__1 = *n;
    for (i__ = 1; i__ <= i__1; ++i__) {
	x[i__] = altsgn * ((real) (i__ - 1) / (real) (*n - 1) + 1.f);
	altsgn = -altsgn;
/* L130: */
    }
    *kase = 1;
    jump = 5;
    return 0;

/*     ................ ENTRY   (JUMP = 5) */
/*     X HAS BEEN OVERWRITTEN BY A*X. */

L140:
    temp = sasum_(n, &x[1], &c__1) / (real) (*n * 3) * 2.f;
    if (temp > *est) {
	scopy_(n, &x[1], &c__1, &v[1], &c__1);
	*est = temp;
    }

L150:
    *kase = 0;
    return 0;

/*     End of SLACON */

} /* slacon_ */
示例#24
0
文件: sdrgsx.c 项目: zangel/uquad
/* Subroutine */ int sdrgsx_(integer *nsize, integer *ncmax, real *thresh, 
	integer *nin, integer *nout, real *a, integer *lda, real *b, real *ai,
	 real *bi, real *z__, real *q, real *alphar, real *alphai, real *beta,
	 real *c__, integer *ldc, real *s, real *work, integer *lwork, 
	integer *iwork, integer *liwork, logical *bwork, integer *info)
{
    /* Format strings */
    static char fmt_9999[] = "(\002 SDRGSX: \002,a,\002 returned INFO=\002,i"
	    "6,\002.\002,/9x,\002N=\002,i6,\002, JTYPE=\002,i6,\002)\002)";
    static char fmt_9997[] = "(\002 SDRGSX: SGET53 returned INFO=\002,i1,"
	    "\002 for eigenvalue \002,i6,\002.\002,/9x,\002N=\002,i6,\002, JT"
	    "YPE=\002,i6,\002)\002)";
    static char fmt_9996[] = "(\002 SDRGSX: S not in Schur form at eigenvalu"
	    "e \002,i6,\002.\002,/9x,\002N=\002,i6,\002, JTYPE=\002,i6,\002"
	    ")\002)";
    static char fmt_9995[] = "(/1x,a3,\002 -- Real Expert Generalized Schur "
	    "form\002,\002 problem driver\002)";
    static char fmt_9993[] = "(\002 Matrix types: \002,/\002  1:  A is a blo"
	    "ck diagonal matrix of Jordan blocks \002,\002and B is the identi"
	    "ty \002,/\002      matrix, \002,/\002  2:  A and B are upper tri"
	    "angular matrices, \002,/\002  3:  A and B are as type 2, but eac"
	    "h second diagonal \002,\002block in A_11 and \002,/\002      eac"
	    "h third diaongal block in A_22 are 2x2 blocks,\002,/\002  4:  A "
	    "and B are block diagonal matrices, \002,/\002  5:  (A,B) has pot"
	    "entially close or common \002,\002eigenvalues.\002,/)";
    static char fmt_9992[] = "(/\002 Tests performed:  (S is Schur, T is tri"
	    "angular, \002,\002Q and Z are \002,a,\002,\002,/19x,\002 a is al"
	    "pha, b is beta, and \002,a,\002 means \002,a,\002.)\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 u"
	    "lp )\002,/\002  5 = 1/ULP  if A is not in \002,\002Schur form "
	    "S\002,/\002  6 = difference between (alpha,beta)\002,\002 and di"
	    "agonals of (S,T)\002,/\002  7 = 1/ULP  if SDIM is not the correc"
	    "t number of \002,\002selected eigenvalues\002,/\002  8 = 1/ULP  "
	    "if DIFEST/DIFTRU > 10*THRESH or \002,\002DIFTRU/DIFEST > 10*THRE"
	    "SH\002,/\002  9 = 1/ULP  if DIFEST <> 0 or DIFTRU > ULP*norm(A,B"
	    ") \002,\002when reordering fails\002,/\002 10 = 1/ULP  if PLEST/"
	    "PLTRU > THRESH or \002,\002PLTRU/PLEST > THRESH\002,/\002    ( T"
	    "est 10 is only for input examples )\002,/)";
    static char fmt_9991[] = "(\002 Matrix order=\002,i2,\002, type=\002,i2"
	    ",\002, a=\002,e10.4,\002, order(A_11)=\002,i2,\002, result \002,"
	    "i2,\002 is \002,0p,f8.2)";
    static char fmt_9990[] = "(\002 Matrix order=\002,i2,\002, type=\002,i2"
	    ",\002, a=\002,e10.4,\002, order(A_11)=\002,i2,\002, result \002,"
	    "i2,\002 is \002,0p,e10.4)";
    static char fmt_9998[] = "(\002 SDRGSX: \002,a,\002 returned INFO=\002,i"
	    "6,\002.\002,/9x,\002N=\002,i6,\002, Input Example #\002,i2,\002"
	    ")\002)";
    static char fmt_9994[] = "(\002Input Example\002)";
    static char fmt_9989[] = "(\002 Input example #\002,i2,\002, matrix orde"
	    "r=\002,i4,\002,\002,\002 result \002,i2,\002 is\002,0p,f8.2)";
    static char fmt_9988[] = "(\002 Input example #\002,i2,\002, matrix orde"
	    "r=\002,i4,\002,\002,\002 result \002,i2,\002 is\002,1p,e10.3)";

    /* System generated locals */
    integer a_dim1, a_offset, ai_dim1, ai_offset, b_dim1, b_offset, bi_dim1, 
	    bi_offset, c_dim1, c_offset, q_dim1, q_offset, z_dim1, z_offset, 
	    i__1, i__2, i__3, i__4;
    real r__1, r__2, r__3, r__4, r__5, r__6, r__7, r__8, r__9, r__10;

    /* Builtin functions */
    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 real temp1, temp2;
    static integer i__, j;
    static real abnrm;
    static integer ifunc, iinfo, linfo;
    extern /* Subroutine */ int sget51_(integer *, integer *, real *, integer 
	    *, real *, integer *, real *, integer *, real *, integer *, real *
	    , real *), sget53_(real *, integer *, real *, integer *, real *, 
	    real *, real *, real *, integer *);
    static char sense[1];
    static integer nerrs, i1, ntest;
    static real pltru;
    extern /* Subroutine */ int slakf2_(integer *, integer *, real *, integer 
	    *, real *, real *, real *, real *, integer *), slatm5_(integer *, 
	    integer *, integer *, real *, integer *, real *, integer *, real *
	    , integer *, real *, integer *, real *, integer *, real *, 
	    integer *, real *, integer *, real *, integer *, real *, integer *
	    , integer *);
    static logical ilabad;
    static real thrsh2;
    extern /* Subroutine */ int slabad_(real *, real *);
    static integer mm, bdspac;
    static real pl[2];
    extern doublereal slamch_(char *), slange_(char *, integer *, 
	    integer *, real *, integer *, real *);
    extern /* Subroutine */ int xerbla_(char *, integer *);
    static real difest[2];
    extern integer ilaenv_(integer *, char *, char *, integer *, integer *, 
	    integer *, integer *, ftnlen, ftnlen);
    static real bignum;
    extern /* Subroutine */ int alasvm_(char *, integer *, integer *, integer 
	    *, integer *);
    static real weight;
    extern /* Subroutine */ int sgesvd_(char *, char *, integer *, integer *, 
	    real *, integer *, real *, real *, integer *, real *, integer *, 
	    real *, integer *, integer *), slacpy_(char *, 
	    integer *, integer *, real *, integer *, real *, integer *);
    static real diftru;
    extern /* Subroutine */ int slaset_(char *, integer *, integer *, real *, 
	    real *, real *, integer *), sggesx_(char *, char *, char *
	    , L_fp, char *, integer *, real *, integer *, real *, integer *, 
	    integer *, real *, real *, real *, real *, integer *, real *, 
	    integer *, real *, real *, real *, integer *, integer *, integer *
	    , logical *, integer *);
    static integer minwrk, maxwrk;
    static real smlnum;
    static integer mn2, nptknt;
    static real ulpinv, result[10];
    static integer ntestt;
    extern logical slctsx_();
    static integer prtype, qba, qbb;
    static real ulp;

    /* Fortran I/O blocks */
    static cilist io___22 = { 0, 0, 0, fmt_9999, 0 };
    static cilist io___31 = { 0, 0, 0, fmt_9997, 0 };
    static cilist io___32 = { 0, 0, 0, fmt_9996, 0 };
    static cilist io___35 = { 0, 0, 0, fmt_9995, 0 };
    static cilist io___36 = { 0, 0, 0, fmt_9993, 0 };
    static cilist io___37 = { 0, 0, 0, fmt_9992, 0 };
    static cilist io___39 = { 0, 0, 0, fmt_9991, 0 };
    static cilist io___40 = { 0, 0, 0, fmt_9990, 0 };
    static cilist io___42 = { 0, 0, 1, 0, 0 };
    static cilist io___43 = { 0, 0, 1, 0, 0 };
    static cilist io___44 = { 0, 0, 0, 0, 0 };
    static cilist io___45 = { 0, 0, 0, 0, 0 };
    static cilist io___46 = { 0, 0, 0, 0, 0 };
    static cilist io___48 = { 0, 0, 0, fmt_9998, 0 };
    static cilist io___49 = { 0, 0, 0, fmt_9997, 0 };
    static cilist io___50 = { 0, 0, 0, fmt_9996, 0 };
    static cilist io___51 = { 0, 0, 0, fmt_9995, 0 };
    static cilist io___52 = { 0, 0, 0, fmt_9994, 0 };
    static cilist io___53 = { 0, 0, 0, fmt_9992, 0 };
    static cilist io___54 = { 0, 0, 0, fmt_9989, 0 };
    static cilist io___55 = { 0, 0, 0, fmt_9988, 0 };



#define ai_ref(a_1,a_2) ai[(a_2)*ai_dim1 + a_1]
#define bi_ref(a_1,a_2) bi[(a_2)*bi_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   
    =======   

    SDRGSX checks the nonsymmetric generalized eigenvalue (Schur form)   
    problem expert driver SGGESX.   

    SGGESX factors A and B as Q S Z' and Q T Z', where ' means   
    transpose, T is upper triangular, S is in generalized Schur form   
    (block upper triangular, with 1x1 and 2x2 blocks on the diagonal,   
    the 2x2 blocks corresponding to complex conjugate pairs of   
    generalized eigenvalues), and Q and Z are orthogonal.  It also   
    computes the generalized eigenvalues (alpha(1),beta(1)), ...,   
    (alpha(n),beta(n)). Thus, w(j) = alpha(j)/beta(j) is a root of the   
    characteristic equation   

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

    Optionally it also reorders the eigenvalues so that a selected   
    cluster of eigenvalues appears in the leading diagonal block of the   
    Schur forms; computes a reciprocal condition number for the average   
    of the selected eigenvalues; and computes a reciprocal condition   
    number for the right and left deflating subspaces corresponding to   
    the selected eigenvalues.   

    When SDRGSX is called with NSIZE > 0, five (5) types of built-in   
    matrix pairs are used to test the routine SGGESX.   

    When SDRGSX is called with NSIZE = 0, it reads in test matrix data   
    to test SGGESX.   

    For each matrix pair, the following tests will be performed and   
    compared with the threshhold THRESH except for the tests (7) and (9):   

    (1)   | A - Q S Z' | / ( |A| n ulp )   

    (2)   | B - Q T Z' | / ( |B| n ulp )   

    (3)   | I - QQ' | / ( n ulp )   

    (4)   | I - ZZ' | / ( n ulp )   

    (5)   if A is in Schur form (i.e. quasi-triangular form)   

    (6)   maximum over j of D(j)  where:   

          if alpha(j) is real:   
                        |alpha(j) - S(j,j)|        |beta(j) - T(j,j)|   
              D(j) = ------------------------ + -----------------------   
                     max(|alpha(j)|,|S(j,j)|)   max(|beta(j)|,|T(j,j)|)   

          if alpha(j) is complex:   
                                    | det( s S - w T ) |   
              D(j) = ---------------------------------------------------   
                     ulp max( s norm(S), |w| norm(T) )*norm( s S - w T )   

              and S and T are here the 2 x 2 diagonal blocks of S and T   
              corresponding to the j-th and j+1-th eigenvalues.   

    (7)   if sorting worked and SDIM is the number of eigenvalues   
          which were selected.   

    (8)   the estimated value DIF does not differ from the true values of   
          Difu and Difl more than a factor 10*THRESH. If the estimate DIF   
          equals zero the corresponding true values of Difu and Difl   
          should be less than EPS*norm(A, B). If the true value of Difu   
          and Difl equal zero, the estimate DIF should be less than   
          EPS*norm(A, B).   

    (9)   If INFO = N+3 is returned by SGGESX, the reordering "failed"   
          and we check that DIF = PL = PR = 0 and that the true value of   
          Difu and Difl is < EPS*norm(A, B). We count the events when   
          INFO=N+3.   

    For read-in test matrices, the above tests are run except that the   
    exact value for DIF (and PL) is input data.  Additionally, there is   
    one more test run for read-in test matrices:   

    (10)  the estimated value PL does not differ from the true value of   
          PLTRU more than a factor THRESH. If the estimate PL equals   
          zero the corresponding true value of PLTRU should be less than   
          EPS*norm(A, B). If the true value of PLTRU equal zero, the   
          estimate PL should be less than EPS*norm(A, B).   

    Note that for the built-in tests, a total of 10*NSIZE*(NSIZE-1)   
    matrix pairs are generated and tested. NSIZE should be kept small.   

    SVD (routine SGESVD) is used for computing the true value of DIF_u   
    and DIF_l when testing the built-in test problems.   

    Built-in Test Matrices   
    ======================   

    All built-in test matrices are the 2 by 2 block of triangular   
    matrices   

             A = [ A11 A12 ]    and      B = [ B11 B12 ]   
                 [     A22 ]                 [     B22 ]   

    where for different type of A11 and A22 are given as the following.   
    A12 and B12 are chosen so that the generalized Sylvester equation   

             A11*R - L*A22 = -A12   
             B11*R - L*B22 = -B12   

    have prescribed solution R and L.   

    Type 1:  A11 = J_m(1,-1) and A_22 = J_k(1-a,1).   
             B11 = I_m, B22 = I_k   
             where J_k(a,b) is the k-by-k Jordan block with ``a'' on   
             diagonal and ``b'' on superdiagonal.   

    Type 2:  A11 = (a_ij) = ( 2(.5-sin(i)) ) and   
             B11 = (b_ij) = ( 2(.5-sin(ij)) ) for i=1,...,m, j=i,...,m   
             A22 = (a_ij) = ( 2(.5-sin(i+j)) ) and   
             B22 = (b_ij) = ( 2(.5-sin(ij)) ) for i=m+1,...,k, j=i,...,k   

    Type 3:  A11, A22 and B11, B22 are chosen as for Type 2, but each   
             second diagonal block in A_11 and each third diagonal block   
             in A_22 are made as 2 by 2 blocks.   

    Type 4:  A11 = ( 20(.5 - sin(ij)) ) and B22 = ( 2(.5 - sin(i+j)) )   
                for i=1,...,m,  j=1,...,m and   
             A22 = ( 20(.5 - sin(i+j)) ) and B22 = ( 2(.5 - sin(ij)) )   
                for i=m+1,...,k,  j=m+1,...,k   

    Type 5:  (A,B) and have potentially close or common eigenvalues and   
             very large departure from block diagonality A_11 is chosen   
             as the m x m leading submatrix of A_1:   
                     |  1  b                            |   
                     | -b  1                            |   
                     |        1+d  b                    |   
                     |         -b 1+d                   |   
              A_1 =  |                  d  1            |   
                     |                 -1  d            |   
                     |                        -d  1     |   
                     |                        -1 -d     |   
                     |                               1  |   
             and A_22 is chosen as the k x k leading submatrix of A_2:   
                     | -1  b                            |   
                     | -b -1                            |   
                     |       1-d  b                     |   
                     |       -b  1-d                    |   
              A_2 =  |                 d 1+b            |   
                     |               -1-b d             |   
                     |                       -d  1+b    |   
                     |                      -1+b  -d    |   
                     |                              1-d |   
             and matrix B are chosen as identity matrices (see SLATM5).   


    Arguments   
    =========   

    NSIZE   (input) INTEGER   
            The maximum size of the matrices to use. NSIZE >= 0.   
            If NSIZE = 0, no built-in tests matrices are used, but   
            read-in test matrices are used to test SGGESX.   

    NCMAX   (input) INTEGER   
            Maximum allowable NMAX for generating Kroneker matrix   
            in call to SLAKF2   

    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.  THRESH >= 0.   

    NIN     (input) INTEGER   
            The FORTRAN unit number for reading in the data file of   
            problems to solve.   

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

    A       (workspace) REAL array, dimension (LDA, NSIZE)   
            Used to store 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, B, AI, BI, Z and Q,   
            LDA >= max( 1, NSIZE ). For the read-in test,   
            LDA >= max( 1, N ), N is the size of the test matrices.   

    B       (workspace) REAL array, dimension (LDA, NSIZE)   
            Used to store the matrix whose eigenvalues are to be   
            computed.  On exit, B contains the last matrix actually used.   

    AI      (workspace) REAL array, dimension (LDA, NSIZE)   
            Copy of A, modified by SGGESX.   

    BI      (workspace) REAL array, dimension (LDA, NSIZE)   
            Copy of B, modified by SGGESX.   

    Z       (workspace) REAL array, dimension (LDA, NSIZE)   
            Z holds the left Schur vectors computed by SGGESX.   

    Q       (workspace) REAL array, dimension (LDA, NSIZE)   
            Q holds the right Schur vectors computed by SGGESX.   

    ALPHAR  (workspace) REAL array, dimension (NSIZE)   
    ALPHAI  (workspace) REAL array, dimension (NSIZE)   
    BETA    (workspace) REAL array, dimension (NSIZE)   
            On exit, (ALPHAR + ALPHAI*i)/BETA are the eigenvalues.   

    C       (workspace) REAL array, dimension (LDC, LDC)   
            Store the matrix generated by subroutine SLAKF2, this is the   
            matrix formed by Kronecker products used for estimating   
            DIF.   

    LDC     (input) INTEGER   
            The leading dimension of C. LDC >= max(1, LDA*LDA/2 ).   

    S       (workspace) REAL array, dimension (LDC)   
            Singular values of C   

    WORK    (workspace) REAL array, dimension (LWORK)   

    LWORK   (input) INTEGER   
            The dimension of the array WORK.   
            LWORK >= MAX( 5*NSIZE*NSIZE/2 - 2, 10*(NSIZE+1) )   

    IWORK   (workspace) INTEGER array, dimension (LIWORK)   

    LIWORK  (input) INTEGER   
            The dimension of the array IWORK. LIWORK >= NSIZE + 6.   

    BWORK   (workspace) LOGICAL array, dimension (LDA)   

    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.   

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


       Check for errors   

       Parameter adjustments */
    q_dim1 = *lda;
    q_offset = 1 + q_dim1 * 1;
    q -= q_offset;
    z_dim1 = *lda;
    z_offset = 1 + z_dim1 * 1;
    z__ -= z_offset;
    bi_dim1 = *lda;
    bi_offset = 1 + bi_dim1 * 1;
    bi -= bi_offset;
    ai_dim1 = *lda;
    ai_offset = 1 + ai_dim1 * 1;
    ai -= ai_offset;
    b_dim1 = *lda;
    b_offset = 1 + b_dim1 * 1;
    b -= b_offset;
    a_dim1 = *lda;
    a_offset = 1 + a_dim1 * 1;
    a -= a_offset;
    --alphar;
    --alphai;
    --beta;
    c_dim1 = *ldc;
    c_offset = 1 + c_dim1 * 1;
    c__ -= c_offset;
    --s;
    --work;
    --iwork;
    --bwork;

    /* Function Body */
    if (*nsize < 0) {
	*info = -1;
    } else if (*thresh < 0.f) {
	*info = -2;
    } else if (*nin <= 0) {
	*info = -3;
    } else if (*nout <= 0) {
	*info = -4;
    } else if (*lda < 1 || *lda < *nsize) {
	*info = -6;
    } else if (*ldc < 1 || *ldc < *nsize * *nsize / 2) {
	*info = -17;
    } else if (*liwork < *nsize + 6) {
	*info = -21;
    }

/*     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 = MAX( 10*( NSIZE+1 ), 5*NSIZE*NSIZE / 2-2 )   
   Computing MAX */
	i__1 = (*nsize + 1) * 10, i__2 = *nsize * 5 * *nsize / 2;
	minwrk = max(i__1,i__2);

/*        workspace for sggesx */

	maxwrk = (*nsize + 1) * 9 + *nsize * ilaenv_(&c__1, "SGEQRF", " ", 
		nsize, &c__1, nsize, &c__0, (ftnlen)6, (ftnlen)1);
/* Computing MAX */
	i__1 = maxwrk, i__2 = (*nsize + 1) * 9 + *nsize * ilaenv_(&c__1, 
		"SORGQR", " ", nsize, &c__1, nsize, &c_n1, (ftnlen)6, (ftnlen)
		1);
	maxwrk = max(i__1,i__2);

/*        workspace for sgesvd */

	bdspac = *nsize * 5 * *nsize / 2;
/* Computing MAX */
	i__3 = *nsize * *nsize / 2;
	i__4 = *nsize * *nsize / 2;
	i__1 = maxwrk, i__2 = *nsize * 3 * *nsize / 2 + *nsize * *nsize * 
		ilaenv_(&c__1, "SGEBRD", " ", &i__3, &i__4, &c_n1, &c_n1, (
		ftnlen)6, (ftnlen)1);
	maxwrk = max(i__1,i__2);
	maxwrk = max(maxwrk,bdspac);

	maxwrk = max(maxwrk,minwrk);

	work[1] = (real) maxwrk;
    }

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

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

/*     Important constants */

    ulp = slamch_("P");
    ulpinv = 1.f / ulp;
    smlnum = slamch_("S") / ulp;
    bignum = 1.f / smlnum;
    slabad_(&smlnum, &bignum);
    thrsh2 = *thresh * 10.f;
    ntestt = 0;
    nerrs = 0;

/*     Go to the tests for read-in matrix pairs */

    ifunc = 0;
    if (*nsize == 0) {
	goto L70;
    }

/*     Test the built-in matrix pairs.   
       Loop over different functions (IFUNC) of SGGESX, types (PRTYPE)   
       of test matrices, different size (M+N) */

    prtype = 0;
    qba = 3;
    qbb = 4;
    weight = sqrt(ulp);

    for (ifunc = 0; ifunc <= 3; ++ifunc) {
	for (prtype = 1; prtype <= 5; ++prtype) {
	    i__1 = *nsize - 1;
	    for (mn_1.m = 1; mn_1.m <= i__1; ++mn_1.m) {
		i__2 = *nsize - mn_1.m;
		for (mn_1.n = 1; mn_1.n <= i__2; ++mn_1.n) {

		    weight = 1.f / weight;
		    mn_1.mplusn = mn_1.m + mn_1.n;

/*                 Generate test matrices */

		    mn_1.fs = TRUE_;
		    mn_1.k = 0;

		    slaset_("Full", &mn_1.mplusn, &mn_1.mplusn, &c_b26, &
			    c_b26, &ai[ai_offset], lda);
		    slaset_("Full", &mn_1.mplusn, &mn_1.mplusn, &c_b26, &
			    c_b26, &bi[bi_offset], lda);

		    slatm5_(&prtype, &mn_1.m, &mn_1.n, &ai[ai_offset], lda, &
			    ai_ref(mn_1.m + 1, mn_1.m + 1), lda, &ai_ref(1, 
			    mn_1.m + 1), lda, &bi[bi_offset], lda, &bi_ref(
			    mn_1.m + 1, mn_1.m + 1), lda, &bi_ref(1, mn_1.m + 
			    1), lda, &q[q_offset], lda, &z__[z_offset], lda, &
			    weight, &qba, &qbb);

/*                 Compute the Schur factorization and swapping the   
                   m-by-m (1,1)-blocks with n-by-n (2,2)-blocks.   
                   Swapping is accomplished via the function SLCTSX   
                   which is supplied below. */

		    if (ifunc == 0) {
			*(unsigned char *)sense = 'N';
		    } else if (ifunc == 1) {
			*(unsigned char *)sense = 'E';
		    } else if (ifunc == 2) {
			*(unsigned char *)sense = 'V';
		    } else if (ifunc == 3) {
			*(unsigned char *)sense = 'B';
		    }

		    slacpy_("Full", &mn_1.mplusn, &mn_1.mplusn, &ai[ai_offset]
			    , lda, &a[a_offset], lda);
		    slacpy_("Full", &mn_1.mplusn, &mn_1.mplusn, &bi[bi_offset]
			    , lda, &b[b_offset], lda);

		    sggesx_("V", "V", "S", (L_fp)slctsx_, sense, &mn_1.mplusn,
			     &ai[ai_offset], lda, &bi[bi_offset], lda, &mm, &
			    alphar[1], &alphai[1], &beta[1], &q[q_offset], 
			    lda, &z__[z_offset], lda, pl, difest, &work[1], 
			    lwork, &iwork[1], liwork, &bwork[1], &linfo);

		    if (linfo != 0 && linfo != mn_1.mplusn + 2) {
			result[0] = ulpinv;
			io___22.ciunit = *nout;
			s_wsfe(&io___22);
			do_fio(&c__1, "SGGESX", (ftnlen)6);
			do_fio(&c__1, (char *)&linfo, (ftnlen)sizeof(integer))
				;
			do_fio(&c__1, (char *)&mn_1.mplusn, (ftnlen)sizeof(
				integer));
			do_fio(&c__1, (char *)&prtype, (ftnlen)sizeof(integer)
				);
			e_wsfe();
			*info = linfo;
			goto L30;
		    }

/*                 Compute the norm(A, B) */

		    slacpy_("Full", &mn_1.mplusn, &mn_1.mplusn, &ai[ai_offset]
			    , lda, &work[1], &mn_1.mplusn);
		    slacpy_("Full", &mn_1.mplusn, &mn_1.mplusn, &bi[bi_offset]
			    , lda, &work[mn_1.mplusn * mn_1.mplusn + 1], &
			    mn_1.mplusn);
		    i__3 = mn_1.mplusn << 1;
		    abnrm = slange_("Fro", &mn_1.mplusn, &i__3, &work[1], &
			    mn_1.mplusn, &work[1]);

/*                 Do tests (1) to (4) */

		    sget51_(&c__1, &mn_1.mplusn, &a[a_offset], lda, &ai[
			    ai_offset], lda, &q[q_offset], lda, &z__[z_offset]
			    , lda, &work[1], result);
		    sget51_(&c__1, &mn_1.mplusn, &b[b_offset], lda, &bi[
			    bi_offset], lda, &q[q_offset], lda, &z__[z_offset]
			    , lda, &work[1], &result[1]);
		    sget51_(&c__3, &mn_1.mplusn, &b[b_offset], lda, &bi[
			    bi_offset], lda, &q[q_offset], lda, &q[q_offset], 
			    lda, &work[1], &result[2]);
		    sget51_(&c__3, &mn_1.mplusn, &b[b_offset], lda, &bi[
			    bi_offset], lda, &z__[z_offset], lda, &z__[
			    z_offset], lda, &work[1], &result[3]);
		    ntest = 4;

/*                 Do tests (5) and (6): check Schur form of A and   
                   compare eigenvalues with diagonals. */

		    temp1 = 0.f;
		    result[4] = 0.f;
		    result[5] = 0.f;

		    i__3 = mn_1.mplusn;
		    for (j = 1; j <= i__3; ++j) {
			ilabad = FALSE_;
			if (alphai[j] == 0.f) {
/* Computing MAX */
			    r__7 = smlnum, r__8 = (r__2 = alphar[j], dabs(
				    r__2)), r__7 = max(r__7,r__8), r__8 = (
				    r__3 = ai_ref(j, j), dabs(r__3));
/* Computing MAX */
			    r__9 = smlnum, r__10 = (r__5 = beta[j], dabs(r__5)
				    ), r__9 = max(r__9,r__10), r__10 = (r__6 =
				     bi_ref(j, j), dabs(r__6));
			    temp2 = ((r__1 = alphar[j] - ai_ref(j, j), dabs(
				    r__1)) / dmax(r__7,r__8) + (r__4 = beta[j]
				     - bi_ref(j, j), dabs(r__4)) / dmax(r__9,
				    r__10)) / ulp;
			    if (j < mn_1.mplusn) {
				if (ai_ref(j + 1, j) != 0.f) {
				    ilabad = TRUE_;
				    result[4] = ulpinv;
				}
			    }
			    if (j > 1) {
				if (ai_ref(j, j - 1) != 0.f) {
				    ilabad = TRUE_;
				    result[4] = ulpinv;
				}
			    }
			} else {
			    if (alphai[j] > 0.f) {
				i1 = j;
			    } else {
				i1 = j - 1;
			    }
			    if (i1 <= 0 || i1 >= mn_1.mplusn) {
				ilabad = TRUE_;
			    } else if (i1 < mn_1.mplusn - 1) {
				if (ai_ref(i1 + 2, i1 + 1) != 0.f) {
				    ilabad = TRUE_;
				    result[4] = ulpinv;
				}
			    } else if (i1 > 1) {
				if (ai_ref(i1, i1 - 1) != 0.f) {
				    ilabad = TRUE_;
				    result[4] = ulpinv;
				}
			    }
			    if (! ilabad) {
				sget53_(&ai_ref(i1, i1), lda, &bi_ref(i1, i1),
					 lda, &beta[j], &alphar[j], &alphai[j]
					, &temp2, &iinfo);
				if (iinfo >= 3) {
				    io___31.ciunit = *nout;
				    s_wsfe(&io___31);
				    do_fio(&c__1, (char *)&iinfo, (ftnlen)
					    sizeof(integer));
				    do_fio(&c__1, (char *)&j, (ftnlen)sizeof(
					    integer));
				    do_fio(&c__1, (char *)&mn_1.mplusn, (
					    ftnlen)sizeof(integer));
				    do_fio(&c__1, (char *)&prtype, (ftnlen)
					    sizeof(integer));
				    e_wsfe();
				    *info = abs(iinfo);
				}
			    } else {
				temp2 = ulpinv;
			    }
			}
			temp1 = dmax(temp1,temp2);
			if (ilabad) {
			    io___32.ciunit = *nout;
			    s_wsfe(&io___32);
			    do_fio(&c__1, (char *)&j, (ftnlen)sizeof(integer))
				    ;
			    do_fio(&c__1, (char *)&mn_1.mplusn, (ftnlen)
				    sizeof(integer));
			    do_fio(&c__1, (char *)&prtype, (ftnlen)sizeof(
				    integer));
			    e_wsfe();
			}
/* L10: */
		    }
		    result[5] = temp1;
		    ntest += 2;

/*                 Test (7) (if sorting worked) */

		    result[6] = 0.f;
		    if (linfo == mn_1.mplusn + 3) {
			result[6] = ulpinv;
		    } else if (mm != mn_1.n) {
			result[6] = ulpinv;
		    }
		    ++ntest;

/*                 Test (8): compare the estimated value DIF and its   
                   value. first, compute the exact DIF. */

		    result[7] = 0.f;
		    mn2 = mm * (mn_1.mplusn - mm) << 1;
		    if (ifunc >= 2 && mn2 <= *ncmax * *ncmax) {

/*                    Note: for either following two causes, there are   
                      almost same number of test cases fail the test. */

			i__3 = mn_1.mplusn - mm;
			slakf2_(&mm, &i__3, &ai[ai_offset], lda, &ai_ref(mm + 
				1, mm + 1), &bi[bi_offset], &bi_ref(mm + 1, 
				mm + 1), &c__[c_offset], ldc);

			i__3 = *lwork - 2;
			sgesvd_("N", "N", &mn2, &mn2, &c__[c_offset], ldc, &s[
				1], &work[1], &c__1, &work[2], &c__1, &work[3]
				, &i__3, info);
			diftru = s[mn2];

			if (difest[1] == 0.f) {
			    if (diftru > abnrm * ulp) {
				result[7] = ulpinv;
			    }
			} else if (diftru == 0.f) {
			    if (difest[1] > abnrm * ulp) {
				result[7] = ulpinv;
			    }
			} else if (diftru > thrsh2 * difest[1] || diftru * 
				thrsh2 < difest[1]) {
/* Computing MAX */
			    r__1 = diftru / difest[1], r__2 = difest[1] / 
				    diftru;
			    result[7] = dmax(r__1,r__2);
			}
			++ntest;
		    }

/*                 Test (9) */

		    result[8] = 0.f;
		    if (linfo == mn_1.mplusn + 2) {
			if (diftru > abnrm * ulp) {
			    result[8] = ulpinv;
			}
			if (ifunc > 1 && difest[1] != 0.f) {
			    result[8] = ulpinv;
			}
			if (ifunc == 1 && pl[0] != 0.f) {
			    result[8] = ulpinv;
			}
			++ntest;
		    }

		    ntestt += ntest;

/*                 Print out tests which fail. */

		    for (j = 1; j <= 9; ++j) {
			if (result[j - 1] >= *thresh) {

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

			    if (nerrs == 0) {
				io___35.ciunit = *nout;
				s_wsfe(&io___35);
				do_fio(&c__1, "SGX", (ftnlen)3);
				e_wsfe();

/*                          Matrix types */

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

/*                          Tests performed */

				io___37.ciunit = *nout;
				s_wsfe(&io___37);
				do_fio(&c__1, "orthogonal", (ftnlen)10);
				do_fio(&c__1, "'", (ftnlen)1);
				do_fio(&c__1, "transpose", (ftnlen)9);
				for (i__ = 1; i__ <= 4; ++i__) {
				    do_fio(&c__1, "'", (ftnlen)1);
				}
				e_wsfe();

			    }
			    ++nerrs;
			    if (result[j - 1] < 1e4f) {
				io___39.ciunit = *nout;
				s_wsfe(&io___39);
				do_fio(&c__1, (char *)&mn_1.mplusn, (ftnlen)
					sizeof(integer));
				do_fio(&c__1, (char *)&prtype, (ftnlen)sizeof(
					integer));
				do_fio(&c__1, (char *)&weight, (ftnlen)sizeof(
					real));
				do_fio(&c__1, (char *)&mn_1.m, (ftnlen)sizeof(
					integer));
				do_fio(&c__1, (char *)&j, (ftnlen)sizeof(
					integer));
				do_fio(&c__1, (char *)&result[j - 1], (ftnlen)
					sizeof(real));
				e_wsfe();
			    } else {
				io___40.ciunit = *nout;
				s_wsfe(&io___40);
				do_fio(&c__1, (char *)&mn_1.mplusn, (ftnlen)
					sizeof(integer));
				do_fio(&c__1, (char *)&prtype, (ftnlen)sizeof(
					integer));
				do_fio(&c__1, (char *)&weight, (ftnlen)sizeof(
					real));
				do_fio(&c__1, (char *)&mn_1.m, (ftnlen)sizeof(
					integer));
				do_fio(&c__1, (char *)&j, (ftnlen)sizeof(
					integer));
				do_fio(&c__1, (char *)&result[j - 1], (ftnlen)
					sizeof(real));
				e_wsfe();
			    }
			}
/* L20: */
		    }

L30:
		    ;
		}
/* L40: */
	    }
/* L50: */
	}
/* L60: */
    }

    goto L150;

L70:

/*     Read in data from file to check accuracy of condition estimation   
       Read input data until N=0 */

    nptknt = 0;

L80:
    io___42.ciunit = *nin;
    i__1 = s_rsle(&io___42);
    if (i__1 != 0) {
	goto L140;
    }
    i__1 = do_lio(&c__3, &c__1, (char *)&mn_1.mplusn, (ftnlen)sizeof(integer))
	    ;
    if (i__1 != 0) {
	goto L140;
    }
    i__1 = e_rsle();
    if (i__1 != 0) {
	goto L140;
    }
    if (mn_1.mplusn == 0) {
	goto L140;
    }
    io___43.ciunit = *nin;
    i__1 = s_rsle(&io___43);
    if (i__1 != 0) {
	goto L140;
    }
    i__1 = do_lio(&c__3, &c__1, (char *)&mn_1.n, (ftnlen)sizeof(integer));
    if (i__1 != 0) {
	goto L140;
    }
    i__1 = e_rsle();
    if (i__1 != 0) {
	goto L140;
    }
    i__1 = mn_1.mplusn;
    for (i__ = 1; i__ <= i__1; ++i__) {
	io___44.ciunit = *nin;
	s_rsle(&io___44);
	i__2 = mn_1.mplusn;
	for (j = 1; j <= i__2; ++j) {
	    do_lio(&c__4, &c__1, (char *)&ai_ref(i__, j), (ftnlen)sizeof(real)
		    );
	}
	e_rsle();
/* L90: */
    }
    i__1 = mn_1.mplusn;
    for (i__ = 1; i__ <= i__1; ++i__) {
	io___45.ciunit = *nin;
	s_rsle(&io___45);
	i__2 = mn_1.mplusn;
	for (j = 1; j <= i__2; ++j) {
	    do_lio(&c__4, &c__1, (char *)&bi_ref(i__, j), (ftnlen)sizeof(real)
		    );
	}
	e_rsle();
/* L100: */
    }
    io___46.ciunit = *nin;
    s_rsle(&io___46);
    do_lio(&c__4, &c__1, (char *)&pltru, (ftnlen)sizeof(real));
    do_lio(&c__4, &c__1, (char *)&diftru, (ftnlen)sizeof(real));
    e_rsle();

    ++nptknt;
    mn_1.fs = TRUE_;
    mn_1.k = 0;
    mn_1.m = mn_1.mplusn - mn_1.n;

    slacpy_("Full", &mn_1.mplusn, &mn_1.mplusn, &ai[ai_offset], lda, &a[
	    a_offset], lda);
    slacpy_("Full", &mn_1.mplusn, &mn_1.mplusn, &bi[bi_offset], lda, &b[
	    b_offset], lda);

/*     Compute the Schur factorization while swaping the   
       m-by-m (1,1)-blocks with n-by-n (2,2)-blocks. */

    sggesx_("V", "V", "S", (L_fp)slctsx_, "B", &mn_1.mplusn, &ai[ai_offset], 
	    lda, &bi[bi_offset], lda, &mm, &alphar[1], &alphai[1], &beta[1], &
	    q[q_offset], lda, &z__[z_offset], lda, pl, difest, &work[1], 
	    lwork, &iwork[1], liwork, &bwork[1], &linfo);

    if (linfo != 0 && linfo != mn_1.mplusn + 2) {
	result[0] = ulpinv;
	io___48.ciunit = *nout;
	s_wsfe(&io___48);
	do_fio(&c__1, "SGGESX", (ftnlen)6);
	do_fio(&c__1, (char *)&linfo, (ftnlen)sizeof(integer));
	do_fio(&c__1, (char *)&mn_1.mplusn, (ftnlen)sizeof(integer));
	do_fio(&c__1, (char *)&nptknt, (ftnlen)sizeof(integer));
	e_wsfe();
	goto L130;
    }

/*     Compute the norm(A, B)   
          (should this be norm of (A,B) or (AI,BI)?) */

    slacpy_("Full", &mn_1.mplusn, &mn_1.mplusn, &ai[ai_offset], lda, &work[1],
	     &mn_1.mplusn);
    slacpy_("Full", &mn_1.mplusn, &mn_1.mplusn, &bi[bi_offset], lda, &work[
	    mn_1.mplusn * mn_1.mplusn + 1], &mn_1.mplusn);
    i__1 = mn_1.mplusn << 1;
    abnrm = slange_("Fro", &mn_1.mplusn, &i__1, &work[1], &mn_1.mplusn, &work[
	    1]);

/*     Do tests (1) to (4) */

    sget51_(&c__1, &mn_1.mplusn, &a[a_offset], lda, &ai[ai_offset], lda, &q[
	    q_offset], lda, &z__[z_offset], lda, &work[1], result);
    sget51_(&c__1, &mn_1.mplusn, &b[b_offset], lda, &bi[bi_offset], lda, &q[
	    q_offset], lda, &z__[z_offset], lda, &work[1], &result[1]);
    sget51_(&c__3, &mn_1.mplusn, &b[b_offset], lda, &bi[bi_offset], lda, &q[
	    q_offset], lda, &q[q_offset], lda, &work[1], &result[2]);
    sget51_(&c__3, &mn_1.mplusn, &b[b_offset], lda, &bi[bi_offset], lda, &z__[
	    z_offset], lda, &z__[z_offset], lda, &work[1], &result[3]);

/*     Do tests (5) and (6): check Schur form of A and compare   
       eigenvalues with diagonals. */

    ntest = 6;
    temp1 = 0.f;
    result[4] = 0.f;
    result[5] = 0.f;

    i__1 = mn_1.mplusn;
    for (j = 1; j <= i__1; ++j) {
	ilabad = FALSE_;
	if (alphai[j] == 0.f) {
/* Computing MAX */
	    r__7 = smlnum, r__8 = (r__2 = alphar[j], dabs(r__2)), r__7 = max(
		    r__7,r__8), r__8 = (r__3 = ai_ref(j, j), dabs(r__3));
/* Computing MAX */
	    r__9 = smlnum, r__10 = (r__5 = beta[j], dabs(r__5)), r__9 = max(
		    r__9,r__10), r__10 = (r__6 = bi_ref(j, j), dabs(r__6));
	    temp2 = ((r__1 = alphar[j] - ai_ref(j, j), dabs(r__1)) / dmax(
		    r__7,r__8) + (r__4 = beta[j] - bi_ref(j, j), dabs(r__4)) /
		     dmax(r__9,r__10)) / ulp;
	    if (j < mn_1.mplusn) {
		if (ai_ref(j + 1, j) != 0.f) {
		    ilabad = TRUE_;
		    result[4] = ulpinv;
		}
	    }
	    if (j > 1) {
		if (ai_ref(j, j - 1) != 0.f) {
		    ilabad = TRUE_;
		    result[4] = ulpinv;
		}
	    }
	} else {
	    if (alphai[j] > 0.f) {
		i1 = j;
	    } else {
		i1 = j - 1;
	    }
	    if (i1 <= 0 || i1 >= mn_1.mplusn) {
		ilabad = TRUE_;
	    } else if (i1 < mn_1.mplusn - 1) {
		if (ai_ref(i1 + 2, i1 + 1) != 0.f) {
		    ilabad = TRUE_;
		    result[4] = ulpinv;
		}
	    } else if (i1 > 1) {
		if (ai_ref(i1, i1 - 1) != 0.f) {
		    ilabad = TRUE_;
		    result[4] = ulpinv;
		}
	    }
	    if (! ilabad) {
		sget53_(&ai_ref(i1, i1), lda, &bi_ref(i1, i1), lda, &beta[j], 
			&alphar[j], &alphai[j], &temp2, &iinfo);
		if (iinfo >= 3) {
		    io___49.ciunit = *nout;
		    s_wsfe(&io___49);
		    do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer));
		    do_fio(&c__1, (char *)&j, (ftnlen)sizeof(integer));
		    do_fio(&c__1, (char *)&mn_1.mplusn, (ftnlen)sizeof(
			    integer));
		    do_fio(&c__1, (char *)&nptknt, (ftnlen)sizeof(integer));
		    e_wsfe();
		    *info = abs(iinfo);
		}
	    } else {
		temp2 = ulpinv;
	    }
	}
	temp1 = dmax(temp1,temp2);
	if (ilabad) {
	    io___50.ciunit = *nout;
	    s_wsfe(&io___50);
	    do_fio(&c__1, (char *)&j, (ftnlen)sizeof(integer));
	    do_fio(&c__1, (char *)&mn_1.mplusn, (ftnlen)sizeof(integer));
	    do_fio(&c__1, (char *)&nptknt, (ftnlen)sizeof(integer));
	    e_wsfe();
	}
/* L110: */
    }
    result[5] = temp1;

/*     Test (7) (if sorting worked)  <--------- need to be checked. */

    ntest = 7;
    result[6] = 0.f;
    if (linfo == mn_1.mplusn + 3) {
	result[6] = ulpinv;
    }

/*     Test (8): compare the estimated value of DIF and its true value. */

    ntest = 8;
    result[7] = 0.f;
    if (difest[1] == 0.f) {
	if (diftru > abnrm * ulp) {
	    result[7] = ulpinv;
	}
    } else if (diftru == 0.f) {
	if (difest[1] > abnrm * ulp) {
	    result[7] = ulpinv;
	}
    } else if (diftru > thrsh2 * difest[1] || diftru * thrsh2 < difest[1]) {
/* Computing MAX */
	r__1 = diftru / difest[1], r__2 = difest[1] / diftru;
	result[7] = dmax(r__1,r__2);
    }

/*     Test (9) */

    ntest = 9;
    result[8] = 0.f;
    if (linfo == mn_1.mplusn + 2) {
	if (diftru > abnrm * ulp) {
	    result[8] = ulpinv;
	}
	if (ifunc > 1 && difest[1] != 0.f) {
	    result[8] = ulpinv;
	}
	if (ifunc == 1 && pl[0] != 0.f) {
	    result[8] = ulpinv;
	}
    }

/*     Test (10): compare the estimated value of PL and it true value. */

    ntest = 10;
    result[9] = 0.f;
    if (pl[0] == 0.f) {
	if (pltru > abnrm * ulp) {
	    result[9] = ulpinv;
	}
    } else if (pltru == 0.f) {
	if (pl[0] > abnrm * ulp) {
	    result[9] = ulpinv;
	}
    } else if (pltru > *thresh * pl[0] || pltru * *thresh < pl[0]) {
	result[9] = ulpinv;
    }

    ntestt += ntest;

/*     Print out tests which fail. */

    i__1 = ntest;
    for (j = 1; j <= i__1; ++j) {
	if (result[j - 1] >= *thresh) {

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

	    if (nerrs == 0) {
		io___51.ciunit = *nout;
		s_wsfe(&io___51);
		do_fio(&c__1, "SGX", (ftnlen)3);
		e_wsfe();

/*              Matrix types */

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

/*              Tests performed */

		io___53.ciunit = *nout;
		s_wsfe(&io___53);
		do_fio(&c__1, "orthogonal", (ftnlen)10);
		do_fio(&c__1, "'", (ftnlen)1);
		do_fio(&c__1, "transpose", (ftnlen)9);
		for (i__ = 1; i__ <= 4; ++i__) {
		    do_fio(&c__1, "'", (ftnlen)1);
		}
		e_wsfe();

	    }
	    ++nerrs;
	    if (result[j - 1] < 1e4f) {
		io___54.ciunit = *nout;
		s_wsfe(&io___54);
		do_fio(&c__1, (char *)&nptknt, (ftnlen)sizeof(integer));
		do_fio(&c__1, (char *)&mn_1.mplusn, (ftnlen)sizeof(integer));
		do_fio(&c__1, (char *)&j, (ftnlen)sizeof(integer));
		do_fio(&c__1, (char *)&result[j - 1], (ftnlen)sizeof(real));
		e_wsfe();
	    } else {
		io___55.ciunit = *nout;
		s_wsfe(&io___55);
		do_fio(&c__1, (char *)&nptknt, (ftnlen)sizeof(integer));
		do_fio(&c__1, (char *)&mn_1.mplusn, (ftnlen)sizeof(integer));
		do_fio(&c__1, (char *)&j, (ftnlen)sizeof(integer));
		do_fio(&c__1, (char *)&result[j - 1], (ftnlen)sizeof(real));
		e_wsfe();
	    }
	}

/* L120: */
    }

L130:
    goto L80;
L140:

L150:

/*     Summary */

    alasvm_("SGX", nout, &nerrs, &ntestt, &c__0);

    work[1] = (real) maxwrk;

    return 0;









/*     End of SDRGSX */

} /* sdrgsx_ */
示例#25
0
文件: slamch.c 项目: aceskpark/osfeo
/* Subroutine */ int slamc2_(int *beta, int *t, int *rnd, float *
	eps, int *emin, float *rmin, int *emax, float *rmax)
{
/*  -- LAPACK auxiliary routine (version 2.0) --   
       Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,   
       Courant Institute, Argonne National Lab, and Rice University   
       October 31, 1992   


    Purpose   
    =======   

    SLAMC2 determines the machine parameters specified in its argument   
    list.   

    Arguments   
    =========   

    BETA    (output) INT   
            The base of the machine.   

    T       (output) INT   
            The number of ( BETA ) digits in the mantissa.   

    RND     (output) INT   
            Specifies whether proper rounding  ( RND = .TRUE. )  or   
            chopping  ( RND = .FALSE. )  occurs in addition. This may not 
  
            be a reliable guide to the way in which the machine performs 
  
            its arithmetic.   

    EPS     (output) FLOAT   
            The smallest positive number such that   

               fl( 1.0 - EPS ) .LT. 1.0,   

            where fl denotes the computed value.   

    EMIN    (output) INT   
            The minimum exponent before (gradual) underflow occurs.   

    RMIN    (output) FLOAT   
            The smallest normalized number for the machine, given by   
            BASE**( EMIN - 1 ), where  BASE  is the floating point value 
  
            of BETA.   

    EMAX    (output) INT   
            The maximum exponent before overflow occurs.   

    RMAX    (output) FLOAT   
            The largest positive number for the machine, given by   
            BASE**EMAX * ( 1 - EPS ), where  BASE  is the floating point 
  
            value of BETA.   

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

    The computation of  EPS  is based on a routine PARANOIA by   
    W. Kahan of the University of California at Berkeley.   

   ===================================================================== 
*/
    /* Table of constant values */
    static int c__1 = 1;
    
    /* Initialized data */
    static int first = TRUE_;
    static int iwarn = FALSE_;
    /* System generated locals */
    int i__1;
    float r__1, r__2, r__3, r__4, r__5;
    /* Builtin functions */
    double pow_ri(float *, int *);
    /* Local variables */
    static int ieee;
    static float half;
    static int lrnd;
    static float leps, zero, a, b, c;
    static int i, lbeta;
    static float rbase;
    static int lemin, lemax, gnmin;
    static float small;
    static int gpmin;
    static float third, lrmin, lrmax, sixth;
    static int lieee1;
    extern /* Subroutine */ int slamc1_(int *, int *, int *, 
	    int *);
    extern double slamc3_(float *, float *);
    extern /* Subroutine */ int slamc4_(int *, float *, int *), 
	    slamc5_(int *, int *, int *, int *, int *, 
	    float *);
    static int lt, ngnmin, ngpmin;
    static float one, two;



    if (first) {
	first = FALSE_;
	zero = 0.f;
	one = 1.f;
	two = 2.f;

/*        LBETA, LT, LRND, LEPS, LEMIN and LRMIN  are the local values
 of   
          BETA, T, RND, EPS, EMIN and RMIN.   

          Throughout this routine  we use the function  SLAMC3  to ens
ure   
          that relevant values are stored  and not held in registers, 
 or   
          are not affected by optimizers.   

          SLAMC1 returns the parameters  LBETA, LT, LRND and LIEEE1. 
*/

	slamc1_(&lbeta, &lt, &lrnd, &lieee1);

/*        Start to find EPS. */

	b = (float) lbeta;
	i__1 = -lt;
	a = pow_ri(&b, &i__1);
	leps = a;

/*        Try some tricks to see whether or not this is the correct  E
PS. */

	b = two / 3;
	half = one / 2;
	r__1 = -(double)half;
	sixth = slamc3_(&b, &r__1);
	third = slamc3_(&sixth, &sixth);
	r__1 = -(double)half;
	b = slamc3_(&third, &r__1);
	b = slamc3_(&b, &sixth);
	b = dabs(b);
	if (b < leps) {
	    b = leps;
	}

	leps = 1.f;

/* +       WHILE( ( LEPS.GT.B ).AND.( B.GT.ZERO ) )LOOP */
L10:
	if (leps > b && b > zero) {
	    leps = b;
	    r__1 = half * leps;
/* Computing 5th power */
	    r__3 = two, r__4 = r__3, r__3 *= r__3;
/* Computing 2nd power */
	    r__5 = leps;
	    r__2 = r__4 * (r__3 * r__3) * (r__5 * r__5);
	    c = slamc3_(&r__1, &r__2);
	    r__1 = -(double)c;
	    c = slamc3_(&half, &r__1);
	    b = slamc3_(&half, &c);
	    r__1 = -(double)b;
	    c = slamc3_(&half, &r__1);
	    b = slamc3_(&half, &c);
	    goto L10;
	}
/* +       END WHILE */

	if (a < leps) {
	    leps = a;
	}

/*        Computation of EPS complete.   

          Now find  EMIN.  Let A = + or - 1, and + or - (1 + BASE**(-3
)).   
          Keep dividing  A by BETA until (gradual) underflow occurs. T
his   
          is detected when we cannot recover the previous A. */

	rbase = one / lbeta;
	small = one;
	for (i = 1; i <= 3; ++i) {
	    r__1 = small * rbase;
	    small = slamc3_(&r__1, &zero);
/* L20: */
	}
	a = slamc3_(&one, &small);
	slamc4_(&ngpmin, &one, &lbeta);
	r__1 = -(double)one;
	slamc4_(&ngnmin, &r__1, &lbeta);
	slamc4_(&gpmin, &a, &lbeta);
	r__1 = -(double)a;
	slamc4_(&gnmin, &r__1, &lbeta);
	ieee = FALSE_;

	if (ngpmin == ngnmin && gpmin == gnmin) {
	    if (ngpmin == gpmin) {
		lemin = ngpmin;
/*            ( Non twos-complement machines, no gradual under
flow;   
                e.g.,  VAX ) */
	    } else if (gpmin - ngpmin == 3) {
		lemin = ngpmin - 1 + lt;
		ieee = TRUE_;
/*            ( Non twos-complement machines, with gradual und
erflow;   
                e.g., IEEE standard followers ) */
	    } else {
		lemin = min(ngpmin,gpmin);
/*            ( A guess; no known machine ) */
		iwarn = TRUE_;
	    }

	} else if (ngpmin == gpmin && ngnmin == gnmin) {
	    if ((i__1 = ngpmin - ngnmin, abs(i__1)) == 1) {
		lemin = max(ngpmin,ngnmin);
/*            ( Twos-complement machines, no gradual underflow
;   
                e.g., CYBER 205 ) */
	    } else {
		lemin = min(ngpmin,ngnmin);
/*            ( A guess; no known machine ) */
		iwarn = TRUE_;
	    }

	} else if ((i__1 = ngpmin - ngnmin, abs(i__1)) == 1 && gpmin == gnmin)
		 {
	    if (gpmin - min(ngpmin,ngnmin) == 3) {
		lemin = max(ngpmin,ngnmin) - 1 + lt;
/*            ( Twos-complement machines with gradual underflo
w;   
                no known machine ) */
	    } else {
		lemin = min(ngpmin,ngnmin);
/*            ( A guess; no known machine ) */
		iwarn = TRUE_;
	    }

	} else {
/* Computing MIN */
	    i__1 = min(ngpmin,ngnmin), i__1 = min(i__1,gpmin);
	    lemin = min(i__1,gnmin);
/*         ( A guess; no known machine ) */
	    iwarn = TRUE_;
	}
/* **   
   Comment out this if block if EMIN is ok */
	if (iwarn) {
	    first = TRUE_;
	    printf("\n\n WARNING. The value EMIN may be incorrect:- ");
	    printf("EMIN = %8i\n",lemin);
	    printf("If, after inspection, the value EMIN looks acceptable");
            printf("please comment out \n the IF block as marked within the"); 
            printf("code of routine SLAMC2, \n otherwise supply EMIN"); 
            printf("explicitly.\n");
	}
/* **   

          Assume IEEE arithmetic if we found denormalised  numbers abo
ve,   
          or if arithmetic seems to round in the  IEEE style,  determi
ned   
          in routine SLAMC1. A true IEEE machine should have both  thi
ngs   
          true; however, faulty machines may have one or the other. */

	ieee = ieee || lieee1;

/*        Compute  RMIN by successive division by  BETA. We could comp
ute   
          RMIN as BASE**( EMIN - 1 ),  but some machines underflow dur
ing   
          this computation. */

	lrmin = 1.f;
	i__1 = 1 - lemin;
	for (i = 1; i <= 1-lemin; ++i) {
	    r__1 = lrmin * rbase;
	    lrmin = slamc3_(&r__1, &zero);
/* L30: */
	}

/*        Finally, call SLAMC5 to compute EMAX and RMAX. */

	slamc5_(&lbeta, &lt, &lemin, &ieee, &lemax, &lrmax);
    }

    *beta = lbeta;
    *t = lt;
    *rnd = lrnd;
    *eps = leps;
    *emin = lemin;
    *rmin = lrmin;
    *emax = lemax;
    *rmax = lrmax;

    return 0;


/*     End of SLAMC2 */

} /* slamc2_ */
示例#26
0
/* DECK CTRSL */
/* Subroutine */ int ctrsl_(complex *t, integer *ldt, integer *n, complex *b, 
	integer *job, integer *info)
{
    /* System generated locals */
    integer t_dim1, t_offset, i__1, i__2, i__3, i__4;
    real r__1, r__2;
    complex q__1, q__2;

    /* Local variables */
    static integer j, jj, case__;
    static complex temp;
    extern /* Complex */ void cdotc_(complex *, integer *, complex *, integer 
	    *, complex *, integer *);
    extern /* Subroutine */ int caxpy_(integer *, complex *, complex *, 
	    integer *, complex *, integer *);

/* ***BEGIN PROLOGUE  CTRSL */
/* ***PURPOSE  Solve a system of the form  T*X=B or CTRANS(T)*X=B, where */
/*            T is a triangular matrix.  Here CTRANS(T) is the conjugate */
/*            transpose. */
/* ***LIBRARY   SLATEC (LINPACK) */
/* ***CATEGORY  D2C3 */
/* ***TYPE      COMPLEX (STRSL-S, DTRSL-D, CTRSL-C) */
/* ***KEYWORDS  LINEAR ALGEBRA, LINPACK, TRIANGULAR LINEAR SYSTEM, */
/*             TRIANGULAR MATRIX */
/* ***AUTHOR  Stewart, G. W., (U. of Maryland) */
/* ***DESCRIPTION */

/*     CTRSL solves systems of the form */

/*                   T * X = B */
/*     or */
/*                   CTRANS(T) * X = B */

/*     where T is a triangular matrix of order N.  Here CTRANS(T) */
/*     denotes the conjugate transpose of the matrix T. */

/*     On Entry */

/*         T         COMPLEX(LDT,N) */
/*                   T contains the matrix of the system.  The zero */
/*                   elements of the matrix are not referenced, and */
/*                   the corresponding elements of the array can be */
/*                   used to store other information. */

/*         LDT       INTEGER */
/*                   LDT is the leading dimension of the array T. */

/*         N         INTEGER */
/*                   N is the order of the system. */

/*         B         COMPLEX(N). */
/*                   B contains the right hand side of the system. */

/*         JOB       INTEGER */
/*                   JOB specifies what kind of system is to be solved. */
/*                   If JOB is */

/*                        00   solve T*X = B, T lower triangular, */
/*                        01   solve T*X = B, T upper triangular, */
/*                        10   solve CTRANS(T)*X = B, T lower triangular, */
/*                        11   solve CTRANS(T)*X = B, T upper triangular. */

/*     On Return */

/*         B         B contains the solution, if INFO .EQ. 0. */
/*                   Otherwise B is unaltered. */

/*         INFO      INTEGER */
/*                   INFO contains zero if the system is nonsingular. */
/*                   Otherwise INFO contains the index of */
/*                   the first zero diagonal element of T. */

/* ***REFERENCES  J. J. Dongarra, J. R. Bunch, C. B. Moler, and G. W. */
/*                 Stewart, LINPACK Users' Guide, SIAM, 1979. */
/* ***ROUTINES CALLED  CAXPY, CDOTC */
/* ***REVISION HISTORY  (YYMMDD) */
/*   780814  DATE WRITTEN */
/*   890831  Modified array declarations.  (WRB) */
/*   890831  REVISION DATE from Version 3.2 */
/*   891214  Prologue converted to Version 4.0 format.  (BAB) */
/*   900326  Removed duplicate information from DESCRIPTION section. */
/*           (WRB) */
/*   920501  Reformatted the REFERENCES section.  (WRB) */
/* ***END PROLOGUE  CTRSL */


/* ***FIRST EXECUTABLE STATEMENT  CTRSL */

/*        CHECK FOR ZERO DIAGONAL ELEMENTS. */

    /* Parameter adjustments */
    t_dim1 = *ldt;
    t_offset = 1 + t_dim1;
    t -= t_offset;
    --b;

    /* Function Body */
    i__1 = *n;
    for (*info = 1; *info <= i__1; ++(*info)) {
	i__2 = *info + *info * t_dim1;
	if ((r__1 = t[i__2].r, dabs(r__1)) + (r__2 = r_imag(&t[*info + *info *
		 t_dim1]), dabs(r__2)) == 0.f) {
	    goto L150;
	}
/* L10: */
    }
    *info = 0;

/*        DETERMINE THE TASK AND GO TO IT. */

    case__ = 1;
    if (*job % 10 != 0) {
	case__ = 2;
    }
    if (*job % 100 / 10 != 0) {
	case__ += 2;
    }
    switch (case__) {
	case 1:  goto L20;
	case 2:  goto L50;
	case 3:  goto L80;
	case 4:  goto L110;
    }

/*        SOLVE T*X=B FOR T LOWER TRIANGULAR */

L20:
    c_div(&q__1, &b[1], &t[t_dim1 + 1]);
    b[1].r = q__1.r, b[1].i = q__1.i;
    if (*n < 2) {
	goto L40;
    }
    i__1 = *n;
    for (j = 2; j <= i__1; ++j) {
	i__2 = j - 1;
	q__1.r = -b[i__2].r, q__1.i = -b[i__2].i;
	temp.r = q__1.r, temp.i = q__1.i;
	i__2 = *n - j + 1;
	caxpy_(&i__2, &temp, &t[j + (j - 1) * t_dim1], &c__1, &b[j], &c__1);
	i__2 = j;
	c_div(&q__1, &b[j], &t[j + j * t_dim1]);
	b[i__2].r = q__1.r, b[i__2].i = q__1.i;
/* L30: */
    }
L40:
    goto L140;

/*        SOLVE T*X=B FOR T UPPER TRIANGULAR. */

L50:
    i__1 = *n;
    c_div(&q__1, &b[*n], &t[*n + *n * t_dim1]);
    b[i__1].r = q__1.r, b[i__1].i = q__1.i;
    if (*n < 2) {
	goto L70;
    }
    i__1 = *n;
    for (jj = 2; jj <= i__1; ++jj) {
	j = *n - jj + 1;
	i__2 = j + 1;
	q__1.r = -b[i__2].r, q__1.i = -b[i__2].i;
	temp.r = q__1.r, temp.i = q__1.i;
	caxpy_(&j, &temp, &t[(j + 1) * t_dim1 + 1], &c__1, &b[1], &c__1);
	i__2 = j;
	c_div(&q__1, &b[j], &t[j + j * t_dim1]);
	b[i__2].r = q__1.r, b[i__2].i = q__1.i;
/* L60: */
    }
L70:
    goto L140;

/*        SOLVE CTRANS(T)*X=B FOR T LOWER TRIANGULAR. */

L80:
    i__1 = *n;
    r_cnjg(&q__2, &t[*n + *n * t_dim1]);
    c_div(&q__1, &b[*n], &q__2);
    b[i__1].r = q__1.r, b[i__1].i = q__1.i;
    if (*n < 2) {
	goto L100;
    }
    i__1 = *n;
    for (jj = 2; jj <= i__1; ++jj) {
	j = *n - jj + 1;
	i__2 = j;
	i__3 = j;
	i__4 = jj - 1;
	cdotc_(&q__2, &i__4, &t[j + 1 + j * t_dim1], &c__1, &b[j + 1], &c__1);
	q__1.r = b[i__3].r - q__2.r, q__1.i = b[i__3].i - q__2.i;
	b[i__2].r = q__1.r, b[i__2].i = q__1.i;
	i__2 = j;
	r_cnjg(&q__2, &t[j + j * t_dim1]);
	c_div(&q__1, &b[j], &q__2);
	b[i__2].r = q__1.r, b[i__2].i = q__1.i;
/* L90: */
    }
L100:
    goto L140;

/*        SOLVE CTRANS(T)*X=B FOR T UPPER TRIANGULAR. */

L110:
    r_cnjg(&q__2, &t[t_dim1 + 1]);
    c_div(&q__1, &b[1], &q__2);
    b[1].r = q__1.r, b[1].i = q__1.i;
    if (*n < 2) {
	goto L130;
    }
    i__1 = *n;
    for (j = 2; j <= i__1; ++j) {
	i__2 = j;
	i__3 = j;
	i__4 = j - 1;
	cdotc_(&q__2, &i__4, &t[j * t_dim1 + 1], &c__1, &b[1], &c__1);
	q__1.r = b[i__3].r - q__2.r, q__1.i = b[i__3].i - q__2.i;
	b[i__2].r = q__1.r, b[i__2].i = q__1.i;
	i__2 = j;
	r_cnjg(&q__2, &t[j + j * t_dim1]);
	c_div(&q__1, &b[j], &q__2);
	b[i__2].r = q__1.r, b[i__2].i = q__1.i;
/* L120: */
    }
L130:
L140:
L150:
    return 0;
} /* ctrsl_ */
示例#27
0
文件: cpsi.c 项目: Rufflewind/cslatec
/* DECK CPSI */
/* Complex */ void cpsi_(complex * ret_val, complex *zin)
{
    /* Initialized data */

    static real bern[13] = { .083333333333333333f,-.0083333333333333333f,
	    .0039682539682539683f,-.0041666666666666667f,
	    .0075757575757575758f,-.021092796092796093f,.083333333333333333f,
	    -.44325980392156863f,3.0539543302701197f,-26.456212121212121f,
	    281.46014492753623f,-3454.8853937728938f,54827.583333333333f };
    static real pi = 3.141592653589793f;
    static logical first = TRUE_;

    /* System generated locals */
    integer i__1, i__2;
    real r__1, r__2;
    doublereal d__1, d__2;
    complex q__1, q__2, q__3, q__4, q__5, q__6;

    /* Local variables */
    static integer i__, n;
    static real x, y;
    static complex z__;
    static integer ndx;
    static real rbig;
    extern /* Complex */ void ccot_(complex *, complex *);
    static complex corr;
    static real rmin;
    static complex z2inv;
    static real cabsz, bound, dxrel;
    static integer nterm;
    extern doublereal r1mach_(integer *);
    extern /* Subroutine */ int xermsg_(char *, char *, char *, integer *, 
	    integer *, ftnlen, ftnlen, ftnlen);

/* ***BEGIN PROLOGUE  CPSI */
/* ***PURPOSE  Compute the Psi (or Digamma) function. */
/* ***LIBRARY   SLATEC (FNLIB) */
/* ***CATEGORY  C7C */
/* ***TYPE      COMPLEX (PSI-S, DPSI-D, CPSI-C) */
/* ***KEYWORDS  DIGAMMA FUNCTION, FNLIB, PSI FUNCTION, SPECIAL FUNCTIONS */
/* ***AUTHOR  Fullerton, W., (LANL) */
/* ***DESCRIPTION */

/* PSI(X) calculates the psi (or digamma) function of X.  PSI(X) */
/* is the logarithmic derivative of the gamma function of X. */

/* ***REFERENCES  (NONE) */
/* ***ROUTINES CALLED  CCOT, R1MACH, XERMSG */
/* ***REVISION HISTORY  (YYMMDD) */
/*   780501  DATE WRITTEN */
/*   890531  Changed all specific intrinsics to generic.  (WRB) */
/*   890531  REVISION DATE from Version 3.2 */
/*   891214  Prologue converted to Version 4.0 format.  (BAB) */
/*   900315  CALLs to XERROR changed to CALLs to XERMSG.  (THJ) */
/*   900727  Added EXTERNAL statement.  (WRB) */
/* ***END PROLOGUE  CPSI */
/* ***FIRST EXECUTABLE STATEMENT  CPSI */
    if (first) {
	nterm = log(r1mach_(&c__3)) * -.3f;
/* MAYBE BOUND = N*(0.1*EPS)**(-1/(2*N-1)) / (PI*EXP(1)) */
	d__1 = (doublereal) (r1mach_(&c__3) * .1f);
	d__2 = (doublereal) (-1.f / ((nterm << 1) - 1));
	bound = nterm * .1171f * pow_dd(&d__1, &d__2);
	dxrel = sqrt(r1mach_(&c__4));
/* Computing MAX */
	r__1 = log(r1mach_(&c__1)), r__2 = -log(r1mach_(&c__2));
	rmin = exp(dmax(r__1,r__2) + .011f);
	rbig = 1.f / r1mach_(&c__3);
    }
    first = FALSE_;

    z__.r = zin->r, z__.i = zin->i;
    x = z__.r;
    y = r_imag(&z__);
    if (y < 0.f) {
	r_cnjg(&q__1, &z__);
	z__.r = q__1.r, z__.i = q__1.i;
    }

    corr.r = 0.f, corr.i = 0.f;
    cabsz = c_abs(&z__);
    if (x >= 0.f && cabsz > bound) {
	goto L50;
    }
    if (x < 0.f && dabs(y) > bound) {
	goto L50;
    }

    if (cabsz < bound) {
	goto L20;
    }

/* USE THE REFLECTION FORMULA FOR REAL(Z) NEGATIVE, ABS(Z) LARGE, AND */
/* ABS(AIMAG(Y)) SMALL. */

    r__1 = -pi;
    q__3.r = pi * z__.r, q__3.i = pi * z__.i;
    ccot_(&q__2, &q__3);
    q__1.r = r__1 * q__2.r, q__1.i = r__1 * q__2.i;
    corr.r = q__1.r, corr.i = q__1.i;
    q__1.r = 1.f - z__.r, q__1.i = -z__.i;
    z__.r = q__1.r, z__.i = q__1.i;
    goto L50;

/* USE THE RECURSION RELATION FOR ABS(Z) SMALL. */

L20:
    if (cabsz < rmin) {
	xermsg_("SLATEC", "CPSI", "CPSI CALLED WITH Z SO NEAR 0 THAT CPSI OV"
		"ERFLOWS", &c__2, &c__2, (ftnlen)6, (ftnlen)4, (ftnlen)48);
    }

    if (x >= -.5f || dabs(y) > dxrel) {
	goto L30;
    }
    r__2 = x - .5f;
    r__1 = r_int(&r__2);
    q__2.r = z__.r - r__1, q__2.i = z__.i;
    q__1.r = q__2.r / x, q__1.i = q__2.i / x;
    if (c_abs(&q__1) < dxrel) {
	xermsg_("SLATEC", "CPSI", "ANSWER LT HALF PRECISION BECAUSE Z TOO NE"
		"AR NEGATIVE INTEGER", &c__1, &c__1, (ftnlen)6, (ftnlen)4, (
		ftnlen)60);
    }
    if (y == 0.f && x == r_int(&x)) {
	xermsg_("SLATEC", "CPSI", "Z IS A NEGATIVE INTEGER", &c__3, &c__2, (
		ftnlen)6, (ftnlen)4, (ftnlen)23);
    }

L30:
/* Computing 2nd power */
    r__1 = bound;
/* Computing 2nd power */
    r__2 = y;
    n = sqrt(r__1 * r__1 - r__2 * r__2) - x + 1.f;
    i__1 = n;
    for (i__ = 1; i__ <= i__1; ++i__) {
	c_div(&q__2, &c_b28, &z__);
	q__1.r = corr.r - q__2.r, q__1.i = corr.i - q__2.i;
	corr.r = q__1.r, corr.i = q__1.i;
	q__1.r = z__.r + 1.f, q__1.i = z__.i;
	z__.r = q__1.r, z__.i = q__1.i;
/* L40: */
    }

/* NOW EVALUATE THE ASYMPTOTIC SERIES FOR SUITABLY LARGE Z. */

L50:
    if (cabsz > rbig) {
	c_log(&q__2, &z__);
	q__1.r = q__2.r + corr.r, q__1.i = q__2.i + corr.i;
	 ret_val->r = q__1.r,  ret_val->i = q__1.i;
    }
    if (cabsz > rbig) {
	goto L70;
    }

     ret_val->r = 0.f,  ret_val->i = 0.f;
    pow_ci(&q__2, &z__, &c__2);
    c_div(&q__1, &c_b28, &q__2);
    z2inv.r = q__1.r, z2inv.i = q__1.i;
    i__1 = nterm;
    for (i__ = 1; i__ <= i__1; ++i__) {
	ndx = nterm + 1 - i__;
	i__2 = ndx - 1;
	q__2.r = z2inv.r *  ret_val->r - z2inv.i *  ret_val->i, q__2.i = 
		z2inv.r *  ret_val->i + z2inv.i *  ret_val->r;
	q__1.r = bern[i__2] + q__2.r, q__1.i = q__2.i;
	 ret_val->r = q__1.r,  ret_val->i = q__1.i;
/* L60: */
    }
    c_log(&q__4, &z__);
    c_div(&q__5, &c_b34, &z__);
    q__3.r = q__4.r - q__5.r, q__3.i = q__4.i - q__5.i;
    q__6.r =  ret_val->r * z2inv.r -  ret_val->i * z2inv.i, q__6.i =  
	    ret_val->r * z2inv.i +  ret_val->i * z2inv.r;
    q__2.r = q__3.r - q__6.r, q__2.i = q__3.i - q__6.i;
    q__1.r = q__2.r + corr.r, q__1.i = q__2.i + corr.i;
     ret_val->r = q__1.r,  ret_val->i = q__1.i;

L70:
    if (y < 0.f) {
	r_cnjg(&q__1,  ret_val);
	 ret_val->r = q__1.r,  ret_val->i = q__1.i;
    }

    return ;
} /* cpsi_ */
示例#28
0
/* 1992-1993: TC93 version */
/* Subroutine */ int dmdsm_(real *l, real *b, integer *ndir, real *dmpsr, 
	real *dist, char *limit, real *sm, real *smtau, real *smtheta, real *
	smiso, ftnlen limit_len)
{
    /* Initialized data */

    static real r0 = 8.5f;
    static real rrmax = 50.f;
    static real zmax = 25.f;
    static real dmax__ = 50.f;
    static logical first = TRUE_;

    /* System generated locals */
    real r__1, r__2, r__3;
    doublereal d__1;

    /* Builtin functions */
    double sin(doublereal), cos(doublereal), sqrt(doublereal), pow_dd(
	    doublereal *, doublereal *);
    /* Subroutine */ int s_stop(char *, ftnlen);

    /* Local variables */
    static real lhb_path__, lhb_dist__, lsb_path__, ldr_path__, dstep_pc__;
    static integer whicharm;
    static real lsb_dist__, ldr_dist__;
    static integer hitclump;
    static real d__;
    static integer i__;
    static real r__, x, y, z__, cb, dd, cl, dm, ne, sb, sl, rr;
    extern /* Subroutine */ int density_2001__(real *, real *, real *, real *,
	     real *, real *, real *, real *, real *, real *, real *, real *, 
	    real *, real *, real *, real *, real *, integer *, integer *, 
	    integer *, integer *, integer *, integer *, integer *, integer *, 
	    integer *);
    static real dm1, dm2, ne1, ne2, loopi_path__, sm1, sm2, loopi_dist__, fgc,
	     dma, nea, fcn, sma, fvn, dsm1, dsm2, dmgc, negc, dmcn, necn, 
	    dsma, smgc;
    static integer wlhb;
    static real smcn, dmvn, sm_sum1_last__;
    static integer wlsb, wldr;
    static real nevn, sm_sum2_last__, sm_sum3_last__, sm_sum4_last__, smvn, 
	    f1val, f2val, faval, dsmgc, dsmcn, flism, dstep, dtest;
    static integer wvoid, wlism, wtemp, nstep;
    static real dsmvn, dmlism, nelism, dmstep, smlism;
    static integer ncount, wloopi, wtotal;
    static real sm_sum1__, sm_sum2__, sm_sum3__, sm_sum4__;
    static integer hitvoid;
    static real sm_term__, dsmlism;

/*  Computes pulsar distance and scattering measure */
/*  from model of Galactic electron distribution. */
/*  Input: real l	galactic longitude in radians */
/*         real b	galactic latitude in radians */
/*         integer ndir  >= 0 calculates dist from dmpsr */
/*                       < 0 for dmpsr from dist */
/* Input or output: */
/* 	  real dmpsr	(dispersion measure in pc/cm^3) */
/*         real dist	(distance in kpc) */
/*  Output: */
/* 	  char*1 limit	(set to '>' if only a lower distance limit can be */
/* 			 given; otherwise set to ' ') */
/*         sm            (scattering measure, uniform weighting) (kpc/m^{20/3}) */
/*         smtau         (scattering measure, weighting for pulse broadening) */
/*         smtheta       (scattering measure, weighting for angular broadening */
/*                        of galactic sources) */
/* 	  smiso 	(scattering measure appropriate for calculating the */
/* 			isoplanatic angle at the source's location' */
/*       parameter(alpha = 11./3.) */
/*       parameter(pi = 3.14159) */
/*       parameter(c_sm = (alpha - 3.) / 2. * (2.*pi)**(4.-alpha) ) */
/* constant in sm definition */
/* units conversion for sm */
/* parameters of large-scale components (inner+outer+arm components): */
/* factors for controlling individual spiral arms: */
/*       narm:   multiplies electron density (in addition to the`fac'' */
/*                     quantities) */
/*       warm:   arm width factors that multiply nominal arm width */
/*       harm:   arm scale height factors */
/*       farm:   factors that multiply n_e^2 when calculating SM */
/* Large scale components: */
/* Galactic center: */
/* LISM: */
/* clumps: */
/* voids: */
/* subroutines needed: */
/* 	density_2001 (and those that it calls) in density.NE2001.f */
/*       scattering routines in scattering98.f */
/* other variables */
/* 	data rrmax/30.0/		! Max radius for reliable ne */
/* 	data zmax/1.76/			! Max |z| */
/* 	data zmax/5.00/			! Max |z| */
/* Max radius for reliable ne */
/* Max |z| */
/* 	logical first */
/* maximum distance calculated */
/* other variables */
/* 	real x, y, z, r, rr */
/* 	real sl, cl, sb, cb */

/* 	real d, dstep, dtest, dstep_pc, dd */

/* 	real dm, dmstep */
/* 	real sm_sum1, sm_sum2, sm_sum3, sm_sum4, sm_term */
/*       real sm_sum1_last, sm_sum2_last, sm_sum3_last, sm_sum4_last */
/* 	integer nstep */
/* 	integer ncount */
/* 	integer i */
/* 	real dm1, dm2, dma, dmgc, dmlism, dmcN, dmvN */
/* 	real sm1, sm2, sma, smgc, smlism, smcN, smvN */
/* 	real dsm1, dsm2, dsma, dsmgc, dsmlism, dsmcN, dsmvN */
/* 	integer wtotal */
/* 	real ne */
/* 	open(24,file='fort.24', status='unknown') */
/* 	open(25,file='fort.25', status='unknown') */
/* 	write(25,*) l*180./acos(-1.), b*180./acos(-1.), ' = l, b' */
/*        write(25,1000) */
/* L1000: */
    if (first) {
/* initial call to density routine to set variable values */
/* through read-in of parameter file: */
	x = 0.f;
	y = r0;
	z__ = 0.f;
	density_2001__(&x, &y, &z__, &ne1, &ne2, &nea, &negc, &nelism, &necn, 
		&nevn, &f1val, &f2val, &faval, &fgc, &flism, &fcn, &fvn, &
		whicharm, &wlism, &wldr, &wlhb, &wlsb, &wloopi, &hitclump, &
		hitvoid, &wvoid);
/*       write(6,*) 'ne1,ne2,negc,nelism,necN,nevN = ', */
/*    .              ne1,ne2,negc,nelism,necN,nevN */
	first = FALSE_;
    }
    sl = sin(*l);
    cl = cos(*l);
    sb = sin(*b);
    cb = cos(*b);
    *(unsigned char *)limit = ' ';
/* 	dstep=0.02			! Step size in kpc */
/*       dstep = min(h1, h2) / 10.       ! step size in terms of scale heights */
    dstep = .01f;
    if (*ndir < 0) {
	dtest = *dist;
    }
    if (*ndir >= 0) {
	dtest = *dmpsr / (galparams_1.n1h1 / galparams_1.h1);
    }
/* approximate test distanc */
    nstep = dtest / dstep;
/* approximate number of steps */
    if (nstep < 10) {
	dstep = dtest / 10;
    }
/*  Sum until dm is reached (ndir >= 0) or dist is reached (ndir < 0). */
/*  Guard against too few terms by counting number of terms (ncount) so that */
/*  routine will work for n_e models with large n_e near the Sun. */
/* make # steps >= 10 */
L5:
    dstep_pc__ = dstep * 1e3f;
    dm = 0.f;
    sm_sum1__ = 0.f;
/* sum of C_n^2 */
    sm_sum2__ = 0.f;
/* sum of C_n^2 * s */
    sm_sum3__ = 0.f;
/* sum of C_n^2 * s^2 */
    sm_sum4__ = 0.f;
/* sum of C_n^2 * s^{5./3.} */
    for (i__ = 1; i__ <= 6; ++i__) {
	armpathlengths_1.armpaths[i__ - 1] = 0.f;
	armpathlengths_1.armdistances[i__ - 1] = 0.f;
    }
    dm1 = 0.f;
    dm2 = 0.f;
    dma = 0.f;
    dmgc = 0.f;
    dmlism = 0.f;
    dmcn = 0.f;
    dmvn = 0.f;
    sm1 = 0.f;
    sm2 = 0.f;
    sma = 0.f;
    smgc = 0.f;
    smlism = 0.f;
    smcn = 0.f;
    smvn = 0.f;
    ldr_path__ = 0.f;
    lhb_path__ = 0.f;
    lsb_path__ = 0.f;
    loopi_path__ = 0.f;
    ldr_dist__ = 0.f;
    lhb_dist__ = 0.f;
    lsb_dist__ = 0.f;
    loopi_dist__ = 0.f;
    ncount = 0;
    d__ = dstep * -.5f;
    for (i__ = 1; i__ <= 99999; ++i__) {
	++ncount;
	d__ += dstep;
/* Distance from Sun in kpc */
	r__ = d__ * cb;
	x = r__ * sl;
	y = r0 - r__ * cl;
	z__ = d__ * sb;
/* Computing 2nd power */
	r__1 = x;
/* Computing 2nd power */
	r__2 = y;
	rr = sqrt(r__1 * r__1 + r__2 * r__2);
/* Galactocentric radius */
	if (*ndir >= 0 && (d__ > dmax__ || dabs(z__) > zmax || rr > rrmax)) {
	    goto L20;
	}
	if (*ndir < 3) {
	    density_2001__(&x, &y, &z__, &ne1, &ne2, &nea, &negc, &nelism, &
		    necn, &nevn, &f1val, &f2val, &faval, &fgc, &flism, &fcn, &
		    fvn, &whicharm, &wlism, &wldr, &wlhb, &wlsb, &wloopi, &
		    hitclump, &hitvoid, &wvoid);
	}
	if (*ndir >= 3) {
	    r__1 = x + dxyz_1.dx0;
	    r__2 = y + dxyz_1.dy0;
	    r__3 = z__ + dxyz_1.dz0;
	    density_2001__(&r__1, &r__2, &r__3, &ne1, &ne2, &nea, &negc, &
		    nelism, &necn, &nevn, &f1val, &f2val, &faval, &fgc, &
		    flism, &fcn, &fvn, &whicharm, &wlism, &wldr, &wlhb, &wlsb,
		     &wloopi, &hitclump, &hitvoid, &wvoid);
	}
/* wlism = 1 causes the lism component to override smooth Galactic components */
/* wvoid = 1 overrides everything except clumps */
	ne = (1.f - modelflags_1.wglism * wlism) * (modelflags_1.wg1 * ne1 + 
		modelflags_1.wg2 * ne2 + modelflags_1.wga * nea + 
		modelflags_1.wggc * negc) + modelflags_1.wglism * wlism * 
		nelism;
	ne = (1 - modelflags_1.wgvn * wvoid) * ne + modelflags_1.wgvn * wvoid 
		* nevn + modelflags_1.wgcn * necn;
	dmstep = dstep_pc__ * ne;
	dm += dmstep;
/* Add DM for this step */
	wtotal = (1 - modelflags_1.wgvn * wvoid) * (1 - modelflags_1.wglism * 
		wlism);
	dm1 += wtotal * modelflags_1.wg1 * ne1;
	dm2 += wtotal * modelflags_1.wg2 * ne2;
	dma += wtotal * modelflags_1.wga * nea;
	dmgc += wtotal * modelflags_1.wggc * negc;
	dmlism += (1.f - modelflags_1.wgvn * wvoid) * modelflags_1.wglism * 
		wlism * nelism;
	dmcn += modelflags_1.wgcn * necn;
	dmvn += modelflags_1.wgvn * wvoid * nevn;
/*         write(24,"('n:',7f10.6,1x))") */
/*    .        ne1,ne2,nea,negc,nelism,necN,nevN */
/*        write(24,"(i2,1x,7(f10.5,1x))") */
/*    .      wtotal,dm1,dm2,dma,dmgc,dmlism,dmcN,dmvN */
/*         sm_term = */
/*    .       (1.-wglism*wlism)* */
/*    .       (wg1   * F1  * ne1**2 + */
/*    .        wg2   * F2  * ne2**2 + */
/*    .        wga   * Fa  * nea**2 + */
/*    .        wggc  * Fgc * negc**2) + */
/*    .        wglism*wlism * Flism * nelism**2 */
/* 	  sm_clumps = FcN * necN**2 */
/* 	  sm_voids  = FvN * nevN**2 */
/*         sm_term = (1-wgvN*wvoid) * sm_term */
/*    .            + wgvN * wvoid * sm_voids */
/*    .            + wgcN * sm_clumps */
/* Computing 2nd power */
	r__1 = ne1;
	dsm1 = wtotal * modelflags_1.wg1 * (r__1 * r__1) * galparams_1.f1;
/* Computing 2nd power */
	r__1 = ne2;
	dsm2 = wtotal * modelflags_1.wg2 * (r__1 * r__1) * galparams_1.f2;
/* Computing 2nd power */
	r__1 = nea;
	dsma = wtotal * modelflags_1.wga * (r__1 * r__1) * galparams_1.fa;
/* Computing 2nd power */
	r__1 = negc;
	dsmgc = wtotal * modelflags_1.wggc * (r__1 * r__1) * fgc;
/* Computing 2nd power */
	r__1 = nelism;
	dsmlism = (1.f - modelflags_1.wgvn * wvoid) * modelflags_1.wglism * 
		wlism * (r__1 * r__1) * flism;
/* Computing 2nd power */
	r__1 = necn;
	dsmcn = modelflags_1.wgcn * (r__1 * r__1) * fcn;
/* Computing 2nd power */
	r__1 = nevn;
	dsmvn = modelflags_1.wgvn * wvoid * (r__1 * r__1) * fvn;
	sm_term__ = dsm1 + dsm2 + dsma + dsmgc + dsmlism + dsmcn + dsmvn;
	sm1 += dsm1;
	sm2 += dsm2;
	sma += dsma;
	smgc += dsmgc;
	smlism += dsmlism;
	smcn += dsmcn;
	smvn += dsmvn;
	sm_sum1__ += sm_term__;
	sm_sum2__ += sm_term__ * d__;
/* Computing 2nd power */
	r__1 = d__;
	sm_sum3__ += sm_term__ * (r__1 * r__1);
	d__1 = (doublereal) d__;
	sm_sum4__ += sm_term__ * pow_dd(&d__1, &c_b8);
/* pathlengths through LISM components: */
/* take into account the weighting hierarchy, LHB:LOOPI:LSB:LDR */
	if (wlism == 1) {
	    if (wlhb == 1) {
		lhb_path__ += dstep;
		lhb_dist__ += d__;
	    }
	    if (wloopi == 1) {
		wtemp = 1 - wlhb;
		loopi_path__ += wtemp * dstep;
		loopi_dist__ += wtemp * d__;
	    }
	    if (wlsb == 1) {
		wtemp = (1 - wlhb) * (1 - wloopi);
		lsb_path__ += wtemp * dstep;
		lsb_dist__ += wtemp * d__;
	    }
	    if (wldr == 1) {
		wtemp = (1 - wlhb) * (1 - wloopi) * (1 - wlsb);
		ldr_path__ += wtemp * dstep;
		ldr_dist__ += wtemp * d__;
	    }
	}
/* pathlengths: whicharm = 0,5 (currently). */
/* 	                  1,4 for the equivalent of the TC93 arms */
/*                         5   for the local arm */
/*                         0   means interarm paths */
	armpathlengths_1.armpaths[whicharm] += dstep;
	armpathlengths_1.armdistances[whicharm] += d__;
/*       write(99,"(2(f8.3,1x), 7f10.6)") */
/*    .     d, dm, sm_term,  sm_sum1, sm_sum2, sm_sum3, */
/*    .     sm_sum1_last, sm_sum2_last, sm_sum3_last */
	if (*ndir >= 0 && dm >= *dmpsr) {
	    goto L30;
	}
/* Reached pulsar's DM? */
	if (*ndir < 0 && d__ >= *dist) {
	    goto L40;
	}
/* Reached pulsar's dist? */
	sm_sum1_last__ = sm_sum1__;
	sm_sum2_last__ = sm_sum2__;
	sm_sum3_last__ = sm_sum3__;
	sm_sum4_last__ = sm_sum4__;
/*        write(25, */
/*     .     "(4(f7.3,1x),f8.4,1x,e10.3,1x,i1,1x,i4,1x,i2)") */
/*     .     d,x,y,z,ne,sm_term,whicharm,hitclump,hitvoid */
/* L10: */
    }
    s_stop("loop limit", (ftnlen)10);
L20:
    *(unsigned char *)limit = '>';
/* Only lower limit is possible */
    *dist = d__ - dstep * .5f;
    goto L999;
L30:
    *dist = d__ + dstep * .5f - dstep * (dm - *dmpsr) / dmstep;
/* Interpolate last step */
    if (ncount < 10) {
	dstep /= 10.f;
	goto L5;
    }
    goto L999;
L40:
    *dmpsr = dm - dmstep * (d__ + dstep * .5f - *dist) / dstep;
    if (ncount < 10) {
	dstep /= 10.f;
	goto L5;
    }
L999:
/* normalize the mean distances: */
    if (ldr_path__ > 0.f) {
	ldr_dist__ /= ldr_path__ / dstep;
    }
    if (lhb_path__ > 0.f) {
	lhb_dist__ /= lhb_path__ / dstep;
    }
    if (lsb_path__ > 0.f) {
	lsb_dist__ /= lsb_path__ / dstep;
    }
    if (loopi_path__ > 0.f) {
	loopi_dist__ /= loopi_path__ / dstep;
    }
    dd = d__ + dstep * .5f - *dist;
/* subtract dd from armpath for latest arm (or iterarm) at end of LOS */
    armpathlengths_1.armpaths[whicharm - 1] -= dd;
    for (i__ = 1; i__ <= 6; ++i__) {
/* Computing MAX */
	r__1 = 1.f, r__2 = armpathlengths_1.armpaths[i__ - 1] / dstep;
	armpathlengths_1.armdistances[i__ - 1] /= dmax(r__1,r__2);
/* mean distan */
    }
    dm1 *= dstep_pc__;
    dm2 *= dstep_pc__;
    dma *= dstep_pc__;
    dmgc *= dstep_pc__;
    dmlism *= dstep_pc__;
    dmcn *= dstep_pc__;
    dmvn *= dstep_pc__;
/*       dsm = sm_term * (d+0.5*dstep - dist) */
/*       dsm = sm_term * dd */
/*       sm_sum2 = sm_sum2 - dsm * d */
/*       sm_sum3 = sm_sum3 - dsm * d**2 */
/*       sm_sum4 = sm_sum4 - dsm * d**1.67 */
/*       sm_sum1 = sm_sum1 - dsm */
/*       write(99,*) 'dmdsm: sm_term, sm_sum1, sm_sum1_last = ', */
/*    .    sm_term, sm_sum1, sm_sum1_last */
/* 	write(6,*) 'dmdsm: dsum1, sm_term = ', */
/*    .     sm_sum1-sm_sum1_last, sm_term */
    sm_sum1__ -= dd * (sm_sum1__ - sm_sum1_last__) / dstep;
    sm_sum2__ -= dd * (sm_sum2__ - sm_sum2_last__) / dstep;
    sm_sum3__ -= dd * (sm_sum3__ - sm_sum3_last__) / dstep;
    sm_sum4__ -= dd * (sm_sum4__ - sm_sum4_last__) / dstep;
/*       sm_sum2 = sm_sum2 - dsm * dist */
/*       sm_sum3 = sm_sum3 - dsm * dist**2 */
/*       sm_sum4 = sm_sum4 - dsm * dist**1.67 */
    *sm = dstep * 1.8389599999999999f * sm_sum1__;
/* Computing 2nd power */
    r__1 = *dist;
    *smtau = dstep * 11.033759999999999f * (sm_sum2__ / *dist - sm_sum3__ / (
	    r__1 * r__1));
/* Computing 2nd power */
    r__1 = *dist;
    *smtheta = dstep * 5.5168799999999996f * (sm_sum1__ + sm_sum3__ / (r__1 * 
	    r__1) - sm_sum2__ * 2.f / *dist);
    *smiso = dstep * 1.8389599999999999f * sm_sum4__;
    sm1 = sm1 * 1.8389599999999999f * dstep;
    sm2 = sm2 * 1.8389599999999999f * dstep;
    sma = sma * 1.8389599999999999f * dstep;
    smgc = smgc * 1.8389599999999999f * dstep;
    smlism = smlism * 1.8389599999999999f * dstep;
    smcn = smcn * 1.8389599999999999f * dstep;
    smvn = smvn * 1.8389599999999999f * dstep;
/*       write(24,*) dm1, dm2, dma, dmgc, dmlism, dmcN, dmvN, dm */
/*        write(24,"(a,a)") 'LISM path lengths (kpc)', */
/*     .    ' with weighting hierarchy LHB:LOOPI:LSB:LDR' */
/*        write(24,"(t15, a)") '  LHB     LoopI     LSB      LDR' */
/* 	write(24, "(t3, a, t15, 4(f6.3, 3x))") 'Length', */
/*     .         lhb_path, loopI_path, lsb_path, ldr_path */
/* 	write(24, "(t3, a, t15, 4(f6.3, 3x))") 'Mean Dist.', */
/*     .         lhb_dist, loopI_dist, lsb_dist, ldr_dist */
/*        write(24,"(a)") 'Fractional contributions to DM:' */
/*        write(24,"(a,a)") */
/*     .  '  outer   inner    arms     gc    lism', */
/*     .  '    clumps  voids       DM' */
/*        write(24,"(7(f7.3,1x), f10.3)") */
/*     .              dm1/dm, dm2/dm, dma/dm, dmgc/dm, */
/*     .              dmlism/dm, dmcN/dm, dmvN/dm, dm */
/*        write(24,"(a)") 'Fractional contributions to SM:' */
/*        write(24,"(a,a)") */
/*     .  '  outer   inner    arms     gc    lism', */
/*     .  '    clumps  voids       SM' */
/*        write(24,"(7(f7.3,1x), e10.3)") */
/*     .              sm1/sm, sm2/sm, sma/sm, smgc/sm, */
/*     .              smlism/sm, smcN/sm, smvN/sm, sm */
/*        write(24,"(a)") 'Path lengths through spiral arms:' */
/*        write(24,"(t1,a,t10, a, t30, a)") */
/*     .      'Arm','Mean Distance','Path Length    (arm=0 => interarm)' */
/* 	do i=1,narmsmax1 */
/*          write(24,"(i2,t10,f8.3,t30,f8.3)") */
/*     .       i-1, armdistances(i), armpaths(i) */
/* 	enddo */
/* 	close(24) */
/* 	close(25) */
    return 0;
} /* dmdsm_ */
示例#29
0
/* Subroutine */ int slaebz_(integer *ijob, integer *nitmax, integer *n, 
	integer *mmax, integer *minp, integer *nbmin, real *abstol, real *
	reltol, real *pivmin, real *d__, real *e, real *e2, integer *nval, 
	real *ab, real *c__, integer *mout, integer *nab, real *work, integer 
	*iwork, integer *info)
{
    /* System generated locals */
    integer nab_dim1, nab_offset, ab_dim1, ab_offset, i__1, i__2, i__3, i__4, 
	    i__5, i__6;
    real r__1, r__2, r__3, r__4;

    /* Local variables */
    integer j, kf, ji, kl, jp, jit;
    real tmp1, tmp2;
    integer itmp1, itmp2, kfnew, klnew;


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

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

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

/*  SLAEBZ contains the iteration loops which compute and use the */
/*  function N(w), which is the count of eigenvalues of a symmetric */
/*  tridiagonal matrix T less than or equal to its argument  w.  It */
/*  performs a choice of two types of loops: */

/*  IJOB=1, followed by */
/*  IJOB=2: It takes as input a list of intervals and returns a list of */
/*          sufficiently small intervals whose union contains the same */
/*          eigenvalues as the union of the original intervals. */
/*          The input intervals are (AB(j,1),AB(j,2)], j=1,...,MINP. */
/*          The output interval (AB(j,1),AB(j,2)] will contain */
/*          eigenvalues NAB(j,1)+1,...,NAB(j,2), where 1 <= j <= MOUT. */

/*  IJOB=3: It performs a binary search in each input interval */
/*          (AB(j,1),AB(j,2)] for a point  w(j)  such that */
/*          N(w(j))=NVAL(j), and uses  C(j)  as the starting point of */
/*          the search.  If such a w(j) is found, then on output */
/*          AB(j,1)=AB(j,2)=w.  If no such w(j) is found, then on output */
/*          (AB(j,1),AB(j,2)] will be a small interval containing the */
/*          point where N(w) jumps through NVAL(j), unless that point */
/*          lies outside the initial interval. */

/*  Note that the intervals are in all cases half-open intervals, */
/*  i.e., of the form  (a,b] , which includes  b  but not  a . */

/*  To avoid underflow, the matrix should be scaled so that its largest */
/*  element is no greater than  overflow**(1/2) * underflow**(1/4) */
/*  in absolute value.  To assure the most accurate computation */
/*  of small eigenvalues, the matrix should be scaled to be */
/*  not much smaller than that, either. */

/*  See W. Kahan "Accurate Eigenvalues of a Symmetric Tridiagonal */
/*  Matrix", Report CS41, Computer Science Dept., Stanford */
/*  University, July 21, 1966 */

/*  Note: the arguments are, in general, *not* checked for unreasonable */
/*  values. */

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

/*  IJOB    (input) INTEGER */
/*          Specifies what is to be done: */
/*          = 1:  Compute NAB for the initial intervals. */
/*          = 2:  Perform bisection iteration to find eigenvalues of T. */
/*          = 3:  Perform bisection iteration to invert N(w), i.e., */
/*                to find a point which has a specified number of */
/*                eigenvalues of T to its left. */
/*          Other values will cause SLAEBZ to return with INFO=-1. */

/*  NITMAX  (input) INTEGER */
/*          The maximum number of "levels" of bisection to be */
/*          performed, i.e., an interval of width W will not be made */
/*          smaller than 2^(-NITMAX) * W.  If not all intervals */
/*          have converged after NITMAX iterations, then INFO is set */
/*          to the number of non-converged intervals. */

/*  N       (input) INTEGER */
/*          The dimension n of the tridiagonal matrix T.  It must be at */
/*          least 1. */

/*  MMAX    (input) INTEGER */
/*          The maximum number of intervals.  If more than MMAX intervals */
/*          are generated, then SLAEBZ will quit with INFO=MMAX+1. */

/*  MINP    (input) INTEGER */
/*          The initial number of intervals.  It may not be greater than */
/*          MMAX. */

/*  NBMIN   (input) INTEGER */
/*          The smallest number of intervals that should be processed */
/*          using a vector loop.  If zero, then only the scalar loop */
/*          will be used. */

/*  ABSTOL  (input) REAL */
/*          The minimum (absolute) width of an interval.  When an */
/*          interval is narrower than ABSTOL, or than RELTOL times the */
/*          larger (in magnitude) endpoint, then it is considered to be */
/*          sufficiently small, i.e., converged.  This must be at least */
/*          zero. */

/*  RELTOL  (input) REAL */
/*          The minimum relative width of an interval.  When an interval */
/*          is narrower than ABSTOL, or than RELTOL times the larger (in */
/*          magnitude) endpoint, then it is considered to be */
/*          sufficiently small, i.e., converged.  Note: this should */
/*          always be at least radix*machine epsilon. */

/*  PIVMIN  (input) REAL */
/*          The minimum absolute value of a "pivot" in the Sturm */
/*          sequence loop.  This *must* be at least  max |e(j)**2| * */
/*          safe_min  and at least safe_min, where safe_min is at least */
/*          the smallest number that can divide one without overflow. */

/*  D       (input) REAL array, dimension (N) */
/*          The diagonal elements of the tridiagonal matrix T. */

/*  E       (input) REAL array, dimension (N) */
/*          The offdiagonal elements of the tridiagonal matrix T in */
/*          positions 1 through N-1.  E(N) is arbitrary. */

/*  E2      (input) REAL array, dimension (N) */
/*          The squares of the offdiagonal elements of the tridiagonal */
/*          matrix T.  E2(N) is ignored. */

/*  NVAL    (input/output) INTEGER array, dimension (MINP) */
/*          If IJOB=1 or 2, not referenced. */
/*          If IJOB=3, the desired values of N(w).  The elements of NVAL */
/*          will be reordered to correspond with the intervals in AB. */
/*          Thus, NVAL(j) on output will not, in general be the same as */
/*          NVAL(j) on input, but it will correspond with the interval */
/*          (AB(j,1),AB(j,2)] on output. */

/*  AB      (input/output) REAL array, dimension (MMAX,2) */
/*          The endpoints of the intervals.  AB(j,1) is  a(j), the left */
/*          endpoint of the j-th interval, and AB(j,2) is b(j), the */
/*          right endpoint of the j-th interval.  The input intervals */
/*          will, in general, be modified, split, and reordered by the */
/*          calculation. */

/*  C       (input/output) REAL array, dimension (MMAX) */
/*          If IJOB=1, ignored. */
/*          If IJOB=2, workspace. */
/*          If IJOB=3, then on input C(j) should be initialized to the */
/*          first search point in the binary search. */

/*  MOUT    (output) INTEGER */
/*          If IJOB=1, the number of eigenvalues in the intervals. */
/*          If IJOB=2 or 3, the number of intervals output. */
/*          If IJOB=3, MOUT will equal MINP. */

/*  NAB     (input/output) INTEGER array, dimension (MMAX,2) */
/*          If IJOB=1, then on output NAB(i,j) will be set to N(AB(i,j)). */
/*          If IJOB=2, then on input, NAB(i,j) should be set.  It must */
/*             satisfy the condition: */
/*             N(AB(i,1)) <= NAB(i,1) <= NAB(i,2) <= N(AB(i,2)), */
/*             which means that in interval i only eigenvalues */
/*             NAB(i,1)+1,...,NAB(i,2) will be considered.  Usually, */
/*             NAB(i,j)=N(AB(i,j)), from a previous call to SLAEBZ with */
/*             IJOB=1. */
/*             On output, NAB(i,j) will contain */
/*             max(na(k),min(nb(k),N(AB(i,j)))), where k is the index of */
/*             the input interval that the output interval */
/*             (AB(j,1),AB(j,2)] came from, and na(k) and nb(k) are the */
/*             the input values of NAB(k,1) and NAB(k,2). */
/*          If IJOB=3, then on output, NAB(i,j) contains N(AB(i,j)), */
/*             unless N(w) > NVAL(i) for all search points  w , in which */
/*             case NAB(i,1) will not be modified, i.e., the output */
/*             value will be the same as the input value (modulo */
/*             reorderings -- see NVAL and AB), or unless N(w) < NVAL(i) */
/*             for all search points  w , in which case NAB(i,2) will */
/*             not be modified.  Normally, NAB should be set to some */
/*             distinctive value(s) before SLAEBZ is called. */

/*  WORK    (workspace) REAL array, dimension (MMAX) */
/*          Workspace. */

/*  IWORK   (workspace) INTEGER array, dimension (MMAX) */
/*          Workspace. */

/*  INFO    (output) INTEGER */
/*          = 0:       All intervals converged. */
/*          = 1--MMAX: The last INFO intervals did not converge. */
/*          = MMAX+1:  More than MMAX intervals were generated. */

/*  Further Details */
/*  =============== */

/*      This routine is intended to be called only by other LAPACK */
/*  routines, thus the interface is less user-friendly.  It is intended */
/*  for two purposes: */

/*  (a) finding eigenvalues.  In this case, SLAEBZ should have one or */
/*      more initial intervals set up in AB, and SLAEBZ should be called */
/*      with IJOB=1.  This sets up NAB, and also counts the eigenvalues. */
/*      Intervals with no eigenvalues would usually be thrown out at */
/*      this point.  Also, if not all the eigenvalues in an interval i */
/*      are desired, NAB(i,1) can be increased or NAB(i,2) decreased. */
/*      For example, set NAB(i,1)=NAB(i,2)-1 to get the largest */
/*      eigenvalue.  SLAEBZ is then called with IJOB=2 and MMAX */
/*      no smaller than the value of MOUT returned by the call with */
/*      IJOB=1.  After this (IJOB=2) call, eigenvalues NAB(i,1)+1 */
/*      through NAB(i,2) are approximately AB(i,1) (or AB(i,2)) to the */
/*      tolerance specified by ABSTOL and RELTOL. */

/*  (b) finding an interval (a',b'] containing eigenvalues w(f),...,w(l). */
/*      In this case, start with a Gershgorin interval  (a,b).  Set up */
/*      AB to contain 2 search intervals, both initially (a,b).  One */
/*      NVAL element should contain  f-1  and the other should contain  l */
/*      , while C should contain a and b, resp.  NAB(i,1) should be -1 */
/*      and NAB(i,2) should be N+1, to flag an error if the desired */
/*      interval does not lie in (a,b).  SLAEBZ is then called with */
/*      IJOB=3.  On exit, if w(f-1) < w(f), then one of the intervals -- */
/*      j -- will have AB(j,1)=AB(j,2) and NAB(j,1)=NAB(j,2)=f-1, while */
/*      if, to the specified tolerance, w(f-k)=...=w(f+r), k > 0 and r */
/*      >= 0, then the interval will have  N(AB(j,1))=NAB(j,1)=f-k and */
/*      N(AB(j,2))=NAB(j,2)=f+r.  The cases w(l) < w(l+1) and */
/*      w(l-r)=...=w(l+k) are handled similarly. */

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

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

/*     Check for Errors */

    /* Parameter adjustments */
    nab_dim1 = *mmax;
    nab_offset = 1 + nab_dim1;
    nab -= nab_offset;
    ab_dim1 = *mmax;
    ab_offset = 1 + ab_dim1;
    ab -= ab_offset;
    --d__;
    --e;
    --e2;
    --nval;
    --c__;
    --work;
    --iwork;

    /* Function Body */
    *info = 0;
    if (*ijob < 1 || *ijob > 3) {
	*info = -1;
	return 0;
    }

/*     Initialize NAB */

    if (*ijob == 1) {

/*        Compute the number of eigenvalues in the initial intervals. */

	*mout = 0;
/* DIR$ NOVECTOR */
	i__1 = *minp;
	for (ji = 1; ji <= i__1; ++ji) {
	    for (jp = 1; jp <= 2; ++jp) {
		tmp1 = d__[1] - ab[ji + jp * ab_dim1];
		if (dabs(tmp1) < *pivmin) {
		    tmp1 = -(*pivmin);
		}
		nab[ji + jp * nab_dim1] = 0;
		if (tmp1 <= 0.f) {
		    nab[ji + jp * nab_dim1] = 1;
		}

		i__2 = *n;
		for (j = 2; j <= i__2; ++j) {
		    tmp1 = d__[j] - e2[j - 1] / tmp1 - ab[ji + jp * ab_dim1];
		    if (dabs(tmp1) < *pivmin) {
			tmp1 = -(*pivmin);
		    }
		    if (tmp1 <= 0.f) {
			++nab[ji + jp * nab_dim1];
		    }
/* L10: */
		}
/* L20: */
	    }
	    *mout = *mout + nab[ji + (nab_dim1 << 1)] - nab[ji + nab_dim1];
/* L30: */
	}
	return 0;
    }

/*     Initialize for loop */

/*     KF and KL have the following meaning: */
/*        Intervals 1,...,KF-1 have converged. */
/*        Intervals KF,...,KL  still need to be refined. */

    kf = 1;
    kl = *minp;

/*     If IJOB=2, initialize C. */
/*     If IJOB=3, use the user-supplied starting point. */

    if (*ijob == 2) {
	i__1 = *minp;
	for (ji = 1; ji <= i__1; ++ji) {
	    c__[ji] = (ab[ji + ab_dim1] + ab[ji + (ab_dim1 << 1)]) * .5f;
/* L40: */
	}
    }

/*     Iteration loop */

    i__1 = *nitmax;
    for (jit = 1; jit <= i__1; ++jit) {

/*        Loop over intervals */

	if (kl - kf + 1 >= *nbmin && *nbmin > 0) {

/*           Begin of Parallel Version of the loop */

	    i__2 = kl;
	    for (ji = kf; ji <= i__2; ++ji) {

/*              Compute N(c), the number of eigenvalues less than c */

		work[ji] = d__[1] - c__[ji];
		iwork[ji] = 0;
		if (work[ji] <= *pivmin) {
		    iwork[ji] = 1;
/* Computing MIN */
		    r__1 = work[ji], r__2 = -(*pivmin);
		    work[ji] = dmin(r__1,r__2);
		}

		i__3 = *n;
		for (j = 2; j <= i__3; ++j) {
		    work[ji] = d__[j] - e2[j - 1] / work[ji] - c__[ji];
		    if (work[ji] <= *pivmin) {
			++iwork[ji];
/* Computing MIN */
			r__1 = work[ji], r__2 = -(*pivmin);
			work[ji] = dmin(r__1,r__2);
		    }
/* L50: */
		}
/* L60: */
	    }

	    if (*ijob <= 2) {

/*              IJOB=2: Choose all intervals containing eigenvalues. */

		klnew = kl;
		i__2 = kl;
		for (ji = kf; ji <= i__2; ++ji) {

/*                 Insure that N(w) is monotone */

/* Computing MIN */
/* Computing MAX */
		    i__5 = nab[ji + nab_dim1], i__6 = iwork[ji];
		    i__3 = nab[ji + (nab_dim1 << 1)], i__4 = max(i__5,i__6);
		    iwork[ji] = min(i__3,i__4);

/*                 Update the Queue -- add intervals if both halves */
/*                 contain eigenvalues. */

		    if (iwork[ji] == nab[ji + (nab_dim1 << 1)]) {

/*                    No eigenvalue in the upper interval: */
/*                    just use the lower interval. */

			ab[ji + (ab_dim1 << 1)] = c__[ji];

		    } else if (iwork[ji] == nab[ji + nab_dim1]) {

/*                    No eigenvalue in the lower interval: */
/*                    just use the upper interval. */

			ab[ji + ab_dim1] = c__[ji];
		    } else {
			++klnew;
			if (klnew <= *mmax) {

/*                       Eigenvalue in both intervals -- add upper to */
/*                       queue. */

			    ab[klnew + (ab_dim1 << 1)] = ab[ji + (ab_dim1 << 
				    1)];
			    nab[klnew + (nab_dim1 << 1)] = nab[ji + (nab_dim1 
				    << 1)];
			    ab[klnew + ab_dim1] = c__[ji];
			    nab[klnew + nab_dim1] = iwork[ji];
			    ab[ji + (ab_dim1 << 1)] = c__[ji];
			    nab[ji + (nab_dim1 << 1)] = iwork[ji];
			} else {
			    *info = *mmax + 1;
			}
		    }
/* L70: */
		}
		if (*info != 0) {
		    return 0;
		}
		kl = klnew;
	    } else {

/*              IJOB=3: Binary search.  Keep only the interval containing */
/*                      w   s.t. N(w) = NVAL */

		i__2 = kl;
		for (ji = kf; ji <= i__2; ++ji) {
		    if (iwork[ji] <= nval[ji]) {
			ab[ji + ab_dim1] = c__[ji];
			nab[ji + nab_dim1] = iwork[ji];
		    }
		    if (iwork[ji] >= nval[ji]) {
			ab[ji + (ab_dim1 << 1)] = c__[ji];
			nab[ji + (nab_dim1 << 1)] = iwork[ji];
		    }
/* L80: */
		}
	    }

	} else {

/*           End of Parallel Version of the loop */

/*           Begin of Serial Version of the loop */

	    klnew = kl;
	    i__2 = kl;
	    for (ji = kf; ji <= i__2; ++ji) {

/*              Compute N(w), the number of eigenvalues less than w */

		tmp1 = c__[ji];
		tmp2 = d__[1] - tmp1;
		itmp1 = 0;
		if (tmp2 <= *pivmin) {
		    itmp1 = 1;
/* Computing MIN */
		    r__1 = tmp2, r__2 = -(*pivmin);
		    tmp2 = dmin(r__1,r__2);
		}

/*              A series of compiler directives to defeat vectorization */
/*              for the next loop */

/* $PL$ CMCHAR=' ' */
/* DIR$          NEXTSCALAR */
/* $DIR          SCALAR */
/* DIR$          NEXT SCALAR */
/* VD$L          NOVECTOR */
/* DEC$          NOVECTOR */
/* VD$           NOVECTOR */
/* VDIR          NOVECTOR */
/* VOCL          LOOP,SCALAR */
/* IBM           PREFER SCALAR */
/* $PL$ CMCHAR='*' */

		i__3 = *n;
		for (j = 2; j <= i__3; ++j) {
		    tmp2 = d__[j] - e2[j - 1] / tmp2 - tmp1;
		    if (tmp2 <= *pivmin) {
			++itmp1;
/* Computing MIN */
			r__1 = tmp2, r__2 = -(*pivmin);
			tmp2 = dmin(r__1,r__2);
		    }
/* L90: */
		}

		if (*ijob <= 2) {

/*                 IJOB=2: Choose all intervals containing eigenvalues. */

/*                 Insure that N(w) is monotone */

/* Computing MIN */
/* Computing MAX */
		    i__5 = nab[ji + nab_dim1];
		    i__3 = nab[ji + (nab_dim1 << 1)], i__4 = max(i__5,itmp1);
		    itmp1 = min(i__3,i__4);

/*                 Update the Queue -- add intervals if both halves */
/*                 contain eigenvalues. */

		    if (itmp1 == nab[ji + (nab_dim1 << 1)]) {

/*                    No eigenvalue in the upper interval: */
/*                    just use the lower interval. */

			ab[ji + (ab_dim1 << 1)] = tmp1;

		    } else if (itmp1 == nab[ji + nab_dim1]) {

/*                    No eigenvalue in the lower interval: */
/*                    just use the upper interval. */

			ab[ji + ab_dim1] = tmp1;
		    } else if (klnew < *mmax) {

/*                    Eigenvalue in both intervals -- add upper to queue. */

			++klnew;
			ab[klnew + (ab_dim1 << 1)] = ab[ji + (ab_dim1 << 1)];
			nab[klnew + (nab_dim1 << 1)] = nab[ji + (nab_dim1 << 
				1)];
			ab[klnew + ab_dim1] = tmp1;
			nab[klnew + nab_dim1] = itmp1;
			ab[ji + (ab_dim1 << 1)] = tmp1;
			nab[ji + (nab_dim1 << 1)] = itmp1;
		    } else {
			*info = *mmax + 1;
			return 0;
		    }
		} else {

/*                 IJOB=3: Binary search.  Keep only the interval */
/*                         containing  w  s.t. N(w) = NVAL */

		    if (itmp1 <= nval[ji]) {
			ab[ji + ab_dim1] = tmp1;
			nab[ji + nab_dim1] = itmp1;
		    }
		    if (itmp1 >= nval[ji]) {
			ab[ji + (ab_dim1 << 1)] = tmp1;
			nab[ji + (nab_dim1 << 1)] = itmp1;
		    }
		}
/* L100: */
	    }
	    kl = klnew;

/*           End of Serial Version of the loop */

	}

/*        Check for convergence */

	kfnew = kf;
	i__2 = kl;
	for (ji = kf; ji <= i__2; ++ji) {
	    tmp1 = (r__1 = ab[ji + (ab_dim1 << 1)] - ab[ji + ab_dim1], dabs(
		    r__1));
/* Computing MAX */
	    r__3 = (r__1 = ab[ji + (ab_dim1 << 1)], dabs(r__1)), r__4 = (r__2 
		    = ab[ji + ab_dim1], dabs(r__2));
	    tmp2 = dmax(r__3,r__4);
/* Computing MAX */
	    r__1 = max(*abstol,*pivmin), r__2 = *reltol * tmp2;
	    if (tmp1 < dmax(r__1,r__2) || nab[ji + nab_dim1] >= nab[ji + (
		    nab_dim1 << 1)]) {

/*              Converged -- Swap with position KFNEW, */
/*                           then increment KFNEW */

		if (ji > kfnew) {
		    tmp1 = ab[ji + ab_dim1];
		    tmp2 = ab[ji + (ab_dim1 << 1)];
		    itmp1 = nab[ji + nab_dim1];
		    itmp2 = nab[ji + (nab_dim1 << 1)];
		    ab[ji + ab_dim1] = ab[kfnew + ab_dim1];
		    ab[ji + (ab_dim1 << 1)] = ab[kfnew + (ab_dim1 << 1)];
		    nab[ji + nab_dim1] = nab[kfnew + nab_dim1];
		    nab[ji + (nab_dim1 << 1)] = nab[kfnew + (nab_dim1 << 1)];
		    ab[kfnew + ab_dim1] = tmp1;
		    ab[kfnew + (ab_dim1 << 1)] = tmp2;
		    nab[kfnew + nab_dim1] = itmp1;
		    nab[kfnew + (nab_dim1 << 1)] = itmp2;
		    if (*ijob == 3) {
			itmp1 = nval[ji];
			nval[ji] = nval[kfnew];
			nval[kfnew] = itmp1;
		    }
		}
		++kfnew;
	    }
/* L110: */
	}
	kf = kfnew;

/*        Choose Midpoints */

	i__2 = kl;
	for (ji = kf; ji <= i__2; ++ji) {
	    c__[ji] = (ab[ji + ab_dim1] + ab[ji + (ab_dim1 << 1)]) * .5f;
/* L120: */
	}

/*        If no more intervals to refine, quit. */

	if (kf > kl) {
	    goto L140;
	}
/* L130: */
    }

/*     Converged */

L140:
/* Computing MAX */
    i__1 = kl + 1 - kf;
    *info = max(i__1,0);
    *mout = kl;

    return 0;

/*     End of SLAEBZ */

} /* slaebz_ */
示例#30
0
/* Subroutine */ int sbdt03_(char *uplo, integer *n, integer *kd, real *d__, 
	real *e, real *u, integer *ldu, real *s, real *vt, integer *ldvt, 
	real *work, real *resid)
{
    /* System generated locals */
    integer u_dim1, u_offset, vt_dim1, vt_offset, i__1, i__2;
    real r__1, r__2, r__3, r__4;

    /* Local variables */
    integer i__, j;
    real eps;
    real bnorm;
    extern /* Subroutine */ int sgemv_(char *, integer *, integer *, real *, 
	    real *, integer *, real *, integer *, real *, real *, integer *);
    extern doublereal sasum_(integer *, real *, integer *), slamch_(char *);
    extern integer isamax_(integer *, real *, integer *);


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

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

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

/*  SBDT03 reconstructs a bidiagonal matrix B from its SVD: */
/*     S = U' * B * V */
/*  where U and V are orthogonal matrices and S is diagonal. */

/*  The test ratio to test the singular value decomposition is */
/*     RESID = norm( B - U * S * VT ) / ( n * norm(B) * EPS ) */
/*  where VT = V' and EPS is the machine precision. */

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

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

/*  N       (input) INTEGER */
/*          The order of the matrix B. */

/*  KD      (input) INTEGER */
/*          The bandwidth of the bidiagonal matrix B.  If KD = 1, the */
/*          matrix B is bidiagonal, and if KD = 0, B is diagonal and E is */
/*          not referenced.  If KD is greater than 1, it is assumed to be */
/*          1, and if KD is less than 0, it is assumed to be 0. */

/*  D       (input) REAL array, dimension (N) */
/*          The n diagonal elements of the bidiagonal matrix B. */

/*  E       (input) REAL array, dimension (N-1) */
/*          The (n-1) superdiagonal elements of the bidiagonal matrix B */
/*          if UPLO = 'U', or the (n-1) subdiagonal elements of B if */
/*          UPLO = 'L'. */

/*  U       (input) REAL array, dimension (LDU,N) */
/*          The n by n orthogonal matrix U in the reduction B = U'*A*P. */

/*  LDU     (input) INTEGER */
/*          The leading dimension of the array U.  LDU >= max(1,N) */

/*  S       (input) REAL array, dimension (N) */
/*          The singular values from the SVD of B, sorted in decreasing */
/*          order. */

/*  VT      (input) REAL array, dimension (LDVT,N) */
/*          The n by n orthogonal matrix V' in the reduction */
/*          B = U * S * V'. */

/*  LDVT    (input) INTEGER */
/*          The leading dimension of the array VT. */

/*  WORK    (workspace) REAL array, dimension (2*N) */

/*  RESID   (output) REAL */
/*          The test ratio:  norm(B - U * S * V') / ( n * norm(A) * EPS ) */

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

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

/*     Quick return if possible */

    /* Parameter adjustments */
    --d__;
    --e;
    u_dim1 = *ldu;
    u_offset = 1 + u_dim1;
    u -= u_offset;
    --s;
    vt_dim1 = *ldvt;
    vt_offset = 1 + vt_dim1;
    vt -= vt_offset;
    --work;

    /* Function Body */
    *resid = 0.f;
    if (*n <= 0) {
	return 0;
    }

/*     Compute B - U * S * V' one column at a time. */

    bnorm = 0.f;
    if (*kd >= 1) {

/*        B is bidiagonal. */

	if (lsame_(uplo, "U")) {

/*           B is upper bidiagonal. */

	    i__1 = *n;
	    for (j = 1; j <= i__1; ++j) {
		i__2 = *n;
		for (i__ = 1; i__ <= i__2; ++i__) {
		    work[*n + i__] = s[i__] * vt[i__ + j * vt_dim1];
/* L10: */
		}
		sgemv_("No transpose", n, n, &c_b6, &u[u_offset], ldu, &work[*
			n + 1], &c__1, &c_b8, &work[1], &c__1);
		work[j] += d__[j];
		if (j > 1) {
		    work[j - 1] += e[j - 1];
/* Computing MAX */
		    r__3 = bnorm, r__4 = (r__1 = d__[j], dabs(r__1)) + (r__2 =
			     e[j - 1], dabs(r__2));
		    bnorm = dmax(r__3,r__4);
		} else {
/* Computing MAX */
		    r__2 = bnorm, r__3 = (r__1 = d__[j], dabs(r__1));
		    bnorm = dmax(r__2,r__3);
		}
/* Computing MAX */
		r__1 = *resid, r__2 = sasum_(n, &work[1], &c__1);
		*resid = dmax(r__1,r__2);
/* L20: */
	    }
	} else {

/*           B is lower bidiagonal. */

	    i__1 = *n;
	    for (j = 1; j <= i__1; ++j) {
		i__2 = *n;
		for (i__ = 1; i__ <= i__2; ++i__) {
		    work[*n + i__] = s[i__] * vt[i__ + j * vt_dim1];
/* L30: */
		}
		sgemv_("No transpose", n, n, &c_b6, &u[u_offset], ldu, &work[*
			n + 1], &c__1, &c_b8, &work[1], &c__1);
		work[j] += d__[j];
		if (j < *n) {
		    work[j + 1] += e[j];
/* Computing MAX */
		    r__3 = bnorm, r__4 = (r__1 = d__[j], dabs(r__1)) + (r__2 =
			     e[j], dabs(r__2));
		    bnorm = dmax(r__3,r__4);
		} else {
/* Computing MAX */
		    r__2 = bnorm, r__3 = (r__1 = d__[j], dabs(r__1));
		    bnorm = dmax(r__2,r__3);
		}
/* Computing MAX */
		r__1 = *resid, r__2 = sasum_(n, &work[1], &c__1);
		*resid = dmax(r__1,r__2);
/* L40: */
	    }
	}
    } else {

/*        B is diagonal. */

	i__1 = *n;
	for (j = 1; j <= i__1; ++j) {
	    i__2 = *n;
	    for (i__ = 1; i__ <= i__2; ++i__) {
		work[*n + i__] = s[i__] * vt[i__ + j * vt_dim1];
/* L50: */
	    }
	    sgemv_("No transpose", n, n, &c_b6, &u[u_offset], ldu, &work[*n + 
		    1], &c__1, &c_b8, &work[1], &c__1);
	    work[j] += d__[j];
/* Computing MAX */
	    r__1 = *resid, r__2 = sasum_(n, &work[1], &c__1);
	    *resid = dmax(r__1,r__2);
/* L60: */
	}
	j = isamax_(n, &d__[1], &c__1);
	bnorm = (r__1 = d__[j], dabs(r__1));
    }

/*     Compute norm(B - U * S * V') / ( n * norm(B) * EPS ) */

    eps = slamch_("Precision");

    if (bnorm <= 0.f) {
	if (*resid != 0.f) {
	    *resid = 1.f / eps;
	}
    } else {
	if (bnorm >= *resid) {
	    *resid = *resid / bnorm / ((real) (*n) * eps);
	} else {
	    if (bnorm < 1.f) {
/* Computing MIN */
		r__1 = *resid, r__2 = (real) (*n) * bnorm;
		*resid = dmin(r__1,r__2) / bnorm / ((real) (*n) * eps);
	    } else {
/* Computing MIN */
		r__1 = *resid / bnorm, r__2 = (real) (*n);
		*resid = dmin(r__1,r__2) / ((real) (*n) * eps);
	    }
	}
    }

    return 0;

/*     End of SBDT03 */

} /* sbdt03_ */