/* 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_ */
/* 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 zpteqr_(char *compz, integer *n, doublereal *d__,
doublereal *e, doublecomplex *z__, integer *ldz, doublereal *work,
integer *info, ftnlen compz_len)
{
/* System generated locals */
integer z_dim1, z_offset, i__1;
/* Builtin functions */
double sqrt(doublereal);
/* Local variables */
static doublecomplex c__[1] /* was [1][1] */;
static integer i__;
static doublecomplex vt[1] /* was [1][1] */;
static integer nru;
extern logical lsame_(char *, char *, ftnlen, ftnlen);
extern /* Subroutine */ int xerbla_(char *, integer *, ftnlen);
static integer icompz;
extern /* Subroutine */ int zlaset_(char *, integer *, integer *,
doublecomplex *, doublecomplex *, doublecomplex *, integer *,
ftnlen), dpttrf_(integer *, doublereal *, doublereal *, integer *)
, zbdsqr_(char *, integer *, integer *, integer *, integer *,
doublereal *, doublereal *, doublecomplex *, integer *,
doublecomplex *, integer *, doublecomplex *, integer *,
doublereal *, integer *, ftnlen);
/* -- LAPACK routine (version 3.0) -- */
/* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., */
/* Courant Institute, Argonne National Lab, and Rice University */
/* October 31, 1999 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* ZPTEQR computes all eigenvalues and, optionally, eigenvectors of a */
/* symmetric positive definite tridiagonal matrix by first factoring the */
/* matrix using DPTTRF and then calling ZBDSQR to compute the singular */
/* values of the bidiagonal factor. */
/* This routine computes the eigenvalues of the positive definite */
/* tridiagonal matrix to high relative accuracy. This means that if the */
/* eigenvalues range over many orders of magnitude in size, then the */
/* small eigenvalues and corresponding eigenvectors will be computed */
/* more accurately than, for example, with the standard QR method. */
/* The eigenvectors of a full or band positive definite Hermitian matrix */
/* can also be found if ZHETRD, ZHPTRD, or ZHBTRD has been used to */
/* reduce this matrix to tridiagonal form. (The reduction to */
/* tridiagonal form, however, may preclude the possibility of obtaining */
/* high relative accuracy in the small eigenvalues of the original */
/* matrix, if these eigenvalues range over many orders of magnitude.) */
/* Arguments */
/* ========= */
/* COMPZ (input) CHARACTER*1 */
/* = 'N': Compute eigenvalues only. */
/* = 'V': Compute eigenvectors of original Hermitian */
/* matrix also. Array Z contains the unitary matrix */
/* used to reduce the original matrix to tridiagonal */
/* form. */
/* = 'I': Compute eigenvectors of tridiagonal matrix also. */
/* N (input) INTEGER */
/* The order of the matrix. N >= 0. */
/* D (input/output) DOUBLE PRECISION array, dimension (N) */
/* On entry, the n diagonal elements of the tridiagonal matrix. */
/* On normal exit, D contains the eigenvalues, in descending */
/* order. */
/* E (input/output) DOUBLE PRECISION array, dimension (N-1) */
/* On entry, the (n-1) subdiagonal elements of the tridiagonal */
/* matrix. */
/* On exit, E has been destroyed. */
/* Z (input/output) COMPLEX*16 array, dimension (LDZ, N) */
/* On entry, if COMPZ = 'V', the unitary matrix used in the */
/* reduction to tridiagonal form. */
/* On exit, if COMPZ = 'V', the orthonormal eigenvectors of the */
/* original Hermitian matrix; */
/* if COMPZ = 'I', the orthonormal eigenvectors of the */
/* tridiagonal matrix. */
/* If INFO > 0 on exit, Z contains the eigenvectors associated */
/* with only the stored eigenvalues. */
/* If COMPZ = 'N', then Z is not referenced. */
/* LDZ (input) INTEGER */
/* The leading dimension of the array Z. LDZ >= 1, and if */
/* COMPZ = 'V' or 'I', LDZ >= max(1,N). */
/* WORK (workspace) DOUBLE PRECISION array, dimension (4*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 Cholesky factorization of the matrix could */
/* not be performed because the i-th principal minor */
/* was not positive definite. */
/* > N the SVD algorithm failed to converge; */
/* if INFO = N+i, i off-diagonal elements of the */
/* bidiagonal factor did not converge to zero. */
/* ==================================================================== */
/* .. Parameters .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Local Arrays .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Executable Statements .. */
/* Test the input parameters. */
/* Parameter adjustments */
--d__;
--e;
z_dim1 = *ldz;
z_offset = 1 + z_dim1;
z__ -= z_offset;
--work;
/* Function Body */
*info = 0;
if (lsame_(compz, "N", (ftnlen)1, (ftnlen)1)) {
icompz = 0;
} else if (lsame_(compz, "V", (ftnlen)1, (ftnlen)1)) {
icompz = 1;
} else if (lsame_(compz, "I", (ftnlen)1, (ftnlen)1)) {
icompz = 2;
} else {
icompz = -1;
}
if (icompz < 0) {
*info = -1;
} else if (*n < 0) {
*info = -2;
} else if (*ldz < 1 || icompz > 0 && *ldz < max(1,*n)) {
*info = -6;
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("ZPTEQR", &i__1, (ftnlen)6);
return 0;
}
/* Quick return if possible */
if (*n == 0) {
return 0;
}
if (*n == 1) {
if (icompz > 0) {
i__1 = z_dim1 + 1;
z__[i__1].r = 1., z__[i__1].i = 0.;
}
return 0;
}
if (icompz == 2) {
zlaset_("Full", n, n, &c_b1, &c_b2, &z__[z_offset], ldz, (ftnlen)4);
}
/* Call DPTTRF to factor the matrix. */
dpttrf_(n, &d__[1], &e[1], info);
if (*info != 0) {
return 0;
}
i__1 = *n;
for (i__ = 1; i__ <= i__1; ++i__) {
d__[i__] = sqrt(d__[i__]);
/* L10: */
}
i__1 = *n - 1;
for (i__ = 1; i__ <= i__1; ++i__) {
e[i__] *= d__[i__];
/* L20: */
}
/* Call ZBDSQR to compute the singular values/vectors of the */
/* bidiagonal factor. */
if (icompz > 0) {
nru = *n;
} else {
nru = 0;
}
zbdsqr_("Lower", n, &c__0, &nru, &c__0, &d__[1], &e[1], vt, &c__1, &z__[
z_offset], ldz, c__, &c__1, &work[1], info, (ftnlen)5);
/* Square the singular values. */
if (*info == 0) {
i__1 = *n;
for (i__ = 1; i__ <= i__1; ++i__) {
d__[i__] *= d__[i__];
/* L30: */
}
} else {
*info = *n + *info;
}
return 0;
/* End of ZPTEQR */
} /* zpteqr_ */
/* Subroutine */ int dpteqr_(char *compz, integer *n, doublereal *d__,
doublereal *e, doublereal *z__, integer *ldz, doublereal *work,
integer *info)
{
/* System generated locals */
integer z_dim1, z_offset, i__1;
/* Builtin functions */
double sqrt(doublereal);
/* Local variables */
static doublereal c__[1] /* was [1][1] */;
static integer i__;
extern logical lsame_(char *, char *);
static doublereal vt[1] /* was [1][1] */;
extern /* Subroutine */ int dlaset_(char *, integer *, integer *,
doublereal *, doublereal *, doublereal *, integer *),
xerbla_(char *, integer *), dbdsqr_(char *, integer *,
integer *, integer *, integer *, doublereal *, doublereal *,
doublereal *, integer *, doublereal *, integer *, doublereal *,
integer *, doublereal *, integer *);
static integer icompz;
extern /* Subroutine */ int dpttrf_(integer *, doublereal *, doublereal *,
integer *);
static integer nru;
#define z___ref(a_1,a_2) z__[(a_2)*z_dim1 + a_1]
/* -- LAPACK routine (version 3.0) --
Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
Courant Institute, Argonne National Lab, and Rice University
October 31, 1999
Purpose
=======
DPTEQR computes all eigenvalues and, optionally, eigenvectors of a
symmetric positive definite tridiagonal matrix by first factoring the
matrix using DPTTRF, and then calling DBDSQR to compute the singular
values of the bidiagonal factor.
This routine computes the eigenvalues of the positive definite
tridiagonal matrix to high relative accuracy. This means that if the
eigenvalues range over many orders of magnitude in size, then the
small eigenvalues and corresponding eigenvectors will be computed
more accurately than, for example, with the standard QR method.
The eigenvectors of a full or band symmetric positive definite matrix
can also be found if DSYTRD, DSPTRD, or DSBTRD has been used to
reduce this matrix to tridiagonal form. (The reduction to tridiagonal
form, however, may preclude the possibility of obtaining high
relative accuracy in the small eigenvalues of the original matrix, if
these eigenvalues range over many orders of magnitude.)
Arguments
=========
COMPZ (input) CHARACTER*1
= 'N': Compute eigenvalues only.
= 'V': Compute eigenvectors of original symmetric
matrix also. Array Z contains the orthogonal
matrix used to reduce the original matrix to
tridiagonal form.
= 'I': Compute eigenvectors of tridiagonal matrix also.
N (input) INTEGER
The order of the matrix. N >= 0.
D (input/output) DOUBLE PRECISION array, dimension (N)
On entry, the n diagonal elements of the tridiagonal
matrix.
On normal exit, D contains the eigenvalues, in descending
order.
E (input/output) DOUBLE PRECISION array, dimension (N-1)
On entry, the (n-1) subdiagonal elements of the tridiagonal
matrix.
On exit, E has been destroyed.
Z (input/output) DOUBLE PRECISION array, dimension (LDZ, N)
On entry, if COMPZ = 'V', the orthogonal matrix used in the
reduction to tridiagonal form.
On exit, if COMPZ = 'V', the orthonormal eigenvectors of the
original symmetric matrix;
if COMPZ = 'I', the orthonormal eigenvectors of the
tridiagonal matrix.
If INFO > 0 on exit, Z contains the eigenvectors associated
with only the stored eigenvalues.
If COMPZ = 'N', then Z is not referenced.
LDZ (input) INTEGER
The leading dimension of the array Z. LDZ >= 1, and if
COMPZ = 'V' or 'I', LDZ >= max(1,N).
WORK (workspace) DOUBLE PRECISION array, dimension (4*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 Cholesky factorization of the matrix could
not be performed because the i-th principal minor
was not positive definite.
> N the SVD algorithm failed to converge;
if INFO = N+i, i off-diagonal elements of the
bidiagonal factor did not converge to zero.
=====================================================================
Test the input parameters.
Parameter adjustments */
--d__;
--e;
z_dim1 = *ldz;
z_offset = 1 + z_dim1 * 1;
z__ -= z_offset;
--work;
/* Function Body */
*info = 0;
if (lsame_(compz, "N")) {
icompz = 0;
} else if (lsame_(compz, "V")) {
icompz = 1;
} else if (lsame_(compz, "I")) {
icompz = 2;
} else {
icompz = -1;
}
if (icompz < 0) {
*info = -1;
} else if (*n < 0) {
*info = -2;
} else if (*ldz < 1 || icompz > 0 && *ldz < max(1,*n)) {
*info = -6;
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("DPTEQR", &i__1);
return 0;
}
/* Quick return if possible */
if (*n == 0) {
return 0;
}
if (*n == 1) {
if (icompz > 0) {
z___ref(1, 1) = 1.;
}
return 0;
}
if (icompz == 2) {
dlaset_("Full", n, n, &c_b7, &c_b8, &z__[z_offset], ldz);
}
/* Call DPTTRF to factor the matrix. */
dpttrf_(n, &d__[1], &e[1], info);
if (*info != 0) {
return 0;
}
i__1 = *n;
for (i__ = 1; i__ <= i__1; ++i__) {
d__[i__] = sqrt(d__[i__]);
/* L10: */
}
i__1 = *n - 1;
for (i__ = 1; i__ <= i__1; ++i__) {
e[i__] *= d__[i__];
/* L20: */
}
/* Call DBDSQR to compute the singular values/vectors of the
bidiagonal factor. */
if (icompz > 0) {
nru = *n;
} else {
nru = 0;
}
dbdsqr_("Lower", n, &c__0, &nru, &c__0, &d__[1], &e[1], vt, &c__1, &z__[
z_offset], ldz, c__, &c__1, &work[1], info);
/* Square the singular values. */
if (*info == 0) {
i__1 = *n;
for (i__ = 1; i__ <= i__1; ++i__) {
d__[i__] *= d__[i__];
/* L30: */
}
} else {
*info = *n + *info;
}
return 0;
/* End of DPTEQR */
} /* dpteqr_ */
/* 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_ */
/* Subroutine */ int dpteqr_(char *compz, integer *n, doublereal *d__,
doublereal *e, doublereal *z__, integer *ldz, doublereal *work,
integer *info)
{
/* System generated locals */
integer z_dim1, z_offset, i__1;
/* Local variables */
doublereal c__[1] /* was [1][1] */;
integer i__;
doublereal vt[1] /* was [1][1] */;
integer nru;
integer icompz;
/* -- LAPACK routine (version 3.2) -- */
/* November 2006 */
/* Purpose */
/* ======= */
/* DPTEQR computes all eigenvalues and, optionally, eigenvectors of a */
/* symmetric positive definite tridiagonal matrix by first factoring the */
/* matrix using DPTTRF, and then calling DBDSQR to compute the singular */
/* values of the bidiagonal factor. */
/* This routine computes the eigenvalues of the positive definite */
/* tridiagonal matrix to high relative accuracy. This means that if the */
/* eigenvalues range over many orders of magnitude in size, then the */
/* small eigenvalues and corresponding eigenvectors will be computed */
/* more accurately than, for example, with the standard QR method. */
/* The eigenvectors of a full or band symmetric positive definite matrix */
/* can also be found if DSYTRD, DSPTRD, or DSBTRD has been used to */
/* reduce this matrix to tridiagonal form. (The reduction to tridiagonal */
/* form, however, may preclude the possibility of obtaining high */
/* relative accuracy in the small eigenvalues of the original matrix, if */
/* these eigenvalues range over many orders of magnitude.) */
/* Arguments */
/* ========= */
/* COMPZ (input) CHARACTER*1 */
/* = 'N': Compute eigenvalues only. */
/* = 'V': Compute eigenvectors of original symmetric */
/* matrix also. Array Z contains the orthogonal */
/* matrix used to reduce the original matrix to */
/* tridiagonal form. */
/* = 'I': Compute eigenvectors of tridiagonal matrix also. */
/* N (input) INTEGER */
/* The order of the matrix. N >= 0. */
/* D (input/output) DOUBLE PRECISION array, dimension (N) */
/* On entry, the n diagonal elements of the tridiagonal */
/* matrix. */
/* On normal exit, D contains the eigenvalues, in descending */
/* order. */
/* E (input/output) DOUBLE PRECISION array, dimension (N-1) */
/* On entry, the (n-1) subdiagonal elements of the tridiagonal */
/* matrix. */
/* On exit, E has been destroyed. */
/* Z (input/output) DOUBLE PRECISION array, dimension (LDZ, N) */
/* On entry, if COMPZ = 'V', the orthogonal matrix used in the */
/* reduction to tridiagonal form. */
/* On exit, if COMPZ = 'V', the orthonormal eigenvectors of the */
/* original symmetric matrix; */
/* if COMPZ = 'I', the orthonormal eigenvectors of the */
/* tridiagonal matrix. */
/* If INFO > 0 on exit, Z contains the eigenvectors associated */
/* with only the stored eigenvalues. */
/* If COMPZ = 'N', then Z is not referenced. */
/* LDZ (input) INTEGER */
/* The leading dimension of the array Z. LDZ >= 1, and if */
/* COMPZ = 'V' or 'I', LDZ >= max(1,N). */
/* WORK (workspace) DOUBLE PRECISION array, dimension (4*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 Cholesky factorization of the matrix could */
/* not be performed because the i-th principal minor */
/* was not positive definite. */
/* > N the SVD algorithm failed to converge; */
/* if INFO = N+i, i off-diagonal elements of the */
/* bidiagonal factor did not converge to zero. */
/* ===================================================================== */
/* Test the input parameters. */
/* Parameter adjustments */
--d__;
--e;
z_dim1 = *ldz;
z_offset = 1 + z_dim1;
z__ -= z_offset;
--work;
/* Function Body */
*info = 0;
if (lsame_(compz, "N")) {
icompz = 0;
} else if (lsame_(compz, "V")) {
icompz = 1;
} else if (lsame_(compz, "I")) {
icompz = 2;
} else {
icompz = -1;
}
if (icompz < 0) {
*info = -1;
} else if (*n < 0) {
*info = -2;
} else if (*ldz < 1 || icompz > 0 && *ldz < max(1,*n)) {
*info = -6;
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("DPTEQR", &i__1);
return 0;
}
/* Quick return if possible */
if (*n == 0) {
return 0;
}
if (*n == 1) {
if (icompz > 0) {
z__[z_dim1 + 1] = 1.;
}
return 0;
}
if (icompz == 2) {
dlaset_("Full", n, n, &c_b7, &c_b8, &z__[z_offset], ldz);
}
/* Call DPTTRF to factor the matrix. */
dpttrf_(n, &d__[1], &e[1], info);
if (*info != 0) {
return 0;
}
i__1 = *n;
for (i__ = 1; i__ <= i__1; ++i__) {
d__[i__] = sqrt(d__[i__]);
}
i__1 = *n - 1;
for (i__ = 1; i__ <= i__1; ++i__) {
e[i__] *= d__[i__];
}
/* Call DBDSQR to compute the singular values/vectors of the */
/* bidiagonal factor. */
if (icompz > 0) {
nru = *n;
} else {
nru = 0;
}
dbdsqr_("Lower", n, &c__0, &nru, &c__0, &d__[1], &e[1], vt, &c__1, &z__[
z_offset], ldz, c__, &c__1, &work[1], info);
/* Square the singular values. */
if (*info == 0) {
i__1 = *n;
for (i__ = 1; i__ <= i__1; ++i__) {
d__[i__] *= d__[i__];
}
} else {
*info = *n + *info;
}
return 0;
/* End of DPTEQR */
} /* dpteqr_ */