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__2 = 2;
00034 static integer c__0 = 0;
00035 static integer c_n1 = -1;
00036 static integer c__1 = 1;
00037 static doublereal c_b46 = 1.;
00038 static doublereal c_b47 = 0.;
00039 static integer c__7 = 7;
00040
00041 int dchkpt_(logical *dotype, integer *nn, integer *nval,
00042 integer *nns, integer *nsval, doublereal *thresh, logical *tsterr,
00043 doublereal *a, doublereal *d__, doublereal *e, doublereal *b,
00044 doublereal *x, doublereal *xact, doublereal *work, doublereal *rwork,
00045 integer *nout)
00046 {
00047
00048
00049 static integer iseedy[4] = { 0,0,0,1 };
00050
00051
00052 static char fmt_9999[] = "(\002 N =\002,i5,\002, type \002,i2,\002, te"
00053 "st \002,i2,\002, ratio = \002,g12.5)";
00054 static char fmt_9998[] = "(\002 N =\002,i5,\002, NRHS=\002,i3,\002, ty"
00055 "pe \002,i2,\002, test(\002,i2,\002) = \002,g12.5)";
00056
00057
00058 integer i__1, i__2, i__3, i__4;
00059 doublereal d__1, d__2, d__3;
00060
00061
00062 int s_copy(char *, char *, ftnlen, ftnlen);
00063 integer s_wsfe(cilist *), do_fio(integer *, char *, ftnlen), e_wsfe(void);
00064
00065
00066 integer i__, j, k, n;
00067 doublereal z__[3];
00068 integer ia, in, kl, ku, ix, lda;
00069 doublereal cond;
00070 integer mode;
00071 doublereal dmax__;
00072 integer imat, info;
00073 char path[3], dist[1];
00074 integer irhs, nrhs;
00075 char type__[1];
00076 integer nrun;
00077 extern int alahd_(integer *, char *), dscal_(
00078 integer *, doublereal *, doublereal *, integer *), dget04_(
00079 integer *, integer *, doublereal *, integer *, doublereal *,
00080 integer *, doublereal *, doublereal *);
00081 integer nfail, iseed[4];
00082 extern doublereal dget06_(doublereal *, doublereal *);
00083 doublereal rcond;
00084 integer nimat;
00085 extern doublereal dasum_(integer *, doublereal *, integer *);
00086 doublereal anorm;
00087 extern int dptt01_(integer *, doublereal *, doublereal *,
00088 doublereal *, doublereal *, doublereal *, doublereal *), dcopy_(
00089 integer *, doublereal *, integer *, doublereal *, integer *),
00090 dptt02_(integer *, integer *, doublereal *, doublereal *,
00091 doublereal *, integer *, doublereal *, integer *, doublereal *),
00092 dptt05_(integer *, integer *, doublereal *, doublereal *,
00093 doublereal *, integer *, doublereal *, integer *, doublereal *,
00094 integer *, doublereal *, doublereal *, doublereal *);
00095 integer izero, nerrs;
00096 logical zerot;
00097 extern int dlatb4_(char *, integer *, integer *, integer
00098 *, char *, integer *, integer *, doublereal *, integer *,
00099 doublereal *, char *), alaerh_(char *,
00100 char *, integer *, integer *, char *, integer *, integer *,
00101 integer *, integer *, integer *, integer *, integer *, integer *,
00102 integer *);
00103 extern integer idamax_(integer *, doublereal *, integer *);
00104 doublereal rcondc;
00105 extern int dlacpy_(char *, integer *, integer *,
00106 doublereal *, integer *, doublereal *, integer *),
00107 dlaptm_(integer *, integer *, doublereal *, doublereal *,
00108 doublereal *, doublereal *, integer *, doublereal *, doublereal *,
00109 integer *), alasum_(char *, integer *, integer *, integer *,
00110 integer *), dlatms_(integer *, integer *, char *, integer
00111 *, char *, doublereal *, integer *, doublereal *, doublereal *,
00112 integer *, integer *, char *, doublereal *, integer *, doublereal
00113 *, integer *);
00114 extern doublereal dlanst_(char *, integer *, doublereal *, doublereal *);
00115 extern int dlarnv_(integer *, integer *, integer *,
00116 doublereal *), derrgt_(char *, integer *);
00117 doublereal ainvnm;
00118 extern int dptcon_(integer *, doublereal *, doublereal *,
00119 doublereal *, doublereal *, doublereal *, integer *), dptrfs_(
00120 integer *, integer *, doublereal *, doublereal *, doublereal *,
00121 doublereal *, doublereal *, integer *, doublereal *, integer *,
00122 doublereal *, doublereal *, doublereal *, integer *), dpttrf_(
00123 integer *, doublereal *, doublereal *, integer *);
00124 doublereal result[7];
00125 extern int dpttrs_(integer *, integer *, doublereal *,
00126 doublereal *, doublereal *, integer *, integer *);
00127
00128
00129 static cilist io___29 = { 0, 0, 0, fmt_9999, 0 };
00130 static cilist io___35 = { 0, 0, 0, fmt_9998, 0 };
00131 static cilist io___37 = { 0, 0, 0, fmt_9999, 0 };
00132
00133
00134
00135
00136
00137
00138
00139
00140
00141
00142
00143
00144
00145
00146
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 --rwork;
00220 --work;
00221 --xact;
00222 --x;
00223 --b;
00224 --e;
00225 --d__;
00226 --a;
00227 --nsval;
00228 --nval;
00229 --dotype;
00230
00231
00232
00233
00234
00235 s_copy(path, "Double precision", (ftnlen)1, (ftnlen)16);
00236 s_copy(path + 1, "PT", (ftnlen)2, (ftnlen)2);
00237 nrun = 0;
00238 nfail = 0;
00239 nerrs = 0;
00240 for (i__ = 1; i__ <= 4; ++i__) {
00241 iseed[i__ - 1] = iseedy[i__ - 1];
00242
00243 }
00244
00245
00246
00247 if (*tsterr) {
00248 derrgt_(path, nout);
00249 }
00250 infoc_1.infot = 0;
00251
00252 i__1 = *nn;
00253 for (in = 1; in <= i__1; ++in) {
00254
00255
00256
00257 n = nval[in];
00258 lda = max(1,n);
00259 nimat = 12;
00260 if (n <= 0) {
00261 nimat = 1;
00262 }
00263
00264 i__2 = nimat;
00265 for (imat = 1; imat <= i__2; ++imat) {
00266
00267
00268
00269 if (n > 0 && ! dotype[imat]) {
00270 goto L100;
00271 }
00272
00273
00274
00275 dlatb4_(path, &imat, &n, &n, type__, &kl, &ku, &anorm, &mode, &
00276 cond, dist);
00277
00278 zerot = imat >= 8 && imat <= 10;
00279 if (imat <= 6) {
00280
00281
00282
00283
00284 s_copy(srnamc_1.srnamt, "DLATMS", (ftnlen)32, (ftnlen)6);
00285 dlatms_(&n, &n, dist, iseed, type__, &rwork[1], &mode, &cond,
00286 &anorm, &kl, &ku, "B", &a[1], &c__2, &work[1], &info);
00287
00288
00289
00290 if (info != 0) {
00291 alaerh_(path, "DLATMS", &info, &c__0, " ", &n, &n, &kl, &
00292 ku, &c_n1, &imat, &nfail, &nerrs, nout);
00293 goto L100;
00294 }
00295 izero = 0;
00296
00297
00298
00299 ia = 1;
00300 i__3 = n - 1;
00301 for (i__ = 1; i__ <= i__3; ++i__) {
00302 d__[i__] = a[ia];
00303 e[i__] = a[ia + 1];
00304 ia += 2;
00305
00306 }
00307 if (n > 0) {
00308 d__[n] = a[ia];
00309 }
00310 } else {
00311
00312
00313
00314
00315 if (! zerot || ! dotype[7]) {
00316
00317
00318
00319 dlarnv_(&c__2, iseed, &n, &d__[1]);
00320 i__3 = n - 1;
00321 dlarnv_(&c__2, iseed, &i__3, &e[1]);
00322
00323
00324
00325 if (n == 1) {
00326 d__[1] = abs(d__[1]);
00327 } else {
00328 d__[1] = abs(d__[1]) + abs(e[1]);
00329 d__[n] = (d__1 = d__[n], abs(d__1)) + (d__2 = e[n - 1]
00330 , abs(d__2));
00331 i__3 = n - 1;
00332 for (i__ = 2; i__ <= i__3; ++i__) {
00333 d__[i__] = (d__1 = d__[i__], abs(d__1)) + (d__2 =
00334 e[i__], abs(d__2)) + (d__3 = e[i__ - 1],
00335 abs(d__3));
00336
00337 }
00338 }
00339
00340
00341
00342 ix = idamax_(&n, &d__[1], &c__1);
00343 dmax__ = d__[ix];
00344 d__1 = anorm / dmax__;
00345 dscal_(&n, &d__1, &d__[1], &c__1);
00346 i__3 = n - 1;
00347 d__1 = anorm / dmax__;
00348 dscal_(&i__3, &d__1, &e[1], &c__1);
00349
00350 } else if (izero > 0) {
00351
00352
00353
00354
00355 if (izero == 1) {
00356 d__[1] = z__[1];
00357 if (n > 1) {
00358 e[1] = z__[2];
00359 }
00360 } else if (izero == n) {
00361 e[n - 1] = z__[0];
00362 d__[n] = z__[1];
00363 } else {
00364 e[izero - 1] = z__[0];
00365 d__[izero] = z__[1];
00366 e[izero] = z__[2];
00367 }
00368 }
00369
00370
00371
00372
00373 izero = 0;
00374 if (imat == 8) {
00375 izero = 1;
00376 z__[1] = d__[1];
00377 d__[1] = 0.;
00378 if (n > 1) {
00379 z__[2] = e[1];
00380 e[1] = 0.;
00381 }
00382 } else if (imat == 9) {
00383 izero = n;
00384 if (n > 1) {
00385 z__[0] = e[n - 1];
00386 e[n - 1] = 0.;
00387 }
00388 z__[1] = d__[n];
00389 d__[n] = 0.;
00390 } else if (imat == 10) {
00391 izero = (n + 1) / 2;
00392 if (izero > 1) {
00393 z__[0] = e[izero - 1];
00394 e[izero - 1] = 0.;
00395 z__[2] = e[izero];
00396 e[izero] = 0.;
00397 }
00398 z__[1] = d__[izero];
00399 d__[izero] = 0.;
00400 }
00401 }
00402
00403 dcopy_(&n, &d__[1], &c__1, &d__[n + 1], &c__1);
00404 if (n > 1) {
00405 i__3 = n - 1;
00406 dcopy_(&i__3, &e[1], &c__1, &e[n + 1], &c__1);
00407 }
00408
00409
00410
00411
00412
00413 dpttrf_(&n, &d__[n + 1], &e[n + 1], &info);
00414
00415
00416
00417 if (info != izero) {
00418 alaerh_(path, "DPTTRF", &info, &izero, " ", &n, &n, &c_n1, &
00419 c_n1, &c_n1, &imat, &nfail, &nerrs, nout);
00420 goto L100;
00421 }
00422
00423 if (info > 0) {
00424 rcondc = 0.;
00425 goto L90;
00426 }
00427
00428 dptt01_(&n, &d__[1], &e[1], &d__[n + 1], &e[n + 1], &work[1],
00429 result);
00430
00431
00432
00433 if (result[0] >= *thresh) {
00434 if (nfail == 0 && nerrs == 0) {
00435 alahd_(nout, path);
00436 }
00437 io___29.ciunit = *nout;
00438 s_wsfe(&io___29);
00439 do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
00440 do_fio(&c__1, (char *)&imat, (ftnlen)sizeof(integer));
00441 do_fio(&c__1, (char *)&c__1, (ftnlen)sizeof(integer));
00442 do_fio(&c__1, (char *)&result[0], (ftnlen)sizeof(doublereal));
00443 e_wsfe();
00444 ++nfail;
00445 }
00446 ++nrun;
00447
00448
00449
00450
00451
00452 anorm = dlanst_("1", &n, &d__[1], &e[1]);
00453
00454
00455
00456
00457 ainvnm = 0.;
00458 i__3 = n;
00459 for (i__ = 1; i__ <= i__3; ++i__) {
00460 i__4 = n;
00461 for (j = 1; j <= i__4; ++j) {
00462 x[j] = 0.;
00463
00464 }
00465 x[i__] = 1.;
00466 dpttrs_(&n, &c__1, &d__[n + 1], &e[n + 1], &x[1], &lda, &info)
00467 ;
00468
00469 d__1 = ainvnm, d__2 = dasum_(&n, &x[1], &c__1);
00470 ainvnm = max(d__1,d__2);
00471
00472 }
00473
00474 d__1 = 1., d__2 = anorm * ainvnm;
00475 rcondc = 1. / max(d__1,d__2);
00476
00477 i__3 = *nns;
00478 for (irhs = 1; irhs <= i__3; ++irhs) {
00479 nrhs = nsval[irhs];
00480
00481
00482
00483 ix = 1;
00484 i__4 = nrhs;
00485 for (j = 1; j <= i__4; ++j) {
00486 dlarnv_(&c__2, iseed, &n, &xact[ix]);
00487 ix += lda;
00488
00489 }
00490
00491
00492
00493 dlaptm_(&n, &nrhs, &c_b46, &d__[1], &e[1], &xact[1], &lda, &
00494 c_b47, &b[1], &lda);
00495
00496
00497
00498
00499 dlacpy_("Full", &n, &nrhs, &b[1], &lda, &x[1], &lda);
00500 dpttrs_(&n, &nrhs, &d__[n + 1], &e[n + 1], &x[1], &lda, &info)
00501 ;
00502
00503
00504
00505 if (info != 0) {
00506 alaerh_(path, "DPTTRS", &info, &c__0, " ", &n, &n, &c_n1,
00507 &c_n1, &nrhs, &imat, &nfail, &nerrs, nout);
00508 }
00509
00510 dlacpy_("Full", &n, &nrhs, &b[1], &lda, &work[1], &lda);
00511 dptt02_(&n, &nrhs, &d__[1], &e[1], &x[1], &lda, &work[1], &
00512 lda, &result[1]);
00513
00514
00515
00516
00517 dget04_(&n, &nrhs, &x[1], &lda, &xact[1], &lda, &rcondc, &
00518 result[2]);
00519
00520
00521
00522
00523 s_copy(srnamc_1.srnamt, "DPTRFS", (ftnlen)32, (ftnlen)6);
00524 dptrfs_(&n, &nrhs, &d__[1], &e[1], &d__[n + 1], &e[n + 1], &b[
00525 1], &lda, &x[1], &lda, &rwork[1], &rwork[nrhs + 1], &
00526 work[1], &info);
00527
00528
00529
00530 if (info != 0) {
00531 alaerh_(path, "DPTRFS", &info, &c__0, " ", &n, &n, &c_n1,
00532 &c_n1, &nrhs, &imat, &nfail, &nerrs, nout);
00533 }
00534
00535 dget04_(&n, &nrhs, &x[1], &lda, &xact[1], &lda, &rcondc, &
00536 result[3]);
00537 dptt05_(&n, &nrhs, &d__[1], &e[1], &b[1], &lda, &x[1], &lda, &
00538 xact[1], &lda, &rwork[1], &rwork[nrhs + 1], &result[4]
00539 );
00540
00541
00542
00543
00544 for (k = 2; k <= 6; ++k) {
00545 if (result[k - 1] >= *thresh) {
00546 if (nfail == 0 && nerrs == 0) {
00547 alahd_(nout, path);
00548 }
00549 io___35.ciunit = *nout;
00550 s_wsfe(&io___35);
00551 do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
00552 do_fio(&c__1, (char *)&nrhs, (ftnlen)sizeof(integer));
00553 do_fio(&c__1, (char *)&imat, (ftnlen)sizeof(integer));
00554 do_fio(&c__1, (char *)&k, (ftnlen)sizeof(integer));
00555 do_fio(&c__1, (char *)&result[k - 1], (ftnlen)sizeof(
00556 doublereal));
00557 e_wsfe();
00558 ++nfail;
00559 }
00560
00561 }
00562 nrun += 5;
00563
00564 }
00565
00566
00567
00568
00569
00570 L90:
00571 s_copy(srnamc_1.srnamt, "DPTCON", (ftnlen)32, (ftnlen)6);
00572 dptcon_(&n, &d__[n + 1], &e[n + 1], &anorm, &rcond, &rwork[1], &
00573 info);
00574
00575
00576
00577 if (info != 0) {
00578 alaerh_(path, "DPTCON", &info, &c__0, " ", &n, &n, &c_n1, &
00579 c_n1, &c_n1, &imat, &nfail, &nerrs, nout);
00580 }
00581
00582 result[6] = dget06_(&rcond, &rcondc);
00583
00584
00585
00586 if (result[6] >= *thresh) {
00587 if (nfail == 0 && nerrs == 0) {
00588 alahd_(nout, path);
00589 }
00590 io___37.ciunit = *nout;
00591 s_wsfe(&io___37);
00592 do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
00593 do_fio(&c__1, (char *)&imat, (ftnlen)sizeof(integer));
00594 do_fio(&c__1, (char *)&c__7, (ftnlen)sizeof(integer));
00595 do_fio(&c__1, (char *)&result[6], (ftnlen)sizeof(doublereal));
00596 e_wsfe();
00597 ++nfail;
00598 }
00599 ++nrun;
00600 L100:
00601 ;
00602 }
00603
00604 }
00605
00606
00607
00608 alasum_(path, nout, &nfail, &nrun, &nerrs);
00609
00610 return 0;
00611
00612
00613
00614 }