int f2c_ctbsv(char* uplo, char* trans, char* diag, integer* N, integer* K, complex* A, integer* lda, complex* X, integer* incX) { ctbsv_(uplo, trans, diag, N, K, A, lda, X, incX); return 0; }
void ctbsv(char uplo, char trans, char diag, int n, int k, complex *a, int lda, complex *x, int incx ) { ctbsv_( &uplo, &trans, &diag, &n, &k, a, &lda, x, &incx ); }
int cpbtrs_(char *uplo, int *n, int *kd, int * nrhs, complex *ab, int *ldab, complex *b, int *ldb, int * info) { /* System generated locals */ int ab_dim1, ab_offset, b_dim1, b_offset, i__1; /* Local variables */ int j; extern int lsame_(char *, char *); extern int ctbsv_(char *, char *, char *, int *, int *, complex *, int *, complex *, int *); int upper; extern int xerbla_(char *, int *); /* -- LAPACK routine (version 3.2) -- */ /* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ /* November 2006 */ /* .. Scalar Arguments .. */ /* .. */ /* .. Array Arguments .. */ /* .. */ /* Purpose */ /* ======= */ /* CPBTRS solves a system of linear equations A*X = B with a Hermitian */ /* positive definite band matrix A using the Cholesky factorization */ /* A = U**H*U or A = L*L**H computed by CPBTRF. */ /* Arguments */ /* ========= */ /* UPLO (input) CHARACTER*1 */ /* = 'U': Upper triangular factor stored in AB; */ /* = 'L': Lower triangular factor stored in AB. */ /* N (input) INTEGER */ /* The order of the matrix A. N >= 0. */ /* KD (input) INTEGER */ /* The number of superdiagonals of the matrix A if UPLO = 'U', */ /* or the number of subdiagonals if UPLO = 'L'. KD >= 0. */ /* NRHS (input) INTEGER */ /* The number of right hand sides, i.e., the number of columns */ /* of the matrix B. NRHS >= 0. */ /* AB (input) COMPLEX array, dimension (LDAB,N) */ /* The triangular factor U or L from the Cholesky factorization */ /* A = U**H*U or A = L*L**H of the band matrix A, stored in the */ /* first KD+1 rows of the array. The j-th column of U or L is */ /* stored in the j-th column of the array AB as follows: */ /* if UPLO ='U', AB(kd+1+i-j,j) = U(i,j) for MAX(1,j-kd)<=i<=j; */ /* if UPLO ='L', AB(1+i-j,j) = L(i,j) for j<=i<=MIN(n,j+kd). */ /* LDAB (input) INTEGER */ /* The leading dimension of the array AB. LDAB >= KD+1. */ /* B (input/output) COMPLEX array, dimension (LDB,NRHS) */ /* On entry, the right hand side matrix B. */ /* On exit, the solution matrix X. */ /* LDB (input) INTEGER */ /* The leading dimension of the array B. LDB >= MAX(1,N). */ /* INFO (output) INTEGER */ /* = 0: successful exit */ /* < 0: if INFO = -i, the i-th argument had an illegal value */ /* ===================================================================== */ /* .. Local Scalars .. */ /* .. */ /* .. External Functions .. */ /* .. */ /* .. External Subroutines .. */ /* .. */ /* .. Intrinsic Functions .. */ /* .. */ /* .. Executable Statements .. */ /* Test the input parameters. */ /* Parameter adjustments */ ab_dim1 = *ldab; ab_offset = 1 + ab_dim1; ab -= ab_offset; b_dim1 = *ldb; b_offset = 1 + b_dim1; b -= b_offset; /* Function Body */ *info = 0; upper = lsame_(uplo, "U"); if (! upper && ! lsame_(uplo, "L")) { *info = -1; } else if (*n < 0) { *info = -2; } else if (*kd < 0) { *info = -3; } else if (*nrhs < 0) { *info = -4; } else if (*ldab < *kd + 1) { *info = -6; } else if (*ldb < MAX(1,*n)) { *info = -8; } if (*info != 0) { i__1 = -(*info); xerbla_("CPBTRS", &i__1); return 0; } /* Quick return if possible */ if (*n == 0 || *nrhs == 0) { return 0; } if (upper) { /* Solve A*X = B where A = U'*U. */ i__1 = *nrhs; for (j = 1; j <= i__1; ++j) { /* Solve U'*X = B, overwriting B with X. */ ctbsv_("Upper", "Conjugate transpose", "Non-unit", n, kd, &ab[ ab_offset], ldab, &b[j * b_dim1 + 1], &c__1); /* Solve U*X = B, overwriting B with X. */ ctbsv_("Upper", "No transpose", "Non-unit", n, kd, &ab[ab_offset], ldab, &b[j * b_dim1 + 1], &c__1); /* L10: */ } } else { /* Solve A*X = B where A = L*L'. */ i__1 = *nrhs; for (j = 1; j <= i__1; ++j) { /* Solve L*X = B, overwriting B with X. */ ctbsv_("Lower", "No transpose", "Non-unit", n, kd, &ab[ab_offset], ldab, &b[j * b_dim1 + 1], &c__1); /* Solve L'*X = B, overwriting B with X. */ ctbsv_("Lower", "Conjugate transpose", "Non-unit", n, kd, &ab[ ab_offset], ldab, &b[j * b_dim1 + 1], &c__1); /* L20: */ } } return 0; /* End of CPBTRS */ } /* cpbtrs_ */
/* Subroutine */ int ctbtrs_(char *uplo, char *trans, char *diag, integer *n, integer *kd, integer *nrhs, complex *ab, integer *ldab, complex *b, integer *ldb, integer *info) { /* System generated locals */ integer ab_dim1, ab_offset, b_dim1, b_offset, i__1, i__2; /* Local variables */ integer j; extern logical lsame_(char *, char *); extern /* Subroutine */ int ctbsv_(char *, char *, char *, integer *, integer *, complex *, integer *, complex *, integer *); logical upper; extern /* Subroutine */ int xerbla_(char *, integer *); logical nounit; /* -- LAPACK routine (version 3.2) -- */ /* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ /* November 2006 */ /* .. Scalar Arguments .. */ /* .. */ /* .. Array Arguments .. */ /* .. */ /* Purpose */ /* ======= */ /* CTBTRS solves a triangular system of the form */ /* A * X = B, A**T * X = B, or A**H * X = B, */ /* where A is a triangular band matrix of order N, and B is an */ /* N-by-NRHS matrix. A check is made to verify that A is nonsingular. */ /* 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 matrix 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 AB. 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/output) COMPLEX array, dimension (LDB,NRHS) */ /* On entry, the right hand side matrix B. */ /* On exit, if INFO = 0, the solution matrix X. */ /* LDB (input) INTEGER */ /* The leading dimension of the array B. LDB >= max(1,N). */ /* INFO (output) INTEGER */ /* = 0: successful exit */ /* < 0: if INFO = -i, the i-th argument had an illegal value */ /* > 0: if INFO = i, the i-th diagonal element of A is zero, */ /* indicating that the matrix is singular and the */ /* solutions X have not been computed. */ /* ===================================================================== */ /* .. Parameters .. */ /* .. */ /* .. Local Scalars .. */ /* .. */ /* .. External Functions .. */ /* .. */ /* .. External Subroutines .. */ /* .. */ /* .. Intrinsic Functions .. */ /* .. */ /* .. Executable Statements .. */ /* Test the input parameters. */ /* Parameter adjustments */ ab_dim1 = *ldab; ab_offset = 1 + ab_dim1; ab -= ab_offset; b_dim1 = *ldb; b_offset = 1 + b_dim1; b -= b_offset; /* Function Body */ *info = 0; nounit = lsame_(diag, "N"); upper = lsame_(uplo, "U"); if (! upper && ! lsame_(uplo, "L")) { *info = -1; } else if (! lsame_(trans, "N") && ! 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; } if (*info != 0) { i__1 = -(*info); xerbla_("CTBTRS", &i__1); return 0; } /* Quick return if possible */ if (*n == 0) { return 0; } /* Check for singularity. */ if (nounit) { if (upper) { i__1 = *n; for (*info = 1; *info <= i__1; ++(*info)) { i__2 = *kd + 1 + *info * ab_dim1; if (ab[i__2].r == 0.f && ab[i__2].i == 0.f) { return 0; } /* L10: */ } } else { i__1 = *n; for (*info = 1; *info <= i__1; ++(*info)) { i__2 = *info * ab_dim1 + 1; if (ab[i__2].r == 0.f && ab[i__2].i == 0.f) { return 0; } /* L20: */ } } } *info = 0; /* Solve A * X = B, A**T * X = B, or A**H * X = B. */ i__1 = *nrhs; for (j = 1; j <= i__1; ++j) { ctbsv_(uplo, trans, diag, n, kd, &ab[ab_offset], ldab, &b[j * b_dim1 + 1], &c__1); /* L30: */ } return 0; /* End of CTBTRS */ } /* ctbtrs_ */
/* Subroutine */ int cgbtrs_(char *trans, integer *n, integer *kl, integer * ku, integer *nrhs, complex *ab, integer *ldab, integer *ipiv, complex *b, integer *ldb, integer *info) { /* System generated locals */ integer ab_dim1, ab_offset, b_dim1, b_offset, i__1, i__2, i__3; complex q__1; /* Local variables */ integer i__, j, l, kd, lm; logical lnoti; logical notran; /* -- LAPACK routine (version 3.2) -- */ /* November 2006 */ /* Purpose */ /* ======= */ /* CGBTRS solves a system of linear equations */ /* A * X = B, A**T * X = B, or A**H * X = B */ /* with a general band matrix A using the LU factorization computed */ /* by CGBTRF. */ /* Arguments */ /* ========= */ /* 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) */ /* N (input) INTEGER */ /* The order of the matrix A. N >= 0. */ /* KL (input) INTEGER */ /* The number of subdiagonals within the band of A. KL >= 0. */ /* KU (input) INTEGER */ /* The number of superdiagonals within the band of A. KU >= 0. */ /* NRHS (input) INTEGER */ /* The number of right hand sides, i.e., the number of columns */ /* of the matrix B. NRHS >= 0. */ /* AB (input) COMPLEX array, dimension (LDAB,N) */ /* Details of the LU factorization of the band matrix A, as */ /* computed by CGBTRF. U is stored as an upper triangular band */ /* matrix with KL+KU superdiagonals in rows 1 to KL+KU+1, and */ /* the multipliers used during the factorization are stored in */ /* rows KL+KU+2 to 2*KL+KU+1. */ /* LDAB (input) INTEGER */ /* The leading dimension of the array AB. LDAB >= 2*KL+KU+1. */ /* IPIV (input) INTEGER array, dimension (N) */ /* The pivot indices; for 1 <= i <= N, row i of the matrix was */ /* interchanged with row IPIV(i). */ /* B (input/output) COMPLEX array, dimension (LDB,NRHS) */ /* On entry, the right hand side matrix B. */ /* On exit, the solution matrix X. */ /* LDB (input) INTEGER */ /* The leading dimension of the array B. LDB >= max(1,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 */ ab_dim1 = *ldab; ab_offset = 1 + ab_dim1; ab -= ab_offset; --ipiv; b_dim1 = *ldb; b_offset = 1 + b_dim1; b -= b_offset; /* Function Body */ *info = 0; notran = lsame_(trans, "N"); if (! notran && ! lsame_(trans, "T") && ! lsame_( trans, "C")) { *info = -1; } else if (*n < 0) { *info = -2; } else if (*kl < 0) { *info = -3; } else if (*ku < 0) { *info = -4; } else if (*nrhs < 0) { *info = -5; } else if (*ldab < (*kl << 1) + *ku + 1) { *info = -7; } else if (*ldb < max(1,*n)) { *info = -10; } if (*info != 0) { i__1 = -(*info); xerbla_("CGBTRS", &i__1); return 0; } /* Quick return if possible */ if (*n == 0 || *nrhs == 0) { return 0; } kd = *ku + *kl + 1; lnoti = *kl > 0; if (notran) { /* Solve A*X = B. */ /* Solve L*X = B, overwriting B with X. */ /* L is represented as a product of permutations and unit lower */ /* where each transformation L(i) is a rank-one modification of */ /* the identity matrix. */ if (lnoti) { i__1 = *n - 1; for (j = 1; j <= i__1; ++j) { /* Computing MIN */ i__2 = *kl, i__3 = *n - j; lm = min(i__2,i__3); l = ipiv[j]; if (l != j) { cswap_(nrhs, &b[l + b_dim1], ldb, &b[j + b_dim1], ldb); } q__1.r = -1.f, q__1.i = -0.f; cgeru_(&lm, nrhs, &q__1, &ab[kd + 1 + j * ab_dim1], &c__1, &b[ j + b_dim1], ldb, &b[j + 1 + b_dim1], ldb); } } i__1 = *nrhs; for (i__ = 1; i__ <= i__1; ++i__) { /* Solve U*X = B, overwriting B with X. */ i__2 = *kl + *ku; ctbsv_("Upper", "No transpose", "Non-unit", n, &i__2, &ab[ ab_offset], ldab, &b[i__ * b_dim1 + 1], &c__1); } } else if (lsame_(trans, "T")) { /* Solve A**T * X = B. */ i__1 = *nrhs; for (i__ = 1; i__ <= i__1; ++i__) { /* Solve U**T * X = B, overwriting B with X. */ i__2 = *kl + *ku; ctbsv_("Upper", "Transpose", "Non-unit", n, &i__2, &ab[ab_offset], ldab, &b[i__ * b_dim1 + 1], &c__1); } /* Solve L**T * X = B, overwriting B with X. */ if (lnoti) { for (j = *n - 1; j >= 1; --j) { /* Computing MIN */ i__1 = *kl, i__2 = *n - j; lm = min(i__1,i__2); q__1.r = -1.f, q__1.i = -0.f; cgemv_("Transpose", &lm, nrhs, &q__1, &b[j + 1 + b_dim1], ldb, &ab[kd + 1 + j * ab_dim1], &c__1, &c_b1, &b[j + b_dim1], ldb); l = ipiv[j]; if (l != j) { cswap_(nrhs, &b[l + b_dim1], ldb, &b[j + b_dim1], ldb); } } } } else { /* Solve A**H * X = B. */ i__1 = *nrhs; for (i__ = 1; i__ <= i__1; ++i__) { /* Solve U**H * X = B, overwriting B with X. */ i__2 = *kl + *ku; ctbsv_("Upper", "Conjugate transpose", "Non-unit", n, &i__2, &ab[ ab_offset], ldab, &b[i__ * b_dim1 + 1], &c__1); } /* Solve L**H * X = B, overwriting B with X. */ if (lnoti) { for (j = *n - 1; j >= 1; --j) { /* Computing MIN */ i__1 = *kl, i__2 = *n - j; lm = min(i__1,i__2); clacgv_(nrhs, &b[j + b_dim1], ldb); q__1.r = -1.f, q__1.i = -0.f; cgemv_("Conjugate transpose", &lm, nrhs, &q__1, &b[j + 1 + b_dim1], ldb, &ab[kd + 1 + j * ab_dim1], &c__1, &c_b1, &b[j + b_dim1], ldb); clacgv_(nrhs, &b[j + b_dim1], ldb); l = ipiv[j]; if (l != j) { cswap_(nrhs, &b[l + b_dim1], ldb, &b[j + b_dim1], ldb); } } } } return 0; /* End of CGBTRS */ } /* cgbtrs_ */
/* Subroutine */ int clatbs_(char *uplo, char *trans, char *diag, char * normin, integer *n, integer *kd, complex *ab, integer *ldab, complex * x, real *scale, real *cnorm, integer *info) { /* System generated locals */ integer ab_dim1, ab_offset, i__1, i__2, i__3, i__4, i__5; real r__1, r__2, r__3, r__4; complex q__1, q__2, q__3, q__4; /* Builtin functions */ double r_imag(complex *); void r_cnjg(complex *, complex *); /* Local variables */ integer i__, j; real xj, rec, tjj; integer jinc, jlen; real xbnd; integer imax; real tmax; complex tjjs; real xmax, grow; integer maind; extern /* Complex */ VOID cdotc_(complex *, integer *, complex *, integer *, complex *, integer *); extern logical lsame_(char *, char *); extern /* Subroutine */ int sscal_(integer *, real *, real *, integer *); real tscal; complex uscal; integer jlast; extern /* Complex */ VOID cdotu_(complex *, integer *, complex *, integer *, complex *, integer *); complex csumj; extern /* Subroutine */ int ctbsv_(char *, char *, char *, integer *, integer *, complex *, integer *, complex *, integer *), caxpy_(integer *, complex *, complex *, integer * , complex *, integer *); logical upper; extern /* Subroutine */ int slabad_(real *, real *); extern integer icamax_(integer *, complex *, integer *); extern /* Complex */ VOID cladiv_(complex *, complex *, complex *); extern doublereal slamch_(char *); extern /* Subroutine */ int csscal_(integer *, real *, complex *, integer *), xerbla_(char *, integer *); real bignum; extern integer isamax_(integer *, real *, integer *); extern doublereal scasum_(integer *, complex *, integer *); logical notran; integer jfirst; real smlnum; logical nounit; /* -- LAPACK auxiliary routine (version 3.2) -- */ /* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ /* November 2006 */ /* .. Scalar Arguments .. */ /* .. */ /* .. Array Arguments .. */ /* .. */ /* Purpose */ /* ======= */ /* CLATBS solves one of the triangular systems */ /* A * x = s*b, A**T * x = s*b, or A**H * x = s*b, */ /* with scaling to prevent overflow, where A is an upper or lower */ /* triangular band matrix. Here A' denotes the transpose of A, x and b */ /* are n-element vectors, and s is a scaling factor, usually less than */ /* or equal to 1, chosen so that the components of x will be less than */ /* the overflow threshold. If the unscaled problem will not cause */ /* overflow, the Level 2 BLAS routine CTBSV is called. If the matrix A */ /* is singular (A(j,j) = 0 for some j), then s is set to 0 and a */ /* non-trivial solution to A*x = 0 is returned. */ /* 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': Solve A * x = s*b (No transpose) */ /* = 'T': Solve A**T * x = s*b (Transpose) */ /* = 'C': Solve 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 */ /* NORMIN (input) CHARACTER*1 */ /* Specifies whether CNORM has been set or not. */ /* = 'Y': CNORM contains the column norms on entry */ /* = 'N': CNORM is not set on entry. On exit, the norms will */ /* be computed and stored in CNORM. */ /* N (input) INTEGER */ /* The order of the matrix A. N >= 0. */ /* KD (input) INTEGER */ /* The number of subdiagonals or superdiagonals in the */ /* triangular matrix A. KD >= 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. */ /* X (input/output) COMPLEX array, dimension (N) */ /* On entry, the right hand side b of the triangular system. */ /* On exit, X is overwritten by the solution vector x. */ /* SCALE (output) REAL */ /* The scaling factor s for the triangular system */ /* A * x = s*b, A**T * x = s*b, or A**H * x = s*b. */ /* If SCALE = 0, the matrix A is singular or badly scaled, and */ /* the vector x is an exact or approximate solution to A*x = 0. */ /* CNORM (input or output) REAL array, dimension (N) */ /* If NORMIN = 'Y', CNORM is an input argument and CNORM(j) */ /* contains the norm of the off-diagonal part of the j-th column */ /* of A. If TRANS = 'N', CNORM(j) must be greater than or equal */ /* to the infinity-norm, and if TRANS = 'T' or 'C', CNORM(j) */ /* must be greater than or equal to the 1-norm. */ /* If NORMIN = 'N', CNORM is an output argument and CNORM(j) */ /* returns the 1-norm of the offdiagonal part of the j-th column */ /* of A. */ /* INFO (output) INTEGER */ /* = 0: successful exit */ /* < 0: if INFO = -k, the k-th argument had an illegal value */ /* Further Details */ /* ======= ======= */ /* A rough bound on x is computed; if that is less than overflow, CTBSV */ /* is called, otherwise, specific code is used which checks for possible */ /* overflow or divide-by-zero at every operation. */ /* A columnwise scheme is used for solving A*x = b. The basic algorithm */ /* if A is lower triangular is */ /* x[1:n] := b[1:n] */ /* for j = 1, ..., n */ /* x(j) := x(j) / A(j,j) */ /* x[j+1:n] := x[j+1:n] - x(j) * A[j+1:n,j] */ /* end */ /* Define bounds on the components of x after j iterations of the loop: */ /* M(j) = bound on x[1:j] */ /* G(j) = bound on x[j+1:n] */ /* Initially, let M(0) = 0 and G(0) = max{x(i), i=1,...,n}. */ /* Then for iteration j+1 we have */ /* M(j+1) <= G(j) / | A(j+1,j+1) | */ /* G(j+1) <= G(j) + M(j+1) * | A[j+2:n,j+1] | */ /* <= G(j) ( 1 + CNORM(j+1) / | A(j+1,j+1) | ) */ /* where CNORM(j+1) is greater than or equal to the infinity-norm of */ /* column j+1 of A, not counting the diagonal. Hence */ /* G(j) <= G(0) product ( 1 + CNORM(i) / | A(i,i) | ) */ /* 1<=i<=j */ /* and */ /* |x(j)| <= ( G(0) / |A(j,j)| ) product ( 1 + CNORM(i) / |A(i,i)| ) */ /* 1<=i< j */ /* Since |x(j)| <= M(j), we use the Level 2 BLAS routine CTBSV if the */ /* reciprocal of the largest M(j), j=1,..,n, is larger than */ /* max(underflow, 1/overflow). */ /* The bound on x(j) is also used to determine when a step in the */ /* columnwise method can be performed without fear of overflow. If */ /* the computed bound is greater than a large constant, x is scaled to */ /* prevent overflow, but if the bound overflows, x is set to 0, x(j) to */ /* 1, and scale to 0, and a non-trivial solution to A*x = 0 is found. */ /* Similarly, a row-wise scheme is used to solve A**T *x = b or */ /* A**H *x = b. The basic algorithm for A upper triangular is */ /* for j = 1, ..., n */ /* x(j) := ( b(j) - A[1:j-1,j]' * x[1:j-1] ) / A(j,j) */ /* end */ /* We simultaneously compute two bounds */ /* G(j) = bound on ( b(i) - A[1:i-1,i]' * x[1:i-1] ), 1<=i<=j */ /* M(j) = bound on x(i), 1<=i<=j */ /* The initial values are G(0) = 0, M(0) = max{b(i), i=1,..,n}, and we */ /* add the constraint G(j) >= G(j-1) and M(j) >= M(j-1) for j >= 1. */ /* Then the bound on x(j) is */ /* M(j) <= M(j-1) * ( 1 + CNORM(j) ) / | A(j,j) | */ /* <= M(0) * product ( ( 1 + CNORM(i) ) / |A(i,i)| ) */ /* 1<=i<=j */ /* and we can safely call CTBSV if 1/M(n) and 1/G(n) are both greater */ /* than max(underflow, 1/overflow). */ /* ===================================================================== */ /* .. Parameters .. */ /* .. */ /* .. Local Scalars .. */ /* .. */ /* .. External Functions .. */ /* .. */ /* .. External Subroutines .. */ /* .. */ /* .. Intrinsic Functions .. */ /* .. */ /* .. Statement Functions .. */ /* .. */ /* .. Statement Function definitions .. */ /* .. */ /* .. Executable Statements .. */ /* Parameter adjustments */ ab_dim1 = *ldab; ab_offset = 1 + ab_dim1; ab -= ab_offset; --x; --cnorm; /* Function Body */ *info = 0; upper = lsame_(uplo, "U"); notran = lsame_(trans, "N"); nounit = lsame_(diag, "N"); /* Test the input parameters. */ 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 (! lsame_(normin, "Y") && ! lsame_(normin, "N")) { *info = -4; } else if (*n < 0) { *info = -5; } else if (*kd < 0) { *info = -6; } else if (*ldab < *kd + 1) { *info = -8; } if (*info != 0) { i__1 = -(*info); xerbla_("CLATBS", &i__1); return 0; } /* Quick return if possible */ if (*n == 0) { return 0; } /* Determine machine dependent parameters to control overflow. */ smlnum = slamch_("Safe minimum"); bignum = 1.f / smlnum; slabad_(&smlnum, &bignum); smlnum /= slamch_("Precision"); bignum = 1.f / smlnum; *scale = 1.f; if (lsame_(normin, "N")) { /* Compute the 1-norm of each column, not including the diagonal. */ if (upper) { /* A is upper triangular. */ i__1 = *n; for (j = 1; j <= i__1; ++j) { /* Computing MIN */ i__2 = *kd, i__3 = j - 1; jlen = min(i__2,i__3); cnorm[j] = scasum_(&jlen, &ab[*kd + 1 - jlen + j * ab_dim1], & c__1); /* L10: */ } } else { /* A is lower triangular. */ i__1 = *n; for (j = 1; j <= i__1; ++j) { /* Computing MIN */ i__2 = *kd, i__3 = *n - j; jlen = min(i__2,i__3); if (jlen > 0) { cnorm[j] = scasum_(&jlen, &ab[j * ab_dim1 + 2], &c__1); } else { cnorm[j] = 0.f; } /* L20: */ } } } /* Scale the column norms by TSCAL if the maximum element in CNORM is */ /* greater than BIGNUM/2. */ imax = isamax_(n, &cnorm[1], &c__1); tmax = cnorm[imax]; if (tmax <= bignum * .5f) { tscal = 1.f; } else { tscal = .5f / (smlnum * tmax); sscal_(n, &tscal, &cnorm[1], &c__1); } /* Compute a bound on the computed solution vector to see if the */ /* Level 2 BLAS routine CTBSV can be used. */ xmax = 0.f; i__1 = *n; for (j = 1; j <= i__1; ++j) { /* Computing MAX */ i__2 = j; r__3 = xmax, r__4 = (r__1 = x[i__2].r / 2.f, dabs(r__1)) + (r__2 = r_imag(&x[j]) / 2.f, dabs(r__2)); xmax = dmax(r__3,r__4); /* L30: */ } xbnd = xmax; if (notran) { /* Compute the growth in A * x = b. */ if (upper) { jfirst = *n; jlast = 1; jinc = -1; maind = *kd + 1; } else { jfirst = 1; jlast = *n; jinc = 1; maind = 1; } if (tscal != 1.f) { grow = 0.f; goto L60; } if (nounit) { /* A is non-unit triangular. */ /* Compute GROW = 1/G(j) and XBND = 1/M(j). */ /* Initially, G(0) = max{x(i), i=1,...,n}. */ grow = .5f / dmax(xbnd,smlnum); xbnd = grow; i__1 = jlast; i__2 = jinc; for (j = jfirst; i__2 < 0 ? j >= i__1 : j <= i__1; j += i__2) { /* Exit the loop if the growth factor is too small. */ if (grow <= smlnum) { goto L60; } i__3 = maind + j * ab_dim1; tjjs.r = ab[i__3].r, tjjs.i = ab[i__3].i; tjj = (r__1 = tjjs.r, dabs(r__1)) + (r__2 = r_imag(&tjjs), dabs(r__2)); if (tjj >= smlnum) { /* M(j) = G(j-1) / abs(A(j,j)) */ /* Computing MIN */ r__1 = xbnd, r__2 = dmin(1.f,tjj) * grow; xbnd = dmin(r__1,r__2); } else { /* M(j) could overflow, set XBND to 0. */ xbnd = 0.f; } if (tjj + cnorm[j] >= smlnum) { /* G(j) = G(j-1)*( 1 + CNORM(j) / abs(A(j,j)) ) */ grow *= tjj / (tjj + cnorm[j]); } else { /* G(j) could overflow, set GROW to 0. */ grow = 0.f; } /* L40: */ } grow = xbnd; } else { /* A is unit triangular. */ /* Compute GROW = 1/G(j), where G(0) = max{x(i), i=1,...,n}. */ /* Computing MIN */ r__1 = 1.f, r__2 = .5f / dmax(xbnd,smlnum); grow = dmin(r__1,r__2); i__2 = jlast; i__1 = jinc; for (j = jfirst; i__1 < 0 ? j >= i__2 : j <= i__2; j += i__1) { /* Exit the loop if the growth factor is too small. */ if (grow <= smlnum) { goto L60; } /* G(j) = G(j-1)*( 1 + CNORM(j) ) */ grow *= 1.f / (cnorm[j] + 1.f); /* L50: */ } } L60: ; } else { /* Compute the growth in A**T * x = b or A**H * x = b. */ if (upper) { jfirst = 1; jlast = *n; jinc = 1; maind = *kd + 1; } else { jfirst = *n; jlast = 1; jinc = -1; maind = 1; } if (tscal != 1.f) { grow = 0.f; goto L90; } if (nounit) { /* A is non-unit triangular. */ /* Compute GROW = 1/G(j) and XBND = 1/M(j). */ /* Initially, M(0) = max{x(i), i=1,...,n}. */ grow = .5f / dmax(xbnd,smlnum); xbnd = grow; i__1 = jlast; i__2 = jinc; for (j = jfirst; i__2 < 0 ? j >= i__1 : j <= i__1; j += i__2) { /* Exit the loop if the growth factor is too small. */ if (grow <= smlnum) { goto L90; } /* G(j) = max( G(j-1), M(j-1)*( 1 + CNORM(j) ) ) */ xj = cnorm[j] + 1.f; /* Computing MIN */ r__1 = grow, r__2 = xbnd / xj; grow = dmin(r__1,r__2); i__3 = maind + j * ab_dim1; tjjs.r = ab[i__3].r, tjjs.i = ab[i__3].i; tjj = (r__1 = tjjs.r, dabs(r__1)) + (r__2 = r_imag(&tjjs), dabs(r__2)); if (tjj >= smlnum) { /* M(j) = M(j-1)*( 1 + CNORM(j) ) / abs(A(j,j)) */ if (xj > tjj) { xbnd *= tjj / xj; } } else { /* M(j) could overflow, set XBND to 0. */ xbnd = 0.f; } /* L70: */ } grow = dmin(grow,xbnd); } else { /* A is unit triangular. */ /* Compute GROW = 1/G(j), where G(0) = max{x(i), i=1,...,n}. */ /* Computing MIN */ r__1 = 1.f, r__2 = .5f / dmax(xbnd,smlnum); grow = dmin(r__1,r__2); i__2 = jlast; i__1 = jinc; for (j = jfirst; i__1 < 0 ? j >= i__2 : j <= i__2; j += i__1) { /* Exit the loop if the growth factor is too small. */ if (grow <= smlnum) { goto L90; } /* G(j) = ( 1 + CNORM(j) )*G(j-1) */ xj = cnorm[j] + 1.f; grow /= xj; /* L80: */ } } L90: ; } if (grow * tscal > smlnum) { /* Use the Level 2 BLAS solve if the reciprocal of the bound on */ /* elements of X is not too small. */ ctbsv_(uplo, trans, diag, n, kd, &ab[ab_offset], ldab, &x[1], &c__1); } else { /* Use a Level 1 BLAS solve, scaling intermediate results. */ if (xmax > bignum * .5f) { /* Scale X so that its components are less than or equal to */ /* BIGNUM in absolute value. */ *scale = bignum * .5f / xmax; csscal_(n, scale, &x[1], &c__1); xmax = bignum; } else { xmax *= 2.f; } if (notran) { /* Solve A * x = b */ i__1 = jlast; i__2 = jinc; for (j = jfirst; i__2 < 0 ? j >= i__1 : j <= i__1; j += i__2) { /* Compute x(j) = b(j) / A(j,j), scaling x if necessary. */ i__3 = j; xj = (r__1 = x[i__3].r, dabs(r__1)) + (r__2 = r_imag(&x[j]), dabs(r__2)); if (nounit) { i__3 = maind + j * ab_dim1; q__1.r = tscal * ab[i__3].r, q__1.i = tscal * ab[i__3].i; tjjs.r = q__1.r, tjjs.i = q__1.i; } else { tjjs.r = tscal, tjjs.i = 0.f; if (tscal == 1.f) { goto L105; } } tjj = (r__1 = tjjs.r, dabs(r__1)) + (r__2 = r_imag(&tjjs), dabs(r__2)); if (tjj > smlnum) { /* abs(A(j,j)) > SMLNUM: */ if (tjj < 1.f) { if (xj > tjj * bignum) { /* Scale x by 1/b(j). */ rec = 1.f / xj; csscal_(n, &rec, &x[1], &c__1); *scale *= rec; xmax *= rec; } } i__3 = j; cladiv_(&q__1, &x[j], &tjjs); x[i__3].r = q__1.r, x[i__3].i = q__1.i; i__3 = j; xj = (r__1 = x[i__3].r, dabs(r__1)) + (r__2 = r_imag(&x[j] ), dabs(r__2)); } else if (tjj > 0.f) { /* 0 < abs(A(j,j)) <= SMLNUM: */ if (xj > tjj * bignum) { /* Scale x by (1/abs(x(j)))*abs(A(j,j))*BIGNUM */ /* to avoid overflow when dividing by A(j,j). */ rec = tjj * bignum / xj; if (cnorm[j] > 1.f) { /* Scale by 1/CNORM(j) to avoid overflow when */ /* multiplying x(j) times column j. */ rec /= cnorm[j]; } csscal_(n, &rec, &x[1], &c__1); *scale *= rec; xmax *= rec; } i__3 = j; cladiv_(&q__1, &x[j], &tjjs); x[i__3].r = q__1.r, x[i__3].i = q__1.i; i__3 = j; xj = (r__1 = x[i__3].r, dabs(r__1)) + (r__2 = r_imag(&x[j] ), dabs(r__2)); } else { /* A(j,j) = 0: Set x(1:n) = 0, x(j) = 1, and */ /* scale = 0, and compute a solution to A*x = 0. */ i__3 = *n; for (i__ = 1; i__ <= i__3; ++i__) { i__4 = i__; x[i__4].r = 0.f, x[i__4].i = 0.f; /* L100: */ } i__3 = j; x[i__3].r = 1.f, x[i__3].i = 0.f; xj = 1.f; *scale = 0.f; xmax = 0.f; } L105: /* Scale x if necessary to avoid overflow when adding a */ /* multiple of column j of A. */ if (xj > 1.f) { rec = 1.f / xj; if (cnorm[j] > (bignum - xmax) * rec) { /* Scale x by 1/(2*abs(x(j))). */ rec *= .5f; csscal_(n, &rec, &x[1], &c__1); *scale *= rec; } } else if (xj * cnorm[j] > bignum - xmax) { /* Scale x by 1/2. */ csscal_(n, &c_b36, &x[1], &c__1); *scale *= .5f; } if (upper) { if (j > 1) { /* Compute the update */ /* x(max(1,j-kd):j-1) := x(max(1,j-kd):j-1) - */ /* x(j)* A(max(1,j-kd):j-1,j) */ /* Computing MIN */ i__3 = *kd, i__4 = j - 1; jlen = min(i__3,i__4); i__3 = j; q__2.r = -x[i__3].r, q__2.i = -x[i__3].i; q__1.r = tscal * q__2.r, q__1.i = tscal * q__2.i; caxpy_(&jlen, &q__1, &ab[*kd + 1 - jlen + j * ab_dim1] , &c__1, &x[j - jlen], &c__1); i__3 = j - 1; i__ = icamax_(&i__3, &x[1], &c__1); i__3 = i__; xmax = (r__1 = x[i__3].r, dabs(r__1)) + (r__2 = r_imag(&x[i__]), dabs(r__2)); } } else if (j < *n) { /* Compute the update */ /* x(j+1:min(j+kd,n)) := x(j+1:min(j+kd,n)) - */ /* x(j) * A(j+1:min(j+kd,n),j) */ /* Computing MIN */ i__3 = *kd, i__4 = *n - j; jlen = min(i__3,i__4); if (jlen > 0) { i__3 = j; q__2.r = -x[i__3].r, q__2.i = -x[i__3].i; q__1.r = tscal * q__2.r, q__1.i = tscal * q__2.i; caxpy_(&jlen, &q__1, &ab[j * ab_dim1 + 2], &c__1, &x[ j + 1], &c__1); } i__3 = *n - j; i__ = j + icamax_(&i__3, &x[j + 1], &c__1); i__3 = i__; xmax = (r__1 = x[i__3].r, dabs(r__1)) + (r__2 = r_imag(&x[ i__]), dabs(r__2)); } /* L110: */ } } else if (lsame_(trans, "T")) { /* Solve A**T * x = b */ i__2 = jlast; i__1 = jinc; for (j = jfirst; i__1 < 0 ? j >= i__2 : j <= i__2; j += i__1) { /* Compute x(j) = b(j) - sum A(k,j)*x(k). */ /* k<>j */ i__3 = j; xj = (r__1 = x[i__3].r, dabs(r__1)) + (r__2 = r_imag(&x[j]), dabs(r__2)); uscal.r = tscal, uscal.i = 0.f; rec = 1.f / dmax(xmax,1.f); if (cnorm[j] > (bignum - xj) * rec) { /* If x(j) could overflow, scale x by 1/(2*XMAX). */ rec *= .5f; if (nounit) { i__3 = maind + j * ab_dim1; q__1.r = tscal * ab[i__3].r, q__1.i = tscal * ab[i__3] .i; tjjs.r = q__1.r, tjjs.i = q__1.i; } else { tjjs.r = tscal, tjjs.i = 0.f; } tjj = (r__1 = tjjs.r, dabs(r__1)) + (r__2 = r_imag(&tjjs), dabs(r__2)); if (tjj > 1.f) { /* Divide by A(j,j) when scaling x if A(j,j) > 1. */ /* Computing MIN */ r__1 = 1.f, r__2 = rec * tjj; rec = dmin(r__1,r__2); cladiv_(&q__1, &uscal, &tjjs); uscal.r = q__1.r, uscal.i = q__1.i; } if (rec < 1.f) { csscal_(n, &rec, &x[1], &c__1); *scale *= rec; xmax *= rec; } } csumj.r = 0.f, csumj.i = 0.f; if (uscal.r == 1.f && uscal.i == 0.f) { /* If the scaling needed for A in the dot product is 1, */ /* call CDOTU to perform the dot product. */ if (upper) { /* Computing MIN */ i__3 = *kd, i__4 = j - 1; jlen = min(i__3,i__4); cdotu_(&q__1, &jlen, &ab[*kd + 1 - jlen + j * ab_dim1] , &c__1, &x[j - jlen], &c__1); csumj.r = q__1.r, csumj.i = q__1.i; } else { /* Computing MIN */ i__3 = *kd, i__4 = *n - j; jlen = min(i__3,i__4); if (jlen > 1) { cdotu_(&q__1, &jlen, &ab[j * ab_dim1 + 2], &c__1, &x[j + 1], &c__1); csumj.r = q__1.r, csumj.i = q__1.i; } } } else { /* Otherwise, use in-line code for the dot product. */ if (upper) { /* Computing MIN */ i__3 = *kd, i__4 = j - 1; jlen = min(i__3,i__4); i__3 = jlen; for (i__ = 1; i__ <= i__3; ++i__) { i__4 = *kd + i__ - jlen + j * ab_dim1; q__3.r = ab[i__4].r * uscal.r - ab[i__4].i * uscal.i, q__3.i = ab[i__4].r * uscal.i + ab[i__4].i * uscal.r; i__5 = j - jlen - 1 + i__; q__2.r = q__3.r * x[i__5].r - q__3.i * x[i__5].i, q__2.i = q__3.r * x[i__5].i + q__3.i * x[ i__5].r; q__1.r = csumj.r + q__2.r, q__1.i = csumj.i + q__2.i; csumj.r = q__1.r, csumj.i = q__1.i; /* L120: */ } } else { /* Computing MIN */ i__3 = *kd, i__4 = *n - j; jlen = min(i__3,i__4); i__3 = jlen; for (i__ = 1; i__ <= i__3; ++i__) { i__4 = i__ + 1 + j * ab_dim1; q__3.r = ab[i__4].r * uscal.r - ab[i__4].i * uscal.i, q__3.i = ab[i__4].r * uscal.i + ab[i__4].i * uscal.r; i__5 = j + i__; q__2.r = q__3.r * x[i__5].r - q__3.i * x[i__5].i, q__2.i = q__3.r * x[i__5].i + q__3.i * x[ i__5].r; q__1.r = csumj.r + q__2.r, q__1.i = csumj.i + q__2.i; csumj.r = q__1.r, csumj.i = q__1.i; /* L130: */ } } } q__1.r = tscal, q__1.i = 0.f; if (uscal.r == q__1.r && uscal.i == q__1.i) { /* Compute x(j) := ( x(j) - CSUMJ ) / A(j,j) if 1/A(j,j) */ /* was not used to scale the dotproduct. */ i__3 = j; i__4 = j; q__1.r = x[i__4].r - csumj.r, q__1.i = x[i__4].i - csumj.i; x[i__3].r = q__1.r, x[i__3].i = q__1.i; i__3 = j; xj = (r__1 = x[i__3].r, dabs(r__1)) + (r__2 = r_imag(&x[j] ), dabs(r__2)); if (nounit) { /* Compute x(j) = x(j) / A(j,j), scaling if necessary. */ i__3 = maind + j * ab_dim1; q__1.r = tscal * ab[i__3].r, q__1.i = tscal * ab[i__3] .i; tjjs.r = q__1.r, tjjs.i = q__1.i; } else { tjjs.r = tscal, tjjs.i = 0.f; if (tscal == 1.f) { goto L145; } } tjj = (r__1 = tjjs.r, dabs(r__1)) + (r__2 = r_imag(&tjjs), dabs(r__2)); if (tjj > smlnum) { /* abs(A(j,j)) > SMLNUM: */ if (tjj < 1.f) { if (xj > tjj * bignum) { /* Scale X by 1/abs(x(j)). */ rec = 1.f / xj; csscal_(n, &rec, &x[1], &c__1); *scale *= rec; xmax *= rec; } } i__3 = j; cladiv_(&q__1, &x[j], &tjjs); x[i__3].r = q__1.r, x[i__3].i = q__1.i; } else if (tjj > 0.f) { /* 0 < abs(A(j,j)) <= SMLNUM: */ if (xj > tjj * bignum) { /* Scale x by (1/abs(x(j)))*abs(A(j,j))*BIGNUM. */ rec = tjj * bignum / xj; csscal_(n, &rec, &x[1], &c__1); *scale *= rec; xmax *= rec; } i__3 = j; cladiv_(&q__1, &x[j], &tjjs); x[i__3].r = q__1.r, x[i__3].i = q__1.i; } else { /* A(j,j) = 0: Set x(1:n) = 0, x(j) = 1, and */ /* scale = 0 and compute a solution to A**T *x = 0. */ i__3 = *n; for (i__ = 1; i__ <= i__3; ++i__) { i__4 = i__; x[i__4].r = 0.f, x[i__4].i = 0.f; /* L140: */ } i__3 = j; x[i__3].r = 1.f, x[i__3].i = 0.f; *scale = 0.f; xmax = 0.f; } L145: ; } else { /* Compute x(j) := x(j) / A(j,j) - CSUMJ if the dot */ /* product has already been divided by 1/A(j,j). */ i__3 = j; cladiv_(&q__2, &x[j], &tjjs); q__1.r = q__2.r - csumj.r, q__1.i = q__2.i - csumj.i; x[i__3].r = q__1.r, x[i__3].i = q__1.i; } /* Computing MAX */ i__3 = j; r__3 = xmax, r__4 = (r__1 = x[i__3].r, dabs(r__1)) + (r__2 = r_imag(&x[j]), dabs(r__2)); xmax = dmax(r__3,r__4); /* L150: */ } } else { /* Solve A**H * x = b */ i__1 = jlast; i__2 = jinc; for (j = jfirst; i__2 < 0 ? j >= i__1 : j <= i__1; j += i__2) { /* Compute x(j) = b(j) - sum A(k,j)*x(k). */ /* k<>j */ i__3 = j; xj = (r__1 = x[i__3].r, dabs(r__1)) + (r__2 = r_imag(&x[j]), dabs(r__2)); uscal.r = tscal, uscal.i = 0.f; rec = 1.f / dmax(xmax,1.f); if (cnorm[j] > (bignum - xj) * rec) { /* If x(j) could overflow, scale x by 1/(2*XMAX). */ rec *= .5f; if (nounit) { r_cnjg(&q__2, &ab[maind + j * ab_dim1]); q__1.r = tscal * q__2.r, q__1.i = tscal * q__2.i; tjjs.r = q__1.r, tjjs.i = q__1.i; } else { tjjs.r = tscal, tjjs.i = 0.f; } tjj = (r__1 = tjjs.r, dabs(r__1)) + (r__2 = r_imag(&tjjs), dabs(r__2)); if (tjj > 1.f) { /* Divide by A(j,j) when scaling x if A(j,j) > 1. */ /* Computing MIN */ r__1 = 1.f, r__2 = rec * tjj; rec = dmin(r__1,r__2); cladiv_(&q__1, &uscal, &tjjs); uscal.r = q__1.r, uscal.i = q__1.i; } if (rec < 1.f) { csscal_(n, &rec, &x[1], &c__1); *scale *= rec; xmax *= rec; } } csumj.r = 0.f, csumj.i = 0.f; if (uscal.r == 1.f && uscal.i == 0.f) { /* If the scaling needed for A in the dot product is 1, */ /* call CDOTC to perform the dot product. */ if (upper) { /* Computing MIN */ i__3 = *kd, i__4 = j - 1; jlen = min(i__3,i__4); cdotc_(&q__1, &jlen, &ab[*kd + 1 - jlen + j * ab_dim1] , &c__1, &x[j - jlen], &c__1); csumj.r = q__1.r, csumj.i = q__1.i; } else { /* Computing MIN */ i__3 = *kd, i__4 = *n - j; jlen = min(i__3,i__4); if (jlen > 1) { cdotc_(&q__1, &jlen, &ab[j * ab_dim1 + 2], &c__1, &x[j + 1], &c__1); csumj.r = q__1.r, csumj.i = q__1.i; } } } else { /* Otherwise, use in-line code for the dot product. */ if (upper) { /* Computing MIN */ i__3 = *kd, i__4 = j - 1; jlen = min(i__3,i__4); i__3 = jlen; for (i__ = 1; i__ <= i__3; ++i__) { r_cnjg(&q__4, &ab[*kd + i__ - jlen + j * ab_dim1]) ; q__3.r = q__4.r * uscal.r - q__4.i * uscal.i, q__3.i = q__4.r * uscal.i + q__4.i * uscal.r; i__4 = j - jlen - 1 + i__; q__2.r = q__3.r * x[i__4].r - q__3.i * x[i__4].i, q__2.i = q__3.r * x[i__4].i + q__3.i * x[ i__4].r; q__1.r = csumj.r + q__2.r, q__1.i = csumj.i + q__2.i; csumj.r = q__1.r, csumj.i = q__1.i; /* L160: */ } } else { /* Computing MIN */ i__3 = *kd, i__4 = *n - j; jlen = min(i__3,i__4); i__3 = jlen; for (i__ = 1; i__ <= i__3; ++i__) { r_cnjg(&q__4, &ab[i__ + 1 + j * ab_dim1]); q__3.r = q__4.r * uscal.r - q__4.i * uscal.i, q__3.i = q__4.r * uscal.i + q__4.i * uscal.r; i__4 = j + i__; q__2.r = q__3.r * x[i__4].r - q__3.i * x[i__4].i, q__2.i = q__3.r * x[i__4].i + q__3.i * x[ i__4].r; q__1.r = csumj.r + q__2.r, q__1.i = csumj.i + q__2.i; csumj.r = q__1.r, csumj.i = q__1.i; /* L170: */ } } } q__1.r = tscal, q__1.i = 0.f; if (uscal.r == q__1.r && uscal.i == q__1.i) { /* Compute x(j) := ( x(j) - CSUMJ ) / A(j,j) if 1/A(j,j) */ /* was not used to scale the dotproduct. */ i__3 = j; i__4 = j; q__1.r = x[i__4].r - csumj.r, q__1.i = x[i__4].i - csumj.i; x[i__3].r = q__1.r, x[i__3].i = q__1.i; i__3 = j; xj = (r__1 = x[i__3].r, dabs(r__1)) + (r__2 = r_imag(&x[j] ), dabs(r__2)); if (nounit) { /* Compute x(j) = x(j) / A(j,j), scaling if necessary. */ r_cnjg(&q__2, &ab[maind + j * ab_dim1]); q__1.r = tscal * q__2.r, q__1.i = tscal * q__2.i; tjjs.r = q__1.r, tjjs.i = q__1.i; } else { tjjs.r = tscal, tjjs.i = 0.f; if (tscal == 1.f) { goto L185; } } tjj = (r__1 = tjjs.r, dabs(r__1)) + (r__2 = r_imag(&tjjs), dabs(r__2)); if (tjj > smlnum) { /* abs(A(j,j)) > SMLNUM: */ if (tjj < 1.f) { if (xj > tjj * bignum) { /* Scale X by 1/abs(x(j)). */ rec = 1.f / xj; csscal_(n, &rec, &x[1], &c__1); *scale *= rec; xmax *= rec; } } i__3 = j; cladiv_(&q__1, &x[j], &tjjs); x[i__3].r = q__1.r, x[i__3].i = q__1.i; } else if (tjj > 0.f) { /* 0 < abs(A(j,j)) <= SMLNUM: */ if (xj > tjj * bignum) { /* Scale x by (1/abs(x(j)))*abs(A(j,j))*BIGNUM. */ rec = tjj * bignum / xj; csscal_(n, &rec, &x[1], &c__1); *scale *= rec; xmax *= rec; } i__3 = j; cladiv_(&q__1, &x[j], &tjjs); x[i__3].r = q__1.r, x[i__3].i = q__1.i; } else { /* A(j,j) = 0: Set x(1:n) = 0, x(j) = 1, and */ /* scale = 0 and compute a solution to A**H *x = 0. */ i__3 = *n; for (i__ = 1; i__ <= i__3; ++i__) { i__4 = i__; x[i__4].r = 0.f, x[i__4].i = 0.f; /* L180: */ } i__3 = j; x[i__3].r = 1.f, x[i__3].i = 0.f; *scale = 0.f; xmax = 0.f; } L185: ; } else { /* Compute x(j) := x(j) / A(j,j) - CSUMJ if the dot */ /* product has already been divided by 1/A(j,j). */ i__3 = j; cladiv_(&q__2, &x[j], &tjjs); q__1.r = q__2.r - csumj.r, q__1.i = q__2.i - csumj.i; x[i__3].r = q__1.r, x[i__3].i = q__1.i; } /* Computing MAX */ i__3 = j; r__3 = xmax, r__4 = (r__1 = x[i__3].r, dabs(r__1)) + (r__2 = r_imag(&x[j]), dabs(r__2)); xmax = dmax(r__3,r__4); /* L190: */ } } *scale /= tscal; } /* Scale the column norms by 1/TSCAL for return. */ if (tscal != 1.f) { r__1 = 1.f / tscal; sscal_(n, &r__1, &cnorm[1], &c__1); } return 0; /* End of CLATBS */ } /* clatbs_ */
/* Subroutine */ int cchktb_(logical *dotype, integer *nn, integer *nval, integer *nns, integer *nsval, real *thresh, logical *tsterr, integer * nmax, complex *ab, complex *ainv, complex *b, complex *x, complex * xact, complex *work, real *rwork, integer *nout) { /* Initialized data */ static integer iseedy[4] = { 1988,1989,1990,1991 }; static char uplos[1*2] = "U" "L"; static char transs[1*3] = "N" "T" "C"; /* Format strings */ static char fmt_9999[] = "(\002 UPLO='\002,a1,\002', TRANS='\002,a1,\002" "', DIAG='\002,a1,\002', N=\002,i5,\002, K" "D=\002,i5,\002, NRHS=\002,i5,\002, type \002,i2,\002, test(\002," "i2,\002)=\002,g12.5)"; static char fmt_9998[] = "(1x,a,\002( '\002,a1,\002', '\002,a1,\002', " "'\002,a1,\002',\002,i5,\002,\002,i5,\002, ... ), type \002,i2" ",\002, test(\002,i2,\002)=\002,g12.5)"; static char fmt_9997[] = "(1x,a,\002( '\002,a1,\002', '\002,a1,\002', " "'\002,a1,\002', '\002,a1,\002',\002,i5,\002,\002,i5,\002, ... )" ", type \002,i2,\002, test(\002,i1,\002)=\002,g12.5)"; /* System generated locals */ address a__1[3], a__2[4]; integer i__1, i__2, i__3, i__4, i__5, i__6[3], i__7[4]; char ch__1[3], ch__2[4]; /* Builtin functions */ /* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen), s_cat(char *, char **, integer *, integer *, ftnlen); integer s_wsfe(cilist *), do_fio(integer *, char *, ftnlen), e_wsfe(void); /* Local variables */ integer i__, j, k, n, kd, ik, in, nk, lda, ldab; char diag[1]; integer imat, info; char path[3]; integer irhs, nrhs; char norm[1], uplo[1]; integer nrun; extern /* Subroutine */ int alahd_(integer *, char *); integer idiag; extern /* Subroutine */ int cget04_(integer *, integer *, complex *, integer *, complex *, integer *, real *, real *); real scale; integer nfail, iseed[4]; extern /* Subroutine */ int ctbt02_(char *, char *, char *, integer *, integer *, integer *, complex *, integer *, complex *, integer *, complex *, integer *, complex *, real *, real *), ctbt03_(char *, char *, char *, integer *, integer *, integer *, complex *, integer *, real *, real *, real *, complex * , integer *, complex *, integer *, complex *, real *); extern logical lsame_(char *, char *); extern /* Subroutine */ int ctbt05_(char *, char *, char *, integer *, integer *, integer *, complex *, integer *, complex *, integer *, complex *, integer *, complex *, integer *, real *, real *, real * ), ctbt06_(real *, real *, char *, char *, integer *, integer *, complex *, integer *, real *, real *); real rcond; integer nimat; real anorm; integer itran; extern /* Subroutine */ int ccopy_(integer *, complex *, integer *, complex *, integer *), ctbsv_(char *, char *, char *, integer *, integer *, complex *, integer *, complex *, integer *); char trans[1]; integer iuplo, nerrs; char xtype[1]; integer nimat2; extern /* Subroutine */ int alaerh_(char *, char *, integer *, integer *, char *, integer *, integer *, integer *, integer *, integer *, integer *, integer *, integer *, integer *); extern doublereal clantb_(char *, char *, char *, integer *, integer *, complex *, integer *, real *); real rcondc; extern /* Subroutine */ int clatbs_(char *, char *, char *, char *, integer *, integer *, complex *, integer *, complex *, real *, real *, integer *), clattb_( integer *, char *, char *, char *, integer *, integer *, integer * , complex *, integer *, complex *, complex *, real *, integer *), clacpy_(char *, integer *, integer *, complex *, integer *, complex *, integer *), clarhs_(char *, char *, char *, char *, integer *, integer *, integer *, integer *, integer *, complex *, integer *, complex *, integer *, complex *, integer *, integer *, integer *), claset_(char *, integer *, integer *, complex *, complex *, complex *, integer *); real rcondi; extern /* Subroutine */ int ctbcon_(char *, char *, char *, integer *, integer *, complex *, integer *, real *, complex *, real *, integer *); extern doublereal clantr_(char *, char *, char *, integer *, integer *, complex *, integer *, real *); real rcondo; extern /* Subroutine */ int alasum_(char *, integer *, integer *, integer *, integer *), ctbrfs_(char *, char *, char *, integer *, integer *, integer *, complex *, integer *, complex *, integer *, complex *, integer *, real *, real *, complex *, real *, integer * ); real ainvnm; extern /* Subroutine */ int cerrtr_(char *, integer *), ctbtrs_( char *, char *, char *, integer *, integer *, integer *, complex * , integer *, complex *, integer *, integer *); real result[8]; /* Fortran I/O blocks */ static cilist io___39 = { 0, 0, 0, fmt_9999, 0 }; static cilist io___41 = { 0, 0, 0, fmt_9998, 0 }; static cilist io___43 = { 0, 0, 0, fmt_9997, 0 }; static cilist io___44 = { 0, 0, 0, fmt_9997, 0 }; /* -- LAPACK test routine (version 3.1) -- */ /* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ /* November 2006 */ /* .. Scalar Arguments .. */ /* .. */ /* .. Array Arguments .. */ /* .. */ /* Purpose */ /* ======= */ /* CCHKTB tests CTBTRS, -RFS, and -CON, and CLATBS. */ /* Arguments */ /* ========= */ /* DOTYPE (input) LOGICAL array, dimension (NTYPES) */ /* The matrix types to be used for testing. Matrices of type j */ /* (for 1 <= j <= NTYPES) are used for testing if DOTYPE(j) = */ /* .TRUE.; if DOTYPE(j) = .FALSE., then type j is not used. */ /* NN (input) INTEGER */ /* The number of values of N contained in the vector NVAL. */ /* NVAL (input) INTEGER array, dimension (NN) */ /* The values of the matrix column dimension N. */ /* NNS (input) INTEGER */ /* The number of values of NRHS contained in the vector NSVAL. */ /* NSVAL (input) INTEGER array, dimension (NNS) */ /* The values of the number of right hand sides NRHS. */ /* THRESH (input) REAL */ /* The threshold value for the test ratios. A result is */ /* included in the output file if RESULT >= THRESH. To have */ /* every test ratio printed, use THRESH = 0. */ /* TSTERR (input) LOGICAL */ /* Flag that indicates whether error exits are to be tested. */ /* NMAX (input) INTEGER */ /* The leading dimension of the work arrays. */ /* NMAX >= the maximum value of N in NVAL. */ /* AB (workspace) COMPLEX array, dimension (NMAX*NMAX) */ /* AINV (workspace) COMPLEX array, dimension (NMAX*NMAX) */ /* B (workspace) COMPLEX array, dimension (NMAX*NSMAX) */ /* where NSMAX is the largest entry in NSVAL. */ /* X (workspace) COMPLEX array, dimension (NMAX*NSMAX) */ /* XACT (workspace) COMPLEX array, dimension (NMAX*NSMAX) */ /* WORK (workspace) COMPLEX array, dimension */ /* (NMAX*max(3,NSMAX)) */ /* RWORK (workspace) REAL array, dimension */ /* (max(NMAX,2*NSMAX)) */ /* NOUT (input) INTEGER */ /* The unit number for output. */ /* ===================================================================== */ /* .. Parameters .. */ /* .. */ /* .. Local Scalars .. */ /* .. */ /* .. Local Arrays .. */ /* .. */ /* .. External Functions .. */ /* .. */ /* .. External Subroutines .. */ /* .. */ /* .. Scalars in Common .. */ /* .. */ /* .. Common blocks .. */ /* .. */ /* .. Intrinsic Functions .. */ /* .. */ /* .. Data statements .. */ /* Parameter adjustments */ --rwork; --work; --xact; --x; --b; --ainv; --ab; --nsval; --nval; --dotype; /* Function Body */ /* .. */ /* .. Executable Statements .. */ /* Initialize constants and the random number seed. */ s_copy(path, "Complex precision", (ftnlen)1, (ftnlen)17); s_copy(path + 1, "TB", (ftnlen)2, (ftnlen)2); nrun = 0; nfail = 0; nerrs = 0; for (i__ = 1; i__ <= 4; ++i__) { iseed[i__ - 1] = iseedy[i__ - 1]; /* L10: */ } /* Test the error exits */ if (*tsterr) { cerrtr_(path, nout); } infoc_1.infot = 0; i__1 = *nn; for (in = 1; in <= i__1; ++in) { /* Do for each value of N in NVAL */ n = nval[in]; lda = max(1,n); *(unsigned char *)xtype = 'N'; nimat = 9; nimat2 = 17; if (n <= 0) { nimat = 1; nimat2 = 10; } /* Computing MIN */ i__2 = n + 1; nk = min(i__2,4); i__2 = nk; for (ik = 1; ik <= i__2; ++ik) { /* Do for KD = 0, N, (3N-1)/4, and (N+1)/4. This order makes */ /* it easier to skip redundant values for small values of N. */ if (ik == 1) { kd = 0; } else if (ik == 2) { kd = max(n,0); } else if (ik == 3) { kd = (n * 3 - 1) / 4; } else if (ik == 4) { kd = (n + 1) / 4; } ldab = kd + 1; i__3 = nimat; for (imat = 1; imat <= i__3; ++imat) { /* Do the tests only if DOTYPE( IMAT ) is true. */ if (! dotype[imat]) { goto L90; } for (iuplo = 1; iuplo <= 2; ++iuplo) { /* Do first for UPLO = 'U', then for UPLO = 'L' */ *(unsigned char *)uplo = *(unsigned char *)&uplos[iuplo - 1]; /* Call CLATTB to generate a triangular test matrix. */ s_copy(srnamc_1.srnamt, "CLATTB", (ftnlen)32, (ftnlen)6); clattb_(&imat, uplo, "No transpose", diag, iseed, &n, &kd, &ab[1], &ldab, &x[1], &work[1], &rwork[1], &info); /* Set IDIAG = 1 for non-unit matrices, 2 for unit. */ if (lsame_(diag, "N")) { idiag = 1; } else { idiag = 2; } /* Form the inverse of A so we can get a good estimate */ /* of RCONDC = 1/(norm(A) * norm(inv(A))). */ claset_("Full", &n, &n, &c_b14, &c_b15, &ainv[1], &lda); if (lsame_(uplo, "U")) { i__4 = n; for (j = 1; j <= i__4; ++j) { ctbsv_(uplo, "No transpose", diag, &j, &kd, &ab[1] , &ldab, &ainv[(j - 1) * lda + 1], &c__1); /* L20: */ } } else { i__4 = n; for (j = 1; j <= i__4; ++j) { i__5 = n - j + 1; ctbsv_(uplo, "No transpose", diag, &i__5, &kd, & ab[(j - 1) * ldab + 1], &ldab, &ainv[(j - 1) * lda + j], &c__1); /* L30: */ } } /* Compute the 1-norm condition number of A. */ anorm = clantb_("1", uplo, diag, &n, &kd, &ab[1], &ldab, & rwork[1]); ainvnm = clantr_("1", uplo, diag, &n, &n, &ainv[1], &lda, &rwork[1]); if (anorm <= 0.f || ainvnm <= 0.f) { rcondo = 1.f; } else { rcondo = 1.f / anorm / ainvnm; } /* Compute the infinity-norm condition number of A. */ anorm = clantb_("I", uplo, diag, &n, &kd, &ab[1], &ldab, & rwork[1]); ainvnm = clantr_("I", uplo, diag, &n, &n, &ainv[1], &lda, &rwork[1]); if (anorm <= 0.f || ainvnm <= 0.f) { rcondi = 1.f; } else { rcondi = 1.f / anorm / ainvnm; } i__4 = *nns; for (irhs = 1; irhs <= i__4; ++irhs) { nrhs = nsval[irhs]; *(unsigned char *)xtype = 'N'; for (itran = 1; itran <= 3; ++itran) { /* Do for op(A) = A, A**T, or A**H. */ *(unsigned char *)trans = *(unsigned char *)& transs[itran - 1]; if (itran == 1) { *(unsigned char *)norm = 'O'; rcondc = rcondo; } else { *(unsigned char *)norm = 'I'; rcondc = rcondi; } /* + TEST 1 */ /* Solve and compute residual for op(A)*x = b. */ s_copy(srnamc_1.srnamt, "CLARHS", (ftnlen)32, ( ftnlen)6); clarhs_(path, xtype, uplo, trans, &n, &n, &kd, & idiag, &nrhs, &ab[1], &ldab, &xact[1], & lda, &b[1], &lda, iseed, &info); *(unsigned char *)xtype = 'C'; clacpy_("Full", &n, &nrhs, &b[1], &lda, &x[1], & lda); s_copy(srnamc_1.srnamt, "CTBTRS", (ftnlen)32, ( ftnlen)6); ctbtrs_(uplo, trans, diag, &n, &kd, &nrhs, &ab[1], &ldab, &x[1], &lda, &info); /* Check error code from CTBTRS. */ if (info != 0) { /* Writing concatenation */ i__6[0] = 1, a__1[0] = uplo; i__6[1] = 1, a__1[1] = trans; i__6[2] = 1, a__1[2] = diag; s_cat(ch__1, a__1, i__6, &c__3, (ftnlen)3); alaerh_(path, "CTBTRS", &info, &c__0, ch__1, & n, &n, &kd, &kd, &nrhs, &imat, &nfail, &nerrs, nout); } ctbt02_(uplo, trans, diag, &n, &kd, &nrhs, &ab[1], &ldab, &x[1], &lda, &b[1], &lda, &work[1] , &rwork[1], result); /* + TEST 2 */ /* Check solution from generated exact solution. */ cget04_(&n, &nrhs, &x[1], &lda, &xact[1], &lda, & rcondc, &result[1]); /* + TESTS 3, 4, and 5 */ /* Use iterative refinement to improve the solution */ /* and compute error bounds. */ s_copy(srnamc_1.srnamt, "CTBRFS", (ftnlen)32, ( ftnlen)6); ctbrfs_(uplo, trans, diag, &n, &kd, &nrhs, &ab[1], &ldab, &b[1], &lda, &x[1], &lda, &rwork[ 1], &rwork[nrhs + 1], &work[1], &rwork[( nrhs << 1) + 1], &info); /* Check error code from CTBRFS. */ if (info != 0) { /* Writing concatenation */ i__6[0] = 1, a__1[0] = uplo; i__6[1] = 1, a__1[1] = trans; i__6[2] = 1, a__1[2] = diag; s_cat(ch__1, a__1, i__6, &c__3, (ftnlen)3); alaerh_(path, "CTBRFS", &info, &c__0, ch__1, & n, &n, &kd, &kd, &nrhs, &imat, &nfail, &nerrs, nout); } cget04_(&n, &nrhs, &x[1], &lda, &xact[1], &lda, & rcondc, &result[2]); ctbt05_(uplo, trans, diag, &n, &kd, &nrhs, &ab[1], &ldab, &b[1], &lda, &x[1], &lda, &xact[1] , &lda, &rwork[1], &rwork[nrhs + 1], & result[3]); /* Print information about the tests that did not */ /* pass the threshold. */ for (k = 1; k <= 5; ++k) { if (result[k - 1] >= *thresh) { if (nfail == 0 && nerrs == 0) { alahd_(nout, path); } io___39.ciunit = *nout; s_wsfe(&io___39); do_fio(&c__1, uplo, (ftnlen)1); do_fio(&c__1, trans, (ftnlen)1); do_fio(&c__1, diag, (ftnlen)1); do_fio(&c__1, (char *)&n, (ftnlen)sizeof( integer)); do_fio(&c__1, (char *)&kd, (ftnlen)sizeof( integer)); do_fio(&c__1, (char *)&nrhs, (ftnlen) sizeof(integer)); do_fio(&c__1, (char *)&imat, (ftnlen) sizeof(integer)); do_fio(&c__1, (char *)&k, (ftnlen)sizeof( integer)); do_fio(&c__1, (char *)&result[k - 1], ( ftnlen)sizeof(real)); e_wsfe(); ++nfail; } /* L40: */ } nrun += 5; /* L50: */ } /* L60: */ } /* + TEST 6 */ /* Get an estimate of RCOND = 1/CNDNUM. */ for (itran = 1; itran <= 2; ++itran) { if (itran == 1) { *(unsigned char *)norm = 'O'; rcondc = rcondo; } else { *(unsigned char *)norm = 'I'; rcondc = rcondi; } s_copy(srnamc_1.srnamt, "CTBCON", (ftnlen)32, (ftnlen) 6); ctbcon_(norm, uplo, diag, &n, &kd, &ab[1], &ldab, & rcond, &work[1], &rwork[1], &info); /* Check error code from CTBCON. */ if (info != 0) { /* Writing concatenation */ i__6[0] = 1, a__1[0] = norm; i__6[1] = 1, a__1[1] = uplo; i__6[2] = 1, a__1[2] = diag; s_cat(ch__1, a__1, i__6, &c__3, (ftnlen)3); alaerh_(path, "CTBCON", &info, &c__0, ch__1, &n, & n, &kd, &kd, &c_n1, &imat, &nfail, &nerrs, nout); } ctbt06_(&rcond, &rcondc, uplo, diag, &n, &kd, &ab[1], &ldab, &rwork[1], &result[5]); /* Print the test ratio if it is .GE. THRESH. */ if (result[5] >= *thresh) { if (nfail == 0 && nerrs == 0) { alahd_(nout, path); } io___41.ciunit = *nout; s_wsfe(&io___41); do_fio(&c__1, "CTBCON", (ftnlen)6); do_fio(&c__1, norm, (ftnlen)1); do_fio(&c__1, uplo, (ftnlen)1); do_fio(&c__1, diag, (ftnlen)1); do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer)) ; do_fio(&c__1, (char *)&kd, (ftnlen)sizeof(integer) ); do_fio(&c__1, (char *)&imat, (ftnlen)sizeof( integer)); do_fio(&c__1, (char *)&c__6, (ftnlen)sizeof( integer)); do_fio(&c__1, (char *)&result[5], (ftnlen)sizeof( real)); e_wsfe(); ++nfail; } ++nrun; /* L70: */ } /* L80: */ } L90: ; } /* Use pathological test matrices to test CLATBS. */ i__3 = nimat2; for (imat = 10; imat <= i__3; ++imat) { /* Do the tests only if DOTYPE( IMAT ) is true. */ if (! dotype[imat]) { goto L120; } for (iuplo = 1; iuplo <= 2; ++iuplo) { /* Do first for UPLO = 'U', then for UPLO = 'L' */ *(unsigned char *)uplo = *(unsigned char *)&uplos[iuplo - 1]; for (itran = 1; itran <= 3; ++itran) { /* Do for op(A) = A, A**T, and A**H. */ *(unsigned char *)trans = *(unsigned char *)&transs[ itran - 1]; /* Call CLATTB to generate a triangular test matrix. */ s_copy(srnamc_1.srnamt, "CLATTB", (ftnlen)32, (ftnlen) 6); clattb_(&imat, uplo, trans, diag, iseed, &n, &kd, &ab[ 1], &ldab, &x[1], &work[1], &rwork[1], &info); /* + TEST 7 */ /* Solve the system op(A)*x = b */ s_copy(srnamc_1.srnamt, "CLATBS", (ftnlen)32, (ftnlen) 6); ccopy_(&n, &x[1], &c__1, &b[1], &c__1); clatbs_(uplo, trans, diag, "N", &n, &kd, &ab[1], & ldab, &b[1], &scale, &rwork[1], &info); /* Check error code from CLATBS. */ if (info != 0) { /* Writing concatenation */ i__7[0] = 1, a__2[0] = uplo; i__7[1] = 1, a__2[1] = trans; i__7[2] = 1, a__2[2] = diag; i__7[3] = 1, a__2[3] = "N"; s_cat(ch__2, a__2, i__7, &c__4, (ftnlen)4); alaerh_(path, "CLATBS", &info, &c__0, ch__2, &n, & n, &kd, &kd, &c_n1, &imat, &nfail, &nerrs, nout); } ctbt03_(uplo, trans, diag, &n, &kd, &c__1, &ab[1], & ldab, &scale, &rwork[1], &c_b90, &b[1], &lda, &x[1], &lda, &work[1], &result[6]); /* + TEST 8 */ /* Solve op(A)*x = b again with NORMIN = 'Y'. */ ccopy_(&n, &x[1], &c__1, &b[1], &c__1); clatbs_(uplo, trans, diag, "Y", &n, &kd, &ab[1], & ldab, &b[1], &scale, &rwork[1], &info); /* Check error code from CLATBS. */ if (info != 0) { /* Writing concatenation */ i__7[0] = 1, a__2[0] = uplo; i__7[1] = 1, a__2[1] = trans; i__7[2] = 1, a__2[2] = diag; i__7[3] = 1, a__2[3] = "Y"; s_cat(ch__2, a__2, i__7, &c__4, (ftnlen)4); alaerh_(path, "CLATBS", &info, &c__0, ch__2, &n, & n, &kd, &kd, &c_n1, &imat, &nfail, &nerrs, nout); } ctbt03_(uplo, trans, diag, &n, &kd, &c__1, &ab[1], & ldab, &scale, &rwork[1], &c_b90, &b[1], &lda, &x[1], &lda, &work[1], &result[7]); /* Print information about the tests that did not pass */ /* the threshold. */ if (result[6] >= *thresh) { if (nfail == 0 && nerrs == 0) { alahd_(nout, path); } io___43.ciunit = *nout; s_wsfe(&io___43); do_fio(&c__1, "CLATBS", (ftnlen)6); do_fio(&c__1, uplo, (ftnlen)1); do_fio(&c__1, trans, (ftnlen)1); do_fio(&c__1, diag, (ftnlen)1); do_fio(&c__1, "N", (ftnlen)1); do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer)) ; do_fio(&c__1, (char *)&kd, (ftnlen)sizeof(integer) ); do_fio(&c__1, (char *)&imat, (ftnlen)sizeof( integer)); do_fio(&c__1, (char *)&c__7, (ftnlen)sizeof( integer)); do_fio(&c__1, (char *)&result[6], (ftnlen)sizeof( real)); e_wsfe(); ++nfail; } if (result[7] >= *thresh) { if (nfail == 0 && nerrs == 0) { alahd_(nout, path); } io___44.ciunit = *nout; s_wsfe(&io___44); do_fio(&c__1, "CLATBS", (ftnlen)6); do_fio(&c__1, uplo, (ftnlen)1); do_fio(&c__1, trans, (ftnlen)1); do_fio(&c__1, diag, (ftnlen)1); do_fio(&c__1, "Y", (ftnlen)1); do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer)) ; do_fio(&c__1, (char *)&kd, (ftnlen)sizeof(integer) ); do_fio(&c__1, (char *)&imat, (ftnlen)sizeof( integer)); do_fio(&c__1, (char *)&c__8, (ftnlen)sizeof( integer)); do_fio(&c__1, (char *)&result[7], (ftnlen)sizeof( real)); e_wsfe(); ++nfail; } nrun += 2; /* L100: */ } /* L110: */ } L120: ; } /* L130: */ } /* L140: */ } /* Print a summary of the results. */ alasum_(path, nout, &nfail, &nrun, &nerrs); return 0; /* End of CCHKTB */ } /* cchktb_ */
/* Subroutine */ int cgbtrs_(char *trans, integer *n, integer *kl, integer * ku, integer *nrhs, complex *ab, integer *ldab, integer *ipiv, complex *b, integer *ldb, integer *info) { /* -- LAPACK routine (version 3.0) -- Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., Courant Institute, Argonne National Lab, and Rice University September 30, 1994 Purpose ======= CGBTRS solves a system of linear equations A * X = B, A**T * X = B, or A**H * X = B with a general band matrix A using the LU factorization computed by CGBTRF. Arguments ========= 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) N (input) INTEGER The order of the matrix A. N >= 0. KL (input) INTEGER The number of subdiagonals within the band of A. KL >= 0. KU (input) INTEGER The number of superdiagonals within the band of A. KU >= 0. NRHS (input) INTEGER The number of right hand sides, i.e., the number of columns of the matrix B. NRHS >= 0. AB (input) COMPLEX array, dimension (LDAB,N) Details of the LU factorization of the band matrix A, as computed by CGBTRF. U is stored as an upper triangular band matrix with KL+KU superdiagonals in rows 1 to KL+KU+1, and the multipliers used during the factorization are stored in rows KL+KU+2 to 2*KL+KU+1. LDAB (input) INTEGER The leading dimension of the array AB. LDAB >= 2*KL+KU+1. IPIV (input) INTEGER array, dimension (N) The pivot indices; for 1 <= i <= N, row i of the matrix was interchanged with row IPIV(i). B (input/output) COMPLEX array, dimension (LDB,NRHS) On entry, the right hand side matrix B. On exit, the solution matrix X. LDB (input) INTEGER The leading dimension of the array B. LDB >= max(1,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 */ /* Table of constant values */ static complex c_b1 = {1.f,0.f}; static integer c__1 = 1; /* System generated locals */ integer ab_dim1, ab_offset, b_dim1, b_offset, i__1, i__2, i__3; complex q__1; /* Local variables */ static integer i__, j, l; extern logical lsame_(char *, char *); extern /* Subroutine */ int cgemv_(char *, integer *, integer *, complex * , complex *, integer *, complex *, integer *, complex *, complex * , integer *), cgeru_(integer *, integer *, complex *, complex *, integer *, complex *, integer *, complex *, integer *), cswap_(integer *, complex *, integer *, complex *, integer *), ctbsv_(char *, char *, char *, integer *, integer *, complex *, integer *, complex *, integer *); static logical lnoti; static integer kd, lm; extern /* Subroutine */ int clacgv_(integer *, complex *, integer *), xerbla_(char *, integer *); static logical notran; #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 ab_subscr(a_1,a_2) (a_2)*ab_dim1 + a_1 #define ab_ref(a_1,a_2) ab[ab_subscr(a_1,a_2)] ab_dim1 = *ldab; ab_offset = 1 + ab_dim1 * 1; ab -= ab_offset; --ipiv; b_dim1 = *ldb; b_offset = 1 + b_dim1 * 1; b -= b_offset; /* Function Body */ *info = 0; notran = lsame_(trans, "N"); if (! notran && ! lsame_(trans, "T") && ! lsame_( trans, "C")) { *info = -1; } else if (*n < 0) { *info = -2; } else if (*kl < 0) { *info = -3; } else if (*ku < 0) { *info = -4; } else if (*nrhs < 0) { *info = -5; } else if (*ldab < (*kl << 1) + *ku + 1) { *info = -7; } else if (*ldb < max(1,*n)) { *info = -10; } if (*info != 0) { i__1 = -(*info); xerbla_("CGBTRS", &i__1); return 0; } /* Quick return if possible */ if (*n == 0 || *nrhs == 0) { return 0; } kd = *ku + *kl + 1; lnoti = *kl > 0; if (notran) { /* Solve A*X = B. Solve L*X = B, overwriting B with X. L is represented as a product of permutations and unit lower triangular matrices L = P(1) * L(1) * ... * P(n-1) * L(n-1), where each transformation L(i) is a rank-one modification of the identity matrix. */ if (lnoti) { i__1 = *n - 1; for (j = 1; j <= i__1; ++j) { /* Computing MIN */ i__2 = *kl, i__3 = *n - j; lm = min(i__2,i__3); l = ipiv[j]; if (l != j) { cswap_(nrhs, &b_ref(l, 1), ldb, &b_ref(j, 1), ldb); } q__1.r = -1.f, q__1.i = 0.f; cgeru_(&lm, nrhs, &q__1, &ab_ref(kd + 1, j), &c__1, &b_ref(j, 1), ldb, &b_ref(j + 1, 1), ldb); /* L10: */ } } i__1 = *nrhs; for (i__ = 1; i__ <= i__1; ++i__) { /* Solve U*X = B, overwriting B with X. */ i__2 = *kl + *ku; ctbsv_("Upper", "No transpose", "Non-unit", n, &i__2, &ab[ ab_offset], ldab, &b_ref(1, i__), &c__1); /* L20: */ } } else if (lsame_(trans, "T")) { /* Solve A**T * X = B. */ i__1 = *nrhs; for (i__ = 1; i__ <= i__1; ++i__) { /* Solve U**T * X = B, overwriting B with X. */ i__2 = *kl + *ku; ctbsv_("Upper", "Transpose", "Non-unit", n, &i__2, &ab[ab_offset], ldab, &b_ref(1, i__), &c__1); /* L30: */ } /* Solve L**T * X = B, overwriting B with X. */ if (lnoti) { for (j = *n - 1; j >= 1; --j) { /* Computing MIN */ i__1 = *kl, i__2 = *n - j; lm = min(i__1,i__2); q__1.r = -1.f, q__1.i = 0.f; cgemv_("Transpose", &lm, nrhs, &q__1, &b_ref(j + 1, 1), ldb, & ab_ref(kd + 1, j), &c__1, &c_b1, &b_ref(j, 1), ldb); l = ipiv[j]; if (l != j) { cswap_(nrhs, &b_ref(l, 1), ldb, &b_ref(j, 1), ldb); } /* L40: */ } } } else { /* Solve A**H * X = B. */ i__1 = *nrhs; for (i__ = 1; i__ <= i__1; ++i__) { /* Solve U**H * X = B, overwriting B with X. */ i__2 = *kl + *ku; ctbsv_("Upper", "Conjugate transpose", "Non-unit", n, &i__2, &ab[ ab_offset], ldab, &b_ref(1, i__), &c__1); /* L50: */ } /* Solve L**H * X = B, overwriting B with X. */ if (lnoti) { for (j = *n - 1; j >= 1; --j) { /* Computing MIN */ i__1 = *kl, i__2 = *n - j; lm = min(i__1,i__2); clacgv_(nrhs, &b_ref(j, 1), ldb); q__1.r = -1.f, q__1.i = 0.f; cgemv_("Conjugate transpose", &lm, nrhs, &q__1, &b_ref(j + 1, 1), ldb, &ab_ref(kd + 1, j), &c__1, &c_b1, &b_ref(j, 1), ldb); clacgv_(nrhs, &b_ref(j, 1), ldb); l = ipiv[j]; if (l != j) { cswap_(nrhs, &b_ref(l, 1), ldb, &b_ref(j, 1), ldb); } /* L60: */ } } } return 0; /* End of CGBTRS */ } /* cgbtrs_ */
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_ */