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

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