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

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