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

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