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