ddrvgt.c
Go to the documentation of this file.
00001 /* ddrvgt.f -- translated by f2c (version 20061008).
00002    You must link the resulting object file with libf2c:
00003         on Microsoft Windows system, link with libf2c.lib;
00004         on Linux or Unix systems, link with .../path/to/libf2c.a -lm
00005         or, if you install libf2c.a in a standard place, with -lf2c -lm
00006         -- in that order, at the end of the command line, as in
00007                 cc *.o -lf2c -lm
00008         Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
00009 
00010                 http://www.netlib.org/f2c/libf2c.zip
00011 */
00012 
00013 #include "f2c.h"
00014 #include "blaswrap.h"
00015 
00016 /* Common Block Declarations */
00017 
00018 struct {
00019     integer infot, nunit;
00020     logical ok, lerr;
00021 } infoc_;
00022 
00023 #define infoc_1 infoc_
00024 
00025 struct {
00026     char srnamt[32];
00027 } srnamc_;
00028 
00029 #define srnamc_1 srnamc_
00030 
00031 /* Table of constant values */
00032 
00033 static integer c__3 = 3;
00034 static integer c__0 = 0;
00035 static integer c_n1 = -1;
00036 static integer c__1 = 1;
00037 static integer c__2 = 2;
00038 static doublereal c_b43 = 1.;
00039 static doublereal c_b44 = 0.;
00040 
00041 /* Subroutine */ int ddrvgt_(logical *dotype, integer *nn, integer *nval, 
00042         integer *nrhs, doublereal *thresh, logical *tsterr, doublereal *a, 
00043         doublereal *af, doublereal *b, doublereal *x, doublereal *xact, 
00044         doublereal *work, doublereal *rwork, integer *iwork, integer *nout)
00045 {
00046     /* Initialized data */
00047 
00048     static integer iseedy[4] = { 0,0,0,1 };
00049     static char transs[1*3] = "N" "T" "C";
00050 
00051     /* Format strings */
00052     static char fmt_9999[] = "(1x,a,\002, N =\002,i5,\002, type \002,i2,\002"
00053             ", test \002,i2,\002, ratio = \002,g12.5)";
00054     static char fmt_9998[] = "(1x,a,\002, FACT='\002,a1,\002', TRANS='\002,a"
00055             "1,\002', N =\002,i5,\002, type \002,i2,\002, test \002,i2,\002, "
00056             "ratio = \002,g12.5)";
00057 
00058     /* System generated locals */
00059     address a__1[2];
00060     integer i__1, i__2, i__3, i__4, i__5[2];
00061     doublereal d__1, d__2;
00062     char ch__1[2];
00063 
00064     /* Builtin functions */
00065     /* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);
00066     integer s_wsfe(cilist *), do_fio(integer *, char *, ftnlen), e_wsfe(void);
00067     /* Subroutine */ int s_cat(char *, char **, integer *, integer *, ftnlen);
00068 
00069     /* Local variables */
00070     integer i__, j, k, m, n;
00071     doublereal z__[3];
00072     integer k1, in, kl, ku, ix, nt, lda;
00073     char fact[1];
00074     doublereal cond;
00075     integer mode, koff, imat, info;
00076     char path[3], dist[1], type__[1];
00077     integer nrun, ifact;
00078     extern /* Subroutine */ int dget04_(integer *, integer *, doublereal *, 
00079             integer *, doublereal *, integer *, doublereal *, doublereal *), 
00080             dscal_(integer *, doublereal *, doublereal *, integer *);
00081     integer nfail, iseed[4];
00082     extern doublereal dget06_(doublereal *, doublereal *);
00083     extern /* Subroutine */ int dgtt01_(integer *, doublereal *, doublereal *, 
00084              doublereal *, doublereal *, doublereal *, doublereal *, 
00085             doublereal *, integer *, doublereal *, integer *, doublereal *, 
00086             doublereal *), dgtt02_(char *, integer *, integer *, doublereal *, 
00087              doublereal *, doublereal *, doublereal *, integer *, doublereal *
00088 , integer *, doublereal *, doublereal *);
00089     doublereal rcond;
00090     extern /* Subroutine */ int dgtt05_(char *, integer *, integer *, 
00091             doublereal *, doublereal *, doublereal *, doublereal *, integer *, 
00092              doublereal *, integer *, doublereal *, integer *, doublereal *, 
00093             doublereal *, doublereal *);
00094     integer nimat;
00095     extern doublereal dasum_(integer *, doublereal *, integer *);
00096     doublereal anorm;
00097     integer itran;
00098     extern /* Subroutine */ int dcopy_(integer *, doublereal *, integer *, 
00099             doublereal *, integer *);
00100     char trans[1];
00101     integer izero, nerrs;
00102     extern /* Subroutine */ int dgtsv_(integer *, integer *, doublereal *, 
00103             doublereal *, doublereal *, doublereal *, integer *, integer *);
00104     logical zerot;
00105     extern /* Subroutine */ int dlatb4_(char *, integer *, integer *, integer 
00106             *, char *, integer *, integer *, doublereal *, integer *, 
00107             doublereal *, char *), aladhd_(integer *, 
00108             char *), alaerh_(char *, char *, integer *, integer *, 
00109             char *, integer *, integer *, integer *, integer *, integer *, 
00110             integer *, integer *, integer *, integer *);
00111     doublereal rcondc;
00112     extern doublereal dlangt_(char *, integer *, doublereal *, doublereal *, 
00113             doublereal *);
00114     extern /* Subroutine */ int dlagtm_(char *, integer *, integer *, 
00115             doublereal *, doublereal *, doublereal *, doublereal *, 
00116             doublereal *, integer *, doublereal *, doublereal *, integer *), dlacpy_(char *, integer *, integer *, doublereal *, 
00117             integer *, doublereal *, integer *), dlaset_(char *, 
00118             integer *, integer *, doublereal *, doublereal *, doublereal *, 
00119             integer *);
00120     doublereal rcondi;
00121     extern /* Subroutine */ int alasvm_(char *, integer *, integer *, integer 
00122             *, integer *);
00123     doublereal rcondo, anormi;
00124     extern /* Subroutine */ int dlarnv_(integer *, integer *, integer *, 
00125             doublereal *), dlatms_(integer *, integer *, char *, integer *, 
00126             char *, doublereal *, integer *, doublereal *, doublereal *, 
00127             integer *, integer *, char *, doublereal *, integer *, doublereal 
00128             *, integer *);
00129     doublereal ainvnm;
00130     logical trfcon;
00131     doublereal anormo;
00132     extern /* Subroutine */ int dgttrf_(integer *, doublereal *, doublereal *, 
00133              doublereal *, doublereal *, integer *, integer *), dgttrs_(char *
00134 , integer *, integer *, doublereal *, doublereal *, doublereal *, 
00135             doublereal *, integer *, doublereal *, integer *, integer *), derrvx_(char *, integer *);
00136     doublereal result[6];
00137     extern /* Subroutine */ int dgtsvx_(char *, char *, integer *, integer *, 
00138             doublereal *, doublereal *, doublereal *, doublereal *, 
00139             doublereal *, doublereal *, doublereal *, integer *, doublereal *, 
00140              integer *, doublereal *, integer *, doublereal *, doublereal *, 
00141             doublereal *, doublereal *, integer *, integer *);
00142 
00143     /* Fortran I/O blocks */
00144     static cilist io___42 = { 0, 0, 0, fmt_9999, 0 };
00145     static cilist io___46 = { 0, 0, 0, fmt_9998, 0 };
00146     static cilist io___47 = { 0, 0, 0, fmt_9998, 0 };
00147 
00148 
00149 
00150 /*  -- LAPACK test routine (version 3.1) -- */
00151 /*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
00152 /*     November 2006 */
00153 
00154 /*     .. Scalar Arguments .. */
00155 /*     .. */
00156 /*     .. Array Arguments .. */
00157 /*     .. */
00158 
00159 /*  Purpose */
00160 /*  ======= */
00161 
00162 /*  DDRVGT tests DGTSV and -SVX. */
00163 
00164 /*  Arguments */
00165 /*  ========= */
00166 
00167 /*  DOTYPE  (input) LOGICAL array, dimension (NTYPES) */
00168 /*          The matrix types to be used for testing.  Matrices of type j */
00169 /*          (for 1 <= j <= NTYPES) are used for testing if DOTYPE(j) = */
00170 /*          .TRUE.; if DOTYPE(j) = .FALSE., then type j is not used. */
00171 
00172 /*  NN      (input) INTEGER */
00173 /*          The number of values of N contained in the vector NVAL. */
00174 
00175 /*  NVAL    (input) INTEGER array, dimension (NN) */
00176 /*          The values of the matrix dimension N. */
00177 
00178 /*  THRESH  (input) DOUBLE PRECISION */
00179 /*          The threshold value for the test ratios.  A result is */
00180 /*          included in the output file if RESULT >= THRESH.  To have */
00181 /*          every test ratio printed, use THRESH = 0. */
00182 
00183 /*  TSTERR  (input) LOGICAL */
00184 /*          Flag that indicates whether error exits are to be tested. */
00185 
00186 /*  A       (workspace) DOUBLE PRECISION array, dimension (NMAX*4) */
00187 
00188 /*  AF      (workspace) DOUBLE PRECISION array, dimension (NMAX*4) */
00189 
00190 /*  B       (workspace) DOUBLE PRECISION array, dimension (NMAX*NRHS) */
00191 
00192 /*  X       (workspace) DOUBLE PRECISION array, dimension (NMAX*NRHS) */
00193 
00194 /*  XACT    (workspace) DOUBLE PRECISION array, dimension (NMAX*NRHS) */
00195 
00196 /*  WORK    (workspace) DOUBLE PRECISION array, dimension */
00197 /*                      (NMAX*max(3,NRHS)) */
00198 
00199 /*  RWORK   (workspace) DOUBLE PRECISION array, dimension */
00200 /*                      (max(NMAX,2*NRHS)) */
00201 
00202 /*  IWORK   (workspace) INTEGER array, dimension (2*NMAX) */
00203 
00204 /*  NOUT    (input) INTEGER */
00205 /*          The unit number for output. */
00206 
00207 /*  ===================================================================== */
00208 
00209 /*     .. Parameters .. */
00210 /*     .. */
00211 /*     .. Local Scalars .. */
00212 /*     .. */
00213 /*     .. Local Arrays .. */
00214 /*     .. */
00215 /*     .. External Functions .. */
00216 /*     .. */
00217 /*     .. External Subroutines .. */
00218 /*     .. */
00219 /*     .. Intrinsic Functions .. */
00220 /*     .. */
00221 /*     .. Scalars in Common .. */
00222 /*     .. */
00223 /*     .. Common blocks .. */
00224 /*     .. */
00225 /*     .. Data statements .. */
00226     /* Parameter adjustments */
00227     --iwork;
00228     --rwork;
00229     --work;
00230     --xact;
00231     --x;
00232     --b;
00233     --af;
00234     --a;
00235     --nval;
00236     --dotype;
00237 
00238     /* Function Body */
00239 /*     .. */
00240 /*     .. Executable Statements .. */
00241 
00242     s_copy(path, "Double precision", (ftnlen)1, (ftnlen)16);
00243     s_copy(path + 1, "GT", (ftnlen)2, (ftnlen)2);
00244     nrun = 0;
00245     nfail = 0;
00246     nerrs = 0;
00247     for (i__ = 1; i__ <= 4; ++i__) {
00248         iseed[i__ - 1] = iseedy[i__ - 1];
00249 /* L10: */
00250     }
00251 
00252 /*     Test the error exits */
00253 
00254     if (*tsterr) {
00255         derrvx_(path, nout);
00256     }
00257     infoc_1.infot = 0;
00258 
00259     i__1 = *nn;
00260     for (in = 1; in <= i__1; ++in) {
00261 
00262 /*        Do for each value of N in NVAL. */
00263 
00264         n = nval[in];
00265 /* Computing MAX */
00266         i__2 = n - 1;
00267         m = max(i__2,0);
00268         lda = max(1,n);
00269         nimat = 12;
00270         if (n <= 0) {
00271             nimat = 1;
00272         }
00273 
00274         i__2 = nimat;
00275         for (imat = 1; imat <= i__2; ++imat) {
00276 
00277 /*           Do the tests only if DOTYPE( IMAT ) is true. */
00278 
00279             if (! dotype[imat]) {
00280                 goto L130;
00281             }
00282 
00283 /*           Set up parameters with DLATB4. */
00284 
00285             dlatb4_(path, &imat, &n, &n, type__, &kl, &ku, &anorm, &mode, &
00286                     cond, dist);
00287 
00288             zerot = imat >= 8 && imat <= 10;
00289             if (imat <= 6) {
00290 
00291 /*              Types 1-6:  generate matrices of known condition number. */
00292 
00293 /* Computing MAX */
00294                 i__3 = 2 - ku, i__4 = 3 - max(1,n);
00295                 koff = max(i__3,i__4);
00296                 s_copy(srnamc_1.srnamt, "DLATMS", (ftnlen)32, (ftnlen)6);
00297                 dlatms_(&n, &n, dist, iseed, type__, &rwork[1], &mode, &cond, 
00298                         &anorm, &kl, &ku, "Z", &af[koff], &c__3, &work[1], &
00299                         info);
00300 
00301 /*              Check the error code from DLATMS. */
00302 
00303                 if (info != 0) {
00304                     alaerh_(path, "DLATMS", &info, &c__0, " ", &n, &n, &kl, &
00305                             ku, &c_n1, &imat, &nfail, &nerrs, nout);
00306                     goto L130;
00307                 }
00308                 izero = 0;
00309 
00310                 if (n > 1) {
00311                     i__3 = n - 1;
00312                     dcopy_(&i__3, &af[4], &c__3, &a[1], &c__1);
00313                     i__3 = n - 1;
00314                     dcopy_(&i__3, &af[3], &c__3, &a[n + m + 1], &c__1);
00315                 }
00316                 dcopy_(&n, &af[2], &c__3, &a[m + 1], &c__1);
00317             } else {
00318 
00319 /*              Types 7-12:  generate tridiagonal matrices with */
00320 /*              unknown condition numbers. */
00321 
00322                 if (! zerot || ! dotype[7]) {
00323 
00324 /*                 Generate a matrix with elements from [-1,1]. */
00325 
00326                     i__3 = n + (m << 1);
00327                     dlarnv_(&c__2, iseed, &i__3, &a[1]);
00328                     if (anorm != 1.) {
00329                         i__3 = n + (m << 1);
00330                         dscal_(&i__3, &anorm, &a[1], &c__1);
00331                     }
00332                 } else if (izero > 0) {
00333 
00334 /*                 Reuse the last matrix by copying back the zeroed out */
00335 /*                 elements. */
00336 
00337                     if (izero == 1) {
00338                         a[n] = z__[1];
00339                         if (n > 1) {
00340                             a[1] = z__[2];
00341                         }
00342                     } else if (izero == n) {
00343                         a[n * 3 - 2] = z__[0];
00344                         a[(n << 1) - 1] = z__[1];
00345                     } else {
00346                         a[(n << 1) - 2 + izero] = z__[0];
00347                         a[n - 1 + izero] = z__[1];
00348                         a[izero] = z__[2];
00349                     }
00350                 }
00351 
00352 /*              If IMAT > 7, set one column of the matrix to 0. */
00353 
00354                 if (! zerot) {
00355                     izero = 0;
00356                 } else if (imat == 8) {
00357                     izero = 1;
00358                     z__[1] = a[n];
00359                     a[n] = 0.;
00360                     if (n > 1) {
00361                         z__[2] = a[1];
00362                         a[1] = 0.;
00363                     }
00364                 } else if (imat == 9) {
00365                     izero = n;
00366                     z__[0] = a[n * 3 - 2];
00367                     z__[1] = a[(n << 1) - 1];
00368                     a[n * 3 - 2] = 0.;
00369                     a[(n << 1) - 1] = 0.;
00370                 } else {
00371                     izero = (n + 1) / 2;
00372                     i__3 = n - 1;
00373                     for (i__ = izero; i__ <= i__3; ++i__) {
00374                         a[(n << 1) - 2 + i__] = 0.;
00375                         a[n - 1 + i__] = 0.;
00376                         a[i__] = 0.;
00377 /* L20: */
00378                     }
00379                     a[n * 3 - 2] = 0.;
00380                     a[(n << 1) - 1] = 0.;
00381                 }
00382             }
00383 
00384             for (ifact = 1; ifact <= 2; ++ifact) {
00385                 if (ifact == 1) {
00386                     *(unsigned char *)fact = 'F';
00387                 } else {
00388                     *(unsigned char *)fact = 'N';
00389                 }
00390 
00391 /*              Compute the condition number for comparison with */
00392 /*              the value returned by DGTSVX. */
00393 
00394                 if (zerot) {
00395                     if (ifact == 1) {
00396                         goto L120;
00397                     }
00398                     rcondo = 0.;
00399                     rcondi = 0.;
00400 
00401                 } else if (ifact == 1) {
00402                     i__3 = n + (m << 1);
00403                     dcopy_(&i__3, &a[1], &c__1, &af[1], &c__1);
00404 
00405 /*                 Compute the 1-norm and infinity-norm of A. */
00406 
00407                     anormo = dlangt_("1", &n, &a[1], &a[m + 1], &a[n + m + 1]);
00408                     anormi = dlangt_("I", &n, &a[1], &a[m + 1], &a[n + m + 1]);
00409 
00410 /*                 Factor the matrix A. */
00411 
00412                     dgttrf_(&n, &af[1], &af[m + 1], &af[n + m + 1], &af[n + (
00413                             m << 1) + 1], &iwork[1], &info);
00414 
00415 /*                 Use DGTTRS to solve for one column at a time of */
00416 /*                 inv(A), computing the maximum column sum as we go. */
00417 
00418                     ainvnm = 0.;
00419                     i__3 = n;
00420                     for (i__ = 1; i__ <= i__3; ++i__) {
00421                         i__4 = n;
00422                         for (j = 1; j <= i__4; ++j) {
00423                             x[j] = 0.;
00424 /* L30: */
00425                         }
00426                         x[i__] = 1.;
00427                         dgttrs_("No transpose", &n, &c__1, &af[1], &af[m + 1], 
00428                                  &af[n + m + 1], &af[n + (m << 1) + 1], &
00429                                 iwork[1], &x[1], &lda, &info);
00430 /* Computing MAX */
00431                         d__1 = ainvnm, d__2 = dasum_(&n, &x[1], &c__1);
00432                         ainvnm = max(d__1,d__2);
00433 /* L40: */
00434                     }
00435 
00436 /*                 Compute the 1-norm condition number of A. */
00437 
00438                     if (anormo <= 0. || ainvnm <= 0.) {
00439                         rcondo = 1.;
00440                     } else {
00441                         rcondo = 1. / anormo / ainvnm;
00442                     }
00443 
00444 /*                 Use DGTTRS to solve for one column at a time of */
00445 /*                 inv(A'), computing the maximum column sum as we go. */
00446 
00447                     ainvnm = 0.;
00448                     i__3 = n;
00449                     for (i__ = 1; i__ <= i__3; ++i__) {
00450                         i__4 = n;
00451                         for (j = 1; j <= i__4; ++j) {
00452                             x[j] = 0.;
00453 /* L50: */
00454                         }
00455                         x[i__] = 1.;
00456                         dgttrs_("Transpose", &n, &c__1, &af[1], &af[m + 1], &
00457                                 af[n + m + 1], &af[n + (m << 1) + 1], &iwork[
00458                                 1], &x[1], &lda, &info);
00459 /* Computing MAX */
00460                         d__1 = ainvnm, d__2 = dasum_(&n, &x[1], &c__1);
00461                         ainvnm = max(d__1,d__2);
00462 /* L60: */
00463                     }
00464 
00465 /*                 Compute the infinity-norm condition number of A. */
00466 
00467                     if (anormi <= 0. || ainvnm <= 0.) {
00468                         rcondi = 1.;
00469                     } else {
00470                         rcondi = 1. / anormi / ainvnm;
00471                     }
00472                 }
00473 
00474                 for (itran = 1; itran <= 3; ++itran) {
00475                     *(unsigned char *)trans = *(unsigned char *)&transs[itran 
00476                             - 1];
00477                     if (itran == 1) {
00478                         rcondc = rcondo;
00479                     } else {
00480                         rcondc = rcondi;
00481                     }
00482 
00483 /*                 Generate NRHS random solution vectors. */
00484 
00485                     ix = 1;
00486                     i__3 = *nrhs;
00487                     for (j = 1; j <= i__3; ++j) {
00488                         dlarnv_(&c__2, iseed, &n, &xact[ix]);
00489                         ix += lda;
00490 /* L70: */
00491                     }
00492 
00493 /*                 Set the right hand side. */
00494 
00495                     dlagtm_(trans, &n, nrhs, &c_b43, &a[1], &a[m + 1], &a[n + 
00496                             m + 1], &xact[1], &lda, &c_b44, &b[1], &lda);
00497 
00498                     if (ifact == 2 && itran == 1) {
00499 
00500 /*                    --- Test DGTSV  --- */
00501 
00502 /*                    Solve the system using Gaussian elimination with */
00503 /*                    partial pivoting. */
00504 
00505                         i__3 = n + (m << 1);
00506                         dcopy_(&i__3, &a[1], &c__1, &af[1], &c__1);
00507                         dlacpy_("Full", &n, nrhs, &b[1], &lda, &x[1], &lda);
00508 
00509                         s_copy(srnamc_1.srnamt, "DGTSV ", (ftnlen)32, (ftnlen)
00510                                 6);
00511                         dgtsv_(&n, nrhs, &af[1], &af[m + 1], &af[n + m + 1], &
00512                                 x[1], &lda, &info);
00513 
00514 /*                    Check error code from DGTSV . */
00515 
00516                         if (info != izero) {
00517                             alaerh_(path, "DGTSV ", &info, &izero, " ", &n, &
00518                                     n, &c__1, &c__1, nrhs, &imat, &nfail, &
00519                                     nerrs, nout);
00520                         }
00521                         nt = 1;
00522                         if (izero == 0) {
00523 
00524 /*                       Check residual of computed solution. */
00525 
00526                             dlacpy_("Full", &n, nrhs, &b[1], &lda, &work[1], &
00527                                     lda);
00528                             dgtt02_(trans, &n, nrhs, &a[1], &a[m + 1], &a[n + 
00529                                     m + 1], &x[1], &lda, &work[1], &lda, &
00530                                     rwork[1], &result[1]);
00531 
00532 /*                       Check solution from generated exact solution. */
00533 
00534                             dget04_(&n, nrhs, &x[1], &lda, &xact[1], &lda, &
00535                                     rcondc, &result[2]);
00536                             nt = 3;
00537                         }
00538 
00539 /*                    Print information about the tests that did not pass */
00540 /*                    the threshold. */
00541 
00542                         i__3 = nt;
00543                         for (k = 2; k <= i__3; ++k) {
00544                             if (result[k - 1] >= *thresh) {
00545                                 if (nfail == 0 && nerrs == 0) {
00546                                     aladhd_(nout, path);
00547                                 }
00548                                 io___42.ciunit = *nout;
00549                                 s_wsfe(&io___42);
00550                                 do_fio(&c__1, "DGTSV ", (ftnlen)6);
00551                                 do_fio(&c__1, (char *)&n, (ftnlen)sizeof(
00552                                         integer));
00553                                 do_fio(&c__1, (char *)&imat, (ftnlen)sizeof(
00554                                         integer));
00555                                 do_fio(&c__1, (char *)&k, (ftnlen)sizeof(
00556                                         integer));
00557                                 do_fio(&c__1, (char *)&result[k - 1], (ftnlen)
00558                                         sizeof(doublereal));
00559                                 e_wsfe();
00560                                 ++nfail;
00561                             }
00562 /* L80: */
00563                         }
00564                         nrun = nrun + nt - 1;
00565                     }
00566 
00567 /*                 --- Test DGTSVX --- */
00568 
00569                     if (ifact > 1) {
00570 
00571 /*                    Initialize AF to zero. */
00572 
00573                         i__3 = n * 3 - 2;
00574                         for (i__ = 1; i__ <= i__3; ++i__) {
00575                             af[i__] = 0.;
00576 /* L90: */
00577                         }
00578                     }
00579                     dlaset_("Full", &n, nrhs, &c_b44, &c_b44, &x[1], &lda);
00580 
00581 /*                 Solve the system and compute the condition number and */
00582 /*                 error bounds using DGTSVX. */
00583 
00584                     s_copy(srnamc_1.srnamt, "DGTSVX", (ftnlen)32, (ftnlen)6);
00585                     dgtsvx_(fact, trans, &n, nrhs, &a[1], &a[m + 1], &a[n + m 
00586                             + 1], &af[1], &af[m + 1], &af[n + m + 1], &af[n + 
00587                             (m << 1) + 1], &iwork[1], &b[1], &lda, &x[1], &
00588                             lda, &rcond, &rwork[1], &rwork[*nrhs + 1], &work[
00589                             1], &iwork[n + 1], &info);
00590 
00591 /*                 Check the error code from DGTSVX. */
00592 
00593                     if (info != izero) {
00594 /* Writing concatenation */
00595                         i__5[0] = 1, a__1[0] = fact;
00596                         i__5[1] = 1, a__1[1] = trans;
00597                         s_cat(ch__1, a__1, i__5, &c__2, (ftnlen)2);
00598                         alaerh_(path, "DGTSVX", &info, &izero, ch__1, &n, &n, 
00599                                 &c__1, &c__1, nrhs, &imat, &nfail, &nerrs, 
00600                                 nout);
00601                     }
00602 
00603                     if (ifact >= 2) {
00604 
00605 /*                    Reconstruct matrix from factors and compute */
00606 /*                    residual. */
00607 
00608                         dgtt01_(&n, &a[1], &a[m + 1], &a[n + m + 1], &af[1], &
00609                                 af[m + 1], &af[n + m + 1], &af[n + (m << 1) + 
00610                                 1], &iwork[1], &work[1], &lda, &rwork[1], 
00611                                 result);
00612                         k1 = 1;
00613                     } else {
00614                         k1 = 2;
00615                     }
00616 
00617                     if (info == 0) {
00618                         trfcon = FALSE_;
00619 
00620 /*                    Check residual of computed solution. */
00621 
00622                         dlacpy_("Full", &n, nrhs, &b[1], &lda, &work[1], &lda);
00623                         dgtt02_(trans, &n, nrhs, &a[1], &a[m + 1], &a[n + m + 
00624                                 1], &x[1], &lda, &work[1], &lda, &rwork[1], &
00625                                 result[1]);
00626 
00627 /*                    Check solution from generated exact solution. */
00628 
00629                         dget04_(&n, nrhs, &x[1], &lda, &xact[1], &lda, &
00630                                 rcondc, &result[2]);
00631 
00632 /*                    Check the error bounds from iterative refinement. */
00633 
00634                         dgtt05_(trans, &n, nrhs, &a[1], &a[m + 1], &a[n + m + 
00635                                 1], &b[1], &lda, &x[1], &lda, &xact[1], &lda, 
00636                                 &rwork[1], &rwork[*nrhs + 1], &result[3]);
00637                         nt = 5;
00638                     }
00639 
00640 /*                 Print information about the tests that did not pass */
00641 /*                 the threshold. */
00642 
00643                     i__3 = nt;
00644                     for (k = k1; k <= i__3; ++k) {
00645                         if (result[k - 1] >= *thresh) {
00646                             if (nfail == 0 && nerrs == 0) {
00647                                 aladhd_(nout, path);
00648                             }
00649                             io___46.ciunit = *nout;
00650                             s_wsfe(&io___46);
00651                             do_fio(&c__1, "DGTSVX", (ftnlen)6);
00652                             do_fio(&c__1, fact, (ftnlen)1);
00653                             do_fio(&c__1, trans, (ftnlen)1);
00654                             do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer))
00655                                     ;
00656                             do_fio(&c__1, (char *)&imat, (ftnlen)sizeof(
00657                                     integer));
00658                             do_fio(&c__1, (char *)&k, (ftnlen)sizeof(integer))
00659                                     ;
00660                             do_fio(&c__1, (char *)&result[k - 1], (ftnlen)
00661                                     sizeof(doublereal));
00662                             e_wsfe();
00663                             ++nfail;
00664                         }
00665 /* L100: */
00666                     }
00667 
00668 /*                 Check the reciprocal of the condition number. */
00669 
00670                     result[5] = dget06_(&rcond, &rcondc);
00671                     if (result[5] >= *thresh) {
00672                         if (nfail == 0 && nerrs == 0) {
00673                             aladhd_(nout, path);
00674                         }
00675                         io___47.ciunit = *nout;
00676                         s_wsfe(&io___47);
00677                         do_fio(&c__1, "DGTSVX", (ftnlen)6);
00678                         do_fio(&c__1, fact, (ftnlen)1);
00679                         do_fio(&c__1, trans, (ftnlen)1);
00680                         do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
00681                         do_fio(&c__1, (char *)&imat, (ftnlen)sizeof(integer));
00682                         do_fio(&c__1, (char *)&k, (ftnlen)sizeof(integer));
00683                         do_fio(&c__1, (char *)&result[k - 1], (ftnlen)sizeof(
00684                                 doublereal));
00685                         e_wsfe();
00686                         ++nfail;
00687                     }
00688                     nrun = nrun + nt - k1 + 2;
00689 
00690 /* L110: */
00691                 }
00692 L120:
00693                 ;
00694             }
00695 L130:
00696             ;
00697         }
00698 /* L140: */
00699     }
00700 
00701 /*     Print a summary of the results. */
00702 
00703     alasvm_(path, nout, &nfail, &nrun, &nerrs);
00704 
00705     return 0;
00706 
00707 /*     End of DDRVGT */
00708 
00709 } /* ddrvgt_ */


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