You can not select more than 25 topics Topics must start with a chinese character,a letter or number, can include dashes ('-') and can be up to 35 characters long.

dgbrfsx.f 29 kB

123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102103104105106107108109110111112113114115116117118119120121122123124125126127128129130131132133134135136137138139140141142143144145146147148149150151152153154155156157158159160161162163164165166167168169170171172173174175176177178179180181182183184185186187188189190191192193194195196197198199200201202203204205206207208209210211212213214215216217218219220221222223224225226227228229230231232233234235236237238239240241242243244245246247248249250251252253254255256257258259260261262263264265266267268269270271272273274275276277278279280281282283284285286287288289290291292293294295296297298299300301302303304305306307308309310311312313314315316317318319320321322323324325326327328329330331332333334335336337338339340341342343344345346347348349350351352353354355356357358359360361362363364365366367368369370371372373374375376377378379380381382383384385386387388389390391392393394395396397398399400401402403404405406407408409410411412413414415416417418419420421422423424425426427428429430431432433434435436437438439440441442443444445446447448449450451452453454455456457458459460461462463464465466467468469470471472473474475476477478479480481482483484485486487488489490491492493494495496497498499500501502503504505506507508509510511512513514515516517518519520521522523524525526527528529530531532533534535536537538539540541542543544545546547548549550551552553554555556557558559560561562563564565566567568569570571572573574575576577578579580581582583584585586587588589590591592593594595596597598599600601602603604605606607608609610611612613614615616617618619620621622623624625626627628629630631632633634635636637638639640641642643644645646647648649650651652653654655656657658659660661662663664665666667668669670671672673674675676677678679680681682683684685686687688689690691692693694695696697698699700701702703704705706707708709710711712713714715716717718719720721722723724725726727728729730731732733734735736737738739740741742743744745746747748749750751752753754755756757758759760761762
  1. *> \brief \b DGBRFSX
  2. *
  3. * =========== DOCUMENTATION ===========
  4. *
  5. * Online html documentation available at
  6. * http://www.netlib.org/lapack/explore-html/
  7. *
  8. *> \htmlonly
  9. *> Download DGBRFSX + dependencies
  10. *> <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/dgbrfsx.f">
  11. *> [TGZ]</a>
  12. *> <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/dgbrfsx.f">
  13. *> [ZIP]</a>
  14. *> <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/dgbrfsx.f">
  15. *> [TXT]</a>
  16. *> \endhtmlonly
  17. *
  18. * Definition:
  19. * ===========
  20. *
  21. * SUBROUTINE DGBRFSX( TRANS, EQUED, N, KL, KU, NRHS, AB, LDAB, AFB,
  22. * LDAFB, IPIV, R, C, B, LDB, X, LDX, RCOND,
  23. * BERR, N_ERR_BNDS, ERR_BNDS_NORM,
  24. * ERR_BNDS_COMP, NPARAMS, PARAMS, WORK, IWORK,
  25. * INFO )
  26. *
  27. * .. Scalar Arguments ..
  28. * CHARACTER TRANS, EQUED
  29. * INTEGER INFO, LDAB, LDAFB, LDB, LDX, N, KL, KU, NRHS,
  30. * $ NPARAMS, N_ERR_BNDS
  31. * DOUBLE PRECISION RCOND
  32. * ..
  33. * .. Array Arguments ..
  34. * INTEGER IPIV( * ), IWORK( * )
  35. * DOUBLE PRECISION AB( LDAB, * ), AFB( LDAFB, * ), B( LDB, * ),
  36. * $ X( LDX , * ),WORK( * )
  37. * DOUBLE PRECISION R( * ), C( * ), PARAMS( * ), BERR( * ),
  38. * $ ERR_BNDS_NORM( NRHS, * ),
  39. * $ ERR_BNDS_COMP( NRHS, * )
  40. * ..
  41. *
  42. *
  43. *> \par Purpose:
  44. * =============
  45. *>
  46. *> \verbatim
  47. *>
  48. *> DGBRFSX improves the computed solution to a system of linear
  49. *> equations and provides error bounds and backward error estimates
  50. *> for the solution. In addition to normwise error bound, the code
  51. *> provides maximum componentwise error bound if possible. See
  52. *> comments for ERR_BNDS_NORM and ERR_BNDS_COMP for details of the
  53. *> error bounds.
  54. *>
  55. *> The original system of linear equations may have been equilibrated
  56. *> before calling this routine, as described by arguments EQUED, R
  57. *> and C below. In this case, the solution and error bounds returned
  58. *> are for the original unequilibrated system.
  59. *> \endverbatim
  60. *
  61. * Arguments:
  62. * ==========
  63. *
  64. *> \verbatim
  65. *> Some optional parameters are bundled in the PARAMS array. These
  66. *> settings determine how refinement is performed, but often the
  67. *> defaults are acceptable. If the defaults are acceptable, users
  68. *> can pass NPARAMS = 0 which prevents the source code from accessing
  69. *> the PARAMS argument.
  70. *> \endverbatim
  71. *>
  72. *> \param[in] TRANS
  73. *> \verbatim
  74. *> TRANS is CHARACTER*1
  75. *> Specifies the form of the system of equations:
  76. *> = 'N': A * X = B (No transpose)
  77. *> = 'T': A**T * X = B (Transpose)
  78. *> = 'C': A**H * X = B (Conjugate transpose = Transpose)
  79. *> \endverbatim
  80. *>
  81. *> \param[in] EQUED
  82. *> \verbatim
  83. *> EQUED is CHARACTER*1
  84. *> Specifies the form of equilibration that was done to A
  85. *> before calling this routine. This is needed to compute
  86. *> the solution and error bounds correctly.
  87. *> = 'N': No equilibration
  88. *> = 'R': Row equilibration, i.e., A has been premultiplied by
  89. *> diag(R).
  90. *> = 'C': Column equilibration, i.e., A has been postmultiplied
  91. *> by diag(C).
  92. *> = 'B': Both row and column equilibration, i.e., A has been
  93. *> replaced by diag(R) * A * diag(C).
  94. *> The right hand side B has been changed accordingly.
  95. *> \endverbatim
  96. *>
  97. *> \param[in] N
  98. *> \verbatim
  99. *> N is INTEGER
  100. *> The order of the matrix A. N >= 0.
  101. *> \endverbatim
  102. *>
  103. *> \param[in] KL
  104. *> \verbatim
  105. *> KL is INTEGER
  106. *> The number of subdiagonals within the band of A. KL >= 0.
  107. *> \endverbatim
  108. *>
  109. *> \param[in] KU
  110. *> \verbatim
  111. *> KU is INTEGER
  112. *> The number of superdiagonals within the band of A. KU >= 0.
  113. *> \endverbatim
  114. *>
  115. *> \param[in] NRHS
  116. *> \verbatim
  117. *> NRHS is INTEGER
  118. *> The number of right hand sides, i.e., the number of columns
  119. *> of the matrices B and X. NRHS >= 0.
  120. *> \endverbatim
  121. *>
  122. *> \param[in] AB
  123. *> \verbatim
  124. *> AB is DOUBLE PRECISION array, dimension (LDAB,N)
  125. *> The original band matrix A, stored in rows 1 to KL+KU+1.
  126. *> The j-th column of A is stored in the j-th column of the
  127. *> array AB as follows:
  128. *> AB(ku+1+i-j,j) = A(i,j) for max(1,j-ku)<=i<=min(n,j+kl).
  129. *> \endverbatim
  130. *>
  131. *> \param[in] LDAB
  132. *> \verbatim
  133. *> LDAB is INTEGER
  134. *> The leading dimension of the array AB. LDAB >= KL+KU+1.
  135. *> \endverbatim
  136. *>
  137. *> \param[in] AFB
  138. *> \verbatim
  139. *> AFB is DOUBLE PRECISION array, dimension (LDAFB,N)
  140. *> Details of the LU factorization of the band matrix A, as
  141. *> computed by DGBTRF. U is stored as an upper triangular band
  142. *> matrix with KL+KU superdiagonals in rows 1 to KL+KU+1, and
  143. *> the multipliers used during the factorization are stored in
  144. *> rows KL+KU+2 to 2*KL+KU+1.
  145. *> \endverbatim
  146. *>
  147. *> \param[in] LDAFB
  148. *> \verbatim
  149. *> LDAFB is INTEGER
  150. *> The leading dimension of the array AFB. LDAFB >= 2*KL*KU+1.
  151. *> \endverbatim
  152. *>
  153. *> \param[in] IPIV
  154. *> \verbatim
  155. *> IPIV is INTEGER array, dimension (N)
  156. *> The pivot indices from DGETRF; for 1<=i<=N, row i of the
  157. *> matrix was interchanged with row IPIV(i).
  158. *> \endverbatim
  159. *>
  160. *> \param[in,out] R
  161. *> \verbatim
  162. *> R is DOUBLE PRECISION array, dimension (N)
  163. *> The row scale factors for A. If EQUED = 'R' or 'B', A is
  164. *> multiplied on the left by diag(R); if EQUED = 'N' or 'C', R
  165. *> is not accessed. R is an input argument if FACT = 'F';
  166. *> otherwise, R is an output argument. If FACT = 'F' and
  167. *> EQUED = 'R' or 'B', each element of R must be positive.
  168. *> If R is output, each element of R is a power of the radix.
  169. *> If R is input, each element of R should be a power of the radix
  170. *> to ensure a reliable solution and error estimates. Scaling by
  171. *> powers of the radix does not cause rounding errors unless the
  172. *> result underflows or overflows. Rounding errors during scaling
  173. *> lead to refining with a matrix that is not equivalent to the
  174. *> input matrix, producing error estimates that may not be
  175. *> reliable.
  176. *> \endverbatim
  177. *>
  178. *> \param[in,out] C
  179. *> \verbatim
  180. *> C is DOUBLE PRECISION array, dimension (N)
  181. *> The column scale factors for A. If EQUED = 'C' or 'B', A is
  182. *> multiplied on the right by diag(C); if EQUED = 'N' or 'R', C
  183. *> is not accessed. C is an input argument if FACT = 'F';
  184. *> otherwise, C is an output argument. If FACT = 'F' and
  185. *> EQUED = 'C' or 'B', each element of C must be positive.
  186. *> If C is output, each element of C is a power of the radix.
  187. *> If C is input, each element of C should be a power of the radix
  188. *> to ensure a reliable solution and error estimates. Scaling by
  189. *> powers of the radix does not cause rounding errors unless the
  190. *> result underflows or overflows. Rounding errors during scaling
  191. *> lead to refining with a matrix that is not equivalent to the
  192. *> input matrix, producing error estimates that may not be
  193. *> reliable.
  194. *> \endverbatim
  195. *>
  196. *> \param[in] B
  197. *> \verbatim
  198. *> B is DOUBLE PRECISION array, dimension (LDB,NRHS)
  199. *> The right hand side matrix B.
  200. *> \endverbatim
  201. *>
  202. *> \param[in] LDB
  203. *> \verbatim
  204. *> LDB is INTEGER
  205. *> The leading dimension of the array B. LDB >= max(1,N).
  206. *> \endverbatim
  207. *>
  208. *> \param[in,out] X
  209. *> \verbatim
  210. *> X is DOUBLE PRECISION array, dimension (LDX,NRHS)
  211. *> On entry, the solution matrix X, as computed by DGETRS.
  212. *> On exit, the improved solution matrix X.
  213. *> \endverbatim
  214. *>
  215. *> \param[in] LDX
  216. *> \verbatim
  217. *> LDX is INTEGER
  218. *> The leading dimension of the array X. LDX >= max(1,N).
  219. *> \endverbatim
  220. *>
  221. *> \param[out] RCOND
  222. *> \verbatim
  223. *> RCOND is DOUBLE PRECISION
  224. *> Reciprocal scaled condition number. This is an estimate of the
  225. *> reciprocal Skeel condition number of the matrix A after
  226. *> equilibration (if done). If this is less than the machine
  227. *> precision (in particular, if it is zero), the matrix is singular
  228. *> to working precision. Note that the error may still be small even
  229. *> if this number is very small and the matrix appears ill-
  230. *> conditioned.
  231. *> \endverbatim
  232. *>
  233. *> \param[out] BERR
  234. *> \verbatim
  235. *> BERR is DOUBLE PRECISION array, dimension (NRHS)
  236. *> Componentwise relative backward error. This is the
  237. *> componentwise relative backward error of each solution vector X(j)
  238. *> (i.e., the smallest relative change in any element of A or B that
  239. *> makes X(j) an exact solution).
  240. *> \endverbatim
  241. *>
  242. *> \param[in] N_ERR_BNDS
  243. *> \verbatim
  244. *> N_ERR_BNDS is INTEGER
  245. *> Number of error bounds to return for each right hand side
  246. *> and each type (normwise or componentwise). See ERR_BNDS_NORM and
  247. *> ERR_BNDS_COMP below.
  248. *> \endverbatim
  249. *>
  250. *> \param[out] ERR_BNDS_NORM
  251. *> \verbatim
  252. *> ERR_BNDS_NORM is DOUBLE PRECISION array, dimension (NRHS, N_ERR_BNDS)
  253. *> For each right-hand side, this array contains information about
  254. *> various error bounds and condition numbers corresponding to the
  255. *> normwise relative error, which is defined as follows:
  256. *>
  257. *> Normwise relative error in the ith solution vector:
  258. *> max_j (abs(XTRUE(j,i) - X(j,i)))
  259. *> ------------------------------
  260. *> max_j abs(X(j,i))
  261. *>
  262. *> The array is indexed by the type of error information as described
  263. *> below. There currently are up to three pieces of information
  264. *> returned.
  265. *>
  266. *> The first index in ERR_BNDS_NORM(i,:) corresponds to the ith
  267. *> right-hand side.
  268. *>
  269. *> The second index in ERR_BNDS_NORM(:,err) contains the following
  270. *> three fields:
  271. *> err = 1 "Trust/don't trust" boolean. Trust the answer if the
  272. *> reciprocal condition number is less than the threshold
  273. *> sqrt(n) * dlamch('Epsilon').
  274. *>
  275. *> err = 2 "Guaranteed" error bound: The estimated forward error,
  276. *> almost certainly within a factor of 10 of the true error
  277. *> so long as the next entry is greater than the threshold
  278. *> sqrt(n) * dlamch('Epsilon'). This error bound should only
  279. *> be trusted if the previous boolean is true.
  280. *>
  281. *> err = 3 Reciprocal condition number: Estimated normwise
  282. *> reciprocal condition number. Compared with the threshold
  283. *> sqrt(n) * dlamch('Epsilon') to determine if the error
  284. *> estimate is "guaranteed". These reciprocal condition
  285. *> numbers are 1 / (norm(Z^{-1},inf) * norm(Z,inf)) for some
  286. *> appropriately scaled matrix Z.
  287. *> Let Z = S*A, where S scales each row by a power of the
  288. *> radix so all absolute row sums of Z are approximately 1.
  289. *>
  290. *> See Lapack Working Note 165 for further details and extra
  291. *> cautions.
  292. *> \endverbatim
  293. *>
  294. *> \param[out] ERR_BNDS_COMP
  295. *> \verbatim
  296. *> ERR_BNDS_COMP is DOUBLE PRECISION array, dimension (NRHS, N_ERR_BNDS)
  297. *> For each right-hand side, this array contains information about
  298. *> various error bounds and condition numbers corresponding to the
  299. *> componentwise relative error, which is defined as follows:
  300. *>
  301. *> Componentwise relative error in the ith solution vector:
  302. *> abs(XTRUE(j,i) - X(j,i))
  303. *> max_j ----------------------
  304. *> abs(X(j,i))
  305. *>
  306. *> The array is indexed by the right-hand side i (on which the
  307. *> componentwise relative error depends), and the type of error
  308. *> information as described below. There currently are up to three
  309. *> pieces of information returned for each right-hand side. If
  310. *> componentwise accuracy is not requested (PARAMS(3) = 0.0), then
  311. *> ERR_BNDS_COMP is not accessed. If N_ERR_BNDS < 3, then at most
  312. *> the first (:,N_ERR_BNDS) entries are returned.
  313. *>
  314. *> The first index in ERR_BNDS_COMP(i,:) corresponds to the ith
  315. *> right-hand side.
  316. *>
  317. *> The second index in ERR_BNDS_COMP(:,err) contains the following
  318. *> three fields:
  319. *> err = 1 "Trust/don't trust" boolean. Trust the answer if the
  320. *> reciprocal condition number is less than the threshold
  321. *> sqrt(n) * dlamch('Epsilon').
  322. *>
  323. *> err = 2 "Guaranteed" error bound: The estimated forward error,
  324. *> almost certainly within a factor of 10 of the true error
  325. *> so long as the next entry is greater than the threshold
  326. *> sqrt(n) * dlamch('Epsilon'). This error bound should only
  327. *> be trusted if the previous boolean is true.
  328. *>
  329. *> err = 3 Reciprocal condition number: Estimated componentwise
  330. *> reciprocal condition number. Compared with the threshold
  331. *> sqrt(n) * dlamch('Epsilon') to determine if the error
  332. *> estimate is "guaranteed". These reciprocal condition
  333. *> numbers are 1 / (norm(Z^{-1},inf) * norm(Z,inf)) for some
  334. *> appropriately scaled matrix Z.
  335. *> Let Z = S*(A*diag(x)), where x is the solution for the
  336. *> current right-hand side and S scales each row of
  337. *> A*diag(x) by a power of the radix so all absolute row
  338. *> sums of Z are approximately 1.
  339. *>
  340. *> See Lapack Working Note 165 for further details and extra
  341. *> cautions.
  342. *> \endverbatim
  343. *>
  344. *> \param[in] NPARAMS
  345. *> \verbatim
  346. *> NPARAMS is INTEGER
  347. *> Specifies the number of parameters set in PARAMS. If <= 0, the
  348. *> PARAMS array is never referenced and default values are used.
  349. *> \endverbatim
  350. *>
  351. *> \param[in,out] PARAMS
  352. *> \verbatim
  353. *> PARAMS is DOUBLE PRECISION array, dimension (NPARAMS)
  354. *> Specifies algorithm parameters. If an entry is < 0.0, then
  355. *> that entry will be filled with default value used for that
  356. *> parameter. Only positions up to NPARAMS are accessed; defaults
  357. *> are used for higher-numbered parameters.
  358. *>
  359. *> PARAMS(LA_LINRX_ITREF_I = 1) : Whether to perform iterative
  360. *> refinement or not.
  361. *> Default: 1.0D+0
  362. *> = 0.0: No refinement is performed, and no error bounds are
  363. *> computed.
  364. *> = 1.0: Use the double-precision refinement algorithm,
  365. *> possibly with doubled-single computations if the
  366. *> compilation environment does not support DOUBLE
  367. *> PRECISION.
  368. *> (other values are reserved for future use)
  369. *>
  370. *> PARAMS(LA_LINRX_ITHRESH_I = 2) : Maximum number of residual
  371. *> computations allowed for refinement.
  372. *> Default: 10
  373. *> Aggressive: Set to 100 to permit convergence using approximate
  374. *> factorizations or factorizations other than LU. If
  375. *> the factorization uses a technique other than
  376. *> Gaussian elimination, the guarantees in
  377. *> err_bnds_norm and err_bnds_comp may no longer be
  378. *> trustworthy.
  379. *>
  380. *> PARAMS(LA_LINRX_CWISE_I = 3) : Flag determining if the code
  381. *> will attempt to find a solution with small componentwise
  382. *> relative error in the double-precision algorithm. Positive
  383. *> is true, 0.0 is false.
  384. *> Default: 1.0 (attempt componentwise convergence)
  385. *> \endverbatim
  386. *>
  387. *> \param[out] WORK
  388. *> \verbatim
  389. *> WORK is DOUBLE PRECISION array, dimension (4*N)
  390. *> \endverbatim
  391. *>
  392. *> \param[out] IWORK
  393. *> \verbatim
  394. *> IWORK is INTEGER array, dimension (N)
  395. *> \endverbatim
  396. *>
  397. *> \param[out] INFO
  398. *> \verbatim
  399. *> INFO is INTEGER
  400. *> = 0: Successful exit. The solution to every right-hand side is
  401. *> guaranteed.
  402. *> < 0: If INFO = -i, the i-th argument had an illegal value
  403. *> > 0 and <= N: U(INFO,INFO) is exactly zero. The factorization
  404. *> has been completed, but the factor U is exactly singular, so
  405. *> the solution and error bounds could not be computed. RCOND = 0
  406. *> is returned.
  407. *> = N+J: The solution corresponding to the Jth right-hand side is
  408. *> not guaranteed. The solutions corresponding to other right-
  409. *> hand sides K with K > J may not be guaranteed as well, but
  410. *> only the first such right-hand side is reported. If a small
  411. *> componentwise error is not requested (PARAMS(3) = 0.0) then
  412. *> the Jth right-hand side is the first with a normwise error
  413. *> bound that is not guaranteed (the smallest J such
  414. *> that ERR_BNDS_NORM(J,1) = 0.0). By default (PARAMS(3) = 1.0)
  415. *> the Jth right-hand side is the first with either a normwise or
  416. *> componentwise error bound that is not guaranteed (the smallest
  417. *> J such that either ERR_BNDS_NORM(J,1) = 0.0 or
  418. *> ERR_BNDS_COMP(J,1) = 0.0). See the definition of
  419. *> ERR_BNDS_NORM(:,1) and ERR_BNDS_COMP(:,1). To get information
  420. *> about all of the right-hand sides check ERR_BNDS_NORM or
  421. *> ERR_BNDS_COMP.
  422. *> \endverbatim
  423. *
  424. * Authors:
  425. * ========
  426. *
  427. *> \author Univ. of Tennessee
  428. *> \author Univ. of California Berkeley
  429. *> \author Univ. of Colorado Denver
  430. *> \author NAG Ltd.
  431. *
  432. *> \ingroup doubleGBcomputational
  433. *
  434. * =====================================================================
  435. SUBROUTINE DGBRFSX( TRANS, EQUED, N, KL, KU, NRHS, AB, LDAB, AFB,
  436. $ LDAFB, IPIV, R, C, B, LDB, X, LDX, RCOND,
  437. $ BERR, N_ERR_BNDS, ERR_BNDS_NORM,
  438. $ ERR_BNDS_COMP, NPARAMS, PARAMS, WORK, IWORK,
  439. $ INFO )
  440. *
  441. * -- LAPACK computational routine --
  442. * -- LAPACK is a software package provided by Univ. of Tennessee, --
  443. * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
  444. *
  445. * .. Scalar Arguments ..
  446. CHARACTER TRANS, EQUED
  447. INTEGER INFO, LDAB, LDAFB, LDB, LDX, N, KL, KU, NRHS,
  448. $ NPARAMS, N_ERR_BNDS
  449. DOUBLE PRECISION RCOND
  450. * ..
  451. * .. Array Arguments ..
  452. INTEGER IPIV( * ), IWORK( * )
  453. DOUBLE PRECISION AB( LDAB, * ), AFB( LDAFB, * ), B( LDB, * ),
  454. $ X( LDX , * ),WORK( * )
  455. DOUBLE PRECISION R( * ), C( * ), PARAMS( * ), BERR( * ),
  456. $ ERR_BNDS_NORM( NRHS, * ),
  457. $ ERR_BNDS_COMP( NRHS, * )
  458. * ..
  459. *
  460. * ==================================================================
  461. *
  462. * .. Parameters ..
  463. DOUBLE PRECISION ZERO, ONE
  464. PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 )
  465. DOUBLE PRECISION ITREF_DEFAULT, ITHRESH_DEFAULT
  466. DOUBLE PRECISION COMPONENTWISE_DEFAULT, RTHRESH_DEFAULT
  467. DOUBLE PRECISION DZTHRESH_DEFAULT
  468. PARAMETER ( ITREF_DEFAULT = 1.0D+0 )
  469. PARAMETER ( ITHRESH_DEFAULT = 10.0D+0 )
  470. PARAMETER ( COMPONENTWISE_DEFAULT = 1.0D+0 )
  471. PARAMETER ( RTHRESH_DEFAULT = 0.5D+0 )
  472. PARAMETER ( DZTHRESH_DEFAULT = 0.25D+0 )
  473. INTEGER LA_LINRX_ITREF_I, LA_LINRX_ITHRESH_I,
  474. $ LA_LINRX_CWISE_I
  475. PARAMETER ( LA_LINRX_ITREF_I = 1,
  476. $ LA_LINRX_ITHRESH_I = 2 )
  477. PARAMETER ( LA_LINRX_CWISE_I = 3 )
  478. INTEGER LA_LINRX_TRUST_I, LA_LINRX_ERR_I,
  479. $ LA_LINRX_RCOND_I
  480. PARAMETER ( LA_LINRX_TRUST_I = 1, LA_LINRX_ERR_I = 2 )
  481. PARAMETER ( LA_LINRX_RCOND_I = 3 )
  482. * ..
  483. * .. Local Scalars ..
  484. CHARACTER(1) NORM
  485. LOGICAL ROWEQU, COLEQU, NOTRAN
  486. INTEGER J, TRANS_TYPE, PREC_TYPE, REF_TYPE
  487. INTEGER N_NORMS
  488. DOUBLE PRECISION ANORM, RCOND_TMP
  489. DOUBLE PRECISION ILLRCOND_THRESH, ERR_LBND, CWISE_WRONG
  490. LOGICAL IGNORE_CWISE
  491. INTEGER ITHRESH
  492. DOUBLE PRECISION RTHRESH, UNSTABLE_THRESH
  493. * ..
  494. * .. External Subroutines ..
  495. EXTERNAL XERBLA, DGBCON
  496. EXTERNAL DLA_GBRFSX_EXTENDED
  497. * ..
  498. * .. Intrinsic Functions ..
  499. INTRINSIC MAX, SQRT
  500. * ..
  501. * .. External Functions ..
  502. EXTERNAL LSAME, ILATRANS, ILAPREC
  503. EXTERNAL DLAMCH, DLANGB, DLA_GBRCOND
  504. DOUBLE PRECISION DLAMCH, DLANGB, DLA_GBRCOND
  505. LOGICAL LSAME
  506. INTEGER ILATRANS, ILAPREC
  507. * ..
  508. * .. Executable Statements ..
  509. *
  510. * Check the input parameters.
  511. *
  512. INFO = 0
  513. TRANS_TYPE = ILATRANS( TRANS )
  514. REF_TYPE = INT( ITREF_DEFAULT )
  515. IF ( NPARAMS .GE. LA_LINRX_ITREF_I ) THEN
  516. IF ( PARAMS( LA_LINRX_ITREF_I ) .LT. 0.0D+0 ) THEN
  517. PARAMS( LA_LINRX_ITREF_I ) = ITREF_DEFAULT
  518. ELSE
  519. REF_TYPE = PARAMS( LA_LINRX_ITREF_I )
  520. END IF
  521. END IF
  522. *
  523. * Set default parameters.
  524. *
  525. ILLRCOND_THRESH = DBLE( N ) * DLAMCH( 'Epsilon' )
  526. ITHRESH = INT( ITHRESH_DEFAULT )
  527. RTHRESH = RTHRESH_DEFAULT
  528. UNSTABLE_THRESH = DZTHRESH_DEFAULT
  529. IGNORE_CWISE = COMPONENTWISE_DEFAULT .EQ. 0.0D+0
  530. *
  531. IF ( NPARAMS.GE.LA_LINRX_ITHRESH_I ) THEN
  532. IF ( PARAMS( LA_LINRX_ITHRESH_I ).LT.0.0D+0 ) THEN
  533. PARAMS( LA_LINRX_ITHRESH_I ) = ITHRESH
  534. ELSE
  535. ITHRESH = INT( PARAMS( LA_LINRX_ITHRESH_I ) )
  536. END IF
  537. END IF
  538. IF ( NPARAMS.GE.LA_LINRX_CWISE_I ) THEN
  539. IF ( PARAMS( LA_LINRX_CWISE_I ).LT.0.0D+0 ) THEN
  540. IF ( IGNORE_CWISE ) THEN
  541. PARAMS( LA_LINRX_CWISE_I ) = 0.0D+0
  542. ELSE
  543. PARAMS( LA_LINRX_CWISE_I ) = 1.0D+0
  544. END IF
  545. ELSE
  546. IGNORE_CWISE = PARAMS( LA_LINRX_CWISE_I ) .EQ. 0.0D+0
  547. END IF
  548. END IF
  549. IF ( REF_TYPE .EQ. 0 .OR. N_ERR_BNDS .EQ. 0 ) THEN
  550. N_NORMS = 0
  551. ELSE IF ( IGNORE_CWISE ) THEN
  552. N_NORMS = 1
  553. ELSE
  554. N_NORMS = 2
  555. END IF
  556. *
  557. NOTRAN = LSAME( TRANS, 'N' )
  558. ROWEQU = LSAME( EQUED, 'R' ) .OR. LSAME( EQUED, 'B' )
  559. COLEQU = LSAME( EQUED, 'C' ) .OR. LSAME( EQUED, 'B' )
  560. *
  561. * Test input parameters.
  562. *
  563. IF( TRANS_TYPE.EQ.-1 ) THEN
  564. INFO = -1
  565. ELSE IF( .NOT.ROWEQU .AND. .NOT.COLEQU .AND.
  566. $ .NOT.LSAME( EQUED, 'N' ) ) THEN
  567. INFO = -2
  568. ELSE IF( N.LT.0 ) THEN
  569. INFO = -3
  570. ELSE IF( KL.LT.0 ) THEN
  571. INFO = -4
  572. ELSE IF( KU.LT.0 ) THEN
  573. INFO = -5
  574. ELSE IF( NRHS.LT.0 ) THEN
  575. INFO = -6
  576. ELSE IF( LDAB.LT.KL+KU+1 ) THEN
  577. INFO = -8
  578. ELSE IF( LDAFB.LT.2*KL+KU+1 ) THEN
  579. INFO = -10
  580. ELSE IF( LDB.LT.MAX( 1, N ) ) THEN
  581. INFO = -13
  582. ELSE IF( LDX.LT.MAX( 1, N ) ) THEN
  583. INFO = -15
  584. END IF
  585. IF( INFO.NE.0 ) THEN
  586. CALL XERBLA( 'DGBRFSX', -INFO )
  587. RETURN
  588. END IF
  589. *
  590. * Quick return if possible.
  591. *
  592. IF( N.EQ.0 .OR. NRHS.EQ.0 ) THEN
  593. RCOND = 1.0D+0
  594. DO J = 1, NRHS
  595. BERR( J ) = 0.0D+0
  596. IF ( N_ERR_BNDS .GE. 1 ) THEN
  597. ERR_BNDS_NORM( J, LA_LINRX_TRUST_I ) = 1.0D+0
  598. ERR_BNDS_COMP( J, LA_LINRX_TRUST_I ) = 1.0D+0
  599. END IF
  600. IF ( N_ERR_BNDS .GE. 2 ) THEN
  601. ERR_BNDS_NORM( J, LA_LINRX_ERR_I ) = 0.0D+0
  602. ERR_BNDS_COMP( J, LA_LINRX_ERR_I ) = 0.0D+0
  603. END IF
  604. IF ( N_ERR_BNDS .GE. 3 ) THEN
  605. ERR_BNDS_NORM( J, LA_LINRX_RCOND_I ) = 1.0D+0
  606. ERR_BNDS_COMP( J, LA_LINRX_RCOND_I ) = 1.0D+0
  607. END IF
  608. END DO
  609. RETURN
  610. END IF
  611. *
  612. * Default to failure.
  613. *
  614. RCOND = 0.0D+0
  615. DO J = 1, NRHS
  616. BERR( J ) = 1.0D+0
  617. IF ( N_ERR_BNDS .GE. 1 ) THEN
  618. ERR_BNDS_NORM( J, LA_LINRX_TRUST_I ) = 1.0D+0
  619. ERR_BNDS_COMP( J, LA_LINRX_TRUST_I ) = 1.0D+0
  620. END IF
  621. IF ( N_ERR_BNDS .GE. 2 ) THEN
  622. ERR_BNDS_NORM( J, LA_LINRX_ERR_I ) = 1.0D+0
  623. ERR_BNDS_COMP( J, LA_LINRX_ERR_I ) = 1.0D+0
  624. END IF
  625. IF ( N_ERR_BNDS .GE. 3 ) THEN
  626. ERR_BNDS_NORM( J, LA_LINRX_RCOND_I ) = 0.0D+0
  627. ERR_BNDS_COMP( J, LA_LINRX_RCOND_I ) = 0.0D+0
  628. END IF
  629. END DO
  630. *
  631. * Compute the norm of A and the reciprocal of the condition
  632. * number of A.
  633. *
  634. IF( NOTRAN ) THEN
  635. NORM = 'I'
  636. ELSE
  637. NORM = '1'
  638. END IF
  639. ANORM = DLANGB( NORM, N, KL, KU, AB, LDAB, WORK )
  640. CALL DGBCON( NORM, N, KL, KU, AFB, LDAFB, IPIV, ANORM, RCOND,
  641. $ WORK, IWORK, INFO )
  642. *
  643. * Perform refinement on each right-hand side
  644. *
  645. IF ( REF_TYPE .NE. 0 .AND. INFO .EQ. 0 ) THEN
  646. PREC_TYPE = ILAPREC( 'E' )
  647. IF ( NOTRAN ) THEN
  648. CALL DLA_GBRFSX_EXTENDED( PREC_TYPE, TRANS_TYPE, N, KL, KU,
  649. $ NRHS, AB, LDAB, AFB, LDAFB, IPIV, COLEQU, C, B,
  650. $ LDB, X, LDX, BERR, N_NORMS, ERR_BNDS_NORM,
  651. $ ERR_BNDS_COMP, WORK( N+1 ), WORK( 1 ), WORK( 2*N+1 ),
  652. $ WORK( 1 ), RCOND, ITHRESH, RTHRESH, UNSTABLE_THRESH,
  653. $ IGNORE_CWISE, INFO )
  654. ELSE
  655. CALL DLA_GBRFSX_EXTENDED( PREC_TYPE, TRANS_TYPE, N, KL, KU,
  656. $ NRHS, AB, LDAB, AFB, LDAFB, IPIV, ROWEQU, R, B,
  657. $ LDB, X, LDX, BERR, N_NORMS, ERR_BNDS_NORM,
  658. $ ERR_BNDS_COMP, WORK( N+1 ), WORK( 1 ), WORK( 2*N+1 ),
  659. $ WORK( 1 ), RCOND, ITHRESH, RTHRESH, UNSTABLE_THRESH,
  660. $ IGNORE_CWISE, INFO )
  661. END IF
  662. END IF
  663. ERR_LBND = MAX( 10.0D+0, SQRT( DBLE( N ) ) ) * DLAMCH( 'Epsilon' )
  664. IF ( N_ERR_BNDS .GE. 1 .AND. N_NORMS .GE. 1 ) THEN
  665. *
  666. * Compute scaled normwise condition number cond(A*C).
  667. *
  668. IF ( COLEQU .AND. NOTRAN ) THEN
  669. RCOND_TMP = DLA_GBRCOND( TRANS, N, KL, KU, AB, LDAB, AFB,
  670. $ LDAFB, IPIV, -1, C, INFO, WORK, IWORK )
  671. ELSE IF ( ROWEQU .AND. .NOT. NOTRAN ) THEN
  672. RCOND_TMP = DLA_GBRCOND( TRANS, N, KL, KU, AB, LDAB, AFB,
  673. $ LDAFB, IPIV, -1, R, INFO, WORK, IWORK )
  674. ELSE
  675. RCOND_TMP = DLA_GBRCOND( TRANS, N, KL, KU, AB, LDAB, AFB,
  676. $ LDAFB, IPIV, 0, R, INFO, WORK, IWORK )
  677. END IF
  678. DO J = 1, NRHS
  679. *
  680. * Cap the error at 1.0.
  681. *
  682. IF ( N_ERR_BNDS .GE. LA_LINRX_ERR_I
  683. $ .AND. ERR_BNDS_NORM( J, LA_LINRX_ERR_I ) .GT. 1.0D+0 )
  684. $ ERR_BNDS_NORM( J, LA_LINRX_ERR_I ) = 1.0D+0
  685. *
  686. * Threshold the error (see LAWN).
  687. *
  688. IF ( RCOND_TMP .LT. ILLRCOND_THRESH ) THEN
  689. ERR_BNDS_NORM( J, LA_LINRX_ERR_I ) = 1.0D+0
  690. ERR_BNDS_NORM( J, LA_LINRX_TRUST_I ) = 0.0D+0
  691. IF ( INFO .LE. N ) INFO = N + J
  692. ELSE IF ( ERR_BNDS_NORM( J, LA_LINRX_ERR_I ) .LT. ERR_LBND )
  693. $ THEN
  694. ERR_BNDS_NORM( J, LA_LINRX_ERR_I ) = ERR_LBND
  695. ERR_BNDS_NORM( J, LA_LINRX_TRUST_I ) = 1.0D+0
  696. END IF
  697. *
  698. * Save the condition number.
  699. *
  700. IF ( N_ERR_BNDS .GE. LA_LINRX_RCOND_I ) THEN
  701. ERR_BNDS_NORM( J, LA_LINRX_RCOND_I ) = RCOND_TMP
  702. END IF
  703. END DO
  704. END IF
  705. IF (N_ERR_BNDS .GE. 1 .AND. N_NORMS .GE. 2) THEN
  706. *
  707. * Compute componentwise condition number cond(A*diag(Y(:,J))) for
  708. * each right-hand side using the current solution as an estimate of
  709. * the true solution. If the componentwise error estimate is too
  710. * large, then the solution is a lousy estimate of truth and the
  711. * estimated RCOND may be too optimistic. To avoid misleading users,
  712. * the inverse condition number is set to 0.0 when the estimated
  713. * cwise error is at least CWISE_WRONG.
  714. *
  715. CWISE_WRONG = SQRT( DLAMCH( 'Epsilon' ) )
  716. DO J = 1, NRHS
  717. IF ( ERR_BNDS_COMP( J, LA_LINRX_ERR_I ) .LT. CWISE_WRONG )
  718. $ THEN
  719. RCOND_TMP = DLA_GBRCOND( TRANS, N, KL, KU, AB, LDAB, AFB,
  720. $ LDAFB, IPIV, 1, X( 1, J ), INFO, WORK, IWORK )
  721. ELSE
  722. RCOND_TMP = 0.0D+0
  723. END IF
  724. *
  725. * Cap the error at 1.0.
  726. *
  727. IF ( N_ERR_BNDS .GE. LA_LINRX_ERR_I
  728. $ .AND. ERR_BNDS_COMP( J, LA_LINRX_ERR_I ) .GT. 1.0D+0 )
  729. $ ERR_BNDS_COMP( J, LA_LINRX_ERR_I ) = 1.0D+0
  730. *
  731. * Threshold the error (see LAWN).
  732. *
  733. IF ( RCOND_TMP .LT. ILLRCOND_THRESH ) THEN
  734. ERR_BNDS_COMP( J, LA_LINRX_ERR_I ) = 1.0D+0
  735. ERR_BNDS_COMP( J, LA_LINRX_TRUST_I ) = 0.0D+0
  736. IF ( PARAMS( LA_LINRX_CWISE_I ) .EQ. 1.0D+0
  737. $ .AND. INFO.LT.N + J ) INFO = N + J
  738. ELSE IF ( ERR_BNDS_COMP( J, LA_LINRX_ERR_I )
  739. $ .LT. ERR_LBND ) THEN
  740. ERR_BNDS_COMP( J, LA_LINRX_ERR_I ) = ERR_LBND
  741. ERR_BNDS_COMP( J, LA_LINRX_TRUST_I ) = 1.0D+0
  742. END IF
  743. *
  744. * Save the condition number.
  745. *
  746. IF ( N_ERR_BNDS .GE. LA_LINRX_RCOND_I ) THEN
  747. ERR_BNDS_COMP( J, LA_LINRX_RCOND_I ) = RCOND_TMP
  748. END IF
  749. END DO
  750. END IF
  751. *
  752. RETURN
  753. *
  754. * End of DGBRFSX
  755. *
  756. END