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__1 = 1;
00034 static integer c__2 = 2;
00035 static integer c__0 = 0;
00036 static integer c_n1 = -1;
00037 static doublereal c_b23 = 0.;
00038 static logical c_true = TRUE_;
00039 static integer c__8 = 8;
00040
00041 int dchkge_(logical *dotype, integer *nm, integer *mval,
00042 integer *nn, integer *nval, integer *nnb, integer *nbval, integer *
00043 nns, integer *nsval, doublereal *thresh, logical *tsterr, integer *
00044 nmax, doublereal *a, doublereal *afac, doublereal *ainv, doublereal *
00045 b, doublereal *x, doublereal *xact, doublereal *work, doublereal *
00046 rwork, integer *iwork, integer *nout)
00047 {
00048
00049
00050 static integer iseedy[4] = { 1988,1989,1990,1991 };
00051 static char transs[1*3] = "N" "T" "C";
00052
00053
00054 static char fmt_9999[] = "(\002 M = \002,i5,\002, N =\002,i5,\002, NB "
00055 "=\002,i4,\002, type \002,i2,\002, test(\002,i2,\002) =\002,g12.5)"
00056 ;
00057 static char fmt_9998[] = "(\002 TRANS='\002,a1,\002', N =\002,i5,\002, N"
00058 "RHS=\002,i3,\002, type \002,i2,\002, test(\002,i2,\002) =\002,g1"
00059 "2.5)";
00060 static char fmt_9997[] = "(\002 NORM ='\002,a1,\002', N =\002,i5,\002"
00061 ",\002,10x,\002 type \002,i2,\002, test(\002,i2,\002) =\002,g12.5)"
00062 ;
00063
00064
00065 integer i__1, i__2, i__3, i__4, i__5;
00066
00067
00068 int s_copy(char *, char *, ftnlen, ftnlen);
00069 integer s_wsfe(cilist *), do_fio(integer *, char *, ftnlen), e_wsfe(void);
00070
00071
00072 integer i__, k, m, n, nb, im, in, kl, ku, nt, lda, inb, ioff, mode, imat,
00073 info;
00074 char path[3], dist[1];
00075 integer irhs, nrhs;
00076 char norm[1], type__[1];
00077 integer nrun;
00078 extern int alahd_(integer *, char *), dget01_(
00079 integer *, integer *, doublereal *, integer *, doublereal *,
00080 integer *, integer *, doublereal *, doublereal *), dget02_(char *,
00081 integer *, integer *, integer *, doublereal *, integer *,
00082 doublereal *, integer *, doublereal *, integer *, doublereal *,
00083 doublereal *), dget03_(integer *, doublereal *, integer *,
00084 doublereal *, integer *, doublereal *, integer *, doublereal *,
00085 doublereal *, doublereal *), dget04_(integer *, integer *,
00086 doublereal *, integer *, doublereal *, integer *, doublereal *,
00087 doublereal *);
00088 integer nfail, iseed[4];
00089 extern doublereal dget06_(doublereal *, doublereal *);
00090 extern int dget07_(char *, integer *, integer *,
00091 doublereal *, integer *, doublereal *, integer *, doublereal *,
00092 integer *, doublereal *, integer *, doublereal *, logical *,
00093 doublereal *, doublereal *);
00094 doublereal rcond;
00095 integer nimat;
00096 doublereal anorm;
00097 integer itran;
00098 char trans[1];
00099 integer izero, nerrs;
00100 doublereal dummy;
00101 integer lwork;
00102 logical zerot;
00103 char xtype[1];
00104 extern int dlatb4_(char *, integer *, integer *, integer
00105 *, char *, integer *, integer *, doublereal *, integer *,
00106 doublereal *, char *);
00107 extern doublereal dlange_(char *, integer *, integer *, doublereal *,
00108 integer *, doublereal *);
00109 extern int alaerh_(char *, char *, integer *, integer *,
00110 char *, integer *, integer *, integer *, integer *, integer *,
00111 integer *, integer *, integer *, integer *), dgecon_(char *, integer *, doublereal *, integer *,
00112 doublereal *, doublereal *, doublereal *, integer *, integer *);
00113 doublereal rcondc;
00114 extern int derrge_(char *, integer *), dgerfs_(
00115 char *, integer *, integer *, doublereal *, integer *, doublereal
00116 *, integer *, integer *, doublereal *, integer *, doublereal *,
00117 integer *, doublereal *, doublereal *, doublereal *, integer *,
00118 integer *), dgetrf_(integer *, integer *, doublereal *,
00119 integer *, integer *, integer *), dlacpy_(char *, integer *,
00120 integer *, doublereal *, integer *, doublereal *, integer *), dlarhs_(char *, char *, char *, char *, integer *,
00121 integer *, integer *, integer *, integer *, doublereal *, integer
00122 *, doublereal *, integer *, doublereal *, integer *, integer *,
00123 integer *);
00124 doublereal rcondi;
00125 extern int dgetri_(integer *, doublereal *, integer *,
00126 integer *, doublereal *, integer *, integer *), dlaset_(char *,
00127 integer *, integer *, doublereal *, doublereal *, doublereal *,
00128 integer *), alasum_(char *, integer *, integer *, integer
00129 *, integer *);
00130 doublereal cndnum, anormi, rcondo;
00131 extern int dlatms_(integer *, integer *, char *, integer
00132 *, char *, doublereal *, integer *, doublereal *, doublereal *,
00133 integer *, integer *, char *, doublereal *, integer *, doublereal
00134 *, integer *);
00135 doublereal ainvnm;
00136 extern int dgetrs_(char *, integer *, integer *,
00137 doublereal *, integer *, integer *, doublereal *, integer *,
00138 integer *);
00139 logical trfcon;
00140 doublereal anormo;
00141 extern int xlaenv_(integer *, integer *);
00142 doublereal result[8];
00143
00144
00145 static cilist io___41 = { 0, 0, 0, fmt_9999, 0 };
00146 static cilist io___46 = { 0, 0, 0, fmt_9998, 0 };
00147 static cilist io___50 = { 0, 0, 0, fmt_9997, 0 };
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
00228
00229
00230
00231
00232
00233
00234
00235
00236
00237
00238
00239
00240
00241
00242
00243
00244
00245
00246
00247
00248
00249
00250
00251
00252
00253 --iwork;
00254 --rwork;
00255 --work;
00256 --xact;
00257 --x;
00258 --b;
00259 --ainv;
00260 --afac;
00261 --a;
00262 --nsval;
00263 --nbval;
00264 --nval;
00265 --mval;
00266 --dotype;
00267
00268
00269
00270
00271
00272
00273
00274 s_copy(path, "Double precision", (ftnlen)1, (ftnlen)16);
00275 s_copy(path + 1, "GE", (ftnlen)2, (ftnlen)2);
00276 nrun = 0;
00277 nfail = 0;
00278 nerrs = 0;
00279 for (i__ = 1; i__ <= 4; ++i__) {
00280 iseed[i__ - 1] = iseedy[i__ - 1];
00281
00282 }
00283
00284
00285
00286 xlaenv_(&c__1, &c__1);
00287 if (*tsterr) {
00288 derrge_(path, nout);
00289 }
00290 infoc_1.infot = 0;
00291 xlaenv_(&c__2, &c__2);
00292
00293
00294
00295 i__1 = *nm;
00296 for (im = 1; im <= i__1; ++im) {
00297 m = mval[im];
00298 lda = max(1,m);
00299
00300
00301
00302 i__2 = *nn;
00303 for (in = 1; in <= i__2; ++in) {
00304 n = nval[in];
00305 *(unsigned char *)xtype = 'N';
00306 nimat = 11;
00307 if (m <= 0 || n <= 0) {
00308 nimat = 1;
00309 }
00310
00311 i__3 = nimat;
00312 for (imat = 1; imat <= i__3; ++imat) {
00313
00314
00315
00316 if (! dotype[imat]) {
00317 goto L100;
00318 }
00319
00320
00321
00322 zerot = imat >= 5 && imat <= 7;
00323 if (zerot && n < imat - 4) {
00324 goto L100;
00325 }
00326
00327
00328
00329
00330 dlatb4_(path, &imat, &m, &n, type__, &kl, &ku, &anorm, &mode,
00331 &cndnum, dist);
00332
00333 s_copy(srnamc_1.srnamt, "DLATMS", (ftnlen)32, (ftnlen)6);
00334 dlatms_(&m, &n, dist, iseed, type__, &rwork[1], &mode, &
00335 cndnum, &anorm, &kl, &ku, "No packing", &a[1], &lda, &
00336 work[1], &info);
00337
00338
00339
00340 if (info != 0) {
00341 alaerh_(path, "DLATMS", &info, &c__0, " ", &m, &n, &c_n1,
00342 &c_n1, &c_n1, &imat, &nfail, &nerrs, nout);
00343 goto L100;
00344 }
00345
00346
00347
00348
00349 if (zerot) {
00350 if (imat == 5) {
00351 izero = 1;
00352 } else if (imat == 6) {
00353 izero = min(m,n);
00354 } else {
00355 izero = min(m,n) / 2 + 1;
00356 }
00357 ioff = (izero - 1) * lda;
00358 if (imat < 7) {
00359 i__4 = m;
00360 for (i__ = 1; i__ <= i__4; ++i__) {
00361 a[ioff + i__] = 0.;
00362
00363 }
00364 } else {
00365 i__4 = n - izero + 1;
00366 dlaset_("Full", &m, &i__4, &c_b23, &c_b23, &a[ioff +
00367 1], &lda);
00368 }
00369 } else {
00370 izero = 0;
00371 }
00372
00373
00374
00375
00376
00377
00378
00379
00380
00381 i__4 = *nnb;
00382 for (inb = 1; inb <= i__4; ++inb) {
00383 nb = nbval[inb];
00384 xlaenv_(&c__1, &nb);
00385
00386
00387
00388 dlacpy_("Full", &m, &n, &a[1], &lda, &afac[1], &lda);
00389 s_copy(srnamc_1.srnamt, "DGETRF", (ftnlen)32, (ftnlen)6);
00390 dgetrf_(&m, &n, &afac[1], &lda, &iwork[1], &info);
00391
00392
00393
00394 if (info != izero) {
00395 alaerh_(path, "DGETRF", &info, &izero, " ", &m, &n, &
00396 c_n1, &c_n1, &nb, &imat, &nfail, &nerrs, nout);
00397 }
00398 trfcon = FALSE_;
00399
00400
00401
00402
00403 dlacpy_("Full", &m, &n, &afac[1], &lda, &ainv[1], &lda);
00404 dget01_(&m, &n, &a[1], &lda, &ainv[1], &lda, &iwork[1], &
00405 rwork[1], result);
00406 nt = 1;
00407
00408
00409
00410
00411
00412 if (m == n && info == 0) {
00413 dlacpy_("Full", &n, &n, &afac[1], &lda, &ainv[1], &
00414 lda);
00415 s_copy(srnamc_1.srnamt, "DGETRI", (ftnlen)32, (ftnlen)
00416 6);
00417 nrhs = nsval[1];
00418 lwork = *nmax * max(3,nrhs);
00419 dgetri_(&n, &ainv[1], &lda, &iwork[1], &work[1], &
00420 lwork, &info);
00421
00422
00423
00424 if (info != 0) {
00425 alaerh_(path, "DGETRI", &info, &c__0, " ", &n, &n,
00426 &c_n1, &c_n1, &nb, &imat, &nfail, &nerrs,
00427 nout);
00428 }
00429
00430
00431
00432
00433
00434 dget03_(&n, &a[1], &lda, &ainv[1], &lda, &work[1], &
00435 lda, &rwork[1], &rcondo, &result[1]);
00436 anormo = dlange_("O", &m, &n, &a[1], &lda, &rwork[1]);
00437
00438
00439
00440 anormi = dlange_("I", &m, &n, &a[1], &lda, &rwork[1]);
00441 ainvnm = dlange_("I", &n, &n, &ainv[1], &lda, &rwork[
00442 1]);
00443 if (anormi <= 0. || ainvnm <= 0.) {
00444 rcondi = 1.;
00445 } else {
00446 rcondi = 1. / anormi / ainvnm;
00447 }
00448 nt = 2;
00449 } else {
00450
00451
00452
00453 trfcon = TRUE_;
00454 anormo = dlange_("O", &m, &n, &a[1], &lda, &rwork[1]);
00455 anormi = dlange_("I", &m, &n, &a[1], &lda, &rwork[1]);
00456 rcondo = 0.;
00457 rcondi = 0.;
00458 }
00459
00460
00461
00462
00463 i__5 = nt;
00464 for (k = 1; k <= i__5; ++k) {
00465 if (result[k - 1] >= *thresh) {
00466 if (nfail == 0 && nerrs == 0) {
00467 alahd_(nout, path);
00468 }
00469 io___41.ciunit = *nout;
00470 s_wsfe(&io___41);
00471 do_fio(&c__1, (char *)&m, (ftnlen)sizeof(integer))
00472 ;
00473 do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer))
00474 ;
00475 do_fio(&c__1, (char *)&nb, (ftnlen)sizeof(integer)
00476 );
00477 do_fio(&c__1, (char *)&imat, (ftnlen)sizeof(
00478 integer));
00479 do_fio(&c__1, (char *)&k, (ftnlen)sizeof(integer))
00480 ;
00481 do_fio(&c__1, (char *)&result[k - 1], (ftnlen)
00482 sizeof(doublereal));
00483 e_wsfe();
00484 ++nfail;
00485 }
00486
00487 }
00488 nrun += nt;
00489
00490
00491
00492
00493
00494 if (inb > 1 || m != n) {
00495 goto L90;
00496 }
00497 if (trfcon) {
00498 goto L70;
00499 }
00500
00501 i__5 = *nns;
00502 for (irhs = 1; irhs <= i__5; ++irhs) {
00503 nrhs = nsval[irhs];
00504 *(unsigned char *)xtype = 'N';
00505
00506 for (itran = 1; itran <= 3; ++itran) {
00507 *(unsigned char *)trans = *(unsigned char *)&
00508 transs[itran - 1];
00509 if (itran == 1) {
00510 rcondc = rcondo;
00511 } else {
00512 rcondc = rcondi;
00513 }
00514
00515
00516
00517
00518 s_copy(srnamc_1.srnamt, "DLARHS", (ftnlen)32, (
00519 ftnlen)6);
00520 dlarhs_(path, xtype, " ", trans, &n, &n, &kl, &ku,
00521 &nrhs, &a[1], &lda, &xact[1], &lda, &b[1]
00522 , &lda, iseed, &info);
00523 *(unsigned char *)xtype = 'C';
00524
00525 dlacpy_("Full", &n, &nrhs, &b[1], &lda, &x[1], &
00526 lda);
00527 s_copy(srnamc_1.srnamt, "DGETRS", (ftnlen)32, (
00528 ftnlen)6);
00529 dgetrs_(trans, &n, &nrhs, &afac[1], &lda, &iwork[
00530 1], &x[1], &lda, &info);
00531
00532
00533
00534 if (info != 0) {
00535 alaerh_(path, "DGETRS", &info, &c__0, trans, &
00536 n, &n, &c_n1, &c_n1, &nrhs, &imat, &
00537 nfail, &nerrs, nout);
00538 }
00539
00540 dlacpy_("Full", &n, &nrhs, &b[1], &lda, &work[1],
00541 &lda);
00542 dget02_(trans, &n, &n, &nrhs, &a[1], &lda, &x[1],
00543 &lda, &work[1], &lda, &rwork[1], &result[
00544 2]);
00545
00546
00547
00548
00549 dget04_(&n, &nrhs, &x[1], &lda, &xact[1], &lda, &
00550 rcondc, &result[3]);
00551
00552
00553
00554
00555
00556 s_copy(srnamc_1.srnamt, "DGERFS", (ftnlen)32, (
00557 ftnlen)6);
00558 dgerfs_(trans, &n, &nrhs, &a[1], &lda, &afac[1], &
00559 lda, &iwork[1], &b[1], &lda, &x[1], &lda,
00560 &rwork[1], &rwork[nrhs + 1], &work[1], &
00561 iwork[n + 1], &info);
00562
00563
00564
00565 if (info != 0) {
00566 alaerh_(path, "DGERFS", &info, &c__0, trans, &
00567 n, &n, &c_n1, &c_n1, &nrhs, &imat, &
00568 nfail, &nerrs, nout);
00569 }
00570
00571 dget04_(&n, &nrhs, &x[1], &lda, &xact[1], &lda, &
00572 rcondc, &result[4]);
00573 dget07_(trans, &n, &nrhs, &a[1], &lda, &b[1], &
00574 lda, &x[1], &lda, &xact[1], &lda, &rwork[
00575 1], &c_true, &rwork[nrhs + 1], &result[5]);
00576
00577
00578
00579
00580 for (k = 3; k <= 7; ++k) {
00581 if (result[k - 1] >= *thresh) {
00582 if (nfail == 0 && nerrs == 0) {
00583 alahd_(nout, path);
00584 }
00585 io___46.ciunit = *nout;
00586 s_wsfe(&io___46);
00587 do_fio(&c__1, trans, (ftnlen)1);
00588 do_fio(&c__1, (char *)&n, (ftnlen)sizeof(
00589 integer));
00590 do_fio(&c__1, (char *)&nrhs, (ftnlen)
00591 sizeof(integer));
00592 do_fio(&c__1, (char *)&imat, (ftnlen)
00593 sizeof(integer));
00594 do_fio(&c__1, (char *)&k, (ftnlen)sizeof(
00595 integer));
00596 do_fio(&c__1, (char *)&result[k - 1], (
00597 ftnlen)sizeof(doublereal));
00598 e_wsfe();
00599 ++nfail;
00600 }
00601
00602 }
00603 nrun += 5;
00604
00605 }
00606
00607 }
00608
00609
00610
00611
00612 L70:
00613 for (itran = 1; itran <= 2; ++itran) {
00614 if (itran == 1) {
00615 anorm = anormo;
00616 rcondc = rcondo;
00617 *(unsigned char *)norm = 'O';
00618 } else {
00619 anorm = anormi;
00620 rcondc = rcondi;
00621 *(unsigned char *)norm = 'I';
00622 }
00623 s_copy(srnamc_1.srnamt, "DGECON", (ftnlen)32, (ftnlen)
00624 6);
00625 dgecon_(norm, &n, &afac[1], &lda, &anorm, &rcond, &
00626 work[1], &iwork[n + 1], &info);
00627
00628
00629
00630 if (info != 0) {
00631 alaerh_(path, "DGECON", &info, &c__0, norm, &n, &
00632 n, &c_n1, &c_n1, &c_n1, &imat, &nfail, &
00633 nerrs, nout);
00634 }
00635
00636
00637
00638 dummy = rcond;
00639
00640 result[7] = dget06_(&rcond, &rcondc);
00641
00642
00643
00644
00645 if (result[7] >= *thresh) {
00646 if (nfail == 0 && nerrs == 0) {
00647 alahd_(nout, path);
00648 }
00649 io___50.ciunit = *nout;
00650 s_wsfe(&io___50);
00651 do_fio(&c__1, norm, (ftnlen)1);
00652 do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer))
00653 ;
00654 do_fio(&c__1, (char *)&imat, (ftnlen)sizeof(
00655 integer));
00656 do_fio(&c__1, (char *)&c__8, (ftnlen)sizeof(
00657 integer));
00658 do_fio(&c__1, (char *)&result[7], (ftnlen)sizeof(
00659 doublereal));
00660 e_wsfe();
00661 ++nfail;
00662 }
00663 ++nrun;
00664
00665 }
00666 L90:
00667 ;
00668 }
00669 L100:
00670 ;
00671 }
00672
00673 }
00674
00675 }
00676
00677
00678
00679 alasum_(path, nout, &nfail, &nrun, &nerrs);
00680
00681 return 0;
00682
00683
00684
00685 }