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