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