00001 /* sgtsvx.f -- translated by f2c (version 20061008). 00002 You must link the resulting object file with libf2c: 00003 on Microsoft Windows system, link with libf2c.lib; 00004 on Linux or Unix systems, link with .../path/to/libf2c.a -lm 00005 or, if you install libf2c.a in a standard place, with -lf2c -lm 00006 -- in that order, at the end of the command line, as in 00007 cc *.o -lf2c -lm 00008 Source for libf2c is in /netlib/f2c/libf2c.zip, e.g., 00009 00010 http://www.netlib.org/f2c/libf2c.zip 00011 */ 00012 00013 #include "f2c.h" 00014 #include "blaswrap.h" 00015 00016 /* Table of constant values */ 00017 00018 static integer c__1 = 1; 00019 00020 /* Subroutine */ int sgtsvx_(char *fact, char *trans, integer *n, integer * 00021 nrhs, real *dl, real *d__, real *du, real *dlf, real *df, real *duf, 00022 real *du2, integer *ipiv, real *b, integer *ldb, real *x, integer * 00023 ldx, real *rcond, real *ferr, real *berr, real *work, integer *iwork, 00024 integer *info) 00025 { 00026 /* System generated locals */ 00027 integer b_dim1, b_offset, x_dim1, x_offset, i__1; 00028 00029 /* Local variables */ 00030 char norm[1]; 00031 extern logical lsame_(char *, char *); 00032 real anorm; 00033 extern /* Subroutine */ int scopy_(integer *, real *, integer *, real *, 00034 integer *); 00035 extern doublereal slamch_(char *); 00036 logical nofact; 00037 extern /* Subroutine */ int xerbla_(char *, integer *); 00038 extern doublereal slangt_(char *, integer *, real *, real *, real *); 00039 extern /* Subroutine */ int slacpy_(char *, integer *, integer *, real *, 00040 integer *, real *, integer *), sgtcon_(char *, integer *, 00041 real *, real *, real *, real *, integer *, real *, real *, real *, 00042 integer *, integer *); 00043 logical notran; 00044 extern /* Subroutine */ int sgtrfs_(char *, integer *, integer *, real *, 00045 real *, real *, real *, real *, real *, real *, integer *, real *, 00046 integer *, real *, integer *, real *, real *, real *, integer *, 00047 integer *), sgttrf_(integer *, real *, real *, real *, 00048 real *, integer *, integer *), sgttrs_(char *, integer *, integer 00049 *, real *, real *, real *, real *, integer *, real *, integer *, 00050 integer *); 00051 00052 00053 /* -- LAPACK routine (version 3.2) -- */ 00054 /* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ 00055 /* November 2006 */ 00056 00057 /* .. Scalar Arguments .. */ 00058 /* .. */ 00059 /* .. Array Arguments .. */ 00060 /* .. */ 00061 00062 /* Purpose */ 00063 /* ======= */ 00064 00065 /* SGTSVX uses the LU factorization to compute the solution to a real */ 00066 /* system of linear equations A * X = B or A**T * X = B, */ 00067 /* where A is a tridiagonal matrix of order N and X and B are N-by-NRHS */ 00068 /* matrices. */ 00069 00070 /* Error bounds on the solution and a condition estimate are also */ 00071 /* provided. */ 00072 00073 /* Description */ 00074 /* =========== */ 00075 00076 /* The following steps are performed: */ 00077 00078 /* 1. If FACT = 'N', the LU decomposition is used to factor the matrix A */ 00079 /* as A = L * U, where L is a product of permutation and unit lower */ 00080 /* bidiagonal matrices and U is upper triangular with nonzeros in */ 00081 /* only the main diagonal and first two superdiagonals. */ 00082 00083 /* 2. If some U(i,i)=0, so that U is exactly singular, then the routine */ 00084 /* returns with INFO = i. Otherwise, the factored form of A is used */ 00085 /* to estimate the condition number of the matrix A. If the */ 00086 /* reciprocal of the condition number is less than machine precision, */ 00087 /* INFO = N+1 is returned as a warning, but the routine still goes on */ 00088 /* to solve for X and compute error bounds as described below. */ 00089 00090 /* 3. The system of equations is solved for X using the factored form */ 00091 /* of A. */ 00092 00093 /* 4. Iterative refinement is applied to improve the computed solution */ 00094 /* matrix and calculate error bounds and backward error estimates */ 00095 /* for it. */ 00096 00097 /* Arguments */ 00098 /* ========= */ 00099 00100 /* FACT (input) CHARACTER*1 */ 00101 /* Specifies whether or not the factored form of A has been */ 00102 /* supplied on entry. */ 00103 /* = 'F': DLF, DF, DUF, DU2, and IPIV contain the factored */ 00104 /* form of A; DL, D, DU, DLF, DF, DUF, DU2 and IPIV */ 00105 /* will not be modified. */ 00106 /* = 'N': The matrix will be copied to DLF, DF, and DUF */ 00107 /* and factored. */ 00108 00109 /* TRANS (input) CHARACTER*1 */ 00110 /* Specifies the form of the system of equations: */ 00111 /* = 'N': A * X = B (No transpose) */ 00112 /* = 'T': A**T * X = B (Transpose) */ 00113 /* = 'C': A**H * X = B (Conjugate transpose = Transpose) */ 00114 00115 /* N (input) INTEGER */ 00116 /* The order of the matrix A. N >= 0. */ 00117 00118 /* NRHS (input) INTEGER */ 00119 /* The number of right hand sides, i.e., the number of columns */ 00120 /* of the matrix B. NRHS >= 0. */ 00121 00122 /* DL (input) REAL array, dimension (N-1) */ 00123 /* The (n-1) subdiagonal elements of A. */ 00124 00125 /* D (input) REAL array, dimension (N) */ 00126 /* The n diagonal elements of A. */ 00127 00128 /* DU (input) REAL array, dimension (N-1) */ 00129 /* The (n-1) superdiagonal elements of A. */ 00130 00131 /* DLF (input or output) REAL array, dimension (N-1) */ 00132 /* If FACT = 'F', then DLF is an input argument and on entry */ 00133 /* contains the (n-1) multipliers that define the matrix L from */ 00134 /* the LU factorization of A as computed by SGTTRF. */ 00135 00136 /* If FACT = 'N', then DLF is an output argument and on exit */ 00137 /* contains the (n-1) multipliers that define the matrix L from */ 00138 /* the LU factorization of A. */ 00139 00140 /* DF (input or output) REAL array, dimension (N) */ 00141 /* If FACT = 'F', then DF is an input argument and on entry */ 00142 /* contains the n diagonal elements of the upper triangular */ 00143 /* matrix U from the LU factorization of A. */ 00144 00145 /* If FACT = 'N', then DF is an output argument and on exit */ 00146 /* contains the n diagonal elements of the upper triangular */ 00147 /* matrix U from the LU factorization of A. */ 00148 00149 /* DUF (input or output) REAL array, dimension (N-1) */ 00150 /* If FACT = 'F', then DUF is an input argument and on entry */ 00151 /* contains the (n-1) elements of the first superdiagonal of U. */ 00152 00153 /* If FACT = 'N', then DUF is an output argument and on exit */ 00154 /* contains the (n-1) elements of the first superdiagonal of U. */ 00155 00156 /* DU2 (input or output) REAL array, dimension (N-2) */ 00157 /* If FACT = 'F', then DU2 is an input argument and on entry */ 00158 /* contains the (n-2) elements of the second superdiagonal of */ 00159 /* U. */ 00160 00161 /* If FACT = 'N', then DU2 is an output argument and on exit */ 00162 /* contains the (n-2) elements of the second superdiagonal of */ 00163 /* U. */ 00164 00165 /* IPIV (input or output) INTEGER array, dimension (N) */ 00166 /* If FACT = 'F', then IPIV is an input argument and on entry */ 00167 /* contains the pivot indices from the LU factorization of A as */ 00168 /* computed by SGTTRF. */ 00169 00170 /* If FACT = 'N', then IPIV is an output argument and on exit */ 00171 /* contains the pivot indices from the LU factorization of A; */ 00172 /* row i of the matrix was interchanged with row IPIV(i). */ 00173 /* IPIV(i) will always be either i or i+1; IPIV(i) = i indicates */ 00174 /* a row interchange was not required. */ 00175 00176 /* B (input) REAL array, dimension (LDB,NRHS) */ 00177 /* The N-by-NRHS right hand side matrix B. */ 00178 00179 /* LDB (input) INTEGER */ 00180 /* The leading dimension of the array B. LDB >= max(1,N). */ 00181 00182 /* X (output) REAL array, dimension (LDX,NRHS) */ 00183 /* If INFO = 0 or INFO = N+1, the N-by-NRHS solution matrix X. */ 00184 00185 /* LDX (input) INTEGER */ 00186 /* The leading dimension of the array X. LDX >= max(1,N). */ 00187 00188 /* RCOND (output) REAL */ 00189 /* The estimate of the reciprocal condition number of the matrix */ 00190 /* A. If RCOND is less than the machine precision (in */ 00191 /* particular, if RCOND = 0), the matrix is singular to working */ 00192 /* precision. This condition is indicated by a return code of */ 00193 /* INFO > 0. */ 00194 00195 /* FERR (output) REAL array, dimension (NRHS) */ 00196 /* The estimated forward error bound for each solution vector */ 00197 /* X(j) (the j-th column of the solution matrix X). */ 00198 /* If XTRUE is the true solution corresponding to X(j), FERR(j) */ 00199 /* is an estimated upper bound for the magnitude of the largest */ 00200 /* element in (X(j) - XTRUE) divided by the magnitude of the */ 00201 /* largest element in X(j). The estimate is as reliable as */ 00202 /* the estimate for RCOND, and is almost always a slight */ 00203 /* overestimate of the true error. */ 00204 00205 /* BERR (output) REAL array, dimension (NRHS) */ 00206 /* The componentwise relative backward error of each solution */ 00207 /* vector X(j) (i.e., the smallest relative change in */ 00208 /* any element of A or B that makes X(j) an exact solution). */ 00209 00210 /* WORK (workspace) REAL array, dimension (3*N) */ 00211 00212 /* IWORK (workspace) INTEGER array, dimension (N) */ 00213 00214 /* INFO (output) INTEGER */ 00215 /* = 0: successful exit */ 00216 /* < 0: if INFO = -i, the i-th argument had an illegal value */ 00217 /* > 0: if INFO = i, and i is */ 00218 /* <= N: U(i,i) is exactly zero. The factorization */ 00219 /* has not been completed unless i = N, but the */ 00220 /* factor U is exactly singular, so the solution */ 00221 /* and error bounds could not be computed. */ 00222 /* RCOND = 0 is returned. */ 00223 /* = N+1: U is nonsingular, but RCOND is less than machine */ 00224 /* precision, meaning that the matrix is singular */ 00225 /* to working precision. Nevertheless, the */ 00226 /* solution and error bounds are computed because */ 00227 /* there are a number of situations where the */ 00228 /* computed solution can be more accurate than the */ 00229 /* value of RCOND would suggest. */ 00230 00231 /* ===================================================================== */ 00232 00233 /* .. Parameters .. */ 00234 /* .. */ 00235 /* .. Local Scalars .. */ 00236 /* .. */ 00237 /* .. External Functions .. */ 00238 /* .. */ 00239 /* .. External Subroutines .. */ 00240 /* .. */ 00241 /* .. Intrinsic Functions .. */ 00242 /* .. */ 00243 /* .. Executable Statements .. */ 00244 00245 /* Parameter adjustments */ 00246 --dl; 00247 --d__; 00248 --du; 00249 --dlf; 00250 --df; 00251 --duf; 00252 --du2; 00253 --ipiv; 00254 b_dim1 = *ldb; 00255 b_offset = 1 + b_dim1; 00256 b -= b_offset; 00257 x_dim1 = *ldx; 00258 x_offset = 1 + x_dim1; 00259 x -= x_offset; 00260 --ferr; 00261 --berr; 00262 --work; 00263 --iwork; 00264 00265 /* Function Body */ 00266 *info = 0; 00267 nofact = lsame_(fact, "N"); 00268 notran = lsame_(trans, "N"); 00269 if (! nofact && ! lsame_(fact, "F")) { 00270 *info = -1; 00271 } else if (! notran && ! lsame_(trans, "T") && ! 00272 lsame_(trans, "C")) { 00273 *info = -2; 00274 } else if (*n < 0) { 00275 *info = -3; 00276 } else if (*nrhs < 0) { 00277 *info = -4; 00278 } else if (*ldb < max(1,*n)) { 00279 *info = -14; 00280 } else if (*ldx < max(1,*n)) { 00281 *info = -16; 00282 } 00283 if (*info != 0) { 00284 i__1 = -(*info); 00285 xerbla_("SGTSVX", &i__1); 00286 return 0; 00287 } 00288 00289 if (nofact) { 00290 00291 /* Compute the LU factorization of A. */ 00292 00293 scopy_(n, &d__[1], &c__1, &df[1], &c__1); 00294 if (*n > 1) { 00295 i__1 = *n - 1; 00296 scopy_(&i__1, &dl[1], &c__1, &dlf[1], &c__1); 00297 i__1 = *n - 1; 00298 scopy_(&i__1, &du[1], &c__1, &duf[1], &c__1); 00299 } 00300 sgttrf_(n, &dlf[1], &df[1], &duf[1], &du2[1], &ipiv[1], info); 00301 00302 /* Return if INFO is non-zero. */ 00303 00304 if (*info > 0) { 00305 *rcond = 0.f; 00306 return 0; 00307 } 00308 } 00309 00310 /* Compute the norm of the matrix A. */ 00311 00312 if (notran) { 00313 *(unsigned char *)norm = '1'; 00314 } else { 00315 *(unsigned char *)norm = 'I'; 00316 } 00317 anorm = slangt_(norm, n, &dl[1], &d__[1], &du[1]); 00318 00319 /* Compute the reciprocal of the condition number of A. */ 00320 00321 sgtcon_(norm, n, &dlf[1], &df[1], &duf[1], &du2[1], &ipiv[1], &anorm, 00322 rcond, &work[1], &iwork[1], info); 00323 00324 /* Compute the solution vectors X. */ 00325 00326 slacpy_("Full", n, nrhs, &b[b_offset], ldb, &x[x_offset], ldx); 00327 sgttrs_(trans, n, nrhs, &dlf[1], &df[1], &duf[1], &du2[1], &ipiv[1], &x[ 00328 x_offset], ldx, info); 00329 00330 /* Use iterative refinement to improve the computed solutions and */ 00331 /* compute error bounds and backward error estimates for them. */ 00332 00333 sgtrfs_(trans, n, nrhs, &dl[1], &d__[1], &du[1], &dlf[1], &df[1], &duf[1], 00334 &du2[1], &ipiv[1], &b[b_offset], ldb, &x[x_offset], ldx, &ferr[1] 00335 , &berr[1], &work[1], &iwork[1], info); 00336 00337 /* Set INFO = N+1 if the matrix is singular to working precision. */ 00338 00339 if (*rcond < slamch_("Epsilon")) { 00340 *info = *n + 1; 00341 } 00342 00343 return 0; 00344 00345 /* End of SGTSVX */ 00346 00347 } /* sgtsvx_ */