dsyrfsx.c 24 KB

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