sdrvgb.c
Go to the documentation of this file.
00001 /* sdrvgb.f -- translated by f2c (version 20061008).
00002    You must link the resulting object file with libf2c:
00003         on Microsoft Windows system, link with libf2c.lib;
00004         on Linux or Unix systems, link with .../path/to/libf2c.a -lm
00005         or, if you install libf2c.a in a standard place, with -lf2c -lm
00006         -- in that order, at the end of the command line, as in
00007                 cc *.o -lf2c -lm
00008         Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
00009 
00010                 http://www.netlib.org/f2c/libf2c.zip
00011 */
00012 
00013 #include "f2c.h"
00014 #include "blaswrap.h"
00015 
00016 /* Common Block Declarations */
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 /* Table of constant values */
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 real c_b48 = 0.f;
00038 static real c_b49 = 1.f;
00039 static integer c__6 = 6;
00040 static integer c__7 = 7;
00041 
00042 /* Subroutine */ int sdrvgb_(logical *dotype, integer *nn, integer *nval, 
00043         integer *nrhs, real *thresh, logical *tsterr, real *a, integer *la, 
00044         real *afb, integer *lafb, real *asav, real *b, real *bsav, real *x, 
00045         real *xact, real *s, real *work, real *rwork, integer *iwork, integer 
00046         *nout)
00047 {
00048     /* Initialized data */
00049 
00050     static integer iseedy[4] = { 1988,1989,1990,1991 };
00051     static char transs[1*3] = "N" "T" "C";
00052     static char facts[1*3] = "F" "N" "E";
00053     static char equeds[1*4] = "N" "R" "C" "B";
00054 
00055     /* Format strings */
00056     static char fmt_9999[] = "(\002 *** In SDRVGB, LA=\002,i5,\002 is too sm"
00057             "all for N=\002,i5,\002, KU=\002,i5,\002, KL=\002,i5,/\002 ==> In"
00058             "crease LA to at least \002,i5)";
00059     static char fmt_9998[] = "(\002 *** In SDRVGB, LAFB=\002,i5,\002 is too "
00060             "small for N=\002,i5,\002, KU=\002,i5,\002, KL=\002,i5,/\002 ==> "
00061             "Increase LAFB to at least \002,i5)";
00062     static char fmt_9997[] = "(1x,a,\002, N=\002,i5,\002, KL=\002,i5,\002, K"
00063             "U=\002,i5,\002, type \002,i1,\002, test(\002,i1,\002)=\002,g12.5)"
00064             ;
00065     static char fmt_9995[] = "(1x,a,\002( '\002,a1,\002','\002,a1,\002',\002"
00066             ",i5,\002,\002,i5,\002,\002,i5,\002,...), EQUED='\002,a1,\002', t"
00067             "ype \002,i1,\002, test(\002,i1,\002)=\002,g12.5)";
00068     static char fmt_9996[] = "(1x,a,\002( '\002,a1,\002','\002,a1,\002',\002"
00069             ",i5,\002,\002,i5,\002,\002,i5,\002,...), type \002,i1,\002, test("
00070             "\002,i1,\002)=\002,g12.5)";
00071 
00072     /* System generated locals */
00073     address a__1[2];
00074     integer i__1, i__2, i__3, i__4, i__5, i__6, i__7, i__8, i__9, i__10, 
00075             i__11[2];
00076     real r__1, r__2, r__3;
00077     char ch__1[2];
00078 
00079     /* Builtin functions */
00080     /* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);
00081     integer s_wsfe(cilist *), do_fio(integer *, char *, ftnlen), e_wsfe(void);
00082     /* Subroutine */ int s_cat(char *, char **, integer *, integer *, ftnlen);
00083 
00084     /* Local variables */
00085     integer i__, j, k, n, i1, i2, k1, nb, in, kl, ku, nt, lda, ldb, ikl, nkl, 
00086             iku, nku;
00087     char fact[1];
00088     integer ioff, mode;
00089     real amax;
00090     char path[3];
00091     integer imat, info;
00092     char dist[1], type__[1];
00093     integer nrun, ldafb, ifact, nfail, iseed[4], nfact;
00094     extern logical lsame_(char *, char *);
00095     extern /* Subroutine */ int sgbt01_(integer *, integer *, integer *, 
00096             integer *, real *, integer *, real *, integer *, integer *, real *
00097 , real *);
00098     char equed[1];
00099     integer nbmin;
00100     real rcond, roldc;
00101     extern /* Subroutine */ int sgbt02_(char *, integer *, integer *, integer 
00102             *, integer *, integer *, real *, integer *, real *, integer *, 
00103             real *, integer *, real *);
00104     integer nimat;
00105     real roldi;
00106     extern doublereal sget06_(real *, real *);
00107     extern /* Subroutine */ int sgbt05_(char *, integer *, integer *, integer 
00108             *, integer *, real *, integer *, real *, integer *, real *, 
00109             integer *, real *, integer *, real *, real *, real *);
00110     real anorm;
00111     integer itran;
00112     extern /* Subroutine */ int sget04_(integer *, integer *, real *, integer 
00113             *, real *, integer *, real *, real *);
00114     logical equil;
00115     real roldo;
00116     extern /* Subroutine */ int sgbsv_(integer *, integer *, integer *, 
00117             integer *, real *, integer *, integer *, real *, integer *, 
00118             integer *);
00119     char trans[1];
00120     integer izero, nerrs;
00121     logical zerot;
00122     char xtype[1];
00123     extern /* Subroutine */ int slatb4_(char *, integer *, integer *, integer 
00124             *, char *, integer *, integer *, real *, integer *, real *, char *
00125 ), aladhd_(integer *, char *), 
00126             alaerh_(char *, char *, integer *, integer *, char *, integer *, 
00127             integer *, integer *, integer *, integer *, integer *, integer *, 
00128             integer *, integer *);
00129     logical prefac;
00130     real colcnd;
00131     extern doublereal slangb_(char *, integer *, integer *, integer *, real *, 
00132              integer *, real *), slamch_(char *);
00133     real rcondc;
00134     extern doublereal slange_(char *, integer *, integer *, real *, integer *, 
00135              real *);
00136     logical nofact;
00137     extern /* Subroutine */ int slaqgb_(integer *, integer *, integer *, 
00138             integer *, real *, integer *, real *, real *, real *, real *, 
00139             real *, char *);
00140     integer iequed;
00141     real rcondi;
00142     extern doublereal slantb_(char *, char *, char *, integer *, integer *, 
00143             real *, integer *, real *);
00144     real cndnum, anormi, rcondo, ainvnm;
00145     extern /* Subroutine */ int alasvm_(char *, integer *, integer *, integer 
00146             *, integer *);
00147     logical trfcon;
00148     real anormo, rowcnd;
00149     extern /* Subroutine */ int sgbequ_(integer *, integer *, integer *, 
00150             integer *, real *, integer *, real *, real *, real *, real *, 
00151             real *, integer *), sgbtrf_(integer *, integer *, integer *, 
00152             integer *, real *, integer *, integer *, integer *), slacpy_(char 
00153             *, integer *, integer *, real *, integer *, real *, integer *), slarhs_(char *, char *, char *, char *, integer *, 
00154             integer *, integer *, integer *, integer *, real *, integer *, 
00155             real *, integer *, real *, integer *, integer *, integer *);
00156     real anrmpv;
00157     extern /* Subroutine */ int sgbtrs_(char *, integer *, integer *, integer 
00158             *, integer *, real *, integer *, integer *, real *, integer *, 
00159             integer *), slaset_(char *, integer *, integer *, real *, 
00160             real *, real *, integer *), slatms_(integer *, integer *, 
00161             char *, integer *, char *, real *, integer *, real *, real *, 
00162             integer *, integer *, char *, real *, integer *, real *, integer *
00163 ), xlaenv_(integer *, integer *), sgbsvx_(
00164             char *, char *, integer *, integer *, integer *, integer *, real *
00165 , integer *, real *, integer *, integer *, char *, real *, real *, 
00166              real *, integer *, real *, integer *, real *, real *, real *, 
00167             real *, integer *, integer *);
00168     real result[7], rpvgrw;
00169     extern /* Subroutine */ int serrvx_(char *, integer *);
00170 
00171     /* Fortran I/O blocks */
00172     static cilist io___26 = { 0, 0, 0, fmt_9999, 0 };
00173     static cilist io___27 = { 0, 0, 0, fmt_9998, 0 };
00174     static cilist io___65 = { 0, 0, 0, fmt_9997, 0 };
00175     static cilist io___72 = { 0, 0, 0, fmt_9995, 0 };
00176     static cilist io___73 = { 0, 0, 0, fmt_9996, 0 };
00177     static cilist io___74 = { 0, 0, 0, fmt_9995, 0 };
00178     static cilist io___75 = { 0, 0, 0, fmt_9996, 0 };
00179     static cilist io___76 = { 0, 0, 0, fmt_9995, 0 };
00180     static cilist io___77 = { 0, 0, 0, fmt_9996, 0 };
00181     static cilist io___78 = { 0, 0, 0, fmt_9995, 0 };
00182     static cilist io___79 = { 0, 0, 0, fmt_9996, 0 };
00183 
00184 
00185 
00186 /*  -- LAPACK test routine (version 3.1) -- */
00187 /*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
00188 /*     November 2006 */
00189 
00190 /*     .. Scalar Arguments .. */
00191 /*     .. */
00192 /*     .. Array Arguments .. */
00193 /*     .. */
00194 
00195 /*  Purpose */
00196 /*  ======= */
00197 
00198 /*  SDRVGB tests the driver routines SGBSV and -SVX. */
00199 
00200 /*  Arguments */
00201 /*  ========= */
00202 
00203 /*  DOTYPE  (input) LOGICAL array, dimension (NTYPES) */
00204 /*          The matrix types to be used for testing.  Matrices of type j */
00205 /*          (for 1 <= j <= NTYPES) are used for testing if DOTYPE(j) = */
00206 /*          .TRUE.; if DOTYPE(j) = .FALSE., then type j is not used. */
00207 
00208 /*  NN      (input) INTEGER */
00209 /*          The number of values of N contained in the vector NVAL. */
00210 
00211 /*  NVAL    (input) INTEGER array, dimension (NN) */
00212 /*          The values of the matrix column dimension N. */
00213 
00214 /*  NRHS    (input) INTEGER */
00215 /*          The number of right hand side vectors to be generated for */
00216 /*          each linear system. */
00217 
00218 /*  THRESH  (input) REAL */
00219 /*          The threshold value for the test ratios.  A result is */
00220 /*          included in the output file if RESULT >= THRESH.  To have */
00221 /*          every test ratio printed, use THRESH = 0. */
00222 
00223 /*  TSTERR  (input) LOGICAL */
00224 /*          Flag that indicates whether error exits are to be tested. */
00225 
00226 /*  A       (workspace) REAL array, dimension (LA) */
00227 
00228 /*  LA      (input) INTEGER */
00229 /*          The length of the array A.  LA >= (2*NMAX-1)*NMAX */
00230 /*          where NMAX is the largest entry in NVAL. */
00231 
00232 /*  AFB     (workspace) REAL array, dimension (LAFB) */
00233 
00234 /*  LAFB    (input) INTEGER */
00235 /*          The length of the array AFB.  LAFB >= (3*NMAX-2)*NMAX */
00236 /*          where NMAX is the largest entry in NVAL. */
00237 
00238 /*  ASAV    (workspace) REAL array, dimension (LA) */
00239 
00240 /*  B       (workspace) REAL array, dimension (NMAX*NRHS) */
00241 
00242 /*  BSAV    (workspace) REAL array, dimension (NMAX*NRHS) */
00243 
00244 /*  X       (workspace) REAL array, dimension (NMAX*NRHS) */
00245 
00246 /*  XACT    (workspace) REAL array, dimension (NMAX*NRHS) */
00247 
00248 /*  S       (workspace) REAL array, dimension (2*NMAX) */
00249 
00250 /*  WORK    (workspace) REAL array, dimension */
00251 /*                      (NMAX*max(3,NRHS,NMAX)) */
00252 
00253 /*  RWORK   (workspace) REAL array, dimension */
00254 /*                      (max(NMAX,2*NRHS)) */
00255 
00256 /*  IWORK   (workspace) INTEGER array, dimension (2*NMAX) */
00257 
00258 /*  NOUT    (input) INTEGER */
00259 /*          The unit number for output. */
00260 
00261 /*  ===================================================================== */
00262 
00263 /*     .. Parameters .. */
00264 /*     .. */
00265 /*     .. Local Scalars .. */
00266 /*     .. */
00267 /*     .. Local Arrays .. */
00268 /*     .. */
00269 /*     .. External Functions .. */
00270 /*     .. */
00271 /*     .. External Subroutines .. */
00272 /*     .. */
00273 /*     .. Intrinsic Functions .. */
00274 /*     .. */
00275 /*     .. Scalars in Common .. */
00276 /*     .. */
00277 /*     .. Common blocks .. */
00278 /*     .. */
00279 /*     .. Data statements .. */
00280     /* Parameter adjustments */
00281     --iwork;
00282     --rwork;
00283     --work;
00284     --s;
00285     --xact;
00286     --x;
00287     --bsav;
00288     --b;
00289     --asav;
00290     --afb;
00291     --a;
00292     --nval;
00293     --dotype;
00294 
00295     /* Function Body */
00296 /*     .. */
00297 /*     .. Executable Statements .. */
00298 
00299 /*     Initialize constants and the random number seed. */
00300 
00301     s_copy(path, "Single precision", (ftnlen)1, (ftnlen)16);
00302     s_copy(path + 1, "GB", (ftnlen)2, (ftnlen)2);
00303     nrun = 0;
00304     nfail = 0;
00305     nerrs = 0;
00306     for (i__ = 1; i__ <= 4; ++i__) {
00307         iseed[i__ - 1] = iseedy[i__ - 1];
00308 /* L10: */
00309     }
00310 
00311 /*     Test the error exits */
00312 
00313     if (*tsterr) {
00314         serrvx_(path, nout);
00315     }
00316     infoc_1.infot = 0;
00317 
00318 /*     Set the block size and minimum block size for testing. */
00319 
00320     nb = 1;
00321     nbmin = 2;
00322     xlaenv_(&c__1, &nb);
00323     xlaenv_(&c__2, &nbmin);
00324 
00325 /*     Do for each value of N in NVAL */
00326 
00327     i__1 = *nn;
00328     for (in = 1; in <= i__1; ++in) {
00329         n = nval[in];
00330         ldb = max(n,1);
00331         *(unsigned char *)xtype = 'N';
00332 
00333 /*        Set limits on the number of loop iterations. */
00334 
00335 /* Computing MAX */
00336         i__2 = 1, i__3 = min(n,4);
00337         nkl = max(i__2,i__3);
00338         if (n == 0) {
00339             nkl = 1;
00340         }
00341         nku = nkl;
00342         nimat = 8;
00343         if (n <= 0) {
00344             nimat = 1;
00345         }
00346 
00347         i__2 = nkl;
00348         for (ikl = 1; ikl <= i__2; ++ikl) {
00349 
00350 /*           Do for KL = 0, N-1, (3N-1)/4, and (N+1)/4. This order makes */
00351 /*           it easier to skip redundant values for small values of N. */
00352 
00353             if (ikl == 1) {
00354                 kl = 0;
00355             } else if (ikl == 2) {
00356 /* Computing MAX */
00357                 i__3 = n - 1;
00358                 kl = max(i__3,0);
00359             } else if (ikl == 3) {
00360                 kl = (n * 3 - 1) / 4;
00361             } else if (ikl == 4) {
00362                 kl = (n + 1) / 4;
00363             }
00364             i__3 = nku;
00365             for (iku = 1; iku <= i__3; ++iku) {
00366 
00367 /*              Do for KU = 0, N-1, (3N-1)/4, and (N+1)/4. This order */
00368 /*              makes it easier to skip redundant values for small */
00369 /*              values of N. */
00370 
00371                 if (iku == 1) {
00372                     ku = 0;
00373                 } else if (iku == 2) {
00374 /* Computing MAX */
00375                     i__4 = n - 1;
00376                     ku = max(i__4,0);
00377                 } else if (iku == 3) {
00378                     ku = (n * 3 - 1) / 4;
00379                 } else if (iku == 4) {
00380                     ku = (n + 1) / 4;
00381                 }
00382 
00383 /*              Check that A and AFB are big enough to generate this */
00384 /*              matrix. */
00385 
00386                 lda = kl + ku + 1;
00387                 ldafb = (kl << 1) + ku + 1;
00388                 if (lda * n > *la || ldafb * n > *lafb) {
00389                     if (nfail == 0 && nerrs == 0) {
00390                         aladhd_(nout, path);
00391                     }
00392                     if (lda * n > *la) {
00393                         io___26.ciunit = *nout;
00394                         s_wsfe(&io___26);
00395                         do_fio(&c__1, (char *)&(*la), (ftnlen)sizeof(integer))
00396                                 ;
00397                         do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
00398                         do_fio(&c__1, (char *)&kl, (ftnlen)sizeof(integer));
00399                         do_fio(&c__1, (char *)&ku, (ftnlen)sizeof(integer));
00400                         i__4 = n * (kl + ku + 1);
00401                         do_fio(&c__1, (char *)&i__4, (ftnlen)sizeof(integer));
00402                         e_wsfe();
00403                         ++nerrs;
00404                     }
00405                     if (ldafb * n > *lafb) {
00406                         io___27.ciunit = *nout;
00407                         s_wsfe(&io___27);
00408                         do_fio(&c__1, (char *)&(*lafb), (ftnlen)sizeof(
00409                                 integer));
00410                         do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
00411                         do_fio(&c__1, (char *)&kl, (ftnlen)sizeof(integer));
00412                         do_fio(&c__1, (char *)&ku, (ftnlen)sizeof(integer));
00413                         i__4 = n * ((kl << 1) + ku + 1);
00414                         do_fio(&c__1, (char *)&i__4, (ftnlen)sizeof(integer));
00415                         e_wsfe();
00416                         ++nerrs;
00417                     }
00418                     goto L130;
00419                 }
00420 
00421                 i__4 = nimat;
00422                 for (imat = 1; imat <= i__4; ++imat) {
00423 
00424 /*                 Do the tests only if DOTYPE( IMAT ) is true. */
00425 
00426                     if (! dotype[imat]) {
00427                         goto L120;
00428                     }
00429 
00430 /*                 Skip types 2, 3, or 4 if the matrix is too small. */
00431 
00432                     zerot = imat >= 2 && imat <= 4;
00433                     if (zerot && n < imat - 1) {
00434                         goto L120;
00435                     }
00436 
00437 /*                 Set up parameters with SLATB4 and generate a */
00438 /*                 test matrix with SLATMS. */
00439 
00440                     slatb4_(path, &imat, &n, &n, type__, &kl, &ku, &anorm, &
00441                             mode, &cndnum, dist);
00442                     rcondc = 1.f / cndnum;
00443 
00444                     s_copy(srnamc_1.srnamt, "SLATMS", (ftnlen)32, (ftnlen)6);
00445                     slatms_(&n, &n, dist, iseed, type__, &rwork[1], &mode, &
00446                             cndnum, &anorm, &kl, &ku, "Z", &a[1], &lda, &work[
00447                             1], &info);
00448 
00449 /*                 Check the error code from SLATMS. */
00450 
00451                     if (info != 0) {
00452                         alaerh_(path, "SLATMS", &info, &c__0, " ", &n, &n, &
00453                                 kl, &ku, &c_n1, &imat, &nfail, &nerrs, nout);
00454                         goto L120;
00455                     }
00456 
00457 /*                 For types 2, 3, and 4, zero one or more columns of */
00458 /*                 the matrix to test that INFO is returned correctly. */
00459 
00460                     izero = 0;
00461                     if (zerot) {
00462                         if (imat == 2) {
00463                             izero = 1;
00464                         } else if (imat == 3) {
00465                             izero = n;
00466                         } else {
00467                             izero = n / 2 + 1;
00468                         }
00469                         ioff = (izero - 1) * lda;
00470                         if (imat < 4) {
00471 /* Computing MAX */
00472                             i__5 = 1, i__6 = ku + 2 - izero;
00473                             i1 = max(i__5,i__6);
00474 /* Computing MIN */
00475                             i__5 = kl + ku + 1, i__6 = ku + 1 + (n - izero);
00476                             i2 = min(i__5,i__6);
00477                             i__5 = i2;
00478                             for (i__ = i1; i__ <= i__5; ++i__) {
00479                                 a[ioff + i__] = 0.f;
00480 /* L20: */
00481                             }
00482                         } else {
00483                             i__5 = n;
00484                             for (j = izero; j <= i__5; ++j) {
00485 /* Computing MAX */
00486                                 i__6 = 1, i__7 = ku + 2 - j;
00487 /* Computing MIN */
00488                                 i__9 = kl + ku + 1, i__10 = ku + 1 + (n - j);
00489                                 i__8 = min(i__9,i__10);
00490                                 for (i__ = max(i__6,i__7); i__ <= i__8; ++i__)
00491                                          {
00492                                     a[ioff + i__] = 0.f;
00493 /* L30: */
00494                                 }
00495                                 ioff += lda;
00496 /* L40: */
00497                             }
00498                         }
00499                     }
00500 
00501 /*                 Save a copy of the matrix A in ASAV. */
00502 
00503                     i__5 = kl + ku + 1;
00504                     slacpy_("Full", &i__5, &n, &a[1], &lda, &asav[1], &lda);
00505 
00506                     for (iequed = 1; iequed <= 4; ++iequed) {
00507                         *(unsigned char *)equed = *(unsigned char *)&equeds[
00508                                 iequed - 1];
00509                         if (iequed == 1) {
00510                             nfact = 3;
00511                         } else {
00512                             nfact = 1;
00513                         }
00514 
00515                         i__5 = nfact;
00516                         for (ifact = 1; ifact <= i__5; ++ifact) {
00517                             *(unsigned char *)fact = *(unsigned char *)&facts[
00518                                     ifact - 1];
00519                             prefac = lsame_(fact, "F");
00520                             nofact = lsame_(fact, "N");
00521                             equil = lsame_(fact, "E");
00522 
00523                             if (zerot) {
00524                                 if (prefac) {
00525                                     goto L100;
00526                                 }
00527                                 rcondo = 0.f;
00528                                 rcondi = 0.f;
00529 
00530                             } else if (! nofact) {
00531 
00532 /*                          Compute the condition number for comparison */
00533 /*                          with the value returned by SGESVX (FACT = */
00534 /*                          'N' reuses the condition number from the */
00535 /*                          previous iteration with FACT = 'F'). */
00536 
00537                                 i__8 = kl + ku + 1;
00538                                 slacpy_("Full", &i__8, &n, &asav[1], &lda, &
00539                                         afb[kl + 1], &ldafb);
00540                                 if (equil || iequed > 1) {
00541 
00542 /*                             Compute row and column scale factors to */
00543 /*                             equilibrate the matrix A. */
00544 
00545                                     sgbequ_(&n, &n, &kl, &ku, &afb[kl + 1], &
00546                                             ldafb, &s[1], &s[n + 1], &rowcnd, 
00547                                             &colcnd, &amax, &info);
00548                                     if (info == 0 && n > 0) {
00549                                         if (lsame_(equed, "R")) {
00550                                             rowcnd = 0.f;
00551                                             colcnd = 1.f;
00552                                         } else if (lsame_(equed, "C")) {
00553                                             rowcnd = 1.f;
00554                                             colcnd = 0.f;
00555                                         } else if (lsame_(equed, "B")) {
00556                                             rowcnd = 0.f;
00557                                             colcnd = 0.f;
00558                                         }
00559 
00560 /*                                Equilibrate the matrix. */
00561 
00562                                         slaqgb_(&n, &n, &kl, &ku, &afb[kl + 1]
00563 , &ldafb, &s[1], &s[n + 1], &
00564                                                 rowcnd, &colcnd, &amax, equed);
00565                                     }
00566                                 }
00567 
00568 /*                          Save the condition number of the */
00569 /*                          non-equilibrated system for use in SGET04. */
00570 
00571                                 if (equil) {
00572                                     roldo = rcondo;
00573                                     roldi = rcondi;
00574                                 }
00575 
00576 /*                          Compute the 1-norm and infinity-norm of A. */
00577 
00578                                 anormo = slangb_("1", &n, &kl, &ku, &afb[kl + 
00579                                         1], &ldafb, &rwork[1]);
00580                                 anormi = slangb_("I", &n, &kl, &ku, &afb[kl + 
00581                                         1], &ldafb, &rwork[1]);
00582 
00583 /*                          Factor the matrix A. */
00584 
00585                                 sgbtrf_(&n, &n, &kl, &ku, &afb[1], &ldafb, &
00586                                         iwork[1], &info);
00587 
00588 /*                          Form the inverse of A. */
00589 
00590                                 slaset_("Full", &n, &n, &c_b48, &c_b49, &work[
00591                                         1], &ldb);
00592                                 s_copy(srnamc_1.srnamt, "SGBTRS", (ftnlen)32, 
00593                                         (ftnlen)6);
00594                                 sgbtrs_("No transpose", &n, &kl, &ku, &n, &
00595                                         afb[1], &ldafb, &iwork[1], &work[1], &
00596                                         ldb, &info);
00597 
00598 /*                          Compute the 1-norm condition number of A. */
00599 
00600                                 ainvnm = slange_("1", &n, &n, &work[1], &ldb, 
00601                                         &rwork[1]);
00602                                 if (anormo <= 0.f || ainvnm <= 0.f) {
00603                                     rcondo = 1.f;
00604                                 } else {
00605                                     rcondo = 1.f / anormo / ainvnm;
00606                                 }
00607 
00608 /*                          Compute the infinity-norm condition number */
00609 /*                          of A. */
00610 
00611                                 ainvnm = slange_("I", &n, &n, &work[1], &ldb, 
00612                                         &rwork[1]);
00613                                 if (anormi <= 0.f || ainvnm <= 0.f) {
00614                                     rcondi = 1.f;
00615                                 } else {
00616                                     rcondi = 1.f / anormi / ainvnm;
00617                                 }
00618                             }
00619 
00620                             for (itran = 1; itran <= 3; ++itran) {
00621 
00622 /*                          Do for each value of TRANS. */
00623 
00624                                 *(unsigned char *)trans = *(unsigned char *)&
00625                                         transs[itran - 1];
00626                                 if (itran == 1) {
00627                                     rcondc = rcondo;
00628                                 } else {
00629                                     rcondc = rcondi;
00630                                 }
00631 
00632 /*                          Restore the matrix A. */
00633 
00634                                 i__8 = kl + ku + 1;
00635                                 slacpy_("Full", &i__8, &n, &asav[1], &lda, &a[
00636                                         1], &lda);
00637 
00638 /*                          Form an exact solution and set the right hand */
00639 /*                          side. */
00640 
00641                                 s_copy(srnamc_1.srnamt, "SLARHS", (ftnlen)32, 
00642                                         (ftnlen)6);
00643                                 slarhs_(path, xtype, "Full", trans, &n, &n, &
00644                                         kl, &ku, nrhs, &a[1], &lda, &xact[1], 
00645                                         &ldb, &b[1], &ldb, iseed, &info);
00646                                 *(unsigned char *)xtype = 'C';
00647                                 slacpy_("Full", &n, nrhs, &b[1], &ldb, &bsav[
00648                                         1], &ldb);
00649 
00650                                 if (nofact && itran == 1) {
00651 
00652 /*                             --- Test SGBSV  --- */
00653 
00654 /*                             Compute the LU factorization of the matrix */
00655 /*                             and solve the system. */
00656 
00657                                     i__8 = kl + ku + 1;
00658                                     slacpy_("Full", &i__8, &n, &a[1], &lda, &
00659                                             afb[kl + 1], &ldafb);
00660                                     slacpy_("Full", &n, nrhs, &b[1], &ldb, &x[
00661                                             1], &ldb);
00662 
00663                                     s_copy(srnamc_1.srnamt, "SGBSV ", (ftnlen)
00664                                             32, (ftnlen)6);
00665                                     sgbsv_(&n, &kl, &ku, nrhs, &afb[1], &
00666                                             ldafb, &iwork[1], &x[1], &ldb, &
00667                                             info);
00668 
00669 /*                             Check error code from SGBSV . */
00670 
00671                                     if (info != izero) {
00672                                         alaerh_(path, "SGBSV ", &info, &izero, 
00673                                                  " ", &n, &n, &kl, &ku, nrhs, 
00674                                                 &imat, &nfail, &nerrs, nout);
00675                                     }
00676 
00677 /*                             Reconstruct matrix from factors and */
00678 /*                             compute residual. */
00679 
00680                                     sgbt01_(&n, &n, &kl, &ku, &a[1], &lda, &
00681                                             afb[1], &ldafb, &iwork[1], &work[
00682                                             1], result);
00683                                     nt = 1;
00684                                     if (izero == 0) {
00685 
00686 /*                                Compute residual of the computed */
00687 /*                                solution. */
00688 
00689                                         slacpy_("Full", &n, nrhs, &b[1], &ldb, 
00690                                                  &work[1], &ldb);
00691                                         sgbt02_("No transpose", &n, &n, &kl, &
00692                                                 ku, nrhs, &a[1], &lda, &x[1], 
00693                                                 &ldb, &work[1], &ldb, &result[
00694                                                 1]);
00695 
00696 /*                                Check solution from generated exact */
00697 /*                                solution. */
00698 
00699                                         sget04_(&n, nrhs, &x[1], &ldb, &xact[
00700                                                 1], &ldb, &rcondc, &result[2])
00701                                                 ;
00702                                         nt = 3;
00703                                     }
00704 
00705 /*                             Print information about the tests that did */
00706 /*                             not pass the threshold. */
00707 
00708                                     i__8 = nt;
00709                                     for (k = 1; k <= i__8; ++k) {
00710                                         if (result[k - 1] >= *thresh) {
00711                                             if (nfail == 0 && nerrs == 0) {
00712                           aladhd_(nout, path);
00713                                             }
00714                                             io___65.ciunit = *nout;
00715                                             s_wsfe(&io___65);
00716                                             do_fio(&c__1, "SGBSV ", (ftnlen)6)
00717                                                     ;
00718                                             do_fio(&c__1, (char *)&n, (ftnlen)
00719                                                     sizeof(integer));
00720                                             do_fio(&c__1, (char *)&kl, (
00721                                                     ftnlen)sizeof(integer));
00722                                             do_fio(&c__1, (char *)&ku, (
00723                                                     ftnlen)sizeof(integer));
00724                                             do_fio(&c__1, (char *)&imat, (
00725                                                     ftnlen)sizeof(integer));
00726                                             do_fio(&c__1, (char *)&k, (ftnlen)
00727                                                     sizeof(integer));
00728                                             do_fio(&c__1, (char *)&result[k - 
00729                                                     1], (ftnlen)sizeof(real));
00730                                             e_wsfe();
00731                                             ++nfail;
00732                                         }
00733 /* L50: */
00734                                     }
00735                                     nrun += nt;
00736                                 }
00737 
00738 /*                          --- Test SGBSVX --- */
00739 
00740                                 if (! prefac) {
00741                                     i__8 = (kl << 1) + ku + 1;
00742                                     slaset_("Full", &i__8, &n, &c_b48, &c_b48, 
00743                                              &afb[1], &ldafb);
00744                                 }
00745                                 slaset_("Full", &n, nrhs, &c_b48, &c_b48, &x[
00746                                         1], &ldb);
00747                                 if (iequed > 1 && n > 0) {
00748 
00749 /*                             Equilibrate the matrix if FACT = 'F' and */
00750 /*                             EQUED = 'R', 'C', or 'B'. */
00751 
00752                                     slaqgb_(&n, &n, &kl, &ku, &a[1], &lda, &s[
00753                                             1], &s[n + 1], &rowcnd, &colcnd, &
00754                                             amax, equed);
00755                                 }
00756 
00757 /*                          Solve the system and compute the condition */
00758 /*                          number and error bounds using SGBSVX. */
00759 
00760                                 s_copy(srnamc_1.srnamt, "SGBSVX", (ftnlen)32, 
00761                                         (ftnlen)6);
00762                                 sgbsvx_(fact, trans, &n, &kl, &ku, nrhs, &a[1]
00763 , &lda, &afb[1], &ldafb, &iwork[1], 
00764                                         equed, &s[1], &s[n + 1], &b[1], &ldb, 
00765                                         &x[1], &ldb, &rcond, &rwork[1], &
00766                                         rwork[*nrhs + 1], &work[1], &iwork[n 
00767                                         + 1], &info);
00768 
00769 /*                          Check the error code from SGBSVX. */
00770 
00771                                 if (info != izero) {
00772 /* Writing concatenation */
00773                                     i__11[0] = 1, a__1[0] = fact;
00774                                     i__11[1] = 1, a__1[1] = trans;
00775                                     s_cat(ch__1, a__1, i__11, &c__2, (ftnlen)
00776                                             2);
00777                                     alaerh_(path, "SGBSVX", &info, &izero, 
00778                                             ch__1, &n, &n, &kl, &ku, nrhs, &
00779                                             imat, &nfail, &nerrs, nout);
00780                                 }
00781 
00782 /*                          Compare WORK(1) from SGBSVX with the computed */
00783 /*                          reciprocal pivot growth factor RPVGRW */
00784 
00785                                 if (info != 0) {
00786                                     anrmpv = 0.f;
00787                                     i__8 = info;
00788                                     for (j = 1; j <= i__8; ++j) {
00789 /* Computing MAX */
00790                                         i__6 = ku + 2 - j;
00791 /* Computing MIN */
00792                                         i__9 = n + ku + 1 - j, i__10 = kl + 
00793                                                 ku + 1;
00794                                         i__7 = min(i__9,i__10);
00795                                         for (i__ = max(i__6,1); i__ <= i__7; 
00796                                                 ++i__) {
00797 /* Computing MAX */
00798                                             r__2 = anrmpv, r__3 = (r__1 = a[
00799                                                     i__ + (j - 1) * lda], 
00800                                                     dabs(r__1));
00801                                             anrmpv = dmax(r__2,r__3);
00802 /* L60: */
00803                                         }
00804 /* L70: */
00805                                     }
00806 /* Computing MIN */
00807                                     i__7 = info - 1, i__6 = kl + ku;
00808                                     i__8 = min(i__7,i__6);
00809 /* Computing MAX */
00810                                     i__9 = 1, i__10 = kl + ku + 2 - info;
00811                                     rpvgrw = slantb_("M", "U", "N", &info, &
00812                                             i__8, &afb[max(i__9, i__10)], &
00813                                             ldafb, &work[1]);
00814                                     if (rpvgrw == 0.f) {
00815                                         rpvgrw = 1.f;
00816                                     } else {
00817                                         rpvgrw = anrmpv / rpvgrw;
00818                                     }
00819                                 } else {
00820                                     i__8 = kl + ku;
00821                                     rpvgrw = slantb_("M", "U", "N", &n, &i__8, 
00822                                              &afb[1], &ldafb, &work[1]);
00823                                     if (rpvgrw == 0.f) {
00824                                         rpvgrw = 1.f;
00825                                     } else {
00826                                         rpvgrw = slangb_("M", &n, &kl, &ku, &
00827                                                 a[1], &lda, &work[1]) / rpvgrw;
00828                                     }
00829                                 }
00830                                 result[6] = (r__1 = rpvgrw - work[1], dabs(
00831                                         r__1)) / dmax(work[1],rpvgrw) / 
00832                                         slamch_("E");
00833 
00834                                 if (! prefac) {
00835 
00836 /*                             Reconstruct matrix from factors and */
00837 /*                             compute residual. */
00838 
00839                                     sgbt01_(&n, &n, &kl, &ku, &a[1], &lda, &
00840                                             afb[1], &ldafb, &iwork[1], &work[
00841                                             1], result);
00842                                     k1 = 1;
00843                                 } else {
00844                                     k1 = 2;
00845                                 }
00846 
00847                                 if (info == 0) {
00848                                     trfcon = FALSE_;
00849 
00850 /*                             Compute residual of the computed solution. */
00851 
00852                                     slacpy_("Full", &n, nrhs, &bsav[1], &ldb, 
00853                                             &work[1], &ldb);
00854                                     sgbt02_(trans, &n, &n, &kl, &ku, nrhs, &
00855                                             asav[1], &lda, &x[1], &ldb, &work[
00856                                             1], &ldb, &result[1]);
00857 
00858 /*                             Check solution from generated exact */
00859 /*                             solution. */
00860 
00861                                     if (nofact || prefac && lsame_(equed, 
00862                                             "N")) {
00863                                         sget04_(&n, nrhs, &x[1], &ldb, &xact[
00864                                                 1], &ldb, &rcondc, &result[2])
00865                                                 ;
00866                                     } else {
00867                                         if (itran == 1) {
00868                                             roldc = roldo;
00869                                         } else {
00870                                             roldc = roldi;
00871                                         }
00872                                         sget04_(&n, nrhs, &x[1], &ldb, &xact[
00873                                                 1], &ldb, &roldc, &result[2]);
00874                                     }
00875 
00876 /*                             Check the error bounds from iterative */
00877 /*                             refinement. */
00878 
00879                                     sgbt05_(trans, &n, &kl, &ku, nrhs, &asav[
00880                                             1], &lda, &b[1], &ldb, &x[1], &
00881                                             ldb, &xact[1], &ldb, &rwork[1], &
00882                                             rwork[*nrhs + 1], &result[3]);
00883                                 } else {
00884                                     trfcon = TRUE_;
00885                                 }
00886 
00887 /*                          Compare RCOND from SGBSVX with the computed */
00888 /*                          value in RCONDC. */
00889 
00890                                 result[5] = sget06_(&rcond, &rcondc);
00891 
00892 /*                          Print information about the tests that did */
00893 /*                          not pass the threshold. */
00894 
00895                                 if (! trfcon) {
00896                                     for (k = k1; k <= 7; ++k) {
00897                                         if (result[k - 1] >= *thresh) {
00898                                             if (nfail == 0 && nerrs == 0) {
00899                           aladhd_(nout, path);
00900                                             }
00901                                             if (prefac) {
00902                           io___72.ciunit = *nout;
00903                           s_wsfe(&io___72);
00904                           do_fio(&c__1, "SGBSVX", (ftnlen)6);
00905                           do_fio(&c__1, fact, (ftnlen)1);
00906                           do_fio(&c__1, trans, (ftnlen)1);
00907                           do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
00908                           do_fio(&c__1, (char *)&kl, (ftnlen)sizeof(integer));
00909                           do_fio(&c__1, (char *)&ku, (ftnlen)sizeof(integer));
00910                           do_fio(&c__1, equed, (ftnlen)1);
00911                           do_fio(&c__1, (char *)&imat, (ftnlen)sizeof(integer)
00912                                   );
00913                           do_fio(&c__1, (char *)&k, (ftnlen)sizeof(integer));
00914                           do_fio(&c__1, (char *)&result[k - 1], (ftnlen)
00915                                   sizeof(real));
00916                           e_wsfe();
00917                                             } else {
00918                           io___73.ciunit = *nout;
00919                           s_wsfe(&io___73);
00920                           do_fio(&c__1, "SGBSVX", (ftnlen)6);
00921                           do_fio(&c__1, fact, (ftnlen)1);
00922                           do_fio(&c__1, trans, (ftnlen)1);
00923                           do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
00924                           do_fio(&c__1, (char *)&kl, (ftnlen)sizeof(integer));
00925                           do_fio(&c__1, (char *)&ku, (ftnlen)sizeof(integer));
00926                           do_fio(&c__1, (char *)&imat, (ftnlen)sizeof(integer)
00927                                   );
00928                           do_fio(&c__1, (char *)&k, (ftnlen)sizeof(integer));
00929                           do_fio(&c__1, (char *)&result[k - 1], (ftnlen)
00930                                   sizeof(real));
00931                           e_wsfe();
00932                                             }
00933                                             ++nfail;
00934                                         }
00935 /* L80: */
00936                                     }
00937                                     nrun = nrun + 7 - k1;
00938                                 } else {
00939                                     if (result[0] >= *thresh && ! prefac) {
00940                                         if (nfail == 0 && nerrs == 0) {
00941                                             aladhd_(nout, path);
00942                                         }
00943                                         if (prefac) {
00944                                             io___74.ciunit = *nout;
00945                                             s_wsfe(&io___74);
00946                                             do_fio(&c__1, "SGBSVX", (ftnlen)6)
00947                                                     ;
00948                                             do_fio(&c__1, fact, (ftnlen)1);
00949                                             do_fio(&c__1, trans, (ftnlen)1);
00950                                             do_fio(&c__1, (char *)&n, (ftnlen)
00951                                                     sizeof(integer));
00952                                             do_fio(&c__1, (char *)&kl, (
00953                                                     ftnlen)sizeof(integer));
00954                                             do_fio(&c__1, (char *)&ku, (
00955                                                     ftnlen)sizeof(integer));
00956                                             do_fio(&c__1, equed, (ftnlen)1);
00957                                             do_fio(&c__1, (char *)&imat, (
00958                                                     ftnlen)sizeof(integer));
00959                                             do_fio(&c__1, (char *)&c__1, (
00960                                                     ftnlen)sizeof(integer));
00961                                             do_fio(&c__1, (char *)&result[0], 
00962                                                     (ftnlen)sizeof(real));
00963                                             e_wsfe();
00964                                         } else {
00965                                             io___75.ciunit = *nout;
00966                                             s_wsfe(&io___75);
00967                                             do_fio(&c__1, "SGBSVX", (ftnlen)6)
00968                                                     ;
00969                                             do_fio(&c__1, fact, (ftnlen)1);
00970                                             do_fio(&c__1, trans, (ftnlen)1);
00971                                             do_fio(&c__1, (char *)&n, (ftnlen)
00972                                                     sizeof(integer));
00973                                             do_fio(&c__1, (char *)&kl, (
00974                                                     ftnlen)sizeof(integer));
00975                                             do_fio(&c__1, (char *)&ku, (
00976                                                     ftnlen)sizeof(integer));
00977                                             do_fio(&c__1, (char *)&imat, (
00978                                                     ftnlen)sizeof(integer));
00979                                             do_fio(&c__1, (char *)&c__1, (
00980                                                     ftnlen)sizeof(integer));
00981                                             do_fio(&c__1, (char *)&result[0], 
00982                                                     (ftnlen)sizeof(real));
00983                                             e_wsfe();
00984                                         }
00985                                         ++nfail;
00986                                         ++nrun;
00987                                     }
00988                                     if (result[5] >= *thresh) {
00989                                         if (nfail == 0 && nerrs == 0) {
00990                                             aladhd_(nout, path);
00991                                         }
00992                                         if (prefac) {
00993                                             io___76.ciunit = *nout;
00994                                             s_wsfe(&io___76);
00995                                             do_fio(&c__1, "SGBSVX", (ftnlen)6)
00996                                                     ;
00997                                             do_fio(&c__1, fact, (ftnlen)1);
00998                                             do_fio(&c__1, trans, (ftnlen)1);
00999                                             do_fio(&c__1, (char *)&n, (ftnlen)
01000                                                     sizeof(integer));
01001                                             do_fio(&c__1, (char *)&kl, (
01002                                                     ftnlen)sizeof(integer));
01003                                             do_fio(&c__1, (char *)&ku, (
01004                                                     ftnlen)sizeof(integer));
01005                                             do_fio(&c__1, equed, (ftnlen)1);
01006                                             do_fio(&c__1, (char *)&imat, (
01007                                                     ftnlen)sizeof(integer));
01008                                             do_fio(&c__1, (char *)&c__6, (
01009                                                     ftnlen)sizeof(integer));
01010                                             do_fio(&c__1, (char *)&result[5], 
01011                                                     (ftnlen)sizeof(real));
01012                                             e_wsfe();
01013                                         } else {
01014                                             io___77.ciunit = *nout;
01015                                             s_wsfe(&io___77);
01016                                             do_fio(&c__1, "SGBSVX", (ftnlen)6)
01017                                                     ;
01018                                             do_fio(&c__1, fact, (ftnlen)1);
01019                                             do_fio(&c__1, trans, (ftnlen)1);
01020                                             do_fio(&c__1, (char *)&n, (ftnlen)
01021                                                     sizeof(integer));
01022                                             do_fio(&c__1, (char *)&kl, (
01023                                                     ftnlen)sizeof(integer));
01024                                             do_fio(&c__1, (char *)&ku, (
01025                                                     ftnlen)sizeof(integer));
01026                                             do_fio(&c__1, (char *)&imat, (
01027                                                     ftnlen)sizeof(integer));
01028                                             do_fio(&c__1, (char *)&c__6, (
01029                                                     ftnlen)sizeof(integer));
01030                                             do_fio(&c__1, (char *)&result[5], 
01031                                                     (ftnlen)sizeof(real));
01032                                             e_wsfe();
01033                                         }
01034                                         ++nfail;
01035                                         ++nrun;
01036                                     }
01037                                     if (result[6] >= *thresh) {
01038                                         if (nfail == 0 && nerrs == 0) {
01039                                             aladhd_(nout, path);
01040                                         }
01041                                         if (prefac) {
01042                                             io___78.ciunit = *nout;
01043                                             s_wsfe(&io___78);
01044                                             do_fio(&c__1, "SGBSVX", (ftnlen)6)
01045                                                     ;
01046                                             do_fio(&c__1, fact, (ftnlen)1);
01047                                             do_fio(&c__1, trans, (ftnlen)1);
01048                                             do_fio(&c__1, (char *)&n, (ftnlen)
01049                                                     sizeof(integer));
01050                                             do_fio(&c__1, (char *)&kl, (
01051                                                     ftnlen)sizeof(integer));
01052                                             do_fio(&c__1, (char *)&ku, (
01053                                                     ftnlen)sizeof(integer));
01054                                             do_fio(&c__1, equed, (ftnlen)1);
01055                                             do_fio(&c__1, (char *)&imat, (
01056                                                     ftnlen)sizeof(integer));
01057                                             do_fio(&c__1, (char *)&c__7, (
01058                                                     ftnlen)sizeof(integer));
01059                                             do_fio(&c__1, (char *)&result[6], 
01060                                                     (ftnlen)sizeof(real));
01061                                             e_wsfe();
01062                                         } else {
01063                                             io___79.ciunit = *nout;
01064                                             s_wsfe(&io___79);
01065                                             do_fio(&c__1, "SGBSVX", (ftnlen)6)
01066                                                     ;
01067                                             do_fio(&c__1, fact, (ftnlen)1);
01068                                             do_fio(&c__1, trans, (ftnlen)1);
01069                                             do_fio(&c__1, (char *)&n, (ftnlen)
01070                                                     sizeof(integer));
01071                                             do_fio(&c__1, (char *)&kl, (
01072                                                     ftnlen)sizeof(integer));
01073                                             do_fio(&c__1, (char *)&ku, (
01074                                                     ftnlen)sizeof(integer));
01075                                             do_fio(&c__1, (char *)&imat, (
01076                                                     ftnlen)sizeof(integer));
01077                                             do_fio(&c__1, (char *)&c__7, (
01078                                                     ftnlen)sizeof(integer));
01079                                             do_fio(&c__1, (char *)&result[6], 
01080                                                     (ftnlen)sizeof(real));
01081                                             e_wsfe();
01082                                         }
01083                                         ++nfail;
01084                                         ++nrun;
01085                                     }
01086 
01087                                 }
01088 /* L90: */
01089                             }
01090 L100:
01091                             ;
01092                         }
01093 /* L110: */
01094                     }
01095 L120:
01096                     ;
01097                 }
01098 L130:
01099                 ;
01100             }
01101 /* L140: */
01102         }
01103 /* L150: */
01104     }
01105 
01106 /*     Print a summary of the results. */
01107 
01108     alasvm_(path, nout, &nfail, &nrun, &nerrs);
01109 
01110 
01111     return 0;
01112 
01113 /*     End of SDRVGB */
01114 
01115 } /* sdrvgb_ */

swiftnav
Author(s):
autogenerated on Sat Jun 8 2019 18:56:00