/* Subroutine */ int sgbsvx_(char *fact, char *trans, integer *n, integer *kl, integer *ku, integer *nrhs, real *ab, integer *ldab, real *afb, integer *ldafb, integer *ipiv, char *equed, real *r__, real *c__, real *b, integer *ldb, real *x, integer *ldx, real *rcond, real *ferr, real *berr, real *work, integer *iwork, integer *info) { /* System generated locals */ integer ab_dim1, ab_offset, afb_dim1, afb_offset, b_dim1, b_offset, x_dim1, x_offset, i__1, i__2, i__3, i__4, i__5; real r__1, r__2, r__3; /* Local variables */ integer i__, j, j1, j2; real amax; char norm[1]; real rcmin, rcmax, anorm; logical equil; real colcnd; logical nofact; real bignum; integer infequ; logical colequ; real rowcnd; logical notran; real smlnum; logical rowequ; real rpvgrw; /* -- LAPACK driver routine (version 3.2) -- */ /* November 2006 */ /* Purpose */ /* ======= */ /* SGBSVX uses the LU factorization to compute the solution to a real */ /* system of linear equations A * X = B, A**T * X = B, or A**H * X = B, */ /* where A is a band matrix of order N with KL subdiagonals and KU */ /* superdiagonals, and X and B are N-by-NRHS matrices. */ /* Error bounds on the solution and a condition estimate are also */ /* provided. */ /* Description */ /* =========== */ /* The following steps are performed by this subroutine: */ /* 1. If FACT = 'E', real scaling factors are computed to equilibrate */ /* the system: */ /* TRANS = 'N': diag(R)*A*diag(C) *inv(diag(C))*X = diag(R)*B */ /* TRANS = 'T': (diag(R)*A*diag(C))**T *inv(diag(R))*X = diag(C)*B */ /* TRANS = 'C': (diag(R)*A*diag(C))**H *inv(diag(R))*X = diag(C)*B */ /* Whether or not the system will be equilibrated depends on the */ /* scaling of the matrix A, but if equilibration is used, A is */ /* overwritten by diag(R)*A*diag(C) and B by diag(R)*B (if TRANS='N') */ /* or diag(C)*B (if TRANS = 'T' or 'C'). */ /* 2. If FACT = 'N' or 'E', the LU decomposition is used to factor the */ /* matrix A (after equilibration if FACT = 'E') as */ /* A = L * U, */ /* where L is a product of permutation and unit lower triangular */ /* matrices with KL subdiagonals, and U is upper triangular with */ /* KL+KU superdiagonals. */ /* 3. If some U(i,i)=0, so that U is exactly singular, then the routine */ /* returns with INFO = i. Otherwise, the factored form of A is used */ /* to estimate the condition number of the matrix A. If the */ /* reciprocal of the condition number is less than machine precision, */ /* INFO = N+1 is returned as a warning, but the routine still goes on */ /* to solve for X and compute error bounds as described below. */ /* 4. The system of equations is solved for X using the factored form */ /* of A. */ /* 5. Iterative refinement is applied to improve the computed solution */ /* matrix and calculate error bounds and backward error estimates */ /* for it. */ /* 6. If equilibration was used, the matrix X is premultiplied by */ /* diag(C) (if TRANS = 'N') or diag(R) (if TRANS = 'T' or 'C') so */ /* that it solves the original system before equilibration. */ /* Arguments */ /* ========= */ /* FACT (input) CHARACTER*1 */ /* Specifies whether or not the factored form of the matrix A is */ /* supplied on entry, and if not, whether the matrix A should be */ /* equilibrated before it is factored. */ /* = 'F': On entry, AFB and IPIV contain the factored form of */ /* A. If EQUED is not 'N', the matrix A has been */ /* equilibrated with scaling factors given by R and C. */ /* AB, AFB, and IPIV are not modified. */ /* = 'N': The matrix A will be copied to AFB and factored. */ /* = 'E': The matrix A will be equilibrated if necessary, then */ /* copied to AFB and factored. */ /* 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 (Transpose) */ /* N (input) INTEGER */ /* The number of linear equations, i.e., 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 matrices B and X. NRHS >= 0. */ /* AB (input/output) REAL array, dimension (LDAB,N) */ /* On entry, the matrix A in band storage, in rows 1 to KL+KU+1. */ /* The j-th column of A is stored in the j-th column of the */ /* array AB as follows: */ /* AB(KU+1+i-j,j) = A(i,j) for max(1,j-KU)<=i<=min(N,j+kl) */ /* If FACT = 'F' and EQUED is not 'N', then A must have been */ /* equilibrated by the scaling factors in R and/or C. AB is not */ /* modified if FACT = 'F' or 'N', or if FACT = 'E' and */ /* EQUED = 'N' on exit. */ /* On exit, if EQUED .ne. 'N', A is scaled as follows: */ /* EQUED = 'R': A := diag(R) * A */ /* EQUED = 'C': A := A * diag(C) */ /* EQUED = 'B': A := diag(R) * A * diag(C). */ /* LDAB (input) INTEGER */ /* The leading dimension of the array AB. LDAB >= KL+KU+1. */ /* AFB (input or output) REAL array, dimension (LDAFB,N) */ /* If FACT = 'F', then AFB is an input argument and on entry */ /* contains details of the LU factorization of the band matrix */ /* A, as computed by SGBTRF. 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. If EQUED .ne. 'N', then AFB is */ /* the factored form of the equilibrated matrix A. */ /* If FACT = 'N', then AFB is an output argument and on exit */ /* returns details of the LU factorization of A. */ /* If FACT = 'E', then AFB is an output argument and on exit */ /* returns details of the LU factorization of the equilibrated */ /* matrix A (see the description of AB for the form of the */ /* equilibrated matrix). */ /* LDAFB (input) INTEGER */ /* The leading dimension of the array AFB. LDAFB >= 2*KL+KU+1. */ /* IPIV (input or output) INTEGER array, dimension (N) */ /* If FACT = 'F', then IPIV is an input argument and on entry */ /* contains the pivot indices from the factorization A = L*U */ /* as computed by SGBTRF; row i of the matrix was interchanged */ /* with row IPIV(i). */ /* If FACT = 'N', then IPIV is an output argument and on exit */ /* contains the pivot indices from the factorization A = L*U */ /* of the original matrix A. */ /* If FACT = 'E', then IPIV is an output argument and on exit */ /* contains the pivot indices from the factorization A = L*U */ /* of the equilibrated matrix A. */ /* EQUED (input or output) CHARACTER*1 */ /* Specifies the form of equilibration that was done. */ /* = 'N': No equilibration (always true if FACT = 'N'). */ /* = 'R': Row equilibration, i.e., A has been premultiplied by */ /* diag(R). */ /* = 'C': Column equilibration, i.e., A has been postmultiplied */ /* by diag(C). */ /* = 'B': Both row and column equilibration, i.e., A has been */ /* replaced by diag(R) * A * diag(C). */ /* EQUED is an input argument if FACT = 'F'; otherwise, it is an */ /* output argument. */ /* R (input or output) REAL array, dimension (N) */ /* The row scale factors for A. If EQUED = 'R' or 'B', A is */ /* multiplied on the left by diag(R); if EQUED = 'N' or 'C', R */ /* is not accessed. R is an input argument if FACT = 'F'; */ /* otherwise, R is an output argument. If FACT = 'F' and */ /* EQUED = 'R' or 'B', each element of R must be positive. */ /* C (input or output) REAL array, dimension (N) */ /* The column scale factors for A. If EQUED = 'C' or 'B', A is */ /* multiplied on the right by diag(C); if EQUED = 'N' or 'R', C */ /* is not accessed. C is an input argument if FACT = 'F'; */ /* otherwise, C is an output argument. If FACT = 'F' and */ /* EQUED = 'C' or 'B', each element of C must be positive. */ /* B (input/output) REAL array, dimension (LDB,NRHS) */ /* On entry, the right hand side matrix B. */ /* On exit, */ /* if EQUED = 'N', B is not modified; */ /* if TRANS = 'N' and EQUED = 'R' or 'B', B is overwritten by */ /* diag(R)*B; */ /* if TRANS = 'T' or 'C' and EQUED = 'C' or 'B', B is */ /* overwritten by diag(C)*B. */ /* LDB (input) INTEGER */ /* The leading dimension of the array B. LDB >= max(1,N). */ /* X (output) REAL array, dimension (LDX,NRHS) */ /* If INFO = 0 or INFO = N+1, the N-by-NRHS solution matrix X */ /* to the original system of equations. Note that A and B are */ /* modified on exit if EQUED .ne. 'N', and the solution to the */ /* equilibrated system is inv(diag(C))*X if TRANS = 'N' and */ /* EQUED = 'C' or 'B', or inv(diag(R))*X if TRANS = 'T' or 'C' */ /* and EQUED = 'R' or 'B'. */ /* LDX (input) INTEGER */ /* The leading dimension of the array X. LDX >= max(1,N). */ /* RCOND (output) REAL */ /* The estimate of the reciprocal condition number of the matrix */ /* A after equilibration (if done). If RCOND is less than the */ /* machine precision (in particular, if RCOND = 0), the matrix */ /* is singular to working precision. This condition is */ /* indicated by a return code of INFO > 0. */ /* 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/output) REAL array, dimension (3*N) */ /* On exit, WORK(1) contains the reciprocal pivot growth */ /* factor norm(A)/norm(U). The "max absolute element" norm is */ /* used. If WORK(1) is much less than 1, then the stability */ /* of the LU factorization of the (equilibrated) matrix A */ /* could be poor. This also means that the solution X, condition */ /* estimator RCOND, and forward error bound FERR could be */ /* unreliable. If factorization fails with 0<INFO<=N, then */ /* WORK(1) contains the reciprocal pivot growth factor for the */ /* leading INFO columns of A. */ /* IWORK (workspace) INTEGER array, dimension (N) */ /* INFO (output) INTEGER */ /* = 0: successful exit */ /* < 0: if INFO = -i, the i-th argument had an illegal value */ /* > 0: if INFO = i, and i is */ /* <= N: U(i,i) is exactly zero. The factorization */ /* has been completed, but the factor U is exactly */ /* singular, so the solution and error bounds */ /* could not be computed. RCOND = 0 is returned. */ /* = N+1: U is nonsingular, but RCOND is less than machine */ /* precision, meaning that the matrix is singular */ /* to working precision. Nevertheless, the */ /* solution and error bounds are computed because */ /* there are a number of situations where the */ /* computed solution can be more accurate than the */ /* value of RCOND would suggest. */ /* ===================================================================== */ /* Moved setting of INFO = N+1 so INFO does not subsequently get */ /* overwritten. Sven, 17 Mar 05. */ /* ===================================================================== */ /* Parameter adjustments */ ab_dim1 = *ldab; ab_offset = 1 + ab_dim1; ab -= ab_offset; afb_dim1 = *ldafb; afb_offset = 1 + afb_dim1; afb -= afb_offset; --ipiv; --r__; --c__; 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; --iwork; /* Function Body */ *info = 0; nofact = lsame_(fact, "N"); equil = lsame_(fact, "E"); notran = lsame_(trans, "N"); if (nofact || equil) { *(unsigned char *)equed = 'N'; rowequ = FALSE_; colequ = FALSE_; } else { rowequ = lsame_(equed, "R") || lsame_(equed, "B"); colequ = lsame_(equed, "C") || lsame_(equed, "B"); smlnum = slamch_("Safe minimum"); bignum = 1.f / smlnum; } /* Test the input parameters. */ if (! nofact && ! equil && ! lsame_(fact, "F")) { *info = -1; } else if (! notran && ! lsame_(trans, "T") && ! lsame_(trans, "C")) { *info = -2; } else if (*n < 0) { *info = -3; } else if (*kl < 0) { *info = -4; } else if (*ku < 0) { *info = -5; } else if (*nrhs < 0) { *info = -6; } else if (*ldab < *kl + *ku + 1) { *info = -8; } else if (*ldafb < (*kl << 1) + *ku + 1) { *info = -10; } else if (lsame_(fact, "F") && ! (rowequ || colequ || lsame_(equed, "N"))) { *info = -12; } else { if (rowequ) { rcmin = bignum; rcmax = 0.f; i__1 = *n; for (j = 1; j <= i__1; ++j) { /* Computing MIN */ r__1 = rcmin, r__2 = r__[j]; rcmin = dmin(r__1,r__2); /* Computing MAX */ r__1 = rcmax, r__2 = r__[j]; rcmax = dmax(r__1,r__2); } if (rcmin <= 0.f) { *info = -13; } else if (*n > 0) { rowcnd = dmax(rcmin,smlnum) / dmin(rcmax,bignum); } else { rowcnd = 1.f; } } if (colequ && *info == 0) { rcmin = bignum; rcmax = 0.f; i__1 = *n; for (j = 1; j <= i__1; ++j) { /* Computing MIN */ r__1 = rcmin, r__2 = c__[j]; rcmin = dmin(r__1,r__2); /* Computing MAX */ r__1 = rcmax, r__2 = c__[j]; rcmax = dmax(r__1,r__2); } if (rcmin <= 0.f) { *info = -14; } else if (*n > 0) { colcnd = dmax(rcmin,smlnum) / dmin(rcmax,bignum); } else { colcnd = 1.f; } } if (*info == 0) { if (*ldb < max(1,*n)) { *info = -16; } else if (*ldx < max(1,*n)) { *info = -18; } } } if (*info != 0) { i__1 = -(*info); xerbla_("SGBSVX", &i__1); return 0; } if (equil) { /* Compute row and column scalings to equilibrate the matrix A. */ sgbequ_(n, n, kl, ku, &ab[ab_offset], ldab, &r__[1], &c__[1], &rowcnd, &colcnd, &amax, &infequ); if (infequ == 0) { /* Equilibrate the matrix. */ slaqgb_(n, n, kl, ku, &ab[ab_offset], ldab, &r__[1], &c__[1], & rowcnd, &colcnd, &amax, equed); rowequ = lsame_(equed, "R") || lsame_(equed, "B"); colequ = lsame_(equed, "C") || lsame_(equed, "B"); } } /* Scale the right hand side. */ if (notran) { if (rowequ) { i__1 = *nrhs; for (j = 1; j <= i__1; ++j) { i__2 = *n; for (i__ = 1; i__ <= i__2; ++i__) { b[i__ + j * b_dim1] = r__[i__] * b[i__ + j * b_dim1]; } } } } else if (colequ) { i__1 = *nrhs; for (j = 1; j <= i__1; ++j) { i__2 = *n; for (i__ = 1; i__ <= i__2; ++i__) { b[i__ + j * b_dim1] = c__[i__] * b[i__ + j * b_dim1]; } } } if (nofact || equil) { /* Compute the LU factorization of the band matrix A. */ i__1 = *n; for (j = 1; j <= i__1; ++j) { /* Computing MAX */ i__2 = j - *ku; j1 = max(i__2,1); /* Computing MIN */ i__2 = j + *kl; j2 = min(i__2,*n); i__2 = j2 - j1 + 1; scopy_(&i__2, &ab[*ku + 1 - j + j1 + j * ab_dim1], &c__1, &afb[* kl + *ku + 1 - j + j1 + j * afb_dim1], &c__1); } sgbtrf_(n, n, kl, ku, &afb[afb_offset], ldafb, &ipiv[1], info); /* Return if INFO is non-zero. */ if (*info > 0) { /* Compute the reciprocal pivot growth factor of the */ /* leading rank-deficient INFO columns of A. */ anorm = 0.f; i__1 = *info; for (j = 1; j <= i__1; ++j) { /* Computing MAX */ i__2 = *ku + 2 - j; /* Computing MIN */ i__4 = *n + *ku + 1 - j, i__5 = *kl + *ku + 1; i__3 = min(i__4,i__5); for (i__ = max(i__2,1); i__ <= i__3; ++i__) { /* Computing MAX */ r__2 = anorm, r__3 = (r__1 = ab[i__ + j * ab_dim1], dabs( r__1)); anorm = dmax(r__2,r__3); } } /* Computing MIN */ i__3 = *info - 1, i__2 = *kl + *ku; i__1 = min(i__3,i__2); /* Computing MAX */ i__4 = 1, i__5 = *kl + *ku + 2 - *info; rpvgrw = slantb_("M", "U", "N", info, &i__1, &afb[max(i__4, i__5) + afb_dim1], ldafb, &work[1]); if (rpvgrw == 0.f) { rpvgrw = 1.f; } else { rpvgrw = anorm / rpvgrw; } work[1] = rpvgrw; *rcond = 0.f; return 0; } } /* Compute the norm of the matrix A and the */ /* reciprocal pivot growth factor RPVGRW. */ if (notran) { *(unsigned char *)norm = '1'; } else { *(unsigned char *)norm = 'I'; } anorm = slangb_(norm, n, kl, ku, &ab[ab_offset], ldab, &work[1]); i__1 = *kl + *ku; rpvgrw = slantb_("M", "U", "N", n, &i__1, &afb[afb_offset], ldafb, &work[ 1]); if (rpvgrw == 0.f) { rpvgrw = 1.f; } else { rpvgrw = slangb_("M", n, kl, ku, &ab[ab_offset], ldab, &work[1]) / rpvgrw; } /* Compute the reciprocal of the condition number of A. */ sgbcon_(norm, n, kl, ku, &afb[afb_offset], ldafb, &ipiv[1], &anorm, rcond, &work[1], &iwork[1], info); /* Compute the solution matrix X. */ slacpy_("Full", n, nrhs, &b[b_offset], ldb, &x[x_offset], ldx); sgbtrs_(trans, n, kl, ku, nrhs, &afb[afb_offset], ldafb, &ipiv[1], &x[ x_offset], ldx, info); /* Use iterative refinement to improve the computed solution and */ /* compute error bounds and backward error estimates for it. */ sgbrfs_(trans, n, kl, ku, nrhs, &ab[ab_offset], ldab, &afb[afb_offset], ldafb, &ipiv[1], &b[b_offset], ldb, &x[x_offset], ldx, &ferr[1], & berr[1], &work[1], &iwork[1], info); /* Transform the solution matrix X to a solution of the original */ /* system. */ if (notran) { if (colequ) { i__1 = *nrhs; for (j = 1; j <= i__1; ++j) { i__3 = *n; for (i__ = 1; i__ <= i__3; ++i__) { x[i__ + j * x_dim1] = c__[i__] * x[i__ + j * x_dim1]; } } i__1 = *nrhs; for (j = 1; j <= i__1; ++j) { ferr[j] /= colcnd; } } } else if (rowequ) { i__1 = *nrhs; for (j = 1; j <= i__1; ++j) { i__3 = *n; for (i__ = 1; i__ <= i__3; ++i__) { x[i__ + j * x_dim1] = r__[i__] * x[i__ + j * x_dim1]; } } i__1 = *nrhs; for (j = 1; j <= i__1; ++j) { ferr[j] /= rowcnd; } } /* Set INFO = N+1 if the matrix is singular to working precision. */ if (*rcond < slamch_("Epsilon")) { *info = *n + 1; } work[1] = rpvgrw; return 0; /* End of SGBSVX */ } /* sgbsvx_ */
/* Subroutine */ int stbt06_(real *rcond, real *rcondc, char *uplo, char * diag, integer *n, integer *kd, real *ab, integer *ldab, real *work, real *rat) { /* System generated locals */ integer ab_dim1, ab_offset; real r__1, r__2; /* Local variables */ static real rmin, rmax, anorm; extern /* Subroutine */ int slabad_(real *, real *); extern doublereal slamch_(char *); static real bignum; extern doublereal slantb_(char *, char *, char *, integer *, integer *, real *, integer *, real *); static real smlnum, eps; /* -- 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 ======= STBT06 computes a test ratio comparing RCOND (the reciprocal condition number of a triangular matrix A) and RCONDC, the estimate computed by STBCON. Information about the triangular matrix A is used if one estimate is zero and the other is non-zero to decide if underflow in the estimate is justified. Arguments ========= RCOND (input) REAL The estimate of the reciprocal condition number obtained by forming the explicit inverse of the matrix A and computing RCOND = 1/( norm(A) * norm(inv(A)) ). RCONDC (input) REAL The estimate of the reciprocal condition number computed by STBCON. UPLO (input) CHARACTER Specifies whether the matrix A is upper or lower triangular. = 'U': Upper triangular = 'L': Lower triangular DIAG (input) CHARACTER 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. AB (input) REAL 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. WORK (workspace) REAL array, dimension (N) RAT (output) REAL The test ratio. If both RCOND and RCONDC are nonzero, RAT = MAX( RCOND, RCONDC )/MIN( RCOND, RCONDC ) - 1. If RAT = 0, the two estimates are exactly the same. ===================================================================== Parameter adjustments */ ab_dim1 = *ldab; ab_offset = 1 + ab_dim1 * 1; ab -= ab_offset; --work; /* Function Body */ eps = slamch_("Epsilon"); rmax = dmax(*rcond,*rcondc); rmin = dmin(*rcond,*rcondc); /* Do the easy cases first. */ if (rmin < 0.f) { /* Invalid value for RCOND or RCONDC, return 1/EPS. */ *rat = 1.f / eps; } else if (rmin > 0.f) { /* Both estimates are positive, return RMAX/RMIN - 1. */ *rat = rmax / rmin - 1.f; } else if (rmax == 0.f) { /* Both estimates zero. */ *rat = 0.f; } else { /* One estimate is zero, the other is non-zero. If the matrix is ill-conditioned, return the nonzero estimate multiplied by 1/EPS; if the matrix is badly scaled, return the nonzero estimate multiplied by BIGNUM/TMAX, where TMAX is the maximum element in absolute value in A. */ smlnum = slamch_("Safe minimum"); bignum = 1.f / smlnum; slabad_(&smlnum, &bignum); anorm = slantb_("M", uplo, diag, n, kd, &ab[ab_offset], ldab, &work[1] ); /* Computing MIN */ r__1 = bignum / dmax(1.f,anorm), r__2 = 1.f / eps; *rat = rmax * dmin(r__1,r__2); } return 0; /* End of STBT06 */ } /* stbt06_ */
/* Subroutine */ int stbt06_(real *rcond, real *rcondc, char *uplo, char * diag, integer *n, integer *kd, real *ab, integer *ldab, real *work, real *rat) { /* System generated locals */ integer ab_dim1, ab_offset; real r__1, r__2; /* Local variables */ real eps, rmin, rmax, anorm; real bignum; real smlnum; /* -- LAPACK test routine (version 3.1) -- */ /* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ /* November 2006 */ /* .. Scalar Arguments .. */ /* .. */ /* .. Array Arguments .. */ /* .. */ /* Purpose */ /* ======= */ /* STBT06 computes a test ratio comparing RCOND (the reciprocal */ /* condition number of a triangular matrix A) and RCONDC, the estimate */ /* computed by STBCON. Information about the triangular matrix A is */ /* used if one estimate is zero and the other is non-zero to decide if */ /* underflow in the estimate is justified. */ /* Arguments */ /* ========= */ /* RCOND (input) REAL */ /* The estimate of the reciprocal condition number obtained by */ /* forming the explicit inverse of the matrix A and computing */ /* RCOND = 1/( norm(A) * norm(inv(A)) ). */ /* RCONDC (input) REAL */ /* The estimate of the reciprocal condition number computed by */ /* STBCON. */ /* UPLO (input) CHARACTER */ /* Specifies whether the matrix A is upper or lower triangular. */ /* = 'U': Upper triangular */ /* = 'L': Lower triangular */ /* DIAG (input) CHARACTER */ /* 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. */ /* AB (input) REAL 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. */ /* WORK (workspace) REAL array, dimension (N) */ /* RAT (output) REAL */ /* The test ratio. If both RCOND and RCONDC are nonzero, */ /* RAT = MAX( RCOND, RCONDC )/MIN( RCOND, RCONDC ) - 1. */ /* If RAT = 0, the two estimates are exactly the same. */ /* ===================================================================== */ /* .. Parameters .. */ /* .. */ /* .. Local Scalars .. */ /* .. */ /* .. External Functions .. */ /* .. */ /* .. Intrinsic Functions .. */ /* .. */ /* .. External Subroutines .. */ /* .. */ /* .. Executable Statements .. */ /* Parameter adjustments */ ab_dim1 = *ldab; ab_offset = 1 + ab_dim1; ab -= ab_offset; --work; /* Function Body */ eps = slamch_("Epsilon"); rmax = dmax(*rcond,*rcondc); rmin = dmin(*rcond,*rcondc); /* Do the easy cases first. */ if (rmin < 0.f) { /* Invalid value for RCOND or RCONDC, return 1/EPS. */ *rat = 1.f / eps; } else if (rmin > 0.f) { /* Both estimates are positive, return RMAX/RMIN - 1. */ *rat = rmax / rmin - 1.f; } else if (rmax == 0.f) { /* Both estimates zero. */ *rat = 0.f; } else { /* One estimate is zero, the other is non-zero. If the matrix is */ /* ill-conditioned, return the nonzero estimate multiplied by */ /* 1/EPS; if the matrix is badly scaled, return the nonzero */ /* estimate multiplied by BIGNUM/TMAX, where TMAX is the maximum */ /* element in absolute value in A. */ smlnum = slamch_("Safe minimum"); bignum = 1.f / smlnum; slabad_(&smlnum, &bignum); anorm = slantb_("M", uplo, diag, n, kd, &ab[ab_offset], ldab, &work[1] ); /* Computing MIN */ r__1 = bignum / dmax(1.f,anorm), r__2 = 1.f / eps; *rat = rmax * dmin(r__1,r__2); } return 0; /* End of STBT06 */ } /* stbt06_ */
/* Subroutine */ int stbcon_(char *norm, char *uplo, char *diag, integer *n, integer *kd, real *ab, integer *ldab, real *rcond, real *work, integer *iwork, integer *info) { /* System generated locals */ integer ab_dim1, ab_offset, i__1; real r__1; /* Local variables */ integer ix, kase, kase1; real scale; extern logical lsame_(char *, char *); integer isave[3]; real anorm; extern /* Subroutine */ int srscl_(integer *, real *, real *, integer *); logical upper; real xnorm; extern /* Subroutine */ int slacn2_(integer *, real *, real *, integer *, real *, integer *, integer *); extern doublereal slamch_(char *); extern /* Subroutine */ int xerbla_(char *, integer *); extern integer isamax_(integer *, real *, integer *); extern doublereal slantb_(char *, char *, char *, integer *, integer *, real *, integer *, real *); real ainvnm; extern /* Subroutine */ int slatbs_(char *, char *, char *, char *, integer *, integer *, real *, integer *, real *, real *, real *, integer *); logical onenrm; char normin[1]; real smlnum; logical nounit; /* -- LAPACK routine (version 3.2) -- */ /* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ /* November 2006 */ /* Modified to call SLACN2 in place of SLACON, 7 Feb 03, SJH. */ /* .. Scalar Arguments .. */ /* .. */ /* .. Array Arguments .. */ /* .. */ /* Purpose */ /* ======= */ /* STBCON estimates the reciprocal of the condition number of a */ /* triangular band matrix A, in either the 1-norm or the infinity-norm. */ /* The norm of A is computed and an estimate is obtained for */ /* norm(inv(A)), then the reciprocal of the condition number is */ /* computed as */ /* RCOND = 1 / ( norm(A) * norm(inv(A)) ). */ /* Arguments */ /* ========= */ /* NORM (input) CHARACTER*1 */ /* Specifies whether the 1-norm condition number or the */ /* infinity-norm condition number is required: */ /* = '1' or 'O': 1-norm; */ /* = 'I': Infinity-norm. */ /* UPLO (input) CHARACTER*1 */ /* = 'U': A is upper triangular; */ /* = 'L': A is lower triangular. */ /* DIAG (input) CHARACTER*1 */ /* = 'N': A is non-unit triangular; */ /* = 'U': A is unit triangular. */ /* N (input) INTEGER */ /* The order of the matrix A. N >= 0. */ /* KD (input) INTEGER */ /* The number of superdiagonals or subdiagonals of the */ /* triangular band matrix A. KD >= 0. */ /* AB (input) REAL 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. */ /* RCOND (output) REAL */ /* The reciprocal of the condition number of the matrix A, */ /* computed as RCOND = 1/(norm(A) * norm(inv(A))). */ /* WORK (workspace) REAL array, dimension (3*N) */ /* IWORK (workspace) INTEGER 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 Functions .. */ /* .. */ /* .. External Subroutines .. */ /* .. */ /* .. Intrinsic Functions .. */ /* .. */ /* .. Executable Statements .. */ /* Test the input parameters. */ /* Parameter adjustments */ ab_dim1 = *ldab; ab_offset = 1 + ab_dim1; ab -= ab_offset; --work; --iwork; /* Function Body */ *info = 0; upper = lsame_(uplo, "U"); onenrm = *(unsigned char *)norm == '1' || lsame_(norm, "O"); nounit = lsame_(diag, "N"); if (! onenrm && ! lsame_(norm, "I")) { *info = -1; } else if (! upper && ! lsame_(uplo, "L")) { *info = -2; } else if (! nounit && ! lsame_(diag, "U")) { *info = -3; } else if (*n < 0) { *info = -4; } else if (*kd < 0) { *info = -5; } else if (*ldab < *kd + 1) { *info = -7; } if (*info != 0) { i__1 = -(*info); xerbla_("STBCON", &i__1); return 0; } /* Quick return if possible */ if (*n == 0) { *rcond = 1.f; return 0; } *rcond = 0.f; smlnum = slamch_("Safe minimum") * (real) max(1,*n); /* Compute the norm of the triangular matrix A. */ anorm = slantb_(norm, uplo, diag, n, kd, &ab[ab_offset], ldab, &work[1]); /* Continue only if ANORM > 0. */ if (anorm > 0.f) { /* Estimate the norm of the inverse of A. */ ainvnm = 0.f; *(unsigned char *)normin = 'N'; if (onenrm) { kase1 = 1; } else { kase1 = 2; } kase = 0; L10: slacn2_(n, &work[*n + 1], &work[1], &iwork[1], &ainvnm, &kase, isave); if (kase != 0) { if (kase == kase1) { /* Multiply by inv(A). */ slatbs_(uplo, "No transpose", diag, normin, n, kd, &ab[ ab_offset], ldab, &work[1], &scale, &work[(*n << 1) + 1], info) ; } else { /* Multiply by inv(A'). */ slatbs_(uplo, "Transpose", diag, normin, n, kd, &ab[ab_offset] , ldab, &work[1], &scale, &work[(*n << 1) + 1], info); } *(unsigned char *)normin = 'Y'; /* Multiply by 1/SCALE if doing so will not cause overflow. */ if (scale != 1.f) { ix = isamax_(n, &work[1], &c__1); xnorm = (r__1 = work[ix], dabs(r__1)); if (scale < xnorm * smlnum || scale == 0.f) { goto L20; } srscl_(n, &scale, &work[1], &c__1); } goto L10; } /* Compute the estimate of the reciprocal condition number. */ if (ainvnm != 0.f) { *rcond = 1.f / anorm / ainvnm; } } L20: return 0; /* End of STBCON */ } /* stbcon_ */
/* Subroutine */ int sdrvgb_(logical *dotype, integer *nn, integer *nval, integer *nrhs, real *thresh, logical *tsterr, real *a, integer *la, real *afb, integer *lafb, real *asav, real *b, real *bsav, real *x, real *xact, real *s, real *work, real *rwork, integer *iwork, integer *nout) { /* Initialized data */ static integer iseedy[4] = { 1988,1989,1990,1991 }; static char transs[1*3] = "N" "T" "C"; static char facts[1*3] = "F" "N" "E"; static char equeds[1*4] = "N" "R" "C" "B"; /* Format strings */ static char fmt_9999[] = "(\002 *** In SDRVGB, LA=\002,i5,\002 is too sm" "all for N=\002,i5,\002, KU=\002,i5,\002, KL=\002,i5,/\002 ==> In" "crease LA to at least \002,i5)"; static char fmt_9998[] = "(\002 *** In SDRVGB, LAFB=\002,i5,\002 is too " "small for N=\002,i5,\002, KU=\002,i5,\002, KL=\002,i5,/\002 ==> " "Increase LAFB to at least \002,i5)"; static char fmt_9997[] = "(1x,a,\002, N=\002,i5,\002, KL=\002,i5,\002, K" "U=\002,i5,\002, type \002,i1,\002, test(\002,i1,\002)=\002,g12.5)" ; static char fmt_9995[] = "(1x,a,\002( '\002,a1,\002','\002,a1,\002',\002" ",i5,\002,\002,i5,\002,\002,i5,\002,...), EQUED='\002,a1,\002', t" "ype \002,i1,\002, test(\002,i1,\002)=\002,g12.5)"; static char fmt_9996[] = "(1x,a,\002( '\002,a1,\002','\002,a1,\002',\002" ",i5,\002,\002,i5,\002,\002,i5,\002,...), type \002,i1,\002, test(" "\002,i1,\002)=\002,g12.5)"; /* System generated locals */ address a__1[2]; integer i__1, i__2, i__3, i__4, i__5, i__6, i__7, i__8, i__9, i__10, i__11[2]; real r__1, r__2, r__3; char ch__1[2]; /* Local variables */ integer i__, j, k, n, i1, i2, k1, nb, in, kl, ku, nt, lda, ldb, ikl, nkl, iku, nku; char fact[1]; integer ioff, mode; real amax; char path[3]; integer imat, info; char dist[1], type__[1]; integer nrun, ldafb, ifact, nfail, iseed[4], nfact; char equed[1]; integer nbmin; real rcond, roldc; integer nimat; real roldi; real anorm; integer itran; logical equil; real roldo; char trans[1]; integer izero, nerrs; logical zerot; char xtype[1]; logical prefac; real colcnd; real rcondc; logical nofact; integer iequed; real rcondi; real cndnum, anormi, rcondo, ainvnm; logical trfcon; real anormo, rowcnd; real anrmpv; real result[7], rpvgrw; /* Fortran I/O blocks */ static cilist io___26 = { 0, 0, 0, fmt_9999, 0 }; static cilist io___27 = { 0, 0, 0, fmt_9998, 0 }; static cilist io___65 = { 0, 0, 0, fmt_9997, 0 }; static cilist io___72 = { 0, 0, 0, fmt_9995, 0 }; static cilist io___73 = { 0, 0, 0, fmt_9996, 0 }; static cilist io___74 = { 0, 0, 0, fmt_9995, 0 }; static cilist io___75 = { 0, 0, 0, fmt_9996, 0 }; static cilist io___76 = { 0, 0, 0, fmt_9995, 0 }; static cilist io___77 = { 0, 0, 0, fmt_9996, 0 }; static cilist io___78 = { 0, 0, 0, fmt_9995, 0 }; static cilist io___79 = { 0, 0, 0, fmt_9996, 0 }; /* -- LAPACK test routine (version 3.1) -- */ /* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ /* November 2006 */ /* .. Scalar Arguments .. */ /* .. */ /* .. Array Arguments .. */ /* .. */ /* Purpose */ /* ======= */ /* SDRVGB tests the driver routines SGBSV and -SVX. */ /* 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. */ /* NRHS (input) INTEGER */ /* The number of right hand side vectors to be generated for */ /* each linear system. */ /* 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. */ /* A (workspace) REAL array, dimension (LA) */ /* LA (input) INTEGER */ /* The length of the array A. LA >= (2*NMAX-1)*NMAX */ /* where NMAX is the largest entry in NVAL. */ /* AFB (workspace) REAL array, dimension (LAFB) */ /* LAFB (input) INTEGER */ /* The length of the array AFB. LAFB >= (3*NMAX-2)*NMAX */ /* where NMAX is the largest entry in NVAL. */ /* ASAV (workspace) REAL array, dimension (LA) */ /* B (workspace) REAL array, dimension (NMAX*NRHS) */ /* BSAV (workspace) REAL array, dimension (NMAX*NRHS) */ /* X (workspace) REAL array, dimension (NMAX*NRHS) */ /* XACT (workspace) REAL array, dimension (NMAX*NRHS) */ /* S (workspace) REAL array, dimension (2*NMAX) */ /* WORK (workspace) REAL array, dimension */ /* (NMAX*max(3,NRHS,NMAX)) */ /* RWORK (workspace) REAL array, dimension */ /* (max(NMAX,2*NRHS)) */ /* IWORK (workspace) INTEGER array, dimension (2*NMAX) */ /* NOUT (input) INTEGER */ /* The unit number for output. */ /* ===================================================================== */ /* .. Parameters .. */ /* .. */ /* .. Local Scalars .. */ /* .. */ /* .. Local Arrays .. */ /* .. */ /* .. External Functions .. */ /* .. */ /* .. External Subroutines .. */ /* .. */ /* .. Intrinsic Functions .. */ /* .. */ /* .. Scalars in Common .. */ /* .. */ /* .. Common blocks .. */ /* .. */ /* .. Data statements .. */ /* Parameter adjustments */ --iwork; --rwork; --work; --s; --xact; --x; --bsav; --b; --asav; --afb; --a; --nval; --dotype; /* Function Body */ /* .. */ /* .. Executable Statements .. */ /* Initialize constants and the random number seed. */ s_copy(path, "Single precision", (ftnlen)1, (ftnlen)16); s_copy(path + 1, "GB", (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) { serrvx_(path, nout); } infoc_1.infot = 0; /* Set the block size and minimum block size for testing. */ nb = 1; nbmin = 2; xlaenv_(&c__1, &nb); xlaenv_(&c__2, &nbmin); /* Do for each value of N in NVAL */ i__1 = *nn; for (in = 1; in <= i__1; ++in) { n = nval[in]; ldb = max(n,1); *(unsigned char *)xtype = 'N'; /* Set limits on the number of loop iterations. */ /* Computing MAX */ i__2 = 1, i__3 = min(n,4); nkl = max(i__2,i__3); if (n == 0) { nkl = 1; } nku = nkl; nimat = 8; if (n <= 0) { nimat = 1; } i__2 = nkl; for (ikl = 1; ikl <= i__2; ++ikl) { /* Do for KL = 0, N-1, (3N-1)/4, and (N+1)/4. This order makes */ /* it easier to skip redundant values for small values of N. */ if (ikl == 1) { kl = 0; } else if (ikl == 2) { /* Computing MAX */ i__3 = n - 1; kl = max(i__3,0); } else if (ikl == 3) { kl = (n * 3 - 1) / 4; } else if (ikl == 4) { kl = (n + 1) / 4; } i__3 = nku; for (iku = 1; iku <= i__3; ++iku) { /* Do for KU = 0, N-1, (3N-1)/4, and (N+1)/4. This order */ /* makes it easier to skip redundant values for small */ /* values of N. */ if (iku == 1) { ku = 0; } else if (iku == 2) { /* Computing MAX */ i__4 = n - 1; ku = max(i__4,0); } else if (iku == 3) { ku = (n * 3 - 1) / 4; } else if (iku == 4) { ku = (n + 1) / 4; } /* Check that A and AFB are big enough to generate this */ /* matrix. */ lda = kl + ku + 1; ldafb = (kl << 1) + ku + 1; if (lda * n > *la || ldafb * n > *lafb) { if (nfail == 0 && nerrs == 0) { aladhd_(nout, path); } if (lda * n > *la) { io___26.ciunit = *nout; s_wsfe(&io___26); do_fio(&c__1, (char *)&(*la), (ftnlen)sizeof(integer)) ; do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer)); do_fio(&c__1, (char *)&kl, (ftnlen)sizeof(integer)); do_fio(&c__1, (char *)&ku, (ftnlen)sizeof(integer)); i__4 = n * (kl + ku + 1); do_fio(&c__1, (char *)&i__4, (ftnlen)sizeof(integer)); e_wsfe(); ++nerrs; } if (ldafb * n > *lafb) { io___27.ciunit = *nout; s_wsfe(&io___27); do_fio(&c__1, (char *)&(*lafb), (ftnlen)sizeof( integer)); do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer)); do_fio(&c__1, (char *)&kl, (ftnlen)sizeof(integer)); do_fio(&c__1, (char *)&ku, (ftnlen)sizeof(integer)); i__4 = n * ((kl << 1) + ku + 1); do_fio(&c__1, (char *)&i__4, (ftnlen)sizeof(integer)); e_wsfe(); ++nerrs; } goto L130; } i__4 = nimat; for (imat = 1; imat <= i__4; ++imat) { /* Do the tests only if DOTYPE( IMAT ) is true. */ if (! dotype[imat]) { goto L120; } /* Skip types 2, 3, or 4 if the matrix is too small. */ zerot = imat >= 2 && imat <= 4; if (zerot && n < imat - 1) { goto L120; } /* Set up parameters with SLATB4 and generate a */ /* test matrix with SLATMS. */ slatb4_(path, &imat, &n, &n, type__, &kl, &ku, &anorm, & mode, &cndnum, dist); rcondc = 1.f / cndnum; s_copy(srnamc_1.srnamt, "SLATMS", (ftnlen)32, (ftnlen)6); slatms_(&n, &n, dist, iseed, type__, &rwork[1], &mode, & cndnum, &anorm, &kl, &ku, "Z", &a[1], &lda, &work[ 1], &info); /* Check the error code from SLATMS. */ if (info != 0) { alaerh_(path, "SLATMS", &info, &c__0, " ", &n, &n, & kl, &ku, &c_n1, &imat, &nfail, &nerrs, nout); goto L120; } /* For types 2, 3, and 4, zero one or more columns of */ /* the matrix to test that INFO is returned correctly. */ izero = 0; if (zerot) { if (imat == 2) { izero = 1; } else if (imat == 3) { izero = n; } else { izero = n / 2 + 1; } ioff = (izero - 1) * lda; if (imat < 4) { /* Computing MAX */ i__5 = 1, i__6 = ku + 2 - izero; i1 = max(i__5,i__6); /* Computing MIN */ i__5 = kl + ku + 1, i__6 = ku + 1 + (n - izero); i2 = min(i__5,i__6); i__5 = i2; for (i__ = i1; i__ <= i__5; ++i__) { a[ioff + i__] = 0.f; /* L20: */ } } else { i__5 = n; for (j = izero; j <= i__5; ++j) { /* Computing MAX */ i__6 = 1, i__7 = ku + 2 - j; /* Computing MIN */ i__9 = kl + ku + 1, i__10 = ku + 1 + (n - j); i__8 = min(i__9,i__10); for (i__ = max(i__6,i__7); i__ <= i__8; ++i__) { a[ioff + i__] = 0.f; /* L30: */ } ioff += lda; /* L40: */ } } } /* Save a copy of the matrix A in ASAV. */ i__5 = kl + ku + 1; slacpy_("Full", &i__5, &n, &a[1], &lda, &asav[1], &lda); for (iequed = 1; iequed <= 4; ++iequed) { *(unsigned char *)equed = *(unsigned char *)&equeds[ iequed - 1]; if (iequed == 1) { nfact = 3; } else { nfact = 1; } i__5 = nfact; for (ifact = 1; ifact <= i__5; ++ifact) { *(unsigned char *)fact = *(unsigned char *)&facts[ ifact - 1]; prefac = lsame_(fact, "F"); nofact = lsame_(fact, "N"); equil = lsame_(fact, "E"); if (zerot) { if (prefac) { goto L100; } rcondo = 0.f; rcondi = 0.f; } else if (! nofact) { /* Compute the condition number for comparison */ /* with the value returned by SGESVX (FACT = */ /* 'N' reuses the condition number from the */ /* previous iteration with FACT = 'F'). */ i__8 = kl + ku + 1; slacpy_("Full", &i__8, &n, &asav[1], &lda, & afb[kl + 1], &ldafb); if (equil || iequed > 1) { /* Compute row and column scale factors to */ /* equilibrate the matrix A. */ sgbequ_(&n, &n, &kl, &ku, &afb[kl + 1], & ldafb, &s[1], &s[n + 1], &rowcnd, &colcnd, &amax, &info); if (info == 0 && n > 0) { if (lsame_(equed, "R")) { rowcnd = 0.f; colcnd = 1.f; } else if (lsame_(equed, "C")) { rowcnd = 1.f; colcnd = 0.f; } else if (lsame_(equed, "B")) { rowcnd = 0.f; colcnd = 0.f; } /* Equilibrate the matrix. */ slaqgb_(&n, &n, &kl, &ku, &afb[kl + 1] , &ldafb, &s[1], &s[n + 1], & rowcnd, &colcnd, &amax, equed); } } /* Save the condition number of the */ /* non-equilibrated system for use in SGET04. */ if (equil) { roldo = rcondo; roldi = rcondi; } /* Compute the 1-norm and infinity-norm of A. */ anormo = slangb_("1", &n, &kl, &ku, &afb[kl + 1], &ldafb, &rwork[1]); anormi = slangb_("I", &n, &kl, &ku, &afb[kl + 1], &ldafb, &rwork[1]); /* Factor the matrix A. */ sgbtrf_(&n, &n, &kl, &ku, &afb[1], &ldafb, & iwork[1], &info); /* Form the inverse of A. */ slaset_("Full", &n, &n, &c_b48, &c_b49, &work[ 1], &ldb); s_copy(srnamc_1.srnamt, "SGBTRS", (ftnlen)32, (ftnlen)6); sgbtrs_("No transpose", &n, &kl, &ku, &n, & afb[1], &ldafb, &iwork[1], &work[1], & ldb, &info); /* Compute the 1-norm condition number of A. */ ainvnm = slange_("1", &n, &n, &work[1], &ldb, &rwork[1]); if (anormo <= 0.f || ainvnm <= 0.f) { rcondo = 1.f; } else { rcondo = 1.f / anormo / ainvnm; } /* Compute the infinity-norm condition number */ /* of A. */ ainvnm = slange_("I", &n, &n, &work[1], &ldb, &rwork[1]); if (anormi <= 0.f || ainvnm <= 0.f) { rcondi = 1.f; } else { rcondi = 1.f / anormi / ainvnm; } } for (itran = 1; itran <= 3; ++itran) { /* Do for each value of TRANS. */ *(unsigned char *)trans = *(unsigned char *)& transs[itran - 1]; if (itran == 1) { rcondc = rcondo; } else { rcondc = rcondi; } /* Restore the matrix A. */ i__8 = kl + ku + 1; slacpy_("Full", &i__8, &n, &asav[1], &lda, &a[ 1], &lda); /* Form an exact solution and set the right hand */ /* side. */ s_copy(srnamc_1.srnamt, "SLARHS", (ftnlen)32, (ftnlen)6); slarhs_(path, xtype, "Full", trans, &n, &n, & kl, &ku, nrhs, &a[1], &lda, &xact[1], &ldb, &b[1], &ldb, iseed, &info); *(unsigned char *)xtype = 'C'; slacpy_("Full", &n, nrhs, &b[1], &ldb, &bsav[ 1], &ldb); if (nofact && itran == 1) { /* --- Test SGBSV --- */ /* Compute the LU factorization of the matrix */ /* and solve the system. */ i__8 = kl + ku + 1; slacpy_("Full", &i__8, &n, &a[1], &lda, & afb[kl + 1], &ldafb); slacpy_("Full", &n, nrhs, &b[1], &ldb, &x[ 1], &ldb); s_copy(srnamc_1.srnamt, "SGBSV ", (ftnlen) 32, (ftnlen)6); sgbsv_(&n, &kl, &ku, nrhs, &afb[1], & ldafb, &iwork[1], &x[1], &ldb, & info); /* Check error code from SGBSV . */ if (info != izero) { alaerh_(path, "SGBSV ", &info, &izero, " ", &n, &n, &kl, &ku, nrhs, &imat, &nfail, &nerrs, nout); } /* Reconstruct matrix from factors and */ /* compute residual. */ sgbt01_(&n, &n, &kl, &ku, &a[1], &lda, & afb[1], &ldafb, &iwork[1], &work[ 1], result); nt = 1; if (izero == 0) { /* Compute residual of the computed */ /* solution. */ slacpy_("Full", &n, nrhs, &b[1], &ldb, &work[1], &ldb); sgbt02_("No transpose", &n, &n, &kl, & ku, nrhs, &a[1], &lda, &x[1], &ldb, &work[1], &ldb, &result[ 1]); /* Check solution from generated exact */ /* solution. */ sget04_(&n, nrhs, &x[1], &ldb, &xact[ 1], &ldb, &rcondc, &result[2]) ; nt = 3; } /* Print information about the tests that did */ /* not pass the threshold. */ i__8 = nt; for (k = 1; k <= i__8; ++k) { if (result[k - 1] >= *thresh) { if (nfail == 0 && nerrs == 0) { aladhd_(nout, path); } io___65.ciunit = *nout; s_wsfe(&io___65); do_fio(&c__1, "SGBSV ", (ftnlen)6) ; do_fio(&c__1, (char *)&n, (ftnlen) sizeof(integer)); do_fio(&c__1, (char *)&kl, ( ftnlen)sizeof(integer)); do_fio(&c__1, (char *)&ku, ( 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; } /* L50: */ } nrun += nt; } /* --- Test SGBSVX --- */ if (! prefac) { i__8 = (kl << 1) + ku + 1; slaset_("Full", &i__8, &n, &c_b48, &c_b48, &afb[1], &ldafb); } slaset_("Full", &n, nrhs, &c_b48, &c_b48, &x[ 1], &ldb); if (iequed > 1 && n > 0) { /* Equilibrate the matrix if FACT = 'F' and */ /* EQUED = 'R', 'C', or 'B'. */ slaqgb_(&n, &n, &kl, &ku, &a[1], &lda, &s[ 1], &s[n + 1], &rowcnd, &colcnd, & amax, equed); } /* Solve the system and compute the condition */ /* number and error bounds using SGBSVX. */ s_copy(srnamc_1.srnamt, "SGBSVX", (ftnlen)32, (ftnlen)6); sgbsvx_(fact, trans, &n, &kl, &ku, nrhs, &a[1] , &lda, &afb[1], &ldafb, &iwork[1], equed, &s[1], &s[n + 1], &b[1], &ldb, &x[1], &ldb, &rcond, &rwork[1], & rwork[*nrhs + 1], &work[1], &iwork[n + 1], &info); /* Check the error code from SGBSVX. */ if (info != izero) { /* Writing concatenation */ i__11[0] = 1, a__1[0] = fact; i__11[1] = 1, a__1[1] = trans; s_cat(ch__1, a__1, i__11, &c__2, (ftnlen) 2); alaerh_(path, "SGBSVX", &info, &izero, ch__1, &n, &n, &kl, &ku, nrhs, & imat, &nfail, &nerrs, nout); } /* Compare WORK(1) from SGBSVX with the computed */ /* reciprocal pivot growth factor RPVGRW */ if (info != 0) { anrmpv = 0.f; i__8 = info; for (j = 1; j <= i__8; ++j) { /* Computing MAX */ i__6 = ku + 2 - j; /* Computing MIN */ i__9 = n + ku + 1 - j, i__10 = kl + ku + 1; i__7 = min(i__9,i__10); for (i__ = max(i__6,1); i__ <= i__7; ++i__) { /* Computing MAX */ r__2 = anrmpv, r__3 = (r__1 = a[ i__ + (j - 1) * lda], dabs(r__1)); anrmpv = dmax(r__2,r__3); /* L60: */ } /* L70: */ } /* Computing MIN */ i__7 = info - 1, i__6 = kl + ku; i__8 = min(i__7,i__6); /* Computing MAX */ i__9 = 1, i__10 = kl + ku + 2 - info; rpvgrw = slantb_("M", "U", "N", &info, & i__8, &afb[max(i__9, i__10)], & ldafb, &work[1]); if (rpvgrw == 0.f) { rpvgrw = 1.f; } else { rpvgrw = anrmpv / rpvgrw; } } else { i__8 = kl + ku; rpvgrw = slantb_("M", "U", "N", &n, &i__8, &afb[1], &ldafb, &work[1]); if (rpvgrw == 0.f) { rpvgrw = 1.f; } else { rpvgrw = slangb_("M", &n, &kl, &ku, & a[1], &lda, &work[1]) / rpvgrw; } } result[6] = (r__1 = rpvgrw - work[1], dabs( r__1)) / dmax(work[1],rpvgrw) / slamch_("E"); if (! prefac) { /* Reconstruct matrix from factors and */ /* compute residual. */ sgbt01_(&n, &n, &kl, &ku, &a[1], &lda, & afb[1], &ldafb, &iwork[1], &work[ 1], result); k1 = 1; } else { k1 = 2; } if (info == 0) { trfcon = FALSE_; /* Compute residual of the computed solution. */ slacpy_("Full", &n, nrhs, &bsav[1], &ldb, &work[1], &ldb); sgbt02_(trans, &n, &n, &kl, &ku, nrhs, & asav[1], &lda, &x[1], &ldb, &work[ 1], &ldb, &result[1]); /* Check solution from generated exact */ /* solution. */ if (nofact || prefac && lsame_(equed, "N")) { sget04_(&n, nrhs, &x[1], &ldb, &xact[ 1], &ldb, &rcondc, &result[2]) ; } else { if (itran == 1) { roldc = roldo; } else { roldc = roldi; } sget04_(&n, nrhs, &x[1], &ldb, &xact[ 1], &ldb, &roldc, &result[2]); } /* Check the error bounds from iterative */ /* refinement. */ sgbt05_(trans, &n, &kl, &ku, nrhs, &asav[ 1], &lda, &b[1], &ldb, &x[1], & ldb, &xact[1], &ldb, &rwork[1], & rwork[*nrhs + 1], &result[3]); } else { trfcon = TRUE_; } /* Compare RCOND from SGBSVX with the computed */ /* value in RCONDC. */ result[5] = sget06_(&rcond, &rcondc); /* Print information about the tests that did */ /* not pass the threshold. */ if (! trfcon) { for (k = k1; k <= 7; ++k) { if (result[k - 1] >= *thresh) { if (nfail == 0 && nerrs == 0) { aladhd_(nout, path); } if (prefac) { io___72.ciunit = *nout; s_wsfe(&io___72); do_fio(&c__1, "SGBSVX", (ftnlen)6); do_fio(&c__1, fact, (ftnlen)1); do_fio(&c__1, trans, (ftnlen)1); do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer)); do_fio(&c__1, (char *)&kl, (ftnlen)sizeof(integer)); do_fio(&c__1, (char *)&ku, (ftnlen)sizeof(integer)); do_fio(&c__1, equed, (ftnlen)1); 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(); } else { io___73.ciunit = *nout; s_wsfe(&io___73); do_fio(&c__1, "SGBSVX", (ftnlen)6); do_fio(&c__1, fact, (ftnlen)1); do_fio(&c__1, trans, (ftnlen)1); do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer)); do_fio(&c__1, (char *)&kl, (ftnlen)sizeof(integer)); do_fio(&c__1, (char *)&ku, (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; } /* L80: */ } nrun = nrun + 7 - k1; } else { if (result[0] >= *thresh && ! prefac) { if (nfail == 0 && nerrs == 0) { aladhd_(nout, path); } if (prefac) { io___74.ciunit = *nout; s_wsfe(&io___74); do_fio(&c__1, "SGBSVX", (ftnlen)6) ; do_fio(&c__1, fact, (ftnlen)1); do_fio(&c__1, trans, (ftnlen)1); do_fio(&c__1, (char *)&n, (ftnlen) sizeof(integer)); do_fio(&c__1, (char *)&kl, ( ftnlen)sizeof(integer)); do_fio(&c__1, (char *)&ku, ( ftnlen)sizeof(integer)); do_fio(&c__1, equed, (ftnlen)1); do_fio(&c__1, (char *)&imat, ( ftnlen)sizeof(integer)); do_fio(&c__1, (char *)&c__1, ( ftnlen)sizeof(integer)); do_fio(&c__1, (char *)&result[0], (ftnlen)sizeof(real)); e_wsfe(); } else { io___75.ciunit = *nout; s_wsfe(&io___75); do_fio(&c__1, "SGBSVX", (ftnlen)6) ; do_fio(&c__1, fact, (ftnlen)1); do_fio(&c__1, trans, (ftnlen)1); do_fio(&c__1, (char *)&n, (ftnlen) sizeof(integer)); do_fio(&c__1, (char *)&kl, ( ftnlen)sizeof(integer)); do_fio(&c__1, (char *)&ku, ( ftnlen)sizeof(integer)); do_fio(&c__1, (char *)&imat, ( ftnlen)sizeof(integer)); do_fio(&c__1, (char *)&c__1, ( ftnlen)sizeof(integer)); do_fio(&c__1, (char *)&result[0], (ftnlen)sizeof(real)); e_wsfe(); } ++nfail; ++nrun; } if (result[5] >= *thresh) { if (nfail == 0 && nerrs == 0) { aladhd_(nout, path); } if (prefac) { io___76.ciunit = *nout; s_wsfe(&io___76); do_fio(&c__1, "SGBSVX", (ftnlen)6) ; do_fio(&c__1, fact, (ftnlen)1); do_fio(&c__1, trans, (ftnlen)1); do_fio(&c__1, (char *)&n, (ftnlen) sizeof(integer)); do_fio(&c__1, (char *)&kl, ( ftnlen)sizeof(integer)); do_fio(&c__1, (char *)&ku, ( ftnlen)sizeof(integer)); do_fio(&c__1, equed, (ftnlen)1); 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(); } else { io___77.ciunit = *nout; s_wsfe(&io___77); do_fio(&c__1, "SGBSVX", (ftnlen)6) ; do_fio(&c__1, fact, (ftnlen)1); do_fio(&c__1, trans, (ftnlen)1); do_fio(&c__1, (char *)&n, (ftnlen) sizeof(integer)); do_fio(&c__1, (char *)&kl, ( ftnlen)sizeof(integer)); do_fio(&c__1, (char *)&ku, ( 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; } if (result[6] >= *thresh) { if (nfail == 0 && nerrs == 0) { aladhd_(nout, path); } if (prefac) { io___78.ciunit = *nout; s_wsfe(&io___78); do_fio(&c__1, "SGBSVX", (ftnlen)6) ; do_fio(&c__1, fact, (ftnlen)1); do_fio(&c__1, trans, (ftnlen)1); do_fio(&c__1, (char *)&n, (ftnlen) sizeof(integer)); do_fio(&c__1, (char *)&kl, ( ftnlen)sizeof(integer)); do_fio(&c__1, (char *)&ku, ( ftnlen)sizeof(integer)); do_fio(&c__1, equed, (ftnlen)1); 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(); } else { io___79.ciunit = *nout; s_wsfe(&io___79); do_fio(&c__1, "SGBSVX", (ftnlen)6) ; do_fio(&c__1, fact, (ftnlen)1); do_fio(&c__1, trans, (ftnlen)1); do_fio(&c__1, (char *)&n, (ftnlen) sizeof(integer)); do_fio(&c__1, (char *)&kl, ( ftnlen)sizeof(integer)); do_fio(&c__1, (char *)&ku, ( 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; ++nrun; } } /* L90: */ } L100: ; } /* L110: */ } L120: ; } L130: ; } /* L140: */ } /* L150: */ } /* Print a summary of the results. */ alasvm_(path, nout, &nfail, &nrun, &nerrs); return 0; /* End of SDRVGB */ } /* sdrvgb_ */
/* Subroutine */ int stbt02_(char *uplo, char *trans, char *diag, integer *n, integer *kd, integer *nrhs, real *ab, integer *ldab, real *x, integer *ldx, real *b, integer *ldb, real *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; /* Local variables */ integer j; real eps; extern logical lsame_(char *, char *); real anorm, bnorm; extern doublereal sasum_(integer *, real *, integer *); extern /* Subroutine */ int stbmv_(char *, char *, char *, integer *, integer *, real *, integer *, real *, integer *), scopy_(integer *, real *, integer *, real *, integer *); real xnorm; extern /* Subroutine */ int saxpy_(integer *, real *, real *, integer *, real *, integer *); extern doublereal slamch_(char *), slantb_(char *, char *, char *, integer *, integer *, real *, integer *, real *); /* -- LAPACK test routine (version 3.1) -- */ /* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ /* November 2006 */ /* .. Scalar Arguments .. */ /* .. */ /* .. Array Arguments .. */ /* .. */ /* Purpose */ /* ======= */ /* STBT02 computes the residual for the computed solution to a */ /* triangular system of linear equations A*x = b or A' *x = b when */ /* A is a triangular band matrix. Here A' is the 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 or A' 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'*x = b (Transpose) */ /* = 'C': A'*x = b (Conjugate transpose = 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) REAL 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) REAL 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) REAL 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) 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; /* 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 = slantb_("1", uplo, diag, n, kd, &ab[ab_offset], ldab, &work[1] ); } else { anorm = slantb_("I", uplo, diag, n, kd, &ab[ab_offset], ldab, &work[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) { scopy_(n, &x[j * x_dim1 + 1], &c__1, &work[1], &c__1); stbmv_(uplo, trans, diag, n, kd, &ab[ab_offset], ldab, &work[1], & c__1); saxpy_(n, &c_b10, &b[j * b_dim1 + 1], &c__1, &work[1], &c__1); bnorm = sasum_(n, &work[1], &c__1); xnorm = sasum_(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 STBT02 */ } /* stbt02_ */