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

1290 lines
46 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. #if defined(_WIN64)

  14. typedef long long BLASLONG;

  15. typedef unsigned long long BLASULONG;

  16. #else

  17. typedef long BLASLONG;

  18. typedef unsigned long BLASULONG;

  19. #endif

  20. 

  21. #ifdef LAPACK_ILP64

  22. typedef BLASLONG blasint;

  23. #if defined(_WIN64)

  24. #define blasabs(x) llabs(x)

  25. #else

  26. #define blasabs(x) labs(x)

  27. #endif

  28. #else

  29. typedef int blasint;

  30. #define blasabs(x) abs(x)

  31. #endif

  32. 

  33. typedef blasint integer;

  34. 

  35. typedef unsigned int uinteger;

  36. typedef char *address;

  37. typedef short int shortint;

  38. typedef float real;

  39. typedef double doublereal;

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

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

  42. #ifdef _MSC_VER

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

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

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

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

  47. #else

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

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

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

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

  52. #endif

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

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

  55. typedef int logical;

  56. typedef short int shortlogical;

  57. typedef char logical1;

  58. typedef char integer1;

  59. 

  60. #define TRUE_ (1)

  61. #define FALSE_ (0)

  62. 

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

  64. #ifndef Extern

  65. #define Extern extern

  66. #endif

  67. 

  68. /* I/O stuff */

  69. 

  70. typedef int flag;

  71. typedef int ftnlen;

  72. typedef int ftnint;

  73. 

  74. /*external read, write*/

  75. typedef struct

  76. {	flag cierr;

  77. 	ftnint ciunit;

  78. 	flag ciend;

  79. 	char *cifmt;

  80. 	ftnint cirec;

  81. } cilist;

  82. 

  83. /*internal read, write*/

  84. typedef struct

  85. {	flag icierr;

  86. 	char *iciunit;

  87. 	flag iciend;

  88. 	char *icifmt;

  89. 	ftnint icirlen;

  90. 	ftnint icirnum;

  91. } icilist;

  92. 

  93. /*open*/

  94. typedef struct

  95. {	flag oerr;

  96. 	ftnint ounit;

  97. 	char *ofnm;

  98. 	ftnlen ofnmlen;

  99. 	char *osta;

  100. 	char *oacc;

  101. 	char *ofm;

  102. 	ftnint orl;

  103. 	char *oblnk;

  104. } olist;

  105. 

  106. /*close*/

  107. typedef struct

  108. {	flag cerr;

  109. 	ftnint cunit;

  110. 	char *csta;

  111. } cllist;

  112. 

  113. /*rewind, backspace, endfile*/

  114. typedef struct

  115. {	flag aerr;

  116. 	ftnint aunit;

  117. } alist;

  118. 

  119. /* inquire */

  120. typedef struct

  121. {	flag inerr;

  122. 	ftnint inunit;

  123. 	char *infile;

  124. 	ftnlen infilen;

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

  126. 	ftnint	*inopen;

  127. 	ftnint	*innum;

  128. 	ftnint	*innamed;

  129. 	char	*inname;

  130. 	ftnlen	innamlen;

  131. 	char	*inacc;

  132. 	ftnlen	inacclen;

  133. 	char	*inseq;

  134. 	ftnlen	inseqlen;

  135. 	char 	*indir;

  136. 	ftnlen	indirlen;

  137. 	char	*infmt;

  138. 	ftnlen	infmtlen;

  139. 	char	*inform;

  140. 	ftnint	informlen;

  141. 	char	*inunf;

  142. 	ftnlen	inunflen;

  143. 	ftnint	*inrecl;

  144. 	ftnint	*innrec;

  145. 	char	*inblank;

  146. 	ftnlen	inblanklen;

  147. } inlist;

  148. 

  149. #define VOID void

  150. 

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

  152. 	integer1 g;

  153. 	shortint h;

  154. 	integer i;

  155. 	/* longint j; */

  156. 	real r;

  157. 	doublereal d;

  158. 	complex c;

  159. 	doublecomplex z;

  160. 	};

  161. 

  162. typedef union Multitype Multitype;

  163. 

  164. struct Vardesc {	/* for Namelist */

  165. 	char *name;

  166. 	char *addr;

  167. 	ftnlen *dims;

  168. 	int  type;

  169. 	};

  170. typedef struct Vardesc Vardesc;

  171. 

  172. struct Namelist {

  173. 	char *name;

  174. 	Vardesc **vars;

  175. 	int nvars;

  176. 	};

  177. typedef struct Namelist Namelist;

  178. 

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

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

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

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

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

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

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

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

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

  188. 

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

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

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

  192. #ifdef _MSC_VER

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

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

  195. #else

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

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

  198. #endif

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

  253. #define myexit_() break;

  254. #define mycycle_() continue;

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

  256. #define myhuge_(w) {HUGE_VAL}

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

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

  259. 

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

  261. 

  262. #define F2C_proc_par_types 1

  263. #ifdef __cplusplus

  264. typedef logical (*L_fp)(...);

  265. #else

  266. typedef logical (*L_fp)();

  267. #endif

  268. 

  269. #if 0

  270. static float spow_ui(float x, integer n) {

  271. 	float pow=1.0; unsigned long int u;

  272. 	if(n != 0) {

  273. 		if(n < 0) n = -n, x = 1/x;

  274. 		for(u = n; ; ) {

  275. 			if(u & 01) pow *= x;

  276. 			if(u >>= 1) x *= x;

  277. 			else break;

  278. 		}

  279. 	}

  280. 	return pow;

  281. }

  282. static double dpow_ui(double x, integer n) {

  283. 	double pow=1.0; unsigned long int u;

  284. 	if(n != 0) {

  285. 		if(n < 0) n = -n, x = 1/x;

  286. 		for(u = n; ; ) {

  287. 			if(u & 01) pow *= x;

  288. 			if(u >>= 1) x *= x;

  289. 			else break;

  290. 		}

  291. 	}

  292. 	return pow;

  293. }

  294. #ifdef _MSC_VER

  295. static _Fcomplex cpow_ui(complex x, integer n) {

  296. 	complex pow={1.0,0.0}; unsigned long int u;

  297. 		if(n != 0) {

  298. 		if(n < 0) n = -n, x.r = 1/x.r, x.i=1/x.i;

  299. 		for(u = n; ; ) {

  300. 			if(u & 01) pow.r *= x.r, pow.i *= x.i;

  301. 			if(u >>= 1) x.r *= x.r, x.i *= x.i;

  302. 			else break;

  303. 		}

  304. 	}

  305. 	_Fcomplex p={pow.r, pow.i};

  306. 	return p;

  307. }

  308. #else

  309. static _Complex float cpow_ui(_Complex float x, integer n) {

  310. 	_Complex float pow=1.0; unsigned long int u;

  311. 	if(n != 0) {

  312. 		if(n < 0) n = -n, x = 1/x;

  313. 		for(u = n; ; ) {

  314. 			if(u & 01) pow *= x;

  315. 			if(u >>= 1) x *= x;

  316. 			else break;

  317. 		}

  318. 	}

  319. 	return pow;

  320. }

  321. #endif

  322. #ifdef _MSC_VER

  323. static _Dcomplex zpow_ui(_Dcomplex x, integer n) {

  324. 	_Dcomplex pow={1.0,0.0}; unsigned long int u;

  325. 	if(n != 0) {

  326. 		if(n < 0) n = -n, x._Val[0] = 1/x._Val[0], x._Val[1] =1/x._Val[1];

  327. 		for(u = n; ; ) {

  328. 			if(u & 01) pow._Val[0] *= x._Val[0], pow._Val[1] *= x._Val[1];

  329. 			if(u >>= 1) x._Val[0] *= x._Val[0], x._Val[1] *= x._Val[1];

  330. 			else break;

  331. 		}

  332. 	}

  333. 	_Dcomplex p = {pow._Val[0], pow._Val[1]};

  334. 	return p;

  335. }

  336. #else

  337. static _Complex double zpow_ui(_Complex double x, integer n) {

  338. 	_Complex double pow=1.0; unsigned long int u;

  339. 	if(n != 0) {

  340. 		if(n < 0) n = -n, x = 1/x;

  341. 		for(u = n; ; ) {

  342. 			if(u & 01) pow *= x;

  343. 			if(u >>= 1) x *= x;

  344. 			else break;

  345. 		}

  346. 	}

  347. 	return pow;

  348. }

  349. #endif

  350. static integer pow_ii(integer x, integer n) {

  351. 	integer pow; unsigned long int u;

  352. 	if (n <= 0) {

  353. 		if (n == 0 || x == 1) pow = 1;

  354. 		else if (x != -1) pow = x == 0 ? 1/x : 0;

  355. 		else n = -n;

  356. 	}

  357. 	if ((n > 0) || !(n == 0 || x == 1 || x != -1)) {

  358. 		u = n;

  359. 		for(pow = 1; ; ) {

  360. 			if(u & 01) pow *= x;

  361. 			if(u >>= 1) x *= x;

  362. 			else break;

  363. 		}

  364. 	}

  365. 	return pow;

  366. }

  367. static integer dmaxloc_(double *w, integer s, integer e, integer *n)

  368. {

  369. 	double m; integer i, mi;

  370. 	for(m=w[s-1], mi=s, i=s+1; i<=e; i++)

  371. 		if (w[i-1]>m) mi=i ,m=w[i-1];

  372. 	return mi-s+1;

  373. }

  374. static integer smaxloc_(float *w, integer s, integer e, integer *n)

  375. {

  376. 	float m; integer i, mi;

  377. 	for(m=w[s-1], mi=s, i=s+1; i<=e; i++)

  378. 		if (w[i-1]>m) mi=i ,m=w[i-1];

  379. 	return mi-s+1;

  380. }

  381. #endif

  382. static inline void cdotc_(complex *z, integer *n_, complex *x, integer *incx_, complex *y, integer *incy_) {

  383. 	integer n = *n_, incx = *incx_, incy = *incy_, i;

  384. #ifdef _MSC_VER

  385. 	_Fcomplex zdotc = {0.0, 0.0};

  386. 	if (incx == 1 && incy == 1) {

  387. 		for (i=0;i<n;i++) { /* zdotc = zdotc + dconjg(x(i))* y(i) */

  388. 			zdotc._Val[0] += conjf(Cf(&x[i]))._Val[0] * Cf(&y[i])._Val[0];

  389. 			zdotc._Val[1] += conjf(Cf(&x[i]))._Val[1] * Cf(&y[i])._Val[1];

  390. 		}

  391. 	} else {

  392. 		for (i=0;i<n;i++) { /* zdotc = zdotc + dconjg(x(i))* y(i) */

  393. 			zdotc._Val[0] += conjf(Cf(&x[i*incx]))._Val[0] * Cf(&y[i*incy])._Val[0];

  394. 			zdotc._Val[1] += conjf(Cf(&x[i*incx]))._Val[1] * Cf(&y[i*incy])._Val[1];

  395. 		}

  396. 	}

  397. 	pCf(z) = zdotc;

  398. }

  399. #else

  400. 	_Complex float zdotc = 0.0;

  401. 	if (incx == 1 && incy == 1) {

  402. 		for (i=0;i<n;i++) { /* zdotc = zdotc + dconjg(x(i))* y(i) */

  403. 			zdotc += conjf(Cf(&x[i])) * Cf(&y[i]);

  404. 		}

  405. 	} else {

  406. 		for (i=0;i<n;i++) { /* zdotc = zdotc + dconjg(x(i))* y(i) */

  407. 			zdotc += conjf(Cf(&x[i*incx])) * Cf(&y[i*incy]);

  408. 		}

  409. 	}

  410. 	pCf(z) = zdotc;

  411. }

  412. #endif

  413. static inline void zdotc_(doublecomplex *z, integer *n_, doublecomplex *x, integer *incx_, doublecomplex *y, integer *incy_) {

  414. 	integer n = *n_, incx = *incx_, incy = *incy_, i;

  415. #ifdef _MSC_VER

  416. 	_Dcomplex zdotc = {0.0, 0.0};

  417. 	if (incx == 1 && incy == 1) {

  418. 		for (i=0;i<n;i++) { /* zdotc = zdotc + dconjg(x(i))* y(i) */

  419. 			zdotc._Val[0] += conj(Cd(&x[i]))._Val[0] * Cd(&y[i])._Val[0];

  420. 			zdotc._Val[1] += conj(Cd(&x[i]))._Val[1] * Cd(&y[i])._Val[1];

  421. 		}

  422. 	} else {

  423. 		for (i=0;i<n;i++) { /* zdotc = zdotc + dconjg(x(i))* y(i) */

  424. 			zdotc._Val[0] += conj(Cd(&x[i*incx]))._Val[0] * Cd(&y[i*incy])._Val[0];

  425. 			zdotc._Val[1] += conj(Cd(&x[i*incx]))._Val[1] * Cd(&y[i*incy])._Val[1];

  426. 		}

  427. 	}

  428. 	pCd(z) = zdotc;

  429. }

  430. #else

  431. 	_Complex double zdotc = 0.0;

  432. 	if (incx == 1 && incy == 1) {

  433. 		for (i=0;i<n;i++) { /* zdotc = zdotc + dconjg(x(i))* y(i) */

  434. 			zdotc += conj(Cd(&x[i])) * Cd(&y[i]);

  435. 		}

  436. 	} else {

  437. 		for (i=0;i<n;i++) { /* zdotc = zdotc + dconjg(x(i))* y(i) */

  438. 			zdotc += conj(Cd(&x[i*incx])) * Cd(&y[i*incy]);

  439. 		}

  440. 	}

  441. 	pCd(z) = zdotc;

  442. }

  443. #endif	

  444. static inline void cdotu_(complex *z, integer *n_, complex *x, integer *incx_, complex *y, integer *incy_) {

  445. 	integer n = *n_, incx = *incx_, incy = *incy_, i;

  446. #ifdef _MSC_VER

  447. 	_Fcomplex zdotc = {0.0, 0.0};

  448. 	if (incx == 1 && incy == 1) {

  449. 		for (i=0;i<n;i++) { /* zdotc = zdotc + dconjg(x(i))* y(i) */

  450. 			zdotc._Val[0] += Cf(&x[i])._Val[0] * Cf(&y[i])._Val[0];

  451. 			zdotc._Val[1] += Cf(&x[i])._Val[1] * Cf(&y[i])._Val[1];

  452. 		}

  453. 	} else {

  454. 		for (i=0;i<n;i++) { /* zdotc = zdotc + dconjg(x(i))* y(i) */

  455. 			zdotc._Val[0] += Cf(&x[i*incx])._Val[0] * Cf(&y[i*incy])._Val[0];

  456. 			zdotc._Val[1] += Cf(&x[i*incx])._Val[1] * Cf(&y[i*incy])._Val[1];

  457. 		}

  458. 	}

  459. 	pCf(z) = zdotc;

  460. }

  461. #else

  462. 	_Complex float zdotc = 0.0;

  463. 	if (incx == 1 && incy == 1) {

  464. 		for (i=0;i<n;i++) { /* zdotc = zdotc + dconjg(x(i))* y(i) */

  465. 			zdotc += Cf(&x[i]) * Cf(&y[i]);

  466. 		}

  467. 	} else {

  468. 		for (i=0;i<n;i++) { /* zdotc = zdotc + dconjg(x(i))* y(i) */

  469. 			zdotc += Cf(&x[i*incx]) * Cf(&y[i*incy]);

  470. 		}

  471. 	}

  472. 	pCf(z) = zdotc;

  473. }

  474. #endif

  475. static inline void zdotu_(doublecomplex *z, integer *n_, doublecomplex *x, integer *incx_, doublecomplex *y, integer *incy_) {

  476. 	integer n = *n_, incx = *incx_, incy = *incy_, i;

  477. #ifdef _MSC_VER

  478. 	_Dcomplex zdotc = {0.0, 0.0};

  479. 	if (incx == 1 && incy == 1) {

  480. 		for (i=0;i<n;i++) { /* zdotc = zdotc + dconjg(x(i))* y(i) */

  481. 			zdotc._Val[0] += Cd(&x[i])._Val[0] * Cd(&y[i])._Val[0];

  482. 			zdotc._Val[1] += Cd(&x[i])._Val[1] * Cd(&y[i])._Val[1];

  483. 		}

  484. 	} else {

  485. 		for (i=0;i<n;i++) { /* zdotc = zdotc + dconjg(x(i))* y(i) */

  486. 			zdotc._Val[0] += Cd(&x[i*incx])._Val[0] * Cd(&y[i*incy])._Val[0];

  487. 			zdotc._Val[1] += Cd(&x[i*incx])._Val[1] * Cd(&y[i*incy])._Val[1];

  488. 		}

  489. 	}

  490. 	pCd(z) = zdotc;

  491. }

  492. #else

  493. 	_Complex double zdotc = 0.0;

  494. 	if (incx == 1 && incy == 1) {

  495. 		for (i=0;i<n;i++) { /* zdotc = zdotc + dconjg(x(i))* y(i) */

  496. 			zdotc += Cd(&x[i]) * Cd(&y[i]);

  497. 		}

  498. 	} else {

  499. 		for (i=0;i<n;i++) { /* zdotc = zdotc + dconjg(x(i))* y(i) */

  500. 			zdotc += Cd(&x[i*incx]) * Cd(&y[i*incy]);

  501. 		}

  502. 	}

  503. 	pCd(z) = zdotc;

  504. }

  505. #endif

  506. 

  507. /* Common Block Declarations */

  508. 

  509. struct {

  510.     integer icase, n, incx, incy, mode;

  511.     logical pass;

  512. } combla_;

  513. 

  514. #define combla_1 combla_

  515. 

  516. /* Table of constant values */

  517. 

  518. static integer c__1 = 1;

  519. static integer c__5 = 5;

  520. static real c_b43 = (float)1.;

  521. 

  522. /* Main program */ int main()

  523. {

  524.     /* Initialized data */

  525. 

  526.     static real sfac = (float)9.765625e-4;

  527. 

  528.     /* Local variables */

  529.     extern /* Subroutine */ int check1_(), check2_();

  530.     static integer ic;

  531.     extern /* Subroutine */ int header_();

  532. 

  533. /*     Test program for the COMPLEX    Level 1 CBLAS. */

  534. /*     Based upon the original CBLAS test routine together with: */

  535. /*     F06GAF Example Program Text */

  536. /*     .. Parameters .. */

  537. /*     .. Scalars in Common .. */

  538. /*     .. Local Scalars .. */

  539. /*     .. External Subroutines .. */

  540. /*     .. Common blocks .. */

  541. /*     .. Data statements .. */

  542. /*     .. Executable Statements .. */

  543.     printf("Complex CBLAS Test Program Results\n");

  544.     for (ic = 1; ic <= 10; ++ic) {

  545. 	combla_1.icase = ic;

  546. 	header_();

  547. 

  548. /*        Initialize PASS, INCX, INCY, and MODE for a new case. */

  549. /*        The value 9999 for INCX, INCY or MODE will appear in the */

  550. /*        detailed  output, if any, for cases that do not involve */

  551. /*        these parameters. */

  552. 

  553. 	combla_1.pass = TRUE_;

  554. 	combla_1.incx = 9999;

  555. 	combla_1.incy = 9999;

  556. 	combla_1.mode = 9999;

  557. 	if (combla_1.icase <= 5) {

  558. 	    check2_(&sfac);

  559. 	} else if (combla_1.icase >= 6) {

  560. 	    check1_(&sfac);

  561. 	}

  562. /*        -- Print */

  563. 	if (combla_1.pass) {

  564. 	printf("                                    ----- PASS -----\n");

  565. 	}

  566. /* L20: */

  567.     }

  568.     exit(0);

  569. 

  570. } /* MAIN__ */

  571. 

  572. /* Subroutine */ int header_()

  573. {

  574.     /* Initialized data */

  575. 

  576.     static char l[15][13] = {"CBLAS_CDOTC " , "CBLAS_CDOTU " , "CBLAS_CAXPY " ,

  577.     "CBLAS_CCOPY " , "CBLAS_CSWAP " , "CBLAS_SCNRM2" , "CBLAS_SCASUM" , "CBLAS_CSCAL " ,

  578.     "CBLAS_CSSCAL" , "CBLAS_ICAMAX" };

  579. 

  580.     /* Format strings */

  581. 

  582.     /* Builtin functions */

  583.     integer s_wsfe(), do_fio(), e_wsfe();

  584. 

  585. /*     .. Parameters .. */

  586. /*     .. Scalars in Common .. */

  587. /*     .. Local Arrays .. */

  588. /*     .. Common blocks .. */

  589. /*     .. Data statements .. */

  590. /*     .. Executable Statements .. */

  591.     printf("Test of subprogram number %3d         %15s\n", combla_1.icase, l[combla_1.icase - 1]);

  592.     return 0;

  593. 

  594. } /* header_ */

  595. 

  596. /* Subroutine */ int check1_(sfac)

  597. real *sfac;

  598. {

  599.     /* Initialized data */

  600. 

  601.     static real strue2[5] = { (float)0.,(float).5,(float).6,(float).7,(float)

  602. 	    .7 };

  603.     static real strue4[5] = { (float)0.,(float).7,(float)1.,(float)1.3,(float)

  604. 	    1.7 };

  605.     static complex ctrue5[80]	/* was [8][5][2] */ = { {(float).1,(float).1},

  606. 	    {(float)1.,(float)2.},{(float)1.,(float)2.},{(float)1.,(float)2.},

  607. 	    {(float)1.,(float)2.},{(float)1.,(float)2.},{(float)1.,(float)2.},

  608. 	    {(float)1.,(float)2.},{(float)-.16,(float)-.37},{(float)3.,(float)

  609. 	    4.},{(float)3.,(float)4.},{(float)3.,(float)4.},{(float)3.,(float)

  610. 	    4.},{(float)3.,(float)4.},{(float)3.,(float)4.},{(float)3.,(float)

  611. 	    4.},{(float)-.17,(float)-.19},{(float).13,(float)-.39},{(float)5.,

  612. 	    (float)6.},{(float)5.,(float)6.},{(float)5.,(float)6.},{(float)5.,

  613. 	    (float)6.},{(float)5.,(float)6.},{(float)5.,(float)6.},{(float)

  614. 	    .11,(float)-.03},{(float)-.17,(float).46},{(float)-.17,(float)

  615. 	    -.19},{(float)7.,(float)8.},{(float)7.,(float)8.},{(float)7.,(

  616. 	    float)8.},{(float)7.,(float)8.},{(float)7.,(float)8.},{(float).19,

  617. 	    (float)-.17},{(float).32,(float).09},{(float).23,(float)-.24},{(

  618. 	    float).18,(float).01},{(float)2.,(float)3.},{(float)2.,(float)3.},

  619. 	    {(float)2.,(float)3.},{(float)2.,(float)3.},{(float).1,(float).1},

  620. 	    {(float)4.,(float)5.},{(float)4.,(float)5.},{(float)4.,(float)5.},

  621. 	    {(float)4.,(float)5.},{(float)4.,(float)5.},{(float)4.,(float)5.},

  622. 	    {(float)4.,(float)5.},{(float)-.16,(float)-.37},{(float)6.,(float)

  623. 	    7.},{(float)6.,(float)7.},{(float)6.,(float)7.},{(float)6.,(float)

  624. 	    7.},{(float)6.,(float)7.},{(float)6.,(float)7.},{(float)6.,(float)

  625. 	    7.},{(float)-.17,(float)-.19},{(float)8.,(float)9.},{(float).13,(

  626. 	    float)-.39},{(float)2.,(float)5.},{(float)2.,(float)5.},{(float)

  627. 	    2.,(float)5.},{(float)2.,(float)5.},{(float)2.,(float)5.},{(float)

  628. 	    .11,(float)-.03},{(float)3.,(float)6.},{(float)-.17,(float).46},{(

  629. 	    float)4.,(float)7.},{(float)-.17,(float)-.19},{(float)7.,(float)

  630. 	    2.},{(float)7.,(float)2.},{(float)7.,(float)2.},{(float).19,(

  631. 	    float)-.17},{(float)5.,(float)8.},{(float).32,(float).09},{(float)

  632. 	    6.,(float)9.},{(float).23,(float)-.24},{(float)8.,(float)3.},{(

  633. 	    float).18,(float).01},{(float)9.,(float)4.} };

  634.     static complex ctrue6[80]	/* was [8][5][2] */ = { {(float).1,(float).1},

  635. 	    {(float)1.,(float)2.},{(float)1.,(float)2.},{(float)1.,(float)2.},

  636. 	    {(float)1.,(float)2.},{(float)1.,(float)2.},{(float)1.,(float)2.},

  637. 	    {(float)1.,(float)2.},{(float).09,(float)-.12},{(float)3.,(float)

  638. 	    4.},{(float)3.,(float)4.},{(float)3.,(float)4.},{(float)3.,(float)

  639. 	    4.},{(float)3.,(float)4.},{(float)3.,(float)4.},{(float)3.,(float)

  640. 	    4.},{(float).03,(float)-.09},{(float).15,(float)-.03},{(float)5.,(

  641. 	    float)6.},{(float)5.,(float)6.},{(float)5.,(float)6.},{(float)5.,(

  642. 	    float)6.},{(float)5.,(float)6.},{(float)5.,(float)6.},{(float).03,

  643. 	    (float).03},{(float)-.18,(float).03},{(float).03,(float)-.09},{(

  644. 	    float)7.,(float)8.},{(float)7.,(float)8.},{(float)7.,(float)8.},{(

  645. 	    float)7.,(float)8.},{(float)7.,(float)8.},{(float).09,(float).03},

  646. 	    {(float).03,(float).12},{(float).12,(float).03},{(float).03,(

  647. 	    float).06},{(float)2.,(float)3.},{(float)2.,(float)3.},{(float)2.,

  648. 	    (float)3.},{(float)2.,(float)3.},{(float).1,(float).1},{(float)4.,

  649. 	    (float)5.},{(float)4.,(float)5.},{(float)4.,(float)5.},{(float)4.,

  650. 	    (float)5.},{(float)4.,(float)5.},{(float)4.,(float)5.},{(float)4.,

  651. 	    (float)5.},{(float).09,(float)-.12},{(float)6.,(float)7.},{(float)

  652. 	    6.,(float)7.},{(float)6.,(float)7.},{(float)6.,(float)7.},{(float)

  653. 	    6.,(float)7.},{(float)6.,(float)7.},{(float)6.,(float)7.},{(float)

  654. 	    .03,(float)-.09},{(float)8.,(float)9.},{(float).15,(float)-.03},{(

  655. 	    float)2.,(float)5.},{(float)2.,(float)5.},{(float)2.,(float)5.},{(

  656. 	    float)2.,(float)5.},{(float)2.,(float)5.},{(float).03,(float).03},

  657. 	    {(float)3.,(float)6.},{(float)-.18,(float).03},{(float)4.,(float)

  658. 	    7.},{(float).03,(float)-.09},{(float)7.,(float)2.},{(float)7.,(

  659. 	    float)2.},{(float)7.,(float)2.},{(float).09,(float).03},{(float)

  660. 	    5.,(float)8.},{(float).03,(float).12},{(float)6.,(float)9.},{(

  661. 	    float).12,(float).03},{(float)8.,(float)3.},{(float).03,(float)

  662. 	    .06},{(float)9.,(float)4.} };

  663.     static integer itrue3[5] = { 0,1,2,2,2 };

  664.     static real sa = (float).3;

  665.     static complex ca = {(float).4,(float)-.7};

  666.     static complex cv[80]	/* was [8][5][2] */ = { {(float).1,(float).1},

  667. 	    {(float)1.,(float)2.},{(float)1.,(float)2.},{(float)1.,(float)2.},

  668. 	    {(float)1.,(float)2.},{(float)1.,(float)2.},{(float)1.,(float)2.},

  669. 	    {(float)1.,(float)2.},{(float).3,(float)-.4},{(float)3.,(float)4.}

  670. 	    ,{(float)3.,(float)4.},{(float)3.,(float)4.},{(float)3.,(float)4.}

  671. 	    ,{(float)3.,(float)4.},{(float)3.,(float)4.},{(float)3.,(float)4.}

  672. 	    ,{(float).1,(float)-.3},{(float).5,(float)-.1},{(float)5.,(float)

  673. 	    6.},{(float)5.,(float)6.},{(float)5.,(float)6.},{(float)5.,(float)

  674. 	    6.},{(float)5.,(float)6.},{(float)5.,(float)6.},{(float).1,(float)

  675. 	    .1},{(float)-.6,(float).1},{(float).1,(float)-.3},{(float)7.,(

  676. 	    float)8.},{(float)7.,(float)8.},{(float)7.,(float)8.},{(float)7.,(

  677. 	    float)8.},{(float)7.,(float)8.},{(float).3,(float).1},{(float).1,(

  678. 	    float).4},{(float).4,(float).1},{(float).1,(float).2},{(float)2.,(

  679. 	    float)3.},{(float)2.,(float)3.},{(float)2.,(float)3.},{(float)2.,(

  680. 	    float)3.},{(float).1,(float).1},{(float)4.,(float)5.},{(float)4.,(

  681. 	    float)5.},{(float)4.,(float)5.},{(float)4.,(float)5.},{(float)4.,(

  682. 	    float)5.},{(float)4.,(float)5.},{(float)4.,(float)5.},{(float).3,(

  683. 	    float)-.4},{(float)6.,(float)7.},{(float)6.,(float)7.},{(float)6.,

  684. 	    (float)7.},{(float)6.,(float)7.},{(float)6.,(float)7.},{(float)6.,

  685. 	    (float)7.},{(float)6.,(float)7.},{(float).1,(float)-.3},{(float)

  686. 	    8.,(float)9.},{(float).5,(float)-.1},{(float)2.,(float)5.},{(

  687. 	    float)2.,(float)5.},{(float)2.,(float)5.},{(float)2.,(float)5.},{(

  688. 	    float)2.,(float)5.},{(float).1,(float).1},{(float)3.,(float)6.},{(

  689. 	    float)-.6,(float).1},{(float)4.,(float)7.},{(float).1,(float)-.3},

  690. 	    {(float)7.,(float)2.},{(float)7.,(float)2.},{(float)7.,(float)2.},

  691. 	    {(float).3,(float).1},{(float)5.,(float)8.},{(float).1,(float).4},

  692. 	    {(float)6.,(float)9.},{(float).4,(float).1},{(float)8.,(float)3.},

  693. 	    {(float).1,(float).2},{(float)9.,(float)4.} };

  694. 

  695.     /* System generated locals */

  696.     integer i__1, i__2, i__3;

  697.     real r__1;

  698.     complex q__1;

  699. 

  700.     /* Local variables */

  701.     static integer i__;

  702.     extern /* Subroutine */ int cscal_(), ctest_();

  703.     static complex mwpcs[5], mwpct[5];

  704.     extern /* Subroutine */ int itest1_(), stest1_();

  705.     static complex cx[8];

  706.     extern real scnrm2test_();

  707.     static integer np1;

  708.     extern integer icamaxtest_();

  709.     extern /* Subroutine */ int csscaltest_();

  710.     extern real scasumtest_();

  711.     static integer len;

  712. 

  713. /*     .. Parameters .. */

  714. /*     .. Scalar Arguments .. */

  715. /*     .. Scalars in Common .. */

  716. /*     .. Local Scalars .. */

  717. /*     .. Local Arrays .. */

  718. /*     .. External Functions .. */

  719. /*     .. External Subroutines .. */

  720. /*     .. Intrinsic Functions .. */

  721. /*     .. Common blocks .. */

  722. /*     .. Data statements .. */

  723. /*     .. Executable Statements .. */

  724.     for (combla_1.incx = 1; combla_1.incx <= 2; ++combla_1.incx) {

  725. 	for (np1 = 1; np1 <= 5; ++np1) {

  726. 	    combla_1.n = np1 - 1;

  727. 	    len = f2cmax(combla_1.n,1) << 1;

  728. /*           .. Set vector arguments .. */

  729. 	    i__1 = len;

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

  731. 		i__2 = i__ - 1;

  732. 		i__3 = i__ + (np1 + combla_1.incx * 5 << 3) - 49;

  733. 		cx[i__2].r = cv[i__3].r, cx[i__2].i = cv[i__3].i;

  734. /* L20: */

  735. 	    }

  736. 	    if (combla_1.icase == 6) {

  737. /*              .. SCNRM2TEST .. */

  738. 		r__1 = scnrm2test_(&combla_1.n, cx, &combla_1.incx);

  739. 		stest1_(&r__1, &strue2[np1 - 1], &strue2[np1 - 1], sfac);

  740. 	    } else if (combla_1.icase == 7) {

  741. /*              .. SCASUMTEST .. */

  742. 		r__1 = scasumtest_(&combla_1.n, cx, &combla_1.incx);

  743. 		stest1_(&r__1, &strue4[np1 - 1], &strue4[np1 - 1], sfac);

  744. 	    } else if (combla_1.icase == 8) {

  745. /*              .. CSCAL .. */

  746. 		cscal_(&combla_1.n, &ca, cx, &combla_1.incx);

  747. 		ctest_(&len, cx, &ctrue5[(np1 + combla_1.incx * 5 << 3) - 48],

  748. 			 &ctrue5[(np1 + combla_1.incx * 5 << 3) - 48], sfac);

  749. 	    } else if (combla_1.icase == 9) {

  750. /*              .. CSSCALTEST .. */

  751. 		csscaltest_(&combla_1.n, &sa, cx, &combla_1.incx);

  752. 		ctest_(&len, cx, &ctrue6[(np1 + combla_1.incx * 5 << 3) - 48],

  753. 			 &ctrue6[(np1 + combla_1.incx * 5 << 3) - 48], sfac);

  754. 	    } else if (combla_1.icase == 10) {

  755. /*              .. ICAMAXTEST .. */

  756. 		i__1 = icamaxtest_(&combla_1.n, cx, &combla_1.incx);

  757. 		itest1_(&i__1, &itrue3[np1 - 1]);

  758. 	    } else {

  759. 		fprintf(stderr,"Shouldn't be here in CHECK1\n");

  760. 		exit(0);

  761. 	    }

  762. 

  763. /* L40: */

  764. 	}

  765. /* L60: */

  766.     }

  767. 

  768.     combla_1.incx = 1;

  769.     if (combla_1.icase == 8) {

  770. /*        CSCAL */

  771. /*        Add a test for alpha equal to zero. */

  772. 	ca.r = (float)0., ca.i = (float)0.;

  773. 	for (i__ = 1; i__ <= 5; ++i__) {

  774. 	    i__1 = i__ - 1;

  775. 	    mwpct[i__1].r = (float)0., mwpct[i__1].i = (float)0.;

  776. 	    i__1 = i__ - 1;

  777. 	    mwpcs[i__1].r = (float)1., mwpcs[i__1].i = (float)1.;

  778. /* L80: */

  779. 	}

  780. 	cscal_(&c__5, &ca, cx, &combla_1.incx);

  781. 	ctest_(&c__5, cx, mwpct, mwpcs, sfac);

  782.     } else if (combla_1.icase == 9) {

  783. /*        CSSCALTEST */

  784. /*        Add a test for alpha equal to zero. */

  785. 	sa = (float)0.;

  786. 	for (i__ = 1; i__ <= 5; ++i__) {

  787. 	    i__1 = i__ - 1;

  788. 	    mwpct[i__1].r = (float)0., mwpct[i__1].i = (float)0.;

  789. 	    i__1 = i__ - 1;

  790. 	    mwpcs[i__1].r = (float)1., mwpcs[i__1].i = (float)1.;

  791. /* L100: */

  792. 	}

  793. 	csscaltest_(&c__5, &sa, cx, &combla_1.incx);

  794. 	ctest_(&c__5, cx, mwpct, mwpcs, sfac);

  795. /*        Add a test for alpha equal to one. */

  796. 	sa = (float)1.;

  797. 	for (i__ = 1; i__ <= 5; ++i__) {

  798. 	    i__1 = i__ - 1;

  799. 	    i__2 = i__ - 1;

  800. 	    mwpct[i__1].r = cx[i__2].r, mwpct[i__1].i = cx[i__2].i;

  801. 	    i__1 = i__ - 1;

  802. 	    i__2 = i__ - 1;

  803. 	    mwpcs[i__1].r = cx[i__2].r, mwpcs[i__1].i = cx[i__2].i;

  804. /* L120: */

  805. 	}

  806. 	csscaltest_(&c__5, &sa, cx, &combla_1.incx);

  807. 	ctest_(&c__5, cx, mwpct, mwpcs, sfac);

  808. /*        Add a test for alpha equal to minus one. */

  809. 	sa = (float)-1.;

  810. 	for (i__ = 1; i__ <= 5; ++i__) {

  811. 	    i__1 = i__ - 1;

  812. 	    i__2 = i__ - 1;

  813. 	    q__1.r = -cx[i__2].r, q__1.i = -cx[i__2].i;

  814. 	    mwpct[i__1].r = q__1.r, mwpct[i__1].i = q__1.i;

  815. 	    i__1 = i__ - 1;

  816. 	    i__2 = i__ - 1;

  817. 	    q__1.r = -cx[i__2].r, q__1.i = -cx[i__2].i;

  818. 	    mwpcs[i__1].r = q__1.r, mwpcs[i__1].i = q__1.i;

  819. /* L140: */

  820. 	}

  821. 	csscaltest_(&c__5, &sa, cx, &combla_1.incx);

  822. 	ctest_(&c__5, cx, mwpct, mwpcs, sfac);

  823.     }

  824.     return 0;

  825. } /* check1_ */

  826. 

  827. /* Subroutine */ int check2_(sfac)

  828. real *sfac;

  829. {

  830.     /* Initialized data */

  831. 

  832.     static complex ca = {(float).4,(float)-.7};

  833.     static integer incxs[4] = { 1,2,-2,-1 };

  834.     static integer incys[4] = { 1,-2,1,-2 };

  835.     static integer lens[8]	/* was [4][2] */ = { 1,1,2,4,1,1,3,7 };

  836.     static integer ns[4] = { 0,1,2,4 };

  837.     static complex cx1[7] = { {(float).7,(float)-.8},{(float)-.4,(float)-.7},{

  838. 	    (float)-.1,(float)-.9},{(float).2,(float)-.8},{(float)-.9,(float)

  839. 	    -.4},{(float).1,(float).4},{(float)-.6,(float).6} };

  840.     static complex cy1[7] = { {(float).6,(float)-.6},{(float)-.9,(float).5},{(

  841. 	    float).7,(float)-.6},{(float).1,(float)-.5},{(float)-.1,(float)

  842. 	    -.2},{(float)-.5,(float)-.3},{(float).8,(float)-.7} };

  843.     static complex ct8[112]	/* was [7][4][4] */ = { {(float).6,(float)-.6}

  844. 	    ,{(float)0.,(float)0.},{(float)0.,(float)0.},{(float)0.,(float)0.}

  845. 	    ,{(float)0.,(float)0.},{(float)0.,(float)0.},{(float)0.,(float)0.}

  846. 	    ,{(float).32,(float)-1.41},{(float)0.,(float)0.},{(float)0.,(

  847. 	    float)0.},{(float)0.,(float)0.},{(float)0.,(float)0.},{(float)0.,(

  848. 	    float)0.},{(float)0.,(float)0.},{(float).32,(float)-1.41},{(float)

  849. 	    -1.55,(float).5},{(float)0.,(float)0.},{(float)0.,(float)0.},{(

  850. 	    float)0.,(float)0.},{(float)0.,(float)0.},{(float)0.,(float)0.},{(

  851. 	    float).32,(float)-1.41},{(float)-1.55,(float).5},{(float).03,(

  852. 	    float)-.89},{(float)-.38,(float)-.96},{(float)0.,(float)0.},{(

  853. 	    float)0.,(float)0.},{(float)0.,(float)0.},{(float).6,(float)-.6},{

  854. 	    (float)0.,(float)0.},{(float)0.,(float)0.},{(float)0.,(float)0.},{

  855. 	    (float)0.,(float)0.},{(float)0.,(float)0.},{(float)0.,(float)0.},{

  856. 	    (float).32,(float)-1.41},{(float)0.,(float)0.},{(float)0.,(float)

  857. 	    0.},{(float)0.,(float)0.},{(float)0.,(float)0.},{(float)0.,(float)

  858. 	    0.},{(float)0.,(float)0.},{(float)-.07,(float)-.89},{(float)-.9,(

  859. 	    float).5},{(float).42,(float)-1.41},{(float)0.,(float)0.},{(float)

  860. 	    0.,(float)0.},{(float)0.,(float)0.},{(float)0.,(float)0.},{(float)

  861. 	    .78,(float).06},{(float)-.9,(float).5},{(float).06,(float)-.13},{(

  862. 	    float).1,(float)-.5},{(float)-.77,(float)-.49},{(float)-.5,(float)

  863. 	    -.3},{(float).52,(float)-1.51},{(float).6,(float)-.6},{(float)0.,(

  864. 	    float)0.},{(float)0.,(float)0.},{(float)0.,(float)0.},{(float)0.,(

  865. 	    float)0.},{(float)0.,(float)0.},{(float)0.,(float)0.},{(float).32,

  866. 	    (float)-1.41},{(float)0.,(float)0.},{(float)0.,(float)0.},{(float)

  867. 	    0.,(float)0.},{(float)0.,(float)0.},{(float)0.,(float)0.},{(float)

  868. 	    0.,(float)0.},{(float)-.07,(float)-.89},{(float)-1.18,(float)-.31}

  869. 	    ,{(float)0.,(float)0.},{(float)0.,(float)0.},{(float)0.,(float)0.}

  870. 	    ,{(float)0.,(float)0.},{(float)0.,(float)0.},{(float).78,(float)

  871. 	    .06},{(float)-1.54,(float).97},{(float).03,(float)-.89},{(float)

  872. 	    -.18,(float)-1.31},{(float)0.,(float)0.},{(float)0.,(float)0.},{(

  873. 	    float)0.,(float)0.},{(float).6,(float)-.6},{(float)0.,(float)0.},{

  874. 	    (float)0.,(float)0.},{(float)0.,(float)0.},{(float)0.,(float)0.},{

  875. 	    (float)0.,(float)0.},{(float)0.,(float)0.},{(float).32,(float)

  876. 	    -1.41},{(float)0.,(float)0.},{(float)0.,(float)0.},{(float)0.,(

  877. 	    float)0.},{(float)0.,(float)0.},{(float)0.,(float)0.},{(float)0.,(

  878. 	    float)0.},{(float).32,(float)-1.41},{(float)-.9,(float).5},{(

  879. 	    float).05,(float)-.6},{(float)0.,(float)0.},{(float)0.,(float)0.},

  880. 	    {(float)0.,(float)0.},{(float)0.,(float)0.},{(float).32,(float)

  881. 	    -1.41},{(float)-.9,(float).5},{(float).05,(float)-.6},{(float).1,(

  882. 	    float)-.5},{(float)-.77,(float)-.49},{(float)-.5,(float)-.3},{(

  883. 	    float).32,(float)-1.16} };

  884.     static complex ct7[16]	/* was [4][4] */ = { {(float)0.,(float)0.},{(

  885. 	    float)-.06,(float)-.9},{(float).65,(float)-.47},{(float)-.34,(

  886. 	    float)-1.22},{(float)0.,(float)0.},{(float)-.06,(float)-.9},{(

  887. 	    float)-.59,(float)-1.46},{(float)-1.04,(float)-.04},{(float)0.,(

  888. 	    float)0.},{(float)-.06,(float)-.9},{(float)-.83,(float).59},{(

  889. 	    float).07,(float)-.37},{(float)0.,(float)0.},{(float)-.06,(float)

  890. 	    -.9},{(float)-.76,(float)-1.15},{(float)-1.33,(float)-1.82} };

  891.     static complex ct6[16]	/* was [4][4] */ = { {(float)0.,(float)0.},{(

  892. 	    float).9,(float).06},{(float).91,(float)-.77},{(float)1.8,(float)

  893. 	    -.1},{(float)0.,(float)0.},{(float).9,(float).06},{(float)1.45,(

  894. 	    float).74},{(float).2,(float).9},{(float)0.,(float)0.},{(float).9,

  895. 	    (float).06},{(float)-.55,(float).23},{(float).83,(float)-.39},{(

  896. 	    float)0.,(float)0.},{(float).9,(float).06},{(float)1.04,(float)

  897. 	    .79},{(float)1.95,(float)1.22} };

  898.     static complex ct10x[112]	/* was [7][4][4] */ = { {(float).7,(float)-.8}

  899. 	    ,{(float)0.,(float)0.},{(float)0.,(float)0.},{(float)0.,(float)0.}

  900. 	    ,{(float)0.,(float)0.},{(float)0.,(float)0.},{(float)0.,(float)0.}

  901. 	    ,{(float).6,(float)-.6},{(float)0.,(float)0.},{(float)0.,(float)

  902. 	    0.},{(float)0.,(float)0.},{(float)0.,(float)0.},{(float)0.,(float)

  903. 	    0.},{(float)0.,(float)0.},{(float).6,(float)-.6},{(float)-.9,(

  904. 	    float).5},{(float)0.,(float)0.},{(float)0.,(float)0.},{(float)0.,(

  905. 	    float)0.},{(float)0.,(float)0.},{(float)0.,(float)0.},{(float).6,(

  906. 	    float)-.6},{(float)-.9,(float).5},{(float).7,(float)-.6},{(float)

  907. 	    .1,(float)-.5},{(float)0.,(float)0.},{(float)0.,(float)0.},{(

  908. 	    float)0.,(float)0.},{(float).7,(float)-.8},{(float)0.,(float)0.},{

  909. 	    (float)0.,(float)0.},{(float)0.,(float)0.},{(float)0.,(float)0.},{

  910. 	    (float)0.,(float)0.},{(float)0.,(float)0.},{(float).6,(float)-.6},

  911. 	    {(float)0.,(float)0.},{(float)0.,(float)0.},{(float)0.,(float)0.},

  912. 	    {(float)0.,(float)0.},{(float)0.,(float)0.},{(float)0.,(float)0.},

  913. 	    {(float).7,(float)-.6},{(float)-.4,(float)-.7},{(float).6,(float)

  914. 	    -.6},{(float)0.,(float)0.},{(float)0.,(float)0.},{(float)0.,(

  915. 	    float)0.},{(float)0.,(float)0.},{(float).8,(float)-.7},{(float)

  916. 	    -.4,(float)-.7},{(float)-.1,(float)-.2},{(float).2,(float)-.8},{(

  917. 	    float).7,(float)-.6},{(float).1,(float).4},{(float).6,(float)-.6},

  918. 	    {(float).7,(float)-.8},{(float)0.,(float)0.},{(float)0.,(float)0.}

  919. 	    ,{(float)0.,(float)0.},{(float)0.,(float)0.},{(float)0.,(float)0.}

  920. 	    ,{(float)0.,(float)0.},{(float).6,(float)-.6},{(float)0.,(float)

  921. 	    0.},{(float)0.,(float)0.},{(float)0.,(float)0.},{(float)0.,(float)

  922. 	    0.},{(float)0.,(float)0.},{(float)0.,(float)0.},{(float)-.9,(

  923. 	    float).5},{(float)-.4,(float)-.7},{(float).6,(float)-.6},{(float)

  924. 	    0.,(float)0.},{(float)0.,(float)0.},{(float)0.,(float)0.},{(float)

  925. 	    0.,(float)0.},{(float).1,(float)-.5},{(float)-.4,(float)-.7},{(

  926. 	    float).7,(float)-.6},{(float).2,(float)-.8},{(float)-.9,(float).5}

  927. 	    ,{(float).1,(float).4},{(float).6,(float)-.6},{(float).7,(float)

  928. 	    -.8},{(float)0.,(float)0.},{(float)0.,(float)0.},{(float)0.,(

  929. 	    float)0.},{(float)0.,(float)0.},{(float)0.,(float)0.},{(float)0.,(

  930. 	    float)0.},{(float).6,(float)-.6},{(float)0.,(float)0.},{(float)0.,

  931. 	    (float)0.},{(float)0.,(float)0.},{(float)0.,(float)0.},{(float)0.,

  932. 	    (float)0.},{(float)0.,(float)0.},{(float).6,(float)-.6},{(float)

  933. 	    .7,(float)-.6},{(float)0.,(float)0.},{(float)0.,(float)0.},{(

  934. 	    float)0.,(float)0.},{(float)0.,(float)0.},{(float)0.,(float)0.},{(

  935. 	    float).6,(float)-.6},{(float).7,(float)-.6},{(float)-.1,(float)

  936. 	    -.2},{(float).8,(float)-.7},{(float)0.,(float)0.},{(float)0.,(

  937. 	    float)0.},{(float)0.,(float)0.} };

  938.     static complex ct10y[112]	/* was [7][4][4] */ = { {(float).6,(float)-.6}

  939. 	    ,{(float)0.,(float)0.},{(float)0.,(float)0.},{(float)0.,(float)0.}

  940. 	    ,{(float)0.,(float)0.},{(float)0.,(float)0.},{(float)0.,(float)0.}

  941. 	    ,{(float).7,(float)-.8},{(float)0.,(float)0.},{(float)0.,(float)

  942. 	    0.},{(float)0.,(float)0.},{(float)0.,(float)0.},{(float)0.,(float)

  943. 	    0.},{(float)0.,(float)0.},{(float).7,(float)-.8},{(float)-.4,(

  944. 	    float)-.7},{(float)0.,(float)0.},{(float)0.,(float)0.},{(float)0.,

  945. 	    (float)0.},{(float)0.,(float)0.},{(float)0.,(float)0.},{(float).7,

  946. 	    (float)-.8},{(float)-.4,(float)-.7},{(float)-.1,(float)-.9},{(

  947. 	    float).2,(float)-.8},{(float)0.,(float)0.},{(float)0.,(float)0.},{

  948. 	    (float)0.,(float)0.},{(float).6,(float)-.6},{(float)0.,(float)0.},

  949. 	    {(float)0.,(float)0.},{(float)0.,(float)0.},{(float)0.,(float)0.},

  950. 	    {(float)0.,(float)0.},{(float)0.,(float)0.},{(float).7,(float)-.8}

  951. 	    ,{(float)0.,(float)0.},{(float)0.,(float)0.},{(float)0.,(float)0.}

  952. 	    ,{(float)0.,(float)0.},{(float)0.,(float)0.},{(float)0.,(float)0.}

  953. 	    ,{(float)-.1,(float)-.9},{(float)-.9,(float).5},{(float).7,(float)

  954. 	    -.8},{(float)0.,(float)0.},{(float)0.,(float)0.},{(float)0.,(

  955. 	    float)0.},{(float)0.,(float)0.},{(float)-.6,(float).6},{(float)

  956. 	    -.9,(float).5},{(float)-.9,(float)-.4},{(float).1,(float)-.5},{(

  957. 	    float)-.1,(float)-.9},{(float)-.5,(float)-.3},{(float).7,(float)

  958. 	    -.8},{(float).6,(float)-.6},{(float)0.,(float)0.},{(float)0.,(

  959. 	    float)0.},{(float)0.,(float)0.},{(float)0.,(float)0.},{(float)0.,(

  960. 	    float)0.},{(float)0.,(float)0.},{(float).7,(float)-.8},{(float)0.,

  961. 	    (float)0.},{(float)0.,(float)0.},{(float)0.,(float)0.},{(float)0.,

  962. 	    (float)0.},{(float)0.,(float)0.},{(float)0.,(float)0.},{(float)

  963. 	    -.1,(float)-.9},{(float).7,(float)-.8},{(float)0.,(float)0.},{(

  964. 	    float)0.,(float)0.},{(float)0.,(float)0.},{(float)0.,(float)0.},{(

  965. 	    float)0.,(float)0.},{(float)-.6,(float).6},{(float)-.9,(float)-.4}

  966. 	    ,{(float)-.1,(float)-.9},{(float).7,(float)-.8},{(float)0.,(float)

  967. 	    0.},{(float)0.,(float)0.},{(float)0.,(float)0.},{(float).6,(float)

  968. 	    -.6},{(float)0.,(float)0.},{(float)0.,(float)0.},{(float)0.,(

  969. 	    float)0.},{(float)0.,(float)0.},{(float)0.,(float)0.},{(float)0.,(

  970. 	    float)0.},{(float).7,(float)-.8},{(float)0.,(float)0.},{(float)0.,

  971. 	    (float)0.},{(float)0.,(float)0.},{(float)0.,(float)0.},{(float)0.,

  972. 	    (float)0.},{(float)0.,(float)0.},{(float).7,(float)-.8},{(float)

  973. 	    -.9,(float).5},{(float)-.4,(float)-.7},{(float)0.,(float)0.},{(

  974. 	    float)0.,(float)0.},{(float)0.,(float)0.},{(float)0.,(float)0.},{(

  975. 	    float).7,(float)-.8},{(float)-.9,(float).5},{(float)-.4,(float)

  976. 	    -.7},{(float).1,(float)-.5},{(float)-.1,(float)-.9},{(float)-.5,(

  977. 	    float)-.3},{(float).2,(float)-.8} };

  978.     static complex csize1[4] = { {(float)0.,(float)0.},{(float).9,(float).9},{

  979. 	    (float)1.63,(float)1.73},{(float)2.9,(float)2.78} };

  980.     static complex csize3[14] = { {(float)0.,(float)0.},{(float)0.,(float)0.},

  981. 	    {(float)0.,(float)0.},{(float)0.,(float)0.},{(float)0.,(float)0.},

  982. 	    {(float)0.,(float)0.},{(float)0.,(float)0.},{(float)1.17,(float)

  983. 	    1.17},{(float)1.17,(float)1.17},{(float)1.17,(float)1.17},{(float)

  984. 	    1.17,(float)1.17},{(float)1.17,(float)1.17},{(float)1.17,(float)

  985. 	    1.17},{(float)1.17,(float)1.17} };

  986.     static complex csize2[14]	/* was [7][2] */ = { {(float)0.,(float)0.},{(

  987. 	    float)0.,(float)0.},{(float)0.,(float)0.},{(float)0.,(float)0.},{(

  988. 	    float)0.,(float)0.},{(float)0.,(float)0.},{(float)0.,(float)0.},{(

  989. 	    float)1.54,(float)1.54},{(float)1.54,(float)1.54},{(float)1.54,(

  990. 	    float)1.54},{(float)1.54,(float)1.54},{(float)1.54,(float)1.54},{(

  991. 	    float)1.54,(float)1.54},{(float)1.54,(float)1.54} };

  992. 

  993.     /* System generated locals */

  994.     integer i__1, i__2;

  995. 

  996.     /* Local variables */

  997.     static complex cdot[1];

  998.     static integer lenx, leny, i__;

  999.     static complex ctemp;

  1000.     extern /* Subroutine */ int ctest_();

  1001.     static integer ksize;

  1002.     extern /* Subroutine */ int cdotctest_(), ccopytest_(), cdotutest_(), 

  1003. 	    cswaptest_(), caxpytest_();

  1004.     static integer ki, kn;

  1005.     static complex cx[7], cy[7];

  1006.     static integer mx, my;

  1007. 

  1008. /*     .. Parameters .. */

  1009. /*     .. Scalar Arguments .. */

  1010. /*     .. Scalars in Common .. */

  1011. /*     .. Local Scalars .. */

  1012. /*     .. Local Arrays .. */

  1013. /*     .. External Functions .. */

  1014. /*     .. External Subroutines .. */

  1015. /*     .. Intrinsic Functions .. */

  1016. /*     .. Common blocks .. */

  1017. /*     .. Data statements .. */

  1018. /*     .. Executable Statements .. */

  1019.     for (ki = 1; ki <= 4; ++ki) {

  1020. 	combla_1.incx = incxs[ki - 1];

  1021. 	combla_1.incy = incys[ki - 1];

  1022. 	mx = abs(combla_1.incx);

  1023. 	my = abs(combla_1.incy);

  1024. 

  1025. 	for (kn = 1; kn <= 4; ++kn) {

  1026. 	    combla_1.n = ns[kn - 1];

  1027. 	    ksize = f2cmin(2,kn);

  1028. 	    lenx = lens[kn + (mx << 2) - 5];

  1029. 	    leny = lens[kn + (my << 2) - 5];

  1030. /*           .. initialize all argument arrays .. */

  1031. 	    for (i__ = 1; i__ <= 7; ++i__) {

  1032. 		i__1 = i__ - 1;

  1033. 		i__2 = i__ - 1;

  1034. 		cx[i__1].r = cx1[i__2].r, cx[i__1].i = cx1[i__2].i;

  1035. 		i__1 = i__ - 1;

  1036. 		i__2 = i__ - 1;

  1037. 		cy[i__1].r = cy1[i__2].r, cy[i__1].i = cy1[i__2].i;

  1038. /* L20: */

  1039. 	    }

  1040. 	    if (combla_1.icase == 1) {

  1041. /*              .. CDOTCTEST .. */

  1042. 		cdotctest_(&combla_1.n, cx, &combla_1.incx, cy, &

  1043. 			combla_1.incy, &ctemp);

  1044. 		cdot[0].r = ctemp.r, cdot[0].i = ctemp.i;

  1045. 		ctest_(&c__1, cdot, &ct6[kn + (ki << 2) - 5], &csize1[kn - 1],

  1046. 			 sfac);

  1047. 	    } else if (combla_1.icase == 2) {

  1048. /*              .. CDOTUTEST .. */

  1049. 		cdotutest_(&combla_1.n, cx, &combla_1.incx, cy, &

  1050. 			combla_1.incy, &ctemp);

  1051. 		cdot[0].r = ctemp.r, cdot[0].i = ctemp.i;

  1052. 		ctest_(&c__1, cdot, &ct7[kn + (ki << 2) - 5], &csize1[kn - 1],

  1053. 			 sfac);

  1054. 	    } else if (combla_1.icase == 3) {

  1055. /*              .. CAXPYTEST .. */

  1056. 		caxpytest_(&combla_1.n, &ca, cx, &combla_1.incx, cy, &

  1057. 			combla_1.incy);

  1058. 		ctest_(&leny, cy, &ct8[(kn + (ki << 2)) * 7 - 35], &csize2[

  1059. 			ksize * 7 - 7], sfac);

  1060. 	    } else if (combla_1.icase == 4) {

  1061. /*              .. CCOPYTEST .. */

  1062. 		ccopytest_(&combla_1.n, cx, &combla_1.incx, cy, &

  1063. 			combla_1.incy);

  1064. 		ctest_(&leny, cy, &ct10y[(kn + (ki << 2)) * 7 - 35], csize3, &

  1065. 			c_b43);

  1066. 	    } else if (combla_1.icase == 5) {

  1067. /*              .. CSWAPTEST .. */

  1068. 		cswaptest_(&combla_1.n, cx, &combla_1.incx, cy, &

  1069. 			combla_1.incy);

  1070. 		ctest_(&lenx, cx, &ct10x[(kn + (ki << 2)) * 7 - 35], csize3, &

  1071. 			c_b43);

  1072. 		ctest_(&leny, cy, &ct10y[(kn + (ki << 2)) * 7 - 35], csize3, &

  1073. 			c_b43);

  1074. 	    } else {

  1075. 		fprintf(stderr,"Shouldn't be here in CHECK2\n");

  1076. 		exit(0);

  1077. 	    }

  1078. 

  1079. /* L40: */

  1080. 	}

  1081. /* L60: */

  1082.     }

  1083.     return 0;

  1084. } /* check2_ */

  1085. 

  1086. /* Subroutine */ int stest_(len, scomp, strue, ssize, sfac)

  1087. integer *len;

  1088. real *scomp, *strue, *ssize, *sfac;

  1089. {

  1090.     /* System generated locals */

  1091.     integer i__1;

  1092.     real r__1, r__2, r__3, r__4, r__5;

  1093. 

  1094.     /* Local variables */

  1095.     static integer i__;

  1096.     extern doublereal sdiff_();

  1097.     static real sd;

  1098. 

  1099. /*     ********************************* STEST ************************** */

  1100. 

  1101. /*     THIS SUBR COMPARES ARRAYS  SCOMP() AND STRUE() OF LENGTH LEN TO */

  1102. /*     SEE IF THE TERM BY TERM DIFFERENCES, MULTIPLIED BY SFAC, ARE */

  1103. /*     NEGLIGIBLE. */

  1104. 

  1105. /*     C. L. LAWSON, JPL, 1974 DEC 10 */

  1106. 

  1107. /*     .. Parameters .. */

  1108. /*     .. Scalar Arguments .. */

  1109. /*     .. Array Arguments .. */

  1110. /*     .. Scalars in Common .. */

  1111. /*     .. Local Scalars .. */

  1112. /*     .. External Functions .. */

  1113. /*     .. Intrinsic Functions .. */

  1114. /*     .. Common blocks .. */

  1115. /*     .. Executable Statements .. */

  1116. 

  1117.     /* Parameter adjustments */

  1118.     --ssize;

  1119.     --strue;

  1120.     --scomp;

  1121. 

  1122.     /* Function Body */

  1123.     i__1 = *len;

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

  1125. 	sd = scomp[i__] - strue[i__];

  1126. 	r__4 = (r__1 = ssize[i__], dabs(r__1)) + (r__2 = *sfac * sd, dabs(

  1127. 		r__2));

  1128. 	r__5 = (r__3 = ssize[i__], dabs(r__3));

  1129. 	if (sdiff_(&r__4, &r__5) == (float)0.) {

  1130. 	    goto L40;

  1131. 	}

  1132. 

  1133. /*                             HERE    SCOMP(I) IS NOT CLOSE TO STRUE(I). */

  1134. 

  1135. 	if (! combla_1.pass) {

  1136. 	    goto L20;

  1137. 	}

  1138. /*                             PRINT FAIL MESSAGE AND HEADER. */

  1139. 	combla_1.pass = FALSE_;

  1140. 	printf("                                       FAIL\n");

  1141. 	printf("CASE  N INCX INCY MODE  I                             COMP(I)                             TRUE(I)  DIFFERENCE     SIZE(I)\n");

  1142. L20:

  1143.         printf("%4d %3d %5d %5d %5d %3d %36.8e %36.8e %12.4e %12.4e\n",combla_1.icase, combla_1.n, combla_1.incx, combla_1.incy,

  1144. 	combla_1.mode, i__, scomp[i__], strue[i__], sd, ssize[i__]);

  1145. L40:

  1146. 	;

  1147.     }

  1148.     return 0;

  1149. 

  1150. } /* stest_ */

  1151. 

  1152. /* Subroutine */ int stest1_(scomp1, strue1, ssize, sfac)

  1153. real *scomp1, *strue1, *ssize, *sfac;

  1154. {

  1155.     static real scomp[1], strue[1];

  1156.     extern /* Subroutine */ int stest_();

  1157. 

  1158. /*     ************************* STEST1 ***************************** */

  1159. 

  1160. /*     THIS IS AN INTERFACE SUBROUTINE TO ACCOMMODATE THE FORTRAN */

  1161. /*     REQUIREMENT THAT WHEN A DUMMY ARGUMENT IS AN ARRAY, THE */

  1162. /*     ACTUAL ARGUMENT MUST ALSO BE AN ARRAY OR AN ARRAY ELEMENT. */

  1163. 

  1164. /*     C.L. LAWSON, JPL, 1978 DEC 6 */

  1165. 

  1166. /*     .. Scalar Arguments .. */

  1167. /*     .. Array Arguments .. */

  1168. /*     .. Local Arrays .. */

  1169. /*     .. External Subroutines .. */

  1170. /*     .. Executable Statements .. */

  1171. 

  1172.     /* Parameter adjustments */

  1173.     --ssize;

  1174. 

  1175.     /* Function Body */

  1176.     scomp[0] = *scomp1;

  1177.     strue[0] = *strue1;

  1178.     stest_(&c__1, scomp, strue, &ssize[1], sfac);

  1179. 

  1180.     return 0;

  1181. } /* stest1_ */

  1182. 

  1183. doublereal sdiff_(sa, sb)

  1184. real *sa, *sb;

  1185. {

  1186.     /* System generated locals */

  1187.     real ret_val;

  1188. 

  1189. /*     ********************************* SDIFF ************************** */

  1190. /*     COMPUTES DIFFERENCE OF TWO NUMBERS.  C. L. LAWSON, JPL 1974 FEB 15 */

  1191. 

  1192. /*     .. Scalar Arguments .. */

  1193. /*     .. Executable Statements .. */

  1194.     ret_val = *sa - *sb;

  1195.     return ret_val;

  1196. } /* sdiff_ */

  1197. 

  1198. /* Subroutine */ int ctest_(len, ccomp, ctrue, csize, sfac)

  1199. integer *len;

  1200. complex *ccomp, *ctrue, *csize;

  1201. real *sfac;

  1202. {

  1203.     /* System generated locals */

  1204.     integer i__1, i__2;

  1205. 

  1206.     /* Builtin functions */

  1207. //    double r_imag();

  1208. 

  1209.     /* Local variables */

  1210.     static integer i__;

  1211.     static real scomp[20], ssize[20], strue[20];

  1212.     extern /* Subroutine */ int stest_();

  1213. 

  1214. /*     **************************** CTEST ***************************** */

  1215. 

  1216. /*     C.L. LAWSON, JPL, 1978 DEC 6 */

  1217. 

  1218. /*     .. Scalar Arguments .. */

  1219. /*     .. Array Arguments .. */

  1220. /*     .. Local Scalars .. */

  1221. /*     .. Local Arrays .. */

  1222. /*     .. External Subroutines .. */

  1223. /*     .. Intrinsic Functions .. */

  1224. /*     .. Executable Statements .. */

  1225.     /* Parameter adjustments */

  1226.     --csize;

  1227.     --ctrue;

  1228.     --ccomp;

  1229. 

  1230.     /* Function Body */

  1231.     i__1 = *len;

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

  1233. 	i__2 = i__;

  1234. 	scomp[(i__ << 1) - 2] = ccomp[i__2].r;

  1235. 	scomp[(i__ << 1) - 1] = r_imag(&ccomp[i__]);

  1236. 	i__2 = i__;

  1237. 	strue[(i__ << 1) - 2] = ctrue[i__2].r;

  1238. 	strue[(i__ << 1) - 1] = r_imag(&ctrue[i__]);

  1239. 	i__2 = i__;

  1240. 	ssize[(i__ << 1) - 2] = csize[i__2].r;

  1241. 	ssize[(i__ << 1) - 1] = r_imag(&csize[i__]);

  1242. /* L20: */

  1243.     }

  1244. 

  1245.     i__1 = *len << 1;

  1246.     stest_(&i__1, scomp, strue, ssize, sfac);

  1247.     return 0;

  1248. } /* ctest_ */

  1249. 

  1250. /* Subroutine */ int itest1_(icomp, itrue)

  1251. integer *icomp, *itrue;

  1252. {

  1253.     /* Local variables */

  1254.     static integer id;

  1255. 

  1256. /*     ********************************* ITEST1 ************************* */

  1257. 

  1258. /*     THIS SUBROUTINE COMPARES THE VARIABLES ICOMP AND ITRUE FOR */

  1259. /*     EQUALITY. */

  1260. /*     C. L. LAWSON, JPL, 1974 DEC 10 */

  1261. 

  1262. /*     .. Parameters .. */

  1263. /*     .. Scalar Arguments .. */

  1264. /*     .. Scalars in Common .. */

  1265. /*     .. Local Scalars .. */

  1266. /*     .. Common blocks .. */

  1267. /*     .. Executable Statements .. */

  1268.     if (*icomp == *itrue) {

  1269. 	goto L40;

  1270.     }

  1271. 

  1272. /*                            HERE ICOMP IS NOT EQUAL TO ITRUE. */

  1273. 

  1274.     if (! combla_1.pass) {

  1275. 	goto L20;

  1276.     }

  1277. /*                             PRINT FAIL MESSAGE AND HEADER. */

  1278.     combla_1.pass = FALSE_;

  1279.     printf("                                       FAIL\n");

  1280.     printf(" CASE  N INCX INCY MODE                                COMP                                TRUE     DIFFERENCE\n");

  1281. L20:

  1282.     id = *icomp - *itrue;

  1283.     printf("%4d %3d %5d %5d %5d %36d %36d %12d\n",combla_1.icase, combla_1.n, combla_1.incx, combla_1.incy, 

  1284.     combla_1.mode, *icomp, *itrue, id);

  1285. L40:

  1286.     return 0;

  1287. 

  1288. } /* itest1_ */