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


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