00001
00002
00003
00004
00005
00006
00007
00008
00009
00010
00011
00012
00013 #include "f2c.h"
00014 #include "blaswrap.h"
00015
00016
00017
00018 struct {
00019 integer infot, nunit;
00020 logical ok, lerr;
00021 } infoc_;
00022
00023 #define infoc_1 infoc_
00024
00025 struct {
00026 char srnamt[32];
00027 } srnamc_;
00028
00029 #define srnamc_1 srnamc_
00030
00031
00032
00033 static integer c__3 = 3;
00034 static integer c__0 = 0;
00035 static integer c_n1 = -1;
00036 static integer c__1 = 1;
00037 static integer c__2 = 2;
00038 static doublereal c_b43 = 1.;
00039 static doublereal c_b44 = 0.;
00040
00041 int ddrvgt_(logical *dotype, integer *nn, integer *nval,
00042 integer *nrhs, doublereal *thresh, logical *tsterr, doublereal *a,
00043 doublereal *af, doublereal *b, doublereal *x, doublereal *xact,
00044 doublereal *work, doublereal *rwork, integer *iwork, integer *nout)
00045 {
00046
00047
00048 static integer iseedy[4] = { 0,0,0,1 };
00049 static char transs[1*3] = "N" "T" "C";
00050
00051
00052 static char fmt_9999[] = "(1x,a,\002, N =\002,i5,\002, type \002,i2,\002"
00053 ", test \002,i2,\002, ratio = \002,g12.5)";
00054 static char fmt_9998[] = "(1x,a,\002, FACT='\002,a1,\002', TRANS='\002,a"
00055 "1,\002', N =\002,i5,\002, type \002,i2,\002, test \002,i2,\002, "
00056 "ratio = \002,g12.5)";
00057
00058
00059 address a__1[2];
00060 integer i__1, i__2, i__3, i__4, i__5[2];
00061 doublereal d__1, d__2;
00062 char ch__1[2];
00063
00064
00065 int s_copy(char *, char *, ftnlen, ftnlen);
00066 integer s_wsfe(cilist *), do_fio(integer *, char *, ftnlen), e_wsfe(void);
00067 int s_cat(char *, char **, integer *, integer *, ftnlen);
00068
00069
00070 integer i__, j, k, m, n;
00071 doublereal z__[3];
00072 integer k1, in, kl, ku, ix, nt, lda;
00073 char fact[1];
00074 doublereal cond;
00075 integer mode, koff, imat, info;
00076 char path[3], dist[1], type__[1];
00077 integer nrun, ifact;
00078 extern int dget04_(integer *, integer *, doublereal *,
00079 integer *, doublereal *, integer *, doublereal *, doublereal *),
00080 dscal_(integer *, doublereal *, doublereal *, integer *);
00081 integer nfail, iseed[4];
00082 extern doublereal dget06_(doublereal *, doublereal *);
00083 extern int dgtt01_(integer *, doublereal *, doublereal *,
00084 doublereal *, doublereal *, doublereal *, doublereal *,
00085 doublereal *, integer *, doublereal *, integer *, doublereal *,
00086 doublereal *), dgtt02_(char *, integer *, integer *, doublereal *,
00087 doublereal *, doublereal *, doublereal *, integer *, doublereal *
00088 , integer *, doublereal *, doublereal *);
00089 doublereal rcond;
00090 extern int dgtt05_(char *, integer *, integer *,
00091 doublereal *, doublereal *, doublereal *, doublereal *, integer *,
00092 doublereal *, integer *, doublereal *, integer *, doublereal *,
00093 doublereal *, doublereal *);
00094 integer nimat;
00095 extern doublereal dasum_(integer *, doublereal *, integer *);
00096 doublereal anorm;
00097 integer itran;
00098 extern int dcopy_(integer *, doublereal *, integer *,
00099 doublereal *, integer *);
00100 char trans[1];
00101 integer izero, nerrs;
00102 extern int dgtsv_(integer *, integer *, doublereal *,
00103 doublereal *, doublereal *, doublereal *, integer *, integer *);
00104 logical zerot;
00105 extern int dlatb4_(char *, integer *, integer *, integer
00106 *, char *, integer *, integer *, doublereal *, integer *,
00107 doublereal *, char *), aladhd_(integer *,
00108 char *), alaerh_(char *, char *, integer *, integer *,
00109 char *, integer *, integer *, integer *, integer *, integer *,
00110 integer *, integer *, integer *, integer *);
00111 doublereal rcondc;
00112 extern doublereal dlangt_(char *, integer *, doublereal *, doublereal *,
00113 doublereal *);
00114 extern int dlagtm_(char *, integer *, integer *,
00115 doublereal *, doublereal *, doublereal *, doublereal *,
00116 doublereal *, integer *, doublereal *, doublereal *, integer *), dlacpy_(char *, integer *, integer *, doublereal *,
00117 integer *, doublereal *, integer *), dlaset_(char *,
00118 integer *, integer *, doublereal *, doublereal *, doublereal *,
00119 integer *);
00120 doublereal rcondi;
00121 extern int alasvm_(char *, integer *, integer *, integer
00122 *, integer *);
00123 doublereal rcondo, anormi;
00124 extern int dlarnv_(integer *, integer *, integer *,
00125 doublereal *), dlatms_(integer *, integer *, char *, integer *,
00126 char *, doublereal *, integer *, doublereal *, doublereal *,
00127 integer *, integer *, char *, doublereal *, integer *, doublereal
00128 *, integer *);
00129 doublereal ainvnm;
00130 logical trfcon;
00131 doublereal anormo;
00132 extern int dgttrf_(integer *, doublereal *, doublereal *,
00133 doublereal *, doublereal *, integer *, integer *), dgttrs_(char *
00134 , integer *, integer *, doublereal *, doublereal *, doublereal *,
00135 doublereal *, integer *, doublereal *, integer *, integer *), derrvx_(char *, integer *);
00136 doublereal result[6];
00137 extern int dgtsvx_(char *, char *, integer *, integer *,
00138 doublereal *, doublereal *, doublereal *, doublereal *,
00139 doublereal *, doublereal *, doublereal *, integer *, doublereal *,
00140 integer *, doublereal *, integer *, doublereal *, doublereal *,
00141 doublereal *, doublereal *, integer *, integer *);
00142
00143
00144 static cilist io___42 = { 0, 0, 0, fmt_9999, 0 };
00145 static cilist io___46 = { 0, 0, 0, fmt_9998, 0 };
00146 static cilist io___47 = { 0, 0, 0, fmt_9998, 0 };
00147
00148
00149
00150
00151
00152
00153
00154
00155
00156
00157
00158
00159
00160
00161
00162
00163
00164
00165
00166
00167
00168
00169
00170
00171
00172
00173
00174
00175
00176
00177
00178
00179
00180
00181
00182
00183
00184
00185
00186
00187
00188
00189
00190
00191
00192
00193
00194
00195
00196
00197
00198
00199
00200
00201
00202
00203
00204
00205
00206
00207
00208
00209
00210
00211
00212
00213
00214
00215
00216
00217
00218
00219
00220
00221
00222
00223
00224
00225
00226
00227 --iwork;
00228 --rwork;
00229 --work;
00230 --xact;
00231 --x;
00232 --b;
00233 --af;
00234 --a;
00235 --nval;
00236 --dotype;
00237
00238
00239
00240
00241
00242 s_copy(path, "Double precision", (ftnlen)1, (ftnlen)16);
00243 s_copy(path + 1, "GT", (ftnlen)2, (ftnlen)2);
00244 nrun = 0;
00245 nfail = 0;
00246 nerrs = 0;
00247 for (i__ = 1; i__ <= 4; ++i__) {
00248 iseed[i__ - 1] = iseedy[i__ - 1];
00249
00250 }
00251
00252
00253
00254 if (*tsterr) {
00255 derrvx_(path, nout);
00256 }
00257 infoc_1.infot = 0;
00258
00259 i__1 = *nn;
00260 for (in = 1; in <= i__1; ++in) {
00261
00262
00263
00264 n = nval[in];
00265
00266 i__2 = n - 1;
00267 m = max(i__2,0);
00268 lda = max(1,n);
00269 nimat = 12;
00270 if (n <= 0) {
00271 nimat = 1;
00272 }
00273
00274 i__2 = nimat;
00275 for (imat = 1; imat <= i__2; ++imat) {
00276
00277
00278
00279 if (! dotype[imat]) {
00280 goto L130;
00281 }
00282
00283
00284
00285 dlatb4_(path, &imat, &n, &n, type__, &kl, &ku, &anorm, &mode, &
00286 cond, dist);
00287
00288 zerot = imat >= 8 && imat <= 10;
00289 if (imat <= 6) {
00290
00291
00292
00293
00294 i__3 = 2 - ku, i__4 = 3 - max(1,n);
00295 koff = max(i__3,i__4);
00296 s_copy(srnamc_1.srnamt, "DLATMS", (ftnlen)32, (ftnlen)6);
00297 dlatms_(&n, &n, dist, iseed, type__, &rwork[1], &mode, &cond,
00298 &anorm, &kl, &ku, "Z", &af[koff], &c__3, &work[1], &
00299 info);
00300
00301
00302
00303 if (info != 0) {
00304 alaerh_(path, "DLATMS", &info, &c__0, " ", &n, &n, &kl, &
00305 ku, &c_n1, &imat, &nfail, &nerrs, nout);
00306 goto L130;
00307 }
00308 izero = 0;
00309
00310 if (n > 1) {
00311 i__3 = n - 1;
00312 dcopy_(&i__3, &af[4], &c__3, &a[1], &c__1);
00313 i__3 = n - 1;
00314 dcopy_(&i__3, &af[3], &c__3, &a[n + m + 1], &c__1);
00315 }
00316 dcopy_(&n, &af[2], &c__3, &a[m + 1], &c__1);
00317 } else {
00318
00319
00320
00321
00322 if (! zerot || ! dotype[7]) {
00323
00324
00325
00326 i__3 = n + (m << 1);
00327 dlarnv_(&c__2, iseed, &i__3, &a[1]);
00328 if (anorm != 1.) {
00329 i__3 = n + (m << 1);
00330 dscal_(&i__3, &anorm, &a[1], &c__1);
00331 }
00332 } else if (izero > 0) {
00333
00334
00335
00336
00337 if (izero == 1) {
00338 a[n] = z__[1];
00339 if (n > 1) {
00340 a[1] = z__[2];
00341 }
00342 } else if (izero == n) {
00343 a[n * 3 - 2] = z__[0];
00344 a[(n << 1) - 1] = z__[1];
00345 } else {
00346 a[(n << 1) - 2 + izero] = z__[0];
00347 a[n - 1 + izero] = z__[1];
00348 a[izero] = z__[2];
00349 }
00350 }
00351
00352
00353
00354 if (! zerot) {
00355 izero = 0;
00356 } else if (imat == 8) {
00357 izero = 1;
00358 z__[1] = a[n];
00359 a[n] = 0.;
00360 if (n > 1) {
00361 z__[2] = a[1];
00362 a[1] = 0.;
00363 }
00364 } else if (imat == 9) {
00365 izero = n;
00366 z__[0] = a[n * 3 - 2];
00367 z__[1] = a[(n << 1) - 1];
00368 a[n * 3 - 2] = 0.;
00369 a[(n << 1) - 1] = 0.;
00370 } else {
00371 izero = (n + 1) / 2;
00372 i__3 = n - 1;
00373 for (i__ = izero; i__ <= i__3; ++i__) {
00374 a[(n << 1) - 2 + i__] = 0.;
00375 a[n - 1 + i__] = 0.;
00376 a[i__] = 0.;
00377
00378 }
00379 a[n * 3 - 2] = 0.;
00380 a[(n << 1) - 1] = 0.;
00381 }
00382 }
00383
00384 for (ifact = 1; ifact <= 2; ++ifact) {
00385 if (ifact == 1) {
00386 *(unsigned char *)fact = 'F';
00387 } else {
00388 *(unsigned char *)fact = 'N';
00389 }
00390
00391
00392
00393
00394 if (zerot) {
00395 if (ifact == 1) {
00396 goto L120;
00397 }
00398 rcondo = 0.;
00399 rcondi = 0.;
00400
00401 } else if (ifact == 1) {
00402 i__3 = n + (m << 1);
00403 dcopy_(&i__3, &a[1], &c__1, &af[1], &c__1);
00404
00405
00406
00407 anormo = dlangt_("1", &n, &a[1], &a[m + 1], &a[n + m + 1]);
00408 anormi = dlangt_("I", &n, &a[1], &a[m + 1], &a[n + m + 1]);
00409
00410
00411
00412 dgttrf_(&n, &af[1], &af[m + 1], &af[n + m + 1], &af[n + (
00413 m << 1) + 1], &iwork[1], &info);
00414
00415
00416
00417
00418 ainvnm = 0.;
00419 i__3 = n;
00420 for (i__ = 1; i__ <= i__3; ++i__) {
00421 i__4 = n;
00422 for (j = 1; j <= i__4; ++j) {
00423 x[j] = 0.;
00424
00425 }
00426 x[i__] = 1.;
00427 dgttrs_("No transpose", &n, &c__1, &af[1], &af[m + 1],
00428 &af[n + m + 1], &af[n + (m << 1) + 1], &
00429 iwork[1], &x[1], &lda, &info);
00430
00431 d__1 = ainvnm, d__2 = dasum_(&n, &x[1], &c__1);
00432 ainvnm = max(d__1,d__2);
00433
00434 }
00435
00436
00437
00438 if (anormo <= 0. || ainvnm <= 0.) {
00439 rcondo = 1.;
00440 } else {
00441 rcondo = 1. / anormo / ainvnm;
00442 }
00443
00444
00445
00446
00447 ainvnm = 0.;
00448 i__3 = n;
00449 for (i__ = 1; i__ <= i__3; ++i__) {
00450 i__4 = n;
00451 for (j = 1; j <= i__4; ++j) {
00452 x[j] = 0.;
00453
00454 }
00455 x[i__] = 1.;
00456 dgttrs_("Transpose", &n, &c__1, &af[1], &af[m + 1], &
00457 af[n + m + 1], &af[n + (m << 1) + 1], &iwork[
00458 1], &x[1], &lda, &info);
00459
00460 d__1 = ainvnm, d__2 = dasum_(&n, &x[1], &c__1);
00461 ainvnm = max(d__1,d__2);
00462
00463 }
00464
00465
00466
00467 if (anormi <= 0. || ainvnm <= 0.) {
00468 rcondi = 1.;
00469 } else {
00470 rcondi = 1. / anormi / ainvnm;
00471 }
00472 }
00473
00474 for (itran = 1; itran <= 3; ++itran) {
00475 *(unsigned char *)trans = *(unsigned char *)&transs[itran
00476 - 1];
00477 if (itran == 1) {
00478 rcondc = rcondo;
00479 } else {
00480 rcondc = rcondi;
00481 }
00482
00483
00484
00485 ix = 1;
00486 i__3 = *nrhs;
00487 for (j = 1; j <= i__3; ++j) {
00488 dlarnv_(&c__2, iseed, &n, &xact[ix]);
00489 ix += lda;
00490
00491 }
00492
00493
00494
00495 dlagtm_(trans, &n, nrhs, &c_b43, &a[1], &a[m + 1], &a[n +
00496 m + 1], &xact[1], &lda, &c_b44, &b[1], &lda);
00497
00498 if (ifact == 2 && itran == 1) {
00499
00500
00501
00502
00503
00504
00505 i__3 = n + (m << 1);
00506 dcopy_(&i__3, &a[1], &c__1, &af[1], &c__1);
00507 dlacpy_("Full", &n, nrhs, &b[1], &lda, &x[1], &lda);
00508
00509 s_copy(srnamc_1.srnamt, "DGTSV ", (ftnlen)32, (ftnlen)
00510 6);
00511 dgtsv_(&n, nrhs, &af[1], &af[m + 1], &af[n + m + 1], &
00512 x[1], &lda, &info);
00513
00514
00515
00516 if (info != izero) {
00517 alaerh_(path, "DGTSV ", &info, &izero, " ", &n, &
00518 n, &c__1, &c__1, nrhs, &imat, &nfail, &
00519 nerrs, nout);
00520 }
00521 nt = 1;
00522 if (izero == 0) {
00523
00524
00525
00526 dlacpy_("Full", &n, nrhs, &b[1], &lda, &work[1], &
00527 lda);
00528 dgtt02_(trans, &n, nrhs, &a[1], &a[m + 1], &a[n +
00529 m + 1], &x[1], &lda, &work[1], &lda, &
00530 rwork[1], &result[1]);
00531
00532
00533
00534 dget04_(&n, nrhs, &x[1], &lda, &xact[1], &lda, &
00535 rcondc, &result[2]);
00536 nt = 3;
00537 }
00538
00539
00540
00541
00542 i__3 = nt;
00543 for (k = 2; k <= i__3; ++k) {
00544 if (result[k - 1] >= *thresh) {
00545 if (nfail == 0 && nerrs == 0) {
00546 aladhd_(nout, path);
00547 }
00548 io___42.ciunit = *nout;
00549 s_wsfe(&io___42);
00550 do_fio(&c__1, "DGTSV ", (ftnlen)6);
00551 do_fio(&c__1, (char *)&n, (ftnlen)sizeof(
00552 integer));
00553 do_fio(&c__1, (char *)&imat, (ftnlen)sizeof(
00554 integer));
00555 do_fio(&c__1, (char *)&k, (ftnlen)sizeof(
00556 integer));
00557 do_fio(&c__1, (char *)&result[k - 1], (ftnlen)
00558 sizeof(doublereal));
00559 e_wsfe();
00560 ++nfail;
00561 }
00562
00563 }
00564 nrun = nrun + nt - 1;
00565 }
00566
00567
00568
00569 if (ifact > 1) {
00570
00571
00572
00573 i__3 = n * 3 - 2;
00574 for (i__ = 1; i__ <= i__3; ++i__) {
00575 af[i__] = 0.;
00576
00577 }
00578 }
00579 dlaset_("Full", &n, nrhs, &c_b44, &c_b44, &x[1], &lda);
00580
00581
00582
00583
00584 s_copy(srnamc_1.srnamt, "DGTSVX", (ftnlen)32, (ftnlen)6);
00585 dgtsvx_(fact, trans, &n, nrhs, &a[1], &a[m + 1], &a[n + m
00586 + 1], &af[1], &af[m + 1], &af[n + m + 1], &af[n +
00587 (m << 1) + 1], &iwork[1], &b[1], &lda, &x[1], &
00588 lda, &rcond, &rwork[1], &rwork[*nrhs + 1], &work[
00589 1], &iwork[n + 1], &info);
00590
00591
00592
00593 if (info != izero) {
00594
00595 i__5[0] = 1, a__1[0] = fact;
00596 i__5[1] = 1, a__1[1] = trans;
00597 s_cat(ch__1, a__1, i__5, &c__2, (ftnlen)2);
00598 alaerh_(path, "DGTSVX", &info, &izero, ch__1, &n, &n,
00599 &c__1, &c__1, nrhs, &imat, &nfail, &nerrs,
00600 nout);
00601 }
00602
00603 if (ifact >= 2) {
00604
00605
00606
00607
00608 dgtt01_(&n, &a[1], &a[m + 1], &a[n + m + 1], &af[1], &
00609 af[m + 1], &af[n + m + 1], &af[n + (m << 1) +
00610 1], &iwork[1], &work[1], &lda, &rwork[1],
00611 result);
00612 k1 = 1;
00613 } else {
00614 k1 = 2;
00615 }
00616
00617 if (info == 0) {
00618 trfcon = FALSE_;
00619
00620
00621
00622 dlacpy_("Full", &n, nrhs, &b[1], &lda, &work[1], &lda);
00623 dgtt02_(trans, &n, nrhs, &a[1], &a[m + 1], &a[n + m +
00624 1], &x[1], &lda, &work[1], &lda, &rwork[1], &
00625 result[1]);
00626
00627
00628
00629 dget04_(&n, nrhs, &x[1], &lda, &xact[1], &lda, &
00630 rcondc, &result[2]);
00631
00632
00633
00634 dgtt05_(trans, &n, nrhs, &a[1], &a[m + 1], &a[n + m +
00635 1], &b[1], &lda, &x[1], &lda, &xact[1], &lda,
00636 &rwork[1], &rwork[*nrhs + 1], &result[3]);
00637 nt = 5;
00638 }
00639
00640
00641
00642
00643 i__3 = nt;
00644 for (k = k1; k <= i__3; ++k) {
00645 if (result[k - 1] >= *thresh) {
00646 if (nfail == 0 && nerrs == 0) {
00647 aladhd_(nout, path);
00648 }
00649 io___46.ciunit = *nout;
00650 s_wsfe(&io___46);
00651 do_fio(&c__1, "DGTSVX", (ftnlen)6);
00652 do_fio(&c__1, fact, (ftnlen)1);
00653 do_fio(&c__1, trans, (ftnlen)1);
00654 do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer))
00655 ;
00656 do_fio(&c__1, (char *)&imat, (ftnlen)sizeof(
00657 integer));
00658 do_fio(&c__1, (char *)&k, (ftnlen)sizeof(integer))
00659 ;
00660 do_fio(&c__1, (char *)&result[k - 1], (ftnlen)
00661 sizeof(doublereal));
00662 e_wsfe();
00663 ++nfail;
00664 }
00665
00666 }
00667
00668
00669
00670 result[5] = dget06_(&rcond, &rcondc);
00671 if (result[5] >= *thresh) {
00672 if (nfail == 0 && nerrs == 0) {
00673 aladhd_(nout, path);
00674 }
00675 io___47.ciunit = *nout;
00676 s_wsfe(&io___47);
00677 do_fio(&c__1, "DGTSVX", (ftnlen)6);
00678 do_fio(&c__1, fact, (ftnlen)1);
00679 do_fio(&c__1, trans, (ftnlen)1);
00680 do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
00681 do_fio(&c__1, (char *)&imat, (ftnlen)sizeof(integer));
00682 do_fio(&c__1, (char *)&k, (ftnlen)sizeof(integer));
00683 do_fio(&c__1, (char *)&result[k - 1], (ftnlen)sizeof(
00684 doublereal));
00685 e_wsfe();
00686 ++nfail;
00687 }
00688 nrun = nrun + nt - k1 + 2;
00689
00690
00691 }
00692 L120:
00693 ;
00694 }
00695 L130:
00696 ;
00697 }
00698
00699 }
00700
00701
00702
00703 alasvm_(path, nout, &nfail, &nrun, &nerrs);
00704
00705 return 0;
00706
00707
00708
00709 }