schkgb.c
Go to the documentation of this file.
00001 /* schkgb.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__2 = 2;
00034 static integer c__1 = 1;
00035 static integer c__0 = 0;
00036 static integer c_n1 = -1;
00037 static real c_b63 = 0.f;
00038 static real c_b64 = 1.f;
00039 static integer c__7 = 7;
00040 
00041 /* Subroutine */ int schkgb_(logical *dotype, integer *nm, integer *mval, 
00042         integer *nn, integer *nval, integer *nnb, integer *nbval, integer *
00043         nns, integer *nsval, real *thresh, logical *tsterr, real *a, integer *
00044         la, real *afac, integer *lafac, real *b, real *x, real *xact, real *
00045         work, real *rwork, integer *iwork, integer *nout)
00046 {
00047     /* Initialized data */
00048 
00049     static integer iseedy[4] = { 1988,1989,1990,1991 };
00050     static char transs[1*3] = "N" "T" "C";
00051 
00052     /* Format strings */
00053     static char fmt_9999[] = "(\002 *** In SCHKGB, LA=\002,i5,\002 is too sm"
00054             "all for M=\002,i5,\002, N=\002,i5,\002, KL=\002,i4,\002, KU=\002"
00055             ",i4,/\002 ==> Increase LA to at least \002,i5)";
00056     static char fmt_9998[] = "(\002 *** In SCHKGB, LAFAC=\002,i5,\002 is too"
00057             " small for M=\002,i5,\002, N=\002,i5,\002, KL=\002,i4,\002, KU"
00058             "=\002,i4,/\002 ==> Increase LAFAC to at least \002,i5)";
00059     static char fmt_9997[] = "(\002 M =\002,i5,\002, N =\002,i5,\002, KL="
00060             "\002,i5,\002, KU=\002,i5,\002, NB =\002,i4,\002, type \002,i1"
00061             ",\002, test(\002,i1,\002)=\002,g12.5)";
00062     static char fmt_9996[] = "(\002 TRANS='\002,a1,\002', N=\002,i5,\002, "
00063             "KL=\002,i5,\002, KU=\002,i5,\002, NRHS=\002,i3,\002, type \002,i"
00064             "1,\002, test(\002,i1,\002)=\002,g12.5)";
00065     static char fmt_9995[] = "(\002 NORM ='\002,a1,\002', N=\002,i5,\002, "
00066             "KL=\002,i5,\002, KU=\002,i5,\002,\002,10x,\002 type \002,i1,\002"
00067             ", test(\002,i1,\002)=\002,g12.5)";
00068 
00069     /* System generated locals */
00070     integer i__1, i__2, i__3, i__4, i__5, i__6, i__7, i__8, i__9, i__10, 
00071             i__11;
00072 
00073     /* Builtin functions */
00074     /* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);
00075     integer s_wsfe(cilist *), do_fio(integer *, char *, ftnlen), e_wsfe(void);
00076 
00077     /* Local variables */
00078     integer i__, j, k, m, n, i1, i2, nb, im, in, kl, ku, lda, ldb, inb, ikl, 
00079             nkl, iku, nku, ioff, mode, koff, imat, info;
00080     char path[3], dist[1];
00081     integer irhs, nrhs;
00082     char norm[1], type__[1];
00083     integer nrun;
00084     extern /* Subroutine */ int alahd_(integer *, char *);
00085     integer nfail, iseed[4];
00086     extern /* Subroutine */ int sgbt01_(integer *, integer *, integer *, 
00087             integer *, real *, integer *, real *, integer *, integer *, real *
00088 , real *), sgbt02_(char *, integer *, integer *, integer *, 
00089             integer *, integer *, real *, integer *, real *, integer *, real *
00090 , integer *, real *), sgbt05_(char *, integer *, integer *
00091 , integer *, integer *, real *, integer *, real *, integer *, 
00092             real *, integer *, real *, integer *, real *, real *, real *);
00093     real rcond;
00094     extern /* Subroutine */ int sget04_(integer *, integer *, real *, integer 
00095             *, real *, integer *, real *, real *);
00096     integer nimat, klval[4];
00097     extern doublereal sget06_(real *, real *);
00098     real anorm;
00099     integer itran, kuval[4];
00100     char trans[1];
00101     integer izero, nerrs;
00102     extern /* Subroutine */ int scopy_(integer *, real *, integer *, real *, 
00103             integer *);
00104     logical zerot;
00105     char xtype[1];
00106     extern /* Subroutine */ int slatb4_(char *, integer *, integer *, integer 
00107             *, char *, integer *, integer *, real *, integer *, real *, char *
00108 );
00109     integer ldafac;
00110     extern /* Subroutine */ int alaerh_(char *, char *, integer *, integer *, 
00111             char *, integer *, integer *, integer *, integer *, integer *, 
00112             integer *, integer *, integer *, integer *);
00113     extern doublereal slangb_(char *, integer *, integer *, integer *, real *, 
00114              integer *, real *);
00115     real rcondc;
00116     extern doublereal slange_(char *, integer *, integer *, real *, integer *, 
00117              real *);
00118     extern /* Subroutine */ int sgbcon_(char *, integer *, integer *, integer 
00119             *, real *, integer *, integer *, real *, real *, real *, integer *
00120 , integer *);
00121     real rcondi;
00122     extern /* Subroutine */ int alasum_(char *, integer *, integer *, integer 
00123             *, integer *);
00124     real cndnum, anormi, rcondo;
00125     extern /* Subroutine */ int serrge_(char *, integer *);
00126     real ainvnm;
00127     extern /* Subroutine */ int sgbrfs_(char *, integer *, integer *, integer 
00128             *, integer *, real *, integer *, real *, integer *, integer *, 
00129             real *, integer *, real *, integer *, real *, real *, real *, 
00130             integer *, integer *), sgbtrf_(integer *, integer *, 
00131             integer *, integer *, real *, integer *, integer *, integer *);
00132     logical trfcon;
00133     real anormo;
00134     extern /* Subroutine */ int slacpy_(char *, integer *, integer *, real *, 
00135             integer *, real *, integer *), slarhs_(char *, char *, 
00136             char *, char *, integer *, integer *, integer *, integer *, 
00137             integer *, real *, integer *, real *, integer *, real *, integer *
00138 , integer *, integer *), slaset_(
00139             char *, integer *, integer *, real *, real *, real *, integer *), xlaenv_(integer *, integer *), slatms_(integer *, 
00140             integer *, char *, integer *, char *, real *, integer *, real *, 
00141             real *, integer *, integer *, char *, real *, integer *, real *, 
00142             integer *), sgbtrs_(char *, integer *, 
00143             integer *, integer *, integer *, real *, integer *, integer *, 
00144             real *, integer *, integer *);
00145     real result[7];
00146 
00147     /* Fortran I/O blocks */
00148     static cilist io___25 = { 0, 0, 0, fmt_9999, 0 };
00149     static cilist io___26 = { 0, 0, 0, fmt_9998, 0 };
00150     static cilist io___45 = { 0, 0, 0, fmt_9997, 0 };
00151     static cilist io___59 = { 0, 0, 0, fmt_9996, 0 };
00152     static cilist io___61 = { 0, 0, 0, fmt_9995, 0 };
00153 
00154 
00155 
00156 /*  -- LAPACK test routine (version 3.1) -- */
00157 /*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
00158 /*     November 2006 */
00159 
00160 /*     .. Scalar Arguments .. */
00161 /*     .. */
00162 /*     .. Array Arguments .. */
00163 /*     .. */
00164 
00165 /*  Purpose */
00166 /*  ======= */
00167 
00168 /*  SCHKGB tests SGBTRF, -TRS, -RFS, and -CON */
00169 
00170 /*  Arguments */
00171 /*  ========= */
00172 
00173 /*  DOTYPE  (input) LOGICAL array, dimension (NTYPES) */
00174 /*          The matrix types to be used for testing.  Matrices of type j */
00175 /*          (for 1 <= j <= NTYPES) are used for testing if DOTYPE(j) = */
00176 /*          .TRUE.; if DOTYPE(j) = .FALSE., then type j is not used. */
00177 
00178 /*  NM      (input) INTEGER */
00179 /*          The number of values of M contained in the vector MVAL. */
00180 
00181 /*  MVAL    (input) INTEGER array, dimension (NM) */
00182 /*          The values of the matrix row dimension M. */
00183 
00184 /*  NN      (input) INTEGER */
00185 /*          The number of values of N contained in the vector NVAL. */
00186 
00187 /*  NVAL    (input) INTEGER array, dimension (NN) */
00188 /*          The values of the matrix column dimension N. */
00189 
00190 /*  NNB     (input) INTEGER */
00191 /*          The number of values of NB contained in the vector NBVAL. */
00192 
00193 /*  NBVAL   (input) INTEGER array, dimension (NNB) */
00194 /*          The values of the blocksize NB. */
00195 
00196 /*  NNS     (input) INTEGER */
00197 /*          The number of values of NRHS contained in the vector NSVAL. */
00198 
00199 /*  NSVAL   (input) INTEGER array, dimension (NNS) */
00200 /*          The values of the number of right hand sides NRHS. */
00201 
00202 /*  THRESH  (input) REAL */
00203 /*          The threshold value for the test ratios.  A result is */
00204 /*          included in the output file if RESULT >= THRESH.  To have */
00205 /*          every test ratio printed, use THRESH = 0. */
00206 
00207 /*  TSTERR  (input) LOGICAL */
00208 /*          Flag that indicates whether error exits are to be tested. */
00209 
00210 /*  A       (workspace) REAL array, dimension (LA) */
00211 
00212 /*  LA      (input) INTEGER */
00213 /*          The length of the array A.  LA >= (KLMAX+KUMAX+1)*NMAX */
00214 /*          where KLMAX is the largest entry in the local array KLVAL, */
00215 /*                KUMAX is the largest entry in the local array KUVAL and */
00216 /*                NMAX is the largest entry in the input array NVAL. */
00217 
00218 /*  AFAC    (workspace) REAL array, dimension (LAFAC) */
00219 
00220 /*  LAFAC   (input) INTEGER */
00221 /*          The length of the array AFAC. LAFAC >= (2*KLMAX+KUMAX+1)*NMAX */
00222 /*          where KLMAX is the largest entry in the local array KLVAL, */
00223 /*                KUMAX is the largest entry in the local array KUVAL and */
00224 /*                NMAX is the largest entry in the input array NVAL. */
00225 
00226 /*  B       (workspace) REAL array, dimension (NMAX*NSMAX) */
00227 /*          where NSMAX is the largest entry in NSVAL. */
00228 
00229 /*  X       (workspace) REAL array, dimension (NMAX*NSMAX) */
00230 
00231 /*  XACT    (workspace) REAL array, dimension (NMAX*NSMAX) */
00232 
00233 /*  WORK    (workspace) REAL array, dimension */
00234 /*                      (NMAX*max(3,NSMAX,NMAX)) */
00235 
00236 /*  RWORK   (workspace) REAL array, dimension */
00237 /*                      (max(NMAX,2*NSMAX)) */
00238 
00239 /*  IWORK   (workspace) INTEGER array, dimension (2*NMAX) */
00240 
00241 /*  NOUT    (input) INTEGER */
00242 /*          The unit number for output. */
00243 
00244 /*  ===================================================================== */
00245 
00246 /*     .. Parameters .. */
00247 /*     .. */
00248 /*     .. Local Scalars .. */
00249 /*     .. */
00250 /*     .. Local Arrays .. */
00251 /*     .. */
00252 /*     .. External Functions .. */
00253 /*     .. */
00254 /*     .. External Subroutines .. */
00255 /*     .. */
00256 /*     .. Intrinsic Functions .. */
00257 /*     .. */
00258 /*     .. Scalars in Common .. */
00259 /*     .. */
00260 /*     .. Common blocks .. */
00261 /*     .. */
00262 /*     .. Data statements .. */
00263     /* Parameter adjustments */
00264     --iwork;
00265     --rwork;
00266     --work;
00267     --xact;
00268     --x;
00269     --b;
00270     --afac;
00271     --a;
00272     --nsval;
00273     --nbval;
00274     --nval;
00275     --mval;
00276     --dotype;
00277 
00278     /* Function Body */
00279 /*     .. */
00280 /*     .. Executable Statements .. */
00281 
00282 /*     Initialize constants and the random number seed. */
00283 
00284     s_copy(path, "Single precision", (ftnlen)1, (ftnlen)16);
00285     s_copy(path + 1, "GB", (ftnlen)2, (ftnlen)2);
00286     nrun = 0;
00287     nfail = 0;
00288     nerrs = 0;
00289     for (i__ = 1; i__ <= 4; ++i__) {
00290         iseed[i__ - 1] = iseedy[i__ - 1];
00291 /* L10: */
00292     }
00293 
00294 /*     Test the error exits */
00295 
00296     if (*tsterr) {
00297         serrge_(path, nout);
00298     }
00299     infoc_1.infot = 0;
00300     xlaenv_(&c__2, &c__2);
00301 
00302 /*     Initialize the first value for the lower and upper bandwidths. */
00303 
00304     klval[0] = 0;
00305     kuval[0] = 0;
00306 
00307 /*     Do for each value of M in MVAL */
00308 
00309     i__1 = *nm;
00310     for (im = 1; im <= i__1; ++im) {
00311         m = mval[im];
00312 
00313 /*        Set values to use for the lower bandwidth. */
00314 
00315         klval[1] = m + (m + 1) / 4;
00316 
00317 /*        KLVAL( 2 ) = MAX( M-1, 0 ) */
00318 
00319         klval[2] = (m * 3 - 1) / 4;
00320         klval[3] = (m + 1) / 4;
00321 
00322 /*        Do for each value of N in NVAL */
00323 
00324         i__2 = *nn;
00325         for (in = 1; in <= i__2; ++in) {
00326             n = nval[in];
00327             *(unsigned char *)xtype = 'N';
00328 
00329 /*           Set values to use for the upper bandwidth. */
00330 
00331             kuval[1] = n + (n + 1) / 4;
00332 
00333 /*           KUVAL( 2 ) = MAX( N-1, 0 ) */
00334 
00335             kuval[2] = (n * 3 - 1) / 4;
00336             kuval[3] = (n + 1) / 4;
00337 
00338 /*           Set limits on the number of loop iterations. */
00339 
00340 /* Computing MIN */
00341             i__3 = m + 1;
00342             nkl = min(i__3,4);
00343             if (n == 0) {
00344                 nkl = 2;
00345             }
00346 /* Computing MIN */
00347             i__3 = n + 1;
00348             nku = min(i__3,4);
00349             if (m == 0) {
00350                 nku = 2;
00351             }
00352             nimat = 8;
00353             if (m <= 0 || n <= 0) {
00354                 nimat = 1;
00355             }
00356 
00357             i__3 = nkl;
00358             for (ikl = 1; ikl <= i__3; ++ikl) {
00359 
00360 /*              Do for KL = 0, (5*M+1)/4, (3M-1)/4, and (M+1)/4. This */
00361 /*              order makes it easier to skip redundant values for small */
00362 /*              values of M. */
00363 
00364                 kl = klval[ikl - 1];
00365                 i__4 = nku;
00366                 for (iku = 1; iku <= i__4; ++iku) {
00367 
00368 /*                 Do for KU = 0, (5*N+1)/4, (3N-1)/4, and (N+1)/4. This */
00369 /*                 order makes it easier to skip redundant values for */
00370 /*                 small values of N. */
00371 
00372                     ku = kuval[iku - 1];
00373 
00374 /*                 Check that A and AFAC are big enough to generate this */
00375 /*                 matrix. */
00376 
00377                     lda = kl + ku + 1;
00378                     ldafac = (kl << 1) + ku + 1;
00379                     if (lda * n > *la || ldafac * n > *lafac) {
00380                         if (nfail == 0 && nerrs == 0) {
00381                             alahd_(nout, path);
00382                         }
00383                         if (n * (kl + ku + 1) > *la) {
00384                             io___25.ciunit = *nout;
00385                             s_wsfe(&io___25);
00386                             do_fio(&c__1, (char *)&(*la), (ftnlen)sizeof(
00387                                     integer));
00388                             do_fio(&c__1, (char *)&m, (ftnlen)sizeof(integer))
00389                                     ;
00390                             do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer))
00391                                     ;
00392                             do_fio(&c__1, (char *)&kl, (ftnlen)sizeof(integer)
00393                                     );
00394                             do_fio(&c__1, (char *)&ku, (ftnlen)sizeof(integer)
00395                                     );
00396                             i__5 = n * (kl + ku + 1);
00397                             do_fio(&c__1, (char *)&i__5, (ftnlen)sizeof(
00398                                     integer));
00399                             e_wsfe();
00400                             ++nerrs;
00401                         }
00402                         if (n * ((kl << 1) + ku + 1) > *lafac) {
00403                             io___26.ciunit = *nout;
00404                             s_wsfe(&io___26);
00405                             do_fio(&c__1, (char *)&(*lafac), (ftnlen)sizeof(
00406                                     integer));
00407                             do_fio(&c__1, (char *)&m, (ftnlen)sizeof(integer))
00408                                     ;
00409                             do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer))
00410                                     ;
00411                             do_fio(&c__1, (char *)&kl, (ftnlen)sizeof(integer)
00412                                     );
00413                             do_fio(&c__1, (char *)&ku, (ftnlen)sizeof(integer)
00414                                     );
00415                             i__5 = n * ((kl << 1) + ku + 1);
00416                             do_fio(&c__1, (char *)&i__5, (ftnlen)sizeof(
00417                                     integer));
00418                             e_wsfe();
00419                             ++nerrs;
00420                         }
00421                         goto L130;
00422                     }
00423 
00424                     i__5 = nimat;
00425                     for (imat = 1; imat <= i__5; ++imat) {
00426 
00427 /*                    Do the tests only if DOTYPE( IMAT ) is true. */
00428 
00429                         if (! dotype[imat]) {
00430                             goto L120;
00431                         }
00432 
00433 /*                    Skip types 2, 3, or 4 if the matrix size is too */
00434 /*                    small. */
00435 
00436                         zerot = imat >= 2 && imat <= 4;
00437                         if (zerot && n < imat - 1) {
00438                             goto L120;
00439                         }
00440 
00441                         if (! zerot || ! dotype[1]) {
00442 
00443 /*                       Set up parameters with SLATB4 and generate a */
00444 /*                       test matrix with SLATMS. */
00445 
00446                             slatb4_(path, &imat, &m, &n, type__, &kl, &ku, &
00447                                     anorm, &mode, &cndnum, dist);
00448 
00449 /* Computing MAX */
00450                             i__6 = 1, i__7 = ku + 2 - n;
00451                             koff = max(i__6,i__7);
00452                             i__6 = koff - 1;
00453                             for (i__ = 1; i__ <= i__6; ++i__) {
00454                                 a[i__] = 0.f;
00455 /* L20: */
00456                             }
00457                             s_copy(srnamc_1.srnamt, "SLATMS", (ftnlen)32, (
00458                                     ftnlen)6);
00459                             slatms_(&m, &n, dist, iseed, type__, &rwork[1], &
00460                                     mode, &cndnum, &anorm, &kl, &ku, "Z", &a[
00461                                     koff], &lda, &work[1], &info);
00462 
00463 /*                       Check the error code from SLATMS. */
00464 
00465                             if (info != 0) {
00466                                 alaerh_(path, "SLATMS", &info, &c__0, " ", &m, 
00467                                          &n, &kl, &ku, &c_n1, &imat, &nfail, &
00468                                         nerrs, nout);
00469                                 goto L120;
00470                             }
00471                         } else if (izero > 0) {
00472 
00473 /*                       Use the same matrix for types 3 and 4 as for */
00474 /*                       type 2 by copying back the zeroed out column. */
00475 
00476                             i__6 = i2 - i1 + 1;
00477                             scopy_(&i__6, &b[1], &c__1, &a[ioff + i1], &c__1);
00478                         }
00479 
00480 /*                    For types 2, 3, and 4, zero one or more columns of */
00481 /*                    the matrix to test that INFO is returned correctly. */
00482 
00483                         izero = 0;
00484                         if (zerot) {
00485                             if (imat == 2) {
00486                                 izero = 1;
00487                             } else if (imat == 3) {
00488                                 izero = min(m,n);
00489                             } else {
00490                                 izero = min(m,n) / 2 + 1;
00491                             }
00492                             ioff = (izero - 1) * lda;
00493                             if (imat < 4) {
00494 
00495 /*                          Store the column to be zeroed out in B. */
00496 
00497 /* Computing MAX */
00498                                 i__6 = 1, i__7 = ku + 2 - izero;
00499                                 i1 = max(i__6,i__7);
00500 /* Computing MIN */
00501                                 i__6 = kl + ku + 1, i__7 = ku + 1 + (m - 
00502                                         izero);
00503                                 i2 = min(i__6,i__7);
00504                                 i__6 = i2 - i1 + 1;
00505                                 scopy_(&i__6, &a[ioff + i1], &c__1, &b[1], &
00506                                         c__1);
00507 
00508                                 i__6 = i2;
00509                                 for (i__ = i1; i__ <= i__6; ++i__) {
00510                                     a[ioff + i__] = 0.f;
00511 /* L30: */
00512                                 }
00513                             } else {
00514                                 i__6 = n;
00515                                 for (j = izero; j <= i__6; ++j) {
00516 /* Computing MAX */
00517                                     i__7 = 1, i__8 = ku + 2 - j;
00518 /* Computing MIN */
00519                                     i__10 = kl + ku + 1, i__11 = ku + 1 + (m 
00520                                             - j);
00521                                     i__9 = min(i__10,i__11);
00522                                     for (i__ = max(i__7,i__8); i__ <= i__9; 
00523                                             ++i__) {
00524                                         a[ioff + i__] = 0.f;
00525 /* L40: */
00526                                     }
00527                                     ioff += lda;
00528 /* L50: */
00529                                 }
00530                             }
00531                         }
00532 
00533 /*                    These lines, if used in place of the calls in the */
00534 /*                    loop over INB, cause the code to bomb on a Sun */
00535 /*                    SPARCstation. */
00536 
00537 /*                     ANORMO = SLANGB( 'O', N, KL, KU, A, LDA, RWORK ) */
00538 /*                     ANORMI = SLANGB( 'I', N, KL, KU, A, LDA, RWORK ) */
00539 
00540 /*                    Do for each blocksize in NBVAL */
00541 
00542                         i__6 = *nnb;
00543                         for (inb = 1; inb <= i__6; ++inb) {
00544                             nb = nbval[inb];
00545                             xlaenv_(&c__1, &nb);
00546 
00547 /*                       Compute the LU factorization of the band matrix. */
00548 
00549                             if (m > 0 && n > 0) {
00550                                 i__9 = kl + ku + 1;
00551                                 slacpy_("Full", &i__9, &n, &a[1], &lda, &afac[
00552                                         kl + 1], &ldafac);
00553                             }
00554                             s_copy(srnamc_1.srnamt, "SGBTRF", (ftnlen)32, (
00555                                     ftnlen)6);
00556                             sgbtrf_(&m, &n, &kl, &ku, &afac[1], &ldafac, &
00557                                     iwork[1], &info);
00558 
00559 /*                       Check error code from SGBTRF. */
00560 
00561                             if (info != izero) {
00562                                 alaerh_(path, "SGBTRF", &info, &izero, " ", &
00563                                         m, &n, &kl, &ku, &nb, &imat, &nfail, &
00564                                         nerrs, nout);
00565                             }
00566                             trfcon = FALSE_;
00567 
00568 /* +    TEST 1 */
00569 /*                       Reconstruct matrix from factors and compute */
00570 /*                       residual. */
00571 
00572                             sgbt01_(&m, &n, &kl, &ku, &a[1], &lda, &afac[1], &
00573                                     ldafac, &iwork[1], &work[1], result);
00574 
00575 /*                       Print information about the tests so far that */
00576 /*                       did not pass the threshold. */
00577 
00578                             if (result[0] >= *thresh) {
00579                                 if (nfail == 0 && nerrs == 0) {
00580                                     alahd_(nout, path);
00581                                 }
00582                                 io___45.ciunit = *nout;
00583                                 s_wsfe(&io___45);
00584                                 do_fio(&c__1, (char *)&m, (ftnlen)sizeof(
00585                                         integer));
00586                                 do_fio(&c__1, (char *)&n, (ftnlen)sizeof(
00587                                         integer));
00588                                 do_fio(&c__1, (char *)&kl, (ftnlen)sizeof(
00589                                         integer));
00590                                 do_fio(&c__1, (char *)&ku, (ftnlen)sizeof(
00591                                         integer));
00592                                 do_fio(&c__1, (char *)&nb, (ftnlen)sizeof(
00593                                         integer));
00594                                 do_fio(&c__1, (char *)&imat, (ftnlen)sizeof(
00595                                         integer));
00596                                 do_fio(&c__1, (char *)&c__1, (ftnlen)sizeof(
00597                                         integer));
00598                                 do_fio(&c__1, (char *)&result[0], (ftnlen)
00599                                         sizeof(real));
00600                                 e_wsfe();
00601                                 ++nfail;
00602                             }
00603                             ++nrun;
00604 
00605 /*                       Skip the remaining tests if this is not the */
00606 /*                       first block size or if M .ne. N. */
00607 
00608                             if (inb > 1 || m != n) {
00609                                 goto L110;
00610                             }
00611 
00612                             anormo = slangb_("O", &n, &kl, &ku, &a[1], &lda, &
00613                                     rwork[1]);
00614                             anormi = slangb_("I", &n, &kl, &ku, &a[1], &lda, &
00615                                     rwork[1]);
00616 
00617                             if (info == 0) {
00618 
00619 /*                          Form the inverse of A so we can get a good */
00620 /*                          estimate of CNDNUM = norm(A) * norm(inv(A)). */
00621 
00622                                 ldb = max(1,n);
00623                                 slaset_("Full", &n, &n, &c_b63, &c_b64, &work[
00624                                         1], &ldb);
00625                                 s_copy(srnamc_1.srnamt, "SGBTRS", (ftnlen)32, 
00626                                         (ftnlen)6);
00627                                 sgbtrs_("No transpose", &n, &kl, &ku, &n, &
00628                                         afac[1], &ldafac, &iwork[1], &work[1], 
00629                                          &ldb, &info);
00630 
00631 /*                          Compute the 1-norm condition number of A. */
00632 
00633                                 ainvnm = slange_("O", &n, &n, &work[1], &ldb, 
00634                                         &rwork[1]);
00635                                 if (anormo <= 0.f || ainvnm <= 0.f) {
00636                                     rcondo = 1.f;
00637                                 } else {
00638                                     rcondo = 1.f / anormo / ainvnm;
00639                                 }
00640 
00641 /*                          Compute the infinity-norm condition number of */
00642 /*                          A. */
00643 
00644                                 ainvnm = slange_("I", &n, &n, &work[1], &ldb, 
00645                                         &rwork[1]);
00646                                 if (anormi <= 0.f || ainvnm <= 0.f) {
00647                                     rcondi = 1.f;
00648                                 } else {
00649                                     rcondi = 1.f / anormi / ainvnm;
00650                                 }
00651                             } else {
00652 
00653 /*                          Do only the condition estimate if INFO.NE.0. */
00654 
00655                                 trfcon = TRUE_;
00656                                 rcondo = 0.f;
00657                                 rcondi = 0.f;
00658                             }
00659 
00660 /*                       Skip the solve tests if the matrix is singular. */
00661 
00662                             if (trfcon) {
00663                                 goto L90;
00664                             }
00665 
00666                             i__9 = *nns;
00667                             for (irhs = 1; irhs <= i__9; ++irhs) {
00668                                 nrhs = nsval[irhs];
00669                                 *(unsigned char *)xtype = 'N';
00670 
00671                                 for (itran = 1; itran <= 3; ++itran) {
00672                                     *(unsigned char *)trans = *(unsigned char 
00673                                             *)&transs[itran - 1];
00674                                     if (itran == 1) {
00675                                         rcondc = rcondo;
00676                                         *(unsigned char *)norm = 'O';
00677                                     } else {
00678                                         rcondc = rcondi;
00679                                         *(unsigned char *)norm = 'I';
00680                                     }
00681 
00682 /* +    TEST 2: */
00683 /*                             Solve and compute residual for A * X = B. */
00684 
00685                                     s_copy(srnamc_1.srnamt, "SLARHS", (ftnlen)
00686                                             32, (ftnlen)6);
00687                                     slarhs_(path, xtype, " ", trans, &n, &n, &
00688                                             kl, &ku, &nrhs, &a[1], &lda, &
00689                                             xact[1], &ldb, &b[1], &ldb, iseed, 
00690                                              &info);
00691                                     *(unsigned char *)xtype = 'C';
00692                                     slacpy_("Full", &n, &nrhs, &b[1], &ldb, &
00693                                             x[1], &ldb);
00694 
00695                                     s_copy(srnamc_1.srnamt, "SGBTRS", (ftnlen)
00696                                             32, (ftnlen)6);
00697                                     sgbtrs_(trans, &n, &kl, &ku, &nrhs, &afac[
00698                                             1], &ldafac, &iwork[1], &x[1], &
00699                                             ldb, &info);
00700 
00701 /*                             Check error code from SGBTRS. */
00702 
00703                                     if (info != 0) {
00704                                         alaerh_(path, "SGBTRS", &info, &c__0, 
00705                                                 trans, &n, &n, &kl, &ku, &
00706                                                 c_n1, &imat, &nfail, &nerrs, 
00707                                                 nout);
00708                                     }
00709 
00710                                     slacpy_("Full", &n, &nrhs, &b[1], &ldb, &
00711                                             work[1], &ldb);
00712                                     sgbt02_(trans, &m, &n, &kl, &ku, &nrhs, &
00713                                             a[1], &lda, &x[1], &ldb, &work[1], 
00714                                              &ldb, &result[1]);
00715 
00716 /* +    TEST 3: */
00717 /*                             Check solution from generated exact */
00718 /*                             solution. */
00719 
00720                                     sget04_(&n, &nrhs, &x[1], &ldb, &xact[1], 
00721                                             &ldb, &rcondc, &result[2]);
00722 
00723 /* +    TESTS 4, 5, 6: */
00724 /*                             Use iterative refinement to improve the */
00725 /*                             solution. */
00726 
00727                                     s_copy(srnamc_1.srnamt, "SGBRFS", (ftnlen)
00728                                             32, (ftnlen)6);
00729                                     sgbrfs_(trans, &n, &kl, &ku, &nrhs, &a[1], 
00730                                              &lda, &afac[1], &ldafac, &iwork[
00731                                             1], &b[1], &ldb, &x[1], &ldb, &
00732                                             rwork[1], &rwork[nrhs + 1], &work[
00733                                             1], &iwork[n + 1], &info);
00734 
00735 /*                             Check error code from SGBRFS. */
00736 
00737                                     if (info != 0) {
00738                                         alaerh_(path, "SGBRFS", &info, &c__0, 
00739                                                 trans, &n, &n, &kl, &ku, &
00740                                                 nrhs, &imat, &nfail, &nerrs, 
00741                                                 nout);
00742                                     }
00743 
00744                                     sget04_(&n, &nrhs, &x[1], &ldb, &xact[1], 
00745                                             &ldb, &rcondc, &result[3]);
00746                                     sgbt05_(trans, &n, &kl, &ku, &nrhs, &a[1], 
00747                                              &lda, &b[1], &ldb, &x[1], &ldb, &
00748                                             xact[1], &ldb, &rwork[1], &rwork[
00749                                             nrhs + 1], &result[4]);
00750                                     for (k = 2; k <= 6; ++k) {
00751                                         if (result[k - 1] >= *thresh) {
00752                                             if (nfail == 0 && nerrs == 0) {
00753                           alahd_(nout, path);
00754                                             }
00755                                             io___59.ciunit = *nout;
00756                                             s_wsfe(&io___59);
00757                                             do_fio(&c__1, trans, (ftnlen)1);
00758                                             do_fio(&c__1, (char *)&n, (ftnlen)
00759                                                     sizeof(integer));
00760                                             do_fio(&c__1, (char *)&kl, (
00761                                                     ftnlen)sizeof(integer));
00762                                             do_fio(&c__1, (char *)&ku, (
00763                                                     ftnlen)sizeof(integer));
00764                                             do_fio(&c__1, (char *)&nrhs, (
00765                                                     ftnlen)sizeof(integer));
00766                                             do_fio(&c__1, (char *)&imat, (
00767                                                     ftnlen)sizeof(integer));
00768                                             do_fio(&c__1, (char *)&k, (ftnlen)
00769                                                     sizeof(integer));
00770                                             do_fio(&c__1, (char *)&result[k - 
00771                                                     1], (ftnlen)sizeof(real));
00772                                             e_wsfe();
00773                                             ++nfail;
00774                                         }
00775 /* L60: */
00776                                     }
00777                                     nrun += 5;
00778 /* L70: */
00779                                 }
00780 /* L80: */
00781                             }
00782 
00783 /* +    TEST 7: */
00784 /*                          Get an estimate of RCOND = 1/CNDNUM. */
00785 
00786 L90:
00787                             for (itran = 1; itran <= 2; ++itran) {
00788                                 if (itran == 1) {
00789                                     anorm = anormo;
00790                                     rcondc = rcondo;
00791                                     *(unsigned char *)norm = 'O';
00792                                 } else {
00793                                     anorm = anormi;
00794                                     rcondc = rcondi;
00795                                     *(unsigned char *)norm = 'I';
00796                                 }
00797                                 s_copy(srnamc_1.srnamt, "SGBCON", (ftnlen)32, 
00798                                         (ftnlen)6);
00799                                 sgbcon_(norm, &n, &kl, &ku, &afac[1], &ldafac, 
00800                                          &iwork[1], &anorm, &rcond, &work[1], 
00801                                         &iwork[n + 1], &info);
00802 
00803 /*                             Check error code from SGBCON. */
00804 
00805                                 if (info != 0) {
00806                                     alaerh_(path, "SGBCON", &info, &c__0, 
00807                                             norm, &n, &n, &kl, &ku, &c_n1, &
00808                                             imat, &nfail, &nerrs, nout);
00809                                 }
00810 
00811                                 result[6] = sget06_(&rcond, &rcondc);
00812 
00813 /*                          Print information about the tests that did */
00814 /*                          not pass the threshold. */
00815 
00816                                 if (result[6] >= *thresh) {
00817                                     if (nfail == 0 && nerrs == 0) {
00818                                         alahd_(nout, path);
00819                                     }
00820                                     io___61.ciunit = *nout;
00821                                     s_wsfe(&io___61);
00822                                     do_fio(&c__1, norm, (ftnlen)1);
00823                                     do_fio(&c__1, (char *)&n, (ftnlen)sizeof(
00824                                             integer));
00825                                     do_fio(&c__1, (char *)&kl, (ftnlen)sizeof(
00826                                             integer));
00827                                     do_fio(&c__1, (char *)&ku, (ftnlen)sizeof(
00828                                             integer));
00829                                     do_fio(&c__1, (char *)&imat, (ftnlen)
00830                                             sizeof(integer));
00831                                     do_fio(&c__1, (char *)&c__7, (ftnlen)
00832                                             sizeof(integer));
00833                                     do_fio(&c__1, (char *)&result[6], (ftnlen)
00834                                             sizeof(real));
00835                                     e_wsfe();
00836                                     ++nfail;
00837                                 }
00838                                 ++nrun;
00839 /* L100: */
00840                             }
00841 
00842 L110:
00843                             ;
00844                         }
00845 L120:
00846                         ;
00847                     }
00848 L130:
00849                     ;
00850                 }
00851 /* L140: */
00852             }
00853 /* L150: */
00854         }
00855 /* L160: */
00856     }
00857 
00858 /*     Print a summary of the results. */
00859 
00860     alasum_(path, nout, &nfail, &nrun, &nerrs);
00861 
00862 
00863     return 0;
00864 
00865 /*     End of SCHKGB */
00866 
00867 } /* schkgb_ */

swiftnav
Author(s):
autogenerated on Sat Jun 8 2019 18:55:58