int f2c_ctbmv(char* uplo, char* trans, char* diag, integer* N, integer* K, complex* A, integer* lda, complex* X, integer* incX) { ctbmv_(uplo, trans, diag, N, K, A, lda, X, incX); return 0; }
/* Subroutine */ int ctbt02_(char *uplo, char *trans, char *diag, integer *n, integer *kd, integer *nrhs, complex *ab, integer *ldab, complex *x, integer *ldx, complex *b, integer *ldb, complex *work, real *rwork, real *resid) { /* System generated locals */ integer ab_dim1, ab_offset, b_dim1, b_offset, x_dim1, x_offset, i__1; real r__1, r__2; /* Local variables */ integer j; real eps; extern logical lsame_(char *, char *); extern /* Subroutine */ int ctbmv_(char *, char *, char *, integer *, integer *, complex *, integer *, complex *, integer *); real anorm, bnorm; extern /* Subroutine */ int ccopy_(integer *, complex *, integer *, complex *, integer *), caxpy_(integer *, complex *, complex *, integer *, complex *, integer *); real xnorm; extern doublereal clantb_(char *, char *, char *, integer *, integer *, complex *, integer *, real *), slamch_( char *), scasum_(integer *, complex *, integer *); /* -- LAPACK test routine (version 3.1) -- */ /* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ /* November 2006 */ /* .. Scalar Arguments .. */ /* .. */ /* .. Array Arguments .. */ /* .. */ /* Purpose */ /* ======= */ /* CTBT02 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 A is a triangular band matrix. 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 */ /* 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. */ /* KD (input) INTEGER */ /* The number of superdiagonals or subdiagonals of the */ /* triangular band matrix A. KD >= 0. */ /* NRHS (input) INTEGER */ /* The number of right hand sides, i.e., the number of columns */ /* of the matrices X and B. NRHS >= 0. */ /* AB (input) COMPLEX array, dimension (LDA,N) */ /* The upper or lower triangular band matrix A, stored in the */ /* first kd+1 rows of the array. The j-th column of A is stored */ /* in the j-th column of the array AB as follows: */ /* if UPLO = 'U', AB(kd+1+i-j,j) = A(i,j) for max(1,j-kd)<=i<=j; */ /* if UPLO = 'L', AB(1+i-j,j) = A(i,j) for j<=i<=min(n,j+kd). */ /* LDAB (input) INTEGER */ /* The leading dimension of the array AB. LDAB >= max(1,KD+1). */ /* X (input) COMPLEX 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 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 array, dimension (N) */ /* RWORK (workspace) REAL array, dimension (N) */ /* RESID (output) REAL */ /* 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 */ ab_dim1 = *ldab; ab_offset = 1 + ab_dim1; ab -= ab_offset; 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.f; return 0; } /* Compute the 1-norm of A or A'. */ if (lsame_(trans, "N")) { anorm = clantb_("1", uplo, diag, n, kd, &ab[ab_offset], ldab, &rwork[ 1]); } else { anorm = clantb_("I", uplo, diag, n, kd, &ab[ab_offset], ldab, &rwork[ 1]); } /* Exit with RESID = 1/EPS if ANORM = 0. */ eps = slamch_("Epsilon"); if (anorm <= 0.f) { *resid = 1.f / 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.f; i__1 = *nrhs; for (j = 1; j <= i__1; ++j) { ccopy_(n, &x[j * x_dim1 + 1], &c__1, &work[1], &c__1); ctbmv_(uplo, trans, diag, n, kd, &ab[ab_offset], ldab, &work[1], & c__1); caxpy_(n, &c_b12, &b[j * b_dim1 + 1], &c__1, &work[1], &c__1); bnorm = scasum_(n, &work[1], &c__1); xnorm = scasum_(n, &x[j * x_dim1 + 1], &c__1); if (xnorm <= 0.f) { *resid = 1.f / eps; } else { /* Computing MAX */ r__1 = *resid, r__2 = bnorm / anorm / xnorm / eps; *resid = dmax(r__1,r__2); } /* L10: */ } return 0; /* End of CTBT02 */ } /* ctbt02_ */
void ctbmv(char uplo, char trans, char diag, int n, int k, complex *a, int lda, complex *x, int incx ) { ctbmv_( &uplo, &trans, &diag, &n, &k, a, &lda, x, &incx ); }
/* Subroutine */ int ctbt03_(char *uplo, char *trans, char *diag, integer *n, integer *kd, integer *nrhs, complex *ab, integer *ldab, real *scale, real *cnorm, real *tscal, complex *x, integer *ldx, complex *b, integer *ldb, complex *work, real *resid) { /* System generated locals */ integer ab_dim1, ab_offset, b_dim1, b_offset, x_dim1, x_offset, i__1; real r__1, r__2; complex q__1; /* Builtin functions */ double c_abs(complex *); /* Local variables */ static integer j; extern logical lsame_(char *, char *); static real xscal; extern /* Subroutine */ int ctbmv_(char *, char *, char *, integer *, integer *, complex *, integer *, complex *, integer *), ccopy_(integer *, complex *, integer *, complex * , integer *), caxpy_(integer *, complex *, complex *, integer *, complex *, integer *); static real tnorm, xnorm; static integer ix; extern integer icamax_(integer *, complex *, integer *); extern doublereal slamch_(char *); extern /* Subroutine */ int csscal_(integer *, real *, complex *, integer *); static real smlnum, eps, err; #define b_subscr(a_1,a_2) (a_2)*b_dim1 + a_1 #define b_ref(a_1,a_2) b[b_subscr(a_1,a_2)] #define x_subscr(a_1,a_2) (a_2)*x_dim1 + a_1 #define x_ref(a_1,a_2) x[x_subscr(a_1,a_2)] #define ab_subscr(a_1,a_2) (a_2)*ab_dim1 + a_1 #define ab_ref(a_1,a_2) ab[ab_subscr(a_1,a_2)] /* -- LAPACK test routine (version 3.0) -- Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., Courant Institute, Argonne National Lab, and Rice University February 29, 1992 Purpose ======= CTBT03 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 A is a triangular band matrix. 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. KD (input) INTEGER The number of superdiagonals or subdiagonals of the triangular band matrix A. KD >= 0. NRHS (input) INTEGER The number of right hand sides, i.e., the number of columns of the matrices X and B. NRHS >= 0. AB (input) COMPLEX array, dimension (LDAB,N) The upper or lower triangular band matrix A, stored in the first kd+1 rows of the array. The j-th column of A is stored in the j-th column of the array AB as follows: if UPLO = 'U', AB(kd+1+i-j,j) = A(i,j) for max(1,j-kd)<=i<=j; if UPLO = 'L', AB(1+i-j,j) = A(i,j) for j<=i<=min(n,j+kd). LDAB (input) INTEGER The leading dimension of the array AB. LDAB >= KD+1. SCALE (input) REAL The scaling factor s used in solving the triangular system. CNORM (input) REAL array, dimension (N) The 1-norms of the columns of A, not counting the diagonal. TSCAL (input) REAL The scaling factor used in computing the 1-norms in CNORM. CNORM actually contains the column norms of TSCAL*A. X (input) COMPLEX 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 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 array, dimension (N) RESID (output) REAL The maximum over the number of right hand sides of norm(op(A)*x - s*b) / ( norm(op(A)) * norm(x) * EPS ). ===================================================================== Quick exit if N = 0 Parameter adjustments */ ab_dim1 = *ldab; ab_offset = 1 + ab_dim1 * 1; ab -= ab_offset; --cnorm; x_dim1 = *ldx; x_offset = 1 + x_dim1 * 1; x -= x_offset; b_dim1 = *ldb; b_offset = 1 + b_dim1 * 1; b -= b_offset; --work; /* Function Body */ if (*n <= 0 || *nrhs <= 0) { *resid = 0.f; return 0; } eps = slamch_("Epsilon"); smlnum = slamch_("Safe minimum"); /* Compute the norm of the triangular matrix A using the column norms already computed by CLATBS. */ tnorm = 0.f; if (lsame_(diag, "N")) { if (lsame_(uplo, "U")) { i__1 = *n; for (j = 1; j <= i__1; ++j) { /* Computing MAX */ r__1 = tnorm, r__2 = *tscal * c_abs(&ab_ref(*kd + 1, j)) + cnorm[j]; tnorm = dmax(r__1,r__2); /* L10: */ } } else { i__1 = *n; for (j = 1; j <= i__1; ++j) { /* Computing MAX */ r__1 = tnorm, r__2 = *tscal * c_abs(&ab_ref(1, j)) + cnorm[j]; tnorm = dmax(r__1,r__2); /* L20: */ } } } else { i__1 = *n; for (j = 1; j <= i__1; ++j) { /* Computing MAX */ r__1 = tnorm, r__2 = *tscal + cnorm[j]; tnorm = dmax(r__1,r__2); /* L30: */ } } /* Compute the maximum over the number of right hand sides of norm(op(A)*x - s*b) / ( norm(op(A)) * norm(x) * EPS ). */ *resid = 0.f; i__1 = *nrhs; for (j = 1; j <= i__1; ++j) { ccopy_(n, &x_ref(1, j), &c__1, &work[1], &c__1); ix = icamax_(n, &work[1], &c__1); /* Computing MAX */ r__1 = 1.f, r__2 = c_abs(&x_ref(ix, j)); xnorm = dmax(r__1,r__2); xscal = 1.f / xnorm / (real) (*kd + 1); csscal_(n, &xscal, &work[1], &c__1); ctbmv_(uplo, trans, diag, n, kd, &ab[ab_offset], ldab, &work[1], & c__1); r__1 = -(*scale) * xscal; q__1.r = r__1, q__1.i = 0.f; caxpy_(n, &q__1, &b_ref(1, j), &c__1, &work[1], &c__1); ix = icamax_(n, &work[1], &c__1); err = *tscal * c_abs(&work[ix]); ix = icamax_(n, &x_ref(1, j), &c__1); xnorm = c_abs(&x_ref(ix, j)); if (err * smlnum <= xnorm) { if (xnorm > 0.f) { err /= xnorm; } } else { if (err > 0.f) { err = 1.f / eps; } } if (err * smlnum <= tnorm) { if (tnorm > 0.f) { err /= tnorm; } } else { if (err > 0.f) { err = 1.f / eps; } } *resid = dmax(*resid,err); /* L40: */ } return 0; /* End of CTBT03 */ } /* ctbt03_ */
/* Subroutine */ int clarhs_(char *path, char *xtype, char *uplo, char *trans, integer *m, integer *n, integer *kl, integer *ku, integer *nrhs, complex *a, integer *lda, complex *x, integer *ldx, complex *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 cgemm_(char *, char *, integer *, integer *, integer *, complex *, complex *, integer *, complex *, integer *, complex *, complex *, integer *), chemm_(char *, char *, integer *, integer *, complex *, complex *, integer *, complex *, integer *, complex *, complex *, integer *), cgbmv_(char *, integer *, integer *, integer *, integer * , complex *, complex *, integer *, complex *, integer *, complex * , complex *, integer *), chbmv_(char *, integer *, integer *, complex *, complex *, integer *, complex *, integer *, complex *, complex *, integer *); extern /* Subroutine */ int csbmv_(char *, integer *, integer *, complex * , complex *, integer *, complex *, integer *, complex *, complex * , integer *), ctbmv_(char *, char *, char *, integer *, integer *, complex *, integer *, complex *, integer *), chpmv_(char *, integer *, complex *, complex *, complex *, integer *, complex *, complex *, integer *), ctrmm_(char *, char *, char *, char *, integer *, integer *, complex *, complex *, integer *, complex *, integer *), cspmv_(char *, integer *, complex *, complex *, complex *, integer *, complex *, complex *, integer *), csymm_(char *, char *, integer *, integer *, complex *, complex *, integer *, complex *, integer *, complex *, complex *, integer *), ctpmv_(char *, char *, char *, integer *, complex *, complex *, integer *), clacpy_(char *, integer *, integer *, complex *, integer *, complex *, integer *), xerbla_(char *, integer *); extern logical lsamen_(integer *, char *, char *); extern /* Subroutine */ int clarnv_(integer *, integer *, integer *, complex *); logical notran; /* -- LAPACK test routine (version 3.1) -- */ /* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ /* November 2006 */ /* .. Scalar Arguments .. */ /* .. */ /* .. Array Arguments .. */ /* .. */ /* Purpose */ /* ======= */ /* CLARHS 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 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 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 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 */ /* CLATMS). 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, "Complex 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_("CLARHS", &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) { clarnv_(&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 */ cgemm_(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 */ chemm_("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 */ csymm_("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) { cgbmv_(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) { chbmv_(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) { csbmv_(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) { chpmv_(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) { cspmv_(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 */ clacpy_("Full", n, nrhs, &x[x_offset], ldx, &b[b_offset], ldb); if (*ku == 2) { *(unsigned char *)diag = 'U'; } else { *(unsigned char *)diag = 'N'; } ctrmm_("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 */ clacpy_("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) { ctpmv_(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 */ clacpy_("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) { ctbmv_(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_("CLARHS", &i__1); } return 0; /* End of CLARHS */ } /* clarhs_ */
int ctbrfs_(char *uplo, char *trans, char *diag, int *n, int *kd, int *nrhs, complex *ab, int *ldab, complex *b, int *ldb, complex *x, int *ldx, float *ferr, float *berr, complex *work, float *rwork, int *info) { /* System generated locals */ int ab_dim1, ab_offset, b_dim1, b_offset, x_dim1, x_offset, i__1, i__2, i__3, i__4, i__5; float r__1, r__2, r__3, r__4; complex q__1; /* Builtin functions */ double r_imag(complex *); /* Local variables */ int i__, j, k; float s, xk; int nz; float eps; int kase; float safe1, safe2; extern int lsame_(char *, char *); int isave[3]; extern int ctbmv_(char *, char *, char *, int *, int *, complex *, int *, complex *, int *), ccopy_(int *, complex *, int *, complex * , int *), ctbsv_(char *, char *, char *, int *, int *, complex *, int *, complex *, int *), caxpy_(int *, complex *, complex *, int *, complex *, int *); int upper; extern int clacn2_(int *, complex *, complex *, float *, int *, int *); extern double slamch_(char *); float safmin; extern int xerbla_(char *, int *); int notran; char transn[1], transt[1]; int nounit; float lstres; /* -- LAPACK routine (version 3.2) -- */ /* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ /* November 2006 */ /* Modified to call CLACN2 in place of CLACON, 10 Feb 03, SJH. */ /* .. Scalar Arguments .. */ /* .. */ /* .. Array Arguments .. */ /* .. */ /* Purpose */ /* ======= */ /* CTBRFS provides error bounds and backward error estimates for the */ /* solution to a system of linear equations with a triangular band */ /* coefficient matrix. */ /* The solution matrix X must be computed by CTBTRS or some other */ /* means before entering this routine. CTBRFS 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. */ /* KD (input) INTEGER */ /* The number of superdiagonals or subdiagonals of the */ /* triangular band matrix A. KD >= 0. */ /* NRHS (input) INTEGER */ /* The number of right hand sides, i.e., the number of columns */ /* of the matrices B and X. NRHS >= 0. */ /* AB (input) COMPLEX array, dimension (LDAB,N) */ /* The upper or lower triangular band matrix A, stored in the */ /* first kd+1 rows of the array. The j-th column of A is stored */ /* in the j-th column of the array AB as follows: */ /* if UPLO = 'U', AB(kd+1+i-j,j) = A(i,j) for MAX(1,j-kd)<=i<=j; */ /* if UPLO = 'L', AB(1+i-j,j) = A(i,j) for j<=i<=MIN(n,j+kd). */ /* If DIAG = 'U', the diagonal elements of A are not referenced */ /* and are assumed to be 1. */ /* LDAB (input) INTEGER */ /* The leading dimension of the array AB. LDAB >= KD+1. */ /* B (input) COMPLEX 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 array, dimension (LDX,NRHS) */ /* The solution matrix X. */ /* LDX (input) INTEGER */ /* The leading dimension of the array X. LDX >= MAX(1,N). */ /* FERR (output) REAL 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) REAL 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 array, dimension (2*N) */ /* RWORK (workspace) REAL 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 */ ab_dim1 = *ldab; ab_offset = 1 + ab_dim1; ab -= ab_offset; 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 (*kd < 0) { *info = -5; } else if (*nrhs < 0) { *info = -6; } else if (*ldab < *kd + 1) { *info = -8; } else if (*ldb < MAX(1,*n)) { *info = -10; } else if (*ldx < MAX(1,*n)) { *info = -12; } if (*info != 0) { i__1 = -(*info); xerbla_("CTBRFS", &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.f; berr[j] = 0.f; /* 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 = *kd + 2; eps = slamch_("Epsilon"); safmin = slamch_("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. */ ccopy_(n, &x[j * x_dim1 + 1], &c__1, &work[1], &c__1); ctbmv_(uplo, trans, diag, n, kd, &ab[ab_offset], ldab, &work[1], & c__1); q__1.r = -1.f, q__1.i = -0.f; caxpy_(n, &q__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__] = (r__1 = b[i__3].r, ABS(r__1)) + (r__2 = r_imag(&b[ i__ + j * b_dim1]), ABS(r__2)); /* L20: */ } if (notran) { /* Compute ABS(A)*ABS(X) + ABS(B). */ if (upper) { if (nounit) { i__2 = *n; for (k = 1; k <= i__2; ++k) { i__3 = k + j * x_dim1; xk = (r__1 = x[i__3].r, ABS(r__1)) + (r__2 = r_imag(& x[k + j * x_dim1]), ABS(r__2)); /* Computing MAX */ i__3 = 1, i__4 = k - *kd; i__5 = k; for (i__ = MAX(i__3,i__4); i__ <= i__5; ++i__) { i__3 = *kd + 1 + i__ - k + k * ab_dim1; rwork[i__] += ((r__1 = ab[i__3].r, ABS(r__1)) + ( r__2 = r_imag(&ab[*kd + 1 + i__ - k + k * ab_dim1]), ABS(r__2))) * xk; /* L30: */ } /* L40: */ } } else { i__2 = *n; for (k = 1; k <= i__2; ++k) { i__5 = k + j * x_dim1; xk = (r__1 = x[i__5].r, ABS(r__1)) + (r__2 = r_imag(& x[k + j * x_dim1]), ABS(r__2)); /* Computing MAX */ i__5 = 1, i__3 = k - *kd; i__4 = k - 1; for (i__ = MAX(i__5,i__3); i__ <= i__4; ++i__) { i__5 = *kd + 1 + i__ - k + k * ab_dim1; rwork[i__] += ((r__1 = ab[i__5].r, ABS(r__1)) + ( r__2 = r_imag(&ab[*kd + 1 + i__ - k + k * ab_dim1]), ABS(r__2))) * xk; /* L50: */ } rwork[k] += xk; /* L60: */ } } } else { if (nounit) { i__2 = *n; for (k = 1; k <= i__2; ++k) { i__4 = k + j * x_dim1; xk = (r__1 = x[i__4].r, ABS(r__1)) + (r__2 = r_imag(& x[k + j * x_dim1]), ABS(r__2)); /* Computing MIN */ i__5 = *n, i__3 = k + *kd; i__4 = MIN(i__5,i__3); for (i__ = k; i__ <= i__4; ++i__) { i__5 = i__ + 1 - k + k * ab_dim1; rwork[i__] += ((r__1 = ab[i__5].r, ABS(r__1)) + ( r__2 = r_imag(&ab[i__ + 1 - k + k * ab_dim1]), ABS(r__2))) * xk; /* L70: */ } /* L80: */ } } else { i__2 = *n; for (k = 1; k <= i__2; ++k) { i__4 = k + j * x_dim1; xk = (r__1 = x[i__4].r, ABS(r__1)) + (r__2 = r_imag(& x[k + j * x_dim1]), ABS(r__2)); /* Computing MIN */ i__5 = *n, i__3 = k + *kd; i__4 = MIN(i__5,i__3); for (i__ = k + 1; i__ <= i__4; ++i__) { i__5 = i__ + 1 - k + k * ab_dim1; rwork[i__] += ((r__1 = ab[i__5].r, ABS(r__1)) + ( r__2 = r_imag(&ab[i__ + 1 - k + k * ab_dim1]), ABS(r__2))) * xk; /* L90: */ } rwork[k] += xk; /* L100: */ } } } } else { /* Compute ABS(A**H)*ABS(X) + ABS(B). */ if (upper) { if (nounit) { i__2 = *n; for (k = 1; k <= i__2; ++k) { s = 0.f; /* Computing MAX */ i__4 = 1, i__5 = k - *kd; i__3 = k; for (i__ = MAX(i__4,i__5); i__ <= i__3; ++i__) { i__4 = *kd + 1 + i__ - k + k * ab_dim1; i__5 = i__ + j * x_dim1; s += ((r__1 = ab[i__4].r, ABS(r__1)) + (r__2 = r_imag(&ab[*kd + 1 + i__ - k + k * ab_dim1]), ABS(r__2))) * ((r__3 = x[i__5] .r, ABS(r__3)) + (r__4 = r_imag(&x[i__ + j * x_dim1]), ABS(r__4))); /* L110: */ } rwork[k] += s; /* L120: */ } } else { i__2 = *n; for (k = 1; k <= i__2; ++k) { i__3 = k + j * x_dim1; s = (r__1 = x[i__3].r, ABS(r__1)) + (r__2 = r_imag(& x[k + j * x_dim1]), ABS(r__2)); /* Computing MAX */ i__3 = 1, i__4 = k - *kd; i__5 = k - 1; for (i__ = MAX(i__3,i__4); i__ <= i__5; ++i__) { i__3 = *kd + 1 + i__ - k + k * ab_dim1; i__4 = i__ + j * x_dim1; s += ((r__1 = ab[i__3].r, ABS(r__1)) + (r__2 = r_imag(&ab[*kd + 1 + i__ - k + k * ab_dim1]), ABS(r__2))) * ((r__3 = x[i__4] .r, ABS(r__3)) + (r__4 = r_imag(&x[i__ + j * x_dim1]), ABS(r__4))); /* L130: */ } rwork[k] += s; /* L140: */ } } } else { if (nounit) { i__2 = *n; for (k = 1; k <= i__2; ++k) { s = 0.f; /* Computing MIN */ i__3 = *n, i__4 = k + *kd; i__5 = MIN(i__3,i__4); for (i__ = k; i__ <= i__5; ++i__) { i__3 = i__ + 1 - k + k * ab_dim1; i__4 = i__ + j * x_dim1; s += ((r__1 = ab[i__3].r, ABS(r__1)) + (r__2 = r_imag(&ab[i__ + 1 - k + k * ab_dim1]), ABS(r__2))) * ((r__3 = x[i__4].r, ABS( r__3)) + (r__4 = r_imag(&x[i__ + j * x_dim1]), ABS(r__4))); /* L150: */ } rwork[k] += s; /* L160: */ } } else { i__2 = *n; for (k = 1; k <= i__2; ++k) { i__5 = k + j * x_dim1; s = (r__1 = x[i__5].r, ABS(r__1)) + (r__2 = r_imag(& x[k + j * x_dim1]), ABS(r__2)); /* Computing MIN */ i__3 = *n, i__4 = k + *kd; i__5 = MIN(i__3,i__4); for (i__ = k + 1; i__ <= i__5; ++i__) { i__3 = i__ + 1 - k + k * ab_dim1; i__4 = i__ + j * x_dim1; s += ((r__1 = ab[i__3].r, ABS(r__1)) + (r__2 = r_imag(&ab[i__ + 1 - k + k * ab_dim1]), ABS(r__2))) * ((r__3 = x[i__4].r, ABS( r__3)) + (r__4 = r_imag(&x[i__ + j * x_dim1]), ABS(r__4))); /* L170: */ } rwork[k] += s; /* L180: */ } } } } s = 0.f; i__2 = *n; for (i__ = 1; i__ <= i__2; ++i__) { if (rwork[i__] > safe2) { /* Computing MAX */ i__5 = i__; r__3 = s, r__4 = ((r__1 = work[i__5].r, ABS(r__1)) + (r__2 = r_imag(&work[i__]), ABS(r__2))) / rwork[i__]; s = MAX(r__3,r__4); } else { /* Computing MAX */ i__5 = i__; r__3 = s, r__4 = ((r__1 = work[i__5].r, ABS(r__1)) + (r__2 = r_imag(&work[i__]), ABS(r__2)) + safe1) / (rwork[i__] + safe1); s = MAX(r__3,r__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 CLACN2 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__5 = i__; rwork[i__] = (r__1 = work[i__5].r, ABS(r__1)) + (r__2 = r_imag(&work[i__]), ABS(r__2)) + nz * eps * rwork[ i__]; } else { i__5 = i__; rwork[i__] = (r__1 = work[i__5].r, ABS(r__1)) + (r__2 = r_imag(&work[i__]), ABS(r__2)) + nz * eps * rwork[ i__] + safe1; } /* L200: */ } kase = 0; L210: clacn2_(n, &work[*n + 1], &work[1], &ferr[j], &kase, isave); if (kase != 0) { if (kase == 1) { /* Multiply by diag(W)*inv(op(A)**H). */ ctbsv_(uplo, transt, diag, n, kd, &ab[ab_offset], ldab, &work[ 1], &c__1); i__2 = *n; for (i__ = 1; i__ <= i__2; ++i__) { i__5 = i__; i__3 = i__; i__4 = i__; q__1.r = rwork[i__3] * work[i__4].r, q__1.i = rwork[i__3] * work[i__4].i; work[i__5].r = q__1.r, work[i__5].i = q__1.i; /* L220: */ } } else { /* Multiply by inv(op(A))*diag(W). */ i__2 = *n; for (i__ = 1; i__ <= i__2; ++i__) { i__5 = i__; i__3 = i__; i__4 = i__; q__1.r = rwork[i__3] * work[i__4].r, q__1.i = rwork[i__3] * work[i__4].i; work[i__5].r = q__1.r, work[i__5].i = q__1.i; /* L230: */ } ctbsv_(uplo, transn, diag, n, kd, &ab[ab_offset], ldab, &work[ 1], &c__1); } goto L210; } /* Normalize error. */ lstres = 0.f; i__2 = *n; for (i__ = 1; i__ <= i__2; ++i__) { /* Computing MAX */ i__5 = i__ + j * x_dim1; r__3 = lstres, r__4 = (r__1 = x[i__5].r, ABS(r__1)) + (r__2 = r_imag(&x[i__ + j * x_dim1]), ABS(r__2)); lstres = MAX(r__3,r__4); /* L240: */ } if (lstres != 0.f) { ferr[j] /= lstres; } /* L250: */ } return 0; /* End of CTBRFS */ } /* ctbrfs_ */