int
f2c_zher(char* uplo, integer* N,
doublereal* alpha,
doublecomplex* X, integer* incX,
doublecomplex* A, integer* lda)
{
zher_(uplo, N, alpha,
X, incX, A, lda);
return 0;
}
PyObject* czher(PyObject *self, PyObject *args)
{
double alpha;
PyArrayObject* x;
PyArrayObject* a;
if (!PyArg_ParseTuple(args, "dOO", &alpha, &x, &a))
return NULL;
int n = PyArray_DIMS(x)[0];
for (int d = 1; d < PyArray_NDIM(x); d++)
n *= PyArray_DIMS(x)[d];
int incx = 1;
int lda = MAX(1, n);
zher_("l", &n, &(alpha),
(void*)COMPLEXP(x), &incx,
(void*)COMPLEXP(a), &lda);
Py_RETURN_NONE;
}
int zpbtf2_(char *uplo, int *n, int *kd,
doublecomplex *ab, int *ldab, int *info)
{
/* System generated locals */
int ab_dim1, ab_offset, i__1, i__2, i__3;
double d__1;
/* Builtin functions */
double sqrt(double);
/* Local variables */
int j, kn;
double ajj;
int kld;
extern int zher_(char *, int *, double *,
doublecomplex *, int *, doublecomplex *, int *);
extern int lsame_(char *, char *);
int upper;
extern int xerbla_(char *, int *), zdscal_(
int *, double *, doublecomplex *, int *), zlacgv_(
int *, doublecomplex *, int *);
/* -- LAPACK routine (version 3.2) -- */
/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/* November 2006 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* ZPBTF2 computes the Cholesky factorization of a complex Hermitian */
/* positive definite band matrix A. */
/* The factorization has the form */
/* A = U' * U , if UPLO = 'U', or */
/* A = L * L', if UPLO = 'L', */
/* where U is an upper triangular matrix, U' is the conjugate transpose */
/* of U, and L is lower triangular. */
/* This is the unblocked version of the algorithm, calling Level 2 BLAS. */
/* Arguments */
/* ========= */
/* UPLO (input) CHARACTER*1 */
/* Specifies whether the upper or lower triangular part of the */
/* Hermitian matrix A is stored: */
/* = 'U': Upper triangular */
/* = 'L': Lower triangular */
/* N (input) INTEGER */
/* The order of the matrix A. N >= 0. */
/* KD (input) INTEGER */
/* The number of super-diagonals of the matrix A if UPLO = 'U', */
/* or the number of sub-diagonals if UPLO = 'L'. KD >= 0. */
/* AB (input/output) COMPLEX*16 array, dimension (LDAB,N) */
/* On entry, the upper or lower triangle of the Hermitian 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'*U or A = L*L' 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 = -k, the k-th argument had an illegal value */
/* > 0: if INFO = k, the leading minor of order k 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. */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Executable Statements .. */
/* Test the input parameters. */
/* Parameter adjustments */
ab_dim1 = *ldab;
ab_offset = 1 + ab_dim1;
ab -= ab_offset;
/* Function Body */
*info = 0;
upper = lsame_(uplo, "U");
if (! upper && ! 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_("ZPBTF2", &i__1);
return 0;
}
/* Quick return if possible */
if (*n == 0) {
return 0;
}
/* Computing MAX */
i__1 = 1, i__2 = *ldab - 1;
kld = MAX(i__1,i__2);
if (upper) {
/* Compute the Cholesky factorization A = U'*U. */
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
/* Compute U(J,J) and test for non-positive-definiteness. */
i__2 = *kd + 1 + j * ab_dim1;
ajj = ab[i__2].r;
if (ajj <= 0.) {
i__2 = *kd + 1 + j * ab_dim1;
ab[i__2].r = ajj, ab[i__2].i = 0.;
goto L30;
}
ajj = sqrt(ajj);
i__2 = *kd + 1 + j * ab_dim1;
ab[i__2].r = ajj, ab[i__2].i = 0.;
/* Compute elements J+1:J+KN of row J and update the */
/* trailing submatrix within the band. */
/* Computing MIN */
i__2 = *kd, i__3 = *n - j;
kn = MIN(i__2,i__3);
if (kn > 0) {
d__1 = 1. / ajj;
zdscal_(&kn, &d__1, &ab[*kd + (j + 1) * ab_dim1], &kld);
zlacgv_(&kn, &ab[*kd + (j + 1) * ab_dim1], &kld);
zher_("Upper", &kn, &c_b8, &ab[*kd + (j + 1) * ab_dim1], &kld,
&ab[*kd + 1 + (j + 1) * ab_dim1], &kld);
zlacgv_(&kn, &ab[*kd + (j + 1) * ab_dim1], &kld);
}
/* L10: */
}
} else {
/* Compute the Cholesky factorization A = L*L'. */
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
/* Compute L(J,J) and test for non-positive-definiteness. */
i__2 = j * ab_dim1 + 1;
ajj = ab[i__2].r;
if (ajj <= 0.) {
i__2 = j * ab_dim1 + 1;
ab[i__2].r = ajj, ab[i__2].i = 0.;
goto L30;
}
ajj = sqrt(ajj);
i__2 = j * ab_dim1 + 1;
ab[i__2].r = ajj, ab[i__2].i = 0.;
/* Compute elements J+1:J+KN of column J and update the */
/* trailing submatrix within the band. */
/* Computing MIN */
i__2 = *kd, i__3 = *n - j;
kn = MIN(i__2,i__3);
if (kn > 0) {
d__1 = 1. / ajj;
zdscal_(&kn, &d__1, &ab[j * ab_dim1 + 2], &c__1);
zher_("Lower", &kn, &c_b8, &ab[j * ab_dim1 + 2], &c__1, &ab[(
j + 1) * ab_dim1 + 1], &kld);
}
/* L20: */
}
}
return 0;
L30:
*info = j;
return 0;
/* End of ZPBTF2 */
} /* zpbtf2_ */
/* Subroutine */ int zpst01_(char *uplo, integer *n, doublecomplex *a,
integer *lda, doublecomplex *afac, integer *ldafac, doublecomplex *
perm, integer *ldperm, integer *piv, doublereal *rwork, doublereal *
resid, integer *rank)
{
/* System generated locals */
integer a_dim1, a_offset, afac_dim1, afac_offset, perm_dim1, perm_offset,
i__1, i__2, i__3, i__4, i__5;
doublereal d__1;
doublecomplex z__1;
/* Local variables */
integer i__, j, k;
doublecomplex tc;
doublereal tr, eps;
doublereal anorm;
/* -- LAPACK test routine (version 3.1) -- */
/* Craig Lucas, University of Manchester / NAG Ltd. */
/* October, 2008 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* ZPST01 reconstructs an Hermitian positive semidefinite matrix A */
/* from its L or U factors and the permutation matrix P and computes */
/* the residual */
/* norm( P*L*L'*P' - A ) / ( N * norm(A) * EPS ) or */
/* norm( P*U'*U*P' - A ) / ( N * norm(A) * EPS ), */
/* where EPS is the machine epsilon, L' is the conjugate transpose of L, */
/* and U' is the conjugate transpose of U. */
/* Arguments */
/* ========== */
/* UPLO (input) CHARACTER*1 */
/* Specifies whether the upper or lower triangular part of the */
/* Hermitian matrix A is stored: */
/* = 'U': Upper triangular */
/* = 'L': Lower triangular */
/* N (input) INTEGER */
/* The number of rows and columns of the matrix A. N >= 0. */
/* A (input) COMPLEX*16 array, dimension (LDA,N) */
/* The original Hermitian matrix A. */
/* LDA (input) INTEGER */
/* The leading dimension of the array A. LDA >= max(1,N) */
/* AFAC (input) COMPLEX*16 array, dimension (LDAFAC,N) */
/* The factor L or U from the L*L' or U'*U */
/* factorization of A. */
/* LDAFAC (input) INTEGER */
/* The leading dimension of the array AFAC. LDAFAC >= max(1,N). */
/* PERM (output) COMPLEX*16 array, dimension (LDPERM,N) */
/* Overwritten with the reconstructed matrix, and then with the */
/* difference P*L*L'*P' - A (or P*U'*U*P' - A) */
/* LDPERM (input) INTEGER */
/* The leading dimension of the array PERM. */
/* LDAPERM >= max(1,N). */
/* PIV (input) INTEGER array, dimension (N) */
/* PIV is such that the nonzero entries are */
/* P( PIV( K ), K ) = 1. */
/* RWORK (workspace) DOUBLE PRECISION array, dimension (N) */
/* RESID (output) DOUBLE PRECISION */
/* If UPLO = 'L', norm(L*L' - A) / ( N * norm(A) * EPS ) */
/* If UPLO = 'U', norm(U'*U - A) / ( N * norm(A) * EPS ) */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Executable Statements .. */
/* Quick exit if N = 0. */
/* Parameter adjustments */
a_dim1 = *lda;
a_offset = 1 + a_dim1;
a -= a_offset;
afac_dim1 = *ldafac;
afac_offset = 1 + afac_dim1;
afac -= afac_offset;
perm_dim1 = *ldperm;
perm_offset = 1 + perm_dim1;
perm -= perm_offset;
--piv;
--rwork;
/* Function Body */
if (*n <= 0) {
*resid = 0.;
return 0;
}
/* Exit with RESID = 1/EPS if ANORM = 0. */
eps = dlamch_("Epsilon");
anorm = zlanhe_("1", uplo, n, &a[a_offset], lda, &rwork[1]);
if (anorm <= 0.) {
*resid = 1. / eps;
return 0;
}
/* Check the imaginary parts of the diagonal elements and return with */
/* an error code if any are nonzero. */
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
if (d_imag(&afac[j + j * afac_dim1]) != 0.) {
*resid = 1. / eps;
return 0;
}
/* L100: */
}
/* Compute the product U'*U, overwriting U. */
if (lsame_(uplo, "U")) {
if (*rank < *n) {
i__1 = *n;
for (j = *rank + 1; j <= i__1; ++j) {
i__2 = j;
for (i__ = *rank + 1; i__ <= i__2; ++i__) {
i__3 = i__ + j * afac_dim1;
afac[i__3].r = 0., afac[i__3].i = 0.;
/* L110: */
}
/* L120: */
}
}
for (k = *n; k >= 1; --k) {
/* Compute the (K,K) element of the result. */
zdotc_(&z__1, &k, &afac[k * afac_dim1 + 1], &c__1, &afac[k *
afac_dim1 + 1], &c__1);
tr = z__1.r;
i__1 = k + k * afac_dim1;
afac[i__1].r = tr, afac[i__1].i = 0.;
/* Compute the rest of column K. */
i__1 = k - 1;
ztrmv_("Upper", "Conjugate", "Non-unit", &i__1, &afac[afac_offset]
, ldafac, &afac[k * afac_dim1 + 1], &c__1);
/* L130: */
}
/* Compute the product L*L', overwriting L. */
} else {
if (*rank < *n) {
i__1 = *n;
for (j = *rank + 1; j <= i__1; ++j) {
i__2 = *n;
for (i__ = j; i__ <= i__2; ++i__) {
i__3 = i__ + j * afac_dim1;
afac[i__3].r = 0., afac[i__3].i = 0.;
/* L140: */
}
/* L150: */
}
}
for (k = *n; k >= 1; --k) {
/* Add a multiple of column K of the factor L to each of */
/* columns K+1 through N. */
if (k + 1 <= *n) {
i__1 = *n - k;
zher_("Lower", &i__1, &c_b20, &afac[k + 1 + k * afac_dim1], &
c__1, &afac[k + 1 + (k + 1) * afac_dim1], ldafac);
}
/* Scale column K by the diagonal element. */
i__1 = k + k * afac_dim1;
tc.r = afac[i__1].r, tc.i = afac[i__1].i;
i__1 = *n - k + 1;
zscal_(&i__1, &tc, &afac[k + k * afac_dim1], &c__1);
/* L160: */
}
}
/* Form P*L*L'*P' or P*U'*U*P' */
if (lsame_(uplo, "U")) {
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
i__2 = *n;
for (i__ = 1; i__ <= i__2; ++i__) {
if (piv[i__] <= piv[j]) {
if (i__ <= j) {
i__3 = piv[i__] + piv[j] * perm_dim1;
i__4 = i__ + j * afac_dim1;
perm[i__3].r = afac[i__4].r, perm[i__3].i = afac[i__4]
.i;
} else {
i__3 = piv[i__] + piv[j] * perm_dim1;
d_cnjg(&z__1, &afac[j + i__ * afac_dim1]);
perm[i__3].r = z__1.r, perm[i__3].i = z__1.i;
}
}
/* L170: */
}
/* L180: */
}
} else {
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
i__2 = *n;
for (i__ = 1; i__ <= i__2; ++i__) {
if (piv[i__] >= piv[j]) {
if (i__ >= j) {
i__3 = piv[i__] + piv[j] * perm_dim1;
i__4 = i__ + j * afac_dim1;
perm[i__3].r = afac[i__4].r, perm[i__3].i = afac[i__4]
.i;
} else {
i__3 = piv[i__] + piv[j] * perm_dim1;
d_cnjg(&z__1, &afac[j + i__ * afac_dim1]);
perm[i__3].r = z__1.r, perm[i__3].i = z__1.i;
}
}
/* L190: */
}
/* L200: */
}
}
/* Compute the difference P*L*L'*P' - A (or P*U'*U*P' - A). */
if (lsame_(uplo, "U")) {
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
i__2 = j - 1;
for (i__ = 1; i__ <= i__2; ++i__) {
i__3 = i__ + j * perm_dim1;
i__4 = i__ + j * perm_dim1;
i__5 = i__ + j * a_dim1;
z__1.r = perm[i__4].r - a[i__5].r, z__1.i = perm[i__4].i - a[
i__5].i;
perm[i__3].r = z__1.r, perm[i__3].i = z__1.i;
/* L210: */
}
i__2 = j + j * perm_dim1;
i__3 = j + j * perm_dim1;
i__4 = j + j * a_dim1;
d__1 = a[i__4].r;
z__1.r = perm[i__3].r - d__1, z__1.i = perm[i__3].i;
perm[i__2].r = z__1.r, perm[i__2].i = z__1.i;
/* L220: */
}
} else {
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
i__2 = j + j * perm_dim1;
i__3 = j + j * perm_dim1;
i__4 = j + j * a_dim1;
d__1 = a[i__4].r;
z__1.r = perm[i__3].r - d__1, z__1.i = perm[i__3].i;
perm[i__2].r = z__1.r, perm[i__2].i = z__1.i;
i__2 = *n;
for (i__ = j + 1; i__ <= i__2; ++i__) {
i__3 = i__ + j * perm_dim1;
i__4 = i__ + j * perm_dim1;
i__5 = i__ + j * a_dim1;
z__1.r = perm[i__4].r - a[i__5].r, z__1.i = perm[i__4].i - a[
i__5].i;
perm[i__3].r = z__1.r, perm[i__3].i = z__1.i;
/* L230: */
}
/* L240: */
}
}
/* Compute norm( P*L*L'P - A ) / ( N * norm(A) * EPS ), or */
/* ( P*U'*U*P' - A )/ ( N * norm(A) * EPS ). */
*resid = zlanhe_("1", uplo, n, &perm[perm_offset], ldafac, &rwork[1]);
*resid = *resid / (doublereal) (*n) / anorm / eps;
return 0;
/* End of ZPST01 */
} /* zpst01_ */
/* Subroutine */ int zpbtf2_(char *uplo, integer *n, integer *kd,
doublecomplex *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
February 29, 1992
Purpose
=======
ZPBTF2 computes the Cholesky factorization of a complex Hermitian
positive definite band matrix A.
The factorization has the form
A = U' * U , if UPLO = 'U', or
A = L * L', if UPLO = 'L',
where U is an upper triangular matrix, U' is the conjugate transpose
of U, and L is lower triangular.
This is the unblocked version of the algorithm, calling Level 2 BLAS.
Arguments
=========
UPLO (input) CHARACTER*1
Specifies whether the upper or lower triangular part of the
Hermitian matrix A is stored:
= 'U': Upper triangular
= 'L': Lower triangular
N (input) INTEGER
The order of the matrix A. N >= 0.
KD (input) INTEGER
The number of super-diagonals of the matrix A if UPLO = 'U',
or the number of sub-diagonals if UPLO = 'L'. KD >= 0.
AB (input/output) COMPLEX*16 array, dimension (LDAB,N)
On entry, the upper or lower triangle of the Hermitian 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'*U or A = L*L' 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 = -k, the k-th argument had an illegal value
> 0: if INFO = k, the leading minor of order k 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.
=====================================================================
Test the input parameters.
Parameter adjustments */
/* Table of constant values */
static doublereal c_b8 = -1.;
static integer c__1 = 1;
/* System generated locals */
integer ab_dim1, ab_offset, i__1, i__2, i__3;
doublereal d__1;
/* Builtin functions */
double sqrt(doublereal);
/* Local variables */
extern /* Subroutine */ int zher_(char *, integer *, doublereal *,
doublecomplex *, integer *, doublecomplex *, integer *);
static integer j;
extern logical lsame_(char *, char *);
static logical upper;
static integer kn;
extern /* Subroutine */ int xerbla_(char *, integer *), zdscal_(
integer *, doublereal *, doublecomplex *, integer *), zlacgv_(
integer *, doublecomplex *, integer *);
static doublereal ajj;
static integer kld;
#define ab_subscr(a_1,a_2) (a_2)*ab_dim1 + a_1
#define ab_ref(a_1,a_2) ab[ab_subscr(a_1,a_2)]
ab_dim1 = *ldab;
ab_offset = 1 + ab_dim1 * 1;
ab -= ab_offset;
/* Function Body */
*info = 0;
upper = lsame_(uplo, "U");
if (! upper && ! 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_("ZPBTF2", &i__1);
return 0;
}
/* Quick return if possible */
if (*n == 0) {
return 0;
}
/* Computing MAX */
i__1 = 1, i__2 = *ldab - 1;
kld = max(i__1,i__2);
if (upper) {
/* Compute the Cholesky factorization A = U'*U. */
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
/* Compute U(J,J) and test for non-positive-definiteness. */
i__2 = ab_subscr(*kd + 1, j);
ajj = ab[i__2].r;
if (ajj <= 0.) {
i__2 = ab_subscr(*kd + 1, j);
ab[i__2].r = ajj, ab[i__2].i = 0.;
goto L30;
}
ajj = sqrt(ajj);
i__2 = ab_subscr(*kd + 1, j);
ab[i__2].r = ajj, ab[i__2].i = 0.;
/* Compute elements J+1:J+KN of row J and update the
trailing submatrix within the band.
Computing MIN */
i__2 = *kd, i__3 = *n - j;
kn = min(i__2,i__3);
if (kn > 0) {
d__1 = 1. / ajj;
zdscal_(&kn, &d__1, &ab_ref(*kd, j + 1), &kld);
zlacgv_(&kn, &ab_ref(*kd, j + 1), &kld);
zher_("Upper", &kn, &c_b8, &ab_ref(*kd, j + 1), &kld, &ab_ref(
*kd + 1, j + 1), &kld);
zlacgv_(&kn, &ab_ref(*kd, j + 1), &kld);
}
/* L10: */
}
} else {
/* Compute the Cholesky factorization A = L*L'. */
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
/* Compute L(J,J) and test for non-positive-definiteness. */
i__2 = ab_subscr(1, j);
ajj = ab[i__2].r;
if (ajj <= 0.) {
i__2 = ab_subscr(1, j);
ab[i__2].r = ajj, ab[i__2].i = 0.;
goto L30;
}
ajj = sqrt(ajj);
i__2 = ab_subscr(1, j);
ab[i__2].r = ajj, ab[i__2].i = 0.;
/* Compute elements J+1:J+KN of column J and update the
trailing submatrix within the band.
Computing MIN */
i__2 = *kd, i__3 = *n - j;
kn = min(i__2,i__3);
if (kn > 0) {
d__1 = 1. / ajj;
zdscal_(&kn, &d__1, &ab_ref(2, j), &c__1);
zher_("Lower", &kn, &c_b8, &ab_ref(2, j), &c__1, &ab_ref(1, j
+ 1), &kld);
}
/* L20: */
}
}
return 0;
L30:
*info = j;
return 0;
/* End of ZPBTF2 */
} /* zpbtf2_ */
void
zher(char uplo, int n, double alpha, doublecomplex *x, int incx, doublecomplex *a, int lda)
{
zher_( &uplo, &n, &alpha, x, &incx, a, &lda);
}
/* Subroutine */ int zhetf2_(char *uplo, integer *n, doublecomplex *a,
integer *lda, integer *ipiv, integer *info)
{
/* System generated locals */
integer a_dim1, a_offset, i__1, i__2, i__3, i__4, i__5, i__6;
doublereal d__1, d__2, d__3, d__4;
doublecomplex z__1, z__2, z__3, z__4, z__5, z__6;
/* Builtin functions */
double sqrt(doublereal), d_imag(doublecomplex *);
void d_cnjg(doublecomplex *, doublecomplex *);
/* Local variables */
doublereal d__;
integer i__, j, k;
doublecomplex t;
doublereal r1, d11;
doublecomplex d12;
doublereal d22;
doublecomplex d21;
integer kk, kp;
doublecomplex wk;
doublereal tt;
doublecomplex wkm1, wkp1;
integer imax, jmax;
extern /* Subroutine */ int zher_(char *, integer *, doublereal *,
doublecomplex *, integer *, doublecomplex *, integer *);
doublereal alpha;
extern logical lsame_(char *, char *);
integer kstep;
logical upper;
extern /* Subroutine */ int zswap_(integer *, doublecomplex *, integer *,
doublecomplex *, integer *);
extern doublereal dlapy2_(doublereal *, doublereal *);
doublereal absakk;
extern logical disnan_(doublereal *);
extern /* Subroutine */ int xerbla_(char *, integer *), zdscal_(
integer *, doublereal *, doublecomplex *, integer *);
doublereal colmax;
extern integer izamax_(integer *, doublecomplex *, integer *);
doublereal rowmax;
/* -- LAPACK routine (version 3.2) -- */
/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/* November 2006 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* ZHETF2 computes the factorization of a complex Hermitian matrix A */
/* using the Bunch-Kaufman diagonal pivoting method: */
/* A = U*D*U' or A = L*D*L' */
/* where U (or L) is a product of permutation and unit upper (lower) */
/* triangular matrices, U' is the conjugate transpose of U, and D is */
/* Hermitian and block diagonal with 1-by-1 and 2-by-2 diagonal blocks. */
/* This is the unblocked version of the algorithm, calling Level 2 BLAS. */
/* Arguments */
/* ========= */
/* UPLO (input) CHARACTER*1 */
/* Specifies whether the upper or lower triangular part of the */
/* Hermitian matrix A is stored: */
/* = 'U': Upper triangular */
/* = 'L': Lower triangular */
/* N (input) INTEGER */
/* The order of the matrix A. N >= 0. */
/* A (input/output) COMPLEX*16 array, dimension (LDA,N) */
/* On entry, the Hermitian 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, the block diagonal matrix D and the multipliers used */
/* to obtain the factor U or L (see below for further details). */
/* LDA (input) INTEGER */
/* The leading dimension of the array A. LDA >= max(1,N). */
/* IPIV (output) INTEGER array, dimension (N) */
/* Details of the interchanges and the block structure of D. */
/* If IPIV(k) > 0, then rows and columns k and IPIV(k) were */
/* interchanged and D(k,k) is a 1-by-1 diagonal block. */
/* If UPLO = 'U' and IPIV(k) = IPIV(k-1) < 0, then rows and */
/* columns k-1 and -IPIV(k) were interchanged and D(k-1:k,k-1:k) */
/* is a 2-by-2 diagonal block. If UPLO = 'L' and IPIV(k) = */
/* IPIV(k+1) < 0, then rows and columns k+1 and -IPIV(k) were */
/* interchanged and D(k:k+1,k:k+1) is a 2-by-2 diagonal block. */
/* INFO (output) INTEGER */
/* = 0: successful exit */
/* < 0: if INFO = -k, the k-th argument had an illegal value */
/* > 0: if INFO = k, D(k,k) is exactly zero. The factorization */
/* has been completed, but the block diagonal matrix D is */
/* exactly singular, and division by zero will occur if it */
/* is used to solve a system of equations. */
/* Further Details */
/* =============== */
/* 09-29-06 - patch from */
/* Bobby Cheng, MathWorks */
/* Replace l.210 and l.393 */
/* IF( MAX( ABSAKK, COLMAX ).EQ.ZERO ) THEN */
/* by */
/* IF( (MAX( ABSAKK, COLMAX ).EQ.ZERO) .OR. DISNAN(ABSAKK) ) THEN */
/* 01-01-96 - Based on modifications by */
/* J. Lewis, Boeing Computer Services Company */
/* A. Petitet, Computer Science Dept., Univ. of Tenn., Knoxville, USA */
/* If UPLO = 'U', then A = U*D*U', where */
/* U = P(n)*U(n)* ... *P(k)U(k)* ..., */
/* i.e., U is a product of terms P(k)*U(k), where k decreases from n to */
/* 1 in steps of 1 or 2, and D is a block diagonal matrix with 1-by-1 */
/* and 2-by-2 diagonal blocks D(k). P(k) is a permutation matrix as */
/* defined by IPIV(k), and U(k) is a unit upper triangular matrix, such */
/* that if the diagonal block D(k) is of order s (s = 1 or 2), then */
/* ( I v 0 ) k-s */
/* U(k) = ( 0 I 0 ) s */
/* ( 0 0 I ) n-k */
/* k-s s n-k */
/* If s = 1, D(k) overwrites A(k,k), and v overwrites A(1:k-1,k). */
/* If s = 2, the upper triangle of D(k) overwrites A(k-1,k-1), A(k-1,k), */
/* and A(k,k), and v overwrites A(1:k-2,k-1:k). */
/* If UPLO = 'L', then A = L*D*L', where */
/* L = P(1)*L(1)* ... *P(k)*L(k)* ..., */
/* i.e., L is a product of terms P(k)*L(k), where k increases from 1 to */
/* n in steps of 1 or 2, and D is a block diagonal matrix with 1-by-1 */
/* and 2-by-2 diagonal blocks D(k). P(k) is a permutation matrix as */
/* defined by IPIV(k), and L(k) is a unit lower triangular matrix, such */
/* that if the diagonal block D(k) is of order s (s = 1 or 2), then */
/* ( I 0 0 ) k-1 */
/* L(k) = ( 0 I 0 ) s */
/* ( 0 v I ) n-k-s+1 */
/* k-1 s n-k-s+1 */
/* If s = 1, D(k) overwrites A(k,k), and v overwrites A(k+1:n,k). */
/* If s = 2, the lower triangle of D(k) overwrites A(k,k), A(k+1,k), */
/* and A(k+1,k+1), and v overwrites A(k+2:n,k:k+1). */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Statement Functions .. */
/* .. */
/* .. Statement Function definitions .. */
/* .. */
/* .. Executable Statements .. */
/* Test the input parameters. */
/* Parameter adjustments */
a_dim1 = *lda;
a_offset = 1 + a_dim1;
a -= a_offset;
--ipiv;
/* 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_("ZHETF2", &i__1);
return 0;
}
/* Initialize ALPHA for use in choosing pivot block size. */
alpha = (sqrt(17.) + 1.) / 8.;
if (upper) {
/* Factorize A as U*D*U' using the upper triangle of A */
/* K is the main loop index, decreasing from N to 1 in steps of */
/* 1 or 2 */
k = *n;
L10:
/* If K < 1, exit from loop */
if (k < 1) {
goto L90;
}
kstep = 1;
/* Determine rows and columns to be interchanged and whether */
/* a 1-by-1 or 2-by-2 pivot block will be used */
i__1 = k + k * a_dim1;
absakk = (d__1 = a[i__1].r, abs(d__1));
/* IMAX is the row-index of the largest off-diagonal element in */
/* column K, and COLMAX is its absolute value */
if (k > 1) {
i__1 = k - 1;
imax = izamax_(&i__1, &a[k * a_dim1 + 1], &c__1);
i__1 = imax + k * a_dim1;
colmax = (d__1 = a[i__1].r, abs(d__1)) + (d__2 = d_imag(&a[imax +
k * a_dim1]), abs(d__2));
} else {
colmax = 0.;
}
if (max(absakk,colmax) == 0. || disnan_(&absakk)) {
/* Column K is zero or contains a NaN: set INFO and continue */
if (*info == 0) {
*info = k;
}
kp = k;
i__1 = k + k * a_dim1;
i__2 = k + k * a_dim1;
d__1 = a[i__2].r;
a[i__1].r = d__1, a[i__1].i = 0.;
} else {
if (absakk >= alpha * colmax) {
/* no interchange, use 1-by-1 pivot block */
kp = k;
} else {
/* JMAX is the column-index of the largest off-diagonal */
/* element in row IMAX, and ROWMAX is its absolute value */
i__1 = k - imax;
jmax = imax + izamax_(&i__1, &a[imax + (imax + 1) * a_dim1],
lda);
i__1 = imax + jmax * a_dim1;
rowmax = (d__1 = a[i__1].r, abs(d__1)) + (d__2 = d_imag(&a[
imax + jmax * a_dim1]), abs(d__2));
if (imax > 1) {
i__1 = imax - 1;
jmax = izamax_(&i__1, &a[imax * a_dim1 + 1], &c__1);
/* Computing MAX */
i__1 = jmax + imax * a_dim1;
d__3 = rowmax, d__4 = (d__1 = a[i__1].r, abs(d__1)) + (
d__2 = d_imag(&a[jmax + imax * a_dim1]), abs(d__2)
);
rowmax = max(d__3,d__4);
}
if (absakk >= alpha * colmax * (colmax / rowmax)) {
/* no interchange, use 1-by-1 pivot block */
kp = k;
} else /* if(complicated condition) */ {
i__1 = imax + imax * a_dim1;
if ((d__1 = a[i__1].r, abs(d__1)) >= alpha * rowmax) {
/* interchange rows and columns K and IMAX, use 1-by-1 */
/* pivot block */
kp = imax;
} else {
/* interchange rows and columns K-1 and IMAX, use 2-by-2 */
/* pivot block */
kp = imax;
kstep = 2;
}
}
}
kk = k - kstep + 1;
if (kp != kk) {
/* Interchange rows and columns KK and KP in the leading */
/* submatrix A(1:k,1:k) */
i__1 = kp - 1;
zswap_(&i__1, &a[kk * a_dim1 + 1], &c__1, &a[kp * a_dim1 + 1],
&c__1);
i__1 = kk - 1;
for (j = kp + 1; j <= i__1; ++j) {
d_cnjg(&z__1, &a[j + kk * a_dim1]);
t.r = z__1.r, t.i = z__1.i;
i__2 = j + kk * a_dim1;
d_cnjg(&z__1, &a[kp + j * a_dim1]);
a[i__2].r = z__1.r, a[i__2].i = z__1.i;
i__2 = kp + j * a_dim1;
a[i__2].r = t.r, a[i__2].i = t.i;
/* L20: */
}
i__1 = kp + kk * a_dim1;
d_cnjg(&z__1, &a[kp + kk * a_dim1]);
a[i__1].r = z__1.r, a[i__1].i = z__1.i;
i__1 = kk + kk * a_dim1;
r1 = a[i__1].r;
i__1 = kk + kk * a_dim1;
i__2 = kp + kp * a_dim1;
d__1 = a[i__2].r;
a[i__1].r = d__1, a[i__1].i = 0.;
i__1 = kp + kp * a_dim1;
a[i__1].r = r1, a[i__1].i = 0.;
if (kstep == 2) {
i__1 = k + k * a_dim1;
i__2 = k + k * a_dim1;
d__1 = a[i__2].r;
a[i__1].r = d__1, a[i__1].i = 0.;
i__1 = k - 1 + k * a_dim1;
t.r = a[i__1].r, t.i = a[i__1].i;
i__1 = k - 1 + k * a_dim1;
i__2 = kp + k * a_dim1;
a[i__1].r = a[i__2].r, a[i__1].i = a[i__2].i;
i__1 = kp + k * a_dim1;
a[i__1].r = t.r, a[i__1].i = t.i;
}
} else {
i__1 = k + k * a_dim1;
i__2 = k + k * a_dim1;
d__1 = a[i__2].r;
a[i__1].r = d__1, a[i__1].i = 0.;
if (kstep == 2) {
i__1 = k - 1 + (k - 1) * a_dim1;
i__2 = k - 1 + (k - 1) * a_dim1;
d__1 = a[i__2].r;
a[i__1].r = d__1, a[i__1].i = 0.;
}
}
/* Update the leading submatrix */
if (kstep == 1) {
/* 1-by-1 pivot block D(k): column k now holds */
/* W(k) = U(k)*D(k) */
/* where U(k) is the k-th column of U */
/* Perform a rank-1 update of A(1:k-1,1:k-1) as */
/* A := A - U(k)*D(k)*U(k)' = A - W(k)*1/D(k)*W(k)' */
i__1 = k + k * a_dim1;
r1 = 1. / a[i__1].r;
i__1 = k - 1;
d__1 = -r1;
zher_(uplo, &i__1, &d__1, &a[k * a_dim1 + 1], &c__1, &a[
a_offset], lda);
/* Store U(k) in column k */
i__1 = k - 1;
zdscal_(&i__1, &r1, &a[k * a_dim1 + 1], &c__1);
} else {
/* 2-by-2 pivot block D(k): columns k and k-1 now hold */
/* ( W(k-1) W(k) ) = ( U(k-1) U(k) )*D(k) */
/* where U(k) and U(k-1) are the k-th and (k-1)-th columns */
/* of U */
/* Perform a rank-2 update of A(1:k-2,1:k-2) as */
/* A := A - ( U(k-1) U(k) )*D(k)*( U(k-1) U(k) )' */
/* = A - ( W(k-1) W(k) )*inv(D(k))*( W(k-1) W(k) )' */
if (k > 2) {
i__1 = k - 1 + k * a_dim1;
d__1 = a[i__1].r;
d__2 = d_imag(&a[k - 1 + k * a_dim1]);
d__ = dlapy2_(&d__1, &d__2);
i__1 = k - 1 + (k - 1) * a_dim1;
d22 = a[i__1].r / d__;
i__1 = k + k * a_dim1;
d11 = a[i__1].r / d__;
tt = 1. / (d11 * d22 - 1.);
i__1 = k - 1 + k * a_dim1;
z__1.r = a[i__1].r / d__, z__1.i = a[i__1].i / d__;
d12.r = z__1.r, d12.i = z__1.i;
d__ = tt / d__;
for (j = k - 2; j >= 1; --j) {
i__1 = j + (k - 1) * a_dim1;
z__3.r = d11 * a[i__1].r, z__3.i = d11 * a[i__1].i;
d_cnjg(&z__5, &d12);
i__2 = j + k * a_dim1;
z__4.r = z__5.r * a[i__2].r - z__5.i * a[i__2].i,
z__4.i = z__5.r * a[i__2].i + z__5.i * a[i__2]
.r;
z__2.r = z__3.r - z__4.r, z__2.i = z__3.i - z__4.i;
z__1.r = d__ * z__2.r, z__1.i = d__ * z__2.i;
wkm1.r = z__1.r, wkm1.i = z__1.i;
i__1 = j + k * a_dim1;
z__3.r = d22 * a[i__1].r, z__3.i = d22 * a[i__1].i;
i__2 = j + (k - 1) * a_dim1;
z__4.r = d12.r * a[i__2].r - d12.i * a[i__2].i,
z__4.i = d12.r * a[i__2].i + d12.i * a[i__2]
.r;
z__2.r = z__3.r - z__4.r, z__2.i = z__3.i - z__4.i;
z__1.r = d__ * z__2.r, z__1.i = d__ * z__2.i;
wk.r = z__1.r, wk.i = z__1.i;
for (i__ = j; i__ >= 1; --i__) {
i__1 = i__ + j * a_dim1;
i__2 = i__ + j * a_dim1;
i__3 = i__ + k * a_dim1;
d_cnjg(&z__4, &wk);
z__3.r = a[i__3].r * z__4.r - a[i__3].i * z__4.i,
z__3.i = a[i__3].r * z__4.i + a[i__3].i *
z__4.r;
z__2.r = a[i__2].r - z__3.r, z__2.i = a[i__2].i -
z__3.i;
i__4 = i__ + (k - 1) * a_dim1;
d_cnjg(&z__6, &wkm1);
z__5.r = a[i__4].r * z__6.r - a[i__4].i * z__6.i,
z__5.i = a[i__4].r * z__6.i + a[i__4].i *
z__6.r;
z__1.r = z__2.r - z__5.r, z__1.i = z__2.i -
z__5.i;
a[i__1].r = z__1.r, a[i__1].i = z__1.i;
/* L30: */
}
i__1 = j + k * a_dim1;
a[i__1].r = wk.r, a[i__1].i = wk.i;
i__1 = j + (k - 1) * a_dim1;
a[i__1].r = wkm1.r, a[i__1].i = wkm1.i;
i__1 = j + j * a_dim1;
i__2 = j + j * a_dim1;
d__1 = a[i__2].r;
z__1.r = d__1, z__1.i = 0.;
a[i__1].r = z__1.r, a[i__1].i = z__1.i;
/* L40: */
}
}
}
}
/* Store details of the interchanges in IPIV */
if (kstep == 1) {
ipiv[k] = kp;
} else {
ipiv[k] = -kp;
ipiv[k - 1] = -kp;
}
/* Decrease K and return to the start of the main loop */
k -= kstep;
goto L10;
} else {
/* Factorize A as L*D*L' using the lower triangle of A */
/* K is the main loop index, increasing from 1 to N in steps of */
/* 1 or 2 */
k = 1;
L50:
/* If K > N, exit from loop */
if (k > *n) {
goto L90;
}
kstep = 1;
/* Determine rows and columns to be interchanged and whether */
/* a 1-by-1 or 2-by-2 pivot block will be used */
i__1 = k + k * a_dim1;
absakk = (d__1 = a[i__1].r, abs(d__1));
/* IMAX is the row-index of the largest off-diagonal element in */
/* column K, and COLMAX is its absolute value */
if (k < *n) {
i__1 = *n - k;
imax = k + izamax_(&i__1, &a[k + 1 + k * a_dim1], &c__1);
i__1 = imax + k * a_dim1;
colmax = (d__1 = a[i__1].r, abs(d__1)) + (d__2 = d_imag(&a[imax +
k * a_dim1]), abs(d__2));
} else {
colmax = 0.;
}
if (max(absakk,colmax) == 0. || disnan_(&absakk)) {
/* Column K is zero or contains a NaN: set INFO and continue */
if (*info == 0) {
*info = k;
}
kp = k;
i__1 = k + k * a_dim1;
i__2 = k + k * a_dim1;
d__1 = a[i__2].r;
a[i__1].r = d__1, a[i__1].i = 0.;
} else {
if (absakk >= alpha * colmax) {
/* no interchange, use 1-by-1 pivot block */
kp = k;
} else {
/* JMAX is the column-index of the largest off-diagonal */
/* element in row IMAX, and ROWMAX is its absolute value */
i__1 = imax - k;
jmax = k - 1 + izamax_(&i__1, &a[imax + k * a_dim1], lda);
i__1 = imax + jmax * a_dim1;
rowmax = (d__1 = a[i__1].r, abs(d__1)) + (d__2 = d_imag(&a[
imax + jmax * a_dim1]), abs(d__2));
if (imax < *n) {
i__1 = *n - imax;
jmax = imax + izamax_(&i__1, &a[imax + 1 + imax * a_dim1],
&c__1);
/* Computing MAX */
i__1 = jmax + imax * a_dim1;
d__3 = rowmax, d__4 = (d__1 = a[i__1].r, abs(d__1)) + (
d__2 = d_imag(&a[jmax + imax * a_dim1]), abs(d__2)
);
rowmax = max(d__3,d__4);
}
if (absakk >= alpha * colmax * (colmax / rowmax)) {
/* no interchange, use 1-by-1 pivot block */
kp = k;
} else /* if(complicated condition) */ {
i__1 = imax + imax * a_dim1;
if ((d__1 = a[i__1].r, abs(d__1)) >= alpha * rowmax) {
/* interchange rows and columns K and IMAX, use 1-by-1 */
/* pivot block */
kp = imax;
} else {
/* interchange rows and columns K+1 and IMAX, use 2-by-2 */
/* pivot block */
kp = imax;
kstep = 2;
}
}
}
kk = k + kstep - 1;
if (kp != kk) {
/* Interchange rows and columns KK and KP in the trailing */
/* submatrix A(k:n,k:n) */
if (kp < *n) {
i__1 = *n - kp;
zswap_(&i__1, &a[kp + 1 + kk * a_dim1], &c__1, &a[kp + 1
+ kp * a_dim1], &c__1);
}
i__1 = kp - 1;
for (j = kk + 1; j <= i__1; ++j) {
d_cnjg(&z__1, &a[j + kk * a_dim1]);
t.r = z__1.r, t.i = z__1.i;
i__2 = j + kk * a_dim1;
d_cnjg(&z__1, &a[kp + j * a_dim1]);
a[i__2].r = z__1.r, a[i__2].i = z__1.i;
i__2 = kp + j * a_dim1;
a[i__2].r = t.r, a[i__2].i = t.i;
/* L60: */
}
i__1 = kp + kk * a_dim1;
d_cnjg(&z__1, &a[kp + kk * a_dim1]);
a[i__1].r = z__1.r, a[i__1].i = z__1.i;
i__1 = kk + kk * a_dim1;
r1 = a[i__1].r;
i__1 = kk + kk * a_dim1;
i__2 = kp + kp * a_dim1;
d__1 = a[i__2].r;
a[i__1].r = d__1, a[i__1].i = 0.;
i__1 = kp + kp * a_dim1;
a[i__1].r = r1, a[i__1].i = 0.;
if (kstep == 2) {
i__1 = k + k * a_dim1;
i__2 = k + k * a_dim1;
d__1 = a[i__2].r;
a[i__1].r = d__1, a[i__1].i = 0.;
i__1 = k + 1 + k * a_dim1;
t.r = a[i__1].r, t.i = a[i__1].i;
i__1 = k + 1 + k * a_dim1;
i__2 = kp + k * a_dim1;
a[i__1].r = a[i__2].r, a[i__1].i = a[i__2].i;
i__1 = kp + k * a_dim1;
a[i__1].r = t.r, a[i__1].i = t.i;
}
} else {
i__1 = k + k * a_dim1;
i__2 = k + k * a_dim1;
d__1 = a[i__2].r;
a[i__1].r = d__1, a[i__1].i = 0.;
if (kstep == 2) {
i__1 = k + 1 + (k + 1) * a_dim1;
i__2 = k + 1 + (k + 1) * a_dim1;
d__1 = a[i__2].r;
a[i__1].r = d__1, a[i__1].i = 0.;
}
}
/* Update the trailing submatrix */
if (kstep == 1) {
/* 1-by-1 pivot block D(k): column k now holds */
/* W(k) = L(k)*D(k) */
/* where L(k) is the k-th column of L */
if (k < *n) {
/* Perform a rank-1 update of A(k+1:n,k+1:n) as */
/* A := A - L(k)*D(k)*L(k)' = A - W(k)*(1/D(k))*W(k)' */
i__1 = k + k * a_dim1;
r1 = 1. / a[i__1].r;
i__1 = *n - k;
d__1 = -r1;
zher_(uplo, &i__1, &d__1, &a[k + 1 + k * a_dim1], &c__1, &
a[k + 1 + (k + 1) * a_dim1], lda);
/* Store L(k) in column K */
i__1 = *n - k;
zdscal_(&i__1, &r1, &a[k + 1 + k * a_dim1], &c__1);
}
} else {
/* 2-by-2 pivot block D(k) */
if (k < *n - 1) {
/* Perform a rank-2 update of A(k+2:n,k+2:n) as */
/* A := A - ( L(k) L(k+1) )*D(k)*( L(k) L(k+1) )' */
/* = A - ( W(k) W(k+1) )*inv(D(k))*( W(k) W(k+1) )' */
/* where L(k) and L(k+1) are the k-th and (k+1)-th */
/* columns of L */
i__1 = k + 1 + k * a_dim1;
d__1 = a[i__1].r;
d__2 = d_imag(&a[k + 1 + k * a_dim1]);
d__ = dlapy2_(&d__1, &d__2);
i__1 = k + 1 + (k + 1) * a_dim1;
d11 = a[i__1].r / d__;
i__1 = k + k * a_dim1;
d22 = a[i__1].r / d__;
tt = 1. / (d11 * d22 - 1.);
i__1 = k + 1 + k * a_dim1;
z__1.r = a[i__1].r / d__, z__1.i = a[i__1].i / d__;
d21.r = z__1.r, d21.i = z__1.i;
d__ = tt / d__;
i__1 = *n;
for (j = k + 2; j <= i__1; ++j) {
i__2 = j + k * a_dim1;
z__3.r = d11 * a[i__2].r, z__3.i = d11 * a[i__2].i;
i__3 = j + (k + 1) * a_dim1;
z__4.r = d21.r * a[i__3].r - d21.i * a[i__3].i,
z__4.i = d21.r * a[i__3].i + d21.i * a[i__3]
.r;
z__2.r = z__3.r - z__4.r, z__2.i = z__3.i - z__4.i;
z__1.r = d__ * z__2.r, z__1.i = d__ * z__2.i;
wk.r = z__1.r, wk.i = z__1.i;
i__2 = j + (k + 1) * a_dim1;
z__3.r = d22 * a[i__2].r, z__3.i = d22 * a[i__2].i;
d_cnjg(&z__5, &d21);
i__3 = j + k * a_dim1;
z__4.r = z__5.r * a[i__3].r - z__5.i * a[i__3].i,
z__4.i = z__5.r * a[i__3].i + z__5.i * a[i__3]
.r;
z__2.r = z__3.r - z__4.r, z__2.i = z__3.i - z__4.i;
z__1.r = d__ * z__2.r, z__1.i = d__ * z__2.i;
wkp1.r = z__1.r, wkp1.i = z__1.i;
i__2 = *n;
for (i__ = j; i__ <= i__2; ++i__) {
i__3 = i__ + j * a_dim1;
i__4 = i__ + j * a_dim1;
i__5 = i__ + k * a_dim1;
d_cnjg(&z__4, &wk);
z__3.r = a[i__5].r * z__4.r - a[i__5].i * z__4.i,
z__3.i = a[i__5].r * z__4.i + a[i__5].i *
z__4.r;
z__2.r = a[i__4].r - z__3.r, z__2.i = a[i__4].i -
z__3.i;
i__6 = i__ + (k + 1) * a_dim1;
d_cnjg(&z__6, &wkp1);
z__5.r = a[i__6].r * z__6.r - a[i__6].i * z__6.i,
z__5.i = a[i__6].r * z__6.i + a[i__6].i *
z__6.r;
z__1.r = z__2.r - z__5.r, z__1.i = z__2.i -
z__5.i;
a[i__3].r = z__1.r, a[i__3].i = z__1.i;
/* L70: */
}
i__2 = j + k * a_dim1;
a[i__2].r = wk.r, a[i__2].i = wk.i;
i__2 = j + (k + 1) * a_dim1;
a[i__2].r = wkp1.r, a[i__2].i = wkp1.i;
i__2 = j + j * a_dim1;
i__3 = j + j * a_dim1;
d__1 = a[i__3].r;
z__1.r = d__1, z__1.i = 0.;
a[i__2].r = z__1.r, a[i__2].i = z__1.i;
/* L80: */
}
}
}
}
/* Store details of the interchanges in IPIV */
if (kstep == 1) {
ipiv[k] = kp;
} else {
ipiv[k] = -kp;
ipiv[k + 1] = -kp;
}
/* Increase K and return to the start of the main loop */
k += kstep;
goto L50;
}
L90:
return 0;
/* End of ZHETF2 */
} /* zhetf2_ */
/* Subroutine */ int zpbt01_(char *uplo, integer *n, integer *kd,
doublecomplex *a, integer *lda, doublecomplex *afac, integer *ldafac,
doublereal *rwork, doublereal *resid)
{
/* System generated locals */
integer a_dim1, a_offset, afac_dim1, afac_offset, i__1, i__2, i__3, i__4,
i__5;
doublecomplex z__1;
/* Builtin functions */
double d_imag(doublecomplex *);
/* Local variables */
static integer klen;
extern /* Subroutine */ int zher_(char *, integer *, doublereal *,
doublecomplex *, integer *, doublecomplex *, integer *);
static integer i__, j, k;
extern logical lsame_(char *, char *);
static doublereal anorm;
extern /* Double Complex */ VOID zdotc_(doublecomplex *, integer *,
doublecomplex *, integer *, doublecomplex *, integer *);
extern /* Subroutine */ int ztrmv_(char *, char *, char *, integer *,
doublecomplex *, integer *, doublecomplex *, integer *);
static integer kc;
extern doublereal dlamch_(char *);
static integer ml, mu;
extern doublereal zlanhb_(char *, char *, integer *, integer *,
doublecomplex *, integer *, doublereal *);
extern /* Subroutine */ int zdscal_(integer *, doublereal *,
doublecomplex *, integer *);
static doublereal akk, eps;
#define a_subscr(a_1,a_2) (a_2)*a_dim1 + a_1
#define a_ref(a_1,a_2) a[a_subscr(a_1,a_2)]
#define afac_subscr(a_1,a_2) (a_2)*afac_dim1 + a_1
#define afac_ref(a_1,a_2) afac[afac_subscr(a_1,a_2)]
/* -- LAPACK test 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
=======
ZPBT01 reconstructs a Hermitian positive definite band matrix A from
its L*L' or U'*U factorization and computes the residual
norm( L*L' - A ) / ( N * norm(A) * EPS ) or
norm( U'*U - A ) / ( N * norm(A) * EPS ),
where EPS is the machine epsilon, L' is the conjugate transpose of
L, and U' is the conjugate transpose of U.
Arguments
=========
UPLO (input) CHARACTER*1
Specifies whether the upper or lower triangular part of the
Hermitian matrix A is stored:
= 'U': Upper triangular
= 'L': Lower triangular
N (input) INTEGER
The number of rows and columns of the matrix A. N >= 0.
KD (input) INTEGER
The number of super-diagonals of the matrix A if UPLO = 'U',
or the number of sub-diagonals if UPLO = 'L'. KD >= 0.
A (input) COMPLEX*16 array, dimension (LDA,N)
The original Hermitian band matrix A. If UPLO = 'U', the
upper triangular part of A is stored as a band matrix; if
UPLO = 'L', the lower triangular part of A is stored. The
columns of the appropriate triangle are stored in the columns
of A and the diagonals of the triangle are stored in the rows
of A. See ZPBTRF for further details.
LDA (input) INTEGER.
The leading dimension of the array A. LDA >= max(1,KD+1).
AFAC (input) COMPLEX*16 array, dimension (LDAFAC,N)
The factored form of the matrix A. AFAC contains the factor
L or U from the L*L' or U'*U factorization in band storage
format, as computed by ZPBTRF.
LDAFAC (input) INTEGER
The leading dimension of the array AFAC.
LDAFAC >= max(1,KD+1).
RWORK (workspace) DOUBLE PRECISION array, dimension (N)
RESID (output) DOUBLE PRECISION
If UPLO = 'L', norm(L*L' - A) / ( N * norm(A) * EPS )
If UPLO = 'U', norm(U'*U - A) / ( N * norm(A) * EPS )
=====================================================================
Quick exit if N = 0.
Parameter adjustments */
a_dim1 = *lda;
a_offset = 1 + a_dim1 * 1;
a -= a_offset;
afac_dim1 = *ldafac;
afac_offset = 1 + afac_dim1 * 1;
afac -= afac_offset;
--rwork;
/* Function Body */
if (*n <= 0) {
*resid = 0.;
return 0;
}
/* Exit with RESID = 1/EPS if ANORM = 0. */
eps = dlamch_("Epsilon");
anorm = zlanhb_("1", uplo, n, kd, &a[a_offset], lda, &rwork[1]);
if (anorm <= 0.) {
*resid = 1. / eps;
return 0;
}
/* Check the imaginary parts of the diagonal elements and return with
an error code if any are nonzero. */
if (lsame_(uplo, "U")) {
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
if (d_imag(&afac_ref(*kd + 1, j)) != 0.) {
*resid = 1. / eps;
return 0;
}
/* L10: */
}
} else {
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
if (d_imag(&afac_ref(1, j)) != 0.) {
*resid = 1. / eps;
return 0;
}
/* L20: */
}
}
/* Compute the product U'*U, overwriting U. */
if (lsame_(uplo, "U")) {
for (k = *n; k >= 1; --k) {
/* Computing MAX */
i__1 = 1, i__2 = *kd + 2 - k;
kc = max(i__1,i__2);
klen = *kd + 1 - kc;
/* Compute the (K,K) element of the result. */
i__1 = klen + 1;
zdotc_(&z__1, &i__1, &afac_ref(kc, k), &c__1, &afac_ref(kc, k), &
c__1);
akk = z__1.r;
i__1 = afac_subscr(*kd + 1, k);
afac[i__1].r = akk, afac[i__1].i = 0.;
/* Compute the rest of column K. */
if (klen > 0) {
i__1 = *ldafac - 1;
ztrmv_("Upper", "Conjugate", "Non-unit", &klen, &afac_ref(*kd
+ 1, k - klen), &i__1, &afac_ref(kc, k), &c__1);
}
/* L30: */
}
/* UPLO = 'L': Compute the product L*L', overwriting L. */
} else {
for (k = *n; k >= 1; --k) {
/* Computing MIN */
i__1 = *kd, i__2 = *n - k;
klen = min(i__1,i__2);
/* Add a multiple of column K of the factor L to each of
columns K+1 through N. */
if (klen > 0) {
i__1 = *ldafac - 1;
zher_("Lower", &klen, &c_b17, &afac_ref(2, k), &c__1, &
afac_ref(1, k + 1), &i__1);
}
/* Scale column K by the diagonal element. */
i__1 = afac_subscr(1, k);
akk = afac[i__1].r;
i__1 = klen + 1;
zdscal_(&i__1, &akk, &afac_ref(1, k), &c__1);
/* L40: */
}
}
/* Compute the difference L*L' - A or U'*U - A. */
if (lsame_(uplo, "U")) {
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
/* Computing MAX */
i__2 = 1, i__3 = *kd + 2 - j;
mu = max(i__2,i__3);
i__2 = *kd + 1;
for (i__ = mu; i__ <= i__2; ++i__) {
i__3 = afac_subscr(i__, j);
i__4 = afac_subscr(i__, j);
i__5 = a_subscr(i__, j);
z__1.r = afac[i__4].r - a[i__5].r, z__1.i = afac[i__4].i - a[
i__5].i;
afac[i__3].r = z__1.r, afac[i__3].i = z__1.i;
/* L50: */
}
/* L60: */
}
} else {
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
/* Computing MIN */
i__2 = *kd + 1, i__3 = *n - j + 1;
ml = min(i__2,i__3);
i__2 = ml;
for (i__ = 1; i__ <= i__2; ++i__) {
i__3 = afac_subscr(i__, j);
i__4 = afac_subscr(i__, j);
i__5 = a_subscr(i__, j);
z__1.r = afac[i__4].r - a[i__5].r, z__1.i = afac[i__4].i - a[
i__5].i;
afac[i__3].r = z__1.r, afac[i__3].i = z__1.i;
/* L70: */
}
/* L80: */
}
}
/* Compute norm( L*L' - A ) / ( N * norm(A) * EPS ) */
*resid = zlanhb_("1", uplo, n, kd, &afac[afac_offset], ldafac, &rwork[1]);
*resid = *resid / (doublereal) (*n) / anorm / eps;
return 0;
/* End of ZPBT01 */
} /* zpbt01_ */
/* Subroutine */ int zpbstf_(char *uplo, integer *n, integer *kd,
doublecomplex *ab, integer *ldab, integer *info)
{
/* -- LAPACK routine (version 2.0) --
Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
Courant Institute, Argonne National Lab, and Rice University
September 30, 1994
Purpose
=======
ZPBSTF computes a split Cholesky factorization of a complex
Hermitian positive definite band matrix A.
This routine is designed to be used in conjunction with ZHBGST.
The factorization has the form A = S**H*S where S is a band matrix
of the same bandwidth as A and the following structure:
S = ( U )
( M L )
where U is upper triangular of order m = (n+kd)/2, and L is lower
triangular of order n-m.
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) COMPLEX*16 array, dimension (LDAB,N)
On entry, the upper or lower triangle of the Hermitian 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 factor S from the split Cholesky
factorization A = S**H*S. See Further Details.
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 factorization could not be completed,
because the updated element a(i,i) was negative; the
matrix A is not positive definite.
Further Details
===============
The band storage scheme is illustrated by the following example, when
N = 7, KD = 2:
S = ( s11 s12 s13 )
( s22 s23 s24 )
( s33 s34 )
( s44 )
( s53 s54 s55 )
( s64 s65 s66 )
( s75 s76 s77 )
If UPLO = 'U', the array AB holds:
on entry: on exit:
* * a13 a24 a35 a46 a57 * * s13 s24 s53' s64' s75'
* a12 a23 a34 a45 a56 a67 * s12 s23 s34 s54' s65' s76'
a11 a22 a33 a44 a55 a66 a77 s11 s22 s33 s44 s55 s66 s77
If UPLO = 'L', the array AB holds:
on entry: on exit:
a11 a22 a33 a44 a55 a66 a77 s11 s22 s33 s44 s55 s66 s77
a21 a32 a43 a54 a65 a76 * s12' s23' s34' s54 s65 s76 *
a31 a42 a53 a64 a64 * * s13' s24' s53 s64 s75 * *
VISArray elements marked * are not used by the routine; s12' denotes
conjg(s12); the diagonal elements of S are real.
=====================================================================
Test the input parameters.
Parameter adjustments
Function Body */
/* Table of constant values */
static integer c__1 = 1;
static doublereal c_b9 = -1.;
/* System generated locals */
integer ab_dim1, ab_offset, i__1, i__2, i__3;
doublereal d__1;
/* Builtin functions */
double sqrt(doublereal);
/* Local variables */
extern /* Subroutine */ int zher_(char *, integer *, doublereal *,
doublecomplex *, integer *, doublecomplex *, integer *);
static integer j, m;
extern logical lsame_(char *, char *);
static logical upper;
static integer km;
extern /* Subroutine */ int xerbla_(char *, integer *), zdscal_(
integer *, doublereal *, doublecomplex *, integer *), zlacgv_(
integer *, doublecomplex *, integer *);
static doublereal ajj;
static integer kld;
#define AB(I,J) ab[(I)-1 + ((J)-1)* ( *ldab)]
*info = 0;
upper = lsame_(uplo, "U");
if (! upper && ! 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_("ZPBSTF", &i__1);
return 0;
}
/* Quick return if possible */
if (*n == 0) {
return 0;
}
/* Computing MAX */
i__1 = 1, i__2 = *ldab - 1;
kld = max(i__1,i__2);
/* Set the splitting point m. */
m = (*n + *kd) / 2;
if (upper) {
/* Factorize A(m+1:n,m+1:n) as L**H*L, and update A(1:m,1:m).
*/
i__1 = m + 1;
for (j = *n; j >= m+1; --j) {
/* Compute s(j,j) and test for non-positive-definiteness
. */
i__2 = *kd + 1 + j * ab_dim1;
ajj = AB(*kd+1,j).r;
if (ajj <= 0.) {
i__2 = *kd + 1 + j * ab_dim1;
AB(*kd+1,j).r = ajj, AB(*kd+1,j).i = 0.;
goto L50;
}
ajj = sqrt(ajj);
i__2 = *kd + 1 + j * ab_dim1;
AB(*kd+1,j).r = ajj, AB(*kd+1,j).i = 0.;
/* Computing MIN */
i__2 = j - 1;
km = min(i__2,*kd);
/* Compute elements j-km:j-1 of the j-th column and upda
te the
the leading submatrix within the band. */
d__1 = 1. / ajj;
zdscal_(&km, &d__1, &AB(*kd+1-km,j), &c__1);
zher_("Upper", &km, &c_b9, &AB(*kd+1-km,j), &c__1,
&AB(*kd+1,j-km), &kld);
/* L10: */
}
/* Factorize the updated submatrix A(1:m,1:m) as U**H*U. */
i__1 = m;
for (j = 1; j <= m; ++j) {
/* Compute s(j,j) and test for non-positive-definiteness
. */
i__2 = *kd + 1 + j * ab_dim1;
ajj = AB(*kd+1,j).r;
if (ajj <= 0.) {
i__2 = *kd + 1 + j * ab_dim1;
AB(*kd+1,j).r = ajj, AB(*kd+1,j).i = 0.;
goto L50;
}
ajj = sqrt(ajj);
i__2 = *kd + 1 + j * ab_dim1;
AB(*kd+1,j).r = ajj, AB(*kd+1,j).i = 0.;
/* Computing MIN */
i__2 = *kd, i__3 = m - j;
km = min(i__2,i__3);
/* Compute elements j+1:j+km of the j-th row and update
the
trailing submatrix within the band. */
if (km > 0) {
d__1 = 1. / ajj;
zdscal_(&km, &d__1, &AB(*kd,j+1), &kld);
zlacgv_(&km, &AB(*kd,j+1), &kld);
zher_("Upper", &km, &c_b9, &AB(*kd,j+1), &kld,
&AB(*kd+1,j+1), &kld);
zlacgv_(&km, &AB(*kd,j+1), &kld);
}
/* L20: */
}
} else {
/* Factorize A(m+1:n,m+1:n) as L**H*L, and update A(1:m,1:m).
*/
i__1 = m + 1;
for (j = *n; j >= m+1; --j) {
/* Compute s(j,j) and test for non-positive-definiteness
. */
i__2 = j * ab_dim1 + 1;
ajj = AB(1,j).r;
if (ajj <= 0.) {
i__2 = j * ab_dim1 + 1;
AB(1,j).r = ajj, AB(1,j).i = 0.;
goto L50;
}
ajj = sqrt(ajj);
i__2 = j * ab_dim1 + 1;
AB(1,j).r = ajj, AB(1,j).i = 0.;
/* Computing MIN */
i__2 = j - 1;
km = min(i__2,*kd);
/* Compute elements j-km:j-1 of the j-th row and update
the
trailing submatrix within the band. */
d__1 = 1. / ajj;
zdscal_(&km, &d__1, &AB(km+1,j-km), &kld);
zlacgv_(&km, &AB(km+1,j-km), &kld);
zher_("Lower", &km, &c_b9, &AB(km+1,j-km), &kld,
&AB(1,j-km), &kld);
zlacgv_(&km, &AB(km+1,j-km), &kld);
/* L30: */
}
/* Factorize the updated submatrix A(1:m,1:m) as U**H*U. */
i__1 = m;
for (j = 1; j <= m; ++j) {
/* Compute s(j,j) and test for non-positive-definiteness
. */
i__2 = j * ab_dim1 + 1;
ajj = AB(1,j).r;
if (ajj <= 0.) {
i__2 = j * ab_dim1 + 1;
AB(1,j).r = ajj, AB(1,j).i = 0.;
goto L50;
}
ajj = sqrt(ajj);
i__2 = j * ab_dim1 + 1;
AB(1,j).r = ajj, AB(1,j).i = 0.;
/* Computing MIN */
i__2 = *kd, i__3 = m - j;
km = min(i__2,i__3);
/* Compute elements j+1:j+km of the j-th column and upda
te the
trailing submatrix within the band. */
if (km > 0) {
d__1 = 1. / ajj;
zdscal_(&km, &d__1, &AB(2,j), &c__1);
zher_("Lower", &km, &c_b9, &AB(2,j), &c__1, &AB(1,j+1), &kld);
}
/* L40: */
}
}
return 0;
L50:
*info = j;
return 0;
/* End of ZPBSTF */
} /* zpbstf_ */
/* Subroutine */ int zhet21_(integer *itype, char *uplo, integer *n, integer *
kband, doublecomplex *a, integer *lda, doublereal *d__, doublereal *e,
doublecomplex *u, integer *ldu, doublecomplex *v, integer *ldv,
doublecomplex *tau, doublecomplex *work, doublereal *rwork,
doublereal *result)
{
/* System generated locals */
integer a_dim1, a_offset, u_dim1, u_offset, v_dim1, v_offset, i__1, i__2,
i__3, i__4, i__5, i__6;
doublereal d__1, d__2;
doublecomplex z__1, z__2, z__3;
/* Local variables */
integer j, jr;
doublereal ulp;
integer jcol;
doublereal unfl;
extern /* Subroutine */ int zher_(char *, integer *, doublereal *,
doublecomplex *, integer *, doublecomplex *, integer *);
integer jrow;
extern /* Subroutine */ int zher2_(char *, integer *, doublecomplex *,
doublecomplex *, integer *, doublecomplex *, integer *,
doublecomplex *, integer *);
extern logical lsame_(char *, char *);
integer iinfo;
doublereal anorm;
extern /* Subroutine */ int zgemm_(char *, char *, integer *, integer *,
integer *, doublecomplex *, doublecomplex *, integer *,
doublecomplex *, integer *, doublecomplex *, doublecomplex *,
integer *);
char cuplo[1];
doublecomplex vsave;
logical lower;
doublereal wnorm;
extern /* Subroutine */ int zunm2l_(char *, char *, integer *, integer *,
integer *, doublecomplex *, integer *, doublecomplex *,
doublecomplex *, integer *, doublecomplex *, integer *);
extern doublereal dlamch_(char *);
extern /* Subroutine */ int zunm2r_(char *, char *, integer *, integer *,
integer *, doublecomplex *, integer *, doublecomplex *,
doublecomplex *, integer *, doublecomplex *, integer *);
extern doublereal zlange_(char *, integer *, integer *, doublecomplex *,
integer *, doublereal *), zlanhe_(char *, char *, integer
*, doublecomplex *, integer *, doublereal *);
extern /* Subroutine */ int zlacpy_(char *, integer *, integer *,
doublecomplex *, integer *, doublecomplex *, integer *),
zlaset_(char *, integer *, integer *, doublecomplex *,
doublecomplex *, doublecomplex *, integer *), zlarfy_(
char *, integer *, doublecomplex *, integer *, doublecomplex *,
doublecomplex *, integer *, doublecomplex *);
/* -- LAPACK test routine (version 3.1) -- */
/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/* November 2006 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* ZHET21 generally checks a decomposition of the form */
/* A = U S U* */
/* where * means conjugate transpose, A is hermitian, U is unitary, and */
/* S is diagonal (if KBAND=0) or (real) symmetric tridiagonal (if */
/* KBAND=1). */
/* If ITYPE=1, then U is represented as a dense matrix; otherwise U is */
/* expressed as a product of Householder transformations, whose vectors */
/* are stored in the array "V" and whose scaling constants are in "TAU". */
/* We shall use the letter "V" to refer to the product of Householder */
/* transformations (which should be equal to U). */
/* Specifically, if ITYPE=1, then: */
/* RESULT(1) = | A - U S U* | / ( |A| n ulp ) *and* */
/* RESULT(2) = | I - UU* | / ( n ulp ) */
/* If ITYPE=2, then: */
/* RESULT(1) = | A - V S V* | / ( |A| n ulp ) */
/* If ITYPE=3, then: */
/* RESULT(1) = | I - UV* | / ( n ulp ) */
/* For ITYPE > 1, the transformation U is expressed as a product */
/* V = H(1)...H(n-2), where H(j) = I - tau(j) v(j) v(j)* and each */
/* vector v(j) has its first j elements 0 and the remaining n-j elements */
/* stored in V(j+1:n,j). */
/* Arguments */
/* ========= */
/* ITYPE (input) INTEGER */
/* Specifies the type of tests to be performed. */
/* 1: U expressed as a dense unitary matrix: */
/* RESULT(1) = | A - U S U* | / ( |A| n ulp ) *and* */
/* RESULT(2) = | I - UU* | / ( n ulp ) */
/* 2: U expressed as a product V of Housholder transformations: */
/* RESULT(1) = | A - V S V* | / ( |A| n ulp ) */
/* 3: U expressed both as a dense unitary matrix and */
/* as a product of Housholder transformations: */
/* RESULT(1) = | I - UV* | / ( n ulp ) */
/* UPLO (input) CHARACTER */
/* If UPLO='U', the upper triangle of A and V will be used and */
/* the (strictly) lower triangle will not be referenced. */
/* If UPLO='L', the lower triangle of A and V will be used and */
/* the (strictly) upper triangle will not be referenced. */
/* N (input) INTEGER */
/* The size of the matrix. If it is zero, ZHET21 does nothing. */
/* It must be at least zero. */
/* KBAND (input) INTEGER */
/* The bandwidth of the matrix. It may only be zero or one. */
/* If zero, then S is diagonal, and E is not referenced. If */
/* one, then S is symmetric tri-diagonal. */
/* A (input) COMPLEX*16 array, dimension (LDA, N) */
/* The original (unfactored) matrix. It is assumed to be */
/* hermitian, and only the upper (UPLO='U') or only the lower */
/* (UPLO='L') will be referenced. */
/* LDA (input) INTEGER */
/* The leading dimension of A. It must be at least 1 */
/* and at least N. */
/* D (input) DOUBLE PRECISION array, dimension (N) */
/* The diagonal of the (symmetric tri-) diagonal matrix. */
/* E (input) DOUBLE PRECISION array, dimension (N-1) */
/* The off-diagonal of the (symmetric tri-) diagonal matrix. */
/* E(1) is the (1,2) and (2,1) element, E(2) is the (2,3) and */
/* (3,2) element, etc. */
/* Not referenced if KBAND=0. */
/* U (input) COMPLEX*16 array, dimension (LDU, N) */
/* If ITYPE=1 or 3, this contains the unitary matrix in */
/* the decomposition, expressed as a dense matrix. If ITYPE=2, */
/* then it is not referenced. */
/* LDU (input) INTEGER */
/* The leading dimension of U. LDU must be at least N and */
/* at least 1. */
/* V (input) COMPLEX*16 array, dimension (LDV, N) */
/* If ITYPE=2 or 3, the columns of this array contain the */
/* Householder vectors used to describe the unitary matrix */
/* in the decomposition. If UPLO='L', then the vectors are in */
/* the lower triangle, if UPLO='U', then in the upper */
/* triangle. */
/* *NOTE* If ITYPE=2 or 3, V is modified and restored. The */
/* subdiagonal (if UPLO='L') or the superdiagonal (if UPLO='U') */
/* is set to one, and later reset to its original value, during */
/* the course of the calculation. */
/* If ITYPE=1, then it is neither referenced nor modified. */
/* LDV (input) INTEGER */
/* The leading dimension of V. LDV must be at least N and */
/* at least 1. */
/* TAU (input) COMPLEX*16 array, dimension (N) */
/* If ITYPE >= 2, then TAU(j) is the scalar factor of */
/* v(j) v(j)* in the Householder transformation H(j) of */
/* the product U = H(1)...H(n-2) */
/* If ITYPE < 2, then TAU is not referenced. */
/* WORK (workspace) COMPLEX*16 array, dimension (2*N**2) */
/* RWORK (workspace) DOUBLE PRECISION array, dimension (N) */
/* RESULT (output) DOUBLE PRECISION array, dimension (2) */
/* The values computed by the two tests described above. The */
/* values are currently limited to 1/ulp, to avoid overflow. */
/* RESULT(1) is always modified. RESULT(2) is modified only */
/* if ITYPE=1. */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Executable Statements .. */
/* Parameter adjustments */
a_dim1 = *lda;
a_offset = 1 + a_dim1;
a -= a_offset;
--d__;
--e;
u_dim1 = *ldu;
u_offset = 1 + u_dim1;
u -= u_offset;
v_dim1 = *ldv;
v_offset = 1 + v_dim1;
v -= v_offset;
--tau;
--work;
--rwork;
--result;
/* Function Body */
result[1] = 0.;
if (*itype == 1) {
result[2] = 0.;
}
if (*n <= 0) {
return 0;
}
if (lsame_(uplo, "U")) {
lower = FALSE_;
*(unsigned char *)cuplo = 'U';
} else {
lower = TRUE_;
*(unsigned char *)cuplo = 'L';
}
unfl = dlamch_("Safe minimum");
ulp = dlamch_("Epsilon") * dlamch_("Base");
/* Some Error Checks */
if (*itype < 1 || *itype > 3) {
result[1] = 10. / ulp;
return 0;
}
/* Do Test 1 */
/* Norm of A: */
if (*itype == 3) {
anorm = 1.;
} else {
/* Computing MAX */
d__1 = zlanhe_("1", cuplo, n, &a[a_offset], lda, &rwork[1]);
anorm = max(d__1,unfl);
}
/* Compute error matrix: */
if (*itype == 1) {
/* ITYPE=1: error = A - U S U* */
zlaset_("Full", n, n, &c_b1, &c_b1, &work[1], n);
zlacpy_(cuplo, n, n, &a[a_offset], lda, &work[1], n);
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
d__1 = -d__[j];
zher_(cuplo, n, &d__1, &u[j * u_dim1 + 1], &c__1, &work[1], n);
/* L10: */
}
if (*n > 1 && *kband == 1) {
i__1 = *n - 1;
for (j = 1; j <= i__1; ++j) {
i__2 = j;
z__2.r = e[i__2], z__2.i = 0.;
z__1.r = -z__2.r, z__1.i = -z__2.i;
zher2_(cuplo, n, &z__1, &u[j * u_dim1 + 1], &c__1, &u[(j - 1)
* u_dim1 + 1], &c__1, &work[1], n);
/* L20: */
}
}
wnorm = zlanhe_("1", cuplo, n, &work[1], n, &rwork[1]);
} else if (*itype == 2) {
/* ITYPE=2: error = V S V* - A */
zlaset_("Full", n, n, &c_b1, &c_b1, &work[1], n);
if (lower) {
/* Computing 2nd power */
i__2 = *n;
i__1 = i__2 * i__2;
i__3 = *n;
work[i__1].r = d__[i__3], work[i__1].i = 0.;
for (j = *n - 1; j >= 1; --j) {
if (*kband == 1) {
i__1 = (*n + 1) * (j - 1) + 2;
i__2 = j;
z__2.r = 1. - tau[i__2].r, z__2.i = 0. - tau[i__2].i;
i__3 = j;
z__1.r = e[i__3] * z__2.r, z__1.i = e[i__3] * z__2.i;
work[i__1].r = z__1.r, work[i__1].i = z__1.i;
i__1 = *n;
for (jr = j + 2; jr <= i__1; ++jr) {
i__2 = (j - 1) * *n + jr;
i__3 = j;
z__3.r = -tau[i__3].r, z__3.i = -tau[i__3].i;
i__4 = j;
z__2.r = e[i__4] * z__3.r, z__2.i = e[i__4] * z__3.i;
i__5 = jr + j * v_dim1;
z__1.r = z__2.r * v[i__5].r - z__2.i * v[i__5].i,
z__1.i = z__2.r * v[i__5].i + z__2.i * v[i__5]
.r;
work[i__2].r = z__1.r, work[i__2].i = z__1.i;
/* L30: */
}
}
i__1 = j + 1 + j * v_dim1;
vsave.r = v[i__1].r, vsave.i = v[i__1].i;
i__1 = j + 1 + j * v_dim1;
v[i__1].r = 1., v[i__1].i = 0.;
i__1 = *n - j;
/* Computing 2nd power */
i__2 = *n;
zlarfy_("L", &i__1, &v[j + 1 + j * v_dim1], &c__1, &tau[j], &
work[(*n + 1) * j + 1], n, &work[i__2 * i__2 + 1]);
i__1 = j + 1 + j * v_dim1;
v[i__1].r = vsave.r, v[i__1].i = vsave.i;
i__1 = (*n + 1) * (j - 1) + 1;
i__2 = j;
work[i__1].r = d__[i__2], work[i__1].i = 0.;
/* L40: */
}
} else {
work[1].r = d__[1], work[1].i = 0.;
i__1 = *n - 1;
for (j = 1; j <= i__1; ++j) {
if (*kband == 1) {
i__2 = (*n + 1) * j;
i__3 = j;
z__2.r = 1. - tau[i__3].r, z__2.i = 0. - tau[i__3].i;
i__4 = j;
z__1.r = e[i__4] * z__2.r, z__1.i = e[i__4] * z__2.i;
work[i__2].r = z__1.r, work[i__2].i = z__1.i;
i__2 = j - 1;
for (jr = 1; jr <= i__2; ++jr) {
i__3 = j * *n + jr;
i__4 = j;
z__3.r = -tau[i__4].r, z__3.i = -tau[i__4].i;
i__5 = j;
z__2.r = e[i__5] * z__3.r, z__2.i = e[i__5] * z__3.i;
i__6 = jr + (j + 1) * v_dim1;
z__1.r = z__2.r * v[i__6].r - z__2.i * v[i__6].i,
z__1.i = z__2.r * v[i__6].i + z__2.i * v[i__6]
.r;
work[i__3].r = z__1.r, work[i__3].i = z__1.i;
/* L50: */
}
}
i__2 = j + (j + 1) * v_dim1;
vsave.r = v[i__2].r, vsave.i = v[i__2].i;
i__2 = j + (j + 1) * v_dim1;
v[i__2].r = 1., v[i__2].i = 0.;
/* Computing 2nd power */
i__2 = *n;
zlarfy_("U", &j, &v[(j + 1) * v_dim1 + 1], &c__1, &tau[j], &
work[1], n, &work[i__2 * i__2 + 1]);
i__2 = j + (j + 1) * v_dim1;
v[i__2].r = vsave.r, v[i__2].i = vsave.i;
i__2 = (*n + 1) * j + 1;
i__3 = j + 1;
work[i__2].r = d__[i__3], work[i__2].i = 0.;
/* L60: */
}
}
i__1 = *n;
for (jcol = 1; jcol <= i__1; ++jcol) {
if (lower) {
i__2 = *n;
for (jrow = jcol; jrow <= i__2; ++jrow) {
i__3 = jrow + *n * (jcol - 1);
i__4 = jrow + *n * (jcol - 1);
i__5 = jrow + jcol * a_dim1;
z__1.r = work[i__4].r - a[i__5].r, z__1.i = work[i__4].i
- a[i__5].i;
work[i__3].r = z__1.r, work[i__3].i = z__1.i;
/* L70: */
}
} else {
i__2 = jcol;
for (jrow = 1; jrow <= i__2; ++jrow) {
i__3 = jrow + *n * (jcol - 1);
i__4 = jrow + *n * (jcol - 1);
i__5 = jrow + jcol * a_dim1;
z__1.r = work[i__4].r - a[i__5].r, z__1.i = work[i__4].i
- a[i__5].i;
work[i__3].r = z__1.r, work[i__3].i = z__1.i;
/* L80: */
}
}
/* L90: */
}
wnorm = zlanhe_("1", cuplo, n, &work[1], n, &rwork[1]);
} else if (*itype == 3) {
/* ITYPE=3: error = U V* - I */
if (*n < 2) {
return 0;
}
zlacpy_(" ", n, n, &u[u_offset], ldu, &work[1], n);
if (lower) {
i__1 = *n - 1;
i__2 = *n - 1;
/* Computing 2nd power */
i__3 = *n;
zunm2r_("R", "C", n, &i__1, &i__2, &v[v_dim1 + 2], ldv, &tau[1], &
work[*n + 1], n, &work[i__3 * i__3 + 1], &iinfo);
} else {
i__1 = *n - 1;
i__2 = *n - 1;
/* Computing 2nd power */
i__3 = *n;
zunm2l_("R", "C", n, &i__1, &i__2, &v[(v_dim1 << 1) + 1], ldv, &
tau[1], &work[1], n, &work[i__3 * i__3 + 1], &iinfo);
}
if (iinfo != 0) {
result[1] = 10. / ulp;
return 0;
}
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
i__2 = (*n + 1) * (j - 1) + 1;
i__3 = (*n + 1) * (j - 1) + 1;
z__1.r = work[i__3].r - 1., z__1.i = work[i__3].i - 0.;
work[i__2].r = z__1.r, work[i__2].i = z__1.i;
/* L100: */
}
wnorm = zlange_("1", n, n, &work[1], n, &rwork[1]);
}
if (anorm > wnorm) {
result[1] = wnorm / anorm / (*n * ulp);
} else {
if (anorm < 1.) {
/* Computing MIN */
d__1 = wnorm, d__2 = *n * anorm;
result[1] = min(d__1,d__2) / anorm / (*n * ulp);
} else {
/* Computing MIN */
d__1 = wnorm / anorm, d__2 = (doublereal) (*n);
result[1] = min(d__1,d__2) / (*n * ulp);
}
}
/* Do Test 2 */
/* Compute UU* - I */
if (*itype == 1) {
zgemm_("N", "C", n, n, n, &c_b2, &u[u_offset], ldu, &u[u_offset], ldu,
&c_b1, &work[1], n);
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
i__2 = (*n + 1) * (j - 1) + 1;
i__3 = (*n + 1) * (j - 1) + 1;
z__1.r = work[i__3].r - 1., z__1.i = work[i__3].i - 0.;
work[i__2].r = z__1.r, work[i__2].i = z__1.i;
/* L110: */
}
/* Computing MIN */
d__1 = zlange_("1", n, n, &work[1], n, &rwork[1]), d__2 = (
doublereal) (*n);
result[2] = min(d__1,d__2) / (*n * ulp);
}
return 0;
/* End of ZHET21 */
} /* zhet21_ */
