00001
00002
00003
00004
00005
00006
00007
00008
00009
00010
00011
00012
00013 #include "f2c.h"
00014 #include "blaswrap.h"
00015
00016
00017
00018 union {
00019 struct {
00020 integer infot, noutc;
00021 logical ok, lerr;
00022 } _1;
00023 struct {
00024 integer infot, nout;
00025 logical ok, lerr;
00026 } _2;
00027 } infoc_;
00028
00029 #define infoc_1 (infoc_._1)
00030 #define infoc_2 (infoc_._2)
00031
00032 struct {
00033 char srnamt[6];
00034 } srnamc_;
00035
00036 #define srnamc_1 srnamc_
00037
00038
00039
00040 static doublecomplex c_b1 = {0.,0.};
00041 static doublecomplex c_b2 = {1.,0.};
00042 static integer c__9 = 9;
00043 static integer c__1 = 1;
00044 static integer c__3 = 3;
00045 static integer c__8 = 8;
00046 static integer c__5 = 5;
00047 static integer c__65 = 65;
00048 static integer c__7 = 7;
00049 static integer c__2 = 2;
00050 static doublereal c_b123 = 1.;
00051 static logical c_true = TRUE_;
00052 static integer c_n1 = -1;
00053 static integer c__0 = 0;
00054 static logical c_false = FALSE_;
00055
00056 int MAIN__(void)
00057 {
00058
00059
00060 static char snames[6*17] = "ZGEMV " "ZGBMV " "ZHEMV " "ZHBMV " "ZHPMV "
00061 "ZTRMV " "ZTBMV " "ZTPMV " "ZTRSV " "ZTBSV " "ZTPSV " "ZGERC "
00062 "ZGERU " "ZHER " "ZHPR " "ZHER2 " "ZHPR2 ";
00063
00064
00065 static char fmt_9997[] = "(\002 NUMBER OF VALUES OF \002,a,\002 IS LESS "
00066 "THAN 1 OR GREATER \002,\002THAN \002,i2)";
00067 static char fmt_9996[] = "(\002 VALUE OF N IS LESS THAN 0 OR GREATER THA"
00068 "N \002,i2)";
00069 static char fmt_9995[] = "(\002 VALUE OF K IS LESS THAN 0\002)";
00070 static char fmt_9994[] = "(\002 ABSOLUTE VALUE OF INCX OR INCY IS 0 OR G"
00071 "REATER THAN \002,i2)";
00072 static char fmt_9993[] = "(\002 TESTS OF THE COMPLEX*16 LEVEL 2 BL"
00073 "AS\002,//\002 THE F\002,\002OLLOWING PARAMETER VALUES WILL BE US"
00074 "ED:\002)";
00075 static char fmt_9992[] = "(\002 FOR N \002,9i6)";
00076 static char fmt_9991[] = "(\002 FOR K \002,7i6)";
00077 static char fmt_9990[] = "(\002 FOR INCX AND INCY \002,7i6)";
00078 static char fmt_9989[] = "(\002 FOR ALPHA \002,7(\002(\002,f4"
00079 ".1,\002,\002,f4.1,\002) \002,:))";
00080 static char fmt_9988[] = "(\002 FOR BETA \002,7(\002(\002,f4"
00081 ".1,\002,\002,f4.1,\002) \002,:))";
00082 static char fmt_9980[] = "(\002 ERROR-EXITS WILL NOT BE TESTED\002)";
00083 static char fmt_9999[] = "(\002 ROUTINES PASS COMPUTATIONAL TESTS IF TES"
00084 "T RATIO IS LES\002,\002S THAN\002,f8.2)";
00085 static char fmt_9984[] = "(a6,l2)";
00086 static char fmt_9986[] = "(\002 SUBPROGRAM NAME \002,a6,\002 NOT RECOGNI"
00087 "ZED\002,/\002 ******* T\002,\002ESTS ABANDONED *******\002)";
00088 static char fmt_9998[] = "(\002 RELATIVE MACHINE PRECISION IS TAKEN TO"
00089 " BE\002,1p,d9.1)";
00090 static char fmt_9985[] = "(\002 ERROR IN ZMVCH - IN-LINE DOT PRODUCTS A"
00091 "RE BEING EVALU\002,\002ATED WRONGLY.\002,/\002 ZMVCH WAS CALLED "
00092 "WITH TRANS = \002,a1,\002 AND RETURNED SAME = \002,l1,\002 AND E"
00093 "RR = \002,f12.3,\002.\002,/\002 THIS MAY BE DUE TO FAULTS IN THE"
00094 " ARITHMETIC OR THE COMPILER.\002,/\002 ******* TESTS ABANDONED *"
00095 "******\002)";
00096 static char fmt_9983[] = "(1x,a6,\002 WAS NOT TESTED\002)";
00097 static char fmt_9982[] = "(/\002 END OF TESTS\002)";
00098 static char fmt_9981[] = "(/\002 ******* FATAL ERROR - TESTS ABANDONED *"
00099 "******\002)";
00100 static char fmt_9987[] = "(\002 AMEND DATA FILE OR INCREASE ARRAY SIZES "
00101 "IN PROGRAM\002,/\002 ******* TESTS ABANDONED *******\002)";
00102
00103
00104 integer i__1, i__2, i__3, i__4, i__5;
00105 doublereal d__1;
00106 olist o__1;
00107 cllist cl__1;
00108
00109
00110 integer s_rsle(cilist *), do_lio(integer *, integer *, char *, ftnlen),
00111 e_rsle(void), f_open(olist *), s_wsfe(cilist *), do_fio(integer *,
00112 char *, ftnlen), e_wsfe(void), s_wsle(cilist *), e_wsle(void),
00113 s_rsfe(cilist *), e_rsfe(void), s_cmp(char *, char *, ftnlen,
00114 ftnlen);
00115 int s_stop(char *, ftnlen);
00116 integer f_clos(cllist *);
00117 int s_copy(char *, char *, ftnlen, ftnlen);
00118
00119
00120 doublecomplex a[4225] ;
00121 doublereal g[65];
00122 integer i__, j, n;
00123 doublecomplex x[65], y[65], z__[130], aa[4225];
00124 integer kb[7];
00125 doublecomplex as[4225], xs[130], ys[130], yt[65], xx[130], yy[130], alf[7]
00126 ;
00127 integer inc[7], nkb;
00128 doublecomplex bet[7];
00129 doublereal eps, err;
00130 extern logical lze_(doublecomplex *, doublecomplex *, integer *);
00131 integer nalf, idim[9];
00132 logical same;
00133 integer ninc, nbet, ntra;
00134 logical rewi;
00135 integer nout;
00136 extern int zchk1_(char *, doublereal *, doublereal *,
00137 integer *, integer *, logical *, logical *, logical *, integer *,
00138 integer *, integer *, integer *, integer *, doublecomplex *,
00139 integer *, doublecomplex *, integer *, integer *, integer *,
00140 integer *, doublecomplex *, doublecomplex *, doublecomplex *,
00141 doublecomplex *, doublecomplex *, doublecomplex *, doublecomplex *
00142 , doublecomplex *, doublecomplex *, doublecomplex *, doublereal *,
00143 ftnlen), zchk2_(char *, doublereal *, doublereal *, integer *,
00144 integer *, logical *, logical *, logical *, integer *, integer *,
00145 integer *, integer *, integer *, doublecomplex *, integer *,
00146 doublecomplex *, integer *, integer *, integer *, integer *,
00147 doublecomplex *, doublecomplex *, doublecomplex *, doublecomplex *
00148 , doublecomplex *, doublecomplex *, doublecomplex *,
00149 doublecomplex *, doublecomplex *, doublecomplex *, doublereal *,
00150 ftnlen), zchk3_(char *, doublereal *, doublereal *, integer *,
00151 integer *, logical *, logical *, logical *, integer *, integer *,
00152 integer *, integer *, integer *, integer *, integer *, integer *,
00153 doublecomplex *, doublecomplex *, doublecomplex *, doublecomplex *
00154 , doublecomplex *, doublecomplex *, doublecomplex *, doublereal *,
00155 doublecomplex *, ftnlen), zchk4_(char *, doublereal *,
00156 doublereal *, integer *, integer *, logical *, logical *, logical
00157 *, integer *, integer *, integer *, doublecomplex *, integer *,
00158 integer *, integer *, integer *, doublecomplex *, doublecomplex *,
00159 doublecomplex *, doublecomplex *, doublecomplex *, doublecomplex
00160 *, doublecomplex *, doublecomplex *, doublecomplex *,
00161 doublecomplex *, doublereal *, doublecomplex *, ftnlen), zchk5_(
00162 char *, doublereal *, doublereal *, integer *, integer *, logical
00163 *, logical *, logical *, integer *, integer *, integer *,
00164 doublecomplex *, integer *, integer *, integer *, integer *,
00165 doublecomplex *, doublecomplex *, doublecomplex *, doublecomplex *
00166 , doublecomplex *, doublecomplex *, doublecomplex *,
00167 doublecomplex *, doublecomplex *, doublecomplex *, doublereal *,
00168 doublecomplex *, ftnlen), zchk6_(char *, doublereal *, doublereal
00169 *, integer *, integer *, logical *, logical *, logical *, integer
00170 *, integer *, integer *, doublecomplex *, integer *, integer *,
00171 integer *, integer *, doublecomplex *, doublecomplex *,
00172 doublecomplex *, doublecomplex *, doublecomplex *, doublecomplex *
00173 , doublecomplex *, doublecomplex *, doublecomplex *,
00174 doublecomplex *, doublereal *, doublecomplex *, ftnlen);
00175 extern doublereal ddiff_(doublereal *, doublereal *);
00176 logical fatal, trace;
00177 integer nidim;
00178 extern int zchke_(integer *, char *, integer *, ftnlen);
00179 char snaps[32], trans[1];
00180 extern int zmvch_(char *, integer *, integer *,
00181 doublecomplex *, doublecomplex *, integer *, doublecomplex *,
00182 integer *, doublecomplex *, doublecomplex *, integer *,
00183 doublecomplex *, doublereal *, doublecomplex *, doublereal *,
00184 doublereal *, logical *, integer *, logical *, ftnlen);
00185 integer isnum;
00186 logical ltest[17], sfatal;
00187 char snamet[6];
00188 doublereal thresh;
00189 logical ltestt, tsterr;
00190 char summry[32];
00191
00192
00193 static cilist io___2 = { 0, 5, 0, 0, 0 };
00194 static cilist io___4 = { 0, 5, 0, 0, 0 };
00195 static cilist io___6 = { 0, 5, 0, 0, 0 };
00196 static cilist io___8 = { 0, 5, 0, 0, 0 };
00197 static cilist io___11 = { 0, 5, 0, 0, 0 };
00198 static cilist io___13 = { 0, 5, 0, 0, 0 };
00199 static cilist io___15 = { 0, 5, 0, 0, 0 };
00200 static cilist io___17 = { 0, 5, 0, 0, 0 };
00201 static cilist io___19 = { 0, 5, 0, 0, 0 };
00202 static cilist io___21 = { 0, 0, 0, fmt_9997, 0 };
00203 static cilist io___22 = { 0, 5, 0, 0, 0 };
00204 static cilist io___25 = { 0, 0, 0, fmt_9996, 0 };
00205 static cilist io___26 = { 0, 5, 0, 0, 0 };
00206 static cilist io___28 = { 0, 0, 0, fmt_9997, 0 };
00207 static cilist io___29 = { 0, 5, 0, 0, 0 };
00208 static cilist io___31 = { 0, 0, 0, fmt_9995, 0 };
00209 static cilist io___32 = { 0, 5, 0, 0, 0 };
00210 static cilist io___34 = { 0, 0, 0, fmt_9997, 0 };
00211 static cilist io___35 = { 0, 5, 0, 0, 0 };
00212 static cilist io___37 = { 0, 0, 0, fmt_9994, 0 };
00213 static cilist io___38 = { 0, 5, 0, 0, 0 };
00214 static cilist io___40 = { 0, 0, 0, fmt_9997, 0 };
00215 static cilist io___41 = { 0, 5, 0, 0, 0 };
00216 static cilist io___43 = { 0, 5, 0, 0, 0 };
00217 static cilist io___45 = { 0, 0, 0, fmt_9997, 0 };
00218 static cilist io___46 = { 0, 5, 0, 0, 0 };
00219 static cilist io___48 = { 0, 0, 0, fmt_9993, 0 };
00220 static cilist io___49 = { 0, 0, 0, fmt_9992, 0 };
00221 static cilist io___50 = { 0, 0, 0, fmt_9991, 0 };
00222 static cilist io___51 = { 0, 0, 0, fmt_9990, 0 };
00223 static cilist io___52 = { 0, 0, 0, fmt_9989, 0 };
00224 static cilist io___53 = { 0, 0, 0, fmt_9988, 0 };
00225 static cilist io___54 = { 0, 0, 0, 0, 0 };
00226 static cilist io___55 = { 0, 0, 0, fmt_9980, 0 };
00227 static cilist io___56 = { 0, 0, 0, 0, 0 };
00228 static cilist io___57 = { 0, 0, 0, fmt_9999, 0 };
00229 static cilist io___58 = { 0, 0, 0, 0, 0 };
00230 static cilist io___60 = { 0, 5, 1, fmt_9984, 0 };
00231 static cilist io___63 = { 0, 0, 0, fmt_9986, 0 };
00232 static cilist io___65 = { 0, 0, 0, fmt_9998, 0 };
00233 static cilist io___78 = { 0, 0, 0, fmt_9985, 0 };
00234 static cilist io___79 = { 0, 0, 0, fmt_9985, 0 };
00235 static cilist io___81 = { 0, 0, 0, 0, 0 };
00236 static cilist io___82 = { 0, 0, 0, fmt_9983, 0 };
00237 static cilist io___83 = { 0, 0, 0, 0, 0 };
00238 static cilist io___90 = { 0, 0, 0, fmt_9982, 0 };
00239 static cilist io___91 = { 0, 0, 0, fmt_9981, 0 };
00240 static cilist io___92 = { 0, 0, 0, fmt_9987, 0 };
00241
00242
00243
00244
00245
00246
00247
00248
00249
00250
00251
00252
00253
00254
00255
00256
00257
00258
00259
00260
00261
00262
00263
00264
00265
00266
00267
00268
00269
00270
00271
00272
00273
00274
00275
00276
00277
00278
00279
00280
00281
00282
00283
00284
00285
00286
00287
00288
00289
00290
00291
00292
00293
00294
00295
00296
00297
00298
00299
00300
00301
00302
00303
00304
00305
00306
00307
00308
00309
00310
00311
00312
00313
00314
00315
00316
00317
00318
00319
00320
00321
00322
00323
00324
00325 s_rsle(&io___2);
00326 do_lio(&c__9, &c__1, summry, (ftnlen)32);
00327 e_rsle();
00328 s_rsle(&io___4);
00329 do_lio(&c__3, &c__1, (char *)&nout, (ftnlen)sizeof(integer));
00330 e_rsle();
00331 o__1.oerr = 0;
00332 o__1.ounit = nout;
00333 o__1.ofnmlen = 32;
00334 o__1.ofnm = summry;
00335 o__1.orl = 0;
00336 o__1.osta = "UNKNOWN";
00337 o__1.oacc = 0;
00338 o__1.ofm = 0;
00339 o__1.oblnk = 0;
00340 f_open(&o__1);
00341 infoc_1.noutc = nout;
00342
00343
00344
00345 s_rsle(&io___6);
00346 do_lio(&c__9, &c__1, snaps, (ftnlen)32);
00347 e_rsle();
00348 s_rsle(&io___8);
00349 do_lio(&c__3, &c__1, (char *)&ntra, (ftnlen)sizeof(integer));
00350 e_rsle();
00351 trace = ntra >= 0;
00352 if (trace) {
00353 o__1.oerr = 0;
00354 o__1.ounit = ntra;
00355 o__1.ofnmlen = 32;
00356 o__1.ofnm = snaps;
00357 o__1.orl = 0;
00358 o__1.osta = "UNKNOWN";
00359 o__1.oacc = 0;
00360 o__1.ofm = 0;
00361 o__1.oblnk = 0;
00362 f_open(&o__1);
00363 }
00364
00365 s_rsle(&io___11);
00366 do_lio(&c__8, &c__1, (char *)&rewi, (ftnlen)sizeof(logical));
00367 e_rsle();
00368 rewi = rewi && trace;
00369
00370 s_rsle(&io___13);
00371 do_lio(&c__8, &c__1, (char *)&sfatal, (ftnlen)sizeof(logical));
00372 e_rsle();
00373
00374 s_rsle(&io___15);
00375 do_lio(&c__8, &c__1, (char *)&tsterr, (ftnlen)sizeof(logical));
00376 e_rsle();
00377
00378 s_rsle(&io___17);
00379 do_lio(&c__5, &c__1, (char *)&thresh, (ftnlen)sizeof(doublereal));
00380 e_rsle();
00381
00382
00383
00384
00385 s_rsle(&io___19);
00386 do_lio(&c__3, &c__1, (char *)&nidim, (ftnlen)sizeof(integer));
00387 e_rsle();
00388 if (nidim < 1 || nidim > 9) {
00389 io___21.ciunit = nout;
00390 s_wsfe(&io___21);
00391 do_fio(&c__1, "N", (ftnlen)1);
00392 do_fio(&c__1, (char *)&c__9, (ftnlen)sizeof(integer));
00393 e_wsfe();
00394 goto L230;
00395 }
00396 s_rsle(&io___22);
00397 i__1 = nidim;
00398 for (i__ = 1; i__ <= i__1; ++i__) {
00399 do_lio(&c__3, &c__1, (char *)&idim[i__ - 1], (ftnlen)sizeof(integer));
00400 }
00401 e_rsle();
00402 i__1 = nidim;
00403 for (i__ = 1; i__ <= i__1; ++i__) {
00404 if (idim[i__ - 1] < 0 || idim[i__ - 1] > 65) {
00405 io___25.ciunit = nout;
00406 s_wsfe(&io___25);
00407 do_fio(&c__1, (char *)&c__65, (ftnlen)sizeof(integer));
00408 e_wsfe();
00409 goto L230;
00410 }
00411
00412 }
00413
00414 s_rsle(&io___26);
00415 do_lio(&c__3, &c__1, (char *)&nkb, (ftnlen)sizeof(integer));
00416 e_rsle();
00417 if (nkb < 1 || nkb > 7) {
00418 io___28.ciunit = nout;
00419 s_wsfe(&io___28);
00420 do_fio(&c__1, "K", (ftnlen)1);
00421 do_fio(&c__1, (char *)&c__7, (ftnlen)sizeof(integer));
00422 e_wsfe();
00423 goto L230;
00424 }
00425 s_rsle(&io___29);
00426 i__1 = nkb;
00427 for (i__ = 1; i__ <= i__1; ++i__) {
00428 do_lio(&c__3, &c__1, (char *)&kb[i__ - 1], (ftnlen)sizeof(integer));
00429 }
00430 e_rsle();
00431 i__1 = nkb;
00432 for (i__ = 1; i__ <= i__1; ++i__) {
00433 if (kb[i__ - 1] < 0) {
00434 io___31.ciunit = nout;
00435 s_wsfe(&io___31);
00436 e_wsfe();
00437 goto L230;
00438 }
00439
00440 }
00441
00442 s_rsle(&io___32);
00443 do_lio(&c__3, &c__1, (char *)&ninc, (ftnlen)sizeof(integer));
00444 e_rsle();
00445 if (ninc < 1 || ninc > 7) {
00446 io___34.ciunit = nout;
00447 s_wsfe(&io___34);
00448 do_fio(&c__1, "INCX AND INCY", (ftnlen)13);
00449 do_fio(&c__1, (char *)&c__7, (ftnlen)sizeof(integer));
00450 e_wsfe();
00451 goto L230;
00452 }
00453 s_rsle(&io___35);
00454 i__1 = ninc;
00455 for (i__ = 1; i__ <= i__1; ++i__) {
00456 do_lio(&c__3, &c__1, (char *)&inc[i__ - 1], (ftnlen)sizeof(integer));
00457 }
00458 e_rsle();
00459 i__1 = ninc;
00460 for (i__ = 1; i__ <= i__1; ++i__) {
00461 if (inc[i__ - 1] == 0 || (i__2 = inc[i__ - 1], abs(i__2)) > 2) {
00462 io___37.ciunit = nout;
00463 s_wsfe(&io___37);
00464 do_fio(&c__1, (char *)&c__2, (ftnlen)sizeof(integer));
00465 e_wsfe();
00466 goto L230;
00467 }
00468
00469 }
00470
00471 s_rsle(&io___38);
00472 do_lio(&c__3, &c__1, (char *)&nalf, (ftnlen)sizeof(integer));
00473 e_rsle();
00474 if (nalf < 1 || nalf > 7) {
00475 io___40.ciunit = nout;
00476 s_wsfe(&io___40);
00477 do_fio(&c__1, "ALPHA", (ftnlen)5);
00478 do_fio(&c__1, (char *)&c__7, (ftnlen)sizeof(integer));
00479 e_wsfe();
00480 goto L230;
00481 }
00482 s_rsle(&io___41);
00483 i__1 = nalf;
00484 for (i__ = 1; i__ <= i__1; ++i__) {
00485 do_lio(&c__7, &c__1, (char *)&alf[i__ - 1], (ftnlen)sizeof(
00486 doublecomplex));
00487 }
00488 e_rsle();
00489
00490 s_rsle(&io___43);
00491 do_lio(&c__3, &c__1, (char *)&nbet, (ftnlen)sizeof(integer));
00492 e_rsle();
00493 if (nbet < 1 || nbet > 7) {
00494 io___45.ciunit = nout;
00495 s_wsfe(&io___45);
00496 do_fio(&c__1, "BETA", (ftnlen)4);
00497 do_fio(&c__1, (char *)&c__7, (ftnlen)sizeof(integer));
00498 e_wsfe();
00499 goto L230;
00500 }
00501 s_rsle(&io___46);
00502 i__1 = nbet;
00503 for (i__ = 1; i__ <= i__1; ++i__) {
00504 do_lio(&c__7, &c__1, (char *)&bet[i__ - 1], (ftnlen)sizeof(
00505 doublecomplex));
00506 }
00507 e_rsle();
00508
00509
00510
00511 io___48.ciunit = nout;
00512 s_wsfe(&io___48);
00513 e_wsfe();
00514 io___49.ciunit = nout;
00515 s_wsfe(&io___49);
00516 i__1 = nidim;
00517 for (i__ = 1; i__ <= i__1; ++i__) {
00518 do_fio(&c__1, (char *)&idim[i__ - 1], (ftnlen)sizeof(integer));
00519 }
00520 e_wsfe();
00521 io___50.ciunit = nout;
00522 s_wsfe(&io___50);
00523 i__1 = nkb;
00524 for (i__ = 1; i__ <= i__1; ++i__) {
00525 do_fio(&c__1, (char *)&kb[i__ - 1], (ftnlen)sizeof(integer));
00526 }
00527 e_wsfe();
00528 io___51.ciunit = nout;
00529 s_wsfe(&io___51);
00530 i__1 = ninc;
00531 for (i__ = 1; i__ <= i__1; ++i__) {
00532 do_fio(&c__1, (char *)&inc[i__ - 1], (ftnlen)sizeof(integer));
00533 }
00534 e_wsfe();
00535 io___52.ciunit = nout;
00536 s_wsfe(&io___52);
00537 i__1 = nalf;
00538 for (i__ = 1; i__ <= i__1; ++i__) {
00539 do_fio(&c__2, (char *)&alf[i__ - 1], (ftnlen)sizeof(doublereal));
00540 }
00541 e_wsfe();
00542 io___53.ciunit = nout;
00543 s_wsfe(&io___53);
00544 i__1 = nbet;
00545 for (i__ = 1; i__ <= i__1; ++i__) {
00546 do_fio(&c__2, (char *)&bet[i__ - 1], (ftnlen)sizeof(doublereal));
00547 }
00548 e_wsfe();
00549 if (! tsterr) {
00550 io___54.ciunit = nout;
00551 s_wsle(&io___54);
00552 e_wsle();
00553 io___55.ciunit = nout;
00554 s_wsfe(&io___55);
00555 e_wsfe();
00556 }
00557 io___56.ciunit = nout;
00558 s_wsle(&io___56);
00559 e_wsle();
00560 io___57.ciunit = nout;
00561 s_wsfe(&io___57);
00562 do_fio(&c__1, (char *)&thresh, (ftnlen)sizeof(doublereal));
00563 e_wsfe();
00564 io___58.ciunit = nout;
00565 s_wsle(&io___58);
00566 e_wsle();
00567
00568
00569
00570
00571 for (i__ = 1; i__ <= 17; ++i__) {
00572 ltest[i__ - 1] = FALSE_;
00573
00574 }
00575 L50:
00576 i__1 = s_rsfe(&io___60);
00577 if (i__1 != 0) {
00578 goto L80;
00579 }
00580 i__1 = do_fio(&c__1, snamet, (ftnlen)6);
00581 if (i__1 != 0) {
00582 goto L80;
00583 }
00584 i__1 = do_fio(&c__1, (char *)<estt, (ftnlen)sizeof(logical));
00585 if (i__1 != 0) {
00586 goto L80;
00587 }
00588 i__1 = e_rsfe();
00589 if (i__1 != 0) {
00590 goto L80;
00591 }
00592 for (i__ = 1; i__ <= 17; ++i__) {
00593 if (s_cmp(snamet, snames + (i__ - 1) * 6, (ftnlen)6, (ftnlen)6) == 0)
00594 {
00595 goto L70;
00596 }
00597
00598 }
00599 io___63.ciunit = nout;
00600 s_wsfe(&io___63);
00601 do_fio(&c__1, snamet, (ftnlen)6);
00602 e_wsfe();
00603 s_stop("", (ftnlen)0);
00604 L70:
00605 ltest[i__ - 1] = ltestt;
00606 goto L50;
00607
00608 L80:
00609 cl__1.cerr = 0;
00610 cl__1.cunit = 5;
00611 cl__1.csta = 0;
00612 f_clos(&cl__1);
00613
00614
00615
00616 eps = 1.;
00617 L90:
00618 d__1 = eps + 1.;
00619 if (ddiff_(&d__1, &c_b123) == 0.) {
00620 goto L100;
00621 }
00622 eps *= .5;
00623 goto L90;
00624 L100:
00625 eps += eps;
00626 io___65.ciunit = nout;
00627 s_wsfe(&io___65);
00628 do_fio(&c__1, (char *)&eps, (ftnlen)sizeof(doublereal));
00629 e_wsfe();
00630
00631
00632
00633 n = 32;
00634 i__1 = n;
00635 for (j = 1; j <= i__1; ++j) {
00636 i__2 = n;
00637 for (i__ = 1; i__ <= i__2; ++i__) {
00638 i__3 = i__ + j * 65 - 66;
00639
00640 i__5 = i__ - j + 1;
00641 i__4 = max(i__5,0);
00642 a[i__3].r = (doublereal) i__4, a[i__3].i = 0.;
00643
00644 }
00645 i__2 = j - 1;
00646 x[i__2].r = (doublereal) j, x[i__2].i = 0.;
00647 i__2 = j - 1;
00648 y[i__2].r = 0., y[i__2].i = 0.;
00649
00650 }
00651 i__1 = n;
00652 for (j = 1; j <= i__1; ++j) {
00653 i__2 = j - 1;
00654 i__3 = j * ((j + 1) * j) / 2 - (j + 1) * j * (j - 1) / 3;
00655 yy[i__2].r = (doublereal) i__3, yy[i__2].i = 0.;
00656
00657 }
00658
00659
00660 *(unsigned char *)trans = 'N';
00661 zmvch_(trans, &n, &n, &c_b2, a, &c__65, x, &c__1, &c_b1, y, &c__1, yt, g,
00662 yy, &eps, &err, &fatal, &nout, &c_true, (ftnlen)1);
00663 same = lze_(yy, yt, &n);
00664 if (! same || err != 0.) {
00665 io___78.ciunit = nout;
00666 s_wsfe(&io___78);
00667 do_fio(&c__1, trans, (ftnlen)1);
00668 do_fio(&c__1, (char *)&same, (ftnlen)sizeof(logical));
00669 do_fio(&c__1, (char *)&err, (ftnlen)sizeof(doublereal));
00670 e_wsfe();
00671 s_stop("", (ftnlen)0);
00672 }
00673 *(unsigned char *)trans = 'T';
00674 zmvch_(trans, &n, &n, &c_b2, a, &c__65, x, &c_n1, &c_b1, y, &c_n1, yt, g,
00675 yy, &eps, &err, &fatal, &nout, &c_true, (ftnlen)1);
00676 same = lze_(yy, yt, &n);
00677 if (! same || err != 0.) {
00678 io___79.ciunit = nout;
00679 s_wsfe(&io___79);
00680 do_fio(&c__1, trans, (ftnlen)1);
00681 do_fio(&c__1, (char *)&same, (ftnlen)sizeof(logical));
00682 do_fio(&c__1, (char *)&err, (ftnlen)sizeof(doublereal));
00683 e_wsfe();
00684 s_stop("", (ftnlen)0);
00685 }
00686
00687
00688
00689 for (isnum = 1; isnum <= 17; ++isnum) {
00690 io___81.ciunit = nout;
00691 s_wsle(&io___81);
00692 e_wsle();
00693 if (! ltest[isnum - 1]) {
00694
00695 io___82.ciunit = nout;
00696 s_wsfe(&io___82);
00697 do_fio(&c__1, snames + (isnum - 1) * 6, (ftnlen)6);
00698 e_wsfe();
00699 } else {
00700 s_copy(srnamc_1.srnamt, snames + (isnum - 1) * 6, (ftnlen)6, (
00701 ftnlen)6);
00702
00703 if (tsterr) {
00704 zchke_(&isnum, snames + (isnum - 1) * 6, &nout, (ftnlen)6);
00705 io___83.ciunit = nout;
00706 s_wsle(&io___83);
00707 e_wsle();
00708 }
00709
00710 infoc_1.infot = 0;
00711 infoc_1.ok = TRUE_;
00712 fatal = FALSE_;
00713 switch (isnum) {
00714 case 1: goto L140;
00715 case 2: goto L140;
00716 case 3: goto L150;
00717 case 4: goto L150;
00718 case 5: goto L150;
00719 case 6: goto L160;
00720 case 7: goto L160;
00721 case 8: goto L160;
00722 case 9: goto L160;
00723 case 10: goto L160;
00724 case 11: goto L160;
00725 case 12: goto L170;
00726 case 13: goto L170;
00727 case 14: goto L180;
00728 case 15: goto L180;
00729 case 16: goto L190;
00730 case 17: goto L190;
00731 }
00732
00733 L140:
00734 zchk1_(snames + (isnum - 1) * 6, &eps, &thresh, &nout, &ntra, &
00735 trace, &rewi, &fatal, &nidim, idim, &nkb, kb, &nalf, alf,
00736 &nbet, bet, &ninc, inc, &c__65, &c__2, a, aa, as, x, xx,
00737 xs, y, yy, ys, yt, g, (ftnlen)6);
00738 goto L200;
00739
00740 L150:
00741 zchk2_(snames + (isnum - 1) * 6, &eps, &thresh, &nout, &ntra, &
00742 trace, &rewi, &fatal, &nidim, idim, &nkb, kb, &nalf, alf,
00743 &nbet, bet, &ninc, inc, &c__65, &c__2, a, aa, as, x, xx,
00744 xs, y, yy, ys, yt, g, (ftnlen)6);
00745 goto L200;
00746
00747
00748 L160:
00749 zchk3_(snames + (isnum - 1) * 6, &eps, &thresh, &nout, &ntra, &
00750 trace, &rewi, &fatal, &nidim, idim, &nkb, kb, &ninc, inc,
00751 &c__65, &c__2, a, aa, as, y, yy, ys, yt, g, z__, (ftnlen)
00752 6);
00753 goto L200;
00754
00755 L170:
00756 zchk4_(snames + (isnum - 1) * 6, &eps, &thresh, &nout, &ntra, &
00757 trace, &rewi, &fatal, &nidim, idim, &nalf, alf, &ninc,
00758 inc, &c__65, &c__2, a, aa, as, x, xx, xs, y, yy, ys, yt,
00759 g, z__, (ftnlen)6);
00760 goto L200;
00761
00762 L180:
00763 zchk5_(snames + (isnum - 1) * 6, &eps, &thresh, &nout, &ntra, &
00764 trace, &rewi, &fatal, &nidim, idim, &nalf, alf, &ninc,
00765 inc, &c__65, &c__2, a, aa, as, x, xx, xs, y, yy, ys, yt,
00766 g, z__, (ftnlen)6);
00767 goto L200;
00768
00769 L190:
00770 zchk6_(snames + (isnum - 1) * 6, &eps, &thresh, &nout, &ntra, &
00771 trace, &rewi, &fatal, &nidim, idim, &nalf, alf, &ninc,
00772 inc, &c__65, &c__2, a, aa, as, x, xx, xs, y, yy, ys, yt,
00773 g, z__, (ftnlen)6);
00774
00775 L200:
00776 if (fatal && sfatal) {
00777 goto L220;
00778 }
00779 }
00780
00781 }
00782 io___90.ciunit = nout;
00783 s_wsfe(&io___90);
00784 e_wsfe();
00785 goto L240;
00786
00787 L220:
00788 io___91.ciunit = nout;
00789 s_wsfe(&io___91);
00790 e_wsfe();
00791 goto L240;
00792
00793 L230:
00794 io___92.ciunit = nout;
00795 s_wsfe(&io___92);
00796 e_wsfe();
00797
00798 L240:
00799 if (trace) {
00800 cl__1.cerr = 0;
00801 cl__1.cunit = ntra;
00802 cl__1.csta = 0;
00803 f_clos(&cl__1);
00804 }
00805 cl__1.cerr = 0;
00806 cl__1.cunit = nout;
00807 cl__1.csta = 0;
00808 f_clos(&cl__1);
00809 s_stop("", (ftnlen)0);
00810
00811
00812
00813
00814 return 0;
00815 }
00816
00817 int zchk1_(char *sname, doublereal *eps, doublereal *thresh,
00818 integer *nout, integer *ntra, logical *trace, logical *rewi, logical *
00819 fatal, integer *nidim, integer *idim, integer *nkb, integer *kb,
00820 integer *nalf, doublecomplex *alf, integer *nbet, doublecomplex *bet,
00821 integer *ninc, integer *inc, integer *nmax, integer *incmax,
00822 doublecomplex *a, doublecomplex *aa, doublecomplex *as, doublecomplex
00823 *x, doublecomplex *xx, doublecomplex *xs, doublecomplex *y,
00824 doublecomplex *yy, doublecomplex *ys, doublecomplex *yt, doublereal *
00825 g, ftnlen sname_len)
00826 {
00827
00828
00829 static char ich[3] = "NTC";
00830
00831
00832 static char fmt_9994[] = "(1x,i6,\002: \002,a6,\002('\002,a1,\002',\002,"
00833 "2(i3,\002,\002),\002(\002,f4.1,\002,\002,f4.1,\002), A,\002,i3"
00834 ",\002, X,\002,i2,\002,(\002,f4.1,\002,\002,f4.1,\002), Y,\002,i2,"
00835 "\002) .\002)";
00836 static char fmt_9995[] = "(1x,i6,\002: \002,a6,\002('\002,a1,\002',\002,"
00837 "4(i3,\002,\002),\002(\002,f4.1,\002,\002,f4.1,\002), A,\002,i3"
00838 ",\002, X,\002,i2,\002,(\002,f4.1,\002,\002,f4.1,\002), Y,\002,i2,"
00839 "\002) .\002)";
00840 static char fmt_9993[] = "(\002 ******* FATAL ERROR - ERROR-EXIT TAKEN O"
00841 "N VALID CALL *\002,\002******\002)";
00842 static char fmt_9998[] = "(\002 ******* FATAL ERROR - PARAMETER NUMBER"
00843 " \002,i2,\002 WAS CH\002,\002ANGED INCORRECTLY *******\002)";
00844 static char fmt_9999[] = "(\002 \002,a6,\002 PASSED THE COMPUTATIONAL TE"
00845 "STS (\002,i6,\002 CALL\002,\002S)\002)";
00846 static char fmt_9997[] = "(\002 \002,a6,\002 COMPLETED THE COMPUTATIONAL"
00847 " TESTS (\002,i6,\002 C\002,\002ALLS)\002,/\002 ******* BUT WITH "
00848 "MAXIMUM TEST RATIO\002,f8.2,\002 - SUSPECT *******\002)";
00849 static char fmt_9996[] = "(\002 ******* \002,a6,\002 FAILED ON CALL NUMB"
00850 "ER:\002)";
00851
00852
00853 integer a_dim1, a_offset, i__1, i__2, i__3, i__4, i__5, i__6, i__7, i__8,
00854 i__9;
00855 alist al__1;
00856
00857
00858 integer s_wsfe(cilist *), do_fio(integer *, char *, ftnlen), e_wsfe(void),
00859 f_rew(alist *);
00860
00861
00862 integer i__, m, n, ia, ib, ic, nc, nd, im, in, kl, ml, nk, nl, ku, ix, iy,
00863 ms, lx, ly, ns, laa, lda;
00864 doublecomplex als, bls;
00865 doublereal err;
00866 integer iku, kls;
00867 extern logical lze_(doublecomplex *, doublecomplex *, integer *);
00868 integer kus;
00869 doublecomplex beta;
00870 integer ldas;
00871 logical same;
00872 integer incx, incy;
00873 logical full, tran, null;
00874 doublecomplex alpha;
00875 logical isame[13];
00876 extern int zmake_(char *, char *, char *, integer *,
00877 integer *, doublecomplex *, integer *, doublecomplex *, integer *,
00878 integer *, integer *, logical *, doublecomplex *, ftnlen, ftnlen,
00879 ftnlen);
00880 integer nargs;
00881 logical reset;
00882 integer incxs, incys;
00883 extern int zgbmv_(char *, integer *, integer *, integer *
00884 , integer *, doublecomplex *, doublecomplex *, integer *,
00885 doublecomplex *, integer *, doublecomplex *, doublecomplex *,
00886 integer *);
00887 char trans[1];
00888 extern int zgemv_(char *, integer *, integer *,
00889 doublecomplex *, doublecomplex *, integer *, doublecomplex *,
00890 integer *, doublecomplex *, doublecomplex *, integer *),
00891 zmvch_(char *, integer *, integer *, doublecomplex *,
00892 doublecomplex *, integer *, doublecomplex *, integer *,
00893 doublecomplex *, doublecomplex *, integer *, doublecomplex *,
00894 doublereal *, doublecomplex *, doublereal *, doublereal *,
00895 logical *, integer *, logical *, ftnlen);
00896 logical banded;
00897 doublereal errmax;
00898 doublecomplex transl;
00899 extern logical lzeres_(char *, char *, integer *, integer *,
00900 doublecomplex *, doublecomplex *, integer *, ftnlen, ftnlen);
00901 char transs[1];
00902
00903
00904 static cilist io___139 = { 0, 0, 0, fmt_9994, 0 };
00905 static cilist io___140 = { 0, 0, 0, fmt_9995, 0 };
00906 static cilist io___141 = { 0, 0, 0, fmt_9993, 0 };
00907 static cilist io___144 = { 0, 0, 0, fmt_9998, 0 };
00908 static cilist io___146 = { 0, 0, 0, fmt_9999, 0 };
00909 static cilist io___147 = { 0, 0, 0, fmt_9997, 0 };
00910 static cilist io___148 = { 0, 0, 0, fmt_9996, 0 };
00911 static cilist io___149 = { 0, 0, 0, fmt_9994, 0 };
00912 static cilist io___150 = { 0, 0, 0, fmt_9995, 0 };
00913
00914
00915
00916
00917
00918
00919
00920
00921
00922
00923
00924
00925
00926
00927
00928
00929
00930
00931
00932
00933
00934
00935
00936 --idim;
00937 --kb;
00938 --alf;
00939 --bet;
00940 --inc;
00941 --g;
00942 --yt;
00943 --y;
00944 --x;
00945 --as;
00946 --aa;
00947 a_dim1 = *nmax;
00948 a_offset = 1 + a_dim1;
00949 a -= a_offset;
00950 --ys;
00951 --yy;
00952 --xs;
00953 --xx;
00954
00955
00956
00957 full = *(unsigned char *)&sname[2] == 'E';
00958 banded = *(unsigned char *)&sname[2] == 'B';
00959
00960 if (full) {
00961 nargs = 11;
00962 } else if (banded) {
00963 nargs = 13;
00964 }
00965
00966 nc = 0;
00967 reset = TRUE_;
00968 errmax = 0.;
00969
00970 i__1 = *nidim;
00971 for (in = 1; in <= i__1; ++in) {
00972 n = idim[in];
00973 nd = n / 2 + 1;
00974
00975 for (im = 1; im <= 2; ++im) {
00976 if (im == 1) {
00977
00978 i__2 = n - nd;
00979 m = max(i__2,0);
00980 }
00981 if (im == 2) {
00982
00983 i__2 = n + nd;
00984 m = min(i__2,*nmax);
00985 }
00986
00987 if (banded) {
00988 nk = *nkb;
00989 } else {
00990 nk = 1;
00991 }
00992 i__2 = nk;
00993 for (iku = 1; iku <= i__2; ++iku) {
00994 if (banded) {
00995 ku = kb[iku];
00996
00997 i__3 = ku - 1;
00998 kl = max(i__3,0);
00999 } else {
01000 ku = n - 1;
01001 kl = m - 1;
01002 }
01003
01004 if (banded) {
01005 lda = kl + ku + 1;
01006 } else {
01007 lda = m;
01008 }
01009 if (lda < *nmax) {
01010 ++lda;
01011 }
01012
01013 if (lda > *nmax) {
01014 goto L100;
01015 }
01016 laa = lda * n;
01017 null = n <= 0 || m <= 0;
01018
01019
01020
01021 transl.r = 0., transl.i = 0.;
01022 zmake_(sname + 1, " ", " ", &m, &n, &a[a_offset], nmax, &aa[1]
01023 , &lda, &kl, &ku, &reset, &transl, (ftnlen)2, (ftnlen)
01024 1, (ftnlen)1);
01025
01026 for (ic = 1; ic <= 3; ++ic) {
01027 *(unsigned char *)trans = *(unsigned char *)&ich[ic - 1];
01028 tran = *(unsigned char *)trans == 'T' || *(unsigned char *
01029 )trans == 'C';
01030
01031 if (tran) {
01032 ml = n;
01033 nl = m;
01034 } else {
01035 ml = m;
01036 nl = n;
01037 }
01038
01039 i__3 = *ninc;
01040 for (ix = 1; ix <= i__3; ++ix) {
01041 incx = inc[ix];
01042 lx = abs(incx) * nl;
01043
01044
01045
01046 transl.r = .5, transl.i = 0.;
01047 i__4 = abs(incx);
01048 i__5 = nl - 1;
01049 zmake_("GE", " ", " ", &c__1, &nl, &x[1], &c__1, &xx[
01050 1], &i__4, &c__0, &i__5, &reset, &transl, (
01051 ftnlen)2, (ftnlen)1, (ftnlen)1);
01052 if (nl > 1) {
01053 i__4 = nl / 2;
01054 x[i__4].r = 0., x[i__4].i = 0.;
01055 i__4 = abs(incx) * (nl / 2 - 1) + 1;
01056 xx[i__4].r = 0., xx[i__4].i = 0.;
01057 }
01058
01059 i__4 = *ninc;
01060 for (iy = 1; iy <= i__4; ++iy) {
01061 incy = inc[iy];
01062 ly = abs(incy) * ml;
01063
01064 i__5 = *nalf;
01065 for (ia = 1; ia <= i__5; ++ia) {
01066 i__6 = ia;
01067 alpha.r = alf[i__6].r, alpha.i = alf[i__6].i;
01068
01069 i__6 = *nbet;
01070 for (ib = 1; ib <= i__6; ++ib) {
01071 i__7 = ib;
01072 beta.r = bet[i__7].r, beta.i = bet[i__7]
01073 .i;
01074
01075
01076
01077 transl.r = 0., transl.i = 0.;
01078 i__7 = abs(incy);
01079 i__8 = ml - 1;
01080 zmake_("GE", " ", " ", &c__1, &ml, &y[1],
01081 &c__1, &yy[1], &i__7, &c__0, &
01082 i__8, &reset, &transl, (ftnlen)2,
01083 (ftnlen)1, (ftnlen)1);
01084
01085 ++nc;
01086
01087
01088
01089
01090 *(unsigned char *)transs = *(unsigned
01091 char *)trans;
01092 ms = m;
01093 ns = n;
01094 kls = kl;
01095 kus = ku;
01096 als.r = alpha.r, als.i = alpha.i;
01097 i__7 = laa;
01098 for (i__ = 1; i__ <= i__7; ++i__) {
01099 i__8 = i__;
01100 i__9 = i__;
01101 as[i__8].r = aa[i__9].r, as[i__8].i =
01102 aa[i__9].i;
01103
01104 }
01105 ldas = lda;
01106 i__7 = lx;
01107 for (i__ = 1; i__ <= i__7; ++i__) {
01108 i__8 = i__;
01109 i__9 = i__;
01110 xs[i__8].r = xx[i__9].r, xs[i__8].i =
01111 xx[i__9].i;
01112
01113 }
01114 incxs = incx;
01115 bls.r = beta.r, bls.i = beta.i;
01116 i__7 = ly;
01117 for (i__ = 1; i__ <= i__7; ++i__) {
01118 i__8 = i__;
01119 i__9 = i__;
01120 ys[i__8].r = yy[i__9].r, ys[i__8].i =
01121 yy[i__9].i;
01122
01123 }
01124 incys = incy;
01125
01126
01127
01128 if (full) {
01129 if (*trace) {
01130 io___139.ciunit = *ntra;
01131 s_wsfe(&io___139);
01132 do_fio(&c__1, (char *)&nc, (
01133 ftnlen)sizeof(integer));
01134 do_fio(&c__1, sname, (ftnlen)6);
01135 do_fio(&c__1, trans, (ftnlen)1);
01136 do_fio(&c__1, (char *)&m, (ftnlen)
01137 sizeof(integer));
01138 do_fio(&c__1, (char *)&n, (ftnlen)
01139 sizeof(integer));
01140 do_fio(&c__2, (char *)&alpha, (
01141 ftnlen)sizeof(doublereal))
01142 ;
01143 do_fio(&c__1, (char *)&lda, (
01144 ftnlen)sizeof(integer));
01145 do_fio(&c__1, (char *)&incx, (
01146 ftnlen)sizeof(integer));
01147 do_fio(&c__2, (char *)&beta, (
01148 ftnlen)sizeof(doublereal))
01149 ;
01150 do_fio(&c__1, (char *)&incy, (
01151 ftnlen)sizeof(integer));
01152 e_wsfe();
01153 }
01154 if (*rewi) {
01155 al__1.aerr = 0;
01156 al__1.aunit = *ntra;
01157 f_rew(&al__1);
01158 }
01159 zgemv_(trans, &m, &n, &alpha, &aa[1],
01160 &lda, &xx[1], &incx, &beta, &
01161 yy[1], &incy);
01162 } else if (banded) {
01163 if (*trace) {
01164 io___140.ciunit = *ntra;
01165 s_wsfe(&io___140);
01166 do_fio(&c__1, (char *)&nc, (
01167 ftnlen)sizeof(integer));
01168 do_fio(&c__1, sname, (ftnlen)6);
01169 do_fio(&c__1, trans, (ftnlen)1);
01170 do_fio(&c__1, (char *)&m, (ftnlen)
01171 sizeof(integer));
01172 do_fio(&c__1, (char *)&n, (ftnlen)
01173 sizeof(integer));
01174 do_fio(&c__1, (char *)&kl, (
01175 ftnlen)sizeof(integer));
01176 do_fio(&c__1, (char *)&ku, (
01177 ftnlen)sizeof(integer));
01178 do_fio(&c__2, (char *)&alpha, (
01179 ftnlen)sizeof(doublereal))
01180 ;
01181 do_fio(&c__1, (char *)&lda, (
01182 ftnlen)sizeof(integer));
01183 do_fio(&c__1, (char *)&incx, (
01184 ftnlen)sizeof(integer));
01185 do_fio(&c__2, (char *)&beta, (
01186 ftnlen)sizeof(doublereal))
01187 ;
01188 do_fio(&c__1, (char *)&incy, (
01189 ftnlen)sizeof(integer));
01190 e_wsfe();
01191 }
01192 if (*rewi) {
01193 al__1.aerr = 0;
01194 al__1.aunit = *ntra;
01195 f_rew(&al__1);
01196 }
01197 zgbmv_(trans, &m, &n, &kl, &ku, &
01198 alpha, &aa[1], &lda, &xx[1], &
01199 incx, &beta, &yy[1], &incy);
01200 }
01201
01202
01203
01204 if (! infoc_1.ok) {
01205 io___141.ciunit = *nout;
01206 s_wsfe(&io___141);
01207 e_wsfe();
01208 *fatal = TRUE_;
01209 goto L130;
01210 }
01211
01212
01213
01214 isame[0] = *(unsigned char *)trans == *(
01215 unsigned char *)transs;
01216 isame[1] = ms == m;
01217 isame[2] = ns == n;
01218 if (full) {
01219 isame[3] = als.r == alpha.r && als.i
01220 == alpha.i;
01221 isame[4] = lze_(&as[1], &aa[1], &laa);
01222 isame[5] = ldas == lda;
01223 isame[6] = lze_(&xs[1], &xx[1], &lx);
01224 isame[7] = incxs == incx;
01225 isame[8] = bls.r == beta.r && bls.i ==
01226 beta.i;
01227 if (null) {
01228 isame[9] = lze_(&ys[1], &yy[1], &
01229 ly);
01230 } else {
01231 i__7 = abs(incy);
01232 isame[9] = lzeres_("GE", " ", &
01233 c__1, &ml, &ys[1], &yy[1],
01234 &i__7, (ftnlen)2, (
01235 ftnlen)1);
01236 }
01237 isame[10] = incys == incy;
01238 } else if (banded) {
01239 isame[3] = kls == kl;
01240 isame[4] = kus == ku;
01241 isame[5] = als.r == alpha.r && als.i
01242 == alpha.i;
01243 isame[6] = lze_(&as[1], &aa[1], &laa);
01244 isame[7] = ldas == lda;
01245 isame[8] = lze_(&xs[1], &xx[1], &lx);
01246 isame[9] = incxs == incx;
01247 isame[10] = bls.r == beta.r && bls.i
01248 == beta.i;
01249 if (null) {
01250 isame[11] = lze_(&ys[1], &yy[1], &
01251 ly);
01252 } else {
01253 i__7 = abs(incy);
01254 isame[11] = lzeres_("GE", " ", &
01255 c__1, &ml, &ys[1], &yy[1],
01256 &i__7, (ftnlen)2, (
01257 ftnlen)1);
01258 }
01259 isame[12] = incys == incy;
01260 }
01261
01262
01263
01264
01265 same = TRUE_;
01266 i__7 = nargs;
01267 for (i__ = 1; i__ <= i__7; ++i__) {
01268 same = same && isame[i__ - 1];
01269 if (! isame[i__ - 1]) {
01270 io___144.ciunit = *nout;
01271 s_wsfe(&io___144);
01272 do_fio(&c__1, (char *)&i__, (
01273 ftnlen)sizeof(integer));
01274 e_wsfe();
01275 }
01276
01277 }
01278 if (! same) {
01279 *fatal = TRUE_;
01280 goto L130;
01281 }
01282
01283 if (! null) {
01284
01285
01286
01287 zmvch_(trans, &m, &n, &alpha, &a[
01288 a_offset], nmax, &x[1], &incx,
01289 &beta, &y[1], &incy, &yt[1],
01290 &g[1], &yy[1], eps, &err,
01291 fatal, nout, &c_true, (ftnlen)
01292 1);
01293 errmax = max(errmax,err);
01294
01295
01296 if (*fatal) {
01297 goto L130;
01298 }
01299 } else {
01300
01301
01302 goto L110;
01303 }
01304
01305
01306 }
01307
01308
01309 }
01310
01311
01312 }
01313
01314
01315 }
01316
01317
01318 }
01319
01320 L100:
01321 ;
01322 }
01323
01324 L110:
01325 ;
01326 }
01327
01328
01329 }
01330
01331
01332
01333 if (errmax < *thresh) {
01334 io___146.ciunit = *nout;
01335 s_wsfe(&io___146);
01336 do_fio(&c__1, sname, (ftnlen)6);
01337 do_fio(&c__1, (char *)&nc, (ftnlen)sizeof(integer));
01338 e_wsfe();
01339 } else {
01340 io___147.ciunit = *nout;
01341 s_wsfe(&io___147);
01342 do_fio(&c__1, sname, (ftnlen)6);
01343 do_fio(&c__1, (char *)&nc, (ftnlen)sizeof(integer));
01344 do_fio(&c__1, (char *)&errmax, (ftnlen)sizeof(doublereal));
01345 e_wsfe();
01346 }
01347 goto L140;
01348
01349 L130:
01350 io___148.ciunit = *nout;
01351 s_wsfe(&io___148);
01352 do_fio(&c__1, sname, (ftnlen)6);
01353 e_wsfe();
01354 if (full) {
01355 io___149.ciunit = *nout;
01356 s_wsfe(&io___149);
01357 do_fio(&c__1, (char *)&nc, (ftnlen)sizeof(integer));
01358 do_fio(&c__1, sname, (ftnlen)6);
01359 do_fio(&c__1, trans, (ftnlen)1);
01360 do_fio(&c__1, (char *)&m, (ftnlen)sizeof(integer));
01361 do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
01362 do_fio(&c__2, (char *)&alpha, (ftnlen)sizeof(doublereal));
01363 do_fio(&c__1, (char *)&lda, (ftnlen)sizeof(integer));
01364 do_fio(&c__1, (char *)&incx, (ftnlen)sizeof(integer));
01365 do_fio(&c__2, (char *)&beta, (ftnlen)sizeof(doublereal));
01366 do_fio(&c__1, (char *)&incy, (ftnlen)sizeof(integer));
01367 e_wsfe();
01368 } else if (banded) {
01369 io___150.ciunit = *nout;
01370 s_wsfe(&io___150);
01371 do_fio(&c__1, (char *)&nc, (ftnlen)sizeof(integer));
01372 do_fio(&c__1, sname, (ftnlen)6);
01373 do_fio(&c__1, trans, (ftnlen)1);
01374 do_fio(&c__1, (char *)&m, (ftnlen)sizeof(integer));
01375 do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
01376 do_fio(&c__1, (char *)&kl, (ftnlen)sizeof(integer));
01377 do_fio(&c__1, (char *)&ku, (ftnlen)sizeof(integer));
01378 do_fio(&c__2, (char *)&alpha, (ftnlen)sizeof(doublereal));
01379 do_fio(&c__1, (char *)&lda, (ftnlen)sizeof(integer));
01380 do_fio(&c__1, (char *)&incx, (ftnlen)sizeof(integer));
01381 do_fio(&c__2, (char *)&beta, (ftnlen)sizeof(doublereal));
01382 do_fio(&c__1, (char *)&incy, (ftnlen)sizeof(integer));
01383 e_wsfe();
01384 }
01385
01386 L140:
01387 return 0;
01388
01389
01390
01391
01392 }
01393
01394 int zchk2_(char *sname, doublereal *eps, doublereal *thresh,
01395 integer *nout, integer *ntra, logical *trace, logical *rewi, logical *
01396 fatal, integer *nidim, integer *idim, integer *nkb, integer *kb,
01397 integer *nalf, doublecomplex *alf, integer *nbet, doublecomplex *bet,
01398 integer *ninc, integer *inc, integer *nmax, integer *incmax,
01399 doublecomplex *a, doublecomplex *aa, doublecomplex *as, doublecomplex
01400 *x, doublecomplex *xx, doublecomplex *xs, doublecomplex *y,
01401 doublecomplex *yy, doublecomplex *ys, doublecomplex *yt, doublereal *
01402 g, ftnlen sname_len)
01403 {
01404
01405
01406 static char ich[2] = "UL";
01407
01408
01409 static char fmt_9993[] = "(1x,i6,\002: \002,a6,\002('\002,a1,\002',\002,"
01410 "i3,\002,(\002,f4.1,\002,\002,f4.1,\002), A,\002,i3,\002, X,\002,"
01411 "i2,\002,(\002,f4.1,\002,\002,f4.1,\002), \002,\002Y,\002,i2,\002"
01412 ") .\002)";
01413 static char fmt_9994[] = "(1x,i6,\002: \002,a6,\002('\002,a1,\002',\002,"
01414 "2(i3,\002,\002),\002(\002,f4.1,\002,\002,f4.1,\002), A,\002,i3"
01415 ",\002, X,\002,i2,\002,(\002,f4.1,\002,\002,f4.1,\002), Y,\002,i2,"
01416 "\002) .\002)";
01417 static char fmt_9995[] = "(1x,i6,\002: \002,a6,\002('\002,a1,\002',\002,"
01418 "i3,\002,(\002,f4.1,\002,\002,f4.1,\002), AP, X,\002,i2,\002,("
01419 "\002,f4.1,\002,\002,f4.1,\002), Y,\002,i2,\002) "
01420 ".\002)";
01421 static char fmt_9992[] = "(\002 ******* FATAL ERROR - ERROR-EXIT TAKEN O"
01422 "N VALID CALL *\002,\002******\002)";
01423 static char fmt_9998[] = "(\002 ******* FATAL ERROR - PARAMETER NUMBER"
01424 " \002,i2,\002 WAS CH\002,\002ANGED INCORRECTLY *******\002)";
01425 static char fmt_9999[] = "(\002 \002,a6,\002 PASSED THE COMPUTATIONAL TE"
01426 "STS (\002,i6,\002 CALL\002,\002S)\002)";
01427 static char fmt_9997[] = "(\002 \002,a6,\002 COMPLETED THE COMPUTATIONAL"
01428 " TESTS (\002,i6,\002 C\002,\002ALLS)\002,/\002 ******* BUT WITH "
01429 "MAXIMUM TEST RATIO\002,f8.2,\002 - SUSPECT *******\002)";
01430 static char fmt_9996[] = "(\002 ******* \002,a6,\002 FAILED ON CALL NUMB"
01431 "ER:\002)";
01432
01433
01434 integer a_dim1, a_offset, i__1, i__2, i__3, i__4, i__5, i__6, i__7, i__8,
01435 i__9;
01436 alist al__1;
01437
01438
01439 integer s_wsfe(cilist *), do_fio(integer *, char *, ftnlen), e_wsfe(void),
01440 f_rew(alist *);
01441
01442
01443 integer i__, k, n, ia, ib, ic, nc, ik, in, nk, ks, ix, iy, ns, lx, ly,
01444 laa, lda;
01445 doublecomplex als, bls;
01446 doublereal err;
01447 extern logical lze_(doublecomplex *, doublecomplex *, integer *);
01448 doublecomplex beta;
01449 integer ldas;
01450 logical same;
01451 integer incx, incy;
01452 logical full, null;
01453 char uplo[1];
01454 doublecomplex alpha;
01455 logical isame[13];
01456 extern int zmake_(char *, char *, char *, integer *,
01457 integer *, doublecomplex *, integer *, doublecomplex *, integer *,
01458 integer *, integer *, logical *, doublecomplex *, ftnlen, ftnlen,
01459 ftnlen);
01460 integer nargs;
01461 logical reset;
01462 integer incxs, incys;
01463 extern int zhbmv_(char *, integer *, integer *,
01464 doublecomplex *, doublecomplex *, integer *, doublecomplex *,
01465 integer *, doublecomplex *, doublecomplex *, integer *),
01466 zmvch_(char *, integer *, integer *, doublecomplex *,
01467 doublecomplex *, integer *, doublecomplex *, integer *,
01468 doublecomplex *, doublecomplex *, integer *, doublecomplex *,
01469 doublereal *, doublecomplex *, doublereal *, doublereal *,
01470 logical *, integer *, logical *, ftnlen), zhemv_(char *, integer *
01471 , doublecomplex *, doublecomplex *, integer *, doublecomplex *,
01472 integer *, doublecomplex *, doublecomplex *, integer *);
01473 char uplos[1];
01474 extern int zhpmv_(char *, integer *, doublecomplex *,
01475 doublecomplex *, doublecomplex *, integer *, doublecomplex *,
01476 doublecomplex *, integer *);
01477 logical banded, packed;
01478 doublereal errmax;
01479 doublecomplex transl;
01480 extern logical lzeres_(char *, char *, integer *, integer *,
01481 doublecomplex *, doublecomplex *, integer *, ftnlen, ftnlen);
01482
01483
01484 static cilist io___189 = { 0, 0, 0, fmt_9993, 0 };
01485 static cilist io___190 = { 0, 0, 0, fmt_9994, 0 };
01486 static cilist io___191 = { 0, 0, 0, fmt_9995, 0 };
01487 static cilist io___192 = { 0, 0, 0, fmt_9992, 0 };
01488 static cilist io___195 = { 0, 0, 0, fmt_9998, 0 };
01489 static cilist io___197 = { 0, 0, 0, fmt_9999, 0 };
01490 static cilist io___198 = { 0, 0, 0, fmt_9997, 0 };
01491 static cilist io___199 = { 0, 0, 0, fmt_9996, 0 };
01492 static cilist io___200 = { 0, 0, 0, fmt_9993, 0 };
01493 static cilist io___201 = { 0, 0, 0, fmt_9994, 0 };
01494 static cilist io___202 = { 0, 0, 0, fmt_9995, 0 };
01495
01496
01497
01498
01499
01500
01501
01502
01503
01504
01505
01506
01507
01508
01509
01510
01511
01512
01513
01514
01515
01516
01517
01518 --idim;
01519 --kb;
01520 --alf;
01521 --bet;
01522 --inc;
01523 --g;
01524 --yt;
01525 --y;
01526 --x;
01527 --as;
01528 --aa;
01529 a_dim1 = *nmax;
01530 a_offset = 1 + a_dim1;
01531 a -= a_offset;
01532 --ys;
01533 --yy;
01534 --xs;
01535 --xx;
01536
01537
01538
01539 full = *(unsigned char *)&sname[2] == 'E';
01540 banded = *(unsigned char *)&sname[2] == 'B';
01541 packed = *(unsigned char *)&sname[2] == 'P';
01542
01543 if (full) {
01544 nargs = 10;
01545 } else if (banded) {
01546 nargs = 11;
01547 } else if (packed) {
01548 nargs = 9;
01549 }
01550
01551 nc = 0;
01552 reset = TRUE_;
01553 errmax = 0.;
01554
01555 i__1 = *nidim;
01556 for (in = 1; in <= i__1; ++in) {
01557 n = idim[in];
01558
01559 if (banded) {
01560 nk = *nkb;
01561 } else {
01562 nk = 1;
01563 }
01564 i__2 = nk;
01565 for (ik = 1; ik <= i__2; ++ik) {
01566 if (banded) {
01567 k = kb[ik];
01568 } else {
01569 k = n - 1;
01570 }
01571
01572 if (banded) {
01573 lda = k + 1;
01574 } else {
01575 lda = n;
01576 }
01577 if (lda < *nmax) {
01578 ++lda;
01579 }
01580
01581 if (lda > *nmax) {
01582 goto L100;
01583 }
01584 if (packed) {
01585 laa = n * (n + 1) / 2;
01586 } else {
01587 laa = lda * n;
01588 }
01589 null = n <= 0;
01590
01591 for (ic = 1; ic <= 2; ++ic) {
01592 *(unsigned char *)uplo = *(unsigned char *)&ich[ic - 1];
01593
01594
01595
01596 transl.r = 0., transl.i = 0.;
01597 zmake_(sname + 1, uplo, " ", &n, &n, &a[a_offset], nmax, &aa[
01598 1], &lda, &k, &k, &reset, &transl, (ftnlen)2, (ftnlen)
01599 1, (ftnlen)1);
01600
01601 i__3 = *ninc;
01602 for (ix = 1; ix <= i__3; ++ix) {
01603 incx = inc[ix];
01604 lx = abs(incx) * n;
01605
01606
01607
01608 transl.r = .5, transl.i = 0.;
01609 i__4 = abs(incx);
01610 i__5 = n - 1;
01611 zmake_("GE", " ", " ", &c__1, &n, &x[1], &c__1, &xx[1], &
01612 i__4, &c__0, &i__5, &reset, &transl, (ftnlen)2, (
01613 ftnlen)1, (ftnlen)1);
01614 if (n > 1) {
01615 i__4 = n / 2;
01616 x[i__4].r = 0., x[i__4].i = 0.;
01617 i__4 = abs(incx) * (n / 2 - 1) + 1;
01618 xx[i__4].r = 0., xx[i__4].i = 0.;
01619 }
01620
01621 i__4 = *ninc;
01622 for (iy = 1; iy <= i__4; ++iy) {
01623 incy = inc[iy];
01624 ly = abs(incy) * n;
01625
01626 i__5 = *nalf;
01627 for (ia = 1; ia <= i__5; ++ia) {
01628 i__6 = ia;
01629 alpha.r = alf[i__6].r, alpha.i = alf[i__6].i;
01630
01631 i__6 = *nbet;
01632 for (ib = 1; ib <= i__6; ++ib) {
01633 i__7 = ib;
01634 beta.r = bet[i__7].r, beta.i = bet[i__7].i;
01635
01636
01637
01638 transl.r = 0., transl.i = 0.;
01639 i__7 = abs(incy);
01640 i__8 = n - 1;
01641 zmake_("GE", " ", " ", &c__1, &n, &y[1], &
01642 c__1, &yy[1], &i__7, &c__0, &i__8, &
01643 reset, &transl, (ftnlen)2, (ftnlen)1,
01644 (ftnlen)1);
01645
01646 ++nc;
01647
01648
01649
01650
01651 *(unsigned char *)uplos = *(unsigned char *)
01652 uplo;
01653 ns = n;
01654 ks = k;
01655 als.r = alpha.r, als.i = alpha.i;
01656 i__7 = laa;
01657 for (i__ = 1; i__ <= i__7; ++i__) {
01658 i__8 = i__;
01659 i__9 = i__;
01660 as[i__8].r = aa[i__9].r, as[i__8].i = aa[
01661 i__9].i;
01662
01663 }
01664 ldas = lda;
01665 i__7 = lx;
01666 for (i__ = 1; i__ <= i__7; ++i__) {
01667 i__8 = i__;
01668 i__9 = i__;
01669 xs[i__8].r = xx[i__9].r, xs[i__8].i = xx[
01670 i__9].i;
01671
01672 }
01673 incxs = incx;
01674 bls.r = beta.r, bls.i = beta.i;
01675 i__7 = ly;
01676 for (i__ = 1; i__ <= i__7; ++i__) {
01677 i__8 = i__;
01678 i__9 = i__;
01679 ys[i__8].r = yy[i__9].r, ys[i__8].i = yy[
01680 i__9].i;
01681
01682 }
01683 incys = incy;
01684
01685
01686
01687 if (full) {
01688 if (*trace) {
01689 io___189.ciunit = *ntra;
01690 s_wsfe(&io___189);
01691 do_fio(&c__1, (char *)&nc, (ftnlen)
01692 sizeof(integer));
01693 do_fio(&c__1, sname, (ftnlen)6);
01694 do_fio(&c__1, uplo, (ftnlen)1);
01695 do_fio(&c__1, (char *)&n, (ftnlen)
01696 sizeof(integer));
01697 do_fio(&c__2, (char *)&alpha, (ftnlen)
01698 sizeof(doublereal));
01699 do_fio(&c__1, (char *)&lda, (ftnlen)
01700 sizeof(integer));
01701 do_fio(&c__1, (char *)&incx, (ftnlen)
01702 sizeof(integer));
01703 do_fio(&c__2, (char *)&beta, (ftnlen)
01704 sizeof(doublereal));
01705 do_fio(&c__1, (char *)&incy, (ftnlen)
01706 sizeof(integer));
01707 e_wsfe();
01708 }
01709 if (*rewi) {
01710 al__1.aerr = 0;
01711 al__1.aunit = *ntra;
01712 f_rew(&al__1);
01713 }
01714 zhemv_(uplo, &n, &alpha, &aa[1], &lda, &
01715 xx[1], &incx, &beta, &yy[1], &
01716 incy);
01717 } else if (banded) {
01718 if (*trace) {
01719 io___190.ciunit = *ntra;
01720 s_wsfe(&io___190);
01721 do_fio(&c__1, (char *)&nc, (ftnlen)
01722 sizeof(integer));
01723 do_fio(&c__1, sname, (ftnlen)6);
01724 do_fio(&c__1, uplo, (ftnlen)1);
01725 do_fio(&c__1, (char *)&n, (ftnlen)
01726 sizeof(integer));
01727 do_fio(&c__1, (char *)&k, (ftnlen)
01728 sizeof(integer));
01729 do_fio(&c__2, (char *)&alpha, (ftnlen)
01730 sizeof(doublereal));
01731 do_fio(&c__1, (char *)&lda, (ftnlen)
01732 sizeof(integer));
01733 do_fio(&c__1, (char *)&incx, (ftnlen)
01734 sizeof(integer));
01735 do_fio(&c__2, (char *)&beta, (ftnlen)
01736 sizeof(doublereal));
01737 do_fio(&c__1, (char *)&incy, (ftnlen)
01738 sizeof(integer));
01739 e_wsfe();
01740 }
01741 if (*rewi) {
01742 al__1.aerr = 0;
01743 al__1.aunit = *ntra;
01744 f_rew(&al__1);
01745 }
01746 zhbmv_(uplo, &n, &k, &alpha, &aa[1], &lda,
01747 &xx[1], &incx, &beta, &yy[1], &
01748 incy);
01749 } else if (packed) {
01750 if (*trace) {
01751 io___191.ciunit = *ntra;
01752 s_wsfe(&io___191);
01753 do_fio(&c__1, (char *)&nc, (ftnlen)
01754 sizeof(integer));
01755 do_fio(&c__1, sname, (ftnlen)6);
01756 do_fio(&c__1, uplo, (ftnlen)1);
01757 do_fio(&c__1, (char *)&n, (ftnlen)
01758 sizeof(integer));
01759 do_fio(&c__2, (char *)&alpha, (ftnlen)
01760 sizeof(doublereal));
01761 do_fio(&c__1, (char *)&incx, (ftnlen)
01762 sizeof(integer));
01763 do_fio(&c__2, (char *)&beta, (ftnlen)
01764 sizeof(doublereal));
01765 do_fio(&c__1, (char *)&incy, (ftnlen)
01766 sizeof(integer));
01767 e_wsfe();
01768 }
01769 if (*rewi) {
01770 al__1.aerr = 0;
01771 al__1.aunit = *ntra;
01772 f_rew(&al__1);
01773 }
01774 zhpmv_(uplo, &n, &alpha, &aa[1], &xx[1], &
01775 incx, &beta, &yy[1], &incy);
01776 }
01777
01778
01779
01780 if (! infoc_1.ok) {
01781 io___192.ciunit = *nout;
01782 s_wsfe(&io___192);
01783 e_wsfe();
01784 *fatal = TRUE_;
01785 goto L120;
01786 }
01787
01788
01789
01790 isame[0] = *(unsigned char *)uplo == *(
01791 unsigned char *)uplos;
01792 isame[1] = ns == n;
01793 if (full) {
01794 isame[2] = als.r == alpha.r && als.i ==
01795 alpha.i;
01796 isame[3] = lze_(&as[1], &aa[1], &laa);
01797 isame[4] = ldas == lda;
01798 isame[5] = lze_(&xs[1], &xx[1], &lx);
01799 isame[6] = incxs == incx;
01800 isame[7] = bls.r == beta.r && bls.i ==
01801 beta.i;
01802 if (null) {
01803 isame[8] = lze_(&ys[1], &yy[1], &ly);
01804 } else {
01805 i__7 = abs(incy);
01806 isame[8] = lzeres_("GE", " ", &c__1, &
01807 n, &ys[1], &yy[1], &i__7, (
01808 ftnlen)2, (ftnlen)1);
01809 }
01810 isame[9] = incys == incy;
01811 } else if (banded) {
01812 isame[2] = ks == k;
01813 isame[3] = als.r == alpha.r && als.i ==
01814 alpha.i;
01815 isame[4] = lze_(&as[1], &aa[1], &laa);
01816 isame[5] = ldas == lda;
01817 isame[6] = lze_(&xs[1], &xx[1], &lx);
01818 isame[7] = incxs == incx;
01819 isame[8] = bls.r == beta.r && bls.i ==
01820 beta.i;
01821 if (null) {
01822 isame[9] = lze_(&ys[1], &yy[1], &ly);
01823 } else {
01824 i__7 = abs(incy);
01825 isame[9] = lzeres_("GE", " ", &c__1, &
01826 n, &ys[1], &yy[1], &i__7, (
01827 ftnlen)2, (ftnlen)1);
01828 }
01829 isame[10] = incys == incy;
01830 } else if (packed) {
01831 isame[2] = als.r == alpha.r && als.i ==
01832 alpha.i;
01833 isame[3] = lze_(&as[1], &aa[1], &laa);
01834 isame[4] = lze_(&xs[1], &xx[1], &lx);
01835 isame[5] = incxs == incx;
01836 isame[6] = bls.r == beta.r && bls.i ==
01837 beta.i;
01838 if (null) {
01839 isame[7] = lze_(&ys[1], &yy[1], &ly);
01840 } else {
01841 i__7 = abs(incy);
01842 isame[7] = lzeres_("GE", " ", &c__1, &
01843 n, &ys[1], &yy[1], &i__7, (
01844 ftnlen)2, (ftnlen)1);
01845 }
01846 isame[8] = incys == incy;
01847 }
01848
01849
01850
01851
01852 same = TRUE_;
01853 i__7 = nargs;
01854 for (i__ = 1; i__ <= i__7; ++i__) {
01855 same = same && isame[i__ - 1];
01856 if (! isame[i__ - 1]) {
01857 io___195.ciunit = *nout;
01858 s_wsfe(&io___195);
01859 do_fio(&c__1, (char *)&i__, (ftnlen)
01860 sizeof(integer));
01861 e_wsfe();
01862 }
01863
01864 }
01865 if (! same) {
01866 *fatal = TRUE_;
01867 goto L120;
01868 }
01869
01870 if (! null) {
01871
01872
01873
01874 zmvch_("N", &n, &n, &alpha, &a[a_offset],
01875 nmax, &x[1], &incx, &beta, &y[1],
01876 &incy, &yt[1], &g[1], &yy[1], eps,
01877 &err, fatal, nout, &c_true, (
01878 ftnlen)1);
01879 errmax = max(errmax,err);
01880
01881
01882 if (*fatal) {
01883 goto L120;
01884 }
01885 } else {
01886
01887 goto L110;
01888 }
01889
01890
01891 }
01892
01893
01894 }
01895
01896
01897 }
01898
01899
01900 }
01901
01902
01903 }
01904
01905 L100:
01906 ;
01907 }
01908
01909 L110:
01910 ;
01911 }
01912
01913
01914
01915 if (errmax < *thresh) {
01916 io___197.ciunit = *nout;
01917 s_wsfe(&io___197);
01918 do_fio(&c__1, sname, (ftnlen)6);
01919 do_fio(&c__1, (char *)&nc, (ftnlen)sizeof(integer));
01920 e_wsfe();
01921 } else {
01922 io___198.ciunit = *nout;
01923 s_wsfe(&io___198);
01924 do_fio(&c__1, sname, (ftnlen)6);
01925 do_fio(&c__1, (char *)&nc, (ftnlen)sizeof(integer));
01926 do_fio(&c__1, (char *)&errmax, (ftnlen)sizeof(doublereal));
01927 e_wsfe();
01928 }
01929 goto L130;
01930
01931 L120:
01932 io___199.ciunit = *nout;
01933 s_wsfe(&io___199);
01934 do_fio(&c__1, sname, (ftnlen)6);
01935 e_wsfe();
01936 if (full) {
01937 io___200.ciunit = *nout;
01938 s_wsfe(&io___200);
01939 do_fio(&c__1, (char *)&nc, (ftnlen)sizeof(integer));
01940 do_fio(&c__1, sname, (ftnlen)6);
01941 do_fio(&c__1, uplo, (ftnlen)1);
01942 do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
01943 do_fio(&c__2, (char *)&alpha, (ftnlen)sizeof(doublereal));
01944 do_fio(&c__1, (char *)&lda, (ftnlen)sizeof(integer));
01945 do_fio(&c__1, (char *)&incx, (ftnlen)sizeof(integer));
01946 do_fio(&c__2, (char *)&beta, (ftnlen)sizeof(doublereal));
01947 do_fio(&c__1, (char *)&incy, (ftnlen)sizeof(integer));
01948 e_wsfe();
01949 } else if (banded) {
01950 io___201.ciunit = *nout;
01951 s_wsfe(&io___201);
01952 do_fio(&c__1, (char *)&nc, (ftnlen)sizeof(integer));
01953 do_fio(&c__1, sname, (ftnlen)6);
01954 do_fio(&c__1, uplo, (ftnlen)1);
01955 do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
01956 do_fio(&c__1, (char *)&k, (ftnlen)sizeof(integer));
01957 do_fio(&c__2, (char *)&alpha, (ftnlen)sizeof(doublereal));
01958 do_fio(&c__1, (char *)&lda, (ftnlen)sizeof(integer));
01959 do_fio(&c__1, (char *)&incx, (ftnlen)sizeof(integer));
01960 do_fio(&c__2, (char *)&beta, (ftnlen)sizeof(doublereal));
01961 do_fio(&c__1, (char *)&incy, (ftnlen)sizeof(integer));
01962 e_wsfe();
01963 } else if (packed) {
01964 io___202.ciunit = *nout;
01965 s_wsfe(&io___202);
01966 do_fio(&c__1, (char *)&nc, (ftnlen)sizeof(integer));
01967 do_fio(&c__1, sname, (ftnlen)6);
01968 do_fio(&c__1, uplo, (ftnlen)1);
01969 do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
01970 do_fio(&c__2, (char *)&alpha, (ftnlen)sizeof(doublereal));
01971 do_fio(&c__1, (char *)&incx, (ftnlen)sizeof(integer));
01972 do_fio(&c__2, (char *)&beta, (ftnlen)sizeof(doublereal));
01973 do_fio(&c__1, (char *)&incy, (ftnlen)sizeof(integer));
01974 e_wsfe();
01975 }
01976
01977 L130:
01978 return 0;
01979
01980
01981
01982
01983 }
01984
01985 int zchk3_(char *sname, doublereal *eps, doublereal *thresh,
01986 integer *nout, integer *ntra, logical *trace, logical *rewi, logical *
01987 fatal, integer *nidim, integer *idim, integer *nkb, integer *kb,
01988 integer *ninc, integer *inc, integer *nmax, integer *incmax,
01989 doublecomplex *a, doublecomplex *aa, doublecomplex *as, doublecomplex
01990 *x, doublecomplex *xx, doublecomplex *xs, doublecomplex *xt,
01991 doublereal *g, doublecomplex *z__, ftnlen sname_len)
01992 {
01993
01994
01995 static char ichu[2] = "UL";
01996 static char icht[3] = "NTC";
01997 static char ichd[2] = "UN";
01998
01999
02000 static char fmt_9993[] = "(1x,i6,\002: \002,a6,\002(\002,3(\002'\002,a1"
02001 ",\002',\002),i3,\002, A,\002,i3,\002, X,\002,i2,\002) "
02002 " .\002)";
02003 static char fmt_9994[] = "(1x,i6,\002: \002,a6,\002(\002,3(\002'\002,a1"
02004 ",\002',\002),2(i3,\002,\002),\002 A,\002,i3,\002, X,\002,i2,\002"
02005 ") .\002)";
02006 static char fmt_9995[] = "(1x,i6,\002: \002,a6,\002(\002,3(\002'\002,a1"
02007 ",\002',\002),i3,\002, AP, \002,\002X,\002,i2,\002) "
02008 " .\002)";
02009 static char fmt_9992[] = "(\002 ******* FATAL ERROR - ERROR-EXIT TAKEN O"
02010 "N VALID CALL *\002,\002******\002)";
02011 static char fmt_9998[] = "(\002 ******* FATAL ERROR - PARAMETER NUMBER"
02012 " \002,i2,\002 WAS CH\002,\002ANGED INCORRECTLY *******\002)";
02013 static char fmt_9999[] = "(\002 \002,a6,\002 PASSED THE COMPUTATIONAL TE"
02014 "STS (\002,i6,\002 CALL\002,\002S)\002)";
02015 static char fmt_9997[] = "(\002 \002,a6,\002 COMPLETED THE COMPUTATIONAL"
02016 " TESTS (\002,i6,\002 C\002,\002ALLS)\002,/\002 ******* BUT WITH "
02017 "MAXIMUM TEST RATIO\002,f8.2,\002 - SUSPECT *******\002)";
02018 static char fmt_9996[] = "(\002 ******* \002,a6,\002 FAILED ON CALL NUMB"
02019 "ER:\002)";
02020
02021
02022 integer a_dim1, a_offset, i__1, i__2, i__3, i__4, i__5, i__6;
02023 alist al__1;
02024
02025
02026 integer s_cmp(char *, char *, ftnlen, ftnlen), s_wsfe(cilist *), do_fio(
02027 integer *, char *, ftnlen), e_wsfe(void), f_rew(alist *);
02028
02029
02030 integer i__, k, n, nc, ik, in, nk, ks, ix, ns, lx, laa, icd, lda, ict,
02031 icu;
02032 doublereal err;
02033 extern logical lze_(doublecomplex *, doublecomplex *, integer *);
02034 char diag[1];
02035 integer ldas;
02036 logical same;
02037 integer incx;
02038 logical full, null;
02039 char uplo[1], diags[1];
02040 logical isame[13];
02041 extern int zmake_(char *, char *, char *, integer *,
02042 integer *, doublecomplex *, integer *, doublecomplex *, integer *,
02043 integer *, integer *, logical *, doublecomplex *, ftnlen, ftnlen,
02044 ftnlen);
02045 integer nargs;
02046 logical reset;
02047 integer incxs;
02048 char trans[1];
02049 extern int zmvch_(char *, integer *, integer *,
02050 doublecomplex *, doublecomplex *, integer *, doublecomplex *,
02051 integer *, doublecomplex *, doublecomplex *, integer *,
02052 doublecomplex *, doublereal *, doublecomplex *, doublereal *,
02053 doublereal *, logical *, integer *, logical *, ftnlen);
02054 char uplos[1];
02055 extern int ztbmv_(char *, char *, char *, integer *,
02056 integer *, doublecomplex *, integer *, doublecomplex *, integer *), ztbsv_(char *, char *, char *, integer *
02057 , integer *, doublecomplex *, integer *, doublecomplex *, integer
02058 *), ztpmv_(char *, char *, char *,
02059 integer *, doublecomplex *, doublecomplex *, integer *), ztrmv_(char *, char *, char *, integer *,
02060 doublecomplex *, integer *, doublecomplex *, integer *), ztpsv_(char *, char *, char *, integer *,
02061 doublecomplex *, doublecomplex *, integer *), ztrsv_(char *, char *, char *, integer *, doublecomplex *
02062 , integer *, doublecomplex *, integer *);
02063 logical banded, packed;
02064 doublereal errmax;
02065 doublecomplex transl;
02066 extern logical lzeres_(char *, char *, integer *, integer *,
02067 doublecomplex *, doublecomplex *, integer *, ftnlen, ftnlen);
02068 char transs[1];
02069
02070
02071 static cilist io___239 = { 0, 0, 0, fmt_9993, 0 };
02072 static cilist io___240 = { 0, 0, 0, fmt_9994, 0 };
02073 static cilist io___241 = { 0, 0, 0, fmt_9995, 0 };
02074 static cilist io___242 = { 0, 0, 0, fmt_9993, 0 };
02075 static cilist io___243 = { 0, 0, 0, fmt_9994, 0 };
02076 static cilist io___244 = { 0, 0, 0, fmt_9995, 0 };
02077 static cilist io___245 = { 0, 0, 0, fmt_9992, 0 };
02078 static cilist io___248 = { 0, 0, 0, fmt_9998, 0 };
02079 static cilist io___250 = { 0, 0, 0, fmt_9999, 0 };
02080 static cilist io___251 = { 0, 0, 0, fmt_9997, 0 };
02081 static cilist io___252 = { 0, 0, 0, fmt_9996, 0 };
02082 static cilist io___253 = { 0, 0, 0, fmt_9993, 0 };
02083 static cilist io___254 = { 0, 0, 0, fmt_9994, 0 };
02084 static cilist io___255 = { 0, 0, 0, fmt_9995, 0 };
02085
02086
02087
02088
02089
02090
02091
02092
02093
02094
02095
02096
02097
02098
02099
02100
02101
02102
02103
02104
02105
02106
02107
02108 --idim;
02109 --kb;
02110 --inc;
02111 --z__;
02112 --g;
02113 --xt;
02114 --x;
02115 --as;
02116 --aa;
02117 a_dim1 = *nmax;
02118 a_offset = 1 + a_dim1;
02119 a -= a_offset;
02120 --xs;
02121 --xx;
02122
02123
02124
02125 full = *(unsigned char *)&sname[2] == 'R';
02126 banded = *(unsigned char *)&sname[2] == 'B';
02127 packed = *(unsigned char *)&sname[2] == 'P';
02128
02129 if (full) {
02130 nargs = 8;
02131 } else if (banded) {
02132 nargs = 9;
02133 } else if (packed) {
02134 nargs = 7;
02135 }
02136
02137 nc = 0;
02138 reset = TRUE_;
02139 errmax = 0.;
02140
02141 i__1 = *nmax;
02142 for (i__ = 1; i__ <= i__1; ++i__) {
02143 i__2 = i__;
02144 z__[i__2].r = 0., z__[i__2].i = 0.;
02145
02146 }
02147
02148 i__1 = *nidim;
02149 for (in = 1; in <= i__1; ++in) {
02150 n = idim[in];
02151
02152 if (banded) {
02153 nk = *nkb;
02154 } else {
02155 nk = 1;
02156 }
02157 i__2 = nk;
02158 for (ik = 1; ik <= i__2; ++ik) {
02159 if (banded) {
02160 k = kb[ik];
02161 } else {
02162 k = n - 1;
02163 }
02164
02165 if (banded) {
02166 lda = k + 1;
02167 } else {
02168 lda = n;
02169 }
02170 if (lda < *nmax) {
02171 ++lda;
02172 }
02173
02174 if (lda > *nmax) {
02175 goto L100;
02176 }
02177 if (packed) {
02178 laa = n * (n + 1) / 2;
02179 } else {
02180 laa = lda * n;
02181 }
02182 null = n <= 0;
02183
02184 for (icu = 1; icu <= 2; ++icu) {
02185 *(unsigned char *)uplo = *(unsigned char *)&ichu[icu - 1];
02186
02187 for (ict = 1; ict <= 3; ++ict) {
02188 *(unsigned char *)trans = *(unsigned char *)&icht[ict - 1]
02189 ;
02190
02191 for (icd = 1; icd <= 2; ++icd) {
02192 *(unsigned char *)diag = *(unsigned char *)&ichd[icd
02193 - 1];
02194
02195
02196
02197 transl.r = 0., transl.i = 0.;
02198 zmake_(sname + 1, uplo, diag, &n, &n, &a[a_offset],
02199 nmax, &aa[1], &lda, &k, &k, &reset, &transl, (
02200 ftnlen)2, (ftnlen)1, (ftnlen)1);
02201
02202 i__3 = *ninc;
02203 for (ix = 1; ix <= i__3; ++ix) {
02204 incx = inc[ix];
02205 lx = abs(incx) * n;
02206
02207
02208
02209 transl.r = .5, transl.i = 0.;
02210 i__4 = abs(incx);
02211 i__5 = n - 1;
02212 zmake_("GE", " ", " ", &c__1, &n, &x[1], &c__1, &
02213 xx[1], &i__4, &c__0, &i__5, &reset, &
02214 transl, (ftnlen)2, (ftnlen)1, (ftnlen)1);
02215 if (n > 1) {
02216 i__4 = n / 2;
02217 x[i__4].r = 0., x[i__4].i = 0.;
02218 i__4 = abs(incx) * (n / 2 - 1) + 1;
02219 xx[i__4].r = 0., xx[i__4].i = 0.;
02220 }
02221
02222 ++nc;
02223
02224
02225
02226 *(unsigned char *)uplos = *(unsigned char *)uplo;
02227 *(unsigned char *)transs = *(unsigned char *)
02228 trans;
02229 *(unsigned char *)diags = *(unsigned char *)diag;
02230 ns = n;
02231 ks = k;
02232 i__4 = laa;
02233 for (i__ = 1; i__ <= i__4; ++i__) {
02234 i__5 = i__;
02235 i__6 = i__;
02236 as[i__5].r = aa[i__6].r, as[i__5].i = aa[i__6]
02237 .i;
02238
02239 }
02240 ldas = lda;
02241 i__4 = lx;
02242 for (i__ = 1; i__ <= i__4; ++i__) {
02243 i__5 = i__;
02244 i__6 = i__;
02245 xs[i__5].r = xx[i__6].r, xs[i__5].i = xx[i__6]
02246 .i;
02247
02248 }
02249 incxs = incx;
02250
02251
02252
02253 if (s_cmp(sname + 3, "MV", (ftnlen)2, (ftnlen)2)
02254 == 0) {
02255 if (full) {
02256 if (*trace) {
02257 io___239.ciunit = *ntra;
02258 s_wsfe(&io___239);
02259 do_fio(&c__1, (char *)&nc, (ftnlen)
02260 sizeof(integer));
02261 do_fio(&c__1, sname, (ftnlen)6);
02262 do_fio(&c__1, uplo, (ftnlen)1);
02263 do_fio(&c__1, trans, (ftnlen)1);
02264 do_fio(&c__1, diag, (ftnlen)1);
02265 do_fio(&c__1, (char *)&n, (ftnlen)
02266 sizeof(integer));
02267 do_fio(&c__1, (char *)&lda, (ftnlen)
02268 sizeof(integer));
02269 do_fio(&c__1, (char *)&incx, (ftnlen)
02270 sizeof(integer));
02271 e_wsfe();
02272 }
02273 if (*rewi) {
02274 al__1.aerr = 0;
02275 al__1.aunit = *ntra;
02276 f_rew(&al__1);
02277 }
02278 ztrmv_(uplo, trans, diag, &n, &aa[1], &
02279 lda, &xx[1], &incx);
02280 } else if (banded) {
02281 if (*trace) {
02282 io___240.ciunit = *ntra;
02283 s_wsfe(&io___240);
02284 do_fio(&c__1, (char *)&nc, (ftnlen)
02285 sizeof(integer));
02286 do_fio(&c__1, sname, (ftnlen)6);
02287 do_fio(&c__1, uplo, (ftnlen)1);
02288 do_fio(&c__1, trans, (ftnlen)1);
02289 do_fio(&c__1, diag, (ftnlen)1);
02290 do_fio(&c__1, (char *)&n, (ftnlen)
02291 sizeof(integer));
02292 do_fio(&c__1, (char *)&k, (ftnlen)
02293 sizeof(integer));
02294 do_fio(&c__1, (char *)&lda, (ftnlen)
02295 sizeof(integer));
02296 do_fio(&c__1, (char *)&incx, (ftnlen)
02297 sizeof(integer));
02298 e_wsfe();
02299 }
02300 if (*rewi) {
02301 al__1.aerr = 0;
02302 al__1.aunit = *ntra;
02303 f_rew(&al__1);
02304 }
02305 ztbmv_(uplo, trans, diag, &n, &k, &aa[1],
02306 &lda, &xx[1], &incx);
02307 } else if (packed) {
02308 if (*trace) {
02309 io___241.ciunit = *ntra;
02310 s_wsfe(&io___241);
02311 do_fio(&c__1, (char *)&nc, (ftnlen)
02312 sizeof(integer));
02313 do_fio(&c__1, sname, (ftnlen)6);
02314 do_fio(&c__1, uplo, (ftnlen)1);
02315 do_fio(&c__1, trans, (ftnlen)1);
02316 do_fio(&c__1, diag, (ftnlen)1);
02317 do_fio(&c__1, (char *)&n, (ftnlen)
02318 sizeof(integer));
02319 do_fio(&c__1, (char *)&incx, (ftnlen)
02320 sizeof(integer));
02321 e_wsfe();
02322 }
02323 if (*rewi) {
02324 al__1.aerr = 0;
02325 al__1.aunit = *ntra;
02326 f_rew(&al__1);
02327 }
02328 ztpmv_(uplo, trans, diag, &n, &aa[1], &xx[
02329 1], &incx);
02330 }
02331 } else if (s_cmp(sname + 3, "SV", (ftnlen)2, (
02332 ftnlen)2) == 0) {
02333 if (full) {
02334 if (*trace) {
02335 io___242.ciunit = *ntra;
02336 s_wsfe(&io___242);
02337 do_fio(&c__1, (char *)&nc, (ftnlen)
02338 sizeof(integer));
02339 do_fio(&c__1, sname, (ftnlen)6);
02340 do_fio(&c__1, uplo, (ftnlen)1);
02341 do_fio(&c__1, trans, (ftnlen)1);
02342 do_fio(&c__1, diag, (ftnlen)1);
02343 do_fio(&c__1, (char *)&n, (ftnlen)
02344 sizeof(integer));
02345 do_fio(&c__1, (char *)&lda, (ftnlen)
02346 sizeof(integer));
02347 do_fio(&c__1, (char *)&incx, (ftnlen)
02348 sizeof(integer));
02349 e_wsfe();
02350 }
02351 if (*rewi) {
02352 al__1.aerr = 0;
02353 al__1.aunit = *ntra;
02354 f_rew(&al__1);
02355 }
02356 ztrsv_(uplo, trans, diag, &n, &aa[1], &
02357 lda, &xx[1], &incx);
02358 } else if (banded) {
02359 if (*trace) {
02360 io___243.ciunit = *ntra;
02361 s_wsfe(&io___243);
02362 do_fio(&c__1, (char *)&nc, (ftnlen)
02363 sizeof(integer));
02364 do_fio(&c__1, sname, (ftnlen)6);
02365 do_fio(&c__1, uplo, (ftnlen)1);
02366 do_fio(&c__1, trans, (ftnlen)1);
02367 do_fio(&c__1, diag, (ftnlen)1);
02368 do_fio(&c__1, (char *)&n, (ftnlen)
02369 sizeof(integer));
02370 do_fio(&c__1, (char *)&k, (ftnlen)
02371 sizeof(integer));
02372 do_fio(&c__1, (char *)&lda, (ftnlen)
02373 sizeof(integer));
02374 do_fio(&c__1, (char *)&incx, (ftnlen)
02375 sizeof(integer));
02376 e_wsfe();
02377 }
02378 if (*rewi) {
02379 al__1.aerr = 0;
02380 al__1.aunit = *ntra;
02381 f_rew(&al__1);
02382 }
02383 ztbsv_(uplo, trans, diag, &n, &k, &aa[1],
02384 &lda, &xx[1], &incx);
02385 } else if (packed) {
02386 if (*trace) {
02387 io___244.ciunit = *ntra;
02388 s_wsfe(&io___244);
02389 do_fio(&c__1, (char *)&nc, (ftnlen)
02390 sizeof(integer));
02391 do_fio(&c__1, sname, (ftnlen)6);
02392 do_fio(&c__1, uplo, (ftnlen)1);
02393 do_fio(&c__1, trans, (ftnlen)1);
02394 do_fio(&c__1, diag, (ftnlen)1);
02395 do_fio(&c__1, (char *)&n, (ftnlen)
02396 sizeof(integer));
02397 do_fio(&c__1, (char *)&incx, (ftnlen)
02398 sizeof(integer));
02399 e_wsfe();
02400 }
02401 if (*rewi) {
02402 al__1.aerr = 0;
02403 al__1.aunit = *ntra;
02404 f_rew(&al__1);
02405 }
02406 ztpsv_(uplo, trans, diag, &n, &aa[1], &xx[
02407 1], &incx);
02408 }
02409 }
02410
02411
02412
02413 if (! infoc_1.ok) {
02414 io___245.ciunit = *nout;
02415 s_wsfe(&io___245);
02416 e_wsfe();
02417 *fatal = TRUE_;
02418 goto L120;
02419 }
02420
02421
02422
02423 isame[0] = *(unsigned char *)uplo == *(unsigned
02424 char *)uplos;
02425 isame[1] = *(unsigned char *)trans == *(unsigned
02426 char *)transs;
02427 isame[2] = *(unsigned char *)diag == *(unsigned
02428 char *)diags;
02429 isame[3] = ns == n;
02430 if (full) {
02431 isame[4] = lze_(&as[1], &aa[1], &laa);
02432 isame[5] = ldas == lda;
02433 if (null) {
02434 isame[6] = lze_(&xs[1], &xx[1], &lx);
02435 } else {
02436 i__4 = abs(incx);
02437 isame[6] = lzeres_("GE", " ", &c__1, &n, &
02438 xs[1], &xx[1], &i__4, (ftnlen)2, (
02439 ftnlen)1);
02440 }
02441 isame[7] = incxs == incx;
02442 } else if (banded) {
02443 isame[4] = ks == k;
02444 isame[5] = lze_(&as[1], &aa[1], &laa);
02445 isame[6] = ldas == lda;
02446 if (null) {
02447 isame[7] = lze_(&xs[1], &xx[1], &lx);
02448 } else {
02449 i__4 = abs(incx);
02450 isame[7] = lzeres_("GE", " ", &c__1, &n, &
02451 xs[1], &xx[1], &i__4, (ftnlen)2, (
02452 ftnlen)1);
02453 }
02454 isame[8] = incxs == incx;
02455 } else if (packed) {
02456 isame[4] = lze_(&as[1], &aa[1], &laa);
02457 if (null) {
02458 isame[5] = lze_(&xs[1], &xx[1], &lx);
02459 } else {
02460 i__4 = abs(incx);
02461 isame[5] = lzeres_("GE", " ", &c__1, &n, &
02462 xs[1], &xx[1], &i__4, (ftnlen)2, (
02463 ftnlen)1);
02464 }
02465 isame[6] = incxs == incx;
02466 }
02467
02468
02469
02470
02471 same = TRUE_;
02472 i__4 = nargs;
02473 for (i__ = 1; i__ <= i__4; ++i__) {
02474 same = same && isame[i__ - 1];
02475 if (! isame[i__ - 1]) {
02476 io___248.ciunit = *nout;
02477 s_wsfe(&io___248);
02478 do_fio(&c__1, (char *)&i__, (ftnlen)
02479 sizeof(integer));
02480 e_wsfe();
02481 }
02482
02483 }
02484 if (! same) {
02485 *fatal = TRUE_;
02486 goto L120;
02487 }
02488
02489 if (! null) {
02490 if (s_cmp(sname + 3, "MV", (ftnlen)2, (ftnlen)
02491 2) == 0) {
02492
02493
02494
02495 zmvch_(trans, &n, &n, &c_b2, &a[a_offset],
02496 nmax, &x[1], &incx, &c_b1, &z__[
02497 1], &incx, &xt[1], &g[1], &xx[1],
02498 eps, &err, fatal, nout, &c_true, (
02499 ftnlen)1);
02500 } else if (s_cmp(sname + 3, "SV", (ftnlen)2, (
02501 ftnlen)2) == 0) {
02502
02503
02504
02505 i__4 = n;
02506 for (i__ = 1; i__ <= i__4; ++i__) {
02507 i__5 = i__;
02508 i__6 = (i__ - 1) * abs(incx) + 1;
02509 z__[i__5].r = xx[i__6].r, z__[i__5].i
02510 = xx[i__6].i;
02511 i__5 = (i__ - 1) * abs(incx) + 1;
02512 i__6 = i__;
02513 xx[i__5].r = x[i__6].r, xx[i__5].i =
02514 x[i__6].i;
02515
02516 }
02517 zmvch_(trans, &n, &n, &c_b2, &a[a_offset],
02518 nmax, &z__[1], &incx, &c_b1, &x[
02519 1], &incx, &xt[1], &g[1], &xx[1],
02520 eps, &err, fatal, nout, &c_false,
02521 (ftnlen)1);
02522 }
02523 errmax = max(errmax,err);
02524
02525 if (*fatal) {
02526 goto L120;
02527 }
02528 } else {
02529
02530 goto L110;
02531 }
02532
02533
02534 }
02535
02536
02537 }
02538
02539
02540 }
02541
02542
02543 }
02544
02545 L100:
02546 ;
02547 }
02548
02549 L110:
02550 ;
02551 }
02552
02553
02554
02555 if (errmax < *thresh) {
02556 io___250.ciunit = *nout;
02557 s_wsfe(&io___250);
02558 do_fio(&c__1, sname, (ftnlen)6);
02559 do_fio(&c__1, (char *)&nc, (ftnlen)sizeof(integer));
02560 e_wsfe();
02561 } else {
02562 io___251.ciunit = *nout;
02563 s_wsfe(&io___251);
02564 do_fio(&c__1, sname, (ftnlen)6);
02565 do_fio(&c__1, (char *)&nc, (ftnlen)sizeof(integer));
02566 do_fio(&c__1, (char *)&errmax, (ftnlen)sizeof(doublereal));
02567 e_wsfe();
02568 }
02569 goto L130;
02570
02571 L120:
02572 io___252.ciunit = *nout;
02573 s_wsfe(&io___252);
02574 do_fio(&c__1, sname, (ftnlen)6);
02575 e_wsfe();
02576 if (full) {
02577 io___253.ciunit = *nout;
02578 s_wsfe(&io___253);
02579 do_fio(&c__1, (char *)&nc, (ftnlen)sizeof(integer));
02580 do_fio(&c__1, sname, (ftnlen)6);
02581 do_fio(&c__1, uplo, (ftnlen)1);
02582 do_fio(&c__1, trans, (ftnlen)1);
02583 do_fio(&c__1, diag, (ftnlen)1);
02584 do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
02585 do_fio(&c__1, (char *)&lda, (ftnlen)sizeof(integer));
02586 do_fio(&c__1, (char *)&incx, (ftnlen)sizeof(integer));
02587 e_wsfe();
02588 } else if (banded) {
02589 io___254.ciunit = *nout;
02590 s_wsfe(&io___254);
02591 do_fio(&c__1, (char *)&nc, (ftnlen)sizeof(integer));
02592 do_fio(&c__1, sname, (ftnlen)6);
02593 do_fio(&c__1, uplo, (ftnlen)1);
02594 do_fio(&c__1, trans, (ftnlen)1);
02595 do_fio(&c__1, diag, (ftnlen)1);
02596 do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
02597 do_fio(&c__1, (char *)&k, (ftnlen)sizeof(integer));
02598 do_fio(&c__1, (char *)&lda, (ftnlen)sizeof(integer));
02599 do_fio(&c__1, (char *)&incx, (ftnlen)sizeof(integer));
02600 e_wsfe();
02601 } else if (packed) {
02602 io___255.ciunit = *nout;
02603 s_wsfe(&io___255);
02604 do_fio(&c__1, (char *)&nc, (ftnlen)sizeof(integer));
02605 do_fio(&c__1, sname, (ftnlen)6);
02606 do_fio(&c__1, uplo, (ftnlen)1);
02607 do_fio(&c__1, trans, (ftnlen)1);
02608 do_fio(&c__1, diag, (ftnlen)1);
02609 do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
02610 do_fio(&c__1, (char *)&incx, (ftnlen)sizeof(integer));
02611 e_wsfe();
02612 }
02613
02614 L130:
02615 return 0;
02616
02617
02618
02619
02620 }
02621
02622 int zchk4_(char *sname, doublereal *eps, doublereal *thresh,
02623 integer *nout, integer *ntra, logical *trace, logical *rewi, logical *
02624 fatal, integer *nidim, integer *idim, integer *nalf, doublecomplex *
02625 alf, integer *ninc, integer *inc, integer *nmax, integer *incmax,
02626 doublecomplex *a, doublecomplex *aa, doublecomplex *as, doublecomplex
02627 *x, doublecomplex *xx, doublecomplex *xs, doublecomplex *y,
02628 doublecomplex *yy, doublecomplex *ys, doublecomplex *yt, doublereal *
02629 g, doublecomplex *z__, ftnlen sname_len)
02630 {
02631
02632 static char fmt_9994[] = "(1x,i6,\002: \002,a6,\002(\002,2(i3,\002,"
02633 "\002),\002(\002,f4.1,\002,\002,f4.1,\002), X,\002,i2,\002, Y,"
02634 "\002,i2,\002, A,\002,i3,\002) \002,\002 "
02635 ".\002)";
02636 static char fmt_9993[] = "(\002 ******* FATAL ERROR - ERROR-EXIT TAKEN O"
02637 "N VALID CALL *\002,\002******\002)";
02638 static char fmt_9998[] = "(\002 ******* FATAL ERROR - PARAMETER NUMBER"
02639 " \002,i2,\002 WAS CH\002,\002ANGED INCORRECTLY *******\002)";
02640 static char fmt_9999[] = "(\002 \002,a6,\002 PASSED THE COMPUTATIONAL TE"
02641 "STS (\002,i6,\002 CALL\002,\002S)\002)";
02642 static char fmt_9997[] = "(\002 \002,a6,\002 COMPLETED THE COMPUTATIONAL"
02643 " TESTS (\002,i6,\002 C\002,\002ALLS)\002,/\002 ******* BUT WITH "
02644 "MAXIMUM TEST RATIO\002,f8.2,\002 - SUSPECT *******\002)";
02645 static char fmt_9995[] = "(\002 THESE ARE THE RESULTS FOR COLUMN"
02646 " \002,i3)";
02647 static char fmt_9996[] = "(\002 ******* \002,a6,\002 FAILED ON CALL NUMB"
02648 "ER:\002)";
02649
02650
02651 integer a_dim1, a_offset, i__1, i__2, i__3, i__4, i__5, i__6, i__7;
02652 doublecomplex z__1;
02653 alist al__1;
02654
02655
02656 integer s_wsfe(cilist *), do_fio(integer *, char *, ftnlen), e_wsfe(void),
02657 f_rew(alist *);
02658 void d_cnjg(doublecomplex *, doublecomplex *);
02659
02660
02661 integer i__, j, m, n;
02662 doublecomplex w[1];
02663 integer ia, nc, nd, im, in, ms, ix, iy, ns, lx, ly, laa, lda;
02664 doublecomplex als;
02665 doublereal err;
02666 extern logical lze_(doublecomplex *, doublecomplex *, integer *);
02667 integer ldas;
02668 logical same, conj;
02669 integer incx, incy;
02670 logical null;
02671 doublecomplex alpha;
02672 logical isame[13];
02673 extern int zmake_(char *, char *, char *, integer *,
02674 integer *, doublecomplex *, integer *, doublecomplex *, integer *,
02675 integer *, integer *, logical *, doublecomplex *, ftnlen, ftnlen,
02676 ftnlen);
02677 integer nargs;
02678 extern int zgerc_(integer *, integer *, doublecomplex *,
02679 doublecomplex *, integer *, doublecomplex *, integer *,
02680 doublecomplex *, integer *);
02681 logical reset;
02682 integer incxs, incys;
02683 extern int zmvch_(char *, integer *, integer *,
02684 doublecomplex *, doublecomplex *, integer *, doublecomplex *,
02685 integer *, doublecomplex *, doublecomplex *, integer *,
02686 doublecomplex *, doublereal *, doublecomplex *, doublereal *,
02687 doublereal *, logical *, integer *, logical *, ftnlen), zgeru_(
02688 integer *, integer *, doublecomplex *, doublecomplex *, integer *,
02689 doublecomplex *, integer *, doublecomplex *, integer *);
02690 doublereal errmax;
02691 doublecomplex transl;
02692 extern logical lzeres_(char *, char *, integer *, integer *,
02693 doublecomplex *, doublecomplex *, integer *, ftnlen, ftnlen);
02694
02695
02696 static cilist io___285 = { 0, 0, 0, fmt_9994, 0 };
02697 static cilist io___286 = { 0, 0, 0, fmt_9993, 0 };
02698 static cilist io___289 = { 0, 0, 0, fmt_9998, 0 };
02699 static cilist io___293 = { 0, 0, 0, fmt_9999, 0 };
02700 static cilist io___294 = { 0, 0, 0, fmt_9997, 0 };
02701 static cilist io___295 = { 0, 0, 0, fmt_9995, 0 };
02702 static cilist io___296 = { 0, 0, 0, fmt_9996, 0 };
02703 static cilist io___297 = { 0, 0, 0, fmt_9994, 0 };
02704
02705
02706
02707
02708
02709
02710
02711
02712
02713
02714
02715
02716
02717
02718
02719
02720
02721
02722
02723
02724
02725
02726
02727 --idim;
02728 --alf;
02729 --inc;
02730 --z__;
02731 --g;
02732 --yt;
02733 --y;
02734 --x;
02735 --as;
02736 --aa;
02737 a_dim1 = *nmax;
02738 a_offset = 1 + a_dim1;
02739 a -= a_offset;
02740 --ys;
02741 --yy;
02742 --xs;
02743 --xx;
02744
02745
02746 conj = *(unsigned char *)&sname[4] == 'C';
02747
02748 nargs = 9;
02749
02750 nc = 0;
02751 reset = TRUE_;
02752 errmax = 0.;
02753
02754 i__1 = *nidim;
02755 for (in = 1; in <= i__1; ++in) {
02756 n = idim[in];
02757 nd = n / 2 + 1;
02758
02759 for (im = 1; im <= 2; ++im) {
02760 if (im == 1) {
02761
02762 i__2 = n - nd;
02763 m = max(i__2,0);
02764 }
02765 if (im == 2) {
02766
02767 i__2 = n + nd;
02768 m = min(i__2,*nmax);
02769 }
02770
02771
02772 lda = m;
02773 if (lda < *nmax) {
02774 ++lda;
02775 }
02776
02777 if (lda > *nmax) {
02778 goto L110;
02779 }
02780 laa = lda * n;
02781 null = n <= 0 || m <= 0;
02782
02783 i__2 = *ninc;
02784 for (ix = 1; ix <= i__2; ++ix) {
02785 incx = inc[ix];
02786 lx = abs(incx) * m;
02787
02788
02789
02790 transl.r = .5, transl.i = 0.;
02791 i__3 = abs(incx);
02792 i__4 = m - 1;
02793 zmake_("GE", " ", " ", &c__1, &m, &x[1], &c__1, &xx[1], &i__3,
02794 &c__0, &i__4, &reset, &transl, (ftnlen)2, (ftnlen)1,
02795 (ftnlen)1);
02796 if (m > 1) {
02797 i__3 = m / 2;
02798 x[i__3].r = 0., x[i__3].i = 0.;
02799 i__3 = abs(incx) * (m / 2 - 1) + 1;
02800 xx[i__3].r = 0., xx[i__3].i = 0.;
02801 }
02802
02803 i__3 = *ninc;
02804 for (iy = 1; iy <= i__3; ++iy) {
02805 incy = inc[iy];
02806 ly = abs(incy) * n;
02807
02808
02809
02810 transl.r = 0., transl.i = 0.;
02811 i__4 = abs(incy);
02812 i__5 = n - 1;
02813 zmake_("GE", " ", " ", &c__1, &n, &y[1], &c__1, &yy[1], &
02814 i__4, &c__0, &i__5, &reset, &transl, (ftnlen)2, (
02815 ftnlen)1, (ftnlen)1);
02816 if (n > 1) {
02817 i__4 = n / 2;
02818 y[i__4].r = 0., y[i__4].i = 0.;
02819 i__4 = abs(incy) * (n / 2 - 1) + 1;
02820 yy[i__4].r = 0., yy[i__4].i = 0.;
02821 }
02822
02823 i__4 = *nalf;
02824 for (ia = 1; ia <= i__4; ++ia) {
02825 i__5 = ia;
02826 alpha.r = alf[i__5].r, alpha.i = alf[i__5].i;
02827
02828
02829
02830 transl.r = 0., transl.i = 0.;
02831 i__5 = m - 1;
02832 i__6 = n - 1;
02833 zmake_(sname + 1, " ", " ", &m, &n, &a[a_offset],
02834 nmax, &aa[1], &lda, &i__5, &i__6, &reset, &
02835 transl, (ftnlen)2, (ftnlen)1, (ftnlen)1);
02836
02837 ++nc;
02838
02839
02840
02841 ms = m;
02842 ns = n;
02843 als.r = alpha.r, als.i = alpha.i;
02844 i__5 = laa;
02845 for (i__ = 1; i__ <= i__5; ++i__) {
02846 i__6 = i__;
02847 i__7 = i__;
02848 as[i__6].r = aa[i__7].r, as[i__6].i = aa[i__7].i;
02849
02850 }
02851 ldas = lda;
02852 i__5 = lx;
02853 for (i__ = 1; i__ <= i__5; ++i__) {
02854 i__6 = i__;
02855 i__7 = i__;
02856 xs[i__6].r = xx[i__7].r, xs[i__6].i = xx[i__7].i;
02857
02858 }
02859 incxs = incx;
02860 i__5 = ly;
02861 for (i__ = 1; i__ <= i__5; ++i__) {
02862 i__6 = i__;
02863 i__7 = i__;
02864 ys[i__6].r = yy[i__7].r, ys[i__6].i = yy[i__7].i;
02865
02866 }
02867 incys = incy;
02868
02869
02870
02871 if (*trace) {
02872 io___285.ciunit = *ntra;
02873 s_wsfe(&io___285);
02874 do_fio(&c__1, (char *)&nc, (ftnlen)sizeof(integer)
02875 );
02876 do_fio(&c__1, sname, (ftnlen)6);
02877 do_fio(&c__1, (char *)&m, (ftnlen)sizeof(integer))
02878 ;
02879 do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer))
02880 ;
02881 do_fio(&c__2, (char *)&alpha, (ftnlen)sizeof(
02882 doublereal));
02883 do_fio(&c__1, (char *)&incx, (ftnlen)sizeof(
02884 integer));
02885 do_fio(&c__1, (char *)&incy, (ftnlen)sizeof(
02886 integer));
02887 do_fio(&c__1, (char *)&lda, (ftnlen)sizeof(
02888 integer));
02889 e_wsfe();
02890 }
02891 if (conj) {
02892 if (*rewi) {
02893 al__1.aerr = 0;
02894 al__1.aunit = *ntra;
02895 f_rew(&al__1);
02896 }
02897 zgerc_(&m, &n, &alpha, &xx[1], &incx, &yy[1], &
02898 incy, &aa[1], &lda);
02899 } else {
02900 if (*rewi) {
02901 al__1.aerr = 0;
02902 al__1.aunit = *ntra;
02903 f_rew(&al__1);
02904 }
02905 zgeru_(&m, &n, &alpha, &xx[1], &incx, &yy[1], &
02906 incy, &aa[1], &lda);
02907 }
02908
02909
02910
02911 if (! infoc_1.ok) {
02912 io___286.ciunit = *nout;
02913 s_wsfe(&io___286);
02914 e_wsfe();
02915 *fatal = TRUE_;
02916 goto L140;
02917 }
02918
02919
02920
02921 isame[0] = ms == m;
02922 isame[1] = ns == n;
02923 isame[2] = als.r == alpha.r && als.i == alpha.i;
02924 isame[3] = lze_(&xs[1], &xx[1], &lx);
02925 isame[4] = incxs == incx;
02926 isame[5] = lze_(&ys[1], &yy[1], &ly);
02927 isame[6] = incys == incy;
02928 if (null) {
02929 isame[7] = lze_(&as[1], &aa[1], &laa);
02930 } else {
02931 isame[7] = lzeres_("GE", " ", &m, &n, &as[1], &aa[
02932 1], &lda, (ftnlen)2, (ftnlen)1);
02933 }
02934 isame[8] = ldas == lda;
02935
02936
02937
02938 same = TRUE_;
02939 i__5 = nargs;
02940 for (i__ = 1; i__ <= i__5; ++i__) {
02941 same = same && isame[i__ - 1];
02942 if (! isame[i__ - 1]) {
02943 io___289.ciunit = *nout;
02944 s_wsfe(&io___289);
02945 do_fio(&c__1, (char *)&i__, (ftnlen)sizeof(
02946 integer));
02947 e_wsfe();
02948 }
02949
02950 }
02951 if (! same) {
02952 *fatal = TRUE_;
02953 goto L140;
02954 }
02955
02956 if (! null) {
02957
02958
02959
02960 if (incx > 0) {
02961 i__5 = m;
02962 for (i__ = 1; i__ <= i__5; ++i__) {
02963 i__6 = i__;
02964 i__7 = i__;
02965 z__[i__6].r = x[i__7].r, z__[i__6].i = x[
02966 i__7].i;
02967
02968 }
02969 } else {
02970 i__5 = m;
02971 for (i__ = 1; i__ <= i__5; ++i__) {
02972 i__6 = i__;
02973 i__7 = m - i__ + 1;
02974 z__[i__6].r = x[i__7].r, z__[i__6].i = x[
02975 i__7].i;
02976
02977 }
02978 }
02979 i__5 = n;
02980 for (j = 1; j <= i__5; ++j) {
02981 if (incy > 0) {
02982 i__6 = j;
02983 w[0].r = y[i__6].r, w[0].i = y[i__6].i;
02984 } else {
02985 i__6 = n - j + 1;
02986 w[0].r = y[i__6].r, w[0].i = y[i__6].i;
02987 }
02988 if (conj) {
02989 d_cnjg(&z__1, w);
02990 w[0].r = z__1.r, w[0].i = z__1.i;
02991 }
02992 zmvch_("N", &m, &c__1, &alpha, &z__[1], nmax,
02993 w, &c__1, &c_b2, &a[j * a_dim1 + 1], &
02994 c__1, &yt[1], &g[1], &aa[(j - 1) *
02995 lda + 1], eps, &err, fatal, nout, &
02996 c_true, (ftnlen)1);
02997 errmax = max(errmax,err);
02998
02999 if (*fatal) {
03000 goto L130;
03001 }
03002
03003 }
03004 } else {
03005
03006 goto L110;
03007 }
03008
03009
03010 }
03011
03012
03013 }
03014
03015
03016 }
03017
03018 L110:
03019 ;
03020 }
03021
03022
03023 }
03024
03025
03026
03027 if (errmax < *thresh) {
03028 io___293.ciunit = *nout;
03029 s_wsfe(&io___293);
03030 do_fio(&c__1, sname, (ftnlen)6);
03031 do_fio(&c__1, (char *)&nc, (ftnlen)sizeof(integer));
03032 e_wsfe();
03033 } else {
03034 io___294.ciunit = *nout;
03035 s_wsfe(&io___294);
03036 do_fio(&c__1, sname, (ftnlen)6);
03037 do_fio(&c__1, (char *)&nc, (ftnlen)sizeof(integer));
03038 do_fio(&c__1, (char *)&errmax, (ftnlen)sizeof(doublereal));
03039 e_wsfe();
03040 }
03041 goto L150;
03042
03043 L130:
03044 io___295.ciunit = *nout;
03045 s_wsfe(&io___295);
03046 do_fio(&c__1, (char *)&j, (ftnlen)sizeof(integer));
03047 e_wsfe();
03048
03049 L140:
03050 io___296.ciunit = *nout;
03051 s_wsfe(&io___296);
03052 do_fio(&c__1, sname, (ftnlen)6);
03053 e_wsfe();
03054 io___297.ciunit = *nout;
03055 s_wsfe(&io___297);
03056 do_fio(&c__1, (char *)&nc, (ftnlen)sizeof(integer));
03057 do_fio(&c__1, sname, (ftnlen)6);
03058 do_fio(&c__1, (char *)&m, (ftnlen)sizeof(integer));
03059 do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
03060 do_fio(&c__2, (char *)&alpha, (ftnlen)sizeof(doublereal));
03061 do_fio(&c__1, (char *)&incx, (ftnlen)sizeof(integer));
03062 do_fio(&c__1, (char *)&incy, (ftnlen)sizeof(integer));
03063 do_fio(&c__1, (char *)&lda, (ftnlen)sizeof(integer));
03064 e_wsfe();
03065
03066 L150:
03067 return 0;
03068
03069
03070
03071
03072 }
03073
03074 int zchk5_(char *sname, doublereal *eps, doublereal *thresh,
03075 integer *nout, integer *ntra, logical *trace, logical *rewi, logical *
03076 fatal, integer *nidim, integer *idim, integer *nalf, doublecomplex *
03077 alf, integer *ninc, integer *inc, integer *nmax, integer *incmax,
03078 doublecomplex *a, doublecomplex *aa, doublecomplex *as, doublecomplex
03079 *x, doublecomplex *xx, doublecomplex *xs, doublecomplex *y,
03080 doublecomplex *yy, doublecomplex *ys, doublecomplex *yt, doublereal *
03081 g, doublecomplex *z__, ftnlen sname_len)
03082 {
03083
03084
03085 static char ich[2] = "UL";
03086
03087
03088 static char fmt_9993[] = "(1x,i6,\002: \002,a6,\002('\002,a1,\002',\002,"
03089 "i3,\002,\002,f4.1,\002, X,\002,i2,\002, A,\002,i3,\002) "
03090 " .\002)";
03091 static char fmt_9994[] = "(1x,i6,\002: \002,a6,\002('\002,a1,\002',\002,"
03092 "i3,\002,\002,f4.1,\002, X,\002,i2,\002, AP) "
03093 " .\002)";
03094 static char fmt_9992[] = "(\002 ******* FATAL ERROR - ERROR-EXIT TAKEN O"
03095 "N VALID CALL *\002,\002******\002)";
03096 static char fmt_9998[] = "(\002 ******* FATAL ERROR - PARAMETER NUMBER"
03097 " \002,i2,\002 WAS CH\002,\002ANGED INCORRECTLY *******\002)";
03098 static char fmt_9999[] = "(\002 \002,a6,\002 PASSED THE COMPUTATIONAL TE"
03099 "STS (\002,i6,\002 CALL\002,\002S)\002)";
03100 static char fmt_9997[] = "(\002 \002,a6,\002 COMPLETED THE COMPUTATIONAL"
03101 " TESTS (\002,i6,\002 C\002,\002ALLS)\002,/\002 ******* BUT WITH "
03102 "MAXIMUM TEST RATIO\002,f8.2,\002 - SUSPECT *******\002)";
03103 static char fmt_9995[] = "(\002 THESE ARE THE RESULTS FOR COLUMN"
03104 " \002,i3)";
03105 static char fmt_9996[] = "(\002 ******* \002,a6,\002 FAILED ON CALL NUMB"
03106 "ER:\002)";
03107
03108
03109 integer a_dim1, a_offset, i__1, i__2, i__3, i__4, i__5, i__6;
03110 doublecomplex z__1;
03111 alist al__1;
03112
03113
03114 integer s_wsfe(cilist *), do_fio(integer *, char *, ftnlen), e_wsfe(void),
03115 f_rew(alist *);
03116 void d_cnjg(doublecomplex *, doublecomplex *);
03117
03118
03119 integer i__, j, n;
03120 doublecomplex w[1];
03121 integer ia, ja, ic, nc, jj, lj, in, ix, ns, lx, laa, lda;
03122 doublereal err;
03123 extern logical lze_(doublecomplex *, doublecomplex *, integer *);
03124 integer ldas;
03125 logical same;
03126 doublereal rals;
03127 integer incx;
03128 logical full;
03129 extern int zher_(char *, integer *, doublereal *,
03130 doublecomplex *, integer *, doublecomplex *, integer *);
03131 logical null;
03132 char uplo[1];
03133 extern int zhpr_(char *, integer *, doublereal *,
03134 doublecomplex *, integer *, doublecomplex *);
03135 doublecomplex alpha;
03136 logical isame[13];
03137 extern int zmake_(char *, char *, char *, integer *,
03138 integer *, doublecomplex *, integer *, doublecomplex *, integer *,
03139 integer *, integer *, logical *, doublecomplex *, ftnlen, ftnlen,
03140 ftnlen);
03141 integer nargs;
03142 logical reset;
03143 integer incxs;
03144 extern int zmvch_(char *, integer *, integer *,
03145 doublecomplex *, doublecomplex *, integer *, doublecomplex *,
03146 integer *, doublecomplex *, doublecomplex *, integer *,
03147 doublecomplex *, doublereal *, doublecomplex *, doublereal *,
03148 doublereal *, logical *, integer *, logical *, ftnlen);
03149 logical upper;
03150 char uplos[1];
03151 logical packed;
03152 doublereal ralpha, errmax;
03153 doublecomplex transl;
03154 extern logical lzeres_(char *, char *, integer *, integer *,
03155 doublecomplex *, doublecomplex *, integer *, ftnlen, ftnlen);
03156
03157
03158 static cilist io___326 = { 0, 0, 0, fmt_9993, 0 };
03159 static cilist io___327 = { 0, 0, 0, fmt_9994, 0 };
03160 static cilist io___328 = { 0, 0, 0, fmt_9992, 0 };
03161 static cilist io___331 = { 0, 0, 0, fmt_9998, 0 };
03162 static cilist io___338 = { 0, 0, 0, fmt_9999, 0 };
03163 static cilist io___339 = { 0, 0, 0, fmt_9997, 0 };
03164 static cilist io___340 = { 0, 0, 0, fmt_9995, 0 };
03165 static cilist io___341 = { 0, 0, 0, fmt_9996, 0 };
03166 static cilist io___342 = { 0, 0, 0, fmt_9993, 0 };
03167 static cilist io___343 = { 0, 0, 0, fmt_9994, 0 };
03168
03169
03170
03171
03172
03173
03174
03175
03176
03177
03178
03179
03180
03181
03182
03183
03184
03185
03186
03187
03188
03189
03190
03191 --idim;
03192 --alf;
03193 --inc;
03194 --z__;
03195 --g;
03196 --yt;
03197 --y;
03198 --x;
03199 --as;
03200 --aa;
03201 a_dim1 = *nmax;
03202 a_offset = 1 + a_dim1;
03203 a -= a_offset;
03204 --ys;
03205 --yy;
03206 --xs;
03207 --xx;
03208
03209
03210
03211 full = *(unsigned char *)&sname[2] == 'E';
03212 packed = *(unsigned char *)&sname[2] == 'P';
03213
03214 if (full) {
03215 nargs = 7;
03216 } else if (packed) {
03217 nargs = 6;
03218 }
03219
03220 nc = 0;
03221 reset = TRUE_;
03222 errmax = 0.;
03223
03224 i__1 = *nidim;
03225 for (in = 1; in <= i__1; ++in) {
03226 n = idim[in];
03227
03228 lda = n;
03229 if (lda < *nmax) {
03230 ++lda;
03231 }
03232
03233 if (lda > *nmax) {
03234 goto L100;
03235 }
03236 if (packed) {
03237 laa = n * (n + 1) / 2;
03238 } else {
03239 laa = lda * n;
03240 }
03241
03242 for (ic = 1; ic <= 2; ++ic) {
03243 *(unsigned char *)uplo = *(unsigned char *)&ich[ic - 1];
03244 upper = *(unsigned char *)uplo == 'U';
03245
03246 i__2 = *ninc;
03247 for (ix = 1; ix <= i__2; ++ix) {
03248 incx = inc[ix];
03249 lx = abs(incx) * n;
03250
03251
03252
03253 transl.r = .5, transl.i = 0.;
03254 i__3 = abs(incx);
03255 i__4 = n - 1;
03256 zmake_("GE", " ", " ", &c__1, &n, &x[1], &c__1, &xx[1], &i__3,
03257 &c__0, &i__4, &reset, &transl, (ftnlen)2, (ftnlen)1,
03258 (ftnlen)1);
03259 if (n > 1) {
03260 i__3 = n / 2;
03261 x[i__3].r = 0., x[i__3].i = 0.;
03262 i__3 = abs(incx) * (n / 2 - 1) + 1;
03263 xx[i__3].r = 0., xx[i__3].i = 0.;
03264 }
03265
03266 i__3 = *nalf;
03267 for (ia = 1; ia <= i__3; ++ia) {
03268 i__4 = ia;
03269 ralpha = alf[i__4].r;
03270 z__1.r = ralpha, z__1.i = 0.;
03271 alpha.r = z__1.r, alpha.i = z__1.i;
03272 null = n <= 0 || ralpha == 0.;
03273
03274
03275
03276 transl.r = 0., transl.i = 0.;
03277 i__4 = n - 1;
03278 i__5 = n - 1;
03279 zmake_(sname + 1, uplo, " ", &n, &n, &a[a_offset], nmax, &
03280 aa[1], &lda, &i__4, &i__5, &reset, &transl, (
03281 ftnlen)2, (ftnlen)1, (ftnlen)1);
03282
03283 ++nc;
03284
03285
03286
03287 *(unsigned char *)uplos = *(unsigned char *)uplo;
03288 ns = n;
03289 rals = ralpha;
03290 i__4 = laa;
03291 for (i__ = 1; i__ <= i__4; ++i__) {
03292 i__5 = i__;
03293 i__6 = i__;
03294 as[i__5].r = aa[i__6].r, as[i__5].i = aa[i__6].i;
03295
03296 }
03297 ldas = lda;
03298 i__4 = lx;
03299 for (i__ = 1; i__ <= i__4; ++i__) {
03300 i__5 = i__;
03301 i__6 = i__;
03302 xs[i__5].r = xx[i__6].r, xs[i__5].i = xx[i__6].i;
03303
03304 }
03305 incxs = incx;
03306
03307
03308
03309 if (full) {
03310 if (*trace) {
03311 io___326.ciunit = *ntra;
03312 s_wsfe(&io___326);
03313 do_fio(&c__1, (char *)&nc, (ftnlen)sizeof(integer)
03314 );
03315 do_fio(&c__1, sname, (ftnlen)6);
03316 do_fio(&c__1, uplo, (ftnlen)1);
03317 do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer))
03318 ;
03319 do_fio(&c__1, (char *)&ralpha, (ftnlen)sizeof(
03320 doublereal));
03321 do_fio(&c__1, (char *)&incx, (ftnlen)sizeof(
03322 integer));
03323 do_fio(&c__1, (char *)&lda, (ftnlen)sizeof(
03324 integer));
03325 e_wsfe();
03326 }
03327 if (*rewi) {
03328 al__1.aerr = 0;
03329 al__1.aunit = *ntra;
03330 f_rew(&al__1);
03331 }
03332 zher_(uplo, &n, &ralpha, &xx[1], &incx, &aa[1], &lda);
03333 } else if (packed) {
03334 if (*trace) {
03335 io___327.ciunit = *ntra;
03336 s_wsfe(&io___327);
03337 do_fio(&c__1, (char *)&nc, (ftnlen)sizeof(integer)
03338 );
03339 do_fio(&c__1, sname, (ftnlen)6);
03340 do_fio(&c__1, uplo, (ftnlen)1);
03341 do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer))
03342 ;
03343 do_fio(&c__1, (char *)&ralpha, (ftnlen)sizeof(
03344 doublereal));
03345 do_fio(&c__1, (char *)&incx, (ftnlen)sizeof(
03346 integer));
03347 e_wsfe();
03348 }
03349 if (*rewi) {
03350 al__1.aerr = 0;
03351 al__1.aunit = *ntra;
03352 f_rew(&al__1);
03353 }
03354 zhpr_(uplo, &n, &ralpha, &xx[1], &incx, &aa[1]);
03355 }
03356
03357
03358
03359 if (! infoc_1.ok) {
03360 io___328.ciunit = *nout;
03361 s_wsfe(&io___328);
03362 e_wsfe();
03363 *fatal = TRUE_;
03364 goto L120;
03365 }
03366
03367
03368
03369 isame[0] = *(unsigned char *)uplo == *(unsigned char *)
03370 uplos;
03371 isame[1] = ns == n;
03372 isame[2] = rals == ralpha;
03373 isame[3] = lze_(&xs[1], &xx[1], &lx);
03374 isame[4] = incxs == incx;
03375 if (null) {
03376 isame[5] = lze_(&as[1], &aa[1], &laa);
03377 } else {
03378 isame[5] = lzeres_(sname + 1, uplo, &n, &n, &as[1], &
03379 aa[1], &lda, (ftnlen)2, (ftnlen)1);
03380 }
03381 if (! packed) {
03382 isame[6] = ldas == lda;
03383 }
03384
03385
03386
03387 same = TRUE_;
03388 i__4 = nargs;
03389 for (i__ = 1; i__ <= i__4; ++i__) {
03390 same = same && isame[i__ - 1];
03391 if (! isame[i__ - 1]) {
03392 io___331.ciunit = *nout;
03393 s_wsfe(&io___331);
03394 do_fio(&c__1, (char *)&i__, (ftnlen)sizeof(
03395 integer));
03396 e_wsfe();
03397 }
03398
03399 }
03400 if (! same) {
03401 *fatal = TRUE_;
03402 goto L120;
03403 }
03404
03405 if (! null) {
03406
03407
03408
03409 if (incx > 0) {
03410 i__4 = n;
03411 for (i__ = 1; i__ <= i__4; ++i__) {
03412 i__5 = i__;
03413 i__6 = i__;
03414 z__[i__5].r = x[i__6].r, z__[i__5].i = x[i__6]
03415 .i;
03416
03417 }
03418 } else {
03419 i__4 = n;
03420 for (i__ = 1; i__ <= i__4; ++i__) {
03421 i__5 = i__;
03422 i__6 = n - i__ + 1;
03423 z__[i__5].r = x[i__6].r, z__[i__5].i = x[i__6]
03424 .i;
03425
03426 }
03427 }
03428 ja = 1;
03429 i__4 = n;
03430 for (j = 1; j <= i__4; ++j) {
03431 d_cnjg(&z__1, &z__[j]);
03432 w[0].r = z__1.r, w[0].i = z__1.i;
03433 if (upper) {
03434 jj = 1;
03435 lj = j;
03436 } else {
03437 jj = j;
03438 lj = n - j + 1;
03439 }
03440 zmvch_("N", &lj, &c__1, &alpha, &z__[jj], &lj, w,
03441 &c__1, &c_b2, &a[jj + j * a_dim1], &c__1,
03442 &yt[1], &g[1], &aa[ja], eps, &err, fatal,
03443 nout, &c_true, (ftnlen)1);
03444 if (full) {
03445 if (upper) {
03446 ja += lda;
03447 } else {
03448 ja = ja + lda + 1;
03449 }
03450 } else {
03451 ja += lj;
03452 }
03453 errmax = max(errmax,err);
03454
03455 if (*fatal) {
03456 goto L110;
03457 }
03458
03459 }
03460 } else {
03461
03462 if (n <= 0) {
03463 goto L100;
03464 }
03465 }
03466
03467
03468 }
03469
03470
03471 }
03472
03473
03474 }
03475
03476 L100:
03477 ;
03478 }
03479
03480
03481
03482 if (errmax < *thresh) {
03483 io___338.ciunit = *nout;
03484 s_wsfe(&io___338);
03485 do_fio(&c__1, sname, (ftnlen)6);
03486 do_fio(&c__1, (char *)&nc, (ftnlen)sizeof(integer));
03487 e_wsfe();
03488 } else {
03489 io___339.ciunit = *nout;
03490 s_wsfe(&io___339);
03491 do_fio(&c__1, sname, (ftnlen)6);
03492 do_fio(&c__1, (char *)&nc, (ftnlen)sizeof(integer));
03493 do_fio(&c__1, (char *)&errmax, (ftnlen)sizeof(doublereal));
03494 e_wsfe();
03495 }
03496 goto L130;
03497
03498 L110:
03499 io___340.ciunit = *nout;
03500 s_wsfe(&io___340);
03501 do_fio(&c__1, (char *)&j, (ftnlen)sizeof(integer));
03502 e_wsfe();
03503
03504 L120:
03505 io___341.ciunit = *nout;
03506 s_wsfe(&io___341);
03507 do_fio(&c__1, sname, (ftnlen)6);
03508 e_wsfe();
03509 if (full) {
03510 io___342.ciunit = *nout;
03511 s_wsfe(&io___342);
03512 do_fio(&c__1, (char *)&nc, (ftnlen)sizeof(integer));
03513 do_fio(&c__1, sname, (ftnlen)6);
03514 do_fio(&c__1, uplo, (ftnlen)1);
03515 do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
03516 do_fio(&c__1, (char *)&ralpha, (ftnlen)sizeof(doublereal));
03517 do_fio(&c__1, (char *)&incx, (ftnlen)sizeof(integer));
03518 do_fio(&c__1, (char *)&lda, (ftnlen)sizeof(integer));
03519 e_wsfe();
03520 } else if (packed) {
03521 io___343.ciunit = *nout;
03522 s_wsfe(&io___343);
03523 do_fio(&c__1, (char *)&nc, (ftnlen)sizeof(integer));
03524 do_fio(&c__1, sname, (ftnlen)6);
03525 do_fio(&c__1, uplo, (ftnlen)1);
03526 do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
03527 do_fio(&c__1, (char *)&ralpha, (ftnlen)sizeof(doublereal));
03528 do_fio(&c__1, (char *)&incx, (ftnlen)sizeof(integer));
03529 e_wsfe();
03530 }
03531
03532 L130:
03533 return 0;
03534
03535
03536
03537
03538 }
03539
03540 int zchk6_(char *sname, doublereal *eps, doublereal *thresh,
03541 integer *nout, integer *ntra, logical *trace, logical *rewi, logical *
03542 fatal, integer *nidim, integer *idim, integer *nalf, doublecomplex *
03543 alf, integer *ninc, integer *inc, integer *nmax, integer *incmax,
03544 doublecomplex *a, doublecomplex *aa, doublecomplex *as, doublecomplex
03545 *x, doublecomplex *xx, doublecomplex *xs, doublecomplex *y,
03546 doublecomplex *yy, doublecomplex *ys, doublecomplex *yt, doublereal *
03547 g, doublecomplex *z__, ftnlen sname_len)
03548 {
03549
03550
03551 static char ich[2] = "UL";
03552
03553
03554 static char fmt_9993[] = "(1x,i6,\002: \002,a6,\002('\002,a1,\002',\002,"
03555 "i3,\002,(\002,f4.1,\002,\002,f4.1,\002), X,\002,i2,\002, Y,\002,"
03556 "i2,\002, A,\002,i3,\002) \002,\002 .\002)";
03557 static char fmt_9994[] = "(1x,i6,\002: \002,a6,\002('\002,a1,\002',\002,"
03558 "i3,\002,(\002,f4.1,\002,\002,f4.1,\002), X,\002,i2,\002, Y,\002,"
03559 "i2,\002, AP) \002,\002 .\002)";
03560 static char fmt_9992[] = "(\002 ******* FATAL ERROR - ERROR-EXIT TAKEN O"
03561 "N VALID CALL *\002,\002******\002)";
03562 static char fmt_9998[] = "(\002 ******* FATAL ERROR - PARAMETER NUMBER"
03563 " \002,i2,\002 WAS CH\002,\002ANGED INCORRECTLY *******\002)";
03564 static char fmt_9999[] = "(\002 \002,a6,\002 PASSED THE COMPUTATIONAL TE"
03565 "STS (\002,i6,\002 CALL\002,\002S)\002)";
03566 static char fmt_9997[] = "(\002 \002,a6,\002 COMPLETED THE COMPUTATIONAL"
03567 " TESTS (\002,i6,\002 C\002,\002ALLS)\002,/\002 ******* BUT WITH "
03568 "MAXIMUM TEST RATIO\002,f8.2,\002 - SUSPECT *******\002)";
03569 static char fmt_9995[] = "(\002 THESE ARE THE RESULTS FOR COLUMN"
03570 " \002,i3)";
03571 static char fmt_9996[] = "(\002 ******* \002,a6,\002 FAILED ON CALL NUMB"
03572 "ER:\002)";
03573
03574
03575 integer a_dim1, a_offset, z_dim1, z_offset, i__1, i__2, i__3, i__4, i__5,
03576 i__6, i__7;
03577 doublecomplex z__1, z__2, z__3;
03578 alist al__1;
03579
03580
03581 integer s_wsfe(cilist *), do_fio(integer *, char *, ftnlen), e_wsfe(void),
03582 f_rew(alist *);
03583 void d_cnjg(doublecomplex *, doublecomplex *);
03584
03585
03586 integer i__, j, n;
03587 doublecomplex w[2];
03588 integer ia, ja, ic, nc, jj, lj, in, ix, iy, ns, lx, ly, laa, lda;
03589 doublecomplex als;
03590 doublereal err;
03591 extern logical lze_(doublecomplex *, doublecomplex *, integer *);
03592 integer ldas;
03593 logical same;
03594 integer incx, incy;
03595 logical full, null;
03596 char uplo[1];
03597 extern int zher2_(char *, integer *, doublecomplex *,
03598 doublecomplex *, integer *, doublecomplex *, integer *,
03599 doublecomplex *, integer *), zhpr2_(char *, integer *,
03600 doublecomplex *, doublecomplex *, integer *, doublecomplex *,
03601 integer *, doublecomplex *);
03602 doublecomplex alpha;
03603 logical isame[13];
03604 extern int zmake_(char *, char *, char *, integer *,
03605 integer *, doublecomplex *, integer *, doublecomplex *, integer *,
03606 integer *, integer *, logical *, doublecomplex *, ftnlen, ftnlen,
03607 ftnlen);
03608 integer nargs;
03609 logical reset;
03610 integer incxs, incys;
03611 extern int zmvch_(char *, integer *, integer *,
03612 doublecomplex *, doublecomplex *, integer *, doublecomplex *,
03613 integer *, doublecomplex *, doublecomplex *, integer *,
03614 doublecomplex *, doublereal *, doublecomplex *, doublereal *,
03615 doublereal *, logical *, integer *, logical *, ftnlen);
03616 logical upper;
03617 char uplos[1];
03618 logical packed;
03619 doublereal errmax;
03620 doublecomplex transl;
03621 extern logical lzeres_(char *, char *, integer *, integer *,
03622 doublecomplex *, doublecomplex *, integer *, ftnlen, ftnlen);
03623
03624
03625 static cilist io___375 = { 0, 0, 0, fmt_9993, 0 };
03626 static cilist io___376 = { 0, 0, 0, fmt_9994, 0 };
03627 static cilist io___377 = { 0, 0, 0, fmt_9992, 0 };
03628 static cilist io___380 = { 0, 0, 0, fmt_9998, 0 };
03629 static cilist io___387 = { 0, 0, 0, fmt_9999, 0 };
03630 static cilist io___388 = { 0, 0, 0, fmt_9997, 0 };
03631 static cilist io___389 = { 0, 0, 0, fmt_9995, 0 };
03632 static cilist io___390 = { 0, 0, 0, fmt_9996, 0 };
03633 static cilist io___391 = { 0, 0, 0, fmt_9993, 0 };
03634 static cilist io___392 = { 0, 0, 0, fmt_9994, 0 };
03635
03636
03637
03638
03639
03640
03641
03642
03643
03644
03645
03646
03647
03648
03649
03650
03651
03652
03653
03654
03655
03656
03657
03658 --idim;
03659 --alf;
03660 --inc;
03661 z_dim1 = *nmax;
03662 z_offset = 1 + z_dim1;
03663 z__ -= z_offset;
03664 --g;
03665 --yt;
03666 --y;
03667 --x;
03668 --as;
03669 --aa;
03670 a_dim1 = *nmax;
03671 a_offset = 1 + a_dim1;
03672 a -= a_offset;
03673 --ys;
03674 --yy;
03675 --xs;
03676 --xx;
03677
03678
03679
03680 full = *(unsigned char *)&sname[2] == 'E';
03681 packed = *(unsigned char *)&sname[2] == 'P';
03682
03683 if (full) {
03684 nargs = 9;
03685 } else if (packed) {
03686 nargs = 8;
03687 }
03688
03689 nc = 0;
03690 reset = TRUE_;
03691 errmax = 0.;
03692
03693 i__1 = *nidim;
03694 for (in = 1; in <= i__1; ++in) {
03695 n = idim[in];
03696
03697 lda = n;
03698 if (lda < *nmax) {
03699 ++lda;
03700 }
03701
03702 if (lda > *nmax) {
03703 goto L140;
03704 }
03705 if (packed) {
03706 laa = n * (n + 1) / 2;
03707 } else {
03708 laa = lda * n;
03709 }
03710
03711 for (ic = 1; ic <= 2; ++ic) {
03712 *(unsigned char *)uplo = *(unsigned char *)&ich[ic - 1];
03713 upper = *(unsigned char *)uplo == 'U';
03714
03715 i__2 = *ninc;
03716 for (ix = 1; ix <= i__2; ++ix) {
03717 incx = inc[ix];
03718 lx = abs(incx) * n;
03719
03720
03721
03722 transl.r = .5, transl.i = 0.;
03723 i__3 = abs(incx);
03724 i__4 = n - 1;
03725 zmake_("GE", " ", " ", &c__1, &n, &x[1], &c__1, &xx[1], &i__3,
03726 &c__0, &i__4, &reset, &transl, (ftnlen)2, (ftnlen)1,
03727 (ftnlen)1);
03728 if (n > 1) {
03729 i__3 = n / 2;
03730 x[i__3].r = 0., x[i__3].i = 0.;
03731 i__3 = abs(incx) * (n / 2 - 1) + 1;
03732 xx[i__3].r = 0., xx[i__3].i = 0.;
03733 }
03734
03735 i__3 = *ninc;
03736 for (iy = 1; iy <= i__3; ++iy) {
03737 incy = inc[iy];
03738 ly = abs(incy) * n;
03739
03740
03741
03742 transl.r = 0., transl.i = 0.;
03743 i__4 = abs(incy);
03744 i__5 = n - 1;
03745 zmake_("GE", " ", " ", &c__1, &n, &y[1], &c__1, &yy[1], &
03746 i__4, &c__0, &i__5, &reset, &transl, (ftnlen)2, (
03747 ftnlen)1, (ftnlen)1);
03748 if (n > 1) {
03749 i__4 = n / 2;
03750 y[i__4].r = 0., y[i__4].i = 0.;
03751 i__4 = abs(incy) * (n / 2 - 1) + 1;
03752 yy[i__4].r = 0., yy[i__4].i = 0.;
03753 }
03754
03755 i__4 = *nalf;
03756 for (ia = 1; ia <= i__4; ++ia) {
03757 i__5 = ia;
03758 alpha.r = alf[i__5].r, alpha.i = alf[i__5].i;
03759 null = n <= 0 || alpha.r == 0. && alpha.i == 0.;
03760
03761
03762
03763 transl.r = 0., transl.i = 0.;
03764 i__5 = n - 1;
03765 i__6 = n - 1;
03766 zmake_(sname + 1, uplo, " ", &n, &n, &a[a_offset],
03767 nmax, &aa[1], &lda, &i__5, &i__6, &reset, &
03768 transl, (ftnlen)2, (ftnlen)1, (ftnlen)1);
03769
03770 ++nc;
03771
03772
03773
03774 *(unsigned char *)uplos = *(unsigned char *)uplo;
03775 ns = n;
03776 als.r = alpha.r, als.i = alpha.i;
03777 i__5 = laa;
03778 for (i__ = 1; i__ <= i__5; ++i__) {
03779 i__6 = i__;
03780 i__7 = i__;
03781 as[i__6].r = aa[i__7].r, as[i__6].i = aa[i__7].i;
03782
03783 }
03784 ldas = lda;
03785 i__5 = lx;
03786 for (i__ = 1; i__ <= i__5; ++i__) {
03787 i__6 = i__;
03788 i__7 = i__;
03789 xs[i__6].r = xx[i__7].r, xs[i__6].i = xx[i__7].i;
03790
03791 }
03792 incxs = incx;
03793 i__5 = ly;
03794 for (i__ = 1; i__ <= i__5; ++i__) {
03795 i__6 = i__;
03796 i__7 = i__;
03797 ys[i__6].r = yy[i__7].r, ys[i__6].i = yy[i__7].i;
03798
03799 }
03800 incys = incy;
03801
03802
03803
03804 if (full) {
03805 if (*trace) {
03806 io___375.ciunit = *ntra;
03807 s_wsfe(&io___375);
03808 do_fio(&c__1, (char *)&nc, (ftnlen)sizeof(
03809 integer));
03810 do_fio(&c__1, sname, (ftnlen)6);
03811 do_fio(&c__1, uplo, (ftnlen)1);
03812 do_fio(&c__1, (char *)&n, (ftnlen)sizeof(
03813 integer));
03814 do_fio(&c__2, (char *)&alpha, (ftnlen)sizeof(
03815 doublereal));
03816 do_fio(&c__1, (char *)&incx, (ftnlen)sizeof(
03817 integer));
03818 do_fio(&c__1, (char *)&incy, (ftnlen)sizeof(
03819 integer));
03820 do_fio(&c__1, (char *)&lda, (ftnlen)sizeof(
03821 integer));
03822 e_wsfe();
03823 }
03824 if (*rewi) {
03825 al__1.aerr = 0;
03826 al__1.aunit = *ntra;
03827 f_rew(&al__1);
03828 }
03829 zher2_(uplo, &n, &alpha, &xx[1], &incx, &yy[1], &
03830 incy, &aa[1], &lda);
03831 } else if (packed) {
03832 if (*trace) {
03833 io___376.ciunit = *ntra;
03834 s_wsfe(&io___376);
03835 do_fio(&c__1, (char *)&nc, (ftnlen)sizeof(
03836 integer));
03837 do_fio(&c__1, sname, (ftnlen)6);
03838 do_fio(&c__1, uplo, (ftnlen)1);
03839 do_fio(&c__1, (char *)&n, (ftnlen)sizeof(
03840 integer));
03841 do_fio(&c__2, (char *)&alpha, (ftnlen)sizeof(
03842 doublereal));
03843 do_fio(&c__1, (char *)&incx, (ftnlen)sizeof(
03844 integer));
03845 do_fio(&c__1, (char *)&incy, (ftnlen)sizeof(
03846 integer));
03847 e_wsfe();
03848 }
03849 if (*rewi) {
03850 al__1.aerr = 0;
03851 al__1.aunit = *ntra;
03852 f_rew(&al__1);
03853 }
03854 zhpr2_(uplo, &n, &alpha, &xx[1], &incx, &yy[1], &
03855 incy, &aa[1]);
03856 }
03857
03858
03859
03860 if (! infoc_1.ok) {
03861 io___377.ciunit = *nout;
03862 s_wsfe(&io___377);
03863 e_wsfe();
03864 *fatal = TRUE_;
03865 goto L160;
03866 }
03867
03868
03869
03870 isame[0] = *(unsigned char *)uplo == *(unsigned char *
03871 )uplos;
03872 isame[1] = ns == n;
03873 isame[2] = als.r == alpha.r && als.i == alpha.i;
03874 isame[3] = lze_(&xs[1], &xx[1], &lx);
03875 isame[4] = incxs == incx;
03876 isame[5] = lze_(&ys[1], &yy[1], &ly);
03877 isame[6] = incys == incy;
03878 if (null) {
03879 isame[7] = lze_(&as[1], &aa[1], &laa);
03880 } else {
03881 isame[7] = lzeres_(sname + 1, uplo, &n, &n, &as[1]
03882 , &aa[1], &lda, (ftnlen)2, (ftnlen)1);
03883 }
03884 if (! packed) {
03885 isame[8] = ldas == lda;
03886 }
03887
03888
03889
03890 same = TRUE_;
03891 i__5 = nargs;
03892 for (i__ = 1; i__ <= i__5; ++i__) {
03893 same = same && isame[i__ - 1];
03894 if (! isame[i__ - 1]) {
03895 io___380.ciunit = *nout;
03896 s_wsfe(&io___380);
03897 do_fio(&c__1, (char *)&i__, (ftnlen)sizeof(
03898 integer));
03899 e_wsfe();
03900 }
03901
03902 }
03903 if (! same) {
03904 *fatal = TRUE_;
03905 goto L160;
03906 }
03907
03908 if (! null) {
03909
03910
03911
03912 if (incx > 0) {
03913 i__5 = n;
03914 for (i__ = 1; i__ <= i__5; ++i__) {
03915 i__6 = i__ + z_dim1;
03916 i__7 = i__;
03917 z__[i__6].r = x[i__7].r, z__[i__6].i = x[
03918 i__7].i;
03919
03920 }
03921 } else {
03922 i__5 = n;
03923 for (i__ = 1; i__ <= i__5; ++i__) {
03924 i__6 = i__ + z_dim1;
03925 i__7 = n - i__ + 1;
03926 z__[i__6].r = x[i__7].r, z__[i__6].i = x[
03927 i__7].i;
03928
03929 }
03930 }
03931 if (incy > 0) {
03932 i__5 = n;
03933 for (i__ = 1; i__ <= i__5; ++i__) {
03934 i__6 = i__ + (z_dim1 << 1);
03935 i__7 = i__;
03936 z__[i__6].r = y[i__7].r, z__[i__6].i = y[
03937 i__7].i;
03938
03939 }
03940 } else {
03941 i__5 = n;
03942 for (i__ = 1; i__ <= i__5; ++i__) {
03943 i__6 = i__ + (z_dim1 << 1);
03944 i__7 = n - i__ + 1;
03945 z__[i__6].r = y[i__7].r, z__[i__6].i = y[
03946 i__7].i;
03947
03948 }
03949 }
03950 ja = 1;
03951 i__5 = n;
03952 for (j = 1; j <= i__5; ++j) {
03953 d_cnjg(&z__2, &z__[j + (z_dim1 << 1)]);
03954 z__1.r = alpha.r * z__2.r - alpha.i * z__2.i,
03955 z__1.i = alpha.r * z__2.i + alpha.i *
03956 z__2.r;
03957 w[0].r = z__1.r, w[0].i = z__1.i;
03958 d_cnjg(&z__2, &alpha);
03959 d_cnjg(&z__3, &z__[j + z_dim1]);
03960 z__1.r = z__2.r * z__3.r - z__2.i * z__3.i,
03961 z__1.i = z__2.r * z__3.i + z__2.i *
03962 z__3.r;
03963 w[1].r = z__1.r, w[1].i = z__1.i;
03964 if (upper) {
03965 jj = 1;
03966 lj = j;
03967 } else {
03968 jj = j;
03969 lj = n - j + 1;
03970 }
03971 zmvch_("N", &lj, &c__2, &c_b2, &z__[jj +
03972 z_dim1], nmax, w, &c__1, &c_b2, &a[jj
03973 + j * a_dim1], &c__1, &yt[1], &g[1], &
03974 aa[ja], eps, &err, fatal, nout, &
03975 c_true, (ftnlen)1);
03976 if (full) {
03977 if (upper) {
03978 ja += lda;
03979 } else {
03980 ja = ja + lda + 1;
03981 }
03982 } else {
03983 ja += lj;
03984 }
03985 errmax = max(errmax,err);
03986
03987 if (*fatal) {
03988 goto L150;
03989 }
03990
03991 }
03992 } else {
03993
03994 if (n <= 0) {
03995 goto L140;
03996 }
03997 }
03998
03999
04000 }
04001
04002
04003 }
04004
04005
04006 }
04007
04008
04009 }
04010
04011 L140:
04012 ;
04013 }
04014
04015
04016
04017 if (errmax < *thresh) {
04018 io___387.ciunit = *nout;
04019 s_wsfe(&io___387);
04020 do_fio(&c__1, sname, (ftnlen)6);
04021 do_fio(&c__1, (char *)&nc, (ftnlen)sizeof(integer));
04022 e_wsfe();
04023 } else {
04024 io___388.ciunit = *nout;
04025 s_wsfe(&io___388);
04026 do_fio(&c__1, sname, (ftnlen)6);
04027 do_fio(&c__1, (char *)&nc, (ftnlen)sizeof(integer));
04028 do_fio(&c__1, (char *)&errmax, (ftnlen)sizeof(doublereal));
04029 e_wsfe();
04030 }
04031 goto L170;
04032
04033 L150:
04034 io___389.ciunit = *nout;
04035 s_wsfe(&io___389);
04036 do_fio(&c__1, (char *)&j, (ftnlen)sizeof(integer));
04037 e_wsfe();
04038
04039 L160:
04040 io___390.ciunit = *nout;
04041 s_wsfe(&io___390);
04042 do_fio(&c__1, sname, (ftnlen)6);
04043 e_wsfe();
04044 if (full) {
04045 io___391.ciunit = *nout;
04046 s_wsfe(&io___391);
04047 do_fio(&c__1, (char *)&nc, (ftnlen)sizeof(integer));
04048 do_fio(&c__1, sname, (ftnlen)6);
04049 do_fio(&c__1, uplo, (ftnlen)1);
04050 do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
04051 do_fio(&c__2, (char *)&alpha, (ftnlen)sizeof(doublereal));
04052 do_fio(&c__1, (char *)&incx, (ftnlen)sizeof(integer));
04053 do_fio(&c__1, (char *)&incy, (ftnlen)sizeof(integer));
04054 do_fio(&c__1, (char *)&lda, (ftnlen)sizeof(integer));
04055 e_wsfe();
04056 } else if (packed) {
04057 io___392.ciunit = *nout;
04058 s_wsfe(&io___392);
04059 do_fio(&c__1, (char *)&nc, (ftnlen)sizeof(integer));
04060 do_fio(&c__1, sname, (ftnlen)6);
04061 do_fio(&c__1, uplo, (ftnlen)1);
04062 do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
04063 do_fio(&c__2, (char *)&alpha, (ftnlen)sizeof(doublereal));
04064 do_fio(&c__1, (char *)&incx, (ftnlen)sizeof(integer));
04065 do_fio(&c__1, (char *)&incy, (ftnlen)sizeof(integer));
04066 e_wsfe();
04067 }
04068
04069 L170:
04070 return 0;
04071
04072
04073
04074
04075 }
04076
04077 int zchke_(integer *isnum, char *srnamt, integer *nout,
04078 ftnlen srnamt_len)
04079 {
04080
04081 static char fmt_9999[] = "(\002 \002,a6,\002 PASSED THE TESTS OF ERROR-E"
04082 "XITS\002)";
04083 static char fmt_9998[] = "(\002 ******* \002,a6,\002 FAILED THE TESTS OF"
04084 " ERROR-EXITS *****\002,\002**\002)";
04085
04086
04087 integer s_wsfe(cilist *), do_fio(integer *, char *, ftnlen), e_wsfe(void);
04088
04089
04090 doublecomplex a[1] , x[1], y[1], beta;
04091 extern int zher_(char *, integer *, doublereal *,
04092 doublecomplex *, integer *, doublecomplex *, integer *),
04093 zhpr_(char *, integer *, doublereal *, doublecomplex *, integer *,
04094 doublecomplex *), zher2_(char *, integer *,
04095 doublecomplex *, doublecomplex *, integer *, doublecomplex *,
04096 integer *, doublecomplex *, integer *), zhpr2_(char *,
04097 integer *, doublecomplex *, doublecomplex *, integer *,
04098 doublecomplex *, integer *, doublecomplex *);
04099 doublecomplex alpha;
04100 extern int zgerc_(integer *, integer *, doublecomplex *,
04101 doublecomplex *, integer *, doublecomplex *, integer *,
04102 doublecomplex *, integer *), zgbmv_(char *, integer *, integer *,
04103 integer *, integer *, doublecomplex *, doublecomplex *, integer *,
04104 doublecomplex *, integer *, doublecomplex *, doublecomplex *,
04105 integer *), zhbmv_(char *, integer *, integer *,
04106 doublecomplex *, doublecomplex *, integer *, doublecomplex *,
04107 integer *, doublecomplex *, doublecomplex *, integer *),
04108 zgemv_(char *, integer *, integer *, doublecomplex *,
04109 doublecomplex *, integer *, doublecomplex *, integer *,
04110 doublecomplex *, doublecomplex *, integer *), zhemv_(char
04111 *, integer *, doublecomplex *, doublecomplex *, integer *,
04112 doublecomplex *, integer *, doublecomplex *, doublecomplex *,
04113 integer *), zgeru_(integer *, integer *, doublecomplex *,
04114 doublecomplex *, integer *, doublecomplex *, integer *,
04115 doublecomplex *, integer *), ztbmv_(char *, char *, char *,
04116 integer *, integer *, doublecomplex *, integer *, doublecomplex *,
04117 integer *), zhpmv_(char *, integer *,
04118 doublecomplex *, doublecomplex *, doublecomplex *, integer *,
04119 doublecomplex *, doublecomplex *, integer *), ztbsv_(char
04120 *, char *, char *, integer *, integer *, doublecomplex *, integer
04121 *, doublecomplex *, integer *), ztpmv_(
04122 char *, char *, char *, integer *, doublecomplex *, doublecomplex
04123 *, integer *), ztrmv_(char *, char *,
04124 char *, integer *, doublecomplex *, integer *, doublecomplex *,
04125 integer *), ztpsv_(char *, char *, char *,
04126 integer *, doublecomplex *, doublecomplex *, integer *), ztrsv_(char *, char *, char *, integer *,
04127 doublecomplex *, integer *, doublecomplex *, integer *);
04128 doublereal ralpha;
04129 extern int chkxer_(char *, integer *, integer *, logical
04130 *, logical *);
04131
04132
04133 static cilist io___399 = { 0, 0, 0, fmt_9999, 0 };
04134 static cilist io___400 = { 0, 0, 0, fmt_9998, 0 };
04135
04136
04137
04138
04139
04140
04141
04142
04143
04144
04145
04146
04147
04148
04149
04150
04151
04152
04153
04154
04155
04156
04157 infoc_1.ok = TRUE_;
04158
04159
04160 infoc_1.lerr = FALSE_;
04161 switch (*isnum) {
04162 case 1: goto L10;
04163 case 2: goto L20;
04164 case 3: goto L30;
04165 case 4: goto L40;
04166 case 5: goto L50;
04167 case 6: goto L60;
04168 case 7: goto L70;
04169 case 8: goto L80;
04170 case 9: goto L90;
04171 case 10: goto L100;
04172 case 11: goto L110;
04173 case 12: goto L120;
04174 case 13: goto L130;
04175 case 14: goto L140;
04176 case 15: goto L150;
04177 case 16: goto L160;
04178 case 17: goto L170;
04179 }
04180 L10:
04181 infoc_1.infot = 1;
04182 zgemv_("/", &c__0, &c__0, &alpha, a, &c__1, x, &c__1, &beta, y, &c__1);
04183 chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
04184 infoc_1.infot = 2;
04185 zgemv_("N", &c_n1, &c__0, &alpha, a, &c__1, x, &c__1, &beta, y, &c__1);
04186 chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
04187 infoc_1.infot = 3;
04188 zgemv_("N", &c__0, &c_n1, &alpha, a, &c__1, x, &c__1, &beta, y, &c__1);
04189 chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
04190 infoc_1.infot = 6;
04191 zgemv_("N", &c__2, &c__0, &alpha, a, &c__1, x, &c__1, &beta, y, &c__1);
04192 chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
04193 infoc_1.infot = 8;
04194 zgemv_("N", &c__0, &c__0, &alpha, a, &c__1, x, &c__0, &beta, y, &c__1);
04195 chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
04196 infoc_1.infot = 11;
04197 zgemv_("N", &c__0, &c__0, &alpha, a, &c__1, x, &c__1, &beta, y, &c__0);
04198 chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
04199 goto L180;
04200 L20:
04201 infoc_1.infot = 1;
04202 zgbmv_("/", &c__0, &c__0, &c__0, &c__0, &alpha, a, &c__1, x, &c__1, &beta,
04203 y, &c__1);
04204 chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
04205 infoc_1.infot = 2;
04206 zgbmv_("N", &c_n1, &c__0, &c__0, &c__0, &alpha, a, &c__1, x, &c__1, &beta,
04207 y, &c__1);
04208 chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
04209 infoc_1.infot = 3;
04210 zgbmv_("N", &c__0, &c_n1, &c__0, &c__0, &alpha, a, &c__1, x, &c__1, &beta,
04211 y, &c__1);
04212 chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
04213 infoc_1.infot = 4;
04214 zgbmv_("N", &c__0, &c__0, &c_n1, &c__0, &alpha, a, &c__1, x, &c__1, &beta,
04215 y, &c__1);
04216 chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
04217 infoc_1.infot = 5;
04218 zgbmv_("N", &c__2, &c__0, &c__0, &c_n1, &alpha, a, &c__1, x, &c__1, &beta,
04219 y, &c__1);
04220 chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
04221 infoc_1.infot = 8;
04222 zgbmv_("N", &c__0, &c__0, &c__1, &c__0, &alpha, a, &c__1, x, &c__1, &beta,
04223 y, &c__1);
04224 chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
04225 infoc_1.infot = 10;
04226 zgbmv_("N", &c__0, &c__0, &c__0, &c__0, &alpha, a, &c__1, x, &c__0, &beta,
04227 y, &c__1);
04228 chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
04229 infoc_1.infot = 13;
04230 zgbmv_("N", &c__0, &c__0, &c__0, &c__0, &alpha, a, &c__1, x, &c__1, &beta,
04231 y, &c__0);
04232 chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
04233 goto L180;
04234 L30:
04235 infoc_1.infot = 1;
04236 zhemv_("/", &c__0, &alpha, a, &c__1, x, &c__1, &beta, y, &c__1)
04237 ;
04238 chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
04239 infoc_1.infot = 2;
04240 zhemv_("U", &c_n1, &alpha, a, &c__1, x, &c__1, &beta, y, &c__1)
04241 ;
04242 chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
04243 infoc_1.infot = 5;
04244 zhemv_("U", &c__2, &alpha, a, &c__1, x, &c__1, &beta, y, &c__1)
04245 ;
04246 chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
04247 infoc_1.infot = 7;
04248 zhemv_("U", &c__0, &alpha, a, &c__1, x, &c__0, &beta, y, &c__1)
04249 ;
04250 chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
04251 infoc_1.infot = 10;
04252 zhemv_("U", &c__0, &alpha, a, &c__1, x, &c__1, &beta, y, &c__0)
04253 ;
04254 chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
04255 goto L180;
04256 L40:
04257 infoc_1.infot = 1;
04258 zhbmv_("/", &c__0, &c__0, &alpha, a, &c__1, x, &c__1, &beta, y, &c__1);
04259 chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
04260 infoc_1.infot = 2;
04261 zhbmv_("U", &c_n1, &c__0, &alpha, a, &c__1, x, &c__1, &beta, y, &c__1);
04262 chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
04263 infoc_1.infot = 3;
04264 zhbmv_("U", &c__0, &c_n1, &alpha, a, &c__1, x, &c__1, &beta, y, &c__1);
04265 chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
04266 infoc_1.infot = 6;
04267 zhbmv_("U", &c__0, &c__1, &alpha, a, &c__1, x, &c__1, &beta, y, &c__1);
04268 chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
04269 infoc_1.infot = 8;
04270 zhbmv_("U", &c__0, &c__0, &alpha, a, &c__1, x, &c__0, &beta, y, &c__1);
04271 chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
04272 infoc_1.infot = 11;
04273 zhbmv_("U", &c__0, &c__0, &alpha, a, &c__1, x, &c__1, &beta, y, &c__0);
04274 chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
04275 goto L180;
04276 L50:
04277 infoc_1.infot = 1;
04278 zhpmv_("/", &c__0, &alpha, a, x, &c__1, &beta, y, &c__1);
04279 chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
04280 infoc_1.infot = 2;
04281 zhpmv_("U", &c_n1, &alpha, a, x, &c__1, &beta, y, &c__1);
04282 chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
04283 infoc_1.infot = 6;
04284 zhpmv_("U", &c__0, &alpha, a, x, &c__0, &beta, y, &c__1);
04285 chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
04286 infoc_1.infot = 9;
04287 zhpmv_("U", &c__0, &alpha, a, x, &c__1, &beta, y, &c__0);
04288 chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
04289 goto L180;
04290 L60:
04291 infoc_1.infot = 1;
04292 ztrmv_("/", "N", "N", &c__0, a, &c__1, x, &c__1);
04293 chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
04294 infoc_1.infot = 2;
04295 ztrmv_("U", "/", "N", &c__0, a, &c__1, x, &c__1);
04296 chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
04297 infoc_1.infot = 3;
04298 ztrmv_("U", "N", "/", &c__0, a, &c__1, x, &c__1);
04299 chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
04300 infoc_1.infot = 4;
04301 ztrmv_("U", "N", "N", &c_n1, a, &c__1, x, &c__1);
04302 chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
04303 infoc_1.infot = 6;
04304 ztrmv_("U", "N", "N", &c__2, a, &c__1, x, &c__1);
04305 chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
04306 infoc_1.infot = 8;
04307 ztrmv_("U", "N", "N", &c__0, a, &c__1, x, &c__0);
04308 chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
04309 goto L180;
04310 L70:
04311 infoc_1.infot = 1;
04312 ztbmv_("/", "N", "N", &c__0, &c__0, a, &c__1, x, &c__1);
04313 chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
04314 infoc_1.infot = 2;
04315 ztbmv_("U", "/", "N", &c__0, &c__0, a, &c__1, x, &c__1);
04316 chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
04317 infoc_1.infot = 3;
04318 ztbmv_("U", "N", "/", &c__0, &c__0, a, &c__1, x, &c__1);
04319 chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
04320 infoc_1.infot = 4;
04321 ztbmv_("U", "N", "N", &c_n1, &c__0, a, &c__1, x, &c__1);
04322 chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
04323 infoc_1.infot = 5;
04324 ztbmv_("U", "N", "N", &c__0, &c_n1, a, &c__1, x, &c__1);
04325 chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
04326 infoc_1.infot = 7;
04327 ztbmv_("U", "N", "N", &c__0, &c__1, a, &c__1, x, &c__1);
04328 chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
04329 infoc_1.infot = 9;
04330 ztbmv_("U", "N", "N", &c__0, &c__0, a, &c__1, x, &c__0);
04331 chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
04332 goto L180;
04333 L80:
04334 infoc_1.infot = 1;
04335 ztpmv_("/", "N", "N", &c__0, a, x, &c__1)
04336 ;
04337 chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
04338 infoc_1.infot = 2;
04339 ztpmv_("U", "/", "N", &c__0, a, x, &c__1)
04340 ;
04341 chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
04342 infoc_1.infot = 3;
04343 ztpmv_("U", "N", "/", &c__0, a, x, &c__1)
04344 ;
04345 chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
04346 infoc_1.infot = 4;
04347 ztpmv_("U", "N", "N", &c_n1, a, x, &c__1)
04348 ;
04349 chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
04350 infoc_1.infot = 7;
04351 ztpmv_("U", "N", "N", &c__0, a, x, &c__0)
04352 ;
04353 chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
04354 goto L180;
04355 L90:
04356 infoc_1.infot = 1;
04357 ztrsv_("/", "N", "N", &c__0, a, &c__1, x, &c__1);
04358 chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
04359 infoc_1.infot = 2;
04360 ztrsv_("U", "/", "N", &c__0, a, &c__1, x, &c__1);
04361 chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
04362 infoc_1.infot = 3;
04363 ztrsv_("U", "N", "/", &c__0, a, &c__1, x, &c__1);
04364 chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
04365 infoc_1.infot = 4;
04366 ztrsv_("U", "N", "N", &c_n1, a, &c__1, x, &c__1);
04367 chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
04368 infoc_1.infot = 6;
04369 ztrsv_("U", "N", "N", &c__2, a, &c__1, x, &c__1);
04370 chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
04371 infoc_1.infot = 8;
04372 ztrsv_("U", "N", "N", &c__0, a, &c__1, x, &c__0);
04373 chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
04374 goto L180;
04375 L100:
04376 infoc_1.infot = 1;
04377 ztbsv_("/", "N", "N", &c__0, &c__0, a, &c__1, x, &c__1);
04378 chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
04379 infoc_1.infot = 2;
04380 ztbsv_("U", "/", "N", &c__0, &c__0, a, &c__1, x, &c__1);
04381 chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
04382 infoc_1.infot = 3;
04383 ztbsv_("U", "N", "/", &c__0, &c__0, a, &c__1, x, &c__1);
04384 chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
04385 infoc_1.infot = 4;
04386 ztbsv_("U", "N", "N", &c_n1, &c__0, a, &c__1, x, &c__1);
04387 chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
04388 infoc_1.infot = 5;
04389 ztbsv_("U", "N", "N", &c__0, &c_n1, a, &c__1, x, &c__1);
04390 chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
04391 infoc_1.infot = 7;
04392 ztbsv_("U", "N", "N", &c__0, &c__1, a, &c__1, x, &c__1);
04393 chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
04394 infoc_1.infot = 9;
04395 ztbsv_("U", "N", "N", &c__0, &c__0, a, &c__1, x, &c__0);
04396 chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
04397 goto L180;
04398 L110:
04399 infoc_1.infot = 1;
04400 ztpsv_("/", "N", "N", &c__0, a, x, &c__1)
04401 ;
04402 chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
04403 infoc_1.infot = 2;
04404 ztpsv_("U", "/", "N", &c__0, a, x, &c__1)
04405 ;
04406 chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
04407 infoc_1.infot = 3;
04408 ztpsv_("U", "N", "/", &c__0, a, x, &c__1)
04409 ;
04410 chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
04411 infoc_1.infot = 4;
04412 ztpsv_("U", "N", "N", &c_n1, a, x, &c__1)
04413 ;
04414 chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
04415 infoc_1.infot = 7;
04416 ztpsv_("U", "N", "N", &c__0, a, x, &c__0)
04417 ;
04418 chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
04419 goto L180;
04420 L120:
04421 infoc_1.infot = 1;
04422 zgerc_(&c_n1, &c__0, &alpha, x, &c__1, y, &c__1, a, &c__1);
04423 chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
04424 infoc_1.infot = 2;
04425 zgerc_(&c__0, &c_n1, &alpha, x, &c__1, y, &c__1, a, &c__1);
04426 chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
04427 infoc_1.infot = 5;
04428 zgerc_(&c__0, &c__0, &alpha, x, &c__0, y, &c__1, a, &c__1);
04429 chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
04430 infoc_1.infot = 7;
04431 zgerc_(&c__0, &c__0, &alpha, x, &c__1, y, &c__0, a, &c__1);
04432 chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
04433 infoc_1.infot = 9;
04434 zgerc_(&c__2, &c__0, &alpha, x, &c__1, y, &c__1, a, &c__1);
04435 chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
04436 goto L180;
04437 L130:
04438 infoc_1.infot = 1;
04439 zgeru_(&c_n1, &c__0, &alpha, x, &c__1, y, &c__1, a, &c__1);
04440 chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
04441 infoc_1.infot = 2;
04442 zgeru_(&c__0, &c_n1, &alpha, x, &c__1, y, &c__1, a, &c__1);
04443 chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
04444 infoc_1.infot = 5;
04445 zgeru_(&c__0, &c__0, &alpha, x, &c__0, y, &c__1, a, &c__1);
04446 chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
04447 infoc_1.infot = 7;
04448 zgeru_(&c__0, &c__0, &alpha, x, &c__1, y, &c__0, a, &c__1);
04449 chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
04450 infoc_1.infot = 9;
04451 zgeru_(&c__2, &c__0, &alpha, x, &c__1, y, &c__1, a, &c__1);
04452 chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
04453 goto L180;
04454 L140:
04455 infoc_1.infot = 1;
04456 zher_("/", &c__0, &ralpha, x, &c__1, a, &c__1);
04457 chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
04458 infoc_1.infot = 2;
04459 zher_("U", &c_n1, &ralpha, x, &c__1, a, &c__1);
04460 chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
04461 infoc_1.infot = 5;
04462 zher_("U", &c__0, &ralpha, x, &c__0, a, &c__1);
04463 chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
04464 infoc_1.infot = 7;
04465 zher_("U", &c__2, &ralpha, x, &c__1, a, &c__1);
04466 chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
04467 goto L180;
04468 L150:
04469 infoc_1.infot = 1;
04470 zhpr_("/", &c__0, &ralpha, x, &c__1, a);
04471 chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
04472 infoc_1.infot = 2;
04473 zhpr_("U", &c_n1, &ralpha, x, &c__1, a);
04474 chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
04475 infoc_1.infot = 5;
04476 zhpr_("U", &c__0, &ralpha, x, &c__0, a);
04477 chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
04478 goto L180;
04479 L160:
04480 infoc_1.infot = 1;
04481 zher2_("/", &c__0, &alpha, x, &c__1, y, &c__1, a, &c__1);
04482 chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
04483 infoc_1.infot = 2;
04484 zher2_("U", &c_n1, &alpha, x, &c__1, y, &c__1, a, &c__1);
04485 chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
04486 infoc_1.infot = 5;
04487 zher2_("U", &c__0, &alpha, x, &c__0, y, &c__1, a, &c__1);
04488 chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
04489 infoc_1.infot = 7;
04490 zher2_("U", &c__0, &alpha, x, &c__1, y, &c__0, a, &c__1);
04491 chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
04492 infoc_1.infot = 9;
04493 zher2_("U", &c__2, &alpha, x, &c__1, y, &c__1, a, &c__1);
04494 chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
04495 goto L180;
04496 L170:
04497 infoc_1.infot = 1;
04498 zhpr2_("/", &c__0, &alpha, x, &c__1, y, &c__1, a);
04499 chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
04500 infoc_1.infot = 2;
04501 zhpr2_("U", &c_n1, &alpha, x, &c__1, y, &c__1, a);
04502 chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
04503 infoc_1.infot = 5;
04504 zhpr2_("U", &c__0, &alpha, x, &c__0, y, &c__1, a);
04505 chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
04506 infoc_1.infot = 7;
04507 zhpr2_("U", &c__0, &alpha, x, &c__1, y, &c__0, a);
04508 chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
04509
04510 L180:
04511 if (infoc_1.ok) {
04512 io___399.ciunit = *nout;
04513 s_wsfe(&io___399);
04514 do_fio(&c__1, srnamt, (ftnlen)6);
04515 e_wsfe();
04516 } else {
04517 io___400.ciunit = *nout;
04518 s_wsfe(&io___400);
04519 do_fio(&c__1, srnamt, (ftnlen)6);
04520 e_wsfe();
04521 }
04522 return 0;
04523
04524
04525
04526
04527 }
04528
04529 int zmake_(char *type__, char *uplo, char *diag, integer *m,
04530 integer *n, doublecomplex *a, integer *nmax, doublecomplex *aa,
04531 integer *lda, integer *kl, integer *ku, logical *reset, doublecomplex
04532 *transl, ftnlen type_len, ftnlen uplo_len, ftnlen diag_len)
04533 {
04534
04535 integer a_dim1, a_offset, i__1, i__2, i__3, i__4;
04536 doublereal d__1;
04537 doublecomplex z__1, z__2;
04538
04539
04540 void d_cnjg(doublecomplex *, doublecomplex *);
04541 integer s_cmp(char *, char *, ftnlen, ftnlen);
04542
04543
04544 integer i__, j, i1, i2, i3, jj, kk;
04545 logical gen, tri, sym;
04546 integer ibeg, iend, ioff;
04547 extern VOID zbeg_(doublecomplex *, logical *);
04548 logical unit, lower, upper;
04549
04550
04551
04552
04553
04554
04555
04556
04557
04558
04559
04560
04561
04562
04563
04564
04565
04566
04567
04568
04569
04570
04571
04572 a_dim1 = *nmax;
04573 a_offset = 1 + a_dim1;
04574 a -= a_offset;
04575 --aa;
04576
04577
04578 gen = *(unsigned char *)type__ == 'G';
04579 sym = *(unsigned char *)type__ == 'H';
04580 tri = *(unsigned char *)type__ == 'T';
04581 upper = (sym || tri) && *(unsigned char *)uplo == 'U';
04582 lower = (sym || tri) && *(unsigned char *)uplo == 'L';
04583 unit = tri && *(unsigned char *)diag == 'U';
04584
04585
04586
04587 i__1 = *n;
04588 for (j = 1; j <= i__1; ++j) {
04589 i__2 = *m;
04590 for (i__ = 1; i__ <= i__2; ++i__) {
04591 if (gen || upper && i__ <= j || lower && i__ >= j) {
04592 if (i__ <= j && j - i__ <= *ku || i__ >= j && i__ - j <= *kl)
04593 {
04594 i__3 = i__ + j * a_dim1;
04595 zbeg_(&z__2, reset);
04596 z__1.r = z__2.r + transl->r, z__1.i = z__2.i + transl->i;
04597 a[i__3].r = z__1.r, a[i__3].i = z__1.i;
04598 } else {
04599 i__3 = i__ + j * a_dim1;
04600 a[i__3].r = 0., a[i__3].i = 0.;
04601 }
04602 if (i__ != j) {
04603 if (sym) {
04604 i__3 = j + i__ * a_dim1;
04605 d_cnjg(&z__1, &a[i__ + j * a_dim1]);
04606 a[i__3].r = z__1.r, a[i__3].i = z__1.i;
04607 } else if (tri) {
04608 i__3 = j + i__ * a_dim1;
04609 a[i__3].r = 0., a[i__3].i = 0.;
04610 }
04611 }
04612 }
04613
04614 }
04615 if (sym) {
04616 i__2 = j + j * a_dim1;
04617 i__3 = j + j * a_dim1;
04618 d__1 = a[i__3].r;
04619 z__1.r = d__1, z__1.i = 0.;
04620 a[i__2].r = z__1.r, a[i__2].i = z__1.i;
04621 }
04622 if (tri) {
04623 i__2 = j + j * a_dim1;
04624 i__3 = j + j * a_dim1;
04625 z__1.r = a[i__3].r + 1., z__1.i = a[i__3].i + 0.;
04626 a[i__2].r = z__1.r, a[i__2].i = z__1.i;
04627 }
04628 if (unit) {
04629 i__2 = j + j * a_dim1;
04630 a[i__2].r = 1., a[i__2].i = 0.;
04631 }
04632
04633 }
04634
04635
04636
04637 if (s_cmp(type__, "GE", (ftnlen)2, (ftnlen)2) == 0) {
04638 i__1 = *n;
04639 for (j = 1; j <= i__1; ++j) {
04640 i__2 = *m;
04641 for (i__ = 1; i__ <= i__2; ++i__) {
04642 i__3 = i__ + (j - 1) * *lda;
04643 i__4 = i__ + j * a_dim1;
04644 aa[i__3].r = a[i__4].r, aa[i__3].i = a[i__4].i;
04645
04646 }
04647 i__2 = *lda;
04648 for (i__ = *m + 1; i__ <= i__2; ++i__) {
04649 i__3 = i__ + (j - 1) * *lda;
04650 aa[i__3].r = -1e10, aa[i__3].i = 1e10;
04651
04652 }
04653
04654 }
04655 } else if (s_cmp(type__, "GB", (ftnlen)2, (ftnlen)2) == 0) {
04656 i__1 = *n;
04657 for (j = 1; j <= i__1; ++j) {
04658 i__2 = *ku + 1 - j;
04659 for (i1 = 1; i1 <= i__2; ++i1) {
04660 i__3 = i1 + (j - 1) * *lda;
04661 aa[i__3].r = -1e10, aa[i__3].i = 1e10;
04662
04663 }
04664
04665 i__3 = *kl + *ku + 1, i__4 = *ku + 1 + *m - j;
04666 i__2 = min(i__3,i__4);
04667 for (i2 = i1; i2 <= i__2; ++i2) {
04668 i__3 = i2 + (j - 1) * *lda;
04669 i__4 = i2 + j - *ku - 1 + j * a_dim1;
04670 aa[i__3].r = a[i__4].r, aa[i__3].i = a[i__4].i;
04671
04672 }
04673 i__2 = *lda;
04674 for (i3 = i2; i3 <= i__2; ++i3) {
04675 i__3 = i3 + (j - 1) * *lda;
04676 aa[i__3].r = -1e10, aa[i__3].i = 1e10;
04677
04678 }
04679
04680 }
04681 } else if (s_cmp(type__, "HE", (ftnlen)2, (ftnlen)2) == 0 || s_cmp(type__,
04682 "TR", (ftnlen)2, (ftnlen)2) == 0) {
04683 i__1 = *n;
04684 for (j = 1; j <= i__1; ++j) {
04685 if (upper) {
04686 ibeg = 1;
04687 if (unit) {
04688 iend = j - 1;
04689 } else {
04690 iend = j;
04691 }
04692 } else {
04693 if (unit) {
04694 ibeg = j + 1;
04695 } else {
04696 ibeg = j;
04697 }
04698 iend = *n;
04699 }
04700 i__2 = ibeg - 1;
04701 for (i__ = 1; i__ <= i__2; ++i__) {
04702 i__3 = i__ + (j - 1) * *lda;
04703 aa[i__3].r = -1e10, aa[i__3].i = 1e10;
04704
04705 }
04706 i__2 = iend;
04707 for (i__ = ibeg; i__ <= i__2; ++i__) {
04708 i__3 = i__ + (j - 1) * *lda;
04709 i__4 = i__ + j * a_dim1;
04710 aa[i__3].r = a[i__4].r, aa[i__3].i = a[i__4].i;
04711
04712 }
04713 i__2 = *lda;
04714 for (i__ = iend + 1; i__ <= i__2; ++i__) {
04715 i__3 = i__ + (j - 1) * *lda;
04716 aa[i__3].r = -1e10, aa[i__3].i = 1e10;
04717
04718 }
04719 if (sym) {
04720 jj = j + (j - 1) * *lda;
04721 i__2 = jj;
04722 i__3 = jj;
04723 d__1 = aa[i__3].r;
04724 z__1.r = d__1, z__1.i = -1e10;
04725 aa[i__2].r = z__1.r, aa[i__2].i = z__1.i;
04726 }
04727
04728 }
04729 } else if (s_cmp(type__, "HB", (ftnlen)2, (ftnlen)2) == 0 || s_cmp(type__,
04730 "TB", (ftnlen)2, (ftnlen)2) == 0) {
04731 i__1 = *n;
04732 for (j = 1; j <= i__1; ++j) {
04733 if (upper) {
04734 kk = *kl + 1;
04735
04736 i__2 = 1, i__3 = *kl + 2 - j;
04737 ibeg = max(i__2,i__3);
04738 if (unit) {
04739 iend = *kl;
04740 } else {
04741 iend = *kl + 1;
04742 }
04743 } else {
04744 kk = 1;
04745 if (unit) {
04746 ibeg = 2;
04747 } else {
04748 ibeg = 1;
04749 }
04750
04751 i__2 = *kl + 1, i__3 = *m + 1 - j;
04752 iend = min(i__2,i__3);
04753 }
04754 i__2 = ibeg - 1;
04755 for (i__ = 1; i__ <= i__2; ++i__) {
04756 i__3 = i__ + (j - 1) * *lda;
04757 aa[i__3].r = -1e10, aa[i__3].i = 1e10;
04758
04759 }
04760 i__2 = iend;
04761 for (i__ = ibeg; i__ <= i__2; ++i__) {
04762 i__3 = i__ + (j - 1) * *lda;
04763 i__4 = i__ + j - kk + j * a_dim1;
04764 aa[i__3].r = a[i__4].r, aa[i__3].i = a[i__4].i;
04765
04766 }
04767 i__2 = *lda;
04768 for (i__ = iend + 1; i__ <= i__2; ++i__) {
04769 i__3 = i__ + (j - 1) * *lda;
04770 aa[i__3].r = -1e10, aa[i__3].i = 1e10;
04771
04772 }
04773 if (sym) {
04774 jj = kk + (j - 1) * *lda;
04775 i__2 = jj;
04776 i__3 = jj;
04777 d__1 = aa[i__3].r;
04778 z__1.r = d__1, z__1.i = -1e10;
04779 aa[i__2].r = z__1.r, aa[i__2].i = z__1.i;
04780 }
04781
04782 }
04783 } else if (s_cmp(type__, "HP", (ftnlen)2, (ftnlen)2) == 0 || s_cmp(type__,
04784 "TP", (ftnlen)2, (ftnlen)2) == 0) {
04785 ioff = 0;
04786 i__1 = *n;
04787 for (j = 1; j <= i__1; ++j) {
04788 if (upper) {
04789 ibeg = 1;
04790 iend = j;
04791 } else {
04792 ibeg = j;
04793 iend = *n;
04794 }
04795 i__2 = iend;
04796 for (i__ = ibeg; i__ <= i__2; ++i__) {
04797 ++ioff;
04798 i__3 = ioff;
04799 i__4 = i__ + j * a_dim1;
04800 aa[i__3].r = a[i__4].r, aa[i__3].i = a[i__4].i;
04801 if (i__ == j) {
04802 if (unit) {
04803 i__3 = ioff;
04804 aa[i__3].r = -1e10, aa[i__3].i = 1e10;
04805 }
04806 if (sym) {
04807 i__3 = ioff;
04808 i__4 = ioff;
04809 d__1 = aa[i__4].r;
04810 z__1.r = d__1, z__1.i = -1e10;
04811 aa[i__3].r = z__1.r, aa[i__3].i = z__1.i;
04812 }
04813 }
04814
04815 }
04816
04817 }
04818 }
04819 return 0;
04820
04821
04822
04823 }
04824
04825 int zmvch_(char *trans, integer *m, integer *n,
04826 doublecomplex *alpha, doublecomplex *a, integer *nmax, doublecomplex *
04827 x, integer *incx, doublecomplex *beta, doublecomplex *y, integer *
04828 incy, doublecomplex *yt, doublereal *g, doublecomplex *yy, doublereal
04829 *eps, doublereal *err, logical *fatal, integer *nout, logical *mv,
04830 ftnlen trans_len)
04831 {
04832
04833 static char fmt_9999[] = "(\002 ******* FATAL ERROR - COMPUTED RESULT IS"
04834 " LESS THAN HAL\002,\002F ACCURATE *******\002,/\002 "
04835 " EXPECTED RE\002,\002SULT COMPUTED R"
04836 "ESULT\002)";
04837 static char fmt_9998[] = "(1x,i7,2(\002 (\002,g15.6,\002,\002,g15.6,"
04838 "\002)\002))";
04839
04840
04841 integer a_dim1, a_offset, i__1, i__2, i__3, i__4, i__5, i__6;
04842 doublereal d__1, d__2, d__3, d__4, d__5, d__6;
04843 doublecomplex z__1, z__2, z__3;
04844
04845
04846 double d_imag(doublecomplex *);
04847 void d_cnjg(doublecomplex *, doublecomplex *);
04848 double z_abs(doublecomplex *), sqrt(doublereal);
04849 integer s_wsfe(cilist *), e_wsfe(void), do_fio(integer *, char *, ftnlen);
04850
04851
04852 integer i__, j, ml, nl, iy, jx, kx, ky;
04853 doublereal erri;
04854 logical tran, ctran;
04855 integer incxl, incyl;
04856
04857
04858 static cilist io___430 = { 0, 0, 0, fmt_9999, 0 };
04859 static cilist io___431 = { 0, 0, 0, fmt_9998, 0 };
04860 static cilist io___432 = { 0, 0, 0, fmt_9998, 0 };
04861
04862
04863
04864
04865
04866
04867
04868
04869
04870
04871
04872
04873
04874
04875
04876
04877
04878
04879
04880
04881 a_dim1 = *nmax;
04882 a_offset = 1 + a_dim1;
04883 a -= a_offset;
04884 --x;
04885 --y;
04886 --yt;
04887 --g;
04888 --yy;
04889
04890
04891 tran = *(unsigned char *)trans == 'T';
04892 ctran = *(unsigned char *)trans == 'C';
04893 if (tran || ctran) {
04894 ml = *n;
04895 nl = *m;
04896 } else {
04897 ml = *m;
04898 nl = *n;
04899 }
04900 if (*incx < 0) {
04901 kx = nl;
04902 incxl = -1;
04903 } else {
04904 kx = 1;
04905 incxl = 1;
04906 }
04907 if (*incy < 0) {
04908 ky = ml;
04909 incyl = -1;
04910 } else {
04911 ky = 1;
04912 incyl = 1;
04913 }
04914
04915
04916
04917
04918 iy = ky;
04919 i__1 = ml;
04920 for (i__ = 1; i__ <= i__1; ++i__) {
04921 i__2 = iy;
04922 yt[i__2].r = 0., yt[i__2].i = 0.;
04923 g[iy] = 0.;
04924 jx = kx;
04925 if (tran) {
04926 i__2 = nl;
04927 for (j = 1; j <= i__2; ++j) {
04928 i__3 = iy;
04929 i__4 = iy;
04930 i__5 = j + i__ * a_dim1;
04931 i__6 = jx;
04932 z__2.r = a[i__5].r * x[i__6].r - a[i__5].i * x[i__6].i,
04933 z__2.i = a[i__5].r * x[i__6].i + a[i__5].i * x[i__6]
04934 .r;
04935 z__1.r = yt[i__4].r + z__2.r, z__1.i = yt[i__4].i + z__2.i;
04936 yt[i__3].r = z__1.r, yt[i__3].i = z__1.i;
04937 i__3 = j + i__ * a_dim1;
04938 i__4 = jx;
04939 g[iy] += ((d__1 = a[i__3].r, abs(d__1)) + (d__2 = d_imag(&a[j
04940 + i__ * a_dim1]), abs(d__2))) * ((d__3 = x[i__4].r,
04941 abs(d__3)) + (d__4 = d_imag(&x[jx]), abs(d__4)));
04942 jx += incxl;
04943
04944 }
04945 } else if (ctran) {
04946 i__2 = nl;
04947 for (j = 1; j <= i__2; ++j) {
04948 i__3 = iy;
04949 i__4 = iy;
04950 d_cnjg(&z__3, &a[j + i__ * a_dim1]);
04951 i__5 = jx;
04952 z__2.r = z__3.r * x[i__5].r - z__3.i * x[i__5].i, z__2.i =
04953 z__3.r * x[i__5].i + z__3.i * x[i__5].r;
04954 z__1.r = yt[i__4].r + z__2.r, z__1.i = yt[i__4].i + z__2.i;
04955 yt[i__3].r = z__1.r, yt[i__3].i = z__1.i;
04956 i__3 = j + i__ * a_dim1;
04957 i__4 = jx;
04958 g[iy] += ((d__1 = a[i__3].r, abs(d__1)) + (d__2 = d_imag(&a[j
04959 + i__ * a_dim1]), abs(d__2))) * ((d__3 = x[i__4].r,
04960 abs(d__3)) + (d__4 = d_imag(&x[jx]), abs(d__4)));
04961 jx += incxl;
04962
04963 }
04964 } else {
04965 i__2 = nl;
04966 for (j = 1; j <= i__2; ++j) {
04967 i__3 = iy;
04968 i__4 = iy;
04969 i__5 = i__ + j * a_dim1;
04970 i__6 = jx;
04971 z__2.r = a[i__5].r * x[i__6].r - a[i__5].i * x[i__6].i,
04972 z__2.i = a[i__5].r * x[i__6].i + a[i__5].i * x[i__6]
04973 .r;
04974 z__1.r = yt[i__4].r + z__2.r, z__1.i = yt[i__4].i + z__2.i;
04975 yt[i__3].r = z__1.r, yt[i__3].i = z__1.i;
04976 i__3 = i__ + j * a_dim1;
04977 i__4 = jx;
04978 g[iy] += ((d__1 = a[i__3].r, abs(d__1)) + (d__2 = d_imag(&a[
04979 i__ + j * a_dim1]), abs(d__2))) * ((d__3 = x[i__4].r,
04980 abs(d__3)) + (d__4 = d_imag(&x[jx]), abs(d__4)));
04981 jx += incxl;
04982
04983 }
04984 }
04985 i__2 = iy;
04986 i__3 = iy;
04987 z__2.r = alpha->r * yt[i__3].r - alpha->i * yt[i__3].i, z__2.i =
04988 alpha->r * yt[i__3].i + alpha->i * yt[i__3].r;
04989 i__4 = iy;
04990 z__3.r = beta->r * y[i__4].r - beta->i * y[i__4].i, z__3.i = beta->r *
04991 y[i__4].i + beta->i * y[i__4].r;
04992 z__1.r = z__2.r + z__3.r, z__1.i = z__2.i + z__3.i;
04993 yt[i__2].r = z__1.r, yt[i__2].i = z__1.i;
04994 i__2 = iy;
04995 g[iy] = ((d__1 = alpha->r, abs(d__1)) + (d__2 = d_imag(alpha), abs(
04996 d__2))) * g[iy] + ((d__3 = beta->r, abs(d__3)) + (d__4 =
04997 d_imag(beta), abs(d__4))) * ((d__5 = y[i__2].r, abs(d__5)) + (
04998 d__6 = d_imag(&y[iy]), abs(d__6)));
04999 iy += incyl;
05000
05001 }
05002
05003
05004
05005 *err = 0.;
05006 i__1 = ml;
05007 for (i__ = 1; i__ <= i__1; ++i__) {
05008 i__2 = i__;
05009 i__3 = (i__ - 1) * abs(*incy) + 1;
05010 z__1.r = yt[i__2].r - yy[i__3].r, z__1.i = yt[i__2].i - yy[i__3].i;
05011 erri = z_abs(&z__1) / *eps;
05012 if (g[i__] != 0.) {
05013 erri /= g[i__];
05014 }
05015 *err = max(*err,erri);
05016 if (*err * sqrt(*eps) >= 1.) {
05017 goto L60;
05018 }
05019
05020 }
05021
05022 goto L80;
05023
05024
05025
05026 L60:
05027 *fatal = TRUE_;
05028 io___430.ciunit = *nout;
05029 s_wsfe(&io___430);
05030 e_wsfe();
05031 i__1 = ml;
05032 for (i__ = 1; i__ <= i__1; ++i__) {
05033 if (*mv) {
05034 io___431.ciunit = *nout;
05035 s_wsfe(&io___431);
05036 do_fio(&c__1, (char *)&i__, (ftnlen)sizeof(integer));
05037 do_fio(&c__2, (char *)&yt[i__], (ftnlen)sizeof(doublereal));
05038 do_fio(&c__2, (char *)&yy[(i__ - 1) * abs(*incy) + 1], (ftnlen)
05039 sizeof(doublereal));
05040 e_wsfe();
05041 } else {
05042 io___432.ciunit = *nout;
05043 s_wsfe(&io___432);
05044 do_fio(&c__1, (char *)&i__, (ftnlen)sizeof(integer));
05045 do_fio(&c__2, (char *)&yy[(i__ - 1) * abs(*incy) + 1], (ftnlen)
05046 sizeof(doublereal));
05047 do_fio(&c__2, (char *)&yt[i__], (ftnlen)sizeof(doublereal));
05048 e_wsfe();
05049 }
05050
05051 }
05052
05053 L80:
05054 return 0;
05055
05056
05057
05058
05059 }
05060
05061 logical lze_(doublecomplex *ri, doublecomplex *rj, integer *lr)
05062 {
05063
05064 integer i__1, i__2, i__3;
05065 logical ret_val;
05066
05067
05068 integer i__;
05069
05070
05071
05072
05073
05074
05075
05076
05077
05078
05079
05080
05081
05082
05083
05084 --rj;
05085 --ri;
05086
05087
05088 i__1 = *lr;
05089 for (i__ = 1; i__ <= i__1; ++i__) {
05090 i__2 = i__;
05091 i__3 = i__;
05092 if (ri[i__2].r != rj[i__3].r || ri[i__2].i != rj[i__3].i) {
05093 goto L20;
05094 }
05095
05096 }
05097 ret_val = TRUE_;
05098 goto L30;
05099 L20:
05100 ret_val = FALSE_;
05101 L30:
05102 return ret_val;
05103
05104
05105
05106 }
05107
05108 logical lzeres_(char *type__, char *uplo, integer *m, integer *n,
05109 doublecomplex *aa, doublecomplex *as, integer *lda, ftnlen type_len,
05110 ftnlen uplo_len)
05111 {
05112
05113 integer aa_dim1, aa_offset, as_dim1, as_offset, i__1, i__2, i__3, i__4;
05114 logical ret_val;
05115
05116
05117 integer s_cmp(char *, char *, ftnlen, ftnlen);
05118
05119
05120 integer i__, j, ibeg, iend;
05121 logical upper;
05122
05123
05124
05125
05126
05127
05128
05129
05130
05131
05132
05133
05134
05135
05136
05137
05138
05139 as_dim1 = *lda;
05140 as_offset = 1 + as_dim1;
05141 as -= as_offset;
05142 aa_dim1 = *lda;
05143 aa_offset = 1 + aa_dim1;
05144 aa -= aa_offset;
05145
05146
05147 upper = *(unsigned char *)uplo == 'U';
05148 if (s_cmp(type__, "GE", (ftnlen)2, (ftnlen)2) == 0) {
05149 i__1 = *n;
05150 for (j = 1; j <= i__1; ++j) {
05151 i__2 = *lda;
05152 for (i__ = *m + 1; i__ <= i__2; ++i__) {
05153 i__3 = i__ + j * aa_dim1;
05154 i__4 = i__ + j * as_dim1;
05155 if (aa[i__3].r != as[i__4].r || aa[i__3].i != as[i__4].i) {
05156 goto L70;
05157 }
05158
05159 }
05160
05161 }
05162 } else if (s_cmp(type__, "HE", (ftnlen)2, (ftnlen)2) == 0) {
05163 i__1 = *n;
05164 for (j = 1; j <= i__1; ++j) {
05165 if (upper) {
05166 ibeg = 1;
05167 iend = j;
05168 } else {
05169 ibeg = j;
05170 iend = *n;
05171 }
05172 i__2 = ibeg - 1;
05173 for (i__ = 1; i__ <= i__2; ++i__) {
05174 i__3 = i__ + j * aa_dim1;
05175 i__4 = i__ + j * as_dim1;
05176 if (aa[i__3].r != as[i__4].r || aa[i__3].i != as[i__4].i) {
05177 goto L70;
05178 }
05179
05180 }
05181 i__2 = *lda;
05182 for (i__ = iend + 1; i__ <= i__2; ++i__) {
05183 i__3 = i__ + j * aa_dim1;
05184 i__4 = i__ + j * as_dim1;
05185 if (aa[i__3].r != as[i__4].r || aa[i__3].i != as[i__4].i) {
05186 goto L70;
05187 }
05188
05189 }
05190
05191 }
05192 }
05193
05194
05195 ret_val = TRUE_;
05196 goto L80;
05197 L70:
05198 ret_val = FALSE_;
05199 L80:
05200 return ret_val;
05201
05202
05203
05204 }
05205
05206 VOID zbeg_(doublecomplex * ret_val, logical *reset)
05207 {
05208
05209 doublereal d__1, d__2;
05210 doublecomplex z__1;
05211
05212
05213 static integer i__, j, ic, mi, mj;
05214
05215
05216
05217
05218
05219
05220
05221
05222
05223
05224
05225
05226
05227
05228
05229
05230 if (*reset) {
05231
05232 mi = 891;
05233 mj = 457;
05234 i__ = 7;
05235 j = 7;
05236 ic = 0;
05237 *reset = FALSE_;
05238 }
05239
05240
05241
05242
05243
05244
05245
05246
05247 ++ic;
05248 L10:
05249 i__ *= mi;
05250 j *= mj;
05251 i__ -= i__ / 1000 * 1000;
05252 j -= j / 1000 * 1000;
05253 if (ic >= 5) {
05254 ic = 0;
05255 goto L10;
05256 }
05257 d__1 = (i__ - 500) / 1001.;
05258 d__2 = (j - 500) / 1001.;
05259 z__1.r = d__1, z__1.i = d__2;
05260 ret_val->r = z__1.r, ret_val->i = z__1.i;
05261 return ;
05262
05263
05264
05265 }
05266
05267 doublereal ddiff_(doublereal *x, doublereal *y)
05268 {
05269
05270 doublereal ret_val;
05271
05272
05273
05274
05275
05276
05277
05278
05279
05280 ret_val = *x - *y;
05281 return ret_val;
05282
05283
05284
05285 }
05286
05287 int chkxer_(char *srnamt, integer *infot, integer *nout,
05288 logical *lerr, logical *ok)
05289 {
05290
05291 static char fmt_9999[] = "(\002 ***** ILLEGAL VALUE OF PARAMETER NUMBER"
05292 " \002,i2,\002 NOT D\002,\002ETECTED BY \002,a6,\002 *****\002)";
05293
05294
05295 integer s_wsfe(cilist *), do_fio(integer *, char *, ftnlen), e_wsfe(void);
05296
05297
05298 static cilist io___444 = { 0, 0, 0, fmt_9999, 0 };
05299
05300
05301
05302
05303
05304
05305
05306
05307
05308
05309
05310
05311
05312 if (! (*lerr)) {
05313 io___444.ciunit = *nout;
05314 s_wsfe(&io___444);
05315 do_fio(&c__1, (char *)&(*infot), (ftnlen)sizeof(integer));
05316 do_fio(&c__1, srnamt, (ftnlen)6);
05317 e_wsfe();
05318 *ok = FALSE_;
05319 }
05320 *lerr = FALSE_;
05321 return 0;
05322
05323
05324
05325
05326 }
05327
05328 int xerbla_(char *srname, integer *info)
05329 {
05330
05331 static char fmt_9999[] = "(\002 ******* XERBLA WAS CALLED WITH INFO ="
05332 " \002,i6,\002 INSTEAD\002,\002 OF \002,i2,\002 *******\002)";
05333 static char fmt_9997[] = "(\002 ******* XERBLA WAS CALLED WITH INFO ="
05334 " \002,i6,\002 *******\002)";
05335 static char fmt_9998[] = "(\002 ******* XERBLA WAS CALLED WITH SRNAME ="
05336 " \002,a6,\002 INSTE\002,\002AD OF \002,a6,\002 *******\002)";
05337
05338
05339 integer s_wsfe(cilist *), do_fio(integer *, char *, ftnlen), e_wsfe(void),
05340 s_cmp(char *, char *, ftnlen, ftnlen);
05341
05342
05343 static cilist io___445 = { 0, 0, 0, fmt_9999, 0 };
05344 static cilist io___446 = { 0, 0, 0, fmt_9997, 0 };
05345 static cilist io___447 = { 0, 0, 0, fmt_9998, 0 };
05346
05347
05348
05349
05350
05351
05352
05353
05354
05355
05356
05357
05358
05359
05360
05361
05362
05363
05364
05365
05366
05367
05368 infoc_2.lerr = TRUE_;
05369 if (*info != infoc_2.infot) {
05370 if (infoc_2.infot != 0) {
05371 io___445.ciunit = infoc_2.nout;
05372 s_wsfe(&io___445);
05373 do_fio(&c__1, (char *)&(*info), (ftnlen)sizeof(integer));
05374 do_fio(&c__1, (char *)&infoc_2.infot, (ftnlen)sizeof(integer));
05375 e_wsfe();
05376 } else {
05377 io___446.ciunit = infoc_2.nout;
05378 s_wsfe(&io___446);
05379 do_fio(&c__1, (char *)&(*info), (ftnlen)sizeof(integer));
05380 e_wsfe();
05381 }
05382 infoc_2.ok = FALSE_;
05383 }
05384 if (s_cmp(srname, srnamc_1.srnamt, (ftnlen)6, (ftnlen)6) != 0) {
05385 io___447.ciunit = infoc_2.nout;
05386 s_wsfe(&io___447);
05387 do_fio(&c__1, srname, (ftnlen)6);
05388 do_fio(&c__1, srnamc_1.srnamt, (ftnlen)6);
05389 e_wsfe();
05390 infoc_2.ok = FALSE_;
05391 }
05392 return 0;
05393
05394
05395
05396
05397 }
05398
05399 int zblat2_ () { MAIN__ (); return 0; }