cdrvpo.c
Go to the documentation of this file.
00001 /* cdrvpo.f -- translated by f2c (version 20061008).
00002    You must link the resulting object file with libf2c:
00003         on Microsoft Windows system, link with libf2c.lib;
00004         on Linux or Unix systems, link with .../path/to/libf2c.a -lm
00005         or, if you install libf2c.a in a standard place, with -lf2c -lm
00006         -- in that order, at the end of the command line, as in
00007                 cc *.o -lf2c -lm
00008         Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
00009 
00010                 http://www.netlib.org/f2c/libf2c.zip
00011 */
00012 
00013 #include "f2c.h"
00014 #include "blaswrap.h"
00015 
00016 /* Common Block Declarations */
00017 
00018 struct {
00019     integer infot, nunit;
00020     logical ok, lerr;
00021 } infoc_;
00022 
00023 #define infoc_1 infoc_
00024 
00025 struct {
00026     char srnamt[32];
00027 } srnamc_;
00028 
00029 #define srnamc_1 srnamc_
00030 
00031 /* Table of constant values */
00032 
00033 static integer c__1 = 1;
00034 static integer c__2 = 2;
00035 static integer c__0 = 0;
00036 static integer c_n1 = -1;
00037 static complex c_b51 = {0.f,0.f};
00038 
00039 /* Subroutine */ int cdrvpo_(logical *dotype, integer *nn, integer *nval, 
00040         integer *nrhs, real *thresh, logical *tsterr, integer *nmax, complex *
00041         a, complex *afac, complex *asav, complex *b, complex *bsav, complex *
00042         x, complex *xact, real *s, complex *work, real *rwork, 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     integer i__, k, n, k1, nb, in, kl, ku, nt, lda;
00073     char fact[1];
00074     integer ioff, mode;
00075     real amax;
00076     char path[3];
00077     integer imat, info;
00078     char dist[1], uplo[1], type__[1];
00079     integer nrun, ifact;
00080     extern /* Subroutine */ int cget04_(integer *, integer *, complex *, 
00081             integer *, complex *, integer *, real *, real *);
00082     integer nfail, iseed[4], nfact;
00083     extern logical lsame_(char *, char *);
00084     char equed[1];
00085     integer nbmin;
00086     real rcond, roldc, scond;
00087     integer nimat;
00088     extern doublereal sget06_(real *, real *);
00089     extern /* Subroutine */ int cpot01_(char *, integer *, complex *, integer 
00090             *, complex *, integer *, real *, real *), cpot02_(char *, 
00091             integer *, integer *, complex *, integer *, complex *, integer *, 
00092             complex *, integer *, real *, real *);
00093     real anorm;
00094     extern /* Subroutine */ int cpot05_(char *, integer *, integer *, complex 
00095             *, integer *, complex *, integer *, complex *, integer *, complex 
00096             *, integer *, real *, real *, real *);
00097     logical equil;
00098     integer iuplo, izero, nerrs;
00099     extern /* Subroutine */ int cposv_(char *, integer *, integer *, complex *
00100 , integer *, complex *, integer *, integer *);
00101     logical zerot;
00102     char xtype[1];
00103     extern /* Subroutine */ int clatb4_(char *, integer *, integer *, integer 
00104             *, char *, integer *, integer *, real *, integer *, real *, char *
00105 ), aladhd_(integer *, char *);
00106     extern doublereal clanhe_(char *, char *, integer *, complex *, integer *, 
00107              real *);
00108     extern /* Subroutine */ int alaerh_(char *, char *, integer *, integer *, 
00109             char *, integer *, integer *, integer *, integer *, integer *, 
00110             integer *, integer *, integer *, integer *), claipd_(integer *, complex *, integer *, integer *), 
00111             claqhe_(char *, integer *, complex *, integer *, real *, real *, 
00112             real *, char *);
00113     logical prefac;
00114     real rcondc;
00115     logical nofact;
00116     extern /* Subroutine */ int clacpy_(char *, integer *, integer *, complex 
00117             *, integer *, complex *, integer *);
00118     integer iequed;
00119     extern /* Subroutine */ int clarhs_(char *, char *, char *, char *, 
00120             integer *, integer *, integer *, integer *, integer *, complex *, 
00121             integer *, complex *, integer *, complex *, integer *, integer *, 
00122             integer *), claset_(char *, 
00123             integer *, integer *, complex *, complex *, complex *, integer *), alasvm_(char *, integer *, integer *, integer *, integer 
00124             *);
00125     real cndnum;
00126     extern /* Subroutine */ int clatms_(integer *, integer *, char *, integer 
00127             *, char *, real *, integer *, real *, real *, integer *, integer *
00128 , char *, complex *, integer *, complex *, integer *);
00129     real ainvnm;
00130     extern /* Subroutine */ int cpoequ_(integer *, complex *, integer *, real 
00131             *, real *, real *, integer *), cpotrf_(char *, integer *, complex 
00132             *, integer *, integer *), cpotri_(char *, integer *, 
00133             complex *, integer *, integer *), xlaenv_(integer *, 
00134             integer *), cerrvx_(char *, integer *);
00135     real result[6];
00136     extern /* Subroutine */ int cposvx_(char *, char *, integer *, integer *, 
00137             complex *, integer *, complex *, integer *, char *, real *, 
00138             complex *, integer *, complex *, integer *, real *, real *, real *
00139 , complex *, real *, integer *);
00140 
00141     /* Fortran I/O blocks */
00142     static cilist io___48 = { 0, 0, 0, fmt_9999, 0 };
00143     static cilist io___51 = { 0, 0, 0, fmt_9997, 0 };
00144     static cilist io___52 = { 0, 0, 0, fmt_9998, 0 };
00145 
00146 
00147 
00148 /*  -- LAPACK test routine (version 3.1) -- */
00149 /*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
00150 /*     November 2006 */
00151 
00152 /*     .. Scalar Arguments .. */
00153 /*     .. */
00154 /*     .. Array Arguments .. */
00155 /*     .. */
00156 
00157 /*  Purpose */
00158 /*  ======= */
00159 
00160 /*  CDRVPO tests the driver routines CPOSV and -SVX. */
00161 
00162 /*  Arguments */
00163 /*  ========= */
00164 
00165 /*  DOTYPE  (input) LOGICAL array, dimension (NTYPES) */
00166 /*          The matrix types to be used for testing.  Matrices of type j */
00167 /*          (for 1 <= j <= NTYPES) are used for testing if DOTYPE(j) = */
00168 /*          .TRUE.; if DOTYPE(j) = .FALSE., then type j is not used. */
00169 
00170 /*  NN      (input) INTEGER */
00171 /*          The number of values of N contained in the vector NVAL. */
00172 
00173 /*  NVAL    (input) INTEGER array, dimension (NN) */
00174 /*          The values of the matrix dimension N. */
00175 
00176 /*  NRHS    (input) INTEGER */
00177 /*          The number of right hand side vectors to be generated for */
00178 /*          each linear system. */
00179 
00180 /*  THRESH  (input) REAL */
00181 /*          The threshold value for the test ratios.  A result is */
00182 /*          included in the output file if RESULT >= THRESH.  To have */
00183 /*          every test ratio printed, use THRESH = 0. */
00184 
00185 /*  TSTERR  (input) LOGICAL */
00186 /*          Flag that indicates whether error exits are to be tested. */
00187 
00188 /*  NMAX    (input) INTEGER */
00189 /*          The maximum value permitted for N, used in dimensioning the */
00190 /*          work arrays. */
00191 
00192 /*  A       (workspace) COMPLEX array, dimension (NMAX*NMAX) */
00193 
00194 /*  AFAC    (workspace) COMPLEX array, dimension (NMAX*NMAX) */
00195 
00196 /*  ASAV    (workspace) COMPLEX array, dimension (NMAX*NMAX) */
00197 
00198 /*  B       (workspace) COMPLEX array, dimension (NMAX*NRHS) */
00199 
00200 /*  BSAV    (workspace) COMPLEX array, dimension (NMAX*NRHS) */
00201 
00202 /*  X       (workspace) COMPLEX array, dimension (NMAX*NRHS) */
00203 
00204 /*  XACT    (workspace) COMPLEX array, dimension (NMAX*NRHS) */
00205 
00206 /*  S       (workspace) REAL array, dimension (NMAX) */
00207 
00208 /*  WORK    (workspace) COMPLEX array, dimension */
00209 /*                      (NMAX*max(3,NRHS)) */
00210 
00211 /*  RWORK   (workspace) REAL array, dimension (NMAX+2*NRHS) */
00212 
00213 /*  NOUT    (input) INTEGER */
00214 /*          The unit number for output. */
00215 
00216 /*  ===================================================================== */
00217 
00218 /*     .. Parameters .. */
00219 /*     .. */
00220 /*     .. Local Scalars .. */
00221 /*     .. */
00222 /*     .. Local Arrays .. */
00223 /*     .. */
00224 /*     .. External Functions .. */
00225 /*     .. */
00226 /*     .. External Subroutines .. */
00227 /*     .. */
00228 /*     .. Scalars in Common .. */
00229 /*     .. */
00230 /*     .. Common blocks .. */
00231 /*     .. */
00232 /*     .. Intrinsic Functions .. */
00233 /*     .. */
00234 /*     .. Data statements .. */
00235     /* Parameter adjustments */
00236     --rwork;
00237     --work;
00238     --s;
00239     --xact;
00240     --x;
00241     --bsav;
00242     --b;
00243     --asav;
00244     --afac;
00245     --a;
00246     --nval;
00247     --dotype;
00248 
00249     /* Function Body */
00250 /*     .. */
00251 /*     .. Executable Statements .. */
00252 
00253 /*     Initialize constants and the random number seed. */
00254 
00255     s_copy(path, "Complex precision", (ftnlen)1, (ftnlen)17);
00256     s_copy(path + 1, "PO", (ftnlen)2, (ftnlen)2);
00257     nrun = 0;
00258     nfail = 0;
00259     nerrs = 0;
00260     for (i__ = 1; i__ <= 4; ++i__) {
00261         iseed[i__ - 1] = iseedy[i__ - 1];
00262 /* L10: */
00263     }
00264 
00265 /*     Test the error exits */
00266 
00267     if (*tsterr) {
00268         cerrvx_(path, nout);
00269     }
00270     infoc_1.infot = 0;
00271 
00272 /*     Set the block size and minimum block size for testing. */
00273 
00274     nb = 1;
00275     nbmin = 2;
00276     xlaenv_(&c__1, &nb);
00277     xlaenv_(&c__2, &nbmin);
00278 
00279 /*     Do for each value of N in NVAL */
00280 
00281     i__1 = *nn;
00282     for (in = 1; in <= i__1; ++in) {
00283         n = nval[in];
00284         lda = max(n,1);
00285         *(unsigned char *)xtype = 'N';
00286         nimat = 9;
00287         if (n <= 0) {
00288             nimat = 1;
00289         }
00290 
00291         i__2 = nimat;
00292         for (imat = 1; imat <= i__2; ++imat) {
00293 
00294 /*           Do the tests only if DOTYPE( IMAT ) is true. */
00295 
00296             if (! dotype[imat]) {
00297                 goto L120;
00298             }
00299 
00300 /*           Skip types 3, 4, or 5 if the matrix size is too small. */
00301 
00302             zerot = imat >= 3 && imat <= 5;
00303             if (zerot && n < imat - 2) {
00304                 goto L120;
00305             }
00306 
00307 /*           Do first for UPLO = 'U', then for UPLO = 'L' */
00308 
00309             for (iuplo = 1; iuplo <= 2; ++iuplo) {
00310                 *(unsigned char *)uplo = *(unsigned char *)&uplos[iuplo - 1];
00311 
00312 /*              Set up parameters with CLATB4 and generate a test matrix */
00313 /*              with CLATMS. */
00314 
00315                 clatb4_(path, &imat, &n, &n, type__, &kl, &ku, &anorm, &mode, 
00316                         &cndnum, dist);
00317 
00318                 s_copy(srnamc_1.srnamt, "CLATMS", (ftnlen)32, (ftnlen)6);
00319                 clatms_(&n, &n, dist, iseed, type__, &rwork[1], &mode, &
00320                         cndnum, &anorm, &kl, &ku, uplo, &a[1], &lda, &work[1], 
00321                          &info);
00322 
00323 /*              Check error code from CLATMS. */
00324 
00325                 if (info != 0) {
00326                     alaerh_(path, "CLATMS", &info, &c__0, uplo, &n, &n, &c_n1, 
00327                              &c_n1, &c_n1, &imat, &nfail, &nerrs, nout);
00328                     goto L110;
00329                 }
00330 
00331 /*              For types 3-5, zero one row and column of the matrix to */
00332 /*              test that INFO is returned correctly. */
00333 
00334                 if (zerot) {
00335                     if (imat == 3) {
00336                         izero = 1;
00337                     } else if (imat == 4) {
00338                         izero = n;
00339                     } else {
00340                         izero = n / 2 + 1;
00341                     }
00342                     ioff = (izero - 1) * lda;
00343 
00344 /*                 Set row and column IZERO of A to 0. */
00345 
00346                     if (iuplo == 1) {
00347                         i__3 = izero - 1;
00348                         for (i__ = 1; i__ <= i__3; ++i__) {
00349                             i__4 = ioff + i__;
00350                             a[i__4].r = 0.f, a[i__4].i = 0.f;
00351 /* L20: */
00352                         }
00353                         ioff += izero;
00354                         i__3 = n;
00355                         for (i__ = izero; i__ <= i__3; ++i__) {
00356                             i__4 = ioff;
00357                             a[i__4].r = 0.f, a[i__4].i = 0.f;
00358                             ioff += lda;
00359 /* L30: */
00360                         }
00361                     } else {
00362                         ioff = izero;
00363                         i__3 = izero - 1;
00364                         for (i__ = 1; i__ <= i__3; ++i__) {
00365                             i__4 = ioff;
00366                             a[i__4].r = 0.f, a[i__4].i = 0.f;
00367                             ioff += lda;
00368 /* L40: */
00369                         }
00370                         ioff -= izero;
00371                         i__3 = n;
00372                         for (i__ = izero; i__ <= i__3; ++i__) {
00373                             i__4 = ioff + i__;
00374                             a[i__4].r = 0.f, a[i__4].i = 0.f;
00375 /* L50: */
00376                         }
00377                     }
00378                 } else {
00379                     izero = 0;
00380                 }
00381 
00382 /*              Set the imaginary part of the diagonals. */
00383 
00384                 i__3 = lda + 1;
00385                 claipd_(&n, &a[1], &i__3, &c__0);
00386 
00387 /*              Save a copy of the matrix A in ASAV. */
00388 
00389                 clacpy_(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                         *(unsigned char *)fact = *(unsigned char *)&facts[
00403                                 ifact - 1];
00404                         prefac = lsame_(fact, "F");
00405                         nofact = lsame_(fact, "N");
00406                         equil = lsame_(fact, "E");
00407 
00408                         if (zerot) {
00409                             if (prefac) {
00410                                 goto L90;
00411                             }
00412                             rcondc = 0.f;
00413 
00414                         } else if (! lsame_(fact, "N")) 
00415                                 {
00416 
00417 /*                       Compute the condition number for comparison with */
00418 /*                       the value returned by CPOSVX (FACT = 'N' reuses */
00419 /*                       the condition number from the previous iteration */
00420 /*                       with FACT = 'F'). */
00421 
00422                             clacpy_(uplo, &n, &n, &asav[1], &lda, &afac[1], &
00423                                     lda);
00424                             if (equil || iequed > 1) {
00425 
00426 /*                          Compute row and column scale factors to */
00427 /*                          equilibrate the matrix A. */
00428 
00429                                 cpoequ_(&n, &afac[1], &lda, &s[1], &scond, &
00430                                         amax, &info);
00431                                 if (info == 0 && n > 0) {
00432                                     if (iequed > 1) {
00433                                         scond = 0.f;
00434                                     }
00435 
00436 /*                             Equilibrate the matrix. */
00437 
00438                                     claqhe_(uplo, &n, &afac[1], &lda, &s[1], &
00439                                             scond, &amax, equed);
00440                                 }
00441                             }
00442 
00443 /*                       Save the condition number of the */
00444 /*                       non-equilibrated system for use in CGET04. */
00445 
00446                             if (equil) {
00447                                 roldc = rcondc;
00448                             }
00449 
00450 /*                       Compute the 1-norm of A. */
00451 
00452                             anorm = clanhe_("1", uplo, &n, &afac[1], &lda, &
00453                                     rwork[1]);
00454 
00455 /*                       Factor the matrix A. */
00456 
00457                             cpotrf_(uplo, &n, &afac[1], &lda, &info);
00458 
00459 /*                       Form the inverse of A. */
00460 
00461                             clacpy_(uplo, &n, &n, &afac[1], &lda, &a[1], &lda);
00462                             cpotri_(uplo, &n, &a[1], &lda, &info);
00463 
00464 /*                       Compute the 1-norm condition number of A. */
00465 
00466                             ainvnm = clanhe_("1", uplo, &n, &a[1], &lda, &
00467                                     rwork[1]);
00468                             if (anorm <= 0.f || ainvnm <= 0.f) {
00469                                 rcondc = 1.f;
00470                             } else {
00471                                 rcondc = 1.f / anorm / ainvnm;
00472                             }
00473                         }
00474 
00475 /*                    Restore the matrix A. */
00476 
00477                         clacpy_(uplo, &n, &n, &asav[1], &lda, &a[1], &lda);
00478 
00479 /*                    Form an exact solution and set the right hand side. */
00480 
00481                         s_copy(srnamc_1.srnamt, "CLARHS", (ftnlen)32, (ftnlen)
00482                                 6);
00483                         clarhs_(path, xtype, uplo, " ", &n, &n, &kl, &ku, 
00484                                 nrhs, &a[1], &lda, &xact[1], &lda, &b[1], &
00485                                 lda, iseed, &info);
00486                         *(unsigned char *)xtype = 'C';
00487                         clacpy_("Full", &n, nrhs, &b[1], &lda, &bsav[1], &lda);
00488 
00489                         if (nofact) {
00490 
00491 /*                       --- Test CPOSV  --- */
00492 
00493 /*                       Compute the L*L' or U'*U factorization of the */
00494 /*                       matrix and solve the system. */
00495 
00496                             clacpy_(uplo, &n, &n, &a[1], &lda, &afac[1], &lda);
00497                             clacpy_("Full", &n, nrhs, &b[1], &lda, &x[1], &
00498                                     lda);
00499 
00500                             s_copy(srnamc_1.srnamt, "CPOSV ", (ftnlen)32, (
00501                                     ftnlen)6);
00502                             cposv_(uplo, &n, nrhs, &afac[1], &lda, &x[1], &
00503                                     lda, &info);
00504 
00505 /*                       Check error code from CPOSV . */
00506 
00507                             if (info != izero) {
00508                                 alaerh_(path, "CPOSV ", &info, &izero, uplo, &
00509                                         n, &n, &c_n1, &c_n1, nrhs, &imat, &
00510                                         nfail, &nerrs, nout);
00511                                 goto L70;
00512                             } else if (info != 0) {
00513                                 goto L70;
00514                             }
00515 
00516 /*                       Reconstruct matrix from factors and compute */
00517 /*                       residual. */
00518 
00519                             cpot01_(uplo, &n, &a[1], &lda, &afac[1], &lda, &
00520                                     rwork[1], result);
00521 
00522 /*                       Compute residual of the computed solution. */
00523 
00524                             clacpy_("Full", &n, nrhs, &b[1], &lda, &work[1], &
00525                                     lda);
00526                             cpot02_(uplo, &n, nrhs, &a[1], &lda, &x[1], &lda, 
00527                                     &work[1], &lda, &rwork[1], &result[1]);
00528 
00529 /*                       Check solution from generated exact solution. */
00530 
00531                             cget04_(&n, nrhs, &x[1], &lda, &xact[1], &lda, &
00532                                     rcondc, &result[2]);
00533                             nt = 3;
00534 
00535 /*                       Print information about the tests that did not */
00536 /*                       pass the threshold. */
00537 
00538                             i__4 = nt;
00539                             for (k = 1; k <= i__4; ++k) {
00540                                 if (result[k - 1] >= *thresh) {
00541                                     if (nfail == 0 && nerrs == 0) {
00542                                         aladhd_(nout, path);
00543                                     }
00544                                     io___48.ciunit = *nout;
00545                                     s_wsfe(&io___48);
00546                                     do_fio(&c__1, "CPOSV ", (ftnlen)6);
00547                                     do_fio(&c__1, uplo, (ftnlen)1);
00548                                     do_fio(&c__1, (char *)&n, (ftnlen)sizeof(
00549                                             integer));
00550                                     do_fio(&c__1, (char *)&imat, (ftnlen)
00551                                             sizeof(integer));
00552                                     do_fio(&c__1, (char *)&k, (ftnlen)sizeof(
00553                                             integer));
00554                                     do_fio(&c__1, (char *)&result[k - 1], (
00555                                             ftnlen)sizeof(real));
00556                                     e_wsfe();
00557                                     ++nfail;
00558                                 }
00559 /* L60: */
00560                             }
00561                             nrun += nt;
00562 L70:
00563                             ;
00564                         }
00565 
00566 /*                    --- Test CPOSVX --- */
00567 
00568                         if (! prefac) {
00569                             claset_(uplo, &n, &n, &c_b51, &c_b51, &afac[1], &
00570                                     lda);
00571                         }
00572                         claset_("Full", &n, nrhs, &c_b51, &c_b51, &x[1], &lda);
00573                         if (iequed > 1 && n > 0) {
00574 
00575 /*                       Equilibrate the matrix if FACT='F' and */
00576 /*                       EQUED='Y'. */
00577 
00578                             claqhe_(uplo, &n, &a[1], &lda, &s[1], &scond, &
00579                                     amax, equed);
00580                         }
00581 
00582 /*                    Solve the system and compute the condition number */
00583 /*                    and error bounds using CPOSVX. */
00584 
00585                         s_copy(srnamc_1.srnamt, "CPOSVX", (ftnlen)32, (ftnlen)
00586                                 6);
00587                         cposvx_(fact, uplo, &n, nrhs, &a[1], &lda, &afac[1], &
00588                                 lda, equed, &s[1], &b[1], &lda, &x[1], &lda, &
00589                                 rcond, &rwork[1], &rwork[*nrhs + 1], &work[1], 
00590                                  &rwork[(*nrhs << 1) + 1], &info);
00591 
00592 /*                    Check the error code from CPOSVX. */
00593 
00594                         if (info != izero) {
00595 /* Writing concatenation */
00596                             i__5[0] = 1, a__1[0] = fact;
00597                             i__5[1] = 1, a__1[1] = uplo;
00598                             s_cat(ch__1, a__1, i__5, &c__2, (ftnlen)2);
00599                             alaerh_(path, "CPOSVX", &info, &izero, ch__1, &n, 
00600                                     &n, &c_n1, &c_n1, nrhs, &imat, &nfail, &
00601                                     nerrs, nout);
00602                             goto L90;
00603                         }
00604 
00605                         if (info == 0) {
00606                             if (! prefac) {
00607 
00608 /*                          Reconstruct matrix from factors and compute */
00609 /*                          residual. */
00610 
00611                                 cpot01_(uplo, &n, &a[1], &lda, &afac[1], &lda, 
00612                                          &rwork[(*nrhs << 1) + 1], result);
00613                                 k1 = 1;
00614                             } else {
00615                                 k1 = 2;
00616                             }
00617 
00618 /*                       Compute residual of the computed solution. */
00619 
00620                             clacpy_("Full", &n, nrhs, &bsav[1], &lda, &work[1]
00621 , &lda);
00622                             cpot02_(uplo, &n, nrhs, &asav[1], &lda, &x[1], &
00623                                     lda, &work[1], &lda, &rwork[(*nrhs << 1) 
00624                                     + 1], &result[1]);
00625 
00626 /*                       Check solution from generated exact solution. */
00627 
00628                             if (nofact || prefac && lsame_(equed, "N")) {
00629                                 cget04_(&n, nrhs, &x[1], &lda, &xact[1], &lda, 
00630                                          &rcondc, &result[2]);
00631                             } else {
00632                                 cget04_(&n, nrhs, &x[1], &lda, &xact[1], &lda, 
00633                                          &roldc, &result[2]);
00634                             }
00635 
00636 /*                       Check the error bounds from iterative */
00637 /*                       refinement. */
00638 
00639                             cpot05_(uplo, &n, nrhs, &asav[1], &lda, &b[1], &
00640                                     lda, &x[1], &lda, &xact[1], &lda, &rwork[
00641                                     1], &rwork[*nrhs + 1], &result[3]);
00642                         } else {
00643                             k1 = 6;
00644                         }
00645 
00646 /*                    Compare RCOND from CPOSVX with the computed value */
00647 /*                    in RCONDC. */
00648 
00649                         result[5] = sget06_(&rcond, &rcondc);
00650 
00651 /*                    Print information about the tests that did not pass */
00652 /*                    the threshold. */
00653 
00654                         for (k = k1; k <= 6; ++k) {
00655                             if (result[k - 1] >= *thresh) {
00656                                 if (nfail == 0 && nerrs == 0) {
00657                                     aladhd_(nout, path);
00658                                 }
00659                                 if (prefac) {
00660                                     io___51.ciunit = *nout;
00661                                     s_wsfe(&io___51);
00662                                     do_fio(&c__1, "CPOSVX", (ftnlen)6);
00663                                     do_fio(&c__1, fact, (ftnlen)1);
00664                                     do_fio(&c__1, uplo, (ftnlen)1);
00665                                     do_fio(&c__1, (char *)&n, (ftnlen)sizeof(
00666                                             integer));
00667                                     do_fio(&c__1, equed, (ftnlen)1);
00668                                     do_fio(&c__1, (char *)&imat, (ftnlen)
00669                                             sizeof(integer));
00670                                     do_fio(&c__1, (char *)&k, (ftnlen)sizeof(
00671                                             integer));
00672                                     do_fio(&c__1, (char *)&result[k - 1], (
00673                                             ftnlen)sizeof(real));
00674                                     e_wsfe();
00675                                 } else {
00676                                     io___52.ciunit = *nout;
00677                                     s_wsfe(&io___52);
00678                                     do_fio(&c__1, "CPOSVX", (ftnlen)6);
00679                                     do_fio(&c__1, fact, (ftnlen)1);
00680                                     do_fio(&c__1, uplo, (ftnlen)1);
00681                                     do_fio(&c__1, (char *)&n, (ftnlen)sizeof(
00682                                             integer));
00683                                     do_fio(&c__1, (char *)&imat, (ftnlen)
00684                                             sizeof(integer));
00685                                     do_fio(&c__1, (char *)&k, (ftnlen)sizeof(
00686                                             integer));
00687                                     do_fio(&c__1, (char *)&result[k - 1], (
00688                                             ftnlen)sizeof(real));
00689                                     e_wsfe();
00690                                 }
00691                                 ++nfail;
00692                             }
00693 /* L80: */
00694                         }
00695                         nrun = nrun + 7 - k1;
00696 L90:
00697                         ;
00698                     }
00699 /* L100: */
00700                 }
00701 L110:
00702                 ;
00703             }
00704 L120:
00705             ;
00706         }
00707 /* L130: */
00708     }
00709 
00710 /*     Print a summary of the results. */
00711 
00712     alasvm_(path, nout, &nfail, &nrun, &nerrs);
00713 
00714     return 0;
00715 
00716 /*     End of CDRVPO */
00717 
00718 } /* cdrvpo_ */


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