cdrvge.c
Go to the documentation of this file.
00001 /* cdrvge.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 complex c_b20 = {0.f,0.f};
00038 static logical c_true = TRUE_;
00039 static integer c__6 = 6;
00040 static integer c__7 = 7;
00041 
00042 /* Subroutine */ int cdrvge_(logical *dotype, integer *nn, integer *nval, 
00043         integer *nrhs, real *thresh, logical *tsterr, integer *nmax, complex *
00044         a, complex *afac, complex *asav, complex *b, complex *bsav, complex *
00045         x, complex *xact, real *s, complex *work, real *rwork, integer *iwork, 
00046          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     real r__1, r__2;
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     real amax;
00081     char path[3];
00082     integer imat, info;
00083     char dist[1];
00084     real rdum[1];
00085     char type__[1];
00086     integer nrun;
00087     extern /* Subroutine */ int cget01_(integer *, integer *, complex *, 
00088             integer *, complex *, integer *, integer *, real *, real *), 
00089             cget02_(char *, integer *, integer *, integer *, complex *, 
00090             integer *, complex *, integer *, complex *, integer *, real *, 
00091             real *);
00092     integer ifact;
00093     extern /* Subroutine */ int cget04_(integer *, integer *, complex *, 
00094             integer *, complex *, integer *, real *, real *);
00095     integer nfail, iseed[4], nfact;
00096     extern /* Subroutine */ int cget07_(char *, integer *, integer *, complex 
00097             *, integer *, complex *, integer *, complex *, integer *, complex 
00098             *, integer *, real *, logical *, real *, real *);
00099     extern logical lsame_(char *, char *);
00100     char equed[1];
00101     integer nbmin;
00102     real rcond, roldc;
00103     extern /* Subroutine */ int cgesv_(integer *, integer *, complex *, 
00104             integer *, integer *, complex *, integer *, integer *);
00105     integer nimat;
00106     real roldi;
00107     extern doublereal sget06_(real *, real *);
00108     real anorm;
00109     integer itran;
00110     logical equil;
00111     real roldo;
00112     char trans[1];
00113     integer izero, nerrs, lwork;
00114     logical zerot;
00115     char xtype[1];
00116     extern /* Subroutine */ int clatb4_(char *, integer *, integer *, integer 
00117             *, char *, integer *, integer *, real *, integer *, real *, char *
00118 ), aladhd_(integer *, char *);
00119     extern doublereal clange_(char *, integer *, integer *, complex *, 
00120             integer *, real *);
00121     extern /* Subroutine */ int alaerh_(char *, char *, integer *, integer *, 
00122             char *, integer *, integer *, integer *, integer *, integer *, 
00123             integer *, integer *, integer *, integer *), claqge_(integer *, integer *, complex *, integer *, real 
00124             *, real *, real *, real *, real *, char *);
00125     logical prefac;
00126     real colcnd;
00127     extern doublereal slamch_(char *);
00128     real rcondc;
00129     extern /* Subroutine */ int cgeequ_(integer *, integer *, complex *, 
00130             integer *, real *, real *, real *, real *, real *, integer *);
00131     logical nofact;
00132     integer iequed;
00133     extern /* Subroutine */ int cgetrf_(integer *, integer *, complex *, 
00134             integer *, integer *, integer *);
00135     real rcondi;
00136     extern /* Subroutine */ int cgetri_(integer *, complex *, integer *, 
00137             integer *, complex *, integer *, integer *), clacpy_(char *, 
00138             integer *, integer *, complex *, integer *, complex *, integer *), clarhs_(char *, char *, char *, char *, integer *, 
00139             integer *, integer *, integer *, integer *, complex *, integer *, 
00140             complex *, integer *, complex *, integer *, integer *, integer *);
00141     extern doublereal clantr_(char *, char *, char *, integer *, integer *, 
00142             complex *, integer *, real *);
00143     real cndnum, anormi, rcondo, ainvnm;
00144     extern /* Subroutine */ int alasvm_(char *, integer *, integer *, integer 
00145             *, integer *), claset_(char *, integer *, integer *, 
00146             complex *, complex *, complex *, integer *);
00147     logical trfcon;
00148     real anormo, rowcnd;
00149     extern /* Subroutine */ int cgesvx_(char *, char *, integer *, integer *, 
00150             complex *, integer *, complex *, integer *, integer *, char *, 
00151             real *, real *, complex *, integer *, complex *, integer *, real *
00152 , real *, real *, complex *, real *, integer *), clatms_(integer *, integer *, char *, integer *, char *, 
00153             real *, integer *, real *, real *, integer *, integer *, char *, 
00154             complex *, integer *, complex *, integer *), xlaenv_(integer *, integer *), cerrvx_(char *, integer *);
00155     real result[7], rpvgrw;
00156 
00157     /* Fortran I/O blocks */
00158     static cilist io___55 = { 0, 0, 0, fmt_9999, 0 };
00159     static cilist io___62 = { 0, 0, 0, fmt_9997, 0 };
00160     static cilist io___63 = { 0, 0, 0, fmt_9998, 0 };
00161     static cilist io___64 = { 0, 0, 0, fmt_9997, 0 };
00162     static cilist io___65 = { 0, 0, 0, fmt_9998, 0 };
00163     static cilist io___66 = { 0, 0, 0, fmt_9997, 0 };
00164     static cilist io___67 = { 0, 0, 0, fmt_9998, 0 };
00165     static cilist io___68 = { 0, 0, 0, fmt_9997, 0 };
00166     static cilist io___69 = { 0, 0, 0, fmt_9998, 0 };
00167 
00168 
00169 
00170 /*  -- LAPACK test routine (version 3.1) -- */
00171 /*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
00172 /*     November 2006 */
00173 
00174 /*     .. Scalar Arguments .. */
00175 /*     .. */
00176 /*     .. Array Arguments .. */
00177 /*     .. */
00178 
00179 /*  Purpose */
00180 /*  ======= */
00181 
00182 /*  CDRVGE tests the driver routines CGESV and -SVX. */
00183 
00184 /*  Arguments */
00185 /*  ========= */
00186 
00187 /*  DOTYPE  (input) LOGICAL array, dimension (NTYPES) */
00188 /*          The matrix types to be used for testing.  Matrices of type j */
00189 /*          (for 1 <= j <= NTYPES) are used for testing if DOTYPE(j) = */
00190 /*          .TRUE.; if DOTYPE(j) = .FALSE., then type j is not used. */
00191 
00192 /*  NN      (input) INTEGER */
00193 /*          The number of values of N contained in the vector NVAL. */
00194 
00195 /*  NVAL    (input) INTEGER array, dimension (NN) */
00196 /*          The values of the matrix column dimension N. */
00197 
00198 /*  NRHS    (input) INTEGER */
00199 /*          The number of right hand side vectors to be generated for */
00200 /*          each linear system. */
00201 
00202 /*  THRESH  (input) REAL */
00203 /*          The threshold value for the test ratios.  A result is */
00204 /*          included in the output file if RESULT >= THRESH.  To have */
00205 /*          every test ratio printed, use THRESH = 0. */
00206 
00207 /*  TSTERR  (input) LOGICAL */
00208 /*          Flag that indicates whether error exits are to be tested. */
00209 
00210 /*  NMAX    (input) INTEGER */
00211 /*          The maximum value permitted for N, used in dimensioning the */
00212 /*          work arrays. */
00213 
00214 /*  A       (workspace) COMPLEX array, dimension (NMAX*NMAX) */
00215 
00216 /*  AFAC    (workspace) COMPLEX array, dimension (NMAX*NMAX) */
00217 
00218 /*  ASAV    (workspace) COMPLEX array, dimension (NMAX*NMAX) */
00219 
00220 /*  B       (workspace) COMPLEX array, dimension (NMAX*NRHS) */
00221 
00222 /*  BSAV    (workspace) COMPLEX array, dimension (NMAX*NRHS) */
00223 
00224 /*  X       (workspace) COMPLEX array, dimension (NMAX*NRHS) */
00225 
00226 /*  XACT    (workspace) COMPLEX array, dimension (NMAX*NRHS) */
00227 
00228 /*  S       (workspace) REAL array, dimension (2*NMAX) */
00229 
00230 /*  WORK    (workspace) COMPLEX array, dimension */
00231 /*                      (NMAX*max(3,NRHS)) */
00232 
00233 /*  RWORK   (workspace) REAL array, dimension (2*NRHS+NMAX) */
00234 
00235 /*  IWORK   (workspace) INTEGER array, dimension (NMAX) */
00236 
00237 /*  NOUT    (input) INTEGER */
00238 /*          The unit number for output. */
00239 
00240 /*  ===================================================================== */
00241 
00242 /*     .. Parameters .. */
00243 /*     .. */
00244 /*     .. Local Scalars .. */
00245 /*     .. */
00246 /*     .. Local Arrays .. */
00247 /*     .. */
00248 /*     .. External Functions .. */
00249 /*     .. */
00250 /*     .. External Subroutines .. */
00251 /*     .. */
00252 /*     .. Intrinsic Functions .. */
00253 /*     .. */
00254 /*     .. Scalars in Common .. */
00255 /*     .. */
00256 /*     .. Common blocks .. */
00257 /*     .. */
00258 /*     .. Data statements .. */
00259     /* Parameter adjustments */
00260     --iwork;
00261     --rwork;
00262     --work;
00263     --s;
00264     --xact;
00265     --x;
00266     --bsav;
00267     --b;
00268     --asav;
00269     --afac;
00270     --a;
00271     --nval;
00272     --dotype;
00273 
00274     /* Function Body */
00275 /*     .. */
00276 /*     .. Executable Statements .. */
00277 
00278 /*     Initialize constants and the random number seed. */
00279 
00280     s_copy(path, "Complex precision", (ftnlen)1, (ftnlen)17);
00281     s_copy(path + 1, "GE", (ftnlen)2, (ftnlen)2);
00282     nrun = 0;
00283     nfail = 0;
00284     nerrs = 0;
00285     for (i__ = 1; i__ <= 4; ++i__) {
00286         iseed[i__ - 1] = iseedy[i__ - 1];
00287 /* L10: */
00288     }
00289 
00290 /*     Test the error exits */
00291 
00292     if (*tsterr) {
00293         cerrvx_(path, nout);
00294     }
00295     infoc_1.infot = 0;
00296 
00297 /*     Set the block size and minimum block size for testing. */
00298 
00299     nb = 1;
00300     nbmin = 2;
00301     xlaenv_(&c__1, &nb);
00302     xlaenv_(&c__2, &nbmin);
00303 
00304 /*     Do for each value of N in NVAL */
00305 
00306     i__1 = *nn;
00307     for (in = 1; in <= i__1; ++in) {
00308         n = nval[in];
00309         lda = max(n,1);
00310         *(unsigned char *)xtype = 'N';
00311         nimat = 11;
00312         if (n <= 0) {
00313             nimat = 1;
00314         }
00315 
00316         i__2 = nimat;
00317         for (imat = 1; imat <= i__2; ++imat) {
00318 
00319 /*           Do the tests only if DOTYPE( IMAT ) is true. */
00320 
00321             if (! dotype[imat]) {
00322                 goto L80;
00323             }
00324 
00325 /*           Skip types 5, 6, or 7 if the matrix size is too small. */
00326 
00327             zerot = imat >= 5 && imat <= 7;
00328             if (zerot && n < imat - 4) {
00329                 goto L80;
00330             }
00331 
00332 /*           Set up parameters with CLATB4 and generate a test matrix */
00333 /*           with CLATMS. */
00334 
00335             clatb4_(path, &imat, &n, &n, type__, &kl, &ku, &anorm, &mode, &
00336                     cndnum, dist);
00337             rcondc = 1.f / cndnum;
00338 
00339             s_copy(srnamc_1.srnamt, "CLATMS", (ftnlen)32, (ftnlen)6);
00340             clatms_(&n, &n, dist, iseed, type__, &rwork[1], &mode, &cndnum, &
00341                     anorm, &kl, &ku, "No packing", &a[1], &lda, &work[1], &
00342                     info);
00343 
00344 /*           Check error code from CLATMS. */
00345 
00346             if (info != 0) {
00347                 alaerh_(path, "CLATMS", &info, &c__0, " ", &n, &n, &c_n1, &
00348                         c_n1, &c_n1, &imat, &nfail, &nerrs, nout);
00349                 goto L80;
00350             }
00351 
00352 /*           For types 5-7, zero one or more columns of the matrix to */
00353 /*           test that INFO is returned correctly. */
00354 
00355             if (zerot) {
00356                 if (imat == 5) {
00357                     izero = 1;
00358                 } else if (imat == 6) {
00359                     izero = n;
00360                 } else {
00361                     izero = n / 2 + 1;
00362                 }
00363                 ioff = (izero - 1) * lda;
00364                 if (imat < 7) {
00365                     i__3 = n;
00366                     for (i__ = 1; i__ <= i__3; ++i__) {
00367                         i__4 = ioff + i__;
00368                         a[i__4].r = 0.f, a[i__4].i = 0.f;
00369 /* L20: */
00370                     }
00371                 } else {
00372                     i__3 = n - izero + 1;
00373                     claset_("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             clacpy_("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 CGESVX (FACT = 'N' reuses */
00412 /*                    the condition number from the previous iteration */
00413 /*                    with FACT = 'F'). */
00414 
00415                         clacpy_("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                             cgeequ_(&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                                 claqge_(&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 CGET04. */
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 = clange_("1", &n, &n, &afac[1], &lda, &rwork[
00455                                 1]);
00456                         anormi = clange_("I", &n, &n, &afac[1], &lda, &rwork[
00457                                 1]);
00458 
00459 /*                    Factor the matrix A. */
00460 
00461                         cgetrf_(&n, &n, &afac[1], &lda, &iwork[1], &info);
00462 
00463 /*                    Form the inverse of A. */
00464 
00465                         clacpy_("Full", &n, &n, &afac[1], &lda, &a[1], &lda);
00466                         lwork = *nmax * max(3,*nrhs);
00467                         cgetri_(&n, &a[1], &lda, &iwork[1], &work[1], &lwork, 
00468                                 &info);
00469 
00470 /*                    Compute the 1-norm condition number of A. */
00471 
00472                         ainvnm = clange_("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 = clange_("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                         clacpy_("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, "CLARHS", (ftnlen)32, (ftnlen)
00508                                 6);
00509                         clarhs_(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                         clacpy_("Full", &n, nrhs, &b[1], &lda, &bsav[1], &lda);
00514 
00515                         if (nofact && itran == 1) {
00516 
00517 /*                       --- Test CGESV  --- */
00518 
00519 /*                       Compute the LU factorization of the matrix and */
00520 /*                       solve the system. */
00521 
00522                             clacpy_("Full", &n, &n, &a[1], &lda, &afac[1], &
00523                                     lda);
00524                             clacpy_("Full", &n, nrhs, &b[1], &lda, &x[1], &
00525                                     lda);
00526 
00527                             s_copy(srnamc_1.srnamt, "CGESV ", (ftnlen)32, (
00528                                     ftnlen)6);
00529                             cgesv_(&n, nrhs, &afac[1], &lda, &iwork[1], &x[1], 
00530                                      &lda, &info);
00531 
00532 /*                       Check error code from CGESV . */
00533 
00534                             if (info != izero) {
00535                                 alaerh_(path, "CGESV ", &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                             cget01_(&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                                 clacpy_("Full", &n, nrhs, &b[1], &lda, &work[
00551                                         1], &lda);
00552                                 cget02_("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                                 cget04_(&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, "CGESV ", (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 CGESVX --- */
00592 
00593                         if (! prefac) {
00594                             claset_("Full", &n, &n, &c_b20, &c_b20, &afac[1], 
00595                                     &lda);
00596                         }
00597                         claset_("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                             claqge_(&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 CGESVX. */
00609 
00610                         s_copy(srnamc_1.srnamt, "CGESVX", (ftnlen)32, (ftnlen)
00611                                 6);
00612                         cgesvx_(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], &rwork[(*nrhs << 
00616                                 1) + 1], &info);
00617 
00618 /*                    Check the error code from CGESVX. */
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, "CGESVX", &info, &izero, ch__1, &n, 
00626                                     &n, &c_n1, &c_n1, nrhs, &imat, &nfail, &
00627                                     nerrs, nout);
00628                         }
00629 
00630 /*                    Compare RWORK(2*NRHS+1) from CGESVX with the */
00631 /*                    computed reciprocal pivot growth factor RPVGRW */
00632 
00633                         if (info != 0) {
00634                             rpvgrw = clantr_("M", "U", "N", &info, &info, &
00635                                     afac[1], &lda, rdum);
00636                             if (rpvgrw == 0.f) {
00637                                 rpvgrw = 1.f;
00638                             } else {
00639                                 rpvgrw = clange_("M", &n, &info, &a[1], &lda, 
00640                                         rdum) / rpvgrw;
00641                             }
00642                         } else {
00643                             rpvgrw = clantr_("M", "U", "N", &n, &n, &afac[1], 
00644                                     &lda, rdum);
00645                             if (rpvgrw == 0.f) {
00646                                 rpvgrw = 1.f;
00647                             } else {
00648                                 rpvgrw = clange_("M", &n, &n, &a[1], &lda, 
00649                                         rdum) / rpvgrw;
00650                             }
00651                         }
00652 /* Computing MAX */
00653                         r__2 = rwork[(*nrhs << 1) + 1];
00654                         result[6] = (r__1 = rpvgrw - rwork[(*nrhs << 1) + 1], 
00655                                 dabs(r__1)) / dmax(r__2,rpvgrw) / slamch_(
00656                                 "E");
00657 
00658                         if (! prefac) {
00659 
00660 /*                       Reconstruct matrix from factors and compute */
00661 /*                       residual. */
00662 
00663                             cget01_(&n, &n, &a[1], &lda, &afac[1], &lda, &
00664                                     iwork[1], &rwork[(*nrhs << 1) + 1], 
00665                                     result);
00666                             k1 = 1;
00667                         } else {
00668                             k1 = 2;
00669                         }
00670 
00671                         if (info == 0) {
00672                             trfcon = FALSE_;
00673 
00674 /*                       Compute residual of the computed solution. */
00675 
00676                             clacpy_("Full", &n, nrhs, &bsav[1], &lda, &work[1]
00677 , &lda);
00678                             cget02_(trans, &n, &n, nrhs, &asav[1], &lda, &x[1]
00679 , &lda, &work[1], &lda, &rwork[(*nrhs << 
00680                                     1) + 1], &result[1]);
00681 
00682 /*                       Check solution from generated exact solution. */
00683 
00684                             if (nofact || prefac && lsame_(equed, "N")) {
00685                                 cget04_(&n, nrhs, &x[1], &lda, &xact[1], &lda, 
00686                                          &rcondc, &result[2]);
00687                             } else {
00688                                 if (itran == 1) {
00689                                     roldc = roldo;
00690                                 } else {
00691                                     roldc = roldi;
00692                                 }
00693                                 cget04_(&n, nrhs, &x[1], &lda, &xact[1], &lda, 
00694                                          &roldc, &result[2]);
00695                             }
00696 
00697 /*                       Check the error bounds from iterative */
00698 /*                       refinement. */
00699 
00700                             cget07_(trans, &n, nrhs, &asav[1], &lda, &b[1], &
00701                                     lda, &x[1], &lda, &xact[1], &lda, &rwork[
00702                                     1], &c_true, &rwork[*nrhs + 1], &result[3]
00703 );
00704                         } else {
00705                             trfcon = TRUE_;
00706                         }
00707 
00708 /*                    Compare RCOND from CGESVX with the computed value */
00709 /*                    in RCONDC. */
00710 
00711                         result[5] = sget06_(&rcond, &rcondc);
00712 
00713 /*                    Print information about the tests that did not pass */
00714 /*                    the threshold. */
00715 
00716                         if (! trfcon) {
00717                             for (k = k1; k <= 7; ++k) {
00718                                 if (result[k - 1] >= *thresh) {
00719                                     if (nfail == 0 && nerrs == 0) {
00720                                         aladhd_(nout, path);
00721                                     }
00722                                     if (prefac) {
00723                                         io___62.ciunit = *nout;
00724                                         s_wsfe(&io___62);
00725                                         do_fio(&c__1, "CGESVX", (ftnlen)6);
00726                                         do_fio(&c__1, fact, (ftnlen)1);
00727                                         do_fio(&c__1, trans, (ftnlen)1);
00728                                         do_fio(&c__1, (char *)&n, (ftnlen)
00729                                                 sizeof(integer));
00730                                         do_fio(&c__1, equed, (ftnlen)1);
00731                                         do_fio(&c__1, (char *)&imat, (ftnlen)
00732                                                 sizeof(integer));
00733                                         do_fio(&c__1, (char *)&k, (ftnlen)
00734                                                 sizeof(integer));
00735                                         do_fio(&c__1, (char *)&result[k - 1], 
00736                                                 (ftnlen)sizeof(real));
00737                                         e_wsfe();
00738                                     } else {
00739                                         io___63.ciunit = *nout;
00740                                         s_wsfe(&io___63);
00741                                         do_fio(&c__1, "CGESVX", (ftnlen)6);
00742                                         do_fio(&c__1, fact, (ftnlen)1);
00743                                         do_fio(&c__1, trans, (ftnlen)1);
00744                                         do_fio(&c__1, (char *)&n, (ftnlen)
00745                                                 sizeof(integer));
00746                                         do_fio(&c__1, (char *)&imat, (ftnlen)
00747                                                 sizeof(integer));
00748                                         do_fio(&c__1, (char *)&k, (ftnlen)
00749                                                 sizeof(integer));
00750                                         do_fio(&c__1, (char *)&result[k - 1], 
00751                                                 (ftnlen)sizeof(real));
00752                                         e_wsfe();
00753                                     }
00754                                     ++nfail;
00755                                 }
00756 /* L40: */
00757                             }
00758                             nrun = nrun + 7 - k1;
00759                         } else {
00760                             if (result[0] >= *thresh && ! prefac) {
00761                                 if (nfail == 0 && nerrs == 0) {
00762                                     aladhd_(nout, path);
00763                                 }
00764                                 if (prefac) {
00765                                     io___64.ciunit = *nout;
00766                                     s_wsfe(&io___64);
00767                                     do_fio(&c__1, "CGESVX", (ftnlen)6);
00768                                     do_fio(&c__1, fact, (ftnlen)1);
00769                                     do_fio(&c__1, trans, (ftnlen)1);
00770                                     do_fio(&c__1, (char *)&n, (ftnlen)sizeof(
00771                                             integer));
00772                                     do_fio(&c__1, equed, (ftnlen)1);
00773                                     do_fio(&c__1, (char *)&imat, (ftnlen)
00774                                             sizeof(integer));
00775                                     do_fio(&c__1, (char *)&c__1, (ftnlen)
00776                                             sizeof(integer));
00777                                     do_fio(&c__1, (char *)&result[0], (ftnlen)
00778                                             sizeof(real));
00779                                     e_wsfe();
00780                                 } else {
00781                                     io___65.ciunit = *nout;
00782                                     s_wsfe(&io___65);
00783                                     do_fio(&c__1, "CGESVX", (ftnlen)6);
00784                                     do_fio(&c__1, fact, (ftnlen)1);
00785                                     do_fio(&c__1, trans, (ftnlen)1);
00786                                     do_fio(&c__1, (char *)&n, (ftnlen)sizeof(
00787                                             integer));
00788                                     do_fio(&c__1, (char *)&imat, (ftnlen)
00789                                             sizeof(integer));
00790                                     do_fio(&c__1, (char *)&c__1, (ftnlen)
00791                                             sizeof(integer));
00792                                     do_fio(&c__1, (char *)&result[0], (ftnlen)
00793                                             sizeof(real));
00794                                     e_wsfe();
00795                                 }
00796                                 ++nfail;
00797                                 ++nrun;
00798                             }
00799                             if (result[5] >= *thresh) {
00800                                 if (nfail == 0 && nerrs == 0) {
00801                                     aladhd_(nout, path);
00802                                 }
00803                                 if (prefac) {
00804                                     io___66.ciunit = *nout;
00805                                     s_wsfe(&io___66);
00806                                     do_fio(&c__1, "CGESVX", (ftnlen)6);
00807                                     do_fio(&c__1, fact, (ftnlen)1);
00808                                     do_fio(&c__1, trans, (ftnlen)1);
00809                                     do_fio(&c__1, (char *)&n, (ftnlen)sizeof(
00810                                             integer));
00811                                     do_fio(&c__1, equed, (ftnlen)1);
00812                                     do_fio(&c__1, (char *)&imat, (ftnlen)
00813                                             sizeof(integer));
00814                                     do_fio(&c__1, (char *)&c__6, (ftnlen)
00815                                             sizeof(integer));
00816                                     do_fio(&c__1, (char *)&result[5], (ftnlen)
00817                                             sizeof(real));
00818                                     e_wsfe();
00819                                 } else {
00820                                     io___67.ciunit = *nout;
00821                                     s_wsfe(&io___67);
00822                                     do_fio(&c__1, "CGESVX", (ftnlen)6);
00823                                     do_fio(&c__1, fact, (ftnlen)1);
00824                                     do_fio(&c__1, trans, (ftnlen)1);
00825                                     do_fio(&c__1, (char *)&n, (ftnlen)sizeof(
00826                                             integer));
00827                                     do_fio(&c__1, (char *)&imat, (ftnlen)
00828                                             sizeof(integer));
00829                                     do_fio(&c__1, (char *)&c__6, (ftnlen)
00830                                             sizeof(integer));
00831                                     do_fio(&c__1, (char *)&result[5], (ftnlen)
00832                                             sizeof(real));
00833                                     e_wsfe();
00834                                 }
00835                                 ++nfail;
00836                                 ++nrun;
00837                             }
00838                             if (result[6] >= *thresh) {
00839                                 if (nfail == 0 && nerrs == 0) {
00840                                     aladhd_(nout, path);
00841                                 }
00842                                 if (prefac) {
00843                                     io___68.ciunit = *nout;
00844                                     s_wsfe(&io___68);
00845                                     do_fio(&c__1, "CGESVX", (ftnlen)6);
00846                                     do_fio(&c__1, fact, (ftnlen)1);
00847                                     do_fio(&c__1, trans, (ftnlen)1);
00848                                     do_fio(&c__1, (char *)&n, (ftnlen)sizeof(
00849                                             integer));
00850                                     do_fio(&c__1, equed, (ftnlen)1);
00851                                     do_fio(&c__1, (char *)&imat, (ftnlen)
00852                                             sizeof(integer));
00853                                     do_fio(&c__1, (char *)&c__7, (ftnlen)
00854                                             sizeof(integer));
00855                                     do_fio(&c__1, (char *)&result[6], (ftnlen)
00856                                             sizeof(real));
00857                                     e_wsfe();
00858                                 } else {
00859                                     io___69.ciunit = *nout;
00860                                     s_wsfe(&io___69);
00861                                     do_fio(&c__1, "CGESVX", (ftnlen)6);
00862                                     do_fio(&c__1, fact, (ftnlen)1);
00863                                     do_fio(&c__1, trans, (ftnlen)1);
00864                                     do_fio(&c__1, (char *)&n, (ftnlen)sizeof(
00865                                             integer));
00866                                     do_fio(&c__1, (char *)&imat, (ftnlen)
00867                                             sizeof(integer));
00868                                     do_fio(&c__1, (char *)&c__7, (ftnlen)
00869                                             sizeof(integer));
00870                                     do_fio(&c__1, (char *)&result[6], (ftnlen)
00871                                             sizeof(real));
00872                                     e_wsfe();
00873                                 }
00874                                 ++nfail;
00875                                 ++nrun;
00876                             }
00877 
00878                         }
00879 
00880 /* L50: */
00881                     }
00882 L60:
00883                     ;
00884                 }
00885 /* L70: */
00886             }
00887 L80:
00888             ;
00889         }
00890 /* L90: */
00891     }
00892 
00893 /*     Print a summary of the results. */
00894 
00895     alasvm_(path, nout, &nfail, &nrun, &nerrs);
00896 
00897     return 0;
00898 
00899 /*     End of CDRVGE */
00900 
00901 } /* cdrvge_ */

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