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

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