int
f2c_zhpr(char* uplo, integer* N,
doublereal* alpha,
doublecomplex* X, integer* incX,
doublecomplex* Ap)
{
zhpr_(uplo, N, alpha,
X, incX, Ap);
return 0;
}
void
zhpr(char uplo, int n, double alpha, doublecomplex *x, int incx, doublecomplex *ap )
{
zhpr_( &uplo, &n, &alpha, x, &incx, ap );
}
/* Subroutine */ int zpptri_(char *uplo, integer *n, doublecomplex *ap,
integer *info, ftnlen uplo_len)
{
/* System generated locals */
integer i__1, i__2, i__3;
doublereal d__1;
doublecomplex z__1;
/* Local variables */
static integer j, jc, jj;
static doublereal ajj;
static integer jjn;
extern /* Subroutine */ int zhpr_(char *, integer *, doublereal *,
doublecomplex *, integer *, doublecomplex *, ftnlen);
extern logical lsame_(char *, char *, ftnlen, ftnlen);
extern /* Double Complex */ VOID zdotc_(doublecomplex *, integer *,
doublecomplex *, integer *, doublecomplex *, integer *);
static logical upper;
extern /* Subroutine */ int ztpmv_(char *, char *, char *, integer *,
doublecomplex *, doublecomplex *, integer *, ftnlen, ftnlen,
ftnlen), xerbla_(char *, integer *, ftnlen), zdscal_(integer *,
doublereal *, doublecomplex *, integer *), ztptri_(char *, char *,
integer *, doublecomplex *, integer *, ftnlen, ftnlen);
/* -- LAPACK routine (version 3.0) -- */
/* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., */
/* Courant Institute, Argonne National Lab, and Rice University */
/* March 31, 1993 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* ZPPTRI computes the inverse of a complex Hermitian positive definite */
/* matrix A using the Cholesky factorization A = U**H*U or A = L*L**H */
/* computed by ZPPTRF. */
/* Arguments */
/* ========= */
/* UPLO (input) CHARACTER*1 */
/* = 'U': Upper triangular factor is stored in AP; */
/* = 'L': Lower triangular factor is stored in AP. */
/* N (input) INTEGER */
/* The order of the matrix A. N >= 0. */
/* AP (input/output) COMPLEX*16 array, dimension (N*(N+1)/2) */
/* On entry, the triangular factor U or L from the Cholesky */
/* factorization A = U**H*U or A = L*L**H, packed columnwise as */
/* a linear array. The j-th column of U or L is stored in the */
/* array AP as follows: */
/* if UPLO = 'U', AP(i + (j-1)*j/2) = U(i,j) for 1<=i<=j; */
/* if UPLO = 'L', AP(i + (j-1)*(2n-j)/2) = L(i,j) for j<=i<=n. */
/* On exit, the upper or lower triangle of the (Hermitian) */
/* inverse of A, overwriting the input factor U or L. */
/* INFO (output) INTEGER */
/* = 0: successful exit */
/* < 0: if INFO = -i, the i-th argument had an illegal value */
/* > 0: if INFO = i, the (i,i) element of the factor U or L is */
/* zero, and the inverse could not be computed. */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Executable Statements .. */
/* Test the input parameters. */
/* Parameter adjustments */
--ap;
/* Function Body */
*info = 0;
upper = lsame_(uplo, "U", (ftnlen)1, (ftnlen)1);
if (! upper && ! lsame_(uplo, "L", (ftnlen)1, (ftnlen)1)) {
*info = -1;
} else if (*n < 0) {
*info = -2;
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("ZPPTRI", &i__1, (ftnlen)6);
return 0;
}
/* Quick return if possible */
if (*n == 0) {
return 0;
}
/* Invert the triangular Cholesky factor U or L. */
ztptri_(uplo, "Non-unit", n, &ap[1], info, (ftnlen)1, (ftnlen)8);
if (*info > 0) {
return 0;
}
if (upper) {
/* Compute the product inv(U) * inv(U)'. */
jj = 0;
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
jc = jj + 1;
jj += j;
if (j > 1) {
i__2 = j - 1;
zhpr_("Upper", &i__2, &c_b8, &ap[jc], &c__1, &ap[1], (ftnlen)
5);
}
i__2 = jj;
ajj = ap[i__2].r;
zdscal_(&j, &ajj, &ap[jc], &c__1);
/* L10: */
}
} else {
/* Compute the product inv(L)' * inv(L). */
jj = 1;
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
jjn = jj + *n - j + 1;
i__2 = jj;
i__3 = *n - j + 1;
zdotc_(&z__1, &i__3, &ap[jj], &c__1, &ap[jj], &c__1);
d__1 = z__1.r;
ap[i__2].r = d__1, ap[i__2].i = 0.;
if (j < *n) {
i__2 = *n - j;
ztpmv_("Lower", "Conjugate transpose", "Non-unit", &i__2, &ap[
jjn], &ap[jj + 1], &c__1, (ftnlen)5, (ftnlen)19, (
ftnlen)8);
}
jj = jjn;
/* L20: */
}
}
return 0;
/* End of ZPPTRI */
} /* zpptri_ */
/* Subroutine */ int zppt01_(char *uplo, integer *n, doublecomplex *a,
doublecomplex *afac, doublereal *rwork, doublereal *resid)
{
/* System generated locals */
integer i__1, i__2, i__3, i__4, i__5;
doublereal d__1;
doublecomplex z__1;
/* Builtin functions */
double d_imag(doublecomplex *);
/* Local variables */
integer i__, k, kc;
doublecomplex tc;
doublereal tr, eps;
extern /* Subroutine */ int zhpr_(char *, integer *, doublereal *,
doublecomplex *, integer *, doublecomplex *);
extern logical lsame_(char *, char *);
doublereal anorm;
extern /* Subroutine */ int zscal_(integer *, doublecomplex *,
doublecomplex *, integer *);
extern /* Double Complex */ VOID zdotc_(doublecomplex *, integer *,
doublecomplex *, integer *, doublecomplex *, integer *);
extern /* Subroutine */ int ztpmv_(char *, char *, char *, integer *,
doublecomplex *, doublecomplex *, integer *);
extern doublereal dlamch_(char *), zlanhp_(char *, char *,
integer *, doublecomplex *, doublereal *);
/* -- LAPACK test routine (version 3.1) -- */
/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/* November 2006 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* ZPPT01 reconstructs a Hermitian positive definite packed 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*16 array, dimension (N*(N+1)/2) */
/* The original Hermitian matrix A, stored as a packed */
/* triangular matrix. */
/* AFAC (input/output) COMPLEX*16 array, dimension (N*(N+1)/2) */
/* On entry, the factor L or U from the L*L' or U'*U */
/* factorization of A, stored as a packed triangular matrix. */
/* Overwritten with the reconstructed matrix, and then with the */
/* difference L*L' - A (or U'*U - A). */
/* 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 */
--rwork;
--afac;
--a;
/* Function Body */
if (*n <= 0) {
*resid = 0.;
return 0;
}
/* Exit with RESID = 1/EPS if ANORM = 0. */
eps = dlamch_("Epsilon");
anorm = zlanhp_("1", uplo, n, &a[1], &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. */
kc = 1;
if (lsame_(uplo, "U")) {
i__1 = *n;
for (k = 1; k <= i__1; ++k) {
if (d_imag(&afac[kc]) != 0.) {
*resid = 1. / eps;
return 0;
}
kc = kc + k + 1;
/* L10: */
}
} else {
i__1 = *n;
for (k = 1; k <= i__1; ++k) {
if (d_imag(&afac[kc]) != 0.) {
*resid = 1. / eps;
return 0;
}
kc = kc + *n - k + 1;
/* L20: */
}
}
/* Compute the product U'*U, overwriting U. */
if (lsame_(uplo, "U")) {
kc = *n * (*n - 1) / 2 + 1;
for (k = *n; k >= 1; --k) {
/* Compute the (K,K) element of the result. */
zdotc_(&z__1, &k, &afac[kc], &c__1, &afac[kc], &c__1);
tr = z__1.r;
i__1 = kc + k - 1;
afac[i__1].r = tr, afac[i__1].i = 0.;
/* Compute the rest of column K. */
if (k > 1) {
i__1 = k - 1;
ztpmv_("Upper", "Conjugate", "Non-unit", &i__1, &afac[1], &
afac[kc], &c__1);
kc -= k - 1;
}
/* L30: */
}
/* Compute the difference L*L' - A */
kc = 1;
i__1 = *n;
for (k = 1; k <= i__1; ++k) {
i__2 = k - 1;
for (i__ = 1; i__ <= i__2; ++i__) {
i__3 = kc + i__ - 1;
i__4 = kc + i__ - 1;
i__5 = kc + i__ - 1;
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;
/* L40: */
}
i__2 = kc + k - 1;
i__3 = kc + k - 1;
i__4 = kc + k - 1;
d__1 = a[i__4].r;
z__1.r = afac[i__3].r - d__1, z__1.i = afac[i__3].i;
afac[i__2].r = z__1.r, afac[i__2].i = z__1.i;
kc += k;
/* L50: */
}
/* Compute the product L*L', overwriting L. */
} else {
kc = *n * (*n + 1) / 2;
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 < *n) {
i__1 = *n - k;
zhpr_("Lower", &i__1, &c_b19, &afac[kc + 1], &c__1, &afac[kc
+ *n - k + 1]);
}
/* Scale column K by the diagonal element. */
i__1 = kc;
tc.r = afac[i__1].r, tc.i = afac[i__1].i;
i__1 = *n - k + 1;
zscal_(&i__1, &tc, &afac[kc], &c__1);
kc -= *n - k + 2;
/* L60: */
}
/* Compute the difference U'*U - A */
kc = 1;
i__1 = *n;
for (k = 1; k <= i__1; ++k) {
i__2 = kc;
i__3 = kc;
i__4 = kc;
d__1 = a[i__4].r;
z__1.r = afac[i__3].r - d__1, z__1.i = afac[i__3].i;
afac[i__2].r = z__1.r, afac[i__2].i = z__1.i;
i__2 = *n;
for (i__ = k + 1; i__ <= i__2; ++i__) {
i__3 = kc + i__ - k;
i__4 = kc + i__ - k;
i__5 = kc + i__ - k;
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: */
}
kc = kc + *n - k + 1;
/* L80: */
}
}
/* Compute norm( L*U - A ) / ( N * norm(A) * EPS ) */
*resid = zlanhp_("1", uplo, n, &afac[1], &rwork[1]);
*resid = *resid / (doublereal) (*n) / anorm / eps;
return 0;
/* End of ZPPT01 */
} /* zppt01_ */
/* Subroutine */ int zhptrf_(char *uplo, integer *n, doublecomplex *ap,
integer *ipiv, integer *info)
{
/* System generated locals */
integer 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 kc, kk, kp;
doublecomplex wk;
integer kx;
doublereal tt;
integer knc, kpc, npp;
doublecomplex wkm1, wkp1;
integer imax, jmax;
extern /* Subroutine */ int zhpr_(char *, integer *, doublereal *,
doublecomplex *, integer *, doublecomplex *);
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 /* 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 */
/* ======= */
/* ZHPTRF computes the factorization of a complex Hermitian packed */
/* matrix A using the Bunch-Kaufman diagonal pivoting method: */
/* A = U*D*U**H or A = L*D*L**H */
/* where U (or L) is a product of permutation and unit upper (lower) */
/* triangular matrices, and D is Hermitian and block diagonal with */
/* 1-by-1 and 2-by-2 diagonal blocks. */
/* Arguments */
/* ========= */
/* UPLO (input) CHARACTER*1 */
/* = 'U': Upper triangle of A is stored; */
/* = 'L': Lower triangle of A is stored. */
/* N (input) INTEGER */
/* The order of the matrix A. N >= 0. */
/* AP (input/output) COMPLEX*16 array, dimension (N*(N+1)/2) */
/* On entry, the upper or lower triangle of the Hermitian matrix */
/* A, packed columnwise in a linear array. The j-th column of A */
/* is stored in the array AP as follows: */
/* if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j; */
/* if UPLO = 'L', AP(i + (j-1)*(2n-j)/2) = A(i,j) for j<=i<=n. */
/* On exit, the block diagonal matrix D and the multipliers used */
/* to obtain the factor U or L, stored as a packed triangular */
/* matrix overwriting A (see below for further details). */
/* 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 = -i, the i-th argument had an illegal value */
/* > 0: if INFO = i, D(i,i) 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 */
/* =============== */
/* 5-96 - Based on modifications by J. Lewis, Boeing Computer Services */
/* Company */
/* 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 */
--ipiv;
--ap;
/* Function Body */
*info = 0;
upper = lsame_(uplo, "U");
if (! upper && ! lsame_(uplo, "L")) {
*info = -1;
} else if (*n < 0) {
*info = -2;
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("ZHPTRF", &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;
kc = (*n - 1) * *n / 2 + 1;
L10:
knc = kc;
/* If K < 1, exit from loop */
if (k < 1) {
goto L110;
}
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 = kc + k - 1;
absakk = (d__1 = ap[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, &ap[kc], &c__1);
i__1 = kc + imax - 1;
colmax = (d__1 = ap[i__1].r, abs(d__1)) + (d__2 = d_imag(&ap[kc +
imax - 1]), abs(d__2));
} else {
colmax = 0.;
}
if (max(absakk,colmax) == 0.) {
/* Column K is zero: set INFO and continue */
if (*info == 0) {
*info = k;
}
kp = k;
i__1 = kc + k - 1;
i__2 = kc + k - 1;
d__1 = ap[i__2].r;
ap[i__1].r = d__1, ap[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 */
rowmax = 0.;
jmax = imax;
kx = imax * (imax + 1) / 2 + imax;
i__1 = k;
for (j = imax + 1; j <= i__1; ++j) {
i__2 = kx;
if ((d__1 = ap[i__2].r, abs(d__1)) + (d__2 = d_imag(&ap[
kx]), abs(d__2)) > rowmax) {
i__2 = kx;
rowmax = (d__1 = ap[i__2].r, abs(d__1)) + (d__2 =
d_imag(&ap[kx]), abs(d__2));
jmax = j;
}
kx += j;
/* L20: */
}
kpc = (imax - 1) * imax / 2 + 1;
if (imax > 1) {
i__1 = imax - 1;
jmax = izamax_(&i__1, &ap[kpc], &c__1);
/* Computing MAX */
i__1 = kpc + jmax - 1;
d__3 = rowmax, d__4 = (d__1 = ap[i__1].r, abs(d__1)) + (
d__2 = d_imag(&ap[kpc + jmax - 1]), 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 = kpc + imax - 1;
if ((d__1 = ap[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 (kstep == 2) {
knc = knc - k + 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, &ap[knc], &c__1, &ap[kpc], &c__1);
kx = kpc + kp - 1;
i__1 = kk - 1;
for (j = kp + 1; j <= i__1; ++j) {
kx = kx + j - 1;
d_cnjg(&z__1, &ap[knc + j - 1]);
t.r = z__1.r, t.i = z__1.i;
i__2 = knc + j - 1;
d_cnjg(&z__1, &ap[kx]);
ap[i__2].r = z__1.r, ap[i__2].i = z__1.i;
i__2 = kx;
ap[i__2].r = t.r, ap[i__2].i = t.i;
/* L30: */
}
i__1 = kx + kk - 1;
d_cnjg(&z__1, &ap[kx + kk - 1]);
ap[i__1].r = z__1.r, ap[i__1].i = z__1.i;
i__1 = knc + kk - 1;
r1 = ap[i__1].r;
i__1 = knc + kk - 1;
i__2 = kpc + kp - 1;
d__1 = ap[i__2].r;
ap[i__1].r = d__1, ap[i__1].i = 0.;
i__1 = kpc + kp - 1;
ap[i__1].r = r1, ap[i__1].i = 0.;
if (kstep == 2) {
i__1 = kc + k - 1;
i__2 = kc + k - 1;
d__1 = ap[i__2].r;
ap[i__1].r = d__1, ap[i__1].i = 0.;
i__1 = kc + k - 2;
t.r = ap[i__1].r, t.i = ap[i__1].i;
i__1 = kc + k - 2;
i__2 = kc + kp - 1;
ap[i__1].r = ap[i__2].r, ap[i__1].i = ap[i__2].i;
i__1 = kc + kp - 1;
ap[i__1].r = t.r, ap[i__1].i = t.i;
}
} else {
i__1 = kc + k - 1;
i__2 = kc + k - 1;
d__1 = ap[i__2].r;
ap[i__1].r = d__1, ap[i__1].i = 0.;
if (kstep == 2) {
i__1 = kc - 1;
i__2 = kc - 1;
d__1 = ap[i__2].r;
ap[i__1].r = d__1, ap[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 = kc + k - 1;
r1 = 1. / ap[i__1].r;
i__1 = k - 1;
d__1 = -r1;
zhpr_(uplo, &i__1, &d__1, &ap[kc], &c__1, &ap[1]);
/* Store U(k) in column k */
i__1 = k - 1;
zdscal_(&i__1, &r1, &ap[kc], &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 - 1) * k / 2;
d__1 = ap[i__1].r;
d__2 = d_imag(&ap[k - 1 + (k - 1) * k / 2]);
d__ = dlapy2_(&d__1, &d__2);
i__1 = k - 1 + (k - 2) * (k - 1) / 2;
d22 = ap[i__1].r / d__;
i__1 = k + (k - 1) * k / 2;
d11 = ap[i__1].r / d__;
tt = 1. / (d11 * d22 - 1.);
i__1 = k - 1 + (k - 1) * k / 2;
z__1.r = ap[i__1].r / d__, z__1.i = ap[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 - 2) * (k - 1) / 2;
z__3.r = d11 * ap[i__1].r, z__3.i = d11 * ap[i__1].i;
d_cnjg(&z__5, &d12);
i__2 = j + (k - 1) * k / 2;
z__4.r = z__5.r * ap[i__2].r - z__5.i * ap[i__2].i,
z__4.i = z__5.r * ap[i__2].i + z__5.i * ap[
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 - 1) * k / 2;
z__3.r = d22 * ap[i__1].r, z__3.i = d22 * ap[i__1].i;
i__2 = j + (k - 2) * (k - 1) / 2;
z__4.r = d12.r * ap[i__2].r - d12.i * ap[i__2].i,
z__4.i = d12.r * ap[i__2].i + d12.i * ap[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 - 1) * j / 2;
i__2 = i__ + (j - 1) * j / 2;
i__3 = i__ + (k - 1) * k / 2;
d_cnjg(&z__4, &wk);
z__3.r = ap[i__3].r * z__4.r - ap[i__3].i *
z__4.i, z__3.i = ap[i__3].r * z__4.i + ap[
i__3].i * z__4.r;
z__2.r = ap[i__2].r - z__3.r, z__2.i = ap[i__2].i
- z__3.i;
i__4 = i__ + (k - 2) * (k - 1) / 2;
d_cnjg(&z__6, &wkm1);
z__5.r = ap[i__4].r * z__6.r - ap[i__4].i *
z__6.i, z__5.i = ap[i__4].r * z__6.i + ap[
i__4].i * z__6.r;
z__1.r = z__2.r - z__5.r, z__1.i = z__2.i -
z__5.i;
ap[i__1].r = z__1.r, ap[i__1].i = z__1.i;
/* L40: */
}
i__1 = j + (k - 1) * k / 2;
ap[i__1].r = wk.r, ap[i__1].i = wk.i;
i__1 = j + (k - 2) * (k - 1) / 2;
ap[i__1].r = wkm1.r, ap[i__1].i = wkm1.i;
i__1 = j + (j - 1) * j / 2;
i__2 = j + (j - 1) * j / 2;
d__1 = ap[i__2].r;
z__1.r = d__1, z__1.i = 0.;
ap[i__1].r = z__1.r, ap[i__1].i = z__1.i;
/* L50: */
}
}
}
}
/* 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;
kc = knc - k;
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;
kc = 1;
npp = *n * (*n + 1) / 2;
L60:
knc = kc;
/* If K > N, exit from loop */
if (k > *n) {
goto L110;
}
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 = kc;
absakk = (d__1 = ap[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, &ap[kc + 1], &c__1);
i__1 = kc + imax - k;
colmax = (d__1 = ap[i__1].r, abs(d__1)) + (d__2 = d_imag(&ap[kc +
imax - k]), abs(d__2));
} else {
colmax = 0.;
}
if (max(absakk,colmax) == 0.) {
/* Column K is zero: set INFO and continue */
if (*info == 0) {
*info = k;
}
kp = k;
i__1 = kc;
i__2 = kc;
d__1 = ap[i__2].r;
ap[i__1].r = d__1, ap[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 */
rowmax = 0.;
kx = kc + imax - k;
i__1 = imax - 1;
for (j = k; j <= i__1; ++j) {
i__2 = kx;
if ((d__1 = ap[i__2].r, abs(d__1)) + (d__2 = d_imag(&ap[
kx]), abs(d__2)) > rowmax) {
i__2 = kx;
rowmax = (d__1 = ap[i__2].r, abs(d__1)) + (d__2 =
d_imag(&ap[kx]), abs(d__2));
jmax = j;
}
kx = kx + *n - j;
/* L70: */
}
kpc = npp - (*n - imax + 1) * (*n - imax + 2) / 2 + 1;
if (imax < *n) {
i__1 = *n - imax;
jmax = imax + izamax_(&i__1, &ap[kpc + 1], &c__1);
/* Computing MAX */
i__1 = kpc + jmax - imax;
d__3 = rowmax, d__4 = (d__1 = ap[i__1].r, abs(d__1)) + (
d__2 = d_imag(&ap[kpc + jmax - imax]), 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 = kpc;
if ((d__1 = ap[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 (kstep == 2) {
knc = knc + *n - k + 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, &ap[knc + kp - kk + 1], &c__1, &ap[kpc + 1],
&c__1);
}
kx = knc + kp - kk;
i__1 = kp - 1;
for (j = kk + 1; j <= i__1; ++j) {
kx = kx + *n - j + 1;
d_cnjg(&z__1, &ap[knc + j - kk]);
t.r = z__1.r, t.i = z__1.i;
i__2 = knc + j - kk;
d_cnjg(&z__1, &ap[kx]);
ap[i__2].r = z__1.r, ap[i__2].i = z__1.i;
i__2 = kx;
ap[i__2].r = t.r, ap[i__2].i = t.i;
/* L80: */
}
i__1 = knc + kp - kk;
d_cnjg(&z__1, &ap[knc + kp - kk]);
ap[i__1].r = z__1.r, ap[i__1].i = z__1.i;
i__1 = knc;
r1 = ap[i__1].r;
i__1 = knc;
i__2 = kpc;
d__1 = ap[i__2].r;
ap[i__1].r = d__1, ap[i__1].i = 0.;
i__1 = kpc;
ap[i__1].r = r1, ap[i__1].i = 0.;
if (kstep == 2) {
i__1 = kc;
i__2 = kc;
d__1 = ap[i__2].r;
ap[i__1].r = d__1, ap[i__1].i = 0.;
i__1 = kc + 1;
t.r = ap[i__1].r, t.i = ap[i__1].i;
i__1 = kc + 1;
i__2 = kc + kp - k;
ap[i__1].r = ap[i__2].r, ap[i__1].i = ap[i__2].i;
i__1 = kc + kp - k;
ap[i__1].r = t.r, ap[i__1].i = t.i;
}
} else {
i__1 = kc;
i__2 = kc;
d__1 = ap[i__2].r;
ap[i__1].r = d__1, ap[i__1].i = 0.;
if (kstep == 2) {
i__1 = knc;
i__2 = knc;
d__1 = ap[i__2].r;
ap[i__1].r = d__1, ap[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 = kc;
r1 = 1. / ap[i__1].r;
i__1 = *n - k;
d__1 = -r1;
zhpr_(uplo, &i__1, &d__1, &ap[kc + 1], &c__1, &ap[kc + *n
- k + 1]);
/* Store L(k) in column K */
i__1 = *n - k;
zdscal_(&i__1, &r1, &ap[kc + 1], &c__1);
}
} else {
/* 2-by-2 pivot block D(k): columns K and K+1 now hold */
/* ( W(k) W(k+1) ) = ( L(k) L(k+1) )*D(k) */
/* where L(k) and L(k+1) are the k-th and (k+1)-th columns */
/* of L */
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 - 1) * ((*n << 1) - k) / 2;
d__1 = ap[i__1].r;
d__2 = d_imag(&ap[k + 1 + (k - 1) * ((*n << 1) - k) / 2]);
d__ = dlapy2_(&d__1, &d__2);
i__1 = k + 1 + k * ((*n << 1) - k - 1) / 2;
d11 = ap[i__1].r / d__;
i__1 = k + (k - 1) * ((*n << 1) - k) / 2;
d22 = ap[i__1].r / d__;
tt = 1. / (d11 * d22 - 1.);
i__1 = k + 1 + (k - 1) * ((*n << 1) - k) / 2;
z__1.r = ap[i__1].r / d__, z__1.i = ap[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 - 1) * ((*n << 1) - k) / 2;
z__3.r = d11 * ap[i__2].r, z__3.i = d11 * ap[i__2].i;
i__3 = j + k * ((*n << 1) - k - 1) / 2;
z__4.r = d21.r * ap[i__3].r - d21.i * ap[i__3].i,
z__4.i = d21.r * ap[i__3].i + d21.i * ap[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 * ((*n << 1) - k - 1) / 2;
z__3.r = d22 * ap[i__2].r, z__3.i = d22 * ap[i__2].i;
d_cnjg(&z__5, &d21);
i__3 = j + (k - 1) * ((*n << 1) - k) / 2;
z__4.r = z__5.r * ap[i__3].r - z__5.i * ap[i__3].i,
z__4.i = z__5.r * ap[i__3].i + z__5.i * ap[
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 - 1) * ((*n << 1) - j) / 2;
i__4 = i__ + (j - 1) * ((*n << 1) - j) / 2;
i__5 = i__ + (k - 1) * ((*n << 1) - k) / 2;
d_cnjg(&z__4, &wk);
z__3.r = ap[i__5].r * z__4.r - ap[i__5].i *
z__4.i, z__3.i = ap[i__5].r * z__4.i + ap[
i__5].i * z__4.r;
z__2.r = ap[i__4].r - z__3.r, z__2.i = ap[i__4].i
- z__3.i;
i__6 = i__ + k * ((*n << 1) - k - 1) / 2;
d_cnjg(&z__6, &wkp1);
z__5.r = ap[i__6].r * z__6.r - ap[i__6].i *
z__6.i, z__5.i = ap[i__6].r * z__6.i + ap[
i__6].i * z__6.r;
z__1.r = z__2.r - z__5.r, z__1.i = z__2.i -
z__5.i;
ap[i__3].r = z__1.r, ap[i__3].i = z__1.i;
/* L90: */
}
i__2 = j + (k - 1) * ((*n << 1) - k) / 2;
ap[i__2].r = wk.r, ap[i__2].i = wk.i;
i__2 = j + k * ((*n << 1) - k - 1) / 2;
ap[i__2].r = wkp1.r, ap[i__2].i = wkp1.i;
i__2 = j + (j - 1) * ((*n << 1) - j) / 2;
i__3 = j + (j - 1) * ((*n << 1) - j) / 2;
d__1 = ap[i__3].r;
z__1.r = d__1, z__1.i = 0.;
ap[i__2].r = z__1.r, ap[i__2].i = z__1.i;
/* L100: */
}
}
}
}
/* 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;
kc = knc + *n - k + 2;
goto L60;
}
L110:
return 0;
/* End of ZHPTRF */
} /* zhptrf_ */
/* Subroutine */ int zpptrf_(char *uplo, integer *n, doublecomplex *ap,
integer *info)
{
/* System generated locals */
integer i__1, i__2, i__3;
doublereal d__1;
doublecomplex z__1, z__2;
/* Local variables */
integer j, jc, jj;
doublereal ajj;
logical upper;
/* -- LAPACK routine (version 3.2) -- */
/* November 2006 */
/* Purpose */
/* ======= */
/* ZPPTRF computes the Cholesky factorization of a complex Hermitian */
/* positive definite matrix A stored in packed format. */
/* The factorization has the form */
/* A = U**H * U, if UPLO = 'U', or */
/* A = L * L**H, if UPLO = 'L', */
/* where U is an upper triangular matrix and L is lower triangular. */
/* Arguments */
/* ========= */
/* UPLO (input) CHARACTER*1 */
/* = 'U': Upper triangle of A is stored; */
/* = 'L': Lower triangle of A is stored. */
/* N (input) INTEGER */
/* The order of the matrix A. N >= 0. */
/* AP (input/output) COMPLEX*16 array, dimension (N*(N+1)/2) */
/* On entry, the upper or lower triangle of the Hermitian matrix */
/* A, packed columnwise in a linear array. The j-th column of A */
/* is stored in the array AP as follows: */
/* if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j; */
/* if UPLO = 'L', AP(i + (j-1)*(2n-j)/2) = A(i,j) for j<=i<=n. */
/* See below for further details. */
/* On exit, if INFO = 0, the triangular factor U or L from the */
/* Cholesky factorization A = U**H*U or A = L*L**H, in the same */
/* storage format as A. */
/* INFO (output) INTEGER */
/* = 0: successful exit */
/* < 0: if INFO = -i, the i-th argument had an illegal value */
/* > 0: if INFO = i, the leading minor of order i is not */
/* positive definite, and the factorization could not be */
/* completed. */
/* Further Details */
/* =============== */
/* The packed storage scheme is illustrated by the following example */
/* when N = 4, UPLO = 'U': */
/* Two-dimensional storage of the Hermitian matrix A: */
/* a11 a12 a13 a14 */
/* a22 a23 a24 */
/* a33 a34 (aij = conjg(aji)) */
/* a44 */
/* Packed storage of the upper triangle of A: */
/* AP = [ a11, a12, a22, a13, a23, a33, a14, a24, a34, a44 ] */
/* ===================================================================== */
/* Test the input parameters. */
/* Parameter adjustments */
--ap;
/* Function Body */
*info = 0;
upper = lsame_(uplo, "U");
if (! upper && ! lsame_(uplo, "L")) {
*info = -1;
} else if (*n < 0) {
*info = -2;
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("ZPPTRF", &i__1);
return 0;
}
/* Quick return if possible */
if (*n == 0) {
return 0;
}
if (upper) {
/* Compute the Cholesky factorization A = U'*U. */
jj = 0;
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
jc = jj + 1;
jj += j;
/* Compute elements 1:J-1 of column J. */
if (j > 1) {
i__2 = j - 1;
ztpsv_("Upper", "Conjugate transpose", "Non-unit", &i__2, &ap[
1], &ap[jc], &c__1);
}
/* Compute U(J,J) and test for non-positive-definiteness. */
i__2 = jj;
d__1 = ap[i__2].r;
i__3 = j - 1;
zdotc_(&z__2, &i__3, &ap[jc], &c__1, &ap[jc], &c__1);
z__1.r = d__1 - z__2.r, z__1.i = -z__2.i;
ajj = z__1.r;
if (ajj <= 0.) {
i__2 = jj;
ap[i__2].r = ajj, ap[i__2].i = 0.;
goto L30;
}
i__2 = jj;
d__1 = sqrt(ajj);
ap[i__2].r = d__1, ap[i__2].i = 0.;
}
} else {
/* Compute the Cholesky factorization A = L*L'. */
jj = 1;
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
/* Compute L(J,J) and test for non-positive-definiteness. */
i__2 = jj;
ajj = ap[i__2].r;
if (ajj <= 0.) {
i__2 = jj;
ap[i__2].r = ajj, ap[i__2].i = 0.;
goto L30;
}
ajj = sqrt(ajj);
i__2 = jj;
ap[i__2].r = ajj, ap[i__2].i = 0.;
/* Compute elements J+1:N of column J and update the trailing */
/* submatrix. */
if (j < *n) {
i__2 = *n - j;
d__1 = 1. / ajj;
zdscal_(&i__2, &d__1, &ap[jj + 1], &c__1);
i__2 = *n - j;
zhpr_("Lower", &i__2, &c_b16, &ap[jj + 1], &c__1, &ap[jj + *n
- j + 1]);
jj = jj + *n - j + 1;
}
}
}
goto L40;
L30:
*info = j;
L40:
return 0;
/* End of ZPPTRF */
} /* zpptrf_ */
/* Subroutine */ int zhpt21_(integer *itype, char *uplo, integer *n, integer *
kband, doublecomplex *ap, doublereal *d__, doublereal *e,
doublecomplex *u, integer *ldu, doublecomplex *vp, doublecomplex *tau,
doublecomplex *work, doublereal *rwork, doublereal *result)
{
/* System generated locals */
integer u_dim1, u_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 */
static doublereal unfl;
static doublecomplex temp;
extern /* Subroutine */ int zhpr_(char *, integer *, doublereal *,
doublecomplex *, integer *, doublecomplex *), zhpr2_(char
*, integer *, doublecomplex *, doublecomplex *, integer *,
doublecomplex *, integer *, doublecomplex *);
static integer j;
extern logical lsame_(char *, char *);
static integer iinfo;
static doublereal anorm;
extern /* Subroutine */ int zgemm_(char *, char *, integer *, integer *,
integer *, doublecomplex *, doublecomplex *, integer *,
doublecomplex *, integer *, doublecomplex *, doublecomplex *,
integer *);
static char cuplo[1];
static doublecomplex vsave;
extern /* Double Complex */ VOID zdotc_(doublecomplex *, integer *,
doublecomplex *, integer *, doublecomplex *, integer *);
static logical lower;
static doublereal wnorm;
extern /* Subroutine */ int zcopy_(integer *, doublecomplex *, integer *,
doublecomplex *, integer *), zhpmv_(char *, integer *,
doublecomplex *, doublecomplex *, doublecomplex *, integer *,
doublecomplex *, doublecomplex *, integer *), zaxpy_(
integer *, doublecomplex *, doublecomplex *, integer *,
doublecomplex *, integer *);
extern doublereal dlamch_(char *);
static integer jp, jr;
extern doublereal zlange_(char *, integer *, integer *, doublecomplex *,
integer *, doublereal *), zlanhp_(char *, char *, integer
*, doublecomplex *, doublereal *);
extern /* Subroutine */ int zlacpy_(char *, integer *, integer *,
doublecomplex *, integer *, doublecomplex *, integer *),
zlaset_(char *, integer *, integer *, doublecomplex *,
doublecomplex *, doublecomplex *, integer *);
static integer jp1;
extern /* Subroutine */ int zupmtr_(char *, char *, char *, integer *,
integer *, doublecomplex *, doublecomplex *, doublecomplex *,
integer *, doublecomplex *, integer *);
static integer lap;
static doublereal 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
=======
ZHPT21 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 the 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 )
Packed storage means that, for example, if UPLO='U', then the columns
of the upper triangle of A are stored one after another, so that
A(1,j+1) immediately follows A(j,j) in the array AP. Similarly, if
UPLO='L', then the columns of the lower triangle of A are stored one
after another in AP, so that A(j+1,j+1) immediately follows A(n,j)
in the array AP. This means that A(i,j) is stored in:
AP( i + j*(j-1)/2 ) if UPLO='U'
AP( i + (2*n-j)*(j-1)/2 ) if UPLO='L'
The array VP bears the same relation to the matrix V that A does to
AP.
For ITYPE > 1, the transformation U is expressed as a product
of Householder transformations:
If UPLO='U', then V = H(n-1)...H(1), where
H(j) = I - tau(j) v(j) v(j)*
and the first j-1 elements of v(j) are stored in V(1:j-1,j+1),
(i.e., VP( j*(j+1)/2 + 1 : j*(j+1)/2 + j-1 ) ),
the j-th element is 1, and the last n-j elements are 0.
If UPLO='L', then V = H(1)...H(n-1), where
H(j) = I - tau(j) v(j) v(j)*
and the first j elements of v(j) are 0, the (j+1)-st is 1, and the
(j+2)-nd through n-th elements are stored in V(j+2:n,j) (i.e.,
in VP( (2*n-j)*(j-1)/2 + j+2 : (2*n-j)*(j-1)/2 + n ) .)
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, ZHPT21 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.
AP (input) COMPLEX*16 array, dimension (N*(N+1)/2)
The original (unfactored) matrix. It is assumed to be
hermitian, and contains the columns of just the upper
triangle (UPLO='U') or only the lower triangle (UPLO='L'),
packed one after another.
D (input) DOUBLE PRECISION array, dimension (N)
The diagonal of the (symmetric tri-) diagonal matrix.
E (input) DOUBLE PRECISION array, dimension (N)
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.
VP (input) DOUBLE PRECISION array, dimension (N*(N+1)/2)
If ITYPE=2 or 3, the columns of this array contain the
Householder vectors used to describe the unitary matrix
in the decomposition, as described in purpose.
*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.
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 (N**2)
Workspace.
RWORK (workspace) DOUBLE PRECISION array, dimension (N)
Workspace.
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.
=====================================================================
Constants
Parameter adjustments */
--ap;
--d__;
--e;
u_dim1 = *ldu;
u_offset = 1 + u_dim1 * 1;
u -= u_offset;
--vp;
--tau;
--work;
--rwork;
--result;
/* Function Body */
result[1] = 0.;
if (*itype == 1) {
result[2] = 0.;
}
if (*n <= 0) {
return 0;
}
lap = *n * (*n + 1) / 2;
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 = zlanhp_("1", cuplo, n, &ap[1], &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);
zcopy_(&lap, &ap[1], &c__1, &work[1], &c__1);
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
d__1 = -d__[j];
zhpr_(cuplo, n, &d__1, &u_ref(1, j), &c__1, &work[1]);
/* 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;
zhpr2_(cuplo, n, &z__1, &u_ref(1, j), &c__1, &u_ref(1, j - 1),
&c__1, &work[1]);
/* L20: */
}
}
wnorm = zlanhp_("1", cuplo, n, &work[1], &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) {
i__1 = lap;
i__2 = *n;
work[i__1].r = d__[i__2], work[i__1].i = 0.;
for (j = *n - 1; j >= 1; --j) {
jp = ((*n << 1) - j) * (j - 1) / 2;
jp1 = jp + *n - j;
if (*kband == 1) {
i__1 = jp + j + 1;
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 = jp + 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 = jp + jr;
z__1.r = z__2.r * vp[i__5].r - z__2.i * vp[i__5].i,
z__1.i = z__2.r * vp[i__5].i + z__2.i * vp[
i__5].r;
work[i__2].r = z__1.r, work[i__2].i = z__1.i;
/* L30: */
}
}
i__1 = j;
if (tau[i__1].r != 0. || tau[i__1].i != 0.) {
i__1 = jp + j + 1;
vsave.r = vp[i__1].r, vsave.i = vp[i__1].i;
i__1 = jp + j + 1;
vp[i__1].r = 1., vp[i__1].i = 0.;
i__1 = *n - j;
zhpmv_("L", &i__1, &c_b2, &work[jp1 + j + 1], &vp[jp + j
+ 1], &c__1, &c_b1, &work[lap + 1], &c__1);
i__1 = j;
z__2.r = tau[i__1].r * -.5, z__2.i = tau[i__1].i * -.5;
i__2 = *n - j;
zdotc_(&z__3, &i__2, &work[lap + 1], &c__1, &vp[jp + j +
1], &c__1);
z__1.r = z__2.r * z__3.r - z__2.i * z__3.i, z__1.i =
z__2.r * z__3.i + z__2.i * z__3.r;
temp.r = z__1.r, temp.i = z__1.i;
i__1 = *n - j;
zaxpy_(&i__1, &temp, &vp[jp + j + 1], &c__1, &work[lap +
1], &c__1);
i__1 = *n - j;
i__2 = j;
z__1.r = -tau[i__2].r, z__1.i = -tau[i__2].i;
zhpr2_("L", &i__1, &z__1, &vp[jp + j + 1], &c__1, &work[
lap + 1], &c__1, &work[jp1 + j + 1]);
i__1 = jp + j + 1;
vp[i__1].r = vsave.r, vp[i__1].i = vsave.i;
}
i__1 = jp + j;
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) {
jp = j * (j - 1) / 2;
jp1 = jp + j;
if (*kband == 1) {
i__2 = jp1 + 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 = jp1 + 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 = jp1 + jr;
z__1.r = z__2.r * vp[i__6].r - z__2.i * vp[i__6].i,
z__1.i = z__2.r * vp[i__6].i + z__2.i * vp[
i__6].r;
work[i__3].r = z__1.r, work[i__3].i = z__1.i;
/* L50: */
}
}
i__2 = j;
if (tau[i__2].r != 0. || tau[i__2].i != 0.) {
i__2 = jp1 + j;
vsave.r = vp[i__2].r, vsave.i = vp[i__2].i;
i__2 = jp1 + j;
vp[i__2].r = 1., vp[i__2].i = 0.;
zhpmv_("U", &j, &c_b2, &work[1], &vp[jp1 + 1], &c__1, &
c_b1, &work[lap + 1], &c__1);
i__2 = j;
z__2.r = tau[i__2].r * -.5, z__2.i = tau[i__2].i * -.5;
zdotc_(&z__3, &j, &work[lap + 1], &c__1, &vp[jp1 + 1], &
c__1);
z__1.r = z__2.r * z__3.r - z__2.i * z__3.i, z__1.i =
z__2.r * z__3.i + z__2.i * z__3.r;
temp.r = z__1.r, temp.i = z__1.i;
zaxpy_(&j, &temp, &vp[jp1 + 1], &c__1, &work[lap + 1], &
c__1);
i__2 = j;
z__1.r = -tau[i__2].r, z__1.i = -tau[i__2].i;
zhpr2_("U", &j, &z__1, &vp[jp1 + 1], &c__1, &work[lap + 1]
, &c__1, &work[1]);
i__2 = jp1 + j;
vp[i__2].r = vsave.r, vp[i__2].i = vsave.i;
}
i__2 = jp1 + j + 1;
i__3 = j + 1;
work[i__2].r = d__[i__3], work[i__2].i = 0.;
/* L60: */
}
}
i__1 = lap;
for (j = 1; j <= i__1; ++j) {
i__2 = j;
i__3 = j;
i__4 = j;
z__1.r = work[i__3].r - ap[i__4].r, z__1.i = work[i__3].i - ap[
i__4].i;
work[i__2].r = z__1.r, work[i__2].i = z__1.i;
/* L70: */
}
wnorm = zlanhp_("1", cuplo, n, &work[1], &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);
/* Computing 2nd power */
i__1 = *n;
zupmtr_("R", cuplo, "C", n, n, &vp[1], &tau[1], &work[1], n, &work[
i__1 * i__1 + 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;
/* L80: */
}
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;
/* L90: */
}
/* 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 ZHPT21 */
} /* zhpt21_ */
/* Subroutine */
int zhptrf_(char *uplo, integer *n, doublecomplex *ap, integer *ipiv, integer *info)
{
/* System generated locals */
integer 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 kc, kk, kp;
doublecomplex wk;
integer kx;
doublereal tt;
integer knc, kpc, npp;
doublecomplex wkm1, wkp1;
integer imax, jmax;
extern /* Subroutine */
int zhpr_(char *, integer *, doublereal *, doublecomplex *, integer *, doublecomplex *);
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 /* Subroutine */
int xerbla_(char *, integer *), zdscal_( integer *, doublereal *, doublecomplex *, integer *);
doublereal colmax;
extern integer izamax_(integer *, doublecomplex *, integer *);
doublereal rowmax;
/* -- LAPACK computational routine (version 3.4.0) -- */
/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */
/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */
/* November 2011 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Statement Functions .. */
/* .. */
/* .. Statement Function definitions .. */
/* .. */
/* .. Executable Statements .. */
/* Test the input parameters. */
/* Parameter adjustments */
--ipiv;
--ap;
/* Function Body */
*info = 0;
upper = lsame_(uplo, "U");
if (! upper && ! lsame_(uplo, "L"))
{
*info = -1;
}
else if (*n < 0)
{
*info = -2;
}
if (*info != 0)
{
i__1 = -(*info);
xerbla_("ZHPTRF", &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**H 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;
kc = (*n - 1) * *n / 2 + 1;
L10:
knc = kc;
/* If K < 1, exit from loop */
if (k < 1)
{
goto L110;
}
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 = kc + k - 1;
absakk = (d__1 = ap[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, &ap[kc], &c__1);
i__1 = kc + imax - 1;
colmax = (d__1 = ap[i__1].r, abs(d__1)) + (d__2 = d_imag(&ap[kc + imax - 1]), abs(d__2));
}
else
{
colmax = 0.;
}
if (max(absakk,colmax) == 0.)
{
/* Column K is zero: set INFO and continue */
if (*info == 0)
{
*info = k;
}
kp = k;
i__1 = kc + k - 1;
i__2 = kc + k - 1;
d__1 = ap[i__2].r;
ap[i__1].r = d__1;
ap[i__1].i = 0.; // , expr subst
}
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 */
rowmax = 0.;
jmax = imax;
kx = imax * (imax + 1) / 2 + imax;
i__1 = k;
for (j = imax + 1;
j <= i__1;
++j)
{
i__2 = kx;
if ((d__1 = ap[i__2].r, abs(d__1)) + (d__2 = d_imag(&ap[ kx]), abs(d__2)) > rowmax)
{
i__2 = kx;
rowmax = (d__1 = ap[i__2].r, abs(d__1)) + (d__2 = d_imag(&ap[kx]), abs(d__2));
jmax = j;
}
kx += j;
/* L20: */
}
kpc = (imax - 1) * imax / 2 + 1;
if (imax > 1)
{
i__1 = imax - 1;
jmax = izamax_(&i__1, &ap[kpc], &c__1);
/* Computing MAX */
i__1 = kpc + jmax - 1;
d__3 = rowmax;
d__4 = (d__1 = ap[i__1].r, abs(d__1)) + ( d__2 = d_imag(&ap[kpc + jmax - 1]), abs(d__2)); // , expr subst
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 = kpc + imax - 1;
if ((d__1 = ap[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 (kstep == 2)
{
knc = knc - k + 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, &ap[knc], &c__1, &ap[kpc], &c__1);
kx = kpc + kp - 1;
i__1 = kk - 1;
for (j = kp + 1;
j <= i__1;
++j)
{
kx = kx + j - 1;
d_cnjg(&z__1, &ap[knc + j - 1]);
t.r = z__1.r;
t.i = z__1.i; // , expr subst
i__2 = knc + j - 1;
d_cnjg(&z__1, &ap[kx]);
ap[i__2].r = z__1.r;
ap[i__2].i = z__1.i; // , expr subst
i__2 = kx;
ap[i__2].r = t.r;
ap[i__2].i = t.i; // , expr subst
/* L30: */
}
i__1 = kx + kk - 1;
d_cnjg(&z__1, &ap[kx + kk - 1]);
ap[i__1].r = z__1.r;
ap[i__1].i = z__1.i; // , expr subst
i__1 = knc + kk - 1;
r1 = ap[i__1].r;
i__1 = knc + kk - 1;
i__2 = kpc + kp - 1;
d__1 = ap[i__2].r;
ap[i__1].r = d__1;
ap[i__1].i = 0.; // , expr subst
i__1 = kpc + kp - 1;
ap[i__1].r = r1;
ap[i__1].i = 0.; // , expr subst
if (kstep == 2)
{
i__1 = kc + k - 1;
i__2 = kc + k - 1;
d__1 = ap[i__2].r;
ap[i__1].r = d__1;
ap[i__1].i = 0.; // , expr subst
i__1 = kc + k - 2;
t.r = ap[i__1].r;
t.i = ap[i__1].i; // , expr subst
i__1 = kc + k - 2;
i__2 = kc + kp - 1;
ap[i__1].r = ap[i__2].r;
ap[i__1].i = ap[i__2].i; // , expr subst
i__1 = kc + kp - 1;
ap[i__1].r = t.r;
ap[i__1].i = t.i; // , expr subst
}
}
else
{
i__1 = kc + k - 1;
i__2 = kc + k - 1;
d__1 = ap[i__2].r;
ap[i__1].r = d__1;
ap[i__1].i = 0.; // , expr subst
if (kstep == 2)
{
i__1 = kc - 1;
i__2 = kc - 1;
d__1 = ap[i__2].r;
ap[i__1].r = d__1;
ap[i__1].i = 0.; // , expr subst
}
}
/* 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)**H = A - W(k)*1/D(k)*W(k)**H */
i__1 = kc + k - 1;
r1 = 1. / ap[i__1].r;
i__1 = k - 1;
d__1 = -r1;
zhpr_(uplo, &i__1, &d__1, &ap[kc], &c__1, &ap[1]);
/* Store U(k) in column k */
i__1 = k - 1;
zdscal_(&i__1, &r1, &ap[kc], &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) )**H */
/* = A - ( W(k-1) W(k) )*inv(D(k))*( W(k-1) W(k) )**H */
if (k > 2)
{
i__1 = k - 1 + (k - 1) * k / 2;
d__1 = ap[i__1].r;
d__2 = d_imag(&ap[k - 1 + (k - 1) * k / 2]);
d__ = dlapy2_(&d__1, &d__2);
i__1 = k - 1 + (k - 2) * (k - 1) / 2;
d22 = ap[i__1].r / d__;
i__1 = k + (k - 1) * k / 2;
d11 = ap[i__1].r / d__;
tt = 1. / (d11 * d22 - 1.);
i__1 = k - 1 + (k - 1) * k / 2;
z__1.r = ap[i__1].r / d__;
z__1.i = ap[i__1].i / d__; // , expr subst
d12.r = z__1.r;
d12.i = z__1.i; // , expr subst
d__ = tt / d__;
for (j = k - 2;
j >= 1;
--j)
{
i__1 = j + (k - 2) * (k - 1) / 2;
z__3.r = d11 * ap[i__1].r;
z__3.i = d11 * ap[i__1].i; // , expr subst
d_cnjg(&z__5, &d12);
i__2 = j + (k - 1) * k / 2;
z__4.r = z__5.r * ap[i__2].r - z__5.i * ap[i__2].i;
z__4.i = z__5.r * ap[i__2].i + z__5.i * ap[ i__2].r; // , expr subst
z__2.r = z__3.r - z__4.r;
z__2.i = z__3.i - z__4.i; // , expr subst
z__1.r = d__ * z__2.r;
z__1.i = d__ * z__2.i; // , expr subst
wkm1.r = z__1.r;
wkm1.i = z__1.i; // , expr subst
i__1 = j + (k - 1) * k / 2;
z__3.r = d22 * ap[i__1].r;
z__3.i = d22 * ap[i__1].i; // , expr subst
i__2 = j + (k - 2) * (k - 1) / 2;
z__4.r = d12.r * ap[i__2].r - d12.i * ap[i__2].i;
z__4.i = d12.r * ap[i__2].i + d12.i * ap[i__2] .r; // , expr subst
z__2.r = z__3.r - z__4.r;
z__2.i = z__3.i - z__4.i; // , expr subst
z__1.r = d__ * z__2.r;
z__1.i = d__ * z__2.i; // , expr subst
wk.r = z__1.r;
wk.i = z__1.i; // , expr subst
for (i__ = j;
i__ >= 1;
--i__)
{
i__1 = i__ + (j - 1) * j / 2;
i__2 = i__ + (j - 1) * j / 2;
i__3 = i__ + (k - 1) * k / 2;
d_cnjg(&z__4, &wk);
z__3.r = ap[i__3].r * z__4.r - ap[i__3].i * z__4.i;
z__3.i = ap[i__3].r * z__4.i + ap[ i__3].i * z__4.r; // , expr subst
z__2.r = ap[i__2].r - z__3.r;
z__2.i = ap[i__2].i - z__3.i; // , expr subst
i__4 = i__ + (k - 2) * (k - 1) / 2;
d_cnjg(&z__6, &wkm1);
z__5.r = ap[i__4].r * z__6.r - ap[i__4].i * z__6.i;
z__5.i = ap[i__4].r * z__6.i + ap[ i__4].i * z__6.r; // , expr subst
z__1.r = z__2.r - z__5.r;
z__1.i = z__2.i - z__5.i; // , expr subst
ap[i__1].r = z__1.r;
ap[i__1].i = z__1.i; // , expr subst
/* L40: */
}
i__1 = j + (k - 1) * k / 2;
ap[i__1].r = wk.r;
ap[i__1].i = wk.i; // , expr subst
i__1 = j + (k - 2) * (k - 1) / 2;
ap[i__1].r = wkm1.r;
ap[i__1].i = wkm1.i; // , expr subst
i__1 = j + (j - 1) * j / 2;
i__2 = j + (j - 1) * j / 2;
d__1 = ap[i__2].r;
z__1.r = d__1;
z__1.i = 0.; // , expr subst
ap[i__1].r = z__1.r;
ap[i__1].i = z__1.i; // , expr subst
/* L50: */
}
}
}
}
/* 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;
kc = knc - k;
goto L10;
}
else
{
/* Factorize A as L*D*L**H 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;
kc = 1;
npp = *n * (*n + 1) / 2;
L60:
knc = kc;
/* If K > N, exit from loop */
if (k > *n)
{
goto L110;
}
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 = kc;
absakk = (d__1 = ap[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, &ap[kc + 1], &c__1);
i__1 = kc + imax - k;
colmax = (d__1 = ap[i__1].r, abs(d__1)) + (d__2 = d_imag(&ap[kc + imax - k]), abs(d__2));
}
else
{
colmax = 0.;
}
if (max(absakk,colmax) == 0.)
{
/* Column K is zero: set INFO and continue */
if (*info == 0)
{
*info = k;
}
kp = k;
i__1 = kc;
i__2 = kc;
d__1 = ap[i__2].r;
ap[i__1].r = d__1;
ap[i__1].i = 0.; // , expr subst
}
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 */
rowmax = 0.;
kx = kc + imax - k;
i__1 = imax - 1;
for (j = k;
j <= i__1;
++j)
{
i__2 = kx;
if ((d__1 = ap[i__2].r, abs(d__1)) + (d__2 = d_imag(&ap[ kx]), abs(d__2)) > rowmax)
{
i__2 = kx;
rowmax = (d__1 = ap[i__2].r, abs(d__1)) + (d__2 = d_imag(&ap[kx]), abs(d__2));
jmax = j;
}
kx = kx + *n - j;
/* L70: */
}
kpc = npp - (*n - imax + 1) * (*n - imax + 2) / 2 + 1;
if (imax < *n)
{
i__1 = *n - imax;
jmax = imax + izamax_(&i__1, &ap[kpc + 1], &c__1);
/* Computing MAX */
i__1 = kpc + jmax - imax;
d__3 = rowmax;
d__4 = (d__1 = ap[i__1].r, abs(d__1)) + ( d__2 = d_imag(&ap[kpc + jmax - imax]), abs(d__2)); // , expr subst
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 = kpc;
if ((d__1 = ap[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 (kstep == 2)
{
knc = knc + *n - k + 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, &ap[knc + kp - kk + 1], &c__1, &ap[kpc + 1], &c__1);
}
kx = knc + kp - kk;
i__1 = kp - 1;
for (j = kk + 1;
j <= i__1;
++j)
{
kx = kx + *n - j + 1;
d_cnjg(&z__1, &ap[knc + j - kk]);
t.r = z__1.r;
t.i = z__1.i; // , expr subst
i__2 = knc + j - kk;
d_cnjg(&z__1, &ap[kx]);
ap[i__2].r = z__1.r;
ap[i__2].i = z__1.i; // , expr subst
i__2 = kx;
ap[i__2].r = t.r;
ap[i__2].i = t.i; // , expr subst
/* L80: */
}
i__1 = knc + kp - kk;
d_cnjg(&z__1, &ap[knc + kp - kk]);
ap[i__1].r = z__1.r;
ap[i__1].i = z__1.i; // , expr subst
i__1 = knc;
r1 = ap[i__1].r;
i__1 = knc;
i__2 = kpc;
d__1 = ap[i__2].r;
ap[i__1].r = d__1;
ap[i__1].i = 0.; // , expr subst
i__1 = kpc;
ap[i__1].r = r1;
ap[i__1].i = 0.; // , expr subst
if (kstep == 2)
{
i__1 = kc;
i__2 = kc;
d__1 = ap[i__2].r;
ap[i__1].r = d__1;
ap[i__1].i = 0.; // , expr subst
i__1 = kc + 1;
t.r = ap[i__1].r;
t.i = ap[i__1].i; // , expr subst
i__1 = kc + 1;
i__2 = kc + kp - k;
ap[i__1].r = ap[i__2].r;
ap[i__1].i = ap[i__2].i; // , expr subst
i__1 = kc + kp - k;
ap[i__1].r = t.r;
ap[i__1].i = t.i; // , expr subst
}
}
else
{
i__1 = kc;
i__2 = kc;
d__1 = ap[i__2].r;
ap[i__1].r = d__1;
ap[i__1].i = 0.; // , expr subst
if (kstep == 2)
{
i__1 = knc;
i__2 = knc;
d__1 = ap[i__2].r;
ap[i__1].r = d__1;
ap[i__1].i = 0.; // , expr subst
}
}
/* 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)**H = A - W(k)*(1/D(k))*W(k)**H */
i__1 = kc;
r1 = 1. / ap[i__1].r;
i__1 = *n - k;
d__1 = -r1;
zhpr_(uplo, &i__1, &d__1, &ap[kc + 1], &c__1, &ap[kc + *n - k + 1]);
/* Store L(k) in column K */
i__1 = *n - k;
zdscal_(&i__1, &r1, &ap[kc + 1], &c__1);
}
}
else
{
/* 2-by-2 pivot block D(k): columns K and K+1 now hold */
/* ( W(k) W(k+1) ) = ( L(k) L(k+1) )*D(k) */
/* where L(k) and L(k+1) are the k-th and (k+1)-th columns */
/* of L */
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) )**H */
/* = A - ( W(k) W(k+1) )*inv(D(k))*( W(k) W(k+1) )**H */
/* where L(k) and L(k+1) are the k-th and (k+1)-th */
/* columns of L */
i__1 = k + 1 + (k - 1) * ((*n << 1) - k) / 2;
d__1 = ap[i__1].r;
d__2 = d_imag(&ap[k + 1 + (k - 1) * ((*n << 1) - k) / 2]);
d__ = dlapy2_(&d__1, &d__2);
i__1 = k + 1 + k * ((*n << 1) - k - 1) / 2;
d11 = ap[i__1].r / d__;
i__1 = k + (k - 1) * ((*n << 1) - k) / 2;
d22 = ap[i__1].r / d__;
tt = 1. / (d11 * d22 - 1.);
i__1 = k + 1 + (k - 1) * ((*n << 1) - k) / 2;
z__1.r = ap[i__1].r / d__;
z__1.i = ap[i__1].i / d__; // , expr subst
d21.r = z__1.r;
d21.i = z__1.i; // , expr subst
d__ = tt / d__;
i__1 = *n;
for (j = k + 2;
j <= i__1;
++j)
{
i__2 = j + (k - 1) * ((*n << 1) - k) / 2;
z__3.r = d11 * ap[i__2].r;
z__3.i = d11 * ap[i__2].i; // , expr subst
i__3 = j + k * ((*n << 1) - k - 1) / 2;
z__4.r = d21.r * ap[i__3].r - d21.i * ap[i__3].i;
z__4.i = d21.r * ap[i__3].i + d21.i * ap[i__3] .r; // , expr subst
z__2.r = z__3.r - z__4.r;
z__2.i = z__3.i - z__4.i; // , expr subst
z__1.r = d__ * z__2.r;
z__1.i = d__ * z__2.i; // , expr subst
wk.r = z__1.r;
wk.i = z__1.i; // , expr subst
i__2 = j + k * ((*n << 1) - k - 1) / 2;
z__3.r = d22 * ap[i__2].r;
z__3.i = d22 * ap[i__2].i; // , expr subst
d_cnjg(&z__5, &d21);
i__3 = j + (k - 1) * ((*n << 1) - k) / 2;
z__4.r = z__5.r * ap[i__3].r - z__5.i * ap[i__3].i;
z__4.i = z__5.r * ap[i__3].i + z__5.i * ap[ i__3].r; // , expr subst
z__2.r = z__3.r - z__4.r;
z__2.i = z__3.i - z__4.i; // , expr subst
z__1.r = d__ * z__2.r;
z__1.i = d__ * z__2.i; // , expr subst
wkp1.r = z__1.r;
wkp1.i = z__1.i; // , expr subst
i__2 = *n;
for (i__ = j;
i__ <= i__2;
++i__)
{
i__3 = i__ + (j - 1) * ((*n << 1) - j) / 2;
i__4 = i__ + (j - 1) * ((*n << 1) - j) / 2;
i__5 = i__ + (k - 1) * ((*n << 1) - k) / 2;
d_cnjg(&z__4, &wk);
z__3.r = ap[i__5].r * z__4.r - ap[i__5].i * z__4.i;
z__3.i = ap[i__5].r * z__4.i + ap[ i__5].i * z__4.r; // , expr subst
z__2.r = ap[i__4].r - z__3.r;
z__2.i = ap[i__4].i - z__3.i; // , expr subst
i__6 = i__ + k * ((*n << 1) - k - 1) / 2;
d_cnjg(&z__6, &wkp1);
z__5.r = ap[i__6].r * z__6.r - ap[i__6].i * z__6.i;
z__5.i = ap[i__6].r * z__6.i + ap[ i__6].i * z__6.r; // , expr subst
z__1.r = z__2.r - z__5.r;
z__1.i = z__2.i - z__5.i; // , expr subst
ap[i__3].r = z__1.r;
ap[i__3].i = z__1.i; // , expr subst
/* L90: */
}
i__2 = j + (k - 1) * ((*n << 1) - k) / 2;
ap[i__2].r = wk.r;
ap[i__2].i = wk.i; // , expr subst
i__2 = j + k * ((*n << 1) - k - 1) / 2;
ap[i__2].r = wkp1.r;
ap[i__2].i = wkp1.i; // , expr subst
i__2 = j + (j - 1) * ((*n << 1) - j) / 2;
i__3 = j + (j - 1) * ((*n << 1) - j) / 2;
d__1 = ap[i__3].r;
z__1.r = d__1;
z__1.i = 0.; // , expr subst
ap[i__2].r = z__1.r;
ap[i__2].i = z__1.i; // , expr subst
/* L100: */
}
}
}
}
/* 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;
kc = knc + *n - k + 2;
goto L60;
}
L110:
return 0;
/* End of ZHPTRF */
}
/* Subroutine */ int zpptrf_(char *uplo, integer *n, doublecomplex *ap,
integer *info)
{
/* -- LAPACK 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
=======
ZPPTRF computes the Cholesky factorization of a complex Hermitian
positive definite matrix A stored in packed format.
The factorization has the form
A = U**H * U, if UPLO = 'U', or
A = L * L**H, if UPLO = 'L',
where U is an upper triangular matrix and L is lower triangular.
Arguments
=========
UPLO (input) CHARACTER*1
= 'U': Upper triangle of A is stored;
= 'L': Lower triangle of A is stored.
N (input) INTEGER
The order of the matrix A. N >= 0.
AP (input/output) COMPLEX*16 array, dimension (N*(N+1)/2)
On entry, the upper or lower triangle of the Hermitian matrix
A, packed columnwise in a linear array. The j-th column of A
is stored in the array AP as follows:
if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j;
if UPLO = 'L', AP(i + (j-1)*(2n-j)/2) = A(i,j) for j<=i<=n.
See below for further details.
On exit, if INFO = 0, the triangular factor U or L from the
Cholesky factorization A = U**H*U or A = L*L**H, in the same
storage format as A.
INFO (output) INTEGER
= 0: successful exit
< 0: if INFO = -i, the i-th argument had an illegal value
> 0: if INFO = i, the leading minor of order i is not
positive definite, and the factorization could not be
completed.
Further Details
===============
The packed storage scheme is illustrated by the following example
when N = 4, UPLO = 'U':
Two-dimensional storage of the Hermitian matrix A:
a11 a12 a13 a14
a22 a23 a24
a33 a34 (aij = conjg(aji))
a44
Packed storage of the upper triangle of A:
AP = [ a11, a12, a22, a13, a23, a33, a14, a24, a34, a44 ]
=====================================================================
Test the input parameters.
Parameter adjustments */
/* Table of constant values */
static integer c__1 = 1;
static doublereal c_b16 = -1.;
/* System generated locals */
integer i__1, i__2, i__3;
doublereal d__1;
doublecomplex z__1, z__2;
/* Builtin functions */
double sqrt(doublereal);
/* Local variables */
extern /* Subroutine */ int zhpr_(char *, integer *, doublereal *,
doublecomplex *, integer *, doublecomplex *);
static integer j;
extern logical lsame_(char *, char *);
extern /* Double Complex */ VOID zdotc_(doublecomplex *, integer *,
doublecomplex *, integer *, doublecomplex *, integer *);
static logical upper;
extern /* Subroutine */ int ztpsv_(char *, char *, char *, integer *,
doublecomplex *, doublecomplex *, integer *);
static integer jc, jj;
extern /* Subroutine */ int xerbla_(char *, integer *), zdscal_(
integer *, doublereal *, doublecomplex *, integer *);
static doublereal ajj;
--ap;
/* Function Body */
*info = 0;
upper = lsame_(uplo, "U");
if (! upper && ! lsame_(uplo, "L")) {
*info = -1;
} else if (*n < 0) {
*info = -2;
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("ZPPTRF", &i__1);
return 0;
}
/* Quick return if possible */
if (*n == 0) {
return 0;
}
if (upper) {
/* Compute the Cholesky factorization A = U'*U. */
jj = 0;
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
jc = jj + 1;
jj += j;
/* Compute elements 1:J-1 of column J. */
if (j > 1) {
i__2 = j - 1;
ztpsv_("Upper", "Conjugate transpose", "Non-unit", &i__2, &ap[
1], &ap[jc], &c__1);
}
/* Compute U(J,J) and test for non-positive-definiteness. */
i__2 = jj;
d__1 = ap[i__2].r;
i__3 = j - 1;
zdotc_(&z__2, &i__3, &ap[jc], &c__1, &ap[jc], &c__1);
z__1.r = d__1 - z__2.r, z__1.i = -z__2.i;
ajj = z__1.r;
if (ajj <= 0.) {
i__2 = jj;
ap[i__2].r = ajj, ap[i__2].i = 0.;
goto L30;
}
i__2 = jj;
d__1 = sqrt(ajj);
ap[i__2].r = d__1, ap[i__2].i = 0.;
/* L10: */
}
} else {
/* Compute the Cholesky factorization A = L*L'. */
jj = 1;
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
/* Compute L(J,J) and test for non-positive-definiteness. */
i__2 = jj;
ajj = ap[i__2].r;
if (ajj <= 0.) {
i__2 = jj;
ap[i__2].r = ajj, ap[i__2].i = 0.;
goto L30;
}
ajj = sqrt(ajj);
i__2 = jj;
ap[i__2].r = ajj, ap[i__2].i = 0.;
/* Compute elements J+1:N of column J and update the trailing
submatrix. */
if (j < *n) {
i__2 = *n - j;
d__1 = 1. / ajj;
zdscal_(&i__2, &d__1, &ap[jj + 1], &c__1);
i__2 = *n - j;
zhpr_("Lower", &i__2, &c_b16, &ap[jj + 1], &c__1, &ap[jj + *n
- j + 1]);
jj = jj + *n - j + 1;
}
/* L20: */
}
}
goto L40;
L30:
*info = j;
L40:
return 0;
/* End of ZPPTRF */
} /* zpptrf_ */
