int GMRFLib_comp_posdef_inverse(double *matrix, int dim)
{
/*
* overwrite a symmetric MATRIX with its inverse
*/
int info = 0, i, j;
switch (GMRFLib_blas_level) {
case BLAS_LEVEL2:
dpotf2_("L", &dim, matrix, &dim, &info, 1);
break;
case BLAS_LEVEL3:
dpotrf_("L", &dim, matrix, &dim, &info, 1);
break;
default:
GMRFLib_ASSERT(1 == 0, GMRFLib_ESNH);
break;
}
if (info)
GMRFLib_ERROR(GMRFLib_ESINGMAT);
dpotri_("L", &dim, matrix, &dim, &info, 1);
if (info)
GMRFLib_ERROR(GMRFLib_ESINGMAT);
for (i = 0; i < dim; i++) /* fill the U-part */
for (j = i + 1; j < dim; j++)
matrix[i + j * dim] = matrix[j + i * dim];
return GMRFLib_SUCCESS;
}
int GMRFLib_comp_chol_general(double **chol, double *matrix, int dim, double *logdet, int ecode)
{
/*
* return a malloc'ed cholesky factorisation of MATRIX in *chol and optional the log(determinant). if fail return
* `ecode'
*
*/
int info = 0, i, j;
double *a = NULL, det;
if (dim == 0) {
*chol = NULL;
return GMRFLib_SUCCESS;
}
a = Calloc(ISQR(dim), double);
memcpy(a, matrix, ISQR(dim) * sizeof(double));
switch (GMRFLib_blas_level) {
case BLAS_LEVEL2:
dpotf2_("L", &dim, a, &dim, &info, 1);
break;
case BLAS_LEVEL3:
dpotrf_("L", &dim, a, &dim, &info, 1);
break;
default:
GMRFLib_ASSERT(1 == 0, GMRFLib_ESNH);
break;
}
if (info) {
Free(a);
*chol = NULL;
return ecode;
}
if (logdet) {
for (det = 0.0, i = 0; i < dim; i++) {
det += log(a[i + i * dim]);
}
*logdet = 2.0 * det;
}
for (i = 0; i < dim; i++) { /* set to zero the upper part */
for (j = i + 1; j < dim; j++) {
a[i + j * dim] = 0.0;
}
}
*chol = a;
return GMRFLib_SUCCESS;
}
double dcholfact(int n, double *A, double *L)
{
/* if A is p.d. , A = L*L'
if A is p.s.d. , A + lambda*I = L*L'; */
int indef, i;
static double lambda = 1e-3/512/512;
memcpy(L, A, sizeof(double)*n*n);
dpotf2_("L", &n, L, &n, &indef);
if (indef != 0)
{
memcpy(L, A, sizeof(double)*n*n);
for (i=0;i<n;i++)
L[i*n+i] += lambda;
dpotf2_("L", &n, L, &n, &indef);
if (indef != 0)
{
printf("A is not positive semi-definite\n");
lambda *= 2;
}
return lambda;
}
return 0;
}
/* Subroutine */ int dpotrf_(char *uplo, integer *n, doublereal *a, integer *
lda, integer *info)
{
/* System generated locals */
integer a_dim1, a_offset, i__1, i__2, i__3, i__4;
/* Local variables */
integer j, jb, nb;
extern /* Subroutine */ int dgemm_(char *, char *, integer *, integer *,
integer *, doublereal *, doublereal *, integer *, doublereal *,
integer *, doublereal *, doublereal *, integer *);
extern logical lsame_(char *, char *);
extern /* Subroutine */ int dtrsm_(char *, char *, char *, char *,
integer *, integer *, doublereal *, doublereal *, integer *,
doublereal *, integer *);
logical upper;
extern /* Subroutine */ int dsyrk_(char *, char *, integer *, integer *,
doublereal *, doublereal *, integer *, doublereal *, doublereal *,
integer *), dpotf2_(char *, integer *,
doublereal *, integer *, integer *), xerbla_(char *,
integer *);
extern integer ilaenv_(integer *, char *, char *, integer *, integer *,
integer *, integer *);
/* -- LAPACK routine (version 3.2) -- */
/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/* November 2006 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* DPOTRF computes the Cholesky factorization of a real symmetric */
/* positive definite matrix A. */
/* 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. */
/* This is the block version of the algorithm, calling Level 3 BLAS. */
/* Arguments */
/* ========= */
/* UPLO (input) CHARACTER*1 */
/* = 'U': Upper triangle of A is stored; */
/* = 'L': Lower triangle of A is stored. */
/* N (input) INTEGER */
/* The order of the matrix A. N >= 0. */
/* A (input/output) DOUBLE PRECISION array, dimension (LDA,N) */
/* On entry, the symmetric matrix A. If UPLO = 'U', the leading */
/* N-by-N upper triangular part of A contains the upper */
/* triangular part of the matrix A, and the strictly lower */
/* triangular part of A is not referenced. If UPLO = 'L', the */
/* leading N-by-N lower triangular part of A contains the lower */
/* triangular part of the matrix A, and the strictly upper */
/* triangular part of A is not referenced. */
/* On exit, if INFO = 0, the factor U or L from the Cholesky */
/* factorization A = U**T*U or A = L*L**T. */
/* LDA (input) INTEGER */
/* The leading dimension of the array A. LDA >= max(1,N). */
/* INFO (output) INTEGER */
/* = 0: successful exit */
/* < 0: if INFO = -i, the i-th argument had an illegal value */
/* > 0: if INFO = i, the leading minor of order i is not */
/* positive definite, and the factorization could not be */
/* completed. */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Executable Statements .. */
/* Test the input parameters. */
/* Parameter adjustments */
a_dim1 = *lda;
a_offset = 1 + a_dim1;
a -= a_offset;
/* Function Body */
*info = 0;
upper = lsame_(uplo, "U");
if (! upper && ! lsame_(uplo, "L")) {
*info = -1;
} else if (*n < 0) {
*info = -2;
} else if (*lda < max(1,*n)) {
*info = -4;
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("DPOTRF", &i__1);
return 0;
}
/* Quick return if possible */
if (*n == 0) {
return 0;
}
/* Determine the block size for this environment. */
nb = ilaenv_(&c__1, "DPOTRF", uplo, n, &c_n1, &c_n1, &c_n1);
if (nb <= 1 || nb >= *n) {
/* Use unblocked code. */
dpotf2_(uplo, n, &a[a_offset], lda, info);
} else {
/* Use blocked code. */
if (upper) {
/* Compute the Cholesky factorization A = U'*U. */
i__1 = *n;
i__2 = nb;
for (j = 1; i__2 < 0 ? j >= i__1 : j <= i__1; j += i__2) {
/* Update and factorize the current diagonal block and test */
/* for non-positive-definiteness. */
/* Computing MIN */
i__3 = nb, i__4 = *n - j + 1;
jb = min(i__3,i__4);
i__3 = j - 1;
dsyrk_("Upper", "Transpose", &jb, &i__3, &c_b13, &a[j *
a_dim1 + 1], lda, &c_b14, &a[j + j * a_dim1], lda);
dpotf2_("Upper", &jb, &a[j + j * a_dim1], lda, info);
if (*info != 0) {
goto L30;
}
if (j + jb <= *n) {
/* Compute the current block row. */
i__3 = *n - j - jb + 1;
i__4 = j - 1;
dgemm_("Transpose", "No transpose", &jb, &i__3, &i__4, &
c_b13, &a[j * a_dim1 + 1], lda, &a[(j + jb) *
a_dim1 + 1], lda, &c_b14, &a[j + (j + jb) *
a_dim1], lda);
i__3 = *n - j - jb + 1;
dtrsm_("Left", "Upper", "Transpose", "Non-unit", &jb, &
i__3, &c_b14, &a[j + j * a_dim1], lda, &a[j + (j
+ jb) * a_dim1], lda);
}
/* L10: */
}
} else {
/* Compute the Cholesky factorization A = L*L'. */
i__2 = *n;
i__1 = nb;
for (j = 1; i__1 < 0 ? j >= i__2 : j <= i__2; j += i__1) {
/* Update and factorize the current diagonal block and test */
/* for non-positive-definiteness. */
/* Computing MIN */
i__3 = nb, i__4 = *n - j + 1;
jb = min(i__3,i__4);
i__3 = j - 1;
dsyrk_("Lower", "No transpose", &jb, &i__3, &c_b13, &a[j +
a_dim1], lda, &c_b14, &a[j + j * a_dim1], lda);
dpotf2_("Lower", &jb, &a[j + j * a_dim1], lda, info);
if (*info != 0) {
goto L30;
}
if (j + jb <= *n) {
/* Compute the current block column. */
i__3 = *n - j - jb + 1;
i__4 = j - 1;
dgemm_("No transpose", "Transpose", &i__3, &jb, &i__4, &
c_b13, &a[j + jb + a_dim1], lda, &a[j + a_dim1],
lda, &c_b14, &a[j + jb + j * a_dim1], lda);
i__3 = *n - j - jb + 1;
dtrsm_("Right", "Lower", "Transpose", "Non-unit", &i__3, &
jb, &c_b14, &a[j + j * a_dim1], lda, &a[j + jb +
j * a_dim1], lda);
}
/* L20: */
}
}
}
goto L40;
L30:
*info = *info + j - 1;
L40:
return 0;
/* End of DPOTRF */
} /* dpotrf_ */
/* Subroutine */ HYPRE_Int dpotrf_(char *uplo, integer *n, doublereal *a, integer *
lda, integer *info)
{
/* -- LAPACK routine (version 3.0) --
Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
Courant Institute, Argonne National Lab, and Rice University
March 31, 1993
Purpose
=======
DPOTRF computes the Cholesky factorization of a real symmetric
positive definite matrix A.
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.
This is the block version of the algorithm, calling Level 3 BLAS.
Arguments
=========
UPLO (input) CHARACTER*1
= 'U': Upper triangle of A is stored;
= 'L': Lower triangle of A is stored.
N (input) INTEGER
The order of the matrix A. N >= 0.
A (input/output) DOUBLE PRECISION array, dimension (LDA,N)
On entry, the symmetric matrix A. If UPLO = 'U', the leading
N-by-N upper triangular part of A contains the upper
triangular part of the matrix A, and the strictly lower
triangular part of A is not referenced. If UPLO = 'L', the
leading N-by-N lower triangular part of A contains the lower
triangular part of the matrix A, and the strictly upper
triangular part of A is not referenced.
On exit, if INFO = 0, the factor U or L from the Cholesky
factorization A = U**T*U or A = L*L**T.
LDA (input) INTEGER
The leading dimension of the array A. LDA >= max(1,N).
INFO (output) INTEGER
= 0: successful exit
< 0: if INFO = -i, the i-th argument had an illegal value
> 0: if INFO = i, the leading minor of order i is not
positive definite, and the factorization could not be
completed.
=====================================================================
Test the input parameters.
Parameter adjustments */
/* Table of constant values */
static integer c__1 = 1;
static integer c_n1 = -1;
static doublereal c_b13 = -1.;
static doublereal c_b14 = 1.;
/* System generated locals */
integer a_dim1, a_offset, i__1, i__2, i__3, i__4;
/* Local variables */
static integer j;
extern /* Subroutine */ HYPRE_Int dgemm_(char *, char *, integer *, integer *,
integer *, doublereal *, doublereal *, integer *, doublereal *,
integer *, doublereal *, doublereal *, integer *);
extern logical lsame_(char *, char *);
extern /* Subroutine */ HYPRE_Int dtrsm_(char *, char *, char *, char *,
integer *, integer *, doublereal *, doublereal *, integer *,
doublereal *, integer *);
static logical upper;
extern /* Subroutine */ HYPRE_Int dsyrk_(char *, char *, integer *, integer *,
doublereal *, doublereal *, integer *, doublereal *, doublereal *,
integer *), dpotf2_(char *, integer *,
doublereal *, integer *, integer *);
static integer jb, nb;
extern /* Subroutine */ HYPRE_Int xerbla_(char *, integer *);
extern integer ilaenv_(integer *, char *, char *, integer *, integer *,
integer *, integer *, ftnlen, ftnlen);
#define a_ref(a_1,a_2) a[(a_2)*a_dim1 + a_1]
a_dim1 = *lda;
a_offset = 1 + a_dim1 * 1;
a -= a_offset;
/* Function Body */
*info = 0;
upper = lsame_(uplo, "U");
if (! upper && ! lsame_(uplo, "L")) {
*info = -1;
} else if (*n < 0) {
*info = -2;
} else if (*lda < max(1,*n)) {
*info = -4;
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("DPOTRF", &i__1);
return 0;
}
/* Quick return if possible */
if (*n == 0) {
return 0;
}
/* Determine the block size for this environment. */
nb = ilaenv_(&c__1, "DPOTRF", uplo, n, &c_n1, &c_n1, &c_n1, (ftnlen)6, (
ftnlen)1);
if (nb <= 1 || nb >= *n) {
/* Use unblocked code. */
dpotf2_(uplo, n, &a[a_offset], lda, info);
} else {
/* Use blocked code. */
if (upper) {
/* Compute the Cholesky factorization A = U'*U. */
i__1 = *n;
i__2 = nb;
for (j = 1; i__2 < 0 ? j >= i__1 : j <= i__1; j += i__2) {
/* Update and factorize the current diagonal block and test
for non-positive-definiteness.
Computing MIN */
i__3 = nb, i__4 = *n - j + 1;
jb = min(i__3,i__4);
i__3 = j - 1;
dsyrk_("Upper", "Transpose", &jb, &i__3, &c_b13, &a_ref(1, j),
lda, &c_b14, &a_ref(j, j), lda)
;
dpotf2_("Upper", &jb, &a_ref(j, j), lda, info);
if (*info != 0) {
goto L30;
}
if (j + jb <= *n) {
/* Compute the current block row. */
i__3 = *n - j - jb + 1;
i__4 = j - 1;
dgemm_("Transpose", "No transpose", &jb, &i__3, &i__4, &
c_b13, &a_ref(1, j), lda, &a_ref(1, j + jb), lda,
&c_b14, &a_ref(j, j + jb), lda);
i__3 = *n - j - jb + 1;
dtrsm_("Left", "Upper", "Transpose", "Non-unit", &jb, &
i__3, &c_b14, &a_ref(j, j), lda, &a_ref(j, j + jb)
, lda)
;
}
/* L10: */
}
} else {
/* Compute the Cholesky factorization A = L*L'. */
i__2 = *n;
i__1 = nb;
for (j = 1; i__1 < 0 ? j >= i__2 : j <= i__2; j += i__1) {
/* Update and factorize the current diagonal block and test
for non-positive-definiteness.
Computing MIN */
i__3 = nb, i__4 = *n - j + 1;
jb = min(i__3,i__4);
i__3 = j - 1;
dsyrk_("Lower", "No transpose", &jb, &i__3, &c_b13, &a_ref(j,
1), lda, &c_b14, &a_ref(j, j), lda);
dpotf2_("Lower", &jb, &a_ref(j, j), lda, info);
if (*info != 0) {
goto L30;
}
if (j + jb <= *n) {
/* Compute the current block column. */
i__3 = *n - j - jb + 1;
i__4 = j - 1;
dgemm_("No transpose", "Transpose", &i__3, &jb, &i__4, &
c_b13, &a_ref(j + jb, 1), lda, &a_ref(j, 1), lda,
&c_b14, &a_ref(j + jb, j), lda);
i__3 = *n - j - jb + 1;
dtrsm_("Right", "Lower", "Transpose", "Non-unit", &i__3, &
jb, &c_b14, &a_ref(j, j), lda, &a_ref(j + jb, j),
lda);
}
/* L20: */
}
}
}
goto L40;
L30:
*info = *info + j - 1;
L40:
return 0;
/* End of DPOTRF */
} /* dpotrf_ */
/* 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 dpbtrf_(char *uplo, integer *n, integer *kd, doublereal *
ab, integer *ldab, integer *info)
{
/* -- LAPACK routine (version 3.0) --
Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
Courant Institute, Argonne National Lab, and Rice University
March 31, 1993
Purpose
=======
DPBTRF computes the Cholesky factorization of a real symmetric
positive definite band matrix A.
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.
Arguments
=========
UPLO (input) CHARACTER*1
= 'U': Upper triangle of A is stored;
= 'L': Lower triangle of A is stored.
N (input) INTEGER
The order of the matrix A. N >= 0.
KD (input) INTEGER
The number of superdiagonals of the matrix A if UPLO = 'U',
or the number of subdiagonals if UPLO = 'L'. KD >= 0.
AB (input/output) DOUBLE PRECISION array, dimension (LDAB,N)
On entry, the upper or lower triangle of the symmetric band
matrix A, stored in the first KD+1 rows of the array. The
j-th column of A is stored in the j-th column of the array AB
as follows:
if UPLO = 'U', AB(kd+1+i-j,j) = A(i,j) for max(1,j-kd)<=i<=j;
if UPLO = 'L', AB(1+i-j,j) = A(i,j) for j<=i<=min(n,j+kd).
On exit, if INFO = 0, the triangular factor U or L from the
Cholesky factorization A = U**T*U or A = L*L**T of the band
matrix A, in the same storage format as A.
LDAB (input) INTEGER
The leading dimension of the array AB. LDAB >= KD+1.
INFO (output) INTEGER
= 0: successful exit
< 0: if INFO = -i, the i-th argument had an illegal value
> 0: if INFO = i, the leading minor of order i is not
positive definite, and the factorization could not be
completed.
Further Details
===============
The band storage scheme is illustrated by the following example, when
N = 6, KD = 2, and UPLO = 'U':
On entry: On exit:
* * a13 a24 a35 a46 * * u13 u24 u35 u46
* a12 a23 a34 a45 a56 * u12 u23 u34 u45 u56
a11 a22 a33 a44 a55 a66 u11 u22 u33 u44 u55 u66
Similarly, if UPLO = 'L' the format of A is as follows:
On entry: On exit:
a11 a22 a33 a44 a55 a66 l11 l22 l33 l44 l55 l66
a21 a32 a43 a54 a65 * l21 l32 l43 l54 l65 *
a31 a42 a53 a64 * * l31 l42 l53 l64 * *
Array elements marked * are not used by the routine.
Contributed by
Peter Mayes and Giuseppe Radicati, IBM ECSEC, Rome, March 23, 1989
=====================================================================
Test the input parameters.
Parameter adjustments */
/* Table of constant values */
static integer c__1 = 1;
static integer c_n1 = -1;
static doublereal c_b18 = 1.;
static doublereal c_b21 = -1.;
static integer c__33 = 33;
/* System generated locals */
integer ab_dim1, ab_offset, i__1, i__2, i__3, i__4;
/* Local variables */
static doublereal work[1056] /* was [33][32] */;
static integer i__, j;
extern /* Subroutine */ int dgemm_(char *, char *, integer *, integer *,
integer *, doublereal *, doublereal *, integer *, doublereal *,
integer *, doublereal *, doublereal *, integer *);
extern logical lsame_(char *, char *);
extern /* Subroutine */ int dtrsm_(char *, char *, char *, char *,
integer *, integer *, doublereal *, doublereal *, integer *,
doublereal *, integer *);
static integer i2, i3;
extern /* Subroutine */ int dsyrk_(char *, char *, integer *, integer *,
doublereal *, doublereal *, integer *, doublereal *, doublereal *,
integer *), dpbtf2_(char *, integer *, integer *,
doublereal *, integer *, integer *), dpotf2_(char *,
integer *, doublereal *, integer *, integer *);
static integer ib, nb, ii, jj;
extern /* Subroutine */ int xerbla_(char *, integer *);
extern integer ilaenv_(integer *, char *, char *, integer *, integer *,
integer *, integer *, ftnlen, ftnlen);
#define work_ref(a_1,a_2) work[(a_2)*33 + a_1 - 34]
#define ab_ref(a_1,a_2) ab[(a_2)*ab_dim1 + a_1]
ab_dim1 = *ldab;
ab_offset = 1 + ab_dim1 * 1;
ab -= ab_offset;
/* Function Body */
*info = 0;
if (! lsame_(uplo, "U") && ! lsame_(uplo, "L")) {
*info = -1;
} else if (*n < 0) {
*info = -2;
} else if (*kd < 0) {
*info = -3;
} else if (*ldab < *kd + 1) {
*info = -5;
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("DPBTRF", &i__1);
return 0;
}
/* Quick return if possible */
if (*n == 0) {
return 0;
}
/* Determine the block size for this environment */
nb = ilaenv_(&c__1, "DPBTRF", uplo, n, kd, &c_n1, &c_n1, (ftnlen)6, (
ftnlen)1);
/* The block size must not exceed the semi-bandwidth KD, and must not
exceed the limit set by the size of the local array WORK. */
nb = min(nb,32);
if (nb <= 1 || nb > *kd) {
/* Use unblocked code */
dpbtf2_(uplo, n, kd, &ab[ab_offset], ldab, info);
} else {
/* Use blocked code */
if (lsame_(uplo, "U")) {
/* Compute the Cholesky factorization of a symmetric band
matrix, given the upper triangle of the matrix in band
storage.
Zero the upper triangle of the work array. */
i__1 = nb;
for (j = 1; j <= i__1; ++j) {
i__2 = j - 1;
for (i__ = 1; i__ <= i__2; ++i__) {
work_ref(i__, j) = 0.;
/* L10: */
}
/* L20: */
}
/* Process the band matrix one diagonal block at a time. */
i__1 = *n;
i__2 = nb;
for (i__ = 1; i__2 < 0 ? i__ >= i__1 : i__ <= i__1; i__ += i__2) {
/* Computing MIN */
i__3 = nb, i__4 = *n - i__ + 1;
ib = min(i__3,i__4);
/* Factorize the diagonal block */
i__3 = *ldab - 1;
dpotf2_(uplo, &ib, &ab_ref(*kd + 1, i__), &i__3, &ii);
if (ii != 0) {
*info = i__ + ii - 1;
goto L150;
}
if (i__ + ib <= *n) {
/* Update the relevant part of the trailing submatrix.
If A11 denotes the diagonal block which has just been
factorized, then we need to update the remaining
blocks in the diagram:
A11 A12 A13
A22 A23
A33
The numbers of rows and columns in the partitioning
are IB, I2, I3 respectively. The blocks A12, A22 and
A23 are empty if IB = KD. The upper triangle of A13
lies outside the band.
Computing MIN */
i__3 = *kd - ib, i__4 = *n - i__ - ib + 1;
i2 = min(i__3,i__4);
/* Computing MIN */
i__3 = ib, i__4 = *n - i__ - *kd + 1;
i3 = min(i__3,i__4);
if (i2 > 0) {
/* Update A12 */
i__3 = *ldab - 1;
i__4 = *ldab - 1;
dtrsm_("Left", "Upper", "Transpose", "Non-unit", &ib,
&i2, &c_b18, &ab_ref(*kd + 1, i__), &i__3, &
ab_ref(*kd + 1 - ib, i__ + ib), &i__4);
/* Update A22 */
i__3 = *ldab - 1;
i__4 = *ldab - 1;
dsyrk_("Upper", "Transpose", &i2, &ib, &c_b21, &
ab_ref(*kd + 1 - ib, i__ + ib), &i__3, &c_b18,
&ab_ref(*kd + 1, i__ + ib), &i__4);
}
if (i3 > 0) {
/* Copy the lower triangle of A13 into the work array. */
i__3 = i3;
for (jj = 1; jj <= i__3; ++jj) {
i__4 = ib;
for (ii = jj; ii <= i__4; ++ii) {
work_ref(ii, jj) = ab_ref(ii - jj + 1, jj +
i__ + *kd - 1);
/* L30: */
}
/* L40: */
}
/* Update A13 (in the work array). */
i__3 = *ldab - 1;
dtrsm_("Left", "Upper", "Transpose", "Non-unit", &ib,
&i3, &c_b18, &ab_ref(*kd + 1, i__), &i__3,
work, &c__33);
/* Update A23 */
if (i2 > 0) {
i__3 = *ldab - 1;
i__4 = *ldab - 1;
dgemm_("Transpose", "No Transpose", &i2, &i3, &ib,
&c_b21, &ab_ref(*kd + 1 - ib, i__ + ib),
&i__3, work, &c__33, &c_b18, &ab_ref(ib +
1, i__ + *kd), &i__4);
}
/* Update A33 */
i__3 = *ldab - 1;
dsyrk_("Upper", "Transpose", &i3, &ib, &c_b21, work, &
c__33, &c_b18, &ab_ref(*kd + 1, i__ + *kd), &
i__3);
/* Copy the lower triangle of A13 back into place. */
i__3 = i3;
for (jj = 1; jj <= i__3; ++jj) {
i__4 = ib;
for (ii = jj; ii <= i__4; ++ii) {
ab_ref(ii - jj + 1, jj + i__ + *kd - 1) =
work_ref(ii, jj);
/* L50: */
}
/* L60: */
}
}
}
/* L70: */
}
} else {
/* Compute the Cholesky factorization of a symmetric band
matrix, given the lower triangle of the matrix in band
storage.
Zero the lower triangle of the work array. */
i__2 = nb;
for (j = 1; j <= i__2; ++j) {
i__1 = nb;
for (i__ = j + 1; i__ <= i__1; ++i__) {
work_ref(i__, j) = 0.;
/* L80: */
}
/* L90: */
}
/* Process the band matrix one diagonal block at a time. */
i__2 = *n;
i__1 = nb;
for (i__ = 1; i__1 < 0 ? i__ >= i__2 : i__ <= i__2; i__ += i__1) {
/* Computing MIN */
i__3 = nb, i__4 = *n - i__ + 1;
ib = min(i__3,i__4);
/* Factorize the diagonal block */
i__3 = *ldab - 1;
dpotf2_(uplo, &ib, &ab_ref(1, i__), &i__3, &ii);
if (ii != 0) {
*info = i__ + ii - 1;
goto L150;
}
if (i__ + ib <= *n) {
/* Update the relevant part of the trailing submatrix.
If A11 denotes the diagonal block which has just been
factorized, then we need to update the remaining
blocks in the diagram:
A11
A21 A22
A31 A32 A33
The numbers of rows and columns in the partitioning
are IB, I2, I3 respectively. The blocks A21, A22 and
A32 are empty if IB = KD. The lower triangle of A31
lies outside the band.
Computing MIN */
i__3 = *kd - ib, i__4 = *n - i__ - ib + 1;
i2 = min(i__3,i__4);
/* Computing MIN */
i__3 = ib, i__4 = *n - i__ - *kd + 1;
i3 = min(i__3,i__4);
if (i2 > 0) {
/* Update A21 */
i__3 = *ldab - 1;
i__4 = *ldab - 1;
dtrsm_("Right", "Lower", "Transpose", "Non-unit", &i2,
&ib, &c_b18, &ab_ref(1, i__), &i__3, &ab_ref(
ib + 1, i__), &i__4);
/* Update A22 */
i__3 = *ldab - 1;
i__4 = *ldab - 1;
dsyrk_("Lower", "No Transpose", &i2, &ib, &c_b21, &
ab_ref(ib + 1, i__), &i__3, &c_b18, &ab_ref(1,
i__ + ib), &i__4);
}
if (i3 > 0) {
/* Copy the upper triangle of A31 into the work array. */
i__3 = ib;
for (jj = 1; jj <= i__3; ++jj) {
i__4 = min(jj,i3);
for (ii = 1; ii <= i__4; ++ii) {
work_ref(ii, jj) = ab_ref(*kd + 1 - jj + ii,
jj + i__ - 1);
/* L100: */
}
/* L110: */
}
/* Update A31 (in the work array). */
i__3 = *ldab - 1;
dtrsm_("Right", "Lower", "Transpose", "Non-unit", &i3,
&ib, &c_b18, &ab_ref(1, i__), &i__3, work, &
c__33);
/* Update A32 */
if (i2 > 0) {
i__3 = *ldab - 1;
i__4 = *ldab - 1;
dgemm_("No transpose", "Transpose", &i3, &i2, &ib,
&c_b21, work, &c__33, &ab_ref(ib + 1,
i__), &i__3, &c_b18, &ab_ref(*kd + 1 - ib,
i__ + ib), &i__4);
}
/* Update A33 */
i__3 = *ldab - 1;
dsyrk_("Lower", "No Transpose", &i3, &ib, &c_b21,
work, &c__33, &c_b18, &ab_ref(1, i__ + *kd), &
i__3);
/* Copy the upper triangle of A31 back into place. */
i__3 = ib;
for (jj = 1; jj <= i__3; ++jj) {
i__4 = min(jj,i3);
for (ii = 1; ii <= i__4; ++ii) {
ab_ref(*kd + 1 - jj + ii, jj + i__ - 1) =
work_ref(ii, jj);
/* L120: */
}
/* L130: */
}
}
}
/* L140: */
}
}
}
return 0;
L150:
return 0;
/* End of DPBTRF */
} /* dpbtrf_ */
/* Subroutine */ int dpbtrf_(char *uplo, integer *n, integer *kd, doublereal *
ab, integer *ldab, integer *info)
{
/* System generated locals */
integer ab_dim1, ab_offset, i__1, i__2, i__3, i__4;
/* Local variables */
integer i__, j, i2, i3, ib, nb, ii, jj;
doublereal work[1056] /* was [33][32] */;
/* -- LAPACK routine (version 3.2) -- */
/* November 2006 */
/* Purpose */
/* ======= */
/* DPBTRF computes the Cholesky factorization of a real symmetric */
/* positive definite band matrix A. */
/* 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. */
/* Arguments */
/* ========= */
/* UPLO (input) CHARACTER*1 */
/* = 'U': Upper triangle of A is stored; */
/* = 'L': Lower triangle of A is stored. */
/* N (input) INTEGER */
/* The order of the matrix A. N >= 0. */
/* KD (input) INTEGER */
/* The number of superdiagonals of the matrix A if UPLO = 'U', */
/* or the number of subdiagonals if UPLO = 'L'. KD >= 0. */
/* AB (input/output) DOUBLE PRECISION array, dimension (LDAB,N) */
/* On entry, the upper or lower triangle of the symmetric band */
/* matrix A, stored in the first KD+1 rows of the array. The */
/* j-th column of A is stored in the j-th column of the array AB */
/* as follows: */
/* if UPLO = 'U', AB(kd+1+i-j,j) = A(i,j) for max(1,j-kd)<=i<=j; */
/* if UPLO = 'L', AB(1+i-j,j) = A(i,j) for j<=i<=min(n,j+kd). */
/* On exit, if INFO = 0, the triangular factor U or L from the */
/* Cholesky factorization A = U**T*U or A = L*L**T of the band */
/* matrix A, in the same storage format as A. */
/* LDAB (input) INTEGER */
/* The leading dimension of the array AB. LDAB >= KD+1. */
/* INFO (output) INTEGER */
/* = 0: successful exit */
/* < 0: if INFO = -i, the i-th argument had an illegal value */
/* > 0: if INFO = i, the leading minor of order i is not */
/* positive definite, and the factorization could not be */
/* completed. */
/* Further Details */
/* =============== */
/* The band storage scheme is illustrated by the following example, when */
/* N = 6, KD = 2, and UPLO = 'U': */
/* On entry: On exit: */
/* * * a13 a24 a35 a46 * * u13 u24 u35 u46 */
/* * a12 a23 a34 a45 a56 * u12 u23 u34 u45 u56 */
/* a11 a22 a33 a44 a55 a66 u11 u22 u33 u44 u55 u66 */
/* Similarly, if UPLO = 'L' the format of A is as follows: */
/* On entry: On exit: */
/* a11 a22 a33 a44 a55 a66 l11 l22 l33 l44 l55 l66 */
/* a21 a32 a43 a54 a65 * l21 l32 l43 l54 l65 * */
/* a31 a42 a53 a64 * * l31 l42 l53 l64 * * */
/* Array elements marked * are not used by the routine. */
/* Contributed by */
/* Peter Mayes and Giuseppe Radicati, IBM ECSEC, Rome, March 23, 1989 */
/* ===================================================================== */
/* Test the input parameters. */
/* Parameter adjustments */
ab_dim1 = *ldab;
ab_offset = 1 + ab_dim1;
ab -= ab_offset;
/* Function Body */
*info = 0;
if (! lsame_(uplo, "U") && ! lsame_(uplo, "L")) {
*info = -1;
} else if (*n < 0) {
*info = -2;
} else if (*kd < 0) {
*info = -3;
} else if (*ldab < *kd + 1) {
*info = -5;
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("DPBTRF", &i__1);
return 0;
}
/* Quick return if possible */
if (*n == 0) {
return 0;
}
/* Determine the block size for this environment */
nb = ilaenv_(&c__1, "DPBTRF", uplo, n, kd, &c_n1, &c_n1);
/* The block size must not exceed the semi-bandwidth KD, and must not */
/* exceed the limit set by the size of the local array WORK. */
nb = min(nb,32);
if (nb <= 1 || nb > *kd) {
/* Use unblocked code */
dpbtf2_(uplo, n, kd, &ab[ab_offset], ldab, info);
} else {
/* Use blocked code */
if (lsame_(uplo, "U")) {
/* Compute the Cholesky factorization of a symmetric band */
/* matrix, given the upper triangle of the matrix in band */
/* storage. */
/* Zero the upper triangle of the work array. */
i__1 = nb;
for (j = 1; j <= i__1; ++j) {
i__2 = j - 1;
for (i__ = 1; i__ <= i__2; ++i__) {
work[i__ + j * 33 - 34] = 0.;
}
}
/* Process the band matrix one diagonal block at a time. */
i__1 = *n;
i__2 = nb;
for (i__ = 1; i__2 < 0 ? i__ >= i__1 : i__ <= i__1; i__ += i__2) {
/* Computing MIN */
i__3 = nb, i__4 = *n - i__ + 1;
ib = min(i__3,i__4);
/* Factorize the diagonal block */
i__3 = *ldab - 1;
dpotf2_(uplo, &ib, &ab[*kd + 1 + i__ * ab_dim1], &i__3, &ii);
if (ii != 0) {
*info = i__ + ii - 1;
goto L150;
}
if (i__ + ib <= *n) {
/* Update the relevant part of the trailing submatrix. */
/* If A11 denotes the diagonal block which has just been */
/* factorized, then we need to update the remaining */
/* blocks in the diagram: */
/* A11 A12 A13 */
/* A22 A23 */
/* A33 */
/* The numbers of rows and columns in the partitioning */
/* are IB, I2, I3 respectively. The blocks A12, A22 and */
/* A23 are empty if IB = KD. The upper triangle of A13 */
/* lies outside the band. */
/* Computing MIN */
i__3 = *kd - ib, i__4 = *n - i__ - ib + 1;
i2 = min(i__3,i__4);
/* Computing MIN */
i__3 = ib, i__4 = *n - i__ - *kd + 1;
i3 = min(i__3,i__4);
if (i2 > 0) {
/* Update A12 */
i__3 = *ldab - 1;
i__4 = *ldab - 1;
dtrsm_("Left", "Upper", "Transpose", "Non-unit", &ib,
&i2, &c_b18, &ab[*kd + 1 + i__ * ab_dim1], &
i__3, &ab[*kd + 1 - ib + (i__ + ib) * ab_dim1]
, &i__4);
/* Update A22 */
i__3 = *ldab - 1;
i__4 = *ldab - 1;
dsyrk_("Upper", "Transpose", &i2, &ib, &c_b21, &ab[*
kd + 1 - ib + (i__ + ib) * ab_dim1], &i__3, &
c_b18, &ab[*kd + 1 + (i__ + ib) * ab_dim1], &
i__4);
}
if (i3 > 0) {
/* Copy the lower triangle of A13 into the work array. */
i__3 = i3;
for (jj = 1; jj <= i__3; ++jj) {
i__4 = ib;
for (ii = jj; ii <= i__4; ++ii) {
work[ii + jj * 33 - 34] = ab[ii - jj + 1 + (
jj + i__ + *kd - 1) * ab_dim1];
}
}
/* Update A13 (in the work array). */
i__3 = *ldab - 1;
dtrsm_("Left", "Upper", "Transpose", "Non-unit", &ib,
&i3, &c_b18, &ab[*kd + 1 + i__ * ab_dim1], &
i__3, work, &c__33);
/* Update A23 */
if (i2 > 0) {
i__3 = *ldab - 1;
i__4 = *ldab - 1;
dgemm_("Transpose", "No Transpose", &i2, &i3, &ib,
&c_b21, &ab[*kd + 1 - ib + (i__ + ib) *
ab_dim1], &i__3, work, &c__33, &c_b18, &
ab[ib + 1 + (i__ + *kd) * ab_dim1], &i__4);
}
/* Update A33 */
i__3 = *ldab - 1;
dsyrk_("Upper", "Transpose", &i3, &ib, &c_b21, work, &
c__33, &c_b18, &ab[*kd + 1 + (i__ + *kd) *
ab_dim1], &i__3);
/* Copy the lower triangle of A13 back into place. */
i__3 = i3;
for (jj = 1; jj <= i__3; ++jj) {
i__4 = ib;
for (ii = jj; ii <= i__4; ++ii) {
ab[ii - jj + 1 + (jj + i__ + *kd - 1) *
ab_dim1] = work[ii + jj * 33 - 34];
}
}
}
}
}
} else {
/* Compute the Cholesky factorization of a symmetric band */
/* matrix, given the lower triangle of the matrix in band */
/* storage. */
/* Zero the lower triangle of the work array. */
i__2 = nb;
for (j = 1; j <= i__2; ++j) {
i__1 = nb;
for (i__ = j + 1; i__ <= i__1; ++i__) {
work[i__ + j * 33 - 34] = 0.;
}
}
/* Process the band matrix one diagonal block at a time. */
i__2 = *n;
i__1 = nb;
for (i__ = 1; i__1 < 0 ? i__ >= i__2 : i__ <= i__2; i__ += i__1) {
/* Computing MIN */
i__3 = nb, i__4 = *n - i__ + 1;
ib = min(i__3,i__4);
/* Factorize the diagonal block */
i__3 = *ldab - 1;
dpotf2_(uplo, &ib, &ab[i__ * ab_dim1 + 1], &i__3, &ii);
if (ii != 0) {
*info = i__ + ii - 1;
goto L150;
}
if (i__ + ib <= *n) {
/* Update the relevant part of the trailing submatrix. */
/* If A11 denotes the diagonal block which has just been */
/* factorized, then we need to update the remaining */
/* blocks in the diagram: */
/* A11 */
/* A21 A22 */
/* A31 A32 A33 */
/* The numbers of rows and columns in the partitioning */
/* are IB, I2, I3 respectively. The blocks A21, A22 and */
/* A32 are empty if IB = KD. The lower triangle of A31 */
/* lies outside the band. */
/* Computing MIN */
i__3 = *kd - ib, i__4 = *n - i__ - ib + 1;
i2 = min(i__3,i__4);
/* Computing MIN */
i__3 = ib, i__4 = *n - i__ - *kd + 1;
i3 = min(i__3,i__4);
if (i2 > 0) {
/* Update A21 */
i__3 = *ldab - 1;
i__4 = *ldab - 1;
dtrsm_("Right", "Lower", "Transpose", "Non-unit", &i2,
&ib, &c_b18, &ab[i__ * ab_dim1 + 1], &i__3, &
ab[ib + 1 + i__ * ab_dim1], &i__4);
/* Update A22 */
i__3 = *ldab - 1;
i__4 = *ldab - 1;
dsyrk_("Lower", "No Transpose", &i2, &ib, &c_b21, &ab[
ib + 1 + i__ * ab_dim1], &i__3, &c_b18, &ab[(
i__ + ib) * ab_dim1 + 1], &i__4);
}
if (i3 > 0) {
/* Copy the upper triangle of A31 into the work array. */
i__3 = ib;
for (jj = 1; jj <= i__3; ++jj) {
i__4 = min(jj,i3);
for (ii = 1; ii <= i__4; ++ii) {
work[ii + jj * 33 - 34] = ab[*kd + 1 - jj +
ii + (jj + i__ - 1) * ab_dim1];
}
}
/* Update A31 (in the work array). */
i__3 = *ldab - 1;
dtrsm_("Right", "Lower", "Transpose", "Non-unit", &i3,
&ib, &c_b18, &ab[i__ * ab_dim1 + 1], &i__3,
work, &c__33);
/* Update A32 */
if (i2 > 0) {
i__3 = *ldab - 1;
i__4 = *ldab - 1;
dgemm_("No transpose", "Transpose", &i3, &i2, &ib,
&c_b21, work, &c__33, &ab[ib + 1 + i__ *
ab_dim1], &i__3, &c_b18, &ab[*kd + 1 - ib
+ (i__ + ib) * ab_dim1], &i__4);
}
/* Update A33 */
i__3 = *ldab - 1;
dsyrk_("Lower", "No Transpose", &i3, &ib, &c_b21,
work, &c__33, &c_b18, &ab[(i__ + *kd) *
ab_dim1 + 1], &i__3);
/* Copy the upper triangle of A31 back into place. */
i__3 = ib;
for (jj = 1; jj <= i__3; ++jj) {
i__4 = min(jj,i3);
for (ii = 1; ii <= i__4; ++ii) {
ab[*kd + 1 - jj + ii + (jj + i__ - 1) *
ab_dim1] = work[ii + jj * 33 - 34];
}
}
}
}
}
}
}
return 0;
L150:
return 0;
/* End of DPBTRF */
} /* dpbtrf_ */
/* Subroutine */ void qpbtrf_(char *uplo, int *n, int *kd, LONG DOUBLE *
#endif
ab, int *ldab, int *info)
{
/* -- LAPACK routine (version 2.0) --
Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
Courant Institute, Argonne National Lab, and Rice University
March 31, 1993
Purpose
=======
DPBTRF computes the Cholesky factorization of a real symmetric
positive definite band matrix A.
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.
Arguments
=========
UPLO (input) CHARACTER*1
= 'U': Upper triangle of A is stored;
= 'L': Lower triangle of A is stored.
N (input) INTEGER
The order of the matrix A. N >= 0.
KD (input) INTEGER
The number of superdiagonals of the matrix A if UPLO = 'U',
or the number of subdiagonals if UPLO = 'L'. KD >= 0.
AB (input/output) LONG DOUBLE PRECISION array, dimension (LDAB,N)
On entry, the upper or lower triangle of the symmetric band
matrix A, stored in the first KD+1 rows of the array. The
j-th column of A is stored in the j-th column of the array AB
as follows:
if UPLO = 'U', AB(kd+1+i-j,j) = A(i,j) for MAX(1,j-kd)<=i<=j;
if UPLO = 'L', AB(1+i-j,j) = A(i,j) for j<=i<=MIN(n,j+kd).
On exit, if INFO = 0, the triangular factor U or L from the
Cholesky factorization A = U**T*U or A = L*L**T of the band
matrix A, in the same storage format as A.
LDAB (input) INTEGER
The leading dimension of the array AB. LDAB >= KD+1.
INFO (output) INTEGER
= 0: successful exit
< 0: if INFO = -i, the i-th argument had an illegal value
> 0: if INFO = i, the leading minor of order i is not
positive definite, and the factorization could not be
completed.
Further Details
===============
The band storage scheme is illustrated by the following example, when
N = 6, KD = 2, and UPLO = 'U':
On entry: On exit:
* * a13 a24 a35 a46 * * u13 u24 u35 u46
* a12 a23 a34 a45 a56 * u12 u23 u34 u45 u56
a11 a22 a33 a44 a55 a66 u11 u22 u33 u44 u55 u66
Similarly, if UPLO = 'L' the format of A is as follows:
On entry: On exit:
a11 a22 a33 a44 a55 a66 l11 l22 l33 l44 l55 l66
a21 a32 a43 a54 a65 * l21 l32 l43 l54 l65 *
a31 a42 a53 a64 * * l31 l42 l53 l64 * *
Array elements marked * are not used by the routine.
Contributed by
Peter Mayes and Giuseppe Radicati, IBM ECSEC, Rome, March 23, 1989
=====================================================================
Test the input parameters.
Parameter adjustments
Function Body */
/* Table of constant values */
static int c__1 = 1;
static int c_n1 = -1;
static LONG DOUBLE c_b18 = 1.;
static LONG DOUBLE c_b21 = -1.;
static int c__33 = 33;
/* System generated locals */
int i__1, i__2, i__3, i__4;
/* Local variables */
static LONG DOUBLE work[1056] /* was [33][32] */;
static int i, j;
#ifdef PETSC_PREFIX_SUFFIX
extern /* Subroutine */ void dgemm_(char *, char *, int *, int *,
#endif
#ifdef Q_C_PREFIX_SUFFIX
extern /* Subroutine */ void qgemm(char *, char *, int *, int *,
#endif
#ifdef Q_NORMAL_PREFIX_SUFFIX
extern /* Subroutine */ void qgemm_(char *, char *, int *, int *,
#endif
int *, LONG DOUBLE *, LONG DOUBLE *, int *, LONG DOUBLE *,
int *, LONG DOUBLE *, LONG DOUBLE *, int *);
extern long int lsame_(char *, char *);
#ifdef PETSC_PREFIX_SUFFIX
extern /* Subroutine */ void dtrsm_(char *, char *, char *, char *,
#endif
#ifdef Q_C_PREFIX_SUFFIX
extern /* Subroutine */ void qtrsm(char *, char *, char *, char *,
#endif
#ifdef Q_NORMAL_PREFIX_SUFFIX
extern /* Subroutine */ void qtrsm_(char *, char *, char *, char *,
#endif
int *, int *, LONG DOUBLE *, LONG DOUBLE *, int *,
LONG DOUBLE *, int *);
static int i2, i3;
#ifdef PETSC_PREFIX_SUFFIX
extern /* Subroutine */ void dsyrk_(char *, char *, int *, int *,
#endif
#ifdef Q_C_PREFIX_SUFFIX
extern /* Subroutine */ void qsyrk(char *, char *, int *, int *,
#endif
#ifdef Q_NORMAL_PREFIX_SUFFIX
extern /* Subroutine */ void qsyrk_(char *, char *, int *, int *,
#endif
LONG DOUBLE *, LONG DOUBLE *, int *, LONG DOUBLE *, LONG DOUBLE *,
#ifdef PETSC_PREFIX_SUFFIX
int *), dpbtf2_(char *, int *, int *,
#endif
#ifdef Q_C_PREFIX_SUFFIX
int *), qpbtf2(char *, int *, int *,
#endif
#ifdef Q_NORMAL_PREFIX_SUFFIX
int *), qpbtf2_(char *, int *, int *,
#endif
#ifdef PETSC_PREFIX_SUFFIX
LONG DOUBLE *, int *, int *), dpotf2_(char *,
#endif
#ifdef Q_C_PREFIX_SUFFIX
LONG DOUBLE *, int *, int *), qpotf2(char *,
#endif
#ifdef Q_NORMAL_PREFIX_SUFFIX
LONG DOUBLE *, int *, int *), qpotf2_(char *,
#endif
int *, LONG DOUBLE *, int *, int *);
static int ib, nb, ii, jj;
extern /* Subroutine */ void xerbla_(char *, int *);
extern int ilaenv_(int *, char *, char *, int *, int *,
int *, int *, long int, long int);
#define WORK(I) work[(I)]
#define WAS(I) was[(I)]
#define AB(I,J) ab[(I)-1 + ((J)-1)* ( *ldab)]
*info = 0;
if (! lsame_(uplo, "U") && ! lsame_(uplo, "L")) {
*info = -1;
} else if (*n < 0) {
*info = -2;
} else if (*kd < 0) {
*info = -3;
} else if (*ldab < *kd + 1) {
*info = -5;
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("DPBTRF", &i__1);
return;
}
/* Quick return if possible */
if (*n == 0) {
return;
}
/* Determine the block size for this environment */
nb = ilaenv_(&c__1, "DPBTRF", uplo, n, kd, &c_n1, &c_n1, 6L, 1L);
/* The block size must not exceed the semi-bandwidth KD, and must not
exceed the limit set by the size of the local array WORK. */
nb = MIN(nb,32);
if (nb <= 1 || nb > *kd) {
/* Use unblocked code */
#ifdef PETSC_PREFIX_SUFFIX
dpbtf2_(uplo, n, kd, &AB(1,1), ldab, info);
#endif
#ifdef Q_C_PREFIX_SUFFIX
qpbtf2(uplo, n, kd, &AB(1,1), ldab, info);
#endif
#ifdef Q_NORMAL_PREFIX_SUFFIX
qpbtf2_(uplo, n, kd, &AB(1,1), ldab, info);
#endif
} else {
/* Use blocked code */
if (lsame_(uplo, "U")) {
/* Compute the Cholesky factorization of a symmetric ban
d
matrix, given the upper triangle of the matrix in ban
d
storage.
Zero the upper triangle of the work array. */
i__1 = nb;
for (j = 1; j <= nb; ++j) {
i__2 = j - 1;
for (i = 1; i <= j-1; ++i) {
WORK(i + j * 33 - 34) = 0.;
/* L10: */
}
/* L20: */
}
/* Process the band matrix one diagonal block at a time.
*/
i__1 = *n;
i__2 = nb;
for (i = 1; nb < 0 ? i >= *n : i <= *n; i += nb) {
/* Computing MIN */
i__3 = nb, i__4 = *n - i + 1;
ib = MIN(i__3,i__4);
/* Factorize the diagonal block */
i__3 = *ldab - 1;
#ifdef PETSC_PREFIX_SUFFIX
dpotf2_(uplo, &ib, &AB(*kd+1,i), &i__3, &ii)
#endif
#ifdef Q_C_PREFIX_SUFFIX
qpotf2(uplo, &ib, &AB(*kd+1,i), &i__3, &ii)
#endif
#ifdef Q_NORMAL_PREFIX_SUFFIX
qpotf2_(uplo, &ib, &AB(*kd+1,i), &i__3, &ii)
#endif
;
if (ii != 0) {
*info = i + ii - 1;
goto L150;
}
if (i + ib <= *n) {
/* Update the relevant part of the trailin
g submatrix.
If A11 denotes the diagonal block which
has just been
factorized, then we need to update the
remaining
blocks in the diagram:
A11 A12 A13
A22 A23
A33
The numbers of rows and columns in the
partitioning
are IB, I2, I3 respectively. The blocks
A12, A22 and
A23 are empty if IB = KD. The upper tri
angle of A13
lies outside the band.
Computing MIN */
i__3 = *kd - ib, i__4 = *n - i - ib + 1;
i2 = MIN(i__3,i__4);
/* Computing MIN */
i__3 = ib, i__4 = *n - i - *kd + 1;
i3 = MIN(i__3,i__4);
if (i2 > 0) {
/* Update A12 */
i__3 = *ldab - 1;
i__4 = *ldab - 1;
#ifdef PETSC_PREFIX_SUFFIX
dtrsm_("Left", "Upper", "Transpose", "Non-unit", &ib,
#endif
#ifdef Q_C_PREFIX_SUFFIX
qtrsm("Left", "Upper", "Transpose", "Non-unit", &ib,
#endif
#ifdef Q_NORMAL_PREFIX_SUFFIX
qtrsm_("Left", "Upper", "Transpose", "Non-unit", &ib,
#endif
&i2, &c_b18, &AB(*kd+1,i), &
i__3, &AB(*kd+1-ib,i+ib),
&i__4);
/* Update A22 */
i__3 = *ldab - 1;
i__4 = *ldab - 1;
#ifdef PETSC_PREFIX_SUFFIX
dsyrk_("Upper", "Transpose", &i2, &ib, &c_b21, &AB(*kd+1-ib,i+ib), &i__3, &
#endif
#ifdef Q_C_PREFIX_SUFFIX
qsyrk("Upper", "Transpose", &i2, &ib, &c_b21, &AB(*kd+1-ib,i+ib), &i__3, &
#endif
#ifdef Q_NORMAL_PREFIX_SUFFIX
qsyrk_("Upper", "Transpose", &i2, &ib, &c_b21, &AB(*kd+1-ib,i+ib), &i__3, &
#endif
c_b18, &AB(*kd+1,i+ib), &
i__4);
}
if (i3 > 0) {
/* Copy the lower triangle of A13 i
nto the work array. */
i__3 = i3;
for (jj = 1; jj <= i3; ++jj) {
i__4 = ib;
for (ii = jj; ii <= ib; ++ii) {
WORK(ii + jj * 33 - 34) = AB(ii-jj+1,jj+i+*kd-1);
/* L30: */
}
/* L40: */
}
/* Update A13 (in the work array).
*/
i__3 = *ldab - 1;
#ifdef PETSC_PREFIX_SUFFIX
dtrsm_("Left", "Upper", "Transpose", "Non-unit", &ib,
#endif
#ifdef Q_C_PREFIX_SUFFIX
qtrsm("Left", "Upper", "Transpose", "Non-unit", &ib,
#endif
#ifdef Q_NORMAL_PREFIX_SUFFIX
qtrsm_("Left", "Upper", "Transpose", "Non-unit", &ib,
#endif
&i3, &c_b18, &AB(*kd+1,i), &
i__3, work, &c__33);
/* Update A23 */
if (i2 > 0) {
i__3 = *ldab - 1;
i__4 = *ldab - 1;
#ifdef PETSC_PREFIX_SUFFIX
dgemm_("Transpose", "No Transpose", &i2, &i3, &ib,
#endif
#ifdef Q_C_PREFIX_SUFFIX
qgemm("Transpose", "No Transpose", &i2, &i3, &ib,
#endif
#ifdef Q_NORMAL_PREFIX_SUFFIX
qgemm_("Transpose", "No Transpose", &i2, &i3, &ib,
#endif
&c_b21, &AB(*kd+1-ib,i+ib), &i__3, work, &c__33, &c_b18, &
AB(ib+1,i+*kd), &i__4);
}
/* Update A33 */
i__3 = *ldab - 1;
#ifdef PETSC_PREFIX_SUFFIX
dsyrk_("Upper", "Transpose", &i3, &ib, &c_b21, work, &
#endif
#ifdef Q_C_PREFIX_SUFFIX
qsyrk("Upper", "Transpose", &i3, &ib, &c_b21, work, &
#endif
#ifdef Q_NORMAL_PREFIX_SUFFIX
qsyrk_("Upper", "Transpose", &i3, &ib, &c_b21, work, &
#endif
c__33, &c_b18, &AB(*kd+1,i+*kd), &i__3);
/* Copy the lower triangle of A13 b
ack into place. */
i__3 = i3;
for (jj = 1; jj <= i3; ++jj) {
i__4 = ib;
for (ii = jj; ii <= ib; ++ii) {
AB(ii-jj+1,jj+i+*kd-1)
= WORK(ii + jj * 33 - 34);
/* L50: */
}
/* L60: */
}
}