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

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