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


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