int pposymatinv(int N,double *A, char UPLO, double *determinant)
{
int INFO;
dpptrf_(&UPLO,&N,A,&INFO);
/* LAPACK routine DPPTRF computes the Cholesky factorization of
a packed real symmetric positive definite matrix A stored in
packed format. The factorization has the form
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 lower triangular.
Parameters in the order in which they appear in the function
call:
uplo="U" indicates the upper triangle, while uplo="L" indicates
the lower triangle of the matrix packed into the vector A, N is
the order of the matrix, A is the vector containing the packed
matrix and INFO is the flag for the result. On exit, if INFO = 0,
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 (INFO==0) {
int i;
(*determinant)=1.0;
if (UPLO=='U') {
for (i=0; i<N; i++) {
(*determinant)*=A[i+i*(i+1)/2]*A[i+i*(i+1)/2];
}
}
else {
for (i=0; i<N; i++) {
(*determinant)*=A[i+(i*(2*N-i-1))/2]*A[i+(i*(2*N-i-1))/2];
}
}
dpptri_(&UPLO,&N,A,&INFO);
/* LAPACK routine DPPTRI computes the inverse of a packed real
symmetric positive definite matrix A using the Cholesky
factorization A = U**T*U or A = L*L**T computed by DPPTRF.
Parameters in the order in which they appear in the function
call:
uplo="U" indicates the upper triangle, while uplo="L" indicates
the lower triangle of the matrix packed into the vector A, N is
the order of the matrix, A is the vector containing the packed
matrix and INFO is the flag for the result. On exit, if INFO = 0,
the upper or lower triangle of the (symmetric) inverse of A,
overwriting the input factor U or L.*/
if (INFO!=0) {
/* Marked by Wei-Chen Chen on 2008/12/26.
* printf("\rProblem in pposymatinv: dpptri error %d",INFO);
* Rprintf("dpptri error %d\n",INFO);
*/
}
}
else {
/* Marked by Wei-Chen Chen on 2008/12/26.
* printf("\rProblem in pposymatinv: dpptrf error %d",INFO);
* Rprintf("dpptrf error %d\n", INFO);
*/
}
return INFO;
}
int main( int argc, char **argv ) {
int size = 256;
// generate a symmetric, positive definite matrix
double *M = (double *) malloc( size*size*sizeof(double) );
fill( M, size*size);
double *Afull = (double *) malloc( size*size*sizeof(double) );
char T = 'T', N = 'n';
double one = 1., zero = 0.;
dgemm_( &T, &N, &size, &size, &size, &one, M, &size, M, &size, &zero, Afull, &size );
double *A = (double *) malloc( size*(size+1)/2*sizeof(double) );
double *Acopy = (double *) malloc( size*(size+1)/2*sizeof(double) );
for( int r = 0; r < size; r++ )
for( int c = 0; c <= r; c++ ) {
setEntry(A, size, r, c, Afull[r*size+c]);
setEntry(Acopy, size, r, c, Afull[r*size+c], size);
}
//printMatrix(Afull,size);
double startTime = read_timer();
chol(A,size);
double endTime = read_timer();
printf("Time %f Gflop/s %f\n", endTime-startTime, size*size*size/3./(endTime-startTime)/1.e9);
int info = 0;
char L = 'L';
startTime = read_timer();
dpptrf_( &L, &size, Acopy, &info);
endTime = read_timer();
printf("dpptrf Time %f Gflop/s %f\n", endTime-startTime, size*size*size/3./(endTime-startTime)/1.e9);
printf("info is %d, size is %d\n", info, size );
startTime = read_timer();
dpotrf_( &L, &size, Afull, &size, &info);
endTime = read_timer();
printf("dpotrf Time %f Gflop/s %f\n", endTime-startTime, size*size*size/3./(endTime-startTime)/1.e9);
//printMatrix(Afull,size);
double maxDev = 0.;
/*
for( int r = 0; r < size; r++ )
for( int c = 0; c <= r; c++ ) {
maxDev = max(maxDev,fabs(Afull[r*size+c]-getEntry(A,size,r,c)));
Afull[r*size+c] = getEntry(A,size,r,c);
}
*/
for( int r = 0; r < size; r++ )
for( int c = 0; c < size; c++ ) {
maxDev = max(maxDev,fabs(getEntry(Acopy,size,r,c,size)-getEntry(A,size,r,c)));
// Afull[r*size+c] = getEntry(Acopy,size,r,c,size);
}
//printMatrix(Afull,size);
printf("Max deviation: %f\n", maxDev);
//for( int r = 0; r < size; r++ )
// for( int c = 0; c < size; c++ ) {
// Afull[r*size+c] = getEntry(A,size,r,c);
// }
//printMatrix(Afull,size);
return 0;
}
int dspgvx_(int *itype, char *jobz, char *range, char *
uplo, int *n, double *ap, double *bp, double *vl,
double *vu, int *il, int *iu, double *abstol, int
*m, double *w, double *z__, int *ldz, double *work,
int *iwork, int *ifail, int *info)
{
/* System generated locals */
int z_dim1, z_offset, i__1;
/* Local variables */
int j;
extern int lsame_(char *, char *);
char trans[1];
int upper;
extern int dtpmv_(char *, char *, char *, int *,
double *, double *, int *),
dtpsv_(char *, char *, char *, int *, double *,
double *, int *);
int wantz, alleig, indeig, valeig;
extern int xerbla_(char *, int *), dpptrf_(
char *, int *, double *, int *), dspgst_(
int *, char *, int *, double *, double *, int
*), dspevx_(char *, char *, char *, int *, double
*, double *, double *, int *, int *, double *,
int *, double *, double *, int *, double *,
int *, int *, int *);
/* -- LAPACK driver routine (version 3.2) -- */
/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/* November 2006 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* DSPGVX computes selected eigenvalues, and optionally, eigenvectors */
/* of a float generalized symmetric-definite eigenproblem, of the form */
/* A*x=(lambda)*B*x, A*Bx=(lambda)*x, or B*A*x=(lambda)*x. Here A */
/* and B are assumed to be symmetric, stored in packed storage, and B */
/* is also positive definite. Eigenvalues and eigenvectors can be */
/* selected by specifying either a range of values or a range of indices */
/* for the desired eigenvalues. */
/* Arguments */
/* ========= */
/* ITYPE (input) INTEGER */
/* Specifies the problem type to be solved: */
/* = 1: A*x = (lambda)*B*x */
/* = 2: A*B*x = (lambda)*x */
/* = 3: B*A*x = (lambda)*x */
/* JOBZ (input) CHARACTER*1 */
/* = 'N': Compute eigenvalues only; */
/* = 'V': Compute eigenvalues and eigenvectors. */
/* RANGE (input) CHARACTER*1 */
/* = 'A': all eigenvalues will be found. */
/* = 'V': all eigenvalues in the half-open interval (VL,VU] */
/* will be found. */
/* = 'I': the IL-th through IU-th eigenvalues will be found. */
/* UPLO (input) CHARACTER*1 */
/* = 'U': Upper triangle of A and B are stored; */
/* = 'L': Lower triangle of A and B are stored. */
/* N (input) INTEGER */
/* The order of the matrix pencil (A,B). N >= 0. */
/* AP (input/output) DOUBLE PRECISION array, dimension (N*(N+1)/2) */
/* On entry, the upper or lower triangle of the symmetric matrix */
/* A, packed columnwise in a linear array. The j-th column of A */
/* is stored in the array AP as follows: */
/* if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j; */
/* if UPLO = 'L', AP(i + (j-1)*(2*n-j)/2) = A(i,j) for j<=i<=n. */
/* On exit, the contents of AP are destroyed. */
/* BP (input/output) DOUBLE PRECISION array, dimension (N*(N+1)/2) */
/* On entry, the upper or lower triangle of the symmetric matrix */
/* B, packed columnwise in a linear array. The j-th column of B */
/* is stored in the array BP as follows: */
/* if UPLO = 'U', BP(i + (j-1)*j/2) = B(i,j) for 1<=i<=j; */
/* if UPLO = 'L', BP(i + (j-1)*(2*n-j)/2) = B(i,j) for j<=i<=n. */
/* On exit, the triangular factor U or L from the Cholesky */
/* factorization B = U**T*U or B = L*L**T, in the same storage */
/* format as B. */
/* VL (input) DOUBLE PRECISION */
/* VU (input) DOUBLE PRECISION */
/* If RANGE='V', the lower and upper bounds of the interval to */
/* be searched for eigenvalues. VL < VU. */
/* Not referenced if RANGE = 'A' or 'I'. */
/* IL (input) INTEGER */
/* IU (input) INTEGER */
/* If RANGE='I', the indices (in ascending order) of the */
/* smallest and largest eigenvalues to be returned. */
/* 1 <= IL <= IU <= N, if N > 0; IL = 1 and IU = 0 if N = 0. */
/* Not referenced if RANGE = 'A' or 'V'. */
/* ABSTOL (input) DOUBLE PRECISION */
/* The absolute error tolerance for the eigenvalues. */
/* An approximate eigenvalue is accepted as converged */
/* when it is determined to lie in an interval [a,b] */
/* of width less than or equal to */
/* ABSTOL + EPS * MAX( |a|,|b| ) , */
/* where EPS is the machine precision. If ABSTOL is less than */
/* or equal to zero, then EPS*|T| will be used in its place, */
/* where |T| is the 1-norm of the tridiagonal matrix obtained */
/* by reducing A to tridiagonal form. */
/* Eigenvalues will be computed most accurately when ABSTOL is */
/* set to twice the underflow threshold 2*DLAMCH('S'), not zero. */
/* If this routine returns with INFO>0, indicating that some */
/* eigenvectors did not converge, try setting ABSTOL to */
/* 2*DLAMCH('S'). */
/* M (output) INTEGER */
/* The total number of eigenvalues found. 0 <= M <= N. */
/* If RANGE = 'A', M = N, and if RANGE = 'I', M = IU-IL+1. */
/* W (output) DOUBLE PRECISION array, dimension (N) */
/* On normal exit, the first M elements contain the selected */
/* eigenvalues in ascending order. */
/* Z (output) DOUBLE PRECISION array, dimension (LDZ, MAX(1,M)) */
/* If JOBZ = 'N', then Z is not referenced. */
/* If JOBZ = 'V', then if INFO = 0, the first M columns of Z */
/* contain the orthonormal eigenvectors of the matrix A */
/* corresponding to the selected eigenvalues, with the i-th */
/* column of Z holding the eigenvector associated with W(i). */
/* The eigenvectors are normalized as follows: */
/* if ITYPE = 1 or 2, Z**T*B*Z = I; */
/* if ITYPE = 3, Z**T*inv(B)*Z = I. */
/* If an eigenvector fails to converge, then that column of Z */
/* contains the latest approximation to the eigenvector, and the */
/* index of the eigenvector is returned in IFAIL. */
/* Note: the user must ensure that at least MAX(1,M) columns are */
/* supplied in the array Z; if RANGE = 'V', the exact value of M */
/* is not known in advance and an upper bound must be used. */
/* LDZ (input) INTEGER */
/* The leading dimension of the array Z. LDZ >= 1, and if */
/* JOBZ = 'V', LDZ >= MAX(1,N). */
/* WORK (workspace) DOUBLE PRECISION array, dimension (8*N) */
/* IWORK (workspace) INTEGER array, dimension (5*N) */
/* IFAIL (output) INTEGER array, dimension (N) */
/* If JOBZ = 'V', then if INFO = 0, the first M elements of */
/* IFAIL are zero. If INFO > 0, then IFAIL contains the */
/* indices of the eigenvectors that failed to converge. */
/* If JOBZ = 'N', then IFAIL is not referenced. */
/* INFO (output) INTEGER */
/* = 0: successful exit */
/* < 0: if INFO = -i, the i-th argument had an illegal value */
/* > 0: DPPTRF or DSPEVX returned an error code: */
/* <= N: if INFO = i, DSPEVX failed to converge; */
/* i eigenvectors failed to converge. Their indices */
/* are stored in array IFAIL. */
/* > N: if INFO = N + i, for 1 <= i <= N, then the leading */
/* minor of order i of B is not positive definite. */
/* The factorization of B could not be completed and */
/* no eigenvalues or eigenvectors were computed. */
/* Further Details */
/* =============== */
/* Based on contributions by */
/* Mark Fahey, Department of Mathematics, Univ. of Kentucky, USA */
/* ===================================================================== */
/* .. Local Scalars .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Executable Statements .. */
/* Test the input parameters. */
/* Parameter adjustments */
--ap;
--bp;
--w;
z_dim1 = *ldz;
z_offset = 1 + z_dim1;
z__ -= z_offset;
--work;
--iwork;
--ifail;
/* Function Body */
upper = lsame_(uplo, "U");
wantz = lsame_(jobz, "V");
alleig = lsame_(range, "A");
valeig = lsame_(range, "V");
indeig = lsame_(range, "I");
*info = 0;
if (*itype < 1 || *itype > 3) {
*info = -1;
} else if (! (wantz || lsame_(jobz, "N"))) {
*info = -2;
} else if (! (alleig || valeig || indeig)) {
*info = -3;
} else if (! (upper || lsame_(uplo, "L"))) {
*info = -4;
} else if (*n < 0) {
*info = -5;
} else {
if (valeig) {
if (*n > 0 && *vu <= *vl) {
*info = -9;
}
} else if (indeig) {
if (*il < 1) {
*info = -10;
} else if (*iu < MIN(*n,*il) || *iu > *n) {
*info = -11;
}
}
}
if (*info == 0) {
if (*ldz < 1 || wantz && *ldz < *n) {
*info = -16;
}
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("DSPGVX", &i__1);
return 0;
}
/* Quick return if possible */
*m = 0;
if (*n == 0) {
return 0;
}
/* Form a Cholesky factorization of B. */
dpptrf_(uplo, n, &bp[1], info);
if (*info != 0) {
*info = *n + *info;
return 0;
}
/* Transform problem to standard eigenvalue problem and solve. */
dspgst_(itype, uplo, n, &ap[1], &bp[1], info);
dspevx_(jobz, range, uplo, n, &ap[1], vl, vu, il, iu, abstol, m, &w[1], &
z__[z_offset], ldz, &work[1], &iwork[1], &ifail[1], info);
if (wantz) {
/* Backtransform eigenvectors to the original problem. */
if (*info > 0) {
*m = *info - 1;
}
if (*itype == 1 || *itype == 2) {
/* For A*x=(lambda)*B*x and A*B*x=(lambda)*x; */
/* backtransform eigenvectors: x = inv(L)'*y or inv(U)*y */
if (upper) {
*(unsigned char *)trans = 'N';
} else {
*(unsigned char *)trans = 'T';
}
i__1 = *m;
for (j = 1; j <= i__1; ++j) {
dtpsv_(uplo, trans, "Non-unit", n, &bp[1], &z__[j * z_dim1 +
1], &c__1);
/* L10: */
}
} else if (*itype == 3) {
/* For B*A*x=(lambda)*x; */
/* backtransform eigenvectors: x = L*y or U'*y */
if (upper) {
*(unsigned char *)trans = 'T';
} else {
*(unsigned char *)trans = 'N';
}
i__1 = *m;
for (j = 1; j <= i__1; ++j) {
dtpmv_(uplo, trans, "Non-unit", n, &bp[1], &z__[j * z_dim1 +
1], &c__1);
/* L20: */
}
}
}
return 0;
/* End of DSPGVX */
} /* dspgvx_ */
/* Subroutine */ int dppsv_(char *uplo, integer *n, integer *nrhs, doublereal
*ap, doublereal *b, integer *ldb, integer *info)
{
/* -- LAPACK driver routine (version 2.0) --
Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
Courant Institute, Argonne National Lab, and Rice University
March 31, 1993
Purpose
=======
DPPSV computes the solution to a real system of linear equations
A * X = B,
where A is an N-by-N symmetric positive definite matrix stored in
packed format and X and B are N-by-NRHS matrices.
The Cholesky decomposition is used to factor A 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. The factored form of A is then used to solve the system of
equations A * X = B.
Arguments
=========
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 matrix B. NRHS >= 0.
AP (input/output) DOUBLE PRECISION array, dimension (N*(N+1)/2)
On entry, the upper or lower triangle of the symmetric matrix
A, packed columnwise in a linear array. The j-th column of A
is stored in the array AP as follows:
if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j;
if UPLO = 'L', AP(i + (j-1)*(2n-j)/2) = A(i,j) for j<=i<=n.
See below for further details.
On exit, if INFO = 0, the factor U or L from the Cholesky
factorization A = U**T*U or A = L*L**T, in the same storage
format as 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 of A is not
positive definite, so the factorization could not be
completed, and the solution has not been computed.
Further Details
===============
The packed storage scheme is illustrated by the following example
when N = 4, UPLO = 'U':
Two-dimensional storage of the symmetric matrix A:
a11 a12 a13 a14
a22 a23 a24
a33 a34 (aij = conjg(aji))
a44
Packed storage of the upper triangle of A:
AP = [ a11, a12, a22, a13, a23, a33, a14, a24, a34, a44 ]
=====================================================================
Test the input parameters.
Parameter adjustments
Function Body */
/* System generated locals */
integer b_dim1, b_offset, i__1;
/* Local variables */
extern logical lsame_(char *, char *);
extern /* Subroutine */ int xerbla_(char *, integer *), dpptrf_(
char *, integer *, doublereal *, integer *), dpptrs_(char
*, integer *, integer *, doublereal *, doublereal *, integer *,
integer *);
#define AP(I) ap[(I)-1]
#define B(I,J) b[(I)-1 + ((J)-1)* ( *ldb)]
*info = 0;
if (! lsame_(uplo, "U") && ! lsame_(uplo, "L")) {
*info = -1;
} else if (*n < 0) {
*info = -2;
} else if (*nrhs < 0) {
*info = -3;
} else if (*ldb < max(1,*n)) {
*info = -6;
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("DPPSV ", &i__1);
return 0;
}
/* Compute the Cholesky factorization A = U'*U or A = L*L'. */
dpptrf_(uplo, n, &AP(1), info);
if (*info == 0) {
/* Solve the system A*X = B, overwriting B with X. */
dpptrs_(uplo, n, nrhs, &AP(1), &B(1,1), ldb, info);
}
return 0;
/* End of DPPSV */
} /* dppsv_ */
/* Subroutine */ int dspgv_(integer *itype, char *jobz, char *uplo, integer *
n, doublereal *ap, doublereal *bp, doublereal *w, doublereal *z__,
integer *ldz, doublereal *work, integer *info)
{
/* -- LAPACK driver routine (version 3.0) --
Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
Courant Institute, Argonne National Lab, and Rice University
September 30, 1994
Purpose
=======
DSPGV computes all the eigenvalues and, optionally, the eigenvectors
of a real generalized symmetric-definite eigenproblem, of the form
A*x=(lambda)*B*x, A*Bx=(lambda)*x, or B*A*x=(lambda)*x.
Here A and B are assumed to be symmetric, stored in packed format,
and B is also positive definite.
Arguments
=========
ITYPE (input) INTEGER
Specifies the problem type to be solved:
= 1: A*x = (lambda)*B*x
= 2: A*B*x = (lambda)*x
= 3: B*A*x = (lambda)*x
JOBZ (input) CHARACTER*1
= 'N': Compute eigenvalues only;
= 'V': Compute eigenvalues and eigenvectors.
UPLO (input) CHARACTER*1
= 'U': Upper triangles of A and B are stored;
= 'L': Lower triangles of A and B are stored.
N (input) INTEGER
The order of the matrices A and B. N >= 0.
AP (input/output) DOUBLE PRECISION array, dimension
(N*(N+1)/2)
On entry, the upper or lower triangle of the symmetric matrix
A, packed columnwise in a linear array. The j-th column of A
is stored in the array AP as follows:
if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j;
if UPLO = 'L', AP(i + (j-1)*(2*n-j)/2) = A(i,j) for j<=i<=n.
On exit, the contents of AP are destroyed.
BP (input/output) DOUBLE PRECISION array, dimension (N*(N+1)/2)
On entry, the upper or lower triangle of the symmetric matrix
B, packed columnwise in a linear array. The j-th column of B
is stored in the array BP as follows:
if UPLO = 'U', BP(i + (j-1)*j/2) = B(i,j) for 1<=i<=j;
if UPLO = 'L', BP(i + (j-1)*(2*n-j)/2) = B(i,j) for j<=i<=n.
On exit, the triangular factor U or L from the Cholesky
factorization B = U**T*U or B = L*L**T, in the same storage
format as B.
W (output) DOUBLE PRECISION array, dimension (N)
If INFO = 0, the eigenvalues in ascending order.
Z (output) DOUBLE PRECISION array, dimension (LDZ, N)
If JOBZ = 'V', then if INFO = 0, Z contains the matrix Z of
eigenvectors. The eigenvectors are normalized as follows:
if ITYPE = 1 or 2, Z**T*B*Z = I;
if ITYPE = 3, Z**T*inv(B)*Z = I.
If JOBZ = 'N', then Z is not referenced.
LDZ (input) INTEGER
The leading dimension of the array Z. LDZ >= 1, and if
JOBZ = 'V', LDZ >= max(1,N).
WORK (workspace) DOUBLE PRECISION array, dimension (3*N)
INFO (output) INTEGER
= 0: successful exit
< 0: if INFO = -i, the i-th argument had an illegal value
> 0: DPPTRF or DSPEV returned an error code:
<= N: if INFO = i, DSPEV failed to converge;
i off-diagonal elements of an intermediate
tridiagonal form did not converge to zero.
> N: if INFO = n + i, for 1 <= i <= n, then the leading
minor of order i of B is not positive definite.
The factorization of B could not be completed and
no eigenvalues or eigenvectors were computed.
=====================================================================
Test the input parameters.
Parameter adjustments */
/* Table of constant values */
static integer c__1 = 1;
/* System generated locals */
integer z_dim1, z_offset, i__1;
/* Local variables */
static integer neig, j;
extern logical lsame_(char *, char *);
extern /* Subroutine */ int dspev_(char *, char *, integer *, doublereal *
, doublereal *, doublereal *, integer *, doublereal *, integer *);
static char trans[1];
static logical upper;
extern /* Subroutine */ int dtpmv_(char *, char *, char *, integer *,
doublereal *, doublereal *, integer *),
dtpsv_(char *, char *, char *, integer *, doublereal *,
doublereal *, integer *);
static logical wantz;
extern /* Subroutine */ int xerbla_(char *, integer *), dpptrf_(
char *, integer *, doublereal *, integer *), dspgst_(
integer *, char *, integer *, doublereal *, doublereal *, integer
*);
#define z___ref(a_1,a_2) z__[(a_2)*z_dim1 + a_1]
--ap;
--bp;
--w;
z_dim1 = *ldz;
z_offset = 1 + z_dim1 * 1;
z__ -= z_offset;
--work;
/* Function Body */
wantz = lsame_(jobz, "V");
upper = lsame_(uplo, "U");
*info = 0;
if (*itype < 0 || *itype > 3) {
*info = -1;
} else if (! (wantz || lsame_(jobz, "N"))) {
*info = -2;
} else if (! (upper || lsame_(uplo, "L"))) {
*info = -3;
} else if (*n < 0) {
*info = -4;
} else if (*ldz < 1 || wantz && *ldz < *n) {
*info = -9;
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("DSPGV ", &i__1);
return 0;
}
/* Quick return if possible */
if (*n == 0) {
return 0;
}
/* Form a Cholesky factorization of B. */
dpptrf_(uplo, n, &bp[1], info);
if (*info != 0) {
*info = *n + *info;
return 0;
}
/* Transform problem to standard eigenvalue problem and solve. */
dspgst_(itype, uplo, n, &ap[1], &bp[1], info);
dspev_(jobz, uplo, n, &ap[1], &w[1], &z__[z_offset], ldz, &work[1], info);
if (wantz) {
/* Backtransform eigenvectors to the original problem. */
neig = *n;
if (*info > 0) {
neig = *info - 1;
}
if (*itype == 1 || *itype == 2) {
/* For A*x=(lambda)*B*x and A*B*x=(lambda)*x;
backtransform eigenvectors: x = inv(L)'*y or inv(U)*y */
if (upper) {
*(unsigned char *)trans = 'N';
} else {
*(unsigned char *)trans = 'T';
}
i__1 = neig;
for (j = 1; j <= i__1; ++j) {
dtpsv_(uplo, trans, "Non-unit", n, &bp[1], &z___ref(1, j), &
c__1);
/* L10: */
}
} else if (*itype == 3) {
/* For B*A*x=(lambda)*x;
backtransform eigenvectors: x = L*y or U'*y */
if (upper) {
*(unsigned char *)trans = 'T';
} else {
*(unsigned char *)trans = 'N';
}
i__1 = neig;
for (j = 1; j <= i__1; ++j) {
dtpmv_(uplo, trans, "Non-unit", n, &bp[1], &z___ref(1, j), &
c__1);
/* L20: */
}
}
}
return 0;
/* End of DSPGV */
} /* dspgv_ */
/* Subroutine */
int dppsv_(char *uplo, integer *n, integer *nrhs, doublereal *ap, doublereal *b, integer *ldb, integer *info)
{
/* System generated locals */
integer b_dim1, b_offset, i__1;
/* Local variables */
extern logical lsame_(char *, char *);
extern /* Subroutine */
int xerbla_(char *, integer *), dpptrf_( char *, integer *, doublereal *, integer *), dpptrs_(char *, integer *, integer *, doublereal *, doublereal *, 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 .. */
/* .. */
/* ===================================================================== */
/* .. External Functions .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Executable Statements .. */
/* Test the input parameters. */
/* Parameter adjustments */
--ap;
b_dim1 = *ldb;
b_offset = 1 + b_dim1;
b -= b_offset;
/* Function Body */
*info = 0;
if (! lsame_(uplo, "U") && ! lsame_(uplo, "L"))
{
*info = -1;
}
else if (*n < 0)
{
*info = -2;
}
else if (*nrhs < 0)
{
*info = -3;
}
else if (*ldb < max(1,*n))
{
*info = -6;
}
if (*info != 0)
{
i__1 = -(*info);
xerbla_("DPPSV ", &i__1);
return 0;
}
/* Compute the Cholesky factorization A = U**T*U or A = L*L**T. */
dpptrf_(uplo, n, &ap[1], info);
if (*info == 0)
{
/* Solve the system A*X = B, overwriting B with X. */
dpptrs_(uplo, n, nrhs, &ap[1], &b[b_offset], ldb, info);
}
return 0;
/* End of DPPSV */
}
/* 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_ */
/* Subroutine */ int dppsvx_(char *fact, char *uplo, integer *n, integer *
nrhs, doublereal *ap, doublereal *afp, char *equed, doublereal *s,
doublereal *b, integer *ldb, doublereal *x, integer *ldx, doublereal *
rcond, doublereal *ferr, doublereal *berr, doublereal *work, integer *
iwork, integer *info)
{
/* -- LAPACK driver routine (version 3.0) --
Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
Courant Institute, Argonne National Lab, and Rice University
June 30, 1999
Purpose
=======
DPPSVX 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 stored in
packed format 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, AFP contains the factored form of A.
If EQUED = 'Y', the matrix A has been equilibrated
with scaling factors given by S. AP and AFP will not
be modified.
= 'N': The matrix A will be copied to AFP and factored.
= 'E': The matrix A will be equilibrated if necessary, then
copied to AFP 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.
AP (input/output) DOUBLE PRECISION array, dimension (N*(N+1)/2)
On entry, the upper or lower triangle of the symmetric matrix
A, packed columnwise in a linear array, except if FACT = 'F'
and EQUED = 'Y', then A must contain the equilibrated matrix
diag(S)*A*diag(S). The j-th column of A is stored in the
array AP as follows:
if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j;
if UPLO = 'L', AP(i + (j-1)*(2n-j)/2) = A(i,j) for j<=i<=n.
See below for further details. 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).
AFP (input or output) DOUBLE PRECISION array, dimension
(N*(N+1)/2)
If FACT = 'F', then AFP is an input argument and on entry
contains the triangular factor U or L from the Cholesky
factorization A = U'*U or A = L*L', in the same storage
format as A. If EQUED .ne. 'N', then AFP is the factored
form of the equilibrated matrix A.
If FACT = 'N', then AFP is an output argument and on exit
returns the triangular factor U or L from the Cholesky
factorization A = U'*U or A = L*L' of the original matrix A.
If FACT = 'E', then AFP is an output argument and on exit
returns the triangular factor U or L from the Cholesky
factorization A = U'*U or A = L*L' of the equilibrated
matrix A (see the description of AP for the form of the
equilibrated matrix).
EQUED (input or output) CHARACTER*1
Specifies the form of equilibration that was done.
= 'N': No equilibration (always true if FACT = 'N').
= 'Y': Equilibration was done, i.e., A has been replaced by
diag(S) * A * diag(S).
EQUED is an input argument if FACT = 'F'; otherwise, it is an
output argument.
S (input or output) DOUBLE PRECISION array, dimension (N)
The scale factors for A; not accessed if EQUED = 'N'. S is
an input argument if FACT = 'F'; otherwise, S is an output
argument. If FACT = 'F' and EQUED = 'Y', each element of S
must be positive.
B (input/output) DOUBLE PRECISION array, dimension (LDB,NRHS)
On entry, the N-by-NRHS right hand side matrix B.
On exit, if EQUED = 'N', B is not modified; if EQUED = 'Y',
B is overwritten by diag(S) * B.
LDB (input) INTEGER
The leading dimension of the array B. LDB >= max(1,N).
X (output) DOUBLE PRECISION array, dimension (LDX,NRHS)
If INFO = 0 or INFO = N+1, the N-by-NRHS solution matrix X to
the original system of equations. Note that if EQUED = 'Y',
A and B are modified on exit, and the solution to the
equilibrated system is inv(diag(S))*X.
LDX (input) INTEGER
The leading dimension of the array X. LDX >= max(1,N).
RCOND (output) DOUBLE PRECISION
The estimate of the reciprocal condition number of the matrix
A after equilibration (if done). If RCOND is less than the
machine precision (in particular, if RCOND = 0), the matrix
is singular to working precision. This condition is
indicated by a return code of INFO > 0.
FERR (output) DOUBLE PRECISION array, dimension (NRHS)
The estimated forward error bound for each solution vector
X(j) (the j-th column of the solution matrix X).
If XTRUE is the true solution corresponding to X(j), FERR(j)
is an estimated upper bound for the magnitude of the largest
element in (X(j) - XTRUE) divided by the magnitude of the
largest element in X(j). The estimate is as reliable as
the estimate for RCOND, and is almost always a slight
overestimate of the true error.
BERR (output) DOUBLE PRECISION array, dimension (NRHS)
The componentwise relative backward error of each solution
vector X(j) (i.e., the smallest relative change in
any element of A or B that makes X(j) an exact solution).
WORK (workspace) DOUBLE PRECISION array, dimension (3*N)
IWORK (workspace) INTEGER array, dimension (N)
INFO (output) INTEGER
= 0: successful exit
< 0: if INFO = -i, the i-th argument had an illegal value
> 0: if INFO = i, and i is
<= N: the leading minor of order i of A is
not positive definite, so the factorization
could not be completed, and the solution has not
been computed. RCOND = 0 is returned.
= N+1: U is nonsingular, but RCOND is less than machine
precision, meaning that the matrix is singular
to working precision. Nevertheless, the
solution and error bounds are computed because
there are a number of situations where the
computed solution can be more accurate than the
value of RCOND would suggest.
Further Details
===============
The packed storage scheme is illustrated by the following example
when N = 4, UPLO = 'U':
Two-dimensional storage of the symmetric matrix A:
a11 a12 a13 a14
a22 a23 a24
a33 a34 (aij = conjg(aji))
a44
Packed storage of the upper triangle of A:
AP = [ a11, a12, a22, a13, a23, a33, a14, a24, a34, a44 ]
=====================================================================
Parameter adjustments */
/* Table of constant values */
static integer c__1 = 1;
/* System generated locals */
integer b_dim1, b_offset, x_dim1, x_offset, i__1, i__2;
doublereal d__1, d__2;
/* Local variables */
static doublereal amax, smin, smax;
static integer i__, j;
extern logical lsame_(char *, char *);
static doublereal scond, anorm;
extern /* Subroutine */ int dcopy_(integer *, doublereal *, integer *,
doublereal *, integer *);
static logical equil, rcequ;
extern doublereal dlamch_(char *);
static logical nofact;
extern /* Subroutine */ int dlacpy_(char *, integer *, integer *,
doublereal *, integer *, doublereal *, integer *),
xerbla_(char *, integer *);
static doublereal bignum;
extern doublereal dlansp_(char *, char *, integer *, doublereal *,
doublereal *);
extern /* Subroutine */ int dppcon_(char *, integer *, doublereal *,
doublereal *, doublereal *, doublereal *, integer *, integer *), dlaqsp_(char *, integer *, doublereal *, doublereal *,
doublereal *, doublereal *, char *);
static integer infequ;
extern /* Subroutine */ int 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 *);
static doublereal smlnum;
extern /* Subroutine */ int dpptrs_(char *, integer *, integer *,
doublereal *, doublereal *, integer *, integer *);
#define b_ref(a_1,a_2) b[(a_2)*b_dim1 + a_1]
#define x_ref(a_1,a_2) x[(a_2)*x_dim1 + a_1]
--ap;
--afp;
--s;
b_dim1 = *ldb;
b_offset = 1 + b_dim1 * 1;
b -= b_offset;
x_dim1 = *ldx;
x_offset = 1 + x_dim1 * 1;
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 (lsame_(fact, "F") && ! (rcequ || lsame_(
equed, "N"))) {
*info = -7;
} else {
if (rcequ) {
smin = bignum;
smax = 0.;
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
/* Computing MIN */
d__1 = smin, d__2 = s[j];
smin = min(d__1,d__2);
/* Computing MAX */
d__1 = smax, d__2 = s[j];
smax = max(d__1,d__2);
/* L10: */
}
if (smin <= 0.) {
*info = -8;
} else if (*n > 0) {
scond = max(smin,smlnum) / min(smax,bignum);
} else {
scond = 1.;
}
}
if (*info == 0) {
if (*ldb < max(1,*n)) {
*info = -10;
} else if (*ldx < max(1,*n)) {
*info = -12;
}
}
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("DPPSVX", &i__1);
return 0;
}
if (equil) {
/* Compute row and column scalings to equilibrate the matrix A. */
dppequ_(uplo, n, &ap[1], &s[1], &scond, &amax, &infequ);
if (infequ == 0) {
/* Equilibrate the matrix. */
dlaqsp_(uplo, n, &ap[1], &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_ref(i__, j) = s[i__] * b_ref(i__, j);
/* L20: */
}
/* L30: */
}
}
if (nofact || equil) {
/* Compute the Cholesky factorization A = U'*U or A = L*L'. */
i__1 = *n * (*n + 1) / 2;
dcopy_(&i__1, &ap[1], &c__1, &afp[1], &c__1);
dpptrf_(uplo, n, &afp[1], info);
/* Return if INFO is non-zero. */
if (*info != 0) {
if (*info > 0) {
*rcond = 0.;
}
return 0;
}
}
/* Compute the norm of the matrix A. */
anorm = dlansp_("I", uplo, n, &ap[1], &work[1]);
/* Compute the reciprocal of the condition number of A. */
dppcon_(uplo, n, &afp[1], &anorm, rcond, &work[1], &iwork[1], info);
/* Set INFO = N+1 if the matrix is singular to working precision. */
if (*rcond < dlamch_("Epsilon")) {
*info = *n + 1;
}
/* Compute the solution matrix X. */
dlacpy_("Full", n, nrhs, &b[b_offset], ldb, &x[x_offset], ldx);
dpptrs_(uplo, n, nrhs, &afp[1], &x[x_offset], ldx, info);
/* Use iterative refinement to improve the computed solution and
compute error bounds and backward error estimates for it. */
dpprfs_(uplo, n, nrhs, &ap[1], &afp[1], &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_ref(i__, j) = s[i__] * x_ref(i__, j);
/* L40: */
}
/* L50: */
}
i__1 = *nrhs;
for (j = 1; j <= i__1; ++j) {
ferr[j] /= scond;
/* L60: */
}
}
return 0;
/* End of DPPSVX */
} /* dppsvx_ */
int log_lkhd(GP *gp, double *phi, double *fn, double *gr)
{
int i, j, k;
int offset;
int one = 1;
int ind;
int err;
char U = 'U';
char N = 'N';
char T = 'T';
char onec = '1';
double det = 0.0;
double *deriv;
double *re;
double tmp;
double tmptmp = 0.0;
double anorm;
double rcond;
double *dwork;
int *iwork;
int ii;
double nug;
double t;
deriv = malloc(sizeof(double) * gp->ud);
re = malloc(sizeof(double) * gp->ud);
R_packed_U(gp->R, gp->phi, gp->ux, gp->ud, gp->dim);
nugget(gp->R, gp->ud, &nug);
printf("nugget %e\n", nug);
for(i=0, ii=0;i<gp->ud;i++)
{
gp->R[ii+i] += nug;
ii += i + 1;
}
/*
for(i=0,offset=0;i<gp->ud;i++)
{
for(j=0;j<=i;j++)
{
printf("%e ", gp->R[offset+j]);
}
printf("\n");
offset+=i+1;
}
*/
#ifdef SAT_DEBUG
dwork = malloc(sizeof(double) * gp->ud * 3);
iwork = malloc(sizeof(double) * gp->ud);
anorm = dlansp_(&onec, &U, &gp->ud, gp->R, dwork);
printf("anorm %e\n", rcond);
#endif
dpptrf_(&U, &gp->ud, gp->R, &err); // R^-1
if(err!=0){printf("CHOLESKY ERROR: %d\n", err);return(err);}
#ifdef SAT_DEBUG
dppcon_(&U, &gp->ud, gp->R, &anorm, &rcond, dwork, iwork, &err);
printf("rcond %e\n", rcond);
if(err!=0){printf("RCOND ERROR: %d\n", err);return(err);}
free(dwork);
free(iwork);
#endif
/*
for(i=0,offset=0;i<gp->ud;i++)
{
for(j=0;j<=i;j++)
{
printf("%e ", gp->R[offset+j]);
}
printf("\n");
offset+=i+1;
}
*/
for(i=0;i<gp->ud;i++)
{
gp->e[i] = gp->uy[i];
gp->F[i] = 1.0;
}
//dpptrs_(&U, &gp->ud, &one, gp->R, gp->e, &gp->dd, &err); // R^-1 * y
dtpsv_(&U, &T, &N, &gp->ud, gp->R, gp->e, &one); // R^-1 * y
//if(err!=0){printf("error: %d\n", err);}
//dpptrs_(&U, &gp->ud, &one, gp->R, gp->F, &gp->dd, &err); // R^-1 * 1
dtpsv_(&U, &T, &N, &gp->ud, gp->R, gp->F, &one); // R^-1 * 1
//if(err!=0){printf("error: %d\n", err);}
*gp->FRF = ddot_(&gp->ud, gp->F, &one, gp->F, &one); //1^t * R^-1 * 1
//printf("FRF %e\n", *gp->FRF);
*gp->beta = (1.0/(*gp->FRF)) * ddot_(&gp->ud, gp->F, &one, gp->e, &one); //beta = (1^t * R^-1 * 1)^-1 * 1^t * R^-1 * y
//printf("beta %e\n", *gp->beta);
for(i=0;i<gp->ud;i++)
{
gp->e[i] = gp->uy[i] - *gp->beta;
}
for(i=0;i<gp->ud;i++)
{
//printf("R1 %e\n", gp->F[i]);
}
//dpptrs_(&U, &gp->ud, &one, gp->R, gp->e, &gp->dd, &err); // R^-1 * e
dtpsv_(&U, &T, &N, &gp->ud, gp->R, gp->e, &one); // R^-1 * e
//if(err!=0){printf("error: %d\n", err);}
gp->sigma = (1.0/(double)gp->ud) * ddot_(&gp->ud, gp->e, &one, gp->e, &one); // sigma = 1/N * e^t * R^-1 * e
for(i=0,ind=0;i<gp->ud;i++)
{
det += log(gp->R[ind+i]);
ind += i+1;
}
det *= 2.0;
*fn = det + gp->ud * gp->sigma;
// CALCULATION OF GRADIENT
t = omp_get_wtime();
for(i=0;i<gp->dim;i++)
{
gr[i] = 0.0;
}
for(i=0;i<gp->ud;i++)
{
re[i] = gp->e[i];
}
dtpsv_(&U, &N, &N, &gp->ud, gp->R, re, &one); // R^-1 * e
for(k=0;k<gp->ud;k++)
{
for(i=0;i<gp->ud;i++)
{
deriv[i] = -re[k] * (gp->uy[i] - *gp->beta);
}
deriv[k] += 1.0;
dpptrs_(&U, &gp->ud, &one, gp->R, deriv, &gp->dd, &err);
for(j=0;j<gp->ud;j++)
{
for(i=0;i<gp->dim;i++)
{
kernel_deriv(i, &gp->ux[j*gp->dim], &gp->ux[k*gp->dim], gp->phi, gp->dim, &tmp);
gr[i] += deriv[j] * tmp;
}
}
}
t = omp_get_wtime() - t;
printf("ITER %d time-grad %e\n", gp->ud, t);
free(deriv);
free(re);
return(0);
}
/* Subroutine */ int dspgvd_(integer *itype, char *jobz, char *uplo, integer *
n, doublereal *ap, doublereal *bp, doublereal *w, doublereal *z__,
integer *ldz, doublereal *work, integer *lwork, integer *iwork,
integer *liwork, integer *info)
{
/* System generated locals */
integer z_dim1, z_offset, i__1;
doublereal d__1, d__2;
/* Local variables */
integer j, neig;
extern logical lsame_(char *, char *);
integer lwmin;
char trans[1];
logical upper;
extern /* Subroutine */ int dtpmv_(char *, char *, char *, integer *,
doublereal *, doublereal *, integer *),
dtpsv_(char *, char *, char *, integer *, doublereal *,
doublereal *, integer *);
logical wantz;
extern /* Subroutine */ int xerbla_(char *, integer *), dspevd_(
char *, char *, integer *, doublereal *, doublereal *, doublereal
*, integer *, doublereal *, integer *, integer *, integer *,
integer *);
integer liwmin;
extern /* Subroutine */ int dpptrf_(char *, integer *, doublereal *,
integer *), dspgst_(integer *, char *, integer *,
doublereal *, doublereal *, integer *);
logical lquery;
/* -- LAPACK driver routine (version 3.1) -- */
/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/* November 2006 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* DSPGVD computes all the eigenvalues, and optionally, the eigenvectors */
/* of a real generalized symmetric-definite eigenproblem, of the form */
/* A*x=(lambda)*B*x, A*Bx=(lambda)*x, or B*A*x=(lambda)*x. Here A and */
/* B are assumed to be symmetric, stored in packed format, and B is also */
/* positive definite. */
/* If eigenvectors are desired, it uses a divide and conquer algorithm. */
/* The divide and conquer algorithm makes very mild assumptions about */
/* floating point arithmetic. It will work on machines with a guard */
/* digit in add/subtract, or on those binary machines without guard */
/* digits which subtract like the Cray X-MP, Cray Y-MP, Cray C-90, or */
/* Cray-2. It could conceivably fail on hexadecimal or decimal machines */
/* without guard digits, but we know of none. */
/* Arguments */
/* ========= */
/* ITYPE (input) INTEGER */
/* Specifies the problem type to be solved: */
/* = 1: A*x = (lambda)*B*x */
/* = 2: A*B*x = (lambda)*x */
/* = 3: B*A*x = (lambda)*x */
/* JOBZ (input) CHARACTER*1 */
/* = 'N': Compute eigenvalues only; */
/* = 'V': Compute eigenvalues and eigenvectors. */
/* UPLO (input) CHARACTER*1 */
/* = 'U': Upper triangles of A and B are stored; */
/* = 'L': Lower triangles of A and B are stored. */
/* N (input) INTEGER */
/* The order of the matrices A and B. N >= 0. */
/* AP (input/output) DOUBLE PRECISION array, dimension (N*(N+1)/2) */
/* On entry, the upper or lower triangle of the symmetric matrix */
/* A, packed columnwise in a linear array. The j-th column of A */
/* is stored in the array AP as follows: */
/* if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j; */
/* if UPLO = 'L', AP(i + (j-1)*(2*n-j)/2) = A(i,j) for j<=i<=n. */
/* On exit, the contents of AP are destroyed. */
/* BP (input/output) DOUBLE PRECISION array, dimension (N*(N+1)/2) */
/* On entry, the upper or lower triangle of the symmetric matrix */
/* B, packed columnwise in a linear array. The j-th column of B */
/* is stored in the array BP as follows: */
/* if UPLO = 'U', BP(i + (j-1)*j/2) = B(i,j) for 1<=i<=j; */
/* if UPLO = 'L', BP(i + (j-1)*(2*n-j)/2) = B(i,j) for j<=i<=n. */
/* On exit, the triangular factor U or L from the Cholesky */
/* factorization B = U**T*U or B = L*L**T, in the same storage */
/* format as B. */
/* W (output) DOUBLE PRECISION array, dimension (N) */
/* If INFO = 0, the eigenvalues in ascending order. */
/* Z (output) DOUBLE PRECISION array, dimension (LDZ, N) */
/* If JOBZ = 'V', then if INFO = 0, Z contains the matrix Z of */
/* eigenvectors. The eigenvectors are normalized as follows: */
/* if ITYPE = 1 or 2, Z**T*B*Z = I; */
/* if ITYPE = 3, Z**T*inv(B)*Z = I. */
/* If JOBZ = 'N', then Z is not referenced. */
/* LDZ (input) INTEGER */
/* The leading dimension of the array Z. LDZ >= 1, and if */
/* JOBZ = 'V', LDZ >= max(1,N). */
/* WORK (workspace/output) DOUBLE PRECISION array, dimension (MAX(1,LWORK)) */
/* On exit, if INFO = 0, WORK(1) returns the required LWORK. */
/* LWORK (input) INTEGER */
/* The dimension of the array WORK. */
/* If N <= 1, LWORK >= 1. */
/* If JOBZ = 'N' and N > 1, LWORK >= 2*N. */
/* If JOBZ = 'V' and N > 1, LWORK >= 1 + 6*N + 2*N**2. */
/* If LWORK = -1, then a workspace query is assumed; the routine */
/* only calculates the required sizes of the WORK and IWORK */
/* arrays, returns these values as the first entries of the WORK */
/* and IWORK arrays, and no error message related to LWORK or */
/* LIWORK is issued by XERBLA. */
/* IWORK (workspace/output) INTEGER array, dimension (MAX(1,LIWORK)) */
/* On exit, if INFO = 0, IWORK(1) returns the required LIWORK. */
/* LIWORK (input) INTEGER */
/* The dimension of the array IWORK. */
/* If JOBZ = 'N' or N <= 1, LIWORK >= 1. */
/* If JOBZ = 'V' and N > 1, LIWORK >= 3 + 5*N. */
/* If LIWORK = -1, then a workspace query is assumed; the */
/* routine only calculates the required sizes of the WORK and */
/* IWORK arrays, returns these values as the first entries of */
/* the WORK and IWORK arrays, and no error message related to */
/* LWORK or LIWORK is issued by XERBLA. */
/* INFO (output) INTEGER */
/* = 0: successful exit */
/* < 0: if INFO = -i, the i-th argument had an illegal value */
/* > 0: DPPTRF or DSPEVD returned an error code: */
/* <= N: if INFO = i, DSPEVD failed to converge; */
/* i off-diagonal elements of an intermediate */
/* tridiagonal form did not converge to zero; */
/* > N: if INFO = N + i, for 1 <= i <= N, then the leading */
/* minor of order i of B is not positive definite. */
/* The factorization of B could not be completed and */
/* no eigenvalues or eigenvectors were computed. */
/* Further Details */
/* =============== */
/* Based on contributions by */
/* Mark Fahey, Department of Mathematics, Univ. of Kentucky, USA */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Executable Statements .. */
/* Test the input parameters. */
/* Parameter adjustments */
--ap;
--bp;
--w;
z_dim1 = *ldz;
z_offset = 1 + z_dim1;
z__ -= z_offset;
--work;
--iwork;
/* Function Body */
wantz = lsame_(jobz, "V");
upper = lsame_(uplo, "U");
lquery = *lwork == -1 || *liwork == -1;
*info = 0;
if (*itype < 1 || *itype > 3) {
*info = -1;
} else if (! (wantz || lsame_(jobz, "N"))) {
*info = -2;
} else if (! (upper || lsame_(uplo, "L"))) {
*info = -3;
} else if (*n < 0) {
*info = -4;
} else if (*ldz < 1 || wantz && *ldz < *n) {
*info = -9;
}
if (*info == 0) {
if (*n <= 1) {
liwmin = 1;
lwmin = 1;
} else {
if (wantz) {
liwmin = *n * 5 + 3;
/* Computing 2nd power */
i__1 = *n;
lwmin = *n * 6 + 1 + (i__1 * i__1 << 1);
} else {
liwmin = 1;
lwmin = *n << 1;
}
}
work[1] = (doublereal) lwmin;
iwork[1] = liwmin;
if (*lwork < lwmin && ! lquery) {
*info = -11;
} else if (*liwork < liwmin && ! lquery) {
*info = -13;
}
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("DSPGVD", &i__1);
return 0;
} else if (lquery) {
return 0;
}
/* Quick return if possible */
if (*n == 0) {
return 0;
}
/* Form a Cholesky factorization of BP. */
dpptrf_(uplo, n, &bp[1], info);
if (*info != 0) {
*info = *n + *info;
return 0;
}
/* Transform problem to standard eigenvalue problem and solve. */
dspgst_(itype, uplo, n, &ap[1], &bp[1], info);
dspevd_(jobz, uplo, n, &ap[1], &w[1], &z__[z_offset], ldz, &work[1],
lwork, &iwork[1], liwork, info);
/* Computing MAX */
d__1 = (doublereal) lwmin;
lwmin = (integer) max(d__1,work[1]);
/* Computing MAX */
d__1 = (doublereal) liwmin, d__2 = (doublereal) iwork[1];
liwmin = (integer) max(d__1,d__2);
if (wantz) {
/* Backtransform eigenvectors to the original problem. */
neig = *n;
if (*info > 0) {
neig = *info - 1;
}
if (*itype == 1 || *itype == 2) {
/* For A*x=(lambda)*B*x and A*B*x=(lambda)*x; */
/* backtransform eigenvectors: x = inv(L)'*y or inv(U)*y */
if (upper) {
*(unsigned char *)trans = 'N';
} else {
*(unsigned char *)trans = 'T';
}
i__1 = neig;
for (j = 1; j <= i__1; ++j) {
dtpsv_(uplo, trans, "Non-unit", n, &bp[1], &z__[j * z_dim1 +
1], &c__1);
/* L10: */
}
} else if (*itype == 3) {
/* For B*A*x=(lambda)*x; */
/* backtransform eigenvectors: x = L*y or U'*y */
if (upper) {
*(unsigned char *)trans = 'T';
} else {
*(unsigned char *)trans = 'N';
}
i__1 = neig;
for (j = 1; j <= i__1; ++j) {
dtpmv_(uplo, trans, "Non-unit", n, &bp[1], &z__[j * z_dim1 +
1], &c__1);
/* L20: */
}
}
}
work[1] = (doublereal) lwmin;
iwork[1] = liwmin;
return 0;
/* End of DSPGVD */
} /* dspgvd_ */
/* Subroutine */ int dspgvd_(integer *itype, char *jobz, char *uplo, integer *
n, doublereal *ap, doublereal *bp, doublereal *w, doublereal *z__,
integer *ldz, doublereal *work, integer *lwork, integer *iwork,
integer *liwork, integer *info)
{
/* -- LAPACK driver routine (version 3.0) --
Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
Courant Institute, Argonne National Lab, and Rice University
June 30, 1999
Purpose
=======
DSPGVD computes all the eigenvalues, and optionally, the eigenvectors
of a real generalized symmetric-definite eigenproblem, of the form
A*x=(lambda)*B*x, A*Bx=(lambda)*x, or B*A*x=(lambda)*x. Here A and
B are assumed to be symmetric, stored in packed format, and B is also
positive definite.
If eigenvectors are desired, it uses a divide and conquer algorithm.
The divide and conquer algorithm makes very mild assumptions about
floating point arithmetic. It will work on machines with a guard
digit in add/subtract, or on those binary machines without guard
digits which subtract like the Cray X-MP, Cray Y-MP, Cray C-90, or
Cray-2. It could conceivably fail on hexadecimal or decimal machines
without guard digits, but we know of none.
Arguments
=========
ITYPE (input) INTEGER
Specifies the problem type to be solved:
= 1: A*x = (lambda)*B*x
= 2: A*B*x = (lambda)*x
= 3: B*A*x = (lambda)*x
JOBZ (input) CHARACTER*1
= 'N': Compute eigenvalues only;
= 'V': Compute eigenvalues and eigenvectors.
UPLO (input) CHARACTER*1
= 'U': Upper triangles of A and B are stored;
= 'L': Lower triangles of A and B are stored.
N (input) INTEGER
The order of the matrices A and B. N >= 0.
AP (input/output) DOUBLE PRECISION array, dimension (N*(N+1)/2)
On entry, the upper or lower triangle of the symmetric matrix
A, packed columnwise in a linear array. The j-th column of A
is stored in the array AP as follows:
if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j;
if UPLO = 'L', AP(i + (j-1)*(2*n-j)/2) = A(i,j) for j<=i<=n.
On exit, the contents of AP are destroyed.
BP (input/output) DOUBLE PRECISION array, dimension (N*(N+1)/2)
On entry, the upper or lower triangle of the symmetric matrix
B, packed columnwise in a linear array. The j-th column of B
is stored in the array BP as follows:
if UPLO = 'U', BP(i + (j-1)*j/2) = B(i,j) for 1<=i<=j;
if UPLO = 'L', BP(i + (j-1)*(2*n-j)/2) = B(i,j) for j<=i<=n.
On exit, the triangular factor U or L from the Cholesky
factorization B = U**T*U or B = L*L**T, in the same storage
format as B.
W (output) DOUBLE PRECISION array, dimension (N)
If INFO = 0, the eigenvalues in ascending order.
Z (output) DOUBLE PRECISION array, dimension (LDZ, N)
If JOBZ = 'V', then if INFO = 0, Z contains the matrix Z of
eigenvectors. The eigenvectors are normalized as follows:
if ITYPE = 1 or 2, Z**T*B*Z = I;
if ITYPE = 3, Z**T*inv(B)*Z = I.
If JOBZ = 'N', then Z is not referenced.
LDZ (input) INTEGER
The leading dimension of the array Z. LDZ >= 1, and if
JOBZ = 'V', LDZ >= max(1,N).
WORK (workspace/output) DOUBLE PRECISION array, dimension (LWORK)
On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
LWORK (input) INTEGER
The dimension of the array WORK.
If N <= 1, LWORK >= 1.
If JOBZ = 'N' and N > 1, LWORK >= 2*N.
If JOBZ = 'V' and N > 1, LWORK >= 1 + 6*N + 2*N**2.
If LWORK = -1, then a workspace query is assumed; the routine
only calculates the optimal size of the WORK array, returns
this value as the first entry of the WORK array, and no error
message related to LWORK is issued by XERBLA.
IWORK (workspace/output) INTEGER array, dimension (LIWORK)
On exit, if INFO = 0, IWORK(1) returns the optimal LIWORK.
LIWORK (input) INTEGER
The dimension of the array IWORK.
If JOBZ = 'N' or N <= 1, LIWORK >= 1.
If JOBZ = 'V' and N > 1, LIWORK >= 3 + 5*N.
If LIWORK = -1, then a workspace query is assumed; the
routine only calculates the optimal size of the IWORK array,
returns this value as the first entry of the IWORK array, and
no error message related to LIWORK is issued by XERBLA.
INFO (output) INTEGER
= 0: successful exit
< 0: if INFO = -i, the i-th argument had an illegal value
> 0: DPPTRF or DSPEVD returned an error code:
<= N: if INFO = i, DSPEVD failed to converge;
i off-diagonal elements of an intermediate
tridiagonal form did not converge to zero;
> N: if INFO = N + i, for 1 <= i <= N, then the leading
minor of order i of B is not positive definite.
The factorization of B could not be completed and
no eigenvalues or eigenvectors were computed.
Further Details
===============
Based on contributions by
Mark Fahey, Department of Mathematics, Univ. of Kentucky, USA
=====================================================================
Test the input parameters.
Parameter adjustments */
/* Table of constant values */
static integer c__2 = 2;
static integer c__1 = 1;
/* System generated locals */
integer z_dim1, z_offset, i__1;
doublereal d__1, d__2;
/* Builtin functions */
double log(doublereal);
integer pow_ii(integer *, integer *);
/* Local variables */
static integer neig, j;
extern logical lsame_(char *, char *);
static integer lwmin;
static char trans[1];
static logical upper;
extern /* Subroutine */ int dtpmv_(char *, char *, char *, integer *,
doublereal *, doublereal *, integer *),
dtpsv_(char *, char *, char *, integer *, doublereal *,
doublereal *, integer *);
static logical wantz;
extern /* Subroutine */ int xerbla_(char *, integer *), dspevd_(
char *, char *, integer *, doublereal *, doublereal *, doublereal
*, integer *, doublereal *, integer *, integer *, integer *,
integer *);
static integer liwmin;
extern /* Subroutine */ int dpptrf_(char *, integer *, doublereal *,
integer *), dspgst_(integer *, char *, integer *,
doublereal *, doublereal *, integer *);
static logical lquery;
static integer lgn;
#define z___ref(a_1,a_2) z__[(a_2)*z_dim1 + a_1]
--ap;
--bp;
--w;
z_dim1 = *ldz;
z_offset = 1 + z_dim1 * 1;
z__ -= z_offset;
--work;
--iwork;
/* Function Body */
wantz = lsame_(jobz, "V");
upper = lsame_(uplo, "U");
lquery = *lwork == -1 || *liwork == -1;
*info = 0;
if (*n <= 1) {
lgn = 0;
liwmin = 1;
lwmin = 1;
} else {
lgn = (integer) (log((doublereal) (*n)) / log(2.));
if (pow_ii(&c__2, &lgn) < *n) {
++lgn;
}
if (pow_ii(&c__2, &lgn) < *n) {
++lgn;
}
if (wantz) {
liwmin = *n * 5 + 3;
/* Computing 2nd power */
i__1 = *n;
lwmin = *n * 5 + 1 + (*n << 1) * lgn + (i__1 * i__1 << 1);
} else {
liwmin = 1;
lwmin = *n << 1;
}
}
if (*itype < 0 || *itype > 3) {
*info = -1;
} else if (! (wantz || lsame_(jobz, "N"))) {
*info = -2;
} else if (! (upper || lsame_(uplo, "L"))) {
*info = -3;
} else if (*n < 0) {
*info = -4;
} else if (*ldz < max(1,*n)) {
*info = -9;
} else if (*lwork < lwmin && ! lquery) {
*info = -11;
} else if (*liwork < liwmin && ! lquery) {
*info = -13;
}
if (*info == 0) {
work[1] = (doublereal) lwmin;
iwork[1] = liwmin;
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("DSPGVD", &i__1);
return 0;
} else if (lquery) {
return 0;
}
/* Quick return if possible */
if (*n == 0) {
return 0;
}
/* Form a Cholesky factorization of BP. */
dpptrf_(uplo, n, &bp[1], info);
if (*info != 0) {
*info = *n + *info;
return 0;
}
/* Transform problem to standard eigenvalue problem and solve. */
dspgst_(itype, uplo, n, &ap[1], &bp[1], info);
dspevd_(jobz, uplo, n, &ap[1], &w[1], &z__[z_offset], ldz, &work[1],
lwork, &iwork[1], liwork, info);
/* Computing MAX */
d__1 = (doublereal) lwmin;
lwmin = (integer) max(d__1,work[1]);
/* Computing MAX */
d__1 = (doublereal) liwmin, d__2 = (doublereal) iwork[1];
liwmin = (integer) max(d__1,d__2);
if (wantz) {
/* Backtransform eigenvectors to the original problem. */
neig = *n;
if (*info > 0) {
neig = *info - 1;
}
if (*itype == 1 || *itype == 2) {
/* For A*x=(lambda)*B*x and A*B*x=(lambda)*x;
backtransform eigenvectors: x = inv(L)'*y or inv(U)*y */
if (upper) {
*(unsigned char *)trans = 'N';
} else {
*(unsigned char *)trans = 'T';
}
i__1 = neig;
for (j = 1; j <= i__1; ++j) {
dtpsv_(uplo, trans, "Non-unit", n, &bp[1], &z___ref(1, j), &
c__1);
/* L10: */
}
} else if (*itype == 3) {
/* For B*A*x=(lambda)*x;
backtransform eigenvectors: x = L*y or U'*y */
if (upper) {
*(unsigned char *)trans = 'T';
} else {
*(unsigned char *)trans = 'N';
}
i__1 = neig;
for (j = 1; j <= i__1; ++j) {
dtpmv_(uplo, trans, "Non-unit", n, &bp[1], &z___ref(1, j), &
c__1);
/* L20: */
}
}
}
work[1] = (doublereal) lwmin;
iwork[1] = liwmin;
return 0;
/* End of DSPGVD */
} /* dspgvd_ */
/* Subroutine */ int dchkpp_(logical *dotype, integer *nn, integer *nval,
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";
static char packs[1*2] = "C" "R";
/* Format strings */
static char fmt_9999[] = "(\002 UPLO = '\002,a1,\002', N =\002,i5,\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)";
/* System generated locals */
integer i__1, i__2, i__3;
/* 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, in, kl, ku, lda, npp, 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;
integer nimat;
extern /* Subroutine */ int dppt01_(char *, integer *, doublereal *,
doublereal *, doublereal *, doublereal *), dppt02_(char *,
integer *, integer *, doublereal *, doublereal *, integer *,
doublereal *, integer *, doublereal *, doublereal *),
dppt03_(char *, integer *, doublereal *, doublereal *, doublereal
*, integer *, doublereal *, doublereal *, doublereal *);
doublereal anorm;
extern /* Subroutine */ int dppt05_(char *, integer *, integer *,
doublereal *, doublereal *, integer *, doublereal *, integer *,
doublereal *, integer *, doublereal *, doublereal *, doublereal *), dcopy_(integer *, doublereal *, integer *, doublereal *,
integer *);
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;
char packit[1];
extern /* Subroutine */ int dlacpy_(char *, integer *, integer *,
doublereal *, integer *, doublereal *, integer *),
dlarhs_(char *, char *, char *, char *, integer *, integer *,
integer *, integer *, integer *, doublereal *, integer *,
doublereal *, integer *, doublereal *, integer *, integer *,
integer *);
extern doublereal dlansp_(char *, char *, integer *, doublereal *,
doublereal *);
extern /* Subroutine */ int 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 *), dppcon_(char *, integer *,
doublereal *, doublereal *, doublereal *, doublereal *, integer *,
integer *), derrpo_(char *, 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 *),
dpptrs_(char *, integer *, integer *, doublereal *, doublereal *,
integer *, integer *);
doublereal result[8];
/* Fortran I/O blocks */
static cilist io___34 = { 0, 0, 0, fmt_9999, 0 };
static cilist io___37 = { 0, 0, 0, fmt_9998, 0 };
static cilist io___39 = { 0, 0, 0, fmt_9999, 0 };
/* -- LAPACK test routine (version 3.1) -- */
/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/* November 2006 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* DCHKPP tests DPPTRF, -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. */
/* 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+1)/2) */
/* AFAC (workspace) DOUBLE PRECISION array, dimension */
/* (NMAX*(NMAX+1)/2) */
/* AINV (workspace) DOUBLE PRECISION array, dimension */
/* (NMAX*(NMAX+1)/2) */
/* 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;
--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, "PP", (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;
/* 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;
}
i__2 = nimat;
for (imat = 1; imat <= i__2; ++imat) {
/* Do the tests only if DOTYPE( IMAT ) is true. */
if (! dotype[imat]) {
goto L100;
}
/* Skip types 3, 4, or 5 if the matrix size is too small. */
zerot = imat >= 3 && imat <= 5;
if (zerot && n < imat - 2) {
goto L100;
}
/* Do first for UPLO = 'U', then for UPLO = 'L' */
for (iuplo = 1; iuplo <= 2; ++iuplo) {
*(unsigned char *)uplo = *(unsigned char *)&uplos[iuplo - 1];
*(unsigned char *)packit = *(unsigned char *)&packs[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)32, (ftnlen)6);
dlatms_(&n, &n, dist, iseed, type__, &rwork[1], &mode, &
cndnum, &anorm, &kl, &ku, packit, &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 L90;
}
/* 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;
}
/* Set row and column IZERO of A to 0. */
if (iuplo == 1) {
ioff = (izero - 1) * izero / 2;
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 += i__;
/* L30: */
}
} else {
ioff = izero;
i__3 = izero - 1;
for (i__ = 1; i__ <= i__3; ++i__) {
a[ioff] = 0.;
ioff = ioff + n - i__;
/* L40: */
}
ioff -= izero;
i__3 = n;
for (i__ = izero; i__ <= i__3; ++i__) {
a[ioff + i__] = 0.;
/* L50: */
}
}
} else {
izero = 0;
}
/* Compute the L*L' or U'*U factorization of the matrix. */
npp = n * (n + 1) / 2;
dcopy_(&npp, &a[1], &c__1, &afac[1], &c__1);
s_copy(srnamc_1.srnamt, "DPPTRF", (ftnlen)32, (ftnlen)6);
dpptrf_(uplo, &n, &afac[1], &info);
/* Check error code from DPPTRF. */
if (info != izero) {
alaerh_(path, "DPPTRF", &info, &izero, uplo, &n, &n, &
c_n1, &c_n1, &c_n1, &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. */
dcopy_(&npp, &afac[1], &c__1, &ainv[1], &c__1);
dppt01_(uplo, &n, &a[1], &ainv[1], &rwork[1], result);
/* + TEST 2 */
/* Form the inverse and compute the residual. */
dcopy_(&npp, &afac[1], &c__1, &ainv[1], &c__1);
s_copy(srnamc_1.srnamt, "DPPTRI", (ftnlen)32, (ftnlen)6);
dpptri_(uplo, &n, &ainv[1], &info);
/* Check error code from DPPTRI. */
if (info != 0) {
alaerh_(path, "DPPTRI", &info, &c__0, uplo, &n, &n, &c_n1,
&c_n1, &c_n1, &imat, &nfail, &nerrs, nout);
}
dppt03_(uplo, &n, &a[1], &ainv[1], &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___34.ciunit = *nout;
s_wsfe(&io___34);
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 *)&k, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&result[k - 1], (ftnlen)sizeof(
doublereal));
e_wsfe();
++nfail;
}
/* L60: */
}
nrun += 2;
i__3 = *nns;
for (irhs = 1; irhs <= i__3; ++irhs) {
nrhs = nsval[irhs];
/* + TEST 3 */
/* Solve and compute residual for A * X = B. */
s_copy(srnamc_1.srnamt, "DLARHS", (ftnlen)32, (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, "DPPTRS", (ftnlen)32, (ftnlen)6);
dpptrs_(uplo, &n, &nrhs, &afac[1], &x[1], &lda, &info);
/* Check error code from DPPTRS. */
if (info != 0) {
alaerh_(path, "DPPTRS", &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);
dppt02_(uplo, &n, &nrhs, &a[1], &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, "DPPRFS", (ftnlen)32, (ftnlen)6);
dpprfs_(uplo, &n, &nrhs, &a[1], &afac[1], &b[1], &lda, &x[
1], &lda, &rwork[1], &rwork[nrhs + 1], &work[1], &
iwork[1], &info);
/* Check error code from DPPRFS. */
if (info != 0) {
alaerh_(path, "DPPRFS", &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]);
dppt05_(uplo, &n, &nrhs, &a[1], &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___37.ciunit = *nout;
s_wsfe(&io___37);
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 = dlansp_("1", uplo, &n, &a[1], &rwork[1]);
s_copy(srnamc_1.srnamt, "DPPCON", (ftnlen)32, (ftnlen)6);
dppcon_(uplo, &n, &afac[1], &anorm, &rcond, &work[1], &iwork[
1], &info);
/* Check error code from DPPCON. */
if (info != 0) {
alaerh_(path, "DPPCON", &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 greater than or equal to THRESH. */
if (result[7] >= *thresh) {
if (nfail == 0 && nerrs == 0) {
alahd_(nout, path);
}
io___39.ciunit = *nout;
s_wsfe(&io___39);
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: */
}
/* Print a summary of the results. */
alasum_(path, nout, &nfail, &nrun, &nerrs);
return 0;
/* End of DCHKPP */
} /* dchkpp_ */
/* Subroutine */ int ddrvpp_(logical *dotype, integer *nn, integer *nval,
integer *nrhs, doublereal *thresh, logical *tsterr, integer *nmax,
doublereal *a, doublereal *afac, doublereal *asav, doublereal *b,
doublereal *bsav, doublereal *x, doublereal *xact, doublereal *s,
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";
static char facts[1*3] = "F" "N" "E";
static char packs[1*2] = "C" "R";
static char equeds[1*2] = "N" "Y";
/* Format strings */
static char fmt_9999[] = "(1x,a,\002, UPLO='\002,a1,\002', N =\002,i5"
",\002, type \002,i1,\002, test(\002,i1,\002)=\002,g12.5)";
static char fmt_9997[] = "(1x,a,\002, FACT='\002,a1,\002', UPLO='\002,"
"a1,\002', N=\002,i5,\002, EQUED='\002,a1,\002', type \002,i1,"
"\002, test(\002,i1,\002)=\002,g12.5)";
static char fmt_9998[] = "(1x,a,\002, FACT='\002,a1,\002', UPLO='\002,"
"a1,\002', N=\002,i5,\002, type \002,i1,\002, test(\002,i1,\002)"
"=\002,g12.5)";
/* System generated locals */
address a__1[2];
integer i__1, i__2, i__3, i__4, i__5[2];
char ch__1[2];
/* Local variables */
integer i__, k, n, k1, in, kl, ku, nt, lda, npp;
char fact[1];
integer ioff, mode;
doublereal amax;
char path[3];
integer imat, info;
char dist[1], uplo[1], type__[1];
integer nrun, ifact;
integer nfail, iseed[4], nfact;
char equed[1];
doublereal roldc, rcond, scond;
integer nimat;
doublereal anorm;
logical equil;
integer iuplo, izero, nerrs;
logical zerot;
char xtype[1];
logical prefac;
doublereal rcondc;
logical nofact;
char packit[1];
integer iequed;
doublereal cndnum;
doublereal ainvnm;
doublereal result[6];
/* Fortran I/O blocks */
static cilist io___49 = { 0, 0, 0, fmt_9999, 0 };
static cilist io___52 = { 0, 0, 0, fmt_9997, 0 };
static cilist io___53 = { 0, 0, 0, fmt_9998, 0 };
/* -- LAPACK test routine (version 3.1) -- */
/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/* November 2006 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* DDRVPP tests the driver routines DPPSV and -SVX. */
/* Arguments */
/* ========= */
/* DOTYPE (input) LOGICAL array, dimension (NTYPES) */
/* The matrix types to be used for testing. Matrices of type j */
/* (for 1 <= j <= NTYPES) are used for testing if DOTYPE(j) = */
/* .TRUE.; if DOTYPE(j) = .FALSE., then type j is not used. */
/* NN (input) INTEGER */
/* The number of values of N contained in the vector NVAL. */
/* NVAL (input) INTEGER array, dimension (NN) */
/* The values of the matrix dimension N. */
/* NRHS (input) INTEGER */
/* The number of right hand side vectors to be generated for */
/* each linear system. */
/* 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+1)/2) */
/* AFAC (workspace) DOUBLE PRECISION array, dimension */
/* (NMAX*(NMAX+1)/2) */
/* ASAV (workspace) DOUBLE PRECISION array, dimension */
/* (NMAX*(NMAX+1)/2) */
/* B (workspace) DOUBLE PRECISION array, dimension (NMAX*NRHS) */
/* BSAV (workspace) DOUBLE PRECISION array, dimension (NMAX*NRHS) */
/* X (workspace) DOUBLE PRECISION array, dimension (NMAX*NRHS) */
/* XACT (workspace) DOUBLE PRECISION array, dimension (NMAX*NRHS) */
/* S (workspace) DOUBLE PRECISION array, dimension (NMAX) */
/* WORK (workspace) DOUBLE PRECISION array, dimension */
/* (NMAX*max(3,NRHS)) */
/* RWORK (workspace) DOUBLE PRECISION array, dimension (NMAX+2*NRHS) */
/* IWORK (workspace) INTEGER array, dimension (NMAX) */
/* NOUT (input) INTEGER */
/* The unit number for output. */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. Local Arrays .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Scalars in Common .. */
/* .. */
/* .. Common blocks .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Data statements .. */
/* Parameter adjustments */
--iwork;
--rwork;
--work;
--s;
--xact;
--x;
--bsav;
--b;
--asav;
--afac;
--a;
--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, "PP", (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) {
derrvx_(path, nout);
}
infoc_1.infot = 0;
/* Do for each value of N in NVAL */
i__1 = *nn;
for (in = 1; in <= i__1; ++in) {
n = nval[in];
lda = max(n,1);
npp = n * (n + 1) / 2;
*(unsigned char *)xtype = 'N';
nimat = 9;
if (n <= 0) {
nimat = 1;
}
i__2 = nimat;
for (imat = 1; imat <= i__2; ++imat) {
/* Do the tests only if DOTYPE( IMAT ) is true. */
if (! dotype[imat]) {
goto L130;
}
/* Skip types 3, 4, or 5 if the matrix size is too small. */
zerot = imat >= 3 && imat <= 5;
if (zerot && n < imat - 2) {
goto L130;
}
/* Do first for UPLO = 'U', then for UPLO = 'L' */
for (iuplo = 1; iuplo <= 2; ++iuplo) {
*(unsigned char *)uplo = *(unsigned char *)&uplos[iuplo - 1];
*(unsigned char *)packit = *(unsigned char *)&packs[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);
rcondc = 1. / cndnum;
s_copy(srnamc_1.srnamt, "DLATMS", (ftnlen)32, (ftnlen)6);
dlatms_(&n, &n, dist, iseed, type__, &rwork[1], &mode, &
cndnum, &anorm, &kl, &ku, packit, &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 L120;
}
/* 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;
}
/* Set row and column IZERO of A to 0. */
if (iuplo == 1) {
ioff = (izero - 1) * izero / 2;
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 += i__;
/* L30: */
}
} else {
ioff = izero;
i__3 = izero - 1;
for (i__ = 1; i__ <= i__3; ++i__) {
a[ioff] = 0.;
ioff = ioff + n - i__;
/* L40: */
}
ioff -= izero;
i__3 = n;
for (i__ = izero; i__ <= i__3; ++i__) {
a[ioff + i__] = 0.;
/* L50: */
}
}
} else {
izero = 0;
}
/* Save a copy of the matrix A in ASAV. */
dcopy_(&npp, &a[1], &c__1, &asav[1], &c__1);
for (iequed = 1; iequed <= 2; ++iequed) {
*(unsigned char *)equed = *(unsigned char *)&equeds[
iequed - 1];
if (iequed == 1) {
nfact = 3;
} else {
nfact = 1;
}
i__3 = nfact;
for (ifact = 1; ifact <= i__3; ++ifact) {
*(unsigned char *)fact = *(unsigned char *)&facts[
ifact - 1];
prefac = lsame_(fact, "F");
nofact = lsame_(fact, "N");
equil = lsame_(fact, "E");
if (zerot) {
if (prefac) {
goto L100;
}
rcondc = 0.;
} else if (! lsame_(fact, "N"))
{
/* Compute the condition number for comparison with */
/* the value returned by DPPSVX (FACT = 'N' reuses */
/* the condition number from the previous iteration */
/* with FACT = 'F'). */
dcopy_(&npp, &asav[1], &c__1, &afac[1], &c__1);
if (equil || iequed > 1) {
/* Compute row and column scale factors to */
/* equilibrate the matrix A. */
dppequ_(uplo, &n, &afac[1], &s[1], &scond, &
amax, &info);
if (info == 0 && n > 0) {
if (iequed > 1) {
scond = 0.;
}
/* Equilibrate the matrix. */
dlaqsp_(uplo, &n, &afac[1], &s[1], &scond,
&amax, equed);
}
}
/* Save the condition number of the */
/* non-equilibrated system for use in DGET04. */
if (equil) {
roldc = rcondc;
}
/* Compute the 1-norm of A. */
anorm = dlansp_("1", uplo, &n, &afac[1], &rwork[1]
);
/* Factor the matrix A. */
dpptrf_(uplo, &n, &afac[1], &info);
/* Form the inverse of A. */
dcopy_(&npp, &afac[1], &c__1, &a[1], &c__1);
dpptri_(uplo, &n, &a[1], &info);
/* Compute the 1-norm condition number of A. */
ainvnm = dlansp_("1", uplo, &n, &a[1], &rwork[1]);
if (anorm <= 0. || ainvnm <= 0.) {
rcondc = 1.;
} else {
rcondc = 1. / anorm / ainvnm;
}
}
/* Restore the matrix A. */
dcopy_(&npp, &asav[1], &c__1, &a[1], &c__1);
/* Form an exact solution and set the right hand side. */
s_copy(srnamc_1.srnamt, "DLARHS", (ftnlen)32, (ftnlen)
6);
dlarhs_(path, xtype, uplo, " ", &n, &n, &kl, &ku,
nrhs, &a[1], &lda, &xact[1], &lda, &b[1], &
lda, iseed, &info);
*(unsigned char *)xtype = 'C';
dlacpy_("Full", &n, nrhs, &b[1], &lda, &bsav[1], &lda);
if (nofact) {
/* --- Test DPPSV --- */
/* Compute the L*L' or U'*U factorization of the */
/* matrix and solve the system. */
dcopy_(&npp, &a[1], &c__1, &afac[1], &c__1);
dlacpy_("Full", &n, nrhs, &b[1], &lda, &x[1], &
lda);
s_copy(srnamc_1.srnamt, "DPPSV ", (ftnlen)32, (
ftnlen)6);
dppsv_(uplo, &n, nrhs, &afac[1], &x[1], &lda, &
info);
/* Check error code from DPPSV . */
if (info != izero) {
alaerh_(path, "DPPSV ", &info, &izero, uplo, &
n, &n, &c_n1, &c_n1, nrhs, &imat, &
nfail, &nerrs, nout);
goto L70;
} else if (info != 0) {
goto L70;
}
/* Reconstruct matrix from factors and compute */
/* residual. */
dppt01_(uplo, &n, &a[1], &afac[1], &rwork[1],
result);
/* Compute residual of the computed solution. */
dlacpy_("Full", &n, nrhs, &b[1], &lda, &work[1], &
lda);
dppt02_(uplo, &n, nrhs, &a[1], &x[1], &lda, &work[
1], &lda, &rwork[1], &result[1]);
/* Check solution from generated exact solution. */
dget04_(&n, nrhs, &x[1], &lda, &xact[1], &lda, &
rcondc, &result[2]);
nt = 3;
/* Print information about the tests that did not */
/* pass the threshold. */
i__4 = nt;
for (k = 1; k <= i__4; ++k) {
if (result[k - 1] >= *thresh) {
if (nfail == 0 && nerrs == 0) {
aladhd_(nout, path);
}
io___49.ciunit = *nout;
s_wsfe(&io___49);
do_fio(&c__1, "DPPSV ", (ftnlen)6);
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 *)&k, (ftnlen)sizeof(
integer));
do_fio(&c__1, (char *)&result[k - 1], (
ftnlen)sizeof(doublereal));
e_wsfe();
++nfail;
}
/* L60: */
}
nrun += nt;
L70:
;
}
/* --- Test DPPSVX --- */
if (! prefac && npp > 0) {
dlaset_("Full", &npp, &c__1, &c_b60, &c_b60, &
afac[1], &npp);
}
dlaset_("Full", &n, nrhs, &c_b60, &c_b60, &x[1], &lda);
if (iequed > 1 && n > 0) {
/* Equilibrate the matrix if FACT='F' and */
/* EQUED='Y'. */
dlaqsp_(uplo, &n, &a[1], &s[1], &scond, &amax,
equed);
}
/* Solve the system and compute the condition number */
/* and error bounds using DPPSVX. */
s_copy(srnamc_1.srnamt, "DPPSVX", (ftnlen)32, (ftnlen)
6);
dppsvx_(fact, uplo, &n, nrhs, &a[1], &afac[1], equed,
&s[1], &b[1], &lda, &x[1], &lda, &rcond, &
rwork[1], &rwork[*nrhs + 1], &work[1], &iwork[
1], &info);
/* Check the error code from DPPSVX. */
if (info != izero) {
/* Writing concatenation */
i__5[0] = 1, a__1[0] = fact;
i__5[1] = 1, a__1[1] = uplo;
s_cat(ch__1, a__1, i__5, &c__2, (ftnlen)2);
alaerh_(path, "DPPSVX", &info, &izero, ch__1, &n,
&n, &c_n1, &c_n1, nrhs, &imat, &nfail, &
nerrs, nout);
goto L90;
}
if (info == 0) {
if (! prefac) {
/* Reconstruct matrix from factors and compute */
/* residual. */
dppt01_(uplo, &n, &a[1], &afac[1], &rwork[(*
nrhs << 1) + 1], result);
k1 = 1;
} else {
k1 = 2;
}
/* Compute residual of the computed solution. */
dlacpy_("Full", &n, nrhs, &bsav[1], &lda, &work[1]
, &lda);
dppt02_(uplo, &n, nrhs, &asav[1], &x[1], &lda, &
work[1], &lda, &rwork[(*nrhs << 1) + 1], &
result[1]);
/* Check solution from generated exact solution. */
if (nofact || prefac && lsame_(equed, "N")) {
dget04_(&n, nrhs, &x[1], &lda, &xact[1], &lda,
&rcondc, &result[2]);
} else {
dget04_(&n, nrhs, &x[1], &lda, &xact[1], &lda,
&roldc, &result[2]);
}
/* Check the error bounds from iterative */
/* refinement. */
dppt05_(uplo, &n, nrhs, &asav[1], &b[1], &lda, &x[
1], &lda, &xact[1], &lda, &rwork[1], &
rwork[*nrhs + 1], &result[3]);
} else {
k1 = 6;
}
/* Compare RCOND from DPPSVX with the computed value */
/* in RCONDC. */
result[5] = dget06_(&rcond, &rcondc);
/* Print information about the tests that did not pass */
/* the threshold. */
for (k = k1; k <= 6; ++k) {
if (result[k - 1] >= *thresh) {
if (nfail == 0 && nerrs == 0) {
aladhd_(nout, path);
}
if (prefac) {
io___52.ciunit = *nout;
s_wsfe(&io___52);
do_fio(&c__1, "DPPSVX", (ftnlen)6);
do_fio(&c__1, fact, (ftnlen)1);
do_fio(&c__1, uplo, (ftnlen)1);
do_fio(&c__1, (char *)&n, (ftnlen)sizeof(
integer));
do_fio(&c__1, equed, (ftnlen)1);
do_fio(&c__1, (char *)&imat, (ftnlen)
sizeof(integer));
do_fio(&c__1, (char *)&k, (ftnlen)sizeof(
integer));
do_fio(&c__1, (char *)&result[k - 1], (
ftnlen)sizeof(doublereal));
e_wsfe();
} else {
io___53.ciunit = *nout;
s_wsfe(&io___53);
do_fio(&c__1, "DPPSVX", (ftnlen)6);
do_fio(&c__1, fact, (ftnlen)1);
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 *)&k, (ftnlen)sizeof(
integer));
do_fio(&c__1, (char *)&result[k - 1], (
ftnlen)sizeof(doublereal));
e_wsfe();
}
++nfail;
}
/* L80: */
}
nrun = nrun + 7 - k1;
L90:
L100:
;
}
/* L110: */
}
L120:
;
}
L130:
;
}
/* L140: */
}
/* Print a summary of the results. */
alasvm_(path, nout, &nfail, &nrun, &nerrs);
return 0;
/* End of DDRVPP */
} /* ddrvpp_ */
