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 selopt, seldim;
00020 logical selval[20];
00021 real selwr[20], selwi[20];
00022 } sslct_;
00023
00024 #define sslct_1 sslct_
00025
00026
00027
00028 static real c_b18 = 0.f;
00029 static integer c__0 = 0;
00030 static real c_b32 = 1.f;
00031 static integer c__4 = 4;
00032 static integer c__6 = 6;
00033 static integer c__1 = 1;
00034 static integer c__2 = 2;
00035 static logical c_false = FALSE_;
00036 static integer c__3 = 3;
00037 static logical c_true = TRUE_;
00038 static integer c__22 = 22;
00039
00040 int sdrvsx_(integer *nsizes, integer *nn, integer *ntypes,
00041 logical *dotype, integer *iseed, real *thresh, integer *niunit,
00042 integer *nounit, real *a, integer *lda, real *h__, real *ht, real *wr,
00043 real *wi, real *wrt, real *wit, real *wrtmp, real *witmp, real *vs,
00044 integer *ldvs, real *vs1, real *result, real *work, integer *lwork,
00045 integer *iwork, logical *bwork, integer *info)
00046 {
00047
00048
00049 static integer ktype[21] = { 1,2,3,4,4,4,4,4,6,6,6,6,6,6,6,6,6,6,9,9,9 };
00050 static integer kmagn[21] = { 1,1,1,1,1,1,2,3,1,1,1,1,1,1,1,1,2,3,1,2,3 };
00051 static integer kmode[21] = { 0,0,0,4,3,1,4,4,4,3,1,5,4,3,1,5,5,5,4,3,1 };
00052 static integer kconds[21] = { 0,0,0,0,0,0,0,0,1,1,1,1,2,2,2,2,2,2,0,0,0 };
00053
00054
00055 static char fmt_9991[] = "(\002 SDRVSX: \002,a,\002 returned INFO=\002,i"
00056 "6,\002.\002,/9x,\002N=\002,i6,\002, JTYPE=\002,i6,\002, ISEED="
00057 "(\002,3(i5,\002,\002),i5,\002)\002)";
00058 static char fmt_9999[] = "(/1x,a3,\002 -- Real Schur Form Decomposition "
00059 "Expert \002,\002Driver\002,/\002 Matrix types (see SDRVSX for de"
00060 "tails):\002)";
00061 static char fmt_9998[] = "(/\002 Special Matrices:\002,/\002 1=Zero mat"
00062 "rix. \002,\002 \002,\002 5=Diagonal: geom"
00063 "etr. spaced entries.\002,/\002 2=Identity matrix. "
00064 " \002,\002 6=Diagona\002,\002l: clustered entries.\002,"
00065 "/\002 3=Transposed Jordan block. \002,\002 \002,\002 "
00066 " 7=Diagonal: large, evenly spaced.\002,/\002 \002,\0024=Diagona"
00067 "l: evenly spaced entries. \002,\002 8=Diagonal: s\002,\002ma"
00068 "ll, evenly spaced.\002)";
00069 static char fmt_9997[] = "(\002 Dense, Non-Symmetric Matrices:\002,/\002"
00070 " 9=Well-cond., ev\002,\002enly spaced eigenvals.\002,\002 14=Il"
00071 "l-cond., geomet. spaced e\002,\002igenals.\002,/\002 10=Well-con"
00072 "d., geom. spaced eigenvals. \002,\002 15=Ill-conditioned, cluste"
00073 "red e.vals.\002,/\002 11=Well-cond\002,\002itioned, clustered e."
00074 "vals. \002,\002 16=Ill-cond., random comp\002,\002lex \002,/\002"
00075 " 12=Well-cond., random complex \002,\002 \002,\002 17=Il"
00076 "l-cond., large rand. complx \002,/\002 13=Ill-condi\002,\002tion"
00077 "ed, evenly spaced. \002,\002 18=Ill-cond., small rand.\002"
00078 ",\002 complx \002)";
00079 static char fmt_9996[] = "(\002 19=Matrix with random O(1) entries. "
00080 " \002,\002 21=Matrix \002,\002with small random entries.\002,"
00081 "/\002 20=Matrix with large ran\002,\002dom entries. \002,/)";
00082 static char fmt_9995[] = "(\002 Tests performed with test threshold ="
00083 "\002,f8.2,/\002 ( A denotes A on input and T denotes A on output)"
00084 "\002,//\002 1 = 0 if T in Schur form (no sort), \002,\002 1/ulp"
00085 " otherwise\002,/\002 2 = | A - VS T transpose(VS) | / ( n |A| ul"
00086 "p ) (no sort)\002,/\002 3 = | I - VS transpose(VS) | / ( n ulp )"
00087 " (no sort) \002,/\002 4 = 0 if WR+sqrt(-1)*WI are eigenvalues of"
00088 " T (no sort),\002,\002 1/ulp otherwise\002,/\002 5 = 0 if T sam"
00089 "e no matter if VS computed (no sort),\002,\002 1/ulp otherwis"
00090 "e\002,/\002 6 = 0 if WR, WI same no matter if VS computed (no so"
00091 "rt)\002,\002, 1/ulp otherwise\002)";
00092 static char fmt_9994[] = "(\002 7 = 0 if T in Schur form (sort), \002"
00093 ",\002 1/ulp otherwise\002,/\002 8 = | A - VS T transpose(VS) | "
00094 "/ ( n |A| ulp ) (sort)\002,/\002 9 = | I - VS transpose(VS) | / "
00095 "( n ulp ) (sort) \002,/\002 10 = 0 if WR+sqrt(-1)*WI are eigenva"
00096 "lues of T (sort),\002,\002 1/ulp otherwise\002,/\002 11 = 0 if "
00097 "T same no matter what else computed (sort),\002,\002 1/ulp othe"
00098 "rwise\002,/\002 12 = 0 if WR, WI same no matter what else comput"
00099 "ed \002,\002(sort), 1/ulp otherwise\002,/\002 13 = 0 if sorting "
00100 "succesful, 1/ulp otherwise\002,/\002 14 = 0 if RCONDE same no ma"
00101 "tter what else computed,\002,\002 1/ulp otherwise\002,/\002 15 ="
00102 " 0 if RCONDv same no matter what else computed,\002,\002 1/ulp o"
00103 "therwise\002,/\002 16 = | RCONDE - RCONDE(precomputed) | / cond("
00104 "RCONDE),\002,/\002 17 = | RCONDV - RCONDV(precomputed) | / cond("
00105 "RCONDV),\002)";
00106 static char fmt_9993[] = "(\002 N=\002,i5,\002, IWK=\002,i2,\002, seed"
00107 "=\002,4(i4,\002,\002),\002 type \002,i2,\002, test(\002,i2,\002)="
00108 "\002,g10.3)";
00109 static char fmt_9992[] = "(\002 N=\002,i5,\002, input example =\002,i3"
00110 ",\002, test(\002,i2,\002)=\002,g10.3)";
00111
00112
00113 integer a_dim1, a_offset, h_dim1, h_offset, ht_dim1, ht_offset, vs_dim1,
00114 vs_offset, vs1_dim1, vs1_offset, i__1, i__2, i__3, i__4;
00115
00116
00117 int s_copy(char *, char *, ftnlen, ftnlen);
00118 double sqrt(doublereal);
00119 integer s_wsfe(cilist *), do_fio(integer *, char *, ftnlen), e_wsfe(void),
00120 s_rsle(cilist *), do_lio(integer *, integer *, char *, ftnlen),
00121 e_rsle(void);
00122
00123
00124 integer i__, j, n, iwk;
00125 real ulp, cond;
00126 integer jcol;
00127 char path[3];
00128 integer nmax;
00129 real unfl, ovfl;
00130 logical badnn;
00131 integer nfail, imode, iinfo;
00132 real conds;
00133 extern int sget24_(logical *, integer *, real *, integer
00134 *, integer *, integer *, real *, integer *, real *, real *, real *
00135 , real *, real *, real *, real *, real *, real *, integer *, real
00136 *, real *, real *, integer *, integer *, real *, real *, integer *
00137 , integer *, logical *, integer *);
00138 real anorm;
00139 integer islct[20], nslct, jsize, nerrs, itype, jtype, ntest;
00140 real rtulp;
00141 extern int slabad_(real *, real *);
00142 real rcdein;
00143 char adumma[1*1];
00144 extern doublereal slamch_(char *);
00145 integer idumma[1], ioldsd[4];
00146 extern int xerbla_(char *, integer *);
00147 real rcdvin;
00148 extern int slatme_(integer *, char *, integer *, real *,
00149 integer *, real *, real *, char *, char *, char *, char *, real *,
00150 integer *, real *, integer *, integer *, real *, real *, integer
00151 *, real *, integer *),
00152 slaset_(char *, integer *, integer *, real *, real *, real *,
00153 integer *), slatmr_(integer *, integer *, char *, integer
00154 *, char *, real *, integer *, real *, real *, char *, char *,
00155 real *, integer *, real *, real *, integer *, real *, char *,
00156 integer *, integer *, integer *, real *, real *, char *, real *,
00157 integer *, integer *, integer *);
00158 integer ntestf;
00159 extern int slasum_(char *, integer *, integer *, integer
00160 *), slatms_(integer *, integer *, char *, integer *, char
00161 *, real *, integer *, real *, real *, integer *, integer *, char *
00162 , real *, integer *, real *, integer *);
00163 real ulpinv;
00164 integer nnwork;
00165 real rtulpi;
00166 integer mtypes, ntestt;
00167
00168
00169 static cilist io___32 = { 0, 0, 0, fmt_9991, 0 };
00170 static cilist io___41 = { 0, 0, 0, fmt_9999, 0 };
00171 static cilist io___42 = { 0, 0, 0, fmt_9998, 0 };
00172 static cilist io___43 = { 0, 0, 0, fmt_9997, 0 };
00173 static cilist io___44 = { 0, 0, 0, fmt_9996, 0 };
00174 static cilist io___45 = { 0, 0, 0, fmt_9995, 0 };
00175 static cilist io___46 = { 0, 0, 0, fmt_9994, 0 };
00176 static cilist io___47 = { 0, 0, 0, fmt_9993, 0 };
00177 static cilist io___48 = { 0, 0, 1, 0, 0 };
00178 static cilist io___49 = { 0, 0, 0, 0, 0 };
00179 static cilist io___51 = { 0, 0, 0, 0, 0 };
00180 static cilist io___52 = { 0, 0, 0, 0, 0 };
00181 static cilist io___53 = { 0, 0, 0, fmt_9999, 0 };
00182 static cilist io___54 = { 0, 0, 0, fmt_9998, 0 };
00183 static cilist io___55 = { 0, 0, 0, fmt_9997, 0 };
00184 static cilist io___56 = { 0, 0, 0, fmt_9996, 0 };
00185 static cilist io___57 = { 0, 0, 0, fmt_9995, 0 };
00186 static cilist io___58 = { 0, 0, 0, fmt_9994, 0 };
00187 static cilist io___59 = { 0, 0, 0, fmt_9992, 0 };
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
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
00317
00318
00319
00320
00321
00322
00323
00324
00325
00326
00327
00328
00329
00330
00331
00332
00333
00334
00335
00336
00337
00338
00339
00340
00341
00342
00343
00344
00345
00346
00347
00348
00349
00350
00351
00352
00353
00354
00355
00356
00357
00358
00359
00360
00361
00362
00363
00364
00365
00366
00367
00368
00369
00370
00371
00372
00373
00374
00375
00376
00377
00378
00379
00380
00381
00382
00383
00384
00385
00386
00387
00388
00389
00390
00391
00392
00393
00394
00395
00396
00397
00398
00399
00400
00401
00402
00403
00404
00405
00406
00407
00408
00409
00410
00411
00412
00413
00414
00415
00416
00417
00418
00419
00420
00421
00422
00423
00424
00425
00426
00427
00428
00429
00430
00431
00432
00433
00434
00435
00436
00437
00438
00439
00440
00441
00442
00443
00444
00445
00446
00447
00448
00449
00450
00451
00452
00453
00454
00455
00456
00457
00458
00459
00460
00461
00462
00463
00464
00465
00466
00467
00468
00469
00470
00471
00472
00473
00474
00475
00476
00477
00478
00479
00480
00481
00482
00483
00484
00485
00486
00487
00488
00489
00490
00491
00492
00493
00494
00495
00496
00497
00498
00499
00500
00501
00502
00503
00504
00505
00506
00507
00508
00509
00510
00511
00512
00513
00514
00515
00516
00517
00518
00519
00520
00521
00522
00523
00524
00525
00526
00527
00528
00529
00530
00531
00532
00533
00534
00535
00536
00537
00538 --nn;
00539 --dotype;
00540 --iseed;
00541 ht_dim1 = *lda;
00542 ht_offset = 1 + ht_dim1;
00543 ht -= ht_offset;
00544 h_dim1 = *lda;
00545 h_offset = 1 + h_dim1;
00546 h__ -= h_offset;
00547 a_dim1 = *lda;
00548 a_offset = 1 + a_dim1;
00549 a -= a_offset;
00550 --wr;
00551 --wi;
00552 --wrt;
00553 --wit;
00554 --wrtmp;
00555 --witmp;
00556 vs1_dim1 = *ldvs;
00557 vs1_offset = 1 + vs1_dim1;
00558 vs1 -= vs1_offset;
00559 vs_dim1 = *ldvs;
00560 vs_offset = 1 + vs_dim1;
00561 vs -= vs_offset;
00562 --result;
00563 --work;
00564 --iwork;
00565 --bwork;
00566
00567
00568
00569
00570
00571 s_copy(path, "Single precision", (ftnlen)1, (ftnlen)16);
00572 s_copy(path + 1, "SX", (ftnlen)2, (ftnlen)2);
00573
00574
00575
00576 ntestt = 0;
00577 ntestf = 0;
00578 *info = 0;
00579
00580
00581
00582 badnn = FALSE_;
00583
00584
00585
00586
00587 nmax = 12;
00588 i__1 = *nsizes;
00589 for (j = 1; j <= i__1; ++j) {
00590
00591 i__2 = nmax, i__3 = nn[j];
00592 nmax = max(i__2,i__3);
00593 if (nn[j] < 0) {
00594 badnn = TRUE_;
00595 }
00596
00597 }
00598
00599
00600
00601 if (*nsizes < 0) {
00602 *info = -1;
00603 } else if (badnn) {
00604 *info = -2;
00605 } else if (*ntypes < 0) {
00606 *info = -3;
00607 } else if (*thresh < 0.f) {
00608 *info = -6;
00609 } else if (*niunit <= 0) {
00610 *info = -7;
00611 } else if (*nounit <= 0) {
00612 *info = -8;
00613 } else if (*lda < 1 || *lda < nmax) {
00614 *info = -10;
00615 } else if (*ldvs < 1 || *ldvs < nmax) {
00616 *info = -20;
00617 } else {
00618
00619
00620 i__3 = nmax;
00621 i__1 = nmax * 3, i__2 = i__3 * i__3 << 1;
00622 if (max(i__1,i__2) > *lwork) {
00623 *info = -24;
00624 }
00625 }
00626
00627 if (*info != 0) {
00628 i__1 = -(*info);
00629 xerbla_("SDRVSX", &i__1);
00630 return 0;
00631 }
00632
00633
00634
00635 if (*nsizes == 0 || *ntypes == 0) {
00636 goto L150;
00637 }
00638
00639
00640
00641 unfl = slamch_("Safe minimum");
00642 ovfl = 1.f / unfl;
00643 slabad_(&unfl, &ovfl);
00644 ulp = slamch_("Precision");
00645 ulpinv = 1.f / ulp;
00646 rtulp = sqrt(ulp);
00647 rtulpi = 1.f / rtulp;
00648
00649
00650
00651 nerrs = 0;
00652
00653 i__1 = *nsizes;
00654 for (jsize = 1; jsize <= i__1; ++jsize) {
00655 n = nn[jsize];
00656 if (*nsizes != 1) {
00657 mtypes = min(21,*ntypes);
00658 } else {
00659 mtypes = min(22,*ntypes);
00660 }
00661
00662 i__2 = mtypes;
00663 for (jtype = 1; jtype <= i__2; ++jtype) {
00664 if (! dotype[jtype]) {
00665 goto L130;
00666 }
00667
00668
00669
00670 for (j = 1; j <= 4; ++j) {
00671 ioldsd[j - 1] = iseed[j];
00672
00673 }
00674
00675
00676
00677
00678
00679
00680
00681
00682
00683
00684
00685
00686
00687
00688
00689
00690
00691 if (mtypes > 21) {
00692 goto L90;
00693 }
00694
00695 itype = ktype[jtype - 1];
00696 imode = kmode[jtype - 1];
00697
00698
00699
00700 switch (kmagn[jtype - 1]) {
00701 case 1: goto L30;
00702 case 2: goto L40;
00703 case 3: goto L50;
00704 }
00705
00706 L30:
00707 anorm = 1.f;
00708 goto L60;
00709
00710 L40:
00711 anorm = ovfl * ulp;
00712 goto L60;
00713
00714 L50:
00715 anorm = unfl * ulpinv;
00716 goto L60;
00717
00718 L60:
00719
00720 slaset_("Full", lda, &n, &c_b18, &c_b18, &a[a_offset], lda);
00721 iinfo = 0;
00722 cond = ulpinv;
00723
00724
00725
00726
00727
00728 if (itype == 1) {
00729 iinfo = 0;
00730
00731 } else if (itype == 2) {
00732
00733
00734
00735 i__3 = n;
00736 for (jcol = 1; jcol <= i__3; ++jcol) {
00737 a[jcol + jcol * a_dim1] = anorm;
00738
00739 }
00740
00741 } else if (itype == 3) {
00742
00743
00744
00745 i__3 = n;
00746 for (jcol = 1; jcol <= i__3; ++jcol) {
00747 a[jcol + jcol * a_dim1] = anorm;
00748 if (jcol > 1) {
00749 a[jcol + (jcol - 1) * a_dim1] = 1.f;
00750 }
00751
00752 }
00753
00754 } else if (itype == 4) {
00755
00756
00757
00758 slatms_(&n, &n, "S", &iseed[1], "S", &work[1], &imode, &cond,
00759 &anorm, &c__0, &c__0, "N", &a[a_offset], lda, &work[n
00760 + 1], &iinfo);
00761
00762 } else if (itype == 5) {
00763
00764
00765
00766 slatms_(&n, &n, "S", &iseed[1], "S", &work[1], &imode, &cond,
00767 &anorm, &n, &n, "N", &a[a_offset], lda, &work[n + 1],
00768 &iinfo);
00769
00770 } else if (itype == 6) {
00771
00772
00773
00774 if (kconds[jtype - 1] == 1) {
00775 conds = 1.f;
00776 } else if (kconds[jtype - 1] == 2) {
00777 conds = rtulpi;
00778 } else {
00779 conds = 0.f;
00780 }
00781
00782 *(unsigned char *)&adumma[0] = ' ';
00783 slatme_(&n, "S", &iseed[1], &work[1], &imode, &cond, &c_b32,
00784 adumma, "T", "T", "T", &work[n + 1], &c__4, &conds, &
00785 n, &n, &anorm, &a[a_offset], lda, &work[(n << 1) + 1],
00786 &iinfo);
00787
00788 } else if (itype == 7) {
00789
00790
00791
00792 slatmr_(&n, &n, "S", &iseed[1], "S", &work[1], &c__6, &c_b32,
00793 &c_b32, "T", "N", &work[n + 1], &c__1, &c_b32, &work[(
00794 n << 1) + 1], &c__1, &c_b32, "N", idumma, &c__0, &
00795 c__0, &c_b18, &anorm, "NO", &a[a_offset], lda, &iwork[
00796 1], &iinfo);
00797
00798 } else if (itype == 8) {
00799
00800
00801
00802 slatmr_(&n, &n, "S", &iseed[1], "S", &work[1], &c__6, &c_b32,
00803 &c_b32, "T", "N", &work[n + 1], &c__1, &c_b32, &work[(
00804 n << 1) + 1], &c__1, &c_b32, "N", idumma, &n, &n, &
00805 c_b18, &anorm, "NO", &a[a_offset], lda, &iwork[1], &
00806 iinfo);
00807
00808 } else if (itype == 9) {
00809
00810
00811
00812 slatmr_(&n, &n, "S", &iseed[1], "N", &work[1], &c__6, &c_b32,
00813 &c_b32, "T", "N", &work[n + 1], &c__1, &c_b32, &work[(
00814 n << 1) + 1], &c__1, &c_b32, "N", idumma, &n, &n, &
00815 c_b18, &anorm, "NO", &a[a_offset], lda, &iwork[1], &
00816 iinfo);
00817 if (n >= 4) {
00818 slaset_("Full", &c__2, &n, &c_b18, &c_b18, &a[a_offset],
00819 lda);
00820 i__3 = n - 3;
00821 slaset_("Full", &i__3, &c__1, &c_b18, &c_b18, &a[a_dim1 +
00822 3], lda);
00823 i__3 = n - 3;
00824 slaset_("Full", &i__3, &c__2, &c_b18, &c_b18, &a[(n - 1) *
00825 a_dim1 + 3], lda);
00826 slaset_("Full", &c__1, &n, &c_b18, &c_b18, &a[n + a_dim1],
00827 lda);
00828 }
00829
00830 } else if (itype == 10) {
00831
00832
00833
00834 slatmr_(&n, &n, "S", &iseed[1], "N", &work[1], &c__6, &c_b32,
00835 &c_b32, "T", "N", &work[n + 1], &c__1, &c_b32, &work[(
00836 n << 1) + 1], &c__1, &c_b32, "N", idumma, &n, &c__0, &
00837 c_b18, &anorm, "NO", &a[a_offset], lda, &iwork[1], &
00838 iinfo);
00839
00840 } else {
00841
00842 iinfo = 1;
00843 }
00844
00845 if (iinfo != 0) {
00846 io___32.ciunit = *nounit;
00847 s_wsfe(&io___32);
00848 do_fio(&c__1, "Generator", (ftnlen)9);
00849 do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer));
00850 do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
00851 do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
00852 do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer));
00853 e_wsfe();
00854 *info = abs(iinfo);
00855 return 0;
00856 }
00857
00858 L90:
00859
00860
00861
00862 for (iwk = 1; iwk <= 2; ++iwk) {
00863 if (iwk == 1) {
00864 nnwork = n * 3;
00865 } else {
00866
00867 i__3 = n * 3, i__4 = (n << 1) * n;
00868 nnwork = max(i__3,i__4);
00869 }
00870 nnwork = max(nnwork,1);
00871
00872 sget24_(&c_false, &jtype, thresh, ioldsd, nounit, &n, &a[
00873 a_offset], lda, &h__[h_offset], &ht[ht_offset], &wr[1]
00874 , &wi[1], &wrt[1], &wit[1], &wrtmp[1], &witmp[1], &vs[
00875 vs_offset], ldvs, &vs1[vs1_offset], &rcdein, &rcdvin,
00876 &nslct, islct, &result[1], &work[1], &nnwork, &iwork[
00877 1], &bwork[1], info);
00878
00879
00880
00881 ntest = 0;
00882 nfail = 0;
00883 for (j = 1; j <= 15; ++j) {
00884 if (result[j] >= 0.f) {
00885 ++ntest;
00886 }
00887 if (result[j] >= *thresh) {
00888 ++nfail;
00889 }
00890
00891 }
00892
00893 if (nfail > 0) {
00894 ++ntestf;
00895 }
00896 if (ntestf == 1) {
00897 io___41.ciunit = *nounit;
00898 s_wsfe(&io___41);
00899 do_fio(&c__1, path, (ftnlen)3);
00900 e_wsfe();
00901 io___42.ciunit = *nounit;
00902 s_wsfe(&io___42);
00903 e_wsfe();
00904 io___43.ciunit = *nounit;
00905 s_wsfe(&io___43);
00906 e_wsfe();
00907 io___44.ciunit = *nounit;
00908 s_wsfe(&io___44);
00909 e_wsfe();
00910 io___45.ciunit = *nounit;
00911 s_wsfe(&io___45);
00912 do_fio(&c__1, (char *)&(*thresh), (ftnlen)sizeof(real));
00913 e_wsfe();
00914 io___46.ciunit = *nounit;
00915 s_wsfe(&io___46);
00916 e_wsfe();
00917 ntestf = 2;
00918 }
00919
00920 for (j = 1; j <= 15; ++j) {
00921 if (result[j] >= *thresh) {
00922 io___47.ciunit = *nounit;
00923 s_wsfe(&io___47);
00924 do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
00925 do_fio(&c__1, (char *)&iwk, (ftnlen)sizeof(integer));
00926 do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(
00927 integer));
00928 do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer))
00929 ;
00930 do_fio(&c__1, (char *)&j, (ftnlen)sizeof(integer));
00931 do_fio(&c__1, (char *)&result[j], (ftnlen)sizeof(real)
00932 );
00933 e_wsfe();
00934 }
00935
00936 }
00937
00938 nerrs += nfail;
00939 ntestt += ntest;
00940
00941
00942 }
00943 L130:
00944 ;
00945 }
00946
00947 }
00948
00949 L150:
00950
00951
00952
00953
00954 jtype = 0;
00955 L160:
00956 io___48.ciunit = *niunit;
00957 i__1 = s_rsle(&io___48);
00958 if (i__1 != 0) {
00959 goto L200;
00960 }
00961 i__1 = do_lio(&c__3, &c__1, (char *)&n, (ftnlen)sizeof(integer));
00962 if (i__1 != 0) {
00963 goto L200;
00964 }
00965 i__1 = do_lio(&c__3, &c__1, (char *)&nslct, (ftnlen)sizeof(integer));
00966 if (i__1 != 0) {
00967 goto L200;
00968 }
00969 i__1 = e_rsle();
00970 if (i__1 != 0) {
00971 goto L200;
00972 }
00973 if (n == 0) {
00974 goto L200;
00975 }
00976 ++jtype;
00977 iseed[1] = jtype;
00978 if (nslct > 0) {
00979 io___49.ciunit = *niunit;
00980 s_rsle(&io___49);
00981 i__1 = nslct;
00982 for (i__ = 1; i__ <= i__1; ++i__) {
00983 do_lio(&c__3, &c__1, (char *)&islct[i__ - 1], (ftnlen)sizeof(
00984 integer));
00985 }
00986 e_rsle();
00987 }
00988 i__1 = n;
00989 for (i__ = 1; i__ <= i__1; ++i__) {
00990 io___51.ciunit = *niunit;
00991 s_rsle(&io___51);
00992 i__2 = n;
00993 for (j = 1; j <= i__2; ++j) {
00994 do_lio(&c__4, &c__1, (char *)&a[i__ + j * a_dim1], (ftnlen)sizeof(
00995 real));
00996 }
00997 e_rsle();
00998
00999 }
01000 io___52.ciunit = *niunit;
01001 s_rsle(&io___52);
01002 do_lio(&c__4, &c__1, (char *)&rcdein, (ftnlen)sizeof(real));
01003 do_lio(&c__4, &c__1, (char *)&rcdvin, (ftnlen)sizeof(real));
01004 e_rsle();
01005
01006 sget24_(&c_true, &c__22, thresh, &iseed[1], nounit, &n, &a[a_offset], lda,
01007 &h__[h_offset], &ht[ht_offset], &wr[1], &wi[1], &wrt[1], &wit[1],
01008 &wrtmp[1], &witmp[1], &vs[vs_offset], ldvs, &vs1[vs1_offset], &
01009 rcdein, &rcdvin, &nslct, islct, &result[1], &work[1], lwork, &
01010 iwork[1], &bwork[1], info);
01011
01012
01013
01014 ntest = 0;
01015 nfail = 0;
01016 for (j = 1; j <= 17; ++j) {
01017 if (result[j] >= 0.f) {
01018 ++ntest;
01019 }
01020 if (result[j] >= *thresh) {
01021 ++nfail;
01022 }
01023
01024 }
01025
01026 if (nfail > 0) {
01027 ++ntestf;
01028 }
01029 if (ntestf == 1) {
01030 io___53.ciunit = *nounit;
01031 s_wsfe(&io___53);
01032 do_fio(&c__1, path, (ftnlen)3);
01033 e_wsfe();
01034 io___54.ciunit = *nounit;
01035 s_wsfe(&io___54);
01036 e_wsfe();
01037 io___55.ciunit = *nounit;
01038 s_wsfe(&io___55);
01039 e_wsfe();
01040 io___56.ciunit = *nounit;
01041 s_wsfe(&io___56);
01042 e_wsfe();
01043 io___57.ciunit = *nounit;
01044 s_wsfe(&io___57);
01045 do_fio(&c__1, (char *)&(*thresh), (ftnlen)sizeof(real));
01046 e_wsfe();
01047 io___58.ciunit = *nounit;
01048 s_wsfe(&io___58);
01049 e_wsfe();
01050 ntestf = 2;
01051 }
01052 for (j = 1; j <= 17; ++j) {
01053 if (result[j] >= *thresh) {
01054 io___59.ciunit = *nounit;
01055 s_wsfe(&io___59);
01056 do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
01057 do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
01058 do_fio(&c__1, (char *)&j, (ftnlen)sizeof(integer));
01059 do_fio(&c__1, (char *)&result[j], (ftnlen)sizeof(real));
01060 e_wsfe();
01061 }
01062
01063 }
01064
01065 nerrs += nfail;
01066 ntestt += ntest;
01067 goto L160;
01068 L200:
01069
01070
01071
01072 slasum_(path, nounit, &nerrs, &ntestt);
01073
01074
01075
01076 return 0;
01077
01078
01079
01080 }