dchktp.c
Go to the documentation of this file.
00001 /* dchktp.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, iounit;
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__0 = 0;
00035 static integer c_n1 = -1;
00036 static integer c__2 = 2;
00037 static integer c__3 = 3;
00038 static integer c__7 = 7;
00039 static integer c__4 = 4;
00040 static doublereal c_b103 = 1.;
00041 static integer c__8 = 8;
00042 static integer c__9 = 9;
00043 
00044 /* Subroutine */ int dchktp_(logical *dotype, integer *nn, integer *nval, 
00045         integer *nns, integer *nsval, doublereal *thresh, logical *tsterr, 
00046         integer *nmax, doublereal *ap, doublereal *ainvp, doublereal *b, 
00047         doublereal *x, doublereal *xact, doublereal *work, doublereal *rwork, 
00048         integer *iwork, integer *nout)
00049 {
00050     /* Initialized data */
00051 
00052     static integer iseedy[4] = { 1988,1989,1990,1991 };
00053     static char uplos[1*2] = "U" "L";
00054     static char transs[1*3] = "N" "T" "C";
00055 
00056     /* Format strings */
00057     static char fmt_9999[] = "(\002 UPLO='\002,a1,\002', DIAG='\002,a1,\002'"
00058             ", N=\002,i5,\002, type \002,i2,\002, test(\002,i2,\002)= \002,g1"
00059             "2.5)";
00060     static char fmt_9998[] = "(\002 UPLO='\002,a1,\002', TRANS='\002,a1,\002"
00061             "', DIAG='\002,a1,\002', N=\002,i5,\002', NRHS=\002,i5,\002, type "
00062             "\002,i2,\002, test(\002,i2,\002)= \002,g12.5)";
00063     static char fmt_9997[] = "(1x,a,\002( '\002,a1,\002', '\002,a1,\002', "
00064             "'\002,a1,\002',\002,i5,\002, ... ), type \002,i2,\002, test(\002"
00065             ",i2,\002)=\002,g12.5)";
00066     static char fmt_9996[] = "(1x,a,\002( '\002,a1,\002', '\002,a1,\002', "
00067             "'\002,a1,\002', '\002,a1,\002',\002,i5,\002, ... ), type \002,i2,"
00068             "\002, test(\002,i2,\002)=\002,g12.5)";
00069 
00070     /* System generated locals */
00071     address a__1[2], a__2[3], a__3[4];
00072     integer i__1, i__2[2], i__3, i__4[3], i__5[4];
00073     char ch__1[2], ch__2[3], ch__3[4];
00074 
00075     /* Builtin functions */
00076     /* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen), s_cat(char *,
00077              char **, integer *, integer *, ftnlen);
00078     integer s_wsfe(cilist *), do_fio(integer *, char *, ftnlen), e_wsfe(void);
00079 
00080     /* Local variables */
00081     integer i__, k, n, in, lda, lap;
00082     char diag[1];
00083     integer imat, info;
00084     char path[3];
00085     integer irhs, nrhs;
00086     char norm[1], uplo[1];
00087     integer nrun;
00088     extern /* Subroutine */ int alahd_(integer *, char *);
00089     integer idiag;
00090     doublereal scale;
00091     extern /* Subroutine */ int dget04_(integer *, integer *, doublereal *, 
00092             integer *, doublereal *, integer *, doublereal *, doublereal *);
00093     integer nfail, iseed[4];
00094     extern logical lsame_(char *, char *);
00095     doublereal rcond, anorm;
00096     integer itran;
00097     extern /* Subroutine */ int dcopy_(integer *, doublereal *, integer *, 
00098             doublereal *, integer *), dtpt01_(char *, char *, integer *, 
00099             doublereal *, doublereal *, doublereal *, doublereal *, 
00100             doublereal *), dtpt02_(char *, char *, char *, 
00101             integer *, integer *, doublereal *, doublereal *, integer *, 
00102             doublereal *, integer *, doublereal *, doublereal *), dtpt03_(char *, char *, char *, integer *, 
00103             integer *, doublereal *, doublereal *, doublereal *, doublereal *, 
00104              doublereal *, integer *, doublereal *, integer *, doublereal *, 
00105             doublereal *), dtpt05_(char *, char *, 
00106             char *, integer *, integer *, doublereal *, doublereal *, integer 
00107             *, doublereal *, integer *, doublereal *, integer *, doublereal *, 
00108              doublereal *, doublereal *), dtpt06_(
00109             doublereal *, doublereal *, char *, char *, integer *, doublereal 
00110             *, doublereal *, doublereal *);
00111     char trans[1];
00112     integer iuplo, nerrs;
00113     char xtype[1];
00114     extern /* Subroutine */ int alaerh_(char *, char *, integer *, integer *, 
00115             char *, integer *, integer *, integer *, integer *, integer *, 
00116             integer *, integer *, integer *, integer *);
00117     doublereal rcondc;
00118     extern /* Subroutine */ int dlacpy_(char *, integer *, integer *, 
00119             doublereal *, integer *, doublereal *, integer *);
00120     doublereal rcondi;
00121     extern /* Subroutine */ int dlarhs_(char *, char *, char *, char *, 
00122             integer *, integer *, integer *, integer *, integer *, doublereal 
00123             *, integer *, doublereal *, integer *, doublereal *, integer *, 
00124             integer *, integer *);
00125     extern doublereal dlantp_(char *, char *, char *, integer *, doublereal *, 
00126              doublereal *);
00127     doublereal rcondo;
00128     extern /* Subroutine */ int alasum_(char *, integer *, integer *, integer 
00129             *, integer *), dlatps_(char *, char *, char *, char *, 
00130             integer *, doublereal *, doublereal *, doublereal *, doublereal *, 
00131              integer *);
00132     doublereal ainvnm;
00133     extern /* Subroutine */ int dlattp_(integer *, char *, char *, char *, 
00134             integer *, integer *, doublereal *, doublereal *, doublereal *, 
00135             integer *), dtpcon_(char *, char *, char *
00136 , integer *, doublereal *, doublereal *, doublereal *, integer *, 
00137             integer *), derrtr_(char *, integer *), dtprfs_(char *, char *, char *, integer *, integer *, 
00138             doublereal *, doublereal *, integer *, doublereal *, integer *, 
00139             doublereal *, doublereal *, doublereal *, integer *, integer *), dtptri_(char *, char *, integer *, 
00140             doublereal *, integer *);
00141     doublereal result[9];
00142     extern /* Subroutine */ int dtptrs_(char *, char *, char *, integer *, 
00143             integer *, doublereal *, doublereal *, integer *, integer *);
00144 
00145     /* Fortran I/O blocks */
00146     static cilist io___26 = { 0, 0, 0, fmt_9999, 0 };
00147     static cilist io___34 = { 0, 0, 0, fmt_9998, 0 };
00148     static cilist io___36 = { 0, 0, 0, fmt_9997, 0 };
00149     static cilist io___38 = { 0, 0, 0, fmt_9996, 0 };
00150     static cilist io___39 = { 0, 0, 0, fmt_9996, 0 };
00151 
00152 
00153 
00154 /*  -- LAPACK test routine (version 3.1) -- */
00155 /*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
00156 /*     November 2006 */
00157 
00158 /*     .. Scalar Arguments .. */
00159 /*     .. */
00160 /*     .. Array Arguments .. */
00161 /*     .. */
00162 
00163 /*  Purpose */
00164 /*  ======= */
00165 
00166 /*  DCHKTP tests DTPTRI, -TRS, -RFS, and -CON, and DLATPS */
00167 
00168 /*  Arguments */
00169 /*  ========= */
00170 
00171 /*  DOTYPE  (input) LOGICAL array, dimension (NTYPES) */
00172 /*          The matrix types to be used for testing.  Matrices of type j */
00173 /*          (for 1 <= j <= NTYPES) are used for testing if DOTYPE(j) = */
00174 /*          .TRUE.; if DOTYPE(j) = .FALSE., then type j is not used. */
00175 
00176 /*  NN      (input) INTEGER */
00177 /*          The number of values of N contained in the vector NVAL. */
00178 
00179 /*  NVAL    (input) INTEGER array, dimension (NN) */
00180 /*          The values of the matrix column dimension N. */
00181 
00182 /*  NNS     (input) INTEGER */
00183 /*          The number of values of NRHS contained in the vector NSVAL. */
00184 
00185 /*  NSVAL   (input) INTEGER array, dimension (NNS) */
00186 /*          The values of the number of right hand sides NRHS. */
00187 
00188 /*  THRESH  (input) DOUBLE PRECISION */
00189 /*          The threshold value for the test ratios.  A result is */
00190 /*          included in the output file if RESULT >= THRESH.  To have */
00191 /*          every test ratio printed, use THRESH = 0. */
00192 
00193 /*  TSTERR  (input) LOGICAL */
00194 /*          Flag that indicates whether error exits are to be tested. */
00195 
00196 /*  NMAX    (input) INTEGER */
00197 /*          The leading dimension of the work arrays.  NMAX >= the */
00198 /*          maximumm value of N in NVAL. */
00199 
00200 /*  AP      (workspace) DOUBLE PRECISION array, dimension */
00201 /*                      (NMAX*(NMAX+1)/2) */
00202 
00203 /*  AINVP   (workspace) DOUBLE PRECISION array, dimension */
00204 /*                      (NMAX*(NMAX+1)/2) */
00205 
00206 /*  B       (workspace) DOUBLE PRECISION array, dimension (NMAX*NSMAX) */
00207 /*          where NSMAX is the largest entry in NSVAL. */
00208 
00209 /*  X       (workspace) DOUBLE PRECISION array, dimension (NMAX*NSMAX) */
00210 
00211 /*  XACT    (workspace) DOUBLE PRECISION array, dimension (NMAX*NSMAX) */
00212 
00213 /*  WORK    (workspace) DOUBLE PRECISION array, dimension */
00214 /*                      (NMAX*max(3,NSMAX)) */
00215 
00216 /*  IWORK   (workspace) INTEGER array, dimension (NMAX) */
00217 
00218 /*  RWORK   (workspace) DOUBLE PRECISION array, dimension */
00219 /*                      (max(NMAX,2*NSMAX)) */
00220 
00221 /*  NOUT    (input) INTEGER */
00222 /*          The unit number for output. */
00223 
00224 /*  ===================================================================== */
00225 
00226 /*     .. Parameters .. */
00227 /*     .. */
00228 /*     .. Local Scalars .. */
00229 /*     .. */
00230 /*     .. Local Arrays .. */
00231 /*     .. */
00232 /*     .. External Functions .. */
00233 /*     .. */
00234 /*     .. External Subroutines .. */
00235 /*     .. */
00236 /*     .. Scalars in Common .. */
00237 /*     .. */
00238 /*     .. Common blocks .. */
00239 /*     .. */
00240 /*     .. Intrinsic Functions .. */
00241 /*     .. */
00242 /*     .. Data statements .. */
00243     /* Parameter adjustments */
00244     --iwork;
00245     --rwork;
00246     --work;
00247     --xact;
00248     --x;
00249     --b;
00250     --ainvp;
00251     --ap;
00252     --nsval;
00253     --nval;
00254     --dotype;
00255 
00256     /* Function Body */
00257 /*     .. */
00258 /*     .. Executable Statements .. */
00259 
00260 /*     Initialize constants and the random number seed. */
00261 
00262     s_copy(path, "Double precision", (ftnlen)1, (ftnlen)16);
00263     s_copy(path + 1, "TP", (ftnlen)2, (ftnlen)2);
00264     nrun = 0;
00265     nfail = 0;
00266     nerrs = 0;
00267     for (i__ = 1; i__ <= 4; ++i__) {
00268         iseed[i__ - 1] = iseedy[i__ - 1];
00269 /* L10: */
00270     }
00271 
00272 /*     Test the error exits */
00273 
00274     if (*tsterr) {
00275         derrtr_(path, nout);
00276     }
00277     infoc_1.infot = 0;
00278 
00279     i__1 = *nn;
00280     for (in = 1; in <= i__1; ++in) {
00281 
00282 /*        Do for each value of N in NVAL */
00283 
00284         n = nval[in];
00285         lda = max(1,n);
00286         lap = lda * (lda + 1) / 2;
00287         *(unsigned char *)xtype = 'N';
00288 
00289         for (imat = 1; imat <= 10; ++imat) {
00290 
00291 /*           Do the tests only if DOTYPE( IMAT ) is true. */
00292 
00293             if (! dotype[imat]) {
00294                 goto L70;
00295             }
00296 
00297             for (iuplo = 1; iuplo <= 2; ++iuplo) {
00298 
00299 /*              Do first for UPLO = 'U', then for UPLO = 'L' */
00300 
00301                 *(unsigned char *)uplo = *(unsigned char *)&uplos[iuplo - 1];
00302 
00303 /*              Call DLATTP to generate a triangular test matrix. */
00304 
00305                 s_copy(srnamc_1.srnamt, "DLATTP", (ftnlen)32, (ftnlen)6);
00306                 dlattp_(&imat, uplo, "No transpose", diag, iseed, &n, &ap[1], 
00307                         &x[1], &work[1], &info);
00308 
00309 /*              Set IDIAG = 1 for non-unit matrices, 2 for unit. */
00310 
00311                 if (lsame_(diag, "N")) {
00312                     idiag = 1;
00313                 } else {
00314                     idiag = 2;
00315                 }
00316 
00317 /* +    TEST 1 */
00318 /*              Form the inverse of A. */
00319 
00320                 if (n > 0) {
00321                     dcopy_(&lap, &ap[1], &c__1, &ainvp[1], &c__1);
00322                 }
00323                 s_copy(srnamc_1.srnamt, "DTPTRI", (ftnlen)32, (ftnlen)6);
00324                 dtptri_(uplo, diag, &n, &ainvp[1], &info);
00325 
00326 /*              Check error code from DTPTRI. */
00327 
00328                 if (info != 0) {
00329 /* Writing concatenation */
00330                     i__2[0] = 1, a__1[0] = uplo;
00331                     i__2[1] = 1, a__1[1] = diag;
00332                     s_cat(ch__1, a__1, i__2, &c__2, (ftnlen)2);
00333                     alaerh_(path, "DTPTRI", &info, &c__0, ch__1, &n, &n, &
00334                             c_n1, &c_n1, &c_n1, &imat, &nfail, &nerrs, nout);
00335                 }
00336 
00337 /*              Compute the infinity-norm condition number of A. */
00338 
00339                 anorm = dlantp_("I", uplo, diag, &n, &ap[1], &rwork[1]);
00340                 ainvnm = dlantp_("I", uplo, diag, &n, &ainvp[1], &rwork[1]);
00341                 if (anorm <= 0. || ainvnm <= 0.) {
00342                     rcondi = 1.;
00343                 } else {
00344                     rcondi = 1. / anorm / ainvnm;
00345                 }
00346 
00347 /*              Compute the residual for the triangular matrix times its */
00348 /*              inverse.  Also compute the 1-norm condition number of A. */
00349 
00350                 dtpt01_(uplo, diag, &n, &ap[1], &ainvp[1], &rcondo, &rwork[1], 
00351                          result);
00352 
00353 /*              Print the test ratio if it is .GE. THRESH. */
00354 
00355                 if (result[0] >= *thresh) {
00356                     if (nfail == 0 && nerrs == 0) {
00357                         alahd_(nout, path);
00358                     }
00359                     io___26.ciunit = *nout;
00360                     s_wsfe(&io___26);
00361                     do_fio(&c__1, uplo, (ftnlen)1);
00362                     do_fio(&c__1, diag, (ftnlen)1);
00363                     do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
00364                     do_fio(&c__1, (char *)&imat, (ftnlen)sizeof(integer));
00365                     do_fio(&c__1, (char *)&c__1, (ftnlen)sizeof(integer));
00366                     do_fio(&c__1, (char *)&result[0], (ftnlen)sizeof(
00367                             doublereal));
00368                     e_wsfe();
00369                     ++nfail;
00370                 }
00371                 ++nrun;
00372 
00373                 i__3 = *nns;
00374                 for (irhs = 1; irhs <= i__3; ++irhs) {
00375                     nrhs = nsval[irhs];
00376                     *(unsigned char *)xtype = 'N';
00377 
00378                     for (itran = 1; itran <= 3; ++itran) {
00379 
00380 /*                 Do for op(A) = A, A**T, or A**H. */
00381 
00382                         *(unsigned char *)trans = *(unsigned char *)&transs[
00383                                 itran - 1];
00384                         if (itran == 1) {
00385                             *(unsigned char *)norm = 'O';
00386                             rcondc = rcondo;
00387                         } else {
00388                             *(unsigned char *)norm = 'I';
00389                             rcondc = rcondi;
00390                         }
00391 
00392 /* +    TEST 2 */
00393 /*                 Solve and compute residual for op(A)*x = b. */
00394 
00395                         s_copy(srnamc_1.srnamt, "DLARHS", (ftnlen)32, (ftnlen)
00396                                 6);
00397                         dlarhs_(path, xtype, uplo, trans, &n, &n, &c__0, &
00398                                 idiag, &nrhs, &ap[1], &lap, &xact[1], &lda, &
00399                                 b[1], &lda, iseed, &info);
00400                         *(unsigned char *)xtype = 'C';
00401                         dlacpy_("Full", &n, &nrhs, &b[1], &lda, &x[1], &lda);
00402 
00403                         s_copy(srnamc_1.srnamt, "DTPTRS", (ftnlen)32, (ftnlen)
00404                                 6);
00405                         dtptrs_(uplo, trans, diag, &n, &nrhs, &ap[1], &x[1], &
00406                                 lda, &info);
00407 
00408 /*                 Check error code from DTPTRS. */
00409 
00410                         if (info != 0) {
00411 /* Writing concatenation */
00412                             i__4[0] = 1, a__2[0] = uplo;
00413                             i__4[1] = 1, a__2[1] = trans;
00414                             i__4[2] = 1, a__2[2] = diag;
00415                             s_cat(ch__2, a__2, i__4, &c__3, (ftnlen)3);
00416                             alaerh_(path, "DTPTRS", &info, &c__0, ch__2, &n, &
00417                                     n, &c_n1, &c_n1, &c_n1, &imat, &nfail, &
00418                                     nerrs, nout);
00419                         }
00420 
00421                         dtpt02_(uplo, trans, diag, &n, &nrhs, &ap[1], &x[1], &
00422                                 lda, &b[1], &lda, &work[1], &result[1]);
00423 
00424 /* +    TEST 3 */
00425 /*                 Check solution from generated exact solution. */
00426 
00427                         dget04_(&n, &nrhs, &x[1], &lda, &xact[1], &lda, &
00428                                 rcondc, &result[2]);
00429 
00430 /* +    TESTS 4, 5, and 6 */
00431 /*                 Use iterative refinement to improve the solution and */
00432 /*                 compute error bounds. */
00433 
00434                         s_copy(srnamc_1.srnamt, "DTPRFS", (ftnlen)32, (ftnlen)
00435                                 6);
00436                         dtprfs_(uplo, trans, diag, &n, &nrhs, &ap[1], &b[1], &
00437                                 lda, &x[1], &lda, &rwork[1], &rwork[nrhs + 1], 
00438                                  &work[1], &iwork[1], &info);
00439 
00440 /*                 Check error code from DTPRFS. */
00441 
00442                         if (info != 0) {
00443 /* Writing concatenation */
00444                             i__4[0] = 1, a__2[0] = uplo;
00445                             i__4[1] = 1, a__2[1] = trans;
00446                             i__4[2] = 1, a__2[2] = diag;
00447                             s_cat(ch__2, a__2, i__4, &c__3, (ftnlen)3);
00448                             alaerh_(path, "DTPRFS", &info, &c__0, ch__2, &n, &
00449                                     n, &c_n1, &c_n1, &nrhs, &imat, &nfail, &
00450                                     nerrs, nout);
00451                         }
00452 
00453                         dget04_(&n, &nrhs, &x[1], &lda, &xact[1], &lda, &
00454                                 rcondc, &result[3]);
00455                         dtpt05_(uplo, trans, diag, &n, &nrhs, &ap[1], &b[1], &
00456                                 lda, &x[1], &lda, &xact[1], &lda, &rwork[1], &
00457                                 rwork[nrhs + 1], &result[4]);
00458 
00459 /*                    Print information about the tests that did not pass */
00460 /*                    the threshold. */
00461 
00462                         for (k = 2; k <= 6; ++k) {
00463                             if (result[k - 1] >= *thresh) {
00464                                 if (nfail == 0 && nerrs == 0) {
00465                                     alahd_(nout, path);
00466                                 }
00467                                 io___34.ciunit = *nout;
00468                                 s_wsfe(&io___34);
00469                                 do_fio(&c__1, uplo, (ftnlen)1);
00470                                 do_fio(&c__1, trans, (ftnlen)1);
00471                                 do_fio(&c__1, diag, (ftnlen)1);
00472                                 do_fio(&c__1, (char *)&n, (ftnlen)sizeof(
00473                                         integer));
00474                                 do_fio(&c__1, (char *)&nrhs, (ftnlen)sizeof(
00475                                         integer));
00476                                 do_fio(&c__1, (char *)&imat, (ftnlen)sizeof(
00477                                         integer));
00478                                 do_fio(&c__1, (char *)&k, (ftnlen)sizeof(
00479                                         integer));
00480                                 do_fio(&c__1, (char *)&result[k - 1], (ftnlen)
00481                                         sizeof(doublereal));
00482                                 e_wsfe();
00483                                 ++nfail;
00484                             }
00485 /* L20: */
00486                         }
00487                         nrun += 5;
00488 /* L30: */
00489                     }
00490 /* L40: */
00491                 }
00492 
00493 /* +    TEST 7 */
00494 /*                 Get an estimate of RCOND = 1/CNDNUM. */
00495 
00496                 for (itran = 1; itran <= 2; ++itran) {
00497                     if (itran == 1) {
00498                         *(unsigned char *)norm = 'O';
00499                         rcondc = rcondo;
00500                     } else {
00501                         *(unsigned char *)norm = 'I';
00502                         rcondc = rcondi;
00503                     }
00504 
00505                     s_copy(srnamc_1.srnamt, "DTPCON", (ftnlen)32, (ftnlen)6);
00506                     dtpcon_(norm, uplo, diag, &n, &ap[1], &rcond, &work[1], &
00507                             iwork[1], &info);
00508 
00509 /*                 Check error code from DTPCON. */
00510 
00511                     if (info != 0) {
00512 /* Writing concatenation */
00513                         i__4[0] = 1, a__2[0] = norm;
00514                         i__4[1] = 1, a__2[1] = uplo;
00515                         i__4[2] = 1, a__2[2] = diag;
00516                         s_cat(ch__2, a__2, i__4, &c__3, (ftnlen)3);
00517                         alaerh_(path, "DTPCON", &info, &c__0, ch__2, &n, &n, &
00518                                 c_n1, &c_n1, &c_n1, &imat, &nfail, &nerrs, 
00519                                 nout);
00520                     }
00521 
00522                     dtpt06_(&rcond, &rcondc, uplo, diag, &n, &ap[1], &rwork[1]
00523 , &result[6]);
00524 
00525 /*                 Print the test ratio if it is .GE. THRESH. */
00526 
00527                     if (result[6] >= *thresh) {
00528                         if (nfail == 0 && nerrs == 0) {
00529                             alahd_(nout, path);
00530                         }
00531                         io___36.ciunit = *nout;
00532                         s_wsfe(&io___36);
00533                         do_fio(&c__1, "DTPCON", (ftnlen)6);
00534                         do_fio(&c__1, norm, (ftnlen)1);
00535                         do_fio(&c__1, uplo, (ftnlen)1);
00536                         do_fio(&c__1, diag, (ftnlen)1);
00537                         do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
00538                         do_fio(&c__1, (char *)&imat, (ftnlen)sizeof(integer));
00539                         do_fio(&c__1, (char *)&c__7, (ftnlen)sizeof(integer));
00540                         do_fio(&c__1, (char *)&result[6], (ftnlen)sizeof(
00541                                 doublereal));
00542                         e_wsfe();
00543                         ++nfail;
00544                     }
00545                     ++nrun;
00546 /* L50: */
00547                 }
00548 /* L60: */
00549             }
00550 L70:
00551             ;
00552         }
00553 
00554 /*        Use pathological test matrices to test DLATPS. */
00555 
00556         for (imat = 11; imat <= 18; ++imat) {
00557 
00558 /*           Do the tests only if DOTYPE( IMAT ) is true. */
00559 
00560             if (! dotype[imat]) {
00561                 goto L100;
00562             }
00563 
00564             for (iuplo = 1; iuplo <= 2; ++iuplo) {
00565 
00566 /*              Do first for UPLO = 'U', then for UPLO = 'L' */
00567 
00568                 *(unsigned char *)uplo = *(unsigned char *)&uplos[iuplo - 1];
00569                 for (itran = 1; itran <= 3; ++itran) {
00570 
00571 /*                 Do for op(A) = A, A**T, or A**H. */
00572 
00573                     *(unsigned char *)trans = *(unsigned char *)&transs[itran 
00574                             - 1];
00575 
00576 /*                 Call DLATTP to generate a triangular test matrix. */
00577 
00578                     s_copy(srnamc_1.srnamt, "DLATTP", (ftnlen)32, (ftnlen)6);
00579                     dlattp_(&imat, uplo, trans, diag, iseed, &n, &ap[1], &x[1]
00580 , &work[1], &info);
00581 
00582 /* +    TEST 8 */
00583 /*                 Solve the system op(A)*x = b. */
00584 
00585                     s_copy(srnamc_1.srnamt, "DLATPS", (ftnlen)32, (ftnlen)6);
00586                     dcopy_(&n, &x[1], &c__1, &b[1], &c__1);
00587                     dlatps_(uplo, trans, diag, "N", &n, &ap[1], &b[1], &scale, 
00588                              &rwork[1], &info);
00589 
00590 /*                 Check error code from DLATPS. */
00591 
00592                     if (info != 0) {
00593 /* Writing concatenation */
00594                         i__5[0] = 1, a__3[0] = uplo;
00595                         i__5[1] = 1, a__3[1] = trans;
00596                         i__5[2] = 1, a__3[2] = diag;
00597                         i__5[3] = 1, a__3[3] = "N";
00598                         s_cat(ch__3, a__3, i__5, &c__4, (ftnlen)4);
00599                         alaerh_(path, "DLATPS", &info, &c__0, ch__3, &n, &n, &
00600                                 c_n1, &c_n1, &c_n1, &imat, &nfail, &nerrs, 
00601                                 nout);
00602                     }
00603 
00604                     dtpt03_(uplo, trans, diag, &n, &c__1, &ap[1], &scale, &
00605                             rwork[1], &c_b103, &b[1], &lda, &x[1], &lda, &
00606                             work[1], &result[7]);
00607 
00608 /* +    TEST 9 */
00609 /*                 Solve op(A)*x = b again with NORMIN = 'Y'. */
00610 
00611                     dcopy_(&n, &x[1], &c__1, &b[n + 1], &c__1);
00612                     dlatps_(uplo, trans, diag, "Y", &n, &ap[1], &b[n + 1], &
00613                             scale, &rwork[1], &info);
00614 
00615 /*                 Check error code from DLATPS. */
00616 
00617                     if (info != 0) {
00618 /* Writing concatenation */
00619                         i__5[0] = 1, a__3[0] = uplo;
00620                         i__5[1] = 1, a__3[1] = trans;
00621                         i__5[2] = 1, a__3[2] = diag;
00622                         i__5[3] = 1, a__3[3] = "Y";
00623                         s_cat(ch__3, a__3, i__5, &c__4, (ftnlen)4);
00624                         alaerh_(path, "DLATPS", &info, &c__0, ch__3, &n, &n, &
00625                                 c_n1, &c_n1, &c_n1, &imat, &nfail, &nerrs, 
00626                                 nout);
00627                     }
00628 
00629                     dtpt03_(uplo, trans, diag, &n, &c__1, &ap[1], &scale, &
00630                             rwork[1], &c_b103, &b[n + 1], &lda, &x[1], &lda, &
00631                             work[1], &result[8]);
00632 
00633 /*                 Print information about the tests that did not pass */
00634 /*                 the threshold. */
00635 
00636                     if (result[7] >= *thresh) {
00637                         if (nfail == 0 && nerrs == 0) {
00638                             alahd_(nout, path);
00639                         }
00640                         io___38.ciunit = *nout;
00641                         s_wsfe(&io___38);
00642                         do_fio(&c__1, "DLATPS", (ftnlen)6);
00643                         do_fio(&c__1, uplo, (ftnlen)1);
00644                         do_fio(&c__1, trans, (ftnlen)1);
00645                         do_fio(&c__1, diag, (ftnlen)1);
00646                         do_fio(&c__1, "N", (ftnlen)1);
00647                         do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
00648                         do_fio(&c__1, (char *)&imat, (ftnlen)sizeof(integer));
00649                         do_fio(&c__1, (char *)&c__8, (ftnlen)sizeof(integer));
00650                         do_fio(&c__1, (char *)&result[7], (ftnlen)sizeof(
00651                                 doublereal));
00652                         e_wsfe();
00653                         ++nfail;
00654                     }
00655                     if (result[8] >= *thresh) {
00656                         if (nfail == 0 && nerrs == 0) {
00657                             alahd_(nout, path);
00658                         }
00659                         io___39.ciunit = *nout;
00660                         s_wsfe(&io___39);
00661                         do_fio(&c__1, "DLATPS", (ftnlen)6);
00662                         do_fio(&c__1, uplo, (ftnlen)1);
00663                         do_fio(&c__1, trans, (ftnlen)1);
00664                         do_fio(&c__1, diag, (ftnlen)1);
00665                         do_fio(&c__1, "Y", (ftnlen)1);
00666                         do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
00667                         do_fio(&c__1, (char *)&imat, (ftnlen)sizeof(integer));
00668                         do_fio(&c__1, (char *)&c__9, (ftnlen)sizeof(integer));
00669                         do_fio(&c__1, (char *)&result[8], (ftnlen)sizeof(
00670                                 doublereal));
00671                         e_wsfe();
00672                         ++nfail;
00673                     }
00674                     nrun += 2;
00675 /* L80: */
00676                 }
00677 /* L90: */
00678             }
00679 L100:
00680             ;
00681         }
00682 /* L110: */
00683     }
00684 
00685 /*     Print a summary of the results. */
00686 
00687     alasum_(path, nout, &nfail, &nrun, &nerrs);
00688 
00689     return 0;
00690 
00691 /*     End of DCHKTP */
00692 
00693 } /* dchktp_ */

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