OSchip
/
OpenBLAS
Not watched
1
0
Fork 0
Code
Releases 66 Wiki evaluate Activity
Issues 0 Pull Requests 0 Datasets Model Cloudbrain HPC
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.
Tree: 66d9185ebe
Branches Tags
${ item.name }
Create branch ${ searchTerm }
from '66d9185ebe'
${ noResults }
OpenBLAS/ctest/c_sblat2c.c

3896 lines
108 kB
Raw Blame History 

  1. #include <math.h>

  2. #include <stdlib.h>

  3. #include <string.h>

  4. #include <stdio.h>

  5. #include <complex.h>

  6. #ifdef complex

  7. #undef complex

  8. #endif

  9. #ifdef I

  10. #undef I

  11. #endif

  12. 

  13. #include "common.h"

  14. 

  15. typedef blasint integer;

  16. 

  17. typedef unsigned int uinteger;

  18. typedef char *address;

  19. typedef short int shortint;

  20. typedef float real;

  21. typedef double doublereal;

  22. typedef struct { real r, i; } complex;

  23. typedef struct { doublereal r, i; } doublecomplex;

  24. #ifdef _MSC_VER

  25. static inline _Fcomplex Cf(complex *z) {_Fcomplex zz={z->r , z->i}; return zz;}

  26. static inline _Dcomplex Cd(doublecomplex *z) {_Dcomplex zz={z->r , z->i};return zz;}

  27. static inline _Fcomplex * _pCf(complex *z) {return (_Fcomplex*)z;}

  28. static inline _Dcomplex * _pCd(doublecomplex *z) {return (_Dcomplex*)z;}

  29. #else

  30. static inline _Complex float Cf(complex *z) {return z->r + z->i*_Complex_I;}

  31. static inline _Complex double Cd(doublecomplex *z) {return z->r + z->i*_Complex_I;}

  32. static inline _Complex float * _pCf(complex *z) {return (_Complex float*)z;}

  33. static inline _Complex double * _pCd(doublecomplex *z) {return (_Complex double*)z;}

  34. #endif

  35. #define pCf(z) (*_pCf(z))

  36. #define pCd(z) (*_pCd(z))

  37. typedef int logical;

  38. typedef short int shortlogical;

  39. typedef char logical1;

  40. typedef char integer1;

  41. 

  42. #define TRUE_ (1)

  43. #define FALSE_ (0)

  44. 

  45. /* Extern is for use with -E */

  46. #ifndef Extern

  47. #define Extern extern

  48. #endif

  49. 

  50. /* I/O stuff */

  51. 

  52. typedef int flag;

  53. typedef int ftnlen;

  54. typedef int ftnint;

  55. 

  56. /*external read, write*/

  57. typedef struct

  58. {	flag cierr;

  59. 	ftnint ciunit;

  60. 	flag ciend;

  61. 	char *cifmt;

  62. 	ftnint cirec;

  63. } cilist;

  64. 

  65. /*internal read, write*/

  66. typedef struct

  67. {	flag icierr;

  68. 	char *iciunit;

  69. 	flag iciend;

  70. 	char *icifmt;

  71. 	ftnint icirlen;

  72. 	ftnint icirnum;

  73. } icilist;

  74. 

  75. /*open*/

  76. typedef struct

  77. {	flag oerr;

  78. 	ftnint ounit;

  79. 	char *ofnm;

  80. 	ftnlen ofnmlen;

  81. 	char *osta;

  82. 	char *oacc;

  83. 	char *ofm;

  84. 	ftnint orl;

  85. 	char *oblnk;

  86. } olist;

  87. 

  88. /*close*/

  89. typedef struct

  90. {	flag cerr;

  91. 	ftnint cunit;

  92. 	char *csta;

  93. } cllist;

  94. 

  95. /*rewind, backspace, endfile*/

  96. typedef struct

  97. {	flag aerr;

  98. 	ftnint aunit;

  99. } alist;

  100. 

  101. /* inquire */

  102. typedef struct

  103. {	flag inerr;

  104. 	ftnint inunit;

  105. 	char *infile;

  106. 	ftnlen infilen;

  107. 	ftnint	*inex;	/*parameters in standard's order*/

  108. 	ftnint	*inopen;

  109. 	ftnint	*innum;

  110. 	ftnint	*innamed;

  111. 	char	*inname;

  112. 	ftnlen	innamlen;

  113. 	char	*inacc;

  114. 	ftnlen	inacclen;

  115. 	char	*inseq;

  116. 	ftnlen	inseqlen;

  117. 	char 	*indir;

  118. 	ftnlen	indirlen;

  119. 	char	*infmt;

  120. 	ftnlen	infmtlen;

  121. 	char	*inform;

  122. 	ftnint	informlen;

  123. 	char	*inunf;

  124. 	ftnlen	inunflen;

  125. 	ftnint	*inrecl;

  126. 	ftnint	*innrec;

  127. 	char	*inblank;

  128. 	ftnlen	inblanklen;

  129. } inlist;

  130. 

  131. #define VOID void

  132. 

  133. union Multitype {	/* for multiple entry points */

  134. 	integer1 g;

  135. 	shortint h;

  136. 	integer i;

  137. 	/* longint j; */

  138. 	real r;

  139. 	doublereal d;

  140. 	complex c;

  141. 	doublecomplex z;

  142. 	};

  143. 

  144. typedef union Multitype Multitype;

  145. 

  146. struct Vardesc {	/* for Namelist */

  147. 	char *name;

  148. 	char *addr;

  149. 	ftnlen *dims;

  150. 	int  type;

  151. 	};

  152. typedef struct Vardesc Vardesc;

  153. 

  154. struct Namelist {

  155. 	char *name;

  156. 	Vardesc **vars;

  157. 	int nvars;

  158. 	};

  159. typedef struct Namelist Namelist;

  160. 

  161. #define abs(x) ((x) >= 0 ? (x) : -(x))

  162. #define dabs(x) (fabs(x))

  163. #define f2cmin(a,b) ((a) <= (b) ? (a) : (b))

  164. #define f2cmax(a,b) ((a) >= (b) ? (a) : (b))

  165. #define dmin(a,b) (f2cmin(a,b))

  166. #define dmax(a,b) (f2cmax(a,b))

  167. #define bit_test(a,b)	((a) >> (b) & 1)

  168. #define bit_clear(a,b)	((a) & ~((uinteger)1 << (b)))

  169. #define bit_set(a,b)	((a) |  ((uinteger)1 << (b)))

  170. 

  171. #define abort_() { sig_die("Fortran abort routine called", 1); }

  172. #define c_abs(z) (cabsf(Cf(z)))

  173. #define c_cos(R,Z) { pCf(R)=ccos(Cf(Z)); }

  174. #ifdef _MSC_VER

  175. #define c_div(c, a, b) {Cf(c)._Val[0] = (Cf(a)._Val[0]/Cf(b)._Val[0]); Cf(c)._Val[1]=(Cf(a)._Val[1]/Cf(b)._Val[1]);}

  176. #define z_div(c, a, b) {Cd(c)._Val[0] = (Cd(a)._Val[0]/Cd(b)._Val[0]); Cd(c)._Val[1]=(Cd(a)._Val[1]/Cd(b)._Val[1]);}

  177. #else

  178. #define c_div(c, a, b) {pCf(c) = Cf(a)/Cf(b);}

  179. #define z_div(c, a, b) {pCd(c) = Cd(a)/Cd(b);}

  180. #endif

  181. #define c_exp(R, Z) {pCf(R) = cexpf(Cf(Z));}

  182. #define c_log(R, Z) {pCf(R) = clogf(Cf(Z));}

  183. #define c_sin(R, Z) {pCf(R) = csinf(Cf(Z));}

  184. //#define c_sqrt(R, Z) {*(R) = csqrtf(Cf(Z));}

  185. #define c_sqrt(R, Z) {pCf(R) = csqrtf(Cf(Z));}

  186. #define d_abs(x) (fabs(*(x)))

  187. #define d_acos(x) (acos(*(x)))

  188. #define d_asin(x) (asin(*(x)))

  189. #define d_atan(x) (atan(*(x)))

  190. #define d_atn2(x, y) (atan2(*(x),*(y)))

  191. #define d_cnjg(R, Z) { pCd(R) = conj(Cd(Z)); }

  192. #define r_cnjg(R, Z) { pCf(R) = conjf(Cf(Z)); }

  193. #define d_cos(x) (cos(*(x)))

  194. #define d_cosh(x) (cosh(*(x)))

  195. #define d_dim(__a, __b) ( *(__a) > *(__b) ? *(__a) - *(__b) : 0.0 )

  196. #define d_exp(x) (exp(*(x)))

  197. #define d_imag(z) (cimag(Cd(z)))

  198. #define r_imag(z) (cimagf(Cf(z)))

  199. #define d_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x)))

  200. #define r_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x)))

  201. #define d_lg10(x) ( 0.43429448190325182765 * log(*(x)) )

  202. #define r_lg10(x) ( 0.43429448190325182765 * log(*(x)) )

  203. #define d_log(x) (log(*(x)))

  204. #define d_mod(x, y) (fmod(*(x), *(y)))

  205. #define u_nint(__x) ((__x)>=0 ? floor((__x) + .5) : -floor(.5 - (__x)))

  206. #define d_nint(x) u_nint(*(x))

  207. #define u_sign(__a,__b) ((__b) >= 0 ? ((__a) >= 0 ? (__a) : -(__a)) : -((__a) >= 0 ? (__a) : -(__a)))

  208. #define d_sign(a,b) u_sign(*(a),*(b))

  209. #define r_sign(a,b) u_sign(*(a),*(b))

  210. #define d_sin(x) (sin(*(x)))

  211. #define d_sinh(x) (sinh(*(x)))

  212. #define d_sqrt(x) (sqrt(*(x)))

  213. #define d_tan(x) (tan(*(x)))

  214. #define d_tanh(x) (tanh(*(x)))

  215. #define i_abs(x) abs(*(x))

  216. #define i_dnnt(x) ((integer)u_nint(*(x)))

  217. #define i_len(s, n) (n)

  218. #define i_nint(x) ((integer)u_nint(*(x)))

  219. #define i_sign(a,b) ((integer)u_sign((integer)*(a),(integer)*(b)))

  220. #define pow_dd(ap, bp) ( pow(*(ap), *(bp)))

  221. #define pow_si(B,E) spow_ui(*(B),*(E))

  222. #define pow_ri(B,E) spow_ui(*(B),*(E))

  223. #define pow_di(B,E) dpow_ui(*(B),*(E))

  224. #define pow_zi(p, a, b) {pCd(p) = zpow_ui(Cd(a), *(b));}

  225. #define pow_ci(p, a, b) {pCf(p) = cpow_ui(Cf(a), *(b));}

  226. #define pow_zz(R,A,B) {pCd(R) = cpow(Cd(A),*(B));}

  227. #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++ = ' '; }

  228. #define s_cmp(a,b,c,d) ((integer)strncmp((a),(b),f2cmin((c),(d))))

  229. #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]; }

  230. #define sig_die(s, kill) { exit(1); }

  231. #define s_stop(s, n) {exit(0);}

  232. #define z_abs(z) (cabs(Cd(z)))

  233. #define z_exp(R, Z) {pCd(R) = cexp(Cd(Z));}

  234. #define z_sqrt(R, Z) {pCd(R) = csqrt(Cd(Z));}

  235. #define myexit_() break;

  236. #define mycycle_() continue;

  237. #define myceiling_(w) {ceil(w)}

  238. #define myhuge_(w) {HUGE_VAL}

  239. //#define mymaxloc_(w,s,e,n) {if (sizeof(*(w)) == sizeof(double)) dmaxloc_((w),*(s),*(e),n); else dmaxloc_((w),*(s),*(e),n);}

  240. #define mymaxloc_(w,s,e,n) dmaxloc_(w,*(s),*(e),n)

  241. 

  242. /* procedure parameter types for -A and -C++ */

  243. 

  244. #define F2C_proc_par_types 1

  245. 

  246. 

  247. /* Common Block Declarations */

  248. 

  249. struct {

  250.     integer infot, noutc;

  251.     logical ok;

  252. } infoc_;

  253. 

  254. #define infoc_1 infoc_

  255. 

  256. struct {

  257.     char srnamt[12];

  258. } srnamc_;

  259. 

  260. #define srnamc_1 srnamc_

  261. 

  262. /* Table of constant values */

  263. 

  264. static integer c__1 = 1;

  265. static integer c__65 = 65;

  266. static integer c__2 = 2;

  267. static real c_b123 = (float)1.;

  268. static real c_b135 = (float)0.;

  269. static integer c__6 = 6;

  270. static logical c_true = TRUE_;

  271. static integer c_n1 = -1;

  272. static integer c__0 = 0;

  273. static logical c_false = FALSE_;

  274. 

  275. /* Main program */ int main(void)

  276. {

  277.     /* Initialized data */

  278. 

  279.     static char snames[16][13] = { "cblas_sgemv ", "cblas_sgbmv ", "cblas_ssymv ",

  280.     "cblas_ssbmv ", "cblas_sspmv ", "cblas_strmv ", "cblas_stbmv ", "cblas_stpmv ",

  281.     "cblas_strsv ", "cblas_stbsv ", "cblas_stpsv ", "cblas_sger  ", "cblas_ssyr  ",

  282.     "cblas_sspr  ", "cblas_ssyr2 ", "cblas_sspr2 "};

  283. 

  284.     /* System generated locals */

  285.     integer i__1, i__2, i__3;

  286.     real r__1;

  287. 

  288.     /* Local variables */

  289.     static integer nalf, idim[9];

  290.     static logical same;

  291.     static integer ninc, nbet, ntra;

  292.     static logical rewi;

  293. extern /* Subroutine */ int schk1_(char*, real*, real*, integer*, integer*, logical*, logical*, logical*, integer*, integer*, integer*, integer*, integer*, real*, integer*, real*, integer*, integer*, integer*, integer*, real*, real*, real*, real*, real*, real*, real*, real*, real*, real*, real*, integer*, ftnlen);

  294. extern /* Subroutine */ int schk2_(char*, real*, real*, integer*, integer*, logical*, logical*, logical*, integer*, integer*, integer*, integer*, integer*, real*, integer*, real*, integer*, integer*, integer*, integer*, real*, real*, real*, real*, real*, real*, real*, real*, real*, real*, real*, integer*, ftnlen);

  295. extern /* Subroutine */ int schk3_(char*, real*, real*, integer*, integer*, logical*, logical*, logical*, integer*, integer*, integer*, integer*, integer*, integer*, integer*, integer*, real*, real*, real*, real*, real*, real*, real*, real*, real*, integer*, ftnlen);

  296. extern /* Subroutine */ int schk4_(char*, real*, real*, integer*, integer*, logical*, logical*, logical*, integer*, integer*, integer*, real*, integer*, integer*, integer*, integer*, real*, real*, real*, real*, real*, real*, real*, real*, real*, real*, real*, real*, integer*, ftnlen);

  297. extern /* Subroutine */ int schk5_(char*, real*, real*, integer*, integer*, logical*, logical*, logical*, integer*, integer*, integer*, real*, integer*, integer*, integer*, integer*, real*, real*, real*, real*, real*, real*, real*, real*, real*, real*, real*, real*, integer*, ftnlen);

  298. extern /* Subroutine */ int schk6_(char* sname, real* eps, real* thresh, integer* nout, integer* ntra, logical* trace, logical* rewi, logical* fatal, integer* nidim, integer* idim, integer* nalf, real* alf, integer* ninc, integer* inc, integer* nmax, integer* incmax, real* a, real* aa, real* as, real* x, real* xx, real* xs, real* y, real* yy, real* ys, real* yt, real* g, real* z__, integer* iorder, ftnlen sname_len);

  299.     static real a[4225]	/* was [65][65] */, g[65];

  300.     static integer i__, j, n;

  301.     static logical fatal;

  302.     static real x[65], y[65], z__[130];

  303.     extern doublereal sdiff_(real*, real*);

  304.     static logical trace;

  305.     static integer nidim;

  306.     extern /* Subroutine */ int smvch_(char*, integer*, integer*, real*, real*, integer*, real*, integer*, real*, real*, integer*, real*, real*, real*, real*, real*, logical*, integer*, logical*, ftnlen);

  307.     static char snaps[32], trans[1];

  308.     static integer isnum;

  309.     static logical ltest[16];

  310.     static real aa[4225];

  311.     static integer kb[7];

  312.     static real as[4225];

  313.     static logical sfatal;

  314.     static real xs[130], ys[130];

  315.     static logical corder;

  316.     static real xx[130], yt[65], yy[130];

  317.     static char snamet[12];

  318.     static real thresh;

  319.     static logical rorder;

  320.     static integer layout;

  321.     static logical ltestt;

  322.     extern /* Subroutine */ int cs2chke_(char*, ftnlen);

  323.     static logical tsterr;

  324.     static real alf[7];

  325.     static integer inc[7], nkb;

  326.     static real bet[7];

  327.     extern logical lse_(real*, real*, integer*);

  328.     static real eps, err;

  329.     char   tmpchar;

  330.     

  331. /*  Test program for the REAL             Level 2 Blas. */

  332. 

  333. /*  The program must be driven by a short data file. The first 17 records */

  334. /*  of the file are read using list-directed input, the last 16 records */

  335. /*  are read using the format ( A12, L2 ). An annotated example of a data */

  336. /*  file can be obtained by deleting the first 3 characters from the */

  337. /*  following 33 lines: */

  338. /*  'SBLAT2.SNAP'     NAME OF SNAPSHOT OUTPUT FILE */

  339. /*  -1                UNIT NUMBER OF SNAPSHOT FILE (NOT USED IF .LT. 0) */

  340. /*  F        LOGICAL FLAG, T TO REWIND SNAPSHOT FILE AFTER EACH RECORD. */

  341. /*  F        LOGICAL FLAG, T TO STOP ON FAILURES. */

  342. /*  T        LOGICAL FLAG, T TO TEST ERROR EXITS. */

  343. /*  2        0 TO TEST COLUMN-MAJOR, 1 TO TEST ROW-MAJOR, 2 TO TEST BOTH */

  344. /*  16.0     THRESHOLD VALUE OF TEST RATIO */

  345. /*  6                 NUMBER OF VALUES OF N */

  346. /*  0 1 2 3 5 9       VALUES OF N */

  347. /*  4                 NUMBER OF VALUES OF K */

  348. /*  0 1 2 4           VALUES OF K */

  349. /*  4                 NUMBER OF VALUES OF INCX AND INCY */

  350. /*  1 2 -1 -2         VALUES OF INCX AND INCY */

  351. /*  3                 NUMBER OF VALUES OF ALPHA */

  352. /*  0.0 1.0 0.7       VALUES OF ALPHA */

  353. /*  3                 NUMBER OF VALUES OF BETA */

  354. /*  0.0 1.0 0.9       VALUES OF BETA */

  355. /*  cblas_sgemv  T PUT F FOR NO TEST. SAME COLUMNS. */

  356. /*  cblas_sgbmv  T PUT F FOR NO TEST. SAME COLUMNS. */

  357. /*  cblas_ssymv  T PUT F FOR NO TEST. SAME COLUMNS. */

  358. /*  cblas_ssbmv  T PUT F FOR NO TEST. SAME COLUMNS. */

  359. /*  cblas_sspmv  T PUT F FOR NO TEST. SAME COLUMNS. */

  360. /*  cblas_strmv  T PUT F FOR NO TEST. SAME COLUMNS. */

  361. /*  cblas_stbmv  T PUT F FOR NO TEST. SAME COLUMNS. */

  362. /*  cblas_stpmv  T PUT F FOR NO TEST. SAME COLUMNS. */

  363. /*  cblas_strsv  T PUT F FOR NO TEST. SAME COLUMNS. */

  364. /*  cblas_stbsv  T PUT F FOR NO TEST. SAME COLUMNS. */

  365. /*  cblas_stpsv  T PUT F FOR NO TEST. SAME COLUMNS. */

  366. /*  cblas_sger   T PUT F FOR NO TEST. SAME COLUMNS. */

  367. /*  cblas_ssyr   T PUT F FOR NO TEST. SAME COLUMNS. */

  368. /*  cblas_sspr   T PUT F FOR NO TEST. SAME COLUMNS. */

  369. /*  cblas_ssyr2  T PUT F FOR NO TEST. SAME COLUMNS. */

  370. /*  cblas_sspr2  T PUT F FOR NO TEST. SAME COLUMNS. */

  371. 

  372. /*     See: */

  373. 

  374. /*        Dongarra J. J., Du Croz J. J., Hammarling S.  and Hanson R. J.. */

  375. /*        An  extended  set of Fortran  Basic Linear Algebra Subprograms. */

  376. 

  377. /*        Technical  Memoranda  Nos. 41 (revision 3) and 81,  Mathematics */

  378. /*        and  Computer Science  Division,  Argonne  National Laboratory, */

  379. /*        9700 South Cass Avenue, Argonne, Illinois 60439, US. */

  380. 

  381. /*        Or */

  382. 

  383. /*        NAG  Technical Reports TR3/87 and TR4/87,  Numerical Algorithms */

  384. /*        Group  Ltd.,  NAG  Central  Office,  256  Banbury  Road, Oxford */

  385. /*        OX2 7DE, UK,  and  Numerical Algorithms Group Inc.,  1101  31st */

  386. /*        Street,  Suite 100,  Downers Grove,  Illinois 60515-1263,  USA. */

  387. 

  388. 

  389. /*  -- Written on 10-August-1987. */

  390. /*     Richard Hanson, Sandia National Labs. */

  391. /*     Jeremy Du Croz, NAG Central Office. */

  392. 

  393. /*     .. Parameters .. */

  394. /*     .. Local Scalars .. */

  395. /*     .. Local Arrays .. */

  396. /*     .. External Functions .. */

  397. /*     .. External Subroutines .. */

  398. /*     .. Intrinsic Functions .. */

  399. /*     .. Scalars in Common .. */

  400. /*     .. Common blocks .. */

  401. /*     .. Data statements .. */

  402. /*     .. Executable Statements .. */

  403. 

  404.     infoc_1.noutc = 6;

  405. 

  406. /*     Read name and unit number for snapshot output file and open file. */

  407. 

  408.     char line[80];

  409.     

  410.     fgets(line,80,stdin);

  411.     sscanf(line,"'%s'",snaps);

  412.     fgets(line,80,stdin);

  413. #ifdef USE64BITINT

  414.     sscanf(line,"%ld",&ntra);

  415. #else

  416.     sscanf(line,"%d",&ntra);

  417. #endif

  418.     trace = ntra >= 0;

  419. 

  420.     if (trace) {

  421. /*	o__1.oerr = 0;

  422. 	o__1.ounit = ntra;

  423. 	o__1.ofnmlen = 32;

  424. 	o__1.ofnm = snaps;

  425. 	o__1.orl = 0;

  426. 	o__1.osta = 0;

  427. 	o__1.oacc = 0;

  428. 	o__1.ofm = 0;

  429. 	o__1.oblnk = 0;

  430. 	f_open(&o__1);*/

  431.     }

  432. /*     Read the flag that directs rewinding of the snapshot file. */

  433.    fgets(line,80,stdin);

  434.    sscanf(line,"%d",&rewi);

  435.    rewi = rewi && trace;

  436. /*     Read the flag that directs stopping on any failure. */

  437.    fgets(line,80,stdin);

  438.    sscanf(line,"%c",&tmpchar);

  439. /*     Read the flag that indicates whether error exits are to be tested. */

  440.    sfatal=FALSE_;

  441.    if (tmpchar=='T')sfatal=TRUE_;

  442.    fgets(line,80,stdin);

  443.    sscanf(line,"%c",&tmpchar);

  444. /*     Read the flag that indicates whether error exits are to be tested. */

  445.    tsterr=FALSE_;

  446.    if (tmpchar=='T')tsterr=TRUE_;

  447. /*     Read the flag that indicates whether row-major data layout to be tested. */

  448.    fgets(line,80,stdin);

  449.    sscanf(line,"%d",&layout);

  450. /*     Read the threshold value of the test ratio */

  451.    fgets(line,80,stdin);

  452.    sscanf(line,"%f",&thresh);

  453. 

  454. /*     Read and check the parameter values for the tests. */

  455. 

  456. /*     Values of N */

  457.    fgets(line,80,stdin);

  458. #ifdef USE64BITINT

  459.    sscanf(line,"%ld",&nidim);

  460. #else

  461.    sscanf(line,"%d",&nidim);

  462. #endif

  463.     if (nidim < 1 || nidim > 9) {

  464.         fprintf(stderr,"NUMBER OF VALUES OF N IS LESS THAN 1 OR GREATER THAN 9");

  465.         goto L220;

  466.     }

  467.    fgets(line,80,stdin);

  468. #ifdef USE64BITINT

  469.    sscanf(line,"%ld %ld %ld %ld %ld %ld %ld %ld %ld",&idim[0],&idim[1],&idim[2],

  470.     &idim[3],&idim[4],&idim[5],&idim[6],&idim[7],&idim[8]);

  471. #else

  472.    sscanf(line,"%d %d %d %d %d %d %d %d %d",&idim[0],&idim[1],&idim[2],

  473.     &idim[3],&idim[4],&idim[5],&idim[6],&idim[7],&idim[8]);

  474. #endif

  475.     i__1 = nidim;

  476.     for (i__ = 1; i__ <= i__1; ++i__) {

  477.         if (idim[i__ - 1] < 0 || idim[i__ - 1] > 65) {

  478.         fprintf(stderr,"VALUE OF N IS LESS THAN 0 OR GREATER THAN 65\n");

  479.             goto L220;

  480.         }

  481. /* L10: */

  482.     }

  483. /*     Values of K */

  484.    fgets(line,80,stdin);

  485. #ifdef USE64BITINT

  486.    sscanf(line,"%ld",&nkb);

  487. #else

  488.    sscanf(line,"%d",&nkb);

  489. #endif

  490.     if (nkb < 1 || nkb > 7) {

  491.         fprintf(stderr,"NUMBER OF VALUES OF K IS LESS THAN 1 OR GREATER THAN 7");

  492.         goto L220;

  493.     }

  494.    fgets(line,80,stdin);

  495. #ifdef USE64BITINT

  496.    sscanf(line,"%ld %ld %ld %ld %ld %ld %ld",&kb[0],&kb[1],&kb[2],&kb[3],&kb[4],&kb[5],&kb[6]);

  497. #else

  498.    sscanf(line,"%d %d %d %d %d %d %d",&kb[0],&kb[1],&kb[2],&kb[3],&kb[4],&kb[5],&kb[6]);

  499. #endif

  500.     i__1 = nkb;

  501.     for (i__ = 1; i__ <= i__1; ++i__) {

  502.         if (kb[i__ - 1] < 0 ) {

  503.         fprintf(stderr,"VALUE OF K IS LESS THAN 0\n");

  504.             goto L230;

  505.         }

  506. /* L20: */

  507.     }

  508. /*     Values of INCX and INCY */

  509.    fgets(line,80,stdin);

  510. #ifdef USE64BITINT

  511.    sscanf(line,"%ld",&ninc);

  512. #else

  513.    sscanf(line,"%d",&ninc);

  514. #endif

  515.     if (ninc < 1 || ninc > 7) {

  516.         fprintf(stderr,"NUMBER OF VALUES OF INCX AND INCY IS LESS THAN 1 OR GREATER THAN 7");

  517.         goto L230;

  518.     }

  519. 

  520.    fgets(line,80,stdin);

  521. #ifdef USE64BITINT

  522.    sscanf(line,"%ld %ld %ld %ld %ld %ld %ld",&inc[0],&inc[1],&inc[2],&inc[3],&inc[4],&inc[5],&inc[6]);

  523. #else

  524.    sscanf(line,"%d %d %d %d %d %d %d",&inc[0],&inc[1],&inc[2],&inc[3],&inc[4],&inc[5],&inc[6]);

  525. #endif

  526.     i__1 = ninc;

  527.     for (i__ = 1; i__ <= i__1; ++i__) {

  528. 	if (inc[i__ - 1] == 0 || (i__2 = inc[i__ - 1], abs(i__2)) > 2) {

  529.     	    fprintf (stderr,"ABSOLUTE VALUE OF INCX OR INCY IS 0 OR GREATER THAN 2\n");

  530. 	    goto L230;

  531. 	}

  532. /* L30: */

  533.     }

  534. /*     Values of ALPHA */

  535.    fgets(line,80,stdin);

  536.    sscanf(line,"%d",&nalf);

  537.     if (nalf < 1 || nalf > 7) {

  538.         fprintf(stderr,"VALUE OF ALPHA IS LESS THAN 0 OR GREATER THAN 7\n");

  539.         goto L230;

  540.     }

  541.    fgets(line,80,stdin);

  542.    sscanf(line,"%f %f %f %f %f %f %f",&alf[0],&alf[1],&alf[2],&alf[3],&alf[4],&alf[5],&alf[6]);

  543. 

  544. /*     Values of BETA */

  545.    fgets(line,80,stdin);

  546.    sscanf(line,"%d",&nbet);

  547.     if (nbet < 1 || nbet > 7) {

  548.         fprintf(stderr,"VALUE OF BETA IS LESS THAN 0 OR GREATER THAN 7\n");

  549.         goto L230;

  550.     }

  551.    fgets(line,80,stdin);

  552.    sscanf(line,"%f %f %f %f %f %f %f",&bet[0],&bet[1],&bet[2],&bet[3],&bet[4],&bet[5],&bet[6]);

  553. 

  554. /*     Report values of parameters. */

  555.     printf("TESTS OF THE REAL      LEVEL 2 BLAS\nTHE FOLLOWING PARAMETER VALUES WILL BE USED:\n");

  556.     printf(" FOR N");

  557.     for (i__ =1; i__ <=nidim;++i__) printf(" %d",idim[i__-1]);

  558.     printf("\n");

  559. 

  560.     printf(" FOR K");

  561.     for (i__ =1; i__ <=nkb;++i__) printf(" %d",kb[i__-1]);

  562.     printf("\n");

  563. 

  564.     printf(" FOR INCX AND INCY");

  565.     for (i__ =1; i__ <=ninc;++i__) printf(" %d",inc[i__-1]);

  566.     printf("\n");

  567. 

  568.     printf(" FOR ALPHA");

  569.     for (i__ =1; i__ <=nalf;++i__) printf(" %f",alf[i__-1]);

  570.     printf("\n");    

  571.     printf(" FOR BETA");

  572.     for (i__ =1; i__ <=nbet;++i__) printf(" %f",bet[i__-1]);

  573.     printf("\n");    

  574. 

  575.     if (! tsterr) {

  576.       printf(" ERROR-EXITS WILL NOT BE TESTED\n"); 

  577.     }

  578.     printf("ROUTINES PASS COMPUTATIONAL TESTS IF TEST RATIO IS LESS THAN %f\n",thresh);

  579.     

  580.     rorder = FALSE_;

  581.     corder = FALSE_;

  582.     if (layout == 2) {

  583. 	rorder = TRUE_;

  584. 	corder = TRUE_;

  585.         printf("COLUMN-MAJOR AND ROW-MAJOR DATA LAYOUTS ARE TESTED\n");

  586.     } else if (layout == 1) {

  587. 	rorder = TRUE_;

  588.         printf("ROW-MAJOR DATA LAYOUT IS TESTED\n");

  589.     } else if (layout == 0) {

  590. 	corder = TRUE_;

  591.         printf("COLUMN-MAJOR DATA LAYOUT IS TESTED\n");

  592.     }

  593. 

  594. /*     Read names of subroutines and flags which indicate */

  595. /*     whether they are to be tested. */

  596. 

  597.     for (i__ = 1; i__ <= 16; ++i__) {

  598. 	ltest[i__ - 1] = FALSE_;

  599. /* L40: */

  600.     }

  601. L50:

  602.     if (! fgets(line,80,stdin)) {

  603. 	goto L80;

  604.     }

  605.     i__1 = sscanf(line,"%12c %c",snamet,&tmpchar);

  606.    ltestt=FALSE_;

  607.    if (tmpchar=='T')ltestt=TRUE_;

  608.     if (i__1 < 2) {

  609.         goto L80;

  610.     }

  611. 

  612.     for (i__ = 1; i__ <= 16; ++i__) {

  613. 	if (s_cmp(snamet, snames[i__ - 1], (ftnlen)12, (ftnlen)12) == 

  614. 		0) {

  615. 	    goto L70;

  616. 	}

  617. /* L60: */

  618.     }

  619.     printf("SUBPROGRAM NAME %s NOT RECOGNIZED\n****** TESTS ABANDONED ******\n",snamet);

  620.     exit(1);

  621. L70:

  622.     ltest[i__ - 1] = ltestt;

  623.     goto L50;

  624. 

  625. L80:

  626. /*    cl__1.cerr = 0;

  627.     cl__1.cunit = 5;

  628.     cl__1.csta = 0;

  629.     f_clos(&cl__1);*/

  630. 

  631. /*     Compute EPS (the machine precision). */

  632. 

  633.     eps = (float)1.;

  634. L90:

  635.     r__1 = eps + (float)1.;

  636.     if (sdiff_(&r__1, &c_b123) == (float)0.) {

  637. 	goto L100;

  638.     }

  639.     eps *= (float).5;

  640.     goto L90;

  641. L100:

  642.     eps += eps;

  643.     printf("RELATIVE MACHINE PRECISION IS TAKEN TO BE %9.1g\n",eps);

  644. 

  645. /*     Check the reliability of SMVCH using exact data. */

  646. 

  647.     n = 32;

  648.     i__1 = n;

  649.     for (j = 1; j <= i__1; ++j) {

  650. 	i__2 = n;

  651. 	for (i__ = 1; i__ <= i__2; ++i__) {

  652. /* Computing MAX */

  653. 	    i__3 = i__ - j + 1;

  654. 	    a[i__ + j * 65 - 66] = (real) f2cmax(i__3,0);

  655. /* L110: */

  656. 	}

  657. 	x[j - 1] = (real) j;

  658. 	y[j - 1] = (float)0.;

  659. /* L120: */

  660.     }

  661.     i__1 = n;

  662.     for (j = 1; j <= i__1; ++j) {

  663. 	yy[j - 1] = (real) (j * ((j + 1) * j) / 2 - (j + 1) * j * (j - 1) / 3)

  664. 		;

  665. /* L130: */

  666.     }

  667. /*     YY holds the exact result. On exit from SMVCH YT holds */

  668. /*     the result computed by SMVCH. */

  669.     *(unsigned char *)trans = 'N';

  670.     smvch_(trans, &n, &n, &c_b123, a, &c__65, x, &c__1, &c_b135, y, &c__1, yt,

  671. 	     g, yy, &eps, &err, &fatal, &c__6, &c_true, (ftnlen)1);

  672.     same = lse_(yy, yt, &n);

  673.     if (! same || err != (float)0.) {

  674.       printf("ERROR IN SMVCH - IN-LINE DOT PRODUCTS ARE BEING EVALUATED WRONGLY\n");

  675.       printf("SMVCH WAS CALLED WITH TRANS = %s ", trans);

  676.       printf("AND RETURNED SAME = %c AND ERR = %12.3f.\n",(same==FALSE_? 'F':'T'),err);

  677.       printf("THIS MAY BE DUE TO FAULTS IN THE ARITHMETIC OR THE COMPILER.\n");

  678.       printf("****** TESTS ABANDONED ******\n");

  679.       exit(1);

  680.     }

  681.     *(unsigned char *)trans = 'T';

  682.     smvch_(trans, &n, &n, &c_b123, a, &c__65, x, &c_n1, &c_b135, y, &c_n1, yt,

  683. 	     g, yy, &eps, &err, &fatal, &c__6, &c_true, (ftnlen)1);

  684.     same = lse_(yy, yt, &n);

  685.     if (! same || err != (float)0.) {

  686.       printf("ERROR IN SMVCH - IN-LINE DOT PRODUCTS ARE BEING EVALUATED WRONGLY\n");

  687.       printf("SMVCH WAS CALLED WITH TRANS = %s ", trans);

  688.       printf("AND RETURNED SAME = %c AND ERR = %12.3f.\n",(same==FALSE_? 'F':'T'),err);

  689.       printf("THIS MAY BE DUE TO FAULTS IN THE ARITHMETIC OR THE COMPILER.\n");

  690.       printf("****** TESTS ABANDONED ******\n");

  691.       exit(1);

  692.     }

  693. 

  694. /*     Test each subroutine in turn. */

  695. 

  696.     for (isnum = 1; isnum <= 16; ++isnum) {

  697. 	if (! ltest[isnum - 1]) {

  698. /*           Subprogram is not to be tested. */

  699.            printf("%12s WAS NOT TESTED\n",snames[isnum-1]);

  700. 	} else {

  701. 	    s_copy(srnamc_1.srnamt, snames[isnum - 1], (ftnlen)12, (

  702. 		    ftnlen)12);

  703. /*           Test error exits. */

  704. 	    if (tsterr) {

  705. 		cs2chke_(snames[isnum - 1], (ftnlen)12);

  706. 	    }

  707. /*           Test computations. */

  708. 	    infoc_1.infot = 0;

  709. 	    infoc_1.ok = TRUE_;

  710. 	    fatal = FALSE_;

  711. 	    switch ((int)isnum) {

  712. 		case 1:  goto L140;

  713. 		case 2:  goto L140;

  714. 		case 3:  goto L150;

  715. 		case 4:  goto L150;

  716. 		case 5:  goto L150;

  717. 		case 6:  goto L160;

  718. 		case 7:  goto L160;

  719. 		case 8:  goto L160;

  720. 		case 9:  goto L160;

  721. 		case 10:  goto L160;

  722. 		case 11:  goto L160;

  723. 		case 12:  goto L170;

  724. 		case 13:  goto L180;

  725. 		case 14:  goto L180;

  726. 		case 15:  goto L190;

  727. 		case 16:  goto L190;

  728. 	    }

  729. /*           Test SGEMV, 01, and SGBMV, 02. */

  730. L140:

  731. 	    if (corder) {

  732. 		schk1_(snames[isnum - 1], &eps, &thresh, &c__6, &ntra,

  733. 			 &trace, &rewi, &fatal, &nidim, idim, &nkb, kb, &nalf,

  734. 			 alf, &nbet, bet, &ninc, inc, &c__65, &c__2, a, aa, 

  735. 			as, x, xx, xs, y, yy, ys, yt, g, &c__0, (ftnlen)12);

  736. 	    }

  737. 	    if (rorder) {

  738. 		schk1_(snames[isnum - 1], &eps, &thresh, &c__6, &ntra,

  739. 			 &trace, &rewi, &fatal, &nidim, idim, &nkb, kb, &nalf,

  740. 			 alf, &nbet, bet, &ninc, inc, &c__65, &c__2, a, aa, 

  741. 			as, x, xx, xs, y, yy, ys, yt, g, &c__1, (ftnlen)12);

  742. 	    }

  743. 	    goto L200;

  744. /*           Test SSYMV, 03, SSBMV, 04, and SSPMV, 05. */

  745. L150:

  746. 	    if (corder) {

  747. 		schk2_(snames[isnum - 1], &eps, &thresh, &c__6, &ntra,

  748. 			 &trace, &rewi, &fatal, &nidim, idim, &nkb, kb, &nalf,

  749. 			 alf, &nbet, bet, &ninc, inc, &c__65, &c__2, a, aa, 

  750. 			as, x, xx, xs, y, yy, ys, yt, g, &c__0, (ftnlen)12);

  751. 	    }

  752. 	    if (rorder) {

  753. 		schk2_(snames[isnum - 1], &eps, &thresh, &c__6, &ntra,

  754. 			 &trace, &rewi, &fatal, &nidim, idim, &nkb, kb, &nalf,

  755. 			 alf, &nbet, bet, &ninc, inc, &c__65, &c__2, a, aa, 

  756. 			as, x, xx, xs, y, yy, ys, yt, g, &c__1, (ftnlen)12);

  757. 	    }

  758. 	    goto L200;

  759. /*           Test STRMV, 06, STBMV, 07, STPMV, 08, */

  760. /*           STRSV, 09, STBSV, 10, and STPSV, 11. */

  761. L160:

  762. 	    if (corder) {

  763. 		schk3_(snames[isnum - 1], &eps, &thresh, &c__6, &ntra,

  764. 			 &trace, &rewi, &fatal, &nidim, idim, &nkb, kb, &ninc,

  765. 			 inc, &c__65, &c__2, a, aa, as, y, yy, ys, yt, g, z__,

  766. 			 &c__0, (ftnlen)12);

  767. 	    }

  768. 	    if (rorder) {

  769. 		schk3_(snames[isnum - 1], &eps, &thresh, &c__6, &ntra,

  770. 			 &trace, &rewi, &fatal, &nidim, idim, &nkb, kb, &ninc,

  771. 			 inc, &c__65, &c__2, a, aa, as, y, yy, ys, yt, g, z__,

  772. 			 &c__1, (ftnlen)12);

  773. 	    }

  774. 	    goto L200;

  775. /*           Test SGER, 12. */

  776. L170:

  777. 	    if (corder) {

  778. 		schk4_(snames[isnum - 1], &eps, &thresh, &c__6, &ntra,

  779. 			 &trace, &rewi, &fatal, &nidim, idim, &nalf, alf, &

  780. 			ninc, inc, &c__65, &c__2, a, aa, as, x, xx, xs, y, yy,

  781. 			 ys, yt, g, z__, &c__0, (ftnlen)12);

  782. 	    }

  783. 	    if (rorder) {

  784. 		schk4_(snames[isnum - 1], &eps, &thresh, &c__6, &ntra,

  785. 			 &trace, &rewi, &fatal, &nidim, idim, &nalf, alf, &

  786. 			ninc, inc, &c__65, &c__2, a, aa, as, x, xx, xs, y, yy,

  787. 			 ys, yt, g, z__, &c__1, (ftnlen)12);

  788. 	    }

  789. 	    goto L200;

  790. /*           Test SSYR, 13, and SSPR, 14. */

  791. L180:

  792. 	    if (corder) {

  793. 		schk5_(snames[isnum - 1], &eps, &thresh, &c__6, &ntra,

  794. 			 &trace, &rewi, &fatal, &nidim, idim, &nalf, alf, &

  795. 			ninc, inc, &c__65, &c__2, a, aa, as, x, xx, xs, y, yy,

  796. 			 ys, yt, g, z__, &c__0, (ftnlen)12);

  797. 	    }

  798. 	    if (rorder) {

  799. 		schk5_(snames[isnum - 1], &eps, &thresh, &c__6, &ntra,

  800. 			 &trace, &rewi, &fatal, &nidim, idim, &nalf, alf, &

  801. 			ninc, inc, &c__65, &c__2, a, aa, as, x, xx, xs, y, yy,

  802. 			 ys, yt, g, z__, &c__1, (ftnlen)12);

  803. 	    }

  804. 	    goto L200;

  805. /*           Test SSYR2, 15, and SSPR2, 16. */

  806. L190:

  807. 	    if (corder) {

  808. 		schk6_(snames[isnum - 1], &eps, &thresh, &c__6, &ntra,

  809. 			 &trace, &rewi, &fatal, &nidim, idim, &nalf, alf, &

  810. 			ninc, inc, &c__65, &c__2, a, aa, as, x, xx, xs, y, yy,

  811. 			 ys, yt, g, z__, &c__0, (ftnlen)12);

  812. 	    }

  813. 	    if (rorder) {

  814. 		schk6_(snames[isnum - 1], &eps, &thresh, &c__6, &ntra,

  815. 			 &trace, &rewi, &fatal, &nidim, idim, &nalf, alf, &

  816. 			ninc, inc, &c__65, &c__2, a, aa, as, x, xx, xs, y, yy,

  817. 			 ys, yt, g, z__, &c__1, (ftnlen)12);

  818. 	    }

  819. 

  820. L200:

  821. 	    if (fatal && sfatal) {

  822. 		goto L220;

  823. 	    }

  824. 	}

  825. /* L210: */

  826.     }

  827.     printf("\nEND OF TESTS\n");

  828.     goto L240;

  829. 

  830. L220:

  831.     printf("\n****** FATAL ERROR - TESTS ABANDONED ******\n");

  832.     goto L240;

  833. 

  834. L230:

  835.     printf("AMEND DATA FILE OR INCREASE ARRAY SIZES IN PROGRAM\n");

  836.     printf("****** TESTS ABANDONED ******\n");

  837. 

  838. L240:

  839.     if (trace) {

  840. /*	cl__1.cerr = 0;

  841. 	cl__1.cunit = ntra;

  842. 	cl__1.csta = 0;

  843. 	f_clos(&cl__1);*/

  844.     }

  845. /*    cl__1.cerr = 0;

  846.     cl__1.cunit = 6;

  847.     cl__1.csta = 0;

  848.     f_clos(&cl__1);

  849.     s_stop("", (ftnlen)0);*/

  850.     exit(0);

  851. 

  852. /*     End of SBLAT2. */

  853. 

  854. } /* MAIN__ */

  855. 

  856. /* Subroutine */ int schk1_(char* sname, real* eps, real* thresh, integer* nout, integer* ntra, logical* trace, logical* rewi, logical* fatal, integer* nidim, integer* idim, integer* nkb, integer* kb, integer* nalf, real* alf, integer* nbet, real* bet, integer* ninc, integer* inc, integer* nmax, integer* incmax, real* a, real* aa, real* as, real* x, real* xx, real* xs, real* y, real* yy, real* ys, real* yt, real* g, integer* iorder, ftnlen sname_len)

  857. {

  858.     /* Initialized data */

  859. 

  860.     static char ich[3+1] = "NTC";

  861. 

  862.     /* System generated locals */

  863.     integer a_dim1, a_offset, i__1, i__2, i__3, i__4, i__5, i__6, i__7, i__8;

  864. 

  865.     /* Local variables */

  866.     static real beta;

  867.     static integer ldas;

  868.     static logical same;

  869.     static integer incx, incy;

  870.     static logical full, tran, null;

  871.     static integer i__, m, n;

  872.     static real alpha;

  873.     static logical isame[13];

  874.     extern /* Subroutine */ int smake_(char*, char*, char*, integer*, integer*, real*, integer*, real*, integer*, integer*, integer*, logical*, real*, ftnlen, ftnlen, ftnlen);

  875.     static integer nargs;

  876.     extern /* Subroutine */ int smvch_(char*, integer*, integer*, real*, real*, integer*, real*, integer*, real*, real*, integer*, real*, real*, real*, real*, real*, logical*, integer*, logical*, ftnlen);

  877.     static logical reset;

  878.     static integer incxs, incys;

  879.     static char trans[1];

  880.     static integer ia, ib, ic;

  881.     static logical banded;

  882.     static integer nc, nd, im, in, kl, ml, nk, nl, ku, ix, iy, ms, lx, ly, ns;

  883.     extern /* Subroutine */ void csgbmv_(integer*, char*, integer*, integer*, integer*, integer*, real*, real*, integer*, real*, integer*, real*, real*, integer*, ftnlen);

  884.     extern /* Subroutine */ void csgemv_(integer*, char*, integer*, integer*, real*, real*, integer*, real*, integer*, real*, real*, integer*, ftnlen);

  885.     static char ctrans[14];

  886.     static real errmax;

  887.     extern logical lseres_(char* type__, char* uplo, integer* m, integer* n, real* aa, real* as, integer* lda, ftnlen ltype_len, ftnlen uplo_len);

  888.     static real transl;

  889.     static char transs[1];

  890.     static integer laa, lda;

  891.     static real als, bls;

  892.     extern logical lse_(real*, real*, integer*);

  893.     static real err;

  894.     static integer iku, kls, kus;

  895. 

  896. /*  Tests SGEMV and SGBMV. */

  897. 

  898. /*  Auxiliary routine for test program for Level 2 Blas. */

  899. 

  900. /*  -- Written on 10-August-1987. */

  901. /*     Richard Hanson, Sandia National Labs. */

  902. /*     Jeremy Du Croz, NAG Central Office. */

  903. 

  904. /*     .. Parameters .. */

  905. /*     .. Scalar Arguments .. */

  906. /*     .. Array Arguments .. */

  907. /*     .. Local Scalars .. */

  908. /*     .. Local Arrays .. */

  909. /*     .. External Functions .. */

  910. /*     .. External Subroutines .. */

  911. /*     .. Intrinsic Functions .. */

  912. /*     .. Scalars in Common .. */

  913. /*     .. Common blocks .. */

  914. /*     .. Data statements .. */

  915.     /* Parameter adjustments */

  916.     --idim;

  917.     --kb;

  918.     --alf;

  919.     --bet;

  920.     --inc;

  921.     --g;

  922.     --yt;

  923.     --y;

  924.     --x;

  925.     --as;

  926.     --aa;

  927.     a_dim1 = *nmax;

  928.     a_offset = 1 + a_dim1 * 1;

  929.     a -= a_offset;

  930.     --ys;

  931.     --yy;

  932.     --xs;

  933.     --xx;

  934. 

  935.     /* Function Body */

  936. /*     .. Executable Statements .. */

  937.     full = *(unsigned char *)&sname[8] == 'e';

  938.     banded = *(unsigned char *)&sname[8] == 'b';

  939. /*     Define the number of arguments. */

  940.     if (full) {

  941. 	nargs = 11;

  942.     } else if (banded) {

  943. 	nargs = 13;

  944.     }

  945. 

  946.     nc = 0;

  947.     reset = TRUE_;

  948.     errmax = (float)0.;

  949. 

  950.     i__1 = *nidim;

  951.     for (in = 1; in <= i__1; ++in) {

  952. 	n = idim[in];

  953. 	nd = n / 2 + 1;

  954. 

  955. 	for (im = 1; im <= 2; ++im) {

  956. 	    if (im == 1) {

  957. /* Computing MAX */

  958. 		i__2 = n - nd;

  959. 		m = f2cmax(i__2,0);

  960. 	    }

  961. 	    if (im == 2) {

  962. /* Computing MIN */

  963. 		i__2 = n + nd;

  964. 		m = f2cmin(i__2,*nmax);

  965. 	    }

  966. 

  967. 	    if (banded) {

  968. 		nk = *nkb;

  969. 	    } else {

  970. 		nk = 1;

  971. 	    }

  972. 	    i__2 = nk;

  973. 	    for (iku = 1; iku <= i__2; ++iku) {

  974. 		if (banded) {

  975. 		    ku = kb[iku];

  976. /* Computing MAX */

  977. 		    i__3 = ku - 1;

  978. 		    kl = f2cmax(i__3,0);

  979. 		} else {

  980. 		    ku = n - 1;

  981. 		    kl = m - 1;

  982. 		}

  983. /*              Set LDA to 1 more than minimum value if room. */

  984. 		if (banded) {

  985. 		    lda = kl + ku + 1;

  986. 		} else {

  987. 		    lda = m;

  988. 		}

  989. 		if (lda < *nmax) {

  990. 		    ++lda;

  991. 		}

  992. /*              Skip tests if not enough room. */

  993. 		if (lda > *nmax) {

  994. 		    goto L100;

  995. 		}

  996. 		laa = lda * n;

  997. 		null = n <= 0 || m <= 0;

  998. 

  999. /*              Generate the matrix A. */

  1000. 

  1001. 		transl = (float)0.;

  1002. 		smake_(sname + 7, " ", " ", &m, &n, &a[a_offset], nmax, &aa[1]

  1003. 			, &lda, &kl, &ku, &reset, &transl, (ftnlen)2, (ftnlen)

  1004. 			1, (ftnlen)1);

  1005. 

  1006. 		for (ic = 1; ic <= 3; ++ic) {

  1007. 		    *(unsigned char *)trans = *(unsigned char *)&ich[ic - 1];

  1008. 		    if (*(unsigned char *)trans == 'N') {

  1009. 			s_copy(ctrans, "  CblasNoTrans", (ftnlen)14, (ftnlen)

  1010. 				14);

  1011. 		    } else if (*(unsigned char *)trans == 'T') {

  1012. 			s_copy(ctrans, "    CblasTrans", (ftnlen)14, (ftnlen)

  1013. 				14);

  1014. 		    } else {

  1015. 			s_copy(ctrans, "CblasConjTrans", (ftnlen)14, (ftnlen)

  1016. 				14);

  1017. 		    }

  1018. 		    tran = *(unsigned char *)trans == 'T' || *(unsigned char *

  1019. 			    )trans == 'C';

  1020. 

  1021. 		    if (tran) {

  1022. 			ml = n;

  1023. 			nl = m;

  1024. 		    } else {

  1025. 			ml = m;

  1026. 			nl = n;

  1027. 		    }

  1028. 

  1029. 		    i__3 = *ninc;

  1030. 		    for (ix = 1; ix <= i__3; ++ix) {

  1031. 			incx = inc[ix];

  1032. 			lx = abs(incx) * nl;

  1033. 

  1034. /*                    Generate the vector X. */

  1035. 

  1036. 			transl = (float).5;

  1037. 			i__4 = abs(incx);

  1038. 			i__5 = nl - 1;

  1039. 			smake_("ge", " ", " ", &c__1, &nl, &x[1], &c__1, &xx[

  1040. 				1], &i__4, &c__0, &i__5, &reset, &transl, (

  1041. 				ftnlen)2, (ftnlen)1, (ftnlen)1);

  1042. 			if (nl > 1) {

  1043. 			    x[nl / 2] = (float)0.;

  1044. 			    xx[abs(incx) * (nl / 2 - 1) + 1] = (float)0.;

  1045. 			}

  1046. 

  1047. 			i__4 = *ninc;

  1048. 			for (iy = 1; iy <= i__4; ++iy) {

  1049. 			    incy = inc[iy];

  1050. 			    ly = abs(incy) * ml;

  1051. 

  1052. 			    i__5 = *nalf;

  1053. 			    for (ia = 1; ia <= i__5; ++ia) {

  1054. 				alpha = alf[ia];

  1055. 

  1056. 				i__6 = *nbet;

  1057. 				for (ib = 1; ib <= i__6; ++ib) {

  1058. 				    beta = bet[ib];

  1059. 

  1060. /*                             Generate the vector Y. */

  1061. 

  1062. 				    transl = (float)0.;

  1063. 				    i__7 = abs(incy);

  1064. 				    i__8 = ml - 1;

  1065. 				    smake_("ge", " ", " ", &c__1, &ml, &y[1], 

  1066. 					    &c__1, &yy[1], &i__7, &c__0, &

  1067. 					    i__8, &reset, &transl, (ftnlen)2, 

  1068. 					    (ftnlen)1, (ftnlen)1);

  1069. 

  1070. 				    ++nc;

  1071. 

  1072. /*                             Save every datum before calling the */

  1073. /*                             subroutine. */

  1074. 

  1075. 				    *(unsigned char *)transs = *(unsigned 

  1076. 					    char *)trans;

  1077. 				    ms = m;

  1078. 				    ns = n;

  1079. 				    kls = kl;

  1080. 				    kus = ku;

  1081. 				    als = alpha;

  1082. 				    i__7 = laa;

  1083. 				    for (i__ = 1; i__ <= i__7; ++i__) {

  1084. 					as[i__] = aa[i__];

  1085. /* L10: */

  1086. 				    }

  1087. 				    ldas = lda;

  1088. 				    i__7 = lx;

  1089. 				    for (i__ = 1; i__ <= i__7; ++i__) {

  1090. 					xs[i__] = xx[i__];

  1091. /* L20: */

  1092. 				    }

  1093. 				    incxs = incx;

  1094. 				    bls = beta;

  1095. 				    i__7 = ly;

  1096. 				    for (i__ = 1; i__ <= i__7; ++i__) {

  1097. 					ys[i__] = yy[i__];

  1098. /* L30: */

  1099. 				    }

  1100. 				    incys = incy;

  1101. 

  1102. /*                             Call the subroutine. */

  1103. 

  1104. 				    if (full) {

  1105. 					if (*trace) {

  1106. /*

  1107.     					    sprintf(ntra,"%6d: %12s  %14s %3d %3d %4.1f A %3d  X  %2d %4.1f  Y  %2d .\n",

  1108.     					    nc,sname,ctrans,m,n,alpha,lda,incx,beta,incy);

  1109. */

  1110. 					}

  1111. 					if (*rewi) {

  1112. /*					    al__1.aerr = 0;

  1113. 					    al__1.aunit = *ntra;

  1114. 					    f_rew(&al__1);*/

  1115. 					}

  1116. 					csgemv_(iorder, trans, &m, &n, &alpha,

  1117. 						 &aa[1], &lda, &xx[1], &incx, 

  1118. 						&beta, &yy[1], &incy, (ftnlen)

  1119. 						1);

  1120. 				    } else if (banded) {

  1121. 					if (*trace) {

  1122. /*

  1123. 					    sprintf(ntra,"%6d: %12s %14s %3d %3d %3d %3d %4.1f A %3d            %2d  %4.1f  Y %2d\n",

  1124.     					    nc,sname,ctrans,m,n,kl,ku,alpha,lda,incx,beta,incy);

  1125. */

  1126. 					}

  1127. 					if (*rewi) {

  1128. /*					    al__1.aerr = 0;

  1129. 					    al__1.aunit = *ntra;

  1130. 					    f_rew(&al__1);*/

  1131. 					}

  1132. 					csgbmv_(iorder, trans, &m, &n, &kl, &

  1133. 						ku, &alpha, &aa[1], &lda, &xx[

  1134. 						1], &incx, &beta, &yy[1], &

  1135. 						incy, (ftnlen)1);

  1136. 				    }

  1137. 

  1138. /*                             Check if error-exit was taken incorrectly. */

  1139. 

  1140. 				    if (! infoc_1.ok) {

  1141. 				    	printf(" ******* FATAL ERROR - ERROR-EXIT TAKEN ON VALID CALL *******n");

  1142. 					*fatal = TRUE_;

  1143. 					goto L130;

  1144. 				    }

  1145. 

  1146. /*                             See what data changed inside subroutines. */

  1147. 

  1148. 				    isame[0] = *(unsigned char *)trans == *(

  1149. 					    unsigned char *)transs;

  1150. 				    isame[1] = ms == m;

  1151. 				    isame[2] = ns == n;

  1152. 				    if (full) {

  1153. 					isame[3] = als == alpha;

  1154. 					isame[4] = lse_(&as[1], &aa[1], &laa);

  1155. 					isame[5] = ldas == lda;

  1156. 					isame[6] = lse_(&xs[1], &xx[1], &lx);

  1157. 					isame[7] = incxs == incx;

  1158. 					isame[8] = bls == beta;

  1159. 					if (null) {

  1160. 					    isame[9] = lse_(&ys[1], &yy[1], &

  1161. 						    ly);

  1162. 					} else {

  1163. 					    i__7 = abs(incy);

  1164. 					    isame[9] = lseres_("ge", " ", &

  1165. 						    c__1, &ml, &ys[1], &yy[1],

  1166. 						     &i__7, (ftnlen)2, (

  1167. 						    ftnlen)1);

  1168. 					}

  1169. 					isame[10] = incys == incy;

  1170. 				    } else if (banded) {

  1171. 					isame[3] = kls == kl;

  1172. 					isame[4] = kus == ku;

  1173. 					isame[5] = als == alpha;

  1174. 					isame[6] = lse_(&as[1], &aa[1], &laa);

  1175. 					isame[7] = ldas == lda;

  1176. 					isame[8] = lse_(&xs[1], &xx[1], &lx);

  1177. 					isame[9] = incxs == incx;

  1178. 					isame[10] = bls == beta;

  1179. 					if (null) {

  1180. 					    isame[11] = lse_(&ys[1], &yy[1], &

  1181. 						    ly);

  1182. 					} else {

  1183. 					    i__7 = abs(incy);

  1184. 					    isame[11] = lseres_("ge", " ", &

  1185. 						    c__1, &ml, &ys[1], &yy[1],

  1186. 						     &i__7, (ftnlen)2, (

  1187. 						    ftnlen)1);

  1188. 					}

  1189. 					isame[12] = incys == incy;

  1190. 				    }

  1191. 

  1192. /*                             If data was incorrectly changed, report */

  1193. /*                             and return. */

  1194. 

  1195. 				    same = TRUE_;

  1196. 				    i__7 = nargs;

  1197. 				    for (i__ = 1; i__ <= i__7; ++i__) {

  1198. 					same = same && isame[i__ - 1];

  1199. 					if (! isame[i__ - 1]) {

  1200. 					    printf(" ******* FATAL ERROR - PARAMETER NUMBER %2d WAS CHANGED INCORRECTLY *******\n",i__);

  1201. 					}

  1202. /* L40: */

  1203. 				    }

  1204. 				    if (! same) {

  1205. 					*fatal = TRUE_;

  1206. 					goto L130;

  1207. 				    }

  1208. 

  1209. 				    if (! null) {

  1210. 

  1211. /*                                Check the result. */

  1212. 

  1213. 					smvch_(trans, &m, &n, &alpha, &a[

  1214. 						a_offset], nmax, &x[1], &incx,

  1215. 						 &beta, &y[1], &incy, &yt[1], 

  1216. 						&g[1], &yy[1], eps, &err, 

  1217. 						fatal, nout, &c_true, (ftnlen)

  1218. 						1);

  1219. 					errmax = dmax(errmax,err);

  1220. /*                                If got really bad answer, report and */

  1221. /*                                return. */

  1222. 					if (*fatal) {

  1223. 					    goto L130;

  1224. 					}

  1225. 				    } else {

  1226. /*                                Avoid repeating tests with M.le.0 or */

  1227. /*                                N.le.0. */

  1228. 					goto L110;

  1229. 				    }

  1230. 

  1231. /* L50: */

  1232. 				}

  1233. 

  1234. /* L60: */

  1235. 			    }

  1236. 

  1237. /* L70: */

  1238. 			}

  1239. 

  1240. /* L80: */

  1241. 		    }

  1242. 

  1243. /* L90: */

  1244. 		}

  1245. 

  1246. L100:

  1247. 		;

  1248. 	    }

  1249. 

  1250. L110:

  1251. 	    ;

  1252. 	}

  1253. 

  1254. /* L120: */

  1255.     }

  1256. 

  1257. /*     Report result. */

  1258. 

  1259.     if (errmax < *thresh) {

  1260. 	if (*iorder == 0) {

  1261. 	    printf("%12s PASSED THE COLUMN-MAJOR COMPUTATIONAL TESTS (%6d CALLS)\n",sname,nc);

  1262. 	}

  1263. 	if (*iorder == 1) {

  1264. 	    printf("%12s PASSED THE ROW-MAJOR COMPUTATIONAL TESTS (%6d CALLS)\n",sname,nc);

  1265. 	}

  1266.     } else {

  1267. 	if (*iorder == 0) {

  1268. 	    printf("%12s COMPLETED THE COLUMN-MAJOR COMPUTATIONAL TESTS (%6d CALLS) ******* BUT WITH MAXIMUM TEST RATIO %8.2f - SUSPECT *******\n",sname,nc,errmax);;

  1269. 	}

  1270. 	if (*iorder == 1) {

  1271. 	    printf("%12s COMPLETED THE ROW-MAJOR COMPUTATIONAL TESTS (%6d CALLS) ******* BUT WITH MAXIMUM TEST RATIO %8.2f - SUSPECT *******\n",sname,nc,errmax);;

  1272. 	}

  1273.     }

  1274.     goto L140;

  1275. 

  1276. L130:

  1277.     printf("******* %12s FAILED ON CALL NUMBER:",sname);

  1278.     if (full) {

  1279. 	printf("%6d: %12s  %14s %3d %3d %4.1f A %3d  X  %2d %4.1f  Y  %2d .\n",

  1280. 		nc,sname,ctrans,m,n,alpha,lda,incx,beta,incy);

  1281.     } else if (banded) {

  1282. 	printf("%6d: %12s %14s %3d %3d %3d %3d %4.1f A %3d            %2d  %4.1f  Y %2d\n",

  1283. 		nc,sname,ctrans,m,n,kl,ku,alpha,lda,incx,beta,incy);

  1284.     }

  1285. 

  1286. L140:

  1287.     return 0;

  1288. 

  1289. /* 9997 FORMAT( ' ',A12, ' COMPLETED THE COMPUTATIONAL TESTS (', I6, ' C', */

  1290. /*     $      'ALLS)', /' ******* BUT WITH MAXIMUM TEST RATIO', F8.2, */

  1291. /*     $      ' - SUSPECT *******' ) */

  1292. 

  1293. /*     End of SCHK1. */

  1294. 

  1295. } /* schk1_ */

  1296. 

  1297. /* Subroutine */ int schk2_(char* sname, real* eps, real* thresh, integer* nout, integer* ntra, logical* trace, logical* rewi, logical* fatal, integer* nidim, integer* idim, integer* nkb, integer* kb, integer* nalf, real* alf, integer* nbet, real* bet, integer* ninc, integer* inc, integer* nmax, integer* incmax, real* a, real* aa, real* as, real* x, real* xx, real* xs, real* y, real* yy, real* ys, real* yt, real* g, integer* iorder, ftnlen sname_len)

  1298. {

  1299.     /* Initialized data */

  1300. 

  1301.     static char ich[2+1] = "UL";

  1302. 

  1303.     /* System generated locals */

  1304.     integer a_dim1, a_offset, i__1, i__2, i__3, i__4, i__5, i__6, i__7, i__8;

  1305. 

  1306.     /* Local variables */

  1307.     static real beta;

  1308.     static integer ldas;

  1309.     static logical same;

  1310.     static integer incx, incy;

  1311.     static logical full, null;

  1312.     static char uplo[1];

  1313.     static integer i__, k, n;

  1314.     static real alpha;

  1315.     static logical isame[13];

  1316.     extern /* Subroutine */ int smake_(char*, char*, char*, integer*, integer*, real*, integer*, real*, integer*, integer*, integer*, logical*, real*, ftnlen, ftnlen, ftnlen);

  1317.     static integer nargs;

  1318.     extern /* Subroutine */ int smvch_(char*, integer*, integer*, real*, real*, integer*, real*, integer*, real*, real*, integer*, real*, real*, real*, real*, real*, logical*, integer*, logical*, ftnlen);

  1319.     static logical reset;

  1320.     static char cuplo[14];

  1321.     static integer incxs, incys;

  1322.     static char uplos[1];

  1323.     static integer ia, ib, ic;

  1324.     static logical banded;

  1325.     static integer nc, ik, in;

  1326.     static logical packed;

  1327.     static integer nk, ks, ix, iy, ns, lx, ly;

  1328.     static real errmax;

  1329.     extern logical lseres_(char* , char*, integer*, integer*, real*, real*, integer*, ftnlen, ftnlen);

  1330.     extern /* Subroutine */ void cssbmv_(integer*, char*, integer*, integer*, real*, real*, integer*, real*, integer*, real*, real*, integer*, ftnlen);

  1331.     static real transl;

  1332.     extern /* Subroutine */ void csspmv_(integer*, char*, integer*, real*, real*, real*, integer*, real*, real*, integer*, ftnlen);

  1333.     extern /* Subroutine */ void cssymv_(integer*, char*, integer*, real*, real*, integer*, real*, integer*, real*, real*, integer*, ftnlen);

  1334.     static integer laa, lda;

  1335.     static real als, bls;

  1336.     extern logical lse_(real*, real*, integer*);

  1337.     static real err;

  1338. 

  1339. /*  Tests SSYMV, SSBMV and SSPMV. */

  1340. 

  1341. /*  Auxiliary routine for test program for Level 2 Blas. */

  1342. 

  1343. /*  -- Written on 10-August-1987. */

  1344. /*     Richard Hanson, Sandia National Labs. */

  1345. /*     Jeremy Du Croz, NAG Central Office. */

  1346. 

  1347. /*     .. Parameters .. */

  1348. /*     .. Scalar Arguments .. */

  1349. /*     .. Array Arguments .. */

  1350. /*     .. Local Scalars .. */

  1351. /*     .. Local Arrays .. */

  1352. /*     .. External Functions .. */

  1353. /*     .. External Subroutines .. */

  1354. /*     .. Intrinsic Functions .. */

  1355. /*     .. Scalars in Common .. */

  1356. /*     .. Common blocks .. */

  1357. /*     .. Data statements .. */

  1358.     /* Parameter adjustments */

  1359.     --idim;

  1360.     --kb;

  1361.     --alf;

  1362.     --bet;

  1363.     --inc;

  1364.     --g;

  1365.     --yt;

  1366.     --y;

  1367.     --x;

  1368.     --as;

  1369.     --aa;

  1370.     a_dim1 = *nmax;

  1371.     a_offset = 1 + a_dim1 * 1;

  1372.     a -= a_offset;

  1373.     --ys;

  1374.     --yy;

  1375.     --xs;

  1376.     --xx;

  1377. 

  1378.     /* Function Body */

  1379. /*     .. Executable Statements .. */

  1380.     full = *(unsigned char *)&sname[8] == 'y';

  1381.     banded = *(unsigned char *)&sname[8] == 'b';

  1382.     packed = *(unsigned char *)&sname[8] == 'p';

  1383. /*     Define the number of arguments. */

  1384.     if (full) {

  1385. 	nargs = 10;

  1386.     } else if (banded) {

  1387. 	nargs = 11;

  1388.     } else if (packed) {

  1389. 	nargs = 9;

  1390.     }

  1391. 

  1392.     nc = 0;

  1393.     reset = TRUE_;

  1394.     errmax = (float)0.;

  1395. 

  1396.     i__1 = *nidim;

  1397.     for (in = 1; in <= i__1; ++in) {

  1398. 	n = idim[in];

  1399. 

  1400. 	if (banded) {

  1401. 	    nk = *nkb;

  1402. 	} else {

  1403. 	    nk = 1;

  1404. 	}

  1405. 	i__2 = nk;

  1406. 	for (ik = 1; ik <= i__2; ++ik) {

  1407. 	    if (banded) {

  1408. 		k = kb[ik];

  1409. 	    } else {

  1410. 		k = n - 1;

  1411. 	    }

  1412. /*           Set LDA to 1 more than minimum value if room. */

  1413. 	    if (banded) {

  1414. 		lda = k + 1;

  1415. 	    } else {

  1416. 		lda = n;

  1417. 	    }

  1418. 	    if (lda < *nmax) {

  1419. 		++lda;

  1420. 	    }

  1421. /*           Skip tests if not enough room. */

  1422. 	    if (lda > *nmax) {

  1423. 		goto L100;

  1424. 	    }

  1425. 	    if (packed) {

  1426. 		laa = n * (n + 1) / 2;

  1427. 	    } else {

  1428. 		laa = lda * n;

  1429. 	    }

  1430. 	    null = n <= 0;

  1431. 

  1432. 	    for (ic = 1; ic <= 2; ++ic) {

  1433. 		*(unsigned char *)uplo = *(unsigned char *)&ich[ic - 1];

  1434. 		if (*(unsigned char *)uplo == 'U') {

  1435. 		    s_copy(cuplo, "    CblasUpper", (ftnlen)14, (ftnlen)14);

  1436. 		} else {

  1437. 		    s_copy(cuplo, "    CblasLower", (ftnlen)14, (ftnlen)14);

  1438. 		}

  1439. 

  1440. /*              Generate the matrix A. */

  1441. 

  1442. 		transl = (float)0.;

  1443. 		smake_(sname + 7, uplo, " ", &n, &n, &a[a_offset], nmax, &aa[

  1444. 			1], &lda, &k, &k, &reset, &transl, (ftnlen)2, (ftnlen)

  1445. 			1, (ftnlen)1);

  1446. 

  1447. 		i__3 = *ninc;

  1448. 		for (ix = 1; ix <= i__3; ++ix) {

  1449. 		    incx = inc[ix];

  1450. 		    lx = abs(incx) * n;

  1451. 

  1452. /*                 Generate the vector X. */

  1453. 

  1454. 		    transl = (float).5;

  1455. 		    i__4 = abs(incx);

  1456. 		    i__5 = n - 1;

  1457. 		    smake_("ge", " ", " ", &c__1, &n, &x[1], &c__1, &xx[1], &

  1458. 			    i__4, &c__0, &i__5, &reset, &transl, (ftnlen)2, (

  1459. 			    ftnlen)1, (ftnlen)1);

  1460. 		    if (n > 1) {

  1461. 			x[n / 2] = (float)0.;

  1462. 			xx[abs(incx) * (n / 2 - 1) + 1] = (float)0.;

  1463. 		    }

  1464. 

  1465. 		    i__4 = *ninc;

  1466. 		    for (iy = 1; iy <= i__4; ++iy) {

  1467. 			incy = inc[iy];

  1468. 			ly = abs(incy) * n;

  1469. 

  1470. 			i__5 = *nalf;

  1471. 			for (ia = 1; ia <= i__5; ++ia) {

  1472. 			    alpha = alf[ia];

  1473. 

  1474. 			    i__6 = *nbet;

  1475. 			    for (ib = 1; ib <= i__6; ++ib) {

  1476. 				beta = bet[ib];

  1477. 

  1478. /*                          Generate the vector Y. */

  1479. 

  1480. 				transl = (float)0.;

  1481. 				i__7 = abs(incy);

  1482. 				i__8 = n - 1;

  1483. 				smake_("ge", " ", " ", &c__1, &n, &y[1], &

  1484. 					c__1, &yy[1], &i__7, &c__0, &i__8, &

  1485. 					reset, &transl, (ftnlen)2, (ftnlen)1, 

  1486. 					(ftnlen)1);

  1487. 

  1488. 				++nc;

  1489. 

  1490. /*                          Save every datum before calling the */

  1491. /*                          subroutine. */

  1492. 

  1493. 				*(unsigned char *)uplos = *(unsigned char *)

  1494. 					uplo;

  1495. 				ns = n;

  1496. 				ks = k;

  1497. 				als = alpha;

  1498. 				i__7 = laa;

  1499. 				for (i__ = 1; i__ <= i__7; ++i__) {

  1500. 				    as[i__] = aa[i__];

  1501. /* L10: */

  1502. 				}

  1503. 				ldas = lda;

  1504. 				i__7 = lx;

  1505. 				for (i__ = 1; i__ <= i__7; ++i__) {

  1506. 				    xs[i__] = xx[i__];

  1507. /* L20: */

  1508. 				}

  1509. 				incxs = incx;

  1510. 				bls = beta;

  1511. 				i__7 = ly;

  1512. 				for (i__ = 1; i__ <= i__7; ++i__) {

  1513. 				    ys[i__] = yy[i__];

  1514. /* L30: */

  1515. 				}

  1516. 				incys = incy;

  1517. 

  1518. /*                          Call the subroutine. */

  1519. 

  1520. 				if (full) {

  1521. 				    if (*trace) {

  1522. /*

  1523. 					sprintf(ntra,"%6d: %12s (%14s, %3d, %4.1f, A %3d, X %2d, %4.1f Y %2d )..\n",

  1524. 					nc,sname,cuplo,n,alpha,lda,incx,beta,incy);

  1525. */

  1526. 				    }

  1527. 				    if (*rewi) {

  1528. /*					al__1.aerr = 0;

  1529. 					al__1.aunit = *ntra;

  1530. 					f_rew(&al__1);*/

  1531. 				    }

  1532. 				    cssymv_(iorder, uplo, &n, &alpha, &aa[1], 

  1533. 					    &lda, &xx[1], &incx, &beta, &yy[1]

  1534. 					    , &incy, (ftnlen)1);

  1535. 				} else if (banded) {

  1536. 				    if (*trace) {

  1537. /*

  1538. 					sprintf(ntra,"%6d: %12s (%14s %3d, %3d, %4.1f, A %3d, X %2d, %4.1f, Y, %2d ).\n",

  1539. 					nc,sname,cuplo,n,k,alpha,lda,incx,beta,incy);

  1540. */

  1541. 				    }

  1542. 				    if (*rewi) {

  1543. /*					al__1.aerr = 0;

  1544. 					al__1.aunit = *ntra;

  1545. 					f_rew(&al__1);*/

  1546. 				    }

  1547. 				    cssbmv_(iorder, uplo, &n, &k, &alpha, &aa[

  1548. 					    1], &lda, &xx[1], &incx, &beta, &

  1549. 					    yy[1], &incy, (ftnlen)1);

  1550. 				} else if (packed) {

  1551. 				    if (*trace) {

  1552. /*

  1553. 					sprintf(ntra,"%6d: %12s ( %14s %3d, %4.1f, AP  X %2d, %4.1f, Y, %2d ).\n",

  1554. 					nc,sname,cuplo,n,alpha,incx,beta,incy);

  1555. */

  1556. 				    }

  1557. 				    if (*rewi) {

  1558. /*					al__1.aerr = 0;

  1559. 					al__1.aunit = *ntra;

  1560. 					f_rew(&al__1);*/

  1561. 				    }

  1562. 				    csspmv_(iorder, uplo, &n, &alpha, &aa[1], 

  1563. 					    &xx[1], &incx, &beta, &yy[1], &

  1564. 					    incy, (ftnlen)1);

  1565. 				}

  1566. 

  1567. /*                          Check if error-exit was taken incorrectly. */

  1568. 

  1569. 				if (! infoc_1.ok) {

  1570. 				    printf(" ******* FATAL ERROR - ERROR-EXIT TAKEN ON VALID CALL *******n");

  1571. 				    *fatal = TRUE_;

  1572. 				    goto L120;

  1573. 				}

  1574. 

  1575. /*                          See what data changed inside subroutines. */

  1576. 

  1577. 				isame[0] = *(unsigned char *)uplo == *(

  1578. 					unsigned char *)uplos;

  1579. 				isame[1] = ns == n;

  1580. 				if (full) {

  1581. 				    isame[2] = als == alpha;

  1582. 				    isame[3] = lse_(&as[1], &aa[1], &laa);

  1583. 				    isame[4] = ldas == lda;

  1584. 				    isame[5] = lse_(&xs[1], &xx[1], &lx);

  1585. 				    isame[6] = incxs == incx;

  1586. 				    isame[7] = bls == beta;

  1587. 				    if (null) {

  1588. 					isame[8] = lse_(&ys[1], &yy[1], &ly);

  1589. 				    } else {

  1590. 					i__7 = abs(incy);

  1591. 					isame[8] = lseres_("ge", " ", &c__1, &

  1592. 						n, &ys[1], &yy[1], &i__7, (

  1593. 						ftnlen)2, (ftnlen)1);

  1594. 				    }

  1595. 				    isame[9] = incys == incy;

  1596. 				} else if (banded) {

  1597. 				    isame[2] = ks == k;

  1598. 				    isame[3] = als == alpha;

  1599. 				    isame[4] = lse_(&as[1], &aa[1], &laa);

  1600. 				    isame[5] = ldas == lda;

  1601. 				    isame[6] = lse_(&xs[1], &xx[1], &lx);

  1602. 				    isame[7] = incxs == incx;

  1603. 				    isame[8] = bls == beta;

  1604. 				    if (null) {

  1605. 					isame[9] = lse_(&ys[1], &yy[1], &ly);

  1606. 				    } else {

  1607. 					i__7 = abs(incy);

  1608. 					isame[9] = lseres_("ge", " ", &c__1, &

  1609. 						n, &ys[1], &yy[1], &i__7, (

  1610. 						ftnlen)2, (ftnlen)1);

  1611. 				    }

  1612. 				    isame[10] = incys == incy;

  1613. 				} else if (packed) {

  1614. 				    isame[2] = als == alpha;

  1615. 				    isame[3] = lse_(&as[1], &aa[1], &laa);

  1616. 				    isame[4] = lse_(&xs[1], &xx[1], &lx);

  1617. 				    isame[5] = incxs == incx;

  1618. 				    isame[6] = bls == beta;

  1619. 				    if (null) {

  1620. 					isame[7] = lse_(&ys[1], &yy[1], &ly);

  1621. 				    } else {

  1622. 					i__7 = abs(incy);

  1623. 					isame[7] = lseres_("ge", " ", &c__1, &

  1624. 						n, &ys[1], &yy[1], &i__7, (

  1625. 						ftnlen)2, (ftnlen)1);

  1626. 				    }

  1627. 				    isame[8] = incys == incy;

  1628. 				}

  1629. 

  1630. /*                          If data was incorrectly changed, report and */

  1631. /*                          return. */

  1632. 

  1633. 				same = TRUE_;

  1634. 				i__7 = nargs;

  1635. 				for (i__ = 1; i__ <= i__7; ++i__) {

  1636. 				    same = same && isame[i__ - 1];

  1637. 				    if (! isame[i__ - 1]) {

  1638. 					printf(" ******* FATAL ERROR - PARAMETER NUMBER %2d WAS CHANGED INCORRECTLY *******\n",i__);

  1639. 				    }

  1640. /* L40: */

  1641. 				}

  1642. 				if (! same) {

  1643. 				    *fatal = TRUE_;

  1644. 				    goto L120;

  1645. 				}

  1646. 

  1647. 				if (! null) {

  1648. 

  1649. /*                             Check the result. */

  1650. 

  1651. 				    smvch_("N", &n, &n, &alpha, &a[a_offset], 

  1652. 					    nmax, &x[1], &incx, &beta, &y[1], 

  1653. 					    &incy, &yt[1], &g[1], &yy[1], eps,

  1654. 					     &err, fatal, nout, &c_true, (

  1655. 					    ftnlen)1);

  1656. 				    errmax = dmax(errmax,err);

  1657. /*                             If got really bad answer, report and */

  1658. /*                             return. */

  1659. 				    if (*fatal) {

  1660. 					goto L120;

  1661. 				    }

  1662. 				} else {

  1663. /*                             Avoid repeating tests with N.le.0 */

  1664. 				    goto L110;

  1665. 				}

  1666. 

  1667. /* L50: */

  1668. 			    }

  1669. 

  1670. /* L60: */

  1671. 			}

  1672. 

  1673. /* L70: */

  1674. 		    }

  1675. 

  1676. /* L80: */

  1677. 		}

  1678. 

  1679. /* L90: */

  1680. 	    }

  1681. 

  1682. L100:

  1683. 	    ;

  1684. 	}

  1685. 

  1686. L110:

  1687. 	;

  1688.     }

  1689. 

  1690. /*     Report result. */

  1691. 

  1692.     if (errmax < *thresh) {

  1693. 	if (*iorder == 0) {

  1694. 	    printf("%12s PASSED THE COLUMN-MAJOR COMPUTATIONAL TESTS (%6d CALLS)\n",sname,nc);

  1695. 	}

  1696. 	if (*iorder == 1) {

  1697. 	    printf("%12s PASSED THE ROW-MAJOR COMPUTATIONAL TESTS (%6d CALLS)\n",sname,nc);

  1698. 	}

  1699.     } else {

  1700. 	if (*iorder == 0) {

  1701. 	    printf("%12s COMPLETED THE COLUMN-MAJOR COMPUTATIONAL TESTS (%6d CALLS) ******* BUT WITH MAXIMUM TEST RATIO %8.2f - SUSPECT *******\n",sname,nc,errmax);;

  1702. 	}

  1703. 	if (*iorder == 1) {

  1704. 	    printf("%12s COMPLETED THE ROW-MAJOR COMPUTATIONAL TESTS (%6d CALLS) ******* BUT WITH MAXIMUM TEST RATIO %8.2f - SUSPECT *******\n",sname,nc,errmax);;

  1705. 	}

  1706.     }

  1707.     goto L130;

  1708. 

  1709. L120:

  1710.     printf("******* %12s FAILED ON CALL NUMBER:",sname);

  1711. 

  1712.     if (full) {

  1713. 	printf("%6d: %12s (%14s, %3d, %4.1f, A %3d, X %2d, %4.1f Y %2d )..\n",

  1714. 		nc,sname,cuplo,n,alpha,lda,incx,beta,incy);

  1715.     } else if (banded) {

  1716. 

  1717. 	printf("%6d: %12s (%14s %3d, %3d, %4.1f, A %3d, X %2d, %4.1f, Y, %2d ).\n",

  1718. 		nc,sname,cuplo,n,k,alpha,lda,incx,beta,incy);

  1719.     } else if (packed) {

  1720. 	printf("%6d: %12s ( %14s %3d, %4.1f, AP  X %2d, %4.1f, Y, %2d ).\n",

  1721. 		nc,sname,cuplo,n,alpha,incx,beta,incy);

  1722.     }

  1723. 

  1724. L130:

  1725.     return 0;

  1726. 

  1727. /* 9997 FORMAT( ' ',A12, ' COMPLETED THE COMPUTATIONAL TESTS (', I6, ' C', */

  1728. /*     $      'ALLS)', /' ******* BUT WITH MAXIMUM TEST RATIO', F8.2, */

  1729. /*     $      ' - SUSPECT *******' ) */

  1730. 

  1731. /*     End of SCHK2. */

  1732. 

  1733. } /* schk2_ */

  1734. 

  1735. /* Subroutine */ int schk3_(char* sname, real* eps, real* thresh, integer* nout, integer* ntra, logical* trace, logical* rewi, logical* fatal, integer* nidim, integer* idim, integer* nkb, integer* kb, integer* ninc, integer* inc, integer* nmax, integer* incmax, real* a, real* aa, real* as, real* x, real* xx, real* xs, real* xt, real* g, real* z__, integer* iorder, ftnlen sname_len)

  1736. {

  1737.     /* Initialized data */

  1738. 

  1739.     static char ichu[2+1] = "UL";

  1740.     static char icht[3+1] = "NTC";

  1741.     static char ichd[2+1] = "UN";

  1742. 

  1743.     /* System generated locals */

  1744.     integer a_dim1, a_offset, i__1, i__2, i__3, i__4, i__5;

  1745. 

  1746.     /* Local variables */

  1747.     static char diag[1];

  1748.     static integer ldas;

  1749.     static logical same;

  1750.     static integer incx;

  1751.     static logical full, null;

  1752.     static char uplo[1], cdiag[14];

  1753.     static integer i__, k, n;

  1754.     static char diags[1];

  1755.     static logical isame[13];

  1756.     extern /* Subroutine */ int smake_(char*, char*, char*, integer*, integer*, real*, integer*, real*, integer*, integer*, integer*, logical*, real*, ftnlen, ftnlen, ftnlen);

  1757.     static integer nargs;

  1758.     extern /* Subroutine */ int smvch_(char*, integer*, integer*, real*, real*, integer*, real*, integer*, real*, real*, integer*, real*, real*, real*, real*, real*, logical*, integer*, logical*, ftnlen);

  1759.     static logical reset;

  1760.     static char cuplo[14];

  1761.     static integer incxs;

  1762.     static char trans[1], uplos[1];

  1763.     static logical banded;

  1764.     static integer nc, ik, in;

  1765.     static logical packed;

  1766.     static integer nk, ks, ix, ns, lx;

  1767.     static char ctrans[14];

  1768.     static real errmax;

  1769.     extern logical lseres_(char*, char*, integer*, integer*, real*, real*, integer*, ftnlen, ftnlen);

  1770.     extern /* Subroutine */ void cstbmv_(integer*, char*, char*, char*, integer*, integer*, real*, integer*, real*, integer*, ftnlen, ftnlen, ftnlen);

  1771.     static real transl;

  1772.     extern /* Subroutine */ void cstbsv_(integer*, char*, char*, char*, integer*, integer*, real*, integer*, real*, integer*, ftnlen, ftnlen, ftnlen);

  1773.     static char transs[1];

  1774.     extern /* Subroutine */ void cstpmv_(integer*, char*, char*, char*, integer*, real*, real*, integer*, ftnlen, ftnlen, ftnlen);

  1775.     extern /* Subroutine */ void cstrmv_(integer*, char*, char*, char*, integer*, real*, integer*, real*, integer*, ftnlen, ftnlen, ftnlen);

  1776.     extern /* Subroutine */ void cstpsv_(integer*, char*, char*, char*, integer*, real*, real*, integer*, ftnlen, ftnlen, ftnlen);

  1777.     extern /* Subroutine */ void cstrsv_(integer*, char*, char*, char*, integer*, real*, integer*, real*, integer*, ftnlen, ftnlen, ftnlen);

  1778.     static integer laa, icd, lda, ict, icu;

  1779.     extern logical lse_(real*, real*, integer*);

  1780.     static real err;

  1781. 

  1782. /*  Tests STRMV, STBMV, STPMV, STRSV, STBSV and STPSV. */

  1783. 

  1784. /*  Auxiliary routine for test program for Level 2 Blas. */

  1785. 

  1786. /*  -- Written on 10-August-1987. */

  1787. /*     Richard Hanson, Sandia National Labs. */

  1788. /*     Jeremy Du Croz, NAG Central Office. */

  1789. 

  1790. /*     .. Parameters .. */

  1791. /*     .. Scalar Arguments .. */

  1792. /*     .. Array Arguments .. */

  1793. /*     .. Local Scalars .. */

  1794. /*     .. Local Arrays .. */

  1795. /*     .. External Functions .. */

  1796. /*     .. External Subroutines .. */

  1797. /*     .. Intrinsic Functions .. */

  1798. /*     .. Scalars in Common .. */

  1799. /*     .. Common blocks .. */

  1800. /*     .. Data statements .. */

  1801.     /* Parameter adjustments */

  1802.     --idim;

  1803.     --kb;

  1804.     --inc;

  1805.     --z__;

  1806.     --g;

  1807.     --xt;

  1808.     --x;

  1809.     --as;

  1810.     --aa;

  1811.     a_dim1 = *nmax;

  1812.     a_offset = 1 + a_dim1 * 1;

  1813.     a -= a_offset;

  1814.     --xs;

  1815.     --xx;

  1816. 

  1817.     /* Function Body */

  1818. /*     .. Executable Statements .. */

  1819.     full = *(unsigned char *)&sname[8] == 'r';

  1820.     banded = *(unsigned char *)&sname[8] == 'b';

  1821.     packed = *(unsigned char *)&sname[8] == 'p';

  1822. /*     Define the number of arguments. */

  1823.     if (full) {

  1824. 	nargs = 8;

  1825.     } else if (banded) {

  1826. 	nargs = 9;

  1827.     } else if (packed) {

  1828. 	nargs = 7;

  1829.     }

  1830. 

  1831.     nc = 0;

  1832.     reset = TRUE_;

  1833.     errmax = (float)0.;

  1834. /*     Set up zero vector for SMVCH. */

  1835.     i__1 = *nmax;

  1836.     for (i__ = 1; i__ <= i__1; ++i__) {

  1837. 	z__[i__] = (float)0.;

  1838. /* L10: */

  1839.     }

  1840. 

  1841.     i__1 = *nidim;

  1842.     for (in = 1; in <= i__1; ++in) {

  1843. 	n = idim[in];

  1844. 

  1845. 	if (banded) {

  1846. 	    nk = *nkb;

  1847. 	} else {

  1848. 	    nk = 1;

  1849. 	}

  1850. 	i__2 = nk;

  1851. 	for (ik = 1; ik <= i__2; ++ik) {

  1852. 	    if (banded) {

  1853. 		k = kb[ik];

  1854. 	    } else {

  1855. 		k = n - 1;

  1856. 	    }

  1857. /*           Set LDA to 1 more than minimum value if room. */

  1858. 	    if (banded) {

  1859. 		lda = k + 1;

  1860. 	    } else {

  1861. 		lda = n;

  1862. 	    }

  1863. 	    if (lda < *nmax) {

  1864. 		++lda;

  1865. 	    }

  1866. /*           Skip tests if not enough room. */

  1867. 	    if (lda > *nmax) {

  1868. 		goto L100;

  1869. 	    }

  1870. 	    if (packed) {

  1871. 		laa = n * (n + 1) / 2;

  1872. 	    } else {

  1873. 		laa = lda * n;

  1874. 	    }

  1875. 	    null = n <= 0;

  1876. 

  1877. 	    for (icu = 1; icu <= 2; ++icu) {

  1878. 		*(unsigned char *)uplo = *(unsigned char *)&ichu[icu - 1];

  1879. 		if (*(unsigned char *)uplo == 'U') {

  1880. 		    s_copy(cuplo, "    CblasUpper", (ftnlen)14, (ftnlen)14);

  1881. 		} else {

  1882. 		    s_copy(cuplo, "    CblasLower", (ftnlen)14, (ftnlen)14);

  1883. 		}

  1884. 

  1885. 		for (ict = 1; ict <= 3; ++ict) {

  1886. 		    *(unsigned char *)trans = *(unsigned char *)&icht[ict - 1]

  1887. 			    ;

  1888. 		    if (*(unsigned char *)trans == 'N') {

  1889. 			s_copy(ctrans, "  CblasNoTrans", (ftnlen)14, (ftnlen)

  1890. 				14);

  1891. 		    } else if (*(unsigned char *)trans == 'T') {

  1892. 			s_copy(ctrans, "    CblasTrans", (ftnlen)14, (ftnlen)

  1893. 				14);

  1894. 		    } else {

  1895. 			s_copy(ctrans, "CblasConjTrans", (ftnlen)14, (ftnlen)

  1896. 				14);

  1897. 		    }

  1898. 

  1899. 		    for (icd = 1; icd <= 2; ++icd) {

  1900. 			*(unsigned char *)diag = *(unsigned char *)&ichd[icd 

  1901. 				- 1];

  1902. 			if (*(unsigned char *)diag == 'N') {

  1903. 			    s_copy(cdiag, "  CblasNonUnit", (ftnlen)14, (

  1904. 				    ftnlen)14);

  1905. 			} else {

  1906. 			    s_copy(cdiag, "     CblasUnit", (ftnlen)14, (

  1907. 				    ftnlen)14);

  1908. 			}

  1909. 

  1910. /*                    Generate the matrix A. */

  1911. 

  1912. 			transl = (float)0.;

  1913. 			smake_(sname + 7, uplo, diag, &n, &n, &a[a_offset], 

  1914. 				nmax, &aa[1], &lda, &k, &k, &reset, &transl, (

  1915. 				ftnlen)2, (ftnlen)1, (ftnlen)1);

  1916. 

  1917. 			i__3 = *ninc;

  1918. 			for (ix = 1; ix <= i__3; ++ix) {

  1919. 			    incx = inc[ix];

  1920. 			    lx = abs(incx) * n;

  1921. 

  1922. /*                       Generate the vector X. */

  1923. 

  1924. 			    transl = (float).5;

  1925. 			    i__4 = abs(incx);

  1926. 			    i__5 = n - 1;

  1927. 			    smake_("ge", " ", " ", &c__1, &n, &x[1], &c__1, &

  1928. 				    xx[1], &i__4, &c__0, &i__5, &reset, &

  1929. 				    transl, (ftnlen)2, (ftnlen)1, (ftnlen)1);

  1930. 			    if (n > 1) {

  1931. 				x[n / 2] = (float)0.;

  1932. 				xx[abs(incx) * (n / 2 - 1) + 1] = (float)0.;

  1933. 			    }

  1934. 

  1935. 			    ++nc;

  1936. 

  1937. /*                       Save every datum before calling the subroutine. */

  1938. 

  1939. 			    *(unsigned char *)uplos = *(unsigned char *)uplo;

  1940. 			    *(unsigned char *)transs = *(unsigned char *)

  1941. 				    trans;

  1942. 			    *(unsigned char *)diags = *(unsigned char *)diag;

  1943. 			    ns = n;

  1944. 			    ks = k;

  1945. 			    i__4 = laa;

  1946. 			    for (i__ = 1; i__ <= i__4; ++i__) {

  1947. 				as[i__] = aa[i__];

  1948. /* L20: */

  1949. 			    }

  1950. 			    ldas = lda;

  1951. 			    i__4 = lx;

  1952. 			    for (i__ = 1; i__ <= i__4; ++i__) {

  1953. 				xs[i__] = xx[i__];

  1954. /* L30: */

  1955. 			    }

  1956. 			    incxs = incx;

  1957. 

  1958. /*                       Call the subroutine. */

  1959. 

  1960. 			    if (s_cmp(sname + 9, "mv", (ftnlen)2, (ftnlen)2) 

  1961. 				    == 0) {

  1962. 				if (full) {

  1963. 				    if (*trace) {

  1964. /*

  1965. 				    sprintf(ntra,"%6d: %12s (%14s,%14s,%14s     %3d  ,A,   %3d, X, %2d ).\n",

  1966. 				    nc,sname,cuplo,ctrans,cdiag,n,lda,incx);

  1967. */

  1968. 				    }

  1969. 				    if (*rewi) {

  1970. /*					al__1.aerr = 0;

  1971. 					al__1.aunit = *ntra;

  1972. 					f_rew(&al__1);*/

  1973. 				    }

  1974. 				    cstrmv_(iorder, uplo, trans, diag, &n, &

  1975. 					    aa[1], &lda, &xx[1], &incx, (

  1976. 					    ftnlen)1, (ftnlen)1, (ftnlen)1);

  1977. 				} else if (banded) {

  1978. 				    if (*trace) {

  1979. /*

  1980. 				    sprintf(ntra,"%6d: %12s (%14s,%14s,%14s     %3d, %3d  ,A,   %3d, X, %2d ).\n",

  1981. 				    nc,sname,cuplo,ctrans,cdiag,n,k,lda,incx);

  1982. */

  1983. 				    }

  1984. 				    if (*rewi) {

  1985. /*					al__1.aerr = 0;

  1986. 					al__1.aunit = *ntra;

  1987. 					f_rew(&al__1);*/

  1988. 				    }

  1989. 				    cstbmv_(iorder, uplo, trans, diag, &n, &k,

  1990. 					     &aa[1], &lda, &xx[1], &incx, (

  1991. 					    ftnlen)1, (ftnlen)1, (ftnlen)1);

  1992. 				} else if (packed) {

  1993. 				    if (*trace) {

  1994. /*

  1995. 				    sprintf(ntra,"%6d: %12s (%14s,%14s,%14s     %3d  ,AP,  X, %2d ).\n",

  1996. 				    nc,sname,cuplo,ctrans,cdiag,n,incx);

  1997. */

  1998. 				    }

  1999. 				    if (*rewi) {

  2000. /*					al__1.aerr = 0;

  2001. 					al__1.aunit = *ntra;

  2002. 					f_rew(&al__1);*/

  2003. 				    }

  2004. 				    cstpmv_(iorder, uplo, trans, diag, &n, &

  2005. 					    aa[1], &xx[1], &incx, (ftnlen)1, (

  2006. 					    ftnlen)1, (ftnlen)1);

  2007. 				}

  2008. 			    } else if (s_cmp(sname + 9, "sv", (ftnlen)2, (

  2009. 				    ftnlen)2) == 0) {

  2010. 				if (full) {

  2011. 				    if (*trace) {

  2012. /*

  2013. 				    sprintf(ntra,"%6d: %12s (%14s,%14s,%14s     %3d  ,A,   %3d, X, %2d ).\n",

  2014. 				    nc,sname,cuplo,ctrans,cdiag,n,lda,incx);

  2015. */

  2016. 				    }

  2017. 				    if (*rewi) {

  2018. /*					al__1.aerr = 0;

  2019. 					al__1.aunit = *ntra;

  2020. 					f_rew(&al__1);*/

  2021. 				    }

  2022. 				    cstrsv_(iorder, uplo, trans, diag, &n, &

  2023. 					    aa[1], &lda, &xx[1], &incx, (

  2024. 					    ftnlen)1, (ftnlen)1, (ftnlen)1);

  2025. 				} else if (banded) {

  2026. 				    if (*trace) {

  2027. /*

  2028. 				    sprintf(ntra,"%6d: %12s (%14s,%14s,%14s     %3d, %3d  ,A,   %3d, X, %2d ).\n",

  2029. 				    nc,sname,cuplo,ctrans,cdiag,n,k,lda,incx);

  2030. */

  2031. 				    }

  2032. 				    if (*rewi) {

  2033. /*					al__1.aerr = 0;

  2034. 					al__1.aunit = *ntra;

  2035. 					f_rew(&al__1);*/

  2036. 				    }

  2037. 				    cstbsv_(iorder, uplo, trans, diag, &n, &k,

  2038. 					     &aa[1], &lda, &xx[1], &incx, (

  2039. 					    ftnlen)1, (ftnlen)1, (ftnlen)1);

  2040. 				} else if (packed) {

  2041. 				    if (*trace) {

  2042. /*

  2043. 				    sprintf(ntra,"%6d: %12s (%14s,%14s,%14s     %3d  ,AP,  X, %2d ).\n",

  2044. 				    nc,sname,cuplo,ctrans,cdiag,n,incx);

  2045. */

  2046. 				    }

  2047. 				    if (*rewi) {

  2048. /*					al__1.aerr = 0;

  2049. 					al__1.aunit = *ntra;

  2050. 					f_rew(&al__1);*/

  2051. 				    }

  2052. 				    cstpsv_(iorder, uplo, trans, diag, &n, &

  2053. 					    aa[1], &xx[1], &incx, (ftnlen)1, (

  2054. 					    ftnlen)1, (ftnlen)1);

  2055. 				}

  2056. 			    }

  2057. 

  2058. /*                       Check if error-exit was taken incorrectly. */

  2059. 

  2060. 			    if (! infoc_1.ok) {

  2061. 				printf(" ******* FATAL ERROR - ERROR-EXIT TAKEN ON VALID CALL *******n");

  2062. 				*fatal = TRUE_;

  2063. 				goto L120;

  2064. 			    }

  2065. 

  2066. /*                       See what data changed inside subroutines. */

  2067. 

  2068. 			    isame[0] = *(unsigned char *)uplo == *(unsigned 

  2069. 				    char *)uplos;

  2070. 			    isame[1] = *(unsigned char *)trans == *(unsigned 

  2071. 				    char *)transs;

  2072. 			    isame[2] = *(unsigned char *)diag == *(unsigned 

  2073. 				    char *)diags;

  2074. 			    isame[3] = ns == n;

  2075. 			    if (full) {

  2076. 				isame[4] = lse_(&as[1], &aa[1], &laa);

  2077. 				isame[5] = ldas == lda;

  2078. 				if (null) {

  2079. 				    isame[6] = lse_(&xs[1], &xx[1], &lx);

  2080. 				} else {

  2081. 				    i__4 = abs(incx);

  2082. 				    isame[6] = lseres_("ge", " ", &c__1, &n, &

  2083. 					    xs[1], &xx[1], &i__4, (ftnlen)2, (

  2084. 					    ftnlen)1);

  2085. 				}

  2086. 				isame[7] = incxs == incx;

  2087. 			    } else if (banded) {

  2088. 				isame[4] = ks == k;

  2089. 				isame[5] = lse_(&as[1], &aa[1], &laa);

  2090. 				isame[6] = ldas == lda;

  2091. 				if (null) {

  2092. 				    isame[7] = lse_(&xs[1], &xx[1], &lx);

  2093. 				} else {

  2094. 				    i__4 = abs(incx);

  2095. 				    isame[7] = lseres_("ge", " ", &c__1, &n, &

  2096. 					    xs[1], &xx[1], &i__4, (ftnlen)2, (

  2097. 					    ftnlen)1);

  2098. 				}

  2099. 				isame[8] = incxs == incx;

  2100. 			    } else if (packed) {

  2101. 				isame[4] = lse_(&as[1], &aa[1], &laa);

  2102. 				if (null) {

  2103. 				    isame[5] = lse_(&xs[1], &xx[1], &lx);

  2104. 				} else {

  2105. 				    i__4 = abs(incx);

  2106. 				    isame[5] = lseres_("ge", " ", &c__1, &n, &

  2107. 					    xs[1], &xx[1], &i__4, (ftnlen)2, (

  2108. 					    ftnlen)1);

  2109. 				}

  2110. 				isame[6] = incxs == incx;

  2111. 			    }

  2112. 

  2113. /*                       If data was incorrectly changed, report and */

  2114. /*                       return. */

  2115. 

  2116. 			    same = TRUE_;

  2117. 			    i__4 = nargs;

  2118. 			    for (i__ = 1; i__ <= i__4; ++i__) {

  2119. 				same = same && isame[i__ - 1];

  2120. 				if (! isame[i__ - 1]) {

  2121. 				    printf(" ******* FATAL ERROR - PARAMETER NUMBER %2d WAS CHANGED INCORRECTLY *******\n",i__);

  2122. 				}

  2123. /* L40: */

  2124. 			    }

  2125. 			    if (! same) {

  2126. 				*fatal = TRUE_;

  2127. 				goto L120;

  2128. 			    }

  2129. 

  2130. 			    if (! null) {

  2131. 				if (s_cmp(sname + 9, "mv", (ftnlen)2, (ftnlen)

  2132. 					2) == 0) {

  2133. 

  2134. /*                             Check the result. */

  2135. 

  2136. 				    smvch_(trans, &n, &n, &c_b123, &a[

  2137. 					    a_offset], nmax, &x[1], &incx, &

  2138. 					    c_b135, &z__[1], &incx, &xt[1], &

  2139. 					    g[1], &xx[1], eps, &err, fatal, 

  2140. 					    nout, &c_true, (ftnlen)1);

  2141. 				} else if (s_cmp(sname + 9, "sv", (ftnlen)2, (

  2142. 					ftnlen)2) == 0) {

  2143. 

  2144. /*                             Compute approximation to original vector. */

  2145. 

  2146. 				    i__4 = n;

  2147. 				    for (i__ = 1; i__ <= i__4; ++i__) {

  2148. 					z__[i__] = xx[(i__ - 1) * abs(incx) + 

  2149. 						1];

  2150. 					xx[(i__ - 1) * abs(incx) + 1] = x[i__]

  2151. 						;

  2152. /* L50: */

  2153. 				    }

  2154. 				    smvch_(trans, &n, &n, &c_b123, &a[

  2155. 					    a_offset], nmax, &z__[1], &incx, &

  2156. 					    c_b135, &x[1], &incx, &xt[1], &g[

  2157. 					    1], &xx[1], eps, &err, fatal, 

  2158. 					    nout, &c_false, (ftnlen)1);

  2159. 				}

  2160. 				errmax = dmax(errmax,err);

  2161. /*                          If got really bad answer, report and return. */

  2162. 				if (*fatal) {

  2163. 				    goto L120;

  2164. 				}

  2165. 			    } else {

  2166. /*                          Avoid repeating tests with N.le.0. */

  2167. 				goto L110;

  2168. 			    }

  2169. 

  2170. /* L60: */

  2171. 			}

  2172. 

  2173. /* L70: */

  2174. 		    }

  2175. 

  2176. /* L80: */

  2177. 		}

  2178. 

  2179. /* L90: */

  2180. 	    }

  2181. 

  2182. L100:

  2183. 	    ;

  2184. 	}

  2185. 

  2186. L110:

  2187. 	;

  2188.     }

  2189. 

  2190. /*     Report result. */

  2191. 

  2192.     if (errmax < *thresh) {

  2193. 	if (*iorder == 0) {

  2194. 	    printf("%12s PASSED THE COLUMN-MAJOR COMPUTATIONAL TESTS (%6d CALLS)\n",sname,nc);

  2195. 	}

  2196. 	if (*iorder == 1) {

  2197. 	    printf("%12s PASSED THE ROW-MAJOR COMPUTATIONAL TESTS (%6d CALLS)\n",sname,nc);

  2198. 	}

  2199.     } else {

  2200. 	if (*iorder == 0) {

  2201. 	    printf("%12s COMPLETED THE COLUMN-MAJOR COMPUTATIONAL TESTS (%6d CALLS) ******* BUT WITH MAXIMUM TEST RATIO %8.2f - SUSPECT *******\n",sname,nc,errmax);;

  2202. 	}

  2203. 	if (*iorder == 1) {

  2204. 	    printf("%12s COMPLETED THE ROW-MAJOR COMPUTATIONAL TESTS (%6d CALLS) ******* BUT WITH MAXIMUM TEST RATIO %8.2f - SUSPECT *******\n",sname,nc,errmax);;

  2205. 	}

  2206.     }

  2207.     goto L130;

  2208. 

  2209. L120:

  2210.     printf("******* %12s FAILED ON CALL NUMBER:",sname);

  2211.     if (full) {

  2212. 	printf("%6d: %12s (%14s,%14s,%14s     %3d  ,A,   %3d, X, %2d ).\n",

  2213. 	nc,sname,cuplo,ctrans,cdiag,n,lda,incx);

  2214.     } else if (banded) {

  2215. 	printf("%6d: %12s (%14s,%14s,%14s     %3d, %3d  ,A,   %3d, X, %2d ).\n",

  2216. 	nc,sname,cuplo,ctrans,cdiag,n,k,lda,incx);

  2217.     } else if (packed) {

  2218. 	printf("%6d: %12s (%14s,%14s,%14s     %3d  ,AP,  X, %2d ).\n",

  2219. 	nc,sname,cuplo,ctrans,cdiag,n,incx);

  2220.     }

  2221. 

  2222. L130:

  2223.     return 0;

  2224. 

  2225. /* 9997 FORMAT( ' ',A12, ' COMPLETED THE COMPUTATIONAL TESTS (', I6, ' C', */

  2226. /*     $      'ALLS)', /' ******* BUT WITH MAXIMUM TEST RATIO', F8.2, */

  2227. /*     $      ' - SUSPECT *******' ) */

  2228. 

  2229. /*     End of SCHK3. */

  2230. 

  2231. } /* schk3_ */

  2232. 

  2233. /* Subroutine */ int schk4_(char* sname, real* eps, real* thresh, integer* nout, integer* ntra, logical* trace, logical* rewi, logical* fatal, integer* nidim, integer* idim, integer* nalf, real* alf, integer* ninc, integer* inc, integer* nmax, integer* incmax, real* a, real* aa, real* as, real* x, real* xx, real* xs, real* y, real* yy, real* ys, real* yt, real* g, real* z__, integer* iorder, ftnlen sname_len)

  2234. {

  2235.     /* System generated locals */

  2236.     integer a_dim1, a_offset, i__1, i__2, i__3, i__4, i__5, i__6;

  2237. 

  2238.     /* Local variables */

  2239.     static integer ldas;

  2240.     static logical same;

  2241.     static integer incx, incy;

  2242.     static logical null;

  2243.     static integer i__, j, m, n;

  2244.     static real alpha, w[1];

  2245.     static logical isame[13];

  2246. /* Subroutine */ int smake_(char*, char*, char*, integer*, integer*, real*, integer*, real*, integer*, integer*, integer*, logical*, real*, ftnlen, ftnlen, ftnlen);

  2247.     extern /* Subroutine */ void csger_(integer*, integer*, integer*, real*, real*, integer*, real*, integer*, real*, integer*);

  2248.     static integer nargs;

  2249.     extern /* Subroutine */ int smvch_(char*, integer*, integer*, real*, real*, integer*, real*, integer*, real*, real*, integer*, real*, real*, real*, real*, real*, logical*, integer*, logical*, ftnlen);

  2250.     static logical reset;

  2251.     static integer incxs, incys, ia, nc, nd, im, in, ms, ix, iy, ns, lx, ly;

  2252.     static real errmax;

  2253.     extern logical lseres_(char* , char*, integer*, integer*, real*, real*, integer*, ftnlen, ftnlen);

  2254.     static real transl;

  2255.     static integer laa, lda;

  2256.     static real als;

  2257.     extern logical lse_(real*, real*, integer*);

  2258.     static real err;

  2259. 

  2260. /*  Tests SGER. */

  2261. 

  2262. /*  Auxiliary routine for test program for Level 2 Blas. */

  2263. 

  2264. /*  -- Written on 10-August-1987. */

  2265. /*     Richard Hanson, Sandia National Labs. */

  2266. /*     Jeremy Du Croz, NAG Central Office. */

  2267. 

  2268. /*     .. Parameters .. */

  2269. /*     .. Scalar Arguments .. */

  2270. /*     .. Array Arguments .. */

  2271. /*     .. Local Scalars .. */

  2272. /*     .. Local Arrays .. */

  2273. /*     .. External Functions .. */

  2274. /*     .. External Subroutines .. */

  2275. /*     .. Intrinsic Functions .. */

  2276. /*     .. Scalars in Common .. */

  2277. /*     .. Common blocks .. */

  2278. /*     .. Executable Statements .. */

  2279. /*     Define the number of arguments. */

  2280.     /* Parameter adjustments */

  2281.     --idim;

  2282.     --alf;

  2283.     --inc;

  2284.     --z__;

  2285.     --g;

  2286.     --yt;

  2287.     --y;

  2288.     --x;

  2289.     --as;

  2290.     --aa;

  2291.     a_dim1 = *nmax;

  2292.     a_offset = 1 + a_dim1 * 1;

  2293.     a -= a_offset;

  2294.     --ys;

  2295.     --yy;

  2296.     --xs;

  2297.     --xx;

  2298. 

  2299.     /* Function Body */

  2300.     nargs = 9;

  2301. 

  2302.     nc = 0;

  2303.     reset = TRUE_;

  2304.     errmax = (float)0.;

  2305. 

  2306.     i__1 = *nidim;

  2307.     for (in = 1; in <= i__1; ++in) {

  2308. 	n = idim[in];

  2309. 	nd = n / 2 + 1;

  2310. 

  2311. 	for (im = 1; im <= 2; ++im) {

  2312. 	    if (im == 1) {

  2313. /* Computing MAX */

  2314. 		i__2 = n - nd;

  2315. 		m = f2cmax(i__2,0);

  2316. 	    }

  2317. 	    if (im == 2) {

  2318. /* Computing MIN */

  2319. 		i__2 = n + nd;

  2320. 		m = f2cmin(i__2,*nmax);

  2321. 	    }

  2322. 

  2323. /*           Set LDA to 1 more than minimum value if room. */

  2324. 	    lda = m;

  2325. 	    if (lda < *nmax) {

  2326. 		++lda;

  2327. 	    }

  2328. /*           Skip tests if not enough room. */

  2329. 	    if (lda > *nmax) {

  2330. 		goto L110;

  2331. 	    }

  2332. 	    laa = lda * n;

  2333. 	    null = n <= 0 || m <= 0;

  2334. 

  2335. 	    i__2 = *ninc;

  2336. 	    for (ix = 1; ix <= i__2; ++ix) {

  2337. 		incx = inc[ix];

  2338. 		lx = abs(incx) * m;

  2339. 

  2340. /*              Generate the vector X. */

  2341. 

  2342. 		transl = (float).5;

  2343. 		i__3 = abs(incx);

  2344. 		i__4 = m - 1;

  2345. 		smake_("ge", " ", " ", &c__1, &m, &x[1], &c__1, &xx[1], &i__3,

  2346. 			 &c__0, &i__4, &reset, &transl, (ftnlen)2, (ftnlen)1, 

  2347. 			(ftnlen)1);

  2348. 		if (m > 1) {

  2349. 		    x[m / 2] = (float)0.;

  2350. 		    xx[abs(incx) * (m / 2 - 1) + 1] = (float)0.;

  2351. 		}

  2352. 

  2353. 		i__3 = *ninc;

  2354. 		for (iy = 1; iy <= i__3; ++iy) {

  2355. 		    incy = inc[iy];

  2356. 		    ly = abs(incy) * n;

  2357. 

  2358. /*                 Generate the vector Y. */

  2359. 

  2360. 		    transl = (float)0.;

  2361. 		    i__4 = abs(incy);

  2362. 		    i__5 = n - 1;

  2363. 		    smake_("ge", " ", " ", &c__1, &n, &y[1], &c__1, &yy[1], &

  2364. 			    i__4, &c__0, &i__5, &reset, &transl, (ftnlen)2, (

  2365. 			    ftnlen)1, (ftnlen)1);

  2366. 		    if (n > 1) {

  2367. 			y[n / 2] = (float)0.;

  2368. 			yy[abs(incy) * (n / 2 - 1) + 1] = (float)0.;

  2369. 		    }

  2370. 

  2371. 		    i__4 = *nalf;

  2372. 		    for (ia = 1; ia <= i__4; ++ia) {

  2373. 			alpha = alf[ia];

  2374. 

  2375. /*                    Generate the matrix A. */

  2376. 

  2377. 			transl = (float)0.;

  2378. 			i__5 = m - 1;

  2379. 			i__6 = n - 1;

  2380. 			smake_(sname + 7, " ", " ", &m, &n, &a[a_offset], 

  2381. 				nmax, &aa[1], &lda, &i__5, &i__6, &reset, &

  2382. 				transl, (ftnlen)2, (ftnlen)1, (ftnlen)1);

  2383. 

  2384. 			++nc;

  2385. 

  2386. /*                    Save every datum before calling the subroutine. */

  2387. 

  2388. 			ms = m;

  2389. 			ns = n;

  2390. 			als = alpha;

  2391. 			i__5 = laa;

  2392. 			for (i__ = 1; i__ <= i__5; ++i__) {

  2393. 			    as[i__] = aa[i__];

  2394. /* L10: */

  2395. 			}

  2396. 			ldas = lda;

  2397. 			i__5 = lx;

  2398. 			for (i__ = 1; i__ <= i__5; ++i__) {

  2399. 			    xs[i__] = xx[i__];

  2400. /* L20: */

  2401. 			}

  2402. 			incxs = incx;

  2403. 			i__5 = ly;

  2404. 			for (i__ = 1; i__ <= i__5; ++i__) {

  2405. 			    ys[i__] = yy[i__];

  2406. /* L30: */

  2407. 			}

  2408. 			incys = incy;

  2409. 

  2410. /*                    Call the subroutine. */

  2411. 

  2412. 			if (*trace) {

  2413. /*

  2414. 			    sprintf(ntra,"%6d: %12s (%3d, %3d) %4.1f, X, %2d, Y, %2d, A, %3d).\n",

  2415. 			    nc,sname,m,n,alpha,incx,incy,lda);

  2416. */			

  2417. 			}

  2418. 			if (*rewi) {

  2419. /*			    al__1.aerr = 0;

  2420. 			    al__1.aunit = *ntra;

  2421. 			    f_rew(&al__1);*/

  2422. 			}

  2423. 			csger_(iorder, &m, &n, &alpha, &xx[1], &incx, &yy[1], 

  2424. 				&incy, &aa[1], &lda);

  2425. 

  2426. /*                    Check if error-exit was taken incorrectly. */

  2427. 

  2428. 			if (! infoc_1.ok) {

  2429. 			    printf(" ******* FATAL ERROR - ERROR-EXIT TAKEN ON VALID CALL *******n");

  2430. 			    *fatal = TRUE_;

  2431. 			    goto L140;

  2432. 			}

  2433. 

  2434. /*                    See what data changed inside subroutine. */

  2435. 

  2436. 			isame[0] = ms == m;

  2437. 			isame[1] = ns == n;

  2438. 			isame[2] = als == alpha;

  2439. 			isame[3] = lse_(&xs[1], &xx[1], &lx);

  2440. 			isame[4] = incxs == incx;

  2441. 			isame[5] = lse_(&ys[1], &yy[1], &ly);

  2442. 			isame[6] = incys == incy;

  2443. 			if (null) {

  2444. 			    isame[7] = lse_(&as[1], &aa[1], &laa);

  2445. 			} else {

  2446. 			    isame[7] = lseres_("ge", " ", &m, &n, &as[1], &aa[

  2447. 				    1], &lda, (ftnlen)2, (ftnlen)1);

  2448. 			}

  2449. 			isame[8] = ldas == lda;

  2450. 

  2451. /*                    If data was incorrectly changed, report and return. */

  2452. 

  2453. 			same = TRUE_;

  2454. 			i__5 = nargs;

  2455. 			for (i__ = 1; i__ <= i__5; ++i__) {

  2456. 			    same = same && isame[i__ - 1];

  2457. 			    if (! isame[i__ - 1]) {

  2458. 				printf(" ******* FATAL ERROR - PARAMETER NUMBER %2d WAS CHANGED INCORRECTLY *******\n",i__);

  2459. 			    }

  2460. /* L40: */

  2461. 			}

  2462. 			if (! same) {

  2463. 			    *fatal = TRUE_;

  2464. 			    goto L140;

  2465. 			}

  2466. 

  2467. 			if (! null) {

  2468. 

  2469. /*                       Check the result column by column. */

  2470. 

  2471. 			    if (incx > 0) {

  2472. 				i__5 = m;

  2473. 				for (i__ = 1; i__ <= i__5; ++i__) {

  2474. 				    z__[i__] = x[i__];

  2475. /* L50: */

  2476. 				}

  2477. 			    } else {

  2478. 				i__5 = m;

  2479. 				for (i__ = 1; i__ <= i__5; ++i__) {

  2480. 				    z__[i__] = x[m - i__ + 1];

  2481. /* L60: */

  2482. 				}

  2483. 			    }

  2484. 			    i__5 = n;

  2485. 			    for (j = 1; j <= i__5; ++j) {

  2486. 				if (incy > 0) {

  2487. 				    w[0] = y[j];

  2488. 				} else {

  2489. 				    w[0] = y[n - j + 1];

  2490. 				}

  2491. 				smvch_("N", &m, &c__1, &alpha, &z__[1], nmax, 

  2492. 					w, &c__1, &c_b123, &a[j * a_dim1 + 1],

  2493. 					 &c__1, &yt[1], &g[1], &aa[(j - 1) * 

  2494. 					lda + 1], eps, &err, fatal, nout, &

  2495. 					c_true, (ftnlen)1);

  2496. 				errmax = dmax(errmax,err);

  2497. /*                          If got really bad answer, report and return. */

  2498. 				if (*fatal) {

  2499. 				    goto L130;

  2500. 				}

  2501. /* L70: */

  2502. 			    }

  2503. 			} else {

  2504. /*                       Avoid repeating tests with M.le.0 or N.le.0. */

  2505. 			    goto L110;

  2506. 			}

  2507. 

  2508. /* L80: */

  2509. 		    }

  2510. 

  2511. /* L90: */

  2512. 		}

  2513. 

  2514. /* L100: */

  2515. 	    }

  2516. 

  2517. L110:

  2518. 	    ;

  2519. 	}

  2520. 

  2521. /* L120: */

  2522.     }

  2523. 

  2524. /*     Report result. */

  2525. 

  2526.     if (errmax < *thresh) {

  2527. 	if (*iorder == 0) {

  2528. 	    printf("%12s PASSED THE COLUMN-MAJOR COMPUTATIONAL TESTS (%6d CALLS)\n",sname,nc);

  2529. 	}

  2530. 	if (*iorder == 1) {

  2531. 	    printf("%12s PASSED THE ROW-MAJOR COMPUTATIONAL TESTS (%6d CALLS)\n",sname,nc);

  2532. 	}

  2533.     } else {

  2534. 	if (*iorder == 0) {

  2535. 	    printf("%12s COMPLETED THE COLUMN-MAJOR COMPUTATIONAL TESTS (%6d CALLS) ******* BUT WITH MAXIMUM TEST RATIO %8.2f - SUSPECT *******\n",sname,nc,errmax);;

  2536. 	}

  2537. 	if (*iorder == 1) {

  2538. 	    printf("%12s COMPLETED THE ROW-MAJOR COMPUTATIONAL TESTS (%6d CALLS) ******* BUT WITH MAXIMUM TEST RATIO %8.2f - SUSPECT *******\n",sname,nc,errmax);;

  2539. 	}

  2540.     }

  2541.     goto L150;

  2542. 

  2543. L130:

  2544.     printf("      THESE ARE THE RESULTS FOR COLUMN %3d:\n",j);

  2545. 

  2546. L140:

  2547.     printf("******* %12s FAILED ON CALL NUMBER:\n",sname);

  2548.     printf("%6d: %12s (%3d, %3d) %4.1f, X, %2d, Y, %2d, A, %3d).\n",

  2549. 			    nc,sname,m,n,alpha,incx,incy,lda);

  2550. 

  2551. L150:

  2552.     return 0;

  2553. 

  2554. /* 9997 FORMAT( ' ',A12, ' COMPLETED THE COMPUTATIONAL TESTS (', I6, ' C', */

  2555. /*     $      'ALLS)', /' ******* BUT WITH MAXIMUM TEST RATIO', F8.2, */

  2556. /*     $      ' - SUSPECT *******' ) */

  2557. 

  2558. /*     End of SCHK4. */

  2559. 

  2560. } /* schk4_ */

  2561. 

  2562. /* Subroutine */ int schk5_(char* sname, real* eps, real* thresh, integer* nout, integer* ntra, logical* trace, logical* rewi, logical* fatal, integer* nidim, integer* idim, integer* nalf, real* alf, integer* ninc, integer* inc, integer* nmax, integer* incmax, real* a, real* aa, real* as, real* x, real* xx, real* xs, real* y, real* yy, real* ys, real* yt, real* g, real* z__, integer* iorder, ftnlen sname_len)

  2563. {

  2564.     /* Initialized data */

  2565. 

  2566.     static char ich[2+1] = "UL";

  2567. 

  2568.     /* System generated locals */

  2569.     integer a_dim1, a_offset, i__1, i__2, i__3, i__4, i__5;

  2570. 

  2571.     /* Builtin functions */

  2572. 

  2573.     /* Local variables */

  2574.     static integer ldas;

  2575.     static logical same;

  2576.     static integer incx;

  2577.     static logical full, null;

  2578.     static char uplo[1];

  2579.     static integer i__, j, n;

  2580.     static real alpha, w[1];

  2581.     static logical isame[13];

  2582.     extern /* Subroutine */ int smake_(char*, char*, char*, integer*, integer*, real*, integer*, real*, integer*, integer*, integer*, logical*, real*, ftnlen, ftnlen, ftnlen);

  2583.     static integer nargs;

  2584.     extern /* Subroutine */ int smvch_(char*, integer*, integer*, real*, real*, integer*, real*, integer*, real*, real*, integer*, real*, real*, real*, real*, real*, logical*, integer*, logical*, ftnlen);

  2585.     static logical reset;

  2586.     static char cuplo[14];

  2587.     static integer incxs;

  2588.     extern /* Subroutine */ void csspr_(integer*, char*, integer*, real*, real*, integer*, real*, ftnlen);

  2589.     static logical upper;

  2590.     static char uplos[1];

  2591.     extern /* Subroutine */ void cssyr_(integer*, char*, integer*, real*, real*, integer*, real*, integer*, ftnlen);

  2592.     static integer ia, ja, ic, nc, jj, lj, in;

  2593.     static logical packed;

  2594.     static integer ix, ns, lx;

  2595.     static real errmax;

  2596.     extern logical lseres_(char*, char*, integer*, integer*, real*, real*, integer*, ftnlen, ftnlen);

  2597.     static real transl;

  2598.     static integer laa, lda;

  2599.     static real als;

  2600.     extern logical lse_(real*, real*, integer*);

  2601.     static real err;

  2602. 

  2603. /*  Tests SSYR and SSPR. */

  2604. 

  2605. /*  Auxiliary routine for test program for Level 2 Blas. */

  2606. 

  2607. /*  -- Written on 10-August-1987. */

  2608. /*     Richard Hanson, Sandia National Labs. */

  2609. /*     Jeremy Du Croz, NAG Central Office. */

  2610. 

  2611. /*     .. Parameters .. */

  2612. /*     .. Scalar Arguments .. */

  2613. /*     .. Array Arguments .. */

  2614. /*     .. Local Scalars .. */

  2615. /*     .. Local Arrays .. */

  2616. /*     .. External Functions .. */

  2617. /*     .. External Subroutines .. */

  2618. /*     .. Intrinsic Functions .. */

  2619. /*     .. Scalars in Common .. */

  2620. /*     .. Common blocks .. */

  2621. /*     .. Data statements .. */

  2622.     /* Parameter adjustments */

  2623.     --idim;

  2624.     --alf;

  2625.     --inc;

  2626.     --z__;

  2627.     --g;

  2628.     --yt;

  2629.     --y;

  2630.     --x;

  2631.     --as;

  2632.     --aa;

  2633.     a_dim1 = *nmax;

  2634.     a_offset = 1 + a_dim1 * 1;

  2635.     a -= a_offset;

  2636.     --ys;

  2637.     --yy;

  2638.     --xs;

  2639.     --xx;

  2640. 

  2641.     /* Function Body */

  2642. /*     .. Executable Statements .. */

  2643.     full = *(unsigned char *)&sname[8] == 'y';

  2644.     packed = *(unsigned char *)&sname[8] == 'p';

  2645. /*     Define the number of arguments. */

  2646.     if (full) {

  2647. 	nargs = 7;

  2648.     } else if (packed) {

  2649. 	nargs = 6;

  2650.     }

  2651. 

  2652.     nc = 0;

  2653.     reset = TRUE_;

  2654.     errmax = (float)0.;

  2655. 

  2656.     i__1 = *nidim;

  2657.     for (in = 1; in <= i__1; ++in) {

  2658. 	n = idim[in];

  2659. /*        Set LDA to 1 more than minimum value if room. */

  2660. 	lda = n;

  2661. 	if (lda < *nmax) {

  2662. 	    ++lda;

  2663. 	}

  2664. /*        Skip tests if not enough room. */

  2665. 	if (lda > *nmax) {

  2666. 	    goto L100;

  2667. 	}

  2668. 	if (packed) {

  2669. 	    laa = n * (n + 1) / 2;

  2670. 	} else {

  2671. 	    laa = lda * n;

  2672. 	}

  2673. 

  2674. 	for (ic = 1; ic <= 2; ++ic) {

  2675. 	    *(unsigned char *)uplo = *(unsigned char *)&ich[ic - 1];

  2676. 	    if (*(unsigned char *)uplo == 'U') {

  2677. 		s_copy(cuplo, "    CblasUpper", (ftnlen)14, (ftnlen)14);

  2678. 	    } else {

  2679. 		s_copy(cuplo, "    CblasLower", (ftnlen)14, (ftnlen)14);

  2680. 	    }

  2681. 	    upper = *(unsigned char *)uplo == 'U';

  2682. 

  2683. 	    i__2 = *ninc;

  2684. 	    for (ix = 1; ix <= i__2; ++ix) {

  2685. 		incx = inc[ix];

  2686. 		lx = abs(incx) * n;

  2687. 

  2688. /*              Generate the vector X. */

  2689. 

  2690. 		transl = (float).5;

  2691. 		i__3 = abs(incx);

  2692. 		i__4 = n - 1;

  2693. 		smake_("ge", " ", " ", &c__1, &n, &x[1], &c__1, &xx[1], &i__3,

  2694. 			 &c__0, &i__4, &reset, &transl, (ftnlen)2, (ftnlen)1, 

  2695. 			(ftnlen)1);

  2696. 		if (n > 1) {

  2697. 		    x[n / 2] = (float)0.;

  2698. 		    xx[abs(incx) * (n / 2 - 1) + 1] = (float)0.;

  2699. 		}

  2700. 

  2701. 		i__3 = *nalf;

  2702. 		for (ia = 1; ia <= i__3; ++ia) {

  2703. 		    alpha = alf[ia];

  2704. 		    null = n <= 0 || alpha == (float)0.;

  2705. 

  2706. /*                 Generate the matrix A. */

  2707. 

  2708. 		    transl = (float)0.;

  2709. 		    i__4 = n - 1;

  2710. 		    i__5 = n - 1;

  2711. 		    smake_(sname + 7, uplo, " ", &n, &n, &a[a_offset], nmax, &

  2712. 			    aa[1], &lda, &i__4, &i__5, &reset, &transl, (

  2713. 			    ftnlen)2, (ftnlen)1, (ftnlen)1);

  2714. 

  2715. 		    ++nc;

  2716. 

  2717. /*                 Save every datum before calling the subroutine. */

  2718. 

  2719. 		    *(unsigned char *)uplos = *(unsigned char *)uplo;

  2720. 		    ns = n;

  2721. 		    als = alpha;

  2722. 		    i__4 = laa;

  2723. 		    for (i__ = 1; i__ <= i__4; ++i__) {

  2724. 			as[i__] = aa[i__];

  2725. /* L10: */

  2726. 		    }

  2727. 		    ldas = lda;

  2728. 		    i__4 = lx;

  2729. 		    for (i__ = 1; i__ <= i__4; ++i__) {

  2730. 			xs[i__] = xx[i__];

  2731. /* L20: */

  2732. 		    }

  2733. 		    incxs = incx;

  2734. 

  2735. /*                 Call the subroutine. */

  2736. 

  2737. 		    if (full) {

  2738. 			if (*trace) {

  2739. /*

  2740. 			    sprintf(ntra,"%6d: %12s (%14s, %3d, %4.1f, X, %2d, A, %3d).\n",

  2741. 			    nc,sname,cuplo,alpha,incx,lda);

  2742. */

  2743. 			}

  2744. 			if (*rewi) {

  2745. /*			    al__1.aerr = 0;

  2746. 			    al__1.aunit = *ntra;

  2747. 			    f_rew(&al__1);*/

  2748. 			}

  2749. 			cssyr_(iorder, uplo, &n, &alpha, &xx[1], &incx, &aa[1]

  2750. 				, &lda, (ftnlen)1);

  2751. 		    } else if (packed) {

  2752. 			if (*trace) {

  2753. /*

  2754. 			    sprintf(ntra,"%6d: %12s (%14s, %3d, %4.1f, X, %2d, AP).\n",

  2755. 			    nc,sname,cuplo,n,alpha,incx);

  2756. */

  2757. 			}

  2758. 			if (*rewi) {

  2759. /*			    al__1.aerr = 0;

  2760. 			    al__1.aunit = *ntra;

  2761. 			    f_rew(&al__1);*/

  2762. 			}

  2763. 			csspr_(iorder, uplo, &n, &alpha, &xx[1], &incx, &aa[1]

  2764. 				, (ftnlen)1);

  2765. 		    }

  2766. 

  2767. /*                 Check if error-exit was taken incorrectly. */

  2768. 

  2769. 		    if (! infoc_1.ok) {

  2770. 			printf(" ******* FATAL ERROR - ERROR-EXIT TAKEN ON VALID CALL *******n");

  2771. 			*fatal = TRUE_;

  2772. 			goto L120;

  2773. 		    }

  2774. 

  2775. /*                 See what data changed inside subroutines. */

  2776. 

  2777. 		    isame[0] = *(unsigned char *)uplo == *(unsigned char *)

  2778. 			    uplos;

  2779. 		    isame[1] = ns == n;

  2780. 		    isame[2] = als == alpha;

  2781. 		    isame[3] = lse_(&xs[1], &xx[1], &lx);

  2782. 		    isame[4] = incxs == incx;

  2783. 		    if (null) {

  2784. 			isame[5] = lse_(&as[1], &aa[1], &laa);

  2785. 		    } else {

  2786. 			isame[5] = lseres_(sname + 7, uplo, &n, &n, &as[1], &

  2787. 				aa[1], &lda, (ftnlen)2, (ftnlen)1);

  2788. 		    }

  2789. 		    if (! packed) {

  2790. 			isame[6] = ldas == lda;

  2791. 		    }

  2792. 

  2793. /*                 If data was incorrectly changed, report and return. */

  2794. 

  2795. 		    same = TRUE_;

  2796. 		    i__4 = nargs;

  2797. 		    for (i__ = 1; i__ <= i__4; ++i__) {

  2798. 			same = same && isame[i__ - 1];

  2799. 			if (! isame[i__ - 1]) {

  2800. 			    printf(" ******* FATAL ERROR - PARAMETER NUMBER %2d WAS CHANGED INCORRECTLY *******\n",i__);

  2801. 			}

  2802. /* L30: */

  2803. 		    }

  2804. 		    if (! same) {

  2805. 			*fatal = TRUE_;

  2806. 			goto L120;

  2807. 		    }

  2808. 

  2809. 		    if (! null) {

  2810. 

  2811. /*                    Check the result column by column. */

  2812. 

  2813. 			if (incx > 0) {

  2814. 			    i__4 = n;

  2815. 			    for (i__ = 1; i__ <= i__4; ++i__) {

  2816. 				z__[i__] = x[i__];

  2817. /* L40: */

  2818. 			    }

  2819. 			} else {

  2820. 			    i__4 = n;

  2821. 			    for (i__ = 1; i__ <= i__4; ++i__) {

  2822. 				z__[i__] = x[n - i__ + 1];

  2823. /* L50: */

  2824. 			    }

  2825. 			}

  2826. 			ja = 1;

  2827. 			i__4 = n;

  2828. 			for (j = 1; j <= i__4; ++j) {

  2829. 			    w[0] = z__[j];

  2830. 			    if (upper) {

  2831. 				jj = 1;

  2832. 				lj = j;

  2833. 			    } else {

  2834. 				jj = j;

  2835. 				lj = n - j + 1;

  2836. 			    }

  2837. 			    smvch_("N", &lj, &c__1, &alpha, &z__[jj], &lj, w, 

  2838. 				    &c__1, &c_b123, &a[jj + j * a_dim1], &

  2839. 				    c__1, &yt[1], &g[1], &aa[ja], eps, &err, 

  2840. 				    fatal, nout, &c_true, (ftnlen)1);

  2841. 			    if (full) {

  2842. 				if (upper) {

  2843. 				    ja += lda;

  2844. 				} else {

  2845. 				    ja = ja + lda + 1;

  2846. 				}

  2847. 			    } else {

  2848. 				ja += lj;

  2849. 			    }

  2850. 			    errmax = dmax(errmax,err);

  2851. /*                       If got really bad answer, report and return. */

  2852. 			    if (*fatal) {

  2853. 				goto L110;

  2854. 			    }

  2855. /* L60: */

  2856. 			}

  2857. 		    } else {

  2858. /*                    Avoid repeating tests if N.le.0. */

  2859. 			if (n <= 0) {

  2860. 			    goto L100;

  2861. 			}

  2862. 		    }

  2863. 

  2864. /* L70: */

  2865. 		}

  2866. 

  2867. /* L80: */

  2868. 	    }

  2869. 

  2870. /* L90: */

  2871. 	}

  2872. 

  2873. L100:

  2874. 	;

  2875.     }

  2876. 

  2877. /*     Report result. */

  2878. 

  2879.     if (errmax < *thresh) {

  2880. 	if (*iorder == 0) {

  2881. 	    printf("%12s PASSED THE COLUMN-MAJOR COMPUTATIONAL TESTS (%6d CALLS)\n",sname,nc);

  2882. 	}

  2883. 	if (*iorder == 1) {

  2884. 	    printf("%12s PASSED THE ROW-MAJOR COMPUTATIONAL TESTS (%6d CALLS)\n",sname,nc);

  2885. 	}

  2886.     } else {

  2887. 	if (*iorder == 0) {

  2888. 	    printf("%12s COMPLETED THE COLUMN-MAJOR COMPUTATIONAL TESTS (%6d CALLS) ******* BUT WITH MAXIMUM TEST RATIO %8.2f - SUSPECT *******\n",sname,nc,errmax);;

  2889. 	}

  2890. 	if (*iorder == 1) {

  2891. 	    printf("%12s COMPLETED THE ROW-MAJOR COMPUTATIONAL TESTS (%6d CALLS) ******* BUT WITH MAXIMUM TEST RATIO %8.2f - SUSPECT *******\n",sname,nc,errmax);;

  2892. 	}

  2893.     }

  2894.     goto L130;

  2895. 

  2896. L110:

  2897.     printf("      THESE ARE THE RESULTS FOR COLUMN %3d:\n",j);

  2898. 

  2899. L120:

  2900.     printf("******* %12s FAILED ON CALL NUMBER:\n",sname);

  2901.     if (full) {

  2902. 	printf("%6d: %12s (%14s, %3d, %4.1f, X, %2d, A, %3d).\n",

  2903. 			    nc,sname,cuplo,n,alpha,incx,lda);

  2904.     } else if (packed) {

  2905. 	printf("%6d: %12s (%14s, %3d, %4.1f, X, %2d, AP).\n",

  2906. 			    nc,sname,cuplo,n,alpha,incx);

  2907.     }

  2908. 

  2909. L130:

  2910.     return 0;

  2911. 

  2912. /* 9997 FORMAT( ' ',A12, ' COMPLETED THE COMPUTATIONAL TESTS (', I6, ' C', */

  2913. /*     $      'ALLS)', /' ******* BUT WITH MAXIMUM TEST RATIO', F8.2, */

  2914. /*     $      ' - SUSPECT *******' ) */

  2915. 

  2916. /*     End of SCHK5. */

  2917. 

  2918. } /* schk5_ */

  2919. 

  2920. /* Subroutine */ int schk6_(char* sname, real* eps, real* thresh, integer* nout, integer* ntra, logical* trace, logical* rewi, logical* fatal, integer* nidim, integer* idim, integer* nalf, real* alf, integer* ninc, integer* inc, integer* nmax, integer* incmax, real* a, real* aa, real* as, real* x, real* xx, real* xs, real* y, real* yy, real* ys, real* yt, real* g, real* z__, integer* iorder, ftnlen sname_len)

  2921. {

  2922.     /* Initialized data */

  2923. 

  2924.     static char ich[2+1] = "UL";

  2925. 

  2926.     /* System generated locals */

  2927.     integer a_dim1, a_offset, z_dim1, z_offset, i__1, i__2, i__3, i__4, i__5, 

  2928. 	    i__6;

  2929. 

  2930.     /* Local variables */

  2931.     static integer ldas;

  2932.     static logical same;

  2933.     static integer incx, incy;

  2934.     static logical full, null;

  2935.     static char uplo[1];

  2936.     static integer i__, j, n;

  2937.     static real alpha, w[2];

  2938.     static logical isame[13];

  2939.     extern /* Subroutine */ int smake_(char*, char*, char*, integer*, integer*, real*, integer*, real*, integer*, integer*, integer*, logical*, real*, ftnlen, ftnlen, ftnlen);

  2940.     static integer nargs;

  2941.     extern /* Subroutine */ int smvch_(char*, integer*, integer*, real*, real*, integer*, real*, integer*, real*, real*, integer*, real*, real*, real*, real*, real*, logical*, integer*, logical*, ftnlen);

  2942.     static logical reset;

  2943.     static char cuplo[14];

  2944.     static integer incxs, incys;

  2945.     static logical upper;

  2946.     static char uplos[1];

  2947.     static integer ia, ja, ic;

  2948.     extern /* Subroutine */ void csspr2_(integer*, char*, integer*, real*, real*, integer*, real*, integer*, real*, ftnlen);

  2949.     static integer nc, jj, lj, in;

  2950.     static logical packed;

  2951.     extern /* Subroutine */ void cssyr2_(integer*, char*, integer*, real*, real*, integer*, real*, integer*, real*, integer*, ftnlen);

  2952.     static integer ix, iy, ns, lx, ly;

  2953.     static real errmax;

  2954.     extern logical lseres_(char* type__, char* uplo, integer* m, integer* n, real* aa, real* as, integer* lda, ftnlen ltype_len, ftnlen uplo_len);

  2955.     static real transl;

  2956.     static integer laa, lda;

  2957.     static real als;

  2958.     extern logical lse_(real*, real*, integer*);

  2959.     static real err;

  2960. 

  2961. /*  Tests SSYR2 and SSPR2. */

  2962. 

  2963. /*  Auxiliary routine for test program for Level 2 Blas. */

  2964. 

  2965. /*  -- Written on 10-August-1987. */

  2966. /*     Richard Hanson, Sandia National Labs. */

  2967. /*     Jeremy Du Croz, NAG Central Office. */

  2968. 

  2969. /*     .. Parameters .. */

  2970. /*     .. Scalar Arguments .. */

  2971. /*     .. Array Arguments .. */

  2972. /*     .. Local Scalars .. */

  2973. /*     .. Local Arrays .. */

  2974. /*     .. External Functions .. */

  2975. /*     .. External Subroutines .. */

  2976. /*     .. Intrinsic Functions .. */

  2977. /*     .. Scalars in Common .. */

  2978. /*     .. Common blocks .. */

  2979. /*     .. Data statements .. */

  2980.     /* Parameter adjustments */

  2981.     --idim;

  2982.     --alf;

  2983.     --inc;

  2984.     z_dim1 = *nmax;

  2985.     z_offset = 1 + z_dim1 * 1;

  2986.     z__ -= z_offset;

  2987.     --g;

  2988.     --yt;

  2989.     --y;

  2990.     --x;

  2991.     --as;

  2992.     --aa;

  2993.     a_dim1 = *nmax;

  2994.     a_offset = 1 + a_dim1 * 1;

  2995.     a -= a_offset;

  2996.     --ys;

  2997.     --yy;

  2998.     --xs;

  2999.     --xx;

  3000. 

  3001.     /* Function Body */

  3002. /*     .. Executable Statements .. */

  3003.     full = *(unsigned char *)&sname[8] == 'y';

  3004.     packed = *(unsigned char *)&sname[8] == 'p';

  3005. /*     Define the number of arguments. */

  3006.     if (full) {

  3007. 	nargs = 9;

  3008.     } else if (packed) {

  3009. 	nargs = 8;

  3010.     }

  3011. 

  3012.     nc = 0;

  3013.     reset = TRUE_;

  3014.     errmax = (float)0.;

  3015. 

  3016.     i__1 = *nidim;

  3017.     for (in = 1; in <= i__1; ++in) {

  3018. 	n = idim[in];

  3019. /*        Set LDA to 1 more than minimum value if room. */

  3020. 	lda = n;

  3021. 	if (lda < *nmax) {

  3022. 	    ++lda;

  3023. 	}

  3024. /*        Skip tests if not enough room. */

  3025. 	if (lda > *nmax) {

  3026. 	    goto L140;

  3027. 	}

  3028. 	if (packed) {

  3029. 	    laa = n * (n + 1) / 2;

  3030. 	} else {

  3031. 	    laa = lda * n;

  3032. 	}

  3033. 

  3034. 	for (ic = 1; ic <= 2; ++ic) {

  3035. 	    *(unsigned char *)uplo = *(unsigned char *)&ich[ic - 1];

  3036. 	    if (*(unsigned char *)uplo == 'U') {

  3037. 		s_copy(cuplo, "    CblasUpper", (ftnlen)14, (ftnlen)14);

  3038. 	    } else {

  3039. 		s_copy(cuplo, "    CblasLower", (ftnlen)14, (ftnlen)14);

  3040. 	    }

  3041. 	    upper = *(unsigned char *)uplo == 'U';

  3042. 

  3043. 	    i__2 = *ninc;

  3044. 	    for (ix = 1; ix <= i__2; ++ix) {

  3045. 		incx = inc[ix];

  3046. 		lx = abs(incx) * n;

  3047. 

  3048. /*              Generate the vector X. */

  3049. 

  3050. 		transl = (float).5;

  3051. 		i__3 = abs(incx);

  3052. 		i__4 = n - 1;

  3053. 		smake_("ge", " ", " ", &c__1, &n, &x[1], &c__1, &xx[1], &i__3,

  3054. 			 &c__0, &i__4, &reset, &transl, (ftnlen)2, (ftnlen)1, 

  3055. 			(ftnlen)1);

  3056. 		if (n > 1) {

  3057. 		    x[n / 2] = (float)0.;

  3058. 		    xx[abs(incx) * (n / 2 - 1) + 1] = (float)0.;

  3059. 		}

  3060. 

  3061. 		i__3 = *ninc;

  3062. 		for (iy = 1; iy <= i__3; ++iy) {

  3063. 		    incy = inc[iy];

  3064. 		    ly = abs(incy) * n;

  3065. 

  3066. /*                 Generate the vector Y. */

  3067. 

  3068. 		    transl = (float)0.;

  3069. 		    i__4 = abs(incy);

  3070. 		    i__5 = n - 1;

  3071. 		    smake_("ge", " ", " ", &c__1, &n, &y[1], &c__1, &yy[1], &

  3072. 			    i__4, &c__0, &i__5, &reset, &transl, (ftnlen)2, (

  3073. 			    ftnlen)1, (ftnlen)1);

  3074. 		    if (n > 1) {

  3075. 			y[n / 2] = (float)0.;

  3076. 			yy[abs(incy) * (n / 2 - 1) + 1] = (float)0.;

  3077. 		    }

  3078. 

  3079. 		    i__4 = *nalf;

  3080. 		    for (ia = 1; ia <= i__4; ++ia) {

  3081. 			alpha = alf[ia];

  3082. 			null = n <= 0 || alpha == (float)0.;

  3083. 

  3084. /*                    Generate the matrix A. */

  3085. 

  3086. 			transl = (float)0.;

  3087. 			i__5 = n - 1;

  3088. 			i__6 = n - 1;

  3089. 			smake_(sname + 7, uplo, " ", &n, &n, &a[a_offset], 

  3090. 				nmax, &aa[1], &lda, &i__5, &i__6, &reset, &

  3091. 				transl, (ftnlen)2, (ftnlen)1, (ftnlen)1);

  3092. 

  3093. 			++nc;

  3094. 

  3095. /*                    Save every datum before calling the subroutine. */

  3096. 

  3097. 			*(unsigned char *)uplos = *(unsigned char *)uplo;

  3098. 			ns = n;

  3099. 			als = alpha;

  3100. 			i__5 = laa;

  3101. 			for (i__ = 1; i__ <= i__5; ++i__) {

  3102. 			    as[i__] = aa[i__];

  3103. /* L10: */

  3104. 			}

  3105. 			ldas = lda;

  3106. 			i__5 = lx;

  3107. 			for (i__ = 1; i__ <= i__5; ++i__) {

  3108. 			    xs[i__] = xx[i__];

  3109. /* L20: */

  3110. 			}

  3111. 			incxs = incx;

  3112. 			i__5 = ly;

  3113. 			for (i__ = 1; i__ <= i__5; ++i__) {

  3114. 			    ys[i__] = yy[i__];

  3115. /* L30: */

  3116. 			}

  3117. 			incys = incy;

  3118. 

  3119. /*                    Call the subroutine. */

  3120. 

  3121. 			if (full) {

  3122. 			    if (*trace) {

  3123. /*

  3124. 				sprintf(ntra,"%6d: %12s (%14s, %3d, %4.1f, X, %2d, Y, %2d, A, %3d).\n",

  3125. 				nc,sname,cuplo,n,alpha,incx,incy,lda);

  3126. */

  3127. 			    }

  3128. 			    if (*rewi) {

  3129. /*				al__1.aerr = 0;

  3130. 				al__1.aunit = *ntra;

  3131. 				f_rew(&al__1);*/

  3132. 			    }

  3133. 			    cssyr2_(iorder, uplo, &n, &alpha, &xx[1], &incx, &

  3134. 				    yy[1], &incy, &aa[1], &lda, (ftnlen)1);

  3135. 			} else if (packed) {

  3136. 			    if (*trace) {

  3137. /*

  3138. 				sprintf(ntra,"%6d: %12s (%14s, %3d, %4.1f, X, %2d, Y, %2d, AP).\n",

  3139. 				nc,sname,cuplo,n,alpha,incx,incy);

  3140. */

  3141. 			    }

  3142. 			    if (*rewi) {

  3143. /*				al__1.aerr = 0;

  3144. 				al__1.aunit = *ntra;

  3145. 				f_rew(&al__1);*/

  3146. 			    }

  3147. 			    csspr2_(iorder, uplo, &n, &alpha, &xx[1], &incx, &

  3148. 				    yy[1], &incy, &aa[1], (ftnlen)1);

  3149. 			}

  3150. 

  3151. /*                    Check if error-exit was taken incorrectly. */

  3152. 

  3153. 			if (! infoc_1.ok) {

  3154. 			    printf(" ******* FATAL ERROR - ERROR-EXIT TAKEN ON VALID CALL *******n");

  3155. 			    *fatal = TRUE_;

  3156. 			    goto L160;

  3157. 			}

  3158. 

  3159. /*                    See what data changed inside subroutines. */

  3160. 

  3161. 			isame[0] = *(unsigned char *)uplo == *(unsigned char *

  3162. 				)uplos;

  3163. 			isame[1] = ns == n;

  3164. 			isame[2] = als == alpha;

  3165. 			isame[3] = lse_(&xs[1], &xx[1], &lx);

  3166. 			isame[4] = incxs == incx;

  3167. 			isame[5] = lse_(&ys[1], &yy[1], &ly);

  3168. 			isame[6] = incys == incy;

  3169. 			if (null) {

  3170. 			    isame[7] = lse_(&as[1], &aa[1], &laa);

  3171. 			} else {

  3172. 			    isame[7] = lseres_(sname + 7, uplo, &n, &n, &as[1]

  3173. 				    , &aa[1], &lda, (ftnlen)2, (ftnlen)1);

  3174. 			}

  3175. 			if (! packed) {

  3176. 			    isame[8] = ldas == lda;

  3177. 			}

  3178. 

  3179. /*                    If data was incorrectly changed, report and return. */

  3180. 

  3181. 			same = TRUE_;

  3182. 			i__5 = nargs;

  3183. 			for (i__ = 1; i__ <= i__5; ++i__) {

  3184. 			    same = same && isame[i__ - 1];

  3185. 			    if (! isame[i__ - 1]) {

  3186. 			        printf(" ******* FATAL ERROR - PARAMETER NUMBER %2d WAS CHANGED INCORRECTLY *******\n",i__);

  3187. 			    }

  3188. /* L40: */

  3189. 			}

  3190. 			if (! same) {

  3191. 			    *fatal = TRUE_;

  3192. 			    goto L160;

  3193. 			}

  3194. 

  3195. 			if (! null) {

  3196. 

  3197. /*                       Check the result column by column. */

  3198. 

  3199. 			    if (incx > 0) {

  3200. 				i__5 = n;

  3201. 				for (i__ = 1; i__ <= i__5; ++i__) {

  3202. 				    z__[i__ + z_dim1] = x[i__];

  3203. /* L50: */

  3204. 				}

  3205. 			    } else {

  3206. 				i__5 = n;

  3207. 				for (i__ = 1; i__ <= i__5; ++i__) {

  3208. 				    z__[i__ + z_dim1] = x[n - i__ + 1];

  3209. /* L60: */

  3210. 				}

  3211. 			    }

  3212. 			    if (incy > 0) {

  3213. 				i__5 = n;

  3214. 				for (i__ = 1; i__ <= i__5; ++i__) {

  3215. 				    z__[i__ + (z_dim1 << 1)] = y[i__];

  3216. /* L70: */

  3217. 				}

  3218. 			    } else {

  3219. 				i__5 = n;

  3220. 				for (i__ = 1; i__ <= i__5; ++i__) {

  3221. 				    z__[i__ + (z_dim1 << 1)] = y[n - i__ + 1];

  3222. /* L80: */

  3223. 				}

  3224. 			    }

  3225. 			    ja = 1;

  3226. 			    i__5 = n;

  3227. 			    for (j = 1; j <= i__5; ++j) {

  3228. 				w[0] = z__[j + (z_dim1 << 1)];

  3229. 				w[1] = z__[j + z_dim1];

  3230. 				if (upper) {

  3231. 				    jj = 1;

  3232. 				    lj = j;

  3233. 				} else {

  3234. 				    jj = j;

  3235. 				    lj = n - j + 1;

  3236. 				}

  3237. 				smvch_("N", &lj, &c__2, &alpha, &z__[jj + 

  3238. 					z_dim1], nmax, w, &c__1, &c_b123, &a[

  3239. 					jj + j * a_dim1], &c__1, &yt[1], &g[1]

  3240. 					, &aa[ja], eps, &err, fatal, nout, &

  3241. 					c_true, (ftnlen)1);

  3242. 				if (full) {

  3243. 				    if (upper) {

  3244. 					ja += lda;

  3245. 				    } else {

  3246. 					ja = ja + lda + 1;

  3247. 				    }

  3248. 				} else {

  3249. 				    ja += lj;

  3250. 				}

  3251. 				errmax = dmax(errmax,err);

  3252. /*                          If got really bad answer, report and return. */

  3253. 				if (*fatal) {

  3254. 				    goto L150;

  3255. 				}

  3256. /* L90: */

  3257. 			    }

  3258. 			} else {

  3259. /*                       Avoid repeating tests with N.le.0. */

  3260. 			    if (n <= 0) {

  3261. 				goto L140;

  3262. 			    }

  3263. 			}

  3264. 

  3265. /* L100: */

  3266. 		    }

  3267. 

  3268. /* L110: */

  3269. 		}

  3270. 

  3271. /* L120: */

  3272. 	    }

  3273. 

  3274. /* L130: */

  3275. 	}

  3276. 

  3277. L140:

  3278. 	;

  3279.     }

  3280. 

  3281. /*     Report result. */

  3282. 

  3283.     if (errmax < *thresh) {

  3284. 	if (*iorder == 0) {

  3285. 	    printf("%12s PASSED THE COLUMN-MAJOR COMPUTATIONAL TESTS (%6d CALLS)\n",sname,nc);

  3286. 	}

  3287. 	if (*iorder == 1) {

  3288. 	    printf("%12s PASSED THE ROW-MAJOR COMPUTATIONAL TESTS (%6d CALLS)\n",sname,nc);

  3289. 	}

  3290.     } else {

  3291. 	if (*iorder == 0) {

  3292. 	    printf("%12s COMPLETED THE COLUMN-MAJOR COMPUTATIONAL TESTS (%6d CALLS) ******* BUT WITH MAXIMUM TEST RATIO %8.2f - SUSPECT *******\n",sname,nc,errmax);;

  3293. 	}

  3294. 	if (*iorder == 1) {

  3295. 	    printf("%12s COMPLETED THE ROW-MAJOR COMPUTATIONAL TESTS (%6d CALLS) ******* BUT WITH MAXIMUM TEST RATIO %8.2f - SUSPECT *******\n",sname,nc,errmax);;

  3296. 	}

  3297.     }

  3298.     goto L170;

  3299. 

  3300. L150:

  3301.     printf("      THESE ARE THE RESULTS FOR COLUMN %3d:\n",j);

  3302. 

  3303. L160:

  3304.     printf("******* %12s FAILED ON CALL NUMBER:\n",sname);

  3305.     if (full) {

  3306. 	printf("%6d: %12s (%14s, %3d, %4.1f, X, %2d, Y, %2d, A, %3d).\n",

  3307. 				nc,sname,cuplo,n,alpha,incx,incy,lda);

  3308.     } else if (packed) {

  3309. 	printf("%6d: %12s (%14s, %3d, %4.1f, X, %2d, Y, %2d, AP).\n",

  3310. 				nc,sname,cuplo,n,alpha,incx,incy);

  3311.     }

  3312. 

  3313. L170:

  3314.     return 0;

  3315. 

  3316. /* 9997 FORMAT( ' ',A12, ' COMPLETED THE COMPUTATIONAL TESTS (', I6, ' C', */

  3317. /*     $      'ALLS)', /' ******* BUT WITH MAXIMUM TEST RATIO', F8.2, */

  3318. /*     $      ' - SUSPECT *******' ) */

  3319. 

  3320. /*     End of SCHK6. */

  3321. 

  3322. } /* schk6_ */

  3323. 

  3324. /* Subroutine */ int smake_(char* type__, char* uplo, char* diag, integer* m, integer* n, real* a, integer* nmax, real* aa, integer* lda, integer* kl, integer* ku, logical* reset, real* transl, ftnlen type_len, ftnlen uplo_len, ftnlen diag_len)

  3325.  {

  3326.     /* System generated locals */

  3327.     integer a_dim1, a_offset, i__1, i__2, i__3, i__4;

  3328. 

  3329.     /* Local variables */

  3330.     static integer ibeg, iend;

  3331.     extern doublereal sbeg_(logical*);

  3332.     static integer ioff;

  3333.     static logical unit;

  3334.     static integer i__, j;

  3335.     static logical lower;

  3336.     static integer i1, i2, i3;

  3337.     static logical upper;

  3338.     static integer kk;

  3339.     static logical gen, tri, sym;

  3340. 

  3341. 

  3342. /*  Generates values for an M by N matrix A within the bandwidth */

  3343. /*  defined by KL and KU. */

  3344. /*  Stores the values in the array AA in the data structure required */

  3345. /*  by the routine, with unwanted elements set to rogue value. */

  3346. 

  3347. /*  TYPE is 'ge', 'gb', 'sy', 'sb', 'sp', 'tr', 'tb' OR 'tp'. */

  3348. 

  3349. /*  Auxiliary routine for test program for Level 2 Blas. */

  3350. 

  3351. /*  -- Written on 10-August-1987. */

  3352. /*     Richard Hanson, Sandia National Labs. */

  3353. /*     Jeremy Du Croz, NAG Central Office. */

  3354. 

  3355. /*     .. Parameters .. */

  3356. /*     .. Scalar Arguments .. */

  3357. /*     .. Array Arguments .. */

  3358. /*     .. Local Scalars .. */

  3359. /*     .. External Functions .. */

  3360. /*     .. Intrinsic Functions .. */

  3361. /*     .. Executable Statements .. */

  3362.     /* Parameter adjustments */

  3363.     a_dim1 = *nmax;

  3364.     a_offset = 1 + a_dim1 * 1;

  3365.     a -= a_offset;

  3366.     --aa;

  3367. 

  3368.     /* Function Body */

  3369.     gen = *(unsigned char *)type__ == 'g';

  3370.     sym = *(unsigned char *)type__ == 's';

  3371.     tri = *(unsigned char *)type__ == 't';

  3372.     upper = (sym || tri) && *(unsigned char *)uplo == 'U';

  3373.     lower = (sym || tri) && *(unsigned char *)uplo == 'L';

  3374.     unit = tri && *(unsigned char *)diag == 'U';

  3375. 

  3376. /*     Generate data in array A. */

  3377. 

  3378.     i__1 = *n;

  3379.     for (j = 1; j <= i__1; ++j) {

  3380. 	i__2 = *m;

  3381. 	for (i__ = 1; i__ <= i__2; ++i__) {

  3382. 	    if (gen || (upper && i__ <= j) || (lower && i__ >= j)) {

  3383. 		if (i__ <= j && (j - i__ <= *ku || i__ >= j && i__ - j <= *kl)) 

  3384. 			{

  3385. 		    a[i__ + j * a_dim1] = sbeg_(reset) + *transl;

  3386. 		} else {

  3387. 		    a[i__ + j * a_dim1] = (float)0.;

  3388. 		}

  3389. 		if (i__ != j) {

  3390. 		    if (sym) {

  3391. 			a[j + i__ * a_dim1] = a[i__ + j * a_dim1];

  3392. 		    } else if (tri) {

  3393. 			a[j + i__ * a_dim1] = (float)0.;

  3394. 		    }

  3395. 		}

  3396. 	    }

  3397. /* L10: */

  3398. 	}

  3399. 	if (tri) {

  3400. 	    a[j + j * a_dim1] += (float)1.;

  3401. 	}

  3402. 	if (unit) {

  3403. 	    a[j + j * a_dim1] = (float)1.;

  3404. 	}

  3405. /* L20: */

  3406.     }

  3407. 

  3408. /*     Store elements in array AS in data structure required by routine. */

  3409. 

  3410.     if (s_cmp(type__, "ge", (ftnlen)2, (ftnlen)2) == 0) {

  3411. 	i__1 = *n;

  3412. 	for (j = 1; j <= i__1; ++j) {

  3413. 	    i__2 = *m;

  3414. 	    for (i__ = 1; i__ <= i__2; ++i__) {

  3415. 		aa[i__ + (j - 1) * *lda] = a[i__ + j * a_dim1];

  3416. /* L30: */

  3417. 	    }

  3418. 	    i__2 = *lda;

  3419. 	    for (i__ = *m + 1; i__ <= i__2; ++i__) {

  3420. 		aa[i__ + (j - 1) * *lda] = (float)-1e10;

  3421. /* L40: */

  3422. 	    }

  3423. /* L50: */

  3424. 	}

  3425.     } else if (s_cmp(type__, "gb", (ftnlen)2, (ftnlen)2) == 0) {

  3426. 	i__1 = *n;

  3427. 	for (j = 1; j <= i__1; ++j) {

  3428. 	    i__2 = *ku + 1 - j;

  3429. 	    for (i1 = 1; i1 <= i__2; ++i1) {

  3430. 		aa[i1 + (j - 1) * *lda] = (float)-1e10;

  3431. /* L60: */

  3432. 	    }

  3433. /* Computing MIN */

  3434. 	    i__3 = *kl + *ku + 1, i__4 = *ku + 1 + *m - j;

  3435. 	    i__2 = f2cmin(i__3,i__4);

  3436. 	    for (i2 = i1; i2 <= i__2; ++i2) {

  3437. 		aa[i2 + (j - 1) * *lda] = a[i2 + j - *ku - 1 + j * a_dim1];

  3438. /* L70: */

  3439. 	    }

  3440. 	    i__2 = *lda;

  3441. 	    for (i3 = i2; i3 <= i__2; ++i3) {

  3442. 		aa[i3 + (j - 1) * *lda] = (float)-1e10;

  3443. /* L80: */

  3444. 	    }

  3445. /* L90: */

  3446. 	}

  3447.     } else if (s_cmp(type__, "sy", (ftnlen)2, (ftnlen)2) == 0 || s_cmp(type__,

  3448. 	     "tr", (ftnlen)2, (ftnlen)2) == 0) {

  3449. 	i__1 = *n;

  3450. 	for (j = 1; j <= i__1; ++j) {

  3451. 	    if (upper) {

  3452. 		ibeg = 1;

  3453. 		if (unit) {

  3454. 		    iend = j - 1;

  3455. 		} else {

  3456. 		    iend = j;

  3457. 		}

  3458. 	    } else {

  3459. 		if (unit) {

  3460. 		    ibeg = j + 1;

  3461. 		} else {

  3462. 		    ibeg = j;

  3463. 		}

  3464. 		iend = *n;

  3465. 	    }

  3466. 	    i__2 = ibeg - 1;

  3467. 	    for (i__ = 1; i__ <= i__2; ++i__) {

  3468. 		aa[i__ + (j - 1) * *lda] = (float)-1e10;

  3469. /* L100: */

  3470. 	    }

  3471. 	    i__2 = iend;

  3472. 	    for (i__ = ibeg; i__ <= i__2; ++i__) {

  3473. 		aa[i__ + (j - 1) * *lda] = a[i__ + j * a_dim1];

  3474. /* L110: */

  3475. 	    }

  3476. 	    i__2 = *lda;

  3477. 	    for (i__ = iend + 1; i__ <= i__2; ++i__) {

  3478. 		aa[i__ + (j - 1) * *lda] = (float)-1e10;

  3479. /* L120: */

  3480. 	    }

  3481. /* L130: */

  3482. 	}

  3483.     } else if (s_cmp(type__, "sb", (ftnlen)2, (ftnlen)2) == 0 || s_cmp(type__,

  3484. 	     "tb", (ftnlen)2, (ftnlen)2) == 0) {

  3485. 	i__1 = *n;

  3486. 	for (j = 1; j <= i__1; ++j) {

  3487. 	    if (upper) {

  3488. 		kk = *kl + 1;

  3489. /* Computing MAX */

  3490. 		i__2 = 1, i__3 = *kl + 2 - j;

  3491. 		ibeg = f2cmax(i__2,i__3);

  3492. 		if (unit) {

  3493. 		    iend = *kl;

  3494. 		} else {

  3495. 		    iend = *kl + 1;

  3496. 		}

  3497. 	    } else {

  3498. 		kk = 1;

  3499. 		if (unit) {

  3500. 		    ibeg = 2;

  3501. 		} else {

  3502. 		    ibeg = 1;

  3503. 		}

  3504. /* Computing MIN */

  3505. 		i__2 = *kl + 1, i__3 = *m + 1 - j;

  3506. 		iend = f2cmin(i__2,i__3);

  3507. 	    }

  3508. 	    i__2 = ibeg - 1;

  3509. 	    for (i__ = 1; i__ <= i__2; ++i__) {

  3510. 		aa[i__ + (j - 1) * *lda] = (float)-1e10;

  3511. /* L140: */

  3512. 	    }

  3513. 	    i__2 = iend;

  3514. 	    for (i__ = ibeg; i__ <= i__2; ++i__) {

  3515. 		aa[i__ + (j - 1) * *lda] = a[i__ + j - kk + j * a_dim1];

  3516. /* L150: */

  3517. 	    }

  3518. 	    i__2 = *lda;

  3519. 	    for (i__ = iend + 1; i__ <= i__2; ++i__) {

  3520. 		aa[i__ + (j - 1) * *lda] = (float)-1e10;

  3521. /* L160: */

  3522. 	    }

  3523. /* L170: */

  3524. 	}

  3525.     } else if (s_cmp(type__, "sp", (ftnlen)2, (ftnlen)2) == 0 || s_cmp(type__,

  3526. 	     "tp", (ftnlen)2, (ftnlen)2) == 0) {

  3527. 	ioff = 0;

  3528. 	i__1 = *n;

  3529. 	for (j = 1; j <= i__1; ++j) {

  3530. 	    if (upper) {

  3531. 		ibeg = 1;

  3532. 		iend = j;

  3533. 	    } else {

  3534. 		ibeg = j;

  3535. 		iend = *n;

  3536. 	    }

  3537. 	    i__2 = iend;

  3538. 	    for (i__ = ibeg; i__ <= i__2; ++i__) {

  3539. 		++ioff;

  3540. 		aa[ioff] = a[i__ + j * a_dim1];

  3541. 		if (i__ == j) {

  3542. 		    if (unit) {

  3543. 			aa[ioff] = (float)-1e10;

  3544. 		    }

  3545. 		}

  3546. /* L180: */

  3547. 	    }

  3548. /* L190: */

  3549. 	}

  3550.     }

  3551.     return 0;

  3552. 

  3553. /*     End of SMAKE. */

  3554. 

  3555. } /* smake_ */

  3556. 

  3557. /* Subroutine */ int smvch_(char* trans, integer* m, integer* n, real* alpha, real* a, integer* nmax, real* x, integer* incx, real* beta, real* y, integer* incy, real* yt, real* g, real* yy, real* eps, real* err, logical* fatal, integer* nout, logical* mv, ftnlen trans_len)

  3558. {

  3559.     /* System generated locals */

  3560.     integer a_dim1, a_offset, i__1, i__2;

  3561.     real r__1;

  3562. 

  3563.     /* Builtin functions */

  3564.     double sqrt(double);

  3565. 

  3566.     /* Local variables */

  3567.     static real erri;

  3568.     static logical tran;

  3569.     static integer i__, j, incxl, incyl, ml, nl, iy, jx, kx, ky;

  3570. 

  3571. /*  Checks the results of the computational tests. */

  3572. 

  3573. /*  Auxiliary routine for test program for Level 2 Blas. */

  3574. 

  3575. /*  -- Written on 10-August-1987. */

  3576. /*     Richard Hanson, Sandia National Labs. */

  3577. /*     Jeremy Du Croz, NAG Central Office. */

  3578. 

  3579. /*     .. Parameters .. */

  3580. /*     .. Scalar Arguments .. */

  3581. /*     .. Array Arguments .. */

  3582. /*     .. Local Scalars .. */

  3583. /*     .. Intrinsic Functions .. */

  3584. /*     .. Executable Statements .. */

  3585.     /* Parameter adjustments */

  3586.     a_dim1 = *nmax;

  3587.     a_offset = 1 + a_dim1 * 1;

  3588.     a -= a_offset;

  3589.     --x;

  3590.     --y;

  3591.     --yt;

  3592.     --g;

  3593.     --yy;

  3594. 

  3595.     /* Function Body */

  3596.     tran = *(unsigned char *)trans == 'T' || *(unsigned char *)trans == 'C';

  3597.     if (tran) {

  3598. 	ml = *n;

  3599. 	nl = *m;

  3600.     } else {

  3601. 	ml = *m;

  3602. 	nl = *n;

  3603.     }

  3604.     if (*incx < 0) {

  3605. 	kx = nl;

  3606. 	incxl = -1;

  3607.     } else {

  3608. 	kx = 1;

  3609. 	incxl = 1;

  3610.     }

  3611.     if (*incy < 0) {

  3612. 	ky = ml;

  3613. 	incyl = -1;

  3614.     } else {

  3615. 	ky = 1;

  3616. 	incyl = 1;

  3617.     }

  3618. 

  3619. /*     Compute expected result in YT using data in A, X and Y. */

  3620. /*     Compute gauges in G. */

  3621. 

  3622.     iy = ky;

  3623.     i__1 = ml;

  3624.     for (i__ = 1; i__ <= i__1; ++i__) {

  3625. 	yt[iy] = (float)0.;

  3626. 	g[iy] = (float)0.;

  3627. 	jx = kx;

  3628. 	if (tran) {

  3629. 	    i__2 = nl;

  3630. 	    for (j = 1; j <= i__2; ++j) {

  3631. 		yt[iy] += a[j + i__ * a_dim1] * x[jx];

  3632. 		g[iy] += (r__1 = a[j + i__ * a_dim1] * x[jx], dabs(r__1));

  3633. 		jx += incxl;

  3634. /* L10: */

  3635. 	    }

  3636. 	} else {

  3637. 	    i__2 = nl;

  3638. 	    for (j = 1; j <= i__2; ++j) {

  3639. 		yt[iy] += a[i__ + j * a_dim1] * x[jx];

  3640. 		g[iy] += (r__1 = a[i__ + j * a_dim1] * x[jx], dabs(r__1));

  3641. 		jx += incxl;

  3642. /* L20: */

  3643. 	    }

  3644. 	}

  3645. 	yt[iy] = *alpha * yt[iy] + *beta * y[iy];

  3646. 	g[iy] = dabs(*alpha) * g[iy] + (r__1 = *beta * y[iy], dabs(r__1));

  3647. 	iy += incyl;

  3648. /* L30: */

  3649.     }

  3650. 

  3651. /*     Compute the error ratio for this result. */

  3652. 

  3653.     *err = (float)0.;

  3654.     i__1 = ml;

  3655.     for (i__ = 1; i__ <= i__1; ++i__) {

  3656. 	erri = (r__1 = yt[i__] - yy[(i__ - 1) * abs(*incy) + 1], dabs(r__1)) /

  3657. 		 *eps;

  3658. 	if (g[i__] != (float)0.) {

  3659. 	    erri /= g[i__];

  3660. 	}

  3661. 	*err = dmax(*err,erri);

  3662. 	if (*err * sqrt(*eps) >= (float)1.) {

  3663. 	    goto L50;

  3664. 	}

  3665. /* L40: */

  3666.     }

  3667. /*     If the loop completes, all results are at least half accurate. */

  3668.     goto L70;

  3669. 

  3670. /*     Report fatal error. */

  3671. 

  3672. L50:

  3673.     *fatal = TRUE_;

  3674.     printf(" ******* FATAL ERROR - COMPUTED RESULT IS LESS THAN HALF ACCURATE *******\n           EXPECTED RESULT   COMPUTED RESULT\n");

  3675.     i__1 = ml;

  3676.     for (i__ = 1; i__ <= i__1; ++i__) {

  3677. 	if (*mv) {

  3678. 	    printf("%7d %18.6g %18.6g\n",i__,yt[i__],yy[(i__ - 1) * abs(*incy) + 1]);

  3679. 	} else {

  3680. 	    printf("%7d %18.6g %18.6g\n",i__,yy[(i__ - 1) * abs(*incy) + 1], yt[i__]);

  3681. 	}

  3682. /* L60: */

  3683.     }

  3684. 

  3685. L70:

  3686.     return 0;

  3687. 

  3688. 

  3689. /*     End of SMVCH. */

  3690. 

  3691. } /* smvch_ */

  3692. 

  3693. logical lse_(real* ri, real* rj, integer* lr)

  3694. {

  3695.     /* System generated locals */

  3696.     integer i__1;

  3697.     logical ret_val;

  3698. 

  3699.     /* Local variables */

  3700.     static integer i__;

  3701. 

  3702. 

  3703. /*  Tests if two arrays are identical. */

  3704. 

  3705. /*  Auxiliary routine for test program for Level 2 Blas. */

  3706. 

  3707. /*  -- Written on 10-August-1987. */

  3708. /*     Richard Hanson, Sandia National Labs. */

  3709. /*     Jeremy Du Croz, NAG Central Office. */

  3710. 

  3711. /*     .. Scalar Arguments .. */

  3712. /*     .. Array Arguments .. */

  3713. /*     .. Local Scalars .. */

  3714. /*     .. Executable Statements .. */

  3715.     /* Parameter adjustments */

  3716.     --rj;

  3717.     --ri;

  3718. 

  3719.     /* Function Body */

  3720.     i__1 = *lr;

  3721.     for (i__ = 1; i__ <= i__1; ++i__) {

  3722. 	if (ri[i__] != rj[i__]) {

  3723. 	    goto L20;

  3724. 	}

  3725. /* L10: */

  3726.     }

  3727.     ret_val = TRUE_;

  3728.     goto L30;

  3729. L20:

  3730.     ret_val = FALSE_;

  3731. L30:

  3732.     return ret_val;

  3733. 

  3734. /*     End of LSE. */

  3735. 

  3736. } /* lse_ */

  3737. 

  3738. logical lseres_(char* type__, char* uplo, integer* m, integer* n, real* aa, real* as, integer* lda, ftnlen ltype_len, ftnlen uplo_len)

  3739. {

  3740.     /* System generated locals */

  3741.     integer aa_dim1, aa_offset, as_dim1, as_offset, i__1, i__2;

  3742.     logical ret_val;

  3743. 

  3744.     /* Local variables */

  3745.     static integer ibeg, iend, i__, j;

  3746.     static logical upper;

  3747. 

  3748. 

  3749. /*  Tests if selected elements in two arrays are equal. */

  3750. 

  3751. /*  TYPE is 'ge', 'sy' or 'sp'. */

  3752. 

  3753. /*  Auxiliary routine for test program for Level 2 Blas. */

  3754. 

  3755. /*  -- Written on 10-August-1987. */

  3756. /*     Richard Hanson, Sandia National Labs. */

  3757. /*     Jeremy Du Croz, NAG Central Office. */

  3758. 

  3759. /*     .. Scalar Arguments .. */

  3760. /*     .. Array Arguments .. */

  3761. /*     .. Local Scalars .. */

  3762. /*     .. Executable Statements .. */

  3763.     /* Parameter adjustments */

  3764.     as_dim1 = *lda;

  3765.     as_offset = 1 + as_dim1 * 1;

  3766.     as -= as_offset;

  3767.     aa_dim1 = *lda;

  3768.     aa_offset = 1 + aa_dim1 * 1;

  3769.     aa -= aa_offset;

  3770. 

  3771.     /* Function Body */

  3772.     upper = *(unsigned char *)uplo == 'U';

  3773.     if (s_cmp(type__, "ge", (ftnlen)2, (ftnlen)2) == 0) {

  3774. 	i__1 = *n;

  3775. 	for (j = 1; j <= i__1; ++j) {

  3776. 	    i__2 = *lda;

  3777. 	    for (i__ = *m + 1; i__ <= i__2; ++i__) {

  3778. 		if (aa[i__ + j * aa_dim1] != as[i__ + j * as_dim1]) {

  3779. 		    goto L70;

  3780. 		}

  3781. /* L10: */

  3782. 	    }

  3783. /* L20: */

  3784. 	}

  3785.     } else if (s_cmp(type__, "sy", (ftnlen)2, (ftnlen)2) == 0) {

  3786. 	i__1 = *n;

  3787. 	for (j = 1; j <= i__1; ++j) {

  3788. 	    if (upper) {

  3789. 		ibeg = 1;

  3790. 		iend = j;

  3791. 	    } else {

  3792. 		ibeg = j;

  3793. 		iend = *n;

  3794. 	    }

  3795. 	    i__2 = ibeg - 1;

  3796. 	    for (i__ = 1; i__ <= i__2; ++i__) {

  3797. 		if (aa[i__ + j * aa_dim1] != as[i__ + j * as_dim1]) {

  3798. 		    goto L70;

  3799. 		}

  3800. /* L30: */

  3801. 	    }

  3802. 	    i__2 = *lda;

  3803. 	    for (i__ = iend + 1; i__ <= i__2; ++i__) {

  3804. 		if (aa[i__ + j * aa_dim1] != as[i__ + j * as_dim1]) {

  3805. 		    goto L70;

  3806. 		}

  3807. /* L40: */

  3808. 	    }

  3809. /* L50: */

  3810. 	}

  3811.     }

  3812. 

  3813. /*   60 CONTINUE */

  3814.     ret_val = TRUE_;

  3815.     goto L80;

  3816. L70:

  3817.     ret_val = FALSE_;

  3818. L80:

  3819.     return ret_val;

  3820. 

  3821. /*     End of LSERES. */

  3822. 

  3823. } /* lseres_ */

  3824. 

  3825. doublereal sbeg_(logical* reset)

  3826. {

  3827.     /* System generated locals */

  3828.     real ret_val;

  3829. 

  3830.     /* Local variables */

  3831.     static integer i__, ic, mi;

  3832. 

  3833. 

  3834. /*  Generates random numbers uniformly distributed between -0.5 and 0.5. */

  3835. 

  3836. /*  Auxiliary routine for test program for Level 2 Blas. */

  3837. 

  3838. /*  -- Written on 10-August-1987. */

  3839. /*     Richard Hanson, Sandia National Labs. */

  3840. /*     Jeremy Du Croz, NAG Central Office. */

  3841. 

  3842. /*     .. Scalar Arguments .. */

  3843. /*     .. Local Scalars .. */

  3844. /*     .. Save statement .. */

  3845. /*     .. Intrinsic Functions .. */

  3846. /*     .. Executable Statements .. */

  3847.     if (*reset) {

  3848. /*        Initialize local variables. */

  3849. 	mi = 891;

  3850. 	i__ = 7;

  3851. 	ic = 0;

  3852. 	*reset = FALSE_;

  3853.     }

  3854. 

  3855. /*     The sequence of values of I is bounded between 1 and 999. */

  3856. /*     If initial I = 1,2,3,6,7 or 9, the period will be 50. */

  3857. /*     If initial I = 4 or 8, the period will be 25. */

  3858. /*     If initial I = 5, the period will be 10. */

  3859. /*     IC is used to break up the period by skipping 1 value of I in 6. */

  3860. 

  3861.     ++ic;

  3862. L10:

  3863.     i__ *= mi;

  3864.     i__ -= i__ / 1000 * 1000;

  3865.     if (ic >= 5) {

  3866. 	ic = 0;

  3867. 	goto L10;

  3868.     }

  3869.     ret_val = (real) (i__ - 500) / (float)1001.;

  3870.     return ret_val;

  3871. 

  3872. /*     End of SBEG. */

  3873. 

  3874. } /* sbeg_ */

  3875. 

  3876. doublereal sdiff_(real* x, real* y)

  3877. {

  3878.     /* System generated locals */

  3879.     real ret_val;

  3880. 

  3881. 

  3882. /*  Auxiliary routine for test program for Level 2 Blas. */

  3883. 

  3884. /*  -- Written on 10-August-1987. */

  3885. /*     Richard Hanson, Sandia National Labs. */

  3886. 

  3887. /*     .. Scalar Arguments .. */

  3888. /*     .. Executable Statements .. */

  3889.     ret_val = *x - *y;

  3890.     return ret_val;

  3891. 

  3892. /*     End of SDIFF. */

  3893. 

  3894. } /* sdiff_ */