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 complex c_b51 = {0.f,0.f};
00038
00039 int cdrvpo_(logical *dotype, integer *nn, integer *nval,
00040 integer *nrhs, real *thresh, logical *tsterr, integer *nmax, complex *
00041 a, complex *afac, complex *asav, complex *b, complex *bsav, complex *
00042 x, complex *xact, real *s, complex *work, real *rwork, integer *nout)
00043 {
00044
00045
00046 static integer iseedy[4] = { 1988,1989,1990,1991 };
00047 static char uplos[1*2] = "U" "L";
00048 static char facts[1*3] = "F" "N" "E";
00049 static char equeds[1*2] = "N" "Y";
00050
00051
00052 static char fmt_9999[] = "(1x,a,\002, UPLO='\002,a1,\002', N =\002,i5"
00053 ",\002, type \002,i1,\002, test(\002,i1,\002)=\002,g12.5)";
00054 static char fmt_9997[] = "(1x,a,\002, FACT='\002,a1,\002', UPLO='\002,"
00055 "a1,\002', N=\002,i5,\002, EQUED='\002,a1,\002', type \002,i1,"
00056 "\002, test(\002,i1,\002) =\002,g12.5)";
00057 static char fmt_9998[] = "(1x,a,\002, FACT='\002,a1,\002', UPLO='\002,"
00058 "a1,\002', N=\002,i5,\002, type \002,i1,\002, test(\002,i1,\002)"
00059 "=\002,g12.5)";
00060
00061
00062 address a__1[2];
00063 integer i__1, i__2, i__3, i__4, i__5[2];
00064 char ch__1[2];
00065
00066
00067 int s_copy(char *, char *, ftnlen, ftnlen);
00068 integer s_wsfe(cilist *), do_fio(integer *, char *, ftnlen), e_wsfe(void);
00069 int s_cat(char *, char **, integer *, integer *, ftnlen);
00070
00071
00072 integer i__, k, n, k1, nb, in, kl, ku, nt, lda;
00073 char fact[1];
00074 integer ioff, mode;
00075 real amax;
00076 char path[3];
00077 integer imat, info;
00078 char dist[1], uplo[1], type__[1];
00079 integer nrun, ifact;
00080 extern int cget04_(integer *, integer *, complex *,
00081 integer *, complex *, integer *, real *, real *);
00082 integer nfail, iseed[4], nfact;
00083 extern logical lsame_(char *, char *);
00084 char equed[1];
00085 integer nbmin;
00086 real rcond, roldc, scond;
00087 integer nimat;
00088 extern doublereal sget06_(real *, real *);
00089 extern int cpot01_(char *, integer *, complex *, integer
00090 *, complex *, integer *, real *, real *), cpot02_(char *,
00091 integer *, integer *, complex *, integer *, complex *, integer *,
00092 complex *, integer *, real *, real *);
00093 real anorm;
00094 extern int cpot05_(char *, integer *, integer *, complex
00095 *, integer *, complex *, integer *, complex *, integer *, complex
00096 *, integer *, real *, real *, real *);
00097 logical equil;
00098 integer iuplo, izero, nerrs;
00099 extern int cposv_(char *, integer *, integer *, complex *
00100 , integer *, complex *, integer *, integer *);
00101 logical zerot;
00102 char xtype[1];
00103 extern int clatb4_(char *, integer *, integer *, integer
00104 *, char *, integer *, integer *, real *, integer *, real *, char *
00105 ), aladhd_(integer *, char *);
00106 extern doublereal clanhe_(char *, char *, integer *, complex *, integer *,
00107 real *);
00108 extern int alaerh_(char *, char *, integer *, integer *,
00109 char *, integer *, integer *, integer *, integer *, integer *,
00110 integer *, integer *, integer *, integer *), claipd_(integer *, complex *, integer *, integer *),
00111 claqhe_(char *, integer *, complex *, integer *, real *, real *,
00112 real *, char *);
00113 logical prefac;
00114 real rcondc;
00115 logical nofact;
00116 extern int clacpy_(char *, integer *, integer *, complex
00117 *, integer *, complex *, integer *);
00118 integer iequed;
00119 extern int clarhs_(char *, char *, char *, char *,
00120 integer *, integer *, integer *, integer *, integer *, complex *,
00121 integer *, complex *, integer *, complex *, integer *, integer *,
00122 integer *), claset_(char *,
00123 integer *, integer *, complex *, complex *, complex *, integer *), alasvm_(char *, integer *, integer *, integer *, integer
00124 *);
00125 real cndnum;
00126 extern int clatms_(integer *, integer *, char *, integer
00127 *, char *, real *, integer *, real *, real *, integer *, integer *
00128 , char *, complex *, integer *, complex *, integer *);
00129 real ainvnm;
00130 extern int cpoequ_(integer *, complex *, integer *, real
00131 *, real *, real *, integer *), cpotrf_(char *, integer *, complex
00132 *, integer *, integer *), cpotri_(char *, integer *,
00133 complex *, integer *, integer *), xlaenv_(integer *,
00134 integer *), cerrvx_(char *, integer *);
00135 real result[6];
00136 extern int cposvx_(char *, char *, integer *, integer *,
00137 complex *, integer *, complex *, integer *, char *, real *,
00138 complex *, integer *, complex *, integer *, real *, real *, real *
00139 , complex *, real *, integer *);
00140
00141
00142 static cilist io___48 = { 0, 0, 0, fmt_9999, 0 };
00143 static cilist io___51 = { 0, 0, 0, fmt_9997, 0 };
00144 static cilist io___52 = { 0, 0, 0, fmt_9998, 0 };
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
00220
00221
00222
00223
00224
00225
00226
00227
00228
00229
00230
00231
00232
00233
00234
00235
00236 --rwork;
00237 --work;
00238 --s;
00239 --xact;
00240 --x;
00241 --bsav;
00242 --b;
00243 --asav;
00244 --afac;
00245 --a;
00246 --nval;
00247 --dotype;
00248
00249
00250
00251
00252
00253
00254
00255 s_copy(path, "Complex precision", (ftnlen)1, (ftnlen)17);
00256 s_copy(path + 1, "PO", (ftnlen)2, (ftnlen)2);
00257 nrun = 0;
00258 nfail = 0;
00259 nerrs = 0;
00260 for (i__ = 1; i__ <= 4; ++i__) {
00261 iseed[i__ - 1] = iseedy[i__ - 1];
00262
00263 }
00264
00265
00266
00267 if (*tsterr) {
00268 cerrvx_(path, nout);
00269 }
00270 infoc_1.infot = 0;
00271
00272
00273
00274 nb = 1;
00275 nbmin = 2;
00276 xlaenv_(&c__1, &nb);
00277 xlaenv_(&c__2, &nbmin);
00278
00279
00280
00281 i__1 = *nn;
00282 for (in = 1; in <= i__1; ++in) {
00283 n = nval[in];
00284 lda = max(n,1);
00285 *(unsigned char *)xtype = 'N';
00286 nimat = 9;
00287 if (n <= 0) {
00288 nimat = 1;
00289 }
00290
00291 i__2 = nimat;
00292 for (imat = 1; imat <= i__2; ++imat) {
00293
00294
00295
00296 if (! dotype[imat]) {
00297 goto L120;
00298 }
00299
00300
00301
00302 zerot = imat >= 3 && imat <= 5;
00303 if (zerot && n < imat - 2) {
00304 goto L120;
00305 }
00306
00307
00308
00309 for (iuplo = 1; iuplo <= 2; ++iuplo) {
00310 *(unsigned char *)uplo = *(unsigned char *)&uplos[iuplo - 1];
00311
00312
00313
00314
00315 clatb4_(path, &imat, &n, &n, type__, &kl, &ku, &anorm, &mode,
00316 &cndnum, dist);
00317
00318 s_copy(srnamc_1.srnamt, "CLATMS", (ftnlen)32, (ftnlen)6);
00319 clatms_(&n, &n, dist, iseed, type__, &rwork[1], &mode, &
00320 cndnum, &anorm, &kl, &ku, uplo, &a[1], &lda, &work[1],
00321 &info);
00322
00323
00324
00325 if (info != 0) {
00326 alaerh_(path, "CLATMS", &info, &c__0, uplo, &n, &n, &c_n1,
00327 &c_n1, &c_n1, &imat, &nfail, &nerrs, nout);
00328 goto L110;
00329 }
00330
00331
00332
00333
00334 if (zerot) {
00335 if (imat == 3) {
00336 izero = 1;
00337 } else if (imat == 4) {
00338 izero = n;
00339 } else {
00340 izero = n / 2 + 1;
00341 }
00342 ioff = (izero - 1) * lda;
00343
00344
00345
00346 if (iuplo == 1) {
00347 i__3 = izero - 1;
00348 for (i__ = 1; i__ <= i__3; ++i__) {
00349 i__4 = ioff + i__;
00350 a[i__4].r = 0.f, a[i__4].i = 0.f;
00351
00352 }
00353 ioff += izero;
00354 i__3 = n;
00355 for (i__ = izero; i__ <= i__3; ++i__) {
00356 i__4 = ioff;
00357 a[i__4].r = 0.f, a[i__4].i = 0.f;
00358 ioff += lda;
00359
00360 }
00361 } else {
00362 ioff = izero;
00363 i__3 = izero - 1;
00364 for (i__ = 1; i__ <= i__3; ++i__) {
00365 i__4 = ioff;
00366 a[i__4].r = 0.f, a[i__4].i = 0.f;
00367 ioff += lda;
00368
00369 }
00370 ioff -= izero;
00371 i__3 = n;
00372 for (i__ = izero; i__ <= i__3; ++i__) {
00373 i__4 = ioff + i__;
00374 a[i__4].r = 0.f, a[i__4].i = 0.f;
00375
00376 }
00377 }
00378 } else {
00379 izero = 0;
00380 }
00381
00382
00383
00384 i__3 = lda + 1;
00385 claipd_(&n, &a[1], &i__3, &c__0);
00386
00387
00388
00389 clacpy_(uplo, &n, &n, &a[1], &lda, &asav[1], &lda);
00390
00391 for (iequed = 1; iequed <= 2; ++iequed) {
00392 *(unsigned char *)equed = *(unsigned char *)&equeds[
00393 iequed - 1];
00394 if (iequed == 1) {
00395 nfact = 3;
00396 } else {
00397 nfact = 1;
00398 }
00399
00400 i__3 = nfact;
00401 for (ifact = 1; ifact <= i__3; ++ifact) {
00402 *(unsigned char *)fact = *(unsigned char *)&facts[
00403 ifact - 1];
00404 prefac = lsame_(fact, "F");
00405 nofact = lsame_(fact, "N");
00406 equil = lsame_(fact, "E");
00407
00408 if (zerot) {
00409 if (prefac) {
00410 goto L90;
00411 }
00412 rcondc = 0.f;
00413
00414 } else if (! lsame_(fact, "N"))
00415 {
00416
00417
00418
00419
00420
00421
00422 clacpy_(uplo, &n, &n, &asav[1], &lda, &afac[1], &
00423 lda);
00424 if (equil || iequed > 1) {
00425
00426
00427
00428
00429 cpoequ_(&n, &afac[1], &lda, &s[1], &scond, &
00430 amax, &info);
00431 if (info == 0 && n > 0) {
00432 if (iequed > 1) {
00433 scond = 0.f;
00434 }
00435
00436
00437
00438 claqhe_(uplo, &n, &afac[1], &lda, &s[1], &
00439 scond, &amax, equed);
00440 }
00441 }
00442
00443
00444
00445
00446 if (equil) {
00447 roldc = rcondc;
00448 }
00449
00450
00451
00452 anorm = clanhe_("1", uplo, &n, &afac[1], &lda, &
00453 rwork[1]);
00454
00455
00456
00457 cpotrf_(uplo, &n, &afac[1], &lda, &info);
00458
00459
00460
00461 clacpy_(uplo, &n, &n, &afac[1], &lda, &a[1], &lda);
00462 cpotri_(uplo, &n, &a[1], &lda, &info);
00463
00464
00465
00466 ainvnm = clanhe_("1", uplo, &n, &a[1], &lda, &
00467 rwork[1]);
00468 if (anorm <= 0.f || ainvnm <= 0.f) {
00469 rcondc = 1.f;
00470 } else {
00471 rcondc = 1.f / anorm / ainvnm;
00472 }
00473 }
00474
00475
00476
00477 clacpy_(uplo, &n, &n, &asav[1], &lda, &a[1], &lda);
00478
00479
00480
00481 s_copy(srnamc_1.srnamt, "CLARHS", (ftnlen)32, (ftnlen)
00482 6);
00483 clarhs_(path, xtype, uplo, " ", &n, &n, &kl, &ku,
00484 nrhs, &a[1], &lda, &xact[1], &lda, &b[1], &
00485 lda, iseed, &info);
00486 *(unsigned char *)xtype = 'C';
00487 clacpy_("Full", &n, nrhs, &b[1], &lda, &bsav[1], &lda);
00488
00489 if (nofact) {
00490
00491
00492
00493
00494
00495
00496 clacpy_(uplo, &n, &n, &a[1], &lda, &afac[1], &lda);
00497 clacpy_("Full", &n, nrhs, &b[1], &lda, &x[1], &
00498 lda);
00499
00500 s_copy(srnamc_1.srnamt, "CPOSV ", (ftnlen)32, (
00501 ftnlen)6);
00502 cposv_(uplo, &n, nrhs, &afac[1], &lda, &x[1], &
00503 lda, &info);
00504
00505
00506
00507 if (info != izero) {
00508 alaerh_(path, "CPOSV ", &info, &izero, uplo, &
00509 n, &n, &c_n1, &c_n1, nrhs, &imat, &
00510 nfail, &nerrs, nout);
00511 goto L70;
00512 } else if (info != 0) {
00513 goto L70;
00514 }
00515
00516
00517
00518
00519 cpot01_(uplo, &n, &a[1], &lda, &afac[1], &lda, &
00520 rwork[1], result);
00521
00522
00523
00524 clacpy_("Full", &n, nrhs, &b[1], &lda, &work[1], &
00525 lda);
00526 cpot02_(uplo, &n, nrhs, &a[1], &lda, &x[1], &lda,
00527 &work[1], &lda, &rwork[1], &result[1]);
00528
00529
00530
00531 cget04_(&n, nrhs, &x[1], &lda, &xact[1], &lda, &
00532 rcondc, &result[2]);
00533 nt = 3;
00534
00535
00536
00537
00538 i__4 = nt;
00539 for (k = 1; k <= i__4; ++k) {
00540 if (result[k - 1] >= *thresh) {
00541 if (nfail == 0 && nerrs == 0) {
00542 aladhd_(nout, path);
00543 }
00544 io___48.ciunit = *nout;
00545 s_wsfe(&io___48);
00546 do_fio(&c__1, "CPOSV ", (ftnlen)6);
00547 do_fio(&c__1, uplo, (ftnlen)1);
00548 do_fio(&c__1, (char *)&n, (ftnlen)sizeof(
00549 integer));
00550 do_fio(&c__1, (char *)&imat, (ftnlen)
00551 sizeof(integer));
00552 do_fio(&c__1, (char *)&k, (ftnlen)sizeof(
00553 integer));
00554 do_fio(&c__1, (char *)&result[k - 1], (
00555 ftnlen)sizeof(real));
00556 e_wsfe();
00557 ++nfail;
00558 }
00559
00560 }
00561 nrun += nt;
00562 L70:
00563 ;
00564 }
00565
00566
00567
00568 if (! prefac) {
00569 claset_(uplo, &n, &n, &c_b51, &c_b51, &afac[1], &
00570 lda);
00571 }
00572 claset_("Full", &n, nrhs, &c_b51, &c_b51, &x[1], &lda);
00573 if (iequed > 1 && n > 0) {
00574
00575
00576
00577
00578 claqhe_(uplo, &n, &a[1], &lda, &s[1], &scond, &
00579 amax, equed);
00580 }
00581
00582
00583
00584
00585 s_copy(srnamc_1.srnamt, "CPOSVX", (ftnlen)32, (ftnlen)
00586 6);
00587 cposvx_(fact, uplo, &n, nrhs, &a[1], &lda, &afac[1], &
00588 lda, equed, &s[1], &b[1], &lda, &x[1], &lda, &
00589 rcond, &rwork[1], &rwork[*nrhs + 1], &work[1],
00590 &rwork[(*nrhs << 1) + 1], &info);
00591
00592
00593
00594 if (info != izero) {
00595
00596 i__5[0] = 1, a__1[0] = fact;
00597 i__5[1] = 1, a__1[1] = uplo;
00598 s_cat(ch__1, a__1, i__5, &c__2, (ftnlen)2);
00599 alaerh_(path, "CPOSVX", &info, &izero, ch__1, &n,
00600 &n, &c_n1, &c_n1, nrhs, &imat, &nfail, &
00601 nerrs, nout);
00602 goto L90;
00603 }
00604
00605 if (info == 0) {
00606 if (! prefac) {
00607
00608
00609
00610
00611 cpot01_(uplo, &n, &a[1], &lda, &afac[1], &lda,
00612 &rwork[(*nrhs << 1) + 1], result);
00613 k1 = 1;
00614 } else {
00615 k1 = 2;
00616 }
00617
00618
00619
00620 clacpy_("Full", &n, nrhs, &bsav[1], &lda, &work[1]
00621 , &lda);
00622 cpot02_(uplo, &n, nrhs, &asav[1], &lda, &x[1], &
00623 lda, &work[1], &lda, &rwork[(*nrhs << 1)
00624 + 1], &result[1]);
00625
00626
00627
00628 if (nofact || prefac && lsame_(equed, "N")) {
00629 cget04_(&n, nrhs, &x[1], &lda, &xact[1], &lda,
00630 &rcondc, &result[2]);
00631 } else {
00632 cget04_(&n, nrhs, &x[1], &lda, &xact[1], &lda,
00633 &roldc, &result[2]);
00634 }
00635
00636
00637
00638
00639 cpot05_(uplo, &n, nrhs, &asav[1], &lda, &b[1], &
00640 lda, &x[1], &lda, &xact[1], &lda, &rwork[
00641 1], &rwork[*nrhs + 1], &result[3]);
00642 } else {
00643 k1 = 6;
00644 }
00645
00646
00647
00648
00649 result[5] = sget06_(&rcond, &rcondc);
00650
00651
00652
00653
00654 for (k = k1; k <= 6; ++k) {
00655 if (result[k - 1] >= *thresh) {
00656 if (nfail == 0 && nerrs == 0) {
00657 aladhd_(nout, path);
00658 }
00659 if (prefac) {
00660 io___51.ciunit = *nout;
00661 s_wsfe(&io___51);
00662 do_fio(&c__1, "CPOSVX", (ftnlen)6);
00663 do_fio(&c__1, fact, (ftnlen)1);
00664 do_fio(&c__1, uplo, (ftnlen)1);
00665 do_fio(&c__1, (char *)&n, (ftnlen)sizeof(
00666 integer));
00667 do_fio(&c__1, equed, (ftnlen)1);
00668 do_fio(&c__1, (char *)&imat, (ftnlen)
00669 sizeof(integer));
00670 do_fio(&c__1, (char *)&k, (ftnlen)sizeof(
00671 integer));
00672 do_fio(&c__1, (char *)&result[k - 1], (
00673 ftnlen)sizeof(real));
00674 e_wsfe();
00675 } else {
00676 io___52.ciunit = *nout;
00677 s_wsfe(&io___52);
00678 do_fio(&c__1, "CPOSVX", (ftnlen)6);
00679 do_fio(&c__1, fact, (ftnlen)1);
00680 do_fio(&c__1, uplo, (ftnlen)1);
00681 do_fio(&c__1, (char *)&n, (ftnlen)sizeof(
00682 integer));
00683 do_fio(&c__1, (char *)&imat, (ftnlen)
00684 sizeof(integer));
00685 do_fio(&c__1, (char *)&k, (ftnlen)sizeof(
00686 integer));
00687 do_fio(&c__1, (char *)&result[k - 1], (
00688 ftnlen)sizeof(real));
00689 e_wsfe();
00690 }
00691 ++nfail;
00692 }
00693
00694 }
00695 nrun = nrun + 7 - k1;
00696 L90:
00697 ;
00698 }
00699
00700 }
00701 L110:
00702 ;
00703 }
00704 L120:
00705 ;
00706 }
00707
00708 }
00709
00710
00711
00712 alasvm_(path, nout, &nfail, &nrun, &nerrs);
00713
00714 return 0;
00715
00716
00717
00718 }