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

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