cchktb.c
Go to the documentation of this file.
00001 /* cchktb.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, iounit;
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 complex c_b14 = {0.f,0.f};
00034 static complex c_b15 = {1.f,0.f};
00035 static integer c__1 = 1;
00036 static integer c__0 = 0;
00037 static integer c__3 = 3;
00038 static integer c_n1 = -1;
00039 static integer c__6 = 6;
00040 static integer c__4 = 4;
00041 static real c_b90 = 1.f;
00042 static integer c__7 = 7;
00043 static integer c__8 = 8;
00044 
00045 /* Subroutine */ int cchktb_(logical *dotype, integer *nn, integer *nval, 
00046         integer *nns, integer *nsval, real *thresh, logical *tsterr, integer *
00047         nmax, complex *ab, complex *ainv, complex *b, complex *x, complex *
00048         xact, complex *work, real *rwork, integer *nout)
00049 {
00050     /* Initialized data */
00051 
00052     static integer iseedy[4] = { 1988,1989,1990,1991 };
00053     static char uplos[1*2] = "U" "L";
00054     static char transs[1*3] = "N" "T" "C";
00055 
00056     /* Format strings */
00057     static char fmt_9999[] = "(\002 UPLO='\002,a1,\002', TRANS='\002,a1,\002"
00058             "',                        DIAG='\002,a1,\002', N=\002,i5,\002, K"
00059             "D=\002,i5,\002, NRHS=\002,i5,\002, type \002,i2,\002, test(\002,"
00060             "i2,\002)=\002,g12.5)";
00061     static char fmt_9998[] = "(1x,a,\002( '\002,a1,\002', '\002,a1,\002', "
00062             "'\002,a1,\002',\002,i5,\002,\002,i5,\002,  ... ), type \002,i2"
00063             ",\002, test(\002,i2,\002)=\002,g12.5)";
00064     static char fmt_9997[] = "(1x,a,\002( '\002,a1,\002', '\002,a1,\002', "
00065             "'\002,a1,\002', '\002,a1,\002',\002,i5,\002,\002,i5,\002, ...  )"
00066             ",  type \002,i2,\002, test(\002,i1,\002)=\002,g12.5)";
00067 
00068     /* System generated locals */
00069     address a__1[3], a__2[4];
00070     integer i__1, i__2, i__3, i__4, i__5, i__6[3], i__7[4];
00071     char ch__1[3], ch__2[4];
00072 
00073     /* Builtin functions */
00074     /* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen), s_cat(char *,
00075              char **, integer *, integer *, ftnlen);
00076     integer s_wsfe(cilist *), do_fio(integer *, char *, ftnlen), e_wsfe(void);
00077 
00078     /* Local variables */
00079     integer i__, j, k, n, kd, ik, in, nk, lda, ldab;
00080     char diag[1];
00081     integer imat, info;
00082     char path[3];
00083     integer irhs, nrhs;
00084     char norm[1], uplo[1];
00085     integer nrun;
00086     extern /* Subroutine */ int alahd_(integer *, char *);
00087     integer idiag;
00088     extern /* Subroutine */ int cget04_(integer *, integer *, complex *, 
00089             integer *, complex *, integer *, real *, real *);
00090     real scale;
00091     integer nfail, iseed[4];
00092     extern /* Subroutine */ int ctbt02_(char *, char *, char *, integer *, 
00093             integer *, integer *, complex *, integer *, complex *, integer *, 
00094             complex *, integer *, complex *, real *, real *), ctbt03_(char *, char *, char *, integer *, integer *, 
00095             integer *, complex *, integer *, real *, real *, real *, complex *
00096 , integer *, complex *, integer *, complex *, real *);
00097     extern logical lsame_(char *, char *);
00098     extern /* Subroutine */ int ctbt05_(char *, char *, char *, integer *, 
00099             integer *, integer *, complex *, integer *, complex *, integer *, 
00100             complex *, integer *, complex *, integer *, real *, real *, real *
00101 ), ctbt06_(real *, real *, char *, char *, 
00102              integer *, integer *, complex *, integer *, real *, real *);
00103     real rcond;
00104     integer nimat;
00105     real anorm;
00106     integer itran;
00107     extern /* Subroutine */ int ccopy_(integer *, complex *, integer *, 
00108             complex *, integer *), ctbsv_(char *, char *, char *, integer *, 
00109             integer *, complex *, integer *, complex *, integer *);
00110     char trans[1];
00111     integer iuplo, nerrs;
00112     char xtype[1];
00113     integer nimat2;
00114     extern /* Subroutine */ int alaerh_(char *, char *, integer *, integer *, 
00115             char *, integer *, integer *, integer *, integer *, integer *, 
00116             integer *, integer *, integer *, integer *);
00117     extern doublereal clantb_(char *, char *, char *, integer *, integer *, 
00118             complex *, integer *, real *);
00119     real rcondc;
00120     extern /* Subroutine */ int clatbs_(char *, char *, char *, char *, 
00121             integer *, integer *, complex *, integer *, complex *, real *, 
00122             real *, integer *), clattb_(
00123             integer *, char *, char *, char *, integer *, integer *, integer *
00124 , complex *, integer *, complex *, complex *, real *, integer *), clacpy_(char *, integer *, integer *, 
00125             complex *, integer *, complex *, integer *), clarhs_(char 
00126             *, char *, char *, char *, integer *, integer *, integer *, 
00127             integer *, integer *, complex *, integer *, complex *, integer *, 
00128             complex *, integer *, integer *, integer *), claset_(char *, integer *, integer *, complex *, 
00129             complex *, complex *, integer *);
00130     real rcondi;
00131     extern /* Subroutine */ int ctbcon_(char *, char *, char *, integer *, 
00132             integer *, complex *, integer *, real *, complex *, real *, 
00133             integer *);
00134     extern doublereal clantr_(char *, char *, char *, integer *, integer *, 
00135             complex *, integer *, real *);
00136     real rcondo;
00137     extern /* Subroutine */ int alasum_(char *, integer *, integer *, integer 
00138             *, integer *), ctbrfs_(char *, char *, char *, integer *, 
00139             integer *, integer *, complex *, integer *, complex *, integer *, 
00140             complex *, integer *, real *, real *, complex *, real *, integer *
00141 );
00142     real ainvnm;
00143     extern /* Subroutine */ int cerrtr_(char *, integer *), ctbtrs_(
00144             char *, char *, char *, integer *, integer *, integer *, complex *
00145 , integer *, complex *, integer *, integer *);
00146     real result[8];
00147 
00148     /* Fortran I/O blocks */
00149     static cilist io___39 = { 0, 0, 0, fmt_9999, 0 };
00150     static cilist io___41 = { 0, 0, 0, fmt_9998, 0 };
00151     static cilist io___43 = { 0, 0, 0, fmt_9997, 0 };
00152     static cilist io___44 = { 0, 0, 0, fmt_9997, 0 };
00153 
00154 
00155 
00156 /*  -- LAPACK test routine (version 3.1) -- */
00157 /*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
00158 /*     November 2006 */
00159 
00160 /*     .. Scalar Arguments .. */
00161 /*     .. */
00162 /*     .. Array Arguments .. */
00163 /*     .. */
00164 
00165 /*  Purpose */
00166 /*  ======= */
00167 
00168 /*  CCHKTB tests CTBTRS, -RFS, and -CON, and CLATBS. */
00169 
00170 /*  Arguments */
00171 /*  ========= */
00172 
00173 /*  DOTYPE  (input) LOGICAL array, dimension (NTYPES) */
00174 /*          The matrix types to be used for testing.  Matrices of type j */
00175 /*          (for 1 <= j <= NTYPES) are used for testing if DOTYPE(j) = */
00176 /*          .TRUE.; if DOTYPE(j) = .FALSE., then type j is not used. */
00177 
00178 /*  NN      (input) INTEGER */
00179 /*          The number of values of N contained in the vector NVAL. */
00180 
00181 /*  NVAL    (input) INTEGER array, dimension (NN) */
00182 /*          The values of the matrix column dimension N. */
00183 
00184 /*  NNS     (input) INTEGER */
00185 /*          The number of values of NRHS contained in the vector NSVAL. */
00186 
00187 /*  NSVAL   (input) INTEGER array, dimension (NNS) */
00188 /*          The values of the number of right hand sides NRHS. */
00189 
00190 /*  THRESH  (input) REAL */
00191 /*          The threshold value for the test ratios.  A result is */
00192 /*          included in the output file if RESULT >= THRESH.  To have */
00193 /*          every test ratio printed, use THRESH = 0. */
00194 
00195 /*  TSTERR  (input) LOGICAL */
00196 /*          Flag that indicates whether error exits are to be tested. */
00197 
00198 /*  NMAX    (input) INTEGER */
00199 /*          The leading dimension of the work arrays. */
00200 /*          NMAX >= the maximum value of N in NVAL. */
00201 
00202 /*  AB      (workspace) COMPLEX array, dimension (NMAX*NMAX) */
00203 
00204 /*  AINV    (workspace) COMPLEX array, dimension (NMAX*NMAX) */
00205 
00206 /*  B       (workspace) COMPLEX array, dimension (NMAX*NSMAX) */
00207 /*          where NSMAX is the largest entry in NSVAL. */
00208 
00209 /*  X       (workspace) COMPLEX array, dimension (NMAX*NSMAX) */
00210 
00211 /*  XACT    (workspace) COMPLEX array, dimension (NMAX*NSMAX) */
00212 
00213 /*  WORK    (workspace) COMPLEX array, dimension */
00214 /*                      (NMAX*max(3,NSMAX)) */
00215 
00216 /*  RWORK   (workspace) REAL array, dimension */
00217 /*                      (max(NMAX,2*NSMAX)) */
00218 
00219 /*  NOUT    (input) INTEGER */
00220 /*          The unit number for output. */
00221 
00222 /*  ===================================================================== */
00223 
00224 /*     .. Parameters .. */
00225 /*     .. */
00226 /*     .. Local Scalars .. */
00227 /*     .. */
00228 /*     .. Local Arrays .. */
00229 /*     .. */
00230 /*     .. External Functions .. */
00231 /*     .. */
00232 /*     .. External Subroutines .. */
00233 /*     .. */
00234 /*     .. Scalars in Common .. */
00235 /*     .. */
00236 /*     .. Common blocks .. */
00237 /*     .. */
00238 /*     .. Intrinsic Functions .. */
00239 /*     .. */
00240 /*     .. Data statements .. */
00241     /* Parameter adjustments */
00242     --rwork;
00243     --work;
00244     --xact;
00245     --x;
00246     --b;
00247     --ainv;
00248     --ab;
00249     --nsval;
00250     --nval;
00251     --dotype;
00252 
00253     /* Function Body */
00254 /*     .. */
00255 /*     .. Executable Statements .. */
00256 
00257 /*     Initialize constants and the random number seed. */
00258 
00259     s_copy(path, "Complex precision", (ftnlen)1, (ftnlen)17);
00260     s_copy(path + 1, "TB", (ftnlen)2, (ftnlen)2);
00261     nrun = 0;
00262     nfail = 0;
00263     nerrs = 0;
00264     for (i__ = 1; i__ <= 4; ++i__) {
00265         iseed[i__ - 1] = iseedy[i__ - 1];
00266 /* L10: */
00267     }
00268 
00269 /*     Test the error exits */
00270 
00271     if (*tsterr) {
00272         cerrtr_(path, nout);
00273     }
00274     infoc_1.infot = 0;
00275 
00276     i__1 = *nn;
00277     for (in = 1; in <= i__1; ++in) {
00278 
00279 /*        Do for each value of N in NVAL */
00280 
00281         n = nval[in];
00282         lda = max(1,n);
00283         *(unsigned char *)xtype = 'N';
00284         nimat = 9;
00285         nimat2 = 17;
00286         if (n <= 0) {
00287             nimat = 1;
00288             nimat2 = 10;
00289         }
00290 
00291 /* Computing MIN */
00292         i__2 = n + 1;
00293         nk = min(i__2,4);
00294         i__2 = nk;
00295         for (ik = 1; ik <= i__2; ++ik) {
00296 
00297 /*           Do for KD = 0, N, (3N-1)/4, and (N+1)/4. This order makes */
00298 /*           it easier to skip redundant values for small values of N. */
00299 
00300             if (ik == 1) {
00301                 kd = 0;
00302             } else if (ik == 2) {
00303                 kd = max(n,0);
00304             } else if (ik == 3) {
00305                 kd = (n * 3 - 1) / 4;
00306             } else if (ik == 4) {
00307                 kd = (n + 1) / 4;
00308             }
00309             ldab = kd + 1;
00310 
00311             i__3 = nimat;
00312             for (imat = 1; imat <= i__3; ++imat) {
00313 
00314 /*              Do the tests only if DOTYPE( IMAT ) is true. */
00315 
00316                 if (! dotype[imat]) {
00317                     goto L90;
00318                 }
00319 
00320                 for (iuplo = 1; iuplo <= 2; ++iuplo) {
00321 
00322 /*                 Do first for UPLO = 'U', then for UPLO = 'L' */
00323 
00324                     *(unsigned char *)uplo = *(unsigned char *)&uplos[iuplo - 
00325                             1];
00326 
00327 /*                 Call CLATTB to generate a triangular test matrix. */
00328 
00329                     s_copy(srnamc_1.srnamt, "CLATTB", (ftnlen)32, (ftnlen)6);
00330                     clattb_(&imat, uplo, "No transpose", diag, iseed, &n, &kd, 
00331                              &ab[1], &ldab, &x[1], &work[1], &rwork[1], &info);
00332 
00333 /*                 Set IDIAG = 1 for non-unit matrices, 2 for unit. */
00334 
00335                     if (lsame_(diag, "N")) {
00336                         idiag = 1;
00337                     } else {
00338                         idiag = 2;
00339                     }
00340 
00341 /*                 Form the inverse of A so we can get a good estimate */
00342 /*                 of RCONDC = 1/(norm(A) * norm(inv(A))). */
00343 
00344                     claset_("Full", &n, &n, &c_b14, &c_b15, &ainv[1], &lda);
00345                     if (lsame_(uplo, "U")) {
00346                         i__4 = n;
00347                         for (j = 1; j <= i__4; ++j) {
00348                             ctbsv_(uplo, "No transpose", diag, &j, &kd, &ab[1]
00349 , &ldab, &ainv[(j - 1) * lda + 1], &c__1);
00350 /* L20: */
00351                         }
00352                     } else {
00353                         i__4 = n;
00354                         for (j = 1; j <= i__4; ++j) {
00355                             i__5 = n - j + 1;
00356                             ctbsv_(uplo, "No transpose", diag, &i__5, &kd, &
00357                                     ab[(j - 1) * ldab + 1], &ldab, &ainv[(j - 
00358                                     1) * lda + j], &c__1);
00359 /* L30: */
00360                         }
00361                     }
00362 
00363 /*                 Compute the 1-norm condition number of A. */
00364 
00365                     anorm = clantb_("1", uplo, diag, &n, &kd, &ab[1], &ldab, &
00366                             rwork[1]);
00367                     ainvnm = clantr_("1", uplo, diag, &n, &n, &ainv[1], &lda, 
00368                             &rwork[1]);
00369                     if (anorm <= 0.f || ainvnm <= 0.f) {
00370                         rcondo = 1.f;
00371                     } else {
00372                         rcondo = 1.f / anorm / ainvnm;
00373                     }
00374 
00375 /*                 Compute the infinity-norm condition number of A. */
00376 
00377                     anorm = clantb_("I", uplo, diag, &n, &kd, &ab[1], &ldab, &
00378                             rwork[1]);
00379                     ainvnm = clantr_("I", uplo, diag, &n, &n, &ainv[1], &lda, 
00380                             &rwork[1]);
00381                     if (anorm <= 0.f || ainvnm <= 0.f) {
00382                         rcondi = 1.f;
00383                     } else {
00384                         rcondi = 1.f / anorm / ainvnm;
00385                     }
00386 
00387                     i__4 = *nns;
00388                     for (irhs = 1; irhs <= i__4; ++irhs) {
00389                         nrhs = nsval[irhs];
00390                         *(unsigned char *)xtype = 'N';
00391 
00392                         for (itran = 1; itran <= 3; ++itran) {
00393 
00394 /*                    Do for op(A) = A, A**T, or A**H. */
00395 
00396                             *(unsigned char *)trans = *(unsigned char *)&
00397                                     transs[itran - 1];
00398                             if (itran == 1) {
00399                                 *(unsigned char *)norm = 'O';
00400                                 rcondc = rcondo;
00401                             } else {
00402                                 *(unsigned char *)norm = 'I';
00403                                 rcondc = rcondi;
00404                             }
00405 
00406 /* +    TEST 1 */
00407 /*                    Solve and compute residual for op(A)*x = b. */
00408 
00409                             s_copy(srnamc_1.srnamt, "CLARHS", (ftnlen)32, (
00410                                     ftnlen)6);
00411                             clarhs_(path, xtype, uplo, trans, &n, &n, &kd, &
00412                                     idiag, &nrhs, &ab[1], &ldab, &xact[1], &
00413                                     lda, &b[1], &lda, iseed, &info);
00414                             *(unsigned char *)xtype = 'C';
00415                             clacpy_("Full", &n, &nrhs, &b[1], &lda, &x[1], &
00416                                     lda);
00417 
00418                             s_copy(srnamc_1.srnamt, "CTBTRS", (ftnlen)32, (
00419                                     ftnlen)6);
00420                             ctbtrs_(uplo, trans, diag, &n, &kd, &nrhs, &ab[1], 
00421                                      &ldab, &x[1], &lda, &info);
00422 
00423 /*                    Check error code from CTBTRS. */
00424 
00425                             if (info != 0) {
00426 /* Writing concatenation */
00427                                 i__6[0] = 1, a__1[0] = uplo;
00428                                 i__6[1] = 1, a__1[1] = trans;
00429                                 i__6[2] = 1, a__1[2] = diag;
00430                                 s_cat(ch__1, a__1, i__6, &c__3, (ftnlen)3);
00431                                 alaerh_(path, "CTBTRS", &info, &c__0, ch__1, &
00432                                         n, &n, &kd, &kd, &nrhs, &imat, &nfail, 
00433                                          &nerrs, nout);
00434                             }
00435 
00436                             ctbt02_(uplo, trans, diag, &n, &kd, &nrhs, &ab[1], 
00437                                      &ldab, &x[1], &lda, &b[1], &lda, &work[1]
00438 , &rwork[1], result);
00439 
00440 /* +    TEST 2 */
00441 /*                    Check solution from generated exact solution. */
00442 
00443                             cget04_(&n, &nrhs, &x[1], &lda, &xact[1], &lda, &
00444                                     rcondc, &result[1]);
00445 
00446 /* +    TESTS 3, 4, and 5 */
00447 /*                    Use iterative refinement to improve the solution */
00448 /*                    and compute error bounds. */
00449 
00450                             s_copy(srnamc_1.srnamt, "CTBRFS", (ftnlen)32, (
00451                                     ftnlen)6);
00452                             ctbrfs_(uplo, trans, diag, &n, &kd, &nrhs, &ab[1], 
00453                                      &ldab, &b[1], &lda, &x[1], &lda, &rwork[
00454                                     1], &rwork[nrhs + 1], &work[1], &rwork[(
00455                                     nrhs << 1) + 1], &info);
00456 
00457 /*                    Check error code from CTBRFS. */
00458 
00459                             if (info != 0) {
00460 /* Writing concatenation */
00461                                 i__6[0] = 1, a__1[0] = uplo;
00462                                 i__6[1] = 1, a__1[1] = trans;
00463                                 i__6[2] = 1, a__1[2] = diag;
00464                                 s_cat(ch__1, a__1, i__6, &c__3, (ftnlen)3);
00465                                 alaerh_(path, "CTBRFS", &info, &c__0, ch__1, &
00466                                         n, &n, &kd, &kd, &nrhs, &imat, &nfail, 
00467                                          &nerrs, nout);
00468                             }
00469 
00470                             cget04_(&n, &nrhs, &x[1], &lda, &xact[1], &lda, &
00471                                     rcondc, &result[2]);
00472                             ctbt05_(uplo, trans, diag, &n, &kd, &nrhs, &ab[1], 
00473                                      &ldab, &b[1], &lda, &x[1], &lda, &xact[1]
00474 , &lda, &rwork[1], &rwork[nrhs + 1], &
00475                                     result[3]);
00476 
00477 /*                       Print information about the tests that did not */
00478 /*                       pass the threshold. */
00479 
00480                             for (k = 1; k <= 5; ++k) {
00481                                 if (result[k - 1] >= *thresh) {
00482                                     if (nfail == 0 && nerrs == 0) {
00483                                         alahd_(nout, path);
00484                                     }
00485                                     io___39.ciunit = *nout;
00486                                     s_wsfe(&io___39);
00487                                     do_fio(&c__1, uplo, (ftnlen)1);
00488                                     do_fio(&c__1, trans, (ftnlen)1);
00489                                     do_fio(&c__1, diag, (ftnlen)1);
00490                                     do_fio(&c__1, (char *)&n, (ftnlen)sizeof(
00491                                             integer));
00492                                     do_fio(&c__1, (char *)&kd, (ftnlen)sizeof(
00493                                             integer));
00494                                     do_fio(&c__1, (char *)&nrhs, (ftnlen)
00495                                             sizeof(integer));
00496                                     do_fio(&c__1, (char *)&imat, (ftnlen)
00497                                             sizeof(integer));
00498                                     do_fio(&c__1, (char *)&k, (ftnlen)sizeof(
00499                                             integer));
00500                                     do_fio(&c__1, (char *)&result[k - 1], (
00501                                             ftnlen)sizeof(real));
00502                                     e_wsfe();
00503                                     ++nfail;
00504                                 }
00505 /* L40: */
00506                             }
00507                             nrun += 5;
00508 /* L50: */
00509                         }
00510 /* L60: */
00511                     }
00512 
00513 /* +    TEST 6 */
00514 /*                    Get an estimate of RCOND = 1/CNDNUM. */
00515 
00516                     for (itran = 1; itran <= 2; ++itran) {
00517                         if (itran == 1) {
00518                             *(unsigned char *)norm = 'O';
00519                             rcondc = rcondo;
00520                         } else {
00521                             *(unsigned char *)norm = 'I';
00522                             rcondc = rcondi;
00523                         }
00524                         s_copy(srnamc_1.srnamt, "CTBCON", (ftnlen)32, (ftnlen)
00525                                 6);
00526                         ctbcon_(norm, uplo, diag, &n, &kd, &ab[1], &ldab, &
00527                                 rcond, &work[1], &rwork[1], &info);
00528 
00529 /*                    Check error code from CTBCON. */
00530 
00531                         if (info != 0) {
00532 /* Writing concatenation */
00533                             i__6[0] = 1, a__1[0] = norm;
00534                             i__6[1] = 1, a__1[1] = uplo;
00535                             i__6[2] = 1, a__1[2] = diag;
00536                             s_cat(ch__1, a__1, i__6, &c__3, (ftnlen)3);
00537                             alaerh_(path, "CTBCON", &info, &c__0, ch__1, &n, &
00538                                     n, &kd, &kd, &c_n1, &imat, &nfail, &nerrs, 
00539                                      nout);
00540                         }
00541 
00542                         ctbt06_(&rcond, &rcondc, uplo, diag, &n, &kd, &ab[1], 
00543                                 &ldab, &rwork[1], &result[5]);
00544 
00545 /*                    Print the test ratio if it is .GE. THRESH. */
00546 
00547                         if (result[5] >= *thresh) {
00548                             if (nfail == 0 && nerrs == 0) {
00549                                 alahd_(nout, path);
00550                             }
00551                             io___41.ciunit = *nout;
00552                             s_wsfe(&io___41);
00553                             do_fio(&c__1, "CTBCON", (ftnlen)6);
00554                             do_fio(&c__1, norm, (ftnlen)1);
00555                             do_fio(&c__1, uplo, (ftnlen)1);
00556                             do_fio(&c__1, diag, (ftnlen)1);
00557                             do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer))
00558                                     ;
00559                             do_fio(&c__1, (char *)&kd, (ftnlen)sizeof(integer)
00560                                     );
00561                             do_fio(&c__1, (char *)&imat, (ftnlen)sizeof(
00562                                     integer));
00563                             do_fio(&c__1, (char *)&c__6, (ftnlen)sizeof(
00564                                     integer));
00565                             do_fio(&c__1, (char *)&result[5], (ftnlen)sizeof(
00566                                     real));
00567                             e_wsfe();
00568                             ++nfail;
00569                         }
00570                         ++nrun;
00571 /* L70: */
00572                     }
00573 /* L80: */
00574                 }
00575 L90:
00576                 ;
00577             }
00578 
00579 /*           Use pathological test matrices to test CLATBS. */
00580 
00581             i__3 = nimat2;
00582             for (imat = 10; imat <= i__3; ++imat) {
00583 
00584 /*              Do the tests only if DOTYPE( IMAT ) is true. */
00585 
00586                 if (! dotype[imat]) {
00587                     goto L120;
00588                 }
00589 
00590                 for (iuplo = 1; iuplo <= 2; ++iuplo) {
00591 
00592 /*                 Do first for UPLO = 'U', then for UPLO = 'L' */
00593 
00594                     *(unsigned char *)uplo = *(unsigned char *)&uplos[iuplo - 
00595                             1];
00596                     for (itran = 1; itran <= 3; ++itran) {
00597 
00598 /*                    Do for op(A) = A, A**T, and A**H. */
00599 
00600                         *(unsigned char *)trans = *(unsigned char *)&transs[
00601                                 itran - 1];
00602 
00603 /*                    Call CLATTB to generate a triangular test matrix. */
00604 
00605                         s_copy(srnamc_1.srnamt, "CLATTB", (ftnlen)32, (ftnlen)
00606                                 6);
00607                         clattb_(&imat, uplo, trans, diag, iseed, &n, &kd, &ab[
00608                                 1], &ldab, &x[1], &work[1], &rwork[1], &info);
00609 
00610 /* +    TEST 7 */
00611 /*                    Solve the system op(A)*x = b */
00612 
00613                         s_copy(srnamc_1.srnamt, "CLATBS", (ftnlen)32, (ftnlen)
00614                                 6);
00615                         ccopy_(&n, &x[1], &c__1, &b[1], &c__1);
00616                         clatbs_(uplo, trans, diag, "N", &n, &kd, &ab[1], &
00617                                 ldab, &b[1], &scale, &rwork[1], &info);
00618 
00619 /*                    Check error code from CLATBS. */
00620 
00621                         if (info != 0) {
00622 /* Writing concatenation */
00623                             i__7[0] = 1, a__2[0] = uplo;
00624                             i__7[1] = 1, a__2[1] = trans;
00625                             i__7[2] = 1, a__2[2] = diag;
00626                             i__7[3] = 1, a__2[3] = "N";
00627                             s_cat(ch__2, a__2, i__7, &c__4, (ftnlen)4);
00628                             alaerh_(path, "CLATBS", &info, &c__0, ch__2, &n, &
00629                                     n, &kd, &kd, &c_n1, &imat, &nfail, &nerrs, 
00630                                      nout);
00631                         }
00632 
00633                         ctbt03_(uplo, trans, diag, &n, &kd, &c__1, &ab[1], &
00634                                 ldab, &scale, &rwork[1], &c_b90, &b[1], &lda, 
00635                                 &x[1], &lda, &work[1], &result[6]);
00636 
00637 /* +    TEST 8 */
00638 /*                    Solve op(A)*x = b again with NORMIN = 'Y'. */
00639 
00640                         ccopy_(&n, &x[1], &c__1, &b[1], &c__1);
00641                         clatbs_(uplo, trans, diag, "Y", &n, &kd, &ab[1], &
00642                                 ldab, &b[1], &scale, &rwork[1], &info);
00643 
00644 /*                    Check error code from CLATBS. */
00645 
00646                         if (info != 0) {
00647 /* Writing concatenation */
00648                             i__7[0] = 1, a__2[0] = uplo;
00649                             i__7[1] = 1, a__2[1] = trans;
00650                             i__7[2] = 1, a__2[2] = diag;
00651                             i__7[3] = 1, a__2[3] = "Y";
00652                             s_cat(ch__2, a__2, i__7, &c__4, (ftnlen)4);
00653                             alaerh_(path, "CLATBS", &info, &c__0, ch__2, &n, &
00654                                     n, &kd, &kd, &c_n1, &imat, &nfail, &nerrs, 
00655                                      nout);
00656                         }
00657 
00658                         ctbt03_(uplo, trans, diag, &n, &kd, &c__1, &ab[1], &
00659                                 ldab, &scale, &rwork[1], &c_b90, &b[1], &lda, 
00660                                 &x[1], &lda, &work[1], &result[7]);
00661 
00662 /*                    Print information about the tests that did not pass */
00663 /*                    the threshold. */
00664 
00665                         if (result[6] >= *thresh) {
00666                             if (nfail == 0 && nerrs == 0) {
00667                                 alahd_(nout, path);
00668                             }
00669                             io___43.ciunit = *nout;
00670                             s_wsfe(&io___43);
00671                             do_fio(&c__1, "CLATBS", (ftnlen)6);
00672                             do_fio(&c__1, uplo, (ftnlen)1);
00673                             do_fio(&c__1, trans, (ftnlen)1);
00674                             do_fio(&c__1, diag, (ftnlen)1);
00675                             do_fio(&c__1, "N", (ftnlen)1);
00676                             do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer))
00677                                     ;
00678                             do_fio(&c__1, (char *)&kd, (ftnlen)sizeof(integer)
00679                                     );
00680                             do_fio(&c__1, (char *)&imat, (ftnlen)sizeof(
00681                                     integer));
00682                             do_fio(&c__1, (char *)&c__7, (ftnlen)sizeof(
00683                                     integer));
00684                             do_fio(&c__1, (char *)&result[6], (ftnlen)sizeof(
00685                                     real));
00686                             e_wsfe();
00687                             ++nfail;
00688                         }
00689                         if (result[7] >= *thresh) {
00690                             if (nfail == 0 && nerrs == 0) {
00691                                 alahd_(nout, path);
00692                             }
00693                             io___44.ciunit = *nout;
00694                             s_wsfe(&io___44);
00695                             do_fio(&c__1, "CLATBS", (ftnlen)6);
00696                             do_fio(&c__1, uplo, (ftnlen)1);
00697                             do_fio(&c__1, trans, (ftnlen)1);
00698                             do_fio(&c__1, diag, (ftnlen)1);
00699                             do_fio(&c__1, "Y", (ftnlen)1);
00700                             do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer))
00701                                     ;
00702                             do_fio(&c__1, (char *)&kd, (ftnlen)sizeof(integer)
00703                                     );
00704                             do_fio(&c__1, (char *)&imat, (ftnlen)sizeof(
00705                                     integer));
00706                             do_fio(&c__1, (char *)&c__8, (ftnlen)sizeof(
00707                                     integer));
00708                             do_fio(&c__1, (char *)&result[7], (ftnlen)sizeof(
00709                                     real));
00710                             e_wsfe();
00711                             ++nfail;
00712                         }
00713                         nrun += 2;
00714 /* L100: */
00715                     }
00716 /* L110: */
00717                 }
00718 L120:
00719                 ;
00720             }
00721 /* L130: */
00722         }
00723 /* L140: */
00724     }
00725 
00726 /*     Print a summary of the results. */
00727 
00728     alasum_(path, nout, &nfail, &nrun, &nerrs);
00729 
00730     return 0;
00731 
00732 /*     End of CCHKTB */
00733 
00734 } /* cchktb_ */

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