cchkgb.c
Go to the documentation of this file.
00001 /* cchkgb.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 complex c_b61 = {0.f,0.f};
00037 static complex c_b62 = {1.f,0.f};
00038 static integer c__7 = 7;
00039 
00040 /* Subroutine */ int cchkgb_(logical *dotype, integer *nm, integer *mval, 
00041         integer *nn, integer *nval, integer *nnb, integer *nbval, integer *
00042         nns, integer *nsval, real *thresh, logical *tsterr, complex *a, 
00043         integer *la, complex *afac, integer *lafac, complex *b, complex *x, 
00044         complex *xact, complex *work, real *rwork, integer *iwork, integer *
00045         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 CCHKGB, 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 CCHKGB, 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 *), cgbt01_(
00085             integer *, integer *, integer *, integer *, complex *, integer *, 
00086             complex *, integer *, integer *, complex *, real *), cgbt02_(char 
00087             *, integer *, integer *, integer *, integer *, integer *, complex 
00088             *, integer *, complex *, integer *, complex *, integer *, real *), cgbt05_(char *, integer *, integer *, integer *, integer 
00089             *, complex *, integer *, complex *, integer *, complex *, integer 
00090             *, complex *, integer *, real *, real *, real *), cget04_(
00091             integer *, integer *, complex *, integer *, complex *, integer *, 
00092             real *, real *);
00093     integer nfail, iseed[4];
00094     real rcond;
00095     integer nimat, klval[4];
00096     extern doublereal sget06_(real *, real *);
00097     real anorm;
00098     integer itran;
00099     extern /* Subroutine */ int ccopy_(integer *, complex *, integer *, 
00100             complex *, integer *);
00101     integer kuval[4];
00102     char trans[1];
00103     integer izero, nerrs;
00104     logical zerot;
00105     char xtype[1];
00106     extern /* Subroutine */ int clatb4_(char *, integer *, integer *, integer 
00107             *, char *, integer *, integer *, real *, integer *, real *, char *
00108 );
00109     integer ldafac;
00110     extern doublereal clangb_(char *, integer *, integer *, integer *, 
00111             complex *, integer *, real *), clange_(char *, integer *, 
00112             integer *, complex *, integer *, real *);
00113     extern /* Subroutine */ int cgbcon_(char *, integer *, integer *, integer 
00114             *, complex *, integer *, integer *, real *, real *, complex *, 
00115             real *, integer *), alaerh_(char *, char *, integer *, 
00116             integer *, char *, integer *, integer *, integer *, integer *, 
00117             integer *, integer *, integer *, integer *, integer *), cgbrfs_(char *, integer *, integer *, integer *, 
00118             integer *, complex *, integer *, complex *, integer *, integer *, 
00119             complex *, integer *, complex *, integer *, real *, real *, 
00120             complex *, real *, integer *), cerrge_(char *, integer *);
00121     real rcondc;
00122     extern /* Subroutine */ int cgbtrf_(integer *, integer *, integer *, 
00123             integer *, complex *, integer *, integer *, integer *), clacpy_(
00124             char *, integer *, integer *, complex *, integer *, complex *, 
00125             integer *), clarhs_(char *, char *, char *, char *, 
00126             integer *, integer *, integer *, integer *, integer *, complex *, 
00127             integer *, complex *, integer *, complex *, integer *, integer *, 
00128             integer *), claset_(char *, 
00129             integer *, integer *, complex *, complex *, complex *, integer *);
00130     real rcondi;
00131     extern /* Subroutine */ int alasum_(char *, integer *, integer *, integer 
00132             *, integer *);
00133     real cndnum, anormi, rcondo;
00134     extern /* Subroutine */ int cgbtrs_(char *, integer *, integer *, integer 
00135             *, integer *, complex *, integer *, integer *, complex *, integer 
00136             *, integer *);
00137     real ainvnm;
00138     extern /* Subroutine */ int clatms_(integer *, integer *, char *, integer 
00139             *, char *, real *, integer *, real *, real *, integer *, integer *
00140 , char *, complex *, integer *, complex *, integer *);
00141     logical trfcon;
00142     real anormo;
00143     extern /* Subroutine */ int xlaenv_(integer *, integer *);
00144     real result[7];
00145 
00146     /* Fortran I/O blocks */
00147     static cilist io___25 = { 0, 0, 0, fmt_9999, 0 };
00148     static cilist io___26 = { 0, 0, 0, fmt_9998, 0 };
00149     static cilist io___45 = { 0, 0, 0, fmt_9997, 0 };
00150     static cilist io___59 = { 0, 0, 0, fmt_9996, 0 };
00151     static cilist io___61 = { 0, 0, 0, fmt_9995, 0 };
00152 
00153 
00154 
00155 /*  -- LAPACK test routine (version 3.1) -- */
00156 /*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
00157 /*     November 2006 */
00158 
00159 /*     .. Scalar Arguments .. */
00160 /*     .. */
00161 /*     .. Array Arguments .. */
00162 /*     .. */
00163 
00164 /*  Purpose */
00165 /*  ======= */
00166 
00167 /*  CCHKGB tests CGBTRF, -TRS, -RFS, and -CON */
00168 
00169 /*  Arguments */
00170 /*  ========= */
00171 
00172 /*  DOTYPE  (input) LOGICAL array, dimension (NTYPES) */
00173 /*          The matrix types to be used for testing.  Matrices of type j */
00174 /*          (for 1 <= j <= NTYPES) are used for testing if DOTYPE(j) = */
00175 /*          .TRUE.; if DOTYPE(j) = .FALSE., then type j is not used. */
00176 
00177 /*  NM      (input) INTEGER */
00178 /*          The number of values of M contained in the vector MVAL. */
00179 
00180 /*  MVAL    (input) INTEGER array, dimension (NM) */
00181 /*          The values of the matrix row dimension M. */
00182 
00183 /*  NN      (input) INTEGER */
00184 /*          The number of values of N contained in the vector NVAL. */
00185 
00186 /*  NVAL    (input) INTEGER array, dimension (NN) */
00187 /*          The values of the matrix column dimension N. */
00188 
00189 /*  NNB     (input) INTEGER */
00190 /*          The number of values of NB contained in the vector NBVAL. */
00191 
00192 /*  NBVAL   (input) INTEGER array, dimension (NNB) */
00193 /*          The values of the blocksize NB. */
00194 
00195 /*  NNS     (input) INTEGER */
00196 /*          The number of values of NRHS contained in the vector NSVAL. */
00197 
00198 /*  NSVAL   (input) INTEGER array, dimension (NNS) */
00199 /*          The values of the number of right hand sides NRHS. */
00200 
00201 /*  THRESH  (input) REAL */
00202 /*          The threshold value for the test ratios.  A result is */
00203 /*          included in the output file if RESULT >= THRESH.  To have */
00204 /*          every test ratio printed, use THRESH = 0. */
00205 
00206 /*  TSTERR  (input) LOGICAL */
00207 /*          Flag that indicates whether error exits are to be tested. */
00208 
00209 /*  A       (workspace) COMPLEX array, dimension (LA) */
00210 
00211 /*  LA      (input) INTEGER */
00212 /*          The length of the array A.  LA >= (KLMAX+KUMAX+1)*NMAX */
00213 /*          where KLMAX is the largest entry in the local array KLVAL, */
00214 /*                KUMAX is the largest entry in the local array KUVAL and */
00215 /*                NMAX is the largest entry in the input array NVAL. */
00216 
00217 /*  AFAC    (workspace) COMPLEX array, dimension (LAFAC) */
00218 
00219 /*  LAFAC   (input) INTEGER */
00220 /*          The length of the array AFAC. LAFAC >= (2*KLMAX+KUMAX+1)*NMAX */
00221 /*          where KLMAX is the largest entry in the local array KLVAL, */
00222 /*                KUMAX is the largest entry in the local array KUVAL and */
00223 /*                NMAX is the largest entry in the input array NVAL. */
00224 
00225 /*  B       (workspace) COMPLEX array, dimension (NMAX*NSMAX) */
00226 
00227 /*  X       (workspace) COMPLEX array, dimension (NMAX*NSMAX) */
00228 
00229 /*  XACT    (workspace) COMPLEX array, dimension (NMAX*NSMAX) */
00230 
00231 /*  WORK    (workspace) COMPLEX array, dimension */
00232 /*                      (NMAX*max(3,NSMAX,NMAX)) */
00233 
00234 /*  RWORK   (workspace) REAL array, dimension */
00235 /*                      (max(NMAX,2*NSMAX)) */
00236 
00237 /*  IWORK   (workspace) INTEGER array, dimension (NMAX) */
00238 
00239 /*  NOUT    (input) INTEGER */
00240 /*          The unit number for output. */
00241 
00242 /*  ===================================================================== */
00243 
00244 /*     .. Parameters .. */
00245 /*     .. */
00246 /*     .. Local Scalars .. */
00247 /*     .. */
00248 /*     .. Local Arrays .. */
00249 /*     .. */
00250 /*     .. External Functions .. */
00251 /*     .. */
00252 /*     .. External Subroutines .. */
00253 /*     .. */
00254 /*     .. Intrinsic Functions .. */
00255 /*     .. */
00256 /*     .. Scalars in Common .. */
00257 /*     .. */
00258 /*     .. Common blocks .. */
00259 /*     .. */
00260 /*     .. Data statements .. */
00261     /* Parameter adjustments */
00262     --iwork;
00263     --rwork;
00264     --work;
00265     --xact;
00266     --x;
00267     --b;
00268     --afac;
00269     --a;
00270     --nsval;
00271     --nbval;
00272     --nval;
00273     --mval;
00274     --dotype;
00275 
00276     /* Function Body */
00277 /*     .. */
00278 /*     .. Executable Statements .. */
00279 
00280 /*     Initialize constants and the random number seed. */
00281 
00282     s_copy(path, "Complex precision", (ftnlen)1, (ftnlen)17);
00283     s_copy(path + 1, "GB", (ftnlen)2, (ftnlen)2);
00284     nrun = 0;
00285     nfail = 0;
00286     nerrs = 0;
00287     for (i__ = 1; i__ <= 4; ++i__) {
00288         iseed[i__ - 1] = iseedy[i__ - 1];
00289 /* L10: */
00290     }
00291 
00292 /*     Test the error exits */
00293 
00294     if (*tsterr) {
00295         cerrge_(path, nout);
00296     }
00297     infoc_1.infot = 0;
00298 
00299 /*     Initialize the first value for the lower and upper bandwidths. */
00300 
00301     klval[0] = 0;
00302     kuval[0] = 0;
00303 
00304 /*     Do for each value of M in MVAL */
00305 
00306     i__1 = *nm;
00307     for (im = 1; im <= i__1; ++im) {
00308         m = mval[im];
00309 
00310 /*        Set values to use for the lower bandwidth. */
00311 
00312         klval[1] = m + (m + 1) / 4;
00313 
00314 /*        KLVAL( 2 ) = MAX( M-1, 0 ) */
00315 
00316         klval[2] = (m * 3 - 1) / 4;
00317         klval[3] = (m + 1) / 4;
00318 
00319 /*        Do for each value of N in NVAL */
00320 
00321         i__2 = *nn;
00322         for (in = 1; in <= i__2; ++in) {
00323             n = nval[in];
00324             *(unsigned char *)xtype = 'N';
00325 
00326 /*           Set values to use for the upper bandwidth. */
00327 
00328             kuval[1] = n + (n + 1) / 4;
00329 
00330 /*           KUVAL( 2 ) = MAX( N-1, 0 ) */
00331 
00332             kuval[2] = (n * 3 - 1) / 4;
00333             kuval[3] = (n + 1) / 4;
00334 
00335 /*           Set limits on the number of loop iterations. */
00336 
00337 /* Computing MIN */
00338             i__3 = m + 1;
00339             nkl = min(i__3,4);
00340             if (n == 0) {
00341                 nkl = 2;
00342             }
00343 /* Computing MIN */
00344             i__3 = n + 1;
00345             nku = min(i__3,4);
00346             if (m == 0) {
00347                 nku = 2;
00348             }
00349             nimat = 8;
00350             if (m <= 0 || n <= 0) {
00351                 nimat = 1;
00352             }
00353 
00354             i__3 = nkl;
00355             for (ikl = 1; ikl <= i__3; ++ikl) {
00356 
00357 /*              Do for KL = 0, (5*M+1)/4, (3M-1)/4, and (M+1)/4. This */
00358 /*              order makes it easier to skip redundant values for small */
00359 /*              values of M. */
00360 
00361                 kl = klval[ikl - 1];
00362                 i__4 = nku;
00363                 for (iku = 1; iku <= i__4; ++iku) {
00364 
00365 /*                 Do for KU = 0, (5*N+1)/4, (3N-1)/4, and (N+1)/4. This */
00366 /*                 order makes it easier to skip redundant values for */
00367 /*                 small values of N. */
00368 
00369                     ku = kuval[iku - 1];
00370 
00371 /*                 Check that A and AFAC are big enough to generate this */
00372 /*                 matrix. */
00373 
00374                     lda = kl + ku + 1;
00375                     ldafac = (kl << 1) + ku + 1;
00376                     if (lda * n > *la || ldafac * n > *lafac) {
00377                         if (nfail == 0 && nerrs == 0) {
00378                             alahd_(nout, path);
00379                         }
00380                         if (n * (kl + ku + 1) > *la) {
00381                             io___25.ciunit = *nout;
00382                             s_wsfe(&io___25);
00383                             do_fio(&c__1, (char *)&(*la), (ftnlen)sizeof(
00384                                     integer));
00385                             do_fio(&c__1, (char *)&m, (ftnlen)sizeof(integer))
00386                                     ;
00387                             do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer))
00388                                     ;
00389                             do_fio(&c__1, (char *)&kl, (ftnlen)sizeof(integer)
00390                                     );
00391                             do_fio(&c__1, (char *)&ku, (ftnlen)sizeof(integer)
00392                                     );
00393                             i__5 = n * (kl + ku + 1);
00394                             do_fio(&c__1, (char *)&i__5, (ftnlen)sizeof(
00395                                     integer));
00396                             e_wsfe();
00397                             ++nerrs;
00398                         }
00399                         if (n * ((kl << 1) + ku + 1) > *lafac) {
00400                             io___26.ciunit = *nout;
00401                             s_wsfe(&io___26);
00402                             do_fio(&c__1, (char *)&(*lafac), (ftnlen)sizeof(
00403                                     integer));
00404                             do_fio(&c__1, (char *)&m, (ftnlen)sizeof(integer))
00405                                     ;
00406                             do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer))
00407                                     ;
00408                             do_fio(&c__1, (char *)&kl, (ftnlen)sizeof(integer)
00409                                     );
00410                             do_fio(&c__1, (char *)&ku, (ftnlen)sizeof(integer)
00411                                     );
00412                             i__5 = n * ((kl << 1) + ku + 1);
00413                             do_fio(&c__1, (char *)&i__5, (ftnlen)sizeof(
00414                                     integer));
00415                             e_wsfe();
00416                             ++nerrs;
00417                         }
00418                         goto L130;
00419                     }
00420 
00421                     i__5 = nimat;
00422                     for (imat = 1; imat <= i__5; ++imat) {
00423 
00424 /*                    Do the tests only if DOTYPE( IMAT ) is true. */
00425 
00426                         if (! dotype[imat]) {
00427                             goto L120;
00428                         }
00429 
00430 /*                    Skip types 2, 3, or 4 if the matrix size is too */
00431 /*                    small. */
00432 
00433                         zerot = imat >= 2 && imat <= 4;
00434                         if (zerot && n < imat - 1) {
00435                             goto L120;
00436                         }
00437 
00438                         if (! zerot || ! dotype[1]) {
00439 
00440 /*                       Set up parameters with CLATB4 and generate a */
00441 /*                       test matrix with CLATMS. */
00442 
00443                             clatb4_(path, &imat, &m, &n, type__, &kl, &ku, &
00444                                     anorm, &mode, &cndnum, dist);
00445 
00446 /* Computing MAX */
00447                             i__6 = 1, i__7 = ku + 2 - n;
00448                             koff = max(i__6,i__7);
00449                             i__6 = koff - 1;
00450                             for (i__ = 1; i__ <= i__6; ++i__) {
00451                                 i__7 = i__;
00452                                 a[i__7].r = 0.f, a[i__7].i = 0.f;
00453 /* L20: */
00454                             }
00455                             s_copy(srnamc_1.srnamt, "CLATMS", (ftnlen)32, (
00456                                     ftnlen)6);
00457                             clatms_(&m, &n, dist, iseed, type__, &rwork[1], &
00458                                     mode, &cndnum, &anorm, &kl, &ku, "Z", &a[
00459                                     koff], &lda, &work[1], &info);
00460 
00461 /*                       Check the error code from CLATMS. */
00462 
00463                             if (info != 0) {
00464                                 alaerh_(path, "CLATMS", &info, &c__0, " ", &m, 
00465                                          &n, &kl, &ku, &c_n1, &imat, &nfail, &
00466                                         nerrs, nout);
00467                                 goto L120;
00468                             }
00469                         } else if (izero > 0) {
00470 
00471 /*                       Use the same matrix for types 3 and 4 as for */
00472 /*                       type 2 by copying back the zeroed out column. */
00473 
00474                             i__6 = i2 - i1 + 1;
00475                             ccopy_(&i__6, &b[1], &c__1, &a[ioff + i1], &c__1);
00476                         }
00477 
00478 /*                    For types 2, 3, and 4, zero one or more columns of */
00479 /*                    the matrix to test that INFO is returned correctly. */
00480 
00481                         izero = 0;
00482                         if (zerot) {
00483                             if (imat == 2) {
00484                                 izero = 1;
00485                             } else if (imat == 3) {
00486                                 izero = min(m,n);
00487                             } else {
00488                                 izero = min(m,n) / 2 + 1;
00489                             }
00490                             ioff = (izero - 1) * lda;
00491                             if (imat < 4) {
00492 
00493 /*                          Store the column to be zeroed out in B. */
00494 
00495 /* Computing MAX */
00496                                 i__6 = 1, i__7 = ku + 2 - izero;
00497                                 i1 = max(i__6,i__7);
00498 /* Computing MIN */
00499                                 i__6 = kl + ku + 1, i__7 = ku + 1 + (m - 
00500                                         izero);
00501                                 i2 = min(i__6,i__7);
00502                                 i__6 = i2 - i1 + 1;
00503                                 ccopy_(&i__6, &a[ioff + i1], &c__1, &b[1], &
00504                                         c__1);
00505 
00506                                 i__6 = i2;
00507                                 for (i__ = i1; i__ <= i__6; ++i__) {
00508                                     i__7 = ioff + i__;
00509                                     a[i__7].r = 0.f, a[i__7].i = 0.f;
00510 /* L30: */
00511                                 }
00512                             } else {
00513                                 i__6 = n;
00514                                 for (j = izero; j <= i__6; ++j) {
00515 /* Computing MAX */
00516                                     i__7 = 1, i__8 = ku + 2 - j;
00517 /* Computing MIN */
00518                                     i__10 = kl + ku + 1, i__11 = ku + 1 + (m 
00519                                             - j);
00520                                     i__9 = min(i__10,i__11);
00521                                     for (i__ = max(i__7,i__8); i__ <= i__9; 
00522                                             ++i__) {
00523                                         i__7 = ioff + i__;
00524                                         a[i__7].r = 0.f, a[i__7].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 = CLANGB( 'O', N, KL, KU, A, LDA, RWORK ) */
00538 /*                     ANORMI = CLANGB( '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                                 clacpy_("Full", &i__9, &n, &a[1], &lda, &afac[
00552                                         kl + 1], &ldafac);
00553                             }
00554                             s_copy(srnamc_1.srnamt, "CGBTRF", (ftnlen)32, (
00555                                     ftnlen)6);
00556                             cgbtrf_(&m, &n, &kl, &ku, &afac[1], &ldafac, &
00557                                     iwork[1], &info);
00558 
00559 /*                       Check error code from CGBTRF. */
00560 
00561                             if (info != izero) {
00562                                 alaerh_(path, "CGBTRF", &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                             cgbt01_(&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 = clangb_("O", &n, &kl, &ku, &a[1], &lda, &
00613                                     rwork[1]);
00614                             anormi = clangb_("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                                 claset_("Full", &n, &n, &c_b61, &c_b62, &work[
00624                                         1], &ldb);
00625                                 s_copy(srnamc_1.srnamt, "CGBTRS", (ftnlen)32, 
00626                                         (ftnlen)6);
00627                                 cgbtrs_("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 = clange_("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 = clange_("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, "CLARHS", (ftnlen)
00686                                             32, (ftnlen)6);
00687                                     clarhs_(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                                     clacpy_("Full", &n, &nrhs, &b[1], &ldb, &
00693                                             x[1], &ldb);
00694 
00695                                     s_copy(srnamc_1.srnamt, "CGBTRS", (ftnlen)
00696                                             32, (ftnlen)6);
00697                                     cgbtrs_(trans, &n, &kl, &ku, &nrhs, &afac[
00698                                             1], &ldafac, &iwork[1], &x[1], &
00699                                             ldb, &info);
00700 
00701 /*                             Check error code from CGBTRS. */
00702 
00703                                     if (info != 0) {
00704                                         alaerh_(path, "CGBTRS", &info, &c__0, 
00705                                                 trans, &n, &n, &kl, &ku, &
00706                                                 c_n1, &imat, &nfail, &nerrs, 
00707                                                 nout);
00708                                     }
00709 
00710                                     clacpy_("Full", &n, &nrhs, &b[1], &ldb, &
00711                                             work[1], &ldb);
00712                                     cgbt02_(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                                     cget04_(&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, "CGBRFS", (ftnlen)
00728                                             32, (ftnlen)6);
00729                                     cgbrfs_(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], &rwork[(nrhs << 1) + 1], &
00734                                             info);
00735 
00736 /*                             Check error code from CGBRFS. */
00737 
00738                                     if (info != 0) {
00739                                         alaerh_(path, "CGBRFS", &info, &c__0, 
00740                                                 trans, &n, &n, &kl, &ku, &
00741                                                 nrhs, &imat, &nfail, &nerrs, 
00742                                                 nout);
00743                                     }
00744 
00745                                     cget04_(&n, &nrhs, &x[1], &ldb, &xact[1], 
00746                                             &ldb, &rcondc, &result[3]);
00747                                     cgbt05_(trans, &n, &kl, &ku, &nrhs, &a[1], 
00748                                              &lda, &b[1], &ldb, &x[1], &ldb, &
00749                                             xact[1], &ldb, &rwork[1], &rwork[
00750                                             nrhs + 1], &result[4]);
00751 
00752 /*                             Print information about the tests that did */
00753 /*                             not pass the threshold. */
00754 
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(real));
00777                                             e_wsfe();
00778                                             ++nfail;
00779                                         }
00780 /* L60: */
00781                                     }
00782                                     nrun += 5;
00783 /* L70: */
00784                                 }
00785 /* L80: */
00786                             }
00787 
00788 /* +    TEST 7: */
00789 /*                          Get an estimate of RCOND = 1/CNDNUM. */
00790 
00791 L90:
00792                             for (itran = 1; itran <= 2; ++itran) {
00793                                 if (itran == 1) {
00794                                     anorm = anormo;
00795                                     rcondc = rcondo;
00796                                     *(unsigned char *)norm = 'O';
00797                                 } else {
00798                                     anorm = anormi;
00799                                     rcondc = rcondi;
00800                                     *(unsigned char *)norm = 'I';
00801                                 }
00802                                 s_copy(srnamc_1.srnamt, "CGBCON", (ftnlen)32, 
00803                                         (ftnlen)6);
00804                                 cgbcon_(norm, &n, &kl, &ku, &afac[1], &ldafac, 
00805                                          &iwork[1], &anorm, &rcond, &work[1], 
00806                                         &rwork[1], &info);
00807 
00808 /*                             Check error code from CGBCON. */
00809 
00810                                 if (info != 0) {
00811                                     alaerh_(path, "CGBCON", &info, &c__0, 
00812                                             norm, &n, &n, &kl, &ku, &c_n1, &
00813                                             imat, &nfail, &nerrs, nout);
00814                                 }
00815 
00816                                 result[6] = sget06_(&rcond, &rcondc);
00817 
00818 /*                          Print information about the tests that did */
00819 /*                          not pass the threshold. */
00820 
00821                                 if (result[6] >= *thresh) {
00822                                     if (nfail == 0 && nerrs == 0) {
00823                                         alahd_(nout, path);
00824                                     }
00825                                     io___61.ciunit = *nout;
00826                                     s_wsfe(&io___61);
00827                                     do_fio(&c__1, norm, (ftnlen)1);
00828                                     do_fio(&c__1, (char *)&n, (ftnlen)sizeof(
00829                                             integer));
00830                                     do_fio(&c__1, (char *)&kl, (ftnlen)sizeof(
00831                                             integer));
00832                                     do_fio(&c__1, (char *)&ku, (ftnlen)sizeof(
00833                                             integer));
00834                                     do_fio(&c__1, (char *)&imat, (ftnlen)
00835                                             sizeof(integer));
00836                                     do_fio(&c__1, (char *)&c__7, (ftnlen)
00837                                             sizeof(integer));
00838                                     do_fio(&c__1, (char *)&result[6], (ftnlen)
00839                                             sizeof(real));
00840                                     e_wsfe();
00841                                     ++nfail;
00842                                 }
00843                                 ++nrun;
00844 /* L100: */
00845                             }
00846 L110:
00847                             ;
00848                         }
00849 L120:
00850                         ;
00851                     }
00852 L130:
00853                     ;
00854                 }
00855 /* L140: */
00856             }
00857 /* L150: */
00858         }
00859 /* L160: */
00860     }
00861 
00862 /*     Print a summary of the results. */
00863 
00864     alasum_(path, nout, &nfail, &nrun, &nerrs);
00865 
00866 
00867     return 0;
00868 
00869 /*     End of CCHKGB */
00870 
00871 } /* cchkgb_ */

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