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