DLLEXPORT int d_cholesky_solve_factored(int n, int nrhs, double a[], double b[])
{
char uplo = 'L';
int info = 0;
dpotrs_(&uplo, &n, &nrhs, a, &n, b, &n, &info);
return info;
}
DLLEXPORT MKL_INT d_cholesky_solve_factored(MKL_INT n, MKL_INT nrhs, double a[], double b[])
{
char uplo = 'L';
MKL_INT info = 0;
dpotrs_(&uplo, &n, &nrhs, a, &n, b, &n, &info);
return info;
}
void chol_solve(Eigen::MatrixXd & A, Eigen::MatrixXd & B) {
if (A.rows() != B.rows()) {throw std::runtime_error("A.rows() must equal B.rows()");}
int info;
int n = A.rows();
int nrhs = B.cols();
dpotrs_(&lower, &n, &nrhs, A.data(), &n, B.data(), &n, &info);
if(info != 0){ throw std::runtime_error("c++ error: Cholesky solve failed (for eigen matrix)");}
}
/* Solve A*X = B with a symmetric positive definite matrix A using the Cholesky factorization */
void THLapack_(potrs)(char uplo, int n, int nrhs, real *a, int lda, real *b, int ldb, int *info)
{
#ifdef USE_LAPACK
#if defined(TH_REAL_IS_DOUBLE)
dpotrs_(&uplo, &n, &nrhs, a, &lda, b, &ldb, info);
#else
spotrs_(&uplo, &n, &nrhs, a, &lda, b, &ldb, info);
#endif
#else
THError("potrs: Lapack library not found in compile time\n");
#endif
}
void THLapack_(gpotrs)(char uplo, int n, int nrhs, real *a, int lda, real *b, int ldb, int *info)
{
#ifdef USE_LAPACK
#if defined(TH_REAL_IS_DOUBLE)
extern void dpotrs_(char *uplo, int *n, int *nrhs, double *a, int *lda, double *b, int *ldb, int *info);
dpotrs_(&uplo, &n, &nrhs, a, &lda, b, &ldb, info);
#else
extern void spotrs_(char *uplo, int *n, int *nrhs, float *a, int *lda, float *b, int *ldb, int *info);
spotrs_(&uplo, &n, &nrhs, a, &lda, b, &ldb, info);
#endif
#else
THError("gpotrs : Lapack library not found in compile time\n");
#endif
}
DLLEXPORT int d_cholesky_solve(int n, int nrhs, double a[], double b[])
{
double* clone = new double[n*n];
memcpy(clone, a, n*n*sizeof(double));
char uplo = 'L';
int info = 0;
dpotrf_(&uplo, &n, clone, &n, &info);
if (info != 0){
delete[] clone;
return info;
}
dpotrs_(&uplo, &n, &nrhs, clone, &n, b, &n, &info);
return info;
}
DLLEXPORT MKL_INT d_cholesky_solve(MKL_INT n, MKL_INT nrhs, double a[], double b[])
{
double* clone = new double[n*n];
std::memcpy(clone, a, n*n*sizeof(double));
char uplo = 'L';
MKL_INT info = 0;
dpotrf_(&uplo, &n, clone, &n, &info);
if (info != 0){
delete[] clone;
return info;
}
dpotrs_(&uplo, &n, &nrhs, clone, &n, b, &n, &info);
delete[] clone;
return info;
}
int GMRFLib_solveAxb_posdef(double *sol, double *chol, double *b, int dim, int nrhs)
{
/*
* solve Ax=b, where chol is lower Cholesky factor of A.
*/
int info;
if (sol != b) {
memcpy(sol, b, dim * nrhs * sizeof(double));
}
dpotrs_("L", &dim, &nrhs, chol, &dim, sol, &dim, &info, 1);
if (info) {
GMRFLib_ERROR(GMRFLib_EPOSDEF);
}
return GMRFLib_SUCCESS;
}
/* Solve a system of linear equations: L'*L * x = b, where L is a Cholesky factrization. */
int
larsen_linalg_cholesky_svx (const size_t size, double *l, const size_t lda, double *b)
{
int info;
char uplo;
int n;
int nrhs;
int _lda;
if (!l) larsen_error ("larsen_linalg_cholesky_svx", "first matrix is empty.");
if (!b) larsen_error ("larsen_linalg_cholesky_svx", "second matrix is empty.");
uplo = 'U';
n = (int) size;
nrhs = 1;
_lda = (int) lda;
dpotrs_ (&uplo, &n, &nrhs, l, &_lda, b, &n, &info);
return info;
}
void mexFunction(int nlhs, mxArray *plhs[], int nrhs, const mxArray *prhs[])
{
double *C;
int n, m, q;
if (nrhs != 2 || nlhs > 1) /* check the input */
mexErrMsgTxt("Usage: X = solve_chol(R, B)");
n = mxGetN(prhs[0]);
if (n != mxGetM(prhs[0]))
mexErrMsgTxt("Error: First argument matrix must be square");
if (n != mxGetM(prhs[1]))
mexErrMsgTxt("Error: First and second argument matrices must have same number of rows");
m = mxGetN(prhs[1]);
plhs[0] = mxCreateDoubleMatrix(n, m, mxREAL); /* allocate space for output */
C = mxGetPr(plhs[0]);
if (n==0) return; /* if argument was empty matrix, do no more */
memcpy(C,mxGetPr(prhs[1]),n*m*sizeof(double)); /* copy argument matrix */
dpotrs_("U", &n, &m, mxGetPr(prhs[0]), &n, C, &n, &q); /* solve system */
if (q > 0)
mexErrMsgTxt("Error: illegal input to solve_chol");
}
void chol_solve(double* A, int n, double* B, int nrhs) {
int info;
dpotrs_(&lower, &n, &nrhs, A, &n, B, &n, &info);
if(info != 0){ throw std::runtime_error("c++ error: Cholesky solve failed");}
}
/* Subroutine */
int dsposv_(char *uplo, integer *n, integer *nrhs, doublereal *a, integer *lda, doublereal *b, integer *ldb, doublereal * x, integer *ldx, doublereal *work, real *swork, integer *iter, integer *info)
{
/* System generated locals */
integer a_dim1, a_offset, b_dim1, b_offset, work_dim1, work_offset, x_dim1, x_offset, i__1;
doublereal d__1;
/* Builtin functions */
double sqrt(doublereal);
/* Local variables */
integer i__;
doublereal cte, eps, anrm;
integer ptsa;
doublereal rnrm, xnrm;
integer ptsx;
extern logical lsame_(char *, char *);
integer iiter;
extern /* Subroutine */
int daxpy_(integer *, doublereal *, doublereal *, integer *, doublereal *, integer *), dsymm_(char *, char *, integer *, integer *, doublereal *, doublereal *, integer *, doublereal *, integer *, doublereal *, doublereal *, integer *), dlag2s_(integer *, integer *, doublereal *, integer *, real *, integer *, integer *), slag2d_(integer *, integer *, real *, integer *, doublereal *, integer *, integer *), dlat2s_(char *, integer *, doublereal *, integer *, real *, integer *, integer *);
extern doublereal dlamch_(char *);
extern integer idamax_(integer *, doublereal *, integer *);
extern /* Subroutine */
int dlacpy_(char *, integer *, integer *, doublereal *, integer *, doublereal *, integer *), xerbla_(char *, integer *);
extern doublereal dlansy_(char *, char *, integer *, doublereal *, integer *, doublereal *);
extern /* Subroutine */
int dpotrf_(char *, integer *, doublereal *, integer *, integer *), dpotrs_(char *, integer *, integer *, doublereal *, integer *, doublereal *, integer *, integer *), spotrf_(char *, integer *, real *, integer *, integer *), spotrs_(char *, integer *, integer *, real *, integer *, real *, integer *, integer *);
/* -- LAPACK driver routine (version 3.4.0) -- */
/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */
/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */
/* November 2011 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* ===================================================================== */
/* .. Parameters .. */
/* .. Local Scalars .. */
/* .. External Subroutines .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Executable Statements .. */
/* Parameter adjustments */
work_dim1 = *n;
work_offset = 1 + work_dim1;
work -= work_offset;
a_dim1 = *lda;
a_offset = 1 + a_dim1;
a -= a_offset;
b_dim1 = *ldb;
b_offset = 1 + b_dim1;
b -= b_offset;
x_dim1 = *ldx;
x_offset = 1 + x_dim1;
x -= x_offset;
--swork;
/* Function Body */
*info = 0;
*iter = 0;
/* Test the input parameters. */
if (! lsame_(uplo, "U") && ! lsame_(uplo, "L"))
{
*info = -1;
}
else if (*n < 0)
{
*info = -2;
}
else if (*nrhs < 0)
{
*info = -3;
}
else if (*lda < max(1,*n))
{
*info = -5;
}
else if (*ldb < max(1,*n))
{
*info = -7;
}
else if (*ldx < max(1,*n))
{
*info = -9;
}
if (*info != 0)
{
i__1 = -(*info);
xerbla_("DSPOSV", &i__1);
return 0;
}
/* Quick return if (N.EQ.0). */
if (*n == 0)
{
return 0;
}
/* Skip single precision iterative refinement if a priori slower */
/* than double precision factorization. */
if (FALSE_)
{
*iter = -1;
goto L40;
}
/* Compute some constants. */
anrm = dlansy_("I", uplo, n, &a[a_offset], lda, &work[work_offset]);
eps = dlamch_("Epsilon");
cte = anrm * eps * sqrt((doublereal) (*n)) * 1.;
/* Set the indices PTSA, PTSX for referencing SA and SX in SWORK. */
ptsa = 1;
ptsx = ptsa + *n * *n;
/* Convert B from double precision to single precision and store the */
/* result in SX. */
dlag2s_(n, nrhs, &b[b_offset], ldb, &swork[ptsx], n, info);
if (*info != 0)
{
*iter = -2;
goto L40;
}
/* Convert A from double precision to single precision and store the */
/* result in SA. */
dlat2s_(uplo, n, &a[a_offset], lda, &swork[ptsa], n, info);
if (*info != 0)
{
*iter = -2;
goto L40;
}
/* Compute the Cholesky factorization of SA. */
spotrf_(uplo, n, &swork[ptsa], n, info);
if (*info != 0)
{
*iter = -3;
goto L40;
}
/* Solve the system SA*SX = SB. */
spotrs_(uplo, n, nrhs, &swork[ptsa], n, &swork[ptsx], n, info);
/* Convert SX back to double precision */
slag2d_(n, nrhs, &swork[ptsx], n, &x[x_offset], ldx, info);
/* Compute R = B - AX (R is WORK). */
dlacpy_("All", n, nrhs, &b[b_offset], ldb, &work[work_offset], n);
dsymm_("Left", uplo, n, nrhs, &c_b10, &a[a_offset], lda, &x[x_offset], ldx, &c_b11, &work[work_offset], n);
/* Check whether the NRHS normwise backward errors satisfy the */
/* stopping criterion. If yes, set ITER=0 and return. */
i__1 = *nrhs;
for (i__ = 1;
i__ <= i__1;
++i__)
{
xnrm = (d__1 = x[idamax_(n, &x[i__ * x_dim1 + 1], &c__1) + i__ * x_dim1], f2c_abs(d__1));
rnrm = (d__1 = work[idamax_(n, &work[i__ * work_dim1 + 1], &c__1) + i__ * work_dim1], f2c_abs(d__1));
if (rnrm > xnrm * cte)
{
goto L10;
}
}
/* If we are here, the NRHS normwise backward errors satisfy the */
/* stopping criterion. We are good to exit. */
*iter = 0;
return 0;
L10:
for (iiter = 1;
iiter <= 30;
++iiter)
{
/* Convert R (in WORK) from double precision to single precision */
/* and store the result in SX. */
dlag2s_(n, nrhs, &work[work_offset], n, &swork[ptsx], n, info);
if (*info != 0)
{
*iter = -2;
goto L40;
}
/* Solve the system SA*SX = SR. */
spotrs_(uplo, n, nrhs, &swork[ptsa], n, &swork[ptsx], n, info);
/* Convert SX back to double precision and update the current */
/* iterate. */
slag2d_(n, nrhs, &swork[ptsx], n, &work[work_offset], n, info);
i__1 = *nrhs;
for (i__ = 1;
i__ <= i__1;
++i__)
{
daxpy_(n, &c_b11, &work[i__ * work_dim1 + 1], &c__1, &x[i__ * x_dim1 + 1], &c__1);
}
/* Compute R = B - AX (R is WORK). */
dlacpy_("All", n, nrhs, &b[b_offset], ldb, &work[work_offset], n);
dsymm_("L", uplo, n, nrhs, &c_b10, &a[a_offset], lda, &x[x_offset], ldx, &c_b11, &work[work_offset], n);
/* Check whether the NRHS normwise backward errors satisfy the */
/* stopping criterion. If yes, set ITER=IITER>0 and return. */
i__1 = *nrhs;
for (i__ = 1;
i__ <= i__1;
++i__)
{
xnrm = (d__1 = x[idamax_(n, &x[i__ * x_dim1 + 1], &c__1) + i__ * x_dim1], f2c_abs(d__1));
rnrm = (d__1 = work[idamax_(n, &work[i__ * work_dim1 + 1], &c__1) + i__ * work_dim1], f2c_abs(d__1));
if (rnrm > xnrm * cte)
{
goto L20;
}
}
/* If we are here, the NRHS normwise backward errors satisfy the */
/* stopping criterion, we are good to exit. */
*iter = iiter;
return 0;
L20: /* L30: */
;
}
/* If we are at this place of the code, this is because we have */
/* performed ITER=ITERMAX iterations and never satisified the */
/* stopping criterion, set up the ITER flag accordingly and follow */
/* up on double precision routine. */
*iter = -31;
L40: /* Single-precision iterative refinement failed to converge to a */
/* satisfactory solution, so we resort to double precision. */
dpotrf_(uplo, n, &a[a_offset], lda, info);
if (*info != 0)
{
return 0;
}
dlacpy_("All", n, nrhs, &b[b_offset], ldb, &x[x_offset], ldx);
dpotrs_(uplo, n, nrhs, &a[a_offset], lda, &x[x_offset], ldx, info);
return 0;
/* End of DSPOSV. */
}
static int lpfnb_ (integer *n, integer *p, doublereal *a, doublereal *c__,
doublereal *b, doublereal *d__, doublereal *u, doublereal *beta,
doublereal *eps, doublereal *x, doublereal *s, doublereal *y,
doublereal *z__, doublereal *w, doublereal *dx, doublereal *ds,
doublereal *dy, doublereal *dz, doublereal *dw, doublereal *dr,
doublereal *rhs, doublereal *ada, integer *nit, integer *info,
void (*callback)(void))
{
integer a_dim1 = *p, ada_dim1 = *p;
integer a_offset = 1 + a_dim1, ada_offset = 1 + ada_dim1;
doublereal d1, d2;
static doublereal g;
static integer i;
static doublereal mu, gap;
static doublereal dsdw, dxdz;
static doublereal deltad, deltap;
int main_iters = 0;
int err = 0;
/* Parameter adjustments */
--dr;
--dw;
--dz;
--ds;
--dx;
--w;
--z__;
--s;
--x;
--u;
--d__;
--c__;
ada -= ada_offset;
--rhs;
--dy;
--y;
--b;
a -= a_offset;
--nit;
/* Function Body */
nit[1] = 0;
nit[2] = 0;
nit[3] = *n;
dgemv_("N", p, n, &c_b4, &a[a_offset], p, &c__[1], &one, &zero, &y[1],
&one);
for (i = 1; i <= *n; ++i) {
d__[i] = 1.;
}
err = stepy_(n, p, &a[a_offset], &d__[1], &y[1], &ada[ada_offset], info);
if (err) {
return err;
}
dcopy_(n, &c__[1], &one, &s[1], &one);
dgemv_("T", p, n, &c_b13, &a[a_offset], p, &y[1], &one, &c_b4, &s[1],
&one);
for (i = 1; i <= *n; ++i) {
if ((d1 = s[i], fabs(d1)) < *eps) {
d1 = s[i];
z__[i] = max(d1,0.) + *eps;
d1 = -s[i];
w[i] = max(d1,0.) + *eps;
} else {
d1 = s[i];
z__[i] = max(d1, 0.);
d1 = -s[i];
w[i] = max(d1, 0.);
}
s[i] = u[i] - x[i];
}
gap = ddot_(n, &z__[1], &one, &x[1], &one) +
ddot_(n, &w[1], &one, &s[1], &one);
looptop:
if (callback != NULL && (main_iters++ % ITERSTEP == 0)) {
callback();
}
if (gap > *eps && nit[1] < 50) {
++nit[1];
for (i = 1; i <= *n; ++i) {
d__[i] = 1. / (z__[i] / x[i] + w[i] / s[i]);
ds[i] = z__[i] - w[i];
dz[i] = d__[i] * ds[i];
}
dcopy_(p, &b[1], &one, &dy[1], &one);
dgemv_("N", p, n, &c_b13, &a[a_offset], p, &x[1], &one, &c_b4, &dy[1],
&one);
dgemv_("N", p, n, &c_b4, &a[a_offset], p, &dz[1], &one, &c_b4, &dy[1],
&one);
dcopy_(p, &dy[1], &one, &rhs[1], &one);
err = stepy_(n, p, &a[a_offset], &d__[1], &dy[1], &ada[ada_offset], info);
if (err) {
return err;
}
dgemv_("T", p, n, &c_b4, &a[a_offset], p, &dy[1], &one, &c_b13,
&ds[1], &one);
deltap = 1e20;
deltad = 1e20;
for (i = 1; i <= *n; ++i) {
dx[i] = d__[i] * ds[i];
ds[i] = -dx[i];
dz[i] = -z__[i] * (dx[i] / x[i] + 1.);
dw[i] = -w[i] * (ds[i] / s[i] + 1.);
if (dx[i] < 0.) {
d1 = deltap, d2 = -x[i] / dx[i];
deltap = min(d1,d2);
}
if (ds[i] < 0.) {
d1 = deltap, d2 = -s[i] / ds[i];
deltap = min(d1,d2);
}
if (dz[i] < 0.) {
d1 = deltad, d2 = -z__[i] / dz[i];
deltad = min(d1,d2);
}
if (dw[i] < 0.) {
d1 = deltad, d2 = -w[i] / dw[i];
deltad = min(d1,d2);
}
}
d1 = *beta * deltap;
deltap = min(d1,1.);
d1 = *beta * deltad;
deltad = min(d1,1.);
if (min(deltap,deltad) < 1.) {
++nit[2];
mu = ddot_(n, &x[1], &one, &z__[1], &one) +
ddot_(n, &s[1], &one, &w[1], &one);
g = mu + deltap * ddot_(n, &dx[1], &one, &z__[1], &one) +
deltad * ddot_(n, &dz[1], &one, &x[1], &one) +
deltap * deltad * ddot_(n, &dz[1], &one, &dx[1], &one) +
deltap * ddot_(n, &ds[1], &one, &w[1], &one) +
deltad * ddot_(n, &dw[1], &one, &s[1], &one) +
deltap * deltad * ddot_(n, &ds[1], &one, &dw[1], &one);
d1 = g / mu;
mu = mu * (d1 * (d1 * d1)) / (doublereal) (*n << 1);
for (i = 1; i <= *n; ++i) {
dr[i] = d__[i] * (mu * (1 / s[i] - 1 / x[i]) + dx[i]
* dz[i] / x[i] - ds[i] * dw[i] / s[i]);
}
dswap_(p, &rhs[1], &one, &dy[1], &one);
dgemv_("N", p, n, &c_b4, &a[a_offset], p, &dr[1], &one, &c_b4,
&dy[1], &one);
dpotrs_("U", p, &one, &ada[ada_offset], p, &dy[1], p, info);
if (*info != 0) {
fprintf(stderr, "lpfnb: dpotrs_ gave info = %d\n", *info);
}
dgemv_("T", p, n, &c_b4, &a[a_offset], p, &dy[1], &one, &zero,
&u[1], &one);
deltap = 1e20;
deltad = 1e20;
for (i = 1; i <= *n; ++i) {
dxdz = dx[i] * dz[i];
dsdw = ds[i] * dw[i];
dx[i] = d__[i] * (u[i] - z__[i] + w[i]) - dr[i];
ds[i] = -dx[i];
dz[i] = -z__[i] + (mu - z__[i] * dx[i] - dxdz) / x[i];
dw[i] = -w[i] + (mu - w[i] * ds[i] - dsdw) / s[i];
if (dx[i] < 0.) {
d1 = deltap, d2 = -x[i] / dx[i];
deltap = min(d1, d2);
}
if (ds[i] < 0.) {
d1 = deltap, d2 = -s[i] / ds[i];
deltap = min(d1, d2);
}
if (dz[i] < 0.) {
d1 = deltad, d2 = -z__[i] / dz[i];
deltad = min(d1, d2);
}
if (dw[i] < 0.) {
d1 = deltad, d2 = -w[i] / dw[i];
deltad = min(d1, d2);
}
}
d1 = *beta * deltap;
deltap = min(d1,1.);
d1 = *beta * deltad;
deltad = min(d1,1.);
}
daxpy_(n, &deltap, &dx[1], &one, &x[1], &one);
daxpy_(n, &deltap, &ds[1], &one, &s[1], &one);
daxpy_(p, &deltad, &dy[1], &one, &y[1], &one);
daxpy_(n, &deltad, &dz[1], &one, &z__[1], &one);
daxpy_(n, &deltad, &dw[1], &one, &w[1], &one);
gap = ddot_(n, &z__[1], &one, &x[1], &one) +
ddot_(n, &w[1], &one, &s[1], &one);
goto looptop;
}
daxpy_(n, &c_b13, &w[1], &one, &z__[1], &one);
dswap_(n, &z__[1], &one, &x[1], &one);
return err;
} /* end of lpfnb_ */
/* Subroutine */ int dporfs_(char *uplo, integer *n, integer *nrhs,
doublereal *a, integer *lda, doublereal *af, integer *ldaf,
doublereal *b, integer *ldb, doublereal *x, integer *ldx, doublereal *
ferr, doublereal *berr, doublereal *work, integer *iwork, integer *
info)
{
/* -- LAPACK routine (version 2.0) --
Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
Courant Institute, Argonne National Lab, and Rice University
September 30, 1994
Purpose
=======
DPORFS improves the computed solution to a system of linear
equations when the coefficient matrix is symmetric positive definite,
and provides error bounds and backward error estimates for the
solution.
Arguments
=========
UPLO (input) CHARACTER*1
= 'U': Upper triangle of A is stored;
= 'L': Lower triangle of A is stored.
N (input) INTEGER
The order of the matrix A. N >= 0.
NRHS (input) INTEGER
The number of right hand sides, i.e., the number of columns
of the matrices B and X. NRHS >= 0.
A (input) DOUBLE PRECISION array, dimension (LDA,N)
The symmetric matrix A. If UPLO = 'U', the leading N-by-N
upper triangular part of A contains the upper triangular part
of the matrix A, and the strictly lower triangular part of A
is not referenced. If UPLO = 'L', the leading N-by-N lower
triangular part of A contains the lower triangular part of
the matrix A, and the strictly upper triangular part of A is
not referenced.
LDA (input) INTEGER
The leading dimension of the array A. LDA >= max(1,N).
AF (input) DOUBLE PRECISION array, dimension (LDAF,N)
The triangular factor U or L from the Cholesky factorization
A = U**T*U or A = L*L**T, as computed by DPOTRF.
LDAF (input) INTEGER
The leading dimension of the array AF. LDAF >= max(1,N).
B (input) DOUBLE PRECISION array, dimension (LDB,NRHS)
The right hand side matrix B.
LDB (input) INTEGER
The leading dimension of the array B. LDB >= max(1,N).
X (input/output) DOUBLE PRECISION array, dimension (LDX,NRHS)
On entry, the solution matrix X, as computed by DPOTRS.
On exit, the improved solution matrix X.
LDX (input) INTEGER
The leading dimension of the array X. LDX >= max(1,N).
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
Internal Parameters
===================
ITMAX is the maximum number of steps of iterative refinement.
=====================================================================
Test the input parameters.
Parameter adjustments
Function Body */
/* Table of constant values */
static integer c__1 = 1;
static doublereal c_b12 = -1.;
static doublereal c_b14 = 1.;
/* System generated locals */
integer a_dim1, a_offset, af_dim1, af_offset, b_dim1, b_offset, x_dim1,
x_offset, i__1, i__2, i__3;
doublereal d__1, d__2, d__3;
/* Local variables */
static integer kase;
static doublereal safe1, safe2;
static integer i, j, k;
static doublereal s;
extern logical lsame_(char *, char *);
extern /* Subroutine */ int dcopy_(integer *, doublereal *, integer *,
doublereal *, integer *), daxpy_(integer *, doublereal *,
doublereal *, integer *, doublereal *, integer *);
static integer count;
static logical upper;
extern /* Subroutine */ int dsymv_(char *, integer *, doublereal *,
doublereal *, integer *, doublereal *, integer *, doublereal *,
doublereal *, integer *);
extern doublereal dlamch_(char *);
extern /* Subroutine */ int dlacon_(integer *, doublereal *, doublereal *,
integer *, doublereal *, integer *);
static doublereal xk;
static integer nz;
static doublereal safmin;
extern /* Subroutine */ int xerbla_(char *, integer *), dpotrs_(
char *, integer *, integer *, doublereal *, integer *, doublereal
*, integer *, integer *);
static doublereal lstres, eps;
#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 A(I,J) a[(I)-1 + ((J)-1)* ( *lda)]
#define AF(I,J) af[(I)-1 + ((J)-1)* ( *ldaf)]
#define B(I,J) b[(I)-1 + ((J)-1)* ( *ldb)]
#define X(I,J) x[(I)-1 + ((J)-1)* ( *ldx)]
*info = 0;
upper = lsame_(uplo, "U");
if (! upper && ! lsame_(uplo, "L")) {
*info = -1;
} else if (*n < 0) {
*info = -2;
} else if (*nrhs < 0) {
*info = -3;
} else if (*lda < max(1,*n)) {
*info = -5;
} else if (*ldaf < max(1,*n)) {
*info = -7;
} else if (*ldb < max(1,*n)) {
*info = -9;
} else if (*ldx < max(1,*n)) {
*info = -11;
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("DPORFS", &i__1);
return 0;
}
/* Quick return if possible */
if (*n == 0 || *nrhs == 0) {
i__1 = *nrhs;
for (j = 1; j <= *nrhs; ++j) {
FERR(j) = 0.;
BERR(j) = 0.;
/* L10: */
}
return 0;
}
/* NZ = maximum number of nonzero elements in each row of A, plus 1 */
nz = *n + 1;
eps = dlamch_("Epsilon");
safmin = dlamch_("Safe minimum");
safe1 = nz * safmin;
safe2 = safe1 / eps;
/* Do for each right hand side */
i__1 = *nrhs;
for (j = 1; j <= *nrhs; ++j) {
count = 1;
lstres = 3.;
L20:
/* Loop until stopping criterion is satisfied.
Compute residual R = B - A * X */
dcopy_(n, &B(1,j), &c__1, &WORK(*n + 1), &c__1);
dsymv_(uplo, n, &c_b12, &A(1,1), lda, &X(1,j), &c__1,
&c_b14, &WORK(*n + 1), &c__1);
/* Compute componentwise relative backward error from formula
max(i) ( abs(R(i)) / ( abs(A)*abs(X) + abs(B) )(i) )
where abs(Z) is the componentwise absolute value of the matr
ix
or vector Z. If the i-th component of the denominator is le
ss
than SAFE2, then SAFE1 is added to the i-th components of th
e
numerator and denominator before dividing. */
i__2 = *n;
for (i = 1; i <= *n; ++i) {
WORK(i) = (d__1 = B(i,j), abs(d__1));
/* L30: */
}
/* Compute abs(A)*abs(X) + abs(B). */
if (upper) {
i__2 = *n;
for (k = 1; k <= *n; ++k) {
s = 0.;
xk = (d__1 = X(k,j), abs(d__1));
i__3 = k - 1;
for (i = 1; i <= k-1; ++i) {
WORK(i) += (d__1 = A(i,k), abs(d__1)) * xk;
s += (d__1 = A(i,k), abs(d__1)) * (d__2 = X(i,j), abs(d__2));
/* L40: */
}
WORK(k) = WORK(k) + (d__1 = A(k,k), abs(d__1)) *
xk + s;
/* L50: */
}
} else {
i__2 = *n;
for (k = 1; k <= *n; ++k) {
s = 0.;
xk = (d__1 = X(k,j), abs(d__1));
WORK(k) += (d__1 = A(k,k), abs(d__1)) * xk;
i__3 = *n;
for (i = k + 1; i <= *n; ++i) {
WORK(i) += (d__1 = A(i,k), abs(d__1)) * xk;
s += (d__1 = A(i,k), abs(d__1)) * (d__2 = X(i,j), abs(d__2));
/* L60: */
}
WORK(k) += s;
/* L70: */
}
}
s = 0.;
i__2 = *n;
for (i = 1; i <= *n; ++i) {
if (WORK(i) > safe2) {
/* Computing MAX */
d__2 = s, d__3 = (d__1 = WORK(*n + i), abs(d__1)) / WORK(i);
s = max(d__2,d__3);
} else {
/* Computing MAX */
d__2 = s, d__3 = ((d__1 = WORK(*n + i), abs(d__1)) + safe1) /
(WORK(i) + safe1);
s = max(d__2,d__3);
}
/* L80: */
}
BERR(j) = s;
/* Test stopping criterion. Continue iterating if
1) The residual BERR(J) is larger than machine epsilon, a
nd
2) BERR(J) decreased by at least a factor of 2 during the
last iteration, and
3) At most ITMAX iterations tried. */
if (BERR(j) > eps && BERR(j) * 2. <= lstres && count <= 5) {
/* Update solution and try again. */
dpotrs_(uplo, n, &c__1, &AF(1,1), ldaf, &WORK(*n + 1), n,
info);
daxpy_(n, &c_b14, &WORK(*n + 1), &c__1, &X(1,j), &c__1)
;
lstres = BERR(j);
++count;
goto L20;
}
/* Bound error from formula
norm(X - XTRUE) / norm(X) .le. FERR =
norm( abs(inv(A))*
( abs(R) + NZ*EPS*( abs(A)*abs(X)+abs(B) ))) / norm(X)
where
norm(Z) is the magnitude of the largest component of Z
inv(A) is the inverse of A
abs(Z) is the componentwise absolute value of the matrix o
r
vector Z
NZ is the maximum number of nonzeros in any row of A, plus
1
EPS is machine epsilon
The i-th component of abs(R)+NZ*EPS*(abs(A)*abs(X)+abs(B))
is incremented by SAFE1 if the i-th component of
abs(A)*abs(X) + abs(B) is less than SAFE2.
Use DLACON to estimate the infinity-norm of the matrix
inv(A) * diag(W),
where W = abs(R) + NZ*EPS*( abs(A)*abs(X)+abs(B) ))) */
i__2 = *n;
for (i = 1; i <= *n; ++i) {
if (WORK(i) > safe2) {
WORK(i) = (d__1 = WORK(*n + i), abs(d__1)) + nz * eps * WORK(
i);
} else {
WORK(i) = (d__1 = WORK(*n + i), abs(d__1)) + nz * eps * WORK(
i) + safe1;
}
/* L90: */
}
kase = 0;
L100:
dlacon_(n, &WORK((*n << 1) + 1), &WORK(*n + 1), &IWORK(1), &FERR(j), &
kase);
if (kase != 0) {
if (kase == 1) {
/* Multiply by diag(W)*inv(A'). */
dpotrs_(uplo, n, &c__1, &AF(1,1), ldaf, &WORK(*n + 1),
n, info);
i__2 = *n;
for (i = 1; i <= *n; ++i) {
WORK(*n + i) = WORK(i) * WORK(*n + i);
/* L110: */
}
} else if (kase == 2) {
/* Multiply by inv(A)*diag(W). */
i__2 = *n;
for (i = 1; i <= *n; ++i) {
WORK(*n + i) = WORK(i) * WORK(*n + i);
/* L120: */
}
dpotrs_(uplo, n, &c__1, &AF(1,1), ldaf, &WORK(*n + 1),
n, info);
}
goto L100;
}
/* Normalize error. */
lstres = 0.;
i__2 = *n;
for (i = 1; i <= *n; ++i) {
/* Computing MAX */
d__2 = lstres, d__3 = (d__1 = X(i,j), abs(d__1));
lstres = max(d__2,d__3);
/* L130: */
}
if (lstres != 0.) {
FERR(j) /= lstres;
}
/* L140: */
}
return 0;
/* End of DPORFS */
} /* dporfs_ */
/* Subroutine */ int dposvx_(char *fact, char *uplo, integer *n, integer *
nrhs, doublereal *a, integer *lda, doublereal *af, integer *ldaf,
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 a_dim1, a_offset, af_dim1, af_offset, b_dim1, b_offset, x_dim1,
x_offset, i__1, i__2;
doublereal d__1, d__2;
/* Local variables */
integer i__, j;
doublereal amax, smin, smax;
doublereal scond, anorm;
logical equil, rcequ;
logical nofact;
doublereal bignum;
integer infequ;
doublereal smlnum;
/* -- LAPACK driver routine (version 3.2) -- */
/* November 2006 */
/* Purpose */
/* ======= */
/* DPOSVX 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 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 matrix and L is a lower triangular */
/* 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, AF contains the factored form of A. */
/* If EQUED = 'Y', the matrix A has been equilibrated */
/* with scaling factors given by S. A and AF will not */
/* be modified. */
/* = 'N': The matrix A will be copied to AF and factored. */
/* = 'E': The matrix A will be equilibrated if necessary, then */
/* copied to AF 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. */
/* NRHS (input) INTEGER */
/* The number of right hand sides, i.e., the number of columns */
/* of the matrices B and X. NRHS >= 0. */
/* A (input/output) DOUBLE PRECISION array, dimension (LDA,N) */
/* On entry, the symmetric matrix A, except if FACT = 'F' and */
/* EQUED = 'Y', then A must contain the equilibrated matrix */
/* diag(S)*A*diag(S). If UPLO = 'U', the leading */
/* N-by-N upper triangular part of A contains the upper */
/* triangular part of the matrix A, and the strictly lower */
/* triangular part of A is not referenced. If UPLO = 'L', the */
/* leading N-by-N lower triangular part of A contains the lower */
/* triangular part of the matrix A, and the strictly upper */
/* triangular part of A is not referenced. A is not modified if */
/* FACT = 'F' or 'N', or if FACT = 'E' and EQUED = 'N' on exit. */
/* On exit, if FACT = 'E' and EQUED = 'Y', A is overwritten by */
/* diag(S)*A*diag(S). */
/* LDA (input) INTEGER */
/* The leading dimension of the array A. LDA >= max(1,N). */
/* AF (input or output) DOUBLE PRECISION array, dimension (LDAF,N) */
/* If FACT = 'F', then AF 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, in the same storage */
/* format as A. If EQUED .ne. 'N', then AF is the factored form */
/* of the equilibrated matrix diag(S)*A*diag(S). */
/* If FACT = 'N', then AF 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 original */
/* matrix A. */
/* If FACT = 'E', then AF 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). */
/* LDAF (input) INTEGER */
/* The leading dimension of the array AF. LDAF >= max(1,N). */
/* 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. */
/* ===================================================================== */
/* Parameter adjustments */
a_dim1 = *lda;
a_offset = 1 + a_dim1;
a -= a_offset;
af_dim1 = *ldaf;
af_offset = 1 + af_dim1;
af -= af_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");
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 (! lsame_(uplo, "U") && ! lsame_(uplo,
"L")) {
*info = -2;
} else if (*n < 0) {
*info = -3;
} else if (*nrhs < 0) {
*info = -4;
} else if (*lda < max(1,*n)) {
*info = -6;
} else if (*ldaf < max(1,*n)) {
*info = -8;
} else if (lsame_(fact, "F") && ! (rcequ || lsame_(
equed, "N"))) {
*info = -9;
} 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);
}
if (smin <= 0.) {
*info = -10;
} else if (*n > 0) {
scond = max(smin,smlnum) / min(smax,bignum);
} else {
scond = 1.;
}
}
if (*info == 0) {
if (*ldb < max(1,*n)) {
*info = -12;
} else if (*ldx < max(1,*n)) {
*info = -14;
}
}
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("DPOSVX", &i__1);
return 0;
}
if (equil) {
/* Compute row and column scalings to equilibrate the matrix A. */
dpoequ_(n, &a[a_offset], lda, &s[1], &scond, &amax, &infequ);
if (infequ == 0) {
/* Equilibrate the matrix. */
dlaqsy_(uplo, n, &a[a_offset], lda, &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];
}
}
}
if (nofact || equil) {
/* Compute the Cholesky factorization A = U'*U or A = L*L'. */
dlacpy_(uplo, n, n, &a[a_offset], lda, &af[af_offset], ldaf);
dpotrf_(uplo, n, &af[af_offset], ldaf, info);
/* Return if INFO is non-zero. */
if (*info > 0) {
*rcond = 0.;
return 0;
}
}
/* Compute the norm of the matrix A. */
anorm = dlansy_("1", uplo, n, &a[a_offset], lda, &work[1]);
/* Compute the reciprocal of the condition number of A. */
dpocon_(uplo, n, &af[af_offset], ldaf, &anorm, rcond, &work[1], &iwork[1],
info);
/* Compute the solution matrix X. */
dlacpy_("Full", n, nrhs, &b[b_offset], ldb, &x[x_offset], ldx);
dpotrs_(uplo, n, nrhs, &af[af_offset], ldaf, &x[x_offset], ldx, info);
/* Use iterative refinement to improve the computed solution and */
/* compute error bounds and backward error estimates for it. */
dporfs_(uplo, n, nrhs, &a[a_offset], lda, &af[af_offset], ldaf, &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];
}
}
i__1 = *nrhs;
for (j = 1; j <= i__1; ++j) {
ferr[j] /= scond;
}
}
/* Set INFO = N+1 if the matrix is singular to working precision. */
if (*rcond < dlamch_("Epsilon")) {
*info = *n + 1;
}
return 0;
/* End of DPOSVX */
} /* dposvx_ */
/* Subroutine */ int dchkpo_(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 };
static char uplos[1*2] = "U" "L";
/* Format strings */
static char fmt_9999[] = "(\002 UPLO = '\002,a1,\002', N =\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, "
"NRHS=\002,i3,\002, type \002,i2,\002, test(\002,i2,\002) =\002,g"
"12.5)";
static char fmt_9997[] = "(\002 UPLO = '\002,a1,\002', N =\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;
/* Builtin functions */
/* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);
integer s_wsfe(cilist *), do_fio(integer *, char *, ftnlen), e_wsfe(void);
/* Local variables */
integer i__, k, n, nb, in, kl, ku, lda, inb, ioff, mode, imat, info;
char path[3], dist[1];
integer irhs, nrhs;
char uplo[1], type__[1];
integer nrun;
extern /* Subroutine */ int alahd_(integer *, char *), dget04_(
integer *, integer *, doublereal *, integer *, doublereal *,
integer *, doublereal *, doublereal *);
integer nfail, iseed[4];
extern doublereal dget06_(doublereal *, doublereal *);
doublereal rcond;
extern /* Subroutine */ int dpot01_(char *, integer *, doublereal *,
integer *, doublereal *, integer *, doublereal *, doublereal *);
integer nimat;
extern /* Subroutine */ int dpot02_(char *, integer *, integer *,
doublereal *, integer *, doublereal *, integer *, doublereal *,
integer *, doublereal *, doublereal *), dpot03_(char *,
integer *, doublereal *, integer *, doublereal *, integer *,
doublereal *, integer *, doublereal *, doublereal *, doublereal *), dpot05_(char *, integer *, integer *, doublereal *,
integer *, doublereal *, integer *, doublereal *, integer *,
doublereal *, integer *, doublereal *, doublereal *, doublereal *);
doublereal anorm;
integer iuplo, izero, nerrs;
logical zerot;
char xtype[1];
extern /* Subroutine */ int dlatb4_(char *, integer *, integer *, integer
*, char *, integer *, integer *, doublereal *, integer *,
doublereal *, char *), alaerh_(char *,
char *, integer *, integer *, char *, integer *, integer *,
integer *, integer *, integer *, integer *, integer *, integer *,
integer *);
doublereal rcondc;
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 *), alasum_(char *,
integer *, integer *, integer *, integer *);
doublereal cndnum;
extern /* Subroutine */ int dlatms_(integer *, integer *, char *, integer
*, char *, doublereal *, integer *, doublereal *, doublereal *,
integer *, integer *, char *, doublereal *, integer *, doublereal
*, integer *), dpocon_(char *, integer *,
doublereal *, integer *, doublereal *, doublereal *, doublereal *,
integer *, integer *);
extern doublereal dlansy_(char *, char *, integer *, doublereal *,
integer *, doublereal *);
extern /* Subroutine */ int derrpo_(char *, integer *), dporfs_(
char *, integer *, integer *, doublereal *, integer *, doublereal
*, integer *, doublereal *, integer *, doublereal *, integer *,
doublereal *, doublereal *, doublereal *, integer *, integer *), dpotrf_(char *, integer *, doublereal *, integer *,
integer *), xlaenv_(integer *, integer *), dpotri_(char *,
integer *, doublereal *, integer *, integer *), dpotrs_(
char *, integer *, integer *, doublereal *, integer *, doublereal
*, integer *, integer *);
doublereal result[8];
/* Fortran I/O blocks */
static cilist io___33 = { 0, 0, 0, fmt_9999, 0 };
static cilist io___36 = { 0, 0, 0, fmt_9998, 0 };
static cilist io___38 = { 0, 0, 0, fmt_9997, 0 };
/* -- LAPACK test routine (version 3.1) -- */
/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/* November 2006 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* DCHKPO tests DPOTRF, -TRI, -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. */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. Local Arrays .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Scalars in Common .. */
/* .. */
/* .. Common blocks .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Data statements .. */
/* Parameter adjustments */
--iwork;
--rwork;
--work;
--xact;
--x;
--b;
--ainv;
--afac;
--a;
--nsval;
--nbval;
--nval;
--dotype;
/* Function Body */
/* .. */
/* .. Executable Statements .. */
/* Initialize constants and the random number seed. */
s_copy(path, "Double precision", (ftnlen)1, (ftnlen)16);
s_copy(path + 1, "PO", (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);
/* 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';
nimat = 9;
if (n <= 0) {
nimat = 1;
}
izero = 0;
i__2 = nimat;
for (imat = 1; imat <= i__2; ++imat) {
/* Do the tests only if DOTYPE( IMAT ) is true. */
if (! dotype[imat]) {
goto L110;
}
/* Skip types 3, 4, or 5 if the matrix size is too small. */
zerot = imat >= 3 && imat <= 5;
if (zerot && n < imat - 2) {
goto L110;
}
/* Do first for UPLO = 'U', then for UPLO = 'L' */
for (iuplo = 1; iuplo <= 2; ++iuplo) {
*(unsigned char *)uplo = *(unsigned char *)&uplos[iuplo - 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, &kl, &ku, uplo, &a[1], &lda, &work[1],
&info);
/* Check error code from DLATMS. */
if (info != 0) {
alaerh_(path, "DLATMS", &info, &c__0, uplo, &n, &n, &c_n1,
&c_n1, &c_n1, &imat, &nfail, &nerrs, nout);
goto L100;
}
/* For types 3-5, zero one row and column of the matrix to */
/* test that INFO is returned correctly. */
if (zerot) {
if (imat == 3) {
izero = 1;
} else if (imat == 4) {
izero = n;
} else {
izero = n / 2 + 1;
}
ioff = (izero - 1) * lda;
/* Set row and column IZERO of A to 0. */
if (iuplo == 1) {
i__3 = izero - 1;
for (i__ = 1; i__ <= i__3; ++i__) {
a[ioff + i__] = 0.;
/* L20: */
}
ioff += izero;
i__3 = n;
for (i__ = izero; i__ <= i__3; ++i__) {
a[ioff] = 0.;
ioff += lda;
/* L30: */
}
} else {
ioff = izero;
i__3 = izero - 1;
for (i__ = 1; i__ <= i__3; ++i__) {
a[ioff] = 0.;
ioff += lda;
/* L40: */
}
ioff -= izero;
i__3 = n;
for (i__ = izero; i__ <= i__3; ++i__) {
a[ioff + i__] = 0.;
/* L50: */
}
}
} else {
izero = 0;
}
/* Do for each value of NB in NBVAL */
i__3 = *nnb;
for (inb = 1; inb <= i__3; ++inb) {
nb = nbval[inb];
xlaenv_(&c__1, &nb);
/* Compute the L*L' or U'*U factorization of the matrix. */
dlacpy_(uplo, &n, &n, &a[1], &lda, &afac[1], &lda);
s_copy(srnamc_1.srnamt, "DPOTRF", (ftnlen)6, (ftnlen)6);
dpotrf_(uplo, &n, &afac[1], &lda, &info);
/* Check error code from DPOTRF. */
if (info != izero) {
alaerh_(path, "DPOTRF", &info, &izero, uplo, &n, &n, &
c_n1, &c_n1, &nb, &imat, &nfail, &nerrs, nout);
goto L90;
}
/* Skip the tests if INFO is not 0. */
if (info != 0) {
goto L90;
}
/* + TEST 1 */
/* Reconstruct matrix from factors and compute residual. */
dlacpy_(uplo, &n, &n, &afac[1], &lda, &ainv[1], &lda);
dpot01_(uplo, &n, &a[1], &lda, &ainv[1], &lda, &rwork[1],
result);
/* + TEST 2 */
/* Form the inverse and compute the residual. */
dlacpy_(uplo, &n, &n, &afac[1], &lda, &ainv[1], &lda);
s_copy(srnamc_1.srnamt, "DPOTRI", (ftnlen)6, (ftnlen)6);
dpotri_(uplo, &n, &ainv[1], &lda, &info);
/* Check error code from DPOTRI. */
if (info != 0) {
alaerh_(path, "DPOTRI", &info, &c__0, uplo, &n, &n, &
c_n1, &c_n1, &c_n1, &imat, &nfail, &nerrs,
nout);
}
dpot03_(uplo, &n, &a[1], &lda, &ainv[1], &lda, &work[1], &
lda, &rwork[1], &rcondc, &result[1]);
/* Print information about the tests that did not pass */
/* the threshold. */
for (k = 1; k <= 2; ++k) {
if (result[k - 1] >= *thresh) {
if (nfail == 0 && nerrs == 0) {
alahd_(nout, path);
}
io___33.ciunit = *nout;
s_wsfe(&io___33);
do_fio(&c__1, uplo, (ftnlen)1);
do_fio(&c__1, (char *)&n, (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 *)&k, (ftnlen)sizeof(integer))
;
do_fio(&c__1, (char *)&result[k - 1], (ftnlen)
sizeof(doublereal));
e_wsfe();
++nfail;
}
/* L60: */
}
nrun += 2;
/* Skip the rest of the tests unless this is the first */
/* blocksize. */
if (inb != 1) {
goto L90;
}
i__4 = *nns;
for (irhs = 1; irhs <= i__4; ++irhs) {
nrhs = nsval[irhs];
/* + TEST 3 */
/* Solve and compute residual for A * X = B . */
s_copy(srnamc_1.srnamt, "DLARHS", (ftnlen)6, (ftnlen)
6);
dlarhs_(path, xtype, uplo, " ", &n, &n, &kl, &ku, &
nrhs, &a[1], &lda, &xact[1], &lda, &b[1], &
lda, iseed, &info);
dlacpy_("Full", &n, &nrhs, &b[1], &lda, &x[1], &lda);
s_copy(srnamc_1.srnamt, "DPOTRS", (ftnlen)6, (ftnlen)
6);
dpotrs_(uplo, &n, &nrhs, &afac[1], &lda, &x[1], &lda,
&info);
/* Check error code from DPOTRS. */
if (info != 0) {
alaerh_(path, "DPOTRS", &info, &c__0, uplo, &n, &
n, &c_n1, &c_n1, &nrhs, &imat, &nfail, &
nerrs, nout);
}
dlacpy_("Full", &n, &nrhs, &b[1], &lda, &work[1], &
lda);
dpot02_(uplo, &n, &nrhs, &a[1], &lda, &x[1], &lda, &
work[1], &lda, &rwork[1], &result[2]);
/* + TEST 4 */
/* Check solution from generated exact solution. */
dget04_(&n, &nrhs, &x[1], &lda, &xact[1], &lda, &
rcondc, &result[3]);
/* + TESTS 5, 6, and 7 */
/* Use iterative refinement to improve the solution. */
s_copy(srnamc_1.srnamt, "DPORFS", (ftnlen)6, (ftnlen)
6);
dporfs_(uplo, &n, &nrhs, &a[1], &lda, &afac[1], &lda,
&b[1], &lda, &x[1], &lda, &rwork[1], &rwork[
nrhs + 1], &work[1], &iwork[1], &info);
/* Check error code from DPORFS. */
if (info != 0) {
alaerh_(path, "DPORFS", &info, &c__0, uplo, &n, &
n, &c_n1, &c_n1, &nrhs, &imat, &nfail, &
nerrs, nout);
}
dget04_(&n, &nrhs, &x[1], &lda, &xact[1], &lda, &
rcondc, &result[4]);
dpot05_(uplo, &n, &nrhs, &a[1], &lda, &b[1], &lda, &x[
1], &lda, &xact[1], &lda, &rwork[1], &rwork[
nrhs + 1], &result[5]);
/* Print information about the tests that did not pass */
/* the threshold. */
for (k = 3; k <= 7; ++k) {
if (result[k - 1] >= *thresh) {
if (nfail == 0 && nerrs == 0) {
alahd_(nout, path);
}
io___36.ciunit = *nout;
s_wsfe(&io___36);
do_fio(&c__1, uplo, (ftnlen)1);
do_fio(&c__1, (char *)&n, (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;
}
/* L70: */
}
nrun += 5;
/* L80: */
}
/* + TEST 8 */
/* Get an estimate of RCOND = 1/CNDNUM. */
anorm = dlansy_("1", uplo, &n, &a[1], &lda, &rwork[1]);
s_copy(srnamc_1.srnamt, "DPOCON", (ftnlen)6, (ftnlen)6);
dpocon_(uplo, &n, &afac[1], &lda, &anorm, &rcond, &work[1]
, &iwork[1], &info);
/* Check error code from DPOCON. */
if (info != 0) {
alaerh_(path, "DPOCON", &info, &c__0, uplo, &n, &n, &
c_n1, &c_n1, &c_n1, &imat, &nfail, &nerrs,
nout);
}
result[7] = dget06_(&rcond, &rcondc);
/* Print the test ratio if it is .GE. THRESH. */
if (result[7] >= *thresh) {
if (nfail == 0 && nerrs == 0) {
alahd_(nout, path);
}
io___38.ciunit = *nout;
s_wsfe(&io___38);
do_fio(&c__1, uplo, (ftnlen)1);
do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&imat, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&c__8, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&result[7], (ftnlen)sizeof(
doublereal));
e_wsfe();
++nfail;
}
++nrun;
L90:
;
}
L100:
;
}
L110:
;
}
/* L120: */
}
/* Print a summary of the results. */
alasum_(path, nout, &nfail, &nrun, &nerrs);
return 0;
/* End of DCHKPO */
} /* dchkpo_ */
/* Subroutine */ int derrpo_(char *path, integer *nunit)
{
/* Builtin functions */
integer s_wsle(cilist *), e_wsle(void);
/* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);
/* Local variables */
doublereal a[16] /* was [4][4] */, b[4];
integer i__, j;
doublereal w[12], x[4];
char c2[2];
doublereal r1[4], r2[4], af[16] /* was [4][4] */;
integer iw[4], info;
doublereal anrm, rcond;
extern /* Subroutine */ int dpbtf2_(char *, integer *, integer *,
doublereal *, integer *, integer *), dpotf2_(char *,
integer *, doublereal *, integer *, integer *), alaesm_(
char *, logical *, integer *), dpbcon_(char *, integer *,
integer *, doublereal *, integer *, doublereal *, doublereal *,
doublereal *, integer *, integer *);
extern logical lsamen_(integer *, char *, char *);
extern /* Subroutine */ int dpbequ_(char *, integer *, integer *,
doublereal *, 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 *), dpocon_(char *, integer *, doublereal *,
integer *, doublereal *, doublereal *, doublereal *, integer *,
integer *), chkxer_(char *, integer *, integer *, logical
*, logical *), dppcon_(char *, integer *, doublereal *,
doublereal *, doublereal *, doublereal *, integer *, integer *), dpoequ_(integer *, doublereal *, integer *, doublereal *,
doublereal *, doublereal *, integer *), dpbtrs_(char *, integer *
, integer *, integer *, doublereal *, integer *, doublereal *,
integer *, integer *), dporfs_(char *, integer *, integer
*, doublereal *, integer *, doublereal *, integer *, doublereal *,
integer *, doublereal *, integer *, doublereal *, doublereal *,
doublereal *, integer *, integer *), dpotrf_(char *,
integer *, doublereal *, integer *, integer *), dpotri_(
char *, integer *, doublereal *, integer *, integer *),
dppequ_(char *, integer *, doublereal *, doublereal *, doublereal
*, doublereal *, integer *), dpprfs_(char *, integer *,
integer *, doublereal *, doublereal *, doublereal *, integer *,
doublereal *, integer *, doublereal *, doublereal *, doublereal *,
integer *, integer *), dpptrf_(char *, integer *,
doublereal *, integer *), dpptri_(char *, integer *,
doublereal *, integer *), dpotrs_(char *, integer *,
integer *, doublereal *, integer *, doublereal *, integer *,
integer *), dpptrs_(char *, integer *, integer *,
doublereal *, doublereal *, integer *, integer *);
/* Fortran I/O blocks */
static cilist io___1 = { 0, 0, 0, 0, 0 };
/* -- LAPACK test routine (version 3.1) -- */
/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/* November 2006 */
/* .. Scalar Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* DERRPO tests the error exits for the DOUBLE PRECISION routines */
/* for symmetric positive definite matrices. */
/* Arguments */
/* ========= */
/* PATH (input) CHARACTER*3 */
/* The LAPACK path name for the routines to be tested. */
/* NUNIT (input) INTEGER */
/* The unit number for output. */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. Local Arrays .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Scalars in Common .. */
/* .. */
/* .. Common blocks .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Executable Statements .. */
infoc_1.nout = *nunit;
io___1.ciunit = infoc_1.nout;
s_wsle(&io___1);
e_wsle();
s_copy(c2, path + 1, (ftnlen)2, (ftnlen)2);
/* Set the variables to innocuous values. */
for (j = 1; j <= 4; ++j) {
for (i__ = 1; i__ <= 4; ++i__) {
a[i__ + (j << 2) - 5] = 1. / (doublereal) (i__ + j);
af[i__ + (j << 2) - 5] = 1. / (doublereal) (i__ + j);
/* L10: */
}
b[j - 1] = 0.;
r1[j - 1] = 0.;
r2[j - 1] = 0.;
w[j - 1] = 0.;
x[j - 1] = 0.;
iw[j - 1] = j;
/* L20: */
}
infoc_1.ok = TRUE_;
if (lsamen_(&c__2, c2, "PO")) {
/* Test error exits of the routines that use the Cholesky */
/* decomposition of a symmetric positive definite matrix. */
/* DPOTRF */
s_copy(srnamc_1.srnamt, "DPOTRF", (ftnlen)32, (ftnlen)6);
infoc_1.infot = 1;
dpotrf_("/", &c__0, a, &c__1, &info);
chkxer_("DPOTRF", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 2;
dpotrf_("U", &c_n1, a, &c__1, &info);
chkxer_("DPOTRF", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 4;
dpotrf_("U", &c__2, a, &c__1, &info);
chkxer_("DPOTRF", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
/* DPOTF2 */
s_copy(srnamc_1.srnamt, "DPOTF2", (ftnlen)32, (ftnlen)6);
infoc_1.infot = 1;
dpotf2_("/", &c__0, a, &c__1, &info);
chkxer_("DPOTF2", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 2;
dpotf2_("U", &c_n1, a, &c__1, &info);
chkxer_("DPOTF2", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 4;
dpotf2_("U", &c__2, a, &c__1, &info);
chkxer_("DPOTF2", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
/* DPOTRI */
s_copy(srnamc_1.srnamt, "DPOTRI", (ftnlen)32, (ftnlen)6);
infoc_1.infot = 1;
dpotri_("/", &c__0, a, &c__1, &info);
chkxer_("DPOTRI", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 2;
dpotri_("U", &c_n1, a, &c__1, &info);
chkxer_("DPOTRI", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 4;
dpotri_("U", &c__2, a, &c__1, &info);
chkxer_("DPOTRI", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
/* DPOTRS */
s_copy(srnamc_1.srnamt, "DPOTRS", (ftnlen)32, (ftnlen)6);
infoc_1.infot = 1;
dpotrs_("/", &c__0, &c__0, a, &c__1, b, &c__1, &info);
chkxer_("DPOTRS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 2;
dpotrs_("U", &c_n1, &c__0, a, &c__1, b, &c__1, &info);
chkxer_("DPOTRS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 3;
dpotrs_("U", &c__0, &c_n1, a, &c__1, b, &c__1, &info);
chkxer_("DPOTRS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 5;
dpotrs_("U", &c__2, &c__1, a, &c__1, b, &c__2, &info);
chkxer_("DPOTRS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 7;
dpotrs_("U", &c__2, &c__1, a, &c__2, b, &c__1, &info);
chkxer_("DPOTRS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
/* DPORFS */
s_copy(srnamc_1.srnamt, "DPORFS", (ftnlen)32, (ftnlen)6);
infoc_1.infot = 1;
dporfs_("/", &c__0, &c__0, a, &c__1, af, &c__1, b, &c__1, x, &c__1,
r1, r2, w, iw, &info);
chkxer_("DPORFS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 2;
dporfs_("U", &c_n1, &c__0, a, &c__1, af, &c__1, b, &c__1, x, &c__1,
r1, r2, w, iw, &info);
chkxer_("DPORFS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 3;
dporfs_("U", &c__0, &c_n1, a, &c__1, af, &c__1, b, &c__1, x, &c__1,
r1, r2, w, iw, &info);
chkxer_("DPORFS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 5;
dporfs_("U", &c__2, &c__1, a, &c__1, af, &c__2, b, &c__2, x, &c__2,
r1, r2, w, iw, &info);
chkxer_("DPORFS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 7;
dporfs_("U", &c__2, &c__1, a, &c__2, af, &c__1, b, &c__2, x, &c__2,
r1, r2, w, iw, &info);
chkxer_("DPORFS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 9;
dporfs_("U", &c__2, &c__1, a, &c__2, af, &c__2, b, &c__1, x, &c__2,
r1, r2, w, iw, &info);
chkxer_("DPORFS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 11;
dporfs_("U", &c__2, &c__1, a, &c__2, af, &c__2, b, &c__2, x, &c__1,
r1, r2, w, iw, &info);
chkxer_("DPORFS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
/* DPOCON */
s_copy(srnamc_1.srnamt, "DPOCON", (ftnlen)32, (ftnlen)6);
infoc_1.infot = 1;
dpocon_("/", &c__0, a, &c__1, &anrm, &rcond, w, iw, &info);
chkxer_("DPOCON", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 2;
dpocon_("U", &c_n1, a, &c__1, &anrm, &rcond, w, iw, &info);
chkxer_("DPOCON", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 4;
dpocon_("U", &c__2, a, &c__1, &anrm, &rcond, w, iw, &info);
chkxer_("DPOCON", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
/* DPOEQU */
s_copy(srnamc_1.srnamt, "DPOEQU", (ftnlen)32, (ftnlen)6);
infoc_1.infot = 1;
dpoequ_(&c_n1, a, &c__1, r1, &rcond, &anrm, &info);
chkxer_("DPOEQU", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 3;
dpoequ_(&c__2, a, &c__1, r1, &rcond, &anrm, &info);
chkxer_("DPOEQU", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
} else if (lsamen_(&c__2, c2, "PP")) {
/* Test error exits of the routines that use the Cholesky */
/* decomposition of a symmetric positive definite packed matrix. */
/* DPPTRF */
s_copy(srnamc_1.srnamt, "DPPTRF", (ftnlen)32, (ftnlen)6);
infoc_1.infot = 1;
dpptrf_("/", &c__0, a, &info);
chkxer_("DPPTRF", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 2;
dpptrf_("U", &c_n1, a, &info);
chkxer_("DPPTRF", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
/* DPPTRI */
s_copy(srnamc_1.srnamt, "DPPTRI", (ftnlen)32, (ftnlen)6);
infoc_1.infot = 1;
dpptri_("/", &c__0, a, &info);
chkxer_("DPPTRI", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 2;
dpptri_("U", &c_n1, a, &info);
chkxer_("DPPTRI", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
/* DPPTRS */
s_copy(srnamc_1.srnamt, "DPPTRS", (ftnlen)32, (ftnlen)6);
infoc_1.infot = 1;
dpptrs_("/", &c__0, &c__0, a, b, &c__1, &info);
chkxer_("DPPTRS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 2;
dpptrs_("U", &c_n1, &c__0, a, b, &c__1, &info);
chkxer_("DPPTRS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 3;
dpptrs_("U", &c__0, &c_n1, a, b, &c__1, &info);
chkxer_("DPPTRS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 6;
dpptrs_("U", &c__2, &c__1, a, b, &c__1, &info);
chkxer_("DPPTRS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
/* DPPRFS */
s_copy(srnamc_1.srnamt, "DPPRFS", (ftnlen)32, (ftnlen)6);
infoc_1.infot = 1;
dpprfs_("/", &c__0, &c__0, a, af, b, &c__1, x, &c__1, r1, r2, w, iw, &
info);
chkxer_("DPPRFS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 2;
dpprfs_("U", &c_n1, &c__0, a, af, b, &c__1, x, &c__1, r1, r2, w, iw, &
info);
chkxer_("DPPRFS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 3;
dpprfs_("U", &c__0, &c_n1, a, af, b, &c__1, x, &c__1, r1, r2, w, iw, &
info);
chkxer_("DPPRFS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 7;
dpprfs_("U", &c__2, &c__1, a, af, b, &c__1, x, &c__2, r1, r2, w, iw, &
info);
chkxer_("DPPRFS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 9;
dpprfs_("U", &c__2, &c__1, a, af, b, &c__2, x, &c__1, r1, r2, w, iw, &
info);
chkxer_("DPPRFS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
/* DPPCON */
s_copy(srnamc_1.srnamt, "DPPCON", (ftnlen)32, (ftnlen)6);
infoc_1.infot = 1;
dppcon_("/", &c__0, a, &anrm, &rcond, w, iw, &info);
chkxer_("DPPCON", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 2;
dppcon_("U", &c_n1, a, &anrm, &rcond, w, iw, &info);
chkxer_("DPPCON", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
/* DPPEQU */
s_copy(srnamc_1.srnamt, "DPPEQU", (ftnlen)32, (ftnlen)6);
infoc_1.infot = 1;
dppequ_("/", &c__0, a, r1, &rcond, &anrm, &info);
chkxer_("DPPEQU", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 2;
dppequ_("U", &c_n1, a, r1, &rcond, &anrm, &info);
chkxer_("DPPEQU", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
} else if (lsamen_(&c__2, c2, "PB")) {
/* Test error exits of the routines that use the Cholesky */
/* decomposition of a symmetric positive definite band matrix. */
/* DPBTRF */
s_copy(srnamc_1.srnamt, "DPBTRF", (ftnlen)32, (ftnlen)6);
infoc_1.infot = 1;
dpbtrf_("/", &c__0, &c__0, a, &c__1, &info);
chkxer_("DPBTRF", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 2;
dpbtrf_("U", &c_n1, &c__0, a, &c__1, &info);
chkxer_("DPBTRF", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 3;
dpbtrf_("U", &c__1, &c_n1, a, &c__1, &info);
chkxer_("DPBTRF", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 5;
dpbtrf_("U", &c__2, &c__1, a, &c__1, &info);
chkxer_("DPBTRF", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
/* DPBTF2 */
s_copy(srnamc_1.srnamt, "DPBTF2", (ftnlen)32, (ftnlen)6);
infoc_1.infot = 1;
dpbtf2_("/", &c__0, &c__0, a, &c__1, &info);
chkxer_("DPBTF2", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 2;
dpbtf2_("U", &c_n1, &c__0, a, &c__1, &info);
chkxer_("DPBTF2", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 3;
dpbtf2_("U", &c__1, &c_n1, a, &c__1, &info);
chkxer_("DPBTF2", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 5;
dpbtf2_("U", &c__2, &c__1, a, &c__1, &info);
chkxer_("DPBTF2", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
/* DPBTRS */
s_copy(srnamc_1.srnamt, "DPBTRS", (ftnlen)32, (ftnlen)6);
infoc_1.infot = 1;
dpbtrs_("/", &c__0, &c__0, &c__0, a, &c__1, b, &c__1, &info);
chkxer_("DPBTRS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 2;
dpbtrs_("U", &c_n1, &c__0, &c__0, a, &c__1, b, &c__1, &info);
chkxer_("DPBTRS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 3;
dpbtrs_("U", &c__1, &c_n1, &c__0, a, &c__1, b, &c__1, &info);
chkxer_("DPBTRS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 4;
dpbtrs_("U", &c__0, &c__0, &c_n1, a, &c__1, b, &c__1, &info);
chkxer_("DPBTRS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 6;
dpbtrs_("U", &c__2, &c__1, &c__1, a, &c__1, b, &c__1, &info);
chkxer_("DPBTRS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 8;
dpbtrs_("U", &c__2, &c__0, &c__1, a, &c__1, b, &c__1, &info);
chkxer_("DPBTRS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
/* DPBRFS */
s_copy(srnamc_1.srnamt, "DPBRFS", (ftnlen)32, (ftnlen)6);
infoc_1.infot = 1;
dpbrfs_("/", &c__0, &c__0, &c__0, a, &c__1, af, &c__1, b, &c__1, x, &
c__1, r1, r2, w, iw, &info);
chkxer_("DPBRFS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 2;
dpbrfs_("U", &c_n1, &c__0, &c__0, a, &c__1, af, &c__1, b, &c__1, x, &
c__1, r1, r2, w, iw, &info);
chkxer_("DPBRFS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 3;
dpbrfs_("U", &c__1, &c_n1, &c__0, a, &c__1, af, &c__1, b, &c__1, x, &
c__1, r1, r2, w, iw, &info);
chkxer_("DPBRFS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 4;
dpbrfs_("U", &c__0, &c__0, &c_n1, a, &c__1, af, &c__1, b, &c__1, x, &
c__1, r1, r2, w, iw, &info);
chkxer_("DPBRFS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 6;
dpbrfs_("U", &c__2, &c__1, &c__1, a, &c__1, af, &c__2, b, &c__2, x, &
c__2, r1, r2, w, iw, &info);
chkxer_("DPBRFS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 8;
dpbrfs_("U", &c__2, &c__1, &c__1, a, &c__2, af, &c__1, b, &c__2, x, &
c__2, r1, r2, w, iw, &info);
chkxer_("DPBRFS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 10;
dpbrfs_("U", &c__2, &c__0, &c__1, a, &c__1, af, &c__1, b, &c__1, x, &
c__2, r1, r2, w, iw, &info);
chkxer_("DPBRFS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 12;
dpbrfs_("U", &c__2, &c__0, &c__1, a, &c__1, af, &c__1, b, &c__2, x, &
c__1, r1, r2, w, iw, &info);
chkxer_("DPBRFS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
/* DPBCON */
s_copy(srnamc_1.srnamt, "DPBCON", (ftnlen)32, (ftnlen)6);
infoc_1.infot = 1;
dpbcon_("/", &c__0, &c__0, a, &c__1, &anrm, &rcond, w, iw, &info);
chkxer_("DPBCON", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 2;
dpbcon_("U", &c_n1, &c__0, a, &c__1, &anrm, &rcond, w, iw, &info);
chkxer_("DPBCON", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 3;
dpbcon_("U", &c__1, &c_n1, a, &c__1, &anrm, &rcond, w, iw, &info);
chkxer_("DPBCON", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 5;
dpbcon_("U", &c__2, &c__1, a, &c__1, &anrm, &rcond, w, iw, &info);
chkxer_("DPBCON", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
/* DPBEQU */
s_copy(srnamc_1.srnamt, "DPBEQU", (ftnlen)32, (ftnlen)6);
infoc_1.infot = 1;
dpbequ_("/", &c__0, &c__0, a, &c__1, r1, &rcond, &anrm, &info);
chkxer_("DPBEQU", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 2;
dpbequ_("U", &c_n1, &c__0, a, &c__1, r1, &rcond, &anrm, &info);
chkxer_("DPBEQU", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 3;
dpbequ_("U", &c__1, &c_n1, a, &c__1, r1, &rcond, &anrm, &info);
chkxer_("DPBEQU", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 5;
dpbequ_("U", &c__2, &c__1, a, &c__1, r1, &rcond, &anrm, &info);
chkxer_("DPBEQU", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
}
/* Print a summary line. */
alaesm_(path, &infoc_1.ok, &infoc_1.nout);
return 0;
/* End of DERRPO */
} /* derrpo_ */
