/* PN_TV1_Weighted
Given a reference signal y and a weight vector lambda, solves the proximity operator
min_x 0.5 ||x-y||^2 + sum_i lambda_i |x_i - x_(i-1)| .
To do so a Projected Newton algorithm is used to solve its dual problem.
Inputs:
- y: reference signal.
- lambda: weight vector.
- x: array in which to store the solution.
- info: array in which to store optimizer information.
- n: length of array y (and x).
- sigma: tolerance for sufficient descent.
- ws: workspace of allocated memory to use. If NULL, any needed memory is locally managed.
*/
int PN_TV1_Weighted(double *y,double *lambda,double *x,double *info,int n,double sigma,Workspace *ws){
int i,ind,nI,recomp,found,iters,nn=n-1;
double lambdaMax,tmp,fval0,fval1,gRd,delta,grad0,stop,stopPrev,improve,rhs,maxStep,prevDelta;
double *w=NULL,*g=NULL,*d=NULL,*aux=NULL,*aux2=NULL;
int *inactive=NULL;
lapack_int one=1,rc,nnp=nn,nIp;
/* Macros */
#define GRAD2GAP(g,w,gap,i) \
gap = 0; \
for(i=0;i<nn;i++) \
gap += fabs(g[i]) * lambda[i] + w[i] * g[i];
#define PRIMAL2VAL(x,val,i) \
val = 0; \
for(i=0;i<n;i++) \
val += x[i]*x[i]; \
val *= 0.5;
#define PROJECTION(w) \
for(i=0;i<nn;i++) \
if(w[i] > lambda[i]) w[i] = lambda[i]; \
else if(w[i] < -lambda[i]) w[i] = -lambda[i];
#define CHECK_INACTIVE(w,g,inactive,nI,i) \
for(i=nI=0 ; i<nn ; i++) \
if( (w[i] > -lambda[i] && w[i] < lambda[i]) || (w[i] == -lambda[i] && g[i] < -EPSILON) || (w[i] == lambda[i] && g[i] > EPSILON) ) \
inactive[nI++] = i;
#define FREE \
if(!ws){ \
if(w) free(w); \
if(g) free(g); \
if(d) free(d); \
if(aux) free(aux); \
if(aux2) free(aux2); \
if(inactive) free(inactive); \
}
#define CANCEL(txt,info) \
printf("PN_TV1: %s\n",txt); \
FREE \
if(info) info[INFO_RC] = RC_ERROR;\
return 0;
/* Alloc memory if no workspace available */
if(!ws){
w = (double*)malloc(sizeof(double)*nn);
g = (double*)malloc(sizeof(double)*nn);
d = (double*)malloc(sizeof(double)*nn);
aux = (double*)malloc(sizeof(double)*nn);
aux2 = (double*)malloc(sizeof(double)*nn);
inactive = (int*)malloc(sizeof(int)*nn);
}
/* If a workspace is available, request memory */
else{
w = getDoubleWorkspace(ws);
g = getDoubleWorkspace(ws);
d = getDoubleWorkspace(ws);
aux = getDoubleWorkspace(ws);
aux2 = getDoubleWorkspace(ws);
inactive = getIntWorkspace(ws);
}
if(!w || !g || ! d || !aux || !aux2 || !inactive)
{CANCEL("out of memory",info)}
/* Precompute useful quantities */
for(i=0;i<nn;i++)
w[i] = (y[i+1] - y[i]); /* Dy */
iters = 0;
/* Factorize Hessian */
for(i=0;i<nn-1;i++){
aux[i] = 2;
aux2[i] = -1;
}
aux[nn-1] = 2;
dpttrf_(&nnp,aux,aux2,&rc);
/* Solve Choleski-like linear system to obtain unconstrained solution */
dpttrs_(&nnp, &one, aux, aux2, w, &nnp, &rc);
/* above assume we solved DD'u = Dy */
/* we wanted to solve DD'Wu = Dy; so now obtain u by dividing by W */
for(i=0;i<nn;i++) w[i]=w[i] / lambda[i];
/* Compute maximum effective penalty */
lambdaMax = 0;
for(i=0;i<nn;i++)
if((tmp = fabs(w[i])) > lambdaMax) lambdaMax = tmp;
/* Check if the unconstrained solution is feasible for the given lambda */
#ifdef DEBUG
fprintf(DEBUG_FILE,"lambda=%lf,lambdaMax=%lf\n",1.0,lambdaMax);
#endif
/* check if infnorm(u ./ w) <= 1 */
if(1.0 >= lambdaMax){
/* In this case all entries of the primal solution should be the same as the mean of y */
tmp = 0;
for(i=0;i<n;i++) tmp += y[i];
tmp /= n;
for(i=0;i<n;i++) x[i] = tmp;
/* Gradient evaluation */
PRIMAL2GRAD(x,g,i)
/* Compute dual gap */
GRAD2GAP(g,w,stop,i)
if(info){
info[INFO_GAP] = fabs(stop);
info[INFO_ITERS] = 0;
info[INFO_RC] = RC_OK;
}
FREE
return 1;
}
/* Subroutine */ int dptsvx_(char *fact, integer *n, integer *nrhs,
doublereal *d__, doublereal *e, doublereal *df, doublereal *ef,
doublereal *b, integer *ldb, doublereal *x, integer *ldx, doublereal *
rcond, doublereal *ferr, doublereal *berr, doublereal *work, integer *
info)
{
/* System generated locals */
integer b_dim1, b_offset, x_dim1, x_offset, i__1;
/* Local variables */
extern logical lsame_(char *, char *);
doublereal anorm;
extern /* Subroutine */ int dcopy_(integer *, doublereal *, integer *,
doublereal *, integer *);
extern doublereal dlamch_(char *);
logical nofact;
extern /* Subroutine */ int dlacpy_(char *, integer *, integer *,
doublereal *, integer *, doublereal *, integer *),
xerbla_(char *, integer *);
extern doublereal dlanst_(char *, integer *, doublereal *, doublereal *);
extern /* Subroutine */ int dptcon_(integer *, doublereal *, doublereal *,
doublereal *, doublereal *, doublereal *, integer *), dptrfs_(
integer *, integer *, doublereal *, doublereal *, doublereal *,
doublereal *, doublereal *, integer *, doublereal *, integer *,
doublereal *, doublereal *, doublereal *, integer *), dpttrf_(
integer *, doublereal *, doublereal *, integer *), dpttrs_(
integer *, integer *, doublereal *, doublereal *, doublereal *,
integer *, integer *);
/* -- LAPACK routine (version 3.2) -- */
/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/* November 2006 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* DPTSVX uses the factorization A = L*D*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 tridiagonal 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 = 'N', the matrix A is factored as A = L*D*L**T, where L */
/* is a unit lower bidiagonal matrix and D is diagonal. The */
/* factorization can also be regarded as having the form */
/* A = U**T*D*U. */
/* 2. 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. */
/* 3. The system of equations is solved for X using the factored form */
/* of A. */
/* 4. Iterative refinement is applied to improve the computed solution */
/* matrix and calculate error bounds and backward error estimates */
/* for it. */
/* Arguments */
/* ========= */
/* FACT (input) CHARACTER*1 */
/* Specifies whether or not the factored form of A has been */
/* supplied on entry. */
/* = 'F': On entry, DF and EF contain the factored form of A. */
/* D, E, DF, and EF will not be modified. */
/* = 'N': The matrix A will be copied to DF and EF and */
/* factored. */
/* 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. */
/* D (input) DOUBLE PRECISION array, dimension (N) */
/* The n diagonal elements of the tridiagonal matrix A. */
/* E (input) DOUBLE PRECISION array, dimension (N-1) */
/* The (n-1) subdiagonal elements of the tridiagonal matrix A. */
/* DF (input or output) DOUBLE PRECISION array, dimension (N) */
/* If FACT = 'F', then DF is an input argument and on entry */
/* contains the n diagonal elements of the diagonal matrix D */
/* from the L*D*L**T factorization of A. */
/* If FACT = 'N', then DF is an output argument and on exit */
/* contains the n diagonal elements of the diagonal matrix D */
/* from the L*D*L**T factorization of A. */
/* EF (input or output) DOUBLE PRECISION array, dimension (N-1) */
/* If FACT = 'F', then EF is an input argument and on entry */
/* contains the (n-1) subdiagonal elements of the unit */
/* bidiagonal factor L from the L*D*L**T factorization of A. */
/* If FACT = 'N', then EF is an output argument and on exit */
/* contains the (n-1) subdiagonal elements of the unit */
/* bidiagonal factor L from the L*D*L**T factorization of A. */
/* B (input) DOUBLE PRECISION array, dimension (LDB,NRHS) */
/* The N-by-NRHS right hand side matrix 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 of INFO = N+1, the N-by-NRHS solution matrix X. */
/* LDX (input) INTEGER */
/* The leading dimension of the array X. LDX >= max(1,N). */
/* RCOND (output) DOUBLE PRECISION */
/* The reciprocal condition number of the matrix A. 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 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). */
/* 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 (2*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. */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Executable Statements .. */
/* Test the input parameters. */
/* Parameter adjustments */
--d__;
--e;
--df;
--ef;
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;
/* Function Body */
*info = 0;
nofact = lsame_(fact, "N");
if (! nofact && ! lsame_(fact, "F")) {
*info = -1;
} else if (*n < 0) {
*info = -2;
} else if (*nrhs < 0) {
*info = -3;
} else if (*ldb < max(1,*n)) {
*info = -9;
} else if (*ldx < max(1,*n)) {
*info = -11;
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("DPTSVX", &i__1);
return 0;
}
if (nofact) {
/* Compute the L*D*L' (or U'*D*U) factorization of A. */
dcopy_(n, &d__[1], &c__1, &df[1], &c__1);
if (*n > 1) {
i__1 = *n - 1;
dcopy_(&i__1, &e[1], &c__1, &ef[1], &c__1);
}
dpttrf_(n, &df[1], &ef[1], info);
/* Return if INFO is non-zero. */
if (*info > 0) {
*rcond = 0.;
return 0;
}
}
/* Compute the norm of the matrix A. */
anorm = dlanst_("1", n, &d__[1], &e[1]);
/* Compute the reciprocal of the condition number of A. */
dptcon_(n, &df[1], &ef[1], &anorm, rcond, &work[1], info);
/* Compute the solution vectors X. */
dlacpy_("Full", n, nrhs, &b[b_offset], ldb, &x[x_offset], ldx);
dpttrs_(n, nrhs, &df[1], &ef[1], &x[x_offset], ldx, info);
/* Use iterative refinement to improve the computed solutions and */
/* compute error bounds and backward error estimates for them. */
dptrfs_(n, nrhs, &d__[1], &e[1], &df[1], &ef[1], &b[b_offset], ldb, &x[
x_offset], ldx, &ferr[1], &berr[1], &work[1], info);
/* Set INFO = N+1 if the matrix is singular to working precision. */
if (*rcond < dlamch_("Epsilon")) {
*info = *n + 1;
}
return 0;
/* End of DPTSVX */
} /* dptsvx_ */
/* Subroutine */ int dptrfs_(integer *n, integer *nrhs, doublereal *d__,
doublereal *e, doublereal *df, doublereal *ef, doublereal *b, integer
*ldb, doublereal *x, integer *ldx, doublereal *ferr, doublereal *berr,
doublereal *work, integer *info)
{
/* System generated locals */
integer b_dim1, b_offset, x_dim1, x_offset, i__1, i__2;
doublereal d__1, d__2, d__3;
/* Local variables */
integer i__, j;
doublereal s, bi, cx, dx, ex;
integer ix, nz;
doublereal eps, safe1, safe2;
integer count;
doublereal safmin;
doublereal lstres;
/* -- LAPACK routine (version 3.2) -- */
/* November 2006 */
/* Purpose */
/* ======= */
/* DPTRFS improves the computed solution to a system of linear */
/* equations when the coefficient matrix is symmetric positive definite */
/* and tridiagonal, and provides error bounds and backward error */
/* estimates for the solution. */
/* Arguments */
/* ========= */
/* 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 matrix B. NRHS >= 0. */
/* D (input) DOUBLE PRECISION array, dimension (N) */
/* The n diagonal elements of the tridiagonal matrix A. */
/* E (input) DOUBLE PRECISION array, dimension (N-1) */
/* The (n-1) subdiagonal elements of the tridiagonal matrix A. */
/* DF (input) DOUBLE PRECISION array, dimension (N) */
/* The n diagonal elements of the diagonal matrix D from the */
/* factorization computed by DPTTRF. */
/* EF (input) DOUBLE PRECISION array, dimension (N-1) */
/* The (n-1) subdiagonal elements of the unit bidiagonal factor */
/* L from the factorization computed by DPTTRF. */
/* 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 DPTTRS. */
/* 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 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). */
/* 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 (2*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 */
--d__;
--e;
--df;
--ef;
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;
/* Function Body */
*info = 0;
if (*n < 0) {
*info = -1;
} else if (*nrhs < 0) {
*info = -2;
} else if (*ldb < max(1,*n)) {
*info = -8;
} else if (*ldx < max(1,*n)) {
*info = -10;
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("DPTRFS", &i__1);
return 0;
}
/* Quick return if possible */
if (*n == 0 || *nrhs == 0) {
i__1 = *nrhs;
for (j = 1; j <= i__1; ++j) {
ferr[j] = 0.;
berr[j] = 0.;
}
return 0;
}
/* NZ = maximum number of nonzero elements in each row of A, plus 1 */
nz = 4;
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 <= i__1; ++j) {
count = 1;
lstres = 3.;
L20:
/* Loop until stopping criterion is satisfied. */
/* Compute residual R = B - A * X. Also compute */
/* abs(A)*abs(x) + abs(b) for use in the backward error bound. */
if (*n == 1) {
bi = b[j * b_dim1 + 1];
dx = d__[1] * x[j * x_dim1 + 1];
work[*n + 1] = bi - dx;
work[1] = abs(bi) + abs(dx);
} else {
bi = b[j * b_dim1 + 1];
dx = d__[1] * x[j * x_dim1 + 1];
ex = e[1] * x[j * x_dim1 + 2];
work[*n + 1] = bi - dx - ex;
work[1] = abs(bi) + abs(dx) + abs(ex);
i__2 = *n - 1;
for (i__ = 2; i__ <= i__2; ++i__) {
bi = b[i__ + j * b_dim1];
cx = e[i__ - 1] * x[i__ - 1 + j * x_dim1];
dx = d__[i__] * x[i__ + j * x_dim1];
ex = e[i__] * x[i__ + 1 + j * x_dim1];
work[*n + i__] = bi - cx - dx - ex;
work[i__] = abs(bi) + abs(cx) + abs(dx) + abs(ex);
}
bi = b[*n + j * b_dim1];
cx = e[*n - 1] * x[*n - 1 + j * x_dim1];
dx = d__[*n] * x[*n + j * x_dim1];
work[*n + *n] = bi - cx - dx;
work[*n] = abs(bi) + abs(cx) + abs(dx);
}
/* 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 matrix */
/* or vector Z. If the i-th component of the denominator is less */
/* than SAFE2, then SAFE1 is added to the i-th components of the */
/* numerator and denominator before dividing. */
s = 0.;
i__2 = *n;
for (i__ = 1; i__ <= i__2; ++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);
}
}
berr[j] = s;
/* Test stopping criterion. Continue iterating if */
/* 1) The residual BERR(J) is larger than machine epsilon, and */
/* 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. */
dpttrs_(n, &c__1, &df[1], &ef[1], &work[*n + 1], n, info);
daxpy_(n, &c_b11, &work[*n + 1], &c__1, &x[j * x_dim1 + 1], &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 or */
/* 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. */
i__2 = *n;
for (i__ = 1; i__ <= i__2; ++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;
}
}
ix = idamax_(n, &work[1], &c__1);
ferr[j] = work[ix];
/* Estimate the norm of inv(A). */
/* Solve M(A) * x = e, where M(A) = (m(i,j)) is given by */
/* m(i,j) = abs(A(i,j)), i = j, */
/* m(i,j) = -abs(A(i,j)), i .ne. j, */
/* Solve M(L) * x = e. */
work[1] = 1.;
i__2 = *n;
for (i__ = 2; i__ <= i__2; ++i__) {
work[i__] = work[i__ - 1] * (d__1 = ef[i__ - 1], abs(d__1)) + 1.;
}
/* Solve D * M(L)' * x = b. */
work[*n] /= df[*n];
for (i__ = *n - 1; i__ >= 1; --i__) {
work[i__] = work[i__] / df[i__] + work[i__ + 1] * (d__1 = ef[i__],
abs(d__1));
}
/* Compute norm(inv(A)) = max(x(i)), 1<=i<=n. */
ix = idamax_(n, &work[1], &c__1);
ferr[j] *= (d__1 = work[ix], abs(d__1));
/* Normalize error. */
lstres = 0.;
i__2 = *n;
for (i__ = 1; i__ <= i__2; ++i__) {
/* Computing MAX */
d__2 = lstres, d__3 = (d__1 = x[i__ + j * x_dim1], abs(d__1));
lstres = max(d__2,d__3);
}
if (lstres != 0.) {
ferr[j] /= lstres;
}
}
return 0;
/* End of DPTRFS */
} /* dptrfs_ */
/* Subroutine */ int dptrfs_(integer *n, integer *nrhs, doublereal *d,
doublereal *e, doublereal *df, doublereal *ef, doublereal *b, integer
*ldb, doublereal *x, integer *ldx, doublereal *ferr, doublereal *berr,
doublereal *work, 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
=======
DPTRFS improves the computed solution to a system of linear
equations when the coefficient matrix is symmetric positive definite
and tridiagonal, and provides error bounds and backward error
estimates for the solution.
Arguments
=========
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 matrix B. NRHS >= 0.
D (input) DOUBLE PRECISION array, dimension (N)
The n diagonal elements of the tridiagonal matrix A.
E (input) DOUBLE PRECISION array, dimension (N-1)
The (n-1) subdiagonal elements of the tridiagonal matrix A.
DF (input) DOUBLE PRECISION array, dimension (N)
The n diagonal elements of the diagonal matrix D from the
factorization computed by DPTTRF.
EF (input) DOUBLE PRECISION array, dimension (N-1)
The (n-1) subdiagonal elements of the unit bidiagonal factor
L from the factorization computed by DPTTRF.
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 DPTTRS.
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 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).
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 (2*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_b11 = 1.;
/* System generated locals */
integer b_dim1, b_offset, x_dim1, x_offset, i__1, i__2;
doublereal d__1, d__2, d__3;
/* Local variables */
static doublereal safe1, safe2;
static integer i, j;
static doublereal s;
extern /* Subroutine */ int daxpy_(integer *, doublereal *, doublereal *,
integer *, doublereal *, integer *);
static integer count;
static doublereal bi;
extern doublereal dlamch_(char *);
static doublereal cx, dx, ex;
static integer ix;
extern integer idamax_(integer *, doublereal *, integer *);
static integer nz;
static doublereal safmin;
extern /* Subroutine */ int xerbla_(char *, integer *);
static doublereal lstres;
extern /* Subroutine */ int dpttrs_(integer *, integer *, doublereal *,
doublereal *, doublereal *, integer *, integer *);
static doublereal eps;
#define D(I) d[(I)-1]
#define E(I) e[(I)-1]
#define DF(I) df[(I)-1]
#define EF(I) ef[(I)-1]
#define FERR(I) ferr[(I)-1]
#define BERR(I) berr[(I)-1]
#define WORK(I) work[(I)-1]
#define B(I,J) b[(I)-1 + ((J)-1)* ( *ldb)]
#define X(I,J) x[(I)-1 + ((J)-1)* ( *ldx)]
*info = 0;
if (*n < 0) {
*info = -1;
} else if (*nrhs < 0) {
*info = -2;
} else if (*ldb < max(1,*n)) {
*info = -8;
} else if (*ldx < max(1,*n)) {
*info = -10;
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("DPTRFS", &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 = 4;
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. Also compute
abs(A)*abs(x) + abs(b) for use in the backward error bound.
*/
if (*n == 1) {
bi = B(1,j);
dx = D(1) * X(1,j);
WORK(*n + 1) = bi - dx;
WORK(1) = abs(bi) + abs(dx);
} else {
bi = B(1,j);
dx = D(1) * X(1,j);
ex = E(1) * X(2,j);
WORK(*n + 1) = bi - dx - ex;
WORK(1) = abs(bi) + abs(dx) + abs(ex);
i__2 = *n - 1;
for (i = 2; i <= *n-1; ++i) {
bi = B(i,j);
cx = E(i - 1) * X(i-1,j);
dx = D(i) * X(i,j);
ex = E(i) * X(i+1,j);
WORK(*n + i) = bi - cx - dx - ex;
WORK(i) = abs(bi) + abs(cx) + abs(dx) + abs(ex);
/* L30: */
}
bi = B(*n,j);
cx = E(*n - 1) * X(*n-1,j);
dx = D(*n) * X(*n,j);
WORK(*n + *n) = bi - cx - dx;
WORK(*n) = abs(bi) + abs(cx) + abs(dx);
}
/* 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. */
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);
}
/* L40: */
}
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. */
dpttrs_(n, &c__1, &DF(1), &EF(1), &WORK(*n + 1), n, info);
daxpy_(n, &c_b11, &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. */
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;
}
/* L50: */
}
ix = idamax_(n, &WORK(1), &c__1);
FERR(j) = WORK(ix);
/* Estimate the norm of inv(A).
Solve M(A) * x = e, where M(A) = (m(i,j)) is given by
m(i,j) = abs(A(i,j)), i = j,
m(i,j) = -abs(A(i,j)), i .ne. j,
and e = [ 1, 1, ..., 1 ]'. Note M(A) = M(L)*D*M(L)'.
Solve M(L) * x = e. */
WORK(1) = 1.;
i__2 = *n;
for (i = 2; i <= *n; ++i) {
WORK(i) = WORK(i - 1) * (d__1 = EF(i - 1), abs(d__1)) + 1.;
/* L60: */
}
/* Solve D * M(L)' * x = b. */
WORK(*n) /= DF(*n);
for (i = *n - 1; i >= 1; --i) {
WORK(i) = WORK(i) / DF(i) + WORK(i + 1) * (d__1 = EF(i), abs(d__1)
);
/* L70: */
}
/* Compute norm(inv(A)) = max(x(i)), 1<=i<=n. */
ix = idamax_(n, &WORK(1), &c__1);
FERR(j) *= (d__1 = WORK(ix), abs(d__1));
/* 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);
/* L80: */
}
if (lstres != 0.) {
FERR(j) /= lstres;
}
/* L90: */
}
return 0;
/* End of DPTRFS */
} /* dptrfs_ */
/* Subroutine */ int dptsv_(integer *n, integer *nrhs, doublereal *d__,
doublereal *e, doublereal *b, integer *ldb, integer *info)
{
/* System generated locals */
integer b_dim1, b_offset, i__1;
/* Local variables */
extern /* Subroutine */ int xerbla_(char *, integer *), dpttrf_(
integer *, doublereal *, doublereal *, integer *), dpttrs_(
integer *, integer *, doublereal *, doublereal *, doublereal *,
integer *, integer *);
/* -- LAPACK routine (version 3.2) -- */
/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/* November 2006 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* DPTSV computes the solution to a real system of linear equations */
/* A*X = B, where A is an N-by-N symmetric positive definite tridiagonal */
/* matrix, and X and B are N-by-NRHS matrices. */
/* A is factored as A = L*D*L**T, and the factored form of A is then */
/* used to solve the system of equations. */
/* Arguments */
/* ========= */
/* 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 matrix B. NRHS >= 0. */
/* D (input/output) DOUBLE PRECISION array, dimension (N) */
/* On entry, the n diagonal elements of the tridiagonal matrix */
/* A. On exit, the n diagonal elements of the diagonal matrix */
/* D from the factorization A = L*D*L**T. */
/* E (input/output) DOUBLE PRECISION array, dimension (N-1) */
/* On entry, the (n-1) subdiagonal elements of the tridiagonal */
/* matrix A. On exit, the (n-1) subdiagonal elements of the */
/* unit bidiagonal factor L from the L*D*L**T factorization of */
/* A. (E can also be regarded as the superdiagonal of the unit */
/* bidiagonal factor U from the U**T*D*U factorization of A.) */
/* B (input/output) DOUBLE PRECISION array, dimension (LDB,NRHS) */
/* On entry, the N-by-NRHS right hand side matrix B. */
/* On exit, if INFO = 0, the N-by-NRHS solution matrix X. */
/* LDB (input) INTEGER */
/* The leading dimension of the array B. LDB >= max(1,N). */
/* INFO (output) INTEGER */
/* = 0: successful exit */
/* < 0: if INFO = -i, the i-th argument had an illegal value */
/* > 0: if INFO = i, the leading minor of order i is not */
/* positive definite, and the solution has not been */
/* computed. The factorization has not been completed */
/* unless i = N. */
/* ===================================================================== */
/* .. External Subroutines .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Executable Statements .. */
/* Test the input parameters. */
/* Parameter adjustments */
--d__;
--e;
b_dim1 = *ldb;
b_offset = 1 + b_dim1;
b -= b_offset;
/* Function Body */
*info = 0;
if (*n < 0) {
*info = -1;
} else if (*nrhs < 0) {
*info = -2;
} else if (*ldb < max(1,*n)) {
*info = -6;
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("DPTSV ", &i__1);
return 0;
}
/* Compute the L*D*L' (or U'*D*U) factorization of A. */
dpttrf_(n, &d__[1], &e[1], info);
if (*info == 0) {
/* Solve the system A*X = B, overwriting B with X. */
dpttrs_(n, nrhs, &d__[1], &e[1], &b[b_offset], ldb, info);
}
return 0;
/* End of DPTSV */
} /* dptsv_ */
/* Subroutine */ int derrgt_(char *path, integer *nunit)
{
/* System generated locals */
doublereal d__1;
/* Builtin functions */
integer s_wsle(cilist *), e_wsle(void);
/* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);
/* Local variables */
static integer info;
static doublereal b[2], c__[2], d__[2], e[2], f[2], w[2], x[2], rcond,
anorm;
static char c2[2];
static doublereal r1[2], r2[2], cf[2], df[2], ef[2];
static integer ip[2], iw[2];
extern /* Subroutine */ int alaesm_(char *, logical *, integer *),
dgtcon_(char *, integer *, doublereal *, doublereal *,
doublereal *, doublereal *, integer *, doublereal *, doublereal *,
doublereal *, integer *, integer *);
extern logical lsamen_(integer *, char *, char *);
extern /* Subroutine */ int chkxer_(char *, integer *, integer *, logical
*, logical *), dptcon_(integer *, doublereal *,
doublereal *, doublereal *, doublereal *, doublereal *, integer *)
, dgtrfs_(char *, integer *, integer *, doublereal *, doublereal *
, doublereal *, doublereal *, doublereal *, doublereal *,
doublereal *, integer *, doublereal *, integer *, doublereal *,
integer *, doublereal *, doublereal *, doublereal *, integer *,
integer *), dgttrf_(integer *, doublereal *, doublereal *,
doublereal *, doublereal *, integer *, integer *), dptrfs_(
integer *, integer *, doublereal *, doublereal *, doublereal *,
doublereal *, doublereal *, integer *, doublereal *, integer *,
doublereal *, doublereal *, doublereal *, integer *), dpttrf_(
integer *, doublereal *, doublereal *, integer *), dgttrs_(char *,
integer *, integer *, doublereal *, doublereal *, doublereal *,
doublereal *, integer *, doublereal *, integer *, integer *), dpttrs_(integer *, integer *, doublereal *, doublereal *,
doublereal *, integer *, integer *);
/* Fortran I/O blocks */
static cilist io___1 = { 0, 0, 0, 0, 0 };
/* -- 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
=======
DERRGT tests the error exits for the DOUBLE PRECISION tridiagonal
routines.
Arguments
=========
PATH (input) CHARACTER*3
The LAPACK path name for the routines to be tested.
NUNIT (input) INTEGER
The unit number for output.
===================================================================== */
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);
d__[0] = 1.;
d__[1] = 2.;
df[0] = 1.;
df[1] = 2.;
e[0] = 3.;
e[1] = 4.;
ef[0] = 3.;
ef[1] = 4.;
anorm = 1.;
infoc_1.ok = TRUE_;
if (lsamen_(&c__2, c2, "GT")) {
/* Test error exits for the general tridiagonal routines.
DGTTRF */
s_copy(srnamc_1.srnamt, "DGTTRF", (ftnlen)6, (ftnlen)6);
infoc_1.infot = 1;
dgttrf_(&c_n1, c__, d__, e, f, ip, &info);
chkxer_("DGTTRF", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
/* DGTTRS */
s_copy(srnamc_1.srnamt, "DGTTRS", (ftnlen)6, (ftnlen)6);
infoc_1.infot = 1;
dgttrs_("/", &c__0, &c__0, c__, d__, e, f, ip, x, &c__1, &info);
chkxer_("DGTTRS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 2;
dgttrs_("N", &c_n1, &c__0, c__, d__, e, f, ip, x, &c__1, &info);
chkxer_("DGTTRS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 3;
dgttrs_("N", &c__0, &c_n1, c__, d__, e, f, ip, x, &c__1, &info);
chkxer_("DGTTRS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 10;
dgttrs_("N", &c__2, &c__1, c__, d__, e, f, ip, x, &c__1, &info);
chkxer_("DGTTRS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
/* DGTRFS */
s_copy(srnamc_1.srnamt, "DGTRFS", (ftnlen)6, (ftnlen)6);
infoc_1.infot = 1;
dgtrfs_("/", &c__0, &c__0, c__, d__, e, cf, df, ef, f, ip, b, &c__1,
x, &c__1, r1, r2, w, iw, &info);
chkxer_("DGTRFS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 2;
dgtrfs_("N", &c_n1, &c__0, c__, d__, e, cf, df, ef, f, ip, b, &c__1,
x, &c__1, r1, r2, w, iw, &info);
chkxer_("DGTRFS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 3;
dgtrfs_("N", &c__0, &c_n1, c__, d__, e, cf, df, ef, f, ip, b, &c__1,
x, &c__1, r1, r2, w, iw, &info);
chkxer_("DGTRFS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 13;
dgtrfs_("N", &c__2, &c__1, c__, d__, e, cf, df, ef, f, ip, b, &c__1,
x, &c__2, r1, r2, w, iw, &info);
chkxer_("DGTRFS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 15;
dgtrfs_("N", &c__2, &c__1, c__, d__, e, cf, df, ef, f, ip, b, &c__2,
x, &c__1, r1, r2, w, iw, &info);
chkxer_("DGTRFS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
/* DGTCON */
s_copy(srnamc_1.srnamt, "DGTCON", (ftnlen)6, (ftnlen)6);
infoc_1.infot = 1;
dgtcon_("/", &c__0, c__, d__, e, f, ip, &anorm, &rcond, w, iw, &info);
chkxer_("DGTCON", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 2;
dgtcon_("I", &c_n1, c__, d__, e, f, ip, &anorm, &rcond, w, iw, &info);
chkxer_("DGTCON", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 8;
d__1 = -anorm;
dgtcon_("I", &c__0, c__, d__, e, f, ip, &d__1, &rcond, w, iw, &info);
chkxer_("DGTCON", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
} else if (lsamen_(&c__2, c2, "PT")) {
/* Test error exits for the positive definite tridiagonal
routines.
DPTTRF */
s_copy(srnamc_1.srnamt, "DPTTRF", (ftnlen)6, (ftnlen)6);
infoc_1.infot = 1;
dpttrf_(&c_n1, d__, e, &info);
chkxer_("DPTTRF", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
/* DPTTRS */
s_copy(srnamc_1.srnamt, "DPTTRS", (ftnlen)6, (ftnlen)6);
infoc_1.infot = 1;
dpttrs_(&c_n1, &c__0, d__, e, x, &c__1, &info);
chkxer_("DPTTRS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 2;
dpttrs_(&c__0, &c_n1, d__, e, x, &c__1, &info);
chkxer_("DPTTRS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 6;
dpttrs_(&c__2, &c__1, d__, e, x, &c__1, &info);
chkxer_("DPTTRS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
/* DPTRFS */
s_copy(srnamc_1.srnamt, "DPTRFS", (ftnlen)6, (ftnlen)6);
infoc_1.infot = 1;
dptrfs_(&c_n1, &c__0, d__, e, df, ef, b, &c__1, x, &c__1, r1, r2, w, &
info);
chkxer_("DPTRFS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 2;
dptrfs_(&c__0, &c_n1, d__, e, df, ef, b, &c__1, x, &c__1, r1, r2, w, &
info);
chkxer_("DPTRFS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 8;
dptrfs_(&c__2, &c__1, d__, e, df, ef, b, &c__1, x, &c__2, r1, r2, w, &
info);
chkxer_("DPTRFS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 10;
dptrfs_(&c__2, &c__1, d__, e, df, ef, b, &c__2, x, &c__1, r1, r2, w, &
info);
chkxer_("DPTRFS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
/* DPTCON */
s_copy(srnamc_1.srnamt, "DPTCON", (ftnlen)6, (ftnlen)6);
infoc_1.infot = 1;
dptcon_(&c_n1, d__, e, &anorm, &rcond, w, &info);
chkxer_("DPTCON", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 4;
d__1 = -anorm;
dptcon_(&c__0, d__, e, &d__1, &rcond, w, &info);
chkxer_("DPTCON", &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 DERRGT */
} /* derrgt_ */
/* Subroutine */ int dptsv_(integer *n, integer *nrhs, doublereal *d,
doublereal *e, doublereal *b, integer *ldb, integer *info)
{
/* -- LAPACK routine (version 2.0) --
Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
Courant Institute, Argonne National Lab, and Rice University
March 31, 1993
Purpose
=======
DPTSV computes the solution to a real system of linear equations
A*X = B, where A is an N-by-N symmetric positive definite tridiagonal
matrix, and X and B are N-by-NRHS matrices.
A is factored as A = L*D*L**T, and the factored form of A is then
used to solve the system of equations.
Arguments
=========
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 matrix B. NRHS >= 0.
D (input/output) DOUBLE PRECISION array, dimension (N)
On entry, the n diagonal elements of the tridiagonal matrix
A. On exit, the n diagonal elements of the diagonal matrix
D from the factorization A = L*D*L**T.
E (input/output) DOUBLE PRECISION array, dimension (N-1)
On entry, the (n-1) subdiagonal elements of the tridiagonal
matrix A. On exit, the (n-1) subdiagonal elements of the
unit bidiagonal factor L from the L*D*L**T factorization of
A. (E can also be regarded as the superdiagonal of the unit
bidiagonal factor U from the U**T*D*U factorization of A.)
B (input/output) DOUBLE PRECISION array, dimension (LDB,N)
On entry, the N-by-NRHS right hand side matrix B.
On exit, if INFO = 0, the N-by-NRHS solution matrix X.
LDB (input) INTEGER
The leading dimension of the array B. LDB >= max(1,N).
INFO (output) INTEGER
= 0: successful exit
< 0: if INFO = -i, the i-th argument had an illegal value
> 0: if INFO = i, the leading minor of order i is not
positive definite, and the solution has not been
computed. The factorization has not been completed
unless i = N.
=====================================================================
Test the input parameters.
Parameter adjustments
Function Body */
/* System generated locals */
integer b_dim1, b_offset, i__1;
/* Local variables */
extern /* Subroutine */ int xerbla_(char *, integer *), dpttrf_(
integer *, doublereal *, doublereal *, integer *), dpttrs_(
integer *, integer *, doublereal *, doublereal *, doublereal *,
integer *, integer *);
#define D(I) d[(I)-1]
#define E(I) e[(I)-1]
#define B(I,J) b[(I)-1 + ((J)-1)* ( *ldb)]
*info = 0;
if (*n < 0) {
*info = -1;
} else if (*nrhs < 0) {
*info = -2;
} else if (*ldb < max(1,*n)) {
*info = -6;
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("DPTSV ", &i__1);
return 0;
}
/* Compute the L*D*L' (or U'*D*U) factorization of A. */
dpttrf_(n, &D(1), &E(1), info);
if (*info == 0) {
/* Solve the system A*X = B, overwriting B with X. */
dpttrs_(n, nrhs, &D(1), &E(1), &B(1,1), ldb, info);
}
return 0;
/* End of DPTSV */
} /* dptsv_ */
