/* 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 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 ztpcon_(char *norm, char *uplo, char *diag, integer *n, doublecomplex *ap, doublereal *rcond, doublecomplex *work, doublereal *rwork, integer *info) { /* System generated locals */ integer i__1; doublereal d__1, d__2; /* Local variables */ integer ix, kase, kase1; doublereal scale; integer isave[3]; doublereal anorm; logical upper; doublereal xnorm; doublereal ainvnm; logical onenrm; char normin[1]; doublereal smlnum; logical nounit; /* -- LAPACK routine (version 3.2) -- */ /* November 2006 */ /* Modified to call ZLACN2 in place of ZLACON, 10 Feb 03, SJH. */ /* Purpose */ /* ======= */ /* ZTPCON estimates the reciprocal of the condition number of a packed */ /* triangular matrix A, in either the 1-norm or the infinity-norm. */ /* The norm of A is computed and an estimate is obtained for */ /* norm(inv(A)), then the reciprocal of the condition number is */ /* computed as */ /* RCOND = 1 / ( norm(A) * norm(inv(A)) ). */ /* Arguments */ /* ========= */ /* NORM (input) CHARACTER*1 */ /* Specifies whether the 1-norm condition number or the */ /* infinity-norm condition number is required: */ /* = '1' or 'O': 1-norm; */ /* = 'I': Infinity-norm. */ /* 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) 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. */ /* RCOND (output) DOUBLE PRECISION */ /* The reciprocal of the condition number of the matrix A, */ /* computed as RCOND = 1/(norm(A) * norm(inv(A))). */ /* 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 */ /* ===================================================================== */ /* Test the input parameters. */ /* Parameter adjustments */ --rwork; --work; --ap; /* Function Body */ *info = 0; upper = lsame_(uplo, "U"); onenrm = *(unsigned char *)norm == '1' || lsame_(norm, "O"); nounit = lsame_(diag, "N"); if (! onenrm && ! lsame_(norm, "I")) { *info = -1; } else if (! upper && ! lsame_(uplo, "L")) { *info = -2; } else if (! nounit && ! lsame_(diag, "U")) { *info = -3; } else if (*n < 0) { *info = -4; } if (*info != 0) { i__1 = -(*info); xerbla_("ZTPCON", &i__1); return 0; } /* Quick return if possible */ if (*n == 0) { *rcond = 1.; return 0; } *rcond = 0.; smlnum = dlamch_("Safe minimum") * (doublereal) max(1,*n); /* Compute the norm of the triangular matrix A. */ anorm = zlantp_(norm, uplo, diag, n, &ap[1], &rwork[1]); /* Continue only if ANORM > 0. */ if (anorm > 0.) { /* Estimate the norm of the inverse of A. */ ainvnm = 0.; *(unsigned char *)normin = 'N'; if (onenrm) { kase1 = 1; } else { kase1 = 2; } kase = 0; L10: zlacn2_(n, &work[*n + 1], &work[1], &ainvnm, &kase, isave); if (kase != 0) { if (kase == kase1) { /* Multiply by inv(A). */ zlatps_(uplo, "No transpose", diag, normin, n, &ap[1], &work[ 1], &scale, &rwork[1], info); } else { /* Multiply by inv(A'). */ zlatps_(uplo, "Conjugate transpose", diag, normin, n, &ap[1], &work[1], &scale, &rwork[1], info); } *(unsigned char *)normin = 'Y'; /* Multiply by 1/SCALE if doing so will not cause overflow. */ if (scale != 1.) { ix = izamax_(n, &work[1], &c__1); i__1 = ix; xnorm = (d__1 = work[i__1].r, abs(d__1)) + (d__2 = d_imag(& work[ix]), abs(d__2)); if (scale < xnorm * smlnum || scale == 0.) { goto L20; } zdrscl_(n, &scale, &work[1], &c__1); } goto L10; } /* Compute the estimate of the reciprocal condition number. */ if (ainvnm != 0.) { *rcond = 1. / anorm / ainvnm; } } L20: return 0; /* End of ZTPCON */ } /* ztpcon_ */
/* Subroutine */ int ztpcon_(char *norm, char *uplo, char *diag, integer *n, doublecomplex *ap, doublereal *rcond, doublecomplex *work, doublereal *rwork, integer *info) { /* -- LAPACK routine (version 2.0) -- Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., Courant Institute, Argonne National Lab, and Rice University March 31, 1993 Purpose ======= ZTPCON estimates the reciprocal of the condition number of a packed triangular matrix A, in either the 1-norm or the infinity-norm. The norm of A is computed and an estimate is obtained for norm(inv(A)), then the reciprocal of the condition number is computed as RCOND = 1 / ( norm(A) * norm(inv(A)) ). Arguments ========= NORM (input) CHARACTER*1 Specifies whether the 1-norm condition number or the infinity-norm condition number is required: = '1' or 'O': 1-norm; = 'I': Infinity-norm. 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) 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. RCOND (output) DOUBLE PRECISION The reciprocal of the condition number of the matrix A, computed as RCOND = 1/(norm(A) * norm(inv(A))). 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 ===================================================================== Test the input parameters. Parameter adjustments Function Body */ /* Table of constant values */ static integer c__1 = 1; /* System generated locals */ integer i__1; doublereal d__1, d__2; /* Builtin functions */ double d_imag(doublecomplex *); /* Local variables */ static integer kase, kase1; static doublereal scale; extern logical lsame_(char *, char *); static doublereal anorm; static logical upper; static doublereal xnorm; extern doublereal dlamch_(char *); static integer ix; extern /* Subroutine */ int xerbla_(char *, integer *), zlacon_( integer *, doublecomplex *, doublecomplex *, doublereal *, integer *); static doublereal ainvnm; extern integer izamax_(integer *, doublecomplex *, integer *); static logical onenrm; extern /* Subroutine */ int zdrscl_(integer *, doublereal *, doublecomplex *, integer *); static char normin[1]; extern doublereal zlantp_(char *, char *, char *, integer *, doublecomplex *, doublereal *); static doublereal smlnum; static logical nounit; extern /* Subroutine */ int zlatps_(char *, char *, char *, char *, integer *, doublecomplex *, doublecomplex *, doublereal *, doublereal *, integer *); #define RWORK(I) rwork[(I)-1] #define WORK(I) work[(I)-1] #define AP(I) ap[(I)-1] *info = 0; upper = lsame_(uplo, "U"); onenrm = *(unsigned char *)norm == '1' || lsame_(norm, "O"); nounit = lsame_(diag, "N"); if (! onenrm && ! lsame_(norm, "I")) { *info = -1; } else if (! upper && ! lsame_(uplo, "L")) { *info = -2; } else if (! nounit && ! lsame_(diag, "U")) { *info = -3; } else if (*n < 0) { *info = -4; } if (*info != 0) { i__1 = -(*info); xerbla_("ZTPCON", &i__1); return 0; } /* Quick return if possible */ if (*n == 0) { *rcond = 1.; return 0; } *rcond = 0.; smlnum = dlamch_("Safe minimum") * (doublereal) max(1,*n); /* Compute the norm of the triangular matrix A. */ anorm = zlantp_(norm, uplo, diag, n, &AP(1), &RWORK(1)); /* Continue only if ANORM > 0. */ if (anorm > 0.) { /* Estimate the norm of the inverse of A. */ ainvnm = 0.; *(unsigned char *)normin = 'N'; if (onenrm) { kase1 = 1; } else { kase1 = 2; } kase = 0; L10: zlacon_(n, &WORK(*n + 1), &WORK(1), &ainvnm, &kase); if (kase != 0) { if (kase == kase1) { /* Multiply by inv(A). */ zlatps_(uplo, "No transpose", diag, normin, n, &AP(1), &WORK( 1), &scale, &RWORK(1), info); } else { /* Multiply by inv(A'). */ zlatps_(uplo, "Conjugate transpose", diag, normin, n, &AP(1), &WORK(1), &scale, &RWORK(1), info); } *(unsigned char *)normin = 'Y'; /* Multiply by 1/SCALE if doing so will not cause overfl ow. */ if (scale != 1.) { ix = izamax_(n, &WORK(1), &c__1); i__1 = ix; xnorm = (d__1 = WORK(ix).r, abs(d__1)) + (d__2 = d_imag(& WORK(ix)), abs(d__2)); if (scale < xnorm * smlnum || scale == 0.) { goto L20; } zdrscl_(n, &scale, &WORK(1), &c__1); } goto L10; } /* Compute the estimate of the reciprocal condition number. */ if (ainvnm != 0.) { *rcond = 1. / anorm / ainvnm; } } L20: return 0; /* End of ZTPCON */ } /* ztpcon_ */