int
f2c_cher(char* uplo, integer* N,
real* alpha,
complex* X, integer* incX,
complex* A, integer* lda)
{
cher_(uplo, N, alpha,
X, incX, A, lda);
return 0;
}
int cpbstf_(char *uplo, int *n, int *kd, complex *ab,
int *ldab, int *info)
{
/* System generated locals */
int ab_dim1, ab_offset, i__1, i__2, i__3;
float r__1;
/* Builtin functions */
double sqrt(double);
/* Local variables */
int j, m, km;
float ajj;
int kld;
extern int cher_(char *, int *, float *, complex *,
int *, complex *, int *);
extern int lsame_(char *, char *);
int upper;
extern int clacgv_(int *, complex *, int *),
csscal_(int *, float *, complex *, int *), xerbla_(char *,
int *);
/* -- LAPACK routine (version 3.2) -- */
/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/* November 2006 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* CPBSTF computes a split Cholesky factorization of a complex */
/* Hermitian positive definite band matrix A. */
/* This routine is designed to be used in conjunction with CHBGST. */
/* 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 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 * * */
/* Array elements marked * are not used by the routine; s12' denotes */
/* conjg(s12); the diagonal elements of S are float. */
/* ===================================================================== */
/* .. 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_("CPBSTF", &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 >= i__1; --j) {
/* Compute s(j,j) and test for non-positive-definiteness. */
i__2 = *kd + 1 + j * ab_dim1;
ajj = ab[i__2].r;
if (ajj <= 0.f) {
i__2 = *kd + 1 + j * ab_dim1;
ab[i__2].r = ajj, ab[i__2].i = 0.f;
goto L50;
}
ajj = sqrt(ajj);
i__2 = *kd + 1 + j * ab_dim1;
ab[i__2].r = ajj, ab[i__2].i = 0.f;
/* Computing MIN */
i__2 = j - 1;
km = MIN(i__2,*kd);
/* Compute elements j-km:j-1 of the j-th column and update the */
/* the leading submatrix within the band. */
r__1 = 1.f / ajj;
csscal_(&km, &r__1, &ab[*kd + 1 - km + j * ab_dim1], &c__1);
cher_("Upper", &km, &c_b9, &ab[*kd + 1 - km + j * ab_dim1], &c__1,
&ab[*kd + 1 + (j - km) * ab_dim1], &kld);
/* L10: */
}
/* Factorize the updated submatrix A(1:m,1:m) as U**H*U. */
i__1 = m;
for (j = 1; j <= i__1; ++j) {
/* Compute s(j,j) and test for non-positive-definiteness. */
i__2 = *kd + 1 + j * ab_dim1;
ajj = ab[i__2].r;
if (ajj <= 0.f) {
i__2 = *kd + 1 + j * ab_dim1;
ab[i__2].r = ajj, ab[i__2].i = 0.f;
goto L50;
}
ajj = sqrt(ajj);
i__2 = *kd + 1 + j * ab_dim1;
ab[i__2].r = ajj, ab[i__2].i = 0.f;
/* 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) {
r__1 = 1.f / ajj;
csscal_(&km, &r__1, &ab[*kd + (j + 1) * ab_dim1], &kld);
clacgv_(&km, &ab[*kd + (j + 1) * ab_dim1], &kld);
cher_("Upper", &km, &c_b9, &ab[*kd + (j + 1) * ab_dim1], &kld,
&ab[*kd + 1 + (j + 1) * ab_dim1], &kld);
clacgv_(&km, &ab[*kd + (j + 1) * ab_dim1], &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 >= i__1; --j) {
/* Compute s(j,j) and test for non-positive-definiteness. */
i__2 = j * ab_dim1 + 1;
ajj = ab[i__2].r;
if (ajj <= 0.f) {
i__2 = j * ab_dim1 + 1;
ab[i__2].r = ajj, ab[i__2].i = 0.f;
goto L50;
}
ajj = sqrt(ajj);
i__2 = j * ab_dim1 + 1;
ab[i__2].r = ajj, ab[i__2].i = 0.f;
/* 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. */
r__1 = 1.f / ajj;
csscal_(&km, &r__1, &ab[km + 1 + (j - km) * ab_dim1], &kld);
clacgv_(&km, &ab[km + 1 + (j - km) * ab_dim1], &kld);
cher_("Lower", &km, &c_b9, &ab[km + 1 + (j - km) * ab_dim1], &kld,
&ab[(j - km) * ab_dim1 + 1], &kld);
clacgv_(&km, &ab[km + 1 + (j - km) * ab_dim1], &kld);
/* L30: */
}
/* Factorize the updated submatrix A(1:m,1:m) as U**H*U. */
i__1 = m;
for (j = 1; j <= i__1; ++j) {
/* Compute s(j,j) and test for non-positive-definiteness. */
i__2 = j * ab_dim1 + 1;
ajj = ab[i__2].r;
if (ajj <= 0.f) {
i__2 = j * ab_dim1 + 1;
ab[i__2].r = ajj, ab[i__2].i = 0.f;
goto L50;
}
ajj = sqrt(ajj);
i__2 = j * ab_dim1 + 1;
ab[i__2].r = ajj, ab[i__2].i = 0.f;
/* 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 update the */
/* trailing submatrix within the band. */
if (km > 0) {
r__1 = 1.f / ajj;
csscal_(&km, &r__1, &ab[j * ab_dim1 + 2], &c__1);
cher_("Lower", &km, &c_b9, &ab[j * ab_dim1 + 2], &c__1, &ab[(
j + 1) * ab_dim1 + 1], &kld);
}
/* L40: */
}
}
return 0;
L50:
*info = j;
return 0;
/* End of CPBSTF */
} /* cpbstf_ */
void
cher(char uplo, int n, float alpha, complex *x, int incx, complex *a, int lda)
{
cher_( &uplo, &n, &alpha, x, &incx, a, &lda);
}
/* Subroutine */ int cpst01_(char *uplo, integer *n, complex *a, integer *lda,
complex *afac, integer *ldafac, complex *perm, integer *ldperm,
integer *piv, real *rwork, real *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;
real r__1;
complex q__1;
/* Local variables */
integer i__, j, k;
complex tc;
real tr, eps;
real anorm;
/* -- LAPACK test routine (version 3.1) -- */
/* Craig Lucas, University of Manchester / NAG Ltd. */
/* October, 2008 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* CPST01 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 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 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 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) REAL array, dimension (N) */
/* RESID (output) REAL */
/* 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.f;
return 0;
}
/* Exit with RESID = 1/EPS if ANORM = 0. */
eps = slamch_("Epsilon");
anorm = clanhe_("1", uplo, n, &a[a_offset], lda, &rwork[1]);
if (anorm <= 0.f) {
*resid = 1.f / 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 (r_imag(&afac[j + j * afac_dim1]) != 0.f) {
*resid = 1.f / 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.f, afac[i__3].i = 0.f;
/* L110: */
}
/* L120: */
}
}
for (k = *n; k >= 1; --k) {
/* Compute the (K,K) element of the result. */
cdotc_(&q__1, &k, &afac[k * afac_dim1 + 1], &c__1, &afac[k *
afac_dim1 + 1], &c__1);
tr = q__1.r;
i__1 = k + k * afac_dim1;
afac[i__1].r = tr, afac[i__1].i = 0.f;
/* Compute the rest of column K. */
i__1 = k - 1;
ctrmv_("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.f, afac[i__3].i = 0.f;
/* 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;
cher_("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;
cscal_(&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;
r_cnjg(&q__1, &afac[j + i__ * afac_dim1]);
perm[i__3].r = q__1.r, perm[i__3].i = q__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;
r_cnjg(&q__1, &afac[j + i__ * afac_dim1]);
perm[i__3].r = q__1.r, perm[i__3].i = q__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;
q__1.r = perm[i__4].r - a[i__5].r, q__1.i = perm[i__4].i - a[
i__5].i;
perm[i__3].r = q__1.r, perm[i__3].i = q__1.i;
/* L210: */
}
i__2 = j + j * perm_dim1;
i__3 = j + j * perm_dim1;
i__4 = j + j * a_dim1;
r__1 = a[i__4].r;
q__1.r = perm[i__3].r - r__1, q__1.i = perm[i__3].i;
perm[i__2].r = q__1.r, perm[i__2].i = q__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;
r__1 = a[i__4].r;
q__1.r = perm[i__3].r - r__1, q__1.i = perm[i__3].i;
perm[i__2].r = q__1.r, perm[i__2].i = q__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;
q__1.r = perm[i__4].r - a[i__5].r, q__1.i = perm[i__4].i - a[
i__5].i;
perm[i__3].r = q__1.r, perm[i__3].i = q__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 = clanhe_("1", uplo, n, &perm[perm_offset], ldafac, &rwork[1]);
*resid = *resid / (real) (*n) / anorm / eps;
return 0;
/* End of CPST01 */
} /* cpst01_ */
/* Subroutine */
int cpbtf2_(char *uplo, integer *n, integer *kd, complex *ab, integer *ldab, integer *info)
{
/* System generated locals */
integer ab_dim1, ab_offset, i__1, i__2, i__3;
real r__1;
/* Builtin functions */
double sqrt(doublereal);
/* Local variables */
integer j, kn;
real ajj;
integer kld;
extern /* Subroutine */
int cher_(char *, integer *, real *, complex *, integer *, complex *, integer *);
extern logical lsame_(char *, char *);
logical upper;
extern /* Subroutine */
int clacgv_(integer *, complex *, integer *), csscal_(integer *, real *, complex *, integer *), xerbla_(char *, integer *);
/* -- LAPACK computational routine (version 3.4.2) -- */
/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */
/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */
/* September 2012 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* ===================================================================== */
/* .. 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_("CPBTF2", &i__1);
return 0;
}
/* Quick return if possible */
if (*n == 0)
{
return 0;
}
/* Computing MAX */
i__1 = 1;
i__2 = *ldab - 1; // , expr subst
kld = max(i__1,i__2);
if (upper)
{
/* Compute the Cholesky factorization A = U**H * 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.f)
{
i__2 = *kd + 1 + j * ab_dim1;
ab[i__2].r = ajj;
ab[i__2].i = 0.f; // , expr subst
goto L30;
}
ajj = sqrt(ajj);
i__2 = *kd + 1 + j * ab_dim1;
ab[i__2].r = ajj;
ab[i__2].i = 0.f; // , expr subst
/* 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; // , expr subst
kn = min(i__2,i__3);
if (kn > 0)
{
r__1 = 1.f / ajj;
csscal_(&kn, &r__1, &ab[*kd + (j + 1) * ab_dim1], &kld);
clacgv_(&kn, &ab[*kd + (j + 1) * ab_dim1], &kld);
cher_("Upper", &kn, &c_b8, &ab[*kd + (j + 1) * ab_dim1], &kld, &ab[*kd + 1 + (j + 1) * ab_dim1], &kld);
clacgv_(&kn, &ab[*kd + (j + 1) * ab_dim1], &kld);
}
/* L10: */
}
}
else
{
/* Compute the Cholesky factorization A = L*L**H. */
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.f)
{
i__2 = j * ab_dim1 + 1;
ab[i__2].r = ajj;
ab[i__2].i = 0.f; // , expr subst
goto L30;
}
ajj = sqrt(ajj);
i__2 = j * ab_dim1 + 1;
ab[i__2].r = ajj;
ab[i__2].i = 0.f; // , expr subst
/* 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; // , expr subst
kn = min(i__2,i__3);
if (kn > 0)
{
r__1 = 1.f / ajj;
csscal_(&kn, &r__1, &ab[j * ab_dim1 + 2], &c__1);
cher_("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 CPBTF2 */
}
/* Subroutine */ int chetf2_(char *uplo, integer *n, complex *a, integer *lda,
integer *ipiv, integer *info, ftnlen uplo_len)
{
/* System generated locals */
integer a_dim1, a_offset, i__1, i__2, i__3, i__4, i__5, i__6;
real r__1, r__2, r__3, r__4;
complex q__1, q__2, q__3, q__4, q__5, q__6;
/* Builtin functions */
double sqrt(doublereal), r_imag(complex *);
void r_cnjg(complex *, complex *);
/* Local variables */
static real d__;
static integer i__, j, k;
static complex t;
static real r1, d11;
static complex d12;
static real d22;
static complex d21;
static integer kk, kp;
static complex wk;
static real tt;
static complex wkm1, wkp1;
extern /* Subroutine */ int cher_(char *, integer *, real *, complex *,
integer *, complex *, integer *, ftnlen);
static integer imax, jmax;
static real alpha;
extern logical lsame_(char *, char *, ftnlen, ftnlen);
extern /* Subroutine */ int cswap_(integer *, complex *, integer *,
complex *, integer *);
static integer kstep;
static logical upper;
extern doublereal slapy2_(real *, real *);
static real absakk;
extern integer icamax_(integer *, complex *, integer *);
extern /* Subroutine */ int csscal_(integer *, real *, complex *, integer
*), xerbla_(char *, integer *, ftnlen);
static real colmax, rowmax;
/* -- LAPACK routine (version 3.0) -- */
/* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., */
/* Courant Institute, Argonne National Lab, and Rice University */
/* June 30, 1999 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* CHETF2 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 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 */
/* =============== */
/* 1-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", (ftnlen)1, (ftnlen)1);
if (! upper && ! lsame_(uplo, "L", (ftnlen)1, (ftnlen)1)) {
*info = -1;
} else if (*n < 0) {
*info = -2;
} else if (*lda < max(1,*n)) {
*info = -4;
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("CHETF2", &i__1, (ftnlen)6);
return 0;
}
/* Initialize ALPHA for use in choosing pivot block size. */
alpha = (sqrt(17.f) + 1.f) / 8.f;
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 = (r__1 = a[i__1].r, dabs(r__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 = icamax_(&i__1, &a[k * a_dim1 + 1], &c__1);
i__1 = imax + k * a_dim1;
colmax = (r__1 = a[i__1].r, dabs(r__1)) + (r__2 = r_imag(&a[imax
+ k * a_dim1]), dabs(r__2));
} else {
colmax = 0.f;
}
if (dmax(absakk,colmax) == 0.f) {
/* Column K is zero: set INFO and continue */
if (*info == 0) {
*info = k;
}
kp = k;
i__1 = k + k * a_dim1;
i__2 = k + k * a_dim1;
r__1 = a[i__2].r;
a[i__1].r = r__1, a[i__1].i = 0.f;
} 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 + icamax_(&i__1, &a[imax + (imax + 1) * a_dim1],
lda);
i__1 = imax + jmax * a_dim1;
rowmax = (r__1 = a[i__1].r, dabs(r__1)) + (r__2 = r_imag(&a[
imax + jmax * a_dim1]), dabs(r__2));
if (imax > 1) {
i__1 = imax - 1;
jmax = icamax_(&i__1, &a[imax * a_dim1 + 1], &c__1);
/* Computing MAX */
i__1 = jmax + imax * a_dim1;
r__3 = rowmax, r__4 = (r__1 = a[i__1].r, dabs(r__1)) + (
r__2 = r_imag(&a[jmax + imax * a_dim1]), dabs(
r__2));
rowmax = dmax(r__3,r__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 ((r__1 = a[i__1].r, dabs(r__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;
cswap_(&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) {
r_cnjg(&q__1, &a[j + kk * a_dim1]);
t.r = q__1.r, t.i = q__1.i;
i__2 = j + kk * a_dim1;
r_cnjg(&q__1, &a[kp + j * a_dim1]);
a[i__2].r = q__1.r, a[i__2].i = q__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;
r_cnjg(&q__1, &a[kp + kk * a_dim1]);
a[i__1].r = q__1.r, a[i__1].i = q__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;
r__1 = a[i__2].r;
a[i__1].r = r__1, a[i__1].i = 0.f;
i__1 = kp + kp * a_dim1;
a[i__1].r = r1, a[i__1].i = 0.f;
if (kstep == 2) {
i__1 = k + k * a_dim1;
i__2 = k + k * a_dim1;
r__1 = a[i__2].r;
a[i__1].r = r__1, a[i__1].i = 0.f;
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;
r__1 = a[i__2].r;
a[i__1].r = r__1, a[i__1].i = 0.f;
if (kstep == 2) {
i__1 = k - 1 + (k - 1) * a_dim1;
i__2 = k - 1 + (k - 1) * a_dim1;
r__1 = a[i__2].r;
a[i__1].r = r__1, a[i__1].i = 0.f;
}
}
/* 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.f / a[i__1].r;
i__1 = k - 1;
r__1 = -r1;
cher_(uplo, &i__1, &r__1, &a[k * a_dim1 + 1], &c__1, &a[
a_offset], lda, (ftnlen)1);
/* Store U(k) in column k */
i__1 = k - 1;
csscal_(&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;
r__1 = a[i__1].r;
r__2 = r_imag(&a[k - 1 + k * a_dim1]);
d__ = slapy2_(&r__1, &r__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.f / (d11 * d22 - 1.f);
i__1 = k - 1 + k * a_dim1;
q__1.r = a[i__1].r / d__, q__1.i = a[i__1].i / d__;
d12.r = q__1.r, d12.i = q__1.i;
d__ = tt / d__;
for (j = k - 2; j >= 1; --j) {
i__1 = j + (k - 1) * a_dim1;
q__3.r = d11 * a[i__1].r, q__3.i = d11 * a[i__1].i;
r_cnjg(&q__5, &d12);
i__2 = j + k * a_dim1;
q__4.r = q__5.r * a[i__2].r - q__5.i * a[i__2].i,
q__4.i = q__5.r * a[i__2].i + q__5.i * a[i__2]
.r;
q__2.r = q__3.r - q__4.r, q__2.i = q__3.i - q__4.i;
q__1.r = d__ * q__2.r, q__1.i = d__ * q__2.i;
wkm1.r = q__1.r, wkm1.i = q__1.i;
i__1 = j + k * a_dim1;
q__3.r = d22 * a[i__1].r, q__3.i = d22 * a[i__1].i;
i__2 = j + (k - 1) * a_dim1;
q__4.r = d12.r * a[i__2].r - d12.i * a[i__2].i,
q__4.i = d12.r * a[i__2].i + d12.i * a[i__2]
.r;
q__2.r = q__3.r - q__4.r, q__2.i = q__3.i - q__4.i;
q__1.r = d__ * q__2.r, q__1.i = d__ * q__2.i;
wk.r = q__1.r, wk.i = q__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;
r_cnjg(&q__4, &wk);
q__3.r = a[i__3].r * q__4.r - a[i__3].i * q__4.i,
q__3.i = a[i__3].r * q__4.i + a[i__3].i *
q__4.r;
q__2.r = a[i__2].r - q__3.r, q__2.i = a[i__2].i -
q__3.i;
i__4 = i__ + (k - 1) * a_dim1;
r_cnjg(&q__6, &wkm1);
q__5.r = a[i__4].r * q__6.r - a[i__4].i * q__6.i,
q__5.i = a[i__4].r * q__6.i + a[i__4].i *
q__6.r;
q__1.r = q__2.r - q__5.r, q__1.i = q__2.i -
q__5.i;
a[i__1].r = q__1.r, a[i__1].i = q__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;
r__1 = a[i__2].r;
q__1.r = r__1, q__1.i = 0.f;
a[i__1].r = q__1.r, a[i__1].i = q__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 = (r__1 = a[i__1].r, dabs(r__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 + icamax_(&i__1, &a[k + 1 + k * a_dim1], &c__1);
i__1 = imax + k * a_dim1;
colmax = (r__1 = a[i__1].r, dabs(r__1)) + (r__2 = r_imag(&a[imax
+ k * a_dim1]), dabs(r__2));
} else {
colmax = 0.f;
}
if (dmax(absakk,colmax) == 0.f) {
/* Column K is zero: set INFO and continue */
if (*info == 0) {
*info = k;
}
kp = k;
i__1 = k + k * a_dim1;
i__2 = k + k * a_dim1;
r__1 = a[i__2].r;
a[i__1].r = r__1, a[i__1].i = 0.f;
} 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 + icamax_(&i__1, &a[imax + k * a_dim1], lda);
i__1 = imax + jmax * a_dim1;
rowmax = (r__1 = a[i__1].r, dabs(r__1)) + (r__2 = r_imag(&a[
imax + jmax * a_dim1]), dabs(r__2));
if (imax < *n) {
i__1 = *n - imax;
jmax = imax + icamax_(&i__1, &a[imax + 1 + imax * a_dim1],
&c__1);
/* Computing MAX */
i__1 = jmax + imax * a_dim1;
r__3 = rowmax, r__4 = (r__1 = a[i__1].r, dabs(r__1)) + (
r__2 = r_imag(&a[jmax + imax * a_dim1]), dabs(
r__2));
rowmax = dmax(r__3,r__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 ((r__1 = a[i__1].r, dabs(r__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;
cswap_(&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) {
r_cnjg(&q__1, &a[j + kk * a_dim1]);
t.r = q__1.r, t.i = q__1.i;
i__2 = j + kk * a_dim1;
r_cnjg(&q__1, &a[kp + j * a_dim1]);
a[i__2].r = q__1.r, a[i__2].i = q__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;
r_cnjg(&q__1, &a[kp + kk * a_dim1]);
a[i__1].r = q__1.r, a[i__1].i = q__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;
r__1 = a[i__2].r;
a[i__1].r = r__1, a[i__1].i = 0.f;
i__1 = kp + kp * a_dim1;
a[i__1].r = r1, a[i__1].i = 0.f;
if (kstep == 2) {
i__1 = k + k * a_dim1;
i__2 = k + k * a_dim1;
r__1 = a[i__2].r;
a[i__1].r = r__1, a[i__1].i = 0.f;
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;
r__1 = a[i__2].r;
a[i__1].r = r__1, a[i__1].i = 0.f;
if (kstep == 2) {
i__1 = k + 1 + (k + 1) * a_dim1;
i__2 = k + 1 + (k + 1) * a_dim1;
r__1 = a[i__2].r;
a[i__1].r = r__1, a[i__1].i = 0.f;
}
}
/* 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.f / a[i__1].r;
i__1 = *n - k;
r__1 = -r1;
cher_(uplo, &i__1, &r__1, &a[k + 1 + k * a_dim1], &c__1, &
a[k + 1 + (k + 1) * a_dim1], lda, (ftnlen)1);
/* Store L(k) in column K */
i__1 = *n - k;
csscal_(&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;
r__1 = a[i__1].r;
r__2 = r_imag(&a[k + 1 + k * a_dim1]);
d__ = slapy2_(&r__1, &r__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.f / (d11 * d22 - 1.f);
i__1 = k + 1 + k * a_dim1;
q__1.r = a[i__1].r / d__, q__1.i = a[i__1].i / d__;
d21.r = q__1.r, d21.i = q__1.i;
d__ = tt / d__;
i__1 = *n;
for (j = k + 2; j <= i__1; ++j) {
i__2 = j + k * a_dim1;
q__3.r = d11 * a[i__2].r, q__3.i = d11 * a[i__2].i;
i__3 = j + (k + 1) * a_dim1;
q__4.r = d21.r * a[i__3].r - d21.i * a[i__3].i,
q__4.i = d21.r * a[i__3].i + d21.i * a[i__3]
.r;
q__2.r = q__3.r - q__4.r, q__2.i = q__3.i - q__4.i;
q__1.r = d__ * q__2.r, q__1.i = d__ * q__2.i;
wk.r = q__1.r, wk.i = q__1.i;
i__2 = j + (k + 1) * a_dim1;
q__3.r = d22 * a[i__2].r, q__3.i = d22 * a[i__2].i;
r_cnjg(&q__5, &d21);
i__3 = j + k * a_dim1;
q__4.r = q__5.r * a[i__3].r - q__5.i * a[i__3].i,
q__4.i = q__5.r * a[i__3].i + q__5.i * a[i__3]
.r;
q__2.r = q__3.r - q__4.r, q__2.i = q__3.i - q__4.i;
q__1.r = d__ * q__2.r, q__1.i = d__ * q__2.i;
wkp1.r = q__1.r, wkp1.i = q__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;
r_cnjg(&q__4, &wk);
q__3.r = a[i__5].r * q__4.r - a[i__5].i * q__4.i,
q__3.i = a[i__5].r * q__4.i + a[i__5].i *
q__4.r;
q__2.r = a[i__4].r - q__3.r, q__2.i = a[i__4].i -
q__3.i;
i__6 = i__ + (k + 1) * a_dim1;
r_cnjg(&q__6, &wkp1);
q__5.r = a[i__6].r * q__6.r - a[i__6].i * q__6.i,
q__5.i = a[i__6].r * q__6.i + a[i__6].i *
q__6.r;
q__1.r = q__2.r - q__5.r, q__1.i = q__2.i -
q__5.i;
a[i__3].r = q__1.r, a[i__3].i = q__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;
r__1 = a[i__3].r;
q__1.r = r__1, q__1.i = 0.f;
a[i__2].r = q__1.r, a[i__2].i = q__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 CHETF2 */
} /* chetf2_ */
/* Subroutine */ int cpbtf2_(char *uplo, integer *n, integer *kd, complex *ab,
integer *ldab, integer *info, ftnlen uplo_len)
{
/* System generated locals */
integer ab_dim1, ab_offset, i__1, i__2, i__3;
real r__1;
/* Builtin functions */
double sqrt(doublereal);
/* Local variables */
static integer j, kn;
static real ajj;
static integer kld;
extern /* Subroutine */ int cher_(char *, integer *, real *, complex *,
integer *, complex *, integer *, ftnlen);
extern logical lsame_(char *, char *, ftnlen, ftnlen);
static logical upper;
extern /* Subroutine */ int clacgv_(integer *, complex *, integer *),
csscal_(integer *, real *, complex *, integer *), xerbla_(char *,
integer *, ftnlen);
/* -- 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 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* CPBTF2 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 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", (ftnlen)1, (ftnlen)1);
if (! upper && ! lsame_(uplo, "L", (ftnlen)1, (ftnlen)1)) {
*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_("CPBTF2", &i__1, (ftnlen)6);
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.f) {
i__2 = *kd + 1 + j * ab_dim1;
ab[i__2].r = ajj, ab[i__2].i = 0.f;
goto L30;
}
ajj = sqrt(ajj);
i__2 = *kd + 1 + j * ab_dim1;
ab[i__2].r = ajj, ab[i__2].i = 0.f;
/* 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) {
r__1 = 1.f / ajj;
csscal_(&kn, &r__1, &ab[*kd + (j + 1) * ab_dim1], &kld);
clacgv_(&kn, &ab[*kd + (j + 1) * ab_dim1], &kld);
cher_("Upper", &kn, &c_b8, &ab[*kd + (j + 1) * ab_dim1], &kld,
&ab[*kd + 1 + (j + 1) * ab_dim1], &kld, (ftnlen)5);
clacgv_(&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.f) {
i__2 = j * ab_dim1 + 1;
ab[i__2].r = ajj, ab[i__2].i = 0.f;
goto L30;
}
ajj = sqrt(ajj);
i__2 = j * ab_dim1 + 1;
ab[i__2].r = ajj, ab[i__2].i = 0.f;
/* 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) {
r__1 = 1.f / ajj;
csscal_(&kn, &r__1, &ab[j * ab_dim1 + 2], &c__1);
cher_("Lower", &kn, &c_b8, &ab[j * ab_dim1 + 2], &c__1, &ab[(
j + 1) * ab_dim1 + 1], &kld, (ftnlen)5);
}
/* L20: */
}
}
return 0;
L30:
*info = j;
return 0;
/* End of CPBTF2 */
} /* cpbtf2_ */
/* Subroutine */ int cpbt01_(char *uplo, integer *n, integer *kd, complex *a,
integer *lda, complex *afac, integer *ldafac, real *rwork, real *
resid)
{
/* System generated locals */
integer a_dim1, a_offset, afac_dim1, afac_offset, i__1, i__2, i__3, i__4,
i__5;
complex q__1;
/* Builtin functions */
double r_imag(complex *);
/* Local variables */
integer i__, j, k, kc, ml, mu;
real akk, eps;
extern /* Subroutine */ int cher_(char *, integer *, real *, complex *,
integer *, complex *, integer *);
integer klen;
extern /* Complex */ VOID cdotc_(complex *, integer *, complex *, integer
*, complex *, integer *);
extern logical lsame_(char *, char *);
real anorm;
extern /* Subroutine */ int ctrmv_(char *, char *, char *, integer *,
complex *, integer *, complex *, integer *);
extern doublereal clanhb_(char *, char *, integer *, integer *, complex *,
integer *, real *), slamch_(char *);
extern /* Subroutine */ int csscal_(integer *, real *, complex *, integer
*);
/* -- LAPACK test routine (version 3.1) -- */
/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/* November 2006 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* CPBT01 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 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 CPBTRF for further details. */
/* LDA (input) INTEGER. */
/* The leading dimension of the array A. LDA >= max(1,KD+1). */
/* AFAC (input) COMPLEX 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 CPBTRF. */
/* LDAFAC (input) INTEGER */
/* The leading dimension of the array AFAC. */
/* LDAFAC >= max(1,KD+1). */
/* RWORK (workspace) REAL array, dimension (N) */
/* RESID (output) REAL */
/* 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;
--rwork;
/* Function Body */
if (*n <= 0) {
*resid = 0.f;
return 0;
}
/* Exit with RESID = 1/EPS if ANORM = 0. */
eps = slamch_("Epsilon");
anorm = clanhb_("1", uplo, n, kd, &a[a_offset], lda, &rwork[1]);
if (anorm <= 0.f) {
*resid = 1.f / 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 (r_imag(&afac[*kd + 1 + j * afac_dim1]) != 0.f) {
*resid = 1.f / eps;
return 0;
}
/* L10: */
}
} else {
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
if (r_imag(&afac[j * afac_dim1 + 1]) != 0.f) {
*resid = 1.f / 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;
cdotc_(&q__1, &i__1, &afac[kc + k * afac_dim1], &c__1, &afac[kc +
k * afac_dim1], &c__1);
akk = q__1.r;
i__1 = *kd + 1 + k * afac_dim1;
afac[i__1].r = akk, afac[i__1].i = 0.f;
/* Compute the rest of column K. */
if (klen > 0) {
i__1 = *ldafac - 1;
ctrmv_("Upper", "Conjugate", "Non-unit", &klen, &afac[*kd + 1
+ (k - klen) * afac_dim1], &i__1, &afac[kc + k *
afac_dim1], &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;
cher_("Lower", &klen, &c_b17, &afac[k * afac_dim1 + 2], &c__1,
&afac[(k + 1) * afac_dim1 + 1], &i__1);
}
/* Scale column K by the diagonal element. */
i__1 = k * afac_dim1 + 1;
akk = afac[i__1].r;
i__1 = klen + 1;
csscal_(&i__1, &akk, &afac[k * afac_dim1 + 1], &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 = i__ + j * afac_dim1;
i__4 = i__ + j * afac_dim1;
i__5 = i__ + j * a_dim1;
q__1.r = afac[i__4].r - a[i__5].r, q__1.i = afac[i__4].i - a[
i__5].i;
afac[i__3].r = q__1.r, afac[i__3].i = q__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 = i__ + j * afac_dim1;
i__4 = i__ + j * afac_dim1;
i__5 = i__ + j * a_dim1;
q__1.r = afac[i__4].r - a[i__5].r, q__1.i = afac[i__4].i - a[
i__5].i;
afac[i__3].r = q__1.r, afac[i__3].i = q__1.i;
/* L70: */
}
/* L80: */
}
}
/* Compute norm( L*L' - A ) / ( N * norm(A) * EPS ) */
*resid = clanhb_("1", uplo, n, kd, &afac[afac_offset], ldafac, &rwork[1]);
*resid = *resid / (real) (*n) / anorm / eps;
return 0;
/* End of CPBT01 */
} /* cpbt01_ */
/* Subroutine */ int cstt21_(integer *n, integer *kband, real *ad, real *ae,
real *sd, real *se, complex *u, integer *ldu, complex *work, real *
rwork, real *result)
{
/* System generated locals */
integer u_dim1, u_offset, i__1, i__2, i__3;
real r__1, r__2, r__3;
complex q__1, q__2;
/* Local variables */
extern /* Subroutine */ int cher_(char *, integer *, real *, complex *,
integer *, complex *, integer *);
static real unfl;
extern /* Subroutine */ int cher2_(char *, integer *, complex *, complex *
, integer *, complex *, integer *, complex *, integer *);
static real temp1, temp2;
static integer j;
extern /* Subroutine */ int cgemm_(char *, char *, integer *, integer *,
integer *, complex *, complex *, integer *, complex *, integer *,
complex *, complex *, integer *);
static real anorm, wnorm;
extern doublereal clange_(char *, integer *, integer *, complex *,
integer *, real *), clanhe_(char *, char *, integer *,
complex *, integer *, real *), slamch_(char *);
extern /* Subroutine */ int claset_(char *, integer *, integer *, complex
*, complex *, complex *, integer *);
static real ulp;
#define u_subscr(a_1,a_2) (a_2)*u_dim1 + a_1
#define u_ref(a_1,a_2) u[u_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
=======
CSTT21 checks a decomposition of the form
A = U S U*
where * means conjugate transpose, A is real symmetric tridiagonal,
U is unitary, and S is real and diagonal (if KBAND=0) or symmetric
tridiagonal (if KBAND=1). Two tests are performed:
RESULT(1) = | A - U S U* | / ( |A| n ulp )
RESULT(2) = | I - UU* | / ( n ulp )
Arguments
=========
N (input) INTEGER
The size of the matrix. If it is zero, CSTT21 does nothing.
It must be at least zero.
KBAND (input) INTEGER
The bandwidth of the matrix S. It may only be zero or one.
If zero, then S is diagonal, and SE is not referenced. If
one, then S is symmetric tri-diagonal.
AD (input) REAL array, dimension (N)
The diagonal of the original (unfactored) matrix A. A is
assumed to be real symmetric tridiagonal.
AE (input) REAL array, dimension (N-1)
The off-diagonal of the original (unfactored) matrix A. A
is assumed to be symmetric tridiagonal. AE(1) is the (1,2)
and (2,1) element, AE(2) is the (2,3) and (3,2) element, etc.
SD (input) REAL array, dimension (N)
The diagonal of the real (symmetric tri-) diagonal matrix S.
SE (input) REAL array, dimension (N-1)
The off-diagonal of the (symmetric tri-) diagonal matrix S.
Not referenced if KBSND=0. If KBAND=1, then AE(1) is the
(1,2) and (2,1) element, SE(2) is the (2,3) and (3,2)
element, etc.
U (input) COMPLEX array, dimension (LDU, N)
The unitary matrix in the decomposition.
LDU (input) INTEGER
The leading dimension of U. LDU must be at least N.
WORK (workspace) COMPLEX array, dimension (N**2)
RWORK (workspace) REAL array, dimension (N)
RESULT (output) REAL 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.
=====================================================================
1) Constants
Parameter adjustments */
--ad;
--ae;
--sd;
--se;
u_dim1 = *ldu;
u_offset = 1 + u_dim1 * 1;
u -= u_offset;
--work;
--rwork;
--result;
/* Function Body */
result[1] = 0.f;
result[2] = 0.f;
if (*n <= 0) {
return 0;
}
unfl = slamch_("Safe minimum");
ulp = slamch_("Precision");
/* Do Test 1
Copy A & Compute its 1-Norm: */
claset_("Full", n, n, &c_b1, &c_b1, &work[1], n);
anorm = 0.f;
temp1 = 0.f;
i__1 = *n - 1;
for (j = 1; j <= i__1; ++j) {
i__2 = (*n + 1) * (j - 1) + 1;
i__3 = j;
work[i__2].r = ad[i__3], work[i__2].i = 0.f;
i__2 = (*n + 1) * (j - 1) + 2;
i__3 = j;
work[i__2].r = ae[i__3], work[i__2].i = 0.f;
temp2 = (r__1 = ae[j], dabs(r__1));
/* Computing MAX */
r__2 = anorm, r__3 = (r__1 = ad[j], dabs(r__1)) + temp1 + temp2;
anorm = dmax(r__2,r__3);
temp1 = temp2;
/* L10: */
}
/* Computing 2nd power */
i__2 = *n;
i__1 = i__2 * i__2;
i__3 = *n;
work[i__1].r = ad[i__3], work[i__1].i = 0.f;
/* Computing MAX */
r__2 = anorm, r__3 = (r__1 = ad[*n], dabs(r__1)) + temp1, r__2 = max(r__2,
r__3);
anorm = dmax(r__2,unfl);
/* Norm of A - USU* */
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
r__1 = -sd[j];
cher_("L", n, &r__1, &u_ref(1, j), &c__1, &work[1], n);
/* L20: */
}
if (*n > 1 && *kband == 1) {
i__1 = *n - 1;
for (j = 1; j <= i__1; ++j) {
i__2 = j;
q__2.r = se[i__2], q__2.i = 0.f;
q__1.r = -q__2.r, q__1.i = -q__2.i;
cher2_("L", n, &q__1, &u_ref(1, j), &c__1, &u_ref(1, j + 1), &
c__1, &work[1], n);
/* L30: */
}
}
wnorm = clanhe_("1", "L", n, &work[1], n, &rwork[1])
;
if (anorm > wnorm) {
result[1] = wnorm / anorm / (*n * ulp);
} else {
if (anorm < 1.f) {
/* Computing MIN */
r__1 = wnorm, r__2 = *n * anorm;
result[1] = dmin(r__1,r__2) / anorm / (*n * ulp);
} else {
/* Computing MIN */
r__1 = wnorm / anorm, r__2 = (real) (*n);
result[1] = dmin(r__1,r__2) / (*n * ulp);
}
}
/* Do Test 2
Compute UU* - I */
cgemm_("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;
q__1.r = work[i__3].r - 1.f, q__1.i = work[i__3].i + 0.f;
work[i__2].r = q__1.r, work[i__2].i = q__1.i;
/* L40: */
}
/* Computing MIN */
r__1 = (real) (*n), r__2 = clange_("1", n, n, &work[1], n, &rwork[1]);
result[2] = dmin(r__1,r__2) / (*n * ulp);
return 0;
/* End of CSTT21 */
} /* cstt21_ */
/* Subroutine */ int cpot01_(char *uplo, integer *n, complex *a, integer *lda,
complex *afac, integer *ldafac, real *rwork, real *resid)
{
/* System generated locals */
integer a_dim1, a_offset, afac_dim1, afac_offset, i__1, i__2, i__3, i__4,
i__5;
real r__1;
complex q__1;
/* Local variables */
integer i__, j, k;
complex tc;
real tr, eps;
real anorm;
/* -- LAPACK test routine (version 3.1) -- */
/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/* November 2006 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* CPOT01 reconstructs a Hermitian positive definite 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. */
/* A (input) COMPLEX 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/output) COMPLEX array, dimension (LDAFAC,N) */
/* On entry, the factor L or U from the L*L' or U'*U */
/* factorization of A. */
/* Overwritten with the reconstructed matrix, and then with the */
/* difference L*L' - A (or U'*U - A). */
/* LDAFAC (input) INTEGER */
/* The leading dimension of the array AFAC. LDAFAC >= max(1,N). */
/* RWORK (workspace) REAL array, dimension (N) */
/* RESID (output) REAL */
/* 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;
--rwork;
/* Function Body */
if (*n <= 0) {
*resid = 0.f;
return 0;
}
/* Exit with RESID = 1/EPS if ANORM = 0. */
eps = slamch_("Epsilon");
anorm = clanhe_("1", uplo, n, &a[a_offset], lda, &rwork[1]);
if (anorm <= 0.f) {
*resid = 1.f / 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 (r_imag(&afac[j + j * afac_dim1]) != 0.f) {
*resid = 1.f / eps;
return 0;
}
/* L10: */
}
/* Compute the product U'*U, overwriting U. */
if (lsame_(uplo, "U")) {
for (k = *n; k >= 1; --k) {
/* Compute the (K,K) element of the result. */
cdotc_(&q__1, &k, &afac[k * afac_dim1 + 1], &c__1, &afac[k *
afac_dim1 + 1], &c__1);
tr = q__1.r;
i__1 = k + k * afac_dim1;
afac[i__1].r = tr, afac[i__1].i = 0.f;
/* Compute the rest of column K. */
i__1 = k - 1;
ctrmv_("Upper", "Conjugate", "Non-unit", &i__1, &afac[afac_offset]
, ldafac, &afac[k * afac_dim1 + 1], &c__1);
/* L20: */
}
/* Compute the product L*L', overwriting L. */
} else {
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;
cher_("Lower", &i__1, &c_b15, &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;
cscal_(&i__1, &tc, &afac[k + k * afac_dim1], &c__1);
/* L30: */
}
}
/* Compute the difference L*L' - A (or U'*U - 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 * afac_dim1;
i__4 = i__ + j * afac_dim1;
i__5 = i__ + j * a_dim1;
q__1.r = afac[i__4].r - a[i__5].r, q__1.i = afac[i__4].i - a[
i__5].i;
afac[i__3].r = q__1.r, afac[i__3].i = q__1.i;
/* L40: */
}
i__2 = j + j * afac_dim1;
i__3 = j + j * afac_dim1;
i__4 = j + j * a_dim1;
r__1 = a[i__4].r;
q__1.r = afac[i__3].r - r__1, q__1.i = afac[i__3].i;
afac[i__2].r = q__1.r, afac[i__2].i = q__1.i;
/* L50: */
}
} else {
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
i__2 = j + j * afac_dim1;
i__3 = j + j * afac_dim1;
i__4 = j + j * a_dim1;
r__1 = a[i__4].r;
q__1.r = afac[i__3].r - r__1, q__1.i = afac[i__3].i;
afac[i__2].r = q__1.r, afac[i__2].i = q__1.i;
i__2 = *n;
for (i__ = j + 1; i__ <= i__2; ++i__) {
i__3 = i__ + j * afac_dim1;
i__4 = i__ + j * afac_dim1;
i__5 = i__ + j * a_dim1;
q__1.r = afac[i__4].r - a[i__5].r, q__1.i = afac[i__4].i - a[
i__5].i;
afac[i__3].r = q__1.r, afac[i__3].i = q__1.i;
/* L60: */
}
/* L70: */
}
}
/* Compute norm( L*U - A ) / ( N * norm(A) * EPS ) */
*resid = clanhe_("1", uplo, n, &afac[afac_offset], ldafac, &rwork[1]);
*resid = *resid / (real) (*n) / anorm / eps;
return 0;
/* End of CPOT01 */
} /* cpot01_ */
/* Subroutine */ int chet21_(integer *itype, char *uplo, integer *n, integer *
kband, complex *a, integer *lda, real *d__, real *e, complex *u,
integer *ldu, complex *v, integer *ldv, complex *tau, complex *work,
real *rwork, real *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;
real r__1, r__2;
complex q__1, q__2, q__3;
/* Local variables */
integer j, jr;
real ulp;
extern /* Subroutine */ int cher_(char *, integer *, real *, complex *,
integer *, complex *, integer *);
integer jcol;
real unfl;
integer jrow;
extern /* Subroutine */ int cher2_(char *, integer *, complex *, complex *
, integer *, complex *, integer *, complex *, integer *),
cgemm_(char *, char *, integer *, integer *, integer *, complex *,
complex *, integer *, complex *, integer *, complex *, complex *,
integer *);
extern logical lsame_(char *, char *);
integer iinfo;
real anorm;
char cuplo[1];
complex vsave;
logical lower;
real wnorm;
extern /* Subroutine */ int cunm2l_(char *, char *, integer *, integer *,
integer *, complex *, integer *, complex *, complex *, integer *,
complex *, integer *), cunm2r_(char *, char *,
integer *, integer *, integer *, complex *, integer *, complex *,
complex *, integer *, complex *, integer *);
extern doublereal clange_(char *, integer *, integer *, complex *,
integer *, real *), clanhe_(char *, char *, integer *,
complex *, integer *, real *), slamch_(char *);
extern /* Subroutine */ int clacpy_(char *, integer *, integer *, complex
*, integer *, complex *, integer *), claset_(char *,
integer *, integer *, complex *, complex *, complex *, integer *), clarfy_(char *, integer *, complex *, integer *, complex
*, complex *, integer *, complex *);
/* -- LAPACK test routine (version 3.1) -- */
/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/* November 2006 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* CHET21 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, CHET21 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 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) REAL array, dimension (N) */
/* The diagonal of the (symmetric tri-) diagonal matrix. */
/* E (input) REAL 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 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 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 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 array, dimension (2*N**2) */
/* RWORK (workspace) REAL array, dimension (N) */
/* RESULT (output) REAL 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.f;
if (*itype == 1) {
result[2] = 0.f;
}
if (*n <= 0) {
return 0;
}
if (lsame_(uplo, "U")) {
lower = FALSE_;
*(unsigned char *)cuplo = 'U';
} else {
lower = TRUE_;
*(unsigned char *)cuplo = 'L';
}
unfl = slamch_("Safe minimum");
ulp = slamch_("Epsilon") * slamch_("Base");
/* Some Error Checks */
if (*itype < 1 || *itype > 3) {
result[1] = 10.f / ulp;
return 0;
}
/* Do Test 1 */
/* Norm of A: */
if (*itype == 3) {
anorm = 1.f;
} else {
/* Computing MAX */
r__1 = clanhe_("1", cuplo, n, &a[a_offset], lda, &rwork[1]);
anorm = dmax(r__1,unfl);
}
/* Compute error matrix: */
if (*itype == 1) {
/* ITYPE=1: error = A - U S U* */
claset_("Full", n, n, &c_b1, &c_b1, &work[1], n);
clacpy_(cuplo, n, n, &a[a_offset], lda, &work[1], n);
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
r__1 = -d__[j];
cher_(cuplo, n, &r__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;
q__2.r = e[i__2], q__2.i = 0.f;
q__1.r = -q__2.r, q__1.i = -q__2.i;
cher2_(cuplo, n, &q__1, &u[j * u_dim1 + 1], &c__1, &u[(j - 1)
* u_dim1 + 1], &c__1, &work[1], n);
/* L20: */
}
}
wnorm = clanhe_("1", cuplo, n, &work[1], n, &rwork[1]);
} else if (*itype == 2) {
/* ITYPE=2: error = V S V* - A */
claset_("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.f;
for (j = *n - 1; j >= 1; --j) {
if (*kband == 1) {
i__1 = (*n + 1) * (j - 1) + 2;
i__2 = j;
q__2.r = 1.f - tau[i__2].r, q__2.i = 0.f - tau[i__2].i;
i__3 = j;
q__1.r = e[i__3] * q__2.r, q__1.i = e[i__3] * q__2.i;
work[i__1].r = q__1.r, work[i__1].i = q__1.i;
i__1 = *n;
for (jr = j + 2; jr <= i__1; ++jr) {
i__2 = (j - 1) * *n + jr;
i__3 = j;
q__3.r = -tau[i__3].r, q__3.i = -tau[i__3].i;
i__4 = j;
q__2.r = e[i__4] * q__3.r, q__2.i = e[i__4] * q__3.i;
i__5 = jr + j * v_dim1;
q__1.r = q__2.r * v[i__5].r - q__2.i * v[i__5].i,
q__1.i = q__2.r * v[i__5].i + q__2.i * v[i__5]
.r;
work[i__2].r = q__1.r, work[i__2].i = q__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.f, v[i__1].i = 0.f;
i__1 = *n - j;
/* Computing 2nd power */
i__2 = *n;
clarfy_("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.f;
/* L40: */
}
} else {
work[1].r = d__[1], work[1].i = 0.f;
i__1 = *n - 1;
for (j = 1; j <= i__1; ++j) {
if (*kband == 1) {
i__2 = (*n + 1) * j;
i__3 = j;
q__2.r = 1.f - tau[i__3].r, q__2.i = 0.f - tau[i__3].i;
i__4 = j;
q__1.r = e[i__4] * q__2.r, q__1.i = e[i__4] * q__2.i;
work[i__2].r = q__1.r, work[i__2].i = q__1.i;
i__2 = j - 1;
for (jr = 1; jr <= i__2; ++jr) {
i__3 = j * *n + jr;
i__4 = j;
q__3.r = -tau[i__4].r, q__3.i = -tau[i__4].i;
i__5 = j;
q__2.r = e[i__5] * q__3.r, q__2.i = e[i__5] * q__3.i;
i__6 = jr + (j + 1) * v_dim1;
q__1.r = q__2.r * v[i__6].r - q__2.i * v[i__6].i,
q__1.i = q__2.r * v[i__6].i + q__2.i * v[i__6]
.r;
work[i__3].r = q__1.r, work[i__3].i = q__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.f, v[i__2].i = 0.f;
/* Computing 2nd power */
i__2 = *n;
clarfy_("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.f;
/* 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;
q__1.r = work[i__4].r - a[i__5].r, q__1.i = work[i__4].i
- a[i__5].i;
work[i__3].r = q__1.r, work[i__3].i = q__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;
q__1.r = work[i__4].r - a[i__5].r, q__1.i = work[i__4].i
- a[i__5].i;
work[i__3].r = q__1.r, work[i__3].i = q__1.i;
/* L80: */
}
}
/* L90: */
}
wnorm = clanhe_("1", cuplo, n, &work[1], n, &rwork[1]);
} else if (*itype == 3) {
/* ITYPE=3: error = U V* - I */
if (*n < 2) {
return 0;
}
clacpy_(" ", 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;
cunm2r_("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;
cunm2l_("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.f / 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;
q__1.r = work[i__3].r - 1.f, q__1.i = work[i__3].i - 0.f;
work[i__2].r = q__1.r, work[i__2].i = q__1.i;
/* L100: */
}
wnorm = clange_("1", n, n, &work[1], n, &rwork[1]);
}
if (anorm > wnorm) {
result[1] = wnorm / anorm / (*n * ulp);
} else {
if (anorm < 1.f) {
/* Computing MIN */
r__1 = wnorm, r__2 = *n * anorm;
result[1] = dmin(r__1,r__2) / anorm / (*n * ulp);
} else {
/* Computing MIN */
r__1 = wnorm / anorm, r__2 = (real) (*n);
result[1] = dmin(r__1,r__2) / (*n * ulp);
}
}
/* Do Test 2 */
/* Compute UU* - I */
if (*itype == 1) {
cgemm_("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;
q__1.r = work[i__3].r - 1.f, q__1.i = work[i__3].i - 0.f;
work[i__2].r = q__1.r, work[i__2].i = q__1.i;
/* L110: */
}
/* Computing MIN */
r__1 = clange_("1", n, n, &work[1], n, &rwork[1]), r__2 = (
real) (*n);
result[2] = dmin(r__1,r__2) / (*n * ulp);
}
return 0;
/* End of CHET21 */
} /* chet21_ */