dchkge.c
Go to the documentation of this file.
00001 /* dchkge.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_b23 = 0.;
00038 static logical c_true = TRUE_;
00039 static integer c__8 = 8;
00040 
00041 /* Subroutine */ int dchkge_(logical *dotype, integer *nm, integer *mval, 
00042         integer *nn, integer *nval, integer *nnb, integer *nbval, integer *
00043         nns, integer *nsval, doublereal *thresh, logical *tsterr, integer *
00044         nmax, doublereal *a, doublereal *afac, doublereal *ainv, doublereal *
00045         b, doublereal *x, doublereal *xact, doublereal *work, doublereal *
00046         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 
00053     /* Format strings */
00054     static char fmt_9999[] = "(\002 M = \002,i5,\002, N =\002,i5,\002, NB "
00055             "=\002,i4,\002, type \002,i2,\002, test(\002,i2,\002) =\002,g12.5)"
00056             ;
00057     static char fmt_9998[] = "(\002 TRANS='\002,a1,\002', N =\002,i5,\002, N"
00058             "RHS=\002,i3,\002, type \002,i2,\002, test(\002,i2,\002) =\002,g1"
00059             "2.5)";
00060     static char fmt_9997[] = "(\002 NORM ='\002,a1,\002', N =\002,i5,\002"
00061             ",\002,10x,\002 type \002,i2,\002, test(\002,i2,\002) =\002,g12.5)"
00062             ;
00063 
00064     /* System generated locals */
00065     integer i__1, i__2, i__3, i__4, i__5;
00066 
00067     /* Builtin functions */
00068     /* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);
00069     integer s_wsfe(cilist *), do_fio(integer *, char *, ftnlen), e_wsfe(void);
00070 
00071     /* Local variables */
00072     integer i__, k, m, n, nb, im, in, kl, ku, nt, lda, inb, ioff, mode, imat, 
00073             info;
00074     char path[3], dist[1];
00075     integer irhs, nrhs;
00076     char norm[1], type__[1];
00077     integer nrun;
00078     extern /* Subroutine */ int alahd_(integer *, char *), dget01_(
00079             integer *, integer *, doublereal *, integer *, doublereal *, 
00080             integer *, integer *, doublereal *, doublereal *), dget02_(char *, 
00081              integer *, integer *, integer *, doublereal *, integer *, 
00082             doublereal *, integer *, doublereal *, integer *, doublereal *, 
00083             doublereal *), dget03_(integer *, doublereal *, integer *, 
00084              doublereal *, integer *, doublereal *, integer *, doublereal *, 
00085             doublereal *, doublereal *), dget04_(integer *, integer *, 
00086             doublereal *, integer *, doublereal *, integer *, doublereal *, 
00087             doublereal *);
00088     integer nfail, iseed[4];
00089     extern doublereal dget06_(doublereal *, doublereal *);
00090     extern /* Subroutine */ int dget07_(char *, integer *, integer *, 
00091             doublereal *, integer *, doublereal *, integer *, doublereal *, 
00092             integer *, doublereal *, integer *, doublereal *, logical *, 
00093             doublereal *, doublereal *);
00094     doublereal rcond;
00095     integer nimat;
00096     doublereal anorm;
00097     integer itran;
00098     char trans[1];
00099     integer izero, nerrs;
00100     doublereal dummy;
00101     integer lwork;
00102     logical zerot;
00103     char xtype[1];
00104     extern /* Subroutine */ int dlatb4_(char *, integer *, integer *, integer 
00105             *, char *, integer *, integer *, doublereal *, integer *, 
00106             doublereal *, char *);
00107     extern doublereal dlange_(char *, integer *, integer *, doublereal *, 
00108             integer *, doublereal *);
00109     extern /* Subroutine */ int alaerh_(char *, char *, integer *, integer *, 
00110             char *, integer *, integer *, integer *, integer *, integer *, 
00111             integer *, integer *, integer *, integer *), dgecon_(char *, integer *, doublereal *, integer *, 
00112             doublereal *, doublereal *, doublereal *, integer *, integer *);
00113     doublereal rcondc;
00114     extern /* Subroutine */ int derrge_(char *, integer *), dgerfs_(
00115             char *, integer *, integer *, doublereal *, integer *, doublereal 
00116             *, integer *, integer *, doublereal *, integer *, doublereal *, 
00117             integer *, doublereal *, doublereal *, doublereal *, integer *, 
00118             integer *), dgetrf_(integer *, integer *, doublereal *, 
00119             integer *, integer *, integer *), dlacpy_(char *, integer *, 
00120             integer *, doublereal *, integer *, doublereal *, integer *), dlarhs_(char *, char *, char *, char *, integer *, 
00121             integer *, integer *, integer *, integer *, doublereal *, integer 
00122             *, doublereal *, integer *, doublereal *, integer *, integer *, 
00123             integer *);
00124     doublereal rcondi;
00125     extern /* Subroutine */ int dgetri_(integer *, doublereal *, integer *, 
00126             integer *, doublereal *, integer *, integer *), dlaset_(char *, 
00127             integer *, integer *, doublereal *, doublereal *, doublereal *, 
00128             integer *), alasum_(char *, integer *, integer *, integer 
00129             *, integer *);
00130     doublereal cndnum, anormi, rcondo;
00131     extern /* Subroutine */ int dlatms_(integer *, integer *, char *, integer 
00132             *, char *, doublereal *, integer *, doublereal *, doublereal *, 
00133             integer *, integer *, char *, doublereal *, integer *, doublereal 
00134             *, integer *);
00135     doublereal ainvnm;
00136     extern /* Subroutine */ int dgetrs_(char *, integer *, integer *, 
00137             doublereal *, integer *, integer *, doublereal *, integer *, 
00138             integer *);
00139     logical trfcon;
00140     doublereal anormo;
00141     extern /* Subroutine */ int xlaenv_(integer *, integer *);
00142     doublereal result[8];
00143 
00144     /* Fortran I/O blocks */
00145     static cilist io___41 = { 0, 0, 0, fmt_9999, 0 };
00146     static cilist io___46 = { 0, 0, 0, fmt_9998, 0 };
00147     static cilist io___50 = { 0, 0, 0, fmt_9997, 0 };
00148 
00149 
00150 
00151 /*  -- LAPACK test routine (version 3.1.1) -- */
00152 /*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
00153 /*     January 2007 */
00154 
00155 /*     .. Scalar Arguments .. */
00156 /*     .. */
00157 /*     .. Array Arguments .. */
00158 /*     .. */
00159 
00160 /*  Purpose */
00161 /*  ======= */
00162 
00163 /*  DCHKGE tests DGETRF, -TRI, -TRS, -RFS, and -CON. */
00164 
00165 /*  Arguments */
00166 /*  ========= */
00167 
00168 /*  DOTYPE  (input) LOGICAL array, dimension (NTYPES) */
00169 /*          The matrix types to be used for testing.  Matrices of type j */
00170 /*          (for 1 <= j <= NTYPES) are used for testing if DOTYPE(j) = */
00171 /*          .TRUE.; if DOTYPE(j) = .FALSE., then type j is not used. */
00172 
00173 /*  NM      (input) INTEGER */
00174 /*          The number of values of M contained in the vector MVAL. */
00175 
00176 /*  MVAL    (input) INTEGER array, dimension (NM) */
00177 /*          The values of the matrix row dimension M. */
00178 
00179 /*  NN      (input) INTEGER */
00180 /*          The number of values of N contained in the vector NVAL. */
00181 
00182 /*  NVAL    (input) INTEGER array, dimension (NN) */
00183 /*          The values of the matrix column dimension N. */
00184 
00185 /*  NNB     (input) INTEGER */
00186 /*          The number of values of NB contained in the vector NBVAL. */
00187 
00188 /*  NBVAL   (input) INTEGER array, dimension (NBVAL) */
00189 /*          The values of the blocksize NB. */
00190 
00191 /*  NNS     (input) INTEGER */
00192 /*          The number of values of NRHS contained in the vector NSVAL. */
00193 
00194 /*  NSVAL   (input) INTEGER array, dimension (NNS) */
00195 /*          The values of the number of right hand sides NRHS. */
00196 
00197 /*  THRESH  (input) DOUBLE PRECISION */
00198 /*          The threshold value for the test ratios.  A result is */
00199 /*          included in the output file if RESULT >= THRESH.  To have */
00200 /*          every test ratio printed, use THRESH = 0. */
00201 
00202 /*  TSTERR  (input) LOGICAL */
00203 /*          Flag that indicates whether error exits are to be tested. */
00204 
00205 /*  NMAX    (input) INTEGER */
00206 /*          The maximum value permitted for M or N, used in dimensioning */
00207 /*          the work arrays. */
00208 
00209 /*  A       (workspace) DOUBLE PRECISION array, dimension (NMAX*NMAX) */
00210 
00211 /*  AFAC    (workspace) DOUBLE PRECISION array, dimension (NMAX*NMAX) */
00212 
00213 /*  AINV    (workspace) DOUBLE PRECISION array, dimension (NMAX*NMAX) */
00214 
00215 /*  B       (workspace) DOUBLE PRECISION array, dimension (NMAX*NSMAX) */
00216 /*          where NSMAX is the largest entry in NSVAL. */
00217 
00218 /*  X       (workspace) DOUBLE PRECISION array, dimension (NMAX*NSMAX) */
00219 
00220 /*  XACT    (workspace) DOUBLE PRECISION array, dimension (NMAX*NSMAX) */
00221 
00222 /*  WORK    (workspace) DOUBLE PRECISION array, dimension */
00223 /*                      (NMAX*max(3,NSMAX)) */
00224 
00225 /*  RWORK   (workspace) DOUBLE PRECISION array, dimension */
00226 /*                      (max(2*NMAX,2*NSMAX+NWORK)) */
00227 
00228 /*  IWORK   (workspace) INTEGER array, dimension (2*NMAX) */
00229 
00230 /*  NOUT    (input) INTEGER */
00231 /*          The unit number for output. */
00232 
00233 /*  ===================================================================== */
00234 
00235 /*     .. Parameters .. */
00236 /*     .. */
00237 /*     .. Local Scalars .. */
00238 /*     .. */
00239 /*     .. Local Arrays .. */
00240 /*     .. */
00241 /*     .. External Functions .. */
00242 /*     .. */
00243 /*     .. External Subroutines .. */
00244 /*     .. */
00245 /*     .. Intrinsic Functions .. */
00246 /*     .. */
00247 /*     .. Scalars in Common .. */
00248 /*     .. */
00249 /*     .. Common blocks .. */
00250 /*     .. */
00251 /*     .. Data statements .. */
00252     /* Parameter adjustments */
00253     --iwork;
00254     --rwork;
00255     --work;
00256     --xact;
00257     --x;
00258     --b;
00259     --ainv;
00260     --afac;
00261     --a;
00262     --nsval;
00263     --nbval;
00264     --nval;
00265     --mval;
00266     --dotype;
00267 
00268     /* Function Body */
00269 /*     .. */
00270 /*     .. Executable Statements .. */
00271 
00272 /*     Initialize constants and the random number seed. */
00273 
00274     s_copy(path, "Double precision", (ftnlen)1, (ftnlen)16);
00275     s_copy(path + 1, "GE", (ftnlen)2, (ftnlen)2);
00276     nrun = 0;
00277     nfail = 0;
00278     nerrs = 0;
00279     for (i__ = 1; i__ <= 4; ++i__) {
00280         iseed[i__ - 1] = iseedy[i__ - 1];
00281 /* L10: */
00282     }
00283 
00284 /*     Test the error exits */
00285 
00286     xlaenv_(&c__1, &c__1);
00287     if (*tsterr) {
00288         derrge_(path, nout);
00289     }
00290     infoc_1.infot = 0;
00291     xlaenv_(&c__2, &c__2);
00292 
00293 /*     Do for each value of M in MVAL */
00294 
00295     i__1 = *nm;
00296     for (im = 1; im <= i__1; ++im) {
00297         m = mval[im];
00298         lda = max(1,m);
00299 
00300 /*        Do for each value of N in NVAL */
00301 
00302         i__2 = *nn;
00303         for (in = 1; in <= i__2; ++in) {
00304             n = nval[in];
00305             *(unsigned char *)xtype = 'N';
00306             nimat = 11;
00307             if (m <= 0 || n <= 0) {
00308                 nimat = 1;
00309             }
00310 
00311             i__3 = nimat;
00312             for (imat = 1; imat <= i__3; ++imat) {
00313 
00314 /*              Do the tests only if DOTYPE( IMAT ) is true. */
00315 
00316                 if (! dotype[imat]) {
00317                     goto L100;
00318                 }
00319 
00320 /*              Skip types 5, 6, or 7 if the matrix size is too small. */
00321 
00322                 zerot = imat >= 5 && imat <= 7;
00323                 if (zerot && n < imat - 4) {
00324                     goto L100;
00325                 }
00326 
00327 /*              Set up parameters with DLATB4 and generate a test matrix */
00328 /*              with DLATMS. */
00329 
00330                 dlatb4_(path, &imat, &m, &n, type__, &kl, &ku, &anorm, &mode, 
00331                         &cndnum, dist);
00332 
00333                 s_copy(srnamc_1.srnamt, "DLATMS", (ftnlen)32, (ftnlen)6);
00334                 dlatms_(&m, &n, dist, iseed, type__, &rwork[1], &mode, &
00335                         cndnum, &anorm, &kl, &ku, "No packing", &a[1], &lda, &
00336                         work[1], &info);
00337 
00338 /*              Check error code from DLATMS. */
00339 
00340                 if (info != 0) {
00341                     alaerh_(path, "DLATMS", &info, &c__0, " ", &m, &n, &c_n1, 
00342                             &c_n1, &c_n1, &imat, &nfail, &nerrs, nout);
00343                     goto L100;
00344                 }
00345 
00346 /*              For types 5-7, zero one or more columns of the matrix to */
00347 /*              test that INFO is returned correctly. */
00348 
00349                 if (zerot) {
00350                     if (imat == 5) {
00351                         izero = 1;
00352                     } else if (imat == 6) {
00353                         izero = min(m,n);
00354                     } else {
00355                         izero = min(m,n) / 2 + 1;
00356                     }
00357                     ioff = (izero - 1) * lda;
00358                     if (imat < 7) {
00359                         i__4 = m;
00360                         for (i__ = 1; i__ <= i__4; ++i__) {
00361                             a[ioff + i__] = 0.;
00362 /* L20: */
00363                         }
00364                     } else {
00365                         i__4 = n - izero + 1;
00366                         dlaset_("Full", &m, &i__4, &c_b23, &c_b23, &a[ioff + 
00367                                 1], &lda);
00368                     }
00369                 } else {
00370                     izero = 0;
00371                 }
00372 
00373 /*              These lines, if used in place of the calls in the DO 60 */
00374 /*              loop, cause the code to bomb on a Sun SPARCstation. */
00375 
00376 /*               ANORMO = DLANGE( 'O', M, N, A, LDA, RWORK ) */
00377 /*               ANORMI = DLANGE( 'I', M, N, A, LDA, RWORK ) */
00378 
00379 /*              Do for each blocksize in NBVAL */
00380 
00381                 i__4 = *nnb;
00382                 for (inb = 1; inb <= i__4; ++inb) {
00383                     nb = nbval[inb];
00384                     xlaenv_(&c__1, &nb);
00385 
00386 /*                 Compute the LU factorization of the matrix. */
00387 
00388                     dlacpy_("Full", &m, &n, &a[1], &lda, &afac[1], &lda);
00389                     s_copy(srnamc_1.srnamt, "DGETRF", (ftnlen)32, (ftnlen)6);
00390                     dgetrf_(&m, &n, &afac[1], &lda, &iwork[1], &info);
00391 
00392 /*                 Check error code from DGETRF. */
00393 
00394                     if (info != izero) {
00395                         alaerh_(path, "DGETRF", &info, &izero, " ", &m, &n, &
00396                                 c_n1, &c_n1, &nb, &imat, &nfail, &nerrs, nout);
00397                     }
00398                     trfcon = FALSE_;
00399 
00400 /* +    TEST 1 */
00401 /*                 Reconstruct matrix from factors and compute residual. */
00402 
00403                     dlacpy_("Full", &m, &n, &afac[1], &lda, &ainv[1], &lda);
00404                     dget01_(&m, &n, &a[1], &lda, &ainv[1], &lda, &iwork[1], &
00405                             rwork[1], result);
00406                     nt = 1;
00407 
00408 /* +    TEST 2 */
00409 /*                 Form the inverse if the factorization was successful */
00410 /*                 and compute the residual. */
00411 
00412                     if (m == n && info == 0) {
00413                         dlacpy_("Full", &n, &n, &afac[1], &lda, &ainv[1], &
00414                                 lda);
00415                         s_copy(srnamc_1.srnamt, "DGETRI", (ftnlen)32, (ftnlen)
00416                                 6);
00417                         nrhs = nsval[1];
00418                         lwork = *nmax * max(3,nrhs);
00419                         dgetri_(&n, &ainv[1], &lda, &iwork[1], &work[1], &
00420                                 lwork, &info);
00421 
00422 /*                    Check error code from DGETRI. */
00423 
00424                         if (info != 0) {
00425                             alaerh_(path, "DGETRI", &info, &c__0, " ", &n, &n, 
00426                                      &c_n1, &c_n1, &nb, &imat, &nfail, &nerrs, 
00427                                      nout);
00428                         }
00429 
00430 /*                    Compute the residual for the matrix times its */
00431 /*                    inverse.  Also compute the 1-norm condition number */
00432 /*                    of A. */
00433 
00434                         dget03_(&n, &a[1], &lda, &ainv[1], &lda, &work[1], &
00435                                 lda, &rwork[1], &rcondo, &result[1]);
00436                         anormo = dlange_("O", &m, &n, &a[1], &lda, &rwork[1]);
00437 
00438 /*                    Compute the infinity-norm condition number of A. */
00439 
00440                         anormi = dlange_("I", &m, &n, &a[1], &lda, &rwork[1]);
00441                         ainvnm = dlange_("I", &n, &n, &ainv[1], &lda, &rwork[
00442                                 1]);
00443                         if (anormi <= 0. || ainvnm <= 0.) {
00444                             rcondi = 1.;
00445                         } else {
00446                             rcondi = 1. / anormi / ainvnm;
00447                         }
00448                         nt = 2;
00449                     } else {
00450 
00451 /*                    Do only the condition estimate if INFO > 0. */
00452 
00453                         trfcon = TRUE_;
00454                         anormo = dlange_("O", &m, &n, &a[1], &lda, &rwork[1]);
00455                         anormi = dlange_("I", &m, &n, &a[1], &lda, &rwork[1]);
00456                         rcondo = 0.;
00457                         rcondi = 0.;
00458                     }
00459 
00460 /*                 Print information about the tests so far that did not */
00461 /*                 pass the threshold. */
00462 
00463                     i__5 = nt;
00464                     for (k = 1; k <= i__5; ++k) {
00465                         if (result[k - 1] >= *thresh) {
00466                             if (nfail == 0 && nerrs == 0) {
00467                                 alahd_(nout, path);
00468                             }
00469                             io___41.ciunit = *nout;
00470                             s_wsfe(&io___41);
00471                             do_fio(&c__1, (char *)&m, (ftnlen)sizeof(integer))
00472                                     ;
00473                             do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer))
00474                                     ;
00475                             do_fio(&c__1, (char *)&nb, (ftnlen)sizeof(integer)
00476                                     );
00477                             do_fio(&c__1, (char *)&imat, (ftnlen)sizeof(
00478                                     integer));
00479                             do_fio(&c__1, (char *)&k, (ftnlen)sizeof(integer))
00480                                     ;
00481                             do_fio(&c__1, (char *)&result[k - 1], (ftnlen)
00482                                     sizeof(doublereal));
00483                             e_wsfe();
00484                             ++nfail;
00485                         }
00486 /* L30: */
00487                     }
00488                     nrun += nt;
00489 
00490 /*                 Skip the remaining tests if this is not the first */
00491 /*                 block size or if M .ne. N.  Skip the solve tests if */
00492 /*                 the matrix is singular. */
00493 
00494                     if (inb > 1 || m != n) {
00495                         goto L90;
00496                     }
00497                     if (trfcon) {
00498                         goto L70;
00499                     }
00500 
00501                     i__5 = *nns;
00502                     for (irhs = 1; irhs <= i__5; ++irhs) {
00503                         nrhs = nsval[irhs];
00504                         *(unsigned char *)xtype = 'N';
00505 
00506                         for (itran = 1; itran <= 3; ++itran) {
00507                             *(unsigned char *)trans = *(unsigned char *)&
00508                                     transs[itran - 1];
00509                             if (itran == 1) {
00510                                 rcondc = rcondo;
00511                             } else {
00512                                 rcondc = rcondi;
00513                             }
00514 
00515 /* +    TEST 3 */
00516 /*                       Solve and compute residual for A * X = B. */
00517 
00518                             s_copy(srnamc_1.srnamt, "DLARHS", (ftnlen)32, (
00519                                     ftnlen)6);
00520                             dlarhs_(path, xtype, " ", trans, &n, &n, &kl, &ku, 
00521                                      &nrhs, &a[1], &lda, &xact[1], &lda, &b[1]
00522 , &lda, iseed, &info);
00523                             *(unsigned char *)xtype = 'C';
00524 
00525                             dlacpy_("Full", &n, &nrhs, &b[1], &lda, &x[1], &
00526                                     lda);
00527                             s_copy(srnamc_1.srnamt, "DGETRS", (ftnlen)32, (
00528                                     ftnlen)6);
00529                             dgetrs_(trans, &n, &nrhs, &afac[1], &lda, &iwork[
00530                                     1], &x[1], &lda, &info);
00531 
00532 /*                       Check error code from DGETRS. */
00533 
00534                             if (info != 0) {
00535                                 alaerh_(path, "DGETRS", &info, &c__0, trans, &
00536                                         n, &n, &c_n1, &c_n1, &nrhs, &imat, &
00537                                         nfail, &nerrs, nout);
00538                             }
00539 
00540                             dlacpy_("Full", &n, &nrhs, &b[1], &lda, &work[1], 
00541                                     &lda);
00542                             dget02_(trans, &n, &n, &nrhs, &a[1], &lda, &x[1], 
00543                                     &lda, &work[1], &lda, &rwork[1], &result[
00544                                     2]);
00545 
00546 /* +    TEST 4 */
00547 /*                       Check solution from generated exact solution. */
00548 
00549                             dget04_(&n, &nrhs, &x[1], &lda, &xact[1], &lda, &
00550                                     rcondc, &result[3]);
00551 
00552 /* +    TESTS 5, 6, and 7 */
00553 /*                       Use iterative refinement to improve the */
00554 /*                       solution. */
00555 
00556                             s_copy(srnamc_1.srnamt, "DGERFS", (ftnlen)32, (
00557                                     ftnlen)6);
00558                             dgerfs_(trans, &n, &nrhs, &a[1], &lda, &afac[1], &
00559                                     lda, &iwork[1], &b[1], &lda, &x[1], &lda, 
00560                                     &rwork[1], &rwork[nrhs + 1], &work[1], &
00561                                     iwork[n + 1], &info);
00562 
00563 /*                       Check error code from DGERFS. */
00564 
00565                             if (info != 0) {
00566                                 alaerh_(path, "DGERFS", &info, &c__0, trans, &
00567                                         n, &n, &c_n1, &c_n1, &nrhs, &imat, &
00568                                         nfail, &nerrs, nout);
00569                             }
00570 
00571                             dget04_(&n, &nrhs, &x[1], &lda, &xact[1], &lda, &
00572                                     rcondc, &result[4]);
00573                             dget07_(trans, &n, &nrhs, &a[1], &lda, &b[1], &
00574                                     lda, &x[1], &lda, &xact[1], &lda, &rwork[
00575                                     1], &c_true, &rwork[nrhs + 1], &result[5]);
00576 
00577 /*                       Print information about the tests that did not */
00578 /*                       pass the threshold. */
00579 
00580                             for (k = 3; k <= 7; ++k) {
00581                                 if (result[k - 1] >= *thresh) {
00582                                     if (nfail == 0 && nerrs == 0) {
00583                                         alahd_(nout, path);
00584                                     }
00585                                     io___46.ciunit = *nout;
00586                                     s_wsfe(&io___46);
00587                                     do_fio(&c__1, trans, (ftnlen)1);
00588                                     do_fio(&c__1, (char *)&n, (ftnlen)sizeof(
00589                                             integer));
00590                                     do_fio(&c__1, (char *)&nrhs, (ftnlen)
00591                                             sizeof(integer));
00592                                     do_fio(&c__1, (char *)&imat, (ftnlen)
00593                                             sizeof(integer));
00594                                     do_fio(&c__1, (char *)&k, (ftnlen)sizeof(
00595                                             integer));
00596                                     do_fio(&c__1, (char *)&result[k - 1], (
00597                                             ftnlen)sizeof(doublereal));
00598                                     e_wsfe();
00599                                     ++nfail;
00600                                 }
00601 /* L40: */
00602                             }
00603                             nrun += 5;
00604 /* L50: */
00605                         }
00606 /* L60: */
00607                     }
00608 
00609 /* +    TEST 8 */
00610 /*                    Get an estimate of RCOND = 1/CNDNUM. */
00611 
00612 L70:
00613                     for (itran = 1; itran <= 2; ++itran) {
00614                         if (itran == 1) {
00615                             anorm = anormo;
00616                             rcondc = rcondo;
00617                             *(unsigned char *)norm = 'O';
00618                         } else {
00619                             anorm = anormi;
00620                             rcondc = rcondi;
00621                             *(unsigned char *)norm = 'I';
00622                         }
00623                         s_copy(srnamc_1.srnamt, "DGECON", (ftnlen)32, (ftnlen)
00624                                 6);
00625                         dgecon_(norm, &n, &afac[1], &lda, &anorm, &rcond, &
00626                                 work[1], &iwork[n + 1], &info);
00627 
00628 /*                       Check error code from DGECON. */
00629 
00630                         if (info != 0) {
00631                             alaerh_(path, "DGECON", &info, &c__0, norm, &n, &
00632                                     n, &c_n1, &c_n1, &c_n1, &imat, &nfail, &
00633                                     nerrs, nout);
00634                         }
00635 
00636 /*                       This line is needed on a Sun SPARCstation. */
00637 
00638                         dummy = rcond;
00639 
00640                         result[7] = dget06_(&rcond, &rcondc);
00641 
00642 /*                    Print information about the tests that did not pass */
00643 /*                    the threshold. */
00644 
00645                         if (result[7] >= *thresh) {
00646                             if (nfail == 0 && nerrs == 0) {
00647                                 alahd_(nout, path);
00648                             }
00649                             io___50.ciunit = *nout;
00650                             s_wsfe(&io___50);
00651                             do_fio(&c__1, norm, (ftnlen)1);
00652                             do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer))
00653                                     ;
00654                             do_fio(&c__1, (char *)&imat, (ftnlen)sizeof(
00655                                     integer));
00656                             do_fio(&c__1, (char *)&c__8, (ftnlen)sizeof(
00657                                     integer));
00658                             do_fio(&c__1, (char *)&result[7], (ftnlen)sizeof(
00659                                     doublereal));
00660                             e_wsfe();
00661                             ++nfail;
00662                         }
00663                         ++nrun;
00664 /* L80: */
00665                     }
00666 L90:
00667                     ;
00668                 }
00669 L100:
00670                 ;
00671             }
00672 /* L110: */
00673         }
00674 /* L120: */
00675     }
00676 
00677 /*     Print a summary of the results. */
00678 
00679     alasum_(path, nout, &nfail, &nrun, &nerrs);
00680 
00681     return 0;
00682 
00683 /*     End of DCHKGE */
00684 
00685 } /* dchkge_ */


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