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.

cgbrfsx.f 29 kB

123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102103104105106107108109110111112113114115116117118119120121122123124125126127128129130131132133134135136137138139140141142143144145146147148149150151152153154155156157158159160161162163164165166167168169170171172173174175176177178179180181182183184185186187188189190191192193194195196197198199200201202203204205206207208209210211212213214215216217218219220221222223224225226227228229230231232233234235236237238239240241242243244245246247248249250251252253254255256257258259260261262263264265266267268269270271272273274275276277278279280281282283284285286287288289290291292293294295296297298299300301302303304305306307308309310311312313314315316317318319320321322323324325326327328329330331332333334335336337338339340341342343344345346347348349350351352353354355356357358359360361362363364365366367368369370371372373374375376377378379380381382383384385386387388389390391392393394395396397398399400401402403404405406407408409410411412413414415416417418419420421422423424425426427428429430431432433434435436437438439440441442443444445446447448449450451452453454455456457458459460461462463464465466467468469470471472473474475476477478479480481482483484485486487488489490491492493494495496497498499500501502503504505506507508509510511512513514515516517518519520521522523524525526527528529530531532533534535536537538539540541542543544545546547548549550551552553554555556557558559560561562563564565566567568569570571572573574575576577578579580581582583584585586587588589590591592593594595596597598599600601602603604605606607608609610611612613614615616617618619620621622623624625626627628629630631632633634635636637638639640641642643644645646647648649650651652653654655656657658659660661662663664665666667668669670671672673674675676677678679680681682683684685686687688689690691692693694695696697698699700701702703704705706707708709710711712713714715716717718719720721722723724725726727728729730731732733734735736737738739740741742743744745746747748749750751752753754755756757758759760761762763764
  1. *> \brief \b CGBRFSX
  2. *
  3. * =========== DOCUMENTATION ===========
  4. *
  5. * Online html documentation available at
  6. * http://www.netlib.org/lapack/explore-html/
  7. *
  8. *> \htmlonly
  9. *> Download CGBRFSX + dependencies
  10. *> <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/cgbrfsx.f">
  11. *> [TGZ]</a>
  12. *> <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/cgbrfsx.f">
  13. *> [ZIP]</a>
  14. *> <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/cgbrfsx.f">
  15. *> [TXT]</a>
  16. *> \endhtmlonly
  17. *
  18. * Definition:
  19. * ===========
  20. *
  21. * SUBROUTINE CGBRFSX( 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, RWORK,
  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. * REAL RCOND
  32. * ..
  33. * .. Array Arguments ..
  34. * INTEGER IPIV( * )
  35. * COMPLEX AB( LDAB, * ), AFB( LDAFB, * ), B( LDB, * ),
  36. * $ X( LDX , * ),WORK( * )
  37. * REAL R( * ), C( * ), PARAMS( * ), BERR( * ),
  38. * $ ERR_BNDS_NORM( NRHS, * ),
  39. * $ ERR_BNDS_COMP( NRHS, * ), RWORK( * )
  40. * ..
  41. *
  42. *
  43. *> \par Purpose:
  44. * =============
  45. *>
  46. *> \verbatim
  47. *>
  48. *> CGBRFSX 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 COMPLEX 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 COMPLEX 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 SGETRF; 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 REAL 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 REAL 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 COMPLEX 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 COMPLEX array, dimension (LDX,NRHS)
  211. *> On entry, the solution matrix X, as computed by SGETRS.
  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 REAL
  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 REAL 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 REAL 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) * slamch('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) * slamch('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) * slamch('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 REAL 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 .LT. 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) * slamch('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) * slamch('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) * slamch('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 .LE. 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 REAL array, dimension NPARAMS
  354. *> Specifies algorithm parameters. If an entry is .LT. 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.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 COMPLEX array, dimension (2*N)
  390. *> \endverbatim
  391. *>
  392. *> \param[out] RWORK
  393. *> \verbatim
  394. *> RWORK is REAL array, dimension (2*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. *> \date April 2012
  433. *
  434. *> \ingroup complexGBcomputational
  435. *
  436. * =====================================================================
  437. SUBROUTINE CGBRFSX( TRANS, EQUED, N, KL, KU, NRHS, AB, LDAB, AFB,
  438. $ LDAFB, IPIV, R, C, B, LDB, X, LDX, RCOND,
  439. $ BERR, N_ERR_BNDS, ERR_BNDS_NORM,
  440. $ ERR_BNDS_COMP, NPARAMS, PARAMS, WORK, RWORK,
  441. $ INFO )
  442. *
  443. * -- LAPACK computational routine (version 3.4.1) --
  444. * -- LAPACK is a software package provided by Univ. of Tennessee, --
  445. * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
  446. * April 2012
  447. *
  448. * .. Scalar Arguments ..
  449. CHARACTER TRANS, EQUED
  450. INTEGER INFO, LDAB, LDAFB, LDB, LDX, N, KL, KU, NRHS,
  451. $ NPARAMS, N_ERR_BNDS
  452. REAL RCOND
  453. * ..
  454. * .. Array Arguments ..
  455. INTEGER IPIV( * )
  456. COMPLEX AB( LDAB, * ), AFB( LDAFB, * ), B( LDB, * ),
  457. $ X( LDX , * ),WORK( * )
  458. REAL R( * ), C( * ), PARAMS( * ), BERR( * ),
  459. $ ERR_BNDS_NORM( NRHS, * ),
  460. $ ERR_BNDS_COMP( NRHS, * ), RWORK( * )
  461. * ..
  462. *
  463. * ==================================================================
  464. *
  465. * .. Parameters ..
  466. REAL ZERO, ONE
  467. PARAMETER ( ZERO = 0.0E+0, ONE = 1.0E+0 )
  468. REAL ITREF_DEFAULT, ITHRESH_DEFAULT,
  469. $ COMPONENTWISE_DEFAULT
  470. REAL RTHRESH_DEFAULT, DZTHRESH_DEFAULT
  471. PARAMETER ( ITREF_DEFAULT = 1.0 )
  472. PARAMETER ( ITHRESH_DEFAULT = 10.0 )
  473. PARAMETER ( COMPONENTWISE_DEFAULT = 1.0 )
  474. PARAMETER ( RTHRESH_DEFAULT = 0.5 )
  475. PARAMETER ( DZTHRESH_DEFAULT = 0.25 )
  476. INTEGER LA_LINRX_ITREF_I, LA_LINRX_ITHRESH_I,
  477. $ LA_LINRX_CWISE_I
  478. PARAMETER ( LA_LINRX_ITREF_I = 1,
  479. $ LA_LINRX_ITHRESH_I = 2 )
  480. PARAMETER ( LA_LINRX_CWISE_I = 3 )
  481. INTEGER LA_LINRX_TRUST_I, LA_LINRX_ERR_I,
  482. $ LA_LINRX_RCOND_I
  483. PARAMETER ( LA_LINRX_TRUST_I = 1, LA_LINRX_ERR_I = 2 )
  484. PARAMETER ( LA_LINRX_RCOND_I = 3 )
  485. * ..
  486. * .. Local Scalars ..
  487. CHARACTER(1) NORM
  488. LOGICAL ROWEQU, COLEQU, NOTRAN, IGNORE_CWISE
  489. INTEGER J, TRANS_TYPE, PREC_TYPE, REF_TYPE, N_NORMS,
  490. $ ITHRESH
  491. REAL ANORM, RCOND_TMP, ILLRCOND_THRESH, ERR_LBND,
  492. $ CWISE_WRONG, RTHRESH, UNSTABLE_THRESH
  493. * ..
  494. * .. External Subroutines ..
  495. EXTERNAL XERBLA, CGBCON, CLA_GBRFSX_EXTENDED
  496. * ..
  497. * .. Intrinsic Functions ..
  498. INTRINSIC MAX, SQRT, TRANSFER
  499. * ..
  500. * .. External Functions ..
  501. EXTERNAL LSAME, BLAS_FPINFO_X, ILATRANS, ILAPREC
  502. EXTERNAL SLAMCH, CLANGB, CLA_GBRCOND_X, CLA_GBRCOND_C
  503. REAL SLAMCH, CLANGB, CLA_GBRCOND_X, CLA_GBRCOND_C
  504. LOGICAL LSAME
  505. INTEGER BLAS_FPINFO_X
  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.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 = REAL( N ) * SLAMCH( 'Epsilon' )
  526. ITHRESH = INT( ITHRESH_DEFAULT )
  527. RTHRESH = RTHRESH_DEFAULT
  528. UNSTABLE_THRESH = DZTHRESH_DEFAULT
  529. IGNORE_CWISE = COMPONENTWISE_DEFAULT .EQ. 0.0
  530. *
  531. IF ( NPARAMS.GE.LA_LINRX_ITHRESH_I ) THEN
  532. IF ( PARAMS( LA_LINRX_ITHRESH_I ).LT.0.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.0 ) THEN
  540. IF ( IGNORE_CWISE ) THEN
  541. PARAMS( LA_LINRX_CWISE_I ) = 0.0
  542. ELSE
  543. PARAMS( LA_LINRX_CWISE_I ) = 1.0
  544. END IF
  545. ELSE
  546. IGNORE_CWISE = PARAMS( LA_LINRX_CWISE_I ) .EQ. 0.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( 'CGBRFSX', -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.0
  594. DO J = 1, NRHS
  595. BERR( J ) = 0.0
  596. IF ( N_ERR_BNDS .GE. 1 ) THEN
  597. ERR_BNDS_NORM( J, LA_LINRX_TRUST_I ) = 1.0
  598. ERR_BNDS_COMP( J, LA_LINRX_TRUST_I ) = 1.0
  599. END IF
  600. IF ( N_ERR_BNDS .GE. 2 ) THEN
  601. ERR_BNDS_NORM( J, LA_LINRX_ERR_I ) = 0.0
  602. ERR_BNDS_COMP( J, LA_LINRX_ERR_I ) = 0.0
  603. END IF
  604. IF ( N_ERR_BNDS .GE. 3 ) THEN
  605. ERR_BNDS_NORM( J, LA_LINRX_RCOND_I ) = 1.0
  606. ERR_BNDS_COMP( J, LA_LINRX_RCOND_I ) = 1.0
  607. END IF
  608. END DO
  609. RETURN
  610. END IF
  611. *
  612. * Default to failure.
  613. *
  614. RCOND = 0.0
  615. DO J = 1, NRHS
  616. BERR( J ) = 1.0
  617. IF ( N_ERR_BNDS .GE. 1 ) THEN
  618. ERR_BNDS_NORM( J, LA_LINRX_TRUST_I ) = 1.0
  619. ERR_BNDS_COMP( J, LA_LINRX_TRUST_I ) = 1.0
  620. END IF
  621. IF ( N_ERR_BNDS .GE. 2 ) THEN
  622. ERR_BNDS_NORM( J, LA_LINRX_ERR_I ) = 1.0
  623. ERR_BNDS_COMP( J, LA_LINRX_ERR_I ) = 1.0
  624. END IF
  625. IF ( N_ERR_BNDS .GE. 3 ) THEN
  626. ERR_BNDS_NORM( J, LA_LINRX_RCOND_I ) = 0.0
  627. ERR_BNDS_COMP( J, LA_LINRX_RCOND_I ) = 0.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 = CLANGB( NORM, N, KL, KU, AB, LDAB, RWORK )
  640. CALL CGBCON( NORM, N, KL, KU, AFB, LDAFB, IPIV, ANORM, RCOND,
  641. $ WORK, RWORK, INFO )
  642. *
  643. * Perform refinement on each right-hand side
  644. *
  645. IF ( REF_TYPE .NE. 0 ) THEN
  646. PREC_TYPE = ILAPREC( 'D' )
  647. IF ( NOTRAN ) THEN
  648. CALL CLA_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, RWORK, WORK(N+1),
  652. $ TRANSFER (RWORK(1:2*N), (/ (ZERO, ZERO) /), N),
  653. $ RCOND, ITHRESH, RTHRESH, UNSTABLE_THRESH, IGNORE_CWISE,
  654. $ INFO )
  655. ELSE
  656. CALL CLA_GBRFSX_EXTENDED( PREC_TYPE, TRANS_TYPE, N, KL, KU,
  657. $ NRHS, AB, LDAB, AFB, LDAFB, IPIV, ROWEQU, R, B,
  658. $ LDB, X, LDX, BERR, N_NORMS, ERR_BNDS_NORM,
  659. $ ERR_BNDS_COMP, WORK, RWORK, WORK(N+1),
  660. $ TRANSFER (RWORK(1:2*N), (/ (ZERO, ZERO) /), N),
  661. $ RCOND, ITHRESH, RTHRESH, UNSTABLE_THRESH, IGNORE_CWISE,
  662. $ INFO )
  663. END IF
  664. END IF
  665. ERR_LBND = MAX( 10.0, SQRT( REAL( N ) ) ) * SLAMCH( 'Epsilon' )
  666. IF (N_ERR_BNDS .GE. 1 .AND. N_NORMS .GE. 1) THEN
  667. *
  668. * Compute scaled normwise condition number cond(A*C).
  669. *
  670. IF ( COLEQU .AND. NOTRAN ) THEN
  671. RCOND_TMP = CLA_GBRCOND_C( TRANS, N, KL, KU, AB, LDAB, AFB,
  672. $ LDAFB, IPIV, C, .TRUE., INFO, WORK, RWORK )
  673. ELSE IF ( ROWEQU .AND. .NOT. NOTRAN ) THEN
  674. RCOND_TMP = CLA_GBRCOND_C( TRANS, N, KL, KU, AB, LDAB, AFB,
  675. $ LDAFB, IPIV, R, .TRUE., INFO, WORK, RWORK )
  676. ELSE
  677. RCOND_TMP = CLA_GBRCOND_C( TRANS, N, KL, KU, AB, LDAB, AFB,
  678. $ LDAFB, IPIV, C, .FALSE., INFO, WORK, RWORK )
  679. END IF
  680. DO J = 1, NRHS
  681. *
  682. * Cap the error at 1.0.
  683. *
  684. IF ( N_ERR_BNDS .GE. LA_LINRX_ERR_I
  685. $ .AND. ERR_BNDS_NORM( J, LA_LINRX_ERR_I ) .GT. 1.0)
  686. $ ERR_BNDS_NORM( J, LA_LINRX_ERR_I ) = 1.0
  687. *
  688. * Threshold the error (see LAWN).
  689. *
  690. IF ( RCOND_TMP .LT. ILLRCOND_THRESH ) THEN
  691. ERR_BNDS_NORM( J, LA_LINRX_ERR_I ) = 1.0
  692. ERR_BNDS_NORM( J, LA_LINRX_TRUST_I ) = 0.0
  693. IF ( INFO .LE. N ) INFO = N + J
  694. ELSE IF ( ERR_BNDS_NORM( J, LA_LINRX_ERR_I ) .LT. ERR_LBND )
  695. $ THEN
  696. ERR_BNDS_NORM( J, LA_LINRX_ERR_I ) = ERR_LBND
  697. ERR_BNDS_NORM( J, LA_LINRX_TRUST_I ) = 1.0
  698. END IF
  699. *
  700. * Save the condition number.
  701. *
  702. IF ( N_ERR_BNDS .GE. LA_LINRX_RCOND_I ) THEN
  703. ERR_BNDS_NORM( J, LA_LINRX_RCOND_I ) = RCOND_TMP
  704. END IF
  705. END DO
  706. END IF
  707. IF (N_ERR_BNDS .GE. 1 .AND. N_NORMS .GE. 2) THEN
  708. *
  709. * Compute componentwise condition number cond(A*diag(Y(:,J))) for
  710. * each right-hand side using the current solution as an estimate of
  711. * the true solution. If the componentwise error estimate is too
  712. * large, then the solution is a lousy estimate of truth and the
  713. * estimated RCOND may be too optimistic. To avoid misleading users,
  714. * the inverse condition number is set to 0.0 when the estimated
  715. * cwise error is at least CWISE_WRONG.
  716. *
  717. CWISE_WRONG = SQRT( SLAMCH( 'Epsilon' ) )
  718. DO J = 1, NRHS
  719. IF (ERR_BNDS_COMP( J, LA_LINRX_ERR_I ) .LT. CWISE_WRONG )
  720. $ THEN
  721. RCOND_TMP = CLA_GBRCOND_X( TRANS, N, KL, KU, AB, LDAB,
  722. $ AFB, LDAFB, IPIV, X( 1, J ), INFO, WORK, RWORK )
  723. ELSE
  724. RCOND_TMP = 0.0
  725. END IF
  726. *
  727. * Cap the error at 1.0.
  728. *
  729. IF ( N_ERR_BNDS .GE. LA_LINRX_ERR_I
  730. $ .AND. ERR_BNDS_COMP( J, LA_LINRX_ERR_I ) .GT. 1.0 )
  731. $ ERR_BNDS_COMP( J, LA_LINRX_ERR_I ) = 1.0
  732. *
  733. * Threshold the error (see LAWN).
  734. *
  735. IF ( RCOND_TMP .LT. ILLRCOND_THRESH ) THEN
  736. ERR_BNDS_COMP( J, LA_LINRX_ERR_I ) = 1.0
  737. ERR_BNDS_COMP( J, LA_LINRX_TRUST_I ) = 0.0
  738. IF ( PARAMS( LA_LINRX_CWISE_I ) .EQ. 1.0
  739. $ .AND. INFO.LT.N + J ) INFO = N + J
  740. ELSE IF ( ERR_BNDS_COMP( J, LA_LINRX_ERR_I )
  741. $ .LT. ERR_LBND ) THEN
  742. ERR_BNDS_COMP( J, LA_LINRX_ERR_I ) = ERR_LBND
  743. ERR_BNDS_COMP( J, LA_LINRX_TRUST_I ) = 1.0
  744. END IF
  745. *
  746. * Save the condition number.
  747. *
  748. IF ( N_ERR_BNDS .GE. LA_LINRX_RCOND_I ) THEN
  749. ERR_BNDS_COMP( J, LA_LINRX_RCOND_I ) = RCOND_TMP
  750. END IF
  751. END DO
  752. END IF
  753. *
  754. RETURN
  755. *
  756. * End of CGBRFSX
  757. *
  758. END