Beispiel #1
0
/* Subroutine */ int dsbevd_(char *jobz, char *uplo, integer *n, integer *kd, 
	doublereal *ab, integer *ldab, doublereal *w, doublereal *z__, 
	integer *ldz, doublereal *work, integer *lwork, integer *iwork, 
	integer *liwork, integer *info)
{
    /* System generated locals */
    integer ab_dim1, ab_offset, z_dim1, z_offset, i__1;
    doublereal d__1;

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

    /* Local variables */
    doublereal eps;
    integer inde;
    doublereal anrm, rmin, rmax;
    extern /* Subroutine */ int dscal_(integer *, doublereal *, doublereal *, 
	    integer *), dgemm_(char *, char *, integer *, integer *, integer *
, doublereal *, doublereal *, integer *, doublereal *, integer *, 
	    doublereal *, doublereal *, integer *);
    doublereal sigma;
    extern logical lsame_(char *, char *);
    integer iinfo, lwmin;
    logical lower, wantz;
    integer indwk2, llwrk2;
    extern doublereal dlamch_(char *);
    integer iscale;
    extern /* Subroutine */ int dlascl_(char *, integer *, integer *, 
	    doublereal *, doublereal *, integer *, integer *, doublereal *, 
	    integer *, integer *);
    extern doublereal dlansb_(char *, char *, integer *, integer *, 
	    doublereal *, integer *, doublereal *);
    extern /* Subroutine */ int dstedc_(char *, integer *, doublereal *, 
	    doublereal *, doublereal *, integer *, doublereal *, integer *, 
	    integer *, integer *, integer *), dlacpy_(char *, integer 
	    *, integer *, doublereal *, integer *, doublereal *, integer *);
    doublereal safmin;
    extern /* Subroutine */ int xerbla_(char *, integer *);
    doublereal bignum;
    extern /* Subroutine */ int dsbtrd_(char *, char *, integer *, integer *, 
	    doublereal *, integer *, doublereal *, doublereal *, doublereal *, 
	     integer *, doublereal *, integer *), dsterf_(
	    integer *, doublereal *, doublereal *, integer *);
    integer indwrk, liwmin;
    doublereal smlnum;
    logical lquery;


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

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

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

/*  DSBEVD computes all the eigenvalues and, optionally, eigenvectors of */
/*  a real symmetric band matrix A. If eigenvectors are desired, it uses */
/*  a divide and conquer algorithm. */

/*  The divide and conquer algorithm makes very mild assumptions about */
/*  floating point arithmetic. It will work on machines with a guard */
/*  digit in add/subtract, or on those binary machines without guard */
/*  digits which subtract like the Cray X-MP, Cray Y-MP, Cray C-90, or */
/*  Cray-2. It could conceivably fail on hexadecimal or decimal machines */
/*  without guard digits, but we know of none. */

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

/*  JOBZ    (input) CHARACTER*1 */
/*          = 'N':  Compute eigenvalues only; */
/*          = 'V':  Compute eigenvalues and eigenvectors. */

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

/*  AB      (input/output) DOUBLE PRECISION array, dimension (LDAB, N) */
/*          On entry, the upper or lower triangle of the symmetric 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). */

/*          On exit, AB is overwritten by values generated during the */
/*          reduction to tridiagonal form.  If UPLO = 'U', the first */
/*          superdiagonal and the diagonal of the tridiagonal matrix T */
/*          are returned in rows KD and KD+1 of AB, and if UPLO = 'L', */
/*          the diagonal and first subdiagonal of T are returned in the */
/*          first two rows of AB. */

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

/*  W       (output) DOUBLE PRECISION array, dimension (N) */
/*          If INFO = 0, the eigenvalues in ascending order. */

/*  Z       (output) DOUBLE PRECISION array, dimension (LDZ, N) */
/*          If JOBZ = 'V', then if INFO = 0, Z contains the orthonormal */
/*          eigenvectors of the matrix A, with the i-th column of Z */
/*          holding the eigenvector associated with W(i). */
/*          If JOBZ = 'N', then Z is not referenced. */

/*  LDZ     (input) INTEGER */
/*          The leading dimension of the array Z.  LDZ >= 1, and if */
/*          JOBZ = 'V', LDZ >= max(1,N). */

/*  WORK    (workspace/output) DOUBLE PRECISION array, */
/*                                         dimension (LWORK) */
/*          On exit, if INFO = 0, WORK(1) returns the optimal LWORK. */

/*  LWORK   (input) INTEGER */
/*          The dimension of the array WORK. */
/*          IF N <= 1,                LWORK must be at least 1. */
/*          If JOBZ  = 'N' and N > 2, LWORK must be at least 2*N. */
/*          If JOBZ  = 'V' and N > 2, LWORK must be at least */
/*                         ( 1 + 5*N + 2*N**2 ). */

/*          If LWORK = -1, then a workspace query is assumed; the routine */
/*          only calculates the optimal sizes of the WORK and IWORK */
/*          arrays, returns these values as the first entries of the WORK */
/*          and IWORK arrays, and no error message related to LWORK or */
/*          LIWORK is issued by XERBLA. */

/*  IWORK   (workspace/output) INTEGER array, dimension (MAX(1,LIWORK)) */
/*          On exit, if INFO = 0, IWORK(1) returns the optimal LIWORK. */

/*  LIWORK  (input) INTEGER */
/*          The dimension of the array LIWORK. */
/*          If JOBZ  = 'N' or N <= 1, LIWORK must be at least 1. */
/*          If JOBZ  = 'V' and N > 2, LIWORK must be at least 3 + 5*N. */

/*          If LIWORK = -1, then a workspace query is assumed; the */
/*          routine only calculates the optimal sizes of the WORK and */
/*          IWORK arrays, returns these values as the first entries of */
/*          the WORK and IWORK arrays, and no error message related to */
/*          LWORK or LIWORK is issued by XERBLA. */

/*  INFO    (output) INTEGER */
/*          = 0:  successful exit */
/*          < 0:  if INFO = -i, the i-th argument had an illegal value */
/*          > 0:  if INFO = i, the algorithm failed to converge; i */
/*                off-diagonal elements of an intermediate tridiagonal */
/*                form did not converge to zero. */

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

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

/*     Test the input parameters. */

    /* Parameter adjustments */
    ab_dim1 = *ldab;
    ab_offset = 1 + ab_dim1;
    ab -= ab_offset;
    --w;
    z_dim1 = *ldz;
    z_offset = 1 + z_dim1;
    z__ -= z_offset;
    --work;
    --iwork;

    /* Function Body */
    wantz = lsame_(jobz, "V");
    lower = lsame_(uplo, "L");
    lquery = *lwork == -1 || *liwork == -1;

    *info = 0;
    if (*n <= 1) {
	liwmin = 1;
	lwmin = 1;
    } else {
	if (wantz) {
	    liwmin = *n * 5 + 3;
/* Computing 2nd power */
	    i__1 = *n;
	    lwmin = *n * 5 + 1 + (i__1 * i__1 << 1);
	} else {
	    liwmin = 1;
	    lwmin = *n << 1;
	}
    }
    if (! (wantz || lsame_(jobz, "N"))) {
	*info = -1;
    } else if (! (lower || lsame_(uplo, "U"))) {
	*info = -2;
    } else if (*n < 0) {
	*info = -3;
    } else if (*kd < 0) {
	*info = -4;
    } else if (*ldab < *kd + 1) {
	*info = -6;
    } else if (*ldz < 1 || wantz && *ldz < *n) {
	*info = -9;
    }

    if (*info == 0) {
	work[1] = (doublereal) lwmin;
	iwork[1] = liwmin;

	if (*lwork < lwmin && ! lquery) {
	    *info = -11;
	} else if (*liwork < liwmin && ! lquery) {
	    *info = -13;
	}
    }

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

/*     Quick return if possible */

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

    if (*n == 1) {
	w[1] = ab[ab_dim1 + 1];
	if (wantz) {
	    z__[z_dim1 + 1] = 1.;
	}
	return 0;
    }

/*     Get machine constants. */

    safmin = dlamch_("Safe minimum");
    eps = dlamch_("Precision");
    smlnum = safmin / eps;
    bignum = 1. / smlnum;
    rmin = sqrt(smlnum);
    rmax = sqrt(bignum);

/*     Scale matrix to allowable range, if necessary. */

    anrm = dlansb_("M", uplo, n, kd, &ab[ab_offset], ldab, &work[1]);
    iscale = 0;
    if (anrm > 0. && anrm < rmin) {
	iscale = 1;
	sigma = rmin / anrm;
    } else if (anrm > rmax) {
	iscale = 1;
	sigma = rmax / anrm;
    }
    if (iscale == 1) {
	if (lower) {
	    dlascl_("B", kd, kd, &c_b11, &sigma, n, n, &ab[ab_offset], ldab, 
		    info);
	} else {
	    dlascl_("Q", kd, kd, &c_b11, &sigma, n, n, &ab[ab_offset], ldab, 
		    info);
	}
    }

/*     Call DSBTRD to reduce symmetric band matrix to tridiagonal form. */

    inde = 1;
    indwrk = inde + *n;
    indwk2 = indwrk + *n * *n;
    llwrk2 = *lwork - indwk2 + 1;
    dsbtrd_(jobz, uplo, n, kd, &ab[ab_offset], ldab, &w[1], &work[inde], &z__[
	    z_offset], ldz, &work[indwrk], &iinfo);

/*     For eigenvalues only, call DSTERF.  For eigenvectors, call SSTEDC. */

    if (! wantz) {
	dsterf_(n, &w[1], &work[inde], info);
    } else {
	dstedc_("I", n, &w[1], &work[inde], &work[indwrk], n, &work[indwk2], &
		llwrk2, &iwork[1], liwork, info);
	dgemm_("N", "N", n, n, n, &c_b11, &z__[z_offset], ldz, &work[indwrk], 
		n, &c_b18, &work[indwk2], n);
	dlacpy_("A", n, n, &work[indwk2], n, &z__[z_offset], ldz);
    }

/*     If matrix was scaled, then rescale eigenvalues appropriately. */

    if (iscale == 1) {
	d__1 = 1. / sigma;
	dscal_(n, &d__1, &w[1], &c__1);
    }

    work[1] = (doublereal) lwmin;
    iwork[1] = liwmin;
    return 0;

/*     End of DSBEVD */

} /* dsbevd_ */
Beispiel #2
0
/* Subroutine */ int dpbsvx_(char *fact, char *uplo, integer *n, integer *kd, 
	integer *nrhs, doublereal *ab, integer *ldab, doublereal *afb, 
	integer *ldafb, char *equed, doublereal *s, doublereal *b, integer *
	ldb, doublereal *x, integer *ldx, doublereal *rcond, doublereal *ferr, 
	 doublereal *berr, doublereal *work, integer *iwork, integer *info)
{
    /* System generated locals */
    integer ab_dim1, ab_offset, afb_dim1, afb_offset, b_dim1, b_offset, 
	    x_dim1, x_offset, i__1, i__2;
    doublereal d__1, d__2;

    /* Local variables */
    integer i__, j, j1, j2;
    doublereal amax, smin, smax;
    extern logical lsame_(char *, char *);
    doublereal scond, anorm;
    extern /* Subroutine */ int dcopy_(integer *, doublereal *, integer *, 
	    doublereal *, integer *);
    logical equil, rcequ, upper;
    extern doublereal dlamch_(char *), dlansb_(char *, char *, 
	    integer *, integer *, doublereal *, integer *, doublereal *);
    extern /* Subroutine */ int dpbcon_(char *, integer *, integer *, 
	    doublereal *, integer *, doublereal *, doublereal *, doublereal *, 
	     integer *, integer *), dlaqsb_(char *, integer *, 
	    integer *, doublereal *, integer *, doublereal *, doublereal *, 
	    doublereal *, char *);
    logical nofact;
    extern /* Subroutine */ int dlacpy_(char *, integer *, integer *, 
	    doublereal *, integer *, doublereal *, integer *), 
	    xerbla_(char *, integer *), dpbequ_(char *, integer *, 
	    integer *, doublereal *, integer *, doublereal *, doublereal *, 
	    doublereal *, integer *);
    doublereal bignum;
    extern /* Subroutine */ int dpbrfs_(char *, integer *, integer *, integer 
	    *, doublereal *, integer *, doublereal *, integer *, doublereal *, 
	     integer *, doublereal *, integer *, doublereal *, doublereal *, 
	    doublereal *, integer *, integer *), dpbtrf_(char *, 
	    integer *, integer *, doublereal *, integer *, integer *);
    integer infequ;
    extern /* Subroutine */ int dpbtrs_(char *, integer *, integer *, integer 
	    *, doublereal *, integer *, doublereal *, integer *, integer *);
    doublereal smlnum;


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

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

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

/*  DPBSVX uses the Cholesky factorization A = U**T*U or A = L*L**T to */
/*  compute the solution to a real system of linear equations */
/*     A * X = B, */
/*  where A is an N-by-N symmetric positive definite band matrix and X */
/*  and B are N-by-NRHS matrices. */

/*  Error bounds on the solution and a condition estimate are also */
/*  provided. */

/*  Description */
/*  =========== */

/*  The following steps are performed: */

/*  1. If FACT = 'E', real scaling factors are computed to equilibrate */
/*     the system: */
/*        diag(S) * A * diag(S) * inv(diag(S)) * X = diag(S) * B */
/*     Whether or not the system will be equilibrated depends on the */
/*     scaling of the matrix A, but if equilibration is used, A is */
/*     overwritten by diag(S)*A*diag(S) and B by diag(S)*B. */

/*  2. If FACT = 'N' or 'E', the Cholesky decomposition is used to */
/*     factor the matrix A (after equilibration if FACT = 'E') as */
/*        A = U**T * U,  if UPLO = 'U', or */
/*        A = L * L**T,  if UPLO = 'L', */
/*     where U is an upper triangular band matrix, and L is a lower */
/*     triangular band matrix. */

/*  3. If the leading i-by-i principal minor is not positive definite, */
/*     then the routine returns with INFO = i. Otherwise, the factored */
/*     form of A is used to estimate the condition number of the matrix */
/*     A.  If the reciprocal of the condition number is less than machine */
/*     precision, INFO = N+1 is returned as a warning, but the routine */
/*     still goes on to solve for X and compute error bounds as */
/*     described below. */

/*  4. The system of equations is solved for X using the factored form */
/*     of A. */

/*  5. Iterative refinement is applied to improve the computed solution */
/*     matrix and calculate error bounds and backward error estimates */
/*     for it. */

/*  6. If equilibration was used, the matrix X is premultiplied by */
/*     diag(S) so that it solves the original system before */
/*     equilibration. */

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

/*  FACT    (input) CHARACTER*1 */
/*          Specifies whether or not the factored form of the matrix A is */
/*          supplied on entry, and if not, whether the matrix A should be */
/*          equilibrated before it is factored. */
/*          = 'F':  On entry, AFB contains the factored form of A. */
/*                  If EQUED = 'Y', the matrix A has been equilibrated */
/*                  with scaling factors given by S.  AB and AFB will not */
/*                  be modified. */
/*          = 'N':  The matrix A will be copied to AFB and factored. */
/*          = 'E':  The matrix A will be equilibrated if necessary, then */
/*                  copied to AFB and factored. */

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

/*  N       (input) INTEGER */
/*          The number of linear equations, i.e., 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/output) DOUBLE PRECISION array, dimension (LDAB,N) */
/*          On entry, the upper or lower triangle of the symmetric band */
/*          matrix A, stored in the first KD+1 rows of the array, except */
/*          if FACT = 'F' and EQUED = 'Y', then A must contain the */
/*          equilibrated matrix diag(S)*A*diag(S).  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). */
/*          See below for further details. */

/*          On exit, if FACT = 'E' and EQUED = 'Y', A is overwritten by */
/*          diag(S)*A*diag(S). */

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

/*  AFB     (input or output) DOUBLE PRECISION array, dimension (LDAFB,N) */
/*          If FACT = 'F', then AFB is an input argument and on entry */
/*          contains the triangular factor U or L from the Cholesky */
/*          factorization A = U**T*U or A = L*L**T of the band matrix */
/*          A, in the same storage format as A (see AB).  If EQUED = 'Y', */
/*          then AFB is the factored form of the equilibrated matrix A. */

/*          If FACT = 'N', then AFB is an output argument and on exit */
/*          returns the triangular factor U or L from the Cholesky */
/*          factorization A = U**T*U or A = L*L**T. */

/*          If FACT = 'E', then AFB is an output argument and on exit */
/*          returns the triangular factor U or L from the Cholesky */
/*          factorization A = U**T*U or A = L*L**T of the equilibrated */
/*          matrix A (see the description of A for the form of the */
/*          equilibrated matrix). */

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

/*  EQUED   (input or output) CHARACTER*1 */
/*          Specifies the form of equilibration that was done. */
/*          = 'N':  No equilibration (always true if FACT = 'N'). */
/*          = 'Y':  Equilibration was done, i.e., A has been replaced by */
/*                  diag(S) * A * diag(S). */
/*          EQUED is an input argument if FACT = 'F'; otherwise, it is an */
/*          output argument. */

/*  S       (input or output) DOUBLE PRECISION array, dimension (N) */
/*          The scale factors for A; not accessed if EQUED = 'N'.  S is */
/*          an input argument if FACT = 'F'; otherwise, S is an output */
/*          argument.  If FACT = 'F' and EQUED = 'Y', each element of S */
/*          must be positive. */

/*  B       (input/output) DOUBLE PRECISION array, dimension (LDB,NRHS) */
/*          On entry, the N-by-NRHS right hand side matrix B. */
/*          On exit, if EQUED = 'N', B is not modified; if EQUED = 'Y', */
/*          B is overwritten by diag(S) * B. */

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

/*  X       (output) DOUBLE PRECISION array, dimension (LDX,NRHS) */
/*          If INFO = 0 or INFO = N+1, the N-by-NRHS solution matrix X to */
/*          the original system of equations.  Note that if EQUED = 'Y', */
/*          A and B are modified on exit, and the solution to the */
/*          equilibrated system is inv(diag(S))*X. */

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

/*  RCOND   (output) DOUBLE PRECISION */
/*          The estimate of the reciprocal condition number of the matrix */
/*          A after equilibration (if done).  If RCOND is less than the */
/*          machine precision (in particular, if RCOND = 0), the matrix */
/*          is singular to working precision.  This condition is */
/*          indicated by a return code of INFO > 0. */

/*  FERR    (output) DOUBLE PRECISION 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) DOUBLE PRECISION 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) DOUBLE PRECISION array, dimension (3*N) */

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

/*  INFO    (output) INTEGER */
/*          = 0:  successful exit */
/*          < 0:  if INFO = -i, the i-th argument had an illegal value */
/*          > 0:  if INFO = i, and i is */
/*                <= N:  the leading minor of order i of A is */
/*                       not positive definite, so the factorization */
/*                       could not be completed, and the solution has not */
/*                       been computed. RCOND = 0 is returned. */
/*                = N+1: U is nonsingular, but RCOND is less than machine */
/*                       precision, meaning that the matrix is singular */
/*                       to working precision.  Nevertheless, the */
/*                       solution and error bounds are computed because */
/*                       there are a number of situations where the */
/*                       computed solution can be more accurate than the */
/*                       value of RCOND would suggest. */

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

/*  The band storage scheme is illustrated by the following example, when */
/*  N = 6, KD = 2, and UPLO = 'U': */

/*  Two-dimensional storage of the symmetric matrix A: */

/*     a11  a12  a13 */
/*          a22  a23  a24 */
/*               a33  a34  a35 */
/*                    a44  a45  a46 */
/*                         a55  a56 */
/*     (aij=conjg(aji))         a66 */

/*  Band storage of the upper triangle of A: */

/*      *    *   a13  a24  a35  a46 */
/*      *   a12  a23  a34  a45  a56 */
/*     a11  a22  a33  a44  a55  a66 */

/*  Similarly, if UPLO = 'L' the format of A is as follows: */

/*     a11  a22  a33  a44  a55  a66 */
/*     a21  a32  a43  a54  a65   * */
/*     a31  a42  a53  a64   *    * */

/*  Array elements marked * are not used by the routine. */

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

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

    /* Parameter adjustments */
    ab_dim1 = *ldab;
    ab_offset = 1 + ab_dim1;
    ab -= ab_offset;
    afb_dim1 = *ldafb;
    afb_offset = 1 + afb_dim1;
    afb -= afb_offset;
    --s;
    b_dim1 = *ldb;
    b_offset = 1 + b_dim1;
    b -= b_offset;
    x_dim1 = *ldx;
    x_offset = 1 + x_dim1;
    x -= x_offset;
    --ferr;
    --berr;
    --work;
    --iwork;

    /* Function Body */
    *info = 0;
    nofact = lsame_(fact, "N");
    equil = lsame_(fact, "E");
    upper = lsame_(uplo, "U");
    if (nofact || equil) {
	*(unsigned char *)equed = 'N';
	rcequ = FALSE_;
    } else {
	rcequ = lsame_(equed, "Y");
	smlnum = dlamch_("Safe minimum");
	bignum = 1. / smlnum;
    }

/*     Test the input parameters. */

    if (! nofact && ! equil && ! lsame_(fact, "F")) {
	*info = -1;
    } else if (! upper && ! lsame_(uplo, "L")) {
	*info = -2;
    } else if (*n < 0) {
	*info = -3;
    } else if (*kd < 0) {
	*info = -4;
    } else if (*nrhs < 0) {
	*info = -5;
    } else if (*ldab < *kd + 1) {
	*info = -7;
    } else if (*ldafb < *kd + 1) {
	*info = -9;
    } else if (lsame_(fact, "F") && ! (rcequ || lsame_(
	    equed, "N"))) {
	*info = -10;
    } else {
	if (rcequ) {
	    smin = bignum;
	    smax = 0.;
	    i__1 = *n;
	    for (j = 1; j <= i__1; ++j) {
/* Computing MIN */
		d__1 = smin, d__2 = s[j];
		smin = min(d__1,d__2);
/* Computing MAX */
		d__1 = smax, d__2 = s[j];
		smax = max(d__1,d__2);
/* L10: */
	    }
	    if (smin <= 0.) {
		*info = -11;
	    } else if (*n > 0) {
		scond = max(smin,smlnum) / min(smax,bignum);
	    } else {
		scond = 1.;
	    }
	}
	if (*info == 0) {
	    if (*ldb < max(1,*n)) {
		*info = -13;
	    } else if (*ldx < max(1,*n)) {
		*info = -15;
	    }
	}
    }

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

    if (equil) {

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

	dpbequ_(uplo, n, kd, &ab[ab_offset], ldab, &s[1], &scond, &amax, &
		infequ);
	if (infequ == 0) {

/*           Equilibrate the matrix. */

	    dlaqsb_(uplo, n, kd, &ab[ab_offset], ldab, &s[1], &scond, &amax, 
		    equed);
	    rcequ = lsame_(equed, "Y");
	}
    }

/*     Scale the right-hand side. */

    if (rcequ) {
	i__1 = *nrhs;
	for (j = 1; j <= i__1; ++j) {
	    i__2 = *n;
	    for (i__ = 1; i__ <= i__2; ++i__) {
		b[i__ + j * b_dim1] = s[i__] * b[i__ + j * b_dim1];
/* L20: */
	    }
/* L30: */
	}
    }

    if (nofact || equil) {

/*        Compute the Cholesky factorization A = U'*U or A = L*L'. */

	if (upper) {
	    i__1 = *n;
	    for (j = 1; j <= i__1; ++j) {
/* Computing MAX */
		i__2 = j - *kd;
		j1 = max(i__2,1);
		i__2 = j - j1 + 1;
		dcopy_(&i__2, &ab[*kd + 1 - j + j1 + j * ab_dim1], &c__1, &
			afb[*kd + 1 - j + j1 + j * afb_dim1], &c__1);
/* L40: */
	    }
	} else {
	    i__1 = *n;
	    for (j = 1; j <= i__1; ++j) {
/* Computing MIN */
		i__2 = j + *kd;
		j2 = min(i__2,*n);
		i__2 = j2 - j + 1;
		dcopy_(&i__2, &ab[j * ab_dim1 + 1], &c__1, &afb[j * afb_dim1 
			+ 1], &c__1);
/* L50: */
	    }
	}

	dpbtrf_(uplo, n, kd, &afb[afb_offset], ldafb, info);

/*        Return if INFO is non-zero. */

	if (*info > 0) {
	    *rcond = 0.;
	    return 0;
	}
    }

/*     Compute the norm of the matrix A. */

    anorm = dlansb_("1", uplo, n, kd, &ab[ab_offset], ldab, &work[1]);

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

    dpbcon_(uplo, n, kd, &afb[afb_offset], ldafb, &anorm, rcond, &work[1], &
	    iwork[1], info);

/*     Compute the solution matrix X. */

    dlacpy_("Full", n, nrhs, &b[b_offset], ldb, &x[x_offset], ldx);
    dpbtrs_(uplo, n, kd, nrhs, &afb[afb_offset], ldafb, &x[x_offset], ldx, 
	    info);

/*     Use iterative refinement to improve the computed solution and */
/*     compute error bounds and backward error estimates for it. */

    dpbrfs_(uplo, n, kd, nrhs, &ab[ab_offset], ldab, &afb[afb_offset], ldafb, 
	    &b[b_offset], ldb, &x[x_offset], ldx, &ferr[1], &berr[1], &work[1]
, &iwork[1], info);

/*     Transform the solution matrix X to a solution of the original */
/*     system. */

    if (rcequ) {
	i__1 = *nrhs;
	for (j = 1; j <= i__1; ++j) {
	    i__2 = *n;
	    for (i__ = 1; i__ <= i__2; ++i__) {
		x[i__ + j * x_dim1] = s[i__] * x[i__ + j * x_dim1];
/* L60: */
	    }
/* L70: */
	}
	i__1 = *nrhs;
	for (j = 1; j <= i__1; ++j) {
	    ferr[j] /= scond;
/* L80: */
	}
    }

/*     Set INFO = N+1 if the matrix is singular to working precision. */

    if (*rcond < dlamch_("Epsilon")) {
	*info = *n + 1;
    }

    return 0;

/*     End of DPBSVX */

} /* dpbsvx_ */
Beispiel #3
0
/* Subroutine */ int dchkpb_(logical *dotype, integer *nn, integer *nval, 
	integer *nnb, integer *nbval, integer *nns, integer *nsval, 
	doublereal *thresh, logical *tsterr, integer *nmax, doublereal *a, 
	doublereal *afac, doublereal *ainv, doublereal *b, doublereal *x, 
	doublereal *xact, doublereal *work, doublereal *rwork, integer *iwork,
	 integer *nout)
{
    /* Initialized data */

    static integer iseedy[4] = { 1988,1989,1990,1991 };

    /* Format strings */
    static char fmt_9999[] = "(\002 UPLO='\002,a1,\002', N=\002,i5,\002, KD"
	    "=\002,i5,\002, NB=\002,i4,\002, type \002,i2,\002, test \002,i2"
	    ",\002, ratio= \002,g12.5)";
    static char fmt_9998[] = "(\002 UPLO='\002,a1,\002', N=\002,i5,\002, KD"
	    "=\002,i5,\002, NRHS=\002,i3,\002, type \002,i2,\002, test(\002,i"
	    "2,\002) = \002,g12.5)";
    static char fmt_9997[] = "(\002 UPLO='\002,a1,\002', N=\002,i5,\002, KD"
	    "=\002,i5,\002,\002,10x,\002 type \002,i2,\002, test(\002,i2,\002"
	    ") = \002,g12.5)";

    /* System generated locals */
    integer i__1, i__2, i__3, i__4, i__5, i__6;

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

    /* Local variables */
    static integer ldab, ioff, mode, koff, imat, info;
    static char path[3], dist[1];
    static integer irhs, nrhs;
    static char uplo[1], type__[1];
    static integer nrun, i__;
    extern /* Subroutine */ int alahd_(integer *, char *);
    static integer k, n;
    extern /* Subroutine */ int dget04_(integer *, integer *, doublereal *, 
	    integer *, doublereal *, integer *, doublereal *, doublereal *);
    static integer nfail, iseed[4];
    extern doublereal dget06_(doublereal *, doublereal *);
    extern /* Subroutine */ int dpbt01_(char *, integer *, integer *, 
	    doublereal *, integer *, doublereal *, integer *, doublereal *, 
	    doublereal *), dpbt02_(char *, integer *, integer *, 
	    integer *, doublereal *, integer *, doublereal *, integer *, 
	    doublereal *, integer *, doublereal *, doublereal *), 
	    dpbt05_(char *, integer *, integer *, integer *, doublereal *, 
	    integer *, doublereal *, integer *, doublereal *, integer *, 
	    doublereal *, integer *, doublereal *, doublereal *, doublereal *);
    static integer kdval[4];
    static doublereal rcond;
    static integer nimat;
    static doublereal anorm;
    extern /* Subroutine */ int dcopy_(integer *, doublereal *, integer *, 
	    doublereal *, integer *), dswap_(integer *, doublereal *, integer 
	    *, doublereal *, integer *);
    static integer iuplo, izero, i1, i2, nerrs;
    static logical zerot;
    static char xtype[1];
    extern /* Subroutine */ int dlatb4_(char *, integer *, integer *, integer 
	    *, char *, integer *, integer *, doublereal *, integer *, 
	    doublereal *, char *);
    static integer kd, nb, in, kl;
    extern doublereal dlange_(char *, integer *, integer *, doublereal *, 
	    integer *, doublereal *);
    extern /* Subroutine */ int alaerh_(char *, char *, integer *, integer *, 
	    char *, integer *, integer *, integer *, integer *, integer *, 
	    integer *, integer *, integer *, integer *);
    static integer iw, ku;
    extern doublereal dlansb_(char *, char *, integer *, integer *, 
	    doublereal *, integer *, doublereal *);
    extern /* Subroutine */ int dpbcon_(char *, integer *, integer *, 
	    doublereal *, integer *, doublereal *, doublereal *, doublereal *,
	     integer *, integer *);
    static doublereal rcondc;
    static char packit[1];
    extern /* Subroutine */ int dlacpy_(char *, integer *, integer *, 
	    doublereal *, integer *, doublereal *, integer *), 
	    dlarhs_(char *, char *, char *, char *, integer *, integer *, 
	    integer *, integer *, integer *, doublereal *, integer *, 
	    doublereal *, integer *, doublereal *, integer *, integer *, 
	    integer *), dlaset_(char *, 
	    integer *, integer *, doublereal *, doublereal *, doublereal *, 
	    integer *), dpbrfs_(char *, integer *, integer *, integer 
	    *, doublereal *, integer *, doublereal *, integer *, doublereal *,
	     integer *, doublereal *, integer *, doublereal *, doublereal *, 
	    doublereal *, integer *, integer *), dpbtrf_(char *, 
	    integer *, integer *, doublereal *, integer *, integer *),
	     alasum_(char *, integer *, integer *, integer *, integer *);
    static doublereal cndnum;
    extern /* Subroutine */ int dlatms_(integer *, integer *, char *, integer 
	    *, char *, doublereal *, integer *, doublereal *, doublereal *, 
	    integer *, integer *, char *, doublereal *, integer *, doublereal 
	    *, integer *);
    static doublereal ainvnm;
    extern /* Subroutine */ int derrpo_(char *, integer *), dpbtrs_(
	    char *, integer *, integer *, integer *, doublereal *, integer *, 
	    doublereal *, integer *, integer *), xlaenv_(integer *, 
	    integer *);
    static doublereal result[7];
    static integer lda, ikd, inb, nkd;

    /* Fortran I/O blocks */
    static cilist io___40 = { 0, 0, 0, fmt_9999, 0 };
    static cilist io___46 = { 0, 0, 0, fmt_9998, 0 };
    static cilist io___48 = { 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   
       December 7, 1999   


    Purpose   
    =======   

    DCHKPB tests DPBTRF, -TRS, -RFS, and -CON.   

    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 dimension N.   

    NNB     (input) INTEGER   
            The number of values of NB contained in the vector NBVAL.   

    NBVAL   (input) INTEGER array, dimension (NBVAL)   
            The values of the blocksize NB.   

    NNS     (input) INTEGER   
            The number of values of NRHS contained in the vector NSVAL.   

    NSVAL   (input) INTEGER array, dimension (NNS)   
            The values of the number of right hand sides NRHS.   

    THRESH  (input) DOUBLE PRECISION   
            The threshold value for the test ratios.  A result is   
            included in the output file if RESULT >= THRESH.  To have   
            every test ratio printed, use THRESH = 0.   

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

    NMAX    (input) INTEGER   
            The maximum value permitted for N, used in dimensioning the   
            work arrays.   

    A       (workspace) DOUBLE PRECISION array, dimension (NMAX*NMAX)   

    AFAC    (workspace) DOUBLE PRECISION array, dimension (NMAX*NMAX)   

    AINV    (workspace) DOUBLE PRECISION array, dimension (NMAX*NMAX)   

    B       (workspace) DOUBLE PRECISION array, dimension (NMAX*NSMAX)   
            where NSMAX is the largest entry in NSVAL.   

    X       (workspace) DOUBLE PRECISION array, dimension (NMAX*NSMAX)   

    XACT    (workspace) DOUBLE PRECISION array, dimension (NMAX*NSMAX)   

    WORK    (workspace) DOUBLE PRECISION array, dimension   
                        (NMAX*max(3,NSMAX))   

    RWORK   (workspace) DOUBLE PRECISION array, dimension   
                        (max(NMAX,2*NSMAX))   

    IWORK   (workspace) INTEGER array, dimension (NMAX)   

    NOUT    (input) INTEGER   
            The unit number for output.   

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

       Parameter adjustments */
    --iwork;
    --rwork;
    --work;
    --xact;
    --x;
    --b;
    --ainv;
    --afac;
    --a;
    --nsval;
    --nbval;
    --nval;
    --dotype;

    /* Function Body   

       Initialize constants and the random number seed. */

    s_copy(path, "Double precision", (ftnlen)1, (ftnlen)16);
    s_copy(path + 1, "PB", (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) {
	derrpo_(path, nout);
    }
    infoc_1.infot = 0;
    xlaenv_(&c__2, &c__2);
    kdval[0] = 0;

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

    i__1 = *nn;
    for (in = 1; in <= i__1; ++in) {
	n = nval[in];
	lda = 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);
	nkd = max(i__2,i__3);
	nimat = 8;
	if (n == 0) {
	    nimat = 1;
	}

	kdval[1] = n + (n + 1) / 4;
	kdval[2] = (n * 3 - 1) / 4;
	kdval[3] = (n + 1) / 4;

	i__2 = nkd;
	for (ikd = 1; ikd <= i__2; ++ikd) {

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

	    kd = kdval[ikd - 1];
	    ldab = kd + 1;

/*           Do first for UPLO = 'U', then for UPLO = 'L' */

	    for (iuplo = 1; iuplo <= 2; ++iuplo) {
		koff = 1;
		if (iuplo == 1) {
		    *(unsigned char *)uplo = 'U';
/* Computing MAX */
		    i__3 = 1, i__4 = kd + 2 - n;
		    koff = max(i__3,i__4);
		    *(unsigned char *)packit = 'Q';
		} else {
		    *(unsigned char *)uplo = 'L';
		    *(unsigned char *)packit = 'B';
		}

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

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

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

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

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

		    if (! zerot || ! dotype[1]) {

/*                    Set up parameters with DLATB4 and generate a test   
                      matrix with DLATMS. */

			dlatb4_(path, &imat, &n, &n, type__, &kl, &ku, &anorm,
				 &mode, &cndnum, dist);

			s_copy(srnamc_1.srnamt, "DLATMS", (ftnlen)6, (ftnlen)
				6);
			dlatms_(&n, &n, dist, iseed, type__, &rwork[1], &mode,
				 &cndnum, &anorm, &kd, &kd, packit, &a[koff], 
				&ldab, &work[1], &info);

/*                    Check error code from DLATMS. */

			if (info != 0) {
			    alaerh_(path, "DLATMS", &info, &c__0, uplo, &n, &
				    n, &kd, &kd, &c_n1, &imat, &nfail, &nerrs,
				     nout);
			    goto L60;
			}
		    } else if (izero > 0) {

/*                    Use the same matrix for types 3 and 4 as for type   
                      2 by copying back the zeroed out column, */

			iw = (lda << 1) + 1;
			if (iuplo == 1) {
			    ioff = (izero - 1) * ldab + kd + 1;
			    i__4 = izero - i1;
			    dcopy_(&i__4, &work[iw], &c__1, &a[ioff - izero + 
				    i1], &c__1);
			    iw = iw + izero - i1;
			    i__4 = i2 - izero + 1;
/* Computing MAX */
			    i__6 = ldab - 1;
			    i__5 = max(i__6,1);
			    dcopy_(&i__4, &work[iw], &c__1, &a[ioff], &i__5);
			} else {
			    ioff = (i1 - 1) * ldab + 1;
			    i__4 = izero - i1;
/* Computing MAX */
			    i__6 = ldab - 1;
			    i__5 = max(i__6,1);
			    dcopy_(&i__4, &work[iw], &c__1, &a[ioff + izero - 
				    i1], &i__5);
			    ioff = (izero - 1) * ldab + 1;
			    iw = iw + izero - i1;
			    i__4 = i2 - izero + 1;
			    dcopy_(&i__4, &work[iw], &c__1, &a[ioff], &c__1);
			}
		    }

/*                 For types 2-4, zero one row and column 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;
			}

/*                    Save the zeroed out row and column in WORK(*,3) */

			iw = lda << 1;
/* Computing MIN */
			i__5 = (kd << 1) + 1;
			i__4 = min(i__5,n);
			for (i__ = 1; i__ <= i__4; ++i__) {
			    work[iw + i__] = 0.;
/* L20: */
			}
			++iw;
/* Computing MAX */
			i__4 = izero - kd;
			i1 = max(i__4,1);
/* Computing MIN */
			i__4 = izero + kd;
			i2 = min(i__4,n);

			if (iuplo == 1) {
			    ioff = (izero - 1) * ldab + kd + 1;
			    i__4 = izero - i1;
			    dswap_(&i__4, &a[ioff - izero + i1], &c__1, &work[
				    iw], &c__1);
			    iw = iw + izero - i1;
			    i__4 = i2 - izero + 1;
/* Computing MAX */
			    i__6 = ldab - 1;
			    i__5 = max(i__6,1);
			    dswap_(&i__4, &a[ioff], &i__5, &work[iw], &c__1);
			} else {
			    ioff = (i1 - 1) * ldab + 1;
			    i__4 = izero - i1;
/* Computing MAX */
			    i__6 = ldab - 1;
			    i__5 = max(i__6,1);
			    dswap_(&i__4, &a[ioff + izero - i1], &i__5, &work[
				    iw], &c__1);
			    ioff = (izero - 1) * ldab + 1;
			    iw = iw + izero - i1;
			    i__4 = i2 - izero + 1;
			    dswap_(&i__4, &a[ioff], &c__1, &work[iw], &c__1);
			}
		    }

/*                 Do for each value of NB in NBVAL */

		    i__4 = *nnb;
		    for (inb = 1; inb <= i__4; ++inb) {
			nb = nbval[inb];
			xlaenv_(&c__1, &nb);

/*                    Compute the L*L' or U'*U factorization of the band   
                      matrix. */

			i__5 = kd + 1;
			dlacpy_("Full", &i__5, &n, &a[1], &ldab, &afac[1], &
				ldab);
			s_copy(srnamc_1.srnamt, "DPBTRF", (ftnlen)6, (ftnlen)
				6);
			dpbtrf_(uplo, &n, &kd, &afac[1], &ldab, &info);

/*                    Check error code from DPBTRF. */

			if (info != izero) {
			    alaerh_(path, "DPBTRF", &info, &izero, uplo, &n, &
				    n, &kd, &kd, &nb, &imat, &nfail, &nerrs, 
				    nout);
			    goto L50;
			}

/*                    Skip the tests if INFO is not 0. */

			if (info != 0) {
			    goto L50;
			}

/* +    TEST 1   
                      Reconstruct matrix from factors and compute   
                      residual. */

			i__5 = kd + 1;
			dlacpy_("Full", &i__5, &n, &afac[1], &ldab, &ainv[1], 
				&ldab);
			dpbt01_(uplo, &n, &kd, &a[1], &ldab, &ainv[1], &ldab, 
				&rwork[1], result);

/*                    Print the test ratio if it is .GE. THRESH. */

			if (result[0] >= *thresh) {
			    if (nfail == 0 && nerrs == 0) {
				alahd_(nout, path);
			    }
			    io___40.ciunit = *nout;
			    s_wsfe(&io___40);
			    do_fio(&c__1, uplo, (ftnlen)1);
			    do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer))
				    ;
			    do_fio(&c__1, (char *)&kd, (ftnlen)sizeof(integer)
				    );
			    do_fio(&c__1, (char *)&nb, (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(
				    doublereal));
			    e_wsfe();
			    ++nfail;
			}
			++nrun;

/*                    Only do other tests if this is the first blocksize. */

			if (inb > 1) {
			    goto L50;
			}

/*                    Form the inverse of A so we can get a good estimate   
                      of RCONDC = 1/(norm(A) * norm(inv(A))). */

			dlaset_("Full", &n, &n, &c_b50, &c_b51, &ainv[1], &
				lda);
			s_copy(srnamc_1.srnamt, "DPBTRS", (ftnlen)6, (ftnlen)
				6);
			dpbtrs_(uplo, &n, &kd, &n, &afac[1], &ldab, &ainv[1], 
				&lda, &info);

/*                    Compute RCONDC = 1/(norm(A) * norm(inv(A))). */

			anorm = dlansb_("1", uplo, &n, &kd, &a[1], &ldab, &
				rwork[1]);
			ainvnm = dlange_("1", &n, &n, &ainv[1], &lda, &rwork[
				1]);
			if (anorm <= 0. || ainvnm <= 0.) {
			    rcondc = 1.;
			} else {
			    rcondc = 1. / anorm / ainvnm;
			}

			i__5 = *nns;
			for (irhs = 1; irhs <= i__5; ++irhs) {
			    nrhs = nsval[irhs];

/* +    TEST 2   
                      Solve and compute residual for A * X = B. */

			    s_copy(srnamc_1.srnamt, "DLARHS", (ftnlen)6, (
				    ftnlen)6);
			    dlarhs_(path, xtype, uplo, " ", &n, &n, &kd, &kd, 
				    &nrhs, &a[1], &ldab, &xact[1], &lda, &b[1]
				    , &lda, iseed, &info);
			    dlacpy_("Full", &n, &nrhs, &b[1], &lda, &x[1], &
				    lda);

			    s_copy(srnamc_1.srnamt, "DPBTRS", (ftnlen)6, (
				    ftnlen)6);
			    dpbtrs_(uplo, &n, &kd, &nrhs, &afac[1], &ldab, &x[
				    1], &lda, &info);

/*                    Check error code from DPBTRS. */

			    if (info != 0) {
				alaerh_(path, "DPBTRS", &info, &c__0, uplo, &
					n, &n, &kd, &kd, &nrhs, &imat, &nfail,
					 &nerrs, nout);
			    }

			    dlacpy_("Full", &n, &nrhs, &b[1], &lda, &work[1], 
				    &lda);
			    dpbt02_(uplo, &n, &kd, &nrhs, &a[1], &ldab, &x[1],
				     &lda, &work[1], &lda, &rwork[1], &result[
				    1]);

/* +    TEST 3   
                      Check solution from generated exact solution. */

			    dget04_(&n, &nrhs, &x[1], &lda, &xact[1], &lda, &
				    rcondc, &result[2]);

/* +    TESTS 4, 5, and 6   
                      Use iterative refinement to improve the solution. */

			    s_copy(srnamc_1.srnamt, "DPBRFS", (ftnlen)6, (
				    ftnlen)6);
			    dpbrfs_(uplo, &n, &kd, &nrhs, &a[1], &ldab, &afac[
				    1], &ldab, &b[1], &lda, &x[1], &lda, &
				    rwork[1], &rwork[nrhs + 1], &work[1], &
				    iwork[1], &info);

/*                    Check error code from DPBRFS. */

			    if (info != 0) {
				alaerh_(path, "DPBRFS", &info, &c__0, uplo, &
					n, &n, &kd, &kd, &nrhs, &imat, &nfail,
					 &nerrs, nout);
			    }

			    dget04_(&n, &nrhs, &x[1], &lda, &xact[1], &lda, &
				    rcondc, &result[3]);
			    dpbt05_(uplo, &n, &kd, &nrhs, &a[1], &ldab, &b[1],
				     &lda, &x[1], &lda, &xact[1], &lda, &
				    rwork[1], &rwork[nrhs + 1], &result[4]);

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

			    for (k = 2; k <= 6; ++k) {
				if (result[k - 1] >= *thresh) {
				    if (nfail == 0 && nerrs == 0) {
					alahd_(nout, path);
				    }
				    io___46.ciunit = *nout;
				    s_wsfe(&io___46);
				    do_fio(&c__1, uplo, (ftnlen)1);
				    do_fio(&c__1, (char *)&n, (ftnlen)sizeof(
					    integer));
				    do_fio(&c__1, (char *)&kd, (ftnlen)sizeof(
					    integer));
				    do_fio(&c__1, (char *)&nrhs, (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(doublereal));
				    e_wsfe();
				    ++nfail;
				}
/* L30: */
			    }
			    nrun += 5;
/* L40: */
			}

/* +    TEST 7   
                      Get an estimate of RCOND = 1/CNDNUM. */

			s_copy(srnamc_1.srnamt, "DPBCON", (ftnlen)6, (ftnlen)
				6);
			dpbcon_(uplo, &n, &kd, &afac[1], &ldab, &anorm, &
				rcond, &work[1], &iwork[1], &info);

/*                    Check error code from DPBCON. */

			if (info != 0) {
			    alaerh_(path, "DPBCON", &info, &c__0, uplo, &n, &
				    n, &kd, &kd, &c_n1, &imat, &nfail, &nerrs,
				     nout);
			}

			result[6] = dget06_(&rcond, &rcondc);

/*                    Print the test ratio if it is .GE. THRESH. */

			if (result[6] >= *thresh) {
			    if (nfail == 0 && nerrs == 0) {
				alahd_(nout, path);
			    }
			    io___48.ciunit = *nout;
			    s_wsfe(&io___48);
			    do_fio(&c__1, uplo, (ftnlen)1);
			    do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer))
				    ;
			    do_fio(&c__1, (char *)&kd, (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(
				    doublereal));
			    e_wsfe();
			    ++nfail;
			}
			++nrun;
L50:
			;
		    }
L60:
		    ;
		}
/* L70: */
	    }
/* L80: */
	}
/* L90: */
    }

/*     Print a summary of the results. */

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

    return 0;

/*     End of DCHKPB */

} /* dchkpb_ */
Beispiel #4
0
/* Subroutine */ int dsbev_(char *jobz, char *uplo, integer *n, integer *kd, 
	doublereal *ab, integer *ldab, doublereal *w, doublereal *z__, 
	integer *ldz, doublereal *work, integer *info)
{
    /* System generated locals */
    integer ab_dim1, ab_offset, z_dim1, z_offset, i__1;
    doublereal d__1;

    /* Local variables */
    doublereal eps;
    integer inde;
    doublereal anrm;
    integer imax;
    doublereal rmin, rmax;
    doublereal sigma;
    integer iinfo;
    logical lower, wantz;
    integer iscale;
    doublereal safmin;
    doublereal bignum;
    integer indwrk;
    doublereal smlnum;

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

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

/*  DSBEV computes all the eigenvalues and, optionally, eigenvectors of */
/*  a real symmetric band matrix A. */

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

/*  JOBZ    (input) CHARACTER*1 */
/*          = 'N':  Compute eigenvalues only; */
/*          = 'V':  Compute eigenvalues and eigenvectors. */

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

/*  AB      (input/output) DOUBLE PRECISION array, dimension (LDAB, N) */
/*          On entry, the upper or lower triangle of the symmetric 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). */

/*          On exit, AB is overwritten by values generated during the */
/*          reduction to tridiagonal form.  If UPLO = 'U', the first */
/*          superdiagonal and the diagonal of the tridiagonal matrix T */
/*          are returned in rows KD and KD+1 of AB, and if UPLO = 'L', */
/*          the diagonal and first subdiagonal of T are returned in the */
/*          first two rows of AB. */

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

/*  W       (output) DOUBLE PRECISION array, dimension (N) */
/*          If INFO = 0, the eigenvalues in ascending order. */

/*  Z       (output) DOUBLE PRECISION array, dimension (LDZ, N) */
/*          If JOBZ = 'V', then if INFO = 0, Z contains the orthonormal */
/*          eigenvectors of the matrix A, with the i-th column of Z */
/*          holding the eigenvector associated with W(i). */
/*          If JOBZ = 'N', then Z is not referenced. */

/*  LDZ     (input) INTEGER */
/*          The leading dimension of the array Z.  LDZ >= 1, and if */
/*          JOBZ = 'V', LDZ >= max(1,N). */

/*  WORK    (workspace) DOUBLE PRECISION array, dimension (max(1,3*N-2)) */

/*  INFO    (output) INTEGER */
/*          = 0:  successful exit */
/*          < 0:  if INFO = -i, the i-th argument had an illegal value */
/*          > 0:  if INFO = i, the algorithm failed to converge; i */
/*                off-diagonal elements of an intermediate tridiagonal */
/*                form did not converge to zero. */

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

/*     Test the input parameters. */

    /* Parameter adjustments */
    ab_dim1 = *ldab;
    ab_offset = 1 + ab_dim1;
    ab -= ab_offset;
    --w;
    z_dim1 = *ldz;
    z_offset = 1 + z_dim1;
    z__ -= z_offset;
    --work;

    /* Function Body */
    wantz = lsame_(jobz, "V");
    lower = lsame_(uplo, "L");

    *info = 0;
    if (! (wantz || lsame_(jobz, "N"))) {
	*info = -1;
    } else if (! (lower || lsame_(uplo, "U"))) {
	*info = -2;
    } else if (*n < 0) {
	*info = -3;
    } else if (*kd < 0) {
	*info = -4;
    } else if (*ldab < *kd + 1) {
	*info = -6;
    } else if (*ldz < 1 || wantz && *ldz < *n) {
	*info = -9;
    }

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

/*     Quick return if possible */

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

    if (*n == 1) {
	if (lower) {
	    w[1] = ab[ab_dim1 + 1];
	} else {
	    w[1] = ab[*kd + 1 + ab_dim1];
	}
	if (wantz) {
	    z__[z_dim1 + 1] = 1.;
	}
	return 0;
    }

/*     Get machine constants. */

    safmin = dlamch_("Safe minimum");
    eps = dlamch_("Precision");
    smlnum = safmin / eps;
    bignum = 1. / smlnum;
    rmin = sqrt(smlnum);
    rmax = sqrt(bignum);

/*     Scale matrix to allowable range, if necessary. */

    anrm = dlansb_("M", uplo, n, kd, &ab[ab_offset], ldab, &work[1]);
    iscale = 0;
    if (anrm > 0. && anrm < rmin) {
	iscale = 1;
	sigma = rmin / anrm;
    } else if (anrm > rmax) {
	iscale = 1;
	sigma = rmax / anrm;
    }
    if (iscale == 1) {
	if (lower) {
	    dlascl_("B", kd, kd, &c_b11, &sigma, n, n, &ab[ab_offset], ldab, 
		    info);
	} else {
	    dlascl_("Q", kd, kd, &c_b11, &sigma, n, n, &ab[ab_offset], ldab, 
		    info);
	}
    }

/*     Call DSBTRD to reduce symmetric band matrix to tridiagonal form. */

    inde = 1;
    indwrk = inde + *n;
    dsbtrd_(jobz, uplo, n, kd, &ab[ab_offset], ldab, &w[1], &work[inde], &z__[
	    z_offset], ldz, &work[indwrk], &iinfo);

/*     For eigenvalues only, call DSTERF.  For eigenvectors, call SSTEQR. */

    if (! wantz) {
	dsterf_(n, &w[1], &work[inde], info);
    } else {
	dsteqr_(jobz, n, &w[1], &work[inde], &z__[z_offset], ldz, &work[
		indwrk], info);
    }

/*     If matrix was scaled, then rescale eigenvalues appropriately. */

    if (iscale == 1) {
	if (*info == 0) {
	    imax = *n;
	} else {
	    imax = *info - 1;
	}
	d__1 = 1. / sigma;
	dscal_(&imax, &d__1, &w[1], &c__1);
    }

    return 0;

/*     End of DSBEV */

} /* dsbev_ */
Beispiel #5
0
/* Subroutine */ int dpbsvx_(char *fact, char *uplo, integer *n, integer *kd, 
	integer *nrhs, doublereal *ab, integer *ldab, doublereal *afb, 
	integer *ldafb, char *equed, doublereal *s, doublereal *b, integer *
	ldb, doublereal *x, integer *ldx, doublereal *rcond, doublereal *ferr,
	 doublereal *berr, doublereal *work, integer *iwork, integer *info)
{
/*  -- LAPACK driver 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   
    =======   

    DPBSVX uses the Cholesky factorization A = U**T*U or A = L*L**T to   
    compute the solution to a real system of linear equations   
       A * X = B,   
    where A is an N-by-N symmetric positive definite band matrix and X   
    and B are N-by-NRHS matrices.   

    Error bounds on the solution and a condition estimate are also   
    provided.   

    Description   
    ===========   

    The following steps are performed:   

    1. If FACT = 'E', real scaling factors are computed to equilibrate   
       the system:   
          diag(S) * A * diag(S) * inv(diag(S)) * X = diag(S) * B   
       Whether or not the system will be equilibrated depends on the   
       scaling of the matrix A, but if equilibration is used, A is   
       overwritten by diag(S)*A*diag(S) and B by diag(S)*B.   

    2. If FACT = 'N' or 'E', the Cholesky decomposition is used to   
       factor the matrix A (after equilibration if FACT = 'E') as   
          A = U**T * U,  if UPLO = 'U', or   
          A = L * L**T,  if UPLO = 'L',   
       where U is an upper triangular band matrix, and L is a lower   
       triangular band matrix.   

    3. The factored form of A is used to estimate the condition number   
       of the matrix A.  If the reciprocal of the condition number is   
       less than machine precision, steps 4-6 are skipped.   

    4. The system of equations is solved for X using the factored form   
       of A.   

    5. Iterative refinement is applied to improve the computed solution   
       matrix and calculate error bounds and backward error estimates   
       for it.   

    6. If equilibration was used, the matrix X is premultiplied by   
       diag(S) so that it solves the original system before   
       equilibration.   

    Arguments   
    =========   

    FACT    (input) CHARACTER*1   
            Specifies whether or not the factored form of the matrix A is 
  
            supplied on entry, and if not, whether the matrix A should be 
  
            equilibrated before it is factored.   
            = 'F':  On entry, AFB contains the factored form of A.   
                    If EQUED = 'Y', the matrix A has been equilibrated   
                    with scaling factors given by S.  AB and AFB will not 
  
                    be modified.   
            = 'N':  The matrix A will be copied to AFB and factored.   
            = 'E':  The matrix A will be equilibrated if necessary, then 
  
                    copied to AFB and factored.   

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

    N       (input) INTEGER   
            The number of linear equations, i.e., 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/output) DOUBLE PRECISION array, dimension (LDAB,N)   
            On entry, the upper or lower triangle of the symmetric band   
            matrix A, stored in the first KD+1 rows of the array, except 
  
            if FACT = 'F' and EQUED = 'Y', then A must contain the   
            equilibrated matrix diag(S)*A*diag(S).  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). 
  
            See below for further details.   

            On exit, if FACT = 'E' and EQUED = 'Y', A is overwritten by   
            diag(S)*A*diag(S).   

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

    AFB     (input or output) DOUBLE PRECISION array, dimension (LDAFB,N) 
  
            If FACT = 'F', then AFB is an input argument and on entry   
            contains the triangular factor U or L from the Cholesky   
            factorization A = U**T*U or A = L*L**T of the band matrix   
            A, in the same storage format as A (see AB).  If EQUED = 'Y', 
  
            then AFB is the factored form of the equilibrated matrix A.   

            If FACT = 'N', then AFB is an output argument and on exit   
            returns the triangular factor U or L from the Cholesky   
            factorization A = U**T*U or A = L*L**T.   

            If FACT = 'E', then AFB is an output argument and on exit   
            returns the triangular factor U or L from the Cholesky   
            factorization A = U**T*U or A = L*L**T of the equilibrated   
            matrix A (see the description of A for the form of the   
            equilibrated matrix).   

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

    EQUED   (input or output) CHARACTER*1   
            Specifies the form of equilibration that was done.   
            = 'N':  No equilibration (always true if FACT = 'N').   
            = 'Y':  Equilibration was done, i.e., A has been replaced by 
  
                    diag(S) * A * diag(S).   
            EQUED is an input argument if FACT = 'F'; otherwise, it is an 
  
            output argument.   

    S       (input or output) DOUBLE PRECISION array, dimension (N)   
            The scale factors for A; not accessed if EQUED = 'N'.  S is   
            an input argument if FACT = 'F'; otherwise, S is an output   
            argument.  If FACT = 'F' and EQUED = 'Y', each element of S   
            must be positive.   

    B       (input/output) DOUBLE PRECISION array, dimension (LDB,NRHS)   
            On entry, the N-by-NRHS right hand side matrix B.   
            On exit, if EQUED = 'N', B is not modified; if EQUED = 'Y',   
            B is overwritten by diag(S) * B.   

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

    X       (output) DOUBLE PRECISION array, dimension (LDX,NRHS)   
            If INFO = 0, the N-by-NRHS solution matrix X to the original 
  
            system of equations.  Note that if EQUED = 'Y', A and B are   
            modified on exit, and the solution to the equilibrated system 
  
            is inv(diag(S))*X.   

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

    RCOND   (output) DOUBLE PRECISION   
            The estimate of the reciprocal condition number of the matrix 
  
            A after equilibration (if done).  If RCOND is less than the   
            machine precision (in particular, if RCOND = 0), the matrix   
            is singular to working precision.  This condition is   
            indicated by a return code of INFO > 0, and the solution and 
  
            error bounds are not computed.   

    FERR    (output) DOUBLE PRECISION 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) DOUBLE PRECISION 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) DOUBLE PRECISION array, dimension (3*N)   

    IWORK   (workspace) INTEGER array, dimension (N)   

    INFO    (output) INTEGER   
            = 0:  successful exit   
            < 0:  if INFO = -i, the i-th argument had an illegal value   
            > 0:  if INFO = i, and i is   
                  <= N: the leading minor of order i of A is   
                       not positive definite, so the factorization could 
  
                       not be completed, and the solution has not been   
                       computed.   
                 = N+1: RCOND is less than machine precision.  The   
                       factorization has been completed, but the matrix   
                       is singular to working precision, and the solution 
  
                       and error bounds have not been computed.   

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

    The band storage scheme is illustrated by the following example, when 
  
    N = 6, KD = 2, and UPLO = 'U':   

    Two-dimensional storage of the symmetric matrix A:   

       a11  a12  a13   
            a22  a23  a24   
                 a33  a34  a35   
                      a44  a45  a46   
                           a55  a56   
       (aij=conjg(aji))         a66   

    Band storage of the upper triangle of A:   

        *    *   a13  a24  a35  a46   
        *   a12  a23  a34  a45  a56   
       a11  a22  a33  a44  a55  a66   

    Similarly, if UPLO = 'L' the format of A is as follows:   

       a11  a22  a33  a44  a55  a66   
       a21  a32  a43  a54  a65   *   
       a31  a42  a53  a64   *    *   

    VISArray elements marked * are not used by the routine.   

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


    
   Parameter adjustments   
       Function Body */
    /* Table of constant values */
    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;
    doublereal d__1, d__2;
    /* Local variables */
    static doublereal amax, smin, smax;
    static integer i, j;
    extern logical lsame_(char *, char *);
    static doublereal scond, anorm;
    extern /* Subroutine */ int dcopy_(integer *, doublereal *, integer *, 
	    doublereal *, integer *);
    static logical equil, rcequ, upper;
    static integer j1, j2;
    extern doublereal dlamch_(char *), dlansb_(char *, char *, 
	    integer *, integer *, doublereal *, integer *, doublereal *);
    extern /* Subroutine */ int dpbcon_(char *, integer *, integer *, 
	    doublereal *, integer *, doublereal *, doublereal *, doublereal *,
	     integer *, integer *), dlaqsb_(char *, integer *, 
	    integer *, doublereal *, integer *, doublereal *, doublereal *, 
	    doublereal *, char *);
    static logical nofact;
    extern /* Subroutine */ int dlacpy_(char *, integer *, integer *, 
	    doublereal *, integer *, doublereal *, integer *), 
	    xerbla_(char *, integer *), dpbequ_(char *, integer *, 
	    integer *, doublereal *, integer *, doublereal *, doublereal *, 
	    doublereal *, integer *);
    static doublereal bignum;
    extern /* Subroutine */ int dpbrfs_(char *, integer *, integer *, integer 
	    *, doublereal *, integer *, doublereal *, integer *, doublereal *,
	     integer *, doublereal *, integer *, doublereal *, doublereal *, 
	    doublereal *, integer *, integer *), dpbtrf_(char *, 
	    integer *, integer *, doublereal *, integer *, integer *);
    static integer infequ;
    extern /* Subroutine */ int dpbtrs_(char *, integer *, integer *, integer 
	    *, doublereal *, integer *, doublereal *, integer *, integer *);
    static doublereal smlnum;



#define S(I) s[(I)-1]
#define FERR(I) ferr[(I)-1]
#define BERR(I) berr[(I)-1]
#define WORK(I) work[(I)-1]
#define IWORK(I) iwork[(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;
    nofact = lsame_(fact, "N");
    equil = lsame_(fact, "E");
    upper = lsame_(uplo, "U");
    if (nofact || equil) {
	*(unsigned char *)equed = 'N';
	rcequ = FALSE_;
    } else {
	rcequ = lsame_(equed, "Y");
	smlnum = dlamch_("Safe minimum");
	bignum = 1. / smlnum;
    }

/*     Test the input parameters. */

    if (! nofact && ! equil && ! lsame_(fact, "F")) {
	*info = -1;
    } else if (! upper && ! lsame_(uplo, "L")) {
	*info = -2;
    } else if (*n < 0) {
	*info = -3;
    } else if (*kd < 0) {
	*info = -4;
    } else if (*nrhs < 0) {
	*info = -5;
    } else if (*ldab < *kd + 1) {
	*info = -7;
    } else if (*ldafb < *kd + 1) {
	*info = -9;
    } else if (lsame_(fact, "F") && ! (rcequ || lsame_(equed, "N"))) {
	*info = -10;
    } else {
	if (rcequ) {
	    smin = bignum;
	    smax = 0.;
	    i__1 = *n;
	    for (j = 1; j <= *n; ++j) {
/* Computing MIN */
		d__1 = smin, d__2 = S(j);
		smin = min(d__1,d__2);
/* Computing MAX */
		d__1 = smax, d__2 = S(j);
		smax = max(d__1,d__2);
/* L10: */
	    }
	    if (smin <= 0.) {
		*info = -11;
	    } else if (*n > 0) {
		scond = max(smin,smlnum) / min(smax,bignum);
	    } else {
		scond = 1.;
	    }
	}
	if (*info == 0) {
	    if (*ldb < max(1,*n)) {
		*info = -13;
	    } else if (*ldx < max(1,*n)) {
		*info = -15;
	    }
	}
    }

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

    if (equil) {

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

	dpbequ_(uplo, n, kd, &AB(1,1), ldab, &S(1), &scond, &amax, &
		infequ);
	if (infequ == 0) {

/*           Equilibrate the matrix. */

	    dlaqsb_(uplo, n, kd, &AB(1,1), ldab, &S(1), &scond, &amax, 
		    equed);
	    rcequ = lsame_(equed, "Y");
	}
    }

/*     Scale the right-hand side. */

    if (rcequ) {
	i__1 = *nrhs;
	for (j = 1; j <= *nrhs; ++j) {
	    i__2 = *n;
	    for (i = 1; i <= *n; ++i) {
		B(i,j) = S(i) * B(i,j);
/* L20: */
	    }
/* L30: */
	}
    }

    if (nofact || equil) {

/*        Compute the Cholesky factorization A = U'*U or A = L*L'. */

	if (upper) {
	    i__1 = *n;
	    for (j = 1; j <= *n; ++j) {
/* Computing MAX */
		i__2 = j - *kd;
		j1 = max(i__2,1);
		i__2 = j - j1 + 1;
		dcopy_(&i__2, &AB(*kd+1-j+j1,j), &c__1, &
			AFB(*kd+1-j+j1,j), &c__1);
/* L40: */
	    }
	} else {
	    i__1 = *n;
	    for (j = 1; j <= *n; ++j) {
/* Computing MIN */
		i__2 = j + *kd;
		j2 = min(i__2,*n);
		i__2 = j2 - j + 1;
		dcopy_(&i__2, &AB(1,j), &c__1, &AFB(1,j), &c__1);
/* L50: */
	    }
	}

	dpbtrf_(uplo, n, kd, &AFB(1,1), ldafb, info);

/*        Return if INFO is non-zero. */

	if (*info != 0) {
	    if (*info > 0) {
		*rcond = 0.;
	    }
	    return 0;
	}
    }

/*     Compute the norm of the matrix A. */

    anorm = dlansb_("1", uplo, n, kd, &AB(1,1), ldab, &WORK(1));

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

    dpbcon_(uplo, n, kd, &AFB(1,1), ldafb, &anorm, rcond, &WORK(1), &
	    IWORK(1), info);

/*     Return if the matrix is singular to working precision. */

    if (*rcond < dlamch_("Epsilon")) {
	*info = *n + 1;
	return 0;
    }

/*     Compute the solution matrix X. */

    dlacpy_("Full", n, nrhs, &B(1,1), ldb, &X(1,1), ldx);
    dpbtrs_(uplo, n, kd, nrhs, &AFB(1,1), ldafb, &X(1,1), ldx, 
	    info);

/*     Use iterative refinement to improve the computed solution and   
       compute error bounds and backward error estimates for it. */

    dpbrfs_(uplo, n, kd, nrhs, &AB(1,1), ldab, &AFB(1,1), ldafb, 
	    &B(1,1), ldb, &X(1,1), ldx, &FERR(1), &BERR(1), &WORK(1)
	    , &IWORK(1), info);

/*     Transform the solution matrix X to a solution of the original   
       system. */

    if (rcequ) {
	i__1 = *nrhs;
	for (j = 1; j <= *nrhs; ++j) {
	    i__2 = *n;
	    for (i = 1; i <= *n; ++i) {
		X(i,j) = S(i) * X(i,j);
/* L60: */
	    }
/* L70: */
	}
	i__1 = *nrhs;
	for (j = 1; j <= *nrhs; ++j) {
	    FERR(j) /= scond;
/* L80: */
	}
    }

    return 0;

/*     End of DPBSVX */

} /* dpbsvx_ */
Beispiel #6
0
/* Subroutine */ int dlatmr_(integer *m, integer *n, char *dist, integer *
	iseed, char *sym, doublereal *d__, integer *mode, doublereal *cond, 
	doublereal *dmax__, char *rsign, char *grade, doublereal *dl, integer 
	*model, doublereal *condl, doublereal *dr, integer *moder, doublereal 
	*condr, char *pivtng, integer *ipivot, integer *kl, integer *ku, 
	doublereal *sparse, doublereal *anorm, char *pack, doublereal *a, 
	integer *lda, integer *iwork, integer *info)
{
    /* System generated locals */
    integer a_dim1, a_offset, i__1, i__2;
    doublereal d__1, d__2, d__3;

    /* Local variables */
    static integer isub, jsub;
    static doublereal temp;
    static integer isym, i__, j, k;
    static doublereal alpha;
    extern /* Subroutine */ int dscal_(integer *, doublereal *, doublereal *, 
	    integer *);
    static integer ipack;
    extern logical lsame_(char *, char *);
    static doublereal tempa[1];
    static integer iisub, idist, jjsub, mnmin;
    static logical dzero;
    static integer mnsub;
    static doublereal onorm;
    static integer mxsub, npvts;
    extern /* Subroutine */ int dlatm1_(integer *, doublereal *, integer *, 
	    integer *, integer *, doublereal *, integer *, integer *);
    extern doublereal dlatm2_(integer *, integer *, integer *, integer *, 
	    integer *, integer *, integer *, integer *, doublereal *, integer 
	    *, doublereal *, doublereal *, integer *, integer *, doublereal *)
	    , dlatm3_(integer *, integer *, integer *, integer *, integer *, 
	    integer *, integer *, integer *, integer *, integer *, doublereal 
	    *, integer *, doublereal *, doublereal *, integer *, integer *, 
	    doublereal *), dlangb_(char *, integer *, integer *, integer *, 
	    doublereal *, integer *, doublereal *), dlange_(char *, 
	    integer *, integer *, doublereal *, integer *, doublereal *);
    static integer igrade;
    extern doublereal dlansb_(char *, char *, integer *, integer *, 
	    doublereal *, integer *, doublereal *);
    static logical fulbnd;
    extern /* Subroutine */ int xerbla_(char *, integer *);
    static logical badpvt;
    extern doublereal dlansp_(char *, char *, integer *, doublereal *, 
	    doublereal *), dlansy_(char *, char *, integer *, 
	    doublereal *, integer *, doublereal *);
    static integer irsign, ipvtng, kll, kuu;


#define a_ref(a_1,a_2) a[(a_2)*a_dim1 + a_1]


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


    Purpose   
    =======   

       DLATMR generates random matrices of various types for testing   
       LAPACK programs.   

       DLATMR operates by applying the following sequence of   
       operations:   

         Generate a matrix A with random entries of distribution DIST   
            which is symmetric if SYM='S', and nonsymmetric   
            if SYM='N'.   

         Set the diagonal to D, where D may be input or   
            computed according to MODE, COND, DMAX and RSIGN   
            as described below.   

         Grade the matrix, if desired, from the left and/or right   
            as specified by GRADE. The inputs DL, MODEL, CONDL, DR,   
            MODER and CONDR also determine the grading as described   
            below.   

         Permute, if desired, the rows and/or columns as specified by   
            PIVTNG and IPIVOT.   

         Set random entries to zero, if desired, to get a random sparse   
            matrix as specified by SPARSE.   

         Make A a band matrix, if desired, by zeroing out the matrix   
            outside a band of lower bandwidth KL and upper bandwidth KU.   

         Scale A, if desired, to have maximum entry ANORM.   

         Pack the matrix if desired. Options specified by PACK are:   
            no packing   
            zero out upper half (if symmetric)   
            zero out lower half (if symmetric)   
            store the upper half columnwise (if symmetric or   
                square upper triangular)   
            store the lower half columnwise (if symmetric or   
                square lower triangular)   
                same as upper half rowwise if symmetric   
            store the lower triangle in banded format (if symmetric)   
            store the upper triangle in banded format (if symmetric)   
            store the entire matrix in banded format   

       Note: If two calls to DLATMR differ only in the PACK parameter,   
             they will generate mathematically equivalent matrices.   

             If two calls to DLATMR both have full bandwidth (KL = M-1   
             and KU = N-1), and differ only in the PIVTNG and PACK   
             parameters, then the matrices generated will differ only   
             in the order of the rows and/or columns, and otherwise   
             contain the same data. This consistency cannot be and   
             is not maintained with less than full bandwidth.   

    Arguments   
    =========   

    M      - INTEGER   
             Number of rows of A. Not modified.   

    N      - INTEGER   
             Number of columns of A. Not modified.   

    DIST   - CHARACTER*1   
             On entry, DIST specifies the type of distribution to be used   
             to generate a random matrix .   
             'U' => UNIFORM( 0, 1 )  ( 'U' for uniform )   
             'S' => UNIFORM( -1, 1 ) ( 'S' for symmetric )   
             'N' => NORMAL( 0, 1 )   ( 'N' for normal )   
             Not modified.   

    ISEED  - INTEGER array, dimension (4)   
             On entry ISEED specifies the seed of the random number   
             generator. They should lie between 0 and 4095 inclusive,   
             and ISEED(4) should 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 DLATMR   
             to continue the same random number sequence.   
             Changed on exit.   

    SYM    - CHARACTER*1   
             If SYM='S' or 'H', generated matrix is symmetric.   
             If SYM='N', generated matrix is nonsymmetric.   
             Not modified.   

    D      - DOUBLE PRECISION array, dimension (min(M,N))   
             On entry this array specifies the diagonal entries   
             of the diagonal of A.  D may either be specified   
             on entry, or set according to MODE and COND as described   
             below. May be changed on exit if MODE is nonzero.   

    MODE   - INTEGER   
             On entry describes how D is to be used:   
             MODE = 0 means use D as input   
             MODE = 1 sets D(1)=1 and D(2:N)=1.0/COND   
             MODE = 2 sets D(1:N-1)=1 and D(N)=1.0/COND   
             MODE = 3 sets D(I)=COND**(-(I-1)/(N-1))   
             MODE = 4 sets D(i)=1 - (i-1)/(N-1)*(1 - 1/COND)   
             MODE = 5 sets D to random numbers in the range   
                      ( 1/COND , 1 ) such that their logarithms   
                      are uniformly distributed.   
             MODE = 6 set D to random numbers from same distribution   
                      as the rest of the matrix.   
             MODE < 0 has the same meaning as ABS(MODE), except that   
                the order of the elements of D is reversed.   
             Thus if MODE is positive, D has entries ranging from   
                1 to 1/COND, if negative, from 1/COND to 1,   
             Not modified.   

    COND   - DOUBLE PRECISION   
             On entry, used as described under MODE above.   
             If used, it must be >= 1. Not modified.   

    DMAX   - DOUBLE PRECISION   
             If MODE neither -6, 0 nor 6, the diagonal is scaled by   
             DMAX / max(abs(D(i))), so that maximum absolute entry   
             of diagonal is abs(DMAX). If DMAX is negative (or zero),   
             diagonal will be scaled by a negative number (or zero).   

    RSIGN  - CHARACTER*1   
             If MODE neither -6, 0 nor 6, specifies sign of diagonal   
             as follows:   
             'T' => diagonal entries are multiplied by 1 or -1   
                    with probability .5   
             'F' => diagonal unchanged   
             Not modified.   

    GRADE  - CHARACTER*1   
             Specifies grading of matrix as follows:   
             'N'  => no grading   
             'L'  => matrix premultiplied by diag( DL )   
                     (only if matrix nonsymmetric)   
             'R'  => matrix postmultiplied by diag( DR )   
                     (only if matrix nonsymmetric)   
             'B'  => matrix premultiplied by diag( DL ) and   
                           postmultiplied by diag( DR )   
                     (only if matrix nonsymmetric)   
             'S' or 'H'  => matrix premultiplied by diag( DL ) and   
                            postmultiplied by diag( DL )   
                            ('S' for symmetric, or 'H' for Hermitian)   
             'E'  => matrix premultiplied by diag( DL ) and   
                           postmultiplied by inv( diag( DL ) )   
                           ( 'E' for eigenvalue invariance)   
                     (only if matrix nonsymmetric)   
                     Note: if GRADE='E', then M must equal N.   
             Not modified.   

    DL     - DOUBLE PRECISION array, dimension (M)   
             If MODEL=0, then on entry this array specifies the diagonal   
             entries of a diagonal matrix used as described under GRADE   
             above. If MODEL is not zero, then DL will be set according   
             to MODEL and CONDL, analogous to the way D is set according   
             to MODE and COND (except there is no DMAX parameter for DL).   
             If GRADE='E', then DL cannot have zero entries.   
             Not referenced if GRADE = 'N' or 'R'. Changed on exit.   

    MODEL  - INTEGER   
             This specifies how the diagonal array DL is to be computed,   
             just as MODE specifies how D is to be computed.   
             Not modified.   

    CONDL  - DOUBLE PRECISION   
             When MODEL is not zero, this specifies the condition number   
             of the computed DL.  Not modified.   

    DR     - DOUBLE PRECISION array, dimension (N)   
             If MODER=0, then on entry this array specifies the diagonal   
             entries of a diagonal matrix used as described under GRADE   
             above. If MODER is not zero, then DR will be set according   
             to MODER and CONDR, analogous to the way D is set according   
             to MODE and COND (except there is no DMAX parameter for DR).   
             Not referenced if GRADE = 'N', 'L', 'H', 'S' or 'E'.   
             Changed on exit.   

    MODER  - INTEGER   
             This specifies how the diagonal array DR is to be computed,   
             just as MODE specifies how D is to be computed.   
             Not modified.   

    CONDR  - DOUBLE PRECISION   
             When MODER is not zero, this specifies the condition number   
             of the computed DR.  Not modified.   

    PIVTNG - CHARACTER*1   
             On entry specifies pivoting permutations as follows:   
             'N' or ' ' => none.   
             'L' => left or row pivoting (matrix must be nonsymmetric).   
             'R' => right or column pivoting (matrix must be   
                    nonsymmetric).   
             'B' or 'F' => both or full pivoting, i.e., on both sides.   
                           In this case, M must equal N   

             If two calls to DLATMR both have full bandwidth (KL = M-1   
             and KU = N-1), and differ only in the PIVTNG and PACK   
             parameters, then the matrices generated will differ only   
             in the order of the rows and/or columns, and otherwise   
             contain the same data. This consistency cannot be   
             maintained with less than full bandwidth.   

    IPIVOT - INTEGER array, dimension (N or M)   
             This array specifies the permutation used.  After the   
             basic matrix is generated, the rows, columns, or both   
             are permuted.   If, say, row pivoting is selected, DLATMR   
             starts with the *last* row and interchanges the M-th and   
             IPIVOT(M)-th rows, then moves to the next-to-last row,   
             interchanging the (M-1)-th and the IPIVOT(M-1)-th rows,   
             and so on.  In terms of "2-cycles", the permutation is   
             (1 IPIVOT(1)) (2 IPIVOT(2)) ... (M IPIVOT(M))   
             where the rightmost cycle is applied first.  This is the   
             *inverse* of the effect of pivoting in LINPACK.  The idea   
             is that factoring (with pivoting) an identity matrix   
             which has been inverse-pivoted in this way should   
             result in a pivot vector identical to IPIVOT.   
             Not referenced if PIVTNG = 'N'. Not modified.   

    SPARSE - DOUBLE PRECISION   
             On entry specifies the sparsity of the matrix if a sparse   
             matrix is to be generated. SPARSE should lie between   
             0 and 1. To generate a sparse matrix, for each matrix entry   
             a uniform ( 0, 1 ) random number x is generated and   
             compared to SPARSE; if x is larger the matrix entry   
             is unchanged and if x is smaller the entry is set   
             to zero. Thus on the average a fraction SPARSE of the   
             entries will be set to zero.   
             Not modified.   

    KL     - INTEGER   
             On entry specifies the lower bandwidth of the  matrix. For   
             example, KL=0 implies upper triangular, KL=1 implies upper   
             Hessenberg, and KL at least M-1 implies the matrix is not   
             banded. Must equal KU if matrix is symmetric.   
             Not modified.   

    KU     - INTEGER   
             On entry specifies the upper bandwidth of the  matrix. For   
             example, KU=0 implies lower triangular, KU=1 implies lower   
             Hessenberg, and KU at least N-1 implies the matrix is not   
             banded. Must equal KL if matrix is symmetric.   
             Not modified.   

    ANORM  - DOUBLE PRECISION   
             On entry specifies maximum entry of output matrix   
             (output matrix will by multiplied by a constant so that   
             its largest absolute entry equal ANORM)   
             if ANORM is nonnegative. If ANORM is negative no scaling   
             is done. Not modified.   

    PACK   - CHARACTER*1   
             On entry specifies packing of matrix as follows:   
             'N' => no packing   
             'U' => zero out all subdiagonal entries (if symmetric)   
             'L' => zero out all superdiagonal entries (if symmetric)   
             'C' => store the upper triangle columnwise   
                    (only if matrix symmetric or square upper triangular)   
             'R' => store the lower triangle columnwise   
                    (only if matrix symmetric or square lower triangular)   
                    (same as upper half rowwise if symmetric)   
             'B' => store the lower triangle in band storage scheme   
                    (only if matrix symmetric)   
             'Q' => store the upper triangle in band storage scheme   
                    (only if matrix symmetric)   
             'Z' => store the entire matrix in band storage scheme   
                        (pivoting can be provided for by using this   
                        option to store A in the trailing rows of   
                        the allocated storage)   

             Using these options, the various LAPACK packed and banded   
             storage schemes can be obtained:   
             GB               - use 'Z'   
             PB, SB or TB     - use 'B' or 'Q'   
             PP, SP or TP     - use 'C' or 'R'   

             If two calls to DLATMR differ only in the PACK parameter,   
             they will generate mathematically equivalent matrices.   
             Not modified.   

    A      - DOUBLE PRECISION array, dimension (LDA,N)   
             On exit A is the desired test matrix. Only those   
             entries of A which are significant on output   
             will be referenced (even if A is in packed or band   
             storage format). The 'unoccupied corners' of A in   
             band format will be zeroed out.   

    LDA    - INTEGER   
             on entry LDA specifies the first dimension of A as   
             declared in the calling program.   
             If PACK='N', 'U' or 'L', LDA must be at least max ( 1, M ).   
             If PACK='C' or 'R', LDA must be at least 1.   
             If PACK='B', or 'Q', LDA must be MIN ( KU+1, N )   
             If PACK='Z', LDA must be at least KUU+KLL+1, where   
             KUU = MIN ( KU, N-1 ) and KLL = MIN ( KL, N-1 )   
             Not modified.   

    IWORK  - INTEGER array, dimension ( N or M)   
             Workspace. Not referenced if PIVTNG = 'N'. Changed on exit.   

    INFO   - INTEGER   
             Error parameter on exit:   
               0 => normal return   
              -1 => M negative or unequal to N and SYM='S' or 'H'   
              -2 => N negative   
              -3 => DIST illegal string   
              -5 => SYM illegal string   
              -7 => MODE not in range -6 to 6   
              -8 => COND less than 1.0, and MODE neither -6, 0 nor 6   
             -10 => MODE neither -6, 0 nor 6 and RSIGN illegal string   
             -11 => GRADE illegal string, or GRADE='E' and   
                    M not equal to N, or GRADE='L', 'R', 'B' or 'E' and   
                    SYM = 'S' or 'H'   
             -12 => GRADE = 'E' and DL contains zero   
             -13 => MODEL not in range -6 to 6 and GRADE= 'L', 'B', 'H',   
                    'S' or 'E'   
             -14 => CONDL less than 1.0, GRADE='L', 'B', 'H', 'S' or 'E',   
                    and MODEL neither -6, 0 nor 6   
             -16 => MODER not in range -6 to 6 and GRADE= 'R' or 'B'   
             -17 => CONDR less than 1.0, GRADE='R' or 'B', and   
                    MODER neither -6, 0 nor 6   
             -18 => PIVTNG illegal string, or PIVTNG='B' or 'F' and   
                    M not equal to N, or PIVTNG='L' or 'R' and SYM='S'   
                    or 'H'   
             -19 => IPIVOT contains out of range number and   
                    PIVTNG not equal to 'N'   
             -20 => KL negative   
             -21 => KU negative, or SYM='S' or 'H' and KU not equal to KL   
             -22 => SPARSE not in range 0. to 1.   
             -24 => PACK illegal string, or PACK='U', 'L', 'B' or 'Q'   
                    and SYM='N', or PACK='C' and SYM='N' and either KL   
                    not equal to 0 or N not equal to M, or PACK='R' and   
                    SYM='N', and either KU not equal to 0 or N not equal   
                    to M   
             -26 => LDA too small   
               1 => Error return from DLATM1 (computing D)   
               2 => Cannot scale diagonal to DMAX (max. entry is 0)   
               3 => Error return from DLATM1 (computing DL)   
               4 => Error return from DLATM1 (computing DR)   
               5 => ANORM is positive, but matrix constructed prior to   
                    attempting to scale it to have norm ANORM, is zero   

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


       1)      Decode and Test the input parameters.   
               Initialize flags & seed.   

       Parameter adjustments */
    --iseed;
    --d__;
    --dl;
    --dr;
    --ipivot;
    a_dim1 = *lda;
    a_offset = 1 + a_dim1 * 1;
    a -= a_offset;
    --iwork;

    /* Function Body */
    *info = 0;

/*     Quick return if possible */

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

/*     Decode DIST */

    if (lsame_(dist, "U")) {
	idist = 1;
    } else if (lsame_(dist, "S")) {
	idist = 2;
    } else if (lsame_(dist, "N")) {
	idist = 3;
    } else {
	idist = -1;
    }

/*     Decode SYM */

    if (lsame_(sym, "S")) {
	isym = 0;
    } else if (lsame_(sym, "N")) {
	isym = 1;
    } else if (lsame_(sym, "H")) {
	isym = 0;
    } else {
	isym = -1;
    }

/*     Decode RSIGN */

    if (lsame_(rsign, "F")) {
	irsign = 0;
    } else if (lsame_(rsign, "T")) {
	irsign = 1;
    } else {
	irsign = -1;
    }

/*     Decode PIVTNG */

    if (lsame_(pivtng, "N")) {
	ipvtng = 0;
    } else if (lsame_(pivtng, " ")) {
	ipvtng = 0;
    } else if (lsame_(pivtng, "L")) {
	ipvtng = 1;
	npvts = *m;
    } else if (lsame_(pivtng, "R")) {
	ipvtng = 2;
	npvts = *n;
    } else if (lsame_(pivtng, "B")) {
	ipvtng = 3;
	npvts = min(*n,*m);
    } else if (lsame_(pivtng, "F")) {
	ipvtng = 3;
	npvts = min(*n,*m);
    } else {
	ipvtng = -1;
    }

/*     Decode GRADE */

    if (lsame_(grade, "N")) {
	igrade = 0;
    } else if (lsame_(grade, "L")) {
	igrade = 1;
    } else if (lsame_(grade, "R")) {
	igrade = 2;
    } else if (lsame_(grade, "B")) {
	igrade = 3;
    } else if (lsame_(grade, "E")) {
	igrade = 4;
    } else if (lsame_(grade, "H") || lsame_(grade, 
	    "S")) {
	igrade = 5;
    } else {
	igrade = -1;
    }

/*     Decode PACK */

    if (lsame_(pack, "N")) {
	ipack = 0;
    } else if (lsame_(pack, "U")) {
	ipack = 1;
    } else if (lsame_(pack, "L")) {
	ipack = 2;
    } else if (lsame_(pack, "C")) {
	ipack = 3;
    } else if (lsame_(pack, "R")) {
	ipack = 4;
    } else if (lsame_(pack, "B")) {
	ipack = 5;
    } else if (lsame_(pack, "Q")) {
	ipack = 6;
    } else if (lsame_(pack, "Z")) {
	ipack = 7;
    } else {
	ipack = -1;
    }

/*     Set certain internal parameters */

    mnmin = min(*m,*n);
/* Computing MIN */
    i__1 = *kl, i__2 = *m - 1;
    kll = min(i__1,i__2);
/* Computing MIN */
    i__1 = *ku, i__2 = *n - 1;
    kuu = min(i__1,i__2);

/*     If inv(DL) is used, check to see if DL has a zero entry. */

    dzero = FALSE_;
    if (igrade == 4 && *model == 0) {
	i__1 = *m;
	for (i__ = 1; i__ <= i__1; ++i__) {
	    if (dl[i__] == 0.) {
		dzero = TRUE_;
	    }
/* L10: */
	}
    }

/*     Check values in IPIVOT */

    badpvt = FALSE_;
    if (ipvtng > 0) {
	i__1 = npvts;
	for (j = 1; j <= i__1; ++j) {
	    if (ipivot[j] <= 0 || ipivot[j] > npvts) {
		badpvt = TRUE_;
	    }
/* L20: */
	}
    }

/*     Set INFO if an error */

    if (*m < 0) {
	*info = -1;
    } else if (*m != *n && isym == 0) {
	*info = -1;
    } else if (*n < 0) {
	*info = -2;
    } else if (idist == -1) {
	*info = -3;
    } else if (isym == -1) {
	*info = -5;
    } else if (*mode < -6 || *mode > 6) {
	*info = -7;
    } else if (*mode != -6 && *mode != 0 && *mode != 6 && *cond < 1.) {
	*info = -8;
    } else if (*mode != -6 && *mode != 0 && *mode != 6 && irsign == -1) {
	*info = -10;
    } else if (igrade == -1 || igrade == 4 && *m != *n || igrade >= 1 && 
	    igrade <= 4 && isym == 0) {
	*info = -11;
    } else if (igrade == 4 && dzero) {
	*info = -12;
    } else if ((igrade == 1 || igrade == 3 || igrade == 4 || igrade == 5) && (
	    *model < -6 || *model > 6)) {
	*info = -13;
    } else if ((igrade == 1 || igrade == 3 || igrade == 4 || igrade == 5) && (
	    *model != -6 && *model != 0 && *model != 6) && *condl < 1.) {
	*info = -14;
    } else if ((igrade == 2 || igrade == 3) && (*moder < -6 || *moder > 6)) {
	*info = -16;
    } else if ((igrade == 2 || igrade == 3) && (*moder != -6 && *moder != 0 &&
	     *moder != 6) && *condr < 1.) {
	*info = -17;
    } else if (ipvtng == -1 || ipvtng == 3 && *m != *n || (ipvtng == 1 || 
	    ipvtng == 2) && isym == 0) {
	*info = -18;
    } else if (ipvtng != 0 && badpvt) {
	*info = -19;
    } else if (*kl < 0) {
	*info = -20;
    } else if (*ku < 0 || isym == 0 && *kl != *ku) {
	*info = -21;
    } else if (*sparse < 0. || *sparse > 1.) {
	*info = -22;
    } else if (ipack == -1 || (ipack == 1 || ipack == 2 || ipack == 5 || 
	    ipack == 6) && isym == 1 || ipack == 3 && isym == 1 && (*kl != 0 
	    || *m != *n) || ipack == 4 && isym == 1 && (*ku != 0 || *m != *n))
	     {
	*info = -24;
    } else if ((ipack == 0 || ipack == 1 || ipack == 2) && *lda < max(1,*m) ||
	     (ipack == 3 || ipack == 4) && *lda < 1 || (ipack == 5 || ipack ==
	     6) && *lda < kuu + 1 || ipack == 7 && *lda < kll + kuu + 1) {
	*info = -26;
    }

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

/*     Decide if we can pivot consistently */

    fulbnd = FALSE_;
    if (kuu == *n - 1 && kll == *m - 1) {
	fulbnd = TRUE_;
    }

/*     Initialize random number generator */

    for (i__ = 1; i__ <= 4; ++i__) {
	iseed[i__] = (i__1 = iseed[i__], abs(i__1)) % 4096;
/* L30: */
    }

    iseed[4] = (iseed[4] / 2 << 1) + 1;

/*     2)      Set up D, DL, and DR, if indicated.   

               Compute D according to COND and MODE */

    dlatm1_(mode, cond, &irsign, &idist, &iseed[1], &d__[1], &mnmin, info);
    if (*info != 0) {
	*info = 1;
	return 0;
    }
    if (*mode != 0 && *mode != -6 && *mode != 6) {

/*        Scale by DMAX */

	temp = abs(d__[1]);
	i__1 = mnmin;
	for (i__ = 2; i__ <= i__1; ++i__) {
/* Computing MAX */
	    d__2 = temp, d__3 = (d__1 = d__[i__], abs(d__1));
	    temp = max(d__2,d__3);
/* L40: */
	}
	if (temp == 0. && *dmax__ != 0.) {
	    *info = 2;
	    return 0;
	}
	if (temp != 0.) {
	    alpha = *dmax__ / temp;
	} else {
	    alpha = 1.;
	}
	i__1 = mnmin;
	for (i__ = 1; i__ <= i__1; ++i__) {
	    d__[i__] = alpha * d__[i__];
/* L50: */
	}

    }

/*     Compute DL if grading set */

    if (igrade == 1 || igrade == 3 || igrade == 4 || igrade == 5) {
	dlatm1_(model, condl, &c__0, &idist, &iseed[1], &dl[1], m, info);
	if (*info != 0) {
	    *info = 3;
	    return 0;
	}
    }

/*     Compute DR if grading set */

    if (igrade == 2 || igrade == 3) {
	dlatm1_(moder, condr, &c__0, &idist, &iseed[1], &dr[1], n, info);
	if (*info != 0) {
	    *info = 4;
	    return 0;
	}
    }

/*     3)     Generate IWORK if pivoting */

    if (ipvtng > 0) {
	i__1 = npvts;
	for (i__ = 1; i__ <= i__1; ++i__) {
	    iwork[i__] = i__;
/* L60: */
	}
	if (fulbnd) {
	    i__1 = npvts;
	    for (i__ = 1; i__ <= i__1; ++i__) {
		k = ipivot[i__];
		j = iwork[i__];
		iwork[i__] = iwork[k];
		iwork[k] = j;
/* L70: */
	    }
	} else {
	    for (i__ = npvts; i__ >= 1; --i__) {
		k = ipivot[i__];
		j = iwork[i__];
		iwork[i__] = iwork[k];
		iwork[k] = j;
/* L80: */
	    }
	}
    }

/*     4)      Generate matrices for each kind of PACKing   
               Always sweep matrix columnwise (if symmetric, upper   
               half only) so that matrix generated does not depend   
               on PACK */

    if (fulbnd) {

/*        Use DLATM3 so matrices generated with differing PIVOTing only   
          differ only in the order of their rows and/or columns. */

	if (ipack == 0) {
	    if (isym == 0) {
		i__1 = *n;
		for (j = 1; j <= i__1; ++j) {
		    i__2 = j;
		    for (i__ = 1; i__ <= i__2; ++i__) {
			temp = dlatm3_(m, n, &i__, &j, &isub, &jsub, kl, ku, &
				idist, &iseed[1], &d__[1], &igrade, &dl[1], &
				dr[1], &ipvtng, &iwork[1], sparse);
			a_ref(isub, jsub) = temp;
			a_ref(jsub, isub) = temp;
/* L90: */
		    }
/* L100: */
		}
	    } else if (isym == 1) {
		i__1 = *n;
		for (j = 1; j <= i__1; ++j) {
		    i__2 = *m;
		    for (i__ = 1; i__ <= i__2; ++i__) {
			temp = dlatm3_(m, n, &i__, &j, &isub, &jsub, kl, ku, &
				idist, &iseed[1], &d__[1], &igrade, &dl[1], &
				dr[1], &ipvtng, &iwork[1], sparse);
			a_ref(isub, jsub) = temp;
/* L110: */
		    }
/* L120: */
		}
	    }

	} else if (ipack == 1) {

	    i__1 = *n;
	    for (j = 1; j <= i__1; ++j) {
		i__2 = j;
		for (i__ = 1; i__ <= i__2; ++i__) {
		    temp = dlatm3_(m, n, &i__, &j, &isub, &jsub, kl, ku, &
			    idist, &iseed[1], &d__[1], &igrade, &dl[1], &dr[1]
			    , &ipvtng, &iwork[1], sparse);
		    mnsub = min(isub,jsub);
		    mxsub = max(isub,jsub);
		    a_ref(mnsub, mxsub) = temp;
		    if (mnsub != mxsub) {
			a_ref(mxsub, mnsub) = 0.;
		    }
/* L130: */
		}
/* L140: */
	    }

	} else if (ipack == 2) {

	    i__1 = *n;
	    for (j = 1; j <= i__1; ++j) {
		i__2 = j;
		for (i__ = 1; i__ <= i__2; ++i__) {
		    temp = dlatm3_(m, n, &i__, &j, &isub, &jsub, kl, ku, &
			    idist, &iseed[1], &d__[1], &igrade, &dl[1], &dr[1]
			    , &ipvtng, &iwork[1], sparse);
		    mnsub = min(isub,jsub);
		    mxsub = max(isub,jsub);
		    a_ref(mxsub, mnsub) = temp;
		    if (mnsub != mxsub) {
			a_ref(mnsub, mxsub) = 0.;
		    }
/* L150: */
		}
/* L160: */
	    }

	} else if (ipack == 3) {

	    i__1 = *n;
	    for (j = 1; j <= i__1; ++j) {
		i__2 = j;
		for (i__ = 1; i__ <= i__2; ++i__) {
		    temp = dlatm3_(m, n, &i__, &j, &isub, &jsub, kl, ku, &
			    idist, &iseed[1], &d__[1], &igrade, &dl[1], &dr[1]
			    , &ipvtng, &iwork[1], sparse);

/*                 Compute K = location of (ISUB,JSUB) entry in packed   
                   array */

		    mnsub = min(isub,jsub);
		    mxsub = max(isub,jsub);
		    k = mxsub * (mxsub - 1) / 2 + mnsub;

/*                 Convert K to (IISUB,JJSUB) location */

		    jjsub = (k - 1) / *lda + 1;
		    iisub = k - *lda * (jjsub - 1);

		    a_ref(iisub, jjsub) = temp;
/* L170: */
		}
/* L180: */
	    }

	} else if (ipack == 4) {

	    i__1 = *n;
	    for (j = 1; j <= i__1; ++j) {
		i__2 = j;
		for (i__ = 1; i__ <= i__2; ++i__) {
		    temp = dlatm3_(m, n, &i__, &j, &isub, &jsub, kl, ku, &
			    idist, &iseed[1], &d__[1], &igrade, &dl[1], &dr[1]
			    , &ipvtng, &iwork[1], sparse);

/*                 Compute K = location of (I,J) entry in packed array */

		    mnsub = min(isub,jsub);
		    mxsub = max(isub,jsub);
		    if (mnsub == 1) {
			k = mxsub;
		    } else {
			k = *n * (*n + 1) / 2 - (*n - mnsub + 1) * (*n - 
				mnsub + 2) / 2 + mxsub - mnsub + 1;
		    }

/*                 Convert K to (IISUB,JJSUB) location */

		    jjsub = (k - 1) / *lda + 1;
		    iisub = k - *lda * (jjsub - 1);

		    a_ref(iisub, jjsub) = temp;
/* L190: */
		}
/* L200: */
	    }

	} else if (ipack == 5) {

	    i__1 = *n;
	    for (j = 1; j <= i__1; ++j) {
		i__2 = j;
		for (i__ = j - kuu; i__ <= i__2; ++i__) {
		    if (i__ < 1) {
			a_ref(j - i__ + 1, i__ + *n) = 0.;
		    } else {
			temp = dlatm3_(m, n, &i__, &j, &isub, &jsub, kl, ku, &
				idist, &iseed[1], &d__[1], &igrade, &dl[1], &
				dr[1], &ipvtng, &iwork[1], sparse);
			mnsub = min(isub,jsub);
			mxsub = max(isub,jsub);
			a_ref(mxsub - mnsub + 1, mnsub) = temp;
		    }
/* L210: */
		}
/* L220: */
	    }

	} else if (ipack == 6) {

	    i__1 = *n;
	    for (j = 1; j <= i__1; ++j) {
		i__2 = j;
		for (i__ = j - kuu; i__ <= i__2; ++i__) {
		    temp = dlatm3_(m, n, &i__, &j, &isub, &jsub, kl, ku, &
			    idist, &iseed[1], &d__[1], &igrade, &dl[1], &dr[1]
			    , &ipvtng, &iwork[1], sparse);
		    mnsub = min(isub,jsub);
		    mxsub = max(isub,jsub);
		    a_ref(mnsub - mxsub + kuu + 1, mxsub) = temp;
/* L230: */
		}
/* L240: */
	    }

	} else if (ipack == 7) {

	    if (isym == 0) {
		i__1 = *n;
		for (j = 1; j <= i__1; ++j) {
		    i__2 = j;
		    for (i__ = j - kuu; i__ <= i__2; ++i__) {
			temp = dlatm3_(m, n, &i__, &j, &isub, &jsub, kl, ku, &
				idist, &iseed[1], &d__[1], &igrade, &dl[1], &
				dr[1], &ipvtng, &iwork[1], sparse);
			mnsub = min(isub,jsub);
			mxsub = max(isub,jsub);
			a_ref(mnsub - mxsub + kuu + 1, mxsub) = temp;
			if (i__ < 1) {
			    a_ref(j - i__ + 1 + kuu, i__ + *n) = 0.;
			}
			if (i__ >= 1 && mnsub != mxsub) {
			    a_ref(mxsub - mnsub + 1 + kuu, mnsub) = temp;
			}
/* L250: */
		    }
/* L260: */
		}
	    } else if (isym == 1) {
		i__1 = *n;
		for (j = 1; j <= i__1; ++j) {
		    i__2 = j + kll;
		    for (i__ = j - kuu; i__ <= i__2; ++i__) {
			temp = dlatm3_(m, n, &i__, &j, &isub, &jsub, kl, ku, &
				idist, &iseed[1], &d__[1], &igrade, &dl[1], &
				dr[1], &ipvtng, &iwork[1], sparse);
			a_ref(isub - jsub + kuu + 1, jsub) = temp;
/* L270: */
		    }
/* L280: */
		}
	    }

	}

    } else {

/*        Use DLATM2 */

	if (ipack == 0) {
	    if (isym == 0) {
		i__1 = *n;
		for (j = 1; j <= i__1; ++j) {
		    i__2 = j;
		    for (i__ = 1; i__ <= i__2; ++i__) {
			a_ref(i__, j) = dlatm2_(m, n, &i__, &j, kl, ku, &
				idist, &iseed[1], &d__[1], &igrade, &dl[1], &
				dr[1], &ipvtng, &iwork[1], sparse);
			a_ref(j, i__) = a_ref(i__, j);
/* L290: */
		    }
/* L300: */
		}
	    } else if (isym == 1) {
		i__1 = *n;
		for (j = 1; j <= i__1; ++j) {
		    i__2 = *m;
		    for (i__ = 1; i__ <= i__2; ++i__) {
			a_ref(i__, j) = dlatm2_(m, n, &i__, &j, kl, ku, &
				idist, &iseed[1], &d__[1], &igrade, &dl[1], &
				dr[1], &ipvtng, &iwork[1], sparse);
/* L310: */
		    }
/* L320: */
		}
	    }

	} else if (ipack == 1) {

	    i__1 = *n;
	    for (j = 1; j <= i__1; ++j) {
		i__2 = j;
		for (i__ = 1; i__ <= i__2; ++i__) {
		    a_ref(i__, j) = dlatm2_(m, n, &i__, &j, kl, ku, &idist, &
			    iseed[1], &d__[1], &igrade, &dl[1], &dr[1], &
			    ipvtng, &iwork[1], sparse);
		    if (i__ != j) {
			a_ref(j, i__) = 0.;
		    }
/* L330: */
		}
/* L340: */
	    }

	} else if (ipack == 2) {

	    i__1 = *n;
	    for (j = 1; j <= i__1; ++j) {
		i__2 = j;
		for (i__ = 1; i__ <= i__2; ++i__) {
		    a_ref(j, i__) = dlatm2_(m, n, &i__, &j, kl, ku, &idist, &
			    iseed[1], &d__[1], &igrade, &dl[1], &dr[1], &
			    ipvtng, &iwork[1], sparse);
		    if (i__ != j) {
			a_ref(i__, j) = 0.;
		    }
/* L350: */
		}
/* L360: */
	    }

	} else if (ipack == 3) {

	    isub = 0;
	    jsub = 1;
	    i__1 = *n;
	    for (j = 1; j <= i__1; ++j) {
		i__2 = j;
		for (i__ = 1; i__ <= i__2; ++i__) {
		    ++isub;
		    if (isub > *lda) {
			isub = 1;
			++jsub;
		    }
		    a_ref(isub, jsub) = dlatm2_(m, n, &i__, &j, kl, ku, &
			    idist, &iseed[1], &d__[1], &igrade, &dl[1], &dr[1]
			    , &ipvtng, &iwork[1], sparse);
/* L370: */
		}
/* L380: */
	    }

	} else if (ipack == 4) {

	    if (isym == 0) {
		i__1 = *n;
		for (j = 1; j <= i__1; ++j) {
		    i__2 = j;
		    for (i__ = 1; i__ <= i__2; ++i__) {

/*                    Compute K = location of (I,J) entry in packed array */

			if (i__ == 1) {
			    k = j;
			} else {
			    k = *n * (*n + 1) / 2 - (*n - i__ + 1) * (*n - 
				    i__ + 2) / 2 + j - i__ + 1;
			}

/*                    Convert K to (ISUB,JSUB) location */

			jsub = (k - 1) / *lda + 1;
			isub = k - *lda * (jsub - 1);

			a_ref(isub, jsub) = dlatm2_(m, n, &i__, &j, kl, ku, &
				idist, &iseed[1], &d__[1], &igrade, &dl[1], &
				dr[1], &ipvtng, &iwork[1], sparse);
/* L390: */
		    }
/* L400: */
		}
	    } else {
		isub = 0;
		jsub = 1;
		i__1 = *n;
		for (j = 1; j <= i__1; ++j) {
		    i__2 = *m;
		    for (i__ = j; i__ <= i__2; ++i__) {
			++isub;
			if (isub > *lda) {
			    isub = 1;
			    ++jsub;
			}
			a_ref(isub, jsub) = dlatm2_(m, n, &i__, &j, kl, ku, &
				idist, &iseed[1], &d__[1], &igrade, &dl[1], &
				dr[1], &ipvtng, &iwork[1], sparse);
/* L410: */
		    }
/* L420: */
		}
	    }

	} else if (ipack == 5) {

	    i__1 = *n;
	    for (j = 1; j <= i__1; ++j) {
		i__2 = j;
		for (i__ = j - kuu; i__ <= i__2; ++i__) {
		    if (i__ < 1) {
			a_ref(j - i__ + 1, i__ + *n) = 0.;
		    } else {
			a_ref(j - i__ + 1, i__) = dlatm2_(m, n, &i__, &j, kl, 
				ku, &idist, &iseed[1], &d__[1], &igrade, &dl[
				1], &dr[1], &ipvtng, &iwork[1], sparse);
		    }
/* L430: */
		}
/* L440: */
	    }

	} else if (ipack == 6) {

	    i__1 = *n;
	    for (j = 1; j <= i__1; ++j) {
		i__2 = j;
		for (i__ = j - kuu; i__ <= i__2; ++i__) {
		    a_ref(i__ - j + kuu + 1, j) = dlatm2_(m, n, &i__, &j, kl, 
			    ku, &idist, &iseed[1], &d__[1], &igrade, &dl[1], &
			    dr[1], &ipvtng, &iwork[1], sparse);
/* L450: */
		}
/* L460: */
	    }

	} else if (ipack == 7) {

	    if (isym == 0) {
		i__1 = *n;
		for (j = 1; j <= i__1; ++j) {
		    i__2 = j;
		    for (i__ = j - kuu; i__ <= i__2; ++i__) {
			a_ref(i__ - j + kuu + 1, j) = dlatm2_(m, n, &i__, &j, 
				kl, ku, &idist, &iseed[1], &d__[1], &igrade, &
				dl[1], &dr[1], &ipvtng, &iwork[1], sparse);
			if (i__ < 1) {
			    a_ref(j - i__ + 1 + kuu, i__ + *n) = 0.;
			}
			if (i__ >= 1 && i__ != j) {
			    a_ref(j - i__ + 1 + kuu, i__) = a_ref(i__ - j + 
				    kuu + 1, j);
			}
/* L470: */
		    }
/* L480: */
		}
	    } else if (isym == 1) {
		i__1 = *n;
		for (j = 1; j <= i__1; ++j) {
		    i__2 = j + kll;
		    for (i__ = j - kuu; i__ <= i__2; ++i__) {
			a_ref(i__ - j + kuu + 1, j) = dlatm2_(m, n, &i__, &j, 
				kl, ku, &idist, &iseed[1], &d__[1], &igrade, &
				dl[1], &dr[1], &ipvtng, &iwork[1], sparse);
/* L490: */
		    }
/* L500: */
		}
	    }

	}

    }

/*     5)      Scaling the norm */

    if (ipack == 0) {
	onorm = dlange_("M", m, n, &a[a_offset], lda, tempa);
    } else if (ipack == 1) {
	onorm = dlansy_("M", "U", n, &a[a_offset], lda, tempa);
    } else if (ipack == 2) {
	onorm = dlansy_("M", "L", n, &a[a_offset], lda, tempa);
    } else if (ipack == 3) {
	onorm = dlansp_("M", "U", n, &a[a_offset], tempa);
    } else if (ipack == 4) {
	onorm = dlansp_("M", "L", n, &a[a_offset], tempa);
    } else if (ipack == 5) {
	onorm = dlansb_("M", "L", n, &kll, &a[a_offset], lda, tempa);
    } else if (ipack == 6) {
	onorm = dlansb_("M", "U", n, &kuu, &a[a_offset], lda, tempa);
    } else if (ipack == 7) {
	onorm = dlangb_("M", n, &kll, &kuu, &a[a_offset], lda, tempa);
    }

    if (*anorm >= 0.) {

	if (*anorm > 0. && onorm == 0.) {

/*           Desired scaling impossible */

	    *info = 5;
	    return 0;

	} else if (*anorm > 1. && onorm < 1. || *anorm < 1. && onorm > 1.) {

/*           Scale carefully to avoid over / underflow */

	    if (ipack <= 2) {
		i__1 = *n;
		for (j = 1; j <= i__1; ++j) {
		    d__1 = 1. / onorm;
		    dscal_(m, &d__1, &a_ref(1, j), &c__1);
		    dscal_(m, anorm, &a_ref(1, j), &c__1);
/* L510: */
		}

	    } else if (ipack == 3 || ipack == 4) {

		i__1 = *n * (*n + 1) / 2;
		d__1 = 1. / onorm;
		dscal_(&i__1, &d__1, &a[a_offset], &c__1);
		i__1 = *n * (*n + 1) / 2;
		dscal_(&i__1, anorm, &a[a_offset], &c__1);

	    } else if (ipack >= 5) {

		i__1 = *n;
		for (j = 1; j <= i__1; ++j) {
		    i__2 = kll + kuu + 1;
		    d__1 = 1. / onorm;
		    dscal_(&i__2, &d__1, &a_ref(1, j), &c__1);
		    i__2 = kll + kuu + 1;
		    dscal_(&i__2, anorm, &a_ref(1, j), &c__1);
/* L520: */
		}

	    }

	} else {

/*           Scale straightforwardly */

	    if (ipack <= 2) {
		i__1 = *n;
		for (j = 1; j <= i__1; ++j) {
		    d__1 = *anorm / onorm;
		    dscal_(m, &d__1, &a_ref(1, j), &c__1);
/* L530: */
		}

	    } else if (ipack == 3 || ipack == 4) {

		i__1 = *n * (*n + 1) / 2;
		d__1 = *anorm / onorm;
		dscal_(&i__1, &d__1, &a[a_offset], &c__1);

	    } else if (ipack >= 5) {

		i__1 = *n;
		for (j = 1; j <= i__1; ++j) {
		    i__2 = kll + kuu + 1;
		    d__1 = *anorm / onorm;
		    dscal_(&i__2, &d__1, &a_ref(1, j), &c__1);
/* L540: */
		}
	    }

	}

    }

/*     End of DLATMR */

    return 0;
} /* dlatmr_ */
Beispiel #7
0
/* Subroutine */ int dpbt02_(char *uplo, integer *n, integer *kd, integer *
	nrhs, doublereal *a, integer *lda, doublereal *x, integer *ldx, 
	doublereal *b, integer *ldb, doublereal *rwork, doublereal *resid)
{
    /* System generated locals */
    integer a_dim1, a_offset, b_dim1, b_offset, x_dim1, x_offset, i__1;
    doublereal d__1, d__2;

    /* Local variables */
    integer j;
    doublereal eps;
    extern doublereal dasum_(integer *, doublereal *, integer *);
    extern /* Subroutine */ int dsbmv_(char *, integer *, integer *, 
	    doublereal *, doublereal *, integer *, doublereal *, integer *, 
	    doublereal *, doublereal *, integer *);
    doublereal anorm, bnorm, xnorm;
    extern doublereal dlamch_(char *), dlansb_(char *, char *, 
	    integer *, integer *, doublereal *, integer *, doublereal *);


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

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

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

/*  DPBT02 computes the residual for a solution of a symmetric banded */
/*  system of equations  A*x = b: */
/*     RESID = norm( B - A*X ) / ( norm(A) * norm(X) * EPS) */
/*  where EPS is the machine precision. */

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

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

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

/*  KD      (input) INTEGER */
/*          The number of super-diagonals of the matrix A if UPLO = 'U', */
/*          or the number of sub-diagonals if UPLO = 'L'.  KD >= 0. */

/*  A       (input) DOUBLE PRECISION array, dimension (LDA,N) */
/*          The original symmetric band matrix A.  If UPLO = 'U', the */
/*          upper triangular part of A is stored as a band matrix; if */
/*          UPLO = 'L', the lower triangular part of A is stored.  The */
/*          columns of the appropriate triangle are stored in the columns */
/*          of A and the diagonals of the triangle are stored in the rows */
/*          of A.  See DPBTRF for further details. */

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

/*  X       (input) DOUBLE PRECISION array, dimension (LDX,NRHS) */
/*          The computed solution vectors for the system of linear */
/*          equations. */

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

/*  B       (input/output) DOUBLE PRECISION array, dimension (LDB,NRHS) */
/*          On entry, the right hand side vectors for the system of */
/*          linear equations. */
/*          On exit, B is overwritten with the difference B - A*X. */

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

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

/*  RESID   (output) DOUBLE PRECISION */
/*          The maximum over the number of right hand sides of */
/*          norm(B - A*X) / ( norm(A) * norm(X) * EPS ). */

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

/*     .. Parameters .. */
/*     .. */
/*     .. Local Scalars .. */
/*     .. */
/*     .. External Functions .. */
/*     .. */
/*     .. External Subroutines .. */
/*     .. */
/*     .. 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;
    x_dim1 = *ldx;
    x_offset = 1 + x_dim1;
    x -= x_offset;
    b_dim1 = *ldb;
    b_offset = 1 + b_dim1;
    b -= b_offset;
    --rwork;

    /* Function Body */
    if (*n <= 0 || *nrhs <= 0) {
	*resid = 0.;
	return 0;
    }

/*     Exit with RESID = 1/EPS if ANORM = 0. */

    eps = dlamch_("Epsilon");
    anorm = dlansb_("1", uplo, n, kd, &a[a_offset], lda, &rwork[1]);
    if (anorm <= 0.) {
	*resid = 1. / eps;
	return 0;
    }

/*     Compute  B - A*X */

    i__1 = *nrhs;
    for (j = 1; j <= i__1; ++j) {
	dsbmv_(uplo, n, kd, &c_b5, &a[a_offset], lda, &x[j * x_dim1 + 1], &
		c__1, &c_b7, &b[j * b_dim1 + 1], &c__1);
/* L10: */
    }

/*     Compute the maximum over the number of right hand sides of */
/*          norm( B - A*X ) / ( norm(A) * norm(X) * EPS ) */

    *resid = 0.;
    i__1 = *nrhs;
    for (j = 1; j <= i__1; ++j) {
	bnorm = dasum_(n, &b[j * b_dim1 + 1], &c__1);
	xnorm = dasum_(n, &x[j * x_dim1 + 1], &c__1);
	if (xnorm <= 0.) {
	    *resid = 1. / eps;
	} else {
/* Computing MAX */
	    d__1 = *resid, d__2 = bnorm / anorm / xnorm / eps;
	    *resid = max(d__1,d__2);
	}
/* L20: */
    }

    return 0;

/*     End of DPBT02 */

} /* dpbt02_ */
Beispiel #8
0
/* Subroutine */ int dsbt21_(char *uplo, integer *n, integer *ka, integer *ks, 
	 doublereal *a, integer *lda, doublereal *d__, doublereal *e, 
	doublereal *u, integer *ldu, doublereal *work, doublereal *result)
{
    /* System generated locals */
    integer a_dim1, a_offset, u_dim1, u_offset, i__1, i__2, i__3, i__4;
    doublereal d__1, d__2;

    /* Local variables */
    integer j, jc, jr, lw, ika;
    doublereal ulp, unfl;
    extern /* Subroutine */ int dspr_(char *, integer *, doublereal *, 
	    doublereal *, integer *, doublereal *), dspr2_(char *, 
	    integer *, doublereal *, doublereal *, integer *, doublereal *, 
	    integer *, doublereal *), dgemm_(char *, char *, integer *
, integer *, integer *, doublereal *, doublereal *, integer *, 
	    doublereal *, integer *, doublereal *, doublereal *, integer *);
    extern logical lsame_(char *, char *);
    doublereal anorm;
    char cuplo[1];
    logical lower;
    doublereal wnorm;
    extern doublereal dlamch_(char *), dlange_(char *, integer *, 
	    integer *, doublereal *, integer *, doublereal *), 
	    dlansb_(char *, char *, integer *, integer *, doublereal *, 
	    integer *, doublereal *), dlansp_(char *, char *, 
	    integer *, doublereal *, doublereal *);


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

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

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

/*  DSBT21  generally checks a decomposition of the form */

/*          A = U S U' */

/*  where ' means transpose, A is symmetric banded, U is */
/*  orthogonal, and S is diagonal (if KS=0) or symmetric */
/*  tridiagonal (if KS=1). */

/*  Specifically: */

/*          RESULT(1) = | A - U S U' | / ( |A| n ulp ) *and* */
/*          RESULT(2) = | I - UU' | / ( n ulp ) */

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

/*  UPLO    (input) CHARACTER */
/*          If UPLO='U', the upper triangle of A and V will be used and */
/*          the (strictly) lower triangle will not be referenced. */
/*          If UPLO='L', the lower triangle of A and V will be used and */
/*          the (strictly) upper triangle will not be referenced. */

/*  N       (input) INTEGER */
/*          The size of the matrix.  If it is zero, DSBT21 does nothing. */
/*          It must be at least zero. */

/*  KA      (input) INTEGER */
/*          The bandwidth of the matrix A.  It must be at least zero.  If */
/*          it is larger than N-1, then max( 0, N-1 ) will be used. */

/*  KS      (input) INTEGER */
/*          The bandwidth of the matrix S.  It may only be zero or one. */
/*          If zero, then S is diagonal, and E is not referenced.  If */
/*          one, then S is symmetric tri-diagonal. */

/*  A       (input) DOUBLE PRECISION array, dimension (LDA, N) */
/*          The original (unfactored) matrix.  It is assumed to be */
/*          symmetric, and only the upper (UPLO='U') or only the lower */
/*          (UPLO='L') will be referenced. */

/*  LDA     (input) INTEGER */
/*          The leading dimension of A.  It must be at least 1 */
/*          and at least min( KA, N-1 ). */

/*  D       (input) DOUBLE PRECISION array, dimension (N) */
/*          The diagonal of the (symmetric tri-) diagonal matrix S. */

/*  E       (input) DOUBLE PRECISION array, dimension (N-1) */
/*          The off-diagonal of the (symmetric tri-) diagonal matrix S. */
/*          E(1) is the (1,2) and (2,1) element, E(2) is the (2,3) and */
/*          (3,2) element, etc. */
/*          Not referenced if KS=0. */

/*  U       (input) DOUBLE PRECISION array, dimension (LDU, N) */
/*          The orthogonal matrix in the decomposition, expressed as a */
/*          dense matrix (i.e., not as a product of Householder */
/*          transformations, Givens transformations, etc.) */

/*  LDU     (input) INTEGER */
/*          The leading dimension of U.  LDU must be at least N and */
/*          at least 1. */

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

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

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

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

/*     Constants */

    /* Parameter adjustments */
    a_dim1 = *lda;
    a_offset = 1 + a_dim1;
    a -= a_offset;
    --d__;
    --e;
    u_dim1 = *ldu;
    u_offset = 1 + u_dim1;
    u -= u_offset;
    --work;
    --result;

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

/* Computing MAX */
/* Computing MIN */
    i__3 = *n - 1;
    i__1 = 0, i__2 = min(i__3,*ka);
    ika = max(i__1,i__2);
    lw = *n * (*n + 1) / 2;

    if (lsame_(uplo, "U")) {
	lower = FALSE_;
	*(unsigned char *)cuplo = 'U';
    } else {
	lower = TRUE_;
	*(unsigned char *)cuplo = 'L';
    }

    unfl = dlamch_("Safe minimum");
    ulp = dlamch_("Epsilon") * dlamch_("Base");

/*     Some Error Checks */

/*     Do Test 1 */

/*     Norm of A: */

/* Computing MAX */
    d__1 = dlansb_("1", cuplo, n, &ika, &a[a_offset], lda, &work[1]);
    anorm = max(d__1,unfl);

/*     Compute error matrix:    Error = A - U S U' */

/*     Copy A from SB to SP storage format. */

    j = 0;
    i__1 = *n;
    for (jc = 1; jc <= i__1; ++jc) {
	if (lower) {
/* Computing MIN */
	    i__3 = ika + 1, i__4 = *n + 1 - jc;
	    i__2 = min(i__3,i__4);
	    for (jr = 1; jr <= i__2; ++jr) {
		++j;
		work[j] = a[jr + jc * a_dim1];
/* L10: */
	    }
	    i__2 = *n + 1 - jc;
	    for (jr = ika + 2; jr <= i__2; ++jr) {
		++j;
		work[j] = 0.;
/* L20: */
	    }
	} else {
	    i__2 = jc;
	    for (jr = ika + 2; jr <= i__2; ++jr) {
		++j;
		work[j] = 0.;
/* L30: */
	    }
/* Computing MIN */
	    i__2 = ika, i__3 = jc - 1;
	    for (jr = min(i__2,i__3); jr >= 0; --jr) {
		++j;
		work[j] = a[ika + 1 - jr + jc * a_dim1];
/* L40: */
	    }
	}
/* L50: */
    }

    i__1 = *n;
    for (j = 1; j <= i__1; ++j) {
	d__1 = -d__[j];
	dspr_(cuplo, n, &d__1, &u[j * u_dim1 + 1], &c__1, &work[1])
		;
/* L60: */
    }

    if (*n > 1 && *ks == 1) {
	i__1 = *n - 1;
	for (j = 1; j <= i__1; ++j) {
	    d__1 = -e[j];
	    dspr2_(cuplo, n, &d__1, &u[j * u_dim1 + 1], &c__1, &u[(j + 1) * 
		    u_dim1 + 1], &c__1, &work[1]);
/* L70: */
	}
    }
    wnorm = dlansp_("1", cuplo, n, &work[1], &work[lw + 1]);

    if (anorm > wnorm) {
	result[1] = wnorm / anorm / (*n * ulp);
    } else {
	if (anorm < 1.) {
/* Computing MIN */
	    d__1 = wnorm, d__2 = *n * anorm;
	    result[1] = min(d__1,d__2) / anorm / (*n * ulp);
	} else {
/* Computing MIN */
	    d__1 = wnorm / anorm, d__2 = (doublereal) (*n);
	    result[1] = min(d__1,d__2) / (*n * ulp);
	}
    }

/*     Do Test 2 */

/*     Compute  UU' - I */

    dgemm_("N", "C", n, n, n, &c_b22, &u[u_offset], ldu, &u[u_offset], ldu, &
	    c_b23, &work[1], n);

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

/* Computing MIN */
/* Computing 2nd power */
    i__1 = *n;
    d__1 = dlange_("1", n, n, &work[1], n, &work[i__1 * i__1 + 1]),
	     d__2 = (doublereal) (*n);
    result[2] = min(d__1,d__2) / (*n * ulp);

    return 0;

/*     End of DSBT21 */

} /* dsbt21_ */
Beispiel #9
0
/* Subroutine */ int dsbevx_(char *jobz, char *range, char *uplo, integer *n,
                             integer *kd, doublereal *ab, integer *ldab, doublereal *q, integer *
                             ldq, doublereal *vl, doublereal *vu, integer *il, integer *iu,
                             doublereal *abstol, integer *m, doublereal *w, doublereal *z__,
                             integer *ldz, doublereal *work, integer *iwork, integer *ifail,
                             integer *info)
{
    /* System generated locals */
    integer ab_dim1, ab_offset, q_dim1, q_offset, z_dim1, z_offset, i__1,
            i__2;
    doublereal d__1, d__2;

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

    /* Local variables */
    integer i__, j, jj;
    doublereal eps, vll, vuu, tmp1;
    integer indd, inde;
    doublereal anrm;
    integer imax;
    doublereal rmin, rmax;
    logical test;
    integer itmp1, indee;
    extern /* Subroutine */ int dscal_(integer *, doublereal *, doublereal *,
                                       integer *);
    doublereal sigma;
    extern logical lsame_(char *, char *);
    extern /* Subroutine */ int dgemv_(char *, integer *, integer *,
                                       doublereal *, doublereal *, integer *, doublereal *, integer *,
                                       doublereal *, doublereal *, integer *);
    integer iinfo;
    char order[1];
    extern /* Subroutine */ int dcopy_(integer *, doublereal *, integer *,
                                       doublereal *, integer *), dswap_(integer *, doublereal *, integer
                                               *, doublereal *, integer *);
    logical lower, wantz;
    extern doublereal dlamch_(char *);
    logical alleig, indeig;
    integer iscale, indibl;
    extern /* Subroutine */ int dlascl_(char *, integer *, integer *,
                                        doublereal *, doublereal *, integer *, integer *, doublereal *,
                                        integer *, integer *);
    extern doublereal dlansb_(char *, char *, integer *, integer *,
                              doublereal *, integer *, doublereal *);
    logical valeig;
    extern /* Subroutine */ int dlacpy_(char *, integer *, integer *,
                                        doublereal *, integer *, doublereal *, integer *);
    doublereal safmin;
    extern /* Subroutine */ int xerbla_(char *, integer *);
    doublereal abstll, bignum;
    extern /* Subroutine */ int dsbtrd_(char *, char *, integer *, integer *,
                                        doublereal *, integer *, doublereal *, doublereal *, doublereal *,
                                        integer *, doublereal *, integer *);
    integer indisp;
    extern /* Subroutine */ int dstein_(integer *, doublereal *, doublereal *,
                                        integer *, doublereal *, integer *, integer *, doublereal *,
                                        integer *, doublereal *, integer *, integer *, integer *),
                                                dsterf_(integer *, doublereal *, doublereal *, integer *);
    integer indiwo;
    extern /* Subroutine */ int dstebz_(char *, char *, integer *, doublereal
                                        *, doublereal *, integer *, integer *, doublereal *, doublereal *,
                                        doublereal *, integer *, integer *, doublereal *, integer *,
                                        integer *, doublereal *, integer *, integer *);
    integer indwrk;
    extern /* Subroutine */ int dsteqr_(char *, integer *, doublereal *,
                                        doublereal *, doublereal *, integer *, doublereal *, integer *);
    integer nsplit;
    doublereal smlnum;


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

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

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

    /*  DSBEVX computes selected eigenvalues and, optionally, eigenvectors */
    /*  of a real symmetric band matrix A.  Eigenvalues and eigenvectors can */
    /*  be selected by specifying either a range of values or a range of */
    /*  indices for the desired eigenvalues. */

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

    /*  JOBZ    (input) CHARACTER*1 */
    /*          = 'N':  Compute eigenvalues only; */
    /*          = 'V':  Compute eigenvalues and eigenvectors. */

    /*  RANGE   (input) CHARACTER*1 */
    /*          = 'A': all eigenvalues will be found; */
    /*          = 'V': all eigenvalues in the half-open interval (VL,VU] */
    /*                 will be found; */
    /*          = 'I': the IL-th through IU-th eigenvalues will be found. */

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

    /*  AB      (input/output) DOUBLE PRECISION array, dimension (LDAB, N) */
    /*          On entry, the upper or lower triangle of the symmetric 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). */

    /*          On exit, AB is overwritten by values generated during the */
    /*          reduction to tridiagonal form.  If UPLO = 'U', the first */
    /*          superdiagonal and the diagonal of the tridiagonal matrix T */
    /*          are returned in rows KD and KD+1 of AB, and if UPLO = 'L', */
    /*          the diagonal and first subdiagonal of T are returned in the */
    /*          first two rows of AB. */

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

    /*  Q       (output) DOUBLE PRECISION array, dimension (LDQ, N) */
    /*          If JOBZ = 'V', the N-by-N orthogonal matrix used in the */
    /*                         reduction to tridiagonal form. */
    /*          If JOBZ = 'N', the array Q is not referenced. */

    /*  LDQ     (input) INTEGER */
    /*          The leading dimension of the array Q.  If JOBZ = 'V', then */
    /*          LDQ >= max(1,N). */

    /*  VL      (input) DOUBLE PRECISION */
    /*  VU      (input) DOUBLE PRECISION */
    /*          If RANGE='V', the lower and upper bounds of the interval to */
    /*          be searched for eigenvalues. 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) DOUBLE PRECISION */
    /*          The absolute error tolerance for the eigenvalues. */
    /*          An approximate eigenvalue is accepted as converged */
    /*          when it is determined to lie in an interval [a,b] */
    /*          of width less than or equal to */

    /*                  ABSTOL + EPS *   max( |a|,|b| ) , */

    /*          where EPS is the machine precision.  If ABSTOL is less than */
    /*          or equal to zero, then  EPS*|T|  will be used in its place, */
    /*          where |T| is the 1-norm of the tridiagonal matrix obtained */
    /*          by reducing AB to tridiagonal form. */

    /*          Eigenvalues will be computed most accurately when ABSTOL is */
    /*          set to twice the underflow threshold 2*DLAMCH('S'), not zero. */
    /*          If this routine returns with INFO>0, indicating that some */
    /*          eigenvectors did not converge, try setting ABSTOL to */
    /*          2*DLAMCH('S'). */

    /*          See "Computing Small Singular Values of Bidiagonal Matrices */
    /*          with Guaranteed High Relative Accuracy," by Demmel and */
    /*          Kahan, LAPACK Working Note #3. */

    /*  M       (output) INTEGER */
    /*          The total number of eigenvalues found.  0 <= M <= N. */
    /*          If RANGE = 'A', M = N, and if RANGE = 'I', M = IU-IL+1. */

    /*  W       (output) DOUBLE PRECISION array, dimension (N) */
    /*          The first M elements contain the selected eigenvalues in */
    /*          ascending order. */

    /*  Z       (output) DOUBLE PRECISION array, dimension (LDZ, max(1,M)) */
    /*          If JOBZ = 'V', then if INFO = 0, the first M columns of Z */
    /*          contain the orthonormal eigenvectors of the matrix A */
    /*          corresponding to the selected eigenvalues, with the i-th */
    /*          column of Z holding the eigenvector associated with W(i). */
    /*          If an eigenvector fails to converge, then that column of Z */
    /*          contains the latest approximation to the eigenvector, and the */
    /*          index of the eigenvector is returned in IFAIL. */
    /*          If JOBZ = 'N', then Z is not referenced. */
    /*          Note: the user must ensure that at least max(1,M) columns are */
    /*          supplied in the array Z; if RANGE = 'V', the exact value of M */
    /*          is not known in advance and an upper bound must be used. */

    /*  LDZ     (input) INTEGER */
    /*          The leading dimension of the array Z.  LDZ >= 1, and if */
    /*          JOBZ = 'V', LDZ >= max(1,N). */

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

    /*  IWORK   (workspace) INTEGER array, dimension (5*N) */

    /*  IFAIL   (output) INTEGER array, dimension (N) */
    /*          If JOBZ = 'V', then if INFO = 0, the first M elements of */
    /*          IFAIL are zero.  If INFO > 0, then IFAIL contains the */
    /*          indices of the eigenvectors that failed to converge. */
    /*          If JOBZ = 'N', then IFAIL is not referenced. */

    /*  INFO    (output) INTEGER */
    /*          = 0:  successful exit. */
    /*          < 0:  if INFO = -i, the i-th argument had an illegal value. */
    /*          > 0:  if INFO = i, then i eigenvectors failed to converge. */
    /*                Their indices are stored in array IFAIL. */

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

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

    /*     Test the input parameters. */

    /* Parameter adjustments */
    ab_dim1 = *ldab;
    ab_offset = 1 + ab_dim1;
    ab -= ab_offset;
    q_dim1 = *ldq;
    q_offset = 1 + q_dim1;
    q -= q_offset;
    --w;
    z_dim1 = *ldz;
    z_offset = 1 + z_dim1;
    z__ -= z_offset;
    --work;
    --iwork;
    --ifail;

    /* Function Body */
    wantz = lsame_(jobz, "V");
    alleig = lsame_(range, "A");
    valeig = lsame_(range, "V");
    indeig = lsame_(range, "I");
    lower = lsame_(uplo, "L");

    *info = 0;
    if (! (wantz || lsame_(jobz, "N"))) {
        *info = -1;
    } else if (! (alleig || valeig || indeig)) {
        *info = -2;
    } else if (! (lower || lsame_(uplo, "U"))) {
        *info = -3;
    } else if (*n < 0) {
        *info = -4;
    } else if (*kd < 0) {
        *info = -5;
    } else if (*ldab < *kd + 1) {
        *info = -7;
    } else if (wantz && *ldq < max(1,*n)) {
        *info = -9;
    } else {
        if (valeig) {
            if (*n > 0 && *vu <= *vl) {
                *info = -11;
            }
        } else if (indeig) {
            if (*il < 1 || *il > max(1,*n)) {
                *info = -12;
            } else if (*iu < min(*n,*il) || *iu > *n) {
                *info = -13;
            }
        }
    }
    if (*info == 0) {
        if (*ldz < 1 || wantz && *ldz < *n) {
            *info = -18;
        }
    }

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

    /*     Quick return if possible */

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

    if (*n == 1) {
        *m = 1;
        if (lower) {
            tmp1 = ab[ab_dim1 + 1];
        } else {
            tmp1 = ab[*kd + 1 + ab_dim1];
        }
        if (valeig) {
            if (! (*vl < tmp1 && *vu >= tmp1)) {
                *m = 0;
            }
        }
        if (*m == 1) {
            w[1] = tmp1;
            if (wantz) {
                z__[z_dim1 + 1] = 1.;
            }
        }
        return 0;
    }

    /*     Get machine constants. */

    safmin = dlamch_("Safe minimum");
    eps = dlamch_("Precision");
    smlnum = safmin / eps;
    bignum = 1. / smlnum;
    rmin = sqrt(smlnum);
    /* Computing MIN */
    d__1 = sqrt(bignum), d__2 = 1. / sqrt(sqrt(safmin));
    rmax = min(d__1,d__2);

    /*     Scale matrix to allowable range, if necessary. */

    iscale = 0;
    abstll = *abstol;
    if (valeig) {
        vll = *vl;
        vuu = *vu;
    } else {
        vll = 0.;
        vuu = 0.;
    }
    anrm = dlansb_("M", uplo, n, kd, &ab[ab_offset], ldab, &work[1]);
    if (anrm > 0. && anrm < rmin) {
        iscale = 1;
        sigma = rmin / anrm;
    } else if (anrm > rmax) {
        iscale = 1;
        sigma = rmax / anrm;
    }
    if (iscale == 1) {
        if (lower) {
            dlascl_("B", kd, kd, &c_b14, &sigma, n, n, &ab[ab_offset], ldab,
                    info);
        } else {
            dlascl_("Q", kd, kd, &c_b14, &sigma, n, n, &ab[ab_offset], ldab,
                    info);
        }
        if (*abstol > 0.) {
            abstll = *abstol * sigma;
        }
        if (valeig) {
            vll = *vl * sigma;
            vuu = *vu * sigma;
        }
    }

    /*     Call DSBTRD to reduce symmetric band matrix to tridiagonal form. */

    indd = 1;
    inde = indd + *n;
    indwrk = inde + *n;
    dsbtrd_(jobz, uplo, n, kd, &ab[ab_offset], ldab, &work[indd], &work[inde],
            &q[q_offset], ldq, &work[indwrk], &iinfo);

    /*     If all eigenvalues are desired and ABSTOL is less than or equal */
    /*     to zero, then call DSTERF or SSTEQR.  If this fails for some */
    /*     eigenvalue, then try DSTEBZ. */

    test = FALSE_;
    if (indeig) {
        if (*il == 1 && *iu == *n) {
            test = TRUE_;
        }
    }
    if ((alleig || test) && *abstol <= 0.) {
        dcopy_(n, &work[indd], &c__1, &w[1], &c__1);
        indee = indwrk + (*n << 1);
        if (! wantz) {
            i__1 = *n - 1;
            dcopy_(&i__1, &work[inde], &c__1, &work[indee], &c__1);
            dsterf_(n, &w[1], &work[indee], info);
        } else {
            dlacpy_("A", n, n, &q[q_offset], ldq, &z__[z_offset], ldz);
            i__1 = *n - 1;
            dcopy_(&i__1, &work[inde], &c__1, &work[indee], &c__1);
            dsteqr_(jobz, n, &w[1], &work[indee], &z__[z_offset], ldz, &work[
                        indwrk], info);
            if (*info == 0) {
                i__1 = *n;
                for (i__ = 1; i__ <= i__1; ++i__) {
                    ifail[i__] = 0;
                    /* L10: */
                }
            }
        }
        if (*info == 0) {
            *m = *n;
            goto L30;
        }
        *info = 0;
    }

    /*     Otherwise, call DSTEBZ and, if eigenvectors are desired, SSTEIN. */

    if (wantz) {
        *(unsigned char *)order = 'B';
    } else {
        *(unsigned char *)order = 'E';
    }
    indibl = 1;
    indisp = indibl + *n;
    indiwo = indisp + *n;
    dstebz_(range, order, n, &vll, &vuu, il, iu, &abstll, &work[indd], &work[
                inde], m, &nsplit, &w[1], &iwork[indibl], &iwork[indisp], &work[
                indwrk], &iwork[indiwo], info);

    if (wantz) {
        dstein_(n, &work[indd], &work[inde], m, &w[1], &iwork[indibl], &iwork[
                    indisp], &z__[z_offset], ldz, &work[indwrk], &iwork[indiwo], &
                ifail[1], info);

        /*        Apply orthogonal matrix used in reduction to tridiagonal */
        /*        form to eigenvectors returned by DSTEIN. */

        i__1 = *m;
        for (j = 1; j <= i__1; ++j) {
            dcopy_(n, &z__[j * z_dim1 + 1], &c__1, &work[1], &c__1);
            dgemv_("N", n, n, &c_b14, &q[q_offset], ldq, &work[1], &c__1, &
                   c_b34, &z__[j * z_dim1 + 1], &c__1);
            /* L20: */
        }
    }

    /*     If matrix was scaled, then rescale eigenvalues appropriately. */

L30:
    if (iscale == 1) {
        if (*info == 0) {
            imax = *m;
        } else {
            imax = *info - 1;
        }
        d__1 = 1. / sigma;
        dscal_(&imax, &d__1, &w[1], &c__1);
    }

    /*     If eigenvalues are not in order, then sort them, along with */
    /*     eigenvectors. */

    if (wantz) {
        i__1 = *m - 1;
        for (j = 1; j <= i__1; ++j) {
            i__ = 0;
            tmp1 = w[j];
            i__2 = *m;
            for (jj = j + 1; jj <= i__2; ++jj) {
                if (w[jj] < tmp1) {
                    i__ = jj;
                    tmp1 = w[jj];
                }
                /* L40: */
            }

            if (i__ != 0) {
                itmp1 = iwork[indibl + i__ - 1];
                w[i__] = w[j];
                iwork[indibl + i__ - 1] = iwork[indibl + j - 1];
                w[j] = tmp1;
                iwork[indibl + j - 1] = itmp1;
                dswap_(n, &z__[i__ * z_dim1 + 1], &c__1, &z__[j * z_dim1 + 1],
                       &c__1);
                if (*info != 0) {
                    itmp1 = ifail[i__];
                    ifail[i__] = ifail[j];
                    ifail[j] = itmp1;
                }
            }
            /* L50: */
        }
    }

    return 0;

    /*     End of DSBEVX */

} /* dsbevx_ */