dgerfsx.c 26 KB

123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102103104105106107108109110111112113114115116117118119120121122123124125126127128129130131132133134135136137138139140141142143144145146147148149150151152153154155156157158159160161162163164165166167168169170171172173174175176177178179180181182183184185186187188189190191192193194195196197198199200201202203204205206207208209210211212213214215216217218219220221222223224225226227228229230231232233234235236237238239240241242243244245246247248249250251252253254255256257258259260261262263264265266267268269270271272273274275276277278279280281282283284285286287288289290291292293294295296297298299300301302303304305306307308309310311312313314315316317318319320321322323324325326327328329330331332333334335336337338339340341342343344345346347348349350351352353354355356357358359360361362363364365366367368369370371372373374375376377378379380381382383384385386387388389390391392393394395396397398399400401402403404405406407408409410411412413414415416417418419420421422423424425426427428429430431432433434435436437438439440441442443444445446447448449450451452453454455456457458459460461462463464465466467468469470471472473474475476477478479480481482483484485486487488489490491492493494495496497498499500501502503504505506507508509510511512513514515516517518519520521522523524525526527528529530531532533534535536537538539540541542543544545546547548549550551552553554555556557558559560561562563564565566567568569570571572573574575576577578579580581582583584585586587588589590591592593594595596597598599600601602603604605606607608609610611612613614615616617618619620621622623624625626627628629630631632633634635636637638639640641642643644645646647648649650651652653654655656657658659660661662663664665666667
  1. /* dgerfsx.f -- translated by f2c (version 20061008).
  2. You must link the resulting object file with libf2c:
  3. on Microsoft Windows system, link with libf2c.lib;
  4. on Linux or Unix systems, link with .../path/to/libf2c.a -lm
  5. or, if you install libf2c.a in a standard place, with -lf2c -lm
  6. -- in that order, at the end of the command line, as in
  7. cc *.o -lf2c -lm
  8. Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
  9. http://www.netlib.org/f2c/libf2c.zip
  10. */
  11. #include "f2c.h"
  12. #include "blaswrap.h"
  13. /* Table of constant values */
  14. static integer c_n1 = -1;
  15. static integer c__0 = 0;
  16. static integer c__1 = 1;
  17. /* Subroutine */ int _starpu_dgerfsx_(char *trans, char *equed, integer *n, integer *
  18. nrhs, doublereal *a, integer *lda, doublereal *af, integer *ldaf,
  19. integer *ipiv, doublereal *r__, doublereal *c__, doublereal *b,
  20. integer *ldb, doublereal *x, integer *ldx, doublereal *rcond,
  21. doublereal *berr, integer *n_err_bnds__, doublereal *err_bnds_norm__,
  22. doublereal *err_bnds_comp__, integer *nparams, doublereal *params,
  23. doublereal *work, integer *iwork, integer *info)
  24. {
  25. /* System generated locals */
  26. integer a_dim1, a_offset, af_dim1, af_offset, b_dim1, b_offset, x_dim1,
  27. x_offset, err_bnds_norm_dim1, err_bnds_norm_offset,
  28. err_bnds_comp_dim1, err_bnds_comp_offset, i__1;
  29. doublereal d__1, d__2;
  30. /* Builtin functions */
  31. double sqrt(doublereal);
  32. /* Local variables */
  33. doublereal illrcond_thresh__, unstable_thresh__, err_lbnd__;
  34. integer ref_type__;
  35. extern integer _starpu_ilatrans_(char *);
  36. integer j;
  37. doublereal rcond_tmp__;
  38. integer prec_type__, trans_type__;
  39. extern doublereal _starpu_dla_gercond__(char *, integer *, doublereal *, integer *
  40. , doublereal *, integer *, integer *, integer *, doublereal *,
  41. integer *, doublereal *, integer *, ftnlen);
  42. doublereal cwise_wrong__;
  43. extern /* Subroutine */ int _starpu_dla_gerfsx_extended__(integer *, integer *,
  44. integer *, integer *, doublereal *, integer *, doublereal *,
  45. integer *, integer *, logical *, doublereal *, doublereal *,
  46. integer *, doublereal *, integer *, doublereal *, integer *,
  47. doublereal *, doublereal *, doublereal *, doublereal *,
  48. doublereal *, doublereal *, doublereal *, integer *, doublereal *,
  49. doublereal *, logical *, integer *);
  50. char norm[1];
  51. logical ignore_cwise__;
  52. extern logical _starpu_lsame_(char *, char *);
  53. doublereal anorm;
  54. extern doublereal _starpu_dlamch_(char *), _starpu_dlange_(char *, integer *,
  55. integer *, doublereal *, integer *, doublereal *);
  56. extern /* Subroutine */ int _starpu_dgecon_(char *, integer *, doublereal *,
  57. integer *, doublereal *, doublereal *, doublereal *, integer *,
  58. integer *), _starpu_xerbla_(char *, integer *);
  59. logical colequ, notran, rowequ;
  60. extern integer _starpu_ilaprec_(char *);
  61. integer ithresh, n_norms__;
  62. doublereal rthresh;
  63. /* -- LAPACK routine (version 3.2.1) -- */
  64. /* -- Contributed by James Demmel, Deaglan Halligan, Yozo Hida and -- */
  65. /* -- Jason Riedy of Univ. of California Berkeley. -- */
  66. /* -- April 2009 -- */
  67. /* -- LAPACK is a software package provided by Univ. of Tennessee, -- */
  68. /* -- Univ. of California Berkeley and NAG Ltd. -- */
  69. /* .. */
  70. /* .. Scalar Arguments .. */
  71. /* .. */
  72. /* .. Array Arguments .. */
  73. /* .. */
  74. /* Purpose */
  75. /* ======= */
  76. /* DGERFSX improves the computed solution to a system of linear */
  77. /* equations and provides error bounds and backward error estimates */
  78. /* for the solution. In addition to normwise error bound, the code */
  79. /* provides maximum componentwise error bound if possible. See */
  80. /* comments for ERR_BNDS_NORM and ERR_BNDS_COMP for details of the */
  81. /* error bounds. */
  82. /* The original system of linear equations may have been equilibrated */
  83. /* before calling this routine, as described by arguments EQUED, R */
  84. /* and C below. In this case, the solution and error bounds returned */
  85. /* are for the original unequilibrated system. */
  86. /* Arguments */
  87. /* ========= */
  88. /* Some optional parameters are bundled in the PARAMS array. These */
  89. /* settings determine how refinement is performed, but often the */
  90. /* defaults are acceptable. If the defaults are acceptable, users */
  91. /* can pass NPARAMS = 0 which prevents the source code from accessing */
  92. /* the PARAMS argument. */
  93. /* TRANS (input) CHARACTER*1 */
  94. /* Specifies the form of the system of equations: */
  95. /* = 'N': A * X = B (No transpose) */
  96. /* = 'T': A**T * X = B (Transpose) */
  97. /* = 'C': A**H * X = B (Conjugate transpose = Transpose) */
  98. /* EQUED (input) CHARACTER*1 */
  99. /* Specifies the form of equilibration that was done to A */
  100. /* before calling this routine. This is needed to compute */
  101. /* the solution and error bounds correctly. */
  102. /* = 'N': No equilibration */
  103. /* = 'R': Row equilibration, i.e., A has been premultiplied by */
  104. /* diag(R). */
  105. /* = 'C': Column equilibration, i.e., A has been postmultiplied */
  106. /* by diag(C). */
  107. /* = 'B': Both row and column equilibration, i.e., A has been */
  108. /* replaced by diag(R) * A * diag(C). */
  109. /* The right hand side B has been changed accordingly. */
  110. /* N (input) INTEGER */
  111. /* The order of the matrix A. N >= 0. */
  112. /* NRHS (input) INTEGER */
  113. /* The number of right hand sides, i.e., the number of columns */
  114. /* of the matrices B and X. NRHS >= 0. */
  115. /* A (input) DOUBLE PRECISION array, dimension (LDA,N) */
  116. /* The original N-by-N matrix A. */
  117. /* LDA (input) INTEGER */
  118. /* The leading dimension of the array A. LDA >= max(1,N). */
  119. /* AF (input) DOUBLE PRECISION array, dimension (LDAF,N) */
  120. /* The factors L and U from the factorization A = P*L*U */
  121. /* as computed by DGETRF. */
  122. /* LDAF (input) INTEGER */
  123. /* The leading dimension of the array AF. LDAF >= max(1,N). */
  124. /* IPIV (input) INTEGER array, dimension (N) */
  125. /* The pivot indices from DGETRF; for 1<=i<=N, row i of the */
  126. /* matrix was interchanged with row IPIV(i). */
  127. /* R (input or output) DOUBLE PRECISION array, dimension (N) */
  128. /* The row scale factors for A. If EQUED = 'R' or 'B', A is */
  129. /* multiplied on the left by diag(R); if EQUED = 'N' or 'C', R */
  130. /* is not accessed. R is an input argument if FACT = 'F'; */
  131. /* otherwise, R is an output argument. If FACT = 'F' and */
  132. /* EQUED = 'R' or 'B', each element of R must be positive. */
  133. /* If R is output, each element of R is a power of the radix. */
  134. /* If R is input, each element of R should be a power of the radix */
  135. /* to ensure a reliable solution and error estimates. Scaling by */
  136. /* powers of the radix does not cause rounding errors unless the */
  137. /* result underflows or overflows. Rounding errors during scaling */
  138. /* lead to refining with a matrix that is not equivalent to the */
  139. /* input matrix, producing error estimates that may not be */
  140. /* reliable. */
  141. /* C (input or output) DOUBLE PRECISION array, dimension (N) */
  142. /* The column scale factors for A. If EQUED = 'C' or 'B', A is */
  143. /* multiplied on the right by diag(C); if EQUED = 'N' or 'R', C */
  144. /* is not accessed. C is an input argument if FACT = 'F'; */
  145. /* otherwise, C is an output argument. If FACT = 'F' and */
  146. /* EQUED = 'C' or 'B', each element of C must be positive. */
  147. /* If C is output, each element of C is a power of the radix. */
  148. /* If C is input, each element of C should be a power of the radix */
  149. /* to ensure a reliable solution and error estimates. Scaling by */
  150. /* powers of the radix does not cause rounding errors unless the */
  151. /* result underflows or overflows. Rounding errors during scaling */
  152. /* lead to refining with a matrix that is not equivalent to the */
  153. /* input matrix, producing error estimates that may not be */
  154. /* reliable. */
  155. /* B (input) DOUBLE PRECISION array, dimension (LDB,NRHS) */
  156. /* The right hand side matrix B. */
  157. /* LDB (input) INTEGER */
  158. /* The leading dimension of the array B. LDB >= max(1,N). */
  159. /* X (input/output) DOUBLE PRECISION array, dimension (LDX,NRHS) */
  160. /* On entry, the solution matrix X, as computed by DGETRS. */
  161. /* On exit, the improved solution matrix X. */
  162. /* LDX (input) INTEGER */
  163. /* The leading dimension of the array X. LDX >= max(1,N). */
  164. /* RCOND (output) DOUBLE PRECISION */
  165. /* Reciprocal scaled condition number. This is an estimate of the */
  166. /* reciprocal Skeel condition number of the matrix A after */
  167. /* equilibration (if done). If this is less than the machine */
  168. /* precision (in particular, if it is zero), the matrix is singular */
  169. /* to working precision. Note that the error may still be small even */
  170. /* if this number is very small and the matrix appears ill- */
  171. /* conditioned. */
  172. /* BERR (output) DOUBLE PRECISION array, dimension (NRHS) */
  173. /* Componentwise relative backward error. This is the */
  174. /* componentwise relative backward error of each solution vector X(j) */
  175. /* (i.e., the smallest relative change in any element of A or B that */
  176. /* makes X(j) an exact solution). */
  177. /* N_ERR_BNDS (input) INTEGER */
  178. /* Number of error bounds to return for each right hand side */
  179. /* and each type (normwise or componentwise). See ERR_BNDS_NORM and */
  180. /* ERR_BNDS_COMP below. */
  181. /* ERR_BNDS_NORM (output) DOUBLE PRECISION array, dimension (NRHS, N_ERR_BNDS) */
  182. /* For each right-hand side, this array contains information about */
  183. /* various error bounds and condition numbers corresponding to the */
  184. /* normwise relative error, which is defined as follows: */
  185. /* Normwise relative error in the ith solution vector: */
  186. /* max_j (abs(XTRUE(j,i) - X(j,i))) */
  187. /* ------------------------------ */
  188. /* max_j abs(X(j,i)) */
  189. /* The array is indexed by the type of error information as described */
  190. /* below. There currently are up to three pieces of information */
  191. /* returned. */
  192. /* The first index in ERR_BNDS_NORM(i,:) corresponds to the ith */
  193. /* right-hand side. */
  194. /* The second index in ERR_BNDS_NORM(:,err) contains the following */
  195. /* three fields: */
  196. /* err = 1 "Trust/don't trust" boolean. Trust the answer if the */
  197. /* reciprocal condition number is less than the threshold */
  198. /* sqrt(n) * dlamch('Epsilon'). */
  199. /* err = 2 "Guaranteed" error bound: The estimated forward error, */
  200. /* almost certainly within a factor of 10 of the true error */
  201. /* so long as the next entry is greater than the threshold */
  202. /* sqrt(n) * dlamch('Epsilon'). This error bound should only */
  203. /* be trusted if the previous boolean is true. */
  204. /* err = 3 Reciprocal condition number: Estimated normwise */
  205. /* reciprocal condition number. Compared with the threshold */
  206. /* sqrt(n) * dlamch('Epsilon') to determine if the error */
  207. /* estimate is "guaranteed". These reciprocal condition */
  208. /* numbers are 1 / (norm(Z^{-1},inf) * norm(Z,inf)) for some */
  209. /* appropriately scaled matrix Z. */
  210. /* Let Z = S*A, where S scales each row by a power of the */
  211. /* radix so all absolute row sums of Z are approximately 1. */
  212. /* See Lapack Working Note 165 for further details and extra */
  213. /* cautions. */
  214. /* ERR_BNDS_COMP (output) DOUBLE PRECISION array, dimension (NRHS, N_ERR_BNDS) */
  215. /* For each right-hand side, this array contains information about */
  216. /* various error bounds and condition numbers corresponding to the */
  217. /* componentwise relative error, which is defined as follows: */
  218. /* Componentwise relative error in the ith solution vector: */
  219. /* abs(XTRUE(j,i) - X(j,i)) */
  220. /* max_j ---------------------- */
  221. /* abs(X(j,i)) */
  222. /* The array is indexed by the right-hand side i (on which the */
  223. /* componentwise relative error depends), and the type of error */
  224. /* information as described below. There currently are up to three */
  225. /* pieces of information returned for each right-hand side. If */
  226. /* componentwise accuracy is not requested (PARAMS(3) = 0.0), then */
  227. /* ERR_BNDS_COMP is not accessed. If N_ERR_BNDS .LT. 3, then at most */
  228. /* the first (:,N_ERR_BNDS) entries are returned. */
  229. /* The first index in ERR_BNDS_COMP(i,:) corresponds to the ith */
  230. /* right-hand side. */
  231. /* The second index in ERR_BNDS_COMP(:,err) contains the following */
  232. /* three fields: */
  233. /* err = 1 "Trust/don't trust" boolean. Trust the answer if the */
  234. /* reciprocal condition number is less than the threshold */
  235. /* sqrt(n) * dlamch('Epsilon'). */
  236. /* err = 2 "Guaranteed" error bound: The estimated forward error, */
  237. /* almost certainly within a factor of 10 of the true error */
  238. /* so long as the next entry is greater than the threshold */
  239. /* sqrt(n) * dlamch('Epsilon'). This error bound should only */
  240. /* be trusted if the previous boolean is true. */
  241. /* err = 3 Reciprocal condition number: Estimated componentwise */
  242. /* reciprocal condition number. Compared with the threshold */
  243. /* sqrt(n) * dlamch('Epsilon') to determine if the error */
  244. /* estimate is "guaranteed". These reciprocal condition */
  245. /* numbers are 1 / (norm(Z^{-1},inf) * norm(Z,inf)) for some */
  246. /* appropriately scaled matrix Z. */
  247. /* Let Z = S*(A*diag(x)), where x is the solution for the */
  248. /* current right-hand side and S scales each row of */
  249. /* A*diag(x) by a power of the radix so all absolute row */
  250. /* sums of Z are approximately 1. */
  251. /* See Lapack Working Note 165 for further details and extra */
  252. /* cautions. */
  253. /* NPARAMS (input) INTEGER */
  254. /* Specifies the number of parameters set in PARAMS. If .LE. 0, the */
  255. /* PARAMS array is never referenced and default values are used. */
  256. /* PARAMS (input / output) DOUBLE PRECISION array, dimension NPARAMS */
  257. /* Specifies algorithm parameters. If an entry is .LT. 0.0, then */
  258. /* that entry will be filled with default value used for that */
  259. /* parameter. Only positions up to NPARAMS are accessed; defaults */
  260. /* are used for higher-numbered parameters. */
  261. /* PARAMS(LA_LINRX_ITREF_I = 1) : Whether to perform iterative */
  262. /* refinement or not. */
  263. /* Default: 1.0D+0 */
  264. /* = 0.0 : No refinement is performed, and no error bounds are */
  265. /* computed. */
  266. /* = 1.0 : Use the double-precision refinement algorithm, */
  267. /* possibly with doubled-single computations if the */
  268. /* compilation environment does not support DOUBLE */
  269. /* PRECISION. */
  270. /* (other values are reserved for future use) */
  271. /* PARAMS(LA_LINRX_ITHRESH_I = 2) : Maximum number of residual */
  272. /* computations allowed for refinement. */
  273. /* Default: 10 */
  274. /* Aggressive: Set to 100 to permit convergence using approximate */
  275. /* factorizations or factorizations other than LU. If */
  276. /* the factorization uses a technique other than */
  277. /* Gaussian elimination, the guarantees in */
  278. /* err_bnds_norm and err_bnds_comp may no longer be */
  279. /* trustworthy. */
  280. /* PARAMS(LA_LINRX_CWISE_I = 3) : Flag determining if the code */
  281. /* will attempt to find a solution with small componentwise */
  282. /* relative error in the double-precision algorithm. Positive */
  283. /* is true, 0.0 is false. */
  284. /* Default: 1.0 (attempt componentwise convergence) */
  285. /* WORK (workspace) DOUBLE PRECISION array, dimension (4*N) */
  286. /* IWORK (workspace) INTEGER array, dimension (N) */
  287. /* INFO (output) INTEGER */
  288. /* = 0: Successful exit. The solution to every right-hand side is */
  289. /* guaranteed. */
  290. /* < 0: If INFO = -i, the i-th argument had an illegal value */
  291. /* > 0 and <= N: U(INFO,INFO) is exactly zero. The factorization */
  292. /* has been completed, but the factor U is exactly singular, so */
  293. /* the solution and error bounds could not be computed. RCOND = 0 */
  294. /* is returned. */
  295. /* = N+J: The solution corresponding to the Jth right-hand side is */
  296. /* not guaranteed. The solutions corresponding to other right- */
  297. /* hand sides K with K > J may not be guaranteed as well, but */
  298. /* only the first such right-hand side is reported. If a small */
  299. /* componentwise error is not requested (PARAMS(3) = 0.0) then */
  300. /* the Jth right-hand side is the first with a normwise error */
  301. /* bound that is not guaranteed (the smallest J such */
  302. /* that ERR_BNDS_NORM(J,1) = 0.0). By default (PARAMS(3) = 1.0) */
  303. /* the Jth right-hand side is the first with either a normwise or */
  304. /* componentwise error bound that is not guaranteed (the smallest */
  305. /* J such that either ERR_BNDS_NORM(J,1) = 0.0 or */
  306. /* ERR_BNDS_COMP(J,1) = 0.0). See the definition of */
  307. /* ERR_BNDS_NORM(:,1) and ERR_BNDS_COMP(:,1). To get information */
  308. /* about all of the right-hand sides check ERR_BNDS_NORM or */
  309. /* ERR_BNDS_COMP. */
  310. /* ================================================================== */
  311. /* .. Parameters .. */
  312. /* .. */
  313. /* .. Local Scalars .. */
  314. /* .. */
  315. /* .. External Subroutines .. */
  316. /* .. */
  317. /* .. Intrinsic Functions .. */
  318. /* .. */
  319. /* .. External Functions .. */
  320. /* .. */
  321. /* .. Executable Statements .. */
  322. /* Check the input parameters. */
  323. /* Parameter adjustments */
  324. err_bnds_comp_dim1 = *nrhs;
  325. err_bnds_comp_offset = 1 + err_bnds_comp_dim1;
  326. err_bnds_comp__ -= err_bnds_comp_offset;
  327. err_bnds_norm_dim1 = *nrhs;
  328. err_bnds_norm_offset = 1 + err_bnds_norm_dim1;
  329. err_bnds_norm__ -= err_bnds_norm_offset;
  330. a_dim1 = *lda;
  331. a_offset = 1 + a_dim1;
  332. a -= a_offset;
  333. af_dim1 = *ldaf;
  334. af_offset = 1 + af_dim1;
  335. af -= af_offset;
  336. --ipiv;
  337. --r__;
  338. --c__;
  339. b_dim1 = *ldb;
  340. b_offset = 1 + b_dim1;
  341. b -= b_offset;
  342. x_dim1 = *ldx;
  343. x_offset = 1 + x_dim1;
  344. x -= x_offset;
  345. --berr;
  346. --params;
  347. --work;
  348. --iwork;
  349. /* Function Body */
  350. *info = 0;
  351. trans_type__ = _starpu_ilatrans_(trans);
  352. ref_type__ = 1;
  353. if (*nparams >= 1) {
  354. if (params[1] < 0.) {
  355. params[1] = 1.;
  356. } else {
  357. ref_type__ = (integer) params[1];
  358. }
  359. }
  360. /* Set default parameters. */
  361. illrcond_thresh__ = (doublereal) (*n) * _starpu_dlamch_("Epsilon");
  362. ithresh = 10;
  363. rthresh = .5;
  364. unstable_thresh__ = .25;
  365. ignore_cwise__ = FALSE_;
  366. if (*nparams >= 2) {
  367. if (params[2] < 0.) {
  368. params[2] = (doublereal) ithresh;
  369. } else {
  370. ithresh = (integer) params[2];
  371. }
  372. }
  373. if (*nparams >= 3) {
  374. if (params[3] < 0.) {
  375. if (ignore_cwise__) {
  376. params[3] = 0.;
  377. } else {
  378. params[3] = 1.;
  379. }
  380. } else {
  381. ignore_cwise__ = params[3] == 0.;
  382. }
  383. }
  384. if (ref_type__ == 0 || *n_err_bnds__ == 0) {
  385. n_norms__ = 0;
  386. } else if (ignore_cwise__) {
  387. n_norms__ = 1;
  388. } else {
  389. n_norms__ = 2;
  390. }
  391. notran = _starpu_lsame_(trans, "N");
  392. rowequ = _starpu_lsame_(equed, "R") || _starpu_lsame_(equed, "B");
  393. colequ = _starpu_lsame_(equed, "C") || _starpu_lsame_(equed, "B");
  394. /* Test input parameters. */
  395. if (trans_type__ == -1) {
  396. *info = -1;
  397. } else if (! rowequ && ! colequ && ! _starpu_lsame_(equed, "N")) {
  398. *info = -2;
  399. } else if (*n < 0) {
  400. *info = -3;
  401. } else if (*nrhs < 0) {
  402. *info = -4;
  403. } else if (*lda < max(1,*n)) {
  404. *info = -6;
  405. } else if (*ldaf < max(1,*n)) {
  406. *info = -8;
  407. } else if (*ldb < max(1,*n)) {
  408. *info = -13;
  409. } else if (*ldx < max(1,*n)) {
  410. *info = -15;
  411. }
  412. if (*info != 0) {
  413. i__1 = -(*info);
  414. _starpu_xerbla_("DGERFSX", &i__1);
  415. return 0;
  416. }
  417. /* Quick return if possible. */
  418. if (*n == 0 || *nrhs == 0) {
  419. *rcond = 1.;
  420. i__1 = *nrhs;
  421. for (j = 1; j <= i__1; ++j) {
  422. berr[j] = 0.;
  423. if (*n_err_bnds__ >= 1) {
  424. err_bnds_norm__[j + err_bnds_norm_dim1] = 1.;
  425. err_bnds_comp__[j + err_bnds_comp_dim1] = 1.;
  426. } else if (*n_err_bnds__ >= 2) {
  427. err_bnds_norm__[j + (err_bnds_norm_dim1 << 1)] = 0.;
  428. err_bnds_comp__[j + (err_bnds_comp_dim1 << 1)] = 0.;
  429. } else if (*n_err_bnds__ >= 3) {
  430. err_bnds_norm__[j + err_bnds_norm_dim1 * 3] = 1.;
  431. err_bnds_comp__[j + err_bnds_comp_dim1 * 3] = 1.;
  432. }
  433. }
  434. return 0;
  435. }
  436. /* Default to failure. */
  437. *rcond = 0.;
  438. i__1 = *nrhs;
  439. for (j = 1; j <= i__1; ++j) {
  440. berr[j] = 1.;
  441. if (*n_err_bnds__ >= 1) {
  442. err_bnds_norm__[j + err_bnds_norm_dim1] = 1.;
  443. err_bnds_comp__[j + err_bnds_comp_dim1] = 1.;
  444. } else if (*n_err_bnds__ >= 2) {
  445. err_bnds_norm__[j + (err_bnds_norm_dim1 << 1)] = 1.;
  446. err_bnds_comp__[j + (err_bnds_comp_dim1 << 1)] = 1.;
  447. } else if (*n_err_bnds__ >= 3) {
  448. err_bnds_norm__[j + err_bnds_norm_dim1 * 3] = 0.;
  449. err_bnds_comp__[j + err_bnds_comp_dim1 * 3] = 0.;
  450. }
  451. }
  452. /* Compute the norm of A and the reciprocal of the condition */
  453. /* number of A. */
  454. if (notran) {
  455. *(unsigned char *)norm = 'I';
  456. } else {
  457. *(unsigned char *)norm = '1';
  458. }
  459. anorm = _starpu_dlange_(norm, n, n, &a[a_offset], lda, &work[1]);
  460. _starpu_dgecon_(norm, n, &af[af_offset], ldaf, &anorm, rcond, &work[1], &iwork[1],
  461. info);
  462. /* Perform refinement on each right-hand side */
  463. if (ref_type__ != 0) {
  464. prec_type__ = _starpu_ilaprec_("E");
  465. if (notran) {
  466. _starpu_dla_gerfsx_extended__(&prec_type__, &trans_type__, n, nrhs, &a[
  467. a_offset], lda, &af[af_offset], ldaf, &ipiv[1], &colequ, &
  468. c__[1], &b[b_offset], ldb, &x[x_offset], ldx, &berr[1], &
  469. n_norms__, &err_bnds_norm__[err_bnds_norm_offset], &
  470. err_bnds_comp__[err_bnds_comp_offset], &work[*n + 1], &
  471. work[1], &work[(*n << 1) + 1], &work[1], rcond, &ithresh,
  472. &rthresh, &unstable_thresh__, &ignore_cwise__, info);
  473. } else {
  474. _starpu_dla_gerfsx_extended__(&prec_type__, &trans_type__, n, nrhs, &a[
  475. a_offset], lda, &af[af_offset], ldaf, &ipiv[1], &rowequ, &
  476. r__[1], &b[b_offset], ldb, &x[x_offset], ldx, &berr[1], &
  477. n_norms__, &err_bnds_norm__[err_bnds_norm_offset], &
  478. err_bnds_comp__[err_bnds_comp_offset], &work[*n + 1], &
  479. work[1], &work[(*n << 1) + 1], &work[1], rcond, &ithresh,
  480. &rthresh, &unstable_thresh__, &ignore_cwise__, info);
  481. }
  482. }
  483. /* Computing MAX */
  484. d__1 = 10., d__2 = sqrt((doublereal) (*n));
  485. err_lbnd__ = max(d__1,d__2) * _starpu_dlamch_("Epsilon");
  486. if (*n_err_bnds__ >= 1 && n_norms__ >= 1) {
  487. /* Compute scaled normwise condition number cond(A*C). */
  488. if (colequ && notran) {
  489. rcond_tmp__ = _starpu_dla_gercond__(trans, n, &a[a_offset], lda, &af[
  490. af_offset], ldaf, &ipiv[1], &c_n1, &c__[1], info, &work[1]
  491. , &iwork[1], (ftnlen)1);
  492. } else if (rowequ && ! notran) {
  493. rcond_tmp__ = _starpu_dla_gercond__(trans, n, &a[a_offset], lda, &af[
  494. af_offset], ldaf, &ipiv[1], &c_n1, &r__[1], info, &work[1]
  495. , &iwork[1], (ftnlen)1);
  496. } else {
  497. rcond_tmp__ = _starpu_dla_gercond__(trans, n, &a[a_offset], lda, &af[
  498. af_offset], ldaf, &ipiv[1], &c__0, &r__[1], info, &work[1]
  499. , &iwork[1], (ftnlen)1);
  500. }
  501. i__1 = *nrhs;
  502. for (j = 1; j <= i__1; ++j) {
  503. /* Cap the error at 1.0. */
  504. if (*n_err_bnds__ >= 2 && err_bnds_norm__[j + (err_bnds_norm_dim1
  505. << 1)] > 1.) {
  506. err_bnds_norm__[j + (err_bnds_norm_dim1 << 1)] = 1.;
  507. }
  508. /* Threshold the error (see LAWN). */
  509. if (rcond_tmp__ < illrcond_thresh__) {
  510. err_bnds_norm__[j + (err_bnds_norm_dim1 << 1)] = 1.;
  511. err_bnds_norm__[j + err_bnds_norm_dim1] = 0.;
  512. if (*info <= *n) {
  513. *info = *n + j;
  514. }
  515. } else if (err_bnds_norm__[j + (err_bnds_norm_dim1 << 1)] <
  516. err_lbnd__) {
  517. err_bnds_norm__[j + (err_bnds_norm_dim1 << 1)] = err_lbnd__;
  518. err_bnds_norm__[j + err_bnds_norm_dim1] = 1.;
  519. }
  520. /* Save the condition number. */
  521. if (*n_err_bnds__ >= 3) {
  522. err_bnds_norm__[j + err_bnds_norm_dim1 * 3] = rcond_tmp__;
  523. }
  524. }
  525. }
  526. if (*n_err_bnds__ >= 1 && n_norms__ >= 2) {
  527. /* Compute componentwise condition number cond(A*diag(Y(:,J))) for */
  528. /* each right-hand side using the current solution as an estimate of */
  529. /* the true solution. If the componentwise error estimate is too */
  530. /* large, then the solution is a lousy estimate of truth and the */
  531. /* estimated RCOND may be too optimistic. To avoid misleading users, */
  532. /* the inverse condition number is set to 0.0 when the estimated */
  533. /* cwise error is at least CWISE_WRONG. */
  534. cwise_wrong__ = sqrt(_starpu_dlamch_("Epsilon"));
  535. i__1 = *nrhs;
  536. for (j = 1; j <= i__1; ++j) {
  537. if (err_bnds_comp__[j + (err_bnds_comp_dim1 << 1)] <
  538. cwise_wrong__) {
  539. rcond_tmp__ = _starpu_dla_gercond__(trans, n, &a[a_offset], lda, &af[
  540. af_offset], ldaf, &ipiv[1], &c__1, &x[j * x_dim1 + 1],
  541. info, &work[1], &iwork[1], (ftnlen)1);
  542. } else {
  543. rcond_tmp__ = 0.;
  544. }
  545. /* Cap the error at 1.0. */
  546. if (*n_err_bnds__ >= 2 && err_bnds_comp__[j + (err_bnds_comp_dim1
  547. << 1)] > 1.) {
  548. err_bnds_comp__[j + (err_bnds_comp_dim1 << 1)] = 1.;
  549. }
  550. /* Threshold the error (see LAWN). */
  551. if (rcond_tmp__ < illrcond_thresh__) {
  552. err_bnds_comp__[j + (err_bnds_comp_dim1 << 1)] = 1.;
  553. err_bnds_comp__[j + err_bnds_comp_dim1] = 0.;
  554. if (params[3] == 1. && *info < *n + j) {
  555. *info = *n + j;
  556. }
  557. } else if (err_bnds_comp__[j + (err_bnds_comp_dim1 << 1)] <
  558. err_lbnd__) {
  559. err_bnds_comp__[j + (err_bnds_comp_dim1 << 1)] = err_lbnd__;
  560. err_bnds_comp__[j + err_bnds_comp_dim1] = 1.;
  561. }
  562. /* Save the condition number. */
  563. if (*n_err_bnds__ >= 3) {
  564. err_bnds_comp__[j + err_bnds_comp_dim1 * 3] = rcond_tmp__;
  565. }
  566. }
  567. }
  568. return 0;
  569. /* End of DGERFSX */
  570. } /* _starpu_dgerfsx_ */