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: 3d6d026fe1
Branches Tags
${ item.name }
Create branch ${ searchTerm }
from '3d6d026fe1'
${ noResults }
OpenBLAS/ctest/c_dblat3c.c

3340 lines
98 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 doublereal c_b90 = 1.;

  267. static doublereal c_b104 = 0.;

  268. static integer c__6 = 6;

  269. static logical c_true = TRUE_;

  270. static integer c__0 = 0;

  271. static logical c_false = FALSE_;

  272. 

  273. /* Main program  MAIN__() */ int main(void)

  274. {

  275.     /* Initialized data */

  276. 

  277.     static char snames[6][13] = {"cblas_dgemm ", "cblas_dsymm ", "cblas_dtrmm ", "cblas_dtrsm ", "cblas_dsyrk ", "cblas_dsyr2k"};

  278. 

  279.     /* System generated locals */

  280.     integer i__1, i__2, i__3;

  281.     doublereal d__1;

  282. 

  283. 

  284.     /* Local variables */

  285.     static integer nalf, idim[9];

  286.     static logical same;

  287.     static integer nbet, ntra;

  288.     static logical rewi;

  289.     extern /* Subroutine */ int dchk1_(char*, doublereal*, doublereal*, integer*, integer*, logical*, logical*, logical*, integer*, integer*, integer*, doublereal*, integer*, doublereal*, integer*, doublereal*, doublereal*, doublereal*, doublereal*, doublereal*, doublereal*, doublereal*, doublereal*, doublereal*, doublereal*, doublereal*, integer*, ftnlen);

  290.     extern /* Subroutine */ int dchk2_(char*, doublereal*, doublereal*, integer*, integer*, logical*, logical*, logical*, integer*, integer*, integer*, doublereal*, integer*, doublereal*, integer*, doublereal*, doublereal*, doublereal*, doublereal*, doublereal*, doublereal*, doublereal*, doublereal*, doublereal*, doublereal*, doublereal*, integer*, ftnlen);

  291.     extern /* Subroutine */ int dchk3_(char*, doublereal*, doublereal*, integer*, integer*, logical*, logical*, logical*, integer*, integer*, integer*, doublereal*, integer*, doublereal*, doublereal*, doublereal*, doublereal*, doublereal*, doublereal*, doublereal*, doublereal*, doublereal*, integer*, ftnlen);

  292.     extern /* Subroutine */ int dchk4_(char*, doublereal*, doublereal*, integer*, integer*, logical*, logical*, logical*, integer*, integer*, integer*, doublereal*, integer*, doublereal*, integer*, doublereal*, doublereal*, doublereal*, doublereal*, doublereal*, doublereal*, doublereal*, doublereal*, doublereal*, doublereal*, doublereal*, integer*, ftnlen);

  293. /* Subroutine */ int dchk5_(char* sname, doublereal* eps, doublereal* thresh, integer* nout, integer* ntra, logical* trace, logical* rewi, logical* fatal, integer* nidim, integer* idim, integer* nalf, doublereal* alf, integer* nbet, doublereal* bet, integer* nmax, doublereal* ab, doublereal* aa, doublereal* as, doublereal* bb, doublereal* bs, doublereal* c__, doublereal* cc, doublereal* cs, doublereal* ct, doublereal* g, doublereal* w, integer* iorder, ftnlen sname_len);

  294.     static doublereal c__[4225]	/* was [65][65] */, g[65];

  295.     static integer i__, j;

  296.     extern doublereal ddiff_(doublereal*, doublereal*);

  297.     static integer n;

  298.     static logical fatal;

  299.     static doublereal w[130];

  300.     extern /* Subroutine */ int dmmch_(char*, char*, integer*, integer*, integer*, doublereal*, doublereal*, integer*, doublereal*, integer*, doublereal*, doublereal*, integer*, doublereal*, doublereal*, doublereal*, integer*, doublereal*, doublereal*, logical*, integer*, logical*, ftnlen, ftnlen);

  301.     static logical trace;

  302.     static integer nidim;

  303.     static char snaps[32];

  304.     static integer isnum;

  305.     static logical ltest[6];

  306.     static doublereal aa[4225], ab[8450]	/* was [65][130] */, bb[4225],

  307. 	     cc[4225], as[4225], bs[4225], cs[4225], ct[65];

  308.     static logical sfatal, corder;

  309.     static char snamet[12], transa[1], transb[1];

  310.     static doublereal thresh;

  311.     static logical rorder;

  312.     extern /* Subroutine */ void cd3chke_(char*, ftnlen);

  313.     static integer layout;

  314.     static logical ltestt, tsterr;

  315.     static doublereal alf[7];

  316.     extern logical lde_(doublereal*, doublereal*, integer*);

  317.     static doublereal bet[7], eps, err;

  318.     char tmpchar;

  319. 

  320. /*  Test program for the DOUBLE PRECISION Level 3 Blas. */

  321. 

  322. /*  The program must be driven by a short data file. The first 13 records */

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

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

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

  326. /*  following 19 lines: */

  327. /*  'DBLAT3.SNAP'     NAME OF SNAPSHOT OUTPUT FILE */

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

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

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

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

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

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

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

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

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

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

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

  339. /*  0.0 1.0 1.3       VALUES OF BETA */

  340. /*  cblas_dgemm  T PUT F FOR NO TEST. SAME COLUMNS. */

  341. /*  cblas_dsymm  T PUT F FOR NO TEST. SAME COLUMNS. */

  342. /*  cblas_dtrmm  T PUT F FOR NO TEST. SAME COLUMNS. */

  343. /*  cblas_dtrsm  T PUT F FOR NO TEST. SAME COLUMNS. */

  344. /*  cblas_dsyrk  T PUT F FOR NO TEST. SAME COLUMNS. */

  345. /*  cblas_dsyr2k T PUT F FOR NO TEST. SAME COLUMNS. */

  346. 

  347. /*  See: */

  348. 

  349. /*     Dongarra J. J., Du Croz J. J., Duff I. S. and Hammarling S. */

  350. /*     A Set of Level 3 Basic Linear Algebra Subprograms. */

  351. 

  352. /*     Technical Memorandum No.88 (Revision 1), Mathematics and */

  353. /*     Computer Science Division, Argonne National Laboratory, 9700 */

  354. /*     South Cass Avenue, Argonne, Illinois 60439, US. */

  355. 

  356. /*  -- Written on 8-February-1989. */

  357. /*     Jack Dongarra, Argonne National Laboratory. */

  358. /*     Iain Duff, AERE Harwell. */

  359. /*     Jeremy Du Croz, Numerical Algorithms Group Ltd. */

  360. /*     Sven Hammarling, Numerical Algorithms Group Ltd. */

  361. 

  362. /*     .. Parameters .. */

  363. /*     .. Local Scalars .. */

  364. /*     .. Local Arrays .. */

  365. /*     .. External Functions .. */

  366. /*     .. External Subroutines .. */

  367. /*     .. Intrinsic Functions .. */

  368. /*     .. Scalars in Common .. */

  369. /*     .. Common blocks .. */

  370. /*     .. Data statements .. */

  371. /*     .. Executable Statements .. */

  372. 

  373. /*     Read name and unit number for summary output file and open file. */

  374. 

  375.     infoc_1.noutc = 6;

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

  377. 

  378.     char line[80];

  379.     

  380.     fgets(line,80,stdin);

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

  382.     fgets(line,80,stdin);

  383. #ifdef USE64BITINT

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

  385. #else

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

  387. #endif

  388.     trace = ntra >= 0;

  389.     if (trace) {

  390. /*	o__1.oerr = 0;

  391. 	o__1.ounit = ntra;

  392. 	o__1.ofnmlen = 32;

  393. 	o__1.ofnm = snaps;

  394. 	o__1.orl = 0;

  395. 	o__1.osta = "NEW";

  396. 	o__1.oacc = 0;

  397. 	o__1.ofm = 0;

  398. 	o__1.oblnk = 0;

  399. 	f_open(&o__1);*/

  400.     }

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

  402.    fgets(line,80,stdin);

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

  404.    rewi = rewi && trace;

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

  406.    fgets(line,80,stdin);

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

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

  409.    sfatal=FALSE_;

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

  411.    fgets(line,80,stdin);

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

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

  414.    tsterr=FALSE_;

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

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

  417.    fgets(line,80,stdin);

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

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

  420.    fgets(line,80,stdin);

  421.    sscanf(line,"%lf",&thresh);

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

  423. 

  424. /*     Values of N */

  425.    fgets(line,80,stdin);

  426. #ifdef USE64BITINT

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

  428. #else

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

  430. #endif

  431. 

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

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

  434.         goto L220;

  435.     }

  436.    fgets(line,80,stdin);

  437. #ifdef USE64BITINT

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

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

  440. #else

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

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

  443. #endif

  444.     i__1 = nidim;

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

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

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

  448.             goto L220;

  449.         }

  450. /* L10: */

  451.     }

  452. /*     Values of ALPHA */

  453.    fgets(line,80,stdin);

  454. #ifdef USE64BITINT

  455.    sscanf(line,"%ld",&nalf);

  456. #else

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

  458. #endif

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

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

  461.         goto L220;

  462.     }

  463.    fgets(line,80,stdin);

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

  465. 

  466. /*     Values of BETA */

  467.    fgets(line,80,stdin);

  468. #ifdef USE64BITINT

  469.    sscanf(line,"%ld",&nbet);

  470. #else

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

  472. #endif

  473.     if (nalf < 1 || nbet > 7) {

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

  475.         goto L220;

  476.     }

  477.    fgets(line,80,stdin);

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

  479. 

  480. /*     Report values of parameters. */

  481. 

  482.     printf("TESTS OF THE DOUBLE PRECISION LEVEL 3 BLAS\nTHE FOLLOWING PARAMETER VALUES WILL BE USED:\n");

  483.     printf(" FOR N");

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

  485.     printf("\n");    

  486.     printf(" FOR ALPHA");

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

  488.     printf("\n");    

  489.     printf(" FOR BETA");

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

  491.     printf("\n");    

  492. 

  493.     if (! tsterr) {

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

  495.     }

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

  497. 

  498.     rorder = FALSE_;

  499.     corder = FALSE_;

  500.     if (layout == 2) {

  501. 	rorder = TRUE_;

  502. 	corder = TRUE_;

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

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

  505. 	rorder = TRUE_;

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

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

  508. 	corder = TRUE_;

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

  510.     }

  511. 

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

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

  514. 

  515.     for (i__ = 1; i__ <= 6; ++i__) {

  516. 	ltest[i__ - 1] = FALSE_;

  517. /* L20: */

  518.     }

  519. L30:

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

  521.         goto L60;

  522.     }

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

  524.    ltestt=FALSE_;

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

  526.     if (i__1 < 2) {

  527.         goto L60;

  528.     }

  529.     for (i__ = 1; i__ <= 6; ++i__) {

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

  531.                 0) {

  532.             goto L50;

  533.         }

  534. /* L40: */

  535.     }

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

  537.     exit(1);

  538. 

  539. 

  540. L50:

  541.     ltest[i__ - 1] = ltestt;

  542.     goto L30;

  543. 

  544. L60:

  545. /*    cl__1.cerr = 0;

  546.     cl__1.cunit = 5;

  547.     cl__1.csta = 0;

  548.     f_clos(&cl__1);*/

  549. 

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

  551. 

  552.     eps = 1.;

  553. L70:

  554.     d__1 = eps + 1.;

  555.     if (ddiff_(&d__1, &c_b90) == 0.) {

  556. 	goto L80;

  557.     }

  558.     eps *= .5;

  559.     goto L70;

  560. L80:

  561.     eps += eps;

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

  563. 

  564. /*     Check the reliability of DMMCH using exact data. */

  565. 

  566.     n = 32;

  567.     i__1 = n;

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

  569. 	i__2 = n;

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

  571. /* Computing MAX */

  572. 	    i__3 = i__ - j + 1;

  573. 	    ab[i__ + j * 65 - 66] = (doublereal) f2cmax(i__3,0);

  574. /* L90: */

  575. 	}

  576. 	ab[j + 4224] = (doublereal) j;

  577. 	ab[(j + 65) * 65 - 65] = (doublereal) j;

  578. 	c__[j - 1] = 0.;

  579. /* L100: */

  580.     }

  581.     i__1 = n;

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

  583. 	cc[j - 1] = (doublereal) (j * ((j + 1) * j) / 2 - (j + 1) * j * (j - 

  584. 		1) / 3);

  585. /* L110: */

  586.     }

  587. /*     CC holds the exact result. On exit from DMMCH CT holds */

  588. /*     the result computed by DMMCH. */

  589.     *(unsigned char *)transa = 'N';

  590.     *(unsigned char *)transb = 'N';

  591.     dmmch_(transa, transb, &n, &c__1, &n, &c_b90, ab, &c__65, &ab[4225], &

  592. 	    c__65, &c_b104, c__, &c__65, ct, g, cc, &c__65, &eps, &err, &

  593. 	    fatal, &c__6, &c_true, (ftnlen)1, (ftnlen)1);

  594.     same = lde_(cc, ct, &n);

  595.     if (! same || err != 0.) {

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

  597.       printf("DMMCH WAS CALLED WITH TRANSA = %s AND TRANSB = %s\n", transa,transb);

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

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

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

  601.       exit(1);

  602.     }

  603.     *(unsigned char *)transb = 'T';

  604.     dmmch_(transa, transb, &n, &c__1, &n, &c_b90, ab, &c__65, &ab[4225], &

  605. 	    c__65, &c_b104, c__, &c__65, ct, g, cc, &c__65, &eps, &err, &

  606. 	    fatal, &c__6, &c_true, (ftnlen)1, (ftnlen)1);

  607.     same = lde_(cc, ct, &n);

  608.     if (! same || err != 0.) {

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

  610.       printf("DMMCH WAS CALLED WITH TRANSA = %s AND TRANSB = %s\n", transa,transb);

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

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

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

  614.       exit(1);

  615.     }

  616.     i__1 = n;

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

  618. 	ab[j + 4224] = (doublereal) (n - j + 1);

  619. 	ab[(j + 65) * 65 - 65] = (doublereal) (n - j + 1);

  620. /* L120: */

  621.     }

  622.     i__1 = n;

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

  624. 	cc[n - j] = (doublereal) (j * ((j + 1) * j) / 2 - (j + 1) * j * (j - 

  625. 		1) / 3);

  626. /* L130: */

  627.     }

  628.     *(unsigned char *)transa = 'T';

  629.     *(unsigned char *)transb = 'N';

  630.     dmmch_(transa, transb, &n, &c__1, &n, &c_b90, ab, &c__65, &ab[4225], &

  631. 	    c__65, &c_b104, c__, &c__65, ct, g, cc, &c__65, &eps, &err, &

  632. 	    fatal, &c__6, &c_true, (ftnlen)1, (ftnlen)1);

  633.     same = lde_(cc, ct, &n);

  634.     if (! same || err != 0.) {

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

  636.       printf("DMMCH WAS CALLED WITH TRANSA = %s AND TRANSB = %s\n", transa,transb);

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

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

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

  640.       exit(1);

  641.     }

  642.     *(unsigned char *)transb = 'T';

  643.     dmmch_(transa, transb, &n, &c__1, &n, &c_b90, ab, &c__65, &ab[4225], &

  644. 	    c__65, &c_b104, c__, &c__65, ct, g, cc, &c__65, &eps, &err, &

  645. 	    fatal, &c__6, &c_true, (ftnlen)1, (ftnlen)1);

  646.     same = lde_(cc, ct, &n);

  647.     if (! same || err != 0.) {

  648.     }

  649. 

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

  651. 

  652.     for (isnum = 1; isnum <= 6; ++isnum) {

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

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

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

  656. 	} else {

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

  658. 		    ftnlen)12);

  659. /*           Test error exits. */

  660. 	    if (tsterr) {

  661. 		cd3chke_(snames[isnum - 1], (ftnlen)12);

  662. 	    }

  663. /*           Test computations. */

  664. 	    infoc_1.infot = 0;

  665. 	    infoc_1.ok = TRUE_;

  666. 	    fatal = FALSE_;

  667. 	    switch ((int)isnum) {

  668. 		case 1:  goto L140;

  669. 		case 2:  goto L150;

  670. 		case 3:  goto L160;

  671. 		case 4:  goto L160;

  672. 		case 5:  goto L170;

  673. 		case 6:  goto L180;

  674. 	    }

  675. /*           Test DGEMM, 01. */

  676. L140:

  677. 	    if (corder) {

  678. 		dchk1_(snames[isnum - 1], &eps, &thresh, &c__6, &ntra,

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

  680. 			nbet, bet, &c__65, ab, aa, as, &ab[4225], bb, bs, c__,

  681. 			 cc, cs, ct, g, &c__0, (ftnlen)12);

  682. 	    }

  683. 	    if (rorder) {

  684. 		dchk1_(snames[isnum - 1], &eps, &thresh, &c__6, &ntra,

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

  686. 			nbet, bet, &c__65, ab, aa, as, &ab[4225], bb, bs, c__,

  687. 			 cc, cs, ct, g, &c__1, (ftnlen)12);

  688. 	    }

  689. 	    goto L190;

  690. /*           Test DSYMM, 02. */

  691. L150:

  692. 	    if (corder) {

  693. 		dchk2_(snames[isnum - 1], &eps, &thresh, &c__6, &ntra,

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

  695. 			nbet, bet, &c__65, ab, aa, as, &ab[4225], bb, bs, c__,

  696. 			 cc, cs, ct, g, &c__0, (ftnlen)12);

  697. 	    }

  698. 	    if (rorder) {

  699. 		dchk2_(snames[isnum - 1], &eps, &thresh, &c__6, &ntra,

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

  701. 			nbet, bet, &c__65, ab, aa, as, &ab[4225], bb, bs, c__,

  702. 			 cc, cs, ct, g, &c__1, (ftnlen)12);

  703. 	    }

  704. 	    goto L190;

  705. /*           Test DTRMM, 03, DTRSM, 04. */

  706. L160:

  707. 	    if (corder) {

  708. 		dchk3_(snames[isnum - 1], &eps, &thresh, &c__6, &ntra,

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

  710. 			c__65, ab, aa, as, &ab[4225], bb, bs, ct, g, c__, &

  711. 			c__0, (ftnlen)12);

  712. 	    }

  713. 	    if (rorder) {

  714. 		dchk3_(snames[isnum - 1], &eps, &thresh, &c__6, &ntra,

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

  716. 			c__65, ab, aa, as, &ab[4225], bb, bs, ct, g, c__, &

  717. 			c__1, (ftnlen)12);

  718. 	    }

  719. 	    goto L190;

  720. /*           Test DSYRK, 05. */

  721. L170:

  722. 	    if (corder) {

  723. 		dchk4_(snames[isnum -1], &eps, &thresh, &c__6, &ntra,

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

  725. 			nbet, bet, &c__65, ab, aa, as, &ab[4225], bb, bs, c__,

  726. 			 cc, cs, ct, g, &c__0, (ftnlen)12);

  727. 	    }

  728. 	    if (rorder) {

  729. 		dchk4_(snames[isnum - 1], &eps, &thresh, &c__6, &ntra,

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

  731. 			nbet, bet, &c__65, ab, aa, as, &ab[4225], bb, bs, c__,

  732. 			 cc, cs, ct, g, &c__1, (ftnlen)12);

  733. 	    }

  734. 	    goto L190;

  735. /*           Test DSYR2K, 06. */

  736. L180:

  737. 	    if (corder) {

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

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

  740. 			nbet, bet, &c__65, ab, aa, as, bb, bs, c__, cc, cs, 

  741. 			ct, g, w, &c__0, (ftnlen)12);

  742. 	    }

  743. 	    if (rorder) {

  744. 		dchk5_(snames[isnum - 1], &eps, &thresh, &c__6, &ntra,

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

  746. 			nbet, bet, &c__65, ab, aa, as, bb, bs, c__, cc, cs, 

  747. 			ct, g, w, &c__1, (ftnlen)12);

  748. 	    }

  749. 	    goto L190;

  750. 

  751. L190:

  752. 	    if (fatal && sfatal) {

  753. 		goto L210;

  754. 	    }

  755. 	}

  756. /* L200: */

  757.     }

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

  759.     goto L230;

  760. 

  761. L210:

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

  763.     goto L230;

  764. 

  765. L220:

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

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

  768. 

  769. L230:

  770.     if (trace) {

  771. /*	cl__1.cerr = 0;

  772. 	cl__1.cunit = ntra;

  773. 	cl__1.csta = 0;

  774. 	f_clos(&cl__1);*/

  775.     }

  776. /*    cl__1.cerr = 0;

  777.     cl__1.cunit = 6;

  778.     cl__1.csta = 0;

  779.     f_clos(&cl__1);*/

  780.     exit(0);

  781. 

  782. /*     End of DBLAT3. */

  783. 

  784. } /* MAIN__ */

  785. 

  786. /* Subroutine */ int dchk1_(char* sname, doublereal* eps, doublereal* thresh, integer* nout, integer* ntra, logical* trace, logical* rewi, logical* fatal, integer* nidim, integer* idim, integer* nalf, doublereal* alf, integer* nbet, doublereal* bet, integer* nmax, doublereal* a, doublereal* aa, doublereal* as, doublereal* b, doublereal* bb, doublereal* bs, doublereal* c__, doublereal* cc, doublereal* cs, doublereal* ct, doublereal* g, integer* iorder, ftnlen sname_len)

  787. {

  788.     /* Initialized data */

  789. 

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

  791. 

  792.     /* System generated locals */

  793.     integer a_dim1, a_offset, b_dim1, b_offset, c_dim1, c_offset, i__1, i__2, 

  794. 	    i__3, i__4, i__5, i__6;

  795. 

  796. 

  797.     /* Local variables */

  798.     static doublereal beta;

  799.     static integer ldas, ldbs, ldcs;

  800.     static logical same, null;

  801.     static integer i__, k, m, n;

  802.     extern /* Subroutine */ int dmake_(char*, char*, char*, integer*, integer*, doublereal*, integer*, doublereal*, integer*, logical*, doublereal*, ftnlen, ftnlen, ftnlen);

  803.     static doublereal alpha;

  804.     extern /* Subroutine */ int dmmch_(char*, char*, integer*, integer*, integer*, doublereal*, doublereal*, integer*, doublereal*, integer*, doublereal*, doublereal*, integer*, doublereal*, doublereal*, doublereal*, integer*, doublereal*, doublereal*, logical*, integer*, logical*, ftnlen, ftnlen);

  805.     static logical isame[13], trana, tranb;

  806.     static integer nargs;

  807.     static logical reset;

  808.     extern /* Subroutine */ void dprcn1_(integer*, integer*, char*, integer*, char*, char*, integer*, integer*, integer*, doublereal*, integer*, integer*, doublereal*, integer*, ftnlen, ftnlen, ftnlen);

  809.     static integer ia, ib, ma, mb, na, nb, nc, ik, im, in;

  810.     extern /* Subroutine */ void cdgemm_(integer*, char*, char*, integer*, integer*, integer*, doublereal*, doublereal*, integer*, doublereal*, integer*, doublereal*, doublereal*, integer*, ftnlen, ftnlen);

  811.     static integer ks, ms, ns;

  812.     extern logical lderes_(char*, char*, integer*, integer*, doublereal*, doublereal*, integer*, ftnlen, ftnlen);

  813.     static char tranas[1], tranbs[1], transa[1], transb[1];

  814.     static doublereal errmax;

  815.     static integer ica, icb, laa, lbb, lda, lcc, ldb, ldc;

  816.     extern logical lde_(doublereal*, doublereal*, integer*);

  817.     static doublereal als, bls, err;

  818. 

  819. /*  Tests DGEMM. */

  820. 

  821. /*  Auxiliary routine for test program for Level 3 Blas. */

  822. 

  823. /*  -- Written on 8-February-1989. */

  824. /*     Jack Dongarra, Argonne National Laboratory. */

  825. /*     Iain Duff, AERE Harwell. */

  826. /*     Jeremy Du Croz, Numerical Algorithms Group Ltd. */

  827. /*     Sven Hammarling, Numerical Algorithms Group Ltd. */

  828. 

  829. /*     .. Parameters .. */

  830. /*     .. Scalar Arguments .. */

  831. /*     .. Array Arguments .. */

  832. /*     .. Local Scalars .. */

  833. /*     .. Local Arrays .. */

  834. /*     .. External Functions .. */

  835. /*     .. External Subroutines .. */

  836. /*     .. Intrinsic Functions .. */

  837. /*     .. Scalars in Common .. */

  838. /*     .. Common blocks .. */

  839. /*     .. Data statements .. */

  840.     /* Parameter adjustments */

  841.     --idim;

  842.     --alf;

  843.     --bet;

  844.     --g;

  845.     --ct;

  846.     --cs;

  847.     --cc;

  848.     c_dim1 = *nmax;

  849.     c_offset = 1 + c_dim1 * 1;

  850.     c__ -= c_offset;

  851.     --bs;

  852.     --bb;

  853.     b_dim1 = *nmax;

  854.     b_offset = 1 + b_dim1 * 1;

  855.     b -= b_offset;

  856.     --as;

  857.     --aa;

  858.     a_dim1 = *nmax;

  859.     a_offset = 1 + a_dim1 * 1;

  860.     a -= a_offset;

  861. 

  862.     /* Function Body */

  863. /*     .. Executable Statements .. */

  864. 

  865.     nargs = 13;

  866.     nc = 0;

  867.     reset = TRUE_;

  868.     errmax = 0.;

  869. 

  870.     i__1 = *nidim;

  871.     for (im = 1; im <= i__1; ++im) {

  872. 	m = idim[im];

  873. 

  874. 	i__2 = *nidim;

  875. 	for (in = 1; in <= i__2; ++in) {

  876. 	    n = idim[in];

  877. /*           Set LDC to 1 more than minimum value if room. */

  878. 	    ldc = m;

  879. 	    if (ldc < *nmax) {

  880. 		++ldc;

  881. 	    }

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

  883. 	    if (ldc > *nmax) {

  884. 		goto L100;

  885. 	    }

  886. 	    lcc = ldc * n;

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

  888. 

  889. 	    i__3 = *nidim;

  890. 	    for (ik = 1; ik <= i__3; ++ik) {

  891. 		k = idim[ik];

  892. 

  893. 		for (ica = 1; ica <= 3; ++ica) {

  894. 		    *(unsigned char *)transa = *(unsigned char *)&ich[ica - 1]

  895. 			    ;

  896. 		    trana = *(unsigned char *)transa == 'T' || *(unsigned 

  897. 			    char *)transa == 'C';

  898. 

  899. 		    if (trana) {

  900. 			ma = k;

  901. 			na = m;

  902. 		    } else {

  903. 			ma = m;

  904. 			na = k;

  905. 		    }

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

  907. 		    lda = ma;

  908. 		    if (lda < *nmax) {

  909. 			++lda;

  910. 		    }

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

  912. 		    if (lda > *nmax) {

  913. 			goto L80;

  914. 		    }

  915. 		    laa = lda * na;

  916. 

  917. /*                 Generate the matrix A. */

  918. 

  919. 		    dmake_("GE", " ", " ", &ma, &na, &a[a_offset], nmax, &aa[

  920. 			    1], &lda, &reset, &c_b104, (ftnlen)2, (ftnlen)1, (

  921. 			    ftnlen)1);

  922. 

  923. 		    for (icb = 1; icb <= 3; ++icb) {

  924. 			*(unsigned char *)transb = *(unsigned char *)&ich[icb 

  925. 				- 1];

  926. 			tranb = *(unsigned char *)transb == 'T' || *(unsigned 

  927. 				char *)transb == 'C';

  928. 

  929. 			if (tranb) {

  930. 			    mb = n;

  931. 			    nb = k;

  932. 			} else {

  933. 			    mb = k;

  934. 			    nb = n;

  935. 			}

  936. /*                    Set LDB to 1 more than minimum value if room. */

  937. 			ldb = mb;

  938. 			if (ldb < *nmax) {

  939. 			    ++ldb;

  940. 			}

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

  942. 			if (ldb > *nmax) {

  943. 			    goto L70;

  944. 			}

  945. 			lbb = ldb * nb;

  946. 

  947. /*                    Generate the matrix B. */

  948. 

  949. 			dmake_("GE", " ", " ", &mb, &nb, &b[b_offset], nmax, &

  950. 				bb[1], &ldb, &reset, &c_b104, (ftnlen)2, (

  951. 				ftnlen)1, (ftnlen)1);

  952. 

  953. 			i__4 = *nalf;

  954. 			for (ia = 1; ia <= i__4; ++ia) {

  955. 			    alpha = alf[ia];

  956. 

  957. 			    i__5 = *nbet;

  958. 			    for (ib = 1; ib <= i__5; ++ib) {

  959. 				beta = bet[ib];

  960. 

  961. /*                          Generate the matrix C. */

  962. 

  963. 				dmake_("GE", " ", " ", &m, &n, &c__[c_offset],

  964. 					 nmax, &cc[1], &ldc, &reset, &c_b104, 

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

  966. 

  967. 				++nc;

  968. 

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

  970. /*                          subroutine. */

  971. 

  972. 				*(unsigned char *)tranas = *(unsigned char *)

  973. 					transa;

  974. 				*(unsigned char *)tranbs = *(unsigned char *)

  975. 					transb;

  976. 				ms = m;

  977. 				ns = n;

  978. 				ks = k;

  979. 				als = alpha;

  980. 				i__6 = laa;

  981. 				for (i__ = 1; i__ <= i__6; ++i__) {

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

  983. /* L10: */

  984. 				}

  985. 				ldas = lda;

  986. 				i__6 = lbb;

  987. 				for (i__ = 1; i__ <= i__6; ++i__) {

  988. 				    bs[i__] = bb[i__];

  989. /* L20: */

  990. 				}

  991. 				ldbs = ldb;

  992. 				bls = beta;

  993. 				i__6 = lcc;

  994. 				for (i__ = 1; i__ <= i__6; ++i__) {

  995. 				    cs[i__] = cc[i__];

  996. /* L30: */

  997. 				}

  998. 				ldcs = ldc;

  999. 

  1000. /*                          Call the subroutine. */

  1001. 

  1002. 				if (*trace) {

  1003. 				    dprcn1_(ntra, &nc, sname, iorder, transa, 

  1004. 					    transb, &m, &n, &k, &alpha, &lda, 

  1005. 					    &ldb, &beta, &ldc, (ftnlen)12, (

  1006. 					    ftnlen)1, (ftnlen)1);

  1007. 				}

  1008. 				if (*rewi) {

  1009. /*				    al__1.aerr = 0;

  1010. 				    al__1.aunit = *ntra;

  1011. 				    f_rew(&al__1);*/

  1012. 				}

  1013. 				cdgemm_(iorder, transa, transb, &m, &n, &k, &

  1014. 					alpha, &aa[1], &lda, &bb[1], &ldb, &

  1015. 					beta, &cc[1], &ldc, (ftnlen)1, (

  1016. 					ftnlen)1);

  1017. 

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

  1019. 

  1020. 				if (! infoc_1.ok) {

  1021.                                     printf(" *** FATAL ERROR - ERROR-CALL MYEXIT TAKEN ON VALID CALL\n");

  1022. 				    *fatal = TRUE_;

  1023. 				    goto L120;

  1024. 				}

  1025. 

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

  1027. 

  1028. 				isame[0] = *(unsigned char *)transa == *(

  1029. 					unsigned char *)tranas;

  1030. 				isame[1] = *(unsigned char *)transb == *(

  1031. 					unsigned char *)tranbs;

  1032. 				isame[2] = ms == m;

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

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

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

  1036. 				isame[6] = lde_(&as[1], &aa[1], &laa);

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

  1038. 				isame[8] = lde_(&bs[1], &bb[1], &lbb);

  1039. 				isame[9] = ldbs == ldb;

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

  1041. 				if (null) {

  1042. 				    isame[11] = lde_(&cs[1], &cc[1], &lcc);

  1043. 				} else {

  1044. 				    isame[11] = lderes_("GE", " ", &m, &n, &

  1045. 					    cs[1], &cc[1], &ldc, (ftnlen)2, (

  1046. 					    ftnlen)1);

  1047. 				}

  1048. 				isame[12] = ldcs == ldc;

  1049. 

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

  1051. /*                          and return. */

  1052. 

  1053. 				same = TRUE_;

  1054. 				i__6 = nargs;

  1055. 				for (i__ = 1; i__ <= i__6; ++i__) {

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

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

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

  1059. 				    }

  1060. /* L40: */

  1061. 				}

  1062. 				if (! same) {

  1063. 				    *fatal = TRUE_;

  1064. 				    goto L120;

  1065. 				}

  1066. 

  1067. 				if (! null) {

  1068. 

  1069. /*                             Check the result. */

  1070. 

  1071. 				    dmmch_(transa, transb, &m, &n, &k, &alpha,

  1072. 					     &a[a_offset], nmax, &b[b_offset],

  1073. 					     nmax, &beta, &c__[c_offset], 

  1074. 					    nmax, &ct[1], &g[1], &cc[1], &ldc,

  1075. 					     eps, &err, fatal, nout, &c_true, 

  1076. 					    (ftnlen)1, (ftnlen)1);

  1077. 				    errmax = f2cmax(errmax,err);

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

  1079. /*                             return. */

  1080. 				    if (*fatal) {

  1081. 					goto L120;

  1082. 				    }

  1083. 				}

  1084. 

  1085. /* L50: */

  1086. 			    }

  1087. 

  1088. /* L60: */

  1089. 			}

  1090. 

  1091. L70:

  1092. 			;

  1093. 		    }

  1094. 

  1095. L80:

  1096. 		    ;

  1097. 		}

  1098. 

  1099. /* L90: */

  1100. 	    }

  1101. 

  1102. L100:

  1103. 	    ;

  1104. 	}

  1105. 

  1106. /* L110: */

  1107.     }

  1108. 

  1109. /*     Report result. */

  1110. 

  1111.     if (errmax < *thresh) {

  1112. 	if (*iorder == 0) {

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

  1114. 	}

  1115. 	if (*iorder == 1) {

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

  1117. 	}

  1118.     } else {

  1119. 	if (*iorder == 0) {

  1120.             printf("%s COMPLETED THE COLUMN-MAJOR COMPUTATIONAL TESTS (%d CALLS)/n",sname,nc);

  1121.             printf("***** BUT WITH MAXIMUM TEST RATIO %8.2f - SUSPECT *******/n",errmax);

  1122. 	}

  1123. 	if (*iorder == 1) {

  1124.             printf("%s COMPLETED THE ROW-MAJOR COMPUTATIONAL TESTS (%d CALLS)/n",sname,nc);

  1125.             printf("***** BUT WITH MAXIMUM TEST RATIO %8.2f - SUSPECT *******/n",errmax);

  1126. 	}

  1127.     }

  1128.     goto L130;

  1129. 

  1130. L120:

  1131.     printf(" ******* %s FAILED ON CALL NUMBER:\n",sname);

  1132.     dprcn1_(nout, &nc, sname, iorder, transa, transb, &m, &n, &k, &alpha, &

  1133. 	    lda, &ldb, &beta, &ldc, (ftnlen)12, (ftnlen)1, (ftnlen)1);

  1134. 

  1135. L130:

  1136.     return 0;

  1137. 

  1138. /* 9995 FORMAT( 1X, I6, ': ', A12,'(''', A1, ''',''', A1, ''',', */

  1139. /*     $      3( I3, ',' ), F4.1, ', A,', I3, ', B,', I3, ',', F4.1, ', ', */

  1140. /*     $      'C,', I3, ').' ) */

  1141. 

  1142. /*     End of DCHK1. */

  1143. 

  1144. } /* dchk1_ */

  1145. 

  1146. /* Subroutine */ void dprcn1_(integer* nout, integer* nc, char* sname, integer* iorder, char* transa, char* transb, integer* m, integer* n, integer* k, doublereal* alpha, integer* lda, integer* ldb, doublereal* beta, integer* ldc, ftnlen sname_len, ftnlen transa_len, ftnlen transb_len)

  1147. {

  1148. 

  1149.     /* Local variables */

  1150.     static char crc[14], cta[14], ctb[14];

  1151. 

  1152.     if (*(unsigned char *)transa == 'N') {

  1153. 	s_copy(cta, "  CblasNoTrans", (ftnlen)14, (ftnlen)14);

  1154.     } else if (*(unsigned char *)transa == 'T') {

  1155. 	s_copy(cta, "    CblasTrans", (ftnlen)14, (ftnlen)14);

  1156.     } else {

  1157. 	s_copy(cta, "CblasConjTrans", (ftnlen)14, (ftnlen)14);

  1158.     }

  1159.     if (*(unsigned char *)transb == 'N') {

  1160. 	s_copy(ctb, "  CblasNoTrans", (ftnlen)14, (ftnlen)14);

  1161.     } else if (*(unsigned char *)transb == 'T') {

  1162. 	s_copy(ctb, "    CblasTrans", (ftnlen)14, (ftnlen)14);

  1163.     } else {

  1164. 	s_copy(ctb, "CblasConjTrans", (ftnlen)14, (ftnlen)14);

  1165.     }

  1166.     if (*iorder == 1) {

  1167. 	s_copy(crc, " CblasRowMajor", (ftnlen)14, (ftnlen)14);

  1168.     } else {

  1169. 	s_copy(crc, " CblasColMajor", (ftnlen)14, (ftnlen)14);

  1170.     }

  1171.     printf("%6d: %s %s %s %s\n",*nc,sname,crc,cta,ctb);

  1172.     printf("%d %d %d %4.1f A, %d, B, %d, %4.1f, C, %d.\n",*m,*n,*k,*alpha,*lda,*ldb,*beta,*ldc);

  1173. } /* dprcn1_ */

  1174. 

  1175. 

  1176. /* Subroutine */ int dchk2_(char* sname, doublereal* eps, doublereal* thresh, integer* nout, integer* ntra, logical* trace, logical* rewi, logical* fatal, integer* nidim, integer* idim, integer* nalf, doublereal* alf, integer* nbet, doublereal* bet, integer* nmax, doublereal* a, doublereal* aa, doublereal* as, doublereal* b, doublereal* bb, doublereal* bs, doublereal* c__, doublereal* cc, doublereal* cs, doublereal* ct, doublereal* g, integer* iorder, ftnlen sname_len)

  1177. {

  1178.     /* Initialized data */

  1179. 

  1180.     static char ichs[2+1] = "LR";

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

  1182. 

  1183.     /* System generated locals */

  1184.     integer a_dim1, a_offset, b_dim1, b_offset, c_dim1, c_offset, i__1, i__2, 

  1185. 	    i__3, i__4, i__5;

  1186. 

  1187. 

  1188.     /* Local variables */

  1189.     static doublereal beta;

  1190.     static integer ldas, ldbs, ldcs;

  1191.     static logical same;

  1192.     static char side[1];

  1193.     static logical left, null;

  1194.     static char uplo[1];

  1195.     static integer i__, m, n;

  1196.     extern /* Subroutine */ int dmake_(char*, char*, char*, integer*, integer*, doublereal*, integer*, doublereal*, integer*, logical*, doublereal*, ftnlen, ftnlen, ftnlen);

  1197.     static doublereal alpha;

  1198.     extern /* Subroutine */ int dmmch_(char*, char*, integer*, integer*, integer*, doublereal*, doublereal*, integer*, doublereal*, integer*, doublereal*, doublereal*, integer*, doublereal*, doublereal*, doublereal*, integer*, doublereal*, doublereal*, logical*, integer*, logical*, ftnlen, ftnlen);

  1199.     static logical isame[13];

  1200.     static char sides[1];

  1201.     static integer nargs;

  1202.     static logical reset;

  1203.     static char uplos[1];

  1204.     extern /* Subroutine */ void dprcn2_(integer*, integer*, char*, integer*, char*, char*, integer*, integer*, doublereal*, integer*, integer*, doublereal*, integer*, ftnlen, ftnlen, ftnlen);

  1205.     static integer ia, ib, na, nc, im, in, ms, ns;

  1206.     extern logical lderes_(char*, char*, integer*, integer*, doublereal*, doublereal*, integer*, ftnlen, ftnlen);

  1207.     extern /* Subroutine */ void cdsymm_(integer*, char*, char*, integer*, integer*, doublereal*, doublereal*, integer*, doublereal*, integer*, doublereal*, doublereal*, integer*, ftnlen, ftnlen);

  1208.     static doublereal errmax;

  1209.     static integer laa, lbb, lda, lcc, ldb, ldc;

  1210.     extern logical lde_(doublereal*, doublereal*, integer*);

  1211.     static integer ics;

  1212.     static doublereal als, bls;

  1213.     static integer icu;

  1214.     static doublereal err;

  1215. 

  1216. /*  Tests DSYMM. */

  1217. 

  1218. /*  Auxiliary routine for test program for Level 3 Blas. */

  1219. 

  1220. /*  -- Written on 8-February-1989. */

  1221. /*     Jack Dongarra, Argonne National Laboratory. */

  1222. /*     Iain Duff, AERE Harwell. */

  1223. /*     Jeremy Du Croz, Numerical Algorithms Group Ltd. */

  1224. /*     Sven Hammarling, Numerical Algorithms Group Ltd. */

  1225. 

  1226. /*     .. Parameters .. */

  1227. /*     .. Scalar Arguments .. */

  1228. /*     .. Array Arguments .. */

  1229. /*     .. Local Scalars .. */

  1230. /*     .. Local Arrays .. */

  1231. /*     .. External Functions .. */

  1232. /*     .. External Subroutines .. */

  1233. /*     .. Intrinsic Functions .. */

  1234. /*     .. Scalars in Common .. */

  1235. /*     .. Common blocks .. */

  1236. /*     .. Data statements .. */

  1237.     /* Parameter adjustments */

  1238.     --idim;

  1239.     --alf;

  1240.     --bet;

  1241.     --g;

  1242.     --ct;

  1243.     --cs;

  1244.     --cc;

  1245.     c_dim1 = *nmax;

  1246.     c_offset = 1 + c_dim1 * 1;

  1247.     c__ -= c_offset;

  1248.     --bs;

  1249.     --bb;

  1250.     b_dim1 = *nmax;

  1251.     b_offset = 1 + b_dim1 * 1;

  1252.     b -= b_offset;

  1253.     --as;

  1254.     --aa;

  1255.     a_dim1 = *nmax;

  1256.     a_offset = 1 + a_dim1 * 1;

  1257.     a -= a_offset;

  1258. 

  1259.     /* Function Body */

  1260. /*     .. Executable Statements .. */

  1261. 

  1262.     nargs = 12;

  1263.     nc = 0;

  1264.     reset = TRUE_;

  1265.     errmax = 0.;

  1266. 

  1267.     i__1 = *nidim;

  1268.     for (im = 1; im <= i__1; ++im) {

  1269. 	m = idim[im];

  1270. 

  1271. 	i__2 = *nidim;

  1272. 	for (in = 1; in <= i__2; ++in) {

  1273. 	    n = idim[in];

  1274. /*           Set LDC to 1 more than minimum value if room. */

  1275. 	    ldc = m;

  1276. 	    if (ldc < *nmax) {

  1277. 		++ldc;

  1278. 	    }

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

  1280. 	    if (ldc > *nmax) {

  1281. 		goto L90;

  1282. 	    }

  1283. 	    lcc = ldc * n;

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

  1285. 

  1286. /*           Set LDB to 1 more than minimum value if room. */

  1287. 	    ldb = m;

  1288. 	    if (ldb < *nmax) {

  1289. 		++ldb;

  1290. 	    }

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

  1292. 	    if (ldb > *nmax) {

  1293. 		goto L90;

  1294. 	    }

  1295. 	    lbb = ldb * n;

  1296. 

  1297. /*           Generate the matrix B. */

  1298. 

  1299. 	    dmake_("GE", " ", " ", &m, &n, &b[b_offset], nmax, &bb[1], &ldb, &

  1300. 		    reset, &c_b104, (ftnlen)2, (ftnlen)1, (ftnlen)1);

  1301. 

  1302. 	    for (ics = 1; ics <= 2; ++ics) {

  1303. 		*(unsigned char *)side = *(unsigned char *)&ichs[ics - 1];

  1304. 		left = *(unsigned char *)side == 'L';

  1305. 

  1306. 		if (left) {

  1307. 		    na = m;

  1308. 		} else {

  1309. 		    na = n;

  1310. 		}

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

  1312. 		lda = na;

  1313. 		if (lda < *nmax) {

  1314. 		    ++lda;

  1315. 		}

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

  1317. 		if (lda > *nmax) {

  1318. 		    goto L80;

  1319. 		}

  1320. 		laa = lda * na;

  1321. 

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

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

  1324. 

  1325. /*                 Generate the symmetric matrix A. */

  1326. 

  1327. 		    dmake_("SY", uplo, " ", &na, &na, &a[a_offset], nmax, &aa[

  1328. 			    1], &lda, &reset, &c_b104, (ftnlen)2, (ftnlen)1, (

  1329. 			    ftnlen)1);

  1330. 

  1331. 		    i__3 = *nalf;

  1332. 		    for (ia = 1; ia <= i__3; ++ia) {

  1333. 			alpha = alf[ia];

  1334. 

  1335. 			i__4 = *nbet;

  1336. 			for (ib = 1; ib <= i__4; ++ib) {

  1337. 			    beta = bet[ib];

  1338. 

  1339. /*                       Generate the matrix C. */

  1340. 

  1341. 			    dmake_("GE", " ", " ", &m, &n, &c__[c_offset], 

  1342. 				    nmax, &cc[1], &ldc, &reset, &c_b104, (

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

  1344. 

  1345. 			    ++nc;

  1346. 

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

  1348. /*                       subroutine. */

  1349. 

  1350. 			    *(unsigned char *)sides = *(unsigned char *)side;

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

  1352. 			    ms = m;

  1353. 			    ns = n;

  1354. 			    als = alpha;

  1355. 			    i__5 = laa;

  1356. 			    for (i__ = 1; i__ <= i__5; ++i__) {

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

  1358. /* L10: */

  1359. 			    }

  1360. 			    ldas = lda;

  1361. 			    i__5 = lbb;

  1362. 			    for (i__ = 1; i__ <= i__5; ++i__) {

  1363. 				bs[i__] = bb[i__];

  1364. /* L20: */

  1365. 			    }

  1366. 			    ldbs = ldb;

  1367. 			    bls = beta;

  1368. 			    i__5 = lcc;

  1369. 			    for (i__ = 1; i__ <= i__5; ++i__) {

  1370. 				cs[i__] = cc[i__];

  1371. /* L30: */

  1372. 			    }

  1373. 			    ldcs = ldc;

  1374. 

  1375. /*                       Call the subroutine. */

  1376. 

  1377. 			    if (*trace) {

  1378. 				dprcn2_(ntra, &nc, sname, iorder, side, uplo, 

  1379. 					&m, &n, &alpha, &lda, &ldb, &beta, &

  1380. 					ldc, (ftnlen)12, (ftnlen)1, (ftnlen)1)

  1381. 					;

  1382. 			    }

  1383. 			    if (*rewi) {

  1384. /*				al__1.aerr = 0;

  1385. 				al__1.aunit = *ntra;

  1386. 				f_rew(&al__1);*/

  1387. 			    }

  1388. 			    cdsymm_(iorder, side, uplo, &m, &n, &alpha, &aa[1]

  1389. 				    , &lda, &bb[1], &ldb, &beta, &cc[1], &ldc,

  1390. 				     (ftnlen)1, (ftnlen)1);

  1391. 

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

  1393. 

  1394. 			    if (! infoc_1.ok) {

  1395.                                 printf("*** FATAL ERROR - ERROR-CALL MYEXIT TAKEN ON VALID CALL\n");

  1396. 				*fatal = TRUE_;

  1397. 				goto L110;

  1398. 			    }

  1399. 

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

  1401. 

  1402. 			    isame[0] = *(unsigned char *)sides == *(unsigned 

  1403. 				    char *)side;

  1404. 			    isame[1] = *(unsigned char *)uplos == *(unsigned 

  1405. 				    char *)uplo;

  1406. 			    isame[2] = ms == m;

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

  1408. 			    isame[4] = als == alpha;

  1409. 			    isame[5] = lde_(&as[1], &aa[1], &laa);

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

  1411. 			    isame[7] = lde_(&bs[1], &bb[1], &lbb);

  1412. 			    isame[8] = ldbs == ldb;

  1413. 			    isame[9] = bls == beta;

  1414. 			    if (null) {

  1415. 				isame[10] = lde_(&cs[1], &cc[1], &lcc);

  1416. 			    } else {

  1417. 				isame[10] = lderes_("GE", " ", &m, &n, &cs[1],

  1418. 					 &cc[1], &ldc, (ftnlen)2, (ftnlen)1);

  1419. 			    }

  1420. 			    isame[11] = ldcs == ldc;

  1421. 

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

  1423. /*                       return. */

  1424. 

  1425. 			    same = TRUE_;

  1426. 			    i__5 = nargs;

  1427. 			    for (i__ = 1; i__ <= i__5; ++i__) {

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

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

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

  1431. 				}

  1432. /* L40: */

  1433. 			    }

  1434. 			    if (! same) {

  1435. 				*fatal = TRUE_;

  1436. 				goto L110;

  1437. 			    }

  1438. 

  1439. 			    if (! null) {

  1440. 

  1441. /*                          Check the result. */

  1442. 

  1443. 				if (left) {

  1444. 				    dmmch_("N", "N", &m, &n, &m, &alpha, &a[

  1445. 					    a_offset], nmax, &b[b_offset], 

  1446. 					    nmax, &beta, &c__[c_offset], nmax,

  1447. 					     &ct[1], &g[1], &cc[1], &ldc, eps,

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

  1449. 					    ftnlen)1, (ftnlen)1);

  1450. 				} else {

  1451. 				    dmmch_("N", "N", &m, &n, &n, &alpha, &b[

  1452. 					    b_offset], nmax, &a[a_offset], 

  1453. 					    nmax, &beta, &c__[c_offset], nmax,

  1454. 					     &ct[1], &g[1], &cc[1], &ldc, eps,

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

  1456. 					    ftnlen)1, (ftnlen)1);

  1457. 				}

  1458. 				errmax = f2cmax(errmax,err);

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

  1460. /*                          return. */

  1461. 				if (*fatal) {

  1462. 				    goto L110;

  1463. 				}

  1464. 			    }

  1465. 

  1466. /* L50: */

  1467. 			}

  1468. 

  1469. /* L60: */

  1470. 		    }

  1471. 

  1472. /* L70: */

  1473. 		}

  1474. 

  1475. L80:

  1476. 		;

  1477. 	    }

  1478. 

  1479. L90:

  1480. 	    ;

  1481. 	}

  1482. 

  1483. /* L100: */

  1484.     }

  1485. 

  1486. /*     Report result. */

  1487. 

  1488.     if (errmax < *thresh) {

  1489. 	if (*iorder == 0) {

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

  1491. 	}

  1492. 	if (*iorder == 1) {

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

  1494. 	}

  1495.     } else {

  1496. 	if (*iorder == 0) {

  1497.             printf("%s COMPLETED THE COLUMN-MAJOR COMPUTATIONAL TESTS (%d CALLS)/n",sname,nc);

  1498.             printf("***** BUT WITH MAXIMUM TEST RATIO %8.2f - SUSPECT *******/n",errmax);

  1499. 	}

  1500. 	if (*iorder == 1) {

  1501.             printf("%s COMPLETED THE ROW-MAJOR COMPUTATIONAL TESTS (%d CALLS)/n",sname,nc);

  1502.             printf("***** BUT WITH MAXIMUM TEST RATIO %8.2f - SUSPECT *******/n",errmax);

  1503. 	}

  1504.     }

  1505.     goto L120;

  1506. 

  1507. L110:

  1508.     printf(" ******* %s FAILED ON CALL NUMBER:\n",sname);

  1509.     dprcn2_(nout, &nc, sname, iorder, side, uplo, &m, &n, &alpha, &lda, &ldb, 

  1510. 	    &beta, &ldc, (ftnlen)12, (ftnlen)1, (ftnlen)1);

  1511. 

  1512. L120:

  1513.     return 0;

  1514. 

  1515. /* 9995 FORMAT( 1X, I6, ': ', A12,'(', 2( '''', A1, ''',' ), 2( I3, ',' ), */

  1516. /*     $      F4.1, ', A,', I3, ', B,', I3, ',', F4.1, ', C,', I3, ')   ', */

  1517. /*     $      ' .' ) */

  1518. 

  1519. /*     End of DCHK2. */

  1520. 

  1521. } /* dchk2_ */

  1522. 

  1523. 

  1524. /* Subroutine */ void dprcn2_(integer* nout, integer* nc, char* sname, integer* iorder, char* side, char* uplo, integer* m, integer* n, doublereal* alpha, integer* lda, integer* ldb, doublereal* beta, integer* ldc, ftnlen sname_len, ftnlen side_len, ftnlen uplo_len)

  1525. {

  1526. 

  1527.     /* Local variables */

  1528.     static char cs[14], cu[14], crc[14];

  1529. 

  1530.     if (*(unsigned char *)side == 'L') {

  1531. 	s_copy(cs, "     CblasLeft", (ftnlen)14, (ftnlen)14);

  1532.     } else {

  1533. 	s_copy(cs, "    CblasRight", (ftnlen)14, (ftnlen)14);

  1534.     }

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

  1536. 	s_copy(cu, "    CblasUpper", (ftnlen)14, (ftnlen)14);

  1537.     } else {

  1538. 	s_copy(cu, "    CblasLower", (ftnlen)14, (ftnlen)14);

  1539.     }

  1540.     if (*iorder == 1) {

  1541. 	s_copy(crc, " CblasRowMajor", (ftnlen)14, (ftnlen)14);

  1542.     } else {

  1543. 	s_copy(crc, " CblasColMajor", (ftnlen)14, (ftnlen)14);

  1544.     }

  1545.     printf("%6d: %s %s %s %s\n",*nc,sname,crc,cs,cu);

  1546.     printf("%d %d %4.1f A, %d, B, %d, %4.1f C, %d.\n",*m,*n,*alpha,*lda,*ldb,*beta,*ldc);

  1547. } /* dprcn2_ */

  1548. 

  1549. 

  1550. /* Subroutine */ int dchk3_(char* sname, doublereal* eps, doublereal* thresh, integer* nout, integer* ntra, logical* trace, logical* rewi, logical* fatal, integer* nidim, integer* idim, integer* nalf, doublereal* alf, integer* nmax, doublereal* a, doublereal* aa, doublereal* as, doublereal* b, doublereal* bb, doublereal* bs, doublereal* ct, doublereal* g, doublereal* c__, integer* iorder, ftnlen sname_len)

  1551. {

  1552.     /* Initialized data */

  1553. 

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

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

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

  1557.     static char ichs[2+1] = "LR";

  1558. 

  1559.     /* System generated locals */

  1560.     integer a_dim1, a_offset, b_dim1, b_offset, c_dim1, c_offset, i__1, i__2, 

  1561. 	    i__3, i__4, i__5;

  1562. 

  1563.     /* Local variables */

  1564.     static char diag[1];

  1565.     static integer ldas, ldbs;

  1566.     static logical same;

  1567.     static char side[1];

  1568.     static logical left, null;

  1569.     static char uplo[1];

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

  1571.     extern /* Subroutine */ int dmake_(char*, char*, char*, integer*, integer*, doublereal*, integer*, doublereal*, integer*, logical*, doublereal*, ftnlen, ftnlen, ftnlen);

  1572.     static doublereal alpha;

  1573.     static char diags[1];

  1574.     extern /* Subroutine */ int dmmch_(char*, char*, integer*, integer*, integer*, doublereal*, doublereal*, integer*, doublereal*, integer*, doublereal*, doublereal*, integer*, doublereal*, doublereal*, doublereal*, integer*, doublereal*, doublereal*, logical*, integer*, logical*, ftnlen, ftnlen);

  1575.     static logical isame[13];

  1576.     static char sides[1];

  1577.     static integer nargs;

  1578.     static logical reset;

  1579.     static char uplos[1];

  1580.     extern /* Subroutine */ void dprcn3_(integer*, integer*, char*, integer*, char*, char*, char*, char*, integer*, integer*, doublereal*, integer*, integer*, ftnlen, ftnlen, ftnlen, ftnlen, ftnlen);

  1581.     static integer ia, na, nc, im, in, ms, ns;

  1582.     extern logical lderes_(char*, char*, integer*, integer*, doublereal*, doublereal*, integer*, ftnlen, ftnlen);

  1583.     extern /* Subroutine */ void cdtrmm_(integer*, char*, char*, char*, char*, integer*, integer*, doublereal*, doublereal*, integer*, doublereal*, integer*, ftnlen, ftnlen, ftnlen, ftnlen);

  1584.     static char tranas[1], transa[1];

  1585.     extern /* Subroutine */ void cdtrsm_(integer*, char*, char*, char*, char*, integer*, integer*, doublereal*, doublereal*, integer*, doublereal*, integer*, ftnlen, ftnlen, ftnlen, ftnlen);

  1586.     static doublereal errmax;

  1587.     static integer laa, icd, lbb, lda, ldb;

  1588.     extern logical lde_(doublereal*, doublereal*, integer*);

  1589.     static integer ics;

  1590.     static doublereal als;

  1591.     static integer ict, icu;

  1592.     static doublereal err;

  1593. 

  1594. /*  Tests DTRMM and DTRSM. */

  1595. 

  1596. /*  Auxiliary routine for test program for Level 3 Blas. */

  1597. 

  1598. /*  -- Written on 8-February-1989. */

  1599. /*     Jack Dongarra, Argonne National Laboratory. */

  1600. /*     Iain Duff, AERE Harwell. */

  1601. /*     Jeremy Du Croz, Numerical Algorithms Group Ltd. */

  1602. /*     Sven Hammarling, Numerical Algorithms Group Ltd. */

  1603. 

  1604. /*     .. Parameters .. */

  1605. /*     .. Scalar Arguments .. */

  1606. /*     .. Array Arguments .. */

  1607. /*     .. Local Scalars .. */

  1608. /*     .. Local Arrays .. */

  1609. /*     .. External Functions .. */

  1610. /*     .. External Subroutines .. */

  1611. /*     .. Intrinsic Functions .. */

  1612. /*     .. Scalars in Common .. */

  1613. /*     .. Common blocks .. */

  1614. /*     .. Data statements .. */

  1615.     /* Parameter adjustments */

  1616.     --idim;

  1617.     --alf;

  1618.     c_dim1 = *nmax;

  1619.     c_offset = 1 + c_dim1 * 1;

  1620.     c__ -= c_offset;

  1621.     --g;

  1622.     --ct;

  1623.     --bs;

  1624.     --bb;

  1625.     b_dim1 = *nmax;

  1626.     b_offset = 1 + b_dim1 * 1;

  1627.     b -= b_offset;

  1628.     --as;

  1629.     --aa;

  1630.     a_dim1 = *nmax;

  1631.     a_offset = 1 + a_dim1 * 1;

  1632.     a -= a_offset;

  1633. 

  1634.     /* Function Body */

  1635. /*     .. Executable Statements .. */

  1636. 

  1637.     nargs = 11;

  1638.     nc = 0;

  1639.     reset = TRUE_;

  1640.     errmax = 0.;

  1641. /*     Set up zero matrix for DMMCH. */

  1642.     i__1 = *nmax;

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

  1644. 	i__2 = *nmax;

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

  1646. 	    c__[i__ + j * c_dim1] = 0.;

  1647. /* L10: */

  1648. 	}

  1649. /* L20: */

  1650.     }

  1651. 

  1652.     i__1 = *nidim;

  1653.     for (im = 1; im <= i__1; ++im) {

  1654. 	m = idim[im];

  1655. 

  1656. 	i__2 = *nidim;

  1657. 	for (in = 1; in <= i__2; ++in) {

  1658. 	    n = idim[in];

  1659. /*           Set LDB to 1 more than minimum value if room. */

  1660. 	    ldb = m;

  1661. 	    if (ldb < *nmax) {

  1662. 		++ldb;

  1663. 	    }

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

  1665. 	    if (ldb > *nmax) {

  1666. 		goto L130;

  1667. 	    }

  1668. 	    lbb = ldb * n;

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

  1670. 

  1671. 	    for (ics = 1; ics <= 2; ++ics) {

  1672. 		*(unsigned char *)side = *(unsigned char *)&ichs[ics - 1];

  1673. 		left = *(unsigned char *)side == 'L';

  1674. 		if (left) {

  1675. 		    na = m;

  1676. 		} else {

  1677. 		    na = n;

  1678. 		}

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

  1680. 		lda = na;

  1681. 		if (lda < *nmax) {

  1682. 		    ++lda;

  1683. 		}

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

  1685. 		if (lda > *nmax) {

  1686. 		    goto L130;

  1687. 		}

  1688. 		laa = lda * na;

  1689. 

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

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

  1692. 

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

  1694. 			*(unsigned char *)transa = *(unsigned char *)&icht[

  1695. 				ict - 1];

  1696. 

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

  1698. 			    *(unsigned char *)diag = *(unsigned char *)&ichd[

  1699. 				    icd - 1];

  1700. 

  1701. 			    i__3 = *nalf;

  1702. 			    for (ia = 1; ia <= i__3; ++ia) {

  1703. 				alpha = alf[ia];

  1704. 

  1705. /*                          Generate the matrix A. */

  1706. 

  1707. 				dmake_("TR", uplo, diag, &na, &na, &a[

  1708. 					a_offset], nmax, &aa[1], &lda, &reset,

  1709. 					 &c_b104, (ftnlen)2, (ftnlen)1, (

  1710. 					ftnlen)1);

  1711. 

  1712. /*                          Generate the matrix B. */

  1713. 

  1714. 				dmake_("GE", " ", " ", &m, &n, &b[b_offset], 

  1715. 					nmax, &bb[1], &ldb, &reset, &c_b104, (

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

  1717. 

  1718. 				++nc;

  1719. 

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

  1721. /*                          subroutine. */

  1722. 

  1723. 				*(unsigned char *)sides = *(unsigned char *)

  1724. 					side;

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

  1726. 					uplo;

  1727. 				*(unsigned char *)tranas = *(unsigned char *)

  1728. 					transa;

  1729. 				*(unsigned char *)diags = *(unsigned char *)

  1730. 					diag;

  1731. 				ms = m;

  1732. 				ns = n;

  1733. 				als = alpha;

  1734. 				i__4 = laa;

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

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

  1737. /* L30: */

  1738. 				}

  1739. 				ldas = lda;

  1740. 				i__4 = lbb;

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

  1742. 				    bs[i__] = bb[i__];

  1743. /* L40: */

  1744. 				}

  1745. 				ldbs = ldb;

  1746. 

  1747. /*                          Call the subroutine. */

  1748. 

  1749. 				if (s_cmp(sname + 9, "mm", (ftnlen)2, (ftnlen)

  1750. 					2) == 0) {

  1751. 				    if (*trace) {

  1752. 					dprcn3_(ntra, &nc, sname, iorder, 

  1753. 						side, uplo, transa, diag, &m, 

  1754. 						&n, &alpha, &lda, &ldb, (

  1755. 						ftnlen)12, (ftnlen)1, (ftnlen)

  1756. 						1, (ftnlen)1, (ftnlen)1);

  1757. 				    }

  1758. 				    if (*rewi) {

  1759. /*					al__1.aerr = 0;

  1760. 					al__1.aunit = *ntra;

  1761. 					f_rew(&al__1);*/

  1762. 				    }

  1763. 				    cdtrmm_(iorder, side, uplo, transa, diag, 

  1764. 					    &m, &n, &alpha, &aa[1], &lda, &bb[

  1765. 					    1], &ldb, (ftnlen)1, (ftnlen)1, (

  1766. 					    ftnlen)1, (ftnlen)1);

  1767. 				} else if (s_cmp(sname + 9, "sm", (ftnlen)2, (

  1768. 					ftnlen)2) == 0) {

  1769. 				    if (*trace) {

  1770. 					dprcn3_(ntra, &nc, sname, iorder, 

  1771. 						side, uplo, transa, diag, &m, 

  1772. 						&n, &alpha, &lda, &ldb, (

  1773. 						ftnlen)12, (ftnlen)1, (ftnlen)

  1774. 						1, (ftnlen)1, (ftnlen)1);

  1775. 				    }

  1776. 				    if (*rewi) {

  1777. /*					al__1.aerr = 0;

  1778. 					al__1.aunit = *ntra;

  1779. 					f_rew(&al__1);*/

  1780. 				    }

  1781. 				    cdtrsm_(iorder, side, uplo, transa, diag, 

  1782. 					    &m, &n, &alpha, &aa[1], &lda, &bb[

  1783. 					    1], &ldb, (ftnlen)1, (ftnlen)1, (

  1784. 					    ftnlen)1, (ftnlen)1);

  1785. 				}

  1786. 

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

  1788. 

  1789. 				if (! infoc_1.ok) {

  1790.                                     printf("*** FATAL ERROR - ERROR-CALL MYEXIT TAKEN ON VALID CALL\n");

  1791. 				    *fatal = TRUE_;

  1792. 				    goto L150;

  1793. 				}

  1794. 

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

  1796. 

  1797. 				isame[0] = *(unsigned char *)sides == *(

  1798. 					unsigned char *)side;

  1799. 				isame[1] = *(unsigned char *)uplos == *(

  1800. 					unsigned char *)uplo;

  1801. 				isame[2] = *(unsigned char *)tranas == *(

  1802. 					unsigned char *)transa;

  1803. 				isame[3] = *(unsigned char *)diags == *(

  1804. 					unsigned char *)diag;

  1805. 				isame[4] = ms == m;

  1806. 				isame[5] = ns == n;

  1807. 				isame[6] = als == alpha;

  1808. 				isame[7] = lde_(&as[1], &aa[1], &laa);

  1809. 				isame[8] = ldas == lda;

  1810. 				if (null) {

  1811. 				    isame[9] = lde_(&bs[1], &bb[1], &lbb);

  1812. 				} else {

  1813. 				    isame[9] = lderes_("GE", " ", &m, &n, &bs[

  1814. 					    1], &bb[1], &ldb, (ftnlen)2, (

  1815. 					    ftnlen)1);

  1816. 				}

  1817. 				isame[10] = ldbs == ldb;

  1818. 

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

  1820. /*                          return. */

  1821. 

  1822. 				same = TRUE_;

  1823. 				i__4 = nargs;

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

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

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

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

  1828. 				    }

  1829. /* L50: */

  1830. 				}

  1831. 				if (! same) {

  1832. 				    *fatal = TRUE_;

  1833. 				    goto L150;

  1834. 				}

  1835. 

  1836. 				if (! null) {

  1837. 				    if (s_cmp(sname + 9, "mm", (ftnlen)2, (

  1838. 					    ftnlen)2) == 0) {

  1839. 

  1840. /*                                Check the result. */

  1841. 

  1842. 					if (left) {

  1843. 					    dmmch_(transa, "N", &m, &n, &m, &

  1844. 						    alpha, &a[a_offset], nmax,

  1845. 						     &b[b_offset], nmax, &

  1846. 						    c_b104, &c__[c_offset], 

  1847. 						    nmax, &ct[1], &g[1], &bb[

  1848. 						    1], &ldb, eps, &err, 

  1849. 						    fatal, nout, &c_true, (

  1850. 						    ftnlen)1, (ftnlen)1);

  1851. 					} else {

  1852. 					    dmmch_("N", transa, &m, &n, &n, &

  1853. 						    alpha, &b[b_offset], nmax,

  1854. 						     &a[a_offset], nmax, &

  1855. 						    c_b104, &c__[c_offset], 

  1856. 						    nmax, &ct[1], &g[1], &bb[

  1857. 						    1], &ldb, eps, &err, 

  1858. 						    fatal, nout, &c_true, (

  1859. 						    ftnlen)1, (ftnlen)1);

  1860. 					}

  1861. 				    } else if (s_cmp(sname + 9, "sm", (ftnlen)

  1862. 					    2, (ftnlen)2) == 0) {

  1863. 

  1864. /*                                Compute approximation to original */

  1865. /*                                matrix. */

  1866. 

  1867. 					i__4 = n;

  1868. 					for (j = 1; j <= i__4; ++j) {

  1869. 					    i__5 = m;

  1870. 					    for (i__ = 1; i__ <= i__5; ++i__) 

  1871. 						    {

  1872. 			  c__[i__ + j * c_dim1] = bb[i__ + (j - 1) * ldb];

  1873. 			  bb[i__ + (j - 1) * ldb] = alpha * b[i__ + j * 

  1874. 				  b_dim1];

  1875. /* L60: */

  1876. 					    }

  1877. /* L70: */

  1878. 					}

  1879. 

  1880. 					if (left) {

  1881. 					    dmmch_(transa, "N", &m, &n, &m, &

  1882. 						    c_b90, &a[a_offset], nmax,

  1883. 						     &c__[c_offset], nmax, &

  1884. 						    c_b104, &b[b_offset], 

  1885. 						    nmax, &ct[1], &g[1], &bb[

  1886. 						    1], &ldb, eps, &err, 

  1887. 						    fatal, nout, &c_false, (

  1888. 						    ftnlen)1, (ftnlen)1);

  1889. 					} else {

  1890. 					    dmmch_("N", transa, &m, &n, &n, &

  1891. 						    c_b90, &c__[c_offset], 

  1892. 						    nmax, &a[a_offset], nmax, 

  1893. 						    &c_b104, &b[b_offset], 

  1894. 						    nmax, &ct[1], &g[1], &bb[

  1895. 						    1], &ldb, eps, &err, 

  1896. 						    fatal, nout, &c_false, (

  1897. 						    ftnlen)1, (ftnlen)1);

  1898. 					}

  1899. 				    }

  1900. 				    errmax = f2cmax(errmax,err);

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

  1902. /*                             return. */

  1903. 				    if (*fatal) {

  1904. 					goto L150;

  1905. 				    }

  1906. 				}

  1907. 

  1908. /* L80: */

  1909. 			    }

  1910. 

  1911. /* L90: */

  1912. 			}

  1913. 

  1914. /* L100: */

  1915. 		    }

  1916. 

  1917. /* L110: */

  1918. 		}

  1919. 

  1920. /* L120: */

  1921. 	    }

  1922. 

  1923. L130:

  1924. 	    ;

  1925. 	}

  1926. 

  1927. /* L140: */

  1928.     }

  1929. 

  1930. /*     Report result. */

  1931. 

  1932.     if (errmax < *thresh) {

  1933. 	if (*iorder == 0) {

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

  1935. 	}

  1936. 	if (*iorder == 1) {

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

  1938. 	}

  1939.     } else {

  1940. 	if (*iorder == 0) {

  1941.             printf("%s COMPLETED THE COLUMN-MAJOR COMPUTATIONAL TESTS (%d CALLS)/n",sname,nc);

  1942.             printf("***** BUT WITH MAXIMUM TEST RATIO %8.2f - SUSPECT *******/n",errmax);

  1943. 	}

  1944. 	if (*iorder == 1) {

  1945.             printf("%s COMPLETED THE ROW-MAJOR COMPUTATIONAL TESTS (%d CALLS)/n",sname,nc);

  1946.             printf("***** BUT WITH MAXIMUM TEST RATIO %8.2f - SUSPECT *******/n",errmax);

  1947. 	}

  1948.     }

  1949.     goto L160;

  1950. 

  1951. L150:

  1952.     printf(" ******* %s FAILED ON CALL NUMBER:\n",sname);

  1953.     if (*trace) {

  1954. 	dprcn3_(ntra, &nc, sname, iorder, side, uplo, transa, diag, &m, &n, &

  1955. 		alpha, &lda, &ldb, (ftnlen)12, (ftnlen)1, (ftnlen)1, (ftnlen)

  1956. 		1, (ftnlen)1);

  1957.     }

  1958. 

  1959. L160:

  1960.     return 0;

  1961. 

  1962. /* 9995 FORMAT( 1X, I6, ': ', A12,'(', 4( '''', A1, ''',' ), 2( I3, ',' ), */

  1963. /*     $      F4.1, ', A,', I3, ', B,', I3, ')        .' ) */

  1964. 

  1965. /*     End of DCHK3. */

  1966. 

  1967. } /* dchk3_ */

  1968. 

  1969. 

  1970. /* Subroutine */ void dprcn3_(integer* nout, integer* nc, char* sname, integer* iorder, char* side, char* uplo, char* transa, char* diag, integer* m, integer* n, doublereal* alpha, integer* lda, integer* ldb, ftnlen sname_len, ftnlen side_len, ftnlen uplo_len, ftnlen transa_len, ftnlen diag_len)

  1971. {

  1972. 

  1973.     /* Local variables */

  1974.     static char ca[14], cd[14], cs[14], cu[14], crc[14];

  1975. 

  1976.     if (*(unsigned char *)side == 'L') {

  1977. 	s_copy(cs, "     CblasLeft", (ftnlen)14, (ftnlen)14);

  1978.     } else {

  1979. 	s_copy(cs, "    CblasRight", (ftnlen)14, (ftnlen)14);

  1980.     }

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

  1982. 	s_copy(cu, "    CblasUpper", (ftnlen)14, (ftnlen)14);

  1983.     } else {

  1984. 	s_copy(cu, "    CblasLower", (ftnlen)14, (ftnlen)14);

  1985.     }

  1986.     if (*(unsigned char *)transa == 'N') {

  1987. 	s_copy(ca, "  CblasNoTrans", (ftnlen)14, (ftnlen)14);

  1988.     } else if (*(unsigned char *)transa == 'T') {

  1989. 	s_copy(ca, "    CblasTrans", (ftnlen)14, (ftnlen)14);

  1990.     } else {

  1991. 	s_copy(ca, "CblasConjTrans", (ftnlen)14, (ftnlen)14);

  1992.     }

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

  1994. 	s_copy(cd, "  CblasNonUnit", (ftnlen)14, (ftnlen)14);

  1995.     } else {

  1996. 	s_copy(cd, "     CblasUnit", (ftnlen)14, (ftnlen)14);

  1997.     }

  1998.     if (*iorder == 1) {

  1999. 	s_copy(crc, " CblasRowMajor", (ftnlen)14, (ftnlen)14);

  2000.     } else {

  2001. 	s_copy(crc, " CblasColMajor", (ftnlen)14, (ftnlen)14);

  2002.     }

  2003.     printf("%6d: %s %s %s %s\n",*nc,sname,crc,cs,cu);

  2004.     printf("         %s %s %d %d %4.1f A %d B %d\n",ca,cd,*m,*n,*alpha,*lda,*ldb);

  2005. } /* dprcn3_ */

  2006. 

  2007. 

  2008. /* Subroutine */ int dchk4_(char* sname, doublereal* eps, doublereal* thresh, integer* nout, integer* ntra, logical* trace, logical* rewi, logical* fatal, integer* nidim, integer* idim, integer* nalf, doublereal* alf, integer* nbet, doublereal* bet, integer* nmax, doublereal* a, doublereal* aa, doublereal* as, doublereal* b, doublereal* bb, doublereal* bs, doublereal* c__, doublereal* cc, doublereal* cs, doublereal* ct, doublereal* g, integer* iorder, ftnlen sname_len)

  2009. {

  2010.     /* Initialized data */

  2011. 

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

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

  2014. 

  2015.     /* System generated locals */

  2016.     integer a_dim1, a_offset, b_dim1, b_offset, c_dim1, c_offset, i__1, i__2, 

  2017. 	    i__3, i__4, i__5;

  2018. 

  2019. 

  2020.     /* Local variables */

  2021.     static doublereal beta;

  2022.     static integer ldas, ldcs;

  2023.     static logical same;

  2024.     static doublereal bets;

  2025.     static logical tran, null;

  2026.     static char uplo[1];

  2027.     static integer i__, j, k, n;

  2028.     extern /* Subroutine */ int dmake_(char*, char*, char*, integer*, integer*, doublereal*, integer*, doublereal*, integer*, logical*, doublereal*, ftnlen, ftnlen, ftnlen);

  2029.     static doublereal alpha;

  2030.     extern /* Subroutine */ int dmmch_(char*, char*, integer*, integer*, integer*, doublereal*, doublereal*, integer*, doublereal*, integer*, doublereal*, doublereal*, integer*, doublereal*, doublereal*, doublereal*, integer*, doublereal*, doublereal*, logical*, integer*, logical*, ftnlen, ftnlen);

  2031.     static logical isame[13];

  2032.     static integer nargs;

  2033.     static logical reset;

  2034.     static char trans[1];

  2035.     static logical upper;

  2036.     static char uplos[1];

  2037.     extern /* Subroutine */ void dprcn4_(integer*, integer*, char*, integer*, char*, char*, integer*, integer*, doublereal*, integer*, doublereal*, integer*, ftnlen, ftnlen, ftnlen);

  2038.     static integer ia, ib, jc, ma, na, nc, ik, in, jj, lj, ks, ns;

  2039.     extern logical lderes_(char*, char*, integer*, integer*, doublereal*, doublereal*, integer*, ftnlen, ftnlen);

  2040.     static doublereal errmax;

  2041.     extern /* Subroutine */ void cdsyrk_(integer*, char*, char*, integer*, integer*, doublereal*, doublereal*, integer*, doublereal*, doublereal*, integer*, ftnlen, ftnlen);

  2042.     static char transs[1];

  2043.     static integer laa, lda, lcc, ldc;

  2044.     extern logical lde_(doublereal*, doublereal*, integer*);

  2045.     static doublereal als;

  2046.     static integer ict, icu;

  2047.     static doublereal err;

  2048. 

  2049. /*  Tests DSYRK. */

  2050. 

  2051. /*  Auxiliary routine for test program for Level 3 Blas. */

  2052. 

  2053. /*  -- Written on 8-February-1989. */

  2054. /*     Jack Dongarra, Argonne National Laboratory. */

  2055. /*     Iain Duff, AERE Harwell. */

  2056. /*     Jeremy Du Croz, Numerical Algorithms Group Ltd. */

  2057. /*     Sven Hammarling, Numerical Algorithms Group Ltd. */

  2058. 

  2059. /*     .. Parameters .. */

  2060. /*     .. Scalar Arguments .. */

  2061. /*     .. Array Arguments .. */

  2062. /*     .. Local Scalars .. */

  2063. /*     .. Local Arrays .. */

  2064. /*     .. External Functions .. */

  2065. /*     .. External Subroutines .. */

  2066. /*     .. Intrinsic Functions .. */

  2067. /*     .. Scalars in Common .. */

  2068. /*     .. Common blocks .. */

  2069. /*     .. Data statements .. */

  2070.     /* Parameter adjustments */

  2071.     --idim;

  2072.     --alf;

  2073.     --bet;

  2074.     --g;

  2075.     --ct;

  2076.     --cs;

  2077.     --cc;

  2078.     c_dim1 = *nmax;

  2079.     c_offset = 1 + c_dim1 * 1;

  2080.     c__ -= c_offset;

  2081.     --bs;

  2082.     --bb;

  2083.     b_dim1 = *nmax;

  2084.     b_offset = 1 + b_dim1 * 1;

  2085.     b -= b_offset;

  2086.     --as;

  2087.     --aa;

  2088.     a_dim1 = *nmax;

  2089.     a_offset = 1 + a_dim1 * 1;

  2090.     a -= a_offset;

  2091. 

  2092.     /* Function Body */

  2093. /*     .. Executable Statements .. */

  2094. 

  2095.     nargs = 10;

  2096.     nc = 0;

  2097.     reset = TRUE_;

  2098.     errmax = 0.;

  2099. 

  2100.     i__1 = *nidim;

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

  2102. 	n = idim[in];

  2103. /*        Set LDC to 1 more than minimum value if room. */

  2104. 	ldc = n;

  2105. 	if (ldc < *nmax) {

  2106. 	    ++ldc;

  2107. 	}

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

  2109. 	if (ldc > *nmax) {

  2110. 	    goto L100;

  2111. 	}

  2112. 	lcc = ldc * n;

  2113. 	null = n <= 0;

  2114. 

  2115. 	i__2 = *nidim;

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

  2117. 	    k = idim[ik];

  2118. 

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

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

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

  2122. 			trans == 'C';

  2123. 		if (tran) {

  2124. 		    ma = k;

  2125. 		    na = n;

  2126. 		} else {

  2127. 		    ma = n;

  2128. 		    na = k;

  2129. 		}

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

  2131. 		lda = ma;

  2132. 		if (lda < *nmax) {

  2133. 		    ++lda;

  2134. 		}

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

  2136. 		if (lda > *nmax) {

  2137. 		    goto L80;

  2138. 		}

  2139. 		laa = lda * na;

  2140. 

  2141. /*              Generate the matrix A. */

  2142. 

  2143. 		dmake_("GE", " ", " ", &ma, &na, &a[a_offset], nmax, &aa[1], &

  2144. 			lda, &reset, &c_b104, (ftnlen)2, (ftnlen)1, (ftnlen)1)

  2145. 			;

  2146. 

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

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

  2149. 		    upper = *(unsigned char *)uplo == 'U';

  2150. 

  2151. 		    i__3 = *nalf;

  2152. 		    for (ia = 1; ia <= i__3; ++ia) {

  2153. 			alpha = alf[ia];

  2154. 

  2155. 			i__4 = *nbet;

  2156. 			for (ib = 1; ib <= i__4; ++ib) {

  2157. 			    beta = bet[ib];

  2158. 

  2159. /*                       Generate the matrix C. */

  2160. 

  2161. 			    dmake_("SY", uplo, " ", &n, &n, &c__[c_offset], 

  2162. 				    nmax, &cc[1], &ldc, &reset, &c_b104, (

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

  2164. 

  2165. 			    ++nc;

  2166. 

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

  2168. 

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

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

  2171. 				    trans;

  2172. 			    ns = n;

  2173. 			    ks = k;

  2174. 			    als = alpha;

  2175. 			    i__5 = laa;

  2176. 			    for (i__ = 1; i__ <= i__5; ++i__) {

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

  2178. /* L10: */

  2179. 			    }

  2180. 			    ldas = lda;

  2181. 			    bets = beta;

  2182. 			    i__5 = lcc;

  2183. 			    for (i__ = 1; i__ <= i__5; ++i__) {

  2184. 				cs[i__] = cc[i__];

  2185. /* L20: */

  2186. 			    }

  2187. 			    ldcs = ldc;

  2188. 

  2189. /*                       Call the subroutine. */

  2190. 

  2191. 			    if (*trace) {

  2192. 				dprcn4_(ntra, &nc, sname, iorder, uplo, trans,

  2193. 					 &n, &k, &alpha, &lda, &beta, &ldc, (

  2194. 					ftnlen)12, (ftnlen)1, (ftnlen)1);

  2195. 			    }

  2196. 			    if (*rewi) {

  2197. /*				al__1.aerr = 0;

  2198. 				al__1.aunit = *ntra;

  2199. 				f_rew(&al__1);*/

  2200. 			    }

  2201. 			    cdsyrk_(iorder, uplo, trans, &n, &k, &alpha, &aa[

  2202. 				    1], &lda, &beta, &cc[1], &ldc, (ftnlen)1, 

  2203. 				    (ftnlen)1);

  2204. 

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

  2206. 

  2207. 			    if (! infoc_1.ok) {

  2208.                                printf("*** FATAL ERROR - ERROR-CALL MYEXIT TAKEN ON VALID CALL\n");

  2209. 				*fatal = TRUE_;

  2210. 				goto L120;

  2211. 			    }

  2212. 

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

  2214. 

  2215. 			    isame[0] = *(unsigned char *)uplos == *(unsigned 

  2216. 				    char *)uplo;

  2217. 			    isame[1] = *(unsigned char *)transs == *(unsigned 

  2218. 				    char *)trans;

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

  2220. 			    isame[3] = ks == k;

  2221. 			    isame[4] = als == alpha;

  2222. 			    isame[5] = lde_(&as[1], &aa[1], &laa);

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

  2224. 			    isame[7] = bets == beta;

  2225. 			    if (null) {

  2226. 				isame[8] = lde_(&cs[1], &cc[1], &lcc);

  2227. 			    } else {

  2228. 				isame[8] = lderes_("SY", uplo, &n, &n, &cs[1],

  2229. 					 &cc[1], &ldc, (ftnlen)2, (ftnlen)1);

  2230. 			    }

  2231. 			    isame[9] = ldcs == ldc;

  2232. 

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

  2234. /*                       return. */

  2235. 

  2236. 			    same = TRUE_;

  2237. 			    i__5 = nargs;

  2238. 			    for (i__ = 1; i__ <= i__5; ++i__) {

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

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

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

  2242.     				}

  2243. /* L30: */

  2244. 			    }

  2245. 			    if (! same) {

  2246. 				*fatal = TRUE_;

  2247. 				goto L120;

  2248. 			    }

  2249. 

  2250. 			    if (! null) {

  2251. 

  2252. /*                          Check the result column by column. */

  2253. 

  2254. 				jc = 1;

  2255. 				i__5 = n;

  2256. 				for (j = 1; j <= i__5; ++j) {

  2257. 				    if (upper) {

  2258. 					jj = 1;

  2259. 					lj = j;

  2260. 				    } else {

  2261. 					jj = j;

  2262. 					lj = n - j + 1;

  2263. 				    }

  2264. 				    if (tran) {

  2265. 					dmmch_("T", "N", &lj, &c__1, &k, &

  2266. 						alpha, &a[jj * a_dim1 + 1], 

  2267. 						nmax, &a[j * a_dim1 + 1], 

  2268. 						nmax, &beta, &c__[jj + j * 

  2269. 						c_dim1], nmax, &ct[1], &g[1], 

  2270. 						&cc[jc], &ldc, eps, &err, 

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

  2272. 						1, (ftnlen)1);

  2273. 				    } else {

  2274. 					dmmch_("N", "T", &lj, &c__1, &k, &

  2275. 						alpha, &a[jj + a_dim1], nmax, 

  2276. 						&a[j + a_dim1], nmax, &beta, &

  2277. 						c__[jj + j * c_dim1], nmax, &

  2278. 						ct[1], &g[1], &cc[jc], &ldc, 

  2279. 						eps, &err, fatal, nout, &

  2280. 						c_true, (ftnlen)1, (ftnlen)1);

  2281. 				    }

  2282. 				    if (upper) {

  2283. 					jc += ldc;

  2284. 				    } else {

  2285. 					jc = jc + ldc + 1;

  2286. 				    }

  2287. 				    errmax = f2cmax(errmax,err);

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

  2289. /*                             return. */

  2290. 				    if (*fatal) {

  2291. 					goto L110;

  2292. 				    }

  2293. /* L40: */

  2294. 				}

  2295. 			    }

  2296. 

  2297. /* L50: */

  2298. 			}

  2299. 

  2300. /* L60: */

  2301. 		    }

  2302. 

  2303. /* L70: */

  2304. 		}

  2305. 

  2306. L80:

  2307. 		;

  2308. 	    }

  2309. 

  2310. /* L90: */

  2311. 	}

  2312. 

  2313. L100:

  2314. 	;

  2315.     }

  2316. 

  2317. /*     Report result. */

  2318. 

  2319.     if (errmax < *thresh) {

  2320. 	if (*iorder == 0) {

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

  2322. 	}

  2323. 	if (*iorder == 1) {

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

  2325. 	}

  2326.     } else {

  2327. 	if (*iorder == 0) {

  2328.             printf("%s COMPLETED THE COLUMN-MAJOR COMPUTATIONAL TESTS (%d CALLS)/n",sname,nc);

  2329.             printf("***** BUT WITH MAXIMUM TEST RATIO %8.2f - SUSPECT *******/n",errmax);

  2330. 	}

  2331. 	if (*iorder == 1) {

  2332.             printf("%s COMPLETED THE ROW-MAJOR COMPUTATIONAL TESTS (%d CALLS)/n",sname,nc);

  2333.             printf("***** BUT WITH MAXIMUM TEST RATIO %8.2f - SUSPECT *******/n",errmax);

  2334. 	}

  2335.     }

  2336.     goto L130;

  2337. 

  2338. L110:

  2339.     if (n > 1) {

  2340.         printf("      THESE ARE THE RESULTS FOR COLUMN %d:\n",j);

  2341.     }

  2342. 

  2343. L120:

  2344.     printf(" ******* %s FAILED ON CALL NUMBER:\n",sname);

  2345.     dprcn4_(nout, &nc, sname, iorder, uplo, trans, &n, &k, &alpha, &lda, &

  2346. 	    beta, &ldc, (ftnlen)12, (ftnlen)1, (ftnlen)1);

  2347. 

  2348. L130:

  2349.     return 0;

  2350. 

  2351. /* 9994 FORMAT( 1X, I6, ': ', A12,'(', 2( '''', A1, ''',' ), 2( I3, ',' ), */

  2352. /*     $      F4.1, ', A,', I3, ',', F4.1, ', C,', I3, ')           .' ) */

  2353. 

  2354. /*     End of DCHK4. */

  2355. 

  2356. } /* dchk4_ */

  2357. 

  2358. 

  2359. /* Subroutine */ void dprcn4_(integer* nout, integer* nc, char* sname, integer* iorder, char* uplo, char* transa, integer* n, integer* k, doublereal* alpha, integer* lda, doublereal* beta, integer* ldc, ftnlen sname_len, ftnlen uplo_len, ftnlen transa_len)

  2360. {

  2361. 

  2362.     /* Local variables */

  2363.     static char ca[14], cu[14], crc[14];

  2364. 

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

  2366. 	s_copy(cu, "    CblasUpper", (ftnlen)14, (ftnlen)14);

  2367.     } else {

  2368. 	s_copy(cu, "    CblasLower", (ftnlen)14, (ftnlen)14);

  2369.     }

  2370.     if (*(unsigned char *)transa == 'N') {

  2371. 	s_copy(ca, "  CblasNoTrans", (ftnlen)14, (ftnlen)14);

  2372.     } else if (*(unsigned char *)transa == 'T') {

  2373. 	s_copy(ca, "    CblasTrans", (ftnlen)14, (ftnlen)14);

  2374.     } else {

  2375. 	s_copy(ca, "CblasConjTrans", (ftnlen)14, (ftnlen)14);

  2376.     }

  2377.     if (*iorder == 1) {

  2378. 	s_copy(crc, " CblasRowMajor", (ftnlen)14, (ftnlen)14);

  2379.     } else {

  2380. 	s_copy(crc, " CblasColMajor", (ftnlen)14, (ftnlen)14);

  2381.     }

  2382.     printf("%6d: %s %s %s %s\n",*nc,sname,crc,cu,ca);

  2383.     printf("(          %d %d %4.1f A %d %4.1f C %d\n",*n,*k,*alpha,*lda,*beta,*ldc);

  2384. } /* dprcn4_ */

  2385. 

  2386. 

  2387. /* Subroutine */ int dchk5_(char* sname, doublereal* eps, doublereal* thresh, integer* nout, integer* ntra, logical* trace, logical* rewi, logical* fatal, integer* nidim, integer* idim, integer* nalf, doublereal* alf, integer* nbet, doublereal* bet, integer* nmax, doublereal* ab, doublereal* aa, doublereal* as, doublereal* bb, doublereal* bs, doublereal* c__, doublereal* cc, doublereal* cs, doublereal* ct, doublereal* g, doublereal* w, integer* iorder, ftnlen sname_len)

  2388. {

  2389.     /* Initialized data */

  2390. 

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

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

  2393. 

  2394.     /* System generated locals */

  2395.     integer c_dim1, c_offset, i__1, i__2, i__3, i__4, i__5, i__6, i__7, i__8;

  2396. 

  2397. 

  2398.     /* Local variables */

  2399.     static integer jjab;

  2400.     static doublereal beta;

  2401.     static integer ldas, ldbs, ldcs;

  2402.     static logical same;

  2403.     static doublereal bets;

  2404.     static logical tran, null;

  2405.     static char uplo[1];

  2406.     static integer i__, j, k, n;

  2407.     extern /* Subroutine */ int dmake_(char*, char*, char*, integer*, integer*, doublereal*, integer*, doublereal*, integer*, logical*, doublereal*, ftnlen, ftnlen, ftnlen);

  2408.     static doublereal alpha;

  2409.     extern /* Subroutine */ int dmmch_(char*, char*, integer*, integer*, integer*, doublereal*, doublereal*, integer*, doublereal*, integer*, doublereal*, doublereal*, integer*, doublereal*, doublereal*, doublereal*, integer*, doublereal*, doublereal*, logical*, integer*, logical*, ftnlen, ftnlen);

  2410.     static logical isame[13];

  2411.     static integer nargs;

  2412.     static logical reset;

  2413.     static char trans[1];

  2414.     static logical upper;

  2415.     static char uplos[1];

  2416.     extern /* Subroutine */ void dprcn5_(integer*, integer*, char*, integer*, char*, char*, integer*, integer*, doublereal*, integer*, integer*, doublereal*, integer*, ftnlen, ftnlen, ftnlen);

  2417.     static integer ia, ib, jc, ma, na, nc, ik, in, jj, lj, ks, ns;

  2418.     extern logical lderes_(char*, char*, integer*, integer*, doublereal*, doublereal*, integer*, ftnlen, ftnlen);

  2419.     static doublereal errmax;

  2420.     static char transs[1];

  2421.     static integer laa, lbb, lda, lcc, ldb, ldc;

  2422.     extern logical lde_(doublereal*, doublereal*, integer*);

  2423.     extern /* Subroutine */ void cdsyr2k_(integer*, char*, char*, integer*, integer*, doublereal*, doublereal*, integer*, doublereal*, integer*, doublereal*, doublereal*, integer*, ftnlen, ftnlen);

  2424.     static doublereal als;

  2425.     static integer ict, icu;

  2426.     static doublereal err;

  2427. 

  2428. /*  Tests DSYR2K. */

  2429. 

  2430. /*  Auxiliary routine for test program for Level 3 Blas. */

  2431. 

  2432. /*  -- Written on 8-February-1989. */

  2433. /*     Jack Dongarra, Argonne National Laboratory. */

  2434. /*     Iain Duff, AERE Harwell. */

  2435. /*     Jeremy Du Croz, Numerical Algorithms Group Ltd. */

  2436. /*     Sven Hammarling, Numerical Algorithms Group Ltd. */

  2437. 

  2438. /*     .. Parameters .. */

  2439. /*     .. Scalar Arguments .. */

  2440. /*     .. Array Arguments .. */

  2441. /*     .. Local Scalars .. */

  2442. /*     .. Local Arrays .. */

  2443. /*     .. External Functions .. */

  2444. /*     .. External Subroutines .. */

  2445. /*     .. Intrinsic Functions .. */

  2446. /*     .. Scalars in Common .. */

  2447. /*     .. Common blocks .. */

  2448. /*     .. Data statements .. */

  2449.     /* Parameter adjustments */

  2450.     --idim;

  2451.     --alf;

  2452.     --bet;

  2453.     --w;

  2454.     --g;

  2455.     --ct;

  2456.     --cs;

  2457.     --cc;

  2458.     c_dim1 = *nmax;

  2459.     c_offset = 1 + c_dim1 * 1;

  2460.     c__ -= c_offset;

  2461.     --bs;

  2462.     --bb;

  2463.     --as;

  2464.     --aa;

  2465.     --ab;

  2466. 

  2467.     /* Function Body */

  2468. /*     .. Executable Statements .. */

  2469. 

  2470.     nargs = 12;

  2471.     nc = 0;

  2472.     reset = TRUE_;

  2473.     errmax = 0.;

  2474. 

  2475.     i__1 = *nidim;

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

  2477. 	n = idim[in];

  2478. /*        Set LDC to 1 more than minimum value if room. */

  2479. 	ldc = n;

  2480. 	if (ldc < *nmax) {

  2481. 	    ++ldc;

  2482. 	}

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

  2484. 	if (ldc > *nmax) {

  2485. 	    goto L130;

  2486. 	}

  2487. 	lcc = ldc * n;

  2488. 	null = n <= 0;

  2489. 

  2490. 	i__2 = *nidim;

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

  2492. 	    k = idim[ik];

  2493. 

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

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

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

  2497. 			trans == 'C';

  2498. 		if (tran) {

  2499. 		    ma = k;

  2500. 		    na = n;

  2501. 		} else {

  2502. 		    ma = n;

  2503. 		    na = k;

  2504. 		}

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

  2506. 		lda = ma;

  2507. 		if (lda < *nmax) {

  2508. 		    ++lda;

  2509. 		}

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

  2511. 		if (lda > *nmax) {

  2512. 		    goto L110;

  2513. 		}

  2514. 		laa = lda * na;

  2515. 

  2516. /*              Generate the matrix A. */

  2517. 

  2518. 		if (tran) {

  2519. 		    i__3 = *nmax << 1;

  2520. 		    dmake_("GE", " ", " ", &ma, &na, &ab[1], &i__3, &aa[1], &

  2521. 			    lda, &reset, &c_b104, (ftnlen)2, (ftnlen)1, (

  2522. 			    ftnlen)1);

  2523. 		} else {

  2524. 		    dmake_("GE", " ", " ", &ma, &na, &ab[1], nmax, &aa[1], &

  2525. 			    lda, &reset, &c_b104, (ftnlen)2, (ftnlen)1, (

  2526. 			    ftnlen)1);

  2527. 		}

  2528. 

  2529. /*              Generate the matrix B. */

  2530. 

  2531. 		ldb = lda;

  2532. 		lbb = laa;

  2533. 		if (tran) {

  2534. 		    i__3 = *nmax << 1;

  2535. 		    dmake_("GE", " ", " ", &ma, &na, &ab[k + 1], &i__3, &bb[1]

  2536. 			    , &ldb, &reset, &c_b104, (ftnlen)2, (ftnlen)1, (

  2537. 			    ftnlen)1);

  2538. 		} else {

  2539. 		    dmake_("GE", " ", " ", &ma, &na, &ab[k * *nmax + 1], nmax,

  2540. 			     &bb[1], &ldb, &reset, &c_b104, (ftnlen)2, (

  2541. 			    ftnlen)1, (ftnlen)1);

  2542. 		}

  2543. 

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

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

  2546. 		    upper = *(unsigned char *)uplo == 'U';

  2547. 

  2548. 		    i__3 = *nalf;

  2549. 		    for (ia = 1; ia <= i__3; ++ia) {

  2550. 			alpha = alf[ia];

  2551. 

  2552. 			i__4 = *nbet;

  2553. 			for (ib = 1; ib <= i__4; ++ib) {

  2554. 			    beta = bet[ib];

  2555. 

  2556. /*                       Generate the matrix C. */

  2557. 

  2558. 			    dmake_("SY", uplo, " ", &n, &n, &c__[c_offset], 

  2559. 				    nmax, &cc[1], &ldc, &reset, &c_b104, (

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

  2561. 

  2562. 			    ++nc;

  2563. 

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

  2565. 

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

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

  2568. 				    trans;

  2569. 			    ns = n;

  2570. 			    ks = k;

  2571. 			    als = alpha;

  2572. 			    i__5 = laa;

  2573. 			    for (i__ = 1; i__ <= i__5; ++i__) {

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

  2575. /* L10: */

  2576. 			    }

  2577. 			    ldas = lda;

  2578. 			    i__5 = lbb;

  2579. 			    for (i__ = 1; i__ <= i__5; ++i__) {

  2580. 				bs[i__] = bb[i__];

  2581. /* L20: */

  2582. 			    }

  2583. 			    ldbs = ldb;

  2584. 			    bets = beta;

  2585. 			    i__5 = lcc;

  2586. 			    for (i__ = 1; i__ <= i__5; ++i__) {

  2587. 				cs[i__] = cc[i__];

  2588. /* L30: */

  2589. 			    }

  2590. 			    ldcs = ldc;

  2591. 

  2592. /*                       Call the subroutine. */

  2593. 

  2594. 			    if (*trace) {

  2595. 				dprcn5_(ntra, &nc, sname, iorder, uplo, trans,

  2596. 					 &n, &k, &alpha, &lda, &ldb, &beta, &

  2597. 					ldc, (ftnlen)12, (ftnlen)1, (ftnlen)1)

  2598. 					;

  2599. 			    }

  2600. 			    if (*rewi) {

  2601. /*				al__1.aerr = 0;

  2602. 				al__1.aunit = *ntra;

  2603. 				f_rew(&al__1);*/

  2604. 			    }

  2605. 			    cdsyr2k_(iorder, uplo, trans, &n, &k, &alpha, &aa[

  2606. 				    1], &lda, &bb[1], &ldb, &beta, &cc[1], &

  2607. 				    ldc, (ftnlen)1, (ftnlen)1);

  2608. 

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

  2610. 

  2611. 			    if (! infoc_1.ok) {

  2612.                                 printf("*** FATAL ERROR - ERROR-CALL MYEXIT TAKEN ON VALID CALL\n");

  2613. 				*fatal = TRUE_;

  2614. 				goto L150;

  2615. 			    }

  2616. 

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

  2618. 

  2619. 			    isame[0] = *(unsigned char *)uplos == *(unsigned 

  2620. 				    char *)uplo;

  2621. 			    isame[1] = *(unsigned char *)transs == *(unsigned 

  2622. 				    char *)trans;

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

  2624. 			    isame[3] = ks == k;

  2625. 			    isame[4] = als == alpha;

  2626. 			    isame[5] = lde_(&as[1], &aa[1], &laa);

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

  2628. 			    isame[7] = lde_(&bs[1], &bb[1], &lbb);

  2629. 			    isame[8] = ldbs == ldb;

  2630. 			    isame[9] = bets == beta;

  2631. 			    if (null) {

  2632. 				isame[10] = lde_(&cs[1], &cc[1], &lcc);

  2633. 			    } else {

  2634. 				isame[10] = lderes_("SY", uplo, &n, &n, &cs[1]

  2635. 					, &cc[1], &ldc, (ftnlen)2, (ftnlen)1);

  2636. 			    }

  2637. 			    isame[11] = ldcs == ldc;

  2638. 

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

  2640. /*                       return. */

  2641. 

  2642. 			    same = TRUE_;

  2643. 			    i__5 = nargs;

  2644. 			    for (i__ = 1; i__ <= i__5; ++i__) {

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

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

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

  2648. 				}

  2649. /* L40: */

  2650. 			    }

  2651. 			    if (! same) {

  2652. 				*fatal = TRUE_;

  2653. 				goto L150;

  2654. 			    }

  2655. 

  2656. 			    if (! null) {

  2657. 

  2658. /*                          Check the result column by column. */

  2659. 

  2660. 				jjab = 1;

  2661. 				jc = 1;

  2662. 				i__5 = n;

  2663. 				for (j = 1; j <= i__5; ++j) {

  2664. 				    if (upper) {

  2665. 					jj = 1;

  2666. 					lj = j;

  2667. 				    } else {

  2668. 					jj = j;

  2669. 					lj = n - j + 1;

  2670. 				    }

  2671. 				    if (tran) {

  2672. 					i__6 = k;

  2673. 					for (i__ = 1; i__ <= i__6; ++i__) {

  2674. 					    w[i__] = ab[((j - 1) << 1) * *nmax 

  2675. 						    + k + i__];

  2676. 					    w[k + i__] = ab[((j - 1) << 1) * *

  2677. 						    nmax + i__];

  2678. /* L50: */

  2679. 					}

  2680. 					i__6 = k << 1;

  2681. 					i__7 = *nmax << 1;

  2682. 					i__8 = *nmax << 1;

  2683. 					dmmch_("T", "N", &lj, &c__1, &i__6, &

  2684. 						alpha, &ab[jjab], &i__7, &w[1]

  2685. 						, &i__8, &beta, &c__[jj + j * 

  2686. 						c_dim1], nmax, &ct[1], &g[1], 

  2687. 						&cc[jc], &ldc, eps, &err, 

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

  2689. 						1, (ftnlen)1);

  2690. 				    } else {

  2691. 					i__6 = k;

  2692. 					for (i__ = 1; i__ <= i__6; ++i__) {

  2693. 					    w[i__] = ab[(k + i__ - 1) * *nmax 

  2694. 						    + j];

  2695. 					    w[k + i__] = ab[(i__ - 1) * *nmax 

  2696. 						    + j];

  2697. /* L60: */

  2698. 					}

  2699. 					i__6 = k << 1;

  2700. 					i__7 = *nmax << 1;

  2701. 					dmmch_("N", "N", &lj, &c__1, &i__6, &

  2702. 						alpha, &ab[jj], nmax, &w[1], &

  2703. 						i__7, &beta, &c__[jj + j * 

  2704. 						c_dim1], nmax, &ct[1], &g[1], 

  2705. 						&cc[jc], &ldc, eps, &err, 

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

  2707. 						1, (ftnlen)1);

  2708. 				    }

  2709. 				    if (upper) {

  2710. 					jc += ldc;

  2711. 				    } else {

  2712. 					jc = jc + ldc + 1;

  2713. 					if (tran) {

  2714. 					    jjab += *nmax << 1;

  2715. 					}

  2716. 				    }

  2717. 				    errmax = f2cmax(errmax,err);

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

  2719. /*                             return. */

  2720. 				    if (*fatal) {

  2721. 					goto L140;

  2722. 				    }

  2723. /* L70: */

  2724. 				}

  2725. 			    }

  2726. 

  2727. /* L80: */

  2728. 			}

  2729. 

  2730. /* L90: */

  2731. 		    }

  2732. 

  2733. /* L100: */

  2734. 		}

  2735. 

  2736. L110:

  2737. 		;

  2738. 	    }

  2739. 

  2740. /* L120: */

  2741. 	}

  2742. 

  2743. L130:

  2744. 	;

  2745.     }

  2746. 

  2747. /*     Report result. */

  2748. 

  2749.     if (errmax < *thresh) {

  2750. 	if (*iorder == 0) {

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

  2752. 	}

  2753. 	if (*iorder == 1) {

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

  2755. 	}

  2756.     } else {

  2757. 	if (*iorder == 0) {

  2758.             printf("%s COMPLETED THE COLUMN-MAJOR COMPUTATIONAL TESTS (%d CALLS)/n",sname,nc);

  2759.             printf("***** BUT WITH MAXIMUM TEST RATIO %8.2f - SUSPECT *******/n",errmax);

  2760. 	}

  2761. 	if (*iorder == 1) {

  2762.             printf("%s COMPLETED THE ROW-MAJOR COMPUTATIONAL TESTS (%d CALLS)/n",sname,nc);

  2763.             printf("***** BUT WITH MAXIMUM TEST RATIO %8.2f - SUSPECT *******/n",errmax);

  2764. 	}

  2765.     }

  2766.     goto L160;

  2767. 

  2768. L140:

  2769.     if (n > 1) {

  2770.         printf("      THESE ARE THE RESULTS FOR COLUMN %d:\n",j);

  2771.     }

  2772. 

  2773. L150:

  2774.     printf(" ******* %s FAILED ON CALL NUMBER:\n",sname);

  2775.     dprcn5_(nout, &nc, sname, iorder, uplo, trans, &n, &k, &alpha, &lda, &ldb,

  2776. 	     &beta, &ldc, (ftnlen)12, (ftnlen)1, (ftnlen)1);

  2777. 

  2778. L160:

  2779.     return 0;

  2780. 

  2781. /* 9994 FORMAT( 1X, I6, ': ', A12,'(', 2( '''', A1, ''',' ), 2( I3, ',' ), */

  2782. /*     $      F4.1, ', A,', I3, ', B,', I3, ',', F4.1, ', C,', I3, ')   ', */

  2783. /*     $      ' .' ) */

  2784. 

  2785. /*     End of DCHK5. */

  2786. 

  2787. } /* dchk5_ */

  2788. 

  2789. 

  2790. /* Subroutine */ void dprcn5_(integer* nout, integer* nc, char* sname, integer* iorder, char* uplo, char* transa, integer* n, integer* k, doublereal* alpha, integer* lda, integer* ldb, doublereal* beta, integer* ldc, ftnlen sname_len, ftnlen uplo_len, ftnlen transa_len)

  2791. {

  2792. 

  2793.     /* Local variables */

  2794.     static char ca[14], cu[14], crc[14];

  2795. 

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

  2797. 	s_copy(cu, "    CblasUpper", (ftnlen)14, (ftnlen)14);

  2798.     } else {

  2799. 	s_copy(cu, "    CblasLower", (ftnlen)14, (ftnlen)14);

  2800.     }

  2801.     if (*(unsigned char *)transa == 'N') {

  2802. 	s_copy(ca, "  CblasNoTrans", (ftnlen)14, (ftnlen)14);

  2803.     } else if (*(unsigned char *)transa == 'T') {

  2804. 	s_copy(ca, "    CblasTrans", (ftnlen)14, (ftnlen)14);

  2805.     } else {

  2806. 	s_copy(ca, "CblasConjTrans", (ftnlen)14, (ftnlen)14);

  2807.     }

  2808.     if (*iorder == 1) {

  2809. 	s_copy(crc, " CblasRowMajor", (ftnlen)14, (ftnlen)14);

  2810.     } else {

  2811. 	s_copy(crc, " CblasColMajor", (ftnlen)14, (ftnlen)14);

  2812.     }

  2813.     printf("%6d: %s %s %s %s\n",*nc,sname,crc,cu,ca);

  2814.     printf("%d %d %4.1f , A, %d, B, %d, %4.1f , C, %d.\n",*n,*k,*alpha,*lda,*ldb,*beta,*ldc);

  2815. } /* dprcn5_ */

  2816. 

  2817. 

  2818. /* Subroutine */ int dmake_(char* type__, char* uplo, char* diag, integer* m, integer* n, doublereal* a, integer* nmax, doublereal* aa, integer* lda, logical* reset, doublereal* transl, ftnlen type_len, ftnlen uplo_len, ftnlen diag_len)

  2819. {

  2820.     /* System generated locals */

  2821.     integer a_dim1, a_offset, i__1, i__2;

  2822. 

  2823.     /* Local variables */

  2824.     extern doublereal dbeg_(logical*);

  2825.     static integer ibeg, iend;

  2826.     static logical unit;

  2827.     static integer i__, j;

  2828.     static logical lower, upper, gen, tri, sym;

  2829. 

  2830. 

  2831. /*  Generates values for an M by N matrix A. */

  2832. /*  Stores the values in the array AA in the data structure required */

  2833. /*  by the routine, with unwanted elements set to rogue value. */

  2834. 

  2835. /*  TYPE is 'GE', 'SY' or 'TR'. */

  2836. 

  2837. /*  Auxiliary routine for test program for Level 3 Blas. */

  2838. 

  2839. /*  -- Written on 8-February-1989. */

  2840. /*     Jack Dongarra, Argonne National Laboratory. */

  2841. /*     Iain Duff, AERE Harwell. */

  2842. /*     Jeremy Du Croz, Numerical Algorithms Group Ltd. */

  2843. /*     Sven Hammarling, Numerical Algorithms Group Ltd. */

  2844. 

  2845. /*     .. Parameters .. */

  2846. /*     .. Scalar Arguments .. */

  2847. /*     .. Array Arguments .. */

  2848. /*     .. Local Scalars .. */

  2849. /*     .. External Functions .. */

  2850. /*     .. Executable Statements .. */

  2851.     /* Parameter adjustments */

  2852.     a_dim1 = *nmax;

  2853.     a_offset = 1 + a_dim1 * 1;

  2854.     a -= a_offset;

  2855.     --aa;

  2856. 

  2857.     /* Function Body */

  2858.     gen = s_cmp(type__, "GE", (ftnlen)2, (ftnlen)2) == 0;

  2859.     sym = s_cmp(type__, "SY", (ftnlen)2, (ftnlen)2) == 0;

  2860.     tri = s_cmp(type__, "TR", (ftnlen)2, (ftnlen)2) == 0;

  2861.     upper = (sym || tri) && *(unsigned char *)uplo == 'U';

  2862.     lower = (sym || tri) && *(unsigned char *)uplo == 'L';

  2863.     unit = tri && *(unsigned char *)diag == 'U';

  2864. 

  2865. /*     Generate data in array A. */

  2866. 

  2867.     i__1 = *n;

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

  2869. 	i__2 = *m;

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

  2871. 	    if (gen || (upper && i__ <= j) || (lower && i__ >= j)) {

  2872. 		a[i__ + j * a_dim1] = dbeg_(reset) + *transl;

  2873. 		if (i__ != j) {

  2874. /*                 Set some elements to zero */

  2875. 		    if (*n > 3 && j == *n / 2) {

  2876. 			a[i__ + j * a_dim1] = 0.;

  2877. 		    }

  2878. 		    if (sym) {

  2879. 			a[j + i__ * a_dim1] = a[i__ + j * a_dim1];

  2880. 		    } else if (tri) {

  2881. 			a[j + i__ * a_dim1] = 0.;

  2882. 		    }

  2883. 		}

  2884. 	    }

  2885. /* L10: */

  2886. 	}

  2887. 	if (tri) {

  2888. 	    a[j + j * a_dim1] += 1.;

  2889. 	}

  2890. 	if (unit) {

  2891. 	    a[j + j * a_dim1] = 1.;

  2892. 	}

  2893. /* L20: */

  2894.     }

  2895. 

  2896. /*     Store elements in array AS in data structure required by routine. */

  2897. 

  2898.     if (s_cmp(type__, "GE", (ftnlen)2, (ftnlen)2) == 0) {

  2899. 	i__1 = *n;

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

  2901. 	    i__2 = *m;

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

  2903. 		aa[i__ + (j - 1) * *lda] = a[i__ + j * a_dim1];

  2904. /* L30: */

  2905. 	    }

  2906. 	    i__2 = *lda;

  2907. 	    for (i__ = *m + 1; i__ <= i__2; ++i__) {

  2908. 		aa[i__ + (j - 1) * *lda] = -1e10;

  2909. /* L40: */

  2910. 	    }

  2911. /* L50: */

  2912. 	}

  2913.     } else if (s_cmp(type__, "SY", (ftnlen)2, (ftnlen)2) == 0 || s_cmp(type__,

  2914. 	     "TR", (ftnlen)2, (ftnlen)2) == 0) {

  2915. 	i__1 = *n;

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

  2917. 	    if (upper) {

  2918. 		ibeg = 1;

  2919. 		if (unit) {

  2920. 		    iend = j - 1;

  2921. 		} else {

  2922. 		    iend = j;

  2923. 		}

  2924. 	    } else {

  2925. 		if (unit) {

  2926. 		    ibeg = j + 1;

  2927. 		} else {

  2928. 		    ibeg = j;

  2929. 		}

  2930. 		iend = *n;

  2931. 	    }

  2932. 	    i__2 = ibeg - 1;

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

  2934. 		aa[i__ + (j - 1) * *lda] = -1e10;

  2935. /* L60: */

  2936. 	    }

  2937. 	    i__2 = iend;

  2938. 	    for (i__ = ibeg; i__ <= i__2; ++i__) {

  2939. 		aa[i__ + (j - 1) * *lda] = a[i__ + j * a_dim1];

  2940. /* L70: */

  2941. 	    }

  2942. 	    i__2 = *lda;

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

  2944. 		aa[i__ + (j - 1) * *lda] = -1e10;

  2945. /* L80: */

  2946. 	    }

  2947. /* L90: */

  2948. 	}

  2949.     }

  2950.     return 0;

  2951. 

  2952. /*     End of DMAKE. */

  2953. 

  2954. } /* dmake_ */

  2955. 

  2956. /* Subroutine */ int dmmch_(char* transa, char* transb, integer* m, integer* n, integer* kk, doublereal* alpha, doublereal* a, integer* lda, doublereal* b, integer* ldb, doublereal* beta, doublereal* c__, integer* ldc, doublereal* ct, doublereal* g, doublereal* cc, integer* ldcc, doublereal* eps, doublereal* err, logical* fatal, integer* nout, logical* mv, ftnlen transa_len, ftnlen transb_len)

  2957. {

  2958.     /* System generated locals */

  2959.     integer a_dim1, a_offset, b_dim1, b_offset, c_dim1, c_offset, cc_dim1, 

  2960. 	    cc_offset, i__1, i__2, i__3;

  2961.     doublereal d__1, d__2;

  2962. 

  2963.     /* Builtin functions */

  2964.     double sqrt(double);

  2965. 

  2966.     /* Local variables */

  2967.     static doublereal erri;

  2968.     static integer i__, j, k;

  2969.     static logical trana, tranb;

  2970. 

  2971. /*  Checks the results of the computational tests. */

  2972. 

  2973. /*  Auxiliary routine for test program for Level 3 Blas. */

  2974. 

  2975. /*  -- Written on 8-February-1989. */

  2976. /*     Jack Dongarra, Argonne National Laboratory. */

  2977. /*     Iain Duff, AERE Harwell. */

  2978. /*     Jeremy Du Croz, Numerical Algorithms Group Ltd. */

  2979. /*     Sven Hammarling, Numerical Algorithms Group Ltd. */

  2980. 

  2981. /*     .. Parameters .. */

  2982. /*     .. Scalar Arguments .. */

  2983. /*     .. Array Arguments .. */

  2984. /*     .. Local Scalars .. */

  2985. /*     .. Intrinsic Functions .. */

  2986. /*     .. Executable Statements .. */

  2987.     /* Parameter adjustments */

  2988.     a_dim1 = *lda;

  2989.     a_offset = 1 + a_dim1 * 1;

  2990.     a -= a_offset;

  2991.     b_dim1 = *ldb;

  2992.     b_offset = 1 + b_dim1 * 1;

  2993.     b -= b_offset;

  2994.     c_dim1 = *ldc;

  2995.     c_offset = 1 + c_dim1 * 1;

  2996.     c__ -= c_offset;

  2997.     --ct;

  2998.     --g;

  2999.     cc_dim1 = *ldcc;

  3000.     cc_offset = 1 + cc_dim1 * 1;

  3001.     cc -= cc_offset;

  3002. 

  3003.     /* Function Body */

  3004.     trana = *(unsigned char *)transa == 'T' || *(unsigned char *)transa == 

  3005. 	    'C';

  3006.     tranb = *(unsigned char *)transb == 'T' || *(unsigned char *)transb == 

  3007. 	    'C';

  3008. 

  3009. /*     Compute expected result, one column at a time, in CT using data */

  3010. /*     in A, B and C. */

  3011. /*     Compute gauges in G. */

  3012. 

  3013.     i__1 = *n;

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

  3015. 

  3016. 	i__2 = *m;

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

  3018. 	    ct[i__] = 0.;

  3019. 	    g[i__] = 0.;

  3020. /* L10: */

  3021. 	}

  3022. 	if (! trana && ! tranb) {

  3023. 	    i__2 = *kk;

  3024. 	    for (k = 1; k <= i__2; ++k) {

  3025. 		i__3 = *m;

  3026. 		for (i__ = 1; i__ <= i__3; ++i__) {

  3027. 		    ct[i__] += a[i__ + k * a_dim1] * b[k + j * b_dim1];

  3028. 		    g[i__] += (d__1 = a[i__ + k * a_dim1], abs(d__1)) * (d__2 

  3029. 			    = b[k + j * b_dim1], abs(d__2));

  3030. /* L20: */

  3031. 		}

  3032. /* L30: */

  3033. 	    }

  3034. 	} else if (trana && ! tranb) {

  3035. 	    i__2 = *kk;

  3036. 	    for (k = 1; k <= i__2; ++k) {

  3037. 		i__3 = *m;

  3038. 		for (i__ = 1; i__ <= i__3; ++i__) {

  3039. 		    ct[i__] += a[k + i__ * a_dim1] * b[k + j * b_dim1];

  3040. 		    g[i__] += (d__1 = a[k + i__ * a_dim1], abs(d__1)) * (d__2 

  3041. 			    = b[k + j * b_dim1], abs(d__2));

  3042. /* L40: */

  3043. 		}

  3044. /* L50: */

  3045. 	    }

  3046. 	} else if (! trana && tranb) {

  3047. 	    i__2 = *kk;

  3048. 	    for (k = 1; k <= i__2; ++k) {

  3049. 		i__3 = *m;

  3050. 		for (i__ = 1; i__ <= i__3; ++i__) {

  3051. 		    ct[i__] += a[i__ + k * a_dim1] * b[j + k * b_dim1];

  3052. 		    g[i__] += (d__1 = a[i__ + k * a_dim1], abs(d__1)) * (d__2 

  3053. 			    = b[j + k * b_dim1], abs(d__2));

  3054. /* L60: */

  3055. 		}

  3056. /* L70: */

  3057. 	    }

  3058. 	} else if (trana && tranb) {

  3059. 	    i__2 = *kk;

  3060. 	    for (k = 1; k <= i__2; ++k) {

  3061. 		i__3 = *m;

  3062. 		for (i__ = 1; i__ <= i__3; ++i__) {

  3063. 		    ct[i__] += a[k + i__ * a_dim1] * b[j + k * b_dim1];

  3064. 		    g[i__] += (d__1 = a[k + i__ * a_dim1], abs(d__1)) * (d__2 

  3065. 			    = b[j + k * b_dim1], abs(d__2));

  3066. /* L80: */

  3067. 		}

  3068. /* L90: */

  3069. 	    }

  3070. 	}

  3071. 	i__2 = *m;

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

  3073. 	    ct[i__] = *alpha * ct[i__] + *beta * c__[i__ + j * c_dim1];

  3074. 	    g[i__] = abs(*alpha) * g[i__] + abs(*beta) * (d__1 = c__[i__ + j *

  3075. 		     c_dim1], abs(d__1));

  3076. /* L100: */

  3077. 	}

  3078. 

  3079. /*        Compute the error ratio for this result. */

  3080. 

  3081. 	*err = 0.;

  3082. 	i__2 = *m;

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

  3084. 	    erri = (d__1 = ct[i__] - cc[i__ + j * cc_dim1], abs(d__1)) / *eps;

  3085. 	    if (g[i__] != 0.) {

  3086. 		erri /= g[i__];

  3087. 	    }

  3088. 	    *err = f2cmax(*err,erri);

  3089. 	    if (*err * sqrt(*eps) >= 1.) {

  3090. 		goto L130;

  3091. 	    }

  3092. /* L110: */

  3093. 	}

  3094. 

  3095. /* L120: */

  3096.     }

  3097. 

  3098. /*     If the loop completes, all results are at least half accurate. */

  3099.     goto L150;

  3100. 

  3101. /*     Report fatal error. */

  3102. 

  3103. L130:

  3104.     *fatal = TRUE_;

  3105.     printf(" ******* FATAL ERROR - COMPUTED RESULT IS LESS THAN HALF ACCURATE *******\n");

  3106.     printf("         EXPECTED RESULT                    COMPUTED RESULT\n");

  3107.     i__1 = *m;

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

  3109. 	if (*mv) {

  3110.             printf("%7d %15.6g %15.6g\n",i__,ct[i__],cc[i__+j*cc_dim1]);

  3111. 	} else {

  3112.             printf("%7d %15.6g %15.6g\n",i__,cc[i__+j*cc_dim1],ct[i__]);

  3113. 	}

  3114. /* L140: */

  3115.     }

  3116.     if (*n > 1) {

  3117.         printf("      THESE ARE THE RESULTS FOR COLUMN %d\n",j);

  3118.     }

  3119. 

  3120. L150:

  3121.     return 0;

  3122. 

  3123. 

  3124. /*     End of DMMCH. */

  3125. 

  3126. } /* dmmch_ */

  3127. 

  3128. logical lde_(doublereal* ri, doublereal* rj, integer* lr)

  3129. {

  3130.     /* System generated locals */

  3131.     integer i__1;

  3132.     logical ret_val;

  3133. 

  3134.     /* Local variables */

  3135.     static integer i__;

  3136. 

  3137. 

  3138. /*  Tests if two arrays are identical. */

  3139. 

  3140. /*  Auxiliary routine for test program for Level 3 Blas. */

  3141. 

  3142. /*  -- Written on 8-February-1989. */

  3143. /*     Jack Dongarra, Argonne National Laboratory. */

  3144. /*     Iain Duff, AERE Harwell. */

  3145. /*     Jeremy Du Croz, Numerical Algorithms Group Ltd. */

  3146. /*     Sven Hammarling, Numerical Algorithms Group Ltd. */

  3147. 

  3148. /*     .. Scalar Arguments .. */

  3149. /*     .. Array Arguments .. */

  3150. /*     .. Local Scalars .. */

  3151. /*     .. Executable Statements .. */

  3152.     /* Parameter adjustments */

  3153.     --rj;

  3154.     --ri;

  3155. 

  3156.     /* Function Body */

  3157.     i__1 = *lr;

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

  3159. 	if (ri[i__] != rj[i__]) {

  3160. 	    goto L20;

  3161. 	}

  3162. /* L10: */

  3163.     }

  3164.     ret_val = TRUE_;

  3165.     goto L30;

  3166. L20:

  3167.     ret_val = FALSE_;

  3168. L30:

  3169.     return ret_val;

  3170. 

  3171. /*     End of LDE. */

  3172. 

  3173. } /* lde_ */

  3174. 

  3175. logical lderes_(char* type__, char* uplo, integer* m, integer* n, doublereal* aa, doublereal* as, integer* lda, ftnlen type_len, ftnlen uplo_len)

  3176. {

  3177.     /* System generated locals */

  3178.     integer aa_dim1, aa_offset, as_dim1, as_offset, i__1, i__2;

  3179.     logical ret_val;

  3180. 

  3181.     /* Local variables */

  3182.     static integer ibeg, iend, i__, j;

  3183.     static logical upper;

  3184. 

  3185. 

  3186. /*  Tests if selected elements in two arrays are equal. */

  3187. 

  3188. /*  TYPE is 'GE' or 'SY'. */

  3189. 

  3190. /*  Auxiliary routine for test program for Level 3 Blas. */

  3191. 

  3192. /*  -- Written on 8-February-1989. */

  3193. /*     Jack Dongarra, Argonne National Laboratory. */

  3194. /*     Iain Duff, AERE Harwell. */

  3195. /*     Jeremy Du Croz, Numerical Algorithms Group Ltd. */

  3196. /*     Sven Hammarling, Numerical Algorithms Group Ltd. */

  3197. 

  3198. /*     .. Scalar Arguments .. */

  3199. /*     .. Array Arguments .. */

  3200. /*     .. Local Scalars .. */

  3201. /*     .. Executable Statements .. */

  3202.     /* Parameter adjustments */

  3203.     as_dim1 = *lda;

  3204.     as_offset = 1 + as_dim1 * 1;

  3205.     as -= as_offset;

  3206.     aa_dim1 = *lda;

  3207.     aa_offset = 1 + aa_dim1 * 1;

  3208.     aa -= aa_offset;

  3209. 

  3210.     /* Function Body */

  3211.     upper = *(unsigned char *)uplo == 'U';

  3212.     if (s_cmp(type__, "GE", (ftnlen)2, (ftnlen)2) == 0) {

  3213. 	i__1 = *n;

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

  3215. 	    i__2 = *lda;

  3216. 	    for (i__ = *m + 1; i__ <= i__2; ++i__) {

  3217. 		if (aa[i__ + j * aa_dim1] != as[i__ + j * as_dim1]) {

  3218. 		    goto L70;

  3219. 		}

  3220. /* L10: */

  3221. 	    }

  3222. /* L20: */

  3223. 	}

  3224.     } else if (s_cmp(type__, "SY", (ftnlen)2, (ftnlen)2) == 0) {

  3225. 	i__1 = *n;

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

  3227. 	    if (upper) {

  3228. 		ibeg = 1;

  3229. 		iend = j;

  3230. 	    } else {

  3231. 		ibeg = j;

  3232. 		iend = *n;

  3233. 	    }

  3234. 	    i__2 = ibeg - 1;

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

  3236. 		if (aa[i__ + j * aa_dim1] != as[i__ + j * as_dim1]) {

  3237. 		    goto L70;

  3238. 		}

  3239. /* L30: */

  3240. 	    }

  3241. 	    i__2 = *lda;

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

  3243. 		if (aa[i__ + j * aa_dim1] != as[i__ + j * as_dim1]) {

  3244. 		    goto L70;

  3245. 		}

  3246. /* L40: */

  3247. 	    }

  3248. /* L50: */

  3249. 	}

  3250.     }

  3251. 

  3252. /*   60 CONTINUE */

  3253.     ret_val = TRUE_;

  3254.     goto L80;

  3255. L70:

  3256.     ret_val = FALSE_;

  3257. L80:

  3258.     return ret_val;

  3259. 

  3260. /*     End of LDERES. */

  3261. 

  3262. } /* lderes_ */

  3263. 

  3264. doublereal dbeg_(logical* reset)

  3265. {

  3266.     /* System generated locals */

  3267.     doublereal ret_val;

  3268. 

  3269.     /* Local variables */

  3270.     static integer i__, ic, mi;

  3271. 

  3272. 

  3273. /*  Generates random numbers uniformly distributed between -0.5 and 0.5. */

  3274. 

  3275. /*  Auxiliary routine for test program for Level 3 Blas. */

  3276. 

  3277. /*  -- Written on 8-February-1989. */

  3278. /*     Jack Dongarra, Argonne National Laboratory. */

  3279. /*     Iain Duff, AERE Harwell. */

  3280. /*     Jeremy Du Croz, Numerical Algorithms Group Ltd. */

  3281. /*     Sven Hammarling, Numerical Algorithms Group Ltd. */

  3282. 

  3283. /*     .. Scalar Arguments .. */

  3284. /*     .. Local Scalars .. */

  3285. /*     .. Save statement .. */

  3286. /*     .. Executable Statements .. */

  3287.     if (*reset) {

  3288. /*        Initialize local variables. */

  3289. 	mi = 891;

  3290. 	i__ = 7;

  3291. 	ic = 0;

  3292. 	*reset = FALSE_;

  3293.     }

  3294. 

  3295. /*     The sequence of values of I is bounded between 1 and 999. */

  3296. /*     If initial I = 1,2,3,6,7 or 9, the period will be 50. */

  3297. /*     If initial I = 4 or 8, the period will be 25. */

  3298. /*     If initial I = 5, the period will be 10. */

  3299. /*     IC is used to break up the period by skipping 1 value of I in 6. */

  3300. 

  3301.     ++ic;

  3302. L10:

  3303.     i__ *= mi;

  3304.     i__ -= i__ / 1000 * 1000;

  3305.     if (ic >= 5) {

  3306. 	ic = 0;

  3307. 	goto L10;

  3308.     }

  3309.     ret_val = (i__ - 500) / 1001.;

  3310.     return ret_val;

  3311. 

  3312. /*     End of DBEG. */

  3313. 

  3314. } /* dbeg_ */

  3315. 

  3316. doublereal ddiff_(doublereal* x, doublereal* y)

  3317. {

  3318.     /* System generated locals */

  3319.     doublereal ret_val;

  3320. 

  3321. 

  3322. /*  Auxiliary routine for test program for Level 3 Blas. */

  3323. 

  3324. /*  -- Written on 8-February-1989. */

  3325. /*     Jack Dongarra, Argonne National Laboratory. */

  3326. /*     Iain Duff, AERE Harwell. */

  3327. /*     Jeremy Du Croz, Numerical Algorithms Group Ltd. */

  3328. /*     Sven Hammarling, Numerical Algorithms Group Ltd. */

  3329. 

  3330. /*     .. Scalar Arguments .. */

  3331. /*     .. Executable Statements .. */

  3332.     ret_val = *x - *y;

  3333.     return ret_val;

  3334. 

  3335. /*     End of DDIFF. */

  3336. 

  3337. } /* ddiff_ */

  3338. 

  3339. /* Main program alias */ /*int dblat3_ () { MAIN__ (); }*/