CFD/hypre
1
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity
8b68747eca
hypre/lapack/dpotrf.c
falgout e3181f26b1 Added 64 bit feature using HYPRE_Int (see tracker [issue489] for details). 
Changed MPI routines to hypre_MPI routines.
Added hypre_printf, etc. routines.
Added AUTOTEST tests to look for 'int' and 'MPI_' calls.
Added a new approach for the Fortran interface (not implemented everywhere yet).
2010-12-20 19:27:44 +00:00

227 lines
6.5 KiB
C
Raw Blame History

#include "../blas/hypre_blas.h"
#include "hypre_lapack.h"
#include "f2c.h"
/* 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_ */
#undef a_ref
Reference in New Issue View Git Blame Copy Permalink