sdrvrf1.c
Go to the documentation of this file.
00001 /* sdrvrf1.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     char srnamt[32];
00020 } srnamc_;
00021 
00022 #define srnamc_1 srnamc_
00023 
00024 /* Table of constant values */
00025 
00026 static integer c__2 = 2;
00027 static integer c__1 = 1;
00028 
00029 /* Subroutine */ int sdrvrf1_(integer *nout, integer *nn, integer *nval, real 
00030         *thresh, real *a, integer *lda, real *arf, real *work)
00031 {
00032     /* Initialized data */
00033 
00034     static integer iseedy[4] = { 1988,1989,1990,1991 };
00035     static char uplos[1*2] = "U" "L";
00036     static char forms[1*2] = "N" "T";
00037     static char norms[1*4] = "M" "1" "I" "F";
00038 
00039     /* Format strings */
00040     static char fmt_9999[] = "(1x,\002 *** Error(s) or Failure(s) while test"
00041             "ing SLANSF              ***\002)";
00042     static char fmt_9998[] = "(1x,\002     Error in \002,a6,\002 with UPLO="
00043             "'\002,a1,\002', FORM='\002,a1,\002', N=\002,i5)";
00044     static char fmt_9997[] = "(1x,\002     Failure in \002,a6,\002 N=\002,"
00045             "i5,\002 TYPE=\002,i5,\002 UPLO='\002,a1,\002', FORM ='\002,a1"
00046             ",\002', NORM='\002,a1,\002', test=\002,g12.5)";
00047     static char fmt_9996[] = "(1x,\002All tests for \002,a6,\002 auxiliary r"
00048             "outine passed the \002,\002threshold (\002,i5,\002 tests run)"
00049             "\002)";
00050     static char fmt_9995[] = "(1x,a6,\002 auxiliary routine:\002,i5,\002 out"
00051             " of \002,i5,\002 tests failed to pass the threshold\002)";
00052     static char fmt_9994[] = "(26x,i5,\002 error message recorded (\002,a6"
00053             ",\002)\002)";
00054 
00055     /* System generated locals */
00056     integer a_dim1, a_offset, i__1, i__2, i__3;
00057 
00058     /* Builtin functions */
00059     /* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);
00060     integer s_wsle(cilist *), e_wsle(void), s_wsfe(cilist *), e_wsfe(void), 
00061             do_fio(integer *, char *, ftnlen);
00062 
00063     /* Local variables */
00064     integer i__, j, n, iin, iit;
00065     real eps;
00066     integer info;
00067     char norm[1], uplo[1];
00068     integer nrun, nfail;
00069     real large;
00070     integer iseed[4];
00071     char cform[1];
00072     real small;
00073     integer iform;
00074     real norma;
00075     integer inorm, iuplo, nerrs;
00076     extern doublereal slamch_(char *), slarnd_(integer *, integer *), 
00077             slansf_(char *, char *, char *, integer *, real *, real *), slansy_(char *, char *, integer *, real *, 
00078             integer *, real *);
00079     real result[1];
00080     extern /* Subroutine */ int strttf_(char *, char *, integer *, real *, 
00081             integer *, real *, integer *);
00082     real normarf;
00083 
00084     /* Fortran I/O blocks */
00085     static cilist io___22 = { 0, 0, 0, 0, 0 };
00086     static cilist io___23 = { 0, 0, 0, fmt_9999, 0 };
00087     static cilist io___24 = { 0, 0, 0, fmt_9998, 0 };
00088     static cilist io___30 = { 0, 0, 0, 0, 0 };
00089     static cilist io___31 = { 0, 0, 0, fmt_9999, 0 };
00090     static cilist io___32 = { 0, 0, 0, fmt_9997, 0 };
00091     static cilist io___33 = { 0, 0, 0, fmt_9996, 0 };
00092     static cilist io___34 = { 0, 0, 0, fmt_9995, 0 };
00093     static cilist io___35 = { 0, 0, 0, fmt_9994, 0 };
00094 
00095 
00096 
00097 /*  -- LAPACK test routine (version 3.2.0) -- */
00098 /*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
00099 /*     November 2008 */
00100 
00101 /*     .. Scalar Arguments .. */
00102 /*     .. */
00103 /*     .. Array Arguments .. */
00104 /*     .. */
00105 
00106 /*  Purpose */
00107 /*  ======= */
00108 
00109 /*  SDRVRF1 tests the LAPACK RFP routines: */
00110 /*      SLANSF */
00111 
00112 /*  Arguments */
00113 /*  ========= */
00114 
00115 /*  NOUT          (input) INTEGER */
00116 /*                The unit number for output. */
00117 
00118 /*  NN            (input) INTEGER */
00119 /*                The number of values of N contained in the vector NVAL. */
00120 
00121 /*  NVAL          (input) INTEGER array, dimension (NN) */
00122 /*                The values of the matrix dimension N. */
00123 
00124 /*  THRESH        (input) REAL */
00125 /*                The threshold value for the test ratios.  A result is */
00126 /*                included in the output file if RESULT >= THRESH.  To have */
00127 /*                every test ratio printed, use THRESH = 0. */
00128 
00129 /*  A             (workspace) REAL array, dimension (LDA,NMAX) */
00130 
00131 /*  LDA           (input) INTEGER */
00132 /*                The leading dimension of the array A.  LDA >= max(1,NMAX). */
00133 
00134 /*  ARF           (workspace) REAL array, dimension ((NMAX*(NMAX+1))/2). */
00135 
00136 /*  WORK          (workspace) REAL array, dimension ( NMAX ) */
00137 
00138 /*  ===================================================================== */
00139 /*     .. */
00140 /*     .. Parameters .. */
00141 /*     .. */
00142 /*     .. Local Scalars .. */
00143 /*     .. */
00144 /*     .. Local Arrays .. */
00145 /*     .. */
00146 /*     .. External Functions .. */
00147 /*     .. */
00148 /*     .. External Subroutines .. */
00149 /*     .. */
00150 /*     .. Scalars in Common .. */
00151 /*     .. */
00152 /*     .. Common blocks .. */
00153 /*     .. */
00154 /*     .. Data statements .. */
00155     /* Parameter adjustments */
00156     --nval;
00157     a_dim1 = *lda;
00158     a_offset = 1 + a_dim1;
00159     a -= a_offset;
00160     --arf;
00161     --work;
00162 
00163     /* Function Body */
00164 /*     .. */
00165 /*     .. Executable Statements .. */
00166 
00167 /*     Initialize constants and the random number seed. */
00168 
00169     nrun = 0;
00170     nfail = 0;
00171     nerrs = 0;
00172     info = 0;
00173     for (i__ = 1; i__ <= 4; ++i__) {
00174         iseed[i__ - 1] = iseedy[i__ - 1];
00175 /* L10: */
00176     }
00177 
00178     eps = slamch_("Precision");
00179     small = slamch_("Safe minimum");
00180     large = 1.f / small;
00181     small = small * *lda * *lda;
00182     large = large / *lda / *lda;
00183 
00184     i__1 = *nn;
00185     for (iin = 1; iin <= i__1; ++iin) {
00186 
00187         n = nval[iin];
00188 
00189         for (iit = 1; iit <= 3; ++iit) {
00190 
00191 /*           IIT = 1 : random matrix */
00192 /*           IIT = 2 : random matrix scaled near underflow */
00193 /*           IIT = 3 : random matrix scaled near overflow */
00194 
00195             i__2 = n;
00196             for (j = 1; j <= i__2; ++j) {
00197                 i__3 = n;
00198                 for (i__ = 1; i__ <= i__3; ++i__) {
00199                     a[i__ + j * a_dim1] = slarnd_(&c__2, iseed);
00200                 }
00201             }
00202 
00203             if (iit == 2) {
00204                 i__2 = n;
00205                 for (j = 1; j <= i__2; ++j) {
00206                     i__3 = n;
00207                     for (i__ = 1; i__ <= i__3; ++i__) {
00208                         a[i__ + j * a_dim1] *= large;
00209                     }
00210                 }
00211             }
00212 
00213             if (iit == 3) {
00214                 i__2 = n;
00215                 for (j = 1; j <= i__2; ++j) {
00216                     i__3 = n;
00217                     for (i__ = 1; i__ <= i__3; ++i__) {
00218                         a[i__ + j * a_dim1] *= small;
00219                     }
00220                 }
00221             }
00222 
00223 /*           Do first for UPLO = 'U', then for UPLO = 'L' */
00224 
00225             for (iuplo = 1; iuplo <= 2; ++iuplo) {
00226 
00227                 *(unsigned char *)uplo = *(unsigned char *)&uplos[iuplo - 1];
00228 
00229 /*              Do first for CFORM = 'N', then for CFORM = 'C' */
00230 
00231                 for (iform = 1; iform <= 2; ++iform) {
00232 
00233                     *(unsigned char *)cform = *(unsigned char *)&forms[iform 
00234                             - 1];
00235 
00236                     s_copy(srnamc_1.srnamt, "STRTTF", (ftnlen)32, (ftnlen)6);
00237                     strttf_(cform, uplo, &n, &a[a_offset], lda, &arf[1], &
00238                             info);
00239 
00240 /*                 Check error code from STRTTF */
00241 
00242                     if (info != 0) {
00243                         if (nfail == 0 && nerrs == 0) {
00244                             io___22.ciunit = *nout;
00245                             s_wsle(&io___22);
00246                             e_wsle();
00247                             io___23.ciunit = *nout;
00248                             s_wsfe(&io___23);
00249                             e_wsfe();
00250                         }
00251                         io___24.ciunit = *nout;
00252                         s_wsfe(&io___24);
00253                         do_fio(&c__1, srnamc_1.srnamt, (ftnlen)32);
00254                         do_fio(&c__1, uplo, (ftnlen)1);
00255                         do_fio(&c__1, cform, (ftnlen)1);
00256                         do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
00257                         e_wsfe();
00258                         ++nerrs;
00259                         goto L100;
00260                     }
00261 
00262                     for (inorm = 1; inorm <= 4; ++inorm) {
00263 
00264 /*                    Check all four norms: 'M', '1', 'I', 'F' */
00265 
00266                         *(unsigned char *)norm = *(unsigned char *)&norms[
00267                                 inorm - 1];
00268                         normarf = slansf_(norm, cform, uplo, &n, &arf[1], &
00269                                 work[1]);
00270                         norma = slansy_(norm, uplo, &n, &a[a_offset], lda, &
00271                                 work[1]);
00272 
00273                         result[0] = (norma - normarf) / norma / eps;
00274                         ++nrun;
00275 
00276                         if (result[0] >= *thresh) {
00277                             if (nfail == 0 && nerrs == 0) {
00278                                 io___30.ciunit = *nout;
00279                                 s_wsle(&io___30);
00280                                 e_wsle();
00281                                 io___31.ciunit = *nout;
00282                                 s_wsfe(&io___31);
00283                                 e_wsfe();
00284                             }
00285                             io___32.ciunit = *nout;
00286                             s_wsfe(&io___32);
00287                             do_fio(&c__1, "SLANSF", (ftnlen)6);
00288                             do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer))
00289                                     ;
00290                             do_fio(&c__1, (char *)&iit, (ftnlen)sizeof(
00291                                     integer));
00292                             do_fio(&c__1, uplo, (ftnlen)1);
00293                             do_fio(&c__1, cform, (ftnlen)1);
00294                             do_fio(&c__1, norm, (ftnlen)1);
00295                             do_fio(&c__1, (char *)&result[0], (ftnlen)sizeof(
00296                                     real));
00297                             e_wsfe();
00298                             ++nfail;
00299                         }
00300 /* L90: */
00301                     }
00302 L100:
00303                     ;
00304                 }
00305 /* L110: */
00306             }
00307 /* L120: */
00308         }
00309 /* L130: */
00310     }
00311 
00312 /*     Print a summary of the results. */
00313 
00314     if (nfail == 0) {
00315         io___33.ciunit = *nout;
00316         s_wsfe(&io___33);
00317         do_fio(&c__1, "SLANSF", (ftnlen)6);
00318         do_fio(&c__1, (char *)&nrun, (ftnlen)sizeof(integer));
00319         e_wsfe();
00320     } else {
00321         io___34.ciunit = *nout;
00322         s_wsfe(&io___34);
00323         do_fio(&c__1, "SLANSF", (ftnlen)6);
00324         do_fio(&c__1, (char *)&nfail, (ftnlen)sizeof(integer));
00325         do_fio(&c__1, (char *)&nrun, (ftnlen)sizeof(integer));
00326         e_wsfe();
00327     }
00328     if (nerrs != 0) {
00329         io___35.ciunit = *nout;
00330         s_wsfe(&io___35);
00331         do_fio(&c__1, (char *)&nerrs, (ftnlen)sizeof(integer));
00332         do_fio(&c__1, "SLANSF", (ftnlen)6);
00333         e_wsfe();
00334     }
00335 
00336 
00337     return 0;
00338 
00339 /*     End of SDRVRF1 */
00340 
00341 } /* sdrvrf1_ */


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