/* Subroutine */ int spptrf_(char *uplo, integer *n, real *ap, integer *info)
{
/* System generated locals */
integer i__1, i__2;
real r__1;
/* Builtin functions */
double sqrt(doublereal);
/* Local variables */
integer j, jc, jj;
real ajj;
extern doublereal sdot_(integer *, real *, integer *, real *, integer *);
extern /* Subroutine */ int sspr_(char *, integer *, real *, real *,
integer *, real *);
extern logical lsame_(char *, char *);
extern /* Subroutine */ int sscal_(integer *, real *, real *, integer *);
logical upper;
extern /* Subroutine */ int stpsv_(char *, char *, char *, integer *,
real *, real *, integer *), xerbla_(char *
, integer *);
/* -- LAPACK routine (version 3.2) -- */
/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/* November 2006 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* SPPTRF computes the Cholesky factorization of a 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. */
/* 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. */
/* AP (input/output) REAL 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 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. */
/* 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 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 = aji) */
/* a44 */
/* Packed storage of the upper triangle of A: */
/* AP = [ a11, a12, a22, a13, a23, a33, a14, a24, a34, a44 ] */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Executable Statements .. */
/* Test the input parameters. */
/* Parameter adjustments */
--ap;
/* Function Body */
*info = 0;
upper = lsame_(uplo, "U");
if (! upper && ! lsame_(uplo, "L")) {
*info = -1;
} else if (*n < 0) {
*info = -2;
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("SPPTRF", &i__1);
return 0;
}
/* Quick return if possible */
if (*n == 0) {
return 0;
}
if (upper) {
/* Compute the Cholesky factorization A = U'*U. */
jj = 0;
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
jc = jj + 1;
jj += j;
/* Compute elements 1:J-1 of column J. */
if (j > 1) {
i__2 = j - 1;
stpsv_("Upper", "Transpose", "Non-unit", &i__2, &ap[1], &ap[
jc], &c__1);
}
/* Compute U(J,J) and test for non-positive-definiteness. */
i__2 = j - 1;
ajj = ap[jj] - sdot_(&i__2, &ap[jc], &c__1, &ap[jc], &c__1);
if (ajj <= 0.f) {
ap[jj] = ajj;
goto L30;
}
ap[jj] = sqrt(ajj);
/* L10: */
}
} else {
/* Compute the Cholesky factorization A = L*L'. */
jj = 1;
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
/* Compute L(J,J) and test for non-positive-definiteness. */
ajj = ap[jj];
if (ajj <= 0.f) {
ap[jj] = ajj;
goto L30;
}
ajj = sqrt(ajj);
ap[jj] = ajj;
/* Compute elements J+1:N of column J and update the trailing */
/* submatrix. */
if (j < *n) {
i__2 = *n - j;
r__1 = 1.f / ajj;
sscal_(&i__2, &r__1, &ap[jj + 1], &c__1);
i__2 = *n - j;
sspr_("Lower", &i__2, &c_b16, &ap[jj + 1], &c__1, &ap[jj + *n
- j + 1]);
jj = jj + *n - j + 1;
}
/* L20: */
}
}
goto L40;
L30:
*info = j;
L40:
return 0;
/* End of SPPTRF */
} /* spptrf_ */
/* Subroutine */ int spptri_(char *uplo, integer *n, real *ap, integer *info)
{
/* -- LAPACK routine (version 2.0) --
Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
Courant Institute, Argonne National Lab, and Rice University
March 31, 1993
Purpose
=======
SPPTRI computes the inverse of a real symmetric positive definite
matrix A using the Cholesky factorization A = U**T*U or A = L*L**T
computed by SPPTRF.
Arguments
=========
UPLO (input) CHARACTER*1
= 'U': Upper triangular factor is stored in AP;
= 'L': Lower triangular factor is stored in AP.
N (input) INTEGER
The order of the matrix A. N >= 0.
AP (input/output) REAL array, dimension (N*(N+1)/2)
On entry, the triangular factor U or L from the Cholesky
factorization A = U**T*U or A = L*L**T, packed columnwise as
a linear array. The j-th column of U or L is stored in the
array AP as follows:
if UPLO = 'U', AP(i + (j-1)*j/2) = U(i,j) for 1<=i<=j;
if UPLO = 'L', AP(i + (j-1)*(2n-j)/2) = L(i,j) for j<=i<=n.
On exit, the upper or lower triangle of the (symmetric)
inverse of A, overwriting the input factor U or L.
INFO (output) INTEGER
= 0: successful exit
< 0: if INFO = -i, the i-th argument had an illegal value
> 0: if INFO = i, the (i,i) element of the factor U or L is
zero, and the inverse could not be computed.
=====================================================================
Test the input parameters.
Parameter adjustments
Function Body */
/* Table of constant values */
static real c_b8 = 1.f;
static integer c__1 = 1;
/* System generated locals */
integer i__1, i__2;
/* Local variables */
extern doublereal sdot_(integer *, real *, integer *, real *, integer *);
extern /* Subroutine */ int sspr_(char *, integer *, real *, real *,
integer *, real *);
static integer j;
extern logical lsame_(char *, char *);
extern /* Subroutine */ int sscal_(integer *, real *, real *, integer *);
static logical upper;
extern /* Subroutine */ int stpmv_(char *, char *, char *, integer *,
real *, real *, integer *);
static integer jc, jj;
extern /* Subroutine */ int xerbla_(char *, integer *), stptri_(
char *, char *, integer *, real *, integer *);
static real ajj;
static integer jjn;
#define AP(I) ap[(I)-1]
*info = 0;
upper = lsame_(uplo, "U");
if (! upper && ! lsame_(uplo, "L")) {
*info = -1;
} else if (*n < 0) {
*info = -2;
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("SPPTRI", &i__1);
return 0;
}
/* Quick return if possible */
if (*n == 0) {
return 0;
}
/* Invert the triangular Cholesky factor U or L. */
stptri_(uplo, "Non-unit", n, &AP(1), info);
if (*info > 0) {
return 0;
}
if (upper) {
/* Compute the product inv(U) * inv(U)'. */
jj = 0;
i__1 = *n;
for (j = 1; j <= *n; ++j) {
jc = jj + 1;
jj += j;
if (j > 1) {
i__2 = j - 1;
sspr_("Upper", &i__2, &c_b8, &AP(jc), &c__1, &AP(1));
}
ajj = AP(jj);
sscal_(&j, &ajj, &AP(jc), &c__1);
/* L10: */
}
} else {
/* Compute the product inv(L)' * inv(L). */
jj = 1;
i__1 = *n;
for (j = 1; j <= *n; ++j) {
jjn = jj + *n - j + 1;
i__2 = *n - j + 1;
AP(jj) = sdot_(&i__2, &AP(jj), &c__1, &AP(jj), &c__1);
if (j < *n) {
i__2 = *n - j;
stpmv_("Lower", "Transpose", "Non-unit", &i__2, &AP(jjn), &AP(
jj + 1), &c__1);
}
jj = jjn;
/* L20: */
}
}
return 0;
/* End of SPPTRI */
} /* spptri_ */
/* Subroutine */
int spptri_(char *uplo, integer *n, real *ap, integer *info)
{
/* System generated locals */
integer i__1, i__2;
/* Local variables */
integer j, jc, jj;
real ajj;
integer jjn;
extern real sdot_(integer *, real *, integer *, real *, integer *);
extern /* Subroutine */
int sspr_(char *, integer *, real *, real *, integer *, real *);
extern logical lsame_(char *, char *);
extern /* Subroutine */
int sscal_(integer *, real *, real *, integer *);
logical upper;
extern /* Subroutine */
int stpmv_(char *, char *, char *, integer *, real *, real *, integer *), xerbla_(char * , integer *), stptri_(char *, char *, integer *, real *, integer *);
/* -- LAPACK computational routine (version 3.4.0) -- */
/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */
/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */
/* November 2011 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Executable Statements .. */
/* Test the input parameters. */
/* Parameter adjustments */
--ap;
/* Function Body */
*info = 0;
upper = lsame_(uplo, "U");
if (! upper && ! lsame_(uplo, "L"))
{
*info = -1;
}
else if (*n < 0)
{
*info = -2;
}
if (*info != 0)
{
i__1 = -(*info);
xerbla_("SPPTRI", &i__1);
return 0;
}
/* Quick return if possible */
if (*n == 0)
{
return 0;
}
/* Invert the triangular Cholesky factor U or L. */
stptri_(uplo, "Non-unit", n, &ap[1], info);
if (*info > 0)
{
return 0;
}
if (upper)
{
/* Compute the product inv(U) * inv(U)**T. */
jj = 0;
i__1 = *n;
for (j = 1;
j <= i__1;
++j)
{
jc = jj + 1;
jj += j;
if (j > 1)
{
i__2 = j - 1;
sspr_("Upper", &i__2, &c_b8, &ap[jc], &c__1, &ap[1]);
}
ajj = ap[jj];
sscal_(&j, &ajj, &ap[jc], &c__1);
/* L10: */
}
}
else
{
/* Compute the product inv(L)**T * inv(L). */
jj = 1;
i__1 = *n;
for (j = 1;
j <= i__1;
++j)
{
jjn = jj + *n - j + 1;
i__2 = *n - j + 1;
ap[jj] = sdot_(&i__2, &ap[jj], &c__1, &ap[jj], &c__1);
if (j < *n)
{
i__2 = *n - j;
stpmv_("Lower", "Transpose", "Non-unit", &i__2, &ap[jjn], &ap[ jj + 1], &c__1);
}
jj = jjn;
/* L20: */
}
}
return 0;
/* End of SPPTRI */
}
