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.

sgbrfsx.c 41 kB

123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102103104105106107108109110111112113114115116117118119120121122123124125126127128129130131132133134135136137138139140141142143144145146147148149150151152153154155156157158159160161162163164165166167168169170171172173174175176177178179180181182183184185186187188189190191192193194195196197198199200201202203204205206207208209210211212213214215216217218219220221222223224225226227228229230231232233234235236237238239240241242243244245246247248249250251252253254255256257258259260261262263264265266267268269270271272273274275276277278279280281282283284285286287288289290291292293294295296297298299300301302303304305306307308309310311312313314315316317318319320321322323324325326327328329330331332333334335336337338339340341342343344345346347348349350351352353354355356357358359360361362363364365366367368369370371372373374375376377378379380381382383384385386387388389390391392393394395396397398399400401402403404405406407408409410411412413414415416417418419420421422423424425426427428429430431432433434435436437438439440441442443444445446447448449450451452453454455456457458459460461462463464465466467468469470471472473474475476477478479480481482483484485486487488489490491492493494495496497498499500501502503504505506507508509510511512513514515516517518519520521522523524525526527528529530531532533534535536537538539540541542543544545546547548549550551552553554555556557558559560561562563564565566567568569570571572573574575576577578579580581582583584585586587588589590591592593594595596597598599600601602603604605606607608609610611612613614615616617618619620621622623624625626627628629630631632633634635636637638639640641642643644645646647648649650651652653654655656657658659660661662663664665666667668669670671672673674675676677678679680681682683684685686687688689690691692693694695696697698699700701702703704705706707708709710711712713714715716717718719720721722723724725726727728729730731732733734735736737738739740741742743744745746747748749750751752753754755756757758759760761762763764765766767768769770771772773774775776777778779780781782783784785786787788789790791792793794795796797798799800801802803804805806807808809810811812813814815816817818819820821822823824825826827828829830831832833834835836837838839840841842843844845846847848849850851852853854855856857858859860861862863864865866867868869870871872873874875876877878879880881882883884885886887888889890891892893894895896897898899900901902903904905906907908909910911912913914915916917918919920921922923924925926927928929930931932933934935936937938939940941942943944945946947948949950951952953954955956957958959960961962963964965966967968969970971972973974975976977978979980981982983984985986987988989990991992993994995996997998999100010011002100310041005100610071008100910101011101210131014101510161017101810191020102110221023102410251026102710281029103010311032103310341035103610371038103910401041104210431044104510461047104810491050105110521053105410551056105710581059106010611062106310641065106610671068106910701071107210731074107510761077107810791080108110821083108410851086108710881089109010911092109310941095109610971098109911001101110211031104110511061107110811091110111111121113111411151116111711181119112011211122112311241125112611271128112911301131113211331134113511361137113811391140114111421143114411451146114711481149115011511152115311541155115611571158115911601161116211631164116511661167116811691170117111721173117411751176117711781179118011811182118311841185118611871188118911901191119211931194119511961197119811991200
  1. /* f2c.h -- Standard Fortran to C header file */
  2. /** barf [ba:rf] 2. "He suggested using FORTRAN, and everybody barfed."
  3. - From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) */
  4. #ifndef F2C_INCLUDE
  5. #define F2C_INCLUDE
  6. #include <math.h>
  7. #include <stdlib.h>
  8. #include <string.h>
  9. #include <stdio.h>
  10. #include <complex.h>
  11. #ifdef complex
  12. #undef complex
  13. #endif
  14. #ifdef I
  15. #undef I
  16. #endif
  17. #if defined(_WIN64)
  18. typedef long long BLASLONG;
  19. typedef unsigned long long BLASULONG;
  20. #else
  21. typedef long BLASLONG;
  22. typedef unsigned long BLASULONG;
  23. #endif
  24. #ifdef LAPACK_ILP64
  25. typedef BLASLONG blasint;
  26. #if defined(_WIN64)
  27. #define blasabs(x) llabs(x)
  28. #else
  29. #define blasabs(x) labs(x)
  30. #endif
  31. #else
  32. typedef int blasint;
  33. #define blasabs(x) abs(x)
  34. #endif
  35. typedef blasint integer;
  36. typedef unsigned int uinteger;
  37. typedef char *address;
  38. typedef short int shortint;
  39. typedef float real;
  40. typedef double doublereal;
  41. typedef struct { real r, i; } complex;
  42. typedef struct { doublereal r, i; } doublecomplex;
  43. static inline _Complex float Cf(complex *z) {return z->r + z->i*_Complex_I;}
  44. static inline _Complex double Cd(doublecomplex *z) {return z->r + z->i*_Complex_I;}
  45. static inline _Complex float * _pCf(complex *z) {return (_Complex float*)z;}
  46. static inline _Complex double * _pCd(doublecomplex *z) {return (_Complex double*)z;}
  47. #define pCf(z) (*_pCf(z))
  48. #define pCd(z) (*_pCd(z))
  49. typedef blasint logical;
  50. typedef char logical1;
  51. typedef char integer1;
  52. #define TRUE_ (1)
  53. #define FALSE_ (0)
  54. /* Extern is for use with -E */
  55. #ifndef Extern
  56. #define Extern extern
  57. #endif
  58. /* I/O stuff */
  59. typedef int flag;
  60. typedef int ftnlen;
  61. typedef int ftnint;
  62. /*external read, write*/
  63. typedef struct
  64. { flag cierr;
  65. ftnint ciunit;
  66. flag ciend;
  67. char *cifmt;
  68. ftnint cirec;
  69. } cilist;
  70. /*internal read, write*/
  71. typedef struct
  72. { flag icierr;
  73. char *iciunit;
  74. flag iciend;
  75. char *icifmt;
  76. ftnint icirlen;
  77. ftnint icirnum;
  78. } icilist;
  79. /*open*/
  80. typedef struct
  81. { flag oerr;
  82. ftnint ounit;
  83. char *ofnm;
  84. ftnlen ofnmlen;
  85. char *osta;
  86. char *oacc;
  87. char *ofm;
  88. ftnint orl;
  89. char *oblnk;
  90. } olist;
  91. /*close*/
  92. typedef struct
  93. { flag cerr;
  94. ftnint cunit;
  95. char *csta;
  96. } cllist;
  97. /*rewind, backspace, endfile*/
  98. typedef struct
  99. { flag aerr;
  100. ftnint aunit;
  101. } alist;
  102. /* inquire */
  103. typedef struct
  104. { flag inerr;
  105. ftnint inunit;
  106. char *infile;
  107. ftnlen infilen;
  108. ftnint *inex; /*parameters in standard's order*/
  109. ftnint *inopen;
  110. ftnint *innum;
  111. ftnint *innamed;
  112. char *inname;
  113. ftnlen innamlen;
  114. char *inacc;
  115. ftnlen inacclen;
  116. char *inseq;
  117. ftnlen inseqlen;
  118. char *indir;
  119. ftnlen indirlen;
  120. char *infmt;
  121. ftnlen infmtlen;
  122. char *inform;
  123. ftnint informlen;
  124. char *inunf;
  125. ftnlen inunflen;
  126. ftnint *inrecl;
  127. ftnint *innrec;
  128. char *inblank;
  129. ftnlen inblanklen;
  130. } inlist;
  131. #define VOID void
  132. union Multitype { /* for multiple entry points */
  133. integer1 g;
  134. shortint h;
  135. integer i;
  136. /* longint j; */
  137. real r;
  138. doublereal d;
  139. complex c;
  140. doublecomplex z;
  141. };
  142. typedef union Multitype Multitype;
  143. struct Vardesc { /* for Namelist */
  144. char *name;
  145. char *addr;
  146. ftnlen *dims;
  147. int type;
  148. };
  149. typedef struct Vardesc Vardesc;
  150. struct Namelist {
  151. char *name;
  152. Vardesc **vars;
  153. int nvars;
  154. };
  155. typedef struct Namelist Namelist;
  156. #define abs(x) ((x) >= 0 ? (x) : -(x))
  157. #define dabs(x) (fabs(x))
  158. #define f2cmin(a,b) ((a) <= (b) ? (a) : (b))
  159. #define f2cmax(a,b) ((a) >= (b) ? (a) : (b))
  160. #define dmin(a,b) (f2cmin(a,b))
  161. #define dmax(a,b) (f2cmax(a,b))
  162. #define bit_test(a,b) ((a) >> (b) & 1)
  163. #define bit_clear(a,b) ((a) & ~((uinteger)1 << (b)))
  164. #define bit_set(a,b) ((a) | ((uinteger)1 << (b)))
  165. #define abort_() { sig_die("Fortran abort routine called", 1); }
  166. #define c_abs(z) (cabsf(Cf(z)))
  167. #define c_cos(R,Z) { pCf(R)=ccos(Cf(Z)); }
  168. #define c_div(c, a, b) {pCf(c) = Cf(a)/Cf(b);}
  169. #define z_div(c, a, b) {pCd(c) = Cd(a)/Cd(b);}
  170. #define c_exp(R, Z) {pCf(R) = cexpf(Cf(Z));}
  171. #define c_log(R, Z) {pCf(R) = clogf(Cf(Z));}
  172. #define c_sin(R, Z) {pCf(R) = csinf(Cf(Z));}
  173. //#define c_sqrt(R, Z) {*(R) = csqrtf(Cf(Z));}
  174. #define c_sqrt(R, Z) {pCf(R) = csqrtf(Cf(Z));}
  175. #define d_abs(x) (fabs(*(x)))
  176. #define d_acos(x) (acos(*(x)))
  177. #define d_asin(x) (asin(*(x)))
  178. #define d_atan(x) (atan(*(x)))
  179. #define d_atn2(x, y) (atan2(*(x),*(y)))
  180. #define d_cnjg(R, Z) { pCd(R) = conj(Cd(Z)); }
  181. #define r_cnjg(R, Z) { pCf(R) = conj(Cf(Z)); }
  182. #define d_cos(x) (cos(*(x)))
  183. #define d_cosh(x) (cosh(*(x)))
  184. #define d_dim(__a, __b) ( *(__a) > *(__b) ? *(__a) - *(__b) : 0.0 )
  185. #define d_exp(x) (exp(*(x)))
  186. #define d_imag(z) (cimag(Cd(z)))
  187. #define r_imag(z) (cimag(Cf(z)))
  188. #define d_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x)))
  189. #define r_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x)))
  190. #define d_lg10(x) ( 0.43429448190325182765 * log(*(x)) )
  191. #define r_lg10(x) ( 0.43429448190325182765 * log(*(x)) )
  192. #define d_log(x) (log(*(x)))
  193. #define d_mod(x, y) (fmod(*(x), *(y)))
  194. #define u_nint(__x) ((__x)>=0 ? floor((__x) + .5) : -floor(.5 - (__x)))
  195. #define d_nint(x) u_nint(*(x))
  196. #define u_sign(__a,__b) ((__b) >= 0 ? ((__a) >= 0 ? (__a) : -(__a)) : -((__a) >= 0 ? (__a) : -(__a)))
  197. #define d_sign(a,b) u_sign(*(a),*(b))
  198. #define r_sign(a,b) u_sign(*(a),*(b))
  199. #define d_sin(x) (sin(*(x)))
  200. #define d_sinh(x) (sinh(*(x)))
  201. #define d_sqrt(x) (sqrt(*(x)))
  202. #define d_tan(x) (tan(*(x)))
  203. #define d_tanh(x) (tanh(*(x)))
  204. #define i_abs(x) abs(*(x))
  205. #define i_dnnt(x) ((integer)u_nint(*(x)))
  206. #define i_len(s, n) (n)
  207. #define i_nint(x) ((integer)u_nint(*(x)))
  208. #define i_sign(a,b) ((integer)u_sign((integer)*(a),(integer)*(b)))
  209. #define pow_dd(ap, bp) ( pow(*(ap), *(bp)))
  210. #define pow_si(B,E) spow_ui(*(B),*(E))
  211. #define pow_ri(B,E) spow_ui(*(B),*(E))
  212. #define pow_di(B,E) dpow_ui(*(B),*(E))
  213. #define pow_zi(p, a, b) {pCd(p) = zpow_ui(Cd(a), *(b));}
  214. #define pow_ci(p, a, b) {pCf(p) = cpow_ui(Cf(a), *(b));}
  215. #define pow_zz(R,A,B) {pCd(R) = cpow(Cd(A),*(B));}
  216. #define s_cat(lpp, rpp, rnp, np, llp) { ftnlen i, nc, ll; char *f__rp, *lp; ll = (llp); lp = (lpp); for(i=0; i < (int)*(np); ++i) { nc = ll; if((rnp)[i] < nc) nc = (rnp)[i]; ll -= nc; f__rp = (rpp)[i]; while(--nc >= 0) *lp++ = *(f__rp)++; } while(--ll >= 0) *lp++ = ' '; }
  217. #define s_cmp(a,b,c,d) ((integer)strncmp((a),(b),f2cmin((c),(d))))
  218. #define s_copy(A,B,C,D) { int __i,__m; for (__i=0, __m=f2cmin((C),(D)); __i<__m && (B)[__i] != 0; ++__i) (A)[__i] = (B)[__i]; }
  219. #define sig_die(s, kill) { exit(1); }
  220. #define s_stop(s, n) {exit(0);}
  221. static char junk[] = "\n@(#)LIBF77 VERSION 19990503\n";
  222. #define z_abs(z) (cabs(Cd(z)))
  223. #define z_exp(R, Z) {pCd(R) = cexp(Cd(Z));}
  224. #define z_sqrt(R, Z) {pCd(R) = csqrt(Cd(Z));}
  225. #define myexit_() break;
  226. #define mycycle() continue;
  227. #define myceiling(w) {ceil(w)}
  228. #define myhuge(w) {HUGE_VAL}
  229. //#define mymaxloc_(w,s,e,n) {if (sizeof(*(w)) == sizeof(double)) dmaxloc_((w),*(s),*(e),n); else dmaxloc_((w),*(s),*(e),n);}
  230. #define mymaxloc(w,s,e,n) {dmaxloc_(w,*(s),*(e),n)}
  231. /* procedure parameter types for -A and -C++ */
  232. #ifdef __cplusplus
  233. typedef logical (*L_fp)(...);
  234. #else
  235. typedef logical (*L_fp)();
  236. #endif
  237. static float spow_ui(float x, integer n) {
  238. float pow=1.0; unsigned long int u;
  239. if(n != 0) {
  240. if(n < 0) n = -n, x = 1/x;
  241. for(u = n; ; ) {
  242. if(u & 01) pow *= x;
  243. if(u >>= 1) x *= x;
  244. else break;
  245. }
  246. }
  247. return pow;
  248. }
  249. static double dpow_ui(double x, integer n) {
  250. double pow=1.0; unsigned long int u;
  251. if(n != 0) {
  252. if(n < 0) n = -n, x = 1/x;
  253. for(u = n; ; ) {
  254. if(u & 01) pow *= x;
  255. if(u >>= 1) x *= x;
  256. else break;
  257. }
  258. }
  259. return pow;
  260. }
  261. static _Complex float cpow_ui(_Complex float x, integer n) {
  262. _Complex float pow=1.0; unsigned long int u;
  263. if(n != 0) {
  264. if(n < 0) n = -n, x = 1/x;
  265. for(u = n; ; ) {
  266. if(u & 01) pow *= x;
  267. if(u >>= 1) x *= x;
  268. else break;
  269. }
  270. }
  271. return pow;
  272. }
  273. static _Complex double zpow_ui(_Complex double x, integer n) {
  274. _Complex double pow=1.0; unsigned long int u;
  275. if(n != 0) {
  276. if(n < 0) n = -n, x = 1/x;
  277. for(u = n; ; ) {
  278. if(u & 01) pow *= x;
  279. if(u >>= 1) x *= x;
  280. else break;
  281. }
  282. }
  283. return pow;
  284. }
  285. static integer pow_ii(integer x, integer n) {
  286. integer pow; unsigned long int u;
  287. if (n <= 0) {
  288. if (n == 0 || x == 1) pow = 1;
  289. else if (x != -1) pow = x == 0 ? 1/x : 0;
  290. else n = -n;
  291. }
  292. if ((n > 0) || !(n == 0 || x == 1 || x != -1)) {
  293. u = n;
  294. for(pow = 1; ; ) {
  295. if(u & 01) pow *= x;
  296. if(u >>= 1) x *= x;
  297. else break;
  298. }
  299. }
  300. return pow;
  301. }
  302. static integer dmaxloc_(double *w, integer s, integer e, integer *n)
  303. {
  304. double m; integer i, mi;
  305. for(m=w[s-1], mi=s, i=s+1; i<=e; i++)
  306. if (w[i-1]>m) mi=i ,m=w[i-1];
  307. return mi-s+1;
  308. }
  309. static integer smaxloc_(float *w, integer s, integer e, integer *n)
  310. {
  311. float m; integer i, mi;
  312. for(m=w[s-1], mi=s, i=s+1; i<=e; i++)
  313. if (w[i-1]>m) mi=i ,m=w[i-1];
  314. return mi-s+1;
  315. }
  316. static inline void cdotc_(complex *z, integer *n_, complex *x, integer *incx_, complex *y, integer *incy_) {
  317. integer n = *n_, incx = *incx_, incy = *incy_, i;
  318. _Complex float zdotc = 0.0;
  319. if (incx == 1 && incy == 1) {
  320. for (i=0;i<n;i++) { /* zdotc = zdotc + dconjg(x(i))* y(i) */
  321. zdotc += conjf(Cf(&x[i])) * Cf(&y[i]);
  322. }
  323. } else {
  324. for (i=0;i<n;i++) { /* zdotc = zdotc + dconjg(x(i))* y(i) */
  325. zdotc += conjf(Cf(&x[i*incx])) * Cf(&y[i*incy]);
  326. }
  327. }
  328. pCf(z) = zdotc;
  329. }
  330. static inline void zdotc_(doublecomplex *z, integer *n_, doublecomplex *x, integer *incx_, doublecomplex *y, integer *incy_) {
  331. integer n = *n_, incx = *incx_, incy = *incy_, i;
  332. _Complex double zdotc = 0.0;
  333. if (incx == 1 && incy == 1) {
  334. for (i=0;i<n;i++) { /* zdotc = zdotc + dconjg(x(i))* y(i) */
  335. zdotc += conj(Cd(&x[i])) * Cd(&y[i]);
  336. }
  337. } else {
  338. for (i=0;i<n;i++) { /* zdotc = zdotc + dconjg(x(i))* y(i) */
  339. zdotc += conj(Cd(&x[i*incx])) * Cd(&y[i*incy]);
  340. }
  341. }
  342. pCd(z) = zdotc;
  343. }
  344. static inline void cdotu_(complex *z, integer *n_, complex *x, integer *incx_, complex *y, integer *incy_) {
  345. integer n = *n_, incx = *incx_, incy = *incy_, i;
  346. _Complex float zdotc = 0.0;
  347. if (incx == 1 && incy == 1) {
  348. for (i=0;i<n;i++) { /* zdotc = zdotc + dconjg(x(i))* y(i) */
  349. zdotc += Cf(&x[i]) * Cf(&y[i]);
  350. }
  351. } else {
  352. for (i=0;i<n;i++) { /* zdotc = zdotc + dconjg(x(i))* y(i) */
  353. zdotc += Cf(&x[i*incx]) * Cf(&y[i*incy]);
  354. }
  355. }
  356. pCf(z) = zdotc;
  357. }
  358. static inline void zdotu_(doublecomplex *z, integer *n_, doublecomplex *x, integer *incx_, doublecomplex *y, integer *incy_) {
  359. integer n = *n_, incx = *incx_, incy = *incy_, i;
  360. _Complex double zdotc = 0.0;
  361. if (incx == 1 && incy == 1) {
  362. for (i=0;i<n;i++) { /* zdotc = zdotc + dconjg(x(i))* y(i) */
  363. zdotc += Cd(&x[i]) * Cd(&y[i]);
  364. }
  365. } else {
  366. for (i=0;i<n;i++) { /* zdotc = zdotc + dconjg(x(i))* y(i) */
  367. zdotc += Cd(&x[i*incx]) * Cd(&y[i*incy]);
  368. }
  369. }
  370. pCd(z) = zdotc;
  371. }
  372. #endif
  373. /* -- translated by f2c (version 20000121).
  374. You must link the resulting object file with the libraries:
  375. -lf2c -lm (in that order)
  376. */
  377. /* Table of constant values */
  378. static integer c_n1 = -1;
  379. static integer c__0 = 0;
  380. static integer c__1 = 1;
  381. /* > \brief \b SGBRFSX */
  382. /* =========== DOCUMENTATION =========== */
  383. /* Online html documentation available at */
  384. /* http://www.netlib.org/lapack/explore-html/ */
  385. /* > \htmlonly */
  386. /* > Download SGBRFSX + dependencies */
  387. /* > <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/sgbrfsx
  388. .f"> */
  389. /* > [TGZ]</a> */
  390. /* > <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/sgbrfsx
  391. .f"> */
  392. /* > [ZIP]</a> */
  393. /* > <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/sgbrfsx
  394. .f"> */
  395. /* > [TXT]</a> */
  396. /* > \endhtmlonly */
  397. /* Definition: */
  398. /* =========== */
  399. /* SUBROUTINE SGBRFSX( TRANS, EQUED, N, KL, KU, NRHS, AB, LDAB, AFB, */
  400. /* LDAFB, IPIV, R, C, B, LDB, X, LDX, RCOND, */
  401. /* BERR, N_ERR_BNDS, ERR_BNDS_NORM, */
  402. /* ERR_BNDS_COMP, NPARAMS, PARAMS, WORK, IWORK, */
  403. /* INFO ) */
  404. /* CHARACTER TRANS, EQUED */
  405. /* INTEGER INFO, LDAB, LDAFB, LDB, LDX, N, KL, KU, NRHS, */
  406. /* $ NPARAMS, N_ERR_BNDS */
  407. /* REAL RCOND */
  408. /* INTEGER IPIV( * ), IWORK( * ) */
  409. /* REAL AB( LDAB, * ), AFB( LDAFB, * ), B( LDB, * ), */
  410. /* $ X( LDX , * ),WORK( * ) */
  411. /* REAL R( * ), C( * ), PARAMS( * ), BERR( * ), */
  412. /* $ ERR_BNDS_NORM( NRHS, * ), */
  413. /* $ ERR_BNDS_COMP( NRHS, * ) */
  414. /* > \par Purpose: */
  415. /* ============= */
  416. /* > */
  417. /* > \verbatim */
  418. /* > */
  419. /* > SGBRFSX improves the computed solution to a system of linear */
  420. /* > equations and provides error bounds and backward error estimates */
  421. /* > for the solution. In addition to normwise error bound, the code */
  422. /* > provides maximum componentwise error bound if possible. See */
  423. /* > comments for ERR_BNDS_NORM and ERR_BNDS_COMP for details of the */
  424. /* > error bounds. */
  425. /* > */
  426. /* > The original system of linear equations may have been equilibrated */
  427. /* > before calling this routine, as described by arguments EQUED, R */
  428. /* > and C below. In this case, the solution and error bounds returned */
  429. /* > are for the original unequilibrated system. */
  430. /* > \endverbatim */
  431. /* Arguments: */
  432. /* ========== */
  433. /* > \verbatim */
  434. /* > Some optional parameters are bundled in the PARAMS array. These */
  435. /* > settings determine how refinement is performed, but often the */
  436. /* > defaults are acceptable. If the defaults are acceptable, users */
  437. /* > can pass NPARAMS = 0 which prevents the source code from accessing */
  438. /* > the PARAMS argument. */
  439. /* > \endverbatim */
  440. /* > */
  441. /* > \param[in] TRANS */
  442. /* > \verbatim */
  443. /* > TRANS is CHARACTER*1 */
  444. /* > Specifies the form of the system of equations: */
  445. /* > = 'N': A * X = B (No transpose) */
  446. /* > = 'T': A**T * X = B (Transpose) */
  447. /* > = 'C': A**H * X = B (Conjugate transpose = Transpose) */
  448. /* > \endverbatim */
  449. /* > */
  450. /* > \param[in] EQUED */
  451. /* > \verbatim */
  452. /* > EQUED is CHARACTER*1 */
  453. /* > Specifies the form of equilibration that was done to A */
  454. /* > before calling this routine. This is needed to compute */
  455. /* > the solution and error bounds correctly. */
  456. /* > = 'N': No equilibration */
  457. /* > = 'R': Row equilibration, i.e., A has been premultiplied by */
  458. /* > diag(R). */
  459. /* > = 'C': Column equilibration, i.e., A has been postmultiplied */
  460. /* > by diag(C). */
  461. /* > = 'B': Both row and column equilibration, i.e., A has been */
  462. /* > replaced by diag(R) * A * diag(C). */
  463. /* > The right hand side B has been changed accordingly. */
  464. /* > \endverbatim */
  465. /* > */
  466. /* > \param[in] N */
  467. /* > \verbatim */
  468. /* > N is INTEGER */
  469. /* > The order of the matrix A. N >= 0. */
  470. /* > \endverbatim */
  471. /* > */
  472. /* > \param[in] KL */
  473. /* > \verbatim */
  474. /* > KL is INTEGER */
  475. /* > The number of subdiagonals within the band of A. KL >= 0. */
  476. /* > \endverbatim */
  477. /* > */
  478. /* > \param[in] KU */
  479. /* > \verbatim */
  480. /* > KU is INTEGER */
  481. /* > The number of superdiagonals within the band of A. KU >= 0. */
  482. /* > \endverbatim */
  483. /* > */
  484. /* > \param[in] NRHS */
  485. /* > \verbatim */
  486. /* > NRHS is INTEGER */
  487. /* > The number of right hand sides, i.e., the number of columns */
  488. /* > of the matrices B and X. NRHS >= 0. */
  489. /* > \endverbatim */
  490. /* > */
  491. /* > \param[in] AB */
  492. /* > \verbatim */
  493. /* > AB is REAL array, dimension (LDAB,N) */
  494. /* > The original band matrix A, stored in rows 1 to KL+KU+1. */
  495. /* > The j-th column of A is stored in the j-th column of the */
  496. /* > array AB as follows: */
  497. /* > AB(ku+1+i-j,j) = A(i,j) for f2cmax(1,j-ku)<=i<=f2cmin(n,j+kl). */
  498. /* > \endverbatim */
  499. /* > */
  500. /* > \param[in] LDAB */
  501. /* > \verbatim */
  502. /* > LDAB is INTEGER */
  503. /* > The leading dimension of the array AB. LDAB >= KL+KU+1. */
  504. /* > \endverbatim */
  505. /* > */
  506. /* > \param[in] AFB */
  507. /* > \verbatim */
  508. /* > AFB is REAL array, dimension (LDAFB,N) */
  509. /* > Details of the LU factorization of the band matrix A, as */
  510. /* > computed by DGBTRF. U is stored as an upper triangular band */
  511. /* > matrix with KL+KU superdiagonals in rows 1 to KL+KU+1, and */
  512. /* > the multipliers used during the factorization are stored in */
  513. /* > rows KL+KU+2 to 2*KL+KU+1. */
  514. /* > \endverbatim */
  515. /* > */
  516. /* > \param[in] LDAFB */
  517. /* > \verbatim */
  518. /* > LDAFB is INTEGER */
  519. /* > The leading dimension of the array AFB. LDAFB >= 2*KL*KU+1. */
  520. /* > \endverbatim */
  521. /* > */
  522. /* > \param[in] IPIV */
  523. /* > \verbatim */
  524. /* > IPIV is INTEGER array, dimension (N) */
  525. /* > The pivot indices from SGETRF; for 1<=i<=N, row i of the */
  526. /* > matrix was interchanged with row IPIV(i). */
  527. /* > \endverbatim */
  528. /* > */
  529. /* > \param[in,out] R */
  530. /* > \verbatim */
  531. /* > R is REAL array, dimension (N) */
  532. /* > The row scale factors for A. If EQUED = 'R' or 'B', A is */
  533. /* > multiplied on the left by diag(R); if EQUED = 'N' or 'C', R */
  534. /* > is not accessed. R is an input argument if FACT = 'F'; */
  535. /* > otherwise, R is an output argument. If FACT = 'F' and */
  536. /* > EQUED = 'R' or 'B', each element of R must be positive. */
  537. /* > If R is output, each element of R is a power of the radix. */
  538. /* > If R is input, each element of R should be a power of the radix */
  539. /* > to ensure a reliable solution and error estimates. Scaling by */
  540. /* > powers of the radix does not cause rounding errors unless the */
  541. /* > result underflows or overflows. Rounding errors during scaling */
  542. /* > lead to refining with a matrix that is not equivalent to the */
  543. /* > input matrix, producing error estimates that may not be */
  544. /* > reliable. */
  545. /* > \endverbatim */
  546. /* > */
  547. /* > \param[in,out] C */
  548. /* > \verbatim */
  549. /* > C is REAL array, dimension (N) */
  550. /* > The column scale factors for A. If EQUED = 'C' or 'B', A is */
  551. /* > multiplied on the right by diag(C); if EQUED = 'N' or 'R', C */
  552. /* > is not accessed. C is an input argument if FACT = 'F'; */
  553. /* > otherwise, C is an output argument. If FACT = 'F' and */
  554. /* > EQUED = 'C' or 'B', each element of C must be positive. */
  555. /* > If C is output, each element of C is a power of the radix. */
  556. /* > If C is input, each element of C should be a power of the radix */
  557. /* > to ensure a reliable solution and error estimates. Scaling by */
  558. /* > powers of the radix does not cause rounding errors unless the */
  559. /* > result underflows or overflows. Rounding errors during scaling */
  560. /* > lead to refining with a matrix that is not equivalent to the */
  561. /* > input matrix, producing error estimates that may not be */
  562. /* > reliable. */
  563. /* > \endverbatim */
  564. /* > */
  565. /* > \param[in] B */
  566. /* > \verbatim */
  567. /* > B is REAL array, dimension (LDB,NRHS) */
  568. /* > The right hand side matrix B. */
  569. /* > \endverbatim */
  570. /* > */
  571. /* > \param[in] LDB */
  572. /* > \verbatim */
  573. /* > LDB is INTEGER */
  574. /* > The leading dimension of the array B. LDB >= f2cmax(1,N). */
  575. /* > \endverbatim */
  576. /* > */
  577. /* > \param[in,out] X */
  578. /* > \verbatim */
  579. /* > X is REAL array, dimension (LDX,NRHS) */
  580. /* > On entry, the solution matrix X, as computed by SGETRS. */
  581. /* > On exit, the improved solution matrix X. */
  582. /* > \endverbatim */
  583. /* > */
  584. /* > \param[in] LDX */
  585. /* > \verbatim */
  586. /* > LDX is INTEGER */
  587. /* > The leading dimension of the array X. LDX >= f2cmax(1,N). */
  588. /* > \endverbatim */
  589. /* > */
  590. /* > \param[out] RCOND */
  591. /* > \verbatim */
  592. /* > RCOND is REAL */
  593. /* > Reciprocal scaled condition number. This is an estimate of the */
  594. /* > reciprocal Skeel condition number of the matrix A after */
  595. /* > equilibration (if done). If this is less than the machine */
  596. /* > precision (in particular, if it is zero), the matrix is singular */
  597. /* > to working precision. Note that the error may still be small even */
  598. /* > if this number is very small and the matrix appears ill- */
  599. /* > conditioned. */
  600. /* > \endverbatim */
  601. /* > */
  602. /* > \param[out] BERR */
  603. /* > \verbatim */
  604. /* > BERR is REAL array, dimension (NRHS) */
  605. /* > Componentwise relative backward error. This is the */
  606. /* > componentwise relative backward error of each solution vector X(j) */
  607. /* > (i.e., the smallest relative change in any element of A or B that */
  608. /* > makes X(j) an exact solution). */
  609. /* > \endverbatim */
  610. /* > */
  611. /* > \param[in] N_ERR_BNDS */
  612. /* > \verbatim */
  613. /* > N_ERR_BNDS is INTEGER */
  614. /* > Number of error bounds to return for each right hand side */
  615. /* > and each type (normwise or componentwise). See ERR_BNDS_NORM and */
  616. /* > ERR_BNDS_COMP below. */
  617. /* > \endverbatim */
  618. /* > */
  619. /* > \param[out] ERR_BNDS_NORM */
  620. /* > \verbatim */
  621. /* > ERR_BNDS_NORM is REAL array, dimension (NRHS, N_ERR_BNDS) */
  622. /* > For each right-hand side, this array contains information about */
  623. /* > various error bounds and condition numbers corresponding to the */
  624. /* > normwise relative error, which is defined as follows: */
  625. /* > */
  626. /* > Normwise relative error in the ith solution vector: */
  627. /* > max_j (abs(XTRUE(j,i) - X(j,i))) */
  628. /* > ------------------------------ */
  629. /* > max_j abs(X(j,i)) */
  630. /* > */
  631. /* > The array is indexed by the type of error information as described */
  632. /* > below. There currently are up to three pieces of information */
  633. /* > returned. */
  634. /* > */
  635. /* > The first index in ERR_BNDS_NORM(i,:) corresponds to the ith */
  636. /* > right-hand side. */
  637. /* > */
  638. /* > The second index in ERR_BNDS_NORM(:,err) contains the following */
  639. /* > three fields: */
  640. /* > err = 1 "Trust/don't trust" boolean. Trust the answer if the */
  641. /* > reciprocal condition number is less than the threshold */
  642. /* > sqrt(n) * slamch('Epsilon'). */
  643. /* > */
  644. /* > err = 2 "Guaranteed" error bound: The estimated forward error, */
  645. /* > almost certainly within a factor of 10 of the true error */
  646. /* > so long as the next entry is greater than the threshold */
  647. /* > sqrt(n) * slamch('Epsilon'). This error bound should only */
  648. /* > be trusted if the previous boolean is true. */
  649. /* > */
  650. /* > err = 3 Reciprocal condition number: Estimated normwise */
  651. /* > reciprocal condition number. Compared with the threshold */
  652. /* > sqrt(n) * slamch('Epsilon') to determine if the error */
  653. /* > estimate is "guaranteed". These reciprocal condition */
  654. /* > numbers are 1 / (norm(Z^{-1},inf) * norm(Z,inf)) for some */
  655. /* > appropriately scaled matrix Z. */
  656. /* > Let Z = S*A, where S scales each row by a power of the */
  657. /* > radix so all absolute row sums of Z are approximately 1. */
  658. /* > */
  659. /* > See Lapack Working Note 165 for further details and extra */
  660. /* > cautions. */
  661. /* > \endverbatim */
  662. /* > */
  663. /* > \param[out] ERR_BNDS_COMP */
  664. /* > \verbatim */
  665. /* > ERR_BNDS_COMP is REAL array, dimension (NRHS, N_ERR_BNDS) */
  666. /* > For each right-hand side, this array contains information about */
  667. /* > various error bounds and condition numbers corresponding to the */
  668. /* > componentwise relative error, which is defined as follows: */
  669. /* > */
  670. /* > Componentwise relative error in the ith solution vector: */
  671. /* > abs(XTRUE(j,i) - X(j,i)) */
  672. /* > max_j ---------------------- */
  673. /* > abs(X(j,i)) */
  674. /* > */
  675. /* > The array is indexed by the right-hand side i (on which the */
  676. /* > componentwise relative error depends), and the type of error */
  677. /* > information as described below. There currently are up to three */
  678. /* > pieces of information returned for each right-hand side. If */
  679. /* > componentwise accuracy is not requested (PARAMS(3) = 0.0), then */
  680. /* > ERR_BNDS_COMP is not accessed. If N_ERR_BNDS < 3, then at most */
  681. /* > the first (:,N_ERR_BNDS) entries are returned. */
  682. /* > */
  683. /* > The first index in ERR_BNDS_COMP(i,:) corresponds to the ith */
  684. /* > right-hand side. */
  685. /* > */
  686. /* > The second index in ERR_BNDS_COMP(:,err) contains the following */
  687. /* > three fields: */
  688. /* > err = 1 "Trust/don't trust" boolean. Trust the answer if the */
  689. /* > reciprocal condition number is less than the threshold */
  690. /* > sqrt(n) * slamch('Epsilon'). */
  691. /* > */
  692. /* > err = 2 "Guaranteed" error bound: The estimated forward error, */
  693. /* > almost certainly within a factor of 10 of the true error */
  694. /* > so long as the next entry is greater than the threshold */
  695. /* > sqrt(n) * slamch('Epsilon'). This error bound should only */
  696. /* > be trusted if the previous boolean is true. */
  697. /* > */
  698. /* > err = 3 Reciprocal condition number: Estimated componentwise */
  699. /* > reciprocal condition number. Compared with the threshold */
  700. /* > sqrt(n) * slamch('Epsilon') to determine if the error */
  701. /* > estimate is "guaranteed". These reciprocal condition */
  702. /* > numbers are 1 / (norm(Z^{-1},inf) * norm(Z,inf)) for some */
  703. /* > appropriately scaled matrix Z. */
  704. /* > Let Z = S*(A*diag(x)), where x is the solution for the */
  705. /* > current right-hand side and S scales each row of */
  706. /* > A*diag(x) by a power of the radix so all absolute row */
  707. /* > sums of Z are approximately 1. */
  708. /* > */
  709. /* > See Lapack Working Note 165 for further details and extra */
  710. /* > cautions. */
  711. /* > \endverbatim */
  712. /* > */
  713. /* > \param[in] NPARAMS */
  714. /* > \verbatim */
  715. /* > NPARAMS is INTEGER */
  716. /* > Specifies the number of parameters set in PARAMS. If <= 0, the */
  717. /* > PARAMS array is never referenced and default values are used. */
  718. /* > \endverbatim */
  719. /* > */
  720. /* > \param[in,out] PARAMS */
  721. /* > \verbatim */
  722. /* > PARAMS is REAL array, dimension NPARAMS */
  723. /* > Specifies algorithm parameters. If an entry is < 0.0, then */
  724. /* > that entry will be filled with default value used for that */
  725. /* > parameter. Only positions up to NPARAMS are accessed; defaults */
  726. /* > are used for higher-numbered parameters. */
  727. /* > */
  728. /* > PARAMS(LA_LINRX_ITREF_I = 1) : Whether to perform iterative */
  729. /* > refinement or not. */
  730. /* > Default: 1.0 */
  731. /* > = 0.0: No refinement is performed, and no error bounds are */
  732. /* > computed. */
  733. /* > = 1.0: Use the double-precision refinement algorithm, */
  734. /* > possibly with doubled-single computations if the */
  735. /* > compilation environment does not support DOUBLE */
  736. /* > PRECISION. */
  737. /* > (other values are reserved for future use) */
  738. /* > */
  739. /* > PARAMS(LA_LINRX_ITHRESH_I = 2) : Maximum number of residual */
  740. /* > computations allowed for refinement. */
  741. /* > Default: 10 */
  742. /* > Aggressive: Set to 100 to permit convergence using approximate */
  743. /* > factorizations or factorizations other than LU. If */
  744. /* > the factorization uses a technique other than */
  745. /* > Gaussian elimination, the guarantees in */
  746. /* > err_bnds_norm and err_bnds_comp may no longer be */
  747. /* > trustworthy. */
  748. /* > */
  749. /* > PARAMS(LA_LINRX_CWISE_I = 3) : Flag determining if the code */
  750. /* > will attempt to find a solution with small componentwise */
  751. /* > relative error in the double-precision algorithm. Positive */
  752. /* > is true, 0.0 is false. */
  753. /* > Default: 1.0 (attempt componentwise convergence) */
  754. /* > \endverbatim */
  755. /* > */
  756. /* > \param[out] WORK */
  757. /* > \verbatim */
  758. /* > WORK is REAL array, dimension (4*N) */
  759. /* > \endverbatim */
  760. /* > */
  761. /* > \param[out] IWORK */
  762. /* > \verbatim */
  763. /* > IWORK is INTEGER array, dimension (N) */
  764. /* > \endverbatim */
  765. /* > */
  766. /* > \param[out] INFO */
  767. /* > \verbatim */
  768. /* > INFO is INTEGER */
  769. /* > = 0: Successful exit. The solution to every right-hand side is */
  770. /* > guaranteed. */
  771. /* > < 0: If INFO = -i, the i-th argument had an illegal value */
  772. /* > > 0 and <= N: U(INFO,INFO) is exactly zero. The factorization */
  773. /* > has been completed, but the factor U is exactly singular, so */
  774. /* > the solution and error bounds could not be computed. RCOND = 0 */
  775. /* > is returned. */
  776. /* > = N+J: The solution corresponding to the Jth right-hand side is */
  777. /* > not guaranteed. The solutions corresponding to other right- */
  778. /* > hand sides K with K > J may not be guaranteed as well, but */
  779. /* > only the first such right-hand side is reported. If a small */
  780. /* > componentwise error is not requested (PARAMS(3) = 0.0) then */
  781. /* > the Jth right-hand side is the first with a normwise error */
  782. /* > bound that is not guaranteed (the smallest J such */
  783. /* > that ERR_BNDS_NORM(J,1) = 0.0). By default (PARAMS(3) = 1.0) */
  784. /* > the Jth right-hand side is the first with either a normwise or */
  785. /* > componentwise error bound that is not guaranteed (the smallest */
  786. /* > J such that either ERR_BNDS_NORM(J,1) = 0.0 or */
  787. /* > ERR_BNDS_COMP(J,1) = 0.0). See the definition of */
  788. /* > ERR_BNDS_NORM(:,1) and ERR_BNDS_COMP(:,1). To get information */
  789. /* > about all of the right-hand sides check ERR_BNDS_NORM or */
  790. /* > ERR_BNDS_COMP. */
  791. /* > \endverbatim */
  792. /* Authors: */
  793. /* ======== */
  794. /* > \author Univ. of Tennessee */
  795. /* > \author Univ. of California Berkeley */
  796. /* > \author Univ. of Colorado Denver */
  797. /* > \author NAG Ltd. */
  798. /* > \date April 2012 */
  799. /* > \ingroup realGBcomputational */
  800. /* ===================================================================== */
  801. /* Subroutine */ void sgbrfsx_(char *trans, char *equed, integer *n, integer *
  802. kl, integer *ku, integer *nrhs, real *ab, integer *ldab, real *afb,
  803. integer *ldafb, integer *ipiv, real *r__, real *c__, real *b, integer
  804. *ldb, real *x, integer *ldx, real *rcond, real *berr, integer *
  805. n_err_bnds__, real *err_bnds_norm__, real *err_bnds_comp__, integer *
  806. nparams, real *params, real *work, integer *iwork, integer *info)
  807. {
  808. /* System generated locals */
  809. integer ab_dim1, ab_offset, afb_dim1, afb_offset, b_dim1, b_offset,
  810. x_dim1, x_offset, err_bnds_norm_dim1, err_bnds_norm_offset,
  811. err_bnds_comp_dim1, err_bnds_comp_offset, i__1;
  812. real r__1, r__2;
  813. /* Local variables */
  814. real illrcond_thresh__;
  815. extern /* Subroutine */ void sla_gbrfsx_extended_(integer *, integer *,
  816. integer *, integer *, integer *, integer *, real *, integer *,
  817. real *, integer *, integer *, logical *, real *, real *, integer *
  818. , real *, integer *, real *, integer *, real *, real *, real *,
  819. real *, real *, real *, real *, integer *, real *, real *,
  820. logical *, integer *);
  821. real unstable_thresh__, err_lbnd__;
  822. char norm[1];
  823. integer ref_type__;
  824. extern integer ilatrans_(char *);
  825. logical ignore_cwise__;
  826. integer j;
  827. extern logical lsame_(char *, char *);
  828. real anorm, rcond_tmp__;
  829. integer prec_type__;
  830. extern real slangb_(char *, integer *, integer *, integer *, real *,
  831. integer *, real *), slamch_(char *);
  832. extern /* Subroutine */ void sgbcon_(char *, integer *, integer *, integer
  833. *, real *, integer *, integer *, real *, real *, real *, integer *
  834. , integer *);
  835. extern int xerbla_(char *, integer *, ftnlen);
  836. logical colequ, notran, rowequ;
  837. integer trans_type__;
  838. extern integer ilaprec_(char *);
  839. extern real sla_gbrcond_(char *, integer *, integer *, integer *, real *,
  840. integer *, real *, integer *, integer *, integer *, real *,
  841. integer *, real *, integer *);
  842. integer ithresh, n_norms__;
  843. real rthresh, cwise_wrong__;
  844. /* -- LAPACK computational routine (version 3.7.0) -- */
  845. /* -- LAPACK is a software package provided by Univ. of Tennessee, -- */
  846. /* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */
  847. /* April 2012 */
  848. /* ================================================================== */
  849. /* Check the input parameters. */
  850. /* Parameter adjustments */
  851. err_bnds_comp_dim1 = *nrhs;
  852. err_bnds_comp_offset = 1 + err_bnds_comp_dim1 * 1;
  853. err_bnds_comp__ -= err_bnds_comp_offset;
  854. err_bnds_norm_dim1 = *nrhs;
  855. err_bnds_norm_offset = 1 + err_bnds_norm_dim1 * 1;
  856. err_bnds_norm__ -= err_bnds_norm_offset;
  857. ab_dim1 = *ldab;
  858. ab_offset = 1 + ab_dim1 * 1;
  859. ab -= ab_offset;
  860. afb_dim1 = *ldafb;
  861. afb_offset = 1 + afb_dim1 * 1;
  862. afb -= afb_offset;
  863. --ipiv;
  864. --r__;
  865. --c__;
  866. b_dim1 = *ldb;
  867. b_offset = 1 + b_dim1 * 1;
  868. b -= b_offset;
  869. x_dim1 = *ldx;
  870. x_offset = 1 + x_dim1 * 1;
  871. x -= x_offset;
  872. --berr;
  873. --params;
  874. --work;
  875. --iwork;
  876. /* Function Body */
  877. *info = 0;
  878. trans_type__ = ilatrans_(trans);
  879. ref_type__ = 1;
  880. if (*nparams >= 1) {
  881. if (params[1] < 0.f) {
  882. params[1] = 1.f;
  883. } else {
  884. ref_type__ = params[1];
  885. }
  886. }
  887. /* Set default parameters. */
  888. illrcond_thresh__ = (real) (*n) * slamch_("Epsilon");
  889. ithresh = 10;
  890. rthresh = .5f;
  891. unstable_thresh__ = .25f;
  892. ignore_cwise__ = FALSE_;
  893. if (*nparams >= 2) {
  894. if (params[2] < 0.f) {
  895. params[2] = (real) ithresh;
  896. } else {
  897. ithresh = (integer) params[2];
  898. }
  899. }
  900. if (*nparams >= 3) {
  901. if (params[3] < 0.f) {
  902. if (ignore_cwise__) {
  903. params[3] = 0.f;
  904. } else {
  905. params[3] = 1.f;
  906. }
  907. } else {
  908. ignore_cwise__ = params[3] == 0.f;
  909. }
  910. }
  911. if (ref_type__ == 0 || *n_err_bnds__ == 0) {
  912. n_norms__ = 0;
  913. } else if (ignore_cwise__) {
  914. n_norms__ = 1;
  915. } else {
  916. n_norms__ = 2;
  917. }
  918. notran = lsame_(trans, "N");
  919. rowequ = lsame_(equed, "R") || lsame_(equed, "B");
  920. colequ = lsame_(equed, "C") || lsame_(equed, "B");
  921. /* Test input parameters. */
  922. if (trans_type__ == -1) {
  923. *info = -1;
  924. } else if (! rowequ && ! colequ && ! lsame_(equed, "N")) {
  925. *info = -2;
  926. } else if (*n < 0) {
  927. *info = -3;
  928. } else if (*kl < 0) {
  929. *info = -4;
  930. } else if (*ku < 0) {
  931. *info = -5;
  932. } else if (*nrhs < 0) {
  933. *info = -6;
  934. } else if (*ldab < *kl + *ku + 1) {
  935. *info = -8;
  936. } else if (*ldafb < (*kl << 1) + *ku + 1) {
  937. *info = -10;
  938. } else if (*ldb < f2cmax(1,*n)) {
  939. *info = -13;
  940. } else if (*ldx < f2cmax(1,*n)) {
  941. *info = -15;
  942. }
  943. if (*info != 0) {
  944. i__1 = -(*info);
  945. xerbla_("SGBRFSX", &i__1, (ftnlen)7);
  946. return;
  947. }
  948. /* Quick return if possible. */
  949. if (*n == 0 || *nrhs == 0) {
  950. *rcond = 1.f;
  951. i__1 = *nrhs;
  952. for (j = 1; j <= i__1; ++j) {
  953. berr[j] = 0.f;
  954. if (*n_err_bnds__ >= 1) {
  955. err_bnds_norm__[j + err_bnds_norm_dim1] = 1.f;
  956. err_bnds_comp__[j + err_bnds_comp_dim1] = 1.f;
  957. }
  958. if (*n_err_bnds__ >= 2) {
  959. err_bnds_norm__[j + (err_bnds_norm_dim1 << 1)] = 0.f;
  960. err_bnds_comp__[j + (err_bnds_comp_dim1 << 1)] = 0.f;
  961. }
  962. if (*n_err_bnds__ >= 3) {
  963. err_bnds_norm__[j + err_bnds_norm_dim1 * 3] = 1.f;
  964. err_bnds_comp__[j + err_bnds_comp_dim1 * 3] = 1.f;
  965. }
  966. }
  967. return;
  968. }
  969. /* Default to failure. */
  970. *rcond = 0.f;
  971. i__1 = *nrhs;
  972. for (j = 1; j <= i__1; ++j) {
  973. berr[j] = 1.f;
  974. if (*n_err_bnds__ >= 1) {
  975. err_bnds_norm__[j + err_bnds_norm_dim1] = 1.f;
  976. err_bnds_comp__[j + err_bnds_comp_dim1] = 1.f;
  977. }
  978. if (*n_err_bnds__ >= 2) {
  979. err_bnds_norm__[j + (err_bnds_norm_dim1 << 1)] = 1.f;
  980. err_bnds_comp__[j + (err_bnds_comp_dim1 << 1)] = 1.f;
  981. }
  982. if (*n_err_bnds__ >= 3) {
  983. err_bnds_norm__[j + err_bnds_norm_dim1 * 3] = 0.f;
  984. err_bnds_comp__[j + err_bnds_comp_dim1 * 3] = 0.f;
  985. }
  986. }
  987. /* Compute the norm of A and the reciprocal of the condition */
  988. /* number of A. */
  989. if (notran) {
  990. *(unsigned char *)norm = 'I';
  991. } else {
  992. *(unsigned char *)norm = '1';
  993. }
  994. anorm = slangb_(norm, n, kl, ku, &ab[ab_offset], ldab, &work[1]);
  995. sgbcon_(norm, n, kl, ku, &afb[afb_offset], ldafb, &ipiv[1], &anorm, rcond,
  996. &work[1], &iwork[1], info);
  997. /* Perform refinement on each right-hand side */
  998. if (ref_type__ != 0 && *info == 0) {
  999. prec_type__ = ilaprec_("D");
  1000. if (notran) {
  1001. sla_gbrfsx_extended_(&prec_type__, &trans_type__, n, kl, ku,
  1002. nrhs, &ab[ab_offset], ldab, &afb[afb_offset], ldafb, &
  1003. ipiv[1], &colequ, &c__[1], &b[b_offset], ldb, &x[x_offset]
  1004. , ldx, &berr[1], &n_norms__, &err_bnds_norm__[
  1005. err_bnds_norm_offset], &err_bnds_comp__[
  1006. err_bnds_comp_offset], &work[*n + 1], &work[1], &work[(*n
  1007. << 1) + 1], &work[1], rcond, &ithresh, &rthresh, &
  1008. unstable_thresh__, &ignore_cwise__, info);
  1009. } else {
  1010. sla_gbrfsx_extended_(&prec_type__, &trans_type__, n, kl, ku,
  1011. nrhs, &ab[ab_offset], ldab, &afb[afb_offset], ldafb, &
  1012. ipiv[1], &rowequ, &r__[1], &b[b_offset], ldb, &x[x_offset]
  1013. , ldx, &berr[1], &n_norms__, &err_bnds_norm__[
  1014. err_bnds_norm_offset], &err_bnds_comp__[
  1015. err_bnds_comp_offset], &work[*n + 1], &work[1], &work[(*n
  1016. << 1) + 1], &work[1], rcond, &ithresh, &rthresh, &
  1017. unstable_thresh__, &ignore_cwise__, info);
  1018. }
  1019. }
  1020. /* Computing MAX */
  1021. r__1 = 10.f, r__2 = sqrt((real) (*n));
  1022. err_lbnd__ = f2cmax(r__1,r__2) * slamch_("Epsilon");
  1023. if (*n_err_bnds__ >= 1 && n_norms__ >= 1) {
  1024. /* Compute scaled normwise condition number cond(A*C). */
  1025. if (colequ && notran) {
  1026. rcond_tmp__ = sla_gbrcond_(trans, n, kl, ku, &ab[ab_offset],
  1027. ldab, &afb[afb_offset], ldafb, &ipiv[1], &c_n1, &c__[1],
  1028. info, &work[1], &iwork[1]);
  1029. } else if (rowequ && ! notran) {
  1030. rcond_tmp__ = sla_gbrcond_(trans, n, kl, ku, &ab[ab_offset],
  1031. ldab, &afb[afb_offset], ldafb, &ipiv[1], &c_n1, &r__[1],
  1032. info, &work[1], &iwork[1]);
  1033. } else {
  1034. rcond_tmp__ = sla_gbrcond_(trans, n, kl, ku, &ab[ab_offset],
  1035. ldab, &afb[afb_offset], ldafb, &ipiv[1], &c__0, &r__[1],
  1036. info, &work[1], &iwork[1]);
  1037. }
  1038. i__1 = *nrhs;
  1039. for (j = 1; j <= i__1; ++j) {
  1040. /* Cap the error at 1.0. */
  1041. if (*n_err_bnds__ >= 2 && err_bnds_norm__[j + (err_bnds_norm_dim1
  1042. << 1)] > 1.f) {
  1043. err_bnds_norm__[j + (err_bnds_norm_dim1 << 1)] = 1.f;
  1044. }
  1045. /* Threshold the error (see LAWN). */
  1046. if (rcond_tmp__ < illrcond_thresh__) {
  1047. err_bnds_norm__[j + (err_bnds_norm_dim1 << 1)] = 1.f;
  1048. err_bnds_norm__[j + err_bnds_norm_dim1] = 0.f;
  1049. if (*info <= *n) {
  1050. *info = *n + j;
  1051. }
  1052. } else if (err_bnds_norm__[j + (err_bnds_norm_dim1 << 1)] <
  1053. err_lbnd__) {
  1054. err_bnds_norm__[j + (err_bnds_norm_dim1 << 1)] = err_lbnd__;
  1055. err_bnds_norm__[j + err_bnds_norm_dim1] = 1.f;
  1056. }
  1057. /* Save the condition number. */
  1058. if (*n_err_bnds__ >= 3) {
  1059. err_bnds_norm__[j + err_bnds_norm_dim1 * 3] = rcond_tmp__;
  1060. }
  1061. }
  1062. }
  1063. if (*n_err_bnds__ >= 1 && n_norms__ >= 2) {
  1064. /* Compute componentwise condition number cond(A*diag(Y(:,J))) for */
  1065. /* each right-hand side using the current solution as an estimate of */
  1066. /* the true solution. If the componentwise error estimate is too */
  1067. /* large, then the solution is a lousy estimate of truth and the */
  1068. /* estimated RCOND may be too optimistic. To avoid misleading users, */
  1069. /* the inverse condition number is set to 0.0 when the estimated */
  1070. /* cwise error is at least CWISE_WRONG. */
  1071. cwise_wrong__ = sqrt(slamch_("Epsilon"));
  1072. i__1 = *nrhs;
  1073. for (j = 1; j <= i__1; ++j) {
  1074. if (err_bnds_comp__[j + (err_bnds_comp_dim1 << 1)] <
  1075. cwise_wrong__) {
  1076. rcond_tmp__ = sla_gbrcond_(trans, n, kl, ku, &ab[ab_offset],
  1077. ldab, &afb[afb_offset], ldafb, &ipiv[1], &c__1, &x[j *
  1078. x_dim1 + 1], info, &work[1], &iwork[1]);
  1079. } else {
  1080. rcond_tmp__ = 0.f;
  1081. }
  1082. /* Cap the error at 1.0. */
  1083. if (*n_err_bnds__ >= 2 && err_bnds_comp__[j + (err_bnds_comp_dim1
  1084. << 1)] > 1.f) {
  1085. err_bnds_comp__[j + (err_bnds_comp_dim1 << 1)] = 1.f;
  1086. }
  1087. /* Threshold the error (see LAWN). */
  1088. if (rcond_tmp__ < illrcond_thresh__) {
  1089. err_bnds_comp__[j + (err_bnds_comp_dim1 << 1)] = 1.f;
  1090. err_bnds_comp__[j + err_bnds_comp_dim1] = 0.f;
  1091. if (params[3] == 1.f && *info < *n + j) {
  1092. *info = *n + j;
  1093. }
  1094. } else if (err_bnds_comp__[j + (err_bnds_comp_dim1 << 1)] <
  1095. err_lbnd__) {
  1096. err_bnds_comp__[j + (err_bnds_comp_dim1 << 1)] = err_lbnd__;
  1097. err_bnds_comp__[j + err_bnds_comp_dim1] = 1.f;
  1098. }
  1099. /* Save the condition number. */
  1100. if (*n_err_bnds__ >= 3) {
  1101. err_bnds_comp__[j + err_bnds_comp_dim1 * 3] = rcond_tmp__;
  1102. }
  1103. }
  1104. }
  1105. return;
  1106. /* End of SGBRFSX */
  1107. } /* sgbrfsx_ */