zchktp.c
Go to the documentation of this file.
00001 /* zchktp.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 zchktp_(logical *dotype, integer *nn, integer *nval, 
00045         integer *nns, integer *nsval, doublereal *thresh, logical *tsterr, 
00046         integer *nmax, doublecomplex *ap, doublecomplex *ainvp, doublecomplex 
00047         *b, doublecomplex *x, doublecomplex *xact, doublecomplex *work, 
00048         doublereal *rwork, 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     integer nfail, iseed[4];
00092     extern logical lsame_(char *, char *);
00093     doublereal rcond, anorm;
00094     integer itran;
00095     extern /* Subroutine */ int zget04_(integer *, integer *, doublecomplex *, 
00096              integer *, doublecomplex *, integer *, doublereal *, doublereal *
00097 );
00098     char trans[1];
00099     integer iuplo, nerrs;
00100     extern /* Subroutine */ int ztpt01_(char *, char *, integer *, 
00101             doublecomplex *, doublecomplex *, doublereal *, doublereal *, 
00102             doublereal *), zcopy_(integer *, doublecomplex *, 
00103             integer *, doublecomplex *, integer *), ztpt02_(char *, char *, 
00104             char *, integer *, integer *, doublecomplex *, doublecomplex *, 
00105             integer *, doublecomplex *, integer *, doublecomplex *, 
00106             doublereal *, doublereal *), ztpt03_(char 
00107             *, char *, char *, integer *, integer *, doublecomplex *, 
00108             doublereal *, doublereal *, doublereal *, doublecomplex *, 
00109             integer *, doublecomplex *, integer *, doublecomplex *, 
00110             doublereal *), ztpt05_(char *, char *, 
00111             char *, integer *, integer *, doublecomplex *, doublecomplex *, 
00112             integer *, doublecomplex *, integer *, doublecomplex *, integer *, 
00113              doublereal *, doublereal *, doublereal *)
00114             ;
00115     char xtype[1];
00116     extern /* Subroutine */ int ztpt06_(doublereal *, doublereal *, char *, 
00117             char *, integer *, doublecomplex *, doublereal *, doublereal *), alaerh_(char *, char *, integer *, integer *, 
00118             char *, integer *, integer *, integer *, integer *, integer *, 
00119             integer *, integer *, integer *, integer *);
00120     doublereal rcondc, rcondi;
00121     extern /* Subroutine */ int alasum_(char *, integer *, integer *, integer 
00122             *, integer *);
00123     doublereal rcondo, ainvnm;
00124     extern /* Subroutine */ int zlacpy_(char *, integer *, integer *, 
00125             doublecomplex *, integer *, doublecomplex *, integer *), 
00126             zlarhs_(char *, char *, char *, char *, integer *, integer *, 
00127             integer *, integer *, integer *, doublecomplex *, integer *, 
00128             doublecomplex *, integer *, doublecomplex *, integer *, integer *, 
00129              integer *);
00130     extern doublereal zlantp_(char *, char *, char *, integer *, 
00131             doublecomplex *, doublereal *);
00132     extern /* Subroutine */ int zlatps_(char *, char *, char *, char *, 
00133             integer *, doublecomplex *, doublecomplex *, doublereal *, 
00134             doublereal *, integer *);
00135     doublereal result[9];
00136     extern /* Subroutine */ int zlattp_(integer *, char *, char *, char *, 
00137             integer *, integer *, doublecomplex *, doublecomplex *, 
00138             doublecomplex *, doublereal *, integer *),
00139              ztpcon_(char *, char *, char *, integer *, doublecomplex *, 
00140             doublereal *, doublecomplex *, doublereal *, integer *), zerrtr_(char *, integer *), ztprfs_(char 
00141             *, char *, char *, integer *, integer *, doublecomplex *, 
00142             doublecomplex *, integer *, doublecomplex *, integer *, 
00143             doublereal *, doublereal *, doublecomplex *, doublereal *, 
00144             integer *), ztptri_(char *, char *, 
00145             integer *, doublecomplex *, integer *), ztptrs_(
00146             char *, char *, char *, integer *, integer *, doublecomplex *, 
00147             doublecomplex *, integer *, integer *);
00148 
00149     /* Fortran I/O blocks */
00150     static cilist io___26 = { 0, 0, 0, fmt_9999, 0 };
00151     static cilist io___34 = { 0, 0, 0, fmt_9998, 0 };
00152     static cilist io___36 = { 0, 0, 0, fmt_9997, 0 };
00153     static cilist io___38 = { 0, 0, 0, fmt_9996, 0 };
00154     static cilist io___39 = { 0, 0, 0, fmt_9996, 0 };
00155 
00156 
00157 
00158 /*  -- LAPACK test routine (version 3.1) -- */
00159 /*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
00160 /*     November 2006 */
00161 
00162 /*     .. Scalar Arguments .. */
00163 /*     .. */
00164 /*     .. Array Arguments .. */
00165 /*     .. */
00166 
00167 /*  Purpose */
00168 /*  ======= */
00169 
00170 /*  ZCHKTP tests ZTPTRI, -TRS, -RFS, and -CON, and ZLATPS */
00171 
00172 /*  Arguments */
00173 /*  ========= */
00174 
00175 /*  DOTYPE  (input) LOGICAL array, dimension (NTYPES) */
00176 /*          The matrix types to be used for testing.  Matrices of type j */
00177 /*          (for 1 <= j <= NTYPES) are used for testing if DOTYPE(j) = */
00178 /*          .TRUE.; if DOTYPE(j) = .FALSE., then type j is not used. */
00179 
00180 /*  NN      (input) INTEGER */
00181 /*          The number of values of N contained in the vector NVAL. */
00182 
00183 /*  NVAL    (input) INTEGER array, dimension (NN) */
00184 /*          The values of the matrix column dimension N. */
00185 
00186 /*  NNS     (input) INTEGER */
00187 /*          The number of values of NRHS contained in the vector NSVAL. */
00188 
00189 /*  NSVAL   (input) INTEGER array, dimension (NNS) */
00190 /*          The values of the number of right hand sides NRHS. */
00191 
00192 /*  THRESH  (input) DOUBLE PRECISION */
00193 /*          The threshold value for the test ratios.  A result is */
00194 /*          included in the output file if RESULT >= THRESH.  To have */
00195 /*          every test ratio printed, use THRESH = 0. */
00196 
00197 /*  TSTERR  (input) LOGICAL */
00198 /*          Flag that indicates whether error exits are to be tested. */
00199 
00200 /*  NMAX    (input) INTEGER */
00201 /*          The leading dimension of the work arrays.  NMAX >= the */
00202 /*          maximumm value of N in NVAL. */
00203 
00204 /*  AP      (workspace) COMPLEX*16 array, dimension (NMAX*(NMAX+1)/2) */
00205 
00206 /*  AINVP   (workspace) COMPLEX*16 array, dimension (NMAX*(NMAX+1)/2) */
00207 
00208 /*  B       (workspace) COMPLEX*16 array, dimension (NMAX*NSMAX) */
00209 /*          where NSMAX is the largest entry in NSVAL. */
00210 
00211 /*  X       (workspace) COMPLEX*16 array, dimension (NMAX*NSMAX) */
00212 
00213 /*  XACT    (workspace) COMPLEX*16 array, dimension (NMAX*NSMAX) */
00214 
00215 /*  WORK    (workspace) COMPLEX*16 array, dimension */
00216 /*                      (NMAX*max(3,NSMAX)) */
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     --rwork;
00245     --work;
00246     --xact;
00247     --x;
00248     --b;
00249     --ainvp;
00250     --ap;
00251     --nsval;
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, "Zomplex precision", (ftnlen)1, (ftnlen)17);
00262     s_copy(path + 1, "TP", (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         zerrtr_(path, nout);
00275     }
00276     infoc_1.infot = 0;
00277 
00278     i__1 = *nn;
00279     for (in = 1; in <= i__1; ++in) {
00280 
00281 /*        Do for each value of N in NVAL */
00282 
00283         n = nval[in];
00284         lda = max(1,n);
00285         lap = lda * (lda + 1) / 2;
00286         *(unsigned char *)xtype = 'N';
00287 
00288         for (imat = 1; imat <= 10; ++imat) {
00289 
00290 /*           Do the tests only if DOTYPE( IMAT ) is true. */
00291 
00292             if (! dotype[imat]) {
00293                 goto L70;
00294             }
00295 
00296             for (iuplo = 1; iuplo <= 2; ++iuplo) {
00297 
00298 /*              Do first for UPLO = 'U', then for UPLO = 'L' */
00299 
00300                 *(unsigned char *)uplo = *(unsigned char *)&uplos[iuplo - 1];
00301 
00302 /*              Call ZLATTP to generate a triangular test matrix. */
00303 
00304                 s_copy(srnamc_1.srnamt, "ZLATTP", (ftnlen)32, (ftnlen)6);
00305                 zlattp_(&imat, uplo, "No transpose", diag, iseed, &n, &ap[1], 
00306                         &x[1], &work[1], &rwork[1], &info);
00307 
00308 /*              Set IDIAG = 1 for non-unit matrices, 2 for unit. */
00309 
00310                 if (lsame_(diag, "N")) {
00311                     idiag = 1;
00312                 } else {
00313                     idiag = 2;
00314                 }
00315 
00316 /* +    TEST 1 */
00317 /*              Form the inverse of A. */
00318 
00319                 if (n > 0) {
00320                     zcopy_(&lap, &ap[1], &c__1, &ainvp[1], &c__1);
00321                 }
00322                 s_copy(srnamc_1.srnamt, "ZTPTRI", (ftnlen)32, (ftnlen)6);
00323                 ztptri_(uplo, diag, &n, &ainvp[1], &info);
00324 
00325 /*              Check error code from ZTPTRI. */
00326 
00327                 if (info != 0) {
00328 /* Writing concatenation */
00329                     i__2[0] = 1, a__1[0] = uplo;
00330                     i__2[1] = 1, a__1[1] = diag;
00331                     s_cat(ch__1, a__1, i__2, &c__2, (ftnlen)2);
00332                     alaerh_(path, "ZTPTRI", &info, &c__0, ch__1, &n, &n, &
00333                             c_n1, &c_n1, &c_n1, &imat, &nfail, &nerrs, nout);
00334                 }
00335 
00336 /*              Compute the infinity-norm condition number of A. */
00337 
00338                 anorm = zlantp_("I", uplo, diag, &n, &ap[1], &rwork[1]);
00339                 ainvnm = zlantp_("I", uplo, diag, &n, &ainvp[1], &rwork[1]);
00340                 if (anorm <= 0. || ainvnm <= 0.) {
00341                     rcondi = 1.;
00342                 } else {
00343                     rcondi = 1. / anorm / ainvnm;
00344                 }
00345 
00346 /*              Compute the residual for the triangular matrix times its */
00347 /*              inverse.  Also compute the 1-norm condition number of A. */
00348 
00349                 ztpt01_(uplo, diag, &n, &ap[1], &ainvp[1], &rcondo, &rwork[1], 
00350                          result);
00351 
00352 /*              Print the test ratio if it is .GE. THRESH. */
00353 
00354                 if (result[0] >= *thresh) {
00355                     if (nfail == 0 && nerrs == 0) {
00356                         alahd_(nout, path);
00357                     }
00358                     io___26.ciunit = *nout;
00359                     s_wsfe(&io___26);
00360                     do_fio(&c__1, uplo, (ftnlen)1);
00361                     do_fio(&c__1, diag, (ftnlen)1);
00362                     do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
00363                     do_fio(&c__1, (char *)&imat, (ftnlen)sizeof(integer));
00364                     do_fio(&c__1, (char *)&c__1, (ftnlen)sizeof(integer));
00365                     do_fio(&c__1, (char *)&result[0], (ftnlen)sizeof(
00366                             doublereal));
00367                     e_wsfe();
00368                     ++nfail;
00369                 }
00370                 ++nrun;
00371 
00372                 i__3 = *nns;
00373                 for (irhs = 1; irhs <= i__3; ++irhs) {
00374                     nrhs = nsval[irhs];
00375                     *(unsigned char *)xtype = 'N';
00376 
00377                     for (itran = 1; itran <= 3; ++itran) {
00378 
00379 /*                 Do for op(A) = A, A**T, or A**H. */
00380 
00381                         *(unsigned char *)trans = *(unsigned char *)&transs[
00382                                 itran - 1];
00383                         if (itran == 1) {
00384                             *(unsigned char *)norm = 'O';
00385                             rcondc = rcondo;
00386                         } else {
00387                             *(unsigned char *)norm = 'I';
00388                             rcondc = rcondi;
00389                         }
00390 
00391 /* +    TEST 2 */
00392 /*                 Solve and compute residual for op(A)*x = b. */
00393 
00394                         s_copy(srnamc_1.srnamt, "ZLARHS", (ftnlen)32, (ftnlen)
00395                                 6);
00396                         zlarhs_(path, xtype, uplo, trans, &n, &n, &c__0, &
00397                                 idiag, &nrhs, &ap[1], &lap, &xact[1], &lda, &
00398                                 b[1], &lda, iseed, &info);
00399                         *(unsigned char *)xtype = 'C';
00400                         zlacpy_("Full", &n, &nrhs, &b[1], &lda, &x[1], &lda);
00401 
00402                         s_copy(srnamc_1.srnamt, "ZTPTRS", (ftnlen)32, (ftnlen)
00403                                 6);
00404                         ztptrs_(uplo, trans, diag, &n, &nrhs, &ap[1], &x[1], &
00405                                 lda, &info);
00406 
00407 /*                 Check error code from ZTPTRS. */
00408 
00409                         if (info != 0) {
00410 /* Writing concatenation */
00411                             i__4[0] = 1, a__2[0] = uplo;
00412                             i__4[1] = 1, a__2[1] = trans;
00413                             i__4[2] = 1, a__2[2] = diag;
00414                             s_cat(ch__2, a__2, i__4, &c__3, (ftnlen)3);
00415                             alaerh_(path, "ZTPTRS", &info, &c__0, ch__2, &n, &
00416                                     n, &c_n1, &c_n1, &c_n1, &imat, &nfail, &
00417                                     nerrs, nout);
00418                         }
00419 
00420                         ztpt02_(uplo, trans, diag, &n, &nrhs, &ap[1], &x[1], &
00421                                 lda, &b[1], &lda, &work[1], &rwork[1], &
00422                                 result[1]);
00423 
00424 /* +    TEST 3 */
00425 /*                 Check solution from generated exact solution. */
00426 
00427                         zget04_(&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, "ZTPRFS", (ftnlen)32, (ftnlen)
00435                                 6);
00436                         ztprfs_(uplo, trans, diag, &n, &nrhs, &ap[1], &b[1], &
00437                                 lda, &x[1], &lda, &rwork[1], &rwork[nrhs + 1], 
00438                                  &work[1], &rwork[(nrhs << 1) + 1], &info);
00439 
00440 /*                 Check error code from ZTPRFS. */
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, "ZTPRFS", &info, &c__0, ch__2, &n, &
00449                                     n, &c_n1, &c_n1, &nrhs, &imat, &nfail, &
00450                                     nerrs, nout);
00451                         }
00452 
00453                         zget04_(&n, &nrhs, &x[1], &lda, &xact[1], &lda, &
00454                                 rcondc, &result[3]);
00455                         ztpt05_(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                     s_copy(srnamc_1.srnamt, "ZTPCON", (ftnlen)32, (ftnlen)6);
00505                     ztpcon_(norm, uplo, diag, &n, &ap[1], &rcond, &work[1], &
00506                             rwork[1], &info);
00507 
00508 /*                 Check error code from ZTPCON. */
00509 
00510                     if (info != 0) {
00511 /* Writing concatenation */
00512                         i__4[0] = 1, a__2[0] = norm;
00513                         i__4[1] = 1, a__2[1] = uplo;
00514                         i__4[2] = 1, a__2[2] = diag;
00515                         s_cat(ch__2, a__2, i__4, &c__3, (ftnlen)3);
00516                         alaerh_(path, "ZTPCON", &info, &c__0, ch__2, &n, &n, &
00517                                 c_n1, &c_n1, &c_n1, &imat, &nfail, &nerrs, 
00518                                 nout);
00519                     }
00520 
00521                     ztpt06_(&rcond, &rcondc, uplo, diag, &n, &ap[1], &rwork[1]
00522 , &result[6]);
00523 
00524 /*                 Print the test ratio if it is .GE. THRESH. */
00525 
00526                     if (result[6] >= *thresh) {
00527                         if (nfail == 0 && nerrs == 0) {
00528                             alahd_(nout, path);
00529                         }
00530                         io___36.ciunit = *nout;
00531                         s_wsfe(&io___36);
00532                         do_fio(&c__1, "ZTPCON", (ftnlen)6);
00533                         do_fio(&c__1, norm, (ftnlen)1);
00534                         do_fio(&c__1, uplo, (ftnlen)1);
00535                         do_fio(&c__1, diag, (ftnlen)1);
00536                         do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
00537                         do_fio(&c__1, (char *)&imat, (ftnlen)sizeof(integer));
00538                         do_fio(&c__1, (char *)&c__7, (ftnlen)sizeof(integer));
00539                         do_fio(&c__1, (char *)&result[6], (ftnlen)sizeof(
00540                                 doublereal));
00541                         e_wsfe();
00542                         ++nfail;
00543                     }
00544                     ++nrun;
00545 /* L50: */
00546                 }
00547 /* L60: */
00548             }
00549 L70:
00550             ;
00551         }
00552 
00553 /*        Use pathological test matrices to test ZLATPS. */
00554 
00555         for (imat = 11; imat <= 18; ++imat) {
00556 
00557 /*           Do the tests only if DOTYPE( IMAT ) is true. */
00558 
00559             if (! dotype[imat]) {
00560                 goto L100;
00561             }
00562 
00563             for (iuplo = 1; iuplo <= 2; ++iuplo) {
00564 
00565 /*              Do first for UPLO = 'U', then for UPLO = 'L' */
00566 
00567                 *(unsigned char *)uplo = *(unsigned char *)&uplos[iuplo - 1];
00568                 for (itran = 1; itran <= 3; ++itran) {
00569 
00570 /*                 Do for op(A) = A, A**T, or A**H. */
00571 
00572                     *(unsigned char *)trans = *(unsigned char *)&transs[itran 
00573                             - 1];
00574 
00575 /*                 Call ZLATTP to generate a triangular test matrix. */
00576 
00577                     s_copy(srnamc_1.srnamt, "ZLATTP", (ftnlen)32, (ftnlen)6);
00578                     zlattp_(&imat, uplo, trans, diag, iseed, &n, &ap[1], &x[1]
00579 , &work[1], &rwork[1], &info);
00580 
00581 /* +    TEST 8 */
00582 /*                 Solve the system op(A)*x = b. */
00583 
00584                     s_copy(srnamc_1.srnamt, "ZLATPS", (ftnlen)32, (ftnlen)6);
00585                     zcopy_(&n, &x[1], &c__1, &b[1], &c__1);
00586                     zlatps_(uplo, trans, diag, "N", &n, &ap[1], &b[1], &scale, 
00587                              &rwork[1], &info);
00588 
00589 /*                 Check error code from ZLATPS. */
00590 
00591                     if (info != 0) {
00592 /* Writing concatenation */
00593                         i__5[0] = 1, a__3[0] = uplo;
00594                         i__5[1] = 1, a__3[1] = trans;
00595                         i__5[2] = 1, a__3[2] = diag;
00596                         i__5[3] = 1, a__3[3] = "N";
00597                         s_cat(ch__3, a__3, i__5, &c__4, (ftnlen)4);
00598                         alaerh_(path, "ZLATPS", &info, &c__0, ch__3, &n, &n, &
00599                                 c_n1, &c_n1, &c_n1, &imat, &nfail, &nerrs, 
00600                                 nout);
00601                     }
00602 
00603                     ztpt03_(uplo, trans, diag, &n, &c__1, &ap[1], &scale, &
00604                             rwork[1], &c_b103, &b[1], &lda, &x[1], &lda, &
00605                             work[1], &result[7]);
00606 
00607 /* +    TEST 9 */
00608 /*                 Solve op(A)*x = b again with NORMIN = 'Y'. */
00609 
00610                     zcopy_(&n, &x[1], &c__1, &b[n + 1], &c__1);
00611                     zlatps_(uplo, trans, diag, "Y", &n, &ap[1], &b[n + 1], &
00612                             scale, &rwork[1], &info);
00613 
00614 /*                 Check error code from ZLATPS. */
00615 
00616                     if (info != 0) {
00617 /* Writing concatenation */
00618                         i__5[0] = 1, a__3[0] = uplo;
00619                         i__5[1] = 1, a__3[1] = trans;
00620                         i__5[2] = 1, a__3[2] = diag;
00621                         i__5[3] = 1, a__3[3] = "Y";
00622                         s_cat(ch__3, a__3, i__5, &c__4, (ftnlen)4);
00623                         alaerh_(path, "ZLATPS", &info, &c__0, ch__3, &n, &n, &
00624                                 c_n1, &c_n1, &c_n1, &imat, &nfail, &nerrs, 
00625                                 nout);
00626                     }
00627 
00628                     ztpt03_(uplo, trans, diag, &n, &c__1, &ap[1], &scale, &
00629                             rwork[1], &c_b103, &b[n + 1], &lda, &x[1], &lda, &
00630                             work[1], &result[8]);
00631 
00632 /*                 Print information about the tests that did not pass */
00633 /*                 the threshold. */
00634 
00635                     if (result[7] >= *thresh) {
00636                         if (nfail == 0 && nerrs == 0) {
00637                             alahd_(nout, path);
00638                         }
00639                         io___38.ciunit = *nout;
00640                         s_wsfe(&io___38);
00641                         do_fio(&c__1, "ZLATPS", (ftnlen)6);
00642                         do_fio(&c__1, uplo, (ftnlen)1);
00643                         do_fio(&c__1, trans, (ftnlen)1);
00644                         do_fio(&c__1, diag, (ftnlen)1);
00645                         do_fio(&c__1, "N", (ftnlen)1);
00646                         do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
00647                         do_fio(&c__1, (char *)&imat, (ftnlen)sizeof(integer));
00648                         do_fio(&c__1, (char *)&c__8, (ftnlen)sizeof(integer));
00649                         do_fio(&c__1, (char *)&result[7], (ftnlen)sizeof(
00650                                 doublereal));
00651                         e_wsfe();
00652                         ++nfail;
00653                     }
00654                     if (result[8] >= *thresh) {
00655                         if (nfail == 0 && nerrs == 0) {
00656                             alahd_(nout, path);
00657                         }
00658                         io___39.ciunit = *nout;
00659                         s_wsfe(&io___39);
00660                         do_fio(&c__1, "ZLATPS", (ftnlen)6);
00661                         do_fio(&c__1, uplo, (ftnlen)1);
00662                         do_fio(&c__1, trans, (ftnlen)1);
00663                         do_fio(&c__1, diag, (ftnlen)1);
00664                         do_fio(&c__1, "Y", (ftnlen)1);
00665                         do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
00666                         do_fio(&c__1, (char *)&imat, (ftnlen)sizeof(integer));
00667                         do_fio(&c__1, (char *)&c__9, (ftnlen)sizeof(integer));
00668                         do_fio(&c__1, (char *)&result[8], (ftnlen)sizeof(
00669                                 doublereal));
00670                         e_wsfe();
00671                         ++nfail;
00672                     }
00673                     nrun += 2;
00674 /* L80: */
00675                 }
00676 /* L90: */
00677             }
00678 L100:
00679             ;
00680         }
00681 /* L110: */
00682     }
00683 
00684 /*     Print a summary of the results. */
00685 
00686     alasum_(path, nout, &nfail, &nrun, &nerrs);
00687 
00688     return 0;
00689 
00690 /*     End of ZCHKTP */
00691 
00692 } /* zchktp_ */

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