int f2c_ztpmv(char* uplo, char* trans, char* diag, integer* N, doublecomplex* Ap, doublecomplex* X, integer* incX) { ztpmv_(uplo, trans, diag, N, Ap, X, incX); return 0; }
/* Subroutine */ int ztpt01_(char *uplo, char *diag, integer *n, doublecomplex *ap, doublecomplex *ainvp, doublereal *rcond, doublereal *rwork, doublereal *resid) { /* System generated locals */ integer i__1, i__2, i__3; doublecomplex z__1; /* Local variables */ integer j, jc; doublereal eps; extern logical lsame_(char *, char *); doublereal anorm; logical unitd; extern /* Subroutine */ int ztpmv_(char *, char *, char *, integer *, doublecomplex *, doublecomplex *, integer *); extern doublereal dlamch_(char *); doublereal ainvnm; extern doublereal zlantp_(char *, 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 */ /* ======= */ /* ZTPT01 computes the residual for a triangular matrix A times its */ /* inverse when A is stored in packed format: */ /* RESID = norm(A*AINV - I) / ( N * norm(A) * norm(AINV) * EPS ), */ /* where EPS is the machine epsilon. */ /* Arguments */ /* ========== */ /* UPLO (input) CHARACTER*1 */ /* Specifies whether the matrix A is upper or lower triangular. */ /* = 'U': Upper triangular */ /* = 'L': Lower triangular */ /* DIAG (input) CHARACTER*1 */ /* Specifies whether or not the matrix A is unit triangular. */ /* = 'N': Non-unit triangular */ /* = 'U': Unit triangular */ /* N (input) INTEGER */ /* The order of the matrix A. N >= 0. */ /* AP (input) COMPLEX*16 array, dimension (N*(N+1)/2) */ /* The original upper or lower triangular 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((j-1)*j/2 + i) = A(i,j) for 1<=i<=j; */ /* if UPLO = 'L', */ /* AP((j-1)*(n-j) + j*(j+1)/2 + i-j) = A(i,j) for j<=i<=n. */ /* AINVP (input) COMPLEX*16 array, dimension (N*(N+1)/2) */ /* On entry, the (triangular) inverse of the matrix A, packed */ /* columnwise in a linear array as in AP. */ /* On exit, the contents of AINVP are destroyed. */ /* RCOND (output) DOUBLE PRECISION */ /* The reciprocal condition number of A, computed as */ /* 1/(norm(A) * norm(AINV)). */ /* RWORK (workspace) DOUBLE PRECISION array, dimension (N) */ /* RESID (output) DOUBLE PRECISION */ /* norm(A*AINV - I) / ( N * norm(A) * norm(AINV) * EPS ) */ /* ===================================================================== */ /* .. Parameters .. */ /* .. */ /* .. Local Scalars .. */ /* .. */ /* .. External Functions .. */ /* .. */ /* .. External Subroutines .. */ /* .. */ /* .. Intrinsic Functions .. */ /* .. */ /* .. Executable Statements .. */ /* Quick exit if N = 0. */ /* Parameter adjustments */ --rwork; --ainvp; --ap; /* Function Body */ if (*n <= 0) { *rcond = 1.; *resid = 0.; return 0; } /* Exit with RESID = 1/EPS if ANORM = 0 or AINVNM = 0. */ eps = dlamch_("Epsilon"); anorm = zlantp_("1", uplo, diag, n, &ap[1], &rwork[1]); ainvnm = zlantp_("1", uplo, diag, n, &ainvp[1], &rwork[1]); if (anorm <= 0. || ainvnm <= 0.) { *rcond = 0.; *resid = 1. / eps; return 0; } *rcond = 1. / anorm / ainvnm; /* Compute A * AINV, overwriting AINV. */ unitd = lsame_(diag, "U"); if (lsame_(uplo, "U")) { jc = 1; i__1 = *n; for (j = 1; j <= i__1; ++j) { if (unitd) { i__2 = jc + j - 1; ainvp[i__2].r = 1., ainvp[i__2].i = 0.; } /* Form the j-th column of A*AINV. */ ztpmv_("Upper", "No transpose", diag, &j, &ap[1], &ainvp[jc], & c__1); /* Subtract 1 from the diagonal to form A*AINV - I. */ i__2 = jc + j - 1; i__3 = jc + j - 1; z__1.r = ainvp[i__3].r - 1., z__1.i = ainvp[i__3].i; ainvp[i__2].r = z__1.r, ainvp[i__2].i = z__1.i; jc += j; /* L10: */ } } else { jc = 1; i__1 = *n; for (j = 1; j <= i__1; ++j) { if (unitd) { i__2 = jc; ainvp[i__2].r = 1., ainvp[i__2].i = 0.; } /* Form the j-th column of A*AINV. */ i__2 = *n - j + 1; ztpmv_("Lower", "No transpose", diag, &i__2, &ap[jc], &ainvp[jc], &c__1); /* Subtract 1 from the diagonal to form A*AINV - I. */ i__2 = jc; i__3 = jc; z__1.r = ainvp[i__3].r - 1., z__1.i = ainvp[i__3].i; ainvp[i__2].r = z__1.r, ainvp[i__2].i = z__1.i; jc = jc + *n - j + 1; /* L20: */ } } /* Compute norm(A*AINV - I) / (N * norm(A) * norm(AINV) * EPS) */ *resid = zlantp_("1", uplo, "Non-unit", n, &ainvp[1], &rwork[1]); *resid = *resid * *rcond / (doublereal) (*n) / eps; return 0; /* End of ZTPT01 */ } /* ztpt01_ */
/* Subroutine */ int ztptri_(char *uplo, char *diag, integer *n, doublecomplex *ap, 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 ======= ZTPTRI computes the inverse of a complex upper or lower triangular matrix A stored in packed format. Arguments ========= UPLO (input) CHARACTER*1 = 'U': A is upper triangular; = 'L': A is lower triangular. DIAG (input) CHARACTER*1 = 'N': A is non-unit triangular; = 'U': A is unit triangular. 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 triangular matrix A, stored 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)*((2*n-j)/2) = A(i,j) for j<=i<=n. See below for further details. On exit, the (triangular) inverse of the original matrix, in the same packed storage format. INFO (output) INTEGER = 0: successful exit < 0: if INFO = -i, the i-th argument had an illegal value > 0: if INFO = i, A(i,i) is exactly zero. The triangular matrix is singular and its inverse can not be computed. Further Details =============== A triangular matrix A can be transferred to packed storage using one of the following program segments: UPLO = 'U': UPLO = 'L': JC = 1 JC = 1 DO 2 J = 1, N DO 2 J = 1, N DO 1 I = 1, J DO 1 I = J, N AP(JC+I-1) = A(I,J) AP(JC+I-J) = A(I,J) 1 CONTINUE 1 CONTINUE JC = JC + J JC = JC + N - J + 1 2 CONTINUE 2 CONTINUE ===================================================================== Test the input parameters. Parameter adjustments Function Body */ /* Table of constant values */ static doublecomplex c_b1 = {1.,0.}; static integer c__1 = 1; /* System generated locals */ integer i__1, i__2; doublecomplex z__1; /* Builtin functions */ void z_div(doublecomplex *, doublecomplex *, doublecomplex *); /* Local variables */ static integer j; extern logical lsame_(char *, char *); extern /* Subroutine */ int zscal_(integer *, doublecomplex *, doublecomplex *, integer *); static logical upper; extern /* Subroutine */ int ztpmv_(char *, char *, char *, integer *, doublecomplex *, doublecomplex *, integer *); static integer jc, jj; extern /* Subroutine */ int xerbla_(char *, integer *); static integer jclast; static logical nounit; static doublecomplex ajj; #define AP(I) ap[(I)-1] *info = 0; upper = lsame_(uplo, "U"); nounit = lsame_(diag, "N"); if (! upper && ! lsame_(uplo, "L")) { *info = -1; } else if (! nounit && ! lsame_(diag, "U")) { *info = -2; } else if (*n < 0) { *info = -3; } if (*info != 0) { i__1 = -(*info); xerbla_("ZTPTRI", &i__1); return 0; } /* Check for singularity if non-unit. */ if (nounit) { if (upper) { jj = 0; i__1 = *n; for (*info = 1; *info <= i__1; ++(*info)) { jj += *info; i__2 = jj; if (AP(jj).r == 0. && AP(jj).i == 0.) { return 0; } /* L10: */ } } else { jj = 1; i__1 = *n; for (*info = 1; *info <= i__1; ++(*info)) { i__2 = jj; if (AP(jj).r == 0. && AP(jj).i == 0.) { return 0; } jj = jj + *n - *info + 1; /* L20: */ } } *info = 0; } if (upper) { /* Compute inverse of upper triangular matrix. */ jc = 1; i__1 = *n; for (j = 1; j <= *n; ++j) { if (nounit) { i__2 = jc + j - 1; z_div(&z__1, &c_b1, &AP(jc + j - 1)); AP(jc+j-1).r = z__1.r, AP(jc+j-1).i = z__1.i; i__2 = jc + j - 1; z__1.r = -AP(jc+j-1).r, z__1.i = -AP(jc+j-1).i; ajj.r = z__1.r, ajj.i = z__1.i; } else { z__1.r = -1., z__1.i = 0.; ajj.r = z__1.r, ajj.i = z__1.i; } /* Compute elements 1:j-1 of j-th column. */ i__2 = j - 1; ztpmv_("Upper", "No transpose", diag, &i__2, &AP(1), &AP(jc), & c__1); i__2 = j - 1; zscal_(&i__2, &ajj, &AP(jc), &c__1); jc += j; /* L30: */ } } else { /* Compute inverse of lower triangular matrix. */ jc = *n * (*n + 1) / 2; for (j = *n; j >= 1; --j) { if (nounit) { i__1 = jc; z_div(&z__1, &c_b1, &AP(jc)); AP(jc).r = z__1.r, AP(jc).i = z__1.i; i__1 = jc; z__1.r = -AP(jc).r, z__1.i = -AP(jc).i; ajj.r = z__1.r, ajj.i = z__1.i; } else { z__1.r = -1., z__1.i = 0.; ajj.r = z__1.r, ajj.i = z__1.i; } if (j < *n) { /* Compute elements j+1:n of j-th column. */ i__1 = *n - j; ztpmv_("Lower", "No transpose", diag, &i__1, &AP(jclast), &AP( jc + 1), &c__1); i__1 = *n - j; zscal_(&i__1, &ajj, &AP(jc + 1), &c__1); } jclast = jc; jc = jc - *n + j - 2; /* L40: */ } } return 0; /* End of ZTPTRI */ } /* ztptri_ */
void ztpmv(char uplo, char transa, char diag, int n, doublecomplex *ap, doublecomplex *x, int incx) { ztpmv_( &uplo, &transa, &diag, &n, ap, x, &incx); }
/* Subroutine */ int ztptri_(char *uplo, char *diag, integer *n, doublecomplex *ap, integer *info) { /* System generated locals */ integer i__1, i__2; doublecomplex z__1; /* Builtin functions */ void z_div(doublecomplex *, doublecomplex *, doublecomplex *); /* Local variables */ integer j, jc, jj; doublecomplex ajj; extern logical lsame_(char *, char *); extern /* Subroutine */ int zscal_(integer *, doublecomplex *, doublecomplex *, integer *); logical upper; extern /* Subroutine */ int ztpmv_(char *, char *, char *, integer *, doublecomplex *, doublecomplex *, integer *), xerbla_(char *, integer *); integer jclast; logical nounit; /* -- LAPACK routine (version 3.2) -- */ /* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ /* November 2006 */ /* .. Scalar Arguments .. */ /* .. */ /* .. Array Arguments .. */ /* .. */ /* Purpose */ /* ======= */ /* ZTPTRI computes the inverse of a complex upper or lower triangular */ /* matrix A stored in packed format. */ /* Arguments */ /* ========= */ /* UPLO (input) CHARACTER*1 */ /* = 'U': A is upper triangular; */ /* = 'L': A is lower triangular. */ /* DIAG (input) CHARACTER*1 */ /* = 'N': A is non-unit triangular; */ /* = 'U': A is unit triangular. */ /* 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 triangular matrix A, stored */ /* 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)*((2*n-j)/2) = A(i,j) for j<=i<=n. */ /* See below for further details. */ /* On exit, the (triangular) inverse of the original matrix, in */ /* the same packed storage format. */ /* INFO (output) INTEGER */ /* = 0: successful exit */ /* < 0: if INFO = -i, the i-th argument had an illegal value */ /* > 0: if INFO = i, A(i,i) is exactly zero. The triangular */ /* matrix is singular and its inverse can not be computed. */ /* Further Details */ /* =============== */ /* A triangular matrix A can be transferred to packed storage using one */ /* of the following program segments: */ /* UPLO = 'U': UPLO = 'L': */ /* JC = 1 JC = 1 */ /* DO 2 J = 1, N DO 2 J = 1, N */ /* DO 1 I = 1, J DO 1 I = J, N */ /* AP(JC+I-1) = A(I,J) AP(JC+I-J) = A(I,J) */ /* 1 CONTINUE 1 CONTINUE */ /* JC = JC + J JC = JC + N - J + 1 */ /* 2 CONTINUE 2 CONTINUE */ /* ===================================================================== */ /* .. Parameters .. */ /* .. */ /* .. Local Scalars .. */ /* .. */ /* .. External Functions .. */ /* .. */ /* .. External Subroutines .. */ /* .. */ /* .. Executable Statements .. */ /* Test the input parameters. */ /* Parameter adjustments */ --ap; /* Function Body */ *info = 0; upper = lsame_(uplo, "U"); nounit = lsame_(diag, "N"); if (! upper && ! lsame_(uplo, "L")) { *info = -1; } else if (! nounit && ! lsame_(diag, "U")) { *info = -2; } else if (*n < 0) { *info = -3; } if (*info != 0) { i__1 = -(*info); xerbla_("ZTPTRI", &i__1); return 0; } /* Check for singularity if non-unit. */ if (nounit) { if (upper) { jj = 0; i__1 = *n; for (*info = 1; *info <= i__1; ++(*info)) { jj += *info; i__2 = jj; if (ap[i__2].r == 0. && ap[i__2].i == 0.) { return 0; } /* L10: */ } } else { jj = 1; i__1 = *n; for (*info = 1; *info <= i__1; ++(*info)) { i__2 = jj; if (ap[i__2].r == 0. && ap[i__2].i == 0.) { return 0; } jj = jj + *n - *info + 1; /* L20: */ } } *info = 0; } if (upper) { /* Compute inverse of upper triangular matrix. */ jc = 1; i__1 = *n; for (j = 1; j <= i__1; ++j) { if (nounit) { i__2 = jc + j - 1; z_div(&z__1, &c_b1, &ap[jc + j - 1]); ap[i__2].r = z__1.r, ap[i__2].i = z__1.i; i__2 = jc + j - 1; z__1.r = -ap[i__2].r, z__1.i = -ap[i__2].i; ajj.r = z__1.r, ajj.i = z__1.i; } else { z__1.r = -1., z__1.i = -0.; ajj.r = z__1.r, ajj.i = z__1.i; } /* Compute elements 1:j-1 of j-th column. */ i__2 = j - 1; ztpmv_("Upper", "No transpose", diag, &i__2, &ap[1], &ap[jc], & c__1); i__2 = j - 1; zscal_(&i__2, &ajj, &ap[jc], &c__1); jc += j; /* L30: */ } } else { /* Compute inverse of lower triangular matrix. */ jc = *n * (*n + 1) / 2; for (j = *n; j >= 1; --j) { if (nounit) { i__1 = jc; z_div(&z__1, &c_b1, &ap[jc]); ap[i__1].r = z__1.r, ap[i__1].i = z__1.i; i__1 = jc; z__1.r = -ap[i__1].r, z__1.i = -ap[i__1].i; ajj.r = z__1.r, ajj.i = z__1.i; } else { z__1.r = -1., z__1.i = -0.; ajj.r = z__1.r, ajj.i = z__1.i; } if (j < *n) { /* Compute elements j+1:n of j-th column. */ i__1 = *n - j; ztpmv_("Lower", "No transpose", diag, &i__1, &ap[jclast], &ap[ jc + 1], &c__1); i__1 = *n - j; zscal_(&i__1, &ajj, &ap[jc + 1], &c__1); } jclast = jc; jc = jc - *n + j - 2; /* L40: */ } } return 0; /* End of ZTPTRI */ } /* ztptri_ */
/* Subroutine */ int zhpgst_(integer *itype, char *uplo, integer *n, doublecomplex *ap, doublecomplex *bp, integer *info) { /* System generated locals */ integer i__1, i__2, i__3, i__4; doublereal d__1, d__2; doublecomplex z__1, z__2, z__3; /* Local variables */ integer j, k, j1, k1, jj, kk; doublecomplex ct; doublereal ajj; integer j1j1; doublereal akk; integer k1k1; doublereal bjj, bkk; extern /* Subroutine */ int zhpr2_(char *, integer *, doublecomplex *, doublecomplex *, integer *, doublecomplex *, integer *, doublecomplex *); extern logical lsame_(char *, char *); extern /* Double Complex */ VOID zdotc_(doublecomplex *, integer *, doublecomplex *, integer *, doublecomplex *, integer *); logical upper; extern /* Subroutine */ int zhpmv_(char *, integer *, doublecomplex *, doublecomplex *, doublecomplex *, integer *, doublecomplex *, doublecomplex *, integer *), zaxpy_(integer *, doublecomplex *, doublecomplex *, integer *, doublecomplex *, integer *), ztpmv_(char *, char *, char *, integer *, doublecomplex *, doublecomplex *, integer *), ztpsv_(char *, char *, char *, integer *, doublecomplex * , doublecomplex *, integer *), xerbla_( char *, integer *), zdscal_(integer *, doublereal *, doublecomplex *, integer *); /* -- LAPACK routine (version 3.2) -- */ /* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ /* November 2006 */ /* .. Scalar Arguments .. */ /* .. */ /* .. Array Arguments .. */ /* .. */ /* Purpose */ /* ======= */ /* ZHPGST reduces a complex Hermitian-definite generalized */ /* eigenproblem to standard form, using packed storage. */ /* If ITYPE = 1, the problem is A*x = lambda*B*x, */ /* and A is overwritten by inv(U**H)*A*inv(U) or inv(L)*A*inv(L**H) */ /* If ITYPE = 2 or 3, the problem is A*B*x = lambda*x or */ /* B*A*x = lambda*x, and A is overwritten by U*A*U**H or L**H*A*L. */ /* B must have been previously factorized as U**H*U or L*L**H by ZPPTRF. */ /* Arguments */ /* ========= */ /* ITYPE (input) INTEGER */ /* = 1: compute inv(U**H)*A*inv(U) or inv(L)*A*inv(L**H); */ /* = 2 or 3: compute U*A*U**H or L**H*A*L. */ /* UPLO (input) CHARACTER*1 */ /* = 'U': Upper triangle of A is stored and B is factored as */ /* U**H*U; */ /* = 'L': Lower triangle of A is stored and B is factored as */ /* L*L**H. */ /* N (input) INTEGER */ /* The order of the matrices A and B. 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, if INFO = 0, the transformed matrix, stored in the */ /* same format as A. */ /* BP (input) COMPLEX*16 array, dimension (N*(N+1)/2) */ /* The triangular factor from the Cholesky factorization of B, */ /* stored in the same format as A, as returned by ZPPTRF. */ /* INFO (output) INTEGER */ /* = 0: successful exit */ /* < 0: if INFO = -i, the i-th argument had an illegal value */ /* ===================================================================== */ /* .. Parameters .. */ /* .. */ /* .. Local Scalars .. */ /* .. */ /* .. External Subroutines .. */ /* .. */ /* .. Intrinsic Functions .. */ /* .. */ /* .. External Functions .. */ /* .. */ /* .. Executable Statements .. */ /* Test the input parameters. */ /* Parameter adjustments */ --bp; --ap; /* Function Body */ *info = 0; upper = lsame_(uplo, "U"); if (*itype < 1 || *itype > 3) { *info = -1; } else if (! upper && ! lsame_(uplo, "L")) { *info = -2; } else if (*n < 0) { *info = -3; } if (*info != 0) { i__1 = -(*info); xerbla_("ZHPGST", &i__1); return 0; } if (*itype == 1) { if (upper) { /* Compute inv(U')*A*inv(U) */ /* J1 and JJ are the indices of A(1,j) and A(j,j) */ jj = 0; i__1 = *n; for (j = 1; j <= i__1; ++j) { j1 = jj + 1; jj += j; /* Compute the j-th column of the upper triangle of A */ i__2 = jj; i__3 = jj; d__1 = ap[i__3].r; ap[i__2].r = d__1, ap[i__2].i = 0.; i__2 = jj; bjj = bp[i__2].r; ztpsv_(uplo, "Conjugate transpose", "Non-unit", &j, &bp[1], & ap[j1], &c__1); i__2 = j - 1; z__1.r = -1., z__1.i = -0.; zhpmv_(uplo, &i__2, &z__1, &ap[1], &bp[j1], &c__1, &c_b1, &ap[ j1], &c__1); i__2 = j - 1; d__1 = 1. / bjj; zdscal_(&i__2, &d__1, &ap[j1], &c__1); i__2 = jj; i__3 = jj; i__4 = j - 1; zdotc_(&z__3, &i__4, &ap[j1], &c__1, &bp[j1], &c__1); z__2.r = ap[i__3].r - z__3.r, z__2.i = ap[i__3].i - z__3.i; z__1.r = z__2.r / bjj, z__1.i = z__2.i / bjj; ap[i__2].r = z__1.r, ap[i__2].i = z__1.i; /* L10: */ } } else { /* Compute inv(L)*A*inv(L') */ /* KK and K1K1 are the indices of A(k,k) and A(k+1,k+1) */ kk = 1; i__1 = *n; for (k = 1; k <= i__1; ++k) { k1k1 = kk + *n - k + 1; /* Update the lower triangle of A(k:n,k:n) */ i__2 = kk; akk = ap[i__2].r; i__2 = kk; bkk = bp[i__2].r; /* Computing 2nd power */ d__1 = bkk; akk /= d__1 * d__1; i__2 = kk; ap[i__2].r = akk, ap[i__2].i = 0.; if (k < *n) { i__2 = *n - k; d__1 = 1. / bkk; zdscal_(&i__2, &d__1, &ap[kk + 1], &c__1); d__1 = akk * -.5; ct.r = d__1, ct.i = 0.; i__2 = *n - k; zaxpy_(&i__2, &ct, &bp[kk + 1], &c__1, &ap[kk + 1], &c__1) ; i__2 = *n - k; z__1.r = -1., z__1.i = -0.; zhpr2_(uplo, &i__2, &z__1, &ap[kk + 1], &c__1, &bp[kk + 1] , &c__1, &ap[k1k1]); i__2 = *n - k; zaxpy_(&i__2, &ct, &bp[kk + 1], &c__1, &ap[kk + 1], &c__1) ; i__2 = *n - k; ztpsv_(uplo, "No transpose", "Non-unit", &i__2, &bp[k1k1], &ap[kk + 1], &c__1); } kk = k1k1; /* L20: */ } } } else { if (upper) { /* Compute U*A*U' */ /* K1 and KK are the indices of A(1,k) and A(k,k) */ kk = 0; i__1 = *n; for (k = 1; k <= i__1; ++k) { k1 = kk + 1; kk += k; /* Update the upper triangle of A(1:k,1:k) */ i__2 = kk; akk = ap[i__2].r; i__2 = kk; bkk = bp[i__2].r; i__2 = k - 1; ztpmv_(uplo, "No transpose", "Non-unit", &i__2, &bp[1], &ap[ k1], &c__1); d__1 = akk * .5; ct.r = d__1, ct.i = 0.; i__2 = k - 1; zaxpy_(&i__2, &ct, &bp[k1], &c__1, &ap[k1], &c__1); i__2 = k - 1; zhpr2_(uplo, &i__2, &c_b1, &ap[k1], &c__1, &bp[k1], &c__1, & ap[1]); i__2 = k - 1; zaxpy_(&i__2, &ct, &bp[k1], &c__1, &ap[k1], &c__1); i__2 = k - 1; zdscal_(&i__2, &bkk, &ap[k1], &c__1); i__2 = kk; /* Computing 2nd power */ d__2 = bkk; d__1 = akk * (d__2 * d__2); ap[i__2].r = d__1, ap[i__2].i = 0.; /* L30: */ } } else { /* Compute L'*A*L */ /* JJ and J1J1 are the indices of A(j,j) and A(j+1,j+1) */ jj = 1; i__1 = *n; for (j = 1; j <= i__1; ++j) { j1j1 = jj + *n - j + 1; /* Compute the j-th column of the lower triangle of A */ i__2 = jj; ajj = ap[i__2].r; i__2 = jj; bjj = bp[i__2].r; i__2 = jj; d__1 = ajj * bjj; i__3 = *n - j; zdotc_(&z__2, &i__3, &ap[jj + 1], &c__1, &bp[jj + 1], &c__1); z__1.r = d__1 + z__2.r, z__1.i = z__2.i; ap[i__2].r = z__1.r, ap[i__2].i = z__1.i; i__2 = *n - j; zdscal_(&i__2, &bjj, &ap[jj + 1], &c__1); i__2 = *n - j; zhpmv_(uplo, &i__2, &c_b1, &ap[j1j1], &bp[jj + 1], &c__1, & c_b1, &ap[jj + 1], &c__1); i__2 = *n - j + 1; ztpmv_(uplo, "Conjugate transpose", "Non-unit", &i__2, &bp[jj] , &ap[jj], &c__1); jj = j1j1; /* L40: */ } } } return 0; /* End of ZHPGST */ } /* zhpgst_ */
/* Subroutine */ int ztprfs_(char *uplo, char *trans, char *diag, integer *n, integer *nrhs, doublecomplex *ap, doublecomplex *b, integer *ldb, doublecomplex *x, integer *ldx, doublereal *ferr, doublereal *berr, doublecomplex *work, doublereal *rwork, integer *info) { /* System generated locals */ integer b_dim1, b_offset, x_dim1, x_offset, i__1, i__2, i__3, i__4, i__5; doublereal d__1, d__2, d__3, d__4; doublecomplex z__1; /* Builtin functions */ double d_imag(doublecomplex *); /* Local variables */ integer i__, j, k; doublereal s; integer kc; doublereal xk; integer nz; doublereal eps; integer kase; doublereal safe1, safe2; extern logical lsame_(char *, char *); integer isave[3]; logical upper; extern /* Subroutine */ int zcopy_(integer *, doublecomplex *, integer *, doublecomplex *, integer *), zaxpy_(integer *, doublecomplex *, doublecomplex *, integer *, doublecomplex *, integer *), ztpmv_( char *, char *, char *, integer *, doublecomplex *, doublecomplex *, integer *), ztpsv_(char *, char *, char *, integer *, doublecomplex *, doublecomplex *, integer *), zlacn2_(integer *, doublecomplex *, doublecomplex *, doublereal *, integer *, integer *); extern doublereal dlamch_(char *); doublereal safmin; extern /* Subroutine */ int xerbla_(char *, integer *); logical notran; char transn[1], transt[1]; logical nounit; doublereal lstres; /* -- LAPACK routine (version 3.2) -- */ /* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ /* November 2006 */ /* Modified to call ZLACN2 in place of ZLACON, 10 Feb 03, SJH. */ /* .. Scalar Arguments .. */ /* .. */ /* .. Array Arguments .. */ /* .. */ /* Purpose */ /* ======= */ /* ZTPRFS provides error bounds and backward error estimates for the */ /* solution to a system of linear equations with a triangular packed */ /* coefficient matrix. */ /* The solution matrix X must be computed by ZTPTRS or some other */ /* means before entering this routine. ZTPRFS does not do iterative */ /* refinement because doing so cannot improve the backward error. */ /* Arguments */ /* ========= */ /* UPLO (input) CHARACTER*1 */ /* = 'U': A is upper triangular; */ /* = 'L': A is lower triangular. */ /* TRANS (input) CHARACTER*1 */ /* Specifies the form of the system of equations: */ /* = 'N': A * X = B (No transpose) */ /* = 'T': A**T * X = B (Transpose) */ /* = 'C': A**H * X = B (Conjugate transpose) */ /* DIAG (input) CHARACTER*1 */ /* = 'N': A is non-unit triangular; */ /* = 'U': A is unit triangular. */ /* N (input) INTEGER */ /* The order of the matrix A. N >= 0. */ /* NRHS (input) INTEGER */ /* The number of right hand sides, i.e., the number of columns */ /* of the matrices B and X. NRHS >= 0. */ /* AP (input) COMPLEX*16 array, dimension (N*(N+1)/2) */ /* The upper or lower triangular 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. */ /* If DIAG = 'U', the diagonal elements of A are not referenced */ /* and are assumed to be 1. */ /* B (input) COMPLEX*16 array, dimension (LDB,NRHS) */ /* The right hand side matrix B. */ /* LDB (input) INTEGER */ /* The leading dimension of the array B. LDB >= max(1,N). */ /* X (input) COMPLEX*16 array, dimension (LDX,NRHS) */ /* The solution matrix X. */ /* LDX (input) INTEGER */ /* The leading dimension of the array X. LDX >= max(1,N). */ /* FERR (output) DOUBLE PRECISION array, dimension (NRHS) */ /* The estimated forward error bound for each solution vector */ /* X(j) (the j-th column of the solution matrix X). */ /* If XTRUE is the true solution corresponding to X(j), FERR(j) */ /* is an estimated upper bound for the magnitude of the largest */ /* element in (X(j) - XTRUE) divided by the magnitude of the */ /* largest element in X(j). The estimate is as reliable as */ /* the estimate for RCOND, and is almost always a slight */ /* overestimate of the true error. */ /* BERR (output) DOUBLE PRECISION array, dimension (NRHS) */ /* The componentwise relative backward error of each solution */ /* vector X(j) (i.e., the smallest relative change in */ /* any element of A or B that makes X(j) an exact solution). */ /* WORK (workspace) COMPLEX*16 array, dimension (2*N) */ /* RWORK (workspace) DOUBLE PRECISION array, dimension (N) */ /* INFO (output) INTEGER */ /* = 0: successful exit */ /* < 0: if INFO = -i, the i-th argument had an illegal value */ /* ===================================================================== */ /* .. Parameters .. */ /* .. */ /* .. Local Scalars .. */ /* .. */ /* .. Local Arrays .. */ /* .. */ /* .. External Subroutines .. */ /* .. */ /* .. Intrinsic Functions .. */ /* .. */ /* .. External Functions .. */ /* .. */ /* .. Statement Functions .. */ /* .. */ /* .. Statement Function definitions .. */ /* .. */ /* .. Executable Statements .. */ /* Test the input parameters. */ /* Parameter adjustments */ --ap; b_dim1 = *ldb; b_offset = 1 + b_dim1; b -= b_offset; x_dim1 = *ldx; x_offset = 1 + x_dim1; x -= x_offset; --ferr; --berr; --work; --rwork; /* Function Body */ *info = 0; upper = lsame_(uplo, "U"); notran = lsame_(trans, "N"); nounit = lsame_(diag, "N"); if (! upper && ! lsame_(uplo, "L")) { *info = -1; } else if (! notran && ! lsame_(trans, "T") && ! lsame_(trans, "C")) { *info = -2; } else if (! nounit && ! lsame_(diag, "U")) { *info = -3; } else if (*n < 0) { *info = -4; } else if (*nrhs < 0) { *info = -5; } else if (*ldb < max(1,*n)) { *info = -8; } else if (*ldx < max(1,*n)) { *info = -10; } if (*info != 0) { i__1 = -(*info); xerbla_("ZTPRFS", &i__1); return 0; } /* Quick return if possible */ if (*n == 0 || *nrhs == 0) { i__1 = *nrhs; for (j = 1; j <= i__1; ++j) { ferr[j] = 0.; berr[j] = 0.; /* L10: */ } return 0; } if (notran) { *(unsigned char *)transn = 'N'; *(unsigned char *)transt = 'C'; } else { *(unsigned char *)transn = 'C'; *(unsigned char *)transt = 'N'; } /* NZ = maximum number of nonzero elements in each row of A, plus 1 */ nz = *n + 1; eps = dlamch_("Epsilon"); safmin = dlamch_("Safe minimum"); safe1 = nz * safmin; safe2 = safe1 / eps; /* Do for each right hand side */ i__1 = *nrhs; for (j = 1; j <= i__1; ++j) { /* Compute residual R = B - op(A) * X, */ /* where op(A) = A, A**T, or A**H, depending on TRANS. */ zcopy_(n, &x[j * x_dim1 + 1], &c__1, &work[1], &c__1); ztpmv_(uplo, trans, diag, n, &ap[1], &work[1], &c__1); z__1.r = -1., z__1.i = -0.; zaxpy_(n, &z__1, &b[j * b_dim1 + 1], &c__1, &work[1], &c__1); /* Compute componentwise relative backward error from formula */ /* max(i) ( abs(R(i)) / ( abs(op(A))*abs(X) + abs(B) )(i) ) */ /* where abs(Z) is the componentwise absolute value of the matrix */ /* or vector Z. If the i-th component of the denominator is less */ /* than SAFE2, then SAFE1 is added to the i-th components of the */ /* numerator and denominator before dividing. */ i__2 = *n; for (i__ = 1; i__ <= i__2; ++i__) { i__3 = i__ + j * b_dim1; rwork[i__] = (d__1 = b[i__3].r, abs(d__1)) + (d__2 = d_imag(&b[ i__ + j * b_dim1]), abs(d__2)); /* L20: */ } if (notran) { /* Compute abs(A)*abs(X) + abs(B). */ if (upper) { kc = 1; if (nounit) { i__2 = *n; for (k = 1; k <= i__2; ++k) { i__3 = k + j * x_dim1; xk = (d__1 = x[i__3].r, abs(d__1)) + (d__2 = d_imag(& x[k + j * x_dim1]), abs(d__2)); i__3 = k; for (i__ = 1; i__ <= i__3; ++i__) { i__4 = kc + i__ - 1; rwork[i__] += ((d__1 = ap[i__4].r, abs(d__1)) + ( d__2 = d_imag(&ap[kc + i__ - 1]), abs( d__2))) * xk; /* L30: */ } kc += k; /* L40: */ } } else { i__2 = *n; for (k = 1; k <= i__2; ++k) { i__3 = k + j * x_dim1; xk = (d__1 = x[i__3].r, abs(d__1)) + (d__2 = d_imag(& x[k + j * x_dim1]), abs(d__2)); i__3 = k - 1; for (i__ = 1; i__ <= i__3; ++i__) { i__4 = kc + i__ - 1; rwork[i__] += ((d__1 = ap[i__4].r, abs(d__1)) + ( d__2 = d_imag(&ap[kc + i__ - 1]), abs( d__2))) * xk; /* L50: */ } rwork[k] += xk; kc += k; /* L60: */ } } } else { kc = 1; if (nounit) { i__2 = *n; for (k = 1; k <= i__2; ++k) { i__3 = k + j * x_dim1; xk = (d__1 = x[i__3].r, abs(d__1)) + (d__2 = d_imag(& x[k + j * x_dim1]), abs(d__2)); i__3 = *n; for (i__ = k; i__ <= i__3; ++i__) { i__4 = kc + i__ - k; rwork[i__] += ((d__1 = ap[i__4].r, abs(d__1)) + ( d__2 = d_imag(&ap[kc + i__ - k]), abs( d__2))) * xk; /* L70: */ } kc = kc + *n - k + 1; /* L80: */ } } else { i__2 = *n; for (k = 1; k <= i__2; ++k) { i__3 = k + j * x_dim1; xk = (d__1 = x[i__3].r, abs(d__1)) + (d__2 = d_imag(& x[k + j * x_dim1]), abs(d__2)); i__3 = *n; for (i__ = k + 1; i__ <= i__3; ++i__) { i__4 = kc + i__ - k; rwork[i__] += ((d__1 = ap[i__4].r, abs(d__1)) + ( d__2 = d_imag(&ap[kc + i__ - k]), abs( d__2))) * xk; /* L90: */ } rwork[k] += xk; kc = kc + *n - k + 1; /* L100: */ } } } } else { /* Compute abs(A**H)*abs(X) + abs(B). */ if (upper) { kc = 1; if (nounit) { i__2 = *n; for (k = 1; k <= i__2; ++k) { s = 0.; i__3 = k; for (i__ = 1; i__ <= i__3; ++i__) { i__4 = kc + i__ - 1; i__5 = i__ + j * x_dim1; s += ((d__1 = ap[i__4].r, abs(d__1)) + (d__2 = d_imag(&ap[kc + i__ - 1]), abs(d__2))) * ( (d__3 = x[i__5].r, abs(d__3)) + (d__4 = d_imag(&x[i__ + j * x_dim1]), abs(d__4))); /* L110: */ } rwork[k] += s; kc += k; /* L120: */ } } else { i__2 = *n; for (k = 1; k <= i__2; ++k) { i__3 = k + j * x_dim1; s = (d__1 = x[i__3].r, abs(d__1)) + (d__2 = d_imag(&x[ k + j * x_dim1]), abs(d__2)); i__3 = k - 1; for (i__ = 1; i__ <= i__3; ++i__) { i__4 = kc + i__ - 1; i__5 = i__ + j * x_dim1; s += ((d__1 = ap[i__4].r, abs(d__1)) + (d__2 = d_imag(&ap[kc + i__ - 1]), abs(d__2))) * ( (d__3 = x[i__5].r, abs(d__3)) + (d__4 = d_imag(&x[i__ + j * x_dim1]), abs(d__4))); /* L130: */ } rwork[k] += s; kc += k; /* L140: */ } } } else { kc = 1; if (nounit) { i__2 = *n; for (k = 1; k <= i__2; ++k) { s = 0.; i__3 = *n; for (i__ = k; i__ <= i__3; ++i__) { i__4 = kc + i__ - k; i__5 = i__ + j * x_dim1; s += ((d__1 = ap[i__4].r, abs(d__1)) + (d__2 = d_imag(&ap[kc + i__ - k]), abs(d__2))) * ( (d__3 = x[i__5].r, abs(d__3)) + (d__4 = d_imag(&x[i__ + j * x_dim1]), abs(d__4))); /* L150: */ } rwork[k] += s; kc = kc + *n - k + 1; /* L160: */ } } else { i__2 = *n; for (k = 1; k <= i__2; ++k) { i__3 = k + j * x_dim1; s = (d__1 = x[i__3].r, abs(d__1)) + (d__2 = d_imag(&x[ k + j * x_dim1]), abs(d__2)); i__3 = *n; for (i__ = k + 1; i__ <= i__3; ++i__) { i__4 = kc + i__ - k; i__5 = i__ + j * x_dim1; s += ((d__1 = ap[i__4].r, abs(d__1)) + (d__2 = d_imag(&ap[kc + i__ - k]), abs(d__2))) * ( (d__3 = x[i__5].r, abs(d__3)) + (d__4 = d_imag(&x[i__ + j * x_dim1]), abs(d__4))); /* L170: */ } rwork[k] += s; kc = kc + *n - k + 1; /* L180: */ } } } } s = 0.; i__2 = *n; for (i__ = 1; i__ <= i__2; ++i__) { if (rwork[i__] > safe2) { /* Computing MAX */ i__3 = i__; d__3 = s, d__4 = ((d__1 = work[i__3].r, abs(d__1)) + (d__2 = d_imag(&work[i__]), abs(d__2))) / rwork[i__]; s = max(d__3,d__4); } else { /* Computing MAX */ i__3 = i__; d__3 = s, d__4 = ((d__1 = work[i__3].r, abs(d__1)) + (d__2 = d_imag(&work[i__]), abs(d__2)) + safe1) / (rwork[i__] + safe1); s = max(d__3,d__4); } /* L190: */ } berr[j] = s; /* Bound error from formula */ /* norm(X - XTRUE) / norm(X) .le. FERR = */ /* norm( abs(inv(op(A)))* */ /* ( abs(R) + NZ*EPS*( abs(op(A))*abs(X)+abs(B) ))) / norm(X) */ /* where */ /* norm(Z) is the magnitude of the largest component of Z */ /* inv(op(A)) is the inverse of op(A) */ /* abs(Z) is the componentwise absolute value of the matrix or */ /* vector Z */ /* NZ is the maximum number of nonzeros in any row of A, plus 1 */ /* EPS is machine epsilon */ /* The i-th component of abs(R)+NZ*EPS*(abs(op(A))*abs(X)+abs(B)) */ /* is incremented by SAFE1 if the i-th component of */ /* abs(op(A))*abs(X) + abs(B) is less than SAFE2. */ /* Use ZLACN2 to estimate the infinity-norm of the matrix */ /* inv(op(A)) * diag(W), */ /* where W = abs(R) + NZ*EPS*( abs(op(A))*abs(X)+abs(B) ))) */ i__2 = *n; for (i__ = 1; i__ <= i__2; ++i__) { if (rwork[i__] > safe2) { i__3 = i__; rwork[i__] = (d__1 = work[i__3].r, abs(d__1)) + (d__2 = d_imag(&work[i__]), abs(d__2)) + nz * eps * rwork[i__] ; } else { i__3 = i__; rwork[i__] = (d__1 = work[i__3].r, abs(d__1)) + (d__2 = d_imag(&work[i__]), abs(d__2)) + nz * eps * rwork[i__] + safe1; } /* L200: */ } kase = 0; L210: zlacn2_(n, &work[*n + 1], &work[1], &ferr[j], &kase, isave); if (kase != 0) { if (kase == 1) { /* Multiply by diag(W)*inv(op(A)**H). */ ztpsv_(uplo, transt, diag, n, &ap[1], &work[1], &c__1); i__2 = *n; for (i__ = 1; i__ <= i__2; ++i__) { i__3 = i__; i__4 = i__; i__5 = i__; z__1.r = rwork[i__4] * work[i__5].r, z__1.i = rwork[i__4] * work[i__5].i; work[i__3].r = z__1.r, work[i__3].i = z__1.i; /* L220: */ } } else { /* Multiply by inv(op(A))*diag(W). */ i__2 = *n; for (i__ = 1; i__ <= i__2; ++i__) { i__3 = i__; i__4 = i__; i__5 = i__; z__1.r = rwork[i__4] * work[i__5].r, z__1.i = rwork[i__4] * work[i__5].i; work[i__3].r = z__1.r, work[i__3].i = z__1.i; /* L230: */ } ztpsv_(uplo, transn, diag, n, &ap[1], &work[1], &c__1); } goto L210; } /* Normalize error. */ lstres = 0.; i__2 = *n; for (i__ = 1; i__ <= i__2; ++i__) { /* Computing MAX */ i__3 = i__ + j * x_dim1; d__3 = lstres, d__4 = (d__1 = x[i__3].r, abs(d__1)) + (d__2 = d_imag(&x[i__ + j * x_dim1]), abs(d__2)); lstres = max(d__3,d__4); /* L240: */ } if (lstres != 0.) { ferr[j] /= lstres; } /* L250: */ } return 0; /* End of ZTPRFS */ } /* ztprfs_ */
/* Subroutine */ int zhpgvx_(integer *itype, char *jobz, char *range, char * uplo, integer *n, doublecomplex *ap, doublecomplex *bp, doublereal * vl, doublereal *vu, integer *il, integer *iu, doublereal *abstol, integer *m, doublereal *w, doublecomplex *z__, integer *ldz, doublecomplex *work, doublereal *rwork, integer *iwork, integer * ifail, integer *info) { /* System generated locals */ integer z_dim1, z_offset, i__1; /* Local variables */ integer j; char trans[1]; logical upper, wantz; logical alleig, indeig, valeig; /* -- LAPACK driver routine (version 3.2) -- */ /* November 2006 */ /* Purpose */ /* ======= */ /* ZHPGVX computes selected eigenvalues and, optionally, eigenvectors */ /* of a complex generalized Hermitian-definite eigenproblem, of the form */ /* A*x=(lambda)*B*x, A*Bx=(lambda)*x, or B*A*x=(lambda)*x. Here A and */ /* B are assumed to be Hermitian, stored in packed format, and B is also */ /* positive definite. Eigenvalues and eigenvectors can be selected by */ /* specifying either a range of values or a range of indices for the */ /* desired eigenvalues. */ /* Arguments */ /* ========= */ /* ITYPE (input) INTEGER */ /* Specifies the problem type to be solved: */ /* = 1: A*x = (lambda)*B*x */ /* = 2: A*B*x = (lambda)*x */ /* = 3: B*A*x = (lambda)*x */ /* JOBZ (input) CHARACTER*1 */ /* = 'N': Compute eigenvalues only; */ /* = 'V': Compute eigenvalues and eigenvectors. */ /* RANGE (input) CHARACTER*1 */ /* = 'A': all eigenvalues will be found; */ /* = 'V': all eigenvalues in the half-open interval (VL,VU] */ /* will be found; */ /* = 'I': the IL-th through IU-th eigenvalues will be found. */ /* UPLO (input) CHARACTER*1 */ /* = 'U': Upper triangles of A and B are stored; */ /* = 'L': Lower triangles of A and B are stored. */ /* N (input) INTEGER */ /* The order of the matrices A and B. 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)*(2*n-j)/2) = A(i,j) for j<=i<=n. */ /* On exit, the contents of AP are destroyed. */ /* BP (input/output) COMPLEX*16 array, dimension (N*(N+1)/2) */ /* On entry, the upper or lower triangle of the Hermitian matrix */ /* B, packed columnwise in a linear array. The j-th column of B */ /* is stored in the array BP as follows: */ /* if UPLO = 'U', BP(i + (j-1)*j/2) = B(i,j) for 1<=i<=j; */ /* if UPLO = 'L', BP(i + (j-1)*(2*n-j)/2) = B(i,j) for j<=i<=n. */ /* On exit, the triangular factor U or L from the Cholesky */ /* factorization B = U**H*U or B = L*L**H, in the same storage */ /* format as B. */ /* VL (input) DOUBLE PRECISION */ /* VU (input) DOUBLE PRECISION */ /* If RANGE='V', the lower and upper bounds of the interval to */ /* be searched for eigenvalues. VL < VU. */ /* Not referenced if RANGE = 'A' or 'I'. */ /* IL (input) INTEGER */ /* IU (input) INTEGER */ /* If RANGE='I', the indices (in ascending order) of the */ /* smallest and largest eigenvalues to be returned. */ /* 1 <= IL <= IU <= N, if N > 0; IL = 1 and IU = 0 if N = 0. */ /* Not referenced if RANGE = 'A' or 'V'. */ /* ABSTOL (input) DOUBLE PRECISION */ /* The absolute error tolerance for the eigenvalues. */ /* An approximate eigenvalue is accepted as converged */ /* when it is determined to lie in an interval [a,b] */ /* of width less than or equal to */ /* ABSTOL + EPS * max( |a|,|b| ) , */ /* where EPS is the machine precision. If ABSTOL is less than */ /* or equal to zero, then EPS*|T| will be used in its place, */ /* where |T| is the 1-norm of the tridiagonal matrix obtained */ /* by reducing AP to tridiagonal form. */ /* Eigenvalues will be computed most accurately when ABSTOL is */ /* set to twice the underflow threshold 2*DLAMCH('S'), not zero. */ /* If this routine returns with INFO>0, indicating that some */ /* eigenvectors did not converge, try setting ABSTOL to */ /* 2*DLAMCH('S'). */ /* M (output) INTEGER */ /* The total number of eigenvalues found. 0 <= M <= N. */ /* If RANGE = 'A', M = N, and if RANGE = 'I', M = IU-IL+1. */ /* W (output) DOUBLE PRECISION array, dimension (N) */ /* On normal exit, the first M elements contain the selected */ /* eigenvalues in ascending order. */ /* Z (output) COMPLEX*16 array, dimension (LDZ, N) */ /* If JOBZ = 'N', then Z is not referenced. */ /* If JOBZ = 'V', then if INFO = 0, the first M columns of Z */ /* contain the orthonormal eigenvectors of the matrix A */ /* corresponding to the selected eigenvalues, with the i-th */ /* column of Z holding the eigenvector associated with W(i). */ /* The eigenvectors are normalized as follows: */ /* if ITYPE = 1 or 2, Z**H*B*Z = I; */ /* if ITYPE = 3, Z**H*inv(B)*Z = I. */ /* If an eigenvector fails to converge, then that column of Z */ /* contains the latest approximation to the eigenvector, and the */ /* index of the eigenvector is returned in IFAIL. */ /* Note: the user must ensure that at least max(1,M) columns are */ /* supplied in the array Z; if RANGE = 'V', the exact value of M */ /* is not known in advance and an upper bound must be used. */ /* LDZ (input) INTEGER */ /* The leading dimension of the array Z. LDZ >= 1, and if */ /* JOBZ = 'V', LDZ >= max(1,N). */ /* WORK (workspace) COMPLEX*16 array, dimension (2*N) */ /* RWORK (workspace) DOUBLE PRECISION array, dimension (7*N) */ /* IWORK (workspace) INTEGER array, dimension (5*N) */ /* IFAIL (output) INTEGER array, dimension (N) */ /* If JOBZ = 'V', then if INFO = 0, the first M elements of */ /* IFAIL are zero. If INFO > 0, then IFAIL contains the */ /* indices of the eigenvectors that failed to converge. */ /* If JOBZ = 'N', then IFAIL is not referenced. */ /* INFO (output) INTEGER */ /* = 0: successful exit */ /* < 0: if INFO = -i, the i-th argument had an illegal value */ /* > 0: ZPPTRF or ZHPEVX returned an error code: */ /* <= N: if INFO = i, ZHPEVX failed to converge; */ /* i eigenvectors failed to converge. Their indices */ /* are stored in array IFAIL. */ /* > N: if INFO = N + i, for 1 <= i <= n, then the leading */ /* minor of order i of B is not positive definite. */ /* The factorization of B could not be completed and */ /* no eigenvalues or eigenvectors were computed. */ /* Further Details */ /* =============== */ /* Based on contributions by */ /* Mark Fahey, Department of Mathematics, Univ. of Kentucky, USA */ /* ===================================================================== */ /* Test the input parameters. */ /* Parameter adjustments */ --ap; --bp; --w; z_dim1 = *ldz; z_offset = 1 + z_dim1; z__ -= z_offset; --work; --rwork; --iwork; --ifail; /* Function Body */ wantz = lsame_(jobz, "V"); upper = lsame_(uplo, "U"); alleig = lsame_(range, "A"); valeig = lsame_(range, "V"); indeig = lsame_(range, "I"); *info = 0; if (*itype < 1 || *itype > 3) { *info = -1; } else if (! (wantz || lsame_(jobz, "N"))) { *info = -2; } else if (! (alleig || valeig || indeig)) { *info = -3; } else if (! (upper || lsame_(uplo, "L"))) { *info = -4; } else if (*n < 0) { *info = -5; } else { if (valeig) { if (*n > 0 && *vu <= *vl) { *info = -9; } } else if (indeig) { if (*il < 1) { *info = -10; } else if (*iu < min(*n,*il) || *iu > *n) { *info = -11; } } } if (*info == 0) { if (*ldz < 1 || wantz && *ldz < *n) { *info = -16; } } if (*info != 0) { i__1 = -(*info); xerbla_("ZHPGVX", &i__1); return 0; } /* Quick return if possible */ if (*n == 0) { return 0; } /* Form a Cholesky factorization of B. */ zpptrf_(uplo, n, &bp[1], info); if (*info != 0) { *info = *n + *info; return 0; } /* Transform problem to standard eigenvalue problem and solve. */ zhpgst_(itype, uplo, n, &ap[1], &bp[1], info); zhpevx_(jobz, range, uplo, n, &ap[1], vl, vu, il, iu, abstol, m, &w[1], & z__[z_offset], ldz, &work[1], &rwork[1], &iwork[1], &ifail[1], info); if (wantz) { /* Backtransform eigenvectors to the original problem. */ if (*info > 0) { *m = *info - 1; } if (*itype == 1 || *itype == 2) { /* For A*x=(lambda)*B*x and A*B*x=(lambda)*x; */ /* backtransform eigenvectors: x = inv(L)'*y or inv(U)*y */ if (upper) { *(unsigned char *)trans = 'N'; } else { *(unsigned char *)trans = 'C'; } i__1 = *m; for (j = 1; j <= i__1; ++j) { ztpsv_(uplo, trans, "Non-unit", n, &bp[1], &z__[j * z_dim1 + 1], &c__1); } } else if (*itype == 3) { /* For B*A*x=(lambda)*x; */ /* backtransform eigenvectors: x = L*y or U'*y */ if (upper) { *(unsigned char *)trans = 'C'; } else { *(unsigned char *)trans = 'N'; } i__1 = *m; for (j = 1; j <= i__1; ++j) { ztpmv_(uplo, trans, "Non-unit", n, &bp[1], &z__[j * z_dim1 + 1], &c__1); } } } return 0; /* End of ZHPGVX */ } /* zhpgvx_ */
/* Subroutine */ int ztpt03_(char *uplo, char *trans, char *diag, integer *n, integer *nrhs, doublecomplex *ap, doublereal *scale, doublereal * cnorm, doublereal *tscal, doublecomplex *x, integer *ldx, doublecomplex *b, integer *ldb, doublecomplex *work, doublereal * resid) { /* System generated locals */ integer b_dim1, b_offset, x_dim1, x_offset, i__1; doublereal d__1, d__2; doublecomplex z__1; /* Local variables */ integer j, jj, ix; doublereal eps, err; doublereal xscal, tnorm, xnorm; doublereal smlnum; /* -- LAPACK test routine (version 3.1) -- */ /* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ /* November 2006 */ /* .. Scalar Arguments .. */ /* .. */ /* .. Array Arguments .. */ /* .. */ /* Purpose */ /* ======= */ /* ZTPT03 computes the residual for the solution to a scaled triangular */ /* system of equations A*x = s*b, A**T *x = s*b, or A**H *x = s*b, */ /* when the triangular matrix A is stored in packed format. Here A**T */ /* denotes the transpose of A, A**H denotes the conjugate transpose of */ /* A, s is a scalar, and x and b are N by NRHS matrices. The test ratio */ /* is the maximum over the number of right hand sides of */ /* norm(s*b - op(A)*x) / ( norm(op(A)) * norm(x) * EPS ), */ /* where op(A) denotes A, A**T, or A**H, and EPS is the machine epsilon. */ /* Arguments */ /* ========= */ /* UPLO (input) CHARACTER*1 */ /* Specifies whether the matrix A is upper or lower triangular. */ /* = 'U': Upper triangular */ /* = 'L': Lower triangular */ /* TRANS (input) CHARACTER*1 */ /* Specifies the operation applied to A. */ /* = 'N': A *x = s*b (No transpose) */ /* = 'T': A**T *x = s*b (Transpose) */ /* = 'C': A**H *x = s*b (Conjugate transpose) */ /* DIAG (input) CHARACTER*1 */ /* Specifies whether or not the matrix A is unit triangular. */ /* = 'N': Non-unit triangular */ /* = 'U': Unit triangular */ /* N (input) INTEGER */ /* The order of the matrix A. N >= 0. */ /* NRHS (input) INTEGER */ /* The number of right hand sides, i.e., the number of columns */ /* of the matrices X and B. NRHS >= 0. */ /* AP (input) COMPLEX*16 array, dimension (N*(N+1)/2) */ /* The upper or lower triangular 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((j-1)*j/2 + i) = A(i,j) for 1<=i<=j; */ /* if UPLO = 'L', */ /* AP((j-1)*(n-j) + j*(j+1)/2 + i-j) = A(i,j) for j<=i<=n. */ /* SCALE (input) DOUBLE PRECISION */ /* The scaling factor s used in solving the triangular system. */ /* CNORM (input) DOUBLE PRECISION array, dimension (N) */ /* The 1-norms of the columns of A, not counting the diagonal. */ /* TSCAL (input) DOUBLE PRECISION */ /* The scaling factor used in computing the 1-norms in CNORM. */ /* CNORM actually contains the column norms of TSCAL*A. */ /* X (input) COMPLEX*16 array, dimension (LDX,NRHS) */ /* The computed solution vectors for the system of linear */ /* equations. */ /* LDX (input) INTEGER */ /* The leading dimension of the array X. LDX >= max(1,N). */ /* B (input) COMPLEX*16 array, dimension (LDB,NRHS) */ /* The right hand side vectors for the system of linear */ /* equations. */ /* LDB (input) INTEGER */ /* The leading dimension of the array B. LDB >= max(1,N). */ /* WORK (workspace) COMPLEX*16 array, dimension (N) */ /* RESID (output) DOUBLE PRECISION */ /* The maximum over the number of right hand sides of */ /* norm(op(A)*x - s*b) / ( norm(op(A)) * norm(x) * EPS ). */ /* ===================================================================== */ /* .. Parameters .. */ /* .. */ /* .. Local Scalars .. */ /* .. */ /* .. External Functions .. */ /* .. */ /* .. External Subroutines .. */ /* .. */ /* .. Intrinsic Functions .. */ /* .. */ /* .. Executable Statements .. */ /* Quick exit if N = 0. */ /* Parameter adjustments */ --ap; --cnorm; x_dim1 = *ldx; x_offset = 1 + x_dim1; x -= x_offset; b_dim1 = *ldb; b_offset = 1 + b_dim1; b -= b_offset; --work; /* Function Body */ if (*n <= 0 || *nrhs <= 0) { *resid = 0.; return 0; } eps = dlamch_("Epsilon"); smlnum = dlamch_("Safe minimum"); /* Compute the norm of the triangular matrix A using the column */ /* norms already computed by ZLATPS. */ tnorm = 0.; if (lsame_(diag, "N")) { if (lsame_(uplo, "U")) { jj = 1; i__1 = *n; for (j = 1; j <= i__1; ++j) { /* Computing MAX */ d__1 = tnorm, d__2 = *tscal * z_abs(&ap[jj]) + cnorm[j]; tnorm = max(d__1,d__2); jj += j; /* L10: */ } } else { jj = 1; i__1 = *n; for (j = 1; j <= i__1; ++j) { /* Computing MAX */ d__1 = tnorm, d__2 = *tscal * z_abs(&ap[jj]) + cnorm[j]; tnorm = max(d__1,d__2); jj = jj + *n - j + 1; /* L20: */ } } } else { i__1 = *n; for (j = 1; j <= i__1; ++j) { /* Computing MAX */ d__1 = tnorm, d__2 = *tscal + cnorm[j]; tnorm = max(d__1,d__2); /* L30: */ } } /* Compute the maximum over the number of right hand sides of */ /* norm(op(A)*x - s*b) / ( norm(A) * norm(x) * EPS ). */ *resid = 0.; i__1 = *nrhs; for (j = 1; j <= i__1; ++j) { zcopy_(n, &x[j * x_dim1 + 1], &c__1, &work[1], &c__1); ix = izamax_(n, &work[1], &c__1); /* Computing MAX */ d__1 = 1., d__2 = z_abs(&x[ix + j * x_dim1]); xnorm = max(d__1,d__2); xscal = 1. / xnorm / (doublereal) (*n); zdscal_(n, &xscal, &work[1], &c__1); ztpmv_(uplo, trans, diag, n, &ap[1], &work[1], &c__1); d__1 = -(*scale) * xscal; z__1.r = d__1, z__1.i = 0.; zaxpy_(n, &z__1, &b[j * b_dim1 + 1], &c__1, &work[1], &c__1); ix = izamax_(n, &work[1], &c__1); err = *tscal * z_abs(&work[ix]); ix = izamax_(n, &x[j * x_dim1 + 1], &c__1); xnorm = z_abs(&x[ix + j * x_dim1]); if (err * smlnum <= xnorm) { if (xnorm > 0.) { err /= xnorm; } } else { if (err > 0.) { err = 1. / eps; } } if (err * smlnum <= tnorm) { if (tnorm > 0.) { err /= tnorm; } } else { if (err > 0.) { err = 1. / eps; } } *resid = max(*resid,err); /* L40: */ } return 0; /* End of ZTPT03 */ } /* ztpt03_ */
/* Subroutine */ int zlarhs_(char *path, char *xtype, char *uplo, char *trans, integer *m, integer *n, integer *kl, integer *ku, integer *nrhs, doublecomplex *a, integer *lda, doublecomplex *x, integer *ldx, doublecomplex *b, integer *ldb, integer *iseed, integer *info) { /* System generated locals */ integer a_dim1, a_offset, b_dim1, b_offset, x_dim1, x_offset, i__1; /* Local variables */ integer j; char c1[1], c2[2]; integer mb, nx; logical gen, tri, qrs, sym, band; char diag[1]; logical tran; extern /* Subroutine */ int zgemm_(char *, char *, integer *, integer *, integer *, doublecomplex *, doublecomplex *, integer *, doublecomplex *, integer *, doublecomplex *, doublecomplex *, integer *), zhemm_(char *, char *, integer *, integer *, doublecomplex *, doublecomplex *, integer *, doublecomplex *, integer *, doublecomplex *, doublecomplex *, integer *), zgbmv_(char *, integer *, integer *, integer *, integer *, doublecomplex *, doublecomplex *, integer *, doublecomplex *, integer *, doublecomplex *, doublecomplex *, integer *), zhbmv_(char *, integer *, integer *, doublecomplex *, doublecomplex *, integer *, doublecomplex *, integer *, doublecomplex *, doublecomplex *, integer *), zsbmv_(char *, integer *, integer *, doublecomplex *, doublecomplex *, integer *, doublecomplex *, integer *, doublecomplex *, doublecomplex *, integer *), ztbmv_(char *, char *, char *, integer *, integer *, doublecomplex *, integer *, doublecomplex *, integer *), zhpmv_( char *, integer *, doublecomplex *, doublecomplex *, doublecomplex *, integer *, doublecomplex *, doublecomplex *, integer *), ztrmm_(char *, char *, char *, char *, integer *, integer *, doublecomplex *, doublecomplex *, integer *, doublecomplex *, integer *), zspmv_(char *, integer *, doublecomplex *, doublecomplex *, doublecomplex *, integer *, doublecomplex *, doublecomplex *, integer *), zsymm_(char *, char *, integer *, integer *, doublecomplex *, doublecomplex *, integer *, doublecomplex *, integer *, doublecomplex *, doublecomplex *, integer *), ztpmv_(char *, char *, char *, integer *, doublecomplex * , doublecomplex *, integer *), xerbla_( char *, integer *); extern logical lsamen_(integer *, char *, char *); logical notran; extern /* Subroutine */ int zlacpy_(char *, integer *, integer *, doublecomplex *, integer *, doublecomplex *, integer *), zlarnv_(integer *, integer *, 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 */ /* ======= */ /* ZLARHS chooses a set of NRHS random solution vectors and sets */ /* up the right hand sides for the linear system */ /* op( A ) * X = B, */ /* where op( A ) may be A, A**T (transpose of A), or A**H (conjugate */ /* transpose of A). */ /* Arguments */ /* ========= */ /* PATH (input) CHARACTER*3 */ /* The type of the complex matrix A. PATH may be given in any */ /* combination of upper and lower case. Valid paths include */ /* xGE: General m x n matrix */ /* xGB: General banded matrix */ /* xPO: Hermitian positive definite, 2-D storage */ /* xPP: Hermitian positive definite packed */ /* xPB: Hermitian positive definite banded */ /* xHE: Hermitian indefinite, 2-D storage */ /* xHP: Hermitian indefinite packed */ /* xHB: Hermitian indefinite banded */ /* xSY: Symmetric indefinite, 2-D storage */ /* xSP: Symmetric indefinite packed */ /* xSB: Symmetric indefinite banded */ /* xTR: Triangular */ /* xTP: Triangular packed */ /* xTB: Triangular banded */ /* xQR: General m x n matrix */ /* xLQ: General m x n matrix */ /* xQL: General m x n matrix */ /* xRQ: General m x n matrix */ /* where the leading character indicates the precision. */ /* XTYPE (input) CHARACTER*1 */ /* Specifies how the exact solution X will be determined: */ /* = 'N': New solution; generate a random X. */ /* = 'C': Computed; use value of X on entry. */ /* UPLO (input) CHARACTER*1 */ /* Used only if A is symmetric or triangular; specifies whether */ /* the upper or lower triangular part of the matrix A is stored. */ /* = 'U': Upper triangular */ /* = 'L': Lower triangular */ /* TRANS (input) CHARACTER*1 */ /* Used only if A is nonsymmetric; specifies the operation */ /* applied to the matrix A. */ /* = 'N': B := A * X */ /* = 'T': B := A**T * X */ /* = 'C': B := A**H * X */ /* M (input) INTEGER */ /* The number of rows of the matrix A. M >= 0. */ /* N (input) INTEGER */ /* The number of columns of the matrix A. N >= 0. */ /* KL (input) INTEGER */ /* Used only if A is a band matrix; specifies the number of */ /* subdiagonals of A if A is a general band matrix or if A is */ /* symmetric or triangular and UPLO = 'L'; specifies the number */ /* of superdiagonals of A if A is symmetric or triangular and */ /* UPLO = 'U'. 0 <= KL <= M-1. */ /* KU (input) INTEGER */ /* Used only if A is a general band matrix or if A is */ /* triangular. */ /* If PATH = xGB, specifies the number of superdiagonals of A, */ /* and 0 <= KU <= N-1. */ /* If PATH = xTR, xTP, or xTB, specifies whether or not the */ /* matrix has unit diagonal: */ /* = 1: matrix has non-unit diagonal (default) */ /* = 2: matrix has unit diagonal */ /* NRHS (input) INTEGER */ /* The number of right hand side vectors in the system A*X = B. */ /* A (input) COMPLEX*16 array, dimension (LDA,N) */ /* The test matrix whose type is given by PATH. */ /* LDA (input) INTEGER */ /* The leading dimension of the array A. */ /* If PATH = xGB, LDA >= KL+KU+1. */ /* If PATH = xPB, xSB, xHB, or xTB, LDA >= KL+1. */ /* Otherwise, LDA >= max(1,M). */ /* X (input or output) COMPLEX*16 array, dimension (LDX,NRHS) */ /* On entry, if XTYPE = 'C' (for 'Computed'), then X contains */ /* the exact solution to the system of linear equations. */ /* On exit, if XTYPE = 'N' (for 'New'), then X is initialized */ /* with random values. */ /* LDX (input) INTEGER */ /* The leading dimension of the array X. If TRANS = 'N', */ /* LDX >= max(1,N); if TRANS = 'T', LDX >= max(1,M). */ /* B (output) COMPLEX*16 array, dimension (LDB,NRHS) */ /* The right hand side vector(s) for the system of equations, */ /* computed from B = op(A) * X, where op(A) is determined by */ /* TRANS. */ /* LDB (input) INTEGER */ /* The leading dimension of the array B. If TRANS = 'N', */ /* LDB >= max(1,M); if TRANS = 'T', LDB >= max(1,N). */ /* ISEED (input/output) INTEGER array, dimension (4) */ /* The seed vector for the random number generator (used in */ /* ZLATMS). Modified on exit. */ /* INFO (output) INTEGER */ /* = 0: successful exit */ /* < 0: if INFO = -i, the i-th argument had an illegal value */ /* ===================================================================== */ /* .. Parameters .. */ /* .. */ /* .. Local Scalars .. */ /* .. */ /* .. External Functions .. */ /* .. */ /* .. External Subroutines .. */ /* .. */ /* .. Intrinsic Functions .. */ /* .. */ /* .. Executable Statements .. */ /* Test the input parameters. */ /* Parameter adjustments */ a_dim1 = *lda; a_offset = 1 + a_dim1; a -= a_offset; x_dim1 = *ldx; x_offset = 1 + x_dim1; x -= x_offset; b_dim1 = *ldb; b_offset = 1 + b_dim1; b -= b_offset; --iseed; /* Function Body */ *info = 0; *(unsigned char *)c1 = *(unsigned char *)path; s_copy(c2, path + 1, (ftnlen)2, (ftnlen)2); tran = lsame_(trans, "T") || lsame_(trans, "C"); notran = ! tran; gen = lsame_(path + 1, "G"); qrs = lsame_(path + 1, "Q") || lsame_(path + 2, "Q"); sym = lsame_(path + 1, "P") || lsame_(path + 1, "S") || lsame_(path + 1, "H"); tri = lsame_(path + 1, "T"); band = lsame_(path + 2, "B"); if (! lsame_(c1, "Zomplex precision")) { *info = -1; } else if (! (lsame_(xtype, "N") || lsame_(xtype, "C"))) { *info = -2; } else if ((sym || tri) && ! (lsame_(uplo, "U") || lsame_(uplo, "L"))) { *info = -3; } else if ((gen || qrs) && ! (tran || lsame_(trans, "N"))) { *info = -4; } else if (*m < 0) { *info = -5; } else if (*n < 0) { *info = -6; } else if (band && *kl < 0) { *info = -7; } else if (band && *ku < 0) { *info = -8; } else if (*nrhs < 0) { *info = -9; } else if (! band && *lda < max(1,*m) || band && (sym || tri) && *lda < * kl + 1 || band && gen && *lda < *kl + *ku + 1) { *info = -11; } else if (notran && *ldx < max(1,*n) || tran && *ldx < max(1,*m)) { *info = -13; } else if (notran && *ldb < max(1,*m) || tran && *ldb < max(1,*n)) { *info = -15; } if (*info != 0) { i__1 = -(*info); xerbla_("ZLARHS", &i__1); return 0; } /* Initialize X to NRHS random vectors unless XTYPE = 'C'. */ if (tran) { nx = *m; mb = *n; } else { nx = *n; mb = *m; } if (! lsame_(xtype, "C")) { i__1 = *nrhs; for (j = 1; j <= i__1; ++j) { zlarnv_(&c__2, &iseed[1], n, &x[j * x_dim1 + 1]); /* L10: */ } } /* Multiply X by op( A ) using an appropriate */ /* matrix multiply routine. */ if (lsamen_(&c__2, c2, "GE") || lsamen_(&c__2, c2, "QR") || lsamen_(&c__2, c2, "LQ") || lsamen_(&c__2, c2, "QL") || lsamen_(&c__2, c2, "RQ")) { /* General matrix */ zgemm_(trans, "N", &mb, nrhs, &nx, &c_b1, &a[a_offset], lda, &x[ x_offset], ldx, &c_b2, &b[b_offset], ldb); } else if (lsamen_(&c__2, c2, "PO") || lsamen_(& c__2, c2, "HE")) { /* Hermitian matrix, 2-D storage */ zhemm_("Left", uplo, n, nrhs, &c_b1, &a[a_offset], lda, &x[x_offset], ldx, &c_b2, &b[b_offset], ldb); } else if (lsamen_(&c__2, c2, "SY")) { /* Symmetric matrix, 2-D storage */ zsymm_("Left", uplo, n, nrhs, &c_b1, &a[a_offset], lda, &x[x_offset], ldx, &c_b2, &b[b_offset], ldb); } else if (lsamen_(&c__2, c2, "GB")) { /* General matrix, band storage */ i__1 = *nrhs; for (j = 1; j <= i__1; ++j) { zgbmv_(trans, m, n, kl, ku, &c_b1, &a[a_offset], lda, &x[j * x_dim1 + 1], &c__1, &c_b2, &b[j * b_dim1 + 1], &c__1); /* L20: */ } } else if (lsamen_(&c__2, c2, "PB") || lsamen_(& c__2, c2, "HB")) { /* Hermitian matrix, band storage */ i__1 = *nrhs; for (j = 1; j <= i__1; ++j) { zhbmv_(uplo, n, kl, &c_b1, &a[a_offset], lda, &x[j * x_dim1 + 1], &c__1, &c_b2, &b[j * b_dim1 + 1], &c__1); /* L30: */ } } else if (lsamen_(&c__2, c2, "SB")) { /* Symmetric matrix, band storage */ i__1 = *nrhs; for (j = 1; j <= i__1; ++j) { zsbmv_(uplo, n, kl, &c_b1, &a[a_offset], lda, &x[j * x_dim1 + 1], &c__1, &c_b2, &b[j * b_dim1 + 1], &c__1); /* L40: */ } } else if (lsamen_(&c__2, c2, "PP") || lsamen_(& c__2, c2, "HP")) { /* Hermitian matrix, packed storage */ i__1 = *nrhs; for (j = 1; j <= i__1; ++j) { zhpmv_(uplo, n, &c_b1, &a[a_offset], &x[j * x_dim1 + 1], &c__1, & c_b2, &b[j * b_dim1 + 1], &c__1); /* L50: */ } } else if (lsamen_(&c__2, c2, "SP")) { /* Symmetric matrix, packed storage */ i__1 = *nrhs; for (j = 1; j <= i__1; ++j) { zspmv_(uplo, n, &c_b1, &a[a_offset], &x[j * x_dim1 + 1], &c__1, & c_b2, &b[j * b_dim1 + 1], &c__1); /* L60: */ } } else if (lsamen_(&c__2, c2, "TR")) { /* Triangular matrix. Note that for triangular matrices, */ /* KU = 1 => non-unit triangular */ /* KU = 2 => unit triangular */ zlacpy_("Full", n, nrhs, &x[x_offset], ldx, &b[b_offset], ldb); if (*ku == 2) { *(unsigned char *)diag = 'U'; } else { *(unsigned char *)diag = 'N'; } ztrmm_("Left", uplo, trans, diag, n, nrhs, &c_b1, &a[a_offset], lda, & b[b_offset], ldb); } else if (lsamen_(&c__2, c2, "TP")) { /* Triangular matrix, packed storage */ zlacpy_("Full", n, nrhs, &x[x_offset], ldx, &b[b_offset], ldb); if (*ku == 2) { *(unsigned char *)diag = 'U'; } else { *(unsigned char *)diag = 'N'; } i__1 = *nrhs; for (j = 1; j <= i__1; ++j) { ztpmv_(uplo, trans, diag, n, &a[a_offset], &b[j * b_dim1 + 1], & c__1); /* L70: */ } } else if (lsamen_(&c__2, c2, "TB")) { /* Triangular matrix, banded storage */ zlacpy_("Full", n, nrhs, &x[x_offset], ldx, &b[b_offset], ldb); if (*ku == 2) { *(unsigned char *)diag = 'U'; } else { *(unsigned char *)diag = 'N'; } i__1 = *nrhs; for (j = 1; j <= i__1; ++j) { ztbmv_(uplo, trans, diag, n, kl, &a[a_offset], lda, &b[j * b_dim1 + 1], &c__1); /* L80: */ } } else { /* If none of the above, set INFO = -1 and return */ *info = -1; i__1 = -(*info); xerbla_("ZLARHS", &i__1); } return 0; /* End of ZLARHS */ } /* zlarhs_ */
/* Subroutine */ int zhpgvd_(integer *itype, char *jobz, char *uplo, integer * n, doublecomplex *ap, doublecomplex *bp, doublereal *w, doublecomplex *z__, integer *ldz, doublecomplex *work, integer *lwork, doublereal * rwork, integer *lrwork, integer *iwork, integer *liwork, integer * info) { /* System generated locals */ integer z_dim1, z_offset, i__1; doublereal d__1, d__2; /* Local variables */ integer j, neig; integer lwmin; char trans[1]; logical upper, wantz; integer liwmin; integer lrwmin; logical lquery; /* -- LAPACK driver routine (version 3.2) -- */ /* November 2006 */ /* Purpose */ /* ======= */ /* ZHPGVD computes all the eigenvalues and, optionally, the eigenvectors */ /* of a complex generalized Hermitian-definite eigenproblem, of the form */ /* A*x=(lambda)*B*x, A*Bx=(lambda)*x, or B*A*x=(lambda)*x. Here A and */ /* B are assumed to be Hermitian, stored in packed format, and B is also */ /* positive definite. */ /* If eigenvectors are desired, it uses a divide and conquer algorithm. */ /* The divide and conquer algorithm makes very mild assumptions about */ /* floating point arithmetic. It will work on machines with a guard */ /* digit in add/subtract, or on those binary machines without guard */ /* digits which subtract like the Cray X-MP, Cray Y-MP, Cray C-90, or */ /* Cray-2. It could conceivably fail on hexadecimal or decimal machines */ /* without guard digits, but we know of none. */ /* Arguments */ /* ========= */ /* ITYPE (input) INTEGER */ /* Specifies the problem type to be solved: */ /* = 1: A*x = (lambda)*B*x */ /* = 2: A*B*x = (lambda)*x */ /* = 3: B*A*x = (lambda)*x */ /* JOBZ (input) CHARACTER*1 */ /* = 'N': Compute eigenvalues only; */ /* = 'V': Compute eigenvalues and eigenvectors. */ /* UPLO (input) CHARACTER*1 */ /* = 'U': Upper triangles of A and B are stored; */ /* = 'L': Lower triangles of A and B are stored. */ /* N (input) INTEGER */ /* The order of the matrices A and B. 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)*(2*n-j)/2) = A(i,j) for j<=i<=n. */ /* On exit, the contents of AP are destroyed. */ /* BP (input/output) COMPLEX*16 array, dimension (N*(N+1)/2) */ /* On entry, the upper or lower triangle of the Hermitian matrix */ /* B, packed columnwise in a linear array. The j-th column of B */ /* is stored in the array BP as follows: */ /* if UPLO = 'U', BP(i + (j-1)*j/2) = B(i,j) for 1<=i<=j; */ /* if UPLO = 'L', BP(i + (j-1)*(2*n-j)/2) = B(i,j) for j<=i<=n. */ /* On exit, the triangular factor U or L from the Cholesky */ /* factorization B = U**H*U or B = L*L**H, in the same storage */ /* format as B. */ /* W (output) DOUBLE PRECISION array, dimension (N) */ /* If INFO = 0, the eigenvalues in ascending order. */ /* Z (output) COMPLEX*16 array, dimension (LDZ, N) */ /* If JOBZ = 'V', then if INFO = 0, Z contains the matrix Z of */ /* eigenvectors. The eigenvectors are normalized as follows: */ /* if ITYPE = 1 or 2, Z**H*B*Z = I; */ /* if ITYPE = 3, Z**H*inv(B)*Z = I. */ /* If JOBZ = 'N', then Z is not referenced. */ /* LDZ (input) INTEGER */ /* The leading dimension of the array Z. LDZ >= 1, and if */ /* JOBZ = 'V', LDZ >= max(1,N). */ /* WORK (workspace) COMPLEX*16 array, dimension (MAX(1,LWORK)) */ /* On exit, if INFO = 0, WORK(1) returns the required LWORK. */ /* LWORK (input) INTEGER */ /* The dimension of array WORK. */ /* If N <= 1, LWORK >= 1. */ /* If JOBZ = 'N' and N > 1, LWORK >= N. */ /* If JOBZ = 'V' and N > 1, LWORK >= 2*N. */ /* If LWORK = -1, then a workspace query is assumed; the routine */ /* only calculates the required sizes of the WORK, RWORK and */ /* IWORK arrays, returns these values as the first entries of */ /* the WORK, RWORK and IWORK arrays, and no error message */ /* related to LWORK or LRWORK or LIWORK is issued by XERBLA. */ /* RWORK (workspace) DOUBLE PRECISION array, dimension (MAX(1,LRWORK)) */ /* On exit, if INFO = 0, RWORK(1) returns the required LRWORK. */ /* LRWORK (input) INTEGER */ /* The dimension of array RWORK. */ /* If N <= 1, LRWORK >= 1. */ /* If JOBZ = 'N' and N > 1, LRWORK >= N. */ /* If JOBZ = 'V' and N > 1, LRWORK >= 1 + 5*N + 2*N**2. */ /* If LRWORK = -1, then a workspace query is assumed; the */ /* routine only calculates the required sizes of the WORK, RWORK */ /* and IWORK arrays, returns these values as the first entries */ /* of the WORK, RWORK and IWORK arrays, and no error message */ /* related to LWORK or LRWORK or LIWORK is issued by XERBLA. */ /* IWORK (workspace/output) INTEGER array, dimension (MAX(1,LIWORK)) */ /* On exit, if INFO = 0, IWORK(1) returns the required LIWORK. */ /* LIWORK (input) INTEGER */ /* The dimension of array IWORK. */ /* If JOBZ = 'N' or N <= 1, LIWORK >= 1. */ /* If JOBZ = 'V' and N > 1, LIWORK >= 3 + 5*N. */ /* If LIWORK = -1, then a workspace query is assumed; the */ /* routine only calculates the required sizes of the WORK, RWORK */ /* and IWORK arrays, returns these values as the first entries */ /* of the WORK, RWORK and IWORK arrays, and no error message */ /* related to LWORK or LRWORK or LIWORK is issued by XERBLA. */ /* INFO (output) INTEGER */ /* = 0: successful exit */ /* < 0: if INFO = -i, the i-th argument had an illegal value */ /* > 0: ZPPTRF or ZHPEVD returned an error code: */ /* <= N: if INFO = i, ZHPEVD failed to converge; */ /* i off-diagonal elements of an intermediate */ /* tridiagonal form did not convergeto zero; */ /* > N: if INFO = N + i, for 1 <= i <= n, then the leading */ /* minor of order i of B is not positive definite. */ /* The factorization of B could not be completed and */ /* no eigenvalues or eigenvectors were computed. */ /* Further Details */ /* =============== */ /* Based on contributions by */ /* Mark Fahey, Department of Mathematics, Univ. of Kentucky, USA */ /* ===================================================================== */ /* Test the input parameters. */ /* Parameter adjustments */ --ap; --bp; --w; z_dim1 = *ldz; z_offset = 1 + z_dim1; z__ -= z_offset; --work; --rwork; --iwork; /* Function Body */ wantz = lsame_(jobz, "V"); upper = lsame_(uplo, "U"); lquery = *lwork == -1 || *lrwork == -1 || *liwork == -1; *info = 0; if (*itype < 1 || *itype > 3) { *info = -1; } else if (! (wantz || lsame_(jobz, "N"))) { *info = -2; } else if (! (upper || lsame_(uplo, "L"))) { *info = -3; } else if (*n < 0) { *info = -4; } else if (*ldz < 1 || wantz && *ldz < *n) { *info = -9; } if (*info == 0) { if (*n <= 1) { lwmin = 1; liwmin = 1; lrwmin = 1; } else { if (wantz) { lwmin = *n << 1; /* Computing 2nd power */ i__1 = *n; lrwmin = *n * 5 + 1 + (i__1 * i__1 << 1); liwmin = *n * 5 + 3; } else { lwmin = *n; lrwmin = *n; liwmin = 1; } } work[1].r = (doublereal) lwmin, work[1].i = 0.; rwork[1] = (doublereal) lrwmin; iwork[1] = liwmin; if (*lwork < lwmin && ! lquery) { *info = -11; } else if (*lrwork < lrwmin && ! lquery) { *info = -13; } else if (*liwork < liwmin && ! lquery) { *info = -15; } } if (*info != 0) { i__1 = -(*info); xerbla_("ZHPGVD", &i__1); return 0; } else if (lquery) { return 0; } /* Quick return if possible */ if (*n == 0) { return 0; } /* Form a Cholesky factorization of B. */ zpptrf_(uplo, n, &bp[1], info); if (*info != 0) { *info = *n + *info; return 0; } /* Transform problem to standard eigenvalue problem and solve. */ zhpgst_(itype, uplo, n, &ap[1], &bp[1], info); zhpevd_(jobz, uplo, n, &ap[1], &w[1], &z__[z_offset], ldz, &work[1], lwork, &rwork[1], lrwork, &iwork[1], liwork, info); /* Computing MAX */ d__1 = (doublereal) lwmin, d__2 = work[1].r; lwmin = (integer) max(d__1,d__2); /* Computing MAX */ d__1 = (doublereal) lrwmin; lrwmin = (integer) max(d__1,rwork[1]); /* Computing MAX */ d__1 = (doublereal) liwmin, d__2 = (doublereal) iwork[1]; liwmin = (integer) max(d__1,d__2); if (wantz) { /* Backtransform eigenvectors to the original problem. */ neig = *n; if (*info > 0) { neig = *info - 1; } if (*itype == 1 || *itype == 2) { /* For A*x=(lambda)*B*x and A*B*x=(lambda)*x; */ /* backtransform eigenvectors: x = inv(L)'*y or inv(U)*y */ if (upper) { *(unsigned char *)trans = 'N'; } else { *(unsigned char *)trans = 'C'; } i__1 = neig; for (j = 1; j <= i__1; ++j) { ztpsv_(uplo, trans, "Non-unit", n, &bp[1], &z__[j * z_dim1 + 1], &c__1); } } else if (*itype == 3) { /* For B*A*x=(lambda)*x; */ /* backtransform eigenvectors: x = L*y or U'*y */ if (upper) { *(unsigned char *)trans = 'C'; } else { *(unsigned char *)trans = 'N'; } i__1 = neig; for (j = 1; j <= i__1; ++j) { ztpmv_(uplo, trans, "Non-unit", n, &bp[1], &z__[j * z_dim1 + 1], &c__1); } } } work[1].r = (doublereal) lwmin, work[1].i = 0.; rwork[1] = (doublereal) lrwmin; iwork[1] = liwmin; return 0; /* End of ZHPGVD */ } /* zhpgvd_ */
/* Subroutine */ int ztpt02_(char *uplo, char *trans, char *diag, integer *n, integer *nrhs, doublecomplex *ap, doublecomplex *x, integer *ldx, doublecomplex *b, integer *ldb, doublecomplex *work, doublereal * rwork, doublereal *resid) { /* System generated locals */ integer b_dim1, b_offset, x_dim1, x_offset, i__1; doublereal d__1, d__2; /* Local variables */ integer j; doublereal eps; extern logical lsame_(char *, char *); doublereal anorm, bnorm, xnorm; extern /* Subroutine */ int zcopy_(integer *, doublecomplex *, integer *, doublecomplex *, integer *), zaxpy_(integer *, doublecomplex *, doublecomplex *, integer *, doublecomplex *, integer *), ztpmv_( char *, char *, char *, integer *, doublecomplex *, doublecomplex *, integer *); extern doublereal dlamch_(char *), dzasum_(integer *, doublecomplex *, integer *), zlantp_(char *, 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 */ /* ======= */ /* ZTPT02 computes the residual for the computed solution to a */ /* triangular system of linear equations A*x = b, A**T *x = b, or */ /* A**H *x = b, when the triangular matrix A is stored in packed format. */ /* Here A**T denotes the transpose of A, A**H denotes the conjugate */ /* transpose of A, and x and b are N by NRHS matrices. The test ratio */ /* is the maximum over the number of right hand sides of */ /* the maximum over the number of right hand sides of */ /* norm(b - op(A)*x) / ( norm(op(A)) * norm(x) * EPS ), */ /* where op(A) denotes A, A**T, or A**H, and EPS is the machine epsilon. */ /* Arguments */ /* ========= */ /* UPLO (input) CHARACTER*1 */ /* Specifies whether the matrix A is upper or lower triangular. */ /* = 'U': Upper triangular */ /* = 'L': Lower triangular */ /* TRANS (input) CHARACTER*1 */ /* Specifies the operation applied to A. */ /* = 'N': A *x = b (No transpose) */ /* = 'T': A**T *x = b (Transpose) */ /* = 'C': A**H *x = b (Conjugate transpose) */ /* DIAG (input) CHARACTER*1 */ /* Specifies whether or not the matrix A is unit triangular. */ /* = 'N': Non-unit triangular */ /* = 'U': Unit triangular */ /* N (input) INTEGER */ /* The order of the matrix A. N >= 0. */ /* NRHS (input) INTEGER */ /* The number of right hand sides, i.e., the number of columns */ /* of the matrices X and B. NRHS >= 0. */ /* AP (input) COMPLEX*16 array, dimension (N*(N+1)/2) */ /* The upper or lower triangular 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((j-1)*j/2 + i) = A(i,j) for 1<=i<=j; */ /* if UPLO = 'L', */ /* AP((j-1)*(n-j) + j*(j+1)/2 + i-j) = A(i,j) for j<=i<=n. */ /* X (input) COMPLEX*16 array, dimension (LDX,NRHS) */ /* The computed solution vectors for the system of linear */ /* equations. */ /* LDX (input) INTEGER */ /* The leading dimension of the array X. LDX >= max(1,N). */ /* B (input) COMPLEX*16 array, dimension (LDB,NRHS) */ /* The right hand side vectors for the system of linear */ /* equations. */ /* LDB (input) INTEGER */ /* The leading dimension of the array B. LDB >= max(1,N). */ /* WORK (workspace) COMPLEX*16 array, dimension (N) */ /* RWORK (workspace) DOUBLE PRECISION array, dimension (N) */ /* RESID (output) DOUBLE PRECISION */ /* The maximum over the number of right hand sides of */ /* norm(op(A)*x - b) / ( norm(op(A)) * norm(x) * EPS ). */ /* ===================================================================== */ /* .. Parameters .. */ /* .. */ /* .. Local Scalars .. */ /* .. */ /* .. External Functions .. */ /* .. */ /* .. External Subroutines .. */ /* .. */ /* .. Intrinsic Functions .. */ /* .. */ /* .. Executable Statements .. */ /* Quick exit if N = 0 or NRHS = 0 */ /* Parameter adjustments */ --ap; x_dim1 = *ldx; x_offset = 1 + x_dim1; x -= x_offset; b_dim1 = *ldb; b_offset = 1 + b_dim1; b -= b_offset; --work; --rwork; /* Function Body */ if (*n <= 0 || *nrhs <= 0) { *resid = 0.; return 0; } /* Compute the 1-norm of A or A**H. */ if (lsame_(trans, "N")) { anorm = zlantp_("1", uplo, diag, n, &ap[1], &rwork[1]); } else { anorm = zlantp_("I", uplo, diag, n, &ap[1], &rwork[1]); } /* Exit with RESID = 1/EPS if ANORM = 0. */ eps = dlamch_("Epsilon"); if (anorm <= 0.) { *resid = 1. / eps; return 0; } /* Compute the maximum over the number of right hand sides of */ /* norm(op(A)*x - b) / ( norm(op(A)) * norm(x) * EPS ). */ *resid = 0.; i__1 = *nrhs; for (j = 1; j <= i__1; ++j) { zcopy_(n, &x[j * x_dim1 + 1], &c__1, &work[1], &c__1); ztpmv_(uplo, trans, diag, n, &ap[1], &work[1], &c__1); zaxpy_(n, &c_b12, &b[j * b_dim1 + 1], &c__1, &work[1], &c__1); bnorm = dzasum_(n, &work[1], &c__1); xnorm = dzasum_(n, &x[j * x_dim1 + 1], &c__1); if (xnorm <= 0.) { *resid = 1. / eps; } else { /* Computing MAX */ d__1 = *resid, d__2 = bnorm / anorm / xnorm / eps; *resid = max(d__1,d__2); } /* L10: */ } return 0; /* End of ZTPT02 */ } /* ztpt02_ */
/* 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 zhpgst_(integer *itype, char *uplo, integer *n, doublecomplex *ap, doublecomplex *bp, integer *info) { /* System generated locals */ integer i__1, i__2, i__3, i__4; doublereal d__1, d__2; doublecomplex z__1, z__2, z__3; /* Local variables */ integer j, k, j1, k1, jj, kk; doublecomplex ct; doublereal ajj; integer j1j1; doublereal akk; integer k1k1; doublereal bjj, bkk; extern /* Subroutine */ int zhpr2_(char *, integer *, doublecomplex *, doublecomplex *, integer *, doublecomplex *, integer *, doublecomplex *); extern logical lsame_(char *, char *); extern /* Double Complex */ VOID zdotc_f2c_(doublecomplex *, integer *, doublecomplex *, integer *, doublecomplex *, integer *); logical upper; extern /* Subroutine */ int zhpmv_(char *, integer *, doublecomplex *, doublecomplex *, doublecomplex *, integer *, doublecomplex *, doublecomplex *, integer *), zaxpy_(integer *, doublecomplex *, doublecomplex *, integer *, doublecomplex *, integer *), ztpmv_(char *, char *, char *, integer *, doublecomplex *, doublecomplex *, integer *), ztpsv_(char *, char *, char *, integer *, doublecomplex * , doublecomplex *, integer *), xerbla_( char *, integer *), zdscal_(integer *, doublereal *, doublecomplex *, integer *); /* -- 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 Subroutines .. */ /* .. */ /* .. Intrinsic Functions .. */ /* .. */ /* .. External Functions .. */ /* .. */ /* .. Executable Statements .. */ /* Test the input parameters. */ /* Parameter adjustments */ --bp; --ap; /* Function Body */ *info = 0; upper = lsame_(uplo, "U"); if (*itype < 1 || *itype > 3) { *info = -1; } else if (! upper && ! lsame_(uplo, "L")) { *info = -2; } else if (*n < 0) { *info = -3; } if (*info != 0) { i__1 = -(*info); xerbla_("ZHPGST", &i__1); return 0; } if (*itype == 1) { if (upper) { /* Compute inv(U**H)*A*inv(U) */ /* J1 and JJ are the indices of A(1,j) and A(j,j) */ jj = 0; i__1 = *n; for (j = 1; j <= i__1; ++j) { j1 = jj + 1; jj += j; /* Compute the j-th column of the upper triangle of A */ i__2 = jj; i__3 = jj; d__1 = ap[i__3].r; ap[i__2].r = d__1; ap[i__2].i = 0.; // , expr subst i__2 = jj; bjj = bp[i__2].r; ztpsv_(uplo, "Conjugate transpose", "Non-unit", &j, &bp[1], & ap[j1], &c__1); i__2 = j - 1; z__1.r = -1.; z__1.i = -0.; // , expr subst zhpmv_(uplo, &i__2, &z__1, &ap[1], &bp[j1], &c__1, &c_b1, &ap[ j1], &c__1); i__2 = j - 1; d__1 = 1. / bjj; zdscal_(&i__2, &d__1, &ap[j1], &c__1); i__2 = jj; i__3 = jj; i__4 = j - 1; zdotc_f2c_(&z__3, &i__4, &ap[j1], &c__1, &bp[j1], &c__1); z__2.r = ap[i__3].r - z__3.r; z__2.i = ap[i__3].i - z__3.i; // , expr subst z__1.r = z__2.r / bjj; z__1.i = z__2.i / bjj; // , expr subst ap[i__2].r = z__1.r; ap[i__2].i = z__1.i; // , expr subst /* L10: */ } } else { /* Compute inv(L)*A*inv(L**H) */ /* KK and K1K1 are the indices of A(k,k) and A(k+1,k+1) */ kk = 1; i__1 = *n; for (k = 1; k <= i__1; ++k) { k1k1 = kk + *n - k + 1; /* Update the lower triangle of A(k:n,k:n) */ i__2 = kk; akk = ap[i__2].r; i__2 = kk; bkk = bp[i__2].r; /* Computing 2nd power */ d__1 = bkk; akk /= d__1 * d__1; i__2 = kk; ap[i__2].r = akk; ap[i__2].i = 0.; // , expr subst if (k < *n) { i__2 = *n - k; d__1 = 1. / bkk; zdscal_(&i__2, &d__1, &ap[kk + 1], &c__1); d__1 = akk * -.5; ct.r = d__1; ct.i = 0.; // , expr subst i__2 = *n - k; zaxpy_(&i__2, &ct, &bp[kk + 1], &c__1, &ap[kk + 1], &c__1) ; i__2 = *n - k; z__1.r = -1.; z__1.i = -0.; // , expr subst zhpr2_(uplo, &i__2, &z__1, &ap[kk + 1], &c__1, &bp[kk + 1] , &c__1, &ap[k1k1]); i__2 = *n - k; zaxpy_(&i__2, &ct, &bp[kk + 1], &c__1, &ap[kk + 1], &c__1) ; i__2 = *n - k; ztpsv_(uplo, "No transpose", "Non-unit", &i__2, &bp[k1k1], &ap[kk + 1], &c__1); } kk = k1k1; /* L20: */ } } } else { if (upper) { /* Compute U*A*U**H */ /* K1 and KK are the indices of A(1,k) and A(k,k) */ kk = 0; i__1 = *n; for (k = 1; k <= i__1; ++k) { k1 = kk + 1; kk += k; /* Update the upper triangle of A(1:k,1:k) */ i__2 = kk; akk = ap[i__2].r; i__2 = kk; bkk = bp[i__2].r; i__2 = k - 1; ztpmv_(uplo, "No transpose", "Non-unit", &i__2, &bp[1], &ap[ k1], &c__1); d__1 = akk * .5; ct.r = d__1; ct.i = 0.; // , expr subst i__2 = k - 1; zaxpy_(&i__2, &ct, &bp[k1], &c__1, &ap[k1], &c__1); i__2 = k - 1; zhpr2_(uplo, &i__2, &c_b1, &ap[k1], &c__1, &bp[k1], &c__1, & ap[1]); i__2 = k - 1; zaxpy_(&i__2, &ct, &bp[k1], &c__1, &ap[k1], &c__1); i__2 = k - 1; zdscal_(&i__2, &bkk, &ap[k1], &c__1); i__2 = kk; /* Computing 2nd power */ d__2 = bkk; d__1 = akk * (d__2 * d__2); ap[i__2].r = d__1; ap[i__2].i = 0.; // , expr subst /* L30: */ } } else { /* Compute L**H *A*L */ /* JJ and J1J1 are the indices of A(j,j) and A(j+1,j+1) */ jj = 1; i__1 = *n; for (j = 1; j <= i__1; ++j) { j1j1 = jj + *n - j + 1; /* Compute the j-th column of the lower triangle of A */ i__2 = jj; ajj = ap[i__2].r; i__2 = jj; bjj = bp[i__2].r; i__2 = jj; d__1 = ajj * bjj; i__3 = *n - j; zdotc_f2c_(&z__2, &i__3, &ap[jj + 1], &c__1, &bp[jj + 1], &c__1); z__1.r = d__1 + z__2.r; z__1.i = z__2.i; // , expr subst ap[i__2].r = z__1.r; ap[i__2].i = z__1.i; // , expr subst i__2 = *n - j; zdscal_(&i__2, &bjj, &ap[jj + 1], &c__1); i__2 = *n - j; zhpmv_(uplo, &i__2, &c_b1, &ap[j1j1], &bp[jj + 1], &c__1, & c_b1, &ap[jj + 1], &c__1); i__2 = *n - j + 1; ztpmv_(uplo, "Conjugate transpose", "Non-unit", &i__2, &bp[jj] , &ap[jj], &c__1); jj = j1j1; /* L40: */ } } } return 0; /* End of ZHPGST */ }