ddrvge.c
Go to the documentation of this file.
00001 /* ddrvge.f -- translated by f2c (version 20061008).
00002    You must link the resulting object file with libf2c:
00003         on Microsoft Windows system, link with libf2c.lib;
00004         on Linux or Unix systems, link with .../path/to/libf2c.a -lm
00005         or, if you install libf2c.a in a standard place, with -lf2c -lm
00006         -- in that order, at the end of the command line, as in
00007                 cc *.o -lf2c -lm
00008         Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
00009 
00010                 http://www.netlib.org/f2c/libf2c.zip
00011 */
00012 
00013 #include "f2c.h"
00014 #include "blaswrap.h"
00015 
00016 /* Common Block Declarations */
00017 
00018 struct {
00019     integer infot, nunit;
00020     logical ok, lerr;
00021 } infoc_;
00022 
00023 #define infoc_1 infoc_
00024 
00025 struct {
00026     char srnamt[32];
00027 } srnamc_;
00028 
00029 #define srnamc_1 srnamc_
00030 
00031 /* Table of constant values */
00032 
00033 static integer c__1 = 1;
00034 static integer c__2 = 2;
00035 static integer c__0 = 0;
00036 static integer c_n1 = -1;
00037 static doublereal c_b20 = 0.;
00038 static logical c_true = TRUE_;
00039 static integer c__6 = 6;
00040 static integer c__7 = 7;
00041 
00042 /* Subroutine */ int ddrvge_(logical *dotype, integer *nn, integer *nval, 
00043         integer *nrhs, doublereal *thresh, logical *tsterr, integer *nmax, 
00044         doublereal *a, doublereal *afac, doublereal *asav, doublereal *b, 
00045         doublereal *bsav, doublereal *x, doublereal *xact, doublereal *s, 
00046         doublereal *work, doublereal *rwork, integer *iwork, integer *nout)
00047 {
00048     /* Initialized data */
00049 
00050     static integer iseedy[4] = { 1988,1989,1990,1991 };
00051     static char transs[1*3] = "N" "T" "C";
00052     static char facts[1*3] = "F" "N" "E";
00053     static char equeds[1*4] = "N" "R" "C" "B";
00054 
00055     /* Format strings */
00056     static char fmt_9999[] = "(1x,a,\002, N =\002,i5,\002, type \002,i2,\002"
00057             ", test(\002,i2,\002) =\002,g12.5)";
00058     static char fmt_9997[] = "(1x,a,\002, FACT='\002,a1,\002', TRANS='\002,a"
00059             "1,\002', N=\002,i5,\002, EQUED='\002,a1,\002', type \002,i2,\002"
00060             ", test(\002,i1,\002)=\002,g12.5)";
00061     static char fmt_9998[] = "(1x,a,\002, FACT='\002,a1,\002', TRANS='\002,a"
00062             "1,\002', N=\002,i5,\002, type \002,i2,\002, test(\002,i1,\002)"
00063             "=\002,g12.5)";
00064 
00065     /* System generated locals */
00066     address a__1[2];
00067     integer i__1, i__2, i__3, i__4, i__5[2];
00068     doublereal d__1;
00069     char ch__1[2];
00070 
00071     /* Builtin functions */
00072     /* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);
00073     integer s_wsfe(cilist *), do_fio(integer *, char *, ftnlen), e_wsfe(void);
00074     /* Subroutine */ int s_cat(char *, char **, integer *, integer *, ftnlen);
00075 
00076     /* Local variables */
00077     integer i__, k, n, k1, nb, in, kl, ku, nt, lda;
00078     char fact[1];
00079     integer ioff, mode;
00080     doublereal amax;
00081     char path[3];
00082     integer imat, info;
00083     char dist[1], type__[1];
00084     integer nrun;
00085     extern /* Subroutine */ int dget01_(integer *, integer *, doublereal *, 
00086             integer *, doublereal *, integer *, integer *, doublereal *, 
00087             doublereal *), dget02_(char *, integer *, integer *, integer *, 
00088             doublereal *, integer *, doublereal *, integer *, doublereal *, 
00089             integer *, doublereal *, doublereal *);
00090     integer ifact;
00091     extern /* Subroutine */ int dget04_(integer *, integer *, doublereal *, 
00092             integer *, doublereal *, integer *, doublereal *, doublereal *);
00093     integer nfail, iseed[4], nfact;
00094     extern doublereal dget06_(doublereal *, doublereal *);
00095     extern /* Subroutine */ int dget07_(char *, integer *, integer *, 
00096             doublereal *, integer *, doublereal *, integer *, doublereal *, 
00097             integer *, doublereal *, integer *, doublereal *, logical *, 
00098             doublereal *, doublereal *);
00099     extern logical lsame_(char *, char *);
00100     char equed[1];
00101     integer nbmin;
00102     doublereal rcond, roldc;
00103     integer nimat;
00104     doublereal roldi;
00105     extern /* Subroutine */ int dgesv_(integer *, integer *, doublereal *, 
00106             integer *, integer *, doublereal *, integer *, integer *);
00107     doublereal anorm;
00108     integer itran;
00109     logical equil;
00110     doublereal roldo;
00111     char trans[1];
00112     integer izero, nerrs, lwork;
00113     logical zerot;
00114     char xtype[1];
00115     extern /* Subroutine */ int dlatb4_(char *, integer *, integer *, integer 
00116             *, char *, integer *, integer *, doublereal *, integer *, 
00117             doublereal *, char *), aladhd_(integer *, 
00118             char *);
00119     extern doublereal dlamch_(char *), dlange_(char *, integer *, 
00120             integer *, doublereal *, integer *, doublereal *);
00121     extern /* Subroutine */ int alaerh_(char *, char *, integer *, integer *, 
00122             char *, integer *, integer *, integer *, integer *, integer *, 
00123             integer *, integer *, integer *, integer *), dlaqge_(integer *, integer *, doublereal *, integer *, 
00124             doublereal *, doublereal *, doublereal *, doublereal *, 
00125             doublereal *, char *);
00126     logical prefac;
00127     doublereal colcnd, rcondc;
00128     logical nofact;
00129     integer iequed;
00130     extern /* Subroutine */ int dgeequ_(integer *, integer *, doublereal *, 
00131             integer *, doublereal *, doublereal *, doublereal *, doublereal *, 
00132              doublereal *, integer *);
00133     doublereal rcondi;
00134     extern /* Subroutine */ int dgetrf_(integer *, integer *, doublereal *, 
00135             integer *, integer *, integer *), dgetri_(integer *, doublereal *, 
00136              integer *, integer *, doublereal *, integer *, integer *), 
00137             dlacpy_(char *, integer *, integer *, doublereal *, integer *, 
00138             doublereal *, integer *), alasvm_(char *, integer *, 
00139             integer *, integer *, integer *);
00140     doublereal cndnum, anormi, rcondo, ainvnm;
00141     extern doublereal dlantr_(char *, char *, char *, integer *, integer *, 
00142             doublereal *, integer *, doublereal *);
00143     extern /* Subroutine */ int dlarhs_(char *, char *, char *, char *, 
00144             integer *, integer *, integer *, integer *, integer *, doublereal 
00145             *, integer *, doublereal *, integer *, doublereal *, integer *, 
00146             integer *, integer *);
00147     logical trfcon;
00148     doublereal anormo, rowcnd;
00149     extern /* Subroutine */ int dlaset_(char *, integer *, integer *, 
00150             doublereal *, doublereal *, doublereal *, integer *), 
00151             dgesvx_(char *, char *, integer *, integer *, doublereal *, 
00152             integer *, doublereal *, integer *, integer *, char *, doublereal 
00153             *, doublereal *, doublereal *, integer *, doublereal *, integer *, 
00154              doublereal *, doublereal *, doublereal *, doublereal *, integer *
00155 , integer *), dlatms_(integer *, integer *
00156 , char *, integer *, char *, doublereal *, integer *, doublereal *
00157 , doublereal *, integer *, integer *, char *, doublereal *, 
00158             integer *, doublereal *, integer *), 
00159             xlaenv_(integer *, integer *), derrvx_(char *, integer *);
00160     doublereal result[7], rpvgrw;
00161 
00162     /* Fortran I/O blocks */
00163     static cilist io___55 = { 0, 0, 0, fmt_9999, 0 };
00164     static cilist io___61 = { 0, 0, 0, fmt_9997, 0 };
00165     static cilist io___62 = { 0, 0, 0, fmt_9998, 0 };
00166     static cilist io___63 = { 0, 0, 0, fmt_9997, 0 };
00167     static cilist io___64 = { 0, 0, 0, fmt_9998, 0 };
00168     static cilist io___65 = { 0, 0, 0, fmt_9997, 0 };
00169     static cilist io___66 = { 0, 0, 0, fmt_9998, 0 };
00170     static cilist io___67 = { 0, 0, 0, fmt_9997, 0 };
00171     static cilist io___68 = { 0, 0, 0, fmt_9998, 0 };
00172 
00173 
00174 
00175 /*  -- LAPACK test routine (version 3.1) -- */
00176 /*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
00177 /*     November 2006 */
00178 
00179 /*     .. Scalar Arguments .. */
00180 /*     .. */
00181 /*     .. Array Arguments .. */
00182 /*     .. */
00183 
00184 /*  Purpose */
00185 /*  ======= */
00186 
00187 /*  DDRVGE tests the driver routines DGESV and -SVX. */
00188 
00189 /*  Arguments */
00190 /*  ========= */
00191 
00192 /*  DOTYPE  (input) LOGICAL array, dimension (NTYPES) */
00193 /*          The matrix types to be used for testing.  Matrices of type j */
00194 /*          (for 1 <= j <= NTYPES) are used for testing if DOTYPE(j) = */
00195 /*          .TRUE.; if DOTYPE(j) = .FALSE., then type j is not used. */
00196 
00197 /*  NN      (input) INTEGER */
00198 /*          The number of values of N contained in the vector NVAL. */
00199 
00200 /*  NVAL    (input) INTEGER array, dimension (NN) */
00201 /*          The values of the matrix column dimension N. */
00202 
00203 /*  NRHS    (input) INTEGER */
00204 /*          The number of right hand side vectors to be generated for */
00205 /*          each linear system. */
00206 
00207 /*  THRESH  (input) DOUBLE PRECISION */
00208 /*          The threshold value for the test ratios.  A result is */
00209 /*          included in the output file if RESULT >= THRESH.  To have */
00210 /*          every test ratio printed, use THRESH = 0. */
00211 
00212 /*  TSTERR  (input) LOGICAL */
00213 /*          Flag that indicates whether error exits are to be tested. */
00214 
00215 /*  NMAX    (input) INTEGER */
00216 /*          The maximum value permitted for N, used in dimensioning the */
00217 /*          work arrays. */
00218 
00219 /*  A       (workspace) DOUBLE PRECISION array, dimension (NMAX*NMAX) */
00220 
00221 /*  AFAC    (workspace) DOUBLE PRECISION array, dimension (NMAX*NMAX) */
00222 
00223 /*  ASAV    (workspace) DOUBLE PRECISION array, dimension (NMAX*NMAX) */
00224 
00225 /*  B       (workspace) DOUBLE PRECISION array, dimension (NMAX*NRHS) */
00226 
00227 /*  BSAV    (workspace) DOUBLE PRECISION array, dimension (NMAX*NRHS) */
00228 
00229 /*  X       (workspace) DOUBLE PRECISION array, dimension (NMAX*NRHS) */
00230 
00231 /*  XACT    (workspace) DOUBLE PRECISION array, dimension (NMAX*NRHS) */
00232 
00233 /*  S       (workspace) DOUBLE PRECISION array, dimension (2*NMAX) */
00234 
00235 /*  WORK    (workspace) DOUBLE PRECISION array, dimension */
00236 /*                      (NMAX*max(3,NRHS)) */
00237 
00238 /*  RWORK   (workspace) DOUBLE PRECISION array, dimension (2*NRHS+NMAX) */
00239 
00240 /*  IWORK   (workspace) INTEGER array, dimension (2*NMAX) */
00241 
00242 /*  NOUT    (input) INTEGER */
00243 /*          The unit number for output. */
00244 
00245 /*  ===================================================================== */
00246 
00247 /*     .. Parameters .. */
00248 /*     .. */
00249 /*     .. Local Scalars .. */
00250 /*     .. */
00251 /*     .. Local Arrays .. */
00252 /*     .. */
00253 /*     .. External Functions .. */
00254 /*     .. */
00255 /*     .. External Subroutines .. */
00256 /*     .. */
00257 /*     .. Intrinsic Functions .. */
00258 /*     .. */
00259 /*     .. Scalars in Common .. */
00260 /*     .. */
00261 /*     .. Common blocks .. */
00262 /*     .. */
00263 /*     .. Data statements .. */
00264     /* Parameter adjustments */
00265     --iwork;
00266     --rwork;
00267     --work;
00268     --s;
00269     --xact;
00270     --x;
00271     --bsav;
00272     --b;
00273     --asav;
00274     --afac;
00275     --a;
00276     --nval;
00277     --dotype;
00278 
00279     /* Function Body */
00280 /*     .. */
00281 /*     .. Executable Statements .. */
00282 
00283 /*     Initialize constants and the random number seed. */
00284 
00285     s_copy(path, "Double precision", (ftnlen)1, (ftnlen)16);
00286     s_copy(path + 1, "GE", (ftnlen)2, (ftnlen)2);
00287     nrun = 0;
00288     nfail = 0;
00289     nerrs = 0;
00290     for (i__ = 1; i__ <= 4; ++i__) {
00291         iseed[i__ - 1] = iseedy[i__ - 1];
00292 /* L10: */
00293     }
00294 
00295 /*     Test the error exits */
00296 
00297     if (*tsterr) {
00298         derrvx_(path, nout);
00299     }
00300     infoc_1.infot = 0;
00301 
00302 /*     Set the block size and minimum block size for testing. */
00303 
00304     nb = 1;
00305     nbmin = 2;
00306     xlaenv_(&c__1, &nb);
00307     xlaenv_(&c__2, &nbmin);
00308 
00309 /*     Do for each value of N in NVAL */
00310 
00311     i__1 = *nn;
00312     for (in = 1; in <= i__1; ++in) {
00313         n = nval[in];
00314         lda = max(n,1);
00315         *(unsigned char *)xtype = 'N';
00316         nimat = 11;
00317         if (n <= 0) {
00318             nimat = 1;
00319         }
00320 
00321         i__2 = nimat;
00322         for (imat = 1; imat <= i__2; ++imat) {
00323 
00324 /*           Do the tests only if DOTYPE( IMAT ) is true. */
00325 
00326             if (! dotype[imat]) {
00327                 goto L80;
00328             }
00329 
00330 /*           Skip types 5, 6, or 7 if the matrix size is too small. */
00331 
00332             zerot = imat >= 5 && imat <= 7;
00333             if (zerot && n < imat - 4) {
00334                 goto L80;
00335             }
00336 
00337 /*           Set up parameters with DLATB4 and generate a test matrix */
00338 /*           with DLATMS. */
00339 
00340             dlatb4_(path, &imat, &n, &n, type__, &kl, &ku, &anorm, &mode, &
00341                     cndnum, dist);
00342             rcondc = 1. / cndnum;
00343 
00344             s_copy(srnamc_1.srnamt, "DLATMS", (ftnlen)32, (ftnlen)6);
00345             dlatms_(&n, &n, dist, iseed, type__, &rwork[1], &mode, &cndnum, &
00346                     anorm, &kl, &ku, "No packing", &a[1], &lda, &work[1], &
00347                     info);
00348 
00349 /*           Check error code from DLATMS. */
00350 
00351             if (info != 0) {
00352                 alaerh_(path, "DLATMS", &info, &c__0, " ", &n, &n, &c_n1, &
00353                         c_n1, &c_n1, &imat, &nfail, &nerrs, nout);
00354                 goto L80;
00355             }
00356 
00357 /*           For types 5-7, zero one or more columns of the matrix to */
00358 /*           test that INFO is returned correctly. */
00359 
00360             if (zerot) {
00361                 if (imat == 5) {
00362                     izero = 1;
00363                 } else if (imat == 6) {
00364                     izero = n;
00365                 } else {
00366                     izero = n / 2 + 1;
00367                 }
00368                 ioff = (izero - 1) * lda;
00369                 if (imat < 7) {
00370                     i__3 = n;
00371                     for (i__ = 1; i__ <= i__3; ++i__) {
00372                         a[ioff + i__] = 0.;
00373 /* L20: */
00374                     }
00375                 } else {
00376                     i__3 = n - izero + 1;
00377                     dlaset_("Full", &n, &i__3, &c_b20, &c_b20, &a[ioff + 1], &
00378                             lda);
00379                 }
00380             } else {
00381                 izero = 0;
00382             }
00383 
00384 /*           Save a copy of the matrix A in ASAV. */
00385 
00386             dlacpy_("Full", &n, &n, &a[1], &lda, &asav[1], &lda);
00387 
00388             for (iequed = 1; iequed <= 4; ++iequed) {
00389                 *(unsigned char *)equed = *(unsigned char *)&equeds[iequed - 
00390                         1];
00391                 if (iequed == 1) {
00392                     nfact = 3;
00393                 } else {
00394                     nfact = 1;
00395                 }
00396 
00397                 i__3 = nfact;
00398                 for (ifact = 1; ifact <= i__3; ++ifact) {
00399                     *(unsigned char *)fact = *(unsigned char *)&facts[ifact - 
00400                             1];
00401                     prefac = lsame_(fact, "F");
00402                     nofact = lsame_(fact, "N");
00403                     equil = lsame_(fact, "E");
00404 
00405                     if (zerot) {
00406                         if (prefac) {
00407                             goto L60;
00408                         }
00409                         rcondo = 0.;
00410                         rcondi = 0.;
00411 
00412                     } else if (! nofact) {
00413 
00414 /*                    Compute the condition number for comparison with */
00415 /*                    the value returned by DGESVX (FACT = 'N' reuses */
00416 /*                    the condition number from the previous iteration */
00417 /*                    with FACT = 'F'). */
00418 
00419                         dlacpy_("Full", &n, &n, &asav[1], &lda, &afac[1], &
00420                                 lda);
00421                         if (equil || iequed > 1) {
00422 
00423 /*                       Compute row and column scale factors to */
00424 /*                       equilibrate the matrix A. */
00425 
00426                             dgeequ_(&n, &n, &afac[1], &lda, &s[1], &s[n + 1], 
00427                                     &rowcnd, &colcnd, &amax, &info);
00428                             if (info == 0 && n > 0) {
00429                                 if (lsame_(equed, "R")) 
00430                                         {
00431                                     rowcnd = 0.;
00432                                     colcnd = 1.;
00433                                 } else if (lsame_(equed, "C")) {
00434                                     rowcnd = 1.;
00435                                     colcnd = 0.;
00436                                 } else if (lsame_(equed, "B")) {
00437                                     rowcnd = 0.;
00438                                     colcnd = 0.;
00439                                 }
00440 
00441 /*                          Equilibrate the matrix. */
00442 
00443                                 dlaqge_(&n, &n, &afac[1], &lda, &s[1], &s[n + 
00444                                         1], &rowcnd, &colcnd, &amax, equed);
00445                             }
00446                         }
00447 
00448 /*                    Save the condition number of the non-equilibrated */
00449 /*                    system for use in DGET04. */
00450 
00451                         if (equil) {
00452                             roldo = rcondo;
00453                             roldi = rcondi;
00454                         }
00455 
00456 /*                    Compute the 1-norm and infinity-norm of A. */
00457 
00458                         anormo = dlange_("1", &n, &n, &afac[1], &lda, &rwork[
00459                                 1]);
00460                         anormi = dlange_("I", &n, &n, &afac[1], &lda, &rwork[
00461                                 1]);
00462 
00463 /*                    Factor the matrix A. */
00464 
00465                         dgetrf_(&n, &n, &afac[1], &lda, &iwork[1], &info);
00466 
00467 /*                    Form the inverse of A. */
00468 
00469                         dlacpy_("Full", &n, &n, &afac[1], &lda, &a[1], &lda);
00470                         lwork = *nmax * max(3,*nrhs);
00471                         dgetri_(&n, &a[1], &lda, &iwork[1], &work[1], &lwork, 
00472                                 &info);
00473 
00474 /*                    Compute the 1-norm condition number of A. */
00475 
00476                         ainvnm = dlange_("1", &n, &n, &a[1], &lda, &rwork[1]);
00477                         if (anormo <= 0. || ainvnm <= 0.) {
00478                             rcondo = 1.;
00479                         } else {
00480                             rcondo = 1. / anormo / ainvnm;
00481                         }
00482 
00483 /*                    Compute the infinity-norm condition number of A. */
00484 
00485                         ainvnm = dlange_("I", &n, &n, &a[1], &lda, &rwork[1]);
00486                         if (anormi <= 0. || ainvnm <= 0.) {
00487                             rcondi = 1.;
00488                         } else {
00489                             rcondi = 1. / anormi / ainvnm;
00490                         }
00491                     }
00492 
00493                     for (itran = 1; itran <= 3; ++itran) {
00494 
00495 /*                    Do for each value of TRANS. */
00496 
00497                         *(unsigned char *)trans = *(unsigned char *)&transs[
00498                                 itran - 1];
00499                         if (itran == 1) {
00500                             rcondc = rcondo;
00501                         } else {
00502                             rcondc = rcondi;
00503                         }
00504 
00505 /*                    Restore the matrix A. */
00506 
00507                         dlacpy_("Full", &n, &n, &asav[1], &lda, &a[1], &lda);
00508 
00509 /*                    Form an exact solution and set the right hand side. */
00510 
00511                         s_copy(srnamc_1.srnamt, "DLARHS", (ftnlen)32, (ftnlen)
00512                                 6);
00513                         dlarhs_(path, xtype, "Full", trans, &n, &n, &kl, &ku, 
00514                                 nrhs, &a[1], &lda, &xact[1], &lda, &b[1], &
00515                                 lda, iseed, &info);
00516                         *(unsigned char *)xtype = 'C';
00517                         dlacpy_("Full", &n, nrhs, &b[1], &lda, &bsav[1], &lda);
00518 
00519                         if (nofact && itran == 1) {
00520 
00521 /*                       --- Test DGESV  --- */
00522 
00523 /*                       Compute the LU factorization of the matrix and */
00524 /*                       solve the system. */
00525 
00526                             dlacpy_("Full", &n, &n, &a[1], &lda, &afac[1], &
00527                                     lda);
00528                             dlacpy_("Full", &n, nrhs, &b[1], &lda, &x[1], &
00529                                     lda);
00530 
00531                             s_copy(srnamc_1.srnamt, "DGESV ", (ftnlen)32, (
00532                                     ftnlen)6);
00533                             dgesv_(&n, nrhs, &afac[1], &lda, &iwork[1], &x[1], 
00534                                      &lda, &info);
00535 
00536 /*                       Check error code from DGESV . */
00537 
00538                             if (info != izero) {
00539                                 alaerh_(path, "DGESV ", &info, &izero, " ", &
00540                                         n, &n, &c_n1, &c_n1, nrhs, &imat, &
00541                                         nfail, &nerrs, nout);
00542                             }
00543 
00544 /*                       Reconstruct matrix from factors and compute */
00545 /*                       residual. */
00546 
00547                             dget01_(&n, &n, &a[1], &lda, &afac[1], &lda, &
00548                                     iwork[1], &rwork[1], result);
00549                             nt = 1;
00550                             if (izero == 0) {
00551 
00552 /*                          Compute residual of the computed solution. */
00553 
00554                                 dlacpy_("Full", &n, nrhs, &b[1], &lda, &work[
00555                                         1], &lda);
00556                                 dget02_("No transpose", &n, &n, nrhs, &a[1], &
00557                                         lda, &x[1], &lda, &work[1], &lda, &
00558                                         rwork[1], &result[1]);
00559 
00560 /*                          Check solution from generated exact solution. */
00561 
00562                                 dget04_(&n, nrhs, &x[1], &lda, &xact[1], &lda, 
00563                                          &rcondc, &result[2]);
00564                                 nt = 3;
00565                             }
00566 
00567 /*                       Print information about the tests that did not */
00568 /*                       pass the threshold. */
00569 
00570                             i__4 = nt;
00571                             for (k = 1; k <= i__4; ++k) {
00572                                 if (result[k - 1] >= *thresh) {
00573                                     if (nfail == 0 && nerrs == 0) {
00574                                         aladhd_(nout, path);
00575                                     }
00576                                     io___55.ciunit = *nout;
00577                                     s_wsfe(&io___55);
00578                                     do_fio(&c__1, "DGESV ", (ftnlen)6);
00579                                     do_fio(&c__1, (char *)&n, (ftnlen)sizeof(
00580                                             integer));
00581                                     do_fio(&c__1, (char *)&imat, (ftnlen)
00582                                             sizeof(integer));
00583                                     do_fio(&c__1, (char *)&k, (ftnlen)sizeof(
00584                                             integer));
00585                                     do_fio(&c__1, (char *)&result[k - 1], (
00586                                             ftnlen)sizeof(doublereal));
00587                                     e_wsfe();
00588                                     ++nfail;
00589                                 }
00590 /* L30: */
00591                             }
00592                             nrun += nt;
00593                         }
00594 
00595 /*                    --- Test DGESVX --- */
00596 
00597                         if (! prefac) {
00598                             dlaset_("Full", &n, &n, &c_b20, &c_b20, &afac[1], 
00599                                     &lda);
00600                         }
00601                         dlaset_("Full", &n, nrhs, &c_b20, &c_b20, &x[1], &lda);
00602                         if (iequed > 1 && n > 0) {
00603 
00604 /*                       Equilibrate the matrix if FACT = 'F' and */
00605 /*                       EQUED = 'R', 'C', or 'B'. */
00606 
00607                             dlaqge_(&n, &n, &a[1], &lda, &s[1], &s[n + 1], &
00608                                     rowcnd, &colcnd, &amax, equed);
00609                         }
00610 
00611 /*                    Solve the system and compute the condition number */
00612 /*                    and error bounds using DGESVX. */
00613 
00614                         s_copy(srnamc_1.srnamt, "DGESVX", (ftnlen)32, (ftnlen)
00615                                 6);
00616                         dgesvx_(fact, trans, &n, nrhs, &a[1], &lda, &afac[1], 
00617                                 &lda, &iwork[1], equed, &s[1], &s[n + 1], &b[
00618                                 1], &lda, &x[1], &lda, &rcond, &rwork[1], &
00619                                 rwork[*nrhs + 1], &work[1], &iwork[n + 1], &
00620                                 info);
00621 
00622 /*                    Check the error code from DGESVX. */
00623 
00624                         if (info != izero) {
00625 /* Writing concatenation */
00626                             i__5[0] = 1, a__1[0] = fact;
00627                             i__5[1] = 1, a__1[1] = trans;
00628                             s_cat(ch__1, a__1, i__5, &c__2, (ftnlen)2);
00629                             alaerh_(path, "DGESVX", &info, &izero, ch__1, &n, 
00630                                     &n, &c_n1, &c_n1, nrhs, &imat, &nfail, &
00631                                     nerrs, nout);
00632                         }
00633 
00634 /*                    Compare WORK(1) from DGESVX with the computed */
00635 /*                    reciprocal pivot growth factor RPVGRW */
00636 
00637                         if (info != 0) {
00638                             rpvgrw = dlantr_("M", "U", "N", &info, &info, &
00639                                     afac[1], &lda, &work[1]);
00640                             if (rpvgrw == 0.) {
00641                                 rpvgrw = 1.;
00642                             } else {
00643                                 rpvgrw = dlange_("M", &n, &info, &a[1], &lda, 
00644                                         &work[1]) / rpvgrw;
00645                             }
00646                         } else {
00647                             rpvgrw = dlantr_("M", "U", "N", &n, &n, &afac[1], 
00648                                     &lda, &work[1]);
00649                             if (rpvgrw == 0.) {
00650                                 rpvgrw = 1.;
00651                             } else {
00652                                 rpvgrw = dlange_("M", &n, &n, &a[1], &lda, &
00653                                         work[1]) / rpvgrw;
00654                             }
00655                         }
00656                         result[6] = (d__1 = rpvgrw - work[1], abs(d__1)) / 
00657                                 max(work[1],rpvgrw) / dlamch_("E");
00658 
00659                         if (! prefac) {
00660 
00661 /*                       Reconstruct matrix from factors and compute */
00662 /*                       residual. */
00663 
00664                             dget01_(&n, &n, &a[1], &lda, &afac[1], &lda, &
00665                                     iwork[1], &rwork[(*nrhs << 1) + 1], 
00666                                     result);
00667                             k1 = 1;
00668                         } else {
00669                             k1 = 2;
00670                         }
00671 
00672                         if (info == 0) {
00673                             trfcon = FALSE_;
00674 
00675 /*                       Compute residual of the computed solution. */
00676 
00677                             dlacpy_("Full", &n, nrhs, &bsav[1], &lda, &work[1]
00678 , &lda);
00679                             dget02_(trans, &n, &n, nrhs, &asav[1], &lda, &x[1]
00680 , &lda, &work[1], &lda, &rwork[(*nrhs << 
00681                                     1) + 1], &result[1]);
00682 
00683 /*                       Check solution from generated exact solution. */
00684 
00685                             if (nofact || prefac && lsame_(equed, "N")) {
00686                                 dget04_(&n, nrhs, &x[1], &lda, &xact[1], &lda, 
00687                                          &rcondc, &result[2]);
00688                             } else {
00689                                 if (itran == 1) {
00690                                     roldc = roldo;
00691                                 } else {
00692                                     roldc = roldi;
00693                                 }
00694                                 dget04_(&n, nrhs, &x[1], &lda, &xact[1], &lda, 
00695                                          &roldc, &result[2]);
00696                             }
00697 
00698 /*                       Check the error bounds from iterative */
00699 /*                       refinement. */
00700 
00701                             dget07_(trans, &n, nrhs, &asav[1], &lda, &b[1], &
00702                                     lda, &x[1], &lda, &xact[1], &lda, &rwork[
00703                                     1], &c_true, &rwork[*nrhs + 1], &result[3]
00704 );
00705                         } else {
00706                             trfcon = TRUE_;
00707                         }
00708 
00709 /*                    Compare RCOND from DGESVX with the computed value */
00710 /*                    in RCONDC. */
00711 
00712                         result[5] = dget06_(&rcond, &rcondc);
00713 
00714 /*                    Print information about the tests that did not pass */
00715 /*                    the threshold. */
00716 
00717                         if (! trfcon) {
00718                             for (k = k1; k <= 7; ++k) {
00719                                 if (result[k - 1] >= *thresh) {
00720                                     if (nfail == 0 && nerrs == 0) {
00721                                         aladhd_(nout, path);
00722                                     }
00723                                     if (prefac) {
00724                                         io___61.ciunit = *nout;
00725                                         s_wsfe(&io___61);
00726                                         do_fio(&c__1, "DGESVX", (ftnlen)6);
00727                                         do_fio(&c__1, fact, (ftnlen)1);
00728                                         do_fio(&c__1, trans, (ftnlen)1);
00729                                         do_fio(&c__1, (char *)&n, (ftnlen)
00730                                                 sizeof(integer));
00731                                         do_fio(&c__1, equed, (ftnlen)1);
00732                                         do_fio(&c__1, (char *)&imat, (ftnlen)
00733                                                 sizeof(integer));
00734                                         do_fio(&c__1, (char *)&k, (ftnlen)
00735                                                 sizeof(integer));
00736                                         do_fio(&c__1, (char *)&result[k - 1], 
00737                                                 (ftnlen)sizeof(doublereal));
00738                                         e_wsfe();
00739                                     } else {
00740                                         io___62.ciunit = *nout;
00741                                         s_wsfe(&io___62);
00742                                         do_fio(&c__1, "DGESVX", (ftnlen)6);
00743                                         do_fio(&c__1, fact, (ftnlen)1);
00744                                         do_fio(&c__1, trans, (ftnlen)1);
00745                                         do_fio(&c__1, (char *)&n, (ftnlen)
00746                                                 sizeof(integer));
00747                                         do_fio(&c__1, (char *)&imat, (ftnlen)
00748                                                 sizeof(integer));
00749                                         do_fio(&c__1, (char *)&k, (ftnlen)
00750                                                 sizeof(integer));
00751                                         do_fio(&c__1, (char *)&result[k - 1], 
00752                                                 (ftnlen)sizeof(doublereal));
00753                                         e_wsfe();
00754                                     }
00755                                     ++nfail;
00756                                 }
00757 /* L40: */
00758                             }
00759                             nrun = nrun + 7 - k1;
00760                         } else {
00761                             if (result[0] >= *thresh && ! prefac) {
00762                                 if (nfail == 0 && nerrs == 0) {
00763                                     aladhd_(nout, path);
00764                                 }
00765                                 if (prefac) {
00766                                     io___63.ciunit = *nout;
00767                                     s_wsfe(&io___63);
00768                                     do_fio(&c__1, "DGESVX", (ftnlen)6);
00769                                     do_fio(&c__1, fact, (ftnlen)1);
00770                                     do_fio(&c__1, trans, (ftnlen)1);
00771                                     do_fio(&c__1, (char *)&n, (ftnlen)sizeof(
00772                                             integer));
00773                                     do_fio(&c__1, equed, (ftnlen)1);
00774                                     do_fio(&c__1, (char *)&imat, (ftnlen)
00775                                             sizeof(integer));
00776                                     do_fio(&c__1, (char *)&c__1, (ftnlen)
00777                                             sizeof(integer));
00778                                     do_fio(&c__1, (char *)&result[0], (ftnlen)
00779                                             sizeof(doublereal));
00780                                     e_wsfe();
00781                                 } else {
00782                                     io___64.ciunit = *nout;
00783                                     s_wsfe(&io___64);
00784                                     do_fio(&c__1, "DGESVX", (ftnlen)6);
00785                                     do_fio(&c__1, fact, (ftnlen)1);
00786                                     do_fio(&c__1, trans, (ftnlen)1);
00787                                     do_fio(&c__1, (char *)&n, (ftnlen)sizeof(
00788                                             integer));
00789                                     do_fio(&c__1, (char *)&imat, (ftnlen)
00790                                             sizeof(integer));
00791                                     do_fio(&c__1, (char *)&c__1, (ftnlen)
00792                                             sizeof(integer));
00793                                     do_fio(&c__1, (char *)&result[0], (ftnlen)
00794                                             sizeof(doublereal));
00795                                     e_wsfe();
00796                                 }
00797                                 ++nfail;
00798                                 ++nrun;
00799                             }
00800                             if (result[5] >= *thresh) {
00801                                 if (nfail == 0 && nerrs == 0) {
00802                                     aladhd_(nout, path);
00803                                 }
00804                                 if (prefac) {
00805                                     io___65.ciunit = *nout;
00806                                     s_wsfe(&io___65);
00807                                     do_fio(&c__1, "DGESVX", (ftnlen)6);
00808                                     do_fio(&c__1, fact, (ftnlen)1);
00809                                     do_fio(&c__1, trans, (ftnlen)1);
00810                                     do_fio(&c__1, (char *)&n, (ftnlen)sizeof(
00811                                             integer));
00812                                     do_fio(&c__1, equed, (ftnlen)1);
00813                                     do_fio(&c__1, (char *)&imat, (ftnlen)
00814                                             sizeof(integer));
00815                                     do_fio(&c__1, (char *)&c__6, (ftnlen)
00816                                             sizeof(integer));
00817                                     do_fio(&c__1, (char *)&result[5], (ftnlen)
00818                                             sizeof(doublereal));
00819                                     e_wsfe();
00820                                 } else {
00821                                     io___66.ciunit = *nout;
00822                                     s_wsfe(&io___66);
00823                                     do_fio(&c__1, "DGESVX", (ftnlen)6);
00824                                     do_fio(&c__1, fact, (ftnlen)1);
00825                                     do_fio(&c__1, trans, (ftnlen)1);
00826                                     do_fio(&c__1, (char *)&n, (ftnlen)sizeof(
00827                                             integer));
00828                                     do_fio(&c__1, (char *)&imat, (ftnlen)
00829                                             sizeof(integer));
00830                                     do_fio(&c__1, (char *)&c__6, (ftnlen)
00831                                             sizeof(integer));
00832                                     do_fio(&c__1, (char *)&result[5], (ftnlen)
00833                                             sizeof(doublereal));
00834                                     e_wsfe();
00835                                 }
00836                                 ++nfail;
00837                                 ++nrun;
00838                             }
00839                             if (result[6] >= *thresh) {
00840                                 if (nfail == 0 && nerrs == 0) {
00841                                     aladhd_(nout, path);
00842                                 }
00843                                 if (prefac) {
00844                                     io___67.ciunit = *nout;
00845                                     s_wsfe(&io___67);
00846                                     do_fio(&c__1, "DGESVX", (ftnlen)6);
00847                                     do_fio(&c__1, fact, (ftnlen)1);
00848                                     do_fio(&c__1, trans, (ftnlen)1);
00849                                     do_fio(&c__1, (char *)&n, (ftnlen)sizeof(
00850                                             integer));
00851                                     do_fio(&c__1, equed, (ftnlen)1);
00852                                     do_fio(&c__1, (char *)&imat, (ftnlen)
00853                                             sizeof(integer));
00854                                     do_fio(&c__1, (char *)&c__7, (ftnlen)
00855                                             sizeof(integer));
00856                                     do_fio(&c__1, (char *)&result[6], (ftnlen)
00857                                             sizeof(doublereal));
00858                                     e_wsfe();
00859                                 } else {
00860                                     io___68.ciunit = *nout;
00861                                     s_wsfe(&io___68);
00862                                     do_fio(&c__1, "DGESVX", (ftnlen)6);
00863                                     do_fio(&c__1, fact, (ftnlen)1);
00864                                     do_fio(&c__1, trans, (ftnlen)1);
00865                                     do_fio(&c__1, (char *)&n, (ftnlen)sizeof(
00866                                             integer));
00867                                     do_fio(&c__1, (char *)&imat, (ftnlen)
00868                                             sizeof(integer));
00869                                     do_fio(&c__1, (char *)&c__7, (ftnlen)
00870                                             sizeof(integer));
00871                                     do_fio(&c__1, (char *)&result[6], (ftnlen)
00872                                             sizeof(doublereal));
00873                                     e_wsfe();
00874                                 }
00875                                 ++nfail;
00876                                 ++nrun;
00877                             }
00878 
00879                         }
00880 
00881 /* L50: */
00882                     }
00883 L60:
00884                     ;
00885                 }
00886 /* L70: */
00887             }
00888 L80:
00889             ;
00890         }
00891 /* L90: */
00892     }
00893 
00894 /*     Print a summary of the results. */
00895 
00896     alasvm_(path, nout, &nfail, &nrun, &nerrs);
00897 
00898     return 0;
00899 
00900 /*     End of DDRVGE */
00901 
00902 } /* ddrvge_ */

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