1 /* zblat2.f -- translated by f2c (version 20100827).
2 You must link the resulting object file with libf2c:
3 on Microsoft Windows system, link with libf2c.lib;
4 on Linux or Unix systems, link with .../path/to/libf2c.a -lm
5 or, if you install libf2c.a in a standard place, with -lf2c -lm
6 -- in that order, at the end of the command line, as in
7 cc *.o -lf2c -lm
8 Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
9
10 http://www.netlib.org/f2c/libf2c.zip
11 */
12
13 #include "f2c.h"
14
15 /* Common Block Declarations */
16
17 union {
18 struct {
19 integer infot, noutc;
20 logical ok, lerr;
21 } _1;
22 struct {
23 integer infot, nout;
24 logical ok, lerr;
25 } _2;
26 } infoc_;
27
28 #define infoc_1 (infoc_._1)
29 #define infoc_2 (infoc_._2)
30
31 struct {
32 char srnamt[6];
33 } srnamc_;
34
35 #define srnamc_1 srnamc_
36
37 /* Table of constant values */
38
39 static doublecomplex c_b1 = {0.,0.};
40 static doublecomplex c_b2 = {1.,0.};
41 static integer c__9 = 9;
42 static integer c__1 = 1;
43 static integer c__3 = 3;
44 static integer c__8 = 8;
45 static integer c__5 = 5;
46 static integer c__65 = 65;
47 static integer c__7 = 7;
48 static integer c__2 = 2;
49 static doublereal c_b122 = 0.;
50 static logical c_true = TRUE_;
51 static integer c_n1 = -1;
52 static integer c__0 = 0;
53 static logical c_false = FALSE_;
54
55 /* > \brief \b ZBLAT2 */
56
57 /* =========== DOCUMENTATION =========== */
58
59 /* Online html documentation available at */
60 /* http://www.netlib.org/lapack/explore-html/ */
61
62 /* Definition: */
63 /* =========== */
64
65 /* PROGRAM ZBLAT2 */
66
67
68 /* > \par Purpose: */
69 /* ============= */
70 /* > */
71 /* > \verbatim */
72 /* > */
73 /* > Test program for the COMPLEX*16 Level 2 Blas. */
74 /* > */
75 /* > The program must be driven by a short data file. The first 18 records */
76 /* > of the file are read using list-directed input, the last 17 records */
77 /* > are read using the format ( A6, L2 ). An annotated example of a data */
78 /* > file can be obtained by deleting the first 3 characters from the */
79 /* > following 35 lines: */
80 /* > 'zblat2.out' NAME OF SUMMARY OUTPUT FILE */
81 /* > 6 UNIT NUMBER OF SUMMARY FILE */
82 /* > 'CBLA2T.SNAP' NAME OF SNAPSHOT OUTPUT FILE */
83 /* > -1 UNIT NUMBER OF SNAPSHOT FILE (NOT USED IF .LT. 0) */
84 /* > F LOGICAL FLAG, T TO REWIND SNAPSHOT FILE AFTER EACH RECORD. */
85 /* > F LOGICAL FLAG, T TO STOP ON FAILURES. */
86 /* > T LOGICAL FLAG, T TO TEST ERROR EXITS. */
87 /* > 16.0 THRESHOLD VALUE OF TEST RATIO */
88 /* > 6 NUMBER OF VALUES OF N */
89 /* > 0 1 2 3 5 9 VALUES OF N */
90 /* > 4 NUMBER OF VALUES OF K */
91 /* > 0 1 2 4 VALUES OF K */
92 /* > 4 NUMBER OF VALUES OF INCX AND INCY */
93 /* > 1 2 -1 -2 VALUES OF INCX AND INCY */
94 /* > 3 NUMBER OF VALUES OF ALPHA */
95 /* > (0.0,0.0) (1.0,0.0) (0.7,-0.9) VALUES OF ALPHA */
96 /* > 3 NUMBER OF VALUES OF BETA */
97 /* > (0.0,0.0) (1.0,0.0) (1.3,-1.1) VALUES OF BETA */
98 /* > ZGEMV T PUT F FOR NO TEST. SAME COLUMNS. */
99 /* > ZGBMV T PUT F FOR NO TEST. SAME COLUMNS. */
100 /* > ZHEMV T PUT F FOR NO TEST. SAME COLUMNS. */
101 /* > ZHBMV T PUT F FOR NO TEST. SAME COLUMNS. */
102 /* > ZHPMV T PUT F FOR NO TEST. SAME COLUMNS. */
103 /* > ZTRMV T PUT F FOR NO TEST. SAME COLUMNS. */
104 /* > ZTBMV T PUT F FOR NO TEST. SAME COLUMNS. */
105 /* > ZTPMV T PUT F FOR NO TEST. SAME COLUMNS. */
106 /* > ZTRSV T PUT F FOR NO TEST. SAME COLUMNS. */
107 /* > ZTBSV T PUT F FOR NO TEST. SAME COLUMNS. */
108 /* > ZTPSV T PUT F FOR NO TEST. SAME COLUMNS. */
109 /* > ZGERC T PUT F FOR NO TEST. SAME COLUMNS. */
110 /* > ZGERU T PUT F FOR NO TEST. SAME COLUMNS. */
111 /* > ZHER T PUT F FOR NO TEST. SAME COLUMNS. */
112 /* > ZHPR T PUT F FOR NO TEST. SAME COLUMNS. */
113 /* > ZHER2 T PUT F FOR NO TEST. SAME COLUMNS. */
114 /* > ZHPR2 T PUT F FOR NO TEST. SAME COLUMNS. */
115 /* > */
116 /* > Further Details */
117 /* > =============== */
118 /* > */
119 /* > See: */
120 /* > */
121 /* > Dongarra J. J., Du Croz J. J., Hammarling S. and Hanson R. J.. */
122 /* > An extended set of Fortran Basic Linear Algebra Subprograms. */
123 /* > */
124 /* > Technical Memoranda Nos. 41 (revision 3) and 81, Mathematics */
125 /* > and Computer Science Division, Argonne National Laboratory, */
126 /* > 9700 South Cass Avenue, Argonne, Illinois 60439, US. */
127 /* > */
128 /* > Or */
129 /* > */
130 /* > NAG Technical Reports TR3/87 and TR4/87, Numerical Algorithms */
131 /* > Group Ltd., NAG Central Office, 256 Banbury Road, Oxford */
132 /* > OX2 7DE, UK, and Numerical Algorithms Group Inc., 1101 31st */
133 /* > Street, Suite 100, Downers Grove, Illinois 60515-1263, USA. */
134 /* > */
135 /* > */
136 /* > -- Written on 10-August-1987. */
137 /* > Richard Hanson, Sandia National Labs. */
138 /* > Jeremy Du Croz, NAG Central Office. */
139 /* > */
140 /* > 10-9-00: Change STATUS='NEW' to 'UNKNOWN' so that the testers */
141 /* > can be run multiple times without deleting generated */
142 /* > output files (susan) */
143 /* > \endverbatim */
144
145 /* Authors: */
146 /* ======== */
147
148 /* > \author Univ. of Tennessee */
149 /* > \author Univ. of California Berkeley */
150 /* > \author Univ. of Colorado Denver */
151 /* > \author NAG Ltd. */
152
153 /* > \date April 2012 */
154
155 /* > \ingroup complex16_blas_testing */
156
157 /* ===================================================================== */
main(void)158 /* Main program */ int main(void)
159 {
160 /* Initialized data */
161
162 static char snames[6*17] = "ZGEMV " "ZGBMV " "ZHEMV " "ZHBMV " "ZHPMV "
163 "ZTRMV " "ZTBMV " "ZTPMV " "ZTRSV " "ZTBSV " "ZTPSV " "ZGERC "
164 "ZGERU " "ZHER " "ZHPR " "ZHER2 " "ZHPR2 ";
165
166 /* Format strings */
167 static char fmt_9997[] = "(\002 NUMBER OF VALUES OF \002,a,\002 IS LESS "
168 "THAN 1 OR GREATER \002,\002THAN \002,i2)";
169 static char fmt_9996[] = "(\002 VALUE OF N IS LESS THAN 0 OR GREATER THA"
170 "N \002,i2)";
171 static char fmt_9995[] = "(\002 VALUE OF K IS LESS THAN 0\002)";
172 static char fmt_9994[] = "(\002 ABSOLUTE VALUE OF INCX OR INCY IS 0 OR G"
173 "REATER THAN \002,i2)";
174 static char fmt_9993[] = "(\002 TESTS OF THE COMPLEX*16 LEVEL 2 BL"
175 "AS\002,//\002 THE F\002,\002OLLOWING PARAMETER VALUES WILL BE US"
176 "ED:\002)";
177 static char fmt_9992[] = "(\002 FOR N \002,9i6)";
178 static char fmt_9991[] = "(\002 FOR K \002,7i6)";
179 static char fmt_9990[] = "(\002 FOR INCX AND INCY \002,7i6)";
180 static char fmt_9989[] = "(\002 FOR ALPHA \002,7(\002(\002,f4"
181 ".1,\002,\002,f4.1,\002) \002,:))";
182 static char fmt_9988[] = "(\002 FOR BETA \002,7(\002(\002,f4"
183 ".1,\002,\002,f4.1,\002) \002,:))";
184 static char fmt_9980[] = "(\002 ERROR-EXITS WILL NOT BE TESTED\002)";
185 static char fmt_9999[] = "(\002 ROUTINES PASS COMPUTATIONAL TESTS IF TES"
186 "T RATIO IS LES\002,\002S THAN\002,f8.2)";
187 static char fmt_9984[] = "(a6,l2)";
188 static char fmt_9986[] = "(\002 SUBPROGRAM NAME \002,a6,\002 NOT RECOGNI"
189 "ZED\002,/\002 ******* T\002,\002ESTS ABANDONED *******\002)";
190 static char fmt_9998[] = "(\002 RELATIVE MACHINE PRECISION IS TAKEN TO"
191 " BE\002,1p,d9.1)";
192 static char fmt_9985[] = "(\002 ERROR IN ZMVCH - IN-LINE DOT PRODUCTS A"
193 "RE BEING EVALU\002,\002ATED WRONGLY.\002,/\002 ZMVCH WAS CALLED "
194 "WITH TRANS = \002,a1,\002 AND RETURNED SAME = \002,l1,\002 AND E"
195 "RR = \002,f12.3,\002.\002,/\002 THIS MAY BE DUE TO FAULTS IN THE"
196 " ARITHMETIC OR THE COMPILER.\002,/\002 ******* TESTS ABANDONED *"
197 "******\002)";
198 static char fmt_9983[] = "(1x,a6,\002 WAS NOT TESTED\002)";
199 static char fmt_9982[] = "(/\002 END OF TESTS\002)";
200 static char fmt_9981[] = "(/\002 ******* FATAL ERROR - TESTS ABANDONED *"
201 "******\002)";
202 static char fmt_9987[] = "(\002 AMEND DATA FILE OR INCREASE ARRAY SIZES "
203 "IN PROGRAM\002,/\002 ******* TESTS ABANDONED *******\002)";
204
205 /* System generated locals */
206 integer i__1, i__2, i__3, i__4, i__5;
207 olist o__1;
208 cllist cl__1;
209
210 /* Builtin functions */
211 integer s_rsle(cilist *), do_lio(integer *, integer *, char *, ftnlen),
212 e_rsle(void), f_open(olist *), s_wsfe(cilist *), do_fio(integer *,
213 char *, ftnlen), e_wsfe(void), s_wsle(cilist *), e_wsle(void),
214 s_rsfe(cilist *), e_rsfe(void), s_cmp(const char *, const char *, ftnlen,
215 ftnlen);
216 /* Subroutine */ int s_stop(char *, ftnlen);
217 integer f_clos(cllist *);
218 /* Subroutine */ int s_copy(char *, const char *, ftnlen, ftnlen);
219
220 /* Local variables */
221 doublecomplex a[4225] /* was [65][65] */;
222 doublereal g[65];
223 integer i__, j, n;
224 doublecomplex x[65], y[65], z__[130], aa[4225];
225 integer kb[7];
226 doublecomplex as[4225], xs[130], ys[130], yt[65], xx[130], yy[130], alf[7]
227 ;
228 integer inc[7], nkb;
229 doublecomplex bet[7];
230 doublereal eps, err;
231 extern logical lze_(doublecomplex *, doublecomplex *, integer *);
232 integer nalf, idim[9];
233 logical same;
234 integer ninc, nbet, ntra;
235 logical rewi;
236 integer nout;
237 extern /* Subroutine */ int zchk1_(char *, doublereal *, doublereal *,
238 integer *, integer *, logical *, logical *, logical *, integer *,
239 integer *, integer *, integer *, integer *, doublecomplex *,
240 integer *, doublecomplex *, integer *, integer *, integer *,
241 integer *, doublecomplex *, doublecomplex *, doublecomplex *,
242 doublecomplex *, doublecomplex *, doublecomplex *, doublecomplex *
243 , doublecomplex *, doublecomplex *, doublecomplex *, doublereal *,
244 ftnlen), zchk2_(char *, doublereal *, doublereal *, integer *,
245 integer *, logical *, logical *, logical *, integer *, integer *,
246 integer *, integer *, integer *, doublecomplex *, integer *,
247 doublecomplex *, integer *, integer *, integer *, integer *,
248 doublecomplex *, doublecomplex *, doublecomplex *, doublecomplex *
249 , doublecomplex *, doublecomplex *, doublecomplex *,
250 doublecomplex *, doublecomplex *, doublecomplex *, doublereal *,
251 ftnlen), zchk3_(char *, doublereal *, doublereal *, integer *,
252 integer *, logical *, logical *, logical *, integer *, integer *,
253 integer *, integer *, integer *, integer *, integer *, integer *,
254 doublecomplex *, doublecomplex *, doublecomplex *, doublecomplex *
255 , doublecomplex *, doublecomplex *, doublecomplex *, doublereal *,
256 doublecomplex *, ftnlen), zchk4_(char *, doublereal *,
257 doublereal *, integer *, integer *, logical *, logical *, logical
258 *, integer *, integer *, integer *, doublecomplex *, integer *,
259 integer *, integer *, integer *, doublecomplex *, doublecomplex *,
260 doublecomplex *, doublecomplex *, doublecomplex *, doublecomplex
261 *, doublecomplex *, doublecomplex *, doublecomplex *,
262 doublecomplex *, doublereal *, doublecomplex *, ftnlen), zchk5_(
263 char *, doublereal *, doublereal *, integer *, integer *, logical
264 *, logical *, logical *, integer *, integer *, integer *,
265 doublecomplex *, integer *, integer *, integer *, integer *,
266 doublecomplex *, doublecomplex *, doublecomplex *, doublecomplex *
267 , doublecomplex *, doublecomplex *, doublecomplex *,
268 doublecomplex *, doublecomplex *, doublecomplex *, doublereal *,
269 doublecomplex *, ftnlen), zchk6_(char *, doublereal *, doublereal
270 *, integer *, integer *, logical *, logical *, logical *, integer
271 *, integer *, integer *, doublecomplex *, integer *, integer *,
272 integer *, integer *, doublecomplex *, doublecomplex *,
273 doublecomplex *, doublecomplex *, doublecomplex *, doublecomplex *
274 , doublecomplex *, doublecomplex *, doublecomplex *,
275 doublecomplex *, doublereal *, doublecomplex *, ftnlen);
276 logical fatal, trace;
277 integer nidim;
278 extern /* Subroutine */ int zchke_(integer *, char *, integer *, ftnlen);
279 char snaps[32], trans[1];
280 extern /* Subroutine */ int zmvch_(char *, integer *, integer *,
281 doublecomplex *, doublecomplex *, integer *, doublecomplex *,
282 integer *, doublecomplex *, doublecomplex *, integer *,
283 doublecomplex *, doublereal *, doublecomplex *, doublereal *,
284 doublereal *, logical *, integer *, logical *, ftnlen);
285 integer isnum;
286 logical ltest[17], sfatal;
287 char snamet[6];
288 doublereal thresh;
289 logical ltestt, tsterr;
290 char summry[32];
291 extern double d_epsilon_(doublereal *);
292
293 /* Fortran I/O blocks */
294 static cilist io___2 = { 0, 5, 0, 0, 0 };
295 static cilist io___4 = { 0, 5, 0, 0, 0 };
296 static cilist io___6 = { 0, 5, 0, 0, 0 };
297 static cilist io___8 = { 0, 5, 0, 0, 0 };
298 static cilist io___11 = { 0, 5, 0, 0, 0 };
299 static cilist io___13 = { 0, 5, 0, 0, 0 };
300 static cilist io___15 = { 0, 5, 0, 0, 0 };
301 static cilist io___17 = { 0, 5, 0, 0, 0 };
302 static cilist io___19 = { 0, 5, 0, 0, 0 };
303 static cilist io___21 = { 0, 0, 0, fmt_9997, 0 };
304 static cilist io___22 = { 0, 5, 0, 0, 0 };
305 static cilist io___25 = { 0, 0, 0, fmt_9996, 0 };
306 static cilist io___26 = { 0, 5, 0, 0, 0 };
307 static cilist io___28 = { 0, 0, 0, fmt_9997, 0 };
308 static cilist io___29 = { 0, 5, 0, 0, 0 };
309 static cilist io___31 = { 0, 0, 0, fmt_9995, 0 };
310 static cilist io___32 = { 0, 5, 0, 0, 0 };
311 static cilist io___34 = { 0, 0, 0, fmt_9997, 0 };
312 static cilist io___35 = { 0, 5, 0, 0, 0 };
313 static cilist io___37 = { 0, 0, 0, fmt_9994, 0 };
314 static cilist io___38 = { 0, 5, 0, 0, 0 };
315 static cilist io___40 = { 0, 0, 0, fmt_9997, 0 };
316 static cilist io___41 = { 0, 5, 0, 0, 0 };
317 static cilist io___43 = { 0, 5, 0, 0, 0 };
318 static cilist io___45 = { 0, 0, 0, fmt_9997, 0 };
319 static cilist io___46 = { 0, 5, 0, 0, 0 };
320 static cilist io___48 = { 0, 0, 0, fmt_9993, 0 };
321 static cilist io___49 = { 0, 0, 0, fmt_9992, 0 };
322 static cilist io___50 = { 0, 0, 0, fmt_9991, 0 };
323 static cilist io___51 = { 0, 0, 0, fmt_9990, 0 };
324 static cilist io___52 = { 0, 0, 0, fmt_9989, 0 };
325 static cilist io___53 = { 0, 0, 0, fmt_9988, 0 };
326 static cilist io___54 = { 0, 0, 0, 0, 0 };
327 static cilist io___55 = { 0, 0, 0, fmt_9980, 0 };
328 static cilist io___56 = { 0, 0, 0, 0, 0 };
329 static cilist io___57 = { 0, 0, 0, fmt_9999, 0 };
330 static cilist io___58 = { 0, 0, 0, 0, 0 };
331 static cilist io___60 = { 0, 5, 1, fmt_9984, 0 };
332 static cilist io___63 = { 0, 0, 0, fmt_9986, 0 };
333 static cilist io___65 = { 0, 0, 0, fmt_9998, 0 };
334 static cilist io___78 = { 0, 0, 0, fmt_9985, 0 };
335 static cilist io___79 = { 0, 0, 0, fmt_9985, 0 };
336 static cilist io___81 = { 0, 0, 0, 0, 0 };
337 static cilist io___82 = { 0, 0, 0, fmt_9983, 0 };
338 static cilist io___83 = { 0, 0, 0, 0, 0 };
339 static cilist io___90 = { 0, 0, 0, fmt_9982, 0 };
340 static cilist io___91 = { 0, 0, 0, fmt_9981, 0 };
341 static cilist io___92 = { 0, 0, 0, fmt_9987, 0 };
342
343
344
345 /* -- Reference BLAS test routine (version 3.4.1) -- */
346 /* -- Reference BLAS is a software package provided by Univ. of Tennessee, -- */
347 /* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */
348 /* April 2012 */
349
350 /* ===================================================================== */
351
352 /* .. Parameters .. */
353 /* .. Local Scalars .. */
354 /* .. Local Arrays .. */
355 /* .. External Functions .. */
356 /* .. External Subroutines .. */
357 /* .. Intrinsic Functions .. */
358 /* .. Scalars in Common .. */
359 /* .. Common blocks .. */
360 /* .. Data statements .. */
361 /* .. Executable Statements .. */
362
363 /* Read name and unit number for summary output file and open file. */
364
365 s_rsle(&io___2);
366 do_lio(&c__9, &c__1, summry, (ftnlen)32);
367 e_rsle();
368 s_rsle(&io___4);
369 do_lio(&c__3, &c__1, (char *)&nout, (ftnlen)sizeof(integer));
370 e_rsle();
371 o__1.oerr = 0;
372 o__1.ounit = nout;
373 o__1.ofnmlen = 32;
374 o__1.ofnm = summry;
375 o__1.orl = 0;
376 o__1.osta = "UNKNOWN";
377 o__1.oacc = 0;
378 o__1.ofm = 0;
379 o__1.oblnk = 0;
380 f_open(&o__1);
381 infoc_1.noutc = nout;
382
383 /* Read name and unit number for snapshot output file and open file. */
384
385 s_rsle(&io___6);
386 do_lio(&c__9, &c__1, snaps, (ftnlen)32);
387 e_rsle();
388 s_rsle(&io___8);
389 do_lio(&c__3, &c__1, (char *)&ntra, (ftnlen)sizeof(integer));
390 e_rsle();
391 trace = ntra >= 0;
392 if (trace) {
393 o__1.oerr = 0;
394 o__1.ounit = ntra;
395 o__1.ofnmlen = 32;
396 o__1.ofnm = snaps;
397 o__1.orl = 0;
398 o__1.osta = "UNKNOWN";
399 o__1.oacc = 0;
400 o__1.ofm = 0;
401 o__1.oblnk = 0;
402 f_open(&o__1);
403 }
404 /* Read the flag that directs rewinding of the snapshot file. */
405 s_rsle(&io___11);
406 do_lio(&c__8, &c__1, (char *)&rewi, (ftnlen)sizeof(logical));
407 e_rsle();
408 rewi = rewi && trace;
409 /* Read the flag that directs stopping on any failure. */
410 s_rsle(&io___13);
411 do_lio(&c__8, &c__1, (char *)&sfatal, (ftnlen)sizeof(logical));
412 e_rsle();
413 /* Read the flag that indicates whether error exits are to be tested. */
414 s_rsle(&io___15);
415 do_lio(&c__8, &c__1, (char *)&tsterr, (ftnlen)sizeof(logical));
416 e_rsle();
417 /* Read the threshold value of the test ratio */
418 s_rsle(&io___17);
419 do_lio(&c__5, &c__1, (char *)&thresh, (ftnlen)sizeof(doublereal));
420 e_rsle();
421
422 /* Read and check the parameter values for the tests. */
423
424 /* Values of N */
425 s_rsle(&io___19);
426 do_lio(&c__3, &c__1, (char *)&nidim, (ftnlen)sizeof(integer));
427 e_rsle();
428 if (nidim < 1 || nidim > 9) {
429 io___21.ciunit = nout;
430 s_wsfe(&io___21);
431 do_fio(&c__1, "N", (ftnlen)1);
432 do_fio(&c__1, (char *)&c__9, (ftnlen)sizeof(integer));
433 e_wsfe();
434 goto L230;
435 }
436 s_rsle(&io___22);
437 i__1 = nidim;
438 for (i__ = 1; i__ <= i__1; ++i__) {
439 do_lio(&c__3, &c__1, (char *)&idim[i__ - 1], (ftnlen)sizeof(integer));
440 }
441 e_rsle();
442 i__1 = nidim;
443 for (i__ = 1; i__ <= i__1; ++i__) {
444 if (idim[i__ - 1] < 0 || idim[i__ - 1] > 65) {
445 io___25.ciunit = nout;
446 s_wsfe(&io___25);
447 do_fio(&c__1, (char *)&c__65, (ftnlen)sizeof(integer));
448 e_wsfe();
449 goto L230;
450 }
451 /* L10: */
452 }
453 /* Values of K */
454 s_rsle(&io___26);
455 do_lio(&c__3, &c__1, (char *)&nkb, (ftnlen)sizeof(integer));
456 e_rsle();
457 if (nkb < 1 || nkb > 7) {
458 io___28.ciunit = nout;
459 s_wsfe(&io___28);
460 do_fio(&c__1, "K", (ftnlen)1);
461 do_fio(&c__1, (char *)&c__7, (ftnlen)sizeof(integer));
462 e_wsfe();
463 goto L230;
464 }
465 s_rsle(&io___29);
466 i__1 = nkb;
467 for (i__ = 1; i__ <= i__1; ++i__) {
468 do_lio(&c__3, &c__1, (char *)&kb[i__ - 1], (ftnlen)sizeof(integer));
469 }
470 e_rsle();
471 i__1 = nkb;
472 for (i__ = 1; i__ <= i__1; ++i__) {
473 if (kb[i__ - 1] < 0) {
474 io___31.ciunit = nout;
475 s_wsfe(&io___31);
476 e_wsfe();
477 goto L230;
478 }
479 /* L20: */
480 }
481 /* Values of INCX and INCY */
482 s_rsle(&io___32);
483 do_lio(&c__3, &c__1, (char *)&ninc, (ftnlen)sizeof(integer));
484 e_rsle();
485 if (ninc < 1 || ninc > 7) {
486 io___34.ciunit = nout;
487 s_wsfe(&io___34);
488 do_fio(&c__1, "INCX AND INCY", (ftnlen)13);
489 do_fio(&c__1, (char *)&c__7, (ftnlen)sizeof(integer));
490 e_wsfe();
491 goto L230;
492 }
493 s_rsle(&io___35);
494 i__1 = ninc;
495 for (i__ = 1; i__ <= i__1; ++i__) {
496 do_lio(&c__3, &c__1, (char *)&inc[i__ - 1], (ftnlen)sizeof(integer));
497 }
498 e_rsle();
499 i__1 = ninc;
500 for (i__ = 1; i__ <= i__1; ++i__) {
501 if (inc[i__ - 1] == 0 || (i__2 = inc[i__ - 1], abs(i__2)) > 2) {
502 io___37.ciunit = nout;
503 s_wsfe(&io___37);
504 do_fio(&c__1, (char *)&c__2, (ftnlen)sizeof(integer));
505 e_wsfe();
506 goto L230;
507 }
508 /* L30: */
509 }
510 /* Values of ALPHA */
511 s_rsle(&io___38);
512 do_lio(&c__3, &c__1, (char *)&nalf, (ftnlen)sizeof(integer));
513 e_rsle();
514 if (nalf < 1 || nalf > 7) {
515 io___40.ciunit = nout;
516 s_wsfe(&io___40);
517 do_fio(&c__1, "ALPHA", (ftnlen)5);
518 do_fio(&c__1, (char *)&c__7, (ftnlen)sizeof(integer));
519 e_wsfe();
520 goto L230;
521 }
522 s_rsle(&io___41);
523 i__1 = nalf;
524 for (i__ = 1; i__ <= i__1; ++i__) {
525 do_lio(&c__7, &c__1, (char *)&alf[i__ - 1], (ftnlen)sizeof(
526 doublecomplex));
527 }
528 e_rsle();
529 /* Values of BETA */
530 s_rsle(&io___43);
531 do_lio(&c__3, &c__1, (char *)&nbet, (ftnlen)sizeof(integer));
532 e_rsle();
533 if (nbet < 1 || nbet > 7) {
534 io___45.ciunit = nout;
535 s_wsfe(&io___45);
536 do_fio(&c__1, "BETA", (ftnlen)4);
537 do_fio(&c__1, (char *)&c__7, (ftnlen)sizeof(integer));
538 e_wsfe();
539 goto L230;
540 }
541 s_rsle(&io___46);
542 i__1 = nbet;
543 for (i__ = 1; i__ <= i__1; ++i__) {
544 do_lio(&c__7, &c__1, (char *)&bet[i__ - 1], (ftnlen)sizeof(
545 doublecomplex));
546 }
547 e_rsle();
548
549 /* Report values of parameters. */
550
551 io___48.ciunit = nout;
552 s_wsfe(&io___48);
553 e_wsfe();
554 io___49.ciunit = nout;
555 s_wsfe(&io___49);
556 i__1 = nidim;
557 for (i__ = 1; i__ <= i__1; ++i__) {
558 do_fio(&c__1, (char *)&idim[i__ - 1], (ftnlen)sizeof(integer));
559 }
560 e_wsfe();
561 io___50.ciunit = nout;
562 s_wsfe(&io___50);
563 i__1 = nkb;
564 for (i__ = 1; i__ <= i__1; ++i__) {
565 do_fio(&c__1, (char *)&kb[i__ - 1], (ftnlen)sizeof(integer));
566 }
567 e_wsfe();
568 io___51.ciunit = nout;
569 s_wsfe(&io___51);
570 i__1 = ninc;
571 for (i__ = 1; i__ <= i__1; ++i__) {
572 do_fio(&c__1, (char *)&inc[i__ - 1], (ftnlen)sizeof(integer));
573 }
574 e_wsfe();
575 io___52.ciunit = nout;
576 s_wsfe(&io___52);
577 i__1 = nalf;
578 for (i__ = 1; i__ <= i__1; ++i__) {
579 do_fio(&c__2, (char *)&alf[i__ - 1], (ftnlen)sizeof(doublereal));
580 }
581 e_wsfe();
582 io___53.ciunit = nout;
583 s_wsfe(&io___53);
584 i__1 = nbet;
585 for (i__ = 1; i__ <= i__1; ++i__) {
586 do_fio(&c__2, (char *)&bet[i__ - 1], (ftnlen)sizeof(doublereal));
587 }
588 e_wsfe();
589 if (! tsterr) {
590 io___54.ciunit = nout;
591 s_wsle(&io___54);
592 e_wsle();
593 io___55.ciunit = nout;
594 s_wsfe(&io___55);
595 e_wsfe();
596 }
597 io___56.ciunit = nout;
598 s_wsle(&io___56);
599 e_wsle();
600 io___57.ciunit = nout;
601 s_wsfe(&io___57);
602 do_fio(&c__1, (char *)&thresh, (ftnlen)sizeof(doublereal));
603 e_wsfe();
604 io___58.ciunit = nout;
605 s_wsle(&io___58);
606 e_wsle();
607
608 /* Read names of subroutines and flags which indicate */
609 /* whether they are to be tested. */
610
611 for (i__ = 1; i__ <= 17; ++i__) {
612 ltest[i__ - 1] = FALSE_;
613 /* L40: */
614 }
615 L50:
616 i__1 = s_rsfe(&io___60);
617 if (i__1 != 0) {
618 goto L80;
619 }
620 i__1 = do_fio(&c__1, snamet, (ftnlen)6);
621 if (i__1 != 0) {
622 goto L80;
623 }
624 i__1 = do_fio(&c__1, (char *)<estt, (ftnlen)sizeof(logical));
625 if (i__1 != 0) {
626 goto L80;
627 }
628 i__1 = e_rsfe();
629 if (i__1 != 0) {
630 goto L80;
631 }
632 for (i__ = 1; i__ <= 17; ++i__) {
633 if (s_cmp(snamet, snames + (i__ - 1) * 6, (ftnlen)6, (ftnlen)6) == 0)
634 {
635 goto L70;
636 }
637 /* L60: */
638 }
639 io___63.ciunit = nout;
640 s_wsfe(&io___63);
641 do_fio(&c__1, snamet, (ftnlen)6);
642 e_wsfe();
643 s_stop("", (ftnlen)0);
644 L70:
645 ltest[i__ - 1] = ltestt;
646 goto L50;
647
648 L80:
649 cl__1.cerr = 0;
650 cl__1.cunit = 5;
651 cl__1.csta = 0;
652 f_clos(&cl__1);
653
654 /* Compute EPS (the machine precision). */
655
656 eps = d_epsilon_(&c_b122);
657 io___65.ciunit = nout;
658 s_wsfe(&io___65);
659 do_fio(&c__1, (char *)&eps, (ftnlen)sizeof(doublereal));
660 e_wsfe();
661
662 /* Check the reliability of ZMVCH using exact data. */
663
664 n = 32;
665 i__1 = n;
666 for (j = 1; j <= i__1; ++j) {
667 i__2 = n;
668 for (i__ = 1; i__ <= i__2; ++i__) {
669 i__3 = i__ + j * 65 - 66;
670 /* Computing MAX */
671 i__5 = i__ - j + 1;
672 i__4 = max(i__5,0);
673 a[i__3].r = (doublereal) i__4, a[i__3].i = 0.;
674 /* L110: */
675 }
676 i__2 = j - 1;
677 x[i__2].r = (doublereal) j, x[i__2].i = 0.;
678 i__2 = j - 1;
679 y[i__2].r = 0., y[i__2].i = 0.;
680 /* L120: */
681 }
682 i__1 = n;
683 for (j = 1; j <= i__1; ++j) {
684 i__2 = j - 1;
685 i__3 = j * ((j + 1) * j) / 2 - (j + 1) * j * (j - 1) / 3;
686 yy[i__2].r = (doublereal) i__3, yy[i__2].i = 0.;
687 /* L130: */
688 }
689 /* YY holds the exact result. On exit from ZMVCH YT holds */
690 /* the result computed by ZMVCH. */
691 *(unsigned char *)trans = 'N';
692 zmvch_(trans, &n, &n, &c_b2, a, &c__65, x, &c__1, &c_b1, y, &c__1, yt, g,
693 yy, &eps, &err, &fatal, &nout, &c_true, (ftnlen)1);
694 same = lze_(yy, yt, &n);
695 if (! same || err != 0.) {
696 io___78.ciunit = nout;
697 s_wsfe(&io___78);
698 do_fio(&c__1, trans, (ftnlen)1);
699 do_fio(&c__1, (char *)&same, (ftnlen)sizeof(logical));
700 do_fio(&c__1, (char *)&err, (ftnlen)sizeof(doublereal));
701 e_wsfe();
702 s_stop("", (ftnlen)0);
703 }
704 *(unsigned char *)trans = 'T';
705 zmvch_(trans, &n, &n, &c_b2, a, &c__65, x, &c_n1, &c_b1, y, &c_n1, yt, g,
706 yy, &eps, &err, &fatal, &nout, &c_true, (ftnlen)1);
707 same = lze_(yy, yt, &n);
708 if (! same || err != 0.) {
709 io___79.ciunit = nout;
710 s_wsfe(&io___79);
711 do_fio(&c__1, trans, (ftnlen)1);
712 do_fio(&c__1, (char *)&same, (ftnlen)sizeof(logical));
713 do_fio(&c__1, (char *)&err, (ftnlen)sizeof(doublereal));
714 e_wsfe();
715 s_stop("", (ftnlen)0);
716 }
717
718 /* Test each subroutine in turn. */
719
720 for (isnum = 1; isnum <= 17; ++isnum) {
721 io___81.ciunit = nout;
722 s_wsle(&io___81);
723 e_wsle();
724 if (! ltest[isnum - 1]) {
725 /* Subprogram is not to be tested. */
726 io___82.ciunit = nout;
727 s_wsfe(&io___82);
728 do_fio(&c__1, snames + (isnum - 1) * 6, (ftnlen)6);
729 e_wsfe();
730 } else {
731 s_copy(srnamc_1.srnamt, snames + (isnum - 1) * 6, (ftnlen)6, (
732 ftnlen)6);
733 /* Test error exits. */
734 if (tsterr) {
735 zchke_(&isnum, snames + (isnum - 1) * 6, &nout, (ftnlen)6);
736 io___83.ciunit = nout;
737 s_wsle(&io___83);
738 e_wsle();
739 }
740 /* Test computations. */
741 infoc_1.infot = 0;
742 infoc_1.ok = TRUE_;
743 fatal = FALSE_;
744 switch (isnum) {
745 case 1: goto L140;
746 case 2: goto L140;
747 case 3: goto L150;
748 case 4: goto L150;
749 case 5: goto L150;
750 case 6: goto L160;
751 case 7: goto L160;
752 case 8: goto L160;
753 case 9: goto L160;
754 case 10: goto L160;
755 case 11: goto L160;
756 case 12: goto L170;
757 case 13: goto L170;
758 case 14: goto L180;
759 case 15: goto L180;
760 case 16: goto L190;
761 case 17: goto L190;
762 }
763 /* Test ZGEMV, 01, and ZGBMV, 02. */
764 L140:
765 zchk1_(snames + (isnum - 1) * 6, &eps, &thresh, &nout, &ntra, &
766 trace, &rewi, &fatal, &nidim, idim, &nkb, kb, &nalf, alf,
767 &nbet, bet, &ninc, inc, &c__65, &c__2, a, aa, as, x, xx,
768 xs, y, yy, ys, yt, g, (ftnlen)6);
769 goto L200;
770 /* Test ZHEMV, 03, ZHBMV, 04, and ZHPMV, 05. */
771 L150:
772 zchk2_(snames + (isnum - 1) * 6, &eps, &thresh, &nout, &ntra, &
773 trace, &rewi, &fatal, &nidim, idim, &nkb, kb, &nalf, alf,
774 &nbet, bet, &ninc, inc, &c__65, &c__2, a, aa, as, x, xx,
775 xs, y, yy, ys, yt, g, (ftnlen)6);
776 goto L200;
777 /* Test ZTRMV, 06, ZTBMV, 07, ZTPMV, 08, */
778 /* ZTRSV, 09, ZTBSV, 10, and ZTPSV, 11. */
779 L160:
780 zchk3_(snames + (isnum - 1) * 6, &eps, &thresh, &nout, &ntra, &
781 trace, &rewi, &fatal, &nidim, idim, &nkb, kb, &ninc, inc,
782 &c__65, &c__2, a, aa, as, y, yy, ys, yt, g, z__, (ftnlen)
783 6);
784 goto L200;
785 /* Test ZGERC, 12, ZGERU, 13. */
786 L170:
787 zchk4_(snames + (isnum - 1) * 6, &eps, &thresh, &nout, &ntra, &
788 trace, &rewi, &fatal, &nidim, idim, &nalf, alf, &ninc,
789 inc, &c__65, &c__2, a, aa, as, x, xx, xs, y, yy, ys, yt,
790 g, z__, (ftnlen)6);
791 goto L200;
792 /* Test ZHER, 14, and ZHPR, 15. */
793 L180:
794 zchk5_(snames + (isnum - 1) * 6, &eps, &thresh, &nout, &ntra, &
795 trace, &rewi, &fatal, &nidim, idim, &nalf, alf, &ninc,
796 inc, &c__65, &c__2, a, aa, as, x, xx, xs, y, yy, ys, yt,
797 g, z__, (ftnlen)6);
798 goto L200;
799 /* Test ZHER2, 16, and ZHPR2, 17. */
800 L190:
801 zchk6_(snames + (isnum - 1) * 6, &eps, &thresh, &nout, &ntra, &
802 trace, &rewi, &fatal, &nidim, idim, &nalf, alf, &ninc,
803 inc, &c__65, &c__2, a, aa, as, x, xx, xs, y, yy, ys, yt,
804 g, z__, (ftnlen)6);
805
806 L200:
807 if (fatal && sfatal) {
808 goto L220;
809 }
810 }
811 /* L210: */
812 }
813 io___90.ciunit = nout;
814 s_wsfe(&io___90);
815 e_wsfe();
816 goto L240;
817
818 L220:
819 io___91.ciunit = nout;
820 s_wsfe(&io___91);
821 e_wsfe();
822 goto L240;
823
824 L230:
825 io___92.ciunit = nout;
826 s_wsfe(&io___92);
827 e_wsfe();
828
829 L240:
830 if (trace) {
831 cl__1.cerr = 0;
832 cl__1.cunit = ntra;
833 cl__1.csta = 0;
834 f_clos(&cl__1);
835 }
836 cl__1.cerr = 0;
837 cl__1.cunit = nout;
838 cl__1.csta = 0;
839 f_clos(&cl__1);
840 s_stop("", (ftnlen)0);
841
842
843 /* End of ZBLAT2. */
844
845 return 0;
846 } /* main */
847
zchk1_(char * sname,doublereal * eps,doublereal * thresh,integer * nout,integer * ntra,logical * trace,logical * rewi,logical * fatal,integer * nidim,integer * idim,integer * nkb,integer * kb,integer * nalf,doublecomplex * alf,integer * nbet,doublecomplex * bet,integer * ninc,integer * inc,integer * nmax,integer * incmax,doublecomplex * a,doublecomplex * aa,doublecomplex * as,doublecomplex * x,doublecomplex * xx,doublecomplex * xs,doublecomplex * y,doublecomplex * yy,doublecomplex * ys,doublecomplex * yt,doublereal * g,ftnlen sname_len)848 /* Subroutine */ int zchk1_(char *sname, doublereal *eps, doublereal *thresh,
849 integer *nout, integer *ntra, logical *trace, logical *rewi, logical *
850 fatal, integer *nidim, integer *idim, integer *nkb, integer *kb,
851 integer *nalf, doublecomplex *alf, integer *nbet, doublecomplex *bet,
852 integer *ninc, integer *inc, integer *nmax, integer *incmax,
853 doublecomplex *a, doublecomplex *aa, doublecomplex *as, doublecomplex
854 *x, doublecomplex *xx, doublecomplex *xs, doublecomplex *y,
855 doublecomplex *yy, doublecomplex *ys, doublecomplex *yt, doublereal *
856 g, ftnlen sname_len)
857 {
858 /* Initialized data */
859
860 static char ich[3] = "NTC";
861
862 /* Format strings */
863 static char fmt_9994[] = "(1x,i6,\002: \002,a6,\002('\002,a1,\002',\002,"
864 "2(i3,\002,\002),\002(\002,f4.1,\002,\002,f4.1,\002), A,\002,i3"
865 ",\002, X,\002,i2,\002,(\002,f4.1,\002,\002,f4.1,\002), Y,\002,i2,"
866 "\002) .\002)";
867 static char fmt_9995[] = "(1x,i6,\002: \002,a6,\002('\002,a1,\002',\002,"
868 "4(i3,\002,\002),\002(\002,f4.1,\002,\002,f4.1,\002), A,\002,i3"
869 ",\002, X,\002,i2,\002,(\002,f4.1,\002,\002,f4.1,\002), Y,\002,i2,"
870 "\002) .\002)";
871 static char fmt_9993[] = "(\002 ******* FATAL ERROR - ERROR-EXIT TAKEN O"
872 "N VALID CALL *\002,\002******\002)";
873 static char fmt_9998[] = "(\002 ******* FATAL ERROR - PARAMETER NUMBER"
874 " \002,i2,\002 WAS CH\002,\002ANGED INCORRECTLY *******\002)";
875 static char fmt_9999[] = "(\002 \002,a6,\002 PASSED THE COMPUTATIONAL TE"
876 "STS (\002,i6,\002 CALL\002,\002S)\002)";
877 static char fmt_9997[] = "(\002 \002,a6,\002 COMPLETED THE COMPUTATIONAL"
878 " TESTS (\002,i6,\002 C\002,\002ALLS)\002,/\002 ******* BUT WITH "
879 "MAXIMUM TEST RATIO\002,f8.2,\002 - SUSPECT *******\002)";
880 static char fmt_9996[] = "(\002 ******* \002,a6,\002 FAILED ON CALL NUMB"
881 "ER:\002)";
882
883 /* System generated locals */
884 integer a_dim1, a_offset, i__1, i__2, i__3, i__4, i__5, i__6, i__7, i__8,
885 i__9;
886 alist al__1;
887
888 /* Builtin functions */
889 integer s_wsfe(cilist *), do_fio(integer *, char *, ftnlen), e_wsfe(void),
890 f_rew(alist *);
891
892 /* Local variables */
893 integer i__, m, n, ia, ib, ic, nc, nd, im, in, kl, ml, nk, nl, ku, ix, iy,
894 ms, lx, ly, ns, laa, lda;
895 doublecomplex als, bls;
896 doublereal err;
897 integer iku, kls;
898 extern logical lze_(doublecomplex *, doublecomplex *, integer *);
899 integer kus;
900 doublecomplex beta;
901 integer ldas;
902 logical same;
903 integer incx, incy;
904 logical full, tran, null;
905 doublecomplex alpha;
906 logical isame[13];
907 extern /* Subroutine */ int zmake_(char *, char *, char *, integer *,
908 integer *, doublecomplex *, integer *, doublecomplex *, integer *,
909 integer *, integer *, logical *, doublecomplex *, ftnlen, ftnlen,
910 ftnlen);
911 integer nargs;
912 logical reset;
913 integer incxs, incys;
914 extern /* Subroutine */ int zgbmv_(char *, integer *, integer *, integer *
915 , integer *, doublecomplex *, doublecomplex *, integer *,
916 doublecomplex *, integer *, doublecomplex *, doublecomplex *,
917 integer *, ftnlen);
918 char trans[1];
919 extern /* Subroutine */ int zgemv_(char *, integer *, integer *,
920 doublecomplex *, doublecomplex *, integer *, doublecomplex *,
921 integer *, doublecomplex *, doublecomplex *, integer *, ftnlen),
922 zmvch_(char *, integer *, integer *, doublecomplex *,
923 doublecomplex *, integer *, doublecomplex *, integer *,
924 doublecomplex *, doublecomplex *, integer *, doublecomplex *,
925 doublereal *, doublecomplex *, doublereal *, doublereal *,
926 logical *, integer *, logical *, ftnlen);
927 logical banded;
928 doublereal errmax;
929 doublecomplex transl;
930 extern logical lzeres_(char *, char *, integer *, integer *,
931 doublecomplex *, doublecomplex *, integer *, ftnlen, ftnlen);
932 char transs[1];
933
934 /* Fortran I/O blocks */
935 static cilist io___139 = { 0, 0, 0, fmt_9994, 0 };
936 static cilist io___140 = { 0, 0, 0, fmt_9995, 0 };
937 static cilist io___141 = { 0, 0, 0, fmt_9993, 0 };
938 static cilist io___144 = { 0, 0, 0, fmt_9998, 0 };
939 static cilist io___146 = { 0, 0, 0, fmt_9999, 0 };
940 static cilist io___147 = { 0, 0, 0, fmt_9997, 0 };
941 static cilist io___148 = { 0, 0, 0, fmt_9996, 0 };
942 static cilist io___149 = { 0, 0, 0, fmt_9994, 0 };
943 static cilist io___150 = { 0, 0, 0, fmt_9995, 0 };
944
945
946
947 /* Tests ZGEMV and ZGBMV. */
948
949 /* Auxiliary routine for test program for Level 2 Blas. */
950
951 /* -- Written on 10-August-1987. */
952 /* Richard Hanson, Sandia National Labs. */
953 /* Jeremy Du Croz, NAG Central Office. */
954
955 /* .. Parameters .. */
956 /* .. Scalar Arguments .. */
957 /* .. Array Arguments .. */
958 /* .. Local Scalars .. */
959 /* .. Local Arrays .. */
960 /* .. External Functions .. */
961 /* .. External Subroutines .. */
962 /* .. Intrinsic Functions .. */
963 /* .. Scalars in Common .. */
964 /* .. Common blocks .. */
965 /* .. Data statements .. */
966 /* Parameter adjustments */
967 --idim;
968 --kb;
969 --alf;
970 --bet;
971 --inc;
972 --g;
973 --yt;
974 --y;
975 --x;
976 --as;
977 --aa;
978 a_dim1 = *nmax;
979 a_offset = 1 + a_dim1;
980 a -= a_offset;
981 --ys;
982 --yy;
983 --xs;
984 --xx;
985
986 /* Function Body */
987 /* .. Executable Statements .. */
988 full = *(unsigned char *)&sname[2] == 'E';
989 banded = *(unsigned char *)&sname[2] == 'B';
990 /* Define the number of arguments. */
991 if (full) {
992 nargs = 11;
993 } else if (banded) {
994 nargs = 13;
995 }
996
997 nc = 0;
998 reset = TRUE_;
999 errmax = 0.;
1000
1001 i__1 = *nidim;
1002 for (in = 1; in <= i__1; ++in) {
1003 n = idim[in];
1004 nd = n / 2 + 1;
1005
1006 for (im = 1; im <= 2; ++im) {
1007 if (im == 1) {
1008 /* Computing MAX */
1009 i__2 = n - nd;
1010 m = max(i__2,0);
1011 }
1012 if (im == 2) {
1013 /* Computing MIN */
1014 i__2 = n + nd;
1015 m = min(i__2,*nmax);
1016 }
1017
1018 if (banded) {
1019 nk = *nkb;
1020 } else {
1021 nk = 1;
1022 }
1023 i__2 = nk;
1024 for (iku = 1; iku <= i__2; ++iku) {
1025 if (banded) {
1026 ku = kb[iku];
1027 /* Computing MAX */
1028 i__3 = ku - 1;
1029 kl = max(i__3,0);
1030 } else {
1031 ku = n - 1;
1032 kl = m - 1;
1033 }
1034 /* Set LDA to 1 more than minimum value if room. */
1035 if (banded) {
1036 lda = kl + ku + 1;
1037 } else {
1038 lda = m;
1039 }
1040 if (lda < *nmax) {
1041 ++lda;
1042 }
1043 /* Skip tests if not enough room. */
1044 if (lda > *nmax) {
1045 goto L100;
1046 }
1047 laa = lda * n;
1048 null = n <= 0 || m <= 0;
1049
1050 /* Generate the matrix A. */
1051
1052 transl.r = 0., transl.i = 0.;
1053 zmake_(sname + 1, " ", " ", &m, &n, &a[a_offset], nmax, &aa[1]
1054 , &lda, &kl, &ku, &reset, &transl, (ftnlen)2, (ftnlen)
1055 1, (ftnlen)1);
1056
1057 for (ic = 1; ic <= 3; ++ic) {
1058 *(unsigned char *)trans = *(unsigned char *)&ich[ic - 1];
1059 tran = *(unsigned char *)trans == 'T' || *(unsigned char *
1060 )trans == 'C';
1061
1062 if (tran) {
1063 ml = n;
1064 nl = m;
1065 } else {
1066 ml = m;
1067 nl = n;
1068 }
1069
1070 i__3 = *ninc;
1071 for (ix = 1; ix <= i__3; ++ix) {
1072 incx = inc[ix];
1073 lx = abs(incx) * nl;
1074
1075 /* Generate the vector X. */
1076
1077 transl.r = .5, transl.i = 0.;
1078 i__4 = abs(incx);
1079 i__5 = nl - 1;
1080 zmake_("GE", " ", " ", &c__1, &nl, &x[1], &c__1, &xx[
1081 1], &i__4, &c__0, &i__5, &reset, &transl, (
1082 ftnlen)2, (ftnlen)1, (ftnlen)1);
1083 if (nl > 1) {
1084 i__4 = nl / 2;
1085 x[i__4].r = 0., x[i__4].i = 0.;
1086 i__4 = abs(incx) * (nl / 2 - 1) + 1;
1087 xx[i__4].r = 0., xx[i__4].i = 0.;
1088 }
1089
1090 i__4 = *ninc;
1091 for (iy = 1; iy <= i__4; ++iy) {
1092 incy = inc[iy];
1093 ly = abs(incy) * ml;
1094
1095 i__5 = *nalf;
1096 for (ia = 1; ia <= i__5; ++ia) {
1097 i__6 = ia;
1098 alpha.r = alf[i__6].r, alpha.i = alf[i__6].i;
1099
1100 i__6 = *nbet;
1101 for (ib = 1; ib <= i__6; ++ib) {
1102 i__7 = ib;
1103 beta.r = bet[i__7].r, beta.i = bet[i__7]
1104 .i;
1105
1106 /* Generate the vector Y. */
1107
1108 transl.r = 0., transl.i = 0.;
1109 i__7 = abs(incy);
1110 i__8 = ml - 1;
1111 zmake_("GE", " ", " ", &c__1, &ml, &y[1],
1112 &c__1, &yy[1], &i__7, &c__0, &
1113 i__8, &reset, &transl, (ftnlen)2,
1114 (ftnlen)1, (ftnlen)1);
1115
1116 ++nc;
1117
1118 /* Save every datum before calling the */
1119 /* subroutine. */
1120
1121 *(unsigned char *)transs = *(unsigned
1122 char *)trans;
1123 ms = m;
1124 ns = n;
1125 kls = kl;
1126 kus = ku;
1127 als.r = alpha.r, als.i = alpha.i;
1128 i__7 = laa;
1129 for (i__ = 1; i__ <= i__7; ++i__) {
1130 i__8 = i__;
1131 i__9 = i__;
1132 as[i__8].r = aa[i__9].r, as[i__8].i =
1133 aa[i__9].i;
1134 /* L10: */
1135 }
1136 ldas = lda;
1137 i__7 = lx;
1138 for (i__ = 1; i__ <= i__7; ++i__) {
1139 i__8 = i__;
1140 i__9 = i__;
1141 xs[i__8].r = xx[i__9].r, xs[i__8].i =
1142 xx[i__9].i;
1143 /* L20: */
1144 }
1145 incxs = incx;
1146 bls.r = beta.r, bls.i = beta.i;
1147 i__7 = ly;
1148 for (i__ = 1; i__ <= i__7; ++i__) {
1149 i__8 = i__;
1150 i__9 = i__;
1151 ys[i__8].r = yy[i__9].r, ys[i__8].i =
1152 yy[i__9].i;
1153 /* L30: */
1154 }
1155 incys = incy;
1156
1157 /* Call the subroutine. */
1158
1159 if (full) {
1160 if (*trace) {
1161 io___139.ciunit = *ntra;
1162 s_wsfe(&io___139);
1163 do_fio(&c__1, (char *)&nc, (
1164 ftnlen)sizeof(integer));
1165 do_fio(&c__1, sname, (ftnlen)6);
1166 do_fio(&c__1, trans, (ftnlen)1);
1167 do_fio(&c__1, (char *)&m, (ftnlen)
1168 sizeof(integer));
1169 do_fio(&c__1, (char *)&n, (ftnlen)
1170 sizeof(integer));
1171 do_fio(&c__2, (char *)&alpha, (
1172 ftnlen)sizeof(doublereal))
1173 ;
1174 do_fio(&c__1, (char *)&lda, (
1175 ftnlen)sizeof(integer));
1176 do_fio(&c__1, (char *)&incx, (
1177 ftnlen)sizeof(integer));
1178 do_fio(&c__2, (char *)&beta, (
1179 ftnlen)sizeof(doublereal))
1180 ;
1181 do_fio(&c__1, (char *)&incy, (
1182 ftnlen)sizeof(integer));
1183 e_wsfe();
1184 }
1185 if (*rewi) {
1186 al__1.aerr = 0;
1187 al__1.aunit = *ntra;
1188 f_rew(&al__1);
1189 }
1190 zgemv_(trans, &m, &n, &alpha, &aa[1],
1191 &lda, &xx[1], &incx, &beta, &
1192 yy[1], &incy, (ftnlen)1);
1193 } else if (banded) {
1194 if (*trace) {
1195 io___140.ciunit = *ntra;
1196 s_wsfe(&io___140);
1197 do_fio(&c__1, (char *)&nc, (
1198 ftnlen)sizeof(integer));
1199 do_fio(&c__1, sname, (ftnlen)6);
1200 do_fio(&c__1, trans, (ftnlen)1);
1201 do_fio(&c__1, (char *)&m, (ftnlen)
1202 sizeof(integer));
1203 do_fio(&c__1, (char *)&n, (ftnlen)
1204 sizeof(integer));
1205 do_fio(&c__1, (char *)&kl, (
1206 ftnlen)sizeof(integer));
1207 do_fio(&c__1, (char *)&ku, (
1208 ftnlen)sizeof(integer));
1209 do_fio(&c__2, (char *)&alpha, (
1210 ftnlen)sizeof(doublereal))
1211 ;
1212 do_fio(&c__1, (char *)&lda, (
1213 ftnlen)sizeof(integer));
1214 do_fio(&c__1, (char *)&incx, (
1215 ftnlen)sizeof(integer));
1216 do_fio(&c__2, (char *)&beta, (
1217 ftnlen)sizeof(doublereal))
1218 ;
1219 do_fio(&c__1, (char *)&incy, (
1220 ftnlen)sizeof(integer));
1221 e_wsfe();
1222 }
1223 if (*rewi) {
1224 al__1.aerr = 0;
1225 al__1.aunit = *ntra;
1226 f_rew(&al__1);
1227 }
1228 zgbmv_(trans, &m, &n, &kl, &ku, &
1229 alpha, &aa[1], &lda, &xx[1], &
1230 incx, &beta, &yy[1], &incy, (
1231 ftnlen)1);
1232 }
1233
1234 /* Check if error-exit was taken incorrectly. */
1235
1236 if (! infoc_1.ok) {
1237 io___141.ciunit = *nout;
1238 s_wsfe(&io___141);
1239 e_wsfe();
1240 *fatal = TRUE_;
1241 goto L130;
1242 }
1243
1244 /* See what data changed inside subroutines. */
1245
1246 isame[0] = *(unsigned char *)trans == *(
1247 unsigned char *)transs;
1248 isame[1] = ms == m;
1249 isame[2] = ns == n;
1250 if (full) {
1251 isame[3] = als.r == alpha.r && als.i
1252 == alpha.i;
1253 isame[4] = lze_(&as[1], &aa[1], &laa);
1254 isame[5] = ldas == lda;
1255 isame[6] = lze_(&xs[1], &xx[1], &lx);
1256 isame[7] = incxs == incx;
1257 isame[8] = bls.r == beta.r && bls.i ==
1258 beta.i;
1259 if (null) {
1260 isame[9] = lze_(&ys[1], &yy[1], &
1261 ly);
1262 } else {
1263 i__7 = abs(incy);
1264 isame[9] = lzeres_("GE", " ", &
1265 c__1, &ml, &ys[1], &yy[1],
1266 &i__7, (ftnlen)2, (
1267 ftnlen)1);
1268 }
1269 isame[10] = incys == incy;
1270 } else if (banded) {
1271 isame[3] = kls == kl;
1272 isame[4] = kus == ku;
1273 isame[5] = als.r == alpha.r && als.i
1274 == alpha.i;
1275 isame[6] = lze_(&as[1], &aa[1], &laa);
1276 isame[7] = ldas == lda;
1277 isame[8] = lze_(&xs[1], &xx[1], &lx);
1278 isame[9] = incxs == incx;
1279 isame[10] = bls.r == beta.r && bls.i
1280 == beta.i;
1281 if (null) {
1282 isame[11] = lze_(&ys[1], &yy[1], &
1283 ly);
1284 } else {
1285 i__7 = abs(incy);
1286 isame[11] = lzeres_("GE", " ", &
1287 c__1, &ml, &ys[1], &yy[1],
1288 &i__7, (ftnlen)2, (
1289 ftnlen)1);
1290 }
1291 isame[12] = incys == incy;
1292 }
1293
1294 /* If data was incorrectly changed, report */
1295 /* and return. */
1296
1297 same = TRUE_;
1298 i__7 = nargs;
1299 for (i__ = 1; i__ <= i__7; ++i__) {
1300 same = same && isame[i__ - 1];
1301 if (! isame[i__ - 1]) {
1302 io___144.ciunit = *nout;
1303 s_wsfe(&io___144);
1304 do_fio(&c__1, (char *)&i__, (
1305 ftnlen)sizeof(integer));
1306 e_wsfe();
1307 }
1308 /* L40: */
1309 }
1310 if (! same) {
1311 *fatal = TRUE_;
1312 goto L130;
1313 }
1314
1315 if (! null) {
1316
1317 /* Check the result. */
1318
1319 zmvch_(trans, &m, &n, &alpha, &a[
1320 a_offset], nmax, &x[1], &incx,
1321 &beta, &y[1], &incy, &yt[1],
1322 &g[1], &yy[1], eps, &err,
1323 fatal, nout, &c_true, (ftnlen)
1324 1);
1325 errmax = max(errmax,err);
1326 /* If got really bad answer, report and */
1327 /* return. */
1328 if (*fatal) {
1329 goto L130;
1330 }
1331 } else {
1332 /* Avoid repeating tests with M.le.0 or */
1333 /* N.le.0. */
1334 goto L110;
1335 }
1336
1337 /* L50: */
1338 }
1339
1340 /* L60: */
1341 }
1342
1343 /* L70: */
1344 }
1345
1346 /* L80: */
1347 }
1348
1349 /* L90: */
1350 }
1351
1352 L100:
1353 ;
1354 }
1355
1356 L110:
1357 ;
1358 }
1359
1360 /* L120: */
1361 }
1362
1363 /* Report result. */
1364
1365 if (errmax < *thresh) {
1366 io___146.ciunit = *nout;
1367 s_wsfe(&io___146);
1368 do_fio(&c__1, sname, (ftnlen)6);
1369 do_fio(&c__1, (char *)&nc, (ftnlen)sizeof(integer));
1370 e_wsfe();
1371 } else {
1372 io___147.ciunit = *nout;
1373 s_wsfe(&io___147);
1374 do_fio(&c__1, sname, (ftnlen)6);
1375 do_fio(&c__1, (char *)&nc, (ftnlen)sizeof(integer));
1376 do_fio(&c__1, (char *)&errmax, (ftnlen)sizeof(doublereal));
1377 e_wsfe();
1378 }
1379 goto L140;
1380
1381 L130:
1382 io___148.ciunit = *nout;
1383 s_wsfe(&io___148);
1384 do_fio(&c__1, sname, (ftnlen)6);
1385 e_wsfe();
1386 if (full) {
1387 io___149.ciunit = *nout;
1388 s_wsfe(&io___149);
1389 do_fio(&c__1, (char *)&nc, (ftnlen)sizeof(integer));
1390 do_fio(&c__1, sname, (ftnlen)6);
1391 do_fio(&c__1, trans, (ftnlen)1);
1392 do_fio(&c__1, (char *)&m, (ftnlen)sizeof(integer));
1393 do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
1394 do_fio(&c__2, (char *)&alpha, (ftnlen)sizeof(doublereal));
1395 do_fio(&c__1, (char *)&lda, (ftnlen)sizeof(integer));
1396 do_fio(&c__1, (char *)&incx, (ftnlen)sizeof(integer));
1397 do_fio(&c__2, (char *)&beta, (ftnlen)sizeof(doublereal));
1398 do_fio(&c__1, (char *)&incy, (ftnlen)sizeof(integer));
1399 e_wsfe();
1400 } else if (banded) {
1401 io___150.ciunit = *nout;
1402 s_wsfe(&io___150);
1403 do_fio(&c__1, (char *)&nc, (ftnlen)sizeof(integer));
1404 do_fio(&c__1, sname, (ftnlen)6);
1405 do_fio(&c__1, trans, (ftnlen)1);
1406 do_fio(&c__1, (char *)&m, (ftnlen)sizeof(integer));
1407 do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
1408 do_fio(&c__1, (char *)&kl, (ftnlen)sizeof(integer));
1409 do_fio(&c__1, (char *)&ku, (ftnlen)sizeof(integer));
1410 do_fio(&c__2, (char *)&alpha, (ftnlen)sizeof(doublereal));
1411 do_fio(&c__1, (char *)&lda, (ftnlen)sizeof(integer));
1412 do_fio(&c__1, (char *)&incx, (ftnlen)sizeof(integer));
1413 do_fio(&c__2, (char *)&beta, (ftnlen)sizeof(doublereal));
1414 do_fio(&c__1, (char *)&incy, (ftnlen)sizeof(integer));
1415 e_wsfe();
1416 }
1417
1418 L140:
1419 return 0;
1420
1421
1422 /* End of ZCHK1. */
1423
1424 } /* zchk1_ */
1425
zchk2_(char * sname,doublereal * eps,doublereal * thresh,integer * nout,integer * ntra,logical * trace,logical * rewi,logical * fatal,integer * nidim,integer * idim,integer * nkb,integer * kb,integer * nalf,doublecomplex * alf,integer * nbet,doublecomplex * bet,integer * ninc,integer * inc,integer * nmax,integer * incmax,doublecomplex * a,doublecomplex * aa,doublecomplex * as,doublecomplex * x,doublecomplex * xx,doublecomplex * xs,doublecomplex * y,doublecomplex * yy,doublecomplex * ys,doublecomplex * yt,doublereal * g,ftnlen sname_len)1426 /* Subroutine */ int zchk2_(char *sname, doublereal *eps, doublereal *thresh,
1427 integer *nout, integer *ntra, logical *trace, logical *rewi, logical *
1428 fatal, integer *nidim, integer *idim, integer *nkb, integer *kb,
1429 integer *nalf, doublecomplex *alf, integer *nbet, doublecomplex *bet,
1430 integer *ninc, integer *inc, integer *nmax, integer *incmax,
1431 doublecomplex *a, doublecomplex *aa, doublecomplex *as, doublecomplex
1432 *x, doublecomplex *xx, doublecomplex *xs, doublecomplex *y,
1433 doublecomplex *yy, doublecomplex *ys, doublecomplex *yt, doublereal *
1434 g, ftnlen sname_len)
1435 {
1436 /* Initialized data */
1437
1438 static char ich[2] = "UL";
1439
1440 /* Format strings */
1441 static char fmt_9993[] = "(1x,i6,\002: \002,a6,\002('\002,a1,\002',\002,"
1442 "i3,\002,(\002,f4.1,\002,\002,f4.1,\002), A,\002,i3,\002, X,\002,"
1443 "i2,\002,(\002,f4.1,\002,\002,f4.1,\002), \002,\002Y,\002,i2,\002"
1444 ") .\002)";
1445 static char fmt_9994[] = "(1x,i6,\002: \002,a6,\002('\002,a1,\002',\002,"
1446 "2(i3,\002,\002),\002(\002,f4.1,\002,\002,f4.1,\002), A,\002,i3"
1447 ",\002, X,\002,i2,\002,(\002,f4.1,\002,\002,f4.1,\002), Y,\002,i2,"
1448 "\002) .\002)";
1449 static char fmt_9995[] = "(1x,i6,\002: \002,a6,\002('\002,a1,\002',\002,"
1450 "i3,\002,(\002,f4.1,\002,\002,f4.1,\002), AP, X,\002,i2,\002,("
1451 "\002,f4.1,\002,\002,f4.1,\002), Y,\002,i2,\002) "
1452 ".\002)";
1453 static char fmt_9992[] = "(\002 ******* FATAL ERROR - ERROR-EXIT TAKEN O"
1454 "N VALID CALL *\002,\002******\002)";
1455 static char fmt_9998[] = "(\002 ******* FATAL ERROR - PARAMETER NUMBER"
1456 " \002,i2,\002 WAS CH\002,\002ANGED INCORRECTLY *******\002)";
1457 static char fmt_9999[] = "(\002 \002,a6,\002 PASSED THE COMPUTATIONAL TE"
1458 "STS (\002,i6,\002 CALL\002,\002S)\002)";
1459 static char fmt_9997[] = "(\002 \002,a6,\002 COMPLETED THE COMPUTATIONAL"
1460 " TESTS (\002,i6,\002 C\002,\002ALLS)\002,/\002 ******* BUT WITH "
1461 "MAXIMUM TEST RATIO\002,f8.2,\002 - SUSPECT *******\002)";
1462 static char fmt_9996[] = "(\002 ******* \002,a6,\002 FAILED ON CALL NUMB"
1463 "ER:\002)";
1464
1465 /* System generated locals */
1466 integer a_dim1, a_offset, i__1, i__2, i__3, i__4, i__5, i__6, i__7, i__8,
1467 i__9;
1468 alist al__1;
1469
1470 /* Builtin functions */
1471 integer s_wsfe(cilist *), do_fio(integer *, char *, ftnlen), e_wsfe(void),
1472 f_rew(alist *);
1473
1474 /* Local variables */
1475 integer i__, k, n, ia, ib, ic, nc, ik, in, nk, ks, ix, iy, ns, lx, ly,
1476 laa, lda;
1477 doublecomplex als, bls;
1478 doublereal err;
1479 extern logical lze_(doublecomplex *, doublecomplex *, integer *);
1480 doublecomplex beta;
1481 integer ldas;
1482 logical same;
1483 integer incx, incy;
1484 logical full, null;
1485 char uplo[1];
1486 doublecomplex alpha;
1487 logical isame[13];
1488 extern /* Subroutine */ int zmake_(char *, char *, char *, integer *,
1489 integer *, doublecomplex *, integer *, doublecomplex *, integer *,
1490 integer *, integer *, logical *, doublecomplex *, ftnlen, ftnlen,
1491 ftnlen);
1492 integer nargs;
1493 logical reset;
1494 integer incxs, incys;
1495 extern /* Subroutine */ int zhbmv_(char *, integer *, integer *,
1496 doublecomplex *, doublecomplex *, integer *, doublecomplex *,
1497 integer *, doublecomplex *, doublecomplex *, integer *, ftnlen),
1498 zmvch_(char *, integer *, integer *, doublecomplex *,
1499 doublecomplex *, integer *, doublecomplex *, integer *,
1500 doublecomplex *, doublecomplex *, integer *, doublecomplex *,
1501 doublereal *, doublecomplex *, doublereal *, doublereal *,
1502 logical *, integer *, logical *, ftnlen), zhemv_(char *, integer *
1503 , doublecomplex *, doublecomplex *, integer *, doublecomplex *,
1504 integer *, doublecomplex *, doublecomplex *, integer *, ftnlen);
1505 char uplos[1];
1506 extern /* Subroutine */ int zhpmv_(char *, integer *, doublecomplex *,
1507 doublecomplex *, doublecomplex *, integer *, doublecomplex *,
1508 doublecomplex *, integer *, ftnlen);
1509 logical banded, packed;
1510 doublereal errmax;
1511 doublecomplex transl;
1512 extern logical lzeres_(char *, char *, integer *, integer *,
1513 doublecomplex *, doublecomplex *, integer *, ftnlen, ftnlen);
1514
1515 /* Fortran I/O blocks */
1516 static cilist io___189 = { 0, 0, 0, fmt_9993, 0 };
1517 static cilist io___190 = { 0, 0, 0, fmt_9994, 0 };
1518 static cilist io___191 = { 0, 0, 0, fmt_9995, 0 };
1519 static cilist io___192 = { 0, 0, 0, fmt_9992, 0 };
1520 static cilist io___195 = { 0, 0, 0, fmt_9998, 0 };
1521 static cilist io___197 = { 0, 0, 0, fmt_9999, 0 };
1522 static cilist io___198 = { 0, 0, 0, fmt_9997, 0 };
1523 static cilist io___199 = { 0, 0, 0, fmt_9996, 0 };
1524 static cilist io___200 = { 0, 0, 0, fmt_9993, 0 };
1525 static cilist io___201 = { 0, 0, 0, fmt_9994, 0 };
1526 static cilist io___202 = { 0, 0, 0, fmt_9995, 0 };
1527
1528
1529
1530 /* Tests ZHEMV, ZHBMV and ZHPMV. */
1531
1532 /* Auxiliary routine for test program for Level 2 Blas. */
1533
1534 /* -- Written on 10-August-1987. */
1535 /* Richard Hanson, Sandia National Labs. */
1536 /* Jeremy Du Croz, NAG Central Office. */
1537
1538 /* .. Parameters .. */
1539 /* .. Scalar Arguments .. */
1540 /* .. Array Arguments .. */
1541 /* .. Local Scalars .. */
1542 /* .. Local Arrays .. */
1543 /* .. External Functions .. */
1544 /* .. External Subroutines .. */
1545 /* .. Intrinsic Functions .. */
1546 /* .. Scalars in Common .. */
1547 /* .. Common blocks .. */
1548 /* .. Data statements .. */
1549 /* Parameter adjustments */
1550 --idim;
1551 --kb;
1552 --alf;
1553 --bet;
1554 --inc;
1555 --g;
1556 --yt;
1557 --y;
1558 --x;
1559 --as;
1560 --aa;
1561 a_dim1 = *nmax;
1562 a_offset = 1 + a_dim1;
1563 a -= a_offset;
1564 --ys;
1565 --yy;
1566 --xs;
1567 --xx;
1568
1569 /* Function Body */
1570 /* .. Executable Statements .. */
1571 full = *(unsigned char *)&sname[2] == 'E';
1572 banded = *(unsigned char *)&sname[2] == 'B';
1573 packed = *(unsigned char *)&sname[2] == 'P';
1574 /* Define the number of arguments. */
1575 if (full) {
1576 nargs = 10;
1577 } else if (banded) {
1578 nargs = 11;
1579 } else if (packed) {
1580 nargs = 9;
1581 }
1582
1583 nc = 0;
1584 reset = TRUE_;
1585 errmax = 0.;
1586
1587 i__1 = *nidim;
1588 for (in = 1; in <= i__1; ++in) {
1589 n = idim[in];
1590
1591 if (banded) {
1592 nk = *nkb;
1593 } else {
1594 nk = 1;
1595 }
1596 i__2 = nk;
1597 for (ik = 1; ik <= i__2; ++ik) {
1598 if (banded) {
1599 k = kb[ik];
1600 } else {
1601 k = n - 1;
1602 }
1603 /* Set LDA to 1 more than minimum value if room. */
1604 if (banded) {
1605 lda = k + 1;
1606 } else {
1607 lda = n;
1608 }
1609 if (lda < *nmax) {
1610 ++lda;
1611 }
1612 /* Skip tests if not enough room. */
1613 if (lda > *nmax) {
1614 goto L100;
1615 }
1616 if (packed) {
1617 laa = n * (n + 1) / 2;
1618 } else {
1619 laa = lda * n;
1620 }
1621 null = n <= 0;
1622
1623 for (ic = 1; ic <= 2; ++ic) {
1624 *(unsigned char *)uplo = *(unsigned char *)&ich[ic - 1];
1625
1626 /* Generate the matrix A. */
1627
1628 transl.r = 0., transl.i = 0.;
1629 zmake_(sname + 1, uplo, " ", &n, &n, &a[a_offset], nmax, &aa[
1630 1], &lda, &k, &k, &reset, &transl, (ftnlen)2, (ftnlen)
1631 1, (ftnlen)1);
1632
1633 i__3 = *ninc;
1634 for (ix = 1; ix <= i__3; ++ix) {
1635 incx = inc[ix];
1636 lx = abs(incx) * n;
1637
1638 /* Generate the vector X. */
1639
1640 transl.r = .5, transl.i = 0.;
1641 i__4 = abs(incx);
1642 i__5 = n - 1;
1643 zmake_("GE", " ", " ", &c__1, &n, &x[1], &c__1, &xx[1], &
1644 i__4, &c__0, &i__5, &reset, &transl, (ftnlen)2, (
1645 ftnlen)1, (ftnlen)1);
1646 if (n > 1) {
1647 i__4 = n / 2;
1648 x[i__4].r = 0., x[i__4].i = 0.;
1649 i__4 = abs(incx) * (n / 2 - 1) + 1;
1650 xx[i__4].r = 0., xx[i__4].i = 0.;
1651 }
1652
1653 i__4 = *ninc;
1654 for (iy = 1; iy <= i__4; ++iy) {
1655 incy = inc[iy];
1656 ly = abs(incy) * n;
1657
1658 i__5 = *nalf;
1659 for (ia = 1; ia <= i__5; ++ia) {
1660 i__6 = ia;
1661 alpha.r = alf[i__6].r, alpha.i = alf[i__6].i;
1662
1663 i__6 = *nbet;
1664 for (ib = 1; ib <= i__6; ++ib) {
1665 i__7 = ib;
1666 beta.r = bet[i__7].r, beta.i = bet[i__7].i;
1667
1668 /* Generate the vector Y. */
1669
1670 transl.r = 0., transl.i = 0.;
1671 i__7 = abs(incy);
1672 i__8 = n - 1;
1673 zmake_("GE", " ", " ", &c__1, &n, &y[1], &
1674 c__1, &yy[1], &i__7, &c__0, &i__8, &
1675 reset, &transl, (ftnlen)2, (ftnlen)1,
1676 (ftnlen)1);
1677
1678 ++nc;
1679
1680 /* Save every datum before calling the */
1681 /* subroutine. */
1682
1683 *(unsigned char *)uplos = *(unsigned char *)
1684 uplo;
1685 ns = n;
1686 ks = k;
1687 als.r = alpha.r, als.i = alpha.i;
1688 i__7 = laa;
1689 for (i__ = 1; i__ <= i__7; ++i__) {
1690 i__8 = i__;
1691 i__9 = i__;
1692 as[i__8].r = aa[i__9].r, as[i__8].i = aa[
1693 i__9].i;
1694 /* L10: */
1695 }
1696 ldas = lda;
1697 i__7 = lx;
1698 for (i__ = 1; i__ <= i__7; ++i__) {
1699 i__8 = i__;
1700 i__9 = i__;
1701 xs[i__8].r = xx[i__9].r, xs[i__8].i = xx[
1702 i__9].i;
1703 /* L20: */
1704 }
1705 incxs = incx;
1706 bls.r = beta.r, bls.i = beta.i;
1707 i__7 = ly;
1708 for (i__ = 1; i__ <= i__7; ++i__) {
1709 i__8 = i__;
1710 i__9 = i__;
1711 ys[i__8].r = yy[i__9].r, ys[i__8].i = yy[
1712 i__9].i;
1713 /* L30: */
1714 }
1715 incys = incy;
1716
1717 /* Call the subroutine. */
1718
1719 if (full) {
1720 if (*trace) {
1721 io___189.ciunit = *ntra;
1722 s_wsfe(&io___189);
1723 do_fio(&c__1, (char *)&nc, (ftnlen)
1724 sizeof(integer));
1725 do_fio(&c__1, sname, (ftnlen)6);
1726 do_fio(&c__1, uplo, (ftnlen)1);
1727 do_fio(&c__1, (char *)&n, (ftnlen)
1728 sizeof(integer));
1729 do_fio(&c__2, (char *)&alpha, (ftnlen)
1730 sizeof(doublereal));
1731 do_fio(&c__1, (char *)&lda, (ftnlen)
1732 sizeof(integer));
1733 do_fio(&c__1, (char *)&incx, (ftnlen)
1734 sizeof(integer));
1735 do_fio(&c__2, (char *)&beta, (ftnlen)
1736 sizeof(doublereal));
1737 do_fio(&c__1, (char *)&incy, (ftnlen)
1738 sizeof(integer));
1739 e_wsfe();
1740 }
1741 if (*rewi) {
1742 al__1.aerr = 0;
1743 al__1.aunit = *ntra;
1744 f_rew(&al__1);
1745 }
1746 zhemv_(uplo, &n, &alpha, &aa[1], &lda, &
1747 xx[1], &incx, &beta, &yy[1], &
1748 incy, (ftnlen)1);
1749 } else if (banded) {
1750 if (*trace) {
1751 io___190.ciunit = *ntra;
1752 s_wsfe(&io___190);
1753 do_fio(&c__1, (char *)&nc, (ftnlen)
1754 sizeof(integer));
1755 do_fio(&c__1, sname, (ftnlen)6);
1756 do_fio(&c__1, uplo, (ftnlen)1);
1757 do_fio(&c__1, (char *)&n, (ftnlen)
1758 sizeof(integer));
1759 do_fio(&c__1, (char *)&k, (ftnlen)
1760 sizeof(integer));
1761 do_fio(&c__2, (char *)&alpha, (ftnlen)
1762 sizeof(doublereal));
1763 do_fio(&c__1, (char *)&lda, (ftnlen)
1764 sizeof(integer));
1765 do_fio(&c__1, (char *)&incx, (ftnlen)
1766 sizeof(integer));
1767 do_fio(&c__2, (char *)&beta, (ftnlen)
1768 sizeof(doublereal));
1769 do_fio(&c__1, (char *)&incy, (ftnlen)
1770 sizeof(integer));
1771 e_wsfe();
1772 }
1773 if (*rewi) {
1774 al__1.aerr = 0;
1775 al__1.aunit = *ntra;
1776 f_rew(&al__1);
1777 }
1778 zhbmv_(uplo, &n, &k, &alpha, &aa[1], &lda,
1779 &xx[1], &incx, &beta, &yy[1], &
1780 incy, (ftnlen)1);
1781 } else if (packed) {
1782 if (*trace) {
1783 io___191.ciunit = *ntra;
1784 s_wsfe(&io___191);
1785 do_fio(&c__1, (char *)&nc, (ftnlen)
1786 sizeof(integer));
1787 do_fio(&c__1, sname, (ftnlen)6);
1788 do_fio(&c__1, uplo, (ftnlen)1);
1789 do_fio(&c__1, (char *)&n, (ftnlen)
1790 sizeof(integer));
1791 do_fio(&c__2, (char *)&alpha, (ftnlen)
1792 sizeof(doublereal));
1793 do_fio(&c__1, (char *)&incx, (ftnlen)
1794 sizeof(integer));
1795 do_fio(&c__2, (char *)&beta, (ftnlen)
1796 sizeof(doublereal));
1797 do_fio(&c__1, (char *)&incy, (ftnlen)
1798 sizeof(integer));
1799 e_wsfe();
1800 }
1801 if (*rewi) {
1802 al__1.aerr = 0;
1803 al__1.aunit = *ntra;
1804 f_rew(&al__1);
1805 }
1806 zhpmv_(uplo, &n, &alpha, &aa[1], &xx[1], &
1807 incx, &beta, &yy[1], &incy, (
1808 ftnlen)1);
1809 }
1810
1811 /* Check if error-exit was taken incorrectly. */
1812
1813 if (! infoc_1.ok) {
1814 io___192.ciunit = *nout;
1815 s_wsfe(&io___192);
1816 e_wsfe();
1817 *fatal = TRUE_;
1818 goto L120;
1819 }
1820
1821 /* See what data changed inside subroutines. */
1822
1823 isame[0] = *(unsigned char *)uplo == *(
1824 unsigned char *)uplos;
1825 isame[1] = ns == n;
1826 if (full) {
1827 isame[2] = als.r == alpha.r && als.i ==
1828 alpha.i;
1829 isame[3] = lze_(&as[1], &aa[1], &laa);
1830 isame[4] = ldas == lda;
1831 isame[5] = lze_(&xs[1], &xx[1], &lx);
1832 isame[6] = incxs == incx;
1833 isame[7] = bls.r == beta.r && bls.i ==
1834 beta.i;
1835 if (null) {
1836 isame[8] = lze_(&ys[1], &yy[1], &ly);
1837 } else {
1838 i__7 = abs(incy);
1839 isame[8] = lzeres_("GE", " ", &c__1, &
1840 n, &ys[1], &yy[1], &i__7, (
1841 ftnlen)2, (ftnlen)1);
1842 }
1843 isame[9] = incys == incy;
1844 } else if (banded) {
1845 isame[2] = ks == k;
1846 isame[3] = als.r == alpha.r && als.i ==
1847 alpha.i;
1848 isame[4] = lze_(&as[1], &aa[1], &laa);
1849 isame[5] = ldas == lda;
1850 isame[6] = lze_(&xs[1], &xx[1], &lx);
1851 isame[7] = incxs == incx;
1852 isame[8] = bls.r == beta.r && bls.i ==
1853 beta.i;
1854 if (null) {
1855 isame[9] = lze_(&ys[1], &yy[1], &ly);
1856 } else {
1857 i__7 = abs(incy);
1858 isame[9] = lzeres_("GE", " ", &c__1, &
1859 n, &ys[1], &yy[1], &i__7, (
1860 ftnlen)2, (ftnlen)1);
1861 }
1862 isame[10] = incys == incy;
1863 } else if (packed) {
1864 isame[2] = als.r == alpha.r && als.i ==
1865 alpha.i;
1866 isame[3] = lze_(&as[1], &aa[1], &laa);
1867 isame[4] = lze_(&xs[1], &xx[1], &lx);
1868 isame[5] = incxs == incx;
1869 isame[6] = bls.r == beta.r && bls.i ==
1870 beta.i;
1871 if (null) {
1872 isame[7] = lze_(&ys[1], &yy[1], &ly);
1873 } else {
1874 i__7 = abs(incy);
1875 isame[7] = lzeres_("GE", " ", &c__1, &
1876 n, &ys[1], &yy[1], &i__7, (
1877 ftnlen)2, (ftnlen)1);
1878 }
1879 isame[8] = incys == incy;
1880 }
1881
1882 /* If data was incorrectly changed, report and */
1883 /* return. */
1884
1885 same = TRUE_;
1886 i__7 = nargs;
1887 for (i__ = 1; i__ <= i__7; ++i__) {
1888 same = same && isame[i__ - 1];
1889 if (! isame[i__ - 1]) {
1890 io___195.ciunit = *nout;
1891 s_wsfe(&io___195);
1892 do_fio(&c__1, (char *)&i__, (ftnlen)
1893 sizeof(integer));
1894 e_wsfe();
1895 }
1896 /* L40: */
1897 }
1898 if (! same) {
1899 *fatal = TRUE_;
1900 goto L120;
1901 }
1902
1903 if (! null) {
1904
1905 /* Check the result. */
1906
1907 zmvch_("N", &n, &n, &alpha, &a[a_offset],
1908 nmax, &x[1], &incx, &beta, &y[1],
1909 &incy, &yt[1], &g[1], &yy[1], eps,
1910 &err, fatal, nout, &c_true, (
1911 ftnlen)1);
1912 errmax = max(errmax,err);
1913 /* If got really bad answer, report and */
1914 /* return. */
1915 if (*fatal) {
1916 goto L120;
1917 }
1918 } else {
1919 /* Avoid repeating tests with N.le.0 */
1920 goto L110;
1921 }
1922
1923 /* L50: */
1924 }
1925
1926 /* L60: */
1927 }
1928
1929 /* L70: */
1930 }
1931
1932 /* L80: */
1933 }
1934
1935 /* L90: */
1936 }
1937
1938 L100:
1939 ;
1940 }
1941
1942 L110:
1943 ;
1944 }
1945
1946 /* Report result. */
1947
1948 if (errmax < *thresh) {
1949 io___197.ciunit = *nout;
1950 s_wsfe(&io___197);
1951 do_fio(&c__1, sname, (ftnlen)6);
1952 do_fio(&c__1, (char *)&nc, (ftnlen)sizeof(integer));
1953 e_wsfe();
1954 } else {
1955 io___198.ciunit = *nout;
1956 s_wsfe(&io___198);
1957 do_fio(&c__1, sname, (ftnlen)6);
1958 do_fio(&c__1, (char *)&nc, (ftnlen)sizeof(integer));
1959 do_fio(&c__1, (char *)&errmax, (ftnlen)sizeof(doublereal));
1960 e_wsfe();
1961 }
1962 goto L130;
1963
1964 L120:
1965 io___199.ciunit = *nout;
1966 s_wsfe(&io___199);
1967 do_fio(&c__1, sname, (ftnlen)6);
1968 e_wsfe();
1969 if (full) {
1970 io___200.ciunit = *nout;
1971 s_wsfe(&io___200);
1972 do_fio(&c__1, (char *)&nc, (ftnlen)sizeof(integer));
1973 do_fio(&c__1, sname, (ftnlen)6);
1974 do_fio(&c__1, uplo, (ftnlen)1);
1975 do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
1976 do_fio(&c__2, (char *)&alpha, (ftnlen)sizeof(doublereal));
1977 do_fio(&c__1, (char *)&lda, (ftnlen)sizeof(integer));
1978 do_fio(&c__1, (char *)&incx, (ftnlen)sizeof(integer));
1979 do_fio(&c__2, (char *)&beta, (ftnlen)sizeof(doublereal));
1980 do_fio(&c__1, (char *)&incy, (ftnlen)sizeof(integer));
1981 e_wsfe();
1982 } else if (banded) {
1983 io___201.ciunit = *nout;
1984 s_wsfe(&io___201);
1985 do_fio(&c__1, (char *)&nc, (ftnlen)sizeof(integer));
1986 do_fio(&c__1, sname, (ftnlen)6);
1987 do_fio(&c__1, uplo, (ftnlen)1);
1988 do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
1989 do_fio(&c__1, (char *)&k, (ftnlen)sizeof(integer));
1990 do_fio(&c__2, (char *)&alpha, (ftnlen)sizeof(doublereal));
1991 do_fio(&c__1, (char *)&lda, (ftnlen)sizeof(integer));
1992 do_fio(&c__1, (char *)&incx, (ftnlen)sizeof(integer));
1993 do_fio(&c__2, (char *)&beta, (ftnlen)sizeof(doublereal));
1994 do_fio(&c__1, (char *)&incy, (ftnlen)sizeof(integer));
1995 e_wsfe();
1996 } else if (packed) {
1997 io___202.ciunit = *nout;
1998 s_wsfe(&io___202);
1999 do_fio(&c__1, (char *)&nc, (ftnlen)sizeof(integer));
2000 do_fio(&c__1, sname, (ftnlen)6);
2001 do_fio(&c__1, uplo, (ftnlen)1);
2002 do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
2003 do_fio(&c__2, (char *)&alpha, (ftnlen)sizeof(doublereal));
2004 do_fio(&c__1, (char *)&incx, (ftnlen)sizeof(integer));
2005 do_fio(&c__2, (char *)&beta, (ftnlen)sizeof(doublereal));
2006 do_fio(&c__1, (char *)&incy, (ftnlen)sizeof(integer));
2007 e_wsfe();
2008 }
2009
2010 L130:
2011 return 0;
2012
2013
2014 /* End of ZCHK2. */
2015
2016 } /* zchk2_ */
2017
zchk3_(char * sname,doublereal * eps,doublereal * thresh,integer * nout,integer * ntra,logical * trace,logical * rewi,logical * fatal,integer * nidim,integer * idim,integer * nkb,integer * kb,integer * ninc,integer * inc,integer * nmax,integer * incmax,doublecomplex * a,doublecomplex * aa,doublecomplex * as,doublecomplex * x,doublecomplex * xx,doublecomplex * xs,doublecomplex * xt,doublereal * g,doublecomplex * z__,ftnlen sname_len)2018 /* Subroutine */ int zchk3_(char *sname, doublereal *eps, doublereal *thresh,
2019 integer *nout, integer *ntra, logical *trace, logical *rewi, logical *
2020 fatal, integer *nidim, integer *idim, integer *nkb, integer *kb,
2021 integer *ninc, integer *inc, integer *nmax, integer *incmax,
2022 doublecomplex *a, doublecomplex *aa, doublecomplex *as, doublecomplex
2023 *x, doublecomplex *xx, doublecomplex *xs, doublecomplex *xt,
2024 doublereal *g, doublecomplex *z__, ftnlen sname_len)
2025 {
2026 /* Initialized data */
2027
2028 static char ichu[2] = "UL";
2029 static char icht[3] = "NTC";
2030 static char ichd[2] = "UN";
2031
2032 /* Format strings */
2033 static char fmt_9993[] = "(1x,i6,\002: \002,a6,\002(\002,3(\002'\002,a1"
2034 ",\002',\002),i3,\002, A,\002,i3,\002, X,\002,i2,\002) "
2035 " .\002)";
2036 static char fmt_9994[] = "(1x,i6,\002: \002,a6,\002(\002,3(\002'\002,a1"
2037 ",\002',\002),2(i3,\002,\002),\002 A,\002,i3,\002, X,\002,i2,\002"
2038 ") .\002)";
2039 static char fmt_9995[] = "(1x,i6,\002: \002,a6,\002(\002,3(\002'\002,a1"
2040 ",\002',\002),i3,\002, AP, \002,\002X,\002,i2,\002) "
2041 " .\002)";
2042 static char fmt_9992[] = "(\002 ******* FATAL ERROR - ERROR-EXIT TAKEN O"
2043 "N VALID CALL *\002,\002******\002)";
2044 static char fmt_9998[] = "(\002 ******* FATAL ERROR - PARAMETER NUMBER"
2045 " \002,i2,\002 WAS CH\002,\002ANGED INCORRECTLY *******\002)";
2046 static char fmt_9999[] = "(\002 \002,a6,\002 PASSED THE COMPUTATIONAL TE"
2047 "STS (\002,i6,\002 CALL\002,\002S)\002)";
2048 static char fmt_9997[] = "(\002 \002,a6,\002 COMPLETED THE COMPUTATIONAL"
2049 " TESTS (\002,i6,\002 C\002,\002ALLS)\002,/\002 ******* BUT WITH "
2050 "MAXIMUM TEST RATIO\002,f8.2,\002 - SUSPECT *******\002)";
2051 static char fmt_9996[] = "(\002 ******* \002,a6,\002 FAILED ON CALL NUMB"
2052 "ER:\002)";
2053
2054 /* System generated locals */
2055 integer a_dim1, a_offset, i__1, i__2, i__3, i__4, i__5, i__6;
2056 alist al__1;
2057
2058 /* Builtin functions */
2059 integer s_cmp(const char *, const char *, ftnlen, ftnlen), s_wsfe(cilist *), do_fio(
2060 integer *, char *, ftnlen), e_wsfe(void), f_rew(alist *);
2061
2062 /* Local variables */
2063 integer i__, k, n, nc, ik, in, nk, ks, ix, ns, lx, laa, icd, lda, ict,
2064 icu;
2065 doublereal err;
2066 extern logical lze_(doublecomplex *, doublecomplex *, integer *);
2067 char diag[1];
2068 integer ldas;
2069 logical same;
2070 integer incx;
2071 logical full, null;
2072 char uplo[1], diags[1];
2073 logical isame[13];
2074 extern /* Subroutine */ int zmake_(char *, char *, char *, integer *,
2075 integer *, doublecomplex *, integer *, doublecomplex *, integer *,
2076 integer *, integer *, logical *, doublecomplex *, ftnlen, ftnlen,
2077 ftnlen);
2078 integer nargs;
2079 logical reset;
2080 integer incxs;
2081 char trans[1];
2082 extern /* Subroutine */ int zmvch_(char *, integer *, integer *,
2083 doublecomplex *, doublecomplex *, integer *, doublecomplex *,
2084 integer *, doublecomplex *, doublecomplex *, integer *,
2085 doublecomplex *, doublereal *, doublecomplex *, doublereal *,
2086 doublereal *, logical *, integer *, logical *, ftnlen);
2087 char uplos[1];
2088 extern /* Subroutine */ int ztbmv_(char *, char *, char *, integer *,
2089 integer *, doublecomplex *, integer *, doublecomplex *, integer *,
2090 ftnlen, ftnlen, ftnlen), ztbsv_(char *, char *, char *, integer *
2091 , integer *, doublecomplex *, integer *, doublecomplex *, integer
2092 *, ftnlen, ftnlen, ftnlen), ztpmv_(char *, char *, char *,
2093 integer *, doublecomplex *, doublecomplex *, integer *, ftnlen,
2094 ftnlen, ftnlen), ztrmv_(char *, char *, char *, integer *,
2095 doublecomplex *, integer *, doublecomplex *, integer *, ftnlen,
2096 ftnlen, ftnlen), ztpsv_(char *, char *, char *, integer *,
2097 doublecomplex *, doublecomplex *, integer *, ftnlen, ftnlen,
2098 ftnlen), ztrsv_(char *, char *, char *, integer *, doublecomplex *
2099 , integer *, doublecomplex *, integer *, ftnlen, ftnlen, ftnlen);
2100 logical banded, packed;
2101 doublereal errmax;
2102 doublecomplex transl;
2103 extern logical lzeres_(char *, char *, integer *, integer *,
2104 doublecomplex *, doublecomplex *, integer *, ftnlen, ftnlen);
2105 char transs[1];
2106
2107 /* Fortran I/O blocks */
2108 static cilist io___239 = { 0, 0, 0, fmt_9993, 0 };
2109 static cilist io___240 = { 0, 0, 0, fmt_9994, 0 };
2110 static cilist io___241 = { 0, 0, 0, fmt_9995, 0 };
2111 static cilist io___242 = { 0, 0, 0, fmt_9993, 0 };
2112 static cilist io___243 = { 0, 0, 0, fmt_9994, 0 };
2113 static cilist io___244 = { 0, 0, 0, fmt_9995, 0 };
2114 static cilist io___245 = { 0, 0, 0, fmt_9992, 0 };
2115 static cilist io___248 = { 0, 0, 0, fmt_9998, 0 };
2116 static cilist io___250 = { 0, 0, 0, fmt_9999, 0 };
2117 static cilist io___251 = { 0, 0, 0, fmt_9997, 0 };
2118 static cilist io___252 = { 0, 0, 0, fmt_9996, 0 };
2119 static cilist io___253 = { 0, 0, 0, fmt_9993, 0 };
2120 static cilist io___254 = { 0, 0, 0, fmt_9994, 0 };
2121 static cilist io___255 = { 0, 0, 0, fmt_9995, 0 };
2122
2123
2124
2125 /* Tests ZTRMV, ZTBMV, ZTPMV, ZTRSV, ZTBSV and ZTPSV. */
2126
2127 /* Auxiliary routine for test program for Level 2 Blas. */
2128
2129 /* -- Written on 10-August-1987. */
2130 /* Richard Hanson, Sandia National Labs. */
2131 /* Jeremy Du Croz, NAG Central Office. */
2132
2133 /* .. Parameters .. */
2134 /* .. Scalar Arguments .. */
2135 /* .. Array Arguments .. */
2136 /* .. Local Scalars .. */
2137 /* .. Local Arrays .. */
2138 /* .. External Functions .. */
2139 /* .. External Subroutines .. */
2140 /* .. Intrinsic Functions .. */
2141 /* .. Scalars in Common .. */
2142 /* .. Common blocks .. */
2143 /* .. Data statements .. */
2144 /* Parameter adjustments */
2145 --idim;
2146 --kb;
2147 --inc;
2148 --z__;
2149 --g;
2150 --xt;
2151 --x;
2152 --as;
2153 --aa;
2154 a_dim1 = *nmax;
2155 a_offset = 1 + a_dim1;
2156 a -= a_offset;
2157 --xs;
2158 --xx;
2159
2160 /* Function Body */
2161 /* .. Executable Statements .. */
2162 full = *(unsigned char *)&sname[2] == 'R';
2163 banded = *(unsigned char *)&sname[2] == 'B';
2164 packed = *(unsigned char *)&sname[2] == 'P';
2165 /* Define the number of arguments. */
2166 if (full) {
2167 nargs = 8;
2168 } else if (banded) {
2169 nargs = 9;
2170 } else if (packed) {
2171 nargs = 7;
2172 }
2173
2174 nc = 0;
2175 reset = TRUE_;
2176 errmax = 0.;
2177 /* Set up zero vector for ZMVCH. */
2178 i__1 = *nmax;
2179 for (i__ = 1; i__ <= i__1; ++i__) {
2180 i__2 = i__;
2181 z__[i__2].r = 0., z__[i__2].i = 0.;
2182 /* L10: */
2183 }
2184
2185 i__1 = *nidim;
2186 for (in = 1; in <= i__1; ++in) {
2187 n = idim[in];
2188
2189 if (banded) {
2190 nk = *nkb;
2191 } else {
2192 nk = 1;
2193 }
2194 i__2 = nk;
2195 for (ik = 1; ik <= i__2; ++ik) {
2196 if (banded) {
2197 k = kb[ik];
2198 } else {
2199 k = n - 1;
2200 }
2201 /* Set LDA to 1 more than minimum value if room. */
2202 if (banded) {
2203 lda = k + 1;
2204 } else {
2205 lda = n;
2206 }
2207 if (lda < *nmax) {
2208 ++lda;
2209 }
2210 /* Skip tests if not enough room. */
2211 if (lda > *nmax) {
2212 goto L100;
2213 }
2214 if (packed) {
2215 laa = n * (n + 1) / 2;
2216 } else {
2217 laa = lda * n;
2218 }
2219 null = n <= 0;
2220
2221 for (icu = 1; icu <= 2; ++icu) {
2222 *(unsigned char *)uplo = *(unsigned char *)&ichu[icu - 1];
2223
2224 for (ict = 1; ict <= 3; ++ict) {
2225 *(unsigned char *)trans = *(unsigned char *)&icht[ict - 1]
2226 ;
2227
2228 for (icd = 1; icd <= 2; ++icd) {
2229 *(unsigned char *)diag = *(unsigned char *)&ichd[icd
2230 - 1];
2231
2232 /* Generate the matrix A. */
2233
2234 transl.r = 0., transl.i = 0.;
2235 zmake_(sname + 1, uplo, diag, &n, &n, &a[a_offset],
2236 nmax, &aa[1], &lda, &k, &k, &reset, &transl, (
2237 ftnlen)2, (ftnlen)1, (ftnlen)1);
2238
2239 i__3 = *ninc;
2240 for (ix = 1; ix <= i__3; ++ix) {
2241 incx = inc[ix];
2242 lx = abs(incx) * n;
2243
2244 /* Generate the vector X. */
2245
2246 transl.r = .5, transl.i = 0.;
2247 i__4 = abs(incx);
2248 i__5 = n - 1;
2249 zmake_("GE", " ", " ", &c__1, &n, &x[1], &c__1, &
2250 xx[1], &i__4, &c__0, &i__5, &reset, &
2251 transl, (ftnlen)2, (ftnlen)1, (ftnlen)1);
2252 if (n > 1) {
2253 i__4 = n / 2;
2254 x[i__4].r = 0., x[i__4].i = 0.;
2255 i__4 = abs(incx) * (n / 2 - 1) + 1;
2256 xx[i__4].r = 0., xx[i__4].i = 0.;
2257 }
2258
2259 ++nc;
2260
2261 /* Save every datum before calling the subroutine. */
2262
2263 *(unsigned char *)uplos = *(unsigned char *)uplo;
2264 *(unsigned char *)transs = *(unsigned char *)
2265 trans;
2266 *(unsigned char *)diags = *(unsigned char *)diag;
2267 ns = n;
2268 ks = k;
2269 i__4 = laa;
2270 for (i__ = 1; i__ <= i__4; ++i__) {
2271 i__5 = i__;
2272 i__6 = i__;
2273 as[i__5].r = aa[i__6].r, as[i__5].i = aa[i__6]
2274 .i;
2275 /* L20: */
2276 }
2277 ldas = lda;
2278 i__4 = lx;
2279 for (i__ = 1; i__ <= i__4; ++i__) {
2280 i__5 = i__;
2281 i__6 = i__;
2282 xs[i__5].r = xx[i__6].r, xs[i__5].i = xx[i__6]
2283 .i;
2284 /* L30: */
2285 }
2286 incxs = incx;
2287
2288 /* Call the subroutine. */
2289
2290 if (s_cmp(sname + 3, "MV", (ftnlen)2, (ftnlen)2)
2291 == 0) {
2292 if (full) {
2293 if (*trace) {
2294 io___239.ciunit = *ntra;
2295 s_wsfe(&io___239);
2296 do_fio(&c__1, (char *)&nc, (ftnlen)
2297 sizeof(integer));
2298 do_fio(&c__1, sname, (ftnlen)6);
2299 do_fio(&c__1, uplo, (ftnlen)1);
2300 do_fio(&c__1, trans, (ftnlen)1);
2301 do_fio(&c__1, diag, (ftnlen)1);
2302 do_fio(&c__1, (char *)&n, (ftnlen)
2303 sizeof(integer));
2304 do_fio(&c__1, (char *)&lda, (ftnlen)
2305 sizeof(integer));
2306 do_fio(&c__1, (char *)&incx, (ftnlen)
2307 sizeof(integer));
2308 e_wsfe();
2309 }
2310 if (*rewi) {
2311 al__1.aerr = 0;
2312 al__1.aunit = *ntra;
2313 f_rew(&al__1);
2314 }
2315 ztrmv_(uplo, trans, diag, &n, &aa[1], &
2316 lda, &xx[1], &incx, (ftnlen)1, (
2317 ftnlen)1, (ftnlen)1);
2318 } else if (banded) {
2319 if (*trace) {
2320 io___240.ciunit = *ntra;
2321 s_wsfe(&io___240);
2322 do_fio(&c__1, (char *)&nc, (ftnlen)
2323 sizeof(integer));
2324 do_fio(&c__1, sname, (ftnlen)6);
2325 do_fio(&c__1, uplo, (ftnlen)1);
2326 do_fio(&c__1, trans, (ftnlen)1);
2327 do_fio(&c__1, diag, (ftnlen)1);
2328 do_fio(&c__1, (char *)&n, (ftnlen)
2329 sizeof(integer));
2330 do_fio(&c__1, (char *)&k, (ftnlen)
2331 sizeof(integer));
2332 do_fio(&c__1, (char *)&lda, (ftnlen)
2333 sizeof(integer));
2334 do_fio(&c__1, (char *)&incx, (ftnlen)
2335 sizeof(integer));
2336 e_wsfe();
2337 }
2338 if (*rewi) {
2339 al__1.aerr = 0;
2340 al__1.aunit = *ntra;
2341 f_rew(&al__1);
2342 }
2343 ztbmv_(uplo, trans, diag, &n, &k, &aa[1],
2344 &lda, &xx[1], &incx, (ftnlen)1, (
2345 ftnlen)1, (ftnlen)1);
2346 } else if (packed) {
2347 if (*trace) {
2348 io___241.ciunit = *ntra;
2349 s_wsfe(&io___241);
2350 do_fio(&c__1, (char *)&nc, (ftnlen)
2351 sizeof(integer));
2352 do_fio(&c__1, sname, (ftnlen)6);
2353 do_fio(&c__1, uplo, (ftnlen)1);
2354 do_fio(&c__1, trans, (ftnlen)1);
2355 do_fio(&c__1, diag, (ftnlen)1);
2356 do_fio(&c__1, (char *)&n, (ftnlen)
2357 sizeof(integer));
2358 do_fio(&c__1, (char *)&incx, (ftnlen)
2359 sizeof(integer));
2360 e_wsfe();
2361 }
2362 if (*rewi) {
2363 al__1.aerr = 0;
2364 al__1.aunit = *ntra;
2365 f_rew(&al__1);
2366 }
2367 ztpmv_(uplo, trans, diag, &n, &aa[1], &xx[
2368 1], &incx, (ftnlen)1, (ftnlen)1, (
2369 ftnlen)1);
2370 }
2371 } else if (s_cmp(sname + 3, "SV", (ftnlen)2, (
2372 ftnlen)2) == 0) {
2373 if (full) {
2374 if (*trace) {
2375 io___242.ciunit = *ntra;
2376 s_wsfe(&io___242);
2377 do_fio(&c__1, (char *)&nc, (ftnlen)
2378 sizeof(integer));
2379 do_fio(&c__1, sname, (ftnlen)6);
2380 do_fio(&c__1, uplo, (ftnlen)1);
2381 do_fio(&c__1, trans, (ftnlen)1);
2382 do_fio(&c__1, diag, (ftnlen)1);
2383 do_fio(&c__1, (char *)&n, (ftnlen)
2384 sizeof(integer));
2385 do_fio(&c__1, (char *)&lda, (ftnlen)
2386 sizeof(integer));
2387 do_fio(&c__1, (char *)&incx, (ftnlen)
2388 sizeof(integer));
2389 e_wsfe();
2390 }
2391 if (*rewi) {
2392 al__1.aerr = 0;
2393 al__1.aunit = *ntra;
2394 f_rew(&al__1);
2395 }
2396 ztrsv_(uplo, trans, diag, &n, &aa[1], &
2397 lda, &xx[1], &incx, (ftnlen)1, (
2398 ftnlen)1, (ftnlen)1);
2399 } else if (banded) {
2400 if (*trace) {
2401 io___243.ciunit = *ntra;
2402 s_wsfe(&io___243);
2403 do_fio(&c__1, (char *)&nc, (ftnlen)
2404 sizeof(integer));
2405 do_fio(&c__1, sname, (ftnlen)6);
2406 do_fio(&c__1, uplo, (ftnlen)1);
2407 do_fio(&c__1, trans, (ftnlen)1);
2408 do_fio(&c__1, diag, (ftnlen)1);
2409 do_fio(&c__1, (char *)&n, (ftnlen)
2410 sizeof(integer));
2411 do_fio(&c__1, (char *)&k, (ftnlen)
2412 sizeof(integer));
2413 do_fio(&c__1, (char *)&lda, (ftnlen)
2414 sizeof(integer));
2415 do_fio(&c__1, (char *)&incx, (ftnlen)
2416 sizeof(integer));
2417 e_wsfe();
2418 }
2419 if (*rewi) {
2420 al__1.aerr = 0;
2421 al__1.aunit = *ntra;
2422 f_rew(&al__1);
2423 }
2424 ztbsv_(uplo, trans, diag, &n, &k, &aa[1],
2425 &lda, &xx[1], &incx, (ftnlen)1, (
2426 ftnlen)1, (ftnlen)1);
2427 } else if (packed) {
2428 if (*trace) {
2429 io___244.ciunit = *ntra;
2430 s_wsfe(&io___244);
2431 do_fio(&c__1, (char *)&nc, (ftnlen)
2432 sizeof(integer));
2433 do_fio(&c__1, sname, (ftnlen)6);
2434 do_fio(&c__1, uplo, (ftnlen)1);
2435 do_fio(&c__1, trans, (ftnlen)1);
2436 do_fio(&c__1, diag, (ftnlen)1);
2437 do_fio(&c__1, (char *)&n, (ftnlen)
2438 sizeof(integer));
2439 do_fio(&c__1, (char *)&incx, (ftnlen)
2440 sizeof(integer));
2441 e_wsfe();
2442 }
2443 if (*rewi) {
2444 al__1.aerr = 0;
2445 al__1.aunit = *ntra;
2446 f_rew(&al__1);
2447 }
2448 ztpsv_(uplo, trans, diag, &n, &aa[1], &xx[
2449 1], &incx, (ftnlen)1, (ftnlen)1, (
2450 ftnlen)1);
2451 }
2452 }
2453
2454 /* Check if error-exit was taken incorrectly. */
2455
2456 if (! infoc_1.ok) {
2457 io___245.ciunit = *nout;
2458 s_wsfe(&io___245);
2459 e_wsfe();
2460 *fatal = TRUE_;
2461 goto L120;
2462 }
2463
2464 /* See what data changed inside subroutines. */
2465
2466 isame[0] = *(unsigned char *)uplo == *(unsigned
2467 char *)uplos;
2468 isame[1] = *(unsigned char *)trans == *(unsigned
2469 char *)transs;
2470 isame[2] = *(unsigned char *)diag == *(unsigned
2471 char *)diags;
2472 isame[3] = ns == n;
2473 if (full) {
2474 isame[4] = lze_(&as[1], &aa[1], &laa);
2475 isame[5] = ldas == lda;
2476 if (null) {
2477 isame[6] = lze_(&xs[1], &xx[1], &lx);
2478 } else {
2479 i__4 = abs(incx);
2480 isame[6] = lzeres_("GE", " ", &c__1, &n, &
2481 xs[1], &xx[1], &i__4, (ftnlen)2, (
2482 ftnlen)1);
2483 }
2484 isame[7] = incxs == incx;
2485 } else if (banded) {
2486 isame[4] = ks == k;
2487 isame[5] = lze_(&as[1], &aa[1], &laa);
2488 isame[6] = ldas == lda;
2489 if (null) {
2490 isame[7] = lze_(&xs[1], &xx[1], &lx);
2491 } else {
2492 i__4 = abs(incx);
2493 isame[7] = lzeres_("GE", " ", &c__1, &n, &
2494 xs[1], &xx[1], &i__4, (ftnlen)2, (
2495 ftnlen)1);
2496 }
2497 isame[8] = incxs == incx;
2498 } else if (packed) {
2499 isame[4] = lze_(&as[1], &aa[1], &laa);
2500 if (null) {
2501 isame[5] = lze_(&xs[1], &xx[1], &lx);
2502 } else {
2503 i__4 = abs(incx);
2504 isame[5] = lzeres_("GE", " ", &c__1, &n, &
2505 xs[1], &xx[1], &i__4, (ftnlen)2, (
2506 ftnlen)1);
2507 }
2508 isame[6] = incxs == incx;
2509 }
2510
2511 /* If data was incorrectly changed, report and */
2512 /* return. */
2513
2514 same = TRUE_;
2515 i__4 = nargs;
2516 for (i__ = 1; i__ <= i__4; ++i__) {
2517 same = same && isame[i__ - 1];
2518 if (! isame[i__ - 1]) {
2519 io___248.ciunit = *nout;
2520 s_wsfe(&io___248);
2521 do_fio(&c__1, (char *)&i__, (ftnlen)
2522 sizeof(integer));
2523 e_wsfe();
2524 }
2525 /* L40: */
2526 }
2527 if (! same) {
2528 *fatal = TRUE_;
2529 goto L120;
2530 }
2531
2532 if (! null) {
2533 if (s_cmp(sname + 3, "MV", (ftnlen)2, (ftnlen)
2534 2) == 0) {
2535
2536 /* Check the result. */
2537
2538 zmvch_(trans, &n, &n, &c_b2, &a[a_offset],
2539 nmax, &x[1], &incx, &c_b1, &z__[
2540 1], &incx, &xt[1], &g[1], &xx[1],
2541 eps, &err, fatal, nout, &c_true, (
2542 ftnlen)1);
2543 } else if (s_cmp(sname + 3, "SV", (ftnlen)2, (
2544 ftnlen)2) == 0) {
2545
2546 /* Compute approximation to original vector. */
2547
2548 i__4 = n;
2549 for (i__ = 1; i__ <= i__4; ++i__) {
2550 i__5 = i__;
2551 i__6 = (i__ - 1) * abs(incx) + 1;
2552 z__[i__5].r = xx[i__6].r, z__[i__5].i
2553 = xx[i__6].i;
2554 i__5 = (i__ - 1) * abs(incx) + 1;
2555 i__6 = i__;
2556 xx[i__5].r = x[i__6].r, xx[i__5].i =
2557 x[i__6].i;
2558 /* L50: */
2559 }
2560 zmvch_(trans, &n, &n, &c_b2, &a[a_offset],
2561 nmax, &z__[1], &incx, &c_b1, &x[
2562 1], &incx, &xt[1], &g[1], &xx[1],
2563 eps, &err, fatal, nout, &c_false,
2564 (ftnlen)1);
2565 }
2566 errmax = max(errmax,err);
2567 /* If got really bad answer, report and return. */
2568 if (*fatal) {
2569 goto L120;
2570 }
2571 } else {
2572 /* Avoid repeating tests with N.le.0. */
2573 goto L110;
2574 }
2575
2576 /* L60: */
2577 }
2578
2579 /* L70: */
2580 }
2581
2582 /* L80: */
2583 }
2584
2585 /* L90: */
2586 }
2587
2588 L100:
2589 ;
2590 }
2591
2592 L110:
2593 ;
2594 }
2595
2596 /* Report result. */
2597
2598 if (errmax < *thresh) {
2599 io___250.ciunit = *nout;
2600 s_wsfe(&io___250);
2601 do_fio(&c__1, sname, (ftnlen)6);
2602 do_fio(&c__1, (char *)&nc, (ftnlen)sizeof(integer));
2603 e_wsfe();
2604 } else {
2605 io___251.ciunit = *nout;
2606 s_wsfe(&io___251);
2607 do_fio(&c__1, sname, (ftnlen)6);
2608 do_fio(&c__1, (char *)&nc, (ftnlen)sizeof(integer));
2609 do_fio(&c__1, (char *)&errmax, (ftnlen)sizeof(doublereal));
2610 e_wsfe();
2611 }
2612 goto L130;
2613
2614 L120:
2615 io___252.ciunit = *nout;
2616 s_wsfe(&io___252);
2617 do_fio(&c__1, sname, (ftnlen)6);
2618 e_wsfe();
2619 if (full) {
2620 io___253.ciunit = *nout;
2621 s_wsfe(&io___253);
2622 do_fio(&c__1, (char *)&nc, (ftnlen)sizeof(integer));
2623 do_fio(&c__1, sname, (ftnlen)6);
2624 do_fio(&c__1, uplo, (ftnlen)1);
2625 do_fio(&c__1, trans, (ftnlen)1);
2626 do_fio(&c__1, diag, (ftnlen)1);
2627 do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
2628 do_fio(&c__1, (char *)&lda, (ftnlen)sizeof(integer));
2629 do_fio(&c__1, (char *)&incx, (ftnlen)sizeof(integer));
2630 e_wsfe();
2631 } else if (banded) {
2632 io___254.ciunit = *nout;
2633 s_wsfe(&io___254);
2634 do_fio(&c__1, (char *)&nc, (ftnlen)sizeof(integer));
2635 do_fio(&c__1, sname, (ftnlen)6);
2636 do_fio(&c__1, uplo, (ftnlen)1);
2637 do_fio(&c__1, trans, (ftnlen)1);
2638 do_fio(&c__1, diag, (ftnlen)1);
2639 do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
2640 do_fio(&c__1, (char *)&k, (ftnlen)sizeof(integer));
2641 do_fio(&c__1, (char *)&lda, (ftnlen)sizeof(integer));
2642 do_fio(&c__1, (char *)&incx, (ftnlen)sizeof(integer));
2643 e_wsfe();
2644 } else if (packed) {
2645 io___255.ciunit = *nout;
2646 s_wsfe(&io___255);
2647 do_fio(&c__1, (char *)&nc, (ftnlen)sizeof(integer));
2648 do_fio(&c__1, sname, (ftnlen)6);
2649 do_fio(&c__1, uplo, (ftnlen)1);
2650 do_fio(&c__1, trans, (ftnlen)1);
2651 do_fio(&c__1, diag, (ftnlen)1);
2652 do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
2653 do_fio(&c__1, (char *)&incx, (ftnlen)sizeof(integer));
2654 e_wsfe();
2655 }
2656
2657 L130:
2658 return 0;
2659
2660
2661 /* End of ZCHK3. */
2662
2663 } /* zchk3_ */
2664
zchk4_(char * sname,doublereal * eps,doublereal * thresh,integer * nout,integer * ntra,logical * trace,logical * rewi,logical * fatal,integer * nidim,integer * idim,integer * nalf,doublecomplex * alf,integer * ninc,integer * inc,integer * nmax,integer * incmax,doublecomplex * a,doublecomplex * aa,doublecomplex * as,doublecomplex * x,doublecomplex * xx,doublecomplex * xs,doublecomplex * y,doublecomplex * yy,doublecomplex * ys,doublecomplex * yt,doublereal * g,doublecomplex * z__,ftnlen sname_len)2665 /* Subroutine */ int zchk4_(char *sname, doublereal *eps, doublereal *thresh,
2666 integer *nout, integer *ntra, logical *trace, logical *rewi, logical *
2667 fatal, integer *nidim, integer *idim, integer *nalf, doublecomplex *
2668 alf, integer *ninc, integer *inc, integer *nmax, integer *incmax,
2669 doublecomplex *a, doublecomplex *aa, doublecomplex *as, doublecomplex
2670 *x, doublecomplex *xx, doublecomplex *xs, doublecomplex *y,
2671 doublecomplex *yy, doublecomplex *ys, doublecomplex *yt, doublereal *
2672 g, doublecomplex *z__, ftnlen sname_len)
2673 {
2674 /* Format strings */
2675 static char fmt_9994[] = "(1x,i6,\002: \002,a6,\002(\002,2(i3,\002,"
2676 "\002),\002(\002,f4.1,\002,\002,f4.1,\002), X,\002,i2,\002, Y,"
2677 "\002,i2,\002, A,\002,i3,\002) \002,\002 "
2678 ".\002)";
2679 static char fmt_9993[] = "(\002 ******* FATAL ERROR - ERROR-EXIT TAKEN O"
2680 "N VALID CALL *\002,\002******\002)";
2681 static char fmt_9998[] = "(\002 ******* FATAL ERROR - PARAMETER NUMBER"
2682 " \002,i2,\002 WAS CH\002,\002ANGED INCORRECTLY *******\002)";
2683 static char fmt_9999[] = "(\002 \002,a6,\002 PASSED THE COMPUTATIONAL TE"
2684 "STS (\002,i6,\002 CALL\002,\002S)\002)";
2685 static char fmt_9997[] = "(\002 \002,a6,\002 COMPLETED THE COMPUTATIONAL"
2686 " TESTS (\002,i6,\002 C\002,\002ALLS)\002,/\002 ******* BUT WITH "
2687 "MAXIMUM TEST RATIO\002,f8.2,\002 - SUSPECT *******\002)";
2688 static char fmt_9995[] = "(\002 THESE ARE THE RESULTS FOR COLUMN"
2689 " \002,i3)";
2690 static char fmt_9996[] = "(\002 ******* \002,a6,\002 FAILED ON CALL NUMB"
2691 "ER:\002)";
2692
2693 /* System generated locals */
2694 integer a_dim1, a_offset, i__1, i__2, i__3, i__4, i__5, i__6, i__7;
2695 doublecomplex z__1;
2696 alist al__1;
2697
2698 /* Builtin functions */
2699 integer s_wsfe(cilist *), do_fio(integer *, char *, ftnlen), e_wsfe(void),
2700 f_rew(alist *);
2701 void d_cnjg(doublecomplex *, const doublecomplex *);
2702
2703 /* Local variables */
2704 integer i__, j, m, n;
2705 doublecomplex w[1];
2706 integer ia, nc, nd, im, in, ms, ix, iy, ns, lx, ly, laa, lda;
2707 doublecomplex als;
2708 doublereal err;
2709 extern logical lze_(doublecomplex *, doublecomplex *, integer *);
2710 integer ldas;
2711 logical same, conj;
2712 integer incx, incy;
2713 logical null;
2714 doublecomplex alpha;
2715 logical isame[13];
2716 extern /* Subroutine */ int zmake_(char *, char *, char *, integer *,
2717 integer *, doublecomplex *, integer *, doublecomplex *, integer *,
2718 integer *, integer *, logical *, doublecomplex *, ftnlen, ftnlen,
2719 ftnlen);
2720 integer nargs;
2721 extern /* Subroutine */ int zgerc_(integer *, integer *, doublecomplex *,
2722 doublecomplex *, integer *, doublecomplex *, integer *,
2723 doublecomplex *, integer *);
2724 logical reset;
2725 integer incxs, incys;
2726 extern /* Subroutine */ int zmvch_(char *, integer *, integer *,
2727 doublecomplex *, doublecomplex *, integer *, doublecomplex *,
2728 integer *, doublecomplex *, doublecomplex *, integer *,
2729 doublecomplex *, doublereal *, doublecomplex *, doublereal *,
2730 doublereal *, logical *, integer *, logical *, ftnlen), zgeru_(
2731 integer *, integer *, doublecomplex *, doublecomplex *, integer *,
2732 doublecomplex *, integer *, doublecomplex *, integer *);
2733 doublereal errmax;
2734 doublecomplex transl;
2735 extern logical lzeres_(char *, char *, integer *, integer *,
2736 doublecomplex *, doublecomplex *, integer *, ftnlen, ftnlen);
2737
2738 /* Fortran I/O blocks */
2739 static cilist io___285 = { 0, 0, 0, fmt_9994, 0 };
2740 static cilist io___286 = { 0, 0, 0, fmt_9993, 0 };
2741 static cilist io___289 = { 0, 0, 0, fmt_9998, 0 };
2742 static cilist io___293 = { 0, 0, 0, fmt_9999, 0 };
2743 static cilist io___294 = { 0, 0, 0, fmt_9997, 0 };
2744 static cilist io___295 = { 0, 0, 0, fmt_9995, 0 };
2745 static cilist io___296 = { 0, 0, 0, fmt_9996, 0 };
2746 static cilist io___297 = { 0, 0, 0, fmt_9994, 0 };
2747
2748
2749
2750 /* Tests ZGERC and ZGERU. */
2751
2752 /* Auxiliary routine for test program for Level 2 Blas. */
2753
2754 /* -- Written on 10-August-1987. */
2755 /* Richard Hanson, Sandia National Labs. */
2756 /* Jeremy Du Croz, NAG Central Office. */
2757
2758 /* .. Parameters .. */
2759 /* .. Scalar Arguments .. */
2760 /* .. Array Arguments .. */
2761 /* .. Local Scalars .. */
2762 /* .. Local Arrays .. */
2763 /* .. External Functions .. */
2764 /* .. External Subroutines .. */
2765 /* .. Intrinsic Functions .. */
2766 /* .. Scalars in Common .. */
2767 /* .. Common blocks .. */
2768 /* .. Executable Statements .. */
2769 /* Parameter adjustments */
2770 --idim;
2771 --alf;
2772 --inc;
2773 --z__;
2774 --g;
2775 --yt;
2776 --y;
2777 --x;
2778 --as;
2779 --aa;
2780 a_dim1 = *nmax;
2781 a_offset = 1 + a_dim1;
2782 a -= a_offset;
2783 --ys;
2784 --yy;
2785 --xs;
2786 --xx;
2787
2788 /* Function Body */
2789 conj = *(unsigned char *)&sname[4] == 'C';
2790 /* Define the number of arguments. */
2791 nargs = 9;
2792
2793 nc = 0;
2794 reset = TRUE_;
2795 errmax = 0.;
2796
2797 i__1 = *nidim;
2798 for (in = 1; in <= i__1; ++in) {
2799 n = idim[in];
2800 nd = n / 2 + 1;
2801
2802 for (im = 1; im <= 2; ++im) {
2803 if (im == 1) {
2804 /* Computing MAX */
2805 i__2 = n - nd;
2806 m = max(i__2,0);
2807 }
2808 if (im == 2) {
2809 /* Computing MIN */
2810 i__2 = n + nd;
2811 m = min(i__2,*nmax);
2812 }
2813
2814 /* Set LDA to 1 more than minimum value if room. */
2815 lda = m;
2816 if (lda < *nmax) {
2817 ++lda;
2818 }
2819 /* Skip tests if not enough room. */
2820 if (lda > *nmax) {
2821 goto L110;
2822 }
2823 laa = lda * n;
2824 null = n <= 0 || m <= 0;
2825
2826 i__2 = *ninc;
2827 for (ix = 1; ix <= i__2; ++ix) {
2828 incx = inc[ix];
2829 lx = abs(incx) * m;
2830
2831 /* Generate the vector X. */
2832
2833 transl.r = .5, transl.i = 0.;
2834 i__3 = abs(incx);
2835 i__4 = m - 1;
2836 zmake_("GE", " ", " ", &c__1, &m, &x[1], &c__1, &xx[1], &i__3,
2837 &c__0, &i__4, &reset, &transl, (ftnlen)2, (ftnlen)1,
2838 (ftnlen)1);
2839 if (m > 1) {
2840 i__3 = m / 2;
2841 x[i__3].r = 0., x[i__3].i = 0.;
2842 i__3 = abs(incx) * (m / 2 - 1) + 1;
2843 xx[i__3].r = 0., xx[i__3].i = 0.;
2844 }
2845
2846 i__3 = *ninc;
2847 for (iy = 1; iy <= i__3; ++iy) {
2848 incy = inc[iy];
2849 ly = abs(incy) * n;
2850
2851 /* Generate the vector Y. */
2852
2853 transl.r = 0., transl.i = 0.;
2854 i__4 = abs(incy);
2855 i__5 = n - 1;
2856 zmake_("GE", " ", " ", &c__1, &n, &y[1], &c__1, &yy[1], &
2857 i__4, &c__0, &i__5, &reset, &transl, (ftnlen)2, (
2858 ftnlen)1, (ftnlen)1);
2859 if (n > 1) {
2860 i__4 = n / 2;
2861 y[i__4].r = 0., y[i__4].i = 0.;
2862 i__4 = abs(incy) * (n / 2 - 1) + 1;
2863 yy[i__4].r = 0., yy[i__4].i = 0.;
2864 }
2865
2866 i__4 = *nalf;
2867 for (ia = 1; ia <= i__4; ++ia) {
2868 i__5 = ia;
2869 alpha.r = alf[i__5].r, alpha.i = alf[i__5].i;
2870
2871 /* Generate the matrix A. */
2872
2873 transl.r = 0., transl.i = 0.;
2874 i__5 = m - 1;
2875 i__6 = n - 1;
2876 zmake_(sname + 1, " ", " ", &m, &n, &a[a_offset],
2877 nmax, &aa[1], &lda, &i__5, &i__6, &reset, &
2878 transl, (ftnlen)2, (ftnlen)1, (ftnlen)1);
2879
2880 ++nc;
2881
2882 /* Save every datum before calling the subroutine. */
2883
2884 ms = m;
2885 ns = n;
2886 als.r = alpha.r, als.i = alpha.i;
2887 i__5 = laa;
2888 for (i__ = 1; i__ <= i__5; ++i__) {
2889 i__6 = i__;
2890 i__7 = i__;
2891 as[i__6].r = aa[i__7].r, as[i__6].i = aa[i__7].i;
2892 /* L10: */
2893 }
2894 ldas = lda;
2895 i__5 = lx;
2896 for (i__ = 1; i__ <= i__5; ++i__) {
2897 i__6 = i__;
2898 i__7 = i__;
2899 xs[i__6].r = xx[i__7].r, xs[i__6].i = xx[i__7].i;
2900 /* L20: */
2901 }
2902 incxs = incx;
2903 i__5 = ly;
2904 for (i__ = 1; i__ <= i__5; ++i__) {
2905 i__6 = i__;
2906 i__7 = i__;
2907 ys[i__6].r = yy[i__7].r, ys[i__6].i = yy[i__7].i;
2908 /* L30: */
2909 }
2910 incys = incy;
2911
2912 /* Call the subroutine. */
2913
2914 if (*trace) {
2915 io___285.ciunit = *ntra;
2916 s_wsfe(&io___285);
2917 do_fio(&c__1, (char *)&nc, (ftnlen)sizeof(integer)
2918 );
2919 do_fio(&c__1, sname, (ftnlen)6);
2920 do_fio(&c__1, (char *)&m, (ftnlen)sizeof(integer))
2921 ;
2922 do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer))
2923 ;
2924 do_fio(&c__2, (char *)&alpha, (ftnlen)sizeof(
2925 doublereal));
2926 do_fio(&c__1, (char *)&incx, (ftnlen)sizeof(
2927 integer));
2928 do_fio(&c__1, (char *)&incy, (ftnlen)sizeof(
2929 integer));
2930 do_fio(&c__1, (char *)&lda, (ftnlen)sizeof(
2931 integer));
2932 e_wsfe();
2933 }
2934 if (conj) {
2935 if (*rewi) {
2936 al__1.aerr = 0;
2937 al__1.aunit = *ntra;
2938 f_rew(&al__1);
2939 }
2940 zgerc_(&m, &n, &alpha, &xx[1], &incx, &yy[1], &
2941 incy, &aa[1], &lda);
2942 } else {
2943 if (*rewi) {
2944 al__1.aerr = 0;
2945 al__1.aunit = *ntra;
2946 f_rew(&al__1);
2947 }
2948 zgeru_(&m, &n, &alpha, &xx[1], &incx, &yy[1], &
2949 incy, &aa[1], &lda);
2950 }
2951
2952 /* Check if error-exit was taken incorrectly. */
2953
2954 if (! infoc_1.ok) {
2955 io___286.ciunit = *nout;
2956 s_wsfe(&io___286);
2957 e_wsfe();
2958 *fatal = TRUE_;
2959 goto L140;
2960 }
2961
2962 /* See what data changed inside subroutine. */
2963
2964 isame[0] = ms == m;
2965 isame[1] = ns == n;
2966 isame[2] = als.r == alpha.r && als.i == alpha.i;
2967 isame[3] = lze_(&xs[1], &xx[1], &lx);
2968 isame[4] = incxs == incx;
2969 isame[5] = lze_(&ys[1], &yy[1], &ly);
2970 isame[6] = incys == incy;
2971 if (null) {
2972 isame[7] = lze_(&as[1], &aa[1], &laa);
2973 } else {
2974 isame[7] = lzeres_("GE", " ", &m, &n, &as[1], &aa[
2975 1], &lda, (ftnlen)2, (ftnlen)1);
2976 }
2977 isame[8] = ldas == lda;
2978
2979 /* If data was incorrectly changed, report and return. */
2980
2981 same = TRUE_;
2982 i__5 = nargs;
2983 for (i__ = 1; i__ <= i__5; ++i__) {
2984 same = same && isame[i__ - 1];
2985 if (! isame[i__ - 1]) {
2986 io___289.ciunit = *nout;
2987 s_wsfe(&io___289);
2988 do_fio(&c__1, (char *)&i__, (ftnlen)sizeof(
2989 integer));
2990 e_wsfe();
2991 }
2992 /* L40: */
2993 }
2994 if (! same) {
2995 *fatal = TRUE_;
2996 goto L140;
2997 }
2998
2999 if (! null) {
3000
3001 /* Check the result column by column. */
3002
3003 if (incx > 0) {
3004 i__5 = m;
3005 for (i__ = 1; i__ <= i__5; ++i__) {
3006 i__6 = i__;
3007 i__7 = i__;
3008 z__[i__6].r = x[i__7].r, z__[i__6].i = x[
3009 i__7].i;
3010 /* L50: */
3011 }
3012 } else {
3013 i__5 = m;
3014 for (i__ = 1; i__ <= i__5; ++i__) {
3015 i__6 = i__;
3016 i__7 = m - i__ + 1;
3017 z__[i__6].r = x[i__7].r, z__[i__6].i = x[
3018 i__7].i;
3019 /* L60: */
3020 }
3021 }
3022 i__5 = n;
3023 for (j = 1; j <= i__5; ++j) {
3024 if (incy > 0) {
3025 i__6 = j;
3026 w[0].r = y[i__6].r, w[0].i = y[i__6].i;
3027 } else {
3028 i__6 = n - j + 1;
3029 w[0].r = y[i__6].r, w[0].i = y[i__6].i;
3030 }
3031 if (conj) {
3032 d_cnjg(&z__1, w);
3033 w[0].r = z__1.r, w[0].i = z__1.i;
3034 }
3035 zmvch_("N", &m, &c__1, &alpha, &z__[1], nmax,
3036 w, &c__1, &c_b2, &a[j * a_dim1 + 1], &
3037 c__1, &yt[1], &g[1], &aa[(j - 1) *
3038 lda + 1], eps, &err, fatal, nout, &
3039 c_true, (ftnlen)1);
3040 errmax = max(errmax,err);
3041 /* If got really bad answer, report and return. */
3042 if (*fatal) {
3043 goto L130;
3044 }
3045 /* L70: */
3046 }
3047 } else {
3048 /* Avoid repeating tests with M.le.0 or N.le.0. */
3049 goto L110;
3050 }
3051
3052 /* L80: */
3053 }
3054
3055 /* L90: */
3056 }
3057
3058 /* L100: */
3059 }
3060
3061 L110:
3062 ;
3063 }
3064
3065 /* L120: */
3066 }
3067
3068 /* Report result. */
3069
3070 if (errmax < *thresh) {
3071 io___293.ciunit = *nout;
3072 s_wsfe(&io___293);
3073 do_fio(&c__1, sname, (ftnlen)6);
3074 do_fio(&c__1, (char *)&nc, (ftnlen)sizeof(integer));
3075 e_wsfe();
3076 } else {
3077 io___294.ciunit = *nout;
3078 s_wsfe(&io___294);
3079 do_fio(&c__1, sname, (ftnlen)6);
3080 do_fio(&c__1, (char *)&nc, (ftnlen)sizeof(integer));
3081 do_fio(&c__1, (char *)&errmax, (ftnlen)sizeof(doublereal));
3082 e_wsfe();
3083 }
3084 goto L150;
3085
3086 L130:
3087 io___295.ciunit = *nout;
3088 s_wsfe(&io___295);
3089 do_fio(&c__1, (char *)&j, (ftnlen)sizeof(integer));
3090 e_wsfe();
3091
3092 L140:
3093 io___296.ciunit = *nout;
3094 s_wsfe(&io___296);
3095 do_fio(&c__1, sname, (ftnlen)6);
3096 e_wsfe();
3097 io___297.ciunit = *nout;
3098 s_wsfe(&io___297);
3099 do_fio(&c__1, (char *)&nc, (ftnlen)sizeof(integer));
3100 do_fio(&c__1, sname, (ftnlen)6);
3101 do_fio(&c__1, (char *)&m, (ftnlen)sizeof(integer));
3102 do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
3103 do_fio(&c__2, (char *)&alpha, (ftnlen)sizeof(doublereal));
3104 do_fio(&c__1, (char *)&incx, (ftnlen)sizeof(integer));
3105 do_fio(&c__1, (char *)&incy, (ftnlen)sizeof(integer));
3106 do_fio(&c__1, (char *)&lda, (ftnlen)sizeof(integer));
3107 e_wsfe();
3108
3109 L150:
3110 return 0;
3111
3112
3113 /* End of ZCHK4. */
3114
3115 } /* zchk4_ */
3116
zchk5_(char * sname,doublereal * eps,doublereal * thresh,integer * nout,integer * ntra,logical * trace,logical * rewi,logical * fatal,integer * nidim,integer * idim,integer * nalf,doublecomplex * alf,integer * ninc,integer * inc,integer * nmax,integer * incmax,doublecomplex * a,doublecomplex * aa,doublecomplex * as,doublecomplex * x,doublecomplex * xx,doublecomplex * xs,doublecomplex * y,doublecomplex * yy,doublecomplex * ys,doublecomplex * yt,doublereal * g,doublecomplex * z__,ftnlen sname_len)3117 /* Subroutine */ int zchk5_(char *sname, doublereal *eps, doublereal *thresh,
3118 integer *nout, integer *ntra, logical *trace, logical *rewi, logical *
3119 fatal, integer *nidim, integer *idim, integer *nalf, doublecomplex *
3120 alf, integer *ninc, integer *inc, integer *nmax, integer *incmax,
3121 doublecomplex *a, doublecomplex *aa, doublecomplex *as, doublecomplex
3122 *x, doublecomplex *xx, doublecomplex *xs, doublecomplex *y,
3123 doublecomplex *yy, doublecomplex *ys, doublecomplex *yt, doublereal *
3124 g, doublecomplex *z__, ftnlen sname_len)
3125 {
3126 /* Initialized data */
3127
3128 static char ich[2] = "UL";
3129
3130 /* Format strings */
3131 static char fmt_9993[] = "(1x,i6,\002: \002,a6,\002('\002,a1,\002',\002,"
3132 "i3,\002,\002,f4.1,\002, X,\002,i2,\002, A,\002,i3,\002) "
3133 " .\002)";
3134 static char fmt_9994[] = "(1x,i6,\002: \002,a6,\002('\002,a1,\002',\002,"
3135 "i3,\002,\002,f4.1,\002, X,\002,i2,\002, AP) "
3136 " .\002)";
3137 static char fmt_9992[] = "(\002 ******* FATAL ERROR - ERROR-EXIT TAKEN O"
3138 "N VALID CALL *\002,\002******\002)";
3139 static char fmt_9998[] = "(\002 ******* FATAL ERROR - PARAMETER NUMBER"
3140 " \002,i2,\002 WAS CH\002,\002ANGED INCORRECTLY *******\002)";
3141 static char fmt_9999[] = "(\002 \002,a6,\002 PASSED THE COMPUTATIONAL TE"
3142 "STS (\002,i6,\002 CALL\002,\002S)\002)";
3143 static char fmt_9997[] = "(\002 \002,a6,\002 COMPLETED THE COMPUTATIONAL"
3144 " TESTS (\002,i6,\002 C\002,\002ALLS)\002,/\002 ******* BUT WITH "
3145 "MAXIMUM TEST RATIO\002,f8.2,\002 - SUSPECT *******\002)";
3146 static char fmt_9995[] = "(\002 THESE ARE THE RESULTS FOR COLUMN"
3147 " \002,i3)";
3148 static char fmt_9996[] = "(\002 ******* \002,a6,\002 FAILED ON CALL NUMB"
3149 "ER:\002)";
3150
3151 /* System generated locals */
3152 integer a_dim1, a_offset, i__1, i__2, i__3, i__4, i__5, i__6;
3153 doublecomplex z__1;
3154 alist al__1;
3155
3156 /* Builtin functions */
3157 integer s_wsfe(cilist *), do_fio(integer *, char *, ftnlen), e_wsfe(void),
3158 f_rew(alist *);
3159 void d_cnjg(doublecomplex *, const doublecomplex *);
3160
3161 /* Local variables */
3162 integer i__, j, n;
3163 doublecomplex w[1];
3164 integer ia, ja, ic, nc, jj, lj, in, ix, ns, lx, laa, lda;
3165 doublereal err;
3166 extern logical lze_(doublecomplex *, doublecomplex *, integer *);
3167 integer ldas;
3168 logical same;
3169 doublereal rals;
3170 integer incx;
3171 logical full;
3172 extern /* Subroutine */ int zher_(char *, integer *, doublereal *,
3173 doublecomplex *, integer *, doublecomplex *, integer *, ftnlen);
3174 logical null;
3175 char uplo[1];
3176 extern /* Subroutine */ int zhpr_(char *, integer *, doublereal *,
3177 doublecomplex *, integer *, doublecomplex *, ftnlen);
3178 doublecomplex alpha;
3179 logical isame[13];
3180 extern /* Subroutine */ int zmake_(char *, char *, char *, integer *,
3181 integer *, doublecomplex *, integer *, doublecomplex *, integer *,
3182 integer *, integer *, logical *, doublecomplex *, ftnlen, ftnlen,
3183 ftnlen);
3184 integer nargs;
3185 logical reset;
3186 integer incxs;
3187 extern /* Subroutine */ int zmvch_(char *, integer *, integer *,
3188 doublecomplex *, doublecomplex *, integer *, doublecomplex *,
3189 integer *, doublecomplex *, doublecomplex *, integer *,
3190 doublecomplex *, doublereal *, doublecomplex *, doublereal *,
3191 doublereal *, logical *, integer *, logical *, ftnlen);
3192 logical upper;
3193 char uplos[1];
3194 logical packed;
3195 doublereal ralpha, errmax;
3196 doublecomplex transl;
3197 extern logical lzeres_(char *, char *, integer *, integer *,
3198 doublecomplex *, doublecomplex *, integer *, ftnlen, ftnlen);
3199
3200 /* Fortran I/O blocks */
3201 static cilist io___326 = { 0, 0, 0, fmt_9993, 0 };
3202 static cilist io___327 = { 0, 0, 0, fmt_9994, 0 };
3203 static cilist io___328 = { 0, 0, 0, fmt_9992, 0 };
3204 static cilist io___331 = { 0, 0, 0, fmt_9998, 0 };
3205 static cilist io___338 = { 0, 0, 0, fmt_9999, 0 };
3206 static cilist io___339 = { 0, 0, 0, fmt_9997, 0 };
3207 static cilist io___340 = { 0, 0, 0, fmt_9995, 0 };
3208 static cilist io___341 = { 0, 0, 0, fmt_9996, 0 };
3209 static cilist io___342 = { 0, 0, 0, fmt_9993, 0 };
3210 static cilist io___343 = { 0, 0, 0, fmt_9994, 0 };
3211
3212
3213
3214 /* Tests ZHER and ZHPR. */
3215
3216 /* Auxiliary routine for test program for Level 2 Blas. */
3217
3218 /* -- Written on 10-August-1987. */
3219 /* Richard Hanson, Sandia National Labs. */
3220 /* Jeremy Du Croz, NAG Central Office. */
3221
3222 /* .. Parameters .. */
3223 /* .. Scalar Arguments .. */
3224 /* .. Array Arguments .. */
3225 /* .. Local Scalars .. */
3226 /* .. Local Arrays .. */
3227 /* .. External Functions .. */
3228 /* .. External Subroutines .. */
3229 /* .. Intrinsic Functions .. */
3230 /* .. Scalars in Common .. */
3231 /* .. Common blocks .. */
3232 /* .. Data statements .. */
3233 /* Parameter adjustments */
3234 --idim;
3235 --alf;
3236 --inc;
3237 --z__;
3238 --g;
3239 --yt;
3240 --y;
3241 --x;
3242 --as;
3243 --aa;
3244 a_dim1 = *nmax;
3245 a_offset = 1 + a_dim1;
3246 a -= a_offset;
3247 --ys;
3248 --yy;
3249 --xs;
3250 --xx;
3251
3252 /* Function Body */
3253 /* .. Executable Statements .. */
3254 full = *(unsigned char *)&sname[2] == 'E';
3255 packed = *(unsigned char *)&sname[2] == 'P';
3256 /* Define the number of arguments. */
3257 if (full) {
3258 nargs = 7;
3259 } else if (packed) {
3260 nargs = 6;
3261 }
3262
3263 nc = 0;
3264 reset = TRUE_;
3265 errmax = 0.;
3266
3267 i__1 = *nidim;
3268 for (in = 1; in <= i__1; ++in) {
3269 n = idim[in];
3270 /* Set LDA to 1 more than minimum value if room. */
3271 lda = n;
3272 if (lda < *nmax) {
3273 ++lda;
3274 }
3275 /* Skip tests if not enough room. */
3276 if (lda > *nmax) {
3277 goto L100;
3278 }
3279 if (packed) {
3280 laa = n * (n + 1) / 2;
3281 } else {
3282 laa = lda * n;
3283 }
3284
3285 for (ic = 1; ic <= 2; ++ic) {
3286 *(unsigned char *)uplo = *(unsigned char *)&ich[ic - 1];
3287 upper = *(unsigned char *)uplo == 'U';
3288
3289 i__2 = *ninc;
3290 for (ix = 1; ix <= i__2; ++ix) {
3291 incx = inc[ix];
3292 lx = abs(incx) * n;
3293
3294 /* Generate the vector X. */
3295
3296 transl.r = .5, transl.i = 0.;
3297 i__3 = abs(incx);
3298 i__4 = n - 1;
3299 zmake_("GE", " ", " ", &c__1, &n, &x[1], &c__1, &xx[1], &i__3,
3300 &c__0, &i__4, &reset, &transl, (ftnlen)2, (ftnlen)1,
3301 (ftnlen)1);
3302 if (n > 1) {
3303 i__3 = n / 2;
3304 x[i__3].r = 0., x[i__3].i = 0.;
3305 i__3 = abs(incx) * (n / 2 - 1) + 1;
3306 xx[i__3].r = 0., xx[i__3].i = 0.;
3307 }
3308
3309 i__3 = *nalf;
3310 for (ia = 1; ia <= i__3; ++ia) {
3311 i__4 = ia;
3312 ralpha = alf[i__4].r;
3313 z__1.r = ralpha, z__1.i = 0.;
3314 alpha.r = z__1.r, alpha.i = z__1.i;
3315 null = n <= 0 || ralpha == 0.;
3316
3317 /* Generate the matrix A. */
3318
3319 transl.r = 0., transl.i = 0.;
3320 i__4 = n - 1;
3321 i__5 = n - 1;
3322 zmake_(sname + 1, uplo, " ", &n, &n, &a[a_offset], nmax, &
3323 aa[1], &lda, &i__4, &i__5, &reset, &transl, (
3324 ftnlen)2, (ftnlen)1, (ftnlen)1);
3325
3326 ++nc;
3327
3328 /* Save every datum before calling the subroutine. */
3329
3330 *(unsigned char *)uplos = *(unsigned char *)uplo;
3331 ns = n;
3332 rals = ralpha;
3333 i__4 = laa;
3334 for (i__ = 1; i__ <= i__4; ++i__) {
3335 i__5 = i__;
3336 i__6 = i__;
3337 as[i__5].r = aa[i__6].r, as[i__5].i = aa[i__6].i;
3338 /* L10: */
3339 }
3340 ldas = lda;
3341 i__4 = lx;
3342 for (i__ = 1; i__ <= i__4; ++i__) {
3343 i__5 = i__;
3344 i__6 = i__;
3345 xs[i__5].r = xx[i__6].r, xs[i__5].i = xx[i__6].i;
3346 /* L20: */
3347 }
3348 incxs = incx;
3349
3350 /* Call the subroutine. */
3351
3352 if (full) {
3353 if (*trace) {
3354 io___326.ciunit = *ntra;
3355 s_wsfe(&io___326);
3356 do_fio(&c__1, (char *)&nc, (ftnlen)sizeof(integer)
3357 );
3358 do_fio(&c__1, sname, (ftnlen)6);
3359 do_fio(&c__1, uplo, (ftnlen)1);
3360 do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer))
3361 ;
3362 do_fio(&c__1, (char *)&ralpha, (ftnlen)sizeof(
3363 doublereal));
3364 do_fio(&c__1, (char *)&incx, (ftnlen)sizeof(
3365 integer));
3366 do_fio(&c__1, (char *)&lda, (ftnlen)sizeof(
3367 integer));
3368 e_wsfe();
3369 }
3370 if (*rewi) {
3371 al__1.aerr = 0;
3372 al__1.aunit = *ntra;
3373 f_rew(&al__1);
3374 }
3375 zher_(uplo, &n, &ralpha, &xx[1], &incx, &aa[1], &lda,
3376 (ftnlen)1);
3377 } else if (packed) {
3378 if (*trace) {
3379 io___327.ciunit = *ntra;
3380 s_wsfe(&io___327);
3381 do_fio(&c__1, (char *)&nc, (ftnlen)sizeof(integer)
3382 );
3383 do_fio(&c__1, sname, (ftnlen)6);
3384 do_fio(&c__1, uplo, (ftnlen)1);
3385 do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer))
3386 ;
3387 do_fio(&c__1, (char *)&ralpha, (ftnlen)sizeof(
3388 doublereal));
3389 do_fio(&c__1, (char *)&incx, (ftnlen)sizeof(
3390 integer));
3391 e_wsfe();
3392 }
3393 if (*rewi) {
3394 al__1.aerr = 0;
3395 al__1.aunit = *ntra;
3396 f_rew(&al__1);
3397 }
3398 zhpr_(uplo, &n, &ralpha, &xx[1], &incx, &aa[1], (
3399 ftnlen)1);
3400 }
3401
3402 /* Check if error-exit was taken incorrectly. */
3403
3404 if (! infoc_1.ok) {
3405 io___328.ciunit = *nout;
3406 s_wsfe(&io___328);
3407 e_wsfe();
3408 *fatal = TRUE_;
3409 goto L120;
3410 }
3411
3412 /* See what data changed inside subroutines. */
3413
3414 isame[0] = *(unsigned char *)uplo == *(unsigned char *)
3415 uplos;
3416 isame[1] = ns == n;
3417 isame[2] = rals == ralpha;
3418 isame[3] = lze_(&xs[1], &xx[1], &lx);
3419 isame[4] = incxs == incx;
3420 if (null) {
3421 isame[5] = lze_(&as[1], &aa[1], &laa);
3422 } else {
3423 isame[5] = lzeres_(sname + 1, uplo, &n, &n, &as[1], &
3424 aa[1], &lda, (ftnlen)2, (ftnlen)1);
3425 }
3426 if (! packed) {
3427 isame[6] = ldas == lda;
3428 }
3429
3430 /* If data was incorrectly changed, report and return. */
3431
3432 same = TRUE_;
3433 i__4 = nargs;
3434 for (i__ = 1; i__ <= i__4; ++i__) {
3435 same = same && isame[i__ - 1];
3436 if (! isame[i__ - 1]) {
3437 io___331.ciunit = *nout;
3438 s_wsfe(&io___331);
3439 do_fio(&c__1, (char *)&i__, (ftnlen)sizeof(
3440 integer));
3441 e_wsfe();
3442 }
3443 /* L30: */
3444 }
3445 if (! same) {
3446 *fatal = TRUE_;
3447 goto L120;
3448 }
3449
3450 if (! null) {
3451
3452 /* Check the result column by column. */
3453
3454 if (incx > 0) {
3455 i__4 = n;
3456 for (i__ = 1; i__ <= i__4; ++i__) {
3457 i__5 = i__;
3458 i__6 = i__;
3459 z__[i__5].r = x[i__6].r, z__[i__5].i = x[i__6]
3460 .i;
3461 /* L40: */
3462 }
3463 } else {
3464 i__4 = n;
3465 for (i__ = 1; i__ <= i__4; ++i__) {
3466 i__5 = i__;
3467 i__6 = n - i__ + 1;
3468 z__[i__5].r = x[i__6].r, z__[i__5].i = x[i__6]
3469 .i;
3470 /* L50: */
3471 }
3472 }
3473 ja = 1;
3474 i__4 = n;
3475 for (j = 1; j <= i__4; ++j) {
3476 d_cnjg(&z__1, &z__[j]);
3477 w[0].r = z__1.r, w[0].i = z__1.i;
3478 if (upper) {
3479 jj = 1;
3480 lj = j;
3481 } else {
3482 jj = j;
3483 lj = n - j + 1;
3484 }
3485 zmvch_("N", &lj, &c__1, &alpha, &z__[jj], &lj, w,
3486 &c__1, &c_b2, &a[jj + j * a_dim1], &c__1,
3487 &yt[1], &g[1], &aa[ja], eps, &err, fatal,
3488 nout, &c_true, (ftnlen)1);
3489 if (full) {
3490 if (upper) {
3491 ja += lda;
3492 } else {
3493 ja = ja + lda + 1;
3494 }
3495 } else {
3496 ja += lj;
3497 }
3498 errmax = max(errmax,err);
3499 /* If got really bad answer, report and return. */
3500 if (*fatal) {
3501 goto L110;
3502 }
3503 /* L60: */
3504 }
3505 } else {
3506 /* Avoid repeating tests if N.le.0. */
3507 if (n <= 0) {
3508 goto L100;
3509 }
3510 }
3511
3512 /* L70: */
3513 }
3514
3515 /* L80: */
3516 }
3517
3518 /* L90: */
3519 }
3520
3521 L100:
3522 ;
3523 }
3524
3525 /* Report result. */
3526
3527 if (errmax < *thresh) {
3528 io___338.ciunit = *nout;
3529 s_wsfe(&io___338);
3530 do_fio(&c__1, sname, (ftnlen)6);
3531 do_fio(&c__1, (char *)&nc, (ftnlen)sizeof(integer));
3532 e_wsfe();
3533 } else {
3534 io___339.ciunit = *nout;
3535 s_wsfe(&io___339);
3536 do_fio(&c__1, sname, (ftnlen)6);
3537 do_fio(&c__1, (char *)&nc, (ftnlen)sizeof(integer));
3538 do_fio(&c__1, (char *)&errmax, (ftnlen)sizeof(doublereal));
3539 e_wsfe();
3540 }
3541 goto L130;
3542
3543 L110:
3544 io___340.ciunit = *nout;
3545 s_wsfe(&io___340);
3546 do_fio(&c__1, (char *)&j, (ftnlen)sizeof(integer));
3547 e_wsfe();
3548
3549 L120:
3550 io___341.ciunit = *nout;
3551 s_wsfe(&io___341);
3552 do_fio(&c__1, sname, (ftnlen)6);
3553 e_wsfe();
3554 if (full) {
3555 io___342.ciunit = *nout;
3556 s_wsfe(&io___342);
3557 do_fio(&c__1, (char *)&nc, (ftnlen)sizeof(integer));
3558 do_fio(&c__1, sname, (ftnlen)6);
3559 do_fio(&c__1, uplo, (ftnlen)1);
3560 do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
3561 do_fio(&c__1, (char *)&ralpha, (ftnlen)sizeof(doublereal));
3562 do_fio(&c__1, (char *)&incx, (ftnlen)sizeof(integer));
3563 do_fio(&c__1, (char *)&lda, (ftnlen)sizeof(integer));
3564 e_wsfe();
3565 } else if (packed) {
3566 io___343.ciunit = *nout;
3567 s_wsfe(&io___343);
3568 do_fio(&c__1, (char *)&nc, (ftnlen)sizeof(integer));
3569 do_fio(&c__1, sname, (ftnlen)6);
3570 do_fio(&c__1, uplo, (ftnlen)1);
3571 do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
3572 do_fio(&c__1, (char *)&ralpha, (ftnlen)sizeof(doublereal));
3573 do_fio(&c__1, (char *)&incx, (ftnlen)sizeof(integer));
3574 e_wsfe();
3575 }
3576
3577 L130:
3578 return 0;
3579
3580
3581 /* End of ZCHK5. */
3582
3583 } /* zchk5_ */
3584
zchk6_(char * sname,doublereal * eps,doublereal * thresh,integer * nout,integer * ntra,logical * trace,logical * rewi,logical * fatal,integer * nidim,integer * idim,integer * nalf,doublecomplex * alf,integer * ninc,integer * inc,integer * nmax,integer * incmax,doublecomplex * a,doublecomplex * aa,doublecomplex * as,doublecomplex * x,doublecomplex * xx,doublecomplex * xs,doublecomplex * y,doublecomplex * yy,doublecomplex * ys,doublecomplex * yt,doublereal * g,doublecomplex * z__,ftnlen sname_len)3585 /* Subroutine */ int zchk6_(char *sname, doublereal *eps, doublereal *thresh,
3586 integer *nout, integer *ntra, logical *trace, logical *rewi, logical *
3587 fatal, integer *nidim, integer *idim, integer *nalf, doublecomplex *
3588 alf, integer *ninc, integer *inc, integer *nmax, integer *incmax,
3589 doublecomplex *a, doublecomplex *aa, doublecomplex *as, doublecomplex
3590 *x, doublecomplex *xx, doublecomplex *xs, doublecomplex *y,
3591 doublecomplex *yy, doublecomplex *ys, doublecomplex *yt, doublereal *
3592 g, doublecomplex *z__, ftnlen sname_len)
3593 {
3594 /* Initialized data */
3595
3596 static char ich[2] = "UL";
3597
3598 /* Format strings */
3599 static char fmt_9993[] = "(1x,i6,\002: \002,a6,\002('\002,a1,\002',\002,"
3600 "i3,\002,(\002,f4.1,\002,\002,f4.1,\002), X,\002,i2,\002, Y,\002,"
3601 "i2,\002, A,\002,i3,\002) \002,\002 .\002)";
3602 static char fmt_9994[] = "(1x,i6,\002: \002,a6,\002('\002,a1,\002',\002,"
3603 "i3,\002,(\002,f4.1,\002,\002,f4.1,\002), X,\002,i2,\002, Y,\002,"
3604 "i2,\002, AP) \002,\002 .\002)";
3605 static char fmt_9992[] = "(\002 ******* FATAL ERROR - ERROR-EXIT TAKEN O"
3606 "N VALID CALL *\002,\002******\002)";
3607 static char fmt_9998[] = "(\002 ******* FATAL ERROR - PARAMETER NUMBER"
3608 " \002,i2,\002 WAS CH\002,\002ANGED INCORRECTLY *******\002)";
3609 static char fmt_9999[] = "(\002 \002,a6,\002 PASSED THE COMPUTATIONAL TE"
3610 "STS (\002,i6,\002 CALL\002,\002S)\002)";
3611 static char fmt_9997[] = "(\002 \002,a6,\002 COMPLETED THE COMPUTATIONAL"
3612 " TESTS (\002,i6,\002 C\002,\002ALLS)\002,/\002 ******* BUT WITH "
3613 "MAXIMUM TEST RATIO\002,f8.2,\002 - SUSPECT *******\002)";
3614 static char fmt_9995[] = "(\002 THESE ARE THE RESULTS FOR COLUMN"
3615 " \002,i3)";
3616 static char fmt_9996[] = "(\002 ******* \002,a6,\002 FAILED ON CALL NUMB"
3617 "ER:\002)";
3618
3619 /* System generated locals */
3620 integer a_dim1, a_offset, z_dim1, z_offset, i__1, i__2, i__3, i__4, i__5,
3621 i__6, i__7;
3622 doublecomplex z__1, z__2, z__3;
3623 alist al__1;
3624
3625 /* Builtin functions */
3626 integer s_wsfe(cilist *), do_fio(integer *, char *, ftnlen), e_wsfe(void),
3627 f_rew(alist *);
3628 void d_cnjg(doublecomplex *, const doublecomplex *);
3629
3630 /* Local variables */
3631 integer i__, j, n;
3632 doublecomplex w[2];
3633 integer ia, ja, ic, nc, jj, lj, in, ix, iy, ns, lx, ly, laa, lda;
3634 doublecomplex als;
3635 doublereal err;
3636 extern logical lze_(doublecomplex *, doublecomplex *, integer *);
3637 integer ldas;
3638 logical same;
3639 integer incx, incy;
3640 logical full, null;
3641 char uplo[1];
3642 extern /* Subroutine */ int zher2_(char *, integer *, doublecomplex *,
3643 doublecomplex *, integer *, doublecomplex *, integer *,
3644 doublecomplex *, integer *, ftnlen), zhpr2_(char *, integer *,
3645 doublecomplex *, doublecomplex *, integer *, doublecomplex *,
3646 integer *, doublecomplex *, ftnlen);
3647 doublecomplex alpha;
3648 logical isame[13];
3649 extern /* Subroutine */ int zmake_(char *, char *, char *, integer *,
3650 integer *, doublecomplex *, integer *, doublecomplex *, integer *,
3651 integer *, integer *, logical *, doublecomplex *, ftnlen, ftnlen,
3652 ftnlen);
3653 integer nargs;
3654 logical reset;
3655 integer incxs, incys;
3656 extern /* Subroutine */ int zmvch_(char *, integer *, integer *,
3657 doublecomplex *, doublecomplex *, integer *, doublecomplex *,
3658 integer *, doublecomplex *, doublecomplex *, integer *,
3659 doublecomplex *, doublereal *, doublecomplex *, doublereal *,
3660 doublereal *, logical *, integer *, logical *, ftnlen);
3661 logical upper;
3662 char uplos[1];
3663 logical packed;
3664 doublereal errmax;
3665 doublecomplex transl;
3666 extern logical lzeres_(char *, char *, integer *, integer *,
3667 doublecomplex *, doublecomplex *, integer *, ftnlen, ftnlen);
3668
3669 /* Fortran I/O blocks */
3670 static cilist io___375 = { 0, 0, 0, fmt_9993, 0 };
3671 static cilist io___376 = { 0, 0, 0, fmt_9994, 0 };
3672 static cilist io___377 = { 0, 0, 0, fmt_9992, 0 };
3673 static cilist io___380 = { 0, 0, 0, fmt_9998, 0 };
3674 static cilist io___387 = { 0, 0, 0, fmt_9999, 0 };
3675 static cilist io___388 = { 0, 0, 0, fmt_9997, 0 };
3676 static cilist io___389 = { 0, 0, 0, fmt_9995, 0 };
3677 static cilist io___390 = { 0, 0, 0, fmt_9996, 0 };
3678 static cilist io___391 = { 0, 0, 0, fmt_9993, 0 };
3679 static cilist io___392 = { 0, 0, 0, fmt_9994, 0 };
3680
3681
3682
3683 /* Tests ZHER2 and ZHPR2. */
3684
3685 /* Auxiliary routine for test program for Level 2 Blas. */
3686
3687 /* -- Written on 10-August-1987. */
3688 /* Richard Hanson, Sandia National Labs. */
3689 /* Jeremy Du Croz, NAG Central Office. */
3690
3691 /* .. Parameters .. */
3692 /* .. Scalar Arguments .. */
3693 /* .. Array Arguments .. */
3694 /* .. Local Scalars .. */
3695 /* .. Local Arrays .. */
3696 /* .. External Functions .. */
3697 /* .. External Subroutines .. */
3698 /* .. Intrinsic Functions .. */
3699 /* .. Scalars in Common .. */
3700 /* .. Common blocks .. */
3701 /* .. Data statements .. */
3702 /* Parameter adjustments */
3703 --idim;
3704 --alf;
3705 --inc;
3706 z_dim1 = *nmax;
3707 z_offset = 1 + z_dim1;
3708 z__ -= z_offset;
3709 --g;
3710 --yt;
3711 --y;
3712 --x;
3713 --as;
3714 --aa;
3715 a_dim1 = *nmax;
3716 a_offset = 1 + a_dim1;
3717 a -= a_offset;
3718 --ys;
3719 --yy;
3720 --xs;
3721 --xx;
3722
3723 /* Function Body */
3724 /* .. Executable Statements .. */
3725 full = *(unsigned char *)&sname[2] == 'E';
3726 packed = *(unsigned char *)&sname[2] == 'P';
3727 /* Define the number of arguments. */
3728 if (full) {
3729 nargs = 9;
3730 } else if (packed) {
3731 nargs = 8;
3732 }
3733
3734 nc = 0;
3735 reset = TRUE_;
3736 errmax = 0.;
3737
3738 i__1 = *nidim;
3739 for (in = 1; in <= i__1; ++in) {
3740 n = idim[in];
3741 /* Set LDA to 1 more than minimum value if room. */
3742 lda = n;
3743 if (lda < *nmax) {
3744 ++lda;
3745 }
3746 /* Skip tests if not enough room. */
3747 if (lda > *nmax) {
3748 goto L140;
3749 }
3750 if (packed) {
3751 laa = n * (n + 1) / 2;
3752 } else {
3753 laa = lda * n;
3754 }
3755
3756 for (ic = 1; ic <= 2; ++ic) {
3757 *(unsigned char *)uplo = *(unsigned char *)&ich[ic - 1];
3758 upper = *(unsigned char *)uplo == 'U';
3759
3760 i__2 = *ninc;
3761 for (ix = 1; ix <= i__2; ++ix) {
3762 incx = inc[ix];
3763 lx = abs(incx) * n;
3764
3765 /* Generate the vector X. */
3766
3767 transl.r = .5, transl.i = 0.;
3768 i__3 = abs(incx);
3769 i__4 = n - 1;
3770 zmake_("GE", " ", " ", &c__1, &n, &x[1], &c__1, &xx[1], &i__3,
3771 &c__0, &i__4, &reset, &transl, (ftnlen)2, (ftnlen)1,
3772 (ftnlen)1);
3773 if (n > 1) {
3774 i__3 = n / 2;
3775 x[i__3].r = 0., x[i__3].i = 0.;
3776 i__3 = abs(incx) * (n / 2 - 1) + 1;
3777 xx[i__3].r = 0., xx[i__3].i = 0.;
3778 }
3779
3780 i__3 = *ninc;
3781 for (iy = 1; iy <= i__3; ++iy) {
3782 incy = inc[iy];
3783 ly = abs(incy) * n;
3784
3785 /* Generate the vector Y. */
3786
3787 transl.r = 0., transl.i = 0.;
3788 i__4 = abs(incy);
3789 i__5 = n - 1;
3790 zmake_("GE", " ", " ", &c__1, &n, &y[1], &c__1, &yy[1], &
3791 i__4, &c__0, &i__5, &reset, &transl, (ftnlen)2, (
3792 ftnlen)1, (ftnlen)1);
3793 if (n > 1) {
3794 i__4 = n / 2;
3795 y[i__4].r = 0., y[i__4].i = 0.;
3796 i__4 = abs(incy) * (n / 2 - 1) + 1;
3797 yy[i__4].r = 0., yy[i__4].i = 0.;
3798 }
3799
3800 i__4 = *nalf;
3801 for (ia = 1; ia <= i__4; ++ia) {
3802 i__5 = ia;
3803 alpha.r = alf[i__5].r, alpha.i = alf[i__5].i;
3804 null = n <= 0 || alpha.r == 0. && alpha.i == 0.;
3805
3806 /* Generate the matrix A. */
3807
3808 transl.r = 0., transl.i = 0.;
3809 i__5 = n - 1;
3810 i__6 = n - 1;
3811 zmake_(sname + 1, uplo, " ", &n, &n, &a[a_offset],
3812 nmax, &aa[1], &lda, &i__5, &i__6, &reset, &
3813 transl, (ftnlen)2, (ftnlen)1, (ftnlen)1);
3814
3815 ++nc;
3816
3817 /* Save every datum before calling the subroutine. */
3818
3819 *(unsigned char *)uplos = *(unsigned char *)uplo;
3820 ns = n;
3821 als.r = alpha.r, als.i = alpha.i;
3822 i__5 = laa;
3823 for (i__ = 1; i__ <= i__5; ++i__) {
3824 i__6 = i__;
3825 i__7 = i__;
3826 as[i__6].r = aa[i__7].r, as[i__6].i = aa[i__7].i;
3827 /* L10: */
3828 }
3829 ldas = lda;
3830 i__5 = lx;
3831 for (i__ = 1; i__ <= i__5; ++i__) {
3832 i__6 = i__;
3833 i__7 = i__;
3834 xs[i__6].r = xx[i__7].r, xs[i__6].i = xx[i__7].i;
3835 /* L20: */
3836 }
3837 incxs = incx;
3838 i__5 = ly;
3839 for (i__ = 1; i__ <= i__5; ++i__) {
3840 i__6 = i__;
3841 i__7 = i__;
3842 ys[i__6].r = yy[i__7].r, ys[i__6].i = yy[i__7].i;
3843 /* L30: */
3844 }
3845 incys = incy;
3846
3847 /* Call the subroutine. */
3848
3849 if (full) {
3850 if (*trace) {
3851 io___375.ciunit = *ntra;
3852 s_wsfe(&io___375);
3853 do_fio(&c__1, (char *)&nc, (ftnlen)sizeof(
3854 integer));
3855 do_fio(&c__1, sname, (ftnlen)6);
3856 do_fio(&c__1, uplo, (ftnlen)1);
3857 do_fio(&c__1, (char *)&n, (ftnlen)sizeof(
3858 integer));
3859 do_fio(&c__2, (char *)&alpha, (ftnlen)sizeof(
3860 doublereal));
3861 do_fio(&c__1, (char *)&incx, (ftnlen)sizeof(
3862 integer));
3863 do_fio(&c__1, (char *)&incy, (ftnlen)sizeof(
3864 integer));
3865 do_fio(&c__1, (char *)&lda, (ftnlen)sizeof(
3866 integer));
3867 e_wsfe();
3868 }
3869 if (*rewi) {
3870 al__1.aerr = 0;
3871 al__1.aunit = *ntra;
3872 f_rew(&al__1);
3873 }
3874 zher2_(uplo, &n, &alpha, &xx[1], &incx, &yy[1], &
3875 incy, &aa[1], &lda, (ftnlen)1);
3876 } else if (packed) {
3877 if (*trace) {
3878 io___376.ciunit = *ntra;
3879 s_wsfe(&io___376);
3880 do_fio(&c__1, (char *)&nc, (ftnlen)sizeof(
3881 integer));
3882 do_fio(&c__1, sname, (ftnlen)6);
3883 do_fio(&c__1, uplo, (ftnlen)1);
3884 do_fio(&c__1, (char *)&n, (ftnlen)sizeof(
3885 integer));
3886 do_fio(&c__2, (char *)&alpha, (ftnlen)sizeof(
3887 doublereal));
3888 do_fio(&c__1, (char *)&incx, (ftnlen)sizeof(
3889 integer));
3890 do_fio(&c__1, (char *)&incy, (ftnlen)sizeof(
3891 integer));
3892 e_wsfe();
3893 }
3894 if (*rewi) {
3895 al__1.aerr = 0;
3896 al__1.aunit = *ntra;
3897 f_rew(&al__1);
3898 }
3899 zhpr2_(uplo, &n, &alpha, &xx[1], &incx, &yy[1], &
3900 incy, &aa[1], (ftnlen)1);
3901 }
3902
3903 /* Check if error-exit was taken incorrectly. */
3904
3905 if (! infoc_1.ok) {
3906 io___377.ciunit = *nout;
3907 s_wsfe(&io___377);
3908 e_wsfe();
3909 *fatal = TRUE_;
3910 goto L160;
3911 }
3912
3913 /* See what data changed inside subroutines. */
3914
3915 isame[0] = *(unsigned char *)uplo == *(unsigned char *
3916 )uplos;
3917 isame[1] = ns == n;
3918 isame[2] = als.r == alpha.r && als.i == alpha.i;
3919 isame[3] = lze_(&xs[1], &xx[1], &lx);
3920 isame[4] = incxs == incx;
3921 isame[5] = lze_(&ys[1], &yy[1], &ly);
3922 isame[6] = incys == incy;
3923 if (null) {
3924 isame[7] = lze_(&as[1], &aa[1], &laa);
3925 } else {
3926 isame[7] = lzeres_(sname + 1, uplo, &n, &n, &as[1]
3927 , &aa[1], &lda, (ftnlen)2, (ftnlen)1);
3928 }
3929 if (! packed) {
3930 isame[8] = ldas == lda;
3931 }
3932
3933 /* If data was incorrectly changed, report and return. */
3934
3935 same = TRUE_;
3936 i__5 = nargs;
3937 for (i__ = 1; i__ <= i__5; ++i__) {
3938 same = same && isame[i__ - 1];
3939 if (! isame[i__ - 1]) {
3940 io___380.ciunit = *nout;
3941 s_wsfe(&io___380);
3942 do_fio(&c__1, (char *)&i__, (ftnlen)sizeof(
3943 integer));
3944 e_wsfe();
3945 }
3946 /* L40: */
3947 }
3948 if (! same) {
3949 *fatal = TRUE_;
3950 goto L160;
3951 }
3952
3953 if (! null) {
3954
3955 /* Check the result column by column. */
3956
3957 if (incx > 0) {
3958 i__5 = n;
3959 for (i__ = 1; i__ <= i__5; ++i__) {
3960 i__6 = i__ + z_dim1;
3961 i__7 = i__;
3962 z__[i__6].r = x[i__7].r, z__[i__6].i = x[
3963 i__7].i;
3964 /* L50: */
3965 }
3966 } else {
3967 i__5 = n;
3968 for (i__ = 1; i__ <= i__5; ++i__) {
3969 i__6 = i__ + z_dim1;
3970 i__7 = n - i__ + 1;
3971 z__[i__6].r = x[i__7].r, z__[i__6].i = x[
3972 i__7].i;
3973 /* L60: */
3974 }
3975 }
3976 if (incy > 0) {
3977 i__5 = n;
3978 for (i__ = 1; i__ <= i__5; ++i__) {
3979 i__6 = i__ + (z_dim1 << 1);
3980 i__7 = i__;
3981 z__[i__6].r = y[i__7].r, z__[i__6].i = y[
3982 i__7].i;
3983 /* L70: */
3984 }
3985 } else {
3986 i__5 = n;
3987 for (i__ = 1; i__ <= i__5; ++i__) {
3988 i__6 = i__ + (z_dim1 << 1);
3989 i__7 = n - i__ + 1;
3990 z__[i__6].r = y[i__7].r, z__[i__6].i = y[
3991 i__7].i;
3992 /* L80: */
3993 }
3994 }
3995 ja = 1;
3996 i__5 = n;
3997 for (j = 1; j <= i__5; ++j) {
3998 d_cnjg(&z__2, &z__[j + (z_dim1 << 1)]);
3999 z__1.r = alpha.r * z__2.r - alpha.i * z__2.i,
4000 z__1.i = alpha.r * z__2.i + alpha.i *
4001 z__2.r;
4002 w[0].r = z__1.r, w[0].i = z__1.i;
4003 d_cnjg(&z__2, &alpha);
4004 d_cnjg(&z__3, &z__[j + z_dim1]);
4005 z__1.r = z__2.r * z__3.r - z__2.i * z__3.i,
4006 z__1.i = z__2.r * z__3.i + z__2.i *
4007 z__3.r;
4008 w[1].r = z__1.r, w[1].i = z__1.i;
4009 if (upper) {
4010 jj = 1;
4011 lj = j;
4012 } else {
4013 jj = j;
4014 lj = n - j + 1;
4015 }
4016 zmvch_("N", &lj, &c__2, &c_b2, &z__[jj +
4017 z_dim1], nmax, w, &c__1, &c_b2, &a[jj
4018 + j * a_dim1], &c__1, &yt[1], &g[1], &
4019 aa[ja], eps, &err, fatal, nout, &
4020 c_true, (ftnlen)1);
4021 if (full) {
4022 if (upper) {
4023 ja += lda;
4024 } else {
4025 ja = ja + lda + 1;
4026 }
4027 } else {
4028 ja += lj;
4029 }
4030 errmax = max(errmax,err);
4031 /* If got really bad answer, report and return. */
4032 if (*fatal) {
4033 goto L150;
4034 }
4035 /* L90: */
4036 }
4037 } else {
4038 /* Avoid repeating tests with N.le.0. */
4039 if (n <= 0) {
4040 goto L140;
4041 }
4042 }
4043
4044 /* L100: */
4045 }
4046
4047 /* L110: */
4048 }
4049
4050 /* L120: */
4051 }
4052
4053 /* L130: */
4054 }
4055
4056 L140:
4057 ;
4058 }
4059
4060 /* Report result. */
4061
4062 if (errmax < *thresh) {
4063 io___387.ciunit = *nout;
4064 s_wsfe(&io___387);
4065 do_fio(&c__1, sname, (ftnlen)6);
4066 do_fio(&c__1, (char *)&nc, (ftnlen)sizeof(integer));
4067 e_wsfe();
4068 } else {
4069 io___388.ciunit = *nout;
4070 s_wsfe(&io___388);
4071 do_fio(&c__1, sname, (ftnlen)6);
4072 do_fio(&c__1, (char *)&nc, (ftnlen)sizeof(integer));
4073 do_fio(&c__1, (char *)&errmax, (ftnlen)sizeof(doublereal));
4074 e_wsfe();
4075 }
4076 goto L170;
4077
4078 L150:
4079 io___389.ciunit = *nout;
4080 s_wsfe(&io___389);
4081 do_fio(&c__1, (char *)&j, (ftnlen)sizeof(integer));
4082 e_wsfe();
4083
4084 L160:
4085 io___390.ciunit = *nout;
4086 s_wsfe(&io___390);
4087 do_fio(&c__1, sname, (ftnlen)6);
4088 e_wsfe();
4089 if (full) {
4090 io___391.ciunit = *nout;
4091 s_wsfe(&io___391);
4092 do_fio(&c__1, (char *)&nc, (ftnlen)sizeof(integer));
4093 do_fio(&c__1, sname, (ftnlen)6);
4094 do_fio(&c__1, uplo, (ftnlen)1);
4095 do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
4096 do_fio(&c__2, (char *)&alpha, (ftnlen)sizeof(doublereal));
4097 do_fio(&c__1, (char *)&incx, (ftnlen)sizeof(integer));
4098 do_fio(&c__1, (char *)&incy, (ftnlen)sizeof(integer));
4099 do_fio(&c__1, (char *)&lda, (ftnlen)sizeof(integer));
4100 e_wsfe();
4101 } else if (packed) {
4102 io___392.ciunit = *nout;
4103 s_wsfe(&io___392);
4104 do_fio(&c__1, (char *)&nc, (ftnlen)sizeof(integer));
4105 do_fio(&c__1, sname, (ftnlen)6);
4106 do_fio(&c__1, uplo, (ftnlen)1);
4107 do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
4108 do_fio(&c__2, (char *)&alpha, (ftnlen)sizeof(doublereal));
4109 do_fio(&c__1, (char *)&incx, (ftnlen)sizeof(integer));
4110 do_fio(&c__1, (char *)&incy, (ftnlen)sizeof(integer));
4111 e_wsfe();
4112 }
4113
4114 L170:
4115 return 0;
4116
4117
4118 /* End of ZCHK6. */
4119
4120 } /* zchk6_ */
4121
zchke_(integer * isnum,char * srnamt,integer * nout,ftnlen srnamt_len)4122 /* Subroutine */ int zchke_(integer *isnum, char *srnamt, integer *nout,
4123 ftnlen srnamt_len)
4124 {
4125 /* Format strings */
4126 static char fmt_9999[] = "(\002 \002,a6,\002 PASSED THE TESTS OF ERROR-E"
4127 "XITS\002)";
4128 static char fmt_9998[] = "(\002 ******* \002,a6,\002 FAILED THE TESTS OF"
4129 " ERROR-EXITS *****\002,\002**\002)";
4130
4131 /* Builtin functions */
4132 integer s_wsfe(cilist *), do_fio(integer *, char *, ftnlen), e_wsfe(void);
4133
4134 /* Local variables */
4135 doublecomplex a[1] /* was [1][1] */, x[1], y[1], beta;
4136 extern /* Subroutine */ int zher_(char *, integer *, doublereal *,
4137 doublecomplex *, integer *, doublecomplex *, integer *, ftnlen),
4138 zhpr_(char *, integer *, doublereal *, doublecomplex *, integer *,
4139 doublecomplex *, ftnlen), zher2_(char *, integer *,
4140 doublecomplex *, doublecomplex *, integer *, doublecomplex *,
4141 integer *, doublecomplex *, integer *, ftnlen), zhpr2_(char *,
4142 integer *, doublecomplex *, doublecomplex *, integer *,
4143 doublecomplex *, integer *, doublecomplex *, ftnlen);
4144 doublecomplex alpha;
4145 extern /* Subroutine */ int zgerc_(integer *, integer *, doublecomplex *,
4146 doublecomplex *, integer *, doublecomplex *, integer *,
4147 doublecomplex *, integer *), zgbmv_(char *, integer *, integer *,
4148 integer *, integer *, doublecomplex *, doublecomplex *, integer *,
4149 doublecomplex *, integer *, doublecomplex *, doublecomplex *,
4150 integer *, ftnlen), zhbmv_(char *, integer *, integer *,
4151 doublecomplex *, doublecomplex *, integer *, doublecomplex *,
4152 integer *, doublecomplex *, doublecomplex *, integer *, ftnlen),
4153 zgemv_(char *, integer *, integer *, doublecomplex *,
4154 doublecomplex *, integer *, doublecomplex *, integer *,
4155 doublecomplex *, doublecomplex *, integer *, ftnlen), zhemv_(char
4156 *, integer *, doublecomplex *, doublecomplex *, integer *,
4157 doublecomplex *, integer *, doublecomplex *, doublecomplex *,
4158 integer *, ftnlen), zgeru_(integer *, integer *, doublecomplex *,
4159 doublecomplex *, integer *, doublecomplex *, integer *,
4160 doublecomplex *, integer *), ztbmv_(char *, char *, char *,
4161 integer *, integer *, doublecomplex *, integer *, doublecomplex *,
4162 integer *, ftnlen, ftnlen, ftnlen), zhpmv_(char *, integer *,
4163 doublecomplex *, doublecomplex *, doublecomplex *, integer *,
4164 doublecomplex *, doublecomplex *, integer *, ftnlen), ztbsv_(char
4165 *, char *, char *, integer *, integer *, doublecomplex *, integer
4166 *, doublecomplex *, integer *, ftnlen, ftnlen, ftnlen), ztpmv_(
4167 char *, char *, char *, integer *, doublecomplex *, doublecomplex
4168 *, integer *, ftnlen, ftnlen, ftnlen), ztrmv_(char *, char *,
4169 char *, integer *, doublecomplex *, integer *, doublecomplex *,
4170 integer *, ftnlen, ftnlen, ftnlen), ztpsv_(char *, char *, char *,
4171 integer *, doublecomplex *, doublecomplex *, integer *, ftnlen,
4172 ftnlen, ftnlen), ztrsv_(char *, char *, char *, integer *,
4173 doublecomplex *, integer *, doublecomplex *, integer *, ftnlen,
4174 ftnlen, ftnlen);
4175 doublereal ralpha;
4176 extern /* Subroutine */ int chkxer_(char *, integer *, integer *, logical
4177 *, logical *, ftnlen);
4178
4179 /* Fortran I/O blocks */
4180 static cilist io___399 = { 0, 0, 0, fmt_9999, 0 };
4181 static cilist io___400 = { 0, 0, 0, fmt_9998, 0 };
4182
4183
4184
4185 /* Tests the error exits from the Level 2 Blas. */
4186 /* Requires a special version of the error-handling routine XERBLA. */
4187 /* ALPHA, RALPHA, BETA, A, X and Y should not need to be defined. */
4188
4189 /* Auxiliary routine for test program for Level 2 Blas. */
4190
4191 /* -- Written on 10-August-1987. */
4192 /* Richard Hanson, Sandia National Labs. */
4193 /* Jeremy Du Croz, NAG Central Office. */
4194
4195 /* .. Scalar Arguments .. */
4196 /* .. Scalars in Common .. */
4197 /* .. Local Scalars .. */
4198 /* .. Local Arrays .. */
4199 /* .. External Subroutines .. */
4200 /* .. Common blocks .. */
4201 /* .. Executable Statements .. */
4202 /* OK is set to .FALSE. by the special version of XERBLA or by CHKXER */
4203 /* if anything is wrong. */
4204 infoc_1.ok = TRUE_;
4205 /* LERR is set to .TRUE. by the special version of XERBLA each time */
4206 /* it is called, and is then tested and re-set by CHKXER. */
4207 infoc_1.lerr = FALSE_;
4208 switch (*isnum) {
4209 case 1: goto L10;
4210 case 2: goto L20;
4211 case 3: goto L30;
4212 case 4: goto L40;
4213 case 5: goto L50;
4214 case 6: goto L60;
4215 case 7: goto L70;
4216 case 8: goto L80;
4217 case 9: goto L90;
4218 case 10: goto L100;
4219 case 11: goto L110;
4220 case 12: goto L120;
4221 case 13: goto L130;
4222 case 14: goto L140;
4223 case 15: goto L150;
4224 case 16: goto L160;
4225 case 17: goto L170;
4226 }
4227 L10:
4228 infoc_1.infot = 1;
4229 zgemv_("/", &c__0, &c__0, &alpha, a, &c__1, x, &c__1, &beta, y, &c__1, (
4230 ftnlen)1);
4231 chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok, (ftnlen)
4232 6);
4233 infoc_1.infot = 2;
4234 zgemv_("N", &c_n1, &c__0, &alpha, a, &c__1, x, &c__1, &beta, y, &c__1, (
4235 ftnlen)1);
4236 chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok, (ftnlen)
4237 6);
4238 infoc_1.infot = 3;
4239 zgemv_("N", &c__0, &c_n1, &alpha, a, &c__1, x, &c__1, &beta, y, &c__1, (
4240 ftnlen)1);
4241 chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok, (ftnlen)
4242 6);
4243 infoc_1.infot = 6;
4244 zgemv_("N", &c__2, &c__0, &alpha, a, &c__1, x, &c__1, &beta, y, &c__1, (
4245 ftnlen)1);
4246 chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok, (ftnlen)
4247 6);
4248 infoc_1.infot = 8;
4249 zgemv_("N", &c__0, &c__0, &alpha, a, &c__1, x, &c__0, &beta, y, &c__1, (
4250 ftnlen)1);
4251 chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok, (ftnlen)
4252 6);
4253 infoc_1.infot = 11;
4254 zgemv_("N", &c__0, &c__0, &alpha, a, &c__1, x, &c__1, &beta, y, &c__0, (
4255 ftnlen)1);
4256 chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok, (ftnlen)
4257 6);
4258 goto L180;
4259 L20:
4260 infoc_1.infot = 1;
4261 zgbmv_("/", &c__0, &c__0, &c__0, &c__0, &alpha, a, &c__1, x, &c__1, &beta,
4262 y, &c__1, (ftnlen)1);
4263 chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok, (ftnlen)
4264 6);
4265 infoc_1.infot = 2;
4266 zgbmv_("N", &c_n1, &c__0, &c__0, &c__0, &alpha, a, &c__1, x, &c__1, &beta,
4267 y, &c__1, (ftnlen)1);
4268 chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok, (ftnlen)
4269 6);
4270 infoc_1.infot = 3;
4271 zgbmv_("N", &c__0, &c_n1, &c__0, &c__0, &alpha, a, &c__1, x, &c__1, &beta,
4272 y, &c__1, (ftnlen)1);
4273 chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok, (ftnlen)
4274 6);
4275 infoc_1.infot = 4;
4276 zgbmv_("N", &c__0, &c__0, &c_n1, &c__0, &alpha, a, &c__1, x, &c__1, &beta,
4277 y, &c__1, (ftnlen)1);
4278 chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok, (ftnlen)
4279 6);
4280 infoc_1.infot = 5;
4281 zgbmv_("N", &c__2, &c__0, &c__0, &c_n1, &alpha, a, &c__1, x, &c__1, &beta,
4282 y, &c__1, (ftnlen)1);
4283 chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok, (ftnlen)
4284 6);
4285 infoc_1.infot = 8;
4286 zgbmv_("N", &c__0, &c__0, &c__1, &c__0, &alpha, a, &c__1, x, &c__1, &beta,
4287 y, &c__1, (ftnlen)1);
4288 chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok, (ftnlen)
4289 6);
4290 infoc_1.infot = 10;
4291 zgbmv_("N", &c__0, &c__0, &c__0, &c__0, &alpha, a, &c__1, x, &c__0, &beta,
4292 y, &c__1, (ftnlen)1);
4293 chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok, (ftnlen)
4294 6);
4295 infoc_1.infot = 13;
4296 zgbmv_("N", &c__0, &c__0, &c__0, &c__0, &alpha, a, &c__1, x, &c__1, &beta,
4297 y, &c__0, (ftnlen)1);
4298 chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok, (ftnlen)
4299 6);
4300 goto L180;
4301 L30:
4302 infoc_1.infot = 1;
4303 zhemv_("/", &c__0, &alpha, a, &c__1, x, &c__1, &beta, y, &c__1, (ftnlen)1)
4304 ;
4305 chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok, (ftnlen)
4306 6);
4307 infoc_1.infot = 2;
4308 zhemv_("U", &c_n1, &alpha, a, &c__1, x, &c__1, &beta, y, &c__1, (ftnlen)1)
4309 ;
4310 chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok, (ftnlen)
4311 6);
4312 infoc_1.infot = 5;
4313 zhemv_("U", &c__2, &alpha, a, &c__1, x, &c__1, &beta, y, &c__1, (ftnlen)1)
4314 ;
4315 chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok, (ftnlen)
4316 6);
4317 infoc_1.infot = 7;
4318 zhemv_("U", &c__0, &alpha, a, &c__1, x, &c__0, &beta, y, &c__1, (ftnlen)1)
4319 ;
4320 chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok, (ftnlen)
4321 6);
4322 infoc_1.infot = 10;
4323 zhemv_("U", &c__0, &alpha, a, &c__1, x, &c__1, &beta, y, &c__0, (ftnlen)1)
4324 ;
4325 chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok, (ftnlen)
4326 6);
4327 goto L180;
4328 L40:
4329 infoc_1.infot = 1;
4330 zhbmv_("/", &c__0, &c__0, &alpha, a, &c__1, x, &c__1, &beta, y, &c__1, (
4331 ftnlen)1);
4332 chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok, (ftnlen)
4333 6);
4334 infoc_1.infot = 2;
4335 zhbmv_("U", &c_n1, &c__0, &alpha, a, &c__1, x, &c__1, &beta, y, &c__1, (
4336 ftnlen)1);
4337 chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok, (ftnlen)
4338 6);
4339 infoc_1.infot = 3;
4340 zhbmv_("U", &c__0, &c_n1, &alpha, a, &c__1, x, &c__1, &beta, y, &c__1, (
4341 ftnlen)1);
4342 chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok, (ftnlen)
4343 6);
4344 infoc_1.infot = 6;
4345 zhbmv_("U", &c__0, &c__1, &alpha, a, &c__1, x, &c__1, &beta, y, &c__1, (
4346 ftnlen)1);
4347 chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok, (ftnlen)
4348 6);
4349 infoc_1.infot = 8;
4350 zhbmv_("U", &c__0, &c__0, &alpha, a, &c__1, x, &c__0, &beta, y, &c__1, (
4351 ftnlen)1);
4352 chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok, (ftnlen)
4353 6);
4354 infoc_1.infot = 11;
4355 zhbmv_("U", &c__0, &c__0, &alpha, a, &c__1, x, &c__1, &beta, y, &c__0, (
4356 ftnlen)1);
4357 chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok, (ftnlen)
4358 6);
4359 goto L180;
4360 L50:
4361 infoc_1.infot = 1;
4362 zhpmv_("/", &c__0, &alpha, a, x, &c__1, &beta, y, &c__1, (ftnlen)1);
4363 chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok, (ftnlen)
4364 6);
4365 infoc_1.infot = 2;
4366 zhpmv_("U", &c_n1, &alpha, a, x, &c__1, &beta, y, &c__1, (ftnlen)1);
4367 chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok, (ftnlen)
4368 6);
4369 infoc_1.infot = 6;
4370 zhpmv_("U", &c__0, &alpha, a, x, &c__0, &beta, y, &c__1, (ftnlen)1);
4371 chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok, (ftnlen)
4372 6);
4373 infoc_1.infot = 9;
4374 zhpmv_("U", &c__0, &alpha, a, x, &c__1, &beta, y, &c__0, (ftnlen)1);
4375 chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok, (ftnlen)
4376 6);
4377 goto L180;
4378 L60:
4379 infoc_1.infot = 1;
4380 ztrmv_("/", "N", "N", &c__0, a, &c__1, x, &c__1, (ftnlen)1, (ftnlen)1, (
4381 ftnlen)1);
4382 chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok, (ftnlen)
4383 6);
4384 infoc_1.infot = 2;
4385 ztrmv_("U", "/", "N", &c__0, a, &c__1, x, &c__1, (ftnlen)1, (ftnlen)1, (
4386 ftnlen)1);
4387 chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok, (ftnlen)
4388 6);
4389 infoc_1.infot = 3;
4390 ztrmv_("U", "N", "/", &c__0, a, &c__1, x, &c__1, (ftnlen)1, (ftnlen)1, (
4391 ftnlen)1);
4392 chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok, (ftnlen)
4393 6);
4394 infoc_1.infot = 4;
4395 ztrmv_("U", "N", "N", &c_n1, a, &c__1, x, &c__1, (ftnlen)1, (ftnlen)1, (
4396 ftnlen)1);
4397 chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok, (ftnlen)
4398 6);
4399 infoc_1.infot = 6;
4400 ztrmv_("U", "N", "N", &c__2, a, &c__1, x, &c__1, (ftnlen)1, (ftnlen)1, (
4401 ftnlen)1);
4402 chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok, (ftnlen)
4403 6);
4404 infoc_1.infot = 8;
4405 ztrmv_("U", "N", "N", &c__0, a, &c__1, x, &c__0, (ftnlen)1, (ftnlen)1, (
4406 ftnlen)1);
4407 chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok, (ftnlen)
4408 6);
4409 goto L180;
4410 L70:
4411 infoc_1.infot = 1;
4412 ztbmv_("/", "N", "N", &c__0, &c__0, a, &c__1, x, &c__1, (ftnlen)1, (
4413 ftnlen)1, (ftnlen)1);
4414 chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok, (ftnlen)
4415 6);
4416 infoc_1.infot = 2;
4417 ztbmv_("U", "/", "N", &c__0, &c__0, a, &c__1, x, &c__1, (ftnlen)1, (
4418 ftnlen)1, (ftnlen)1);
4419 chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok, (ftnlen)
4420 6);
4421 infoc_1.infot = 3;
4422 ztbmv_("U", "N", "/", &c__0, &c__0, a, &c__1, x, &c__1, (ftnlen)1, (
4423 ftnlen)1, (ftnlen)1);
4424 chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok, (ftnlen)
4425 6);
4426 infoc_1.infot = 4;
4427 ztbmv_("U", "N", "N", &c_n1, &c__0, a, &c__1, x, &c__1, (ftnlen)1, (
4428 ftnlen)1, (ftnlen)1);
4429 chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok, (ftnlen)
4430 6);
4431 infoc_1.infot = 5;
4432 ztbmv_("U", "N", "N", &c__0, &c_n1, a, &c__1, x, &c__1, (ftnlen)1, (
4433 ftnlen)1, (ftnlen)1);
4434 chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok, (ftnlen)
4435 6);
4436 infoc_1.infot = 7;
4437 ztbmv_("U", "N", "N", &c__0, &c__1, a, &c__1, x, &c__1, (ftnlen)1, (
4438 ftnlen)1, (ftnlen)1);
4439 chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok, (ftnlen)
4440 6);
4441 infoc_1.infot = 9;
4442 ztbmv_("U", "N", "N", &c__0, &c__0, a, &c__1, x, &c__0, (ftnlen)1, (
4443 ftnlen)1, (ftnlen)1);
4444 chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok, (ftnlen)
4445 6);
4446 goto L180;
4447 L80:
4448 infoc_1.infot = 1;
4449 ztpmv_("/", "N", "N", &c__0, a, x, &c__1, (ftnlen)1, (ftnlen)1, (ftnlen)1)
4450 ;
4451 chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok, (ftnlen)
4452 6);
4453 infoc_1.infot = 2;
4454 ztpmv_("U", "/", "N", &c__0, a, x, &c__1, (ftnlen)1, (ftnlen)1, (ftnlen)1)
4455 ;
4456 chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok, (ftnlen)
4457 6);
4458 infoc_1.infot = 3;
4459 ztpmv_("U", "N", "/", &c__0, a, x, &c__1, (ftnlen)1, (ftnlen)1, (ftnlen)1)
4460 ;
4461 chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok, (ftnlen)
4462 6);
4463 infoc_1.infot = 4;
4464 ztpmv_("U", "N", "N", &c_n1, a, x, &c__1, (ftnlen)1, (ftnlen)1, (ftnlen)1)
4465 ;
4466 chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok, (ftnlen)
4467 6);
4468 infoc_1.infot = 7;
4469 ztpmv_("U", "N", "N", &c__0, a, x, &c__0, (ftnlen)1, (ftnlen)1, (ftnlen)1)
4470 ;
4471 chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok, (ftnlen)
4472 6);
4473 goto L180;
4474 L90:
4475 infoc_1.infot = 1;
4476 ztrsv_("/", "N", "N", &c__0, a, &c__1, x, &c__1, (ftnlen)1, (ftnlen)1, (
4477 ftnlen)1);
4478 chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok, (ftnlen)
4479 6);
4480 infoc_1.infot = 2;
4481 ztrsv_("U", "/", "N", &c__0, a, &c__1, x, &c__1, (ftnlen)1, (ftnlen)1, (
4482 ftnlen)1);
4483 chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok, (ftnlen)
4484 6);
4485 infoc_1.infot = 3;
4486 ztrsv_("U", "N", "/", &c__0, a, &c__1, x, &c__1, (ftnlen)1, (ftnlen)1, (
4487 ftnlen)1);
4488 chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok, (ftnlen)
4489 6);
4490 infoc_1.infot = 4;
4491 ztrsv_("U", "N", "N", &c_n1, a, &c__1, x, &c__1, (ftnlen)1, (ftnlen)1, (
4492 ftnlen)1);
4493 chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok, (ftnlen)
4494 6);
4495 infoc_1.infot = 6;
4496 ztrsv_("U", "N", "N", &c__2, a, &c__1, x, &c__1, (ftnlen)1, (ftnlen)1, (
4497 ftnlen)1);
4498 chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok, (ftnlen)
4499 6);
4500 infoc_1.infot = 8;
4501 ztrsv_("U", "N", "N", &c__0, a, &c__1, x, &c__0, (ftnlen)1, (ftnlen)1, (
4502 ftnlen)1);
4503 chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok, (ftnlen)
4504 6);
4505 goto L180;
4506 L100:
4507 infoc_1.infot = 1;
4508 ztbsv_("/", "N", "N", &c__0, &c__0, a, &c__1, x, &c__1, (ftnlen)1, (
4509 ftnlen)1, (ftnlen)1);
4510 chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok, (ftnlen)
4511 6);
4512 infoc_1.infot = 2;
4513 ztbsv_("U", "/", "N", &c__0, &c__0, a, &c__1, x, &c__1, (ftnlen)1, (
4514 ftnlen)1, (ftnlen)1);
4515 chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok, (ftnlen)
4516 6);
4517 infoc_1.infot = 3;
4518 ztbsv_("U", "N", "/", &c__0, &c__0, a, &c__1, x, &c__1, (ftnlen)1, (
4519 ftnlen)1, (ftnlen)1);
4520 chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok, (ftnlen)
4521 6);
4522 infoc_1.infot = 4;
4523 ztbsv_("U", "N", "N", &c_n1, &c__0, a, &c__1, x, &c__1, (ftnlen)1, (
4524 ftnlen)1, (ftnlen)1);
4525 chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok, (ftnlen)
4526 6);
4527 infoc_1.infot = 5;
4528 ztbsv_("U", "N", "N", &c__0, &c_n1, a, &c__1, x, &c__1, (ftnlen)1, (
4529 ftnlen)1, (ftnlen)1);
4530 chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok, (ftnlen)
4531 6);
4532 infoc_1.infot = 7;
4533 ztbsv_("U", "N", "N", &c__0, &c__1, a, &c__1, x, &c__1, (ftnlen)1, (
4534 ftnlen)1, (ftnlen)1);
4535 chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok, (ftnlen)
4536 6);
4537 infoc_1.infot = 9;
4538 ztbsv_("U", "N", "N", &c__0, &c__0, a, &c__1, x, &c__0, (ftnlen)1, (
4539 ftnlen)1, (ftnlen)1);
4540 chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok, (ftnlen)
4541 6);
4542 goto L180;
4543 L110:
4544 infoc_1.infot = 1;
4545 ztpsv_("/", "N", "N", &c__0, a, x, &c__1, (ftnlen)1, (ftnlen)1, (ftnlen)1)
4546 ;
4547 chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok, (ftnlen)
4548 6);
4549 infoc_1.infot = 2;
4550 ztpsv_("U", "/", "N", &c__0, a, x, &c__1, (ftnlen)1, (ftnlen)1, (ftnlen)1)
4551 ;
4552 chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok, (ftnlen)
4553 6);
4554 infoc_1.infot = 3;
4555 ztpsv_("U", "N", "/", &c__0, a, x, &c__1, (ftnlen)1, (ftnlen)1, (ftnlen)1)
4556 ;
4557 chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok, (ftnlen)
4558 6);
4559 infoc_1.infot = 4;
4560 ztpsv_("U", "N", "N", &c_n1, a, x, &c__1, (ftnlen)1, (ftnlen)1, (ftnlen)1)
4561 ;
4562 chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok, (ftnlen)
4563 6);
4564 infoc_1.infot = 7;
4565 ztpsv_("U", "N", "N", &c__0, a, x, &c__0, (ftnlen)1, (ftnlen)1, (ftnlen)1)
4566 ;
4567 chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok, (ftnlen)
4568 6);
4569 goto L180;
4570 L120:
4571 infoc_1.infot = 1;
4572 zgerc_(&c_n1, &c__0, &alpha, x, &c__1, y, &c__1, a, &c__1);
4573 chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok, (ftnlen)
4574 6);
4575 infoc_1.infot = 2;
4576 zgerc_(&c__0, &c_n1, &alpha, x, &c__1, y, &c__1, a, &c__1);
4577 chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok, (ftnlen)
4578 6);
4579 infoc_1.infot = 5;
4580 zgerc_(&c__0, &c__0, &alpha, x, &c__0, y, &c__1, a, &c__1);
4581 chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok, (ftnlen)
4582 6);
4583 infoc_1.infot = 7;
4584 zgerc_(&c__0, &c__0, &alpha, x, &c__1, y, &c__0, a, &c__1);
4585 chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok, (ftnlen)
4586 6);
4587 infoc_1.infot = 9;
4588 zgerc_(&c__2, &c__0, &alpha, x, &c__1, y, &c__1, a, &c__1);
4589 chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok, (ftnlen)
4590 6);
4591 goto L180;
4592 L130:
4593 infoc_1.infot = 1;
4594 zgeru_(&c_n1, &c__0, &alpha, x, &c__1, y, &c__1, a, &c__1);
4595 chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok, (ftnlen)
4596 6);
4597 infoc_1.infot = 2;
4598 zgeru_(&c__0, &c_n1, &alpha, x, &c__1, y, &c__1, a, &c__1);
4599 chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok, (ftnlen)
4600 6);
4601 infoc_1.infot = 5;
4602 zgeru_(&c__0, &c__0, &alpha, x, &c__0, y, &c__1, a, &c__1);
4603 chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok, (ftnlen)
4604 6);
4605 infoc_1.infot = 7;
4606 zgeru_(&c__0, &c__0, &alpha, x, &c__1, y, &c__0, a, &c__1);
4607 chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok, (ftnlen)
4608 6);
4609 infoc_1.infot = 9;
4610 zgeru_(&c__2, &c__0, &alpha, x, &c__1, y, &c__1, a, &c__1);
4611 chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok, (ftnlen)
4612 6);
4613 goto L180;
4614 L140:
4615 infoc_1.infot = 1;
4616 zher_("/", &c__0, &ralpha, x, &c__1, a, &c__1, (ftnlen)1);
4617 chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok, (ftnlen)
4618 6);
4619 infoc_1.infot = 2;
4620 zher_("U", &c_n1, &ralpha, x, &c__1, a, &c__1, (ftnlen)1);
4621 chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok, (ftnlen)
4622 6);
4623 infoc_1.infot = 5;
4624 zher_("U", &c__0, &ralpha, x, &c__0, a, &c__1, (ftnlen)1);
4625 chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok, (ftnlen)
4626 6);
4627 infoc_1.infot = 7;
4628 zher_("U", &c__2, &ralpha, x, &c__1, a, &c__1, (ftnlen)1);
4629 chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok, (ftnlen)
4630 6);
4631 goto L180;
4632 L150:
4633 infoc_1.infot = 1;
4634 zhpr_("/", &c__0, &ralpha, x, &c__1, a, (ftnlen)1);
4635 chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok, (ftnlen)
4636 6);
4637 infoc_1.infot = 2;
4638 zhpr_("U", &c_n1, &ralpha, x, &c__1, a, (ftnlen)1);
4639 chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok, (ftnlen)
4640 6);
4641 infoc_1.infot = 5;
4642 zhpr_("U", &c__0, &ralpha, x, &c__0, a, (ftnlen)1);
4643 chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok, (ftnlen)
4644 6);
4645 goto L180;
4646 L160:
4647 infoc_1.infot = 1;
4648 zher2_("/", &c__0, &alpha, x, &c__1, y, &c__1, a, &c__1, (ftnlen)1);
4649 chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok, (ftnlen)
4650 6);
4651 infoc_1.infot = 2;
4652 zher2_("U", &c_n1, &alpha, x, &c__1, y, &c__1, a, &c__1, (ftnlen)1);
4653 chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok, (ftnlen)
4654 6);
4655 infoc_1.infot = 5;
4656 zher2_("U", &c__0, &alpha, x, &c__0, y, &c__1, a, &c__1, (ftnlen)1);
4657 chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok, (ftnlen)
4658 6);
4659 infoc_1.infot = 7;
4660 zher2_("U", &c__0, &alpha, x, &c__1, y, &c__0, a, &c__1, (ftnlen)1);
4661 chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok, (ftnlen)
4662 6);
4663 infoc_1.infot = 9;
4664 zher2_("U", &c__2, &alpha, x, &c__1, y, &c__1, a, &c__1, (ftnlen)1);
4665 chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok, (ftnlen)
4666 6);
4667 goto L180;
4668 L170:
4669 infoc_1.infot = 1;
4670 zhpr2_("/", &c__0, &alpha, x, &c__1, y, &c__1, a, (ftnlen)1);
4671 chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok, (ftnlen)
4672 6);
4673 infoc_1.infot = 2;
4674 zhpr2_("U", &c_n1, &alpha, x, &c__1, y, &c__1, a, (ftnlen)1);
4675 chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok, (ftnlen)
4676 6);
4677 infoc_1.infot = 5;
4678 zhpr2_("U", &c__0, &alpha, x, &c__0, y, &c__1, a, (ftnlen)1);
4679 chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok, (ftnlen)
4680 6);
4681 infoc_1.infot = 7;
4682 zhpr2_("U", &c__0, &alpha, x, &c__1, y, &c__0, a, (ftnlen)1);
4683 chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok, (ftnlen)
4684 6);
4685
4686 L180:
4687 if (infoc_1.ok) {
4688 io___399.ciunit = *nout;
4689 s_wsfe(&io___399);
4690 do_fio(&c__1, srnamt, (ftnlen)6);
4691 e_wsfe();
4692 } else {
4693 io___400.ciunit = *nout;
4694 s_wsfe(&io___400);
4695 do_fio(&c__1, srnamt, (ftnlen)6);
4696 e_wsfe();
4697 }
4698 return 0;
4699
4700
4701 /* End of ZCHKE. */
4702
4703 } /* zchke_ */
4704
zmake_(char * type__,char * uplo,char * diag,integer * m,integer * n,doublecomplex * a,integer * nmax,doublecomplex * aa,integer * lda,integer * kl,integer * ku,logical * reset,doublecomplex * transl,ftnlen type_len,ftnlen uplo_len,ftnlen diag_len)4705 /* Subroutine */ int zmake_(char *type__, char *uplo, char *diag, integer *m,
4706 integer *n, doublecomplex *a, integer *nmax, doublecomplex *aa,
4707 integer *lda, integer *kl, integer *ku, logical *reset, doublecomplex
4708 *transl, ftnlen type_len, ftnlen uplo_len, ftnlen diag_len)
4709 {
4710 /* System generated locals */
4711 integer a_dim1, a_offset, i__1, i__2, i__3, i__4;
4712 doublereal d__1;
4713 doublecomplex z__1, z__2;
4714
4715 /* Builtin functions */
4716 void d_cnjg(doublecomplex *, const doublecomplex *);
4717 integer s_cmp(const char *, const char *, ftnlen, ftnlen);
4718
4719 /* Local variables */
4720 integer i__, j, i1, i2, i3, jj, kk;
4721 logical gen, tri, sym;
4722 integer ibeg, iend, ioff;
4723 extern /* Double Complex */ void zbeg_(doublecomplex *, logical *);
4724 logical unit, lower, upper;
4725
4726
4727 /* Generates values for an M by N matrix A within the bandwidth */
4728 /* defined by KL and KU. */
4729 /* Stores the values in the array AA in the data structure required */
4730 /* by the routine, with unwanted elements set to rogue value. */
4731
4732 /* TYPE is 'GE', 'GB', 'HE', 'HB', 'HP', 'TR', 'TB' OR 'TP'. */
4733
4734 /* Auxiliary routine for test program for Level 2 Blas. */
4735
4736 /* -- Written on 10-August-1987. */
4737 /* Richard Hanson, Sandia National Labs. */
4738 /* Jeremy Du Croz, NAG Central Office. */
4739
4740 /* .. Parameters .. */
4741 /* .. Scalar Arguments .. */
4742 /* .. Array Arguments .. */
4743 /* .. Local Scalars .. */
4744 /* .. External Functions .. */
4745 /* .. Intrinsic Functions .. */
4746 /* .. Executable Statements .. */
4747 /* Parameter adjustments */
4748 a_dim1 = *nmax;
4749 a_offset = 1 + a_dim1;
4750 a -= a_offset;
4751 --aa;
4752
4753 /* Function Body */
4754 gen = *(unsigned char *)type__ == 'G';
4755 sym = *(unsigned char *)type__ == 'H';
4756 tri = *(unsigned char *)type__ == 'T';
4757 upper = (sym || tri) && *(unsigned char *)uplo == 'U';
4758 lower = (sym || tri) && *(unsigned char *)uplo == 'L';
4759 unit = tri && *(unsigned char *)diag == 'U';
4760
4761 /* Generate data in array A. */
4762
4763 i__1 = *n;
4764 for (j = 1; j <= i__1; ++j) {
4765 i__2 = *m;
4766 for (i__ = 1; i__ <= i__2; ++i__) {
4767 if (gen || upper && i__ <= j || lower && i__ >= j) {
4768 if (i__ <= j && j - i__ <= *ku || i__ >= j && i__ - j <= *kl)
4769 {
4770 i__3 = i__ + j * a_dim1;
4771 zbeg_(&z__2, reset);
4772 z__1.r = z__2.r + transl->r, z__1.i = z__2.i + transl->i;
4773 a[i__3].r = z__1.r, a[i__3].i = z__1.i;
4774 } else {
4775 i__3 = i__ + j * a_dim1;
4776 a[i__3].r = 0., a[i__3].i = 0.;
4777 }
4778 if (i__ != j) {
4779 if (sym) {
4780 i__3 = j + i__ * a_dim1;
4781 d_cnjg(&z__1, &a[i__ + j * a_dim1]);
4782 a[i__3].r = z__1.r, a[i__3].i = z__1.i;
4783 } else if (tri) {
4784 i__3 = j + i__ * a_dim1;
4785 a[i__3].r = 0., a[i__3].i = 0.;
4786 }
4787 }
4788 }
4789 /* L10: */
4790 }
4791 if (sym) {
4792 i__2 = j + j * a_dim1;
4793 i__3 = j + j * a_dim1;
4794 d__1 = a[i__3].r;
4795 z__1.r = d__1, z__1.i = 0.;
4796 a[i__2].r = z__1.r, a[i__2].i = z__1.i;
4797 }
4798 if (tri) {
4799 i__2 = j + j * a_dim1;
4800 i__3 = j + j * a_dim1;
4801 z__1.r = a[i__3].r + 1., z__1.i = a[i__3].i + 0.;
4802 a[i__2].r = z__1.r, a[i__2].i = z__1.i;
4803 }
4804 if (unit) {
4805 i__2 = j + j * a_dim1;
4806 a[i__2].r = 1., a[i__2].i = 0.;
4807 }
4808 /* L20: */
4809 }
4810
4811 /* Store elements in array AS in data structure required by routine. */
4812
4813 if (s_cmp(type__, "GE", (ftnlen)2, (ftnlen)2) == 0) {
4814 i__1 = *n;
4815 for (j = 1; j <= i__1; ++j) {
4816 i__2 = *m;
4817 for (i__ = 1; i__ <= i__2; ++i__) {
4818 i__3 = i__ + (j - 1) * *lda;
4819 i__4 = i__ + j * a_dim1;
4820 aa[i__3].r = a[i__4].r, aa[i__3].i = a[i__4].i;
4821 /* L30: */
4822 }
4823 i__2 = *lda;
4824 for (i__ = *m + 1; i__ <= i__2; ++i__) {
4825 i__3 = i__ + (j - 1) * *lda;
4826 aa[i__3].r = -1e10, aa[i__3].i = 1e10;
4827 /* L40: */
4828 }
4829 /* L50: */
4830 }
4831 } else if (s_cmp(type__, "GB", (ftnlen)2, (ftnlen)2) == 0) {
4832 i__1 = *n;
4833 for (j = 1; j <= i__1; ++j) {
4834 i__2 = *ku + 1 - j;
4835 for (i1 = 1; i1 <= i__2; ++i1) {
4836 i__3 = i1 + (j - 1) * *lda;
4837 aa[i__3].r = -1e10, aa[i__3].i = 1e10;
4838 /* L60: */
4839 }
4840 /* Computing MIN */
4841 i__3 = *kl + *ku + 1, i__4 = *ku + 1 + *m - j;
4842 i__2 = min(i__3,i__4);
4843 for (i2 = i1; i2 <= i__2; ++i2) {
4844 i__3 = i2 + (j - 1) * *lda;
4845 i__4 = i2 + j - *ku - 1 + j * a_dim1;
4846 aa[i__3].r = a[i__4].r, aa[i__3].i = a[i__4].i;
4847 /* L70: */
4848 }
4849 i__2 = *lda;
4850 for (i3 = i2; i3 <= i__2; ++i3) {
4851 i__3 = i3 + (j - 1) * *lda;
4852 aa[i__3].r = -1e10, aa[i__3].i = 1e10;
4853 /* L80: */
4854 }
4855 /* L90: */
4856 }
4857 } else if (s_cmp(type__, "HE", (ftnlen)2, (ftnlen)2) == 0 || s_cmp(type__,
4858 "TR", (ftnlen)2, (ftnlen)2) == 0) {
4859 i__1 = *n;
4860 for (j = 1; j <= i__1; ++j) {
4861 if (upper) {
4862 ibeg = 1;
4863 if (unit) {
4864 iend = j - 1;
4865 } else {
4866 iend = j;
4867 }
4868 } else {
4869 if (unit) {
4870 ibeg = j + 1;
4871 } else {
4872 ibeg = j;
4873 }
4874 iend = *n;
4875 }
4876 i__2 = ibeg - 1;
4877 for (i__ = 1; i__ <= i__2; ++i__) {
4878 i__3 = i__ + (j - 1) * *lda;
4879 aa[i__3].r = -1e10, aa[i__3].i = 1e10;
4880 /* L100: */
4881 }
4882 i__2 = iend;
4883 for (i__ = ibeg; i__ <= i__2; ++i__) {
4884 i__3 = i__ + (j - 1) * *lda;
4885 i__4 = i__ + j * a_dim1;
4886 aa[i__3].r = a[i__4].r, aa[i__3].i = a[i__4].i;
4887 /* L110: */
4888 }
4889 i__2 = *lda;
4890 for (i__ = iend + 1; i__ <= i__2; ++i__) {
4891 i__3 = i__ + (j - 1) * *lda;
4892 aa[i__3].r = -1e10, aa[i__3].i = 1e10;
4893 /* L120: */
4894 }
4895 if (sym) {
4896 jj = j + (j - 1) * *lda;
4897 i__2 = jj;
4898 i__3 = jj;
4899 d__1 = aa[i__3].r;
4900 z__1.r = d__1, z__1.i = -1e10;
4901 aa[i__2].r = z__1.r, aa[i__2].i = z__1.i;
4902 }
4903 /* L130: */
4904 }
4905 } else if (s_cmp(type__, "HB", (ftnlen)2, (ftnlen)2) == 0 || s_cmp(type__,
4906 "TB", (ftnlen)2, (ftnlen)2) == 0) {
4907 i__1 = *n;
4908 for (j = 1; j <= i__1; ++j) {
4909 if (upper) {
4910 kk = *kl + 1;
4911 /* Computing MAX */
4912 i__2 = 1, i__3 = *kl + 2 - j;
4913 ibeg = max(i__2,i__3);
4914 if (unit) {
4915 iend = *kl;
4916 } else {
4917 iend = *kl + 1;
4918 }
4919 } else {
4920 kk = 1;
4921 if (unit) {
4922 ibeg = 2;
4923 } else {
4924 ibeg = 1;
4925 }
4926 /* Computing MIN */
4927 i__2 = *kl + 1, i__3 = *m + 1 - j;
4928 iend = min(i__2,i__3);
4929 }
4930 i__2 = ibeg - 1;
4931 for (i__ = 1; i__ <= i__2; ++i__) {
4932 i__3 = i__ + (j - 1) * *lda;
4933 aa[i__3].r = -1e10, aa[i__3].i = 1e10;
4934 /* L140: */
4935 }
4936 i__2 = iend;
4937 for (i__ = ibeg; i__ <= i__2; ++i__) {
4938 i__3 = i__ + (j - 1) * *lda;
4939 i__4 = i__ + j - kk + j * a_dim1;
4940 aa[i__3].r = a[i__4].r, aa[i__3].i = a[i__4].i;
4941 /* L150: */
4942 }
4943 i__2 = *lda;
4944 for (i__ = iend + 1; i__ <= i__2; ++i__) {
4945 i__3 = i__ + (j - 1) * *lda;
4946 aa[i__3].r = -1e10, aa[i__3].i = 1e10;
4947 /* L160: */
4948 }
4949 if (sym) {
4950 jj = kk + (j - 1) * *lda;
4951 i__2 = jj;
4952 i__3 = jj;
4953 d__1 = aa[i__3].r;
4954 z__1.r = d__1, z__1.i = -1e10;
4955 aa[i__2].r = z__1.r, aa[i__2].i = z__1.i;
4956 }
4957 /* L170: */
4958 }
4959 } else if (s_cmp(type__, "HP", (ftnlen)2, (ftnlen)2) == 0 || s_cmp(type__,
4960 "TP", (ftnlen)2, (ftnlen)2) == 0) {
4961 ioff = 0;
4962 i__1 = *n;
4963 for (j = 1; j <= i__1; ++j) {
4964 if (upper) {
4965 ibeg = 1;
4966 iend = j;
4967 } else {
4968 ibeg = j;
4969 iend = *n;
4970 }
4971 i__2 = iend;
4972 for (i__ = ibeg; i__ <= i__2; ++i__) {
4973 ++ioff;
4974 i__3 = ioff;
4975 i__4 = i__ + j * a_dim1;
4976 aa[i__3].r = a[i__4].r, aa[i__3].i = a[i__4].i;
4977 if (i__ == j) {
4978 if (unit) {
4979 i__3 = ioff;
4980 aa[i__3].r = -1e10, aa[i__3].i = 1e10;
4981 }
4982 if (sym) {
4983 i__3 = ioff;
4984 i__4 = ioff;
4985 d__1 = aa[i__4].r;
4986 z__1.r = d__1, z__1.i = -1e10;
4987 aa[i__3].r = z__1.r, aa[i__3].i = z__1.i;
4988 }
4989 }
4990 /* L180: */
4991 }
4992 /* L190: */
4993 }
4994 }
4995 return 0;
4996
4997 /* End of ZMAKE. */
4998
4999 } /* zmake_ */
5000
zmvch_(char * trans,integer * m,integer * n,doublecomplex * alpha,doublecomplex * a,integer * nmax,doublecomplex * x,integer * incx,doublecomplex * beta,doublecomplex * y,integer * incy,doublecomplex * yt,doublereal * g,doublecomplex * yy,doublereal * eps,doublereal * err,logical * fatal,integer * nout,logical * mv,ftnlen trans_len)5001 /* Subroutine */ int zmvch_(char *trans, integer *m, integer *n,
5002 doublecomplex *alpha, doublecomplex *a, integer *nmax, doublecomplex *
5003 x, integer *incx, doublecomplex *beta, doublecomplex *y, integer *
5004 incy, doublecomplex *yt, doublereal *g, doublecomplex *yy, doublereal
5005 *eps, doublereal *err, logical *fatal, integer *nout, logical *mv,
5006 ftnlen trans_len)
5007 {
5008 /* Format strings */
5009 static char fmt_9999[] = "(\002 ******* FATAL ERROR - COMPUTED RESULT IS"
5010 " LESS THAN HAL\002,\002F ACCURATE *******\002,/\002 "
5011 " EXPECTED RE\002,\002SULT COMPUTED R"
5012 "ESULT\002)";
5013 static char fmt_9998[] = "(1x,i7,2(\002 (\002,g15.6,\002,\002,g15.6,"
5014 "\002)\002))";
5015
5016 /* System generated locals */
5017 integer a_dim1, a_offset, i__1, i__2, i__3, i__4, i__5, i__6;
5018 doublereal d__1, d__2, d__3, d__4, d__5, d__6;
5019 doublecomplex z__1, z__2, z__3;
5020
5021 /* Builtin functions */
5022 double d_imag(const doublecomplex *);
5023 void d_cnjg(doublecomplex *, const doublecomplex *);
5024 double z_abs(const doublecomplex *), sqrt(doublereal);
5025 integer s_wsfe(cilist *), e_wsfe(void), do_fio(integer *, char *, ftnlen);
5026
5027 /* Local variables */
5028 integer i__, j, ml, nl, iy, jx, kx, ky;
5029 doublereal erri;
5030 logical tran, ctran;
5031 integer incxl, incyl;
5032
5033 /* Fortran I/O blocks */
5034 static cilist io___430 = { 0, 0, 0, fmt_9999, 0 };
5035 static cilist io___431 = { 0, 0, 0, fmt_9998, 0 };
5036 static cilist io___432 = { 0, 0, 0, fmt_9998, 0 };
5037
5038
5039
5040 /* Checks the results of the computational tests. */
5041
5042 /* Auxiliary routine for test program for Level 2 Blas. */
5043
5044 /* -- Written on 10-August-1987. */
5045 /* Richard Hanson, Sandia National Labs. */
5046 /* Jeremy Du Croz, NAG Central Office. */
5047
5048 /* .. Parameters .. */
5049 /* .. Scalar Arguments .. */
5050 /* .. Array Arguments .. */
5051 /* .. Local Scalars .. */
5052 /* .. Intrinsic Functions .. */
5053 /* .. Statement Functions .. */
5054 /* .. Statement Function definitions .. */
5055 /* .. Executable Statements .. */
5056 /* Parameter adjustments */
5057 a_dim1 = *nmax;
5058 a_offset = 1 + a_dim1;
5059 a -= a_offset;
5060 --x;
5061 --y;
5062 --yt;
5063 --g;
5064 --yy;
5065
5066 /* Function Body */
5067 tran = *(unsigned char *)trans == 'T';
5068 ctran = *(unsigned char *)trans == 'C';
5069 if (tran || ctran) {
5070 ml = *n;
5071 nl = *m;
5072 } else {
5073 ml = *m;
5074 nl = *n;
5075 }
5076 if (*incx < 0) {
5077 kx = nl;
5078 incxl = -1;
5079 } else {
5080 kx = 1;
5081 incxl = 1;
5082 }
5083 if (*incy < 0) {
5084 ky = ml;
5085 incyl = -1;
5086 } else {
5087 ky = 1;
5088 incyl = 1;
5089 }
5090
5091 /* Compute expected result in YT using data in A, X and Y. */
5092 /* Compute gauges in G. */
5093
5094 iy = ky;
5095 i__1 = ml;
5096 for (i__ = 1; i__ <= i__1; ++i__) {
5097 i__2 = iy;
5098 yt[i__2].r = 0., yt[i__2].i = 0.;
5099 g[iy] = 0.;
5100 jx = kx;
5101 if (tran) {
5102 i__2 = nl;
5103 for (j = 1; j <= i__2; ++j) {
5104 i__3 = iy;
5105 i__4 = iy;
5106 i__5 = j + i__ * a_dim1;
5107 i__6 = jx;
5108 z__2.r = a[i__5].r * x[i__6].r - a[i__5].i * x[i__6].i,
5109 z__2.i = a[i__5].r * x[i__6].i + a[i__5].i * x[i__6]
5110 .r;
5111 z__1.r = yt[i__4].r + z__2.r, z__1.i = yt[i__4].i + z__2.i;
5112 yt[i__3].r = z__1.r, yt[i__3].i = z__1.i;
5113 i__3 = j + i__ * a_dim1;
5114 i__4 = jx;
5115 g[iy] += ((d__1 = a[i__3].r, abs(d__1)) + (d__2 = d_imag(&a[j
5116 + i__ * a_dim1]), abs(d__2))) * ((d__3 = x[i__4].r,
5117 abs(d__3)) + (d__4 = d_imag(&x[jx]), abs(d__4)));
5118 jx += incxl;
5119 /* L10: */
5120 }
5121 } else if (ctran) {
5122 i__2 = nl;
5123 for (j = 1; j <= i__2; ++j) {
5124 i__3 = iy;
5125 i__4 = iy;
5126 d_cnjg(&z__3, &a[j + i__ * a_dim1]);
5127 i__5 = jx;
5128 z__2.r = z__3.r * x[i__5].r - z__3.i * x[i__5].i, z__2.i =
5129 z__3.r * x[i__5].i + z__3.i * x[i__5].r;
5130 z__1.r = yt[i__4].r + z__2.r, z__1.i = yt[i__4].i + z__2.i;
5131 yt[i__3].r = z__1.r, yt[i__3].i = z__1.i;
5132 i__3 = j + i__ * a_dim1;
5133 i__4 = jx;
5134 g[iy] += ((d__1 = a[i__3].r, abs(d__1)) + (d__2 = d_imag(&a[j
5135 + i__ * a_dim1]), abs(d__2))) * ((d__3 = x[i__4].r,
5136 abs(d__3)) + (d__4 = d_imag(&x[jx]), abs(d__4)));
5137 jx += incxl;
5138 /* L20: */
5139 }
5140 } else {
5141 i__2 = nl;
5142 for (j = 1; j <= i__2; ++j) {
5143 i__3 = iy;
5144 i__4 = iy;
5145 i__5 = i__ + j * a_dim1;
5146 i__6 = jx;
5147 z__2.r = a[i__5].r * x[i__6].r - a[i__5].i * x[i__6].i,
5148 z__2.i = a[i__5].r * x[i__6].i + a[i__5].i * x[i__6]
5149 .r;
5150 z__1.r = yt[i__4].r + z__2.r, z__1.i = yt[i__4].i + z__2.i;
5151 yt[i__3].r = z__1.r, yt[i__3].i = z__1.i;
5152 i__3 = i__ + j * a_dim1;
5153 i__4 = jx;
5154 g[iy] += ((d__1 = a[i__3].r, abs(d__1)) + (d__2 = d_imag(&a[
5155 i__ + j * a_dim1]), abs(d__2))) * ((d__3 = x[i__4].r,
5156 abs(d__3)) + (d__4 = d_imag(&x[jx]), abs(d__4)));
5157 jx += incxl;
5158 /* L30: */
5159 }
5160 }
5161 i__2 = iy;
5162 i__3 = iy;
5163 z__2.r = alpha->r * yt[i__3].r - alpha->i * yt[i__3].i, z__2.i =
5164 alpha->r * yt[i__3].i + alpha->i * yt[i__3].r;
5165 i__4 = iy;
5166 z__3.r = beta->r * y[i__4].r - beta->i * y[i__4].i, z__3.i = beta->r *
5167 y[i__4].i + beta->i * y[i__4].r;
5168 z__1.r = z__2.r + z__3.r, z__1.i = z__2.i + z__3.i;
5169 yt[i__2].r = z__1.r, yt[i__2].i = z__1.i;
5170 i__2 = iy;
5171 g[iy] = ((d__1 = alpha->r, abs(d__1)) + (d__2 = d_imag(alpha), abs(
5172 d__2))) * g[iy] + ((d__3 = beta->r, abs(d__3)) + (d__4 =
5173 d_imag(beta), abs(d__4))) * ((d__5 = y[i__2].r, abs(d__5)) + (
5174 d__6 = d_imag(&y[iy]), abs(d__6)));
5175 iy += incyl;
5176 /* L40: */
5177 }
5178
5179 /* Compute the error ratio for this result. */
5180
5181 *err = 0.;
5182 i__1 = ml;
5183 for (i__ = 1; i__ <= i__1; ++i__) {
5184 i__2 = i__;
5185 i__3 = (i__ - 1) * abs(*incy) + 1;
5186 z__1.r = yt[i__2].r - yy[i__3].r, z__1.i = yt[i__2].i - yy[i__3].i;
5187 erri = z_abs(&z__1) / *eps;
5188 if (g[i__] != 0.) {
5189 erri /= g[i__];
5190 }
5191 *err = max(*err,erri);
5192 if (*err * sqrt(*eps) >= 1.) {
5193 goto L60;
5194 }
5195 /* L50: */
5196 }
5197 /* If the loop completes, all results are at least half accurate. */
5198 goto L80;
5199
5200 /* Report fatal error. */
5201
5202 L60:
5203 *fatal = TRUE_;
5204 io___430.ciunit = *nout;
5205 s_wsfe(&io___430);
5206 e_wsfe();
5207 i__1 = ml;
5208 for (i__ = 1; i__ <= i__1; ++i__) {
5209 if (*mv) {
5210 io___431.ciunit = *nout;
5211 s_wsfe(&io___431);
5212 do_fio(&c__1, (char *)&i__, (ftnlen)sizeof(integer));
5213 do_fio(&c__2, (char *)&yt[i__], (ftnlen)sizeof(doublereal));
5214 do_fio(&c__2, (char *)&yy[(i__ - 1) * abs(*incy) + 1], (ftnlen)
5215 sizeof(doublereal));
5216 e_wsfe();
5217 } else {
5218 io___432.ciunit = *nout;
5219 s_wsfe(&io___432);
5220 do_fio(&c__1, (char *)&i__, (ftnlen)sizeof(integer));
5221 do_fio(&c__2, (char *)&yy[(i__ - 1) * abs(*incy) + 1], (ftnlen)
5222 sizeof(doublereal));
5223 do_fio(&c__2, (char *)&yt[i__], (ftnlen)sizeof(doublereal));
5224 e_wsfe();
5225 }
5226 /* L70: */
5227 }
5228
5229 L80:
5230 return 0;
5231
5232
5233 /* End of ZMVCH. */
5234
5235 } /* zmvch_ */
5236
lze_(doublecomplex * ri,doublecomplex * rj,integer * lr)5237 logical lze_(doublecomplex *ri, doublecomplex *rj, integer *lr)
5238 {
5239 /* System generated locals */
5240 integer i__1, i__2, i__3;
5241 logical ret_val;
5242
5243 /* Local variables */
5244 integer i__;
5245
5246
5247 /* Tests if two arrays are identical. */
5248
5249 /* Auxiliary routine for test program for Level 2 Blas. */
5250
5251 /* -- Written on 10-August-1987. */
5252 /* Richard Hanson, Sandia National Labs. */
5253 /* Jeremy Du Croz, NAG Central Office. */
5254
5255 /* .. Scalar Arguments .. */
5256 /* .. Array Arguments .. */
5257 /* .. Local Scalars .. */
5258 /* .. Executable Statements .. */
5259 /* Parameter adjustments */
5260 --rj;
5261 --ri;
5262
5263 /* Function Body */
5264 i__1 = *lr;
5265 for (i__ = 1; i__ <= i__1; ++i__) {
5266 i__2 = i__;
5267 i__3 = i__;
5268 if (ri[i__2].r != rj[i__3].r || ri[i__2].i != rj[i__3].i) {
5269 goto L20;
5270 }
5271 /* L10: */
5272 }
5273 ret_val = TRUE_;
5274 goto L30;
5275 L20:
5276 ret_val = FALSE_;
5277 L30:
5278 return ret_val;
5279
5280 /* End of LZE. */
5281
5282 } /* lze_ */
5283
lzeres_(char * type__,char * uplo,integer * m,integer * n,doublecomplex * aa,doublecomplex * as,integer * lda,ftnlen type_len,ftnlen uplo_len)5284 logical lzeres_(char *type__, char *uplo, integer *m, integer *n,
5285 doublecomplex *aa, doublecomplex *as, integer *lda, ftnlen type_len,
5286 ftnlen uplo_len)
5287 {
5288 /* System generated locals */
5289 integer aa_dim1, aa_offset, as_dim1, as_offset, i__1, i__2, i__3, i__4;
5290 logical ret_val;
5291
5292 /* Builtin functions */
5293 integer s_cmp(const char *, const char *, ftnlen, ftnlen);
5294
5295 /* Local variables */
5296 integer i__, j, ibeg, iend;
5297 logical upper;
5298
5299
5300 /* Tests if selected elements in two arrays are equal. */
5301
5302 /* TYPE is 'GE', 'HE' or 'HP'. */
5303
5304 /* Auxiliary routine for test program for Level 2 Blas. */
5305
5306 /* -- Written on 10-August-1987. */
5307 /* Richard Hanson, Sandia National Labs. */
5308 /* Jeremy Du Croz, NAG Central Office. */
5309
5310 /* .. Scalar Arguments .. */
5311 /* .. Array Arguments .. */
5312 /* .. Local Scalars .. */
5313 /* .. Executable Statements .. */
5314 /* Parameter adjustments */
5315 as_dim1 = *lda;
5316 as_offset = 1 + as_dim1;
5317 as -= as_offset;
5318 aa_dim1 = *lda;
5319 aa_offset = 1 + aa_dim1;
5320 aa -= aa_offset;
5321
5322 /* Function Body */
5323 upper = *(unsigned char *)uplo == 'U';
5324 if (s_cmp(type__, "GE", (ftnlen)2, (ftnlen)2) == 0) {
5325 i__1 = *n;
5326 for (j = 1; j <= i__1; ++j) {
5327 i__2 = *lda;
5328 for (i__ = *m + 1; i__ <= i__2; ++i__) {
5329 i__3 = i__ + j * aa_dim1;
5330 i__4 = i__ + j * as_dim1;
5331 if (aa[i__3].r != as[i__4].r || aa[i__3].i != as[i__4].i) {
5332 goto L70;
5333 }
5334 /* L10: */
5335 }
5336 /* L20: */
5337 }
5338 } else if (s_cmp(type__, "HE", (ftnlen)2, (ftnlen)2) == 0) {
5339 i__1 = *n;
5340 for (j = 1; j <= i__1; ++j) {
5341 if (upper) {
5342 ibeg = 1;
5343 iend = j;
5344 } else {
5345 ibeg = j;
5346 iend = *n;
5347 }
5348 i__2 = ibeg - 1;
5349 for (i__ = 1; i__ <= i__2; ++i__) {
5350 i__3 = i__ + j * aa_dim1;
5351 i__4 = i__ + j * as_dim1;
5352 if (aa[i__3].r != as[i__4].r || aa[i__3].i != as[i__4].i) {
5353 goto L70;
5354 }
5355 /* L30: */
5356 }
5357 i__2 = *lda;
5358 for (i__ = iend + 1; i__ <= i__2; ++i__) {
5359 i__3 = i__ + j * aa_dim1;
5360 i__4 = i__ + j * as_dim1;
5361 if (aa[i__3].r != as[i__4].r || aa[i__3].i != as[i__4].i) {
5362 goto L70;
5363 }
5364 /* L40: */
5365 }
5366 /* L50: */
5367 }
5368 }
5369
5370 ret_val = TRUE_;
5371 goto L80;
5372 L70:
5373 ret_val = FALSE_;
5374 L80:
5375 return ret_val;
5376
5377 /* End of LZERES. */
5378
5379 } /* lzeres_ */
5380
zbeg_(doublecomplex * ret_val,logical * reset)5381 /* Double Complex */ void zbeg_(doublecomplex * ret_val, logical *reset)
5382 {
5383 /* System generated locals */
5384 doublereal d__1, d__2;
5385 doublecomplex z__1;
5386
5387 /* Local variables */
5388 static integer i__, j, ic, mi, mj;
5389
5390
5391 /* Generates complex numbers as pairs of random numbers uniformly */
5392 /* distributed between -0.5 and 0.5. */
5393
5394 /* Auxiliary routine for test program for Level 2 Blas. */
5395
5396 /* -- Written on 10-August-1987. */
5397 /* Richard Hanson, Sandia National Labs. */
5398 /* Jeremy Du Croz, NAG Central Office. */
5399
5400 /* .. Scalar Arguments .. */
5401 /* .. Local Scalars .. */
5402 /* .. Save statement .. */
5403 /* .. Intrinsic Functions .. */
5404 /* .. Executable Statements .. */
5405 if (*reset) {
5406 /* Initialize local variables. */
5407 mi = 891;
5408 mj = 457;
5409 i__ = 7;
5410 j = 7;
5411 ic = 0;
5412 *reset = FALSE_;
5413 }
5414
5415 /* The sequence of values of I or J is bounded between 1 and 999. */
5416 /* If initial I or J = 1,2,3,6,7 or 9, the period will be 50. */
5417 /* If initial I or J = 4 or 8, the period will be 25. */
5418 /* If initial I or J = 5, the period will be 10. */
5419 /* IC is used to break up the period by skipping 1 value of I or J */
5420 /* in 6. */
5421
5422 ++ic;
5423 L10:
5424 i__ *= mi;
5425 j *= mj;
5426 i__ -= i__ / 1000 * 1000;
5427 j -= j / 1000 * 1000;
5428 if (ic >= 5) {
5429 ic = 0;
5430 goto L10;
5431 }
5432 d__1 = (i__ - 500) / 1001.;
5433 d__2 = (j - 500) / 1001.;
5434 z__1.r = d__1, z__1.i = d__2;
5435 ret_val->r = z__1.r, ret_val->i = z__1.i;
5436 return ;
5437
5438 /* End of ZBEG. */
5439
5440 } /* zbeg_ */
5441
ddiff_(doublereal * x,doublereal * y)5442 doublereal ddiff_(doublereal *x, doublereal *y)
5443 {
5444 /* System generated locals */
5445 doublereal ret_val;
5446
5447
5448 /* Auxiliary routine for test program for Level 2 Blas. */
5449
5450 /* -- Written on 10-August-1987. */
5451 /* Richard Hanson, Sandia National Labs. */
5452
5453 /* .. Scalar Arguments .. */
5454 /* .. Executable Statements .. */
5455 ret_val = *x - *y;
5456 return ret_val;
5457
5458 /* End of DDIFF. */
5459
5460 } /* ddiff_ */
5461
chkxer_(char * srnamt,integer * infot,integer * nout,logical * lerr,logical * ok,ftnlen srnamt_len)5462 /* Subroutine */ int chkxer_(char *srnamt, integer *infot, integer *nout,
5463 logical *lerr, logical *ok, ftnlen srnamt_len)
5464 {
5465 /* Format strings */
5466 static char fmt_9999[] = "(\002 ***** ILLEGAL VALUE OF PARAMETER NUMBER"
5467 " \002,i2,\002 NOT D\002,\002ETECTED BY \002,a6,\002 *****\002)";
5468
5469 /* Builtin functions */
5470 integer s_wsfe(cilist *), do_fio(integer *, char *, ftnlen), e_wsfe(void);
5471
5472 /* Fortran I/O blocks */
5473 static cilist io___444 = { 0, 0, 0, fmt_9999, 0 };
5474
5475
5476
5477 /* Tests whether XERBLA has detected an error when it should. */
5478
5479 /* Auxiliary routine for test program for Level 2 Blas. */
5480
5481 /* -- Written on 10-August-1987. */
5482 /* Richard Hanson, Sandia National Labs. */
5483 /* Jeremy Du Croz, NAG Central Office. */
5484
5485 /* .. Scalar Arguments .. */
5486 /* .. Executable Statements .. */
5487 if (! (*lerr)) {
5488 io___444.ciunit = *nout;
5489 s_wsfe(&io___444);
5490 do_fio(&c__1, (char *)&(*infot), (ftnlen)sizeof(integer));
5491 do_fio(&c__1, srnamt, (ftnlen)6);
5492 e_wsfe();
5493 *ok = FALSE_;
5494 }
5495 *lerr = FALSE_;
5496 return 0;
5497
5498
5499 /* End of CHKXER. */
5500
5501 } /* chkxer_ */
5502
xerbla_(char * srname,integer * info,ftnlen srname_len)5503 /* Subroutine */ int xerbla_(char *srname, integer *info, ftnlen srname_len)
5504 {
5505 /* Format strings */
5506 static char fmt_9999[] = "(\002 ******* XERBLA WAS CALLED WITH INFO ="
5507 " \002,i6,\002 INSTEAD\002,\002 OF \002,i2,\002 *******\002)";
5508 static char fmt_9997[] = "(\002 ******* XERBLA WAS CALLED WITH INFO ="
5509 " \002,i6,\002 *******\002)";
5510 static char fmt_9998[] = "(\002 ******* XERBLA WAS CALLED WITH SRNAME ="
5511 " \002,a6,\002 INSTE\002,\002AD OF \002,a6,\002 *******\002)";
5512
5513 /* Builtin functions */
5514 integer s_wsfe(cilist *), do_fio(integer *, char *, ftnlen), e_wsfe(void),
5515 s_cmp(const char *, const char *, ftnlen, ftnlen);
5516
5517 /* Fortran I/O blocks */
5518 static cilist io___445 = { 0, 0, 0, fmt_9999, 0 };
5519 static cilist io___446 = { 0, 0, 0, fmt_9997, 0 };
5520 static cilist io___447 = { 0, 0, 0, fmt_9998, 0 };
5521
5522
5523
5524 /* This is a special version of XERBLA to be used only as part of */
5525 /* the test program for testing error exits from the Level 2 BLAS */
5526 /* routines. */
5527
5528 /* XERBLA is an error handler for the Level 2 BLAS routines. */
5529
5530 /* It is called by the Level 2 BLAS routines if an input parameter is */
5531 /* invalid. */
5532
5533 /* Auxiliary routine for test program for Level 2 Blas. */
5534
5535 /* -- Written on 10-August-1987. */
5536 /* Richard Hanson, Sandia National Labs. */
5537 /* Jeremy Du Croz, NAG Central Office. */
5538
5539 /* .. Scalar Arguments .. */
5540 /* .. Scalars in Common .. */
5541 /* .. Common blocks .. */
5542 /* .. Executable Statements .. */
5543 infoc_2.lerr = TRUE_;
5544 if (*info != infoc_2.infot) {
5545 if (infoc_2.infot != 0) {
5546 io___445.ciunit = infoc_2.nout;
5547 s_wsfe(&io___445);
5548 do_fio(&c__1, (char *)&(*info), (ftnlen)sizeof(integer));
5549 do_fio(&c__1, (char *)&infoc_2.infot, (ftnlen)sizeof(integer));
5550 e_wsfe();
5551 } else {
5552 io___446.ciunit = infoc_2.nout;
5553 s_wsfe(&io___446);
5554 do_fio(&c__1, (char *)&(*info), (ftnlen)sizeof(integer));
5555 e_wsfe();
5556 }
5557 infoc_2.ok = FALSE_;
5558 }
5559 if (s_cmp(srname, srnamc_1.srnamt, (ftnlen)6, (ftnlen)6) != 0) {
5560 io___447.ciunit = infoc_2.nout;
5561 s_wsfe(&io___447);
5562 do_fio(&c__1, srname, (ftnlen)6);
5563 do_fio(&c__1, srnamc_1.srnamt, (ftnlen)6);
5564 e_wsfe();
5565 infoc_2.ok = FALSE_;
5566 }
5567 return 0;
5568
5569
5570 /* End of XERBLA */
5571
5572 } /* xerbla_ */
5573
zblat2_()5574 /* Main program alias */ int zblat2_ () { main (); return 0; }
5575