zchkgb.c
Go to the documentation of this file.
00001 /* zchkgb.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__0 = 0;
00035 static integer c_n1 = -1;
00036 static doublecomplex c_b61 = {0.,0.};
00037 static doublecomplex c_b62 = {1.,0.};
00038 static integer c__7 = 7;
00039 
00040 /* Subroutine */ int zchkgb_(logical *dotype, integer *nm, integer *mval, 
00041         integer *nn, integer *nval, integer *nnb, integer *nbval, integer *
00042         nns, integer *nsval, doublereal *thresh, logical *tsterr, 
00043         doublecomplex *a, integer *la, doublecomplex *afac, integer *lafac, 
00044         doublecomplex *b, doublecomplex *x, doublecomplex *xact, 
00045         doublecomplex *work, doublereal *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 ZCHKGB, 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 ZCHKGB, 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 doublereal dget06_(doublereal *, doublereal *);
00087     doublereal rcond;
00088     extern /* Subroutine */ int zgbt01_(integer *, integer *, integer *, 
00089             integer *, doublecomplex *, integer *, doublecomplex *, integer *, 
00090              integer *, doublecomplex *, doublereal *);
00091     integer nimat, klval[4];
00092     extern /* Subroutine */ int zgbt02_(char *, integer *, integer *, integer 
00093             *, integer *, integer *, doublecomplex *, integer *, 
00094             doublecomplex *, integer *, doublecomplex *, integer *, 
00095             doublereal *), zgbt05_(char *, integer *, integer *, 
00096             integer *, integer *, doublecomplex *, integer *, doublecomplex *, 
00097              integer *, doublecomplex *, integer *, doublecomplex *, integer *
00098 , doublereal *, doublereal *, doublereal *);
00099     doublereal anorm;
00100     integer itran;
00101     extern /* Subroutine */ int zget04_(integer *, integer *, doublecomplex *, 
00102              integer *, doublecomplex *, integer *, doublereal *, doublereal *
00103 );
00104     integer kuval[4];
00105     char trans[1];
00106     integer izero, nerrs;
00107     logical zerot;
00108     extern /* Subroutine */ int zcopy_(integer *, doublecomplex *, integer *, 
00109             doublecomplex *, integer *);
00110     char xtype[1];
00111     extern /* Subroutine */ int zlatb4_(char *, integer *, integer *, integer 
00112             *, char *, integer *, integer *, doublereal *, integer *, 
00113             doublereal *, char *);
00114     integer ldafac;
00115     extern /* Subroutine */ int alaerh_(char *, char *, integer *, integer *, 
00116             char *, integer *, integer *, integer *, integer *, integer *, 
00117             integer *, integer *, integer *, integer *);
00118     doublereal rcondc;
00119     extern doublereal zlangb_(char *, integer *, integer *, integer *, 
00120             doublecomplex *, integer *, doublereal *);
00121     doublereal rcondi;
00122     extern doublereal zlange_(char *, integer *, integer *, doublecomplex *, 
00123             integer *, doublereal *);
00124     extern /* Subroutine */ int alasum_(char *, integer *, integer *, integer 
00125             *, integer *);
00126     doublereal cndnum, anormi, rcondo;
00127     extern /* Subroutine */ int zgbcon_(char *, integer *, integer *, integer 
00128             *, doublecomplex *, integer *, integer *, doublereal *, 
00129             doublereal *, doublecomplex *, doublereal *, integer *);
00130     doublereal ainvnm;
00131     logical trfcon;
00132     doublereal anormo;
00133     extern /* Subroutine */ int xlaenv_(integer *, integer *), zerrge_(char *, 
00134              integer *), zgbrfs_(char *, integer *, integer *, 
00135             integer *, integer *, doublecomplex *, integer *, doublecomplex *, 
00136              integer *, integer *, doublecomplex *, integer *, doublecomplex *
00137 , integer *, doublereal *, doublereal *, doublecomplex *, 
00138             doublereal *, integer *), zgbtrf_(integer *, integer *, 
00139             integer *, integer *, doublecomplex *, integer *, integer *, 
00140             integer *), zlacpy_(char *, integer *, integer *, doublecomplex *, 
00141              integer *, doublecomplex *, integer *), zlarhs_(char *, 
00142             char *, char *, char *, integer *, integer *, integer *, integer *
00143 , integer *, doublecomplex *, integer *, doublecomplex *, integer 
00144             *, doublecomplex *, integer *, integer *, integer *), zlaset_(char *, integer *, integer *, 
00145             doublecomplex *, doublecomplex *, doublecomplex *, integer *), zgbtrs_(char *, integer *, integer *, integer *, integer 
00146             *, doublecomplex *, integer *, integer *, doublecomplex *, 
00147             integer *, integer *), zlatms_(integer *, integer *, char 
00148             *, integer *, char *, doublereal *, integer *, doublereal *, 
00149             doublereal *, integer *, integer *, char *, doublecomplex *, 
00150             integer *, doublecomplex *, integer *);
00151     doublereal result[7];
00152 
00153     /* Fortran I/O blocks */
00154     static cilist io___25 = { 0, 0, 0, fmt_9999, 0 };
00155     static cilist io___26 = { 0, 0, 0, fmt_9998, 0 };
00156     static cilist io___45 = { 0, 0, 0, fmt_9997, 0 };
00157     static cilist io___59 = { 0, 0, 0, fmt_9996, 0 };
00158     static cilist io___61 = { 0, 0, 0, fmt_9995, 0 };
00159 
00160 
00161 
00162 /*  -- LAPACK test routine (version 3.1) -- */
00163 /*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
00164 /*     November 2006 */
00165 
00166 /*     .. Scalar Arguments .. */
00167 /*     .. */
00168 /*     .. Array Arguments .. */
00169 /*     .. */
00170 
00171 /*  Purpose */
00172 /*  ======= */
00173 
00174 /*  ZCHKGB tests ZGBTRF, -TRS, -RFS, and -CON */
00175 
00176 /*  Arguments */
00177 /*  ========= */
00178 
00179 /*  DOTYPE  (input) LOGICAL array, dimension (NTYPES) */
00180 /*          The matrix types to be used for testing.  Matrices of type j */
00181 /*          (for 1 <= j <= NTYPES) are used for testing if DOTYPE(j) = */
00182 /*          .TRUE.; if DOTYPE(j) = .FALSE., then type j is not used. */
00183 
00184 /*  NM      (input) INTEGER */
00185 /*          The number of values of M contained in the vector MVAL. */
00186 
00187 /*  MVAL    (input) INTEGER array, dimension (NM) */
00188 /*          The values of the matrix row dimension M. */
00189 
00190 /*  NN      (input) INTEGER */
00191 /*          The number of values of N contained in the vector NVAL. */
00192 
00193 /*  NVAL    (input) INTEGER array, dimension (NN) */
00194 /*          The values of the matrix column dimension N. */
00195 
00196 /*  NNB     (input) INTEGER */
00197 /*          The number of values of NB contained in the vector NBVAL. */
00198 
00199 /*  NBVAL   (input) INTEGER array, dimension (NBVAL) */
00200 /*          The values of the blocksize NB. */
00201 
00202 /*  NNS     (input) INTEGER */
00203 /*          The number of values of NRHS contained in the vector NSVAL. */
00204 
00205 /*  NSVAL   (input) INTEGER array, dimension (NNS) */
00206 /*          The values of the number of right hand sides NRHS. */
00207 
00208 /*  THRESH  (input) DOUBLE PRECISION */
00209 /*          The threshold value for the test ratios.  A result is */
00210 /*          included in the output file if RESULT >= THRESH.  To have */
00211 /*          every test ratio printed, use THRESH = 0. */
00212 
00213 /*  TSTERR  (input) LOGICAL */
00214 /*          Flag that indicates whether error exits are to be tested. */
00215 
00216 /*  A       (workspace) COMPLEX*16 array, dimension (LA) */
00217 
00218 /*  LA      (input) INTEGER */
00219 /*          The length of the array A.  LA >= (KLMAX+KUMAX+1)*NMAX */
00220 /*          where KLMAX is the largest entry in the local array KLVAL, */
00221 /*                KUMAX is the largest entry in the local array KUVAL and */
00222 /*                NMAX is the largest entry in the input array NVAL. */
00223 
00224 /*  AFAC    (workspace) COMPLEX*16 array, dimension (LAFAC) */
00225 
00226 /*  LAFAC   (input) INTEGER */
00227 /*          The length of the array AFAC. LAFAC >= (2*KLMAX+KUMAX+1)*NMAX */
00228 /*          where KLMAX is the largest entry in the local array KLVAL, */
00229 /*                KUMAX is the largest entry in the local array KUVAL and */
00230 /*                NMAX is the largest entry in the input array NVAL. */
00231 
00232 /*  B       (workspace) COMPLEX*16 array, dimension (NMAX*NSMAX) */
00233 
00234 /*  X       (workspace) COMPLEX*16 array, dimension (NMAX*NSMAX) */
00235 
00236 /*  XACT    (workspace) COMPLEX*16 array, dimension (NMAX*NSMAX) */
00237 
00238 /*  WORK    (workspace) COMPLEX*16 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 (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, "Zomplex precision", (ftnlen)1, (ftnlen)17);
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         zerrge_(path, nout);
00303     }
00304     infoc_1.infot = 0;
00305 
00306 /*     Initialize the first value for the lower and upper bandwidths. */
00307 
00308     klval[0] = 0;
00309     kuval[0] = 0;
00310 
00311 /*     Do for each value of M in MVAL */
00312 
00313     i__1 = *nm;
00314     for (im = 1; im <= i__1; ++im) {
00315         m = mval[im];
00316 
00317 /*        Set values to use for the lower bandwidth. */
00318 
00319         klval[1] = m + (m + 1) / 4;
00320 
00321 /*        KLVAL( 2 ) = MAX( M-1, 0 ) */
00322 
00323         klval[2] = (m * 3 - 1) / 4;
00324         klval[3] = (m + 1) / 4;
00325 
00326 /*        Do for each value of N in NVAL */
00327 
00328         i__2 = *nn;
00329         for (in = 1; in <= i__2; ++in) {
00330             n = nval[in];
00331             *(unsigned char *)xtype = 'N';
00332 
00333 /*           Set values to use for the upper bandwidth. */
00334 
00335             kuval[1] = n + (n + 1) / 4;
00336 
00337 /*           KUVAL( 2 ) = MAX( N-1, 0 ) */
00338 
00339             kuval[2] = (n * 3 - 1) / 4;
00340             kuval[3] = (n + 1) / 4;
00341 
00342 /*           Set limits on the number of loop iterations. */
00343 
00344 /* Computing MIN */
00345             i__3 = m + 1;
00346             nkl = min(i__3,4);
00347             if (n == 0) {
00348                 nkl = 2;
00349             }
00350 /* Computing MIN */
00351             i__3 = n + 1;
00352             nku = min(i__3,4);
00353             if (m == 0) {
00354                 nku = 2;
00355             }
00356             nimat = 8;
00357             if (m <= 0 || n <= 0) {
00358                 nimat = 1;
00359             }
00360 
00361             i__3 = nkl;
00362             for (ikl = 1; ikl <= i__3; ++ikl) {
00363 
00364 /*              Do for KL = 0, (5*M+1)/4, (3M-1)/4, and (M+1)/4. This */
00365 /*              order makes it easier to skip redundant values for small */
00366 /*              values of M. */
00367 
00368                 kl = klval[ikl - 1];
00369                 i__4 = nku;
00370                 for (iku = 1; iku <= i__4; ++iku) {
00371 
00372 /*                 Do for KU = 0, (5*N+1)/4, (3N-1)/4, and (N+1)/4. This */
00373 /*                 order makes it easier to skip redundant values for */
00374 /*                 small values of N. */
00375 
00376                     ku = kuval[iku - 1];
00377 
00378 /*                 Check that A and AFAC are big enough to generate this */
00379 /*                 matrix. */
00380 
00381                     lda = kl + ku + 1;
00382                     ldafac = (kl << 1) + ku + 1;
00383                     if (lda * n > *la || ldafac * n > *lafac) {
00384                         if (nfail == 0 && nerrs == 0) {
00385                             alahd_(nout, path);
00386                         }
00387                         if (n * (kl + ku + 1) > *la) {
00388                             io___25.ciunit = *nout;
00389                             s_wsfe(&io___25);
00390                             do_fio(&c__1, (char *)&(*la), (ftnlen)sizeof(
00391                                     integer));
00392                             do_fio(&c__1, (char *)&m, (ftnlen)sizeof(integer))
00393                                     ;
00394                             do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer))
00395                                     ;
00396                             do_fio(&c__1, (char *)&kl, (ftnlen)sizeof(integer)
00397                                     );
00398                             do_fio(&c__1, (char *)&ku, (ftnlen)sizeof(integer)
00399                                     );
00400                             i__5 = n * (kl + ku + 1);
00401                             do_fio(&c__1, (char *)&i__5, (ftnlen)sizeof(
00402                                     integer));
00403                             e_wsfe();
00404                             ++nerrs;
00405                         }
00406                         if (n * ((kl << 1) + ku + 1) > *lafac) {
00407                             io___26.ciunit = *nout;
00408                             s_wsfe(&io___26);
00409                             do_fio(&c__1, (char *)&(*lafac), (ftnlen)sizeof(
00410                                     integer));
00411                             do_fio(&c__1, (char *)&m, (ftnlen)sizeof(integer))
00412                                     ;
00413                             do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer))
00414                                     ;
00415                             do_fio(&c__1, (char *)&kl, (ftnlen)sizeof(integer)
00416                                     );
00417                             do_fio(&c__1, (char *)&ku, (ftnlen)sizeof(integer)
00418                                     );
00419                             i__5 = n * ((kl << 1) + ku + 1);
00420                             do_fio(&c__1, (char *)&i__5, (ftnlen)sizeof(
00421                                     integer));
00422                             e_wsfe();
00423                             ++nerrs;
00424                         }
00425                         goto L130;
00426                     }
00427 
00428                     i__5 = nimat;
00429                     for (imat = 1; imat <= i__5; ++imat) {
00430 
00431 /*                    Do the tests only if DOTYPE( IMAT ) is true. */
00432 
00433                         if (! dotype[imat]) {
00434                             goto L120;
00435                         }
00436 
00437 /*                    Skip types 2, 3, or 4 if the matrix size is too */
00438 /*                    small. */
00439 
00440                         zerot = imat >= 2 && imat <= 4;
00441                         if (zerot && n < imat - 1) {
00442                             goto L120;
00443                         }
00444 
00445                         if (! zerot || ! dotype[1]) {
00446 
00447 /*                       Set up parameters with ZLATB4 and generate a */
00448 /*                       test matrix with ZLATMS. */
00449 
00450                             zlatb4_(path, &imat, &m, &n, type__, &kl, &ku, &
00451                                     anorm, &mode, &cndnum, dist);
00452 
00453 /* Computing MAX */
00454                             i__6 = 1, i__7 = ku + 2 - n;
00455                             koff = max(i__6,i__7);
00456                             i__6 = koff - 1;
00457                             for (i__ = 1; i__ <= i__6; ++i__) {
00458                                 i__7 = i__;
00459                                 a[i__7].r = 0., a[i__7].i = 0.;
00460 /* L20: */
00461                             }
00462                             s_copy(srnamc_1.srnamt, "ZLATMS", (ftnlen)32, (
00463                                     ftnlen)6);
00464                             zlatms_(&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 ZLATMS. */
00469 
00470                             if (info != 0) {
00471                                 alaerh_(path, "ZLATMS", &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                             zcopy_(&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                                 zcopy_(&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                                     i__7 = ioff + i__;
00516                                     a[i__7].r = 0., a[i__7].i = 0.;
00517 /* L30: */
00518                                 }
00519                             } else {
00520                                 i__6 = n;
00521                                 for (j = izero; j <= i__6; ++j) {
00522 /* Computing MAX */
00523                                     i__7 = 1, i__8 = ku + 2 - j;
00524 /* Computing MIN */
00525                                     i__10 = kl + ku + 1, i__11 = ku + 1 + (m 
00526                                             - j);
00527                                     i__9 = min(i__10,i__11);
00528                                     for (i__ = max(i__7,i__8); i__ <= i__9; 
00529                                             ++i__) {
00530                                         i__7 = ioff + i__;
00531                                         a[i__7].r = 0., a[i__7].i = 0.;
00532 /* L40: */
00533                                     }
00534                                     ioff += lda;
00535 /* L50: */
00536                                 }
00537                             }
00538                         }
00539 
00540 /*                    These lines, if used in place of the calls in the */
00541 /*                    loop over INB, cause the code to bomb on a Sun */
00542 /*                    SPARCstation. */
00543 
00544 /*                     ANORMO = ZLANGB( 'O', N, KL, KU, A, LDA, RWORK ) */
00545 /*                     ANORMI = ZLANGB( 'I', N, KL, KU, A, LDA, RWORK ) */
00546 
00547 /*                    Do for each blocksize in NBVAL */
00548 
00549                         i__6 = *nnb;
00550                         for (inb = 1; inb <= i__6; ++inb) {
00551                             nb = nbval[inb];
00552                             xlaenv_(&c__1, &nb);
00553 
00554 /*                       Compute the LU factorization of the band matrix. */
00555 
00556                             if (m > 0 && n > 0) {
00557                                 i__9 = kl + ku + 1;
00558                                 zlacpy_("Full", &i__9, &n, &a[1], &lda, &afac[
00559                                         kl + 1], &ldafac);
00560                             }
00561                             s_copy(srnamc_1.srnamt, "ZGBTRF", (ftnlen)32, (
00562                                     ftnlen)6);
00563                             zgbtrf_(&m, &n, &kl, &ku, &afac[1], &ldafac, &
00564                                     iwork[1], &info);
00565 
00566 /*                       Check error code from ZGBTRF. */
00567 
00568                             if (info != izero) {
00569                                 alaerh_(path, "ZGBTRF", &info, &izero, " ", &
00570                                         m, &n, &kl, &ku, &nb, &imat, &nfail, &
00571                                         nerrs, nout);
00572                             }
00573                             trfcon = FALSE_;
00574 
00575 /* +    TEST 1 */
00576 /*                       Reconstruct matrix from factors and compute */
00577 /*                       residual. */
00578 
00579                             zgbt01_(&m, &n, &kl, &ku, &a[1], &lda, &afac[1], &
00580                                     ldafac, &iwork[1], &work[1], result);
00581 
00582 /*                       Print information about the tests so far that */
00583 /*                       did not pass the threshold. */
00584 
00585                             if (result[0] >= *thresh) {
00586                                 if (nfail == 0 && nerrs == 0) {
00587                                     alahd_(nout, path);
00588                                 }
00589                                 io___45.ciunit = *nout;
00590                                 s_wsfe(&io___45);
00591                                 do_fio(&c__1, (char *)&m, (ftnlen)sizeof(
00592                                         integer));
00593                                 do_fio(&c__1, (char *)&n, (ftnlen)sizeof(
00594                                         integer));
00595                                 do_fio(&c__1, (char *)&kl, (ftnlen)sizeof(
00596                                         integer));
00597                                 do_fio(&c__1, (char *)&ku, (ftnlen)sizeof(
00598                                         integer));
00599                                 do_fio(&c__1, (char *)&nb, (ftnlen)sizeof(
00600                                         integer));
00601                                 do_fio(&c__1, (char *)&imat, (ftnlen)sizeof(
00602                                         integer));
00603                                 do_fio(&c__1, (char *)&c__1, (ftnlen)sizeof(
00604                                         integer));
00605                                 do_fio(&c__1, (char *)&result[0], (ftnlen)
00606                                         sizeof(doublereal));
00607                                 e_wsfe();
00608                                 ++nfail;
00609                             }
00610                             ++nrun;
00611 
00612 /*                       Skip the remaining tests if this is not the */
00613 /*                       first block size or if M .ne. N. */
00614 
00615                             if (inb > 1 || m != n) {
00616                                 goto L110;
00617                             }
00618 
00619                             anormo = zlangb_("O", &n, &kl, &ku, &a[1], &lda, &
00620                                     rwork[1]);
00621                             anormi = zlangb_("I", &n, &kl, &ku, &a[1], &lda, &
00622                                     rwork[1]);
00623 
00624                             if (info == 0) {
00625 
00626 /*                          Form the inverse of A so we can get a good */
00627 /*                          estimate of CNDNUM = norm(A) * norm(inv(A)). */
00628 
00629                                 ldb = max(1,n);
00630                                 zlaset_("Full", &n, &n, &c_b61, &c_b62, &work[
00631                                         1], &ldb);
00632                                 s_copy(srnamc_1.srnamt, "ZGBTRS", (ftnlen)32, 
00633                                         (ftnlen)6);
00634                                 zgbtrs_("No transpose", &n, &kl, &ku, &n, &
00635                                         afac[1], &ldafac, &iwork[1], &work[1], 
00636                                          &ldb, &info);
00637 
00638 /*                          Compute the 1-norm condition number of A. */
00639 
00640                                 ainvnm = zlange_("O", &n, &n, &work[1], &ldb, 
00641                                         &rwork[1]);
00642                                 if (anormo <= 0. || ainvnm <= 0.) {
00643                                     rcondo = 1.;
00644                                 } else {
00645                                     rcondo = 1. / anormo / ainvnm;
00646                                 }
00647 
00648 /*                          Compute the infinity-norm condition number of */
00649 /*                          A. */
00650 
00651                                 ainvnm = zlange_("I", &n, &n, &work[1], &ldb, 
00652                                         &rwork[1]);
00653                                 if (anormi <= 0. || ainvnm <= 0.) {
00654                                     rcondi = 1.;
00655                                 } else {
00656                                     rcondi = 1. / anormi / ainvnm;
00657                                 }
00658                             } else {
00659 
00660 /*                          Do only the condition estimate if INFO.NE.0. */
00661 
00662                                 trfcon = TRUE_;
00663                                 rcondo = 0.;
00664                                 rcondi = 0.;
00665                             }
00666 
00667 /*                       Skip the solve tests if the matrix is singular. */
00668 
00669                             if (trfcon) {
00670                                 goto L90;
00671                             }
00672 
00673                             i__9 = *nns;
00674                             for (irhs = 1; irhs <= i__9; ++irhs) {
00675                                 nrhs = nsval[irhs];
00676                                 *(unsigned char *)xtype = 'N';
00677 
00678                                 for (itran = 1; itran <= 3; ++itran) {
00679                                     *(unsigned char *)trans = *(unsigned char 
00680                                             *)&transs[itran - 1];
00681                                     if (itran == 1) {
00682                                         rcondc = rcondo;
00683                                         *(unsigned char *)norm = 'O';
00684                                     } else {
00685                                         rcondc = rcondi;
00686                                         *(unsigned char *)norm = 'I';
00687                                     }
00688 
00689 /* +    TEST 2: */
00690 /*                             Solve and compute residual for A * X = B. */
00691 
00692                                     s_copy(srnamc_1.srnamt, "ZLARHS", (ftnlen)
00693                                             32, (ftnlen)6);
00694                                     zlarhs_(path, xtype, " ", trans, &n, &n, &
00695                                             kl, &ku, &nrhs, &a[1], &lda, &
00696                                             xact[1], &ldb, &b[1], &ldb, iseed, 
00697                                              &info);
00698                                     *(unsigned char *)xtype = 'C';
00699                                     zlacpy_("Full", &n, &nrhs, &b[1], &ldb, &
00700                                             x[1], &ldb);
00701 
00702                                     s_copy(srnamc_1.srnamt, "ZGBTRS", (ftnlen)
00703                                             32, (ftnlen)6);
00704                                     zgbtrs_(trans, &n, &kl, &ku, &nrhs, &afac[
00705                                             1], &ldafac, &iwork[1], &x[1], &
00706                                             ldb, &info);
00707 
00708 /*                             Check error code from ZGBTRS. */
00709 
00710                                     if (info != 0) {
00711                                         alaerh_(path, "ZGBTRS", &info, &c__0, 
00712                                                 trans, &n, &n, &kl, &ku, &
00713                                                 c_n1, &imat, &nfail, &nerrs, 
00714                                                 nout);
00715                                     }
00716 
00717                                     zlacpy_("Full", &n, &nrhs, &b[1], &ldb, &
00718                                             work[1], &ldb);
00719                                     zgbt02_(trans, &m, &n, &kl, &ku, &nrhs, &
00720                                             a[1], &lda, &x[1], &ldb, &work[1], 
00721                                              &ldb, &result[1]);
00722 
00723 /* +    TEST 3: */
00724 /*                             Check solution from generated exact */
00725 /*                             solution. */
00726 
00727                                     zget04_(&n, &nrhs, &x[1], &ldb, &xact[1], 
00728                                             &ldb, &rcondc, &result[2]);
00729 
00730 /* +    TESTS 4, 5, 6: */
00731 /*                             Use iterative refinement to improve the */
00732 /*                             solution. */
00733 
00734                                     s_copy(srnamc_1.srnamt, "ZGBRFS", (ftnlen)
00735                                             32, (ftnlen)6);
00736                                     zgbrfs_(trans, &n, &kl, &ku, &nrhs, &a[1], 
00737                                              &lda, &afac[1], &ldafac, &iwork[
00738                                             1], &b[1], &ldb, &x[1], &ldb, &
00739                                             rwork[1], &rwork[nrhs + 1], &work[
00740                                             1], &rwork[(nrhs << 1) + 1], &
00741                                             info);
00742 
00743 /*                             Check error code from ZGBRFS. */
00744 
00745                                     if (info != 0) {
00746                                         alaerh_(path, "ZGBRFS", &info, &c__0, 
00747                                                 trans, &n, &n, &kl, &ku, &
00748                                                 nrhs, &imat, &nfail, &nerrs, 
00749                                                 nout);
00750                                     }
00751 
00752                                     zget04_(&n, &nrhs, &x[1], &ldb, &xact[1], 
00753                                             &ldb, &rcondc, &result[3]);
00754                                     zgbt05_(trans, &n, &kl, &ku, &nrhs, &a[1], 
00755                                              &lda, &b[1], &ldb, &x[1], &ldb, &
00756                                             xact[1], &ldb, &rwork[1], &rwork[
00757                                             nrhs + 1], &result[4]);
00758 
00759 /*                             Print information about the tests that did */
00760 /*                             not pass the threshold. */
00761 
00762                                     for (k = 2; k <= 6; ++k) {
00763                                         if (result[k - 1] >= *thresh) {
00764                                             if (nfail == 0 && nerrs == 0) {
00765                           alahd_(nout, path);
00766                                             }
00767                                             io___59.ciunit = *nout;
00768                                             s_wsfe(&io___59);
00769                                             do_fio(&c__1, trans, (ftnlen)1);
00770                                             do_fio(&c__1, (char *)&n, (ftnlen)
00771                                                     sizeof(integer));
00772                                             do_fio(&c__1, (char *)&kl, (
00773                                                     ftnlen)sizeof(integer));
00774                                             do_fio(&c__1, (char *)&ku, (
00775                                                     ftnlen)sizeof(integer));
00776                                             do_fio(&c__1, (char *)&nrhs, (
00777                                                     ftnlen)sizeof(integer));
00778                                             do_fio(&c__1, (char *)&imat, (
00779                                                     ftnlen)sizeof(integer));
00780                                             do_fio(&c__1, (char *)&k, (ftnlen)
00781                                                     sizeof(integer));
00782                                             do_fio(&c__1, (char *)&result[k - 
00783                                                     1], (ftnlen)sizeof(
00784                                                     doublereal));
00785                                             e_wsfe();
00786                                             ++nfail;
00787                                         }
00788 /* L60: */
00789                                     }
00790                                     nrun += 5;
00791 /* L70: */
00792                                 }
00793 /* L80: */
00794                             }
00795 
00796 /* +    TEST 7: */
00797 /*                          Get an estimate of RCOND = 1/CNDNUM. */
00798 
00799 L90:
00800                             for (itran = 1; itran <= 2; ++itran) {
00801                                 if (itran == 1) {
00802                                     anorm = anormo;
00803                                     rcondc = rcondo;
00804                                     *(unsigned char *)norm = 'O';
00805                                 } else {
00806                                     anorm = anormi;
00807                                     rcondc = rcondi;
00808                                     *(unsigned char *)norm = 'I';
00809                                 }
00810                                 s_copy(srnamc_1.srnamt, "ZGBCON", (ftnlen)32, 
00811                                         (ftnlen)6);
00812                                 zgbcon_(norm, &n, &kl, &ku, &afac[1], &ldafac, 
00813                                          &iwork[1], &anorm, &rcond, &work[1], 
00814                                         &rwork[1], &info);
00815 
00816 /*                             Check error code from ZGBCON. */
00817 
00818                                 if (info != 0) {
00819                                     alaerh_(path, "ZGBCON", &info, &c__0, 
00820                                             norm, &n, &n, &kl, &ku, &c_n1, &
00821                                             imat, &nfail, &nerrs, nout);
00822                                 }
00823 
00824                                 result[6] = dget06_(&rcond, &rcondc);
00825 
00826 /*                          Print information about the tests that did */
00827 /*                          not pass the threshold. */
00828 
00829                                 if (result[6] >= *thresh) {
00830                                     if (nfail == 0 && nerrs == 0) {
00831                                         alahd_(nout, path);
00832                                     }
00833                                     io___61.ciunit = *nout;
00834                                     s_wsfe(&io___61);
00835                                     do_fio(&c__1, norm, (ftnlen)1);
00836                                     do_fio(&c__1, (char *)&n, (ftnlen)sizeof(
00837                                             integer));
00838                                     do_fio(&c__1, (char *)&kl, (ftnlen)sizeof(
00839                                             integer));
00840                                     do_fio(&c__1, (char *)&ku, (ftnlen)sizeof(
00841                                             integer));
00842                                     do_fio(&c__1, (char *)&imat, (ftnlen)
00843                                             sizeof(integer));
00844                                     do_fio(&c__1, (char *)&c__7, (ftnlen)
00845                                             sizeof(integer));
00846                                     do_fio(&c__1, (char *)&result[6], (ftnlen)
00847                                             sizeof(doublereal));
00848                                     e_wsfe();
00849                                     ++nfail;
00850                                 }
00851                                 ++nrun;
00852 /* L100: */
00853                             }
00854 L110:
00855                             ;
00856                         }
00857 L120:
00858                         ;
00859                     }
00860 L130:
00861                     ;
00862                 }
00863 /* L140: */
00864             }
00865 /* L150: */
00866         }
00867 /* L160: */
00868     }
00869 
00870 /*     Print a summary of the results. */
00871 
00872     alasum_(path, nout, &nfail, &nrun, &nerrs);
00873 
00874 
00875     return 0;
00876 
00877 /*     End of ZCHKGB */
00878 
00879 } /* zchkgb_ */

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