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