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

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