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

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