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


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