dblat1.c
Go to the documentation of this file.
00001 /* dblat1.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 icase, n, incx, incy, mode;
00020     logical pass;
00021 } combla_;
00022 
00023 #define combla_1 combla_
00024 
00025 /* Table of constant values */
00026 
00027 static integer c__1 = 1;
00028 static integer c__9 = 9;
00029 static doublereal c_b34 = 1.;
00030 static integer c__5 = 5;
00031 
00032 /* Main program */ int MAIN__(void)
00033 {
00034     /* Initialized data */
00035 
00036     static doublereal sfac = 9.765625e-4;
00037 
00038     /* Format strings */
00039     static char fmt_99999[] = "(\002 Real BLAS Test Program Results\002,/1x)";
00040     static char fmt_99998[] = "(\002                                    ----"
00041             "- PASS -----\002)";
00042 
00043     /* Builtin functions */
00044     integer s_wsfe(cilist *), e_wsfe(void);
00045     /* Subroutine */ int s_stop(char *, ftnlen);
00046 
00047     /* Local variables */
00048     integer ic;
00049     extern /* Subroutine */ int check0_(doublereal *), check1_(doublereal *), 
00050             check2_(doublereal *), check3_(doublereal *), header_(void);
00051 
00052     /* Fortran I/O blocks */
00053     static cilist io___2 = { 0, 6, 0, fmt_99999, 0 };
00054     static cilist io___4 = { 0, 6, 0, fmt_99998, 0 };
00055 
00056 
00057 /*     Test program for the DOUBLE PRECISION Level 1 BLAS. */
00058 /*     Based upon the original BLAS test routine together with: */
00059 /*     F06EAF Example Program Text */
00060 /*     .. Parameters .. */
00061 /*     .. Scalars in Common .. */
00062 /*     .. Local Scalars .. */
00063 /*     .. External Subroutines .. */
00064 /*     .. Common blocks .. */
00065 /*     .. Data statements .. */
00066 /*     .. Executable Statements .. */
00067     s_wsfe(&io___2);
00068     e_wsfe();
00069     for (ic = 1; ic <= 10; ++ic) {
00070         combla_1.icase = ic;
00071         header_();
00072 
00073 /*        .. Initialize  PASS,  INCX,  INCY, and MODE for a new case. .. */
00074 /*        .. the value 9999 for INCX, INCY or MODE will appear in the .. */
00075 /*        .. detailed  output, if any, for cases  that do not involve .. */
00076 /*        .. these parameters .. */
00077 
00078         combla_1.pass = TRUE_;
00079         combla_1.incx = 9999;
00080         combla_1.incy = 9999;
00081         combla_1.mode = 9999;
00082         if (combla_1.icase == 3) {
00083             check0_(&sfac);
00084         } else if (combla_1.icase == 7 || combla_1.icase == 8 || 
00085                 combla_1.icase == 9 || combla_1.icase == 10) {
00086             check1_(&sfac);
00087         } else if (combla_1.icase == 1 || combla_1.icase == 2 || 
00088                 combla_1.icase == 5 || combla_1.icase == 6) {
00089             check2_(&sfac);
00090         } else if (combla_1.icase == 4) {
00091             check3_(&sfac);
00092         }
00093 /*        -- Print */
00094         if (combla_1.pass) {
00095             s_wsfe(&io___4);
00096             e_wsfe();
00097         }
00098 /* L20: */
00099     }
00100     s_stop("", (ftnlen)0);
00101 
00102     return 0;
00103 } /* MAIN__ */
00104 
00105 /* Subroutine */ int header_(void)
00106 {
00107     /* Initialized data */
00108 
00109     static char l[6*10] = " DDOT " "DAXPY " "DROTG " " DROT " "DCOPY " "DSWA"
00110             "P " "DNRM2 " "DASUM " "DSCAL " "IDAMAX";
00111 
00112     /* Format strings */
00113     static char fmt_99999[] = "(/\002 Test of subprogram number\002,i3,12x,a"
00114             "6)";
00115 
00116     /* Builtin functions */
00117     integer s_wsfe(cilist *), do_fio(integer *, char *, ftnlen), e_wsfe(void);
00118 
00119     /* Fortran I/O blocks */
00120     static cilist io___6 = { 0, 6, 0, fmt_99999, 0 };
00121 
00122 
00123 /*     .. Parameters .. */
00124 /*     .. Scalars in Common .. */
00125 /*     .. Local Arrays .. */
00126 /*     .. Common blocks .. */
00127 /*     .. Data statements .. */
00128 /*     .. Executable Statements .. */
00129     s_wsfe(&io___6);
00130     do_fio(&c__1, (char *)&combla_1.icase, (ftnlen)sizeof(integer));
00131     do_fio(&c__1, l + (0 + (0 + (combla_1.icase - 1) * 6)), (ftnlen)6);
00132     e_wsfe();
00133     return 0;
00134 
00135 } /* header_ */
00136 
00137 /* Subroutine */ int check0_(doublereal *sfac)
00138 {
00139     /* Initialized data */
00140 
00141     static doublereal ds1[8] = { .8,.6,.8,-.6,.8,0.,1.,0. };
00142     static doublereal datrue[8] = { .5,.5,.5,-.5,-.5,0.,1.,1. };
00143     static doublereal dbtrue[8] = { 0.,.6,0.,-.6,0.,0.,1.,0. };
00144     static doublereal da1[8] = { .3,.4,-.3,-.4,-.3,0.,0.,1. };
00145     static doublereal db1[8] = { .4,.3,.4,.3,-.4,0.,1.,0. };
00146     static doublereal dc1[8] = { .6,.8,-.6,.8,.6,1.,0.,1. };
00147 
00148     /* Builtin functions */
00149     integer s_wsle(cilist *), do_lio(integer *, integer *, char *, ftnlen), 
00150             e_wsle(void);
00151     /* Subroutine */ int s_stop(char *, ftnlen);
00152 
00153     /* Local variables */
00154     integer k;
00155     doublereal sa, sb, sc, ss;
00156     extern /* Subroutine */ int drotg_(doublereal *, doublereal *, doublereal 
00157             *, doublereal *), stest1_(doublereal *, doublereal *, doublereal *
00158             , doublereal *);
00159 
00160     /* Fortran I/O blocks */
00161     static cilist io___18 = { 0, 6, 0, 0, 0 };
00162 
00163 
00164 /*     .. Parameters .. */
00165 /*     .. Scalar Arguments .. */
00166 /*     .. Scalars in Common .. */
00167 /*     .. Local Scalars .. */
00168 /*     .. Local Arrays .. */
00169 /*     .. External Subroutines .. */
00170 /*     .. Common blocks .. */
00171 /*     .. Data statements .. */
00172 /*     .. Executable Statements .. */
00173 
00174 /*     Compute true values which cannot be prestored */
00175 /*     in decimal notation */
00176 
00177     dbtrue[0] = 1.6666666666666667;
00178     dbtrue[2] = -1.6666666666666667;
00179     dbtrue[4] = 1.6666666666666667;
00180 
00181     for (k = 1; k <= 8; ++k) {
00182 /*        .. Set N=K for identification in output if any .. */
00183         combla_1.n = k;
00184         if (combla_1.icase == 3) {
00185 /*           .. DROTG .. */
00186             if (k > 8) {
00187                 goto L40;
00188             }
00189             sa = da1[k - 1];
00190             sb = db1[k - 1];
00191             drotg_(&sa, &sb, &sc, &ss);
00192             stest1_(&sa, &datrue[k - 1], &datrue[k - 1], sfac);
00193             stest1_(&sb, &dbtrue[k - 1], &dbtrue[k - 1], sfac);
00194             stest1_(&sc, &dc1[k - 1], &dc1[k - 1], sfac);
00195             stest1_(&ss, &ds1[k - 1], &ds1[k - 1], sfac);
00196         } else {
00197             s_wsle(&io___18);
00198             do_lio(&c__9, &c__1, " Shouldn't be here in CHECK0", (ftnlen)28);
00199             e_wsle();
00200             s_stop("", (ftnlen)0);
00201         }
00202 /* L20: */
00203     }
00204 L40:
00205     return 0;
00206 } /* check0_ */
00207 
00208 /* Subroutine */ int check1_(doublereal *sfac)
00209 {
00210     /* Initialized data */
00211 
00212     static doublereal sa[10] = { .3,-1.,0.,1.,.3,.3,.3,.3,.3,.3 };
00213     static doublereal dv[80]    /* was [8][5][2] */ = { .1,2.,2.,2.,2.,2.,2.,
00214             2.,.3,3.,3.,3.,3.,3.,3.,3.,.3,-.4,4.,4.,4.,4.,4.,4.,.2,-.6,.3,5.,
00215             5.,5.,5.,5.,.1,-.3,.5,-.1,6.,6.,6.,6.,.1,8.,8.,8.,8.,8.,8.,8.,.3,
00216             9.,9.,9.,9.,9.,9.,9.,.3,2.,-.4,2.,2.,2.,2.,2.,.2,3.,-.6,5.,.3,2.,
00217             2.,2.,.1,4.,-.3,6.,-.5,7.,-.1,3. };
00218     static doublereal dtrue1[5] = { 0.,.3,.5,.7,.6 };
00219     static doublereal dtrue3[5] = { 0.,.3,.7,1.1,1. };
00220     static doublereal dtrue5[80]        /* was [8][5][2] */ = { .1,2.,2.,2.,
00221             2.,2.,2.,2.,-.3,3.,3.,3.,3.,3.,3.,3.,0.,0.,4.,4.,4.,4.,4.,4.,.2,
00222             -.6,.3,5.,5.,5.,5.,5.,.03,-.09,.15,-.03,6.,6.,6.,6.,.1,8.,8.,8.,
00223             8.,8.,8.,8.,.09,9.,9.,9.,9.,9.,9.,9.,.09,2.,-.12,2.,2.,2.,2.,2.,
00224             .06,3.,-.18,5.,.09,2.,2.,2.,.03,4.,-.09,6.,-.15,7.,-.03,3. };
00225     static integer itrue2[5] = { 0,1,2,2,3 };
00226 
00227     /* System generated locals */
00228     integer i__1;
00229     doublereal d__1;
00230 
00231     /* Builtin functions */
00232     integer s_wsle(cilist *), do_lio(integer *, integer *, char *, ftnlen), 
00233             e_wsle(void);
00234     /* Subroutine */ int s_stop(char *, ftnlen);
00235 
00236     /* Local variables */
00237     integer i__;
00238     doublereal sx[8];
00239     integer np1, len;
00240     extern doublereal dnrm2_(integer *, doublereal *, integer *);
00241     extern /* Subroutine */ int dscal_(integer *, doublereal *, doublereal *, 
00242             integer *);
00243     extern doublereal dasum_(integer *, doublereal *, integer *);
00244     doublereal stemp[1], strue[8];
00245     extern /* Subroutine */ int stest_(integer *, doublereal *, doublereal *, 
00246             doublereal *, doublereal *), itest1_(integer *, integer *), 
00247             stest1_(doublereal *, doublereal *, doublereal *, doublereal *);
00248     extern integer idamax_(integer *, doublereal *, integer *);
00249 
00250     /* Fortran I/O blocks */
00251     static cilist io___31 = { 0, 6, 0, 0, 0 };
00252 
00253 
00254 /*     .. Parameters .. */
00255 /*     .. Scalar Arguments .. */
00256 /*     .. Scalars in Common .. */
00257 /*     .. Local Scalars .. */
00258 /*     .. Local Arrays .. */
00259 /*     .. External Functions .. */
00260 /*     .. External Subroutines .. */
00261 /*     .. Intrinsic Functions .. */
00262 /*     .. Common blocks .. */
00263 /*     .. Data statements .. */
00264 /*     .. Executable Statements .. */
00265     for (combla_1.incx = 1; combla_1.incx <= 2; ++combla_1.incx) {
00266         for (np1 = 1; np1 <= 5; ++np1) {
00267             combla_1.n = np1 - 1;
00268             len = max(combla_1.n,1) << 1;
00269 /*           .. Set vector arguments .. */
00270             i__1 = len;
00271             for (i__ = 1; i__ <= i__1; ++i__) {
00272                 sx[i__ - 1] = dv[i__ + (np1 + combla_1.incx * 5 << 3) - 49];
00273 /* L20: */
00274             }
00275 
00276             if (combla_1.icase == 7) {
00277 /*              .. DNRM2 .. */
00278                 stemp[0] = dtrue1[np1 - 1];
00279                 d__1 = dnrm2_(&combla_1.n, sx, &combla_1.incx);
00280                 stest1_(&d__1, stemp, stemp, sfac);
00281             } else if (combla_1.icase == 8) {
00282 /*              .. DASUM .. */
00283                 stemp[0] = dtrue3[np1 - 1];
00284                 d__1 = dasum_(&combla_1.n, sx, &combla_1.incx);
00285                 stest1_(&d__1, stemp, stemp, sfac);
00286             } else if (combla_1.icase == 9) {
00287 /*              .. DSCAL .. */
00288                 dscal_(&combla_1.n, &sa[(combla_1.incx - 1) * 5 + np1 - 1], 
00289                         sx, &combla_1.incx);
00290                 i__1 = len;
00291                 for (i__ = 1; i__ <= i__1; ++i__) {
00292                     strue[i__ - 1] = dtrue5[i__ + (np1 + combla_1.incx * 5 << 
00293                             3) - 49];
00294 /* L40: */
00295                 }
00296                 stest_(&len, sx, strue, strue, sfac);
00297             } else if (combla_1.icase == 10) {
00298 /*              .. IDAMAX .. */
00299                 i__1 = idamax_(&combla_1.n, sx, &combla_1.incx);
00300                 itest1_(&i__1, &itrue2[np1 - 1]);
00301             } else {
00302                 s_wsle(&io___31);
00303                 do_lio(&c__9, &c__1, " Shouldn't be here in CHECK1", (ftnlen)
00304                         28);
00305                 e_wsle();
00306                 s_stop("", (ftnlen)0);
00307             }
00308 /* L60: */
00309         }
00310 /* L80: */
00311     }
00312     return 0;
00313 } /* check1_ */
00314 
00315 /* Subroutine */ int check2_(doublereal *sfac)
00316 {
00317     /* Initialized data */
00318 
00319     static doublereal sa = .3;
00320     static integer incxs[4] = { 1,2,-2,-1 };
00321     static integer incys[4] = { 1,-2,1,-2 };
00322     static integer lens[8]      /* was [4][2] */ = { 1,1,2,4,1,1,3,7 };
00323     static integer ns[4] = { 0,1,2,4 };
00324     static doublereal dx1[7] = { .6,.1,-.5,.8,.9,-.3,-.4 };
00325     static doublereal dy1[7] = { .5,-.9,.3,.7,-.6,.2,.8 };
00326     static doublereal dt7[16]   /* was [4][4] */ = { 0.,.3,.21,.62,0.,.3,-.07,
00327             .85,0.,.3,-.79,-.74,0.,.3,.33,1.27 };
00328     static doublereal dt8[112]  /* was [7][4][4] */ = { .5,0.,0.,0.,0.,0.,0.,
00329             .68,0.,0.,0.,0.,0.,0.,.68,-.87,0.,0.,0.,0.,0.,.68,-.87,.15,.94,0.,
00330             0.,0.,.5,0.,0.,0.,0.,0.,0.,.68,0.,0.,0.,0.,0.,0.,.35,-.9,.48,0.,
00331             0.,0.,0.,.38,-.9,.57,.7,-.75,.2,.98,.5,0.,0.,0.,0.,0.,0.,.68,0.,
00332             0.,0.,0.,0.,0.,.35,-.72,0.,0.,0.,0.,0.,.38,-.63,.15,.88,0.,0.,0.,
00333             .5,0.,0.,0.,0.,0.,0.,.68,0.,0.,0.,0.,0.,0.,.68,-.9,.33,0.,0.,0.,
00334             0.,.68,-.9,.33,.7,-.75,.2,1.04 };
00335     static doublereal dt10x[112]        /* was [7][4][4] */ = { .6,0.,0.,0.,
00336             0.,0.,0.,.5,0.,0.,0.,0.,0.,0.,.5,-.9,0.,0.,0.,0.,0.,.5,-.9,.3,.7,
00337             0.,0.,0.,.6,0.,0.,0.,0.,0.,0.,.5,0.,0.,0.,0.,0.,0.,.3,.1,.5,0.,0.,
00338             0.,0.,.8,.1,-.6,.8,.3,-.3,.5,.6,0.,0.,0.,0.,0.,0.,.5,0.,0.,0.,0.,
00339             0.,0.,-.9,.1,.5,0.,0.,0.,0.,.7,.1,.3,.8,-.9,-.3,.5,.6,0.,0.,0.,0.,
00340             0.,0.,.5,0.,0.,0.,0.,0.,0.,.5,.3,0.,0.,0.,0.,0.,.5,.3,-.6,.8,0.,
00341             0.,0. };
00342     static doublereal dt10y[112]        /* was [7][4][4] */ = { .5,0.,0.,0.,
00343             0.,0.,0.,.6,0.,0.,0.,0.,0.,0.,.6,.1,0.,0.,0.,0.,0.,.6,.1,-.5,.8,
00344             0.,0.,0.,.5,0.,0.,0.,0.,0.,0.,.6,0.,0.,0.,0.,0.,0.,-.5,-.9,.6,0.,
00345             0.,0.,0.,-.4,-.9,.9,.7,-.5,.2,.6,.5,0.,0.,0.,0.,0.,0.,.6,0.,0.,0.,
00346             0.,0.,0.,-.5,.6,0.,0.,0.,0.,0.,-.4,.9,-.5,.6,0.,0.,0.,.5,0.,0.,0.,
00347             0.,0.,0.,.6,0.,0.,0.,0.,0.,0.,.6,-.9,.1,0.,0.,0.,0.,.6,-.9,.1,.7,
00348             -.5,.2,.8 };
00349     static doublereal ssize1[4] = { 0.,.3,1.6,3.2 };
00350     static doublereal ssize2[28]        /* was [14][2] */ = { 0.,0.,0.,0.,0.,
00351             0.,0.,0.,0.,0.,0.,0.,0.,0.,1.17,1.17,1.17,1.17,1.17,1.17,1.17,
00352             1.17,1.17,1.17,1.17,1.17,1.17,1.17 };
00353 
00354     /* System generated locals */
00355     integer i__1;
00356     doublereal d__1;
00357 
00358     /* Builtin functions */
00359     integer s_wsle(cilist *), do_lio(integer *, integer *, char *, ftnlen), 
00360             e_wsle(void);
00361     /* Subroutine */ int s_stop(char *, ftnlen);
00362 
00363     /* Local variables */
00364     integer i__, j, ki, kn, mx, my;
00365     doublereal sx[7], sy[7], stx[7], sty[7];
00366     extern doublereal ddot_(integer *, doublereal *, integer *, doublereal *, 
00367             integer *);
00368     integer lenx, leny;
00369     extern /* Subroutine */ int dcopy_(integer *, doublereal *, integer *, 
00370             doublereal *, integer *), dswap_(integer *, doublereal *, integer 
00371             *, doublereal *, integer *);
00372     integer ksize;
00373     extern /* Subroutine */ int daxpy_(integer *, doublereal *, doublereal *, 
00374             integer *, doublereal *, integer *), stest_(integer *, doublereal 
00375             *, doublereal *, doublereal *, doublereal *), stest1_(doublereal *
00376             , doublereal *, doublereal *, doublereal *);
00377 
00378     /* Fortran I/O blocks */
00379     static cilist io___58 = { 0, 6, 0, 0, 0 };
00380 
00381 
00382 /*     .. Parameters .. */
00383 /*     .. Scalar Arguments .. */
00384 /*     .. Scalars in Common .. */
00385 /*     .. Local Scalars .. */
00386 /*     .. Local Arrays .. */
00387 /*     .. External Functions .. */
00388 /*     .. External Subroutines .. */
00389 /*     .. Intrinsic Functions .. */
00390 /*     .. Common blocks .. */
00391 /*     .. Data statements .. */
00392 /*     .. Executable Statements .. */
00393 
00394     for (ki = 1; ki <= 4; ++ki) {
00395         combla_1.incx = incxs[ki - 1];
00396         combla_1.incy = incys[ki - 1];
00397         mx = abs(combla_1.incx);
00398         my = abs(combla_1.incy);
00399 
00400         for (kn = 1; kn <= 4; ++kn) {
00401             combla_1.n = ns[kn - 1];
00402             ksize = min(2,kn);
00403             lenx = lens[kn + (mx << 2) - 5];
00404             leny = lens[kn + (my << 2) - 5];
00405 /*           .. Initialize all argument arrays .. */
00406             for (i__ = 1; i__ <= 7; ++i__) {
00407                 sx[i__ - 1] = dx1[i__ - 1];
00408                 sy[i__ - 1] = dy1[i__ - 1];
00409 /* L20: */
00410             }
00411 
00412             if (combla_1.icase == 1) {
00413 /*              .. DDOT .. */
00414                 d__1 = ddot_(&combla_1.n, sx, &combla_1.incx, sy, &
00415                         combla_1.incy);
00416                 stest1_(&d__1, &dt7[kn + (ki << 2) - 5], &ssize1[kn - 1], 
00417                         sfac);
00418             } else if (combla_1.icase == 2) {
00419 /*              .. DAXPY .. */
00420                 daxpy_(&combla_1.n, &sa, sx, &combla_1.incx, sy, &
00421                         combla_1.incy);
00422                 i__1 = leny;
00423                 for (j = 1; j <= i__1; ++j) {
00424                     sty[j - 1] = dt8[j + (kn + (ki << 2)) * 7 - 36];
00425 /* L40: */
00426                 }
00427                 stest_(&leny, sy, sty, &ssize2[ksize * 14 - 14], sfac);
00428             } else if (combla_1.icase == 5) {
00429 /*              .. DCOPY .. */
00430                 for (i__ = 1; i__ <= 7; ++i__) {
00431                     sty[i__ - 1] = dt10y[i__ + (kn + (ki << 2)) * 7 - 36];
00432 /* L60: */
00433                 }
00434                 dcopy_(&combla_1.n, sx, &combla_1.incx, sy, &combla_1.incy);
00435                 stest_(&leny, sy, sty, ssize2, &c_b34);
00436             } else if (combla_1.icase == 6) {
00437 /*              .. DSWAP .. */
00438                 dswap_(&combla_1.n, sx, &combla_1.incx, sy, &combla_1.incy);
00439                 for (i__ = 1; i__ <= 7; ++i__) {
00440                     stx[i__ - 1] = dt10x[i__ + (kn + (ki << 2)) * 7 - 36];
00441                     sty[i__ - 1] = dt10y[i__ + (kn + (ki << 2)) * 7 - 36];
00442 /* L80: */
00443                 }
00444                 stest_(&lenx, sx, stx, ssize2, &c_b34);
00445                 stest_(&leny, sy, sty, ssize2, &c_b34);
00446             } else {
00447                 s_wsle(&io___58);
00448                 do_lio(&c__9, &c__1, " Shouldn't be here in CHECK2", (ftnlen)
00449                         28);
00450                 e_wsle();
00451                 s_stop("", (ftnlen)0);
00452             }
00453 /* L100: */
00454         }
00455 /* L120: */
00456     }
00457     return 0;
00458 } /* check2_ */
00459 
00460 /* Subroutine */ int check3_(doublereal *sfac)
00461 {
00462     /* Initialized data */
00463 
00464     static integer incxs[4] = { 1,2,-2,-1 };
00465     static integer incys[4] = { 1,-2,1,-2 };
00466     static integer lens[8]      /* was [4][2] */ = { 1,1,2,4,1,1,3,7 };
00467     static integer ns[4] = { 0,1,2,4 };
00468     static doublereal dx1[7] = { .6,.1,-.5,.8,.9,-.3,-.4 };
00469     static doublereal dy1[7] = { .5,-.9,.3,.7,-.6,.2,.8 };
00470     static doublereal sc = .8;
00471     static doublereal ss = .6;
00472     static doublereal dt9x[112] /* was [7][4][4] */ = { .6,0.,0.,0.,0.,0.,0.,
00473             .78,0.,0.,0.,0.,0.,0.,.78,-.46,0.,0.,0.,0.,0.,.78,-.46,-.22,1.06,
00474             0.,0.,0.,.6,0.,0.,0.,0.,0.,0.,.78,0.,0.,0.,0.,0.,0.,.66,.1,-.1,0.,
00475             0.,0.,0.,.96,.1,-.76,.8,.9,-.3,-.02,.6,0.,0.,0.,0.,0.,0.,.78,0.,
00476             0.,0.,0.,0.,0.,-.06,.1,-.1,0.,0.,0.,0.,.9,.1,-.22,.8,.18,-.3,-.02,
00477             .6,0.,0.,0.,0.,0.,0.,.78,0.,0.,0.,0.,0.,0.,.78,.26,0.,0.,0.,0.,0.,
00478             .78,.26,-.76,1.12,0.,0.,0. };
00479     static doublereal dt9y[112] /* was [7][4][4] */ = { .5,0.,0.,0.,0.,0.,0.,
00480             .04,0.,0.,0.,0.,0.,0.,.04,-.78,0.,0.,0.,0.,0.,.04,-.78,.54,.08,0.,
00481             0.,0.,.5,0.,0.,0.,0.,0.,0.,.04,0.,0.,0.,0.,0.,0.,.7,-.9,-.12,0.,
00482             0.,0.,0.,.64,-.9,-.3,.7,-.18,.2,.28,.5,0.,0.,0.,0.,0.,0.,.04,0.,
00483             0.,0.,0.,0.,0.,.7,-1.08,0.,0.,0.,0.,0.,.64,-1.26,.54,.2,0.,0.,0.,
00484             .5,0.,0.,0.,0.,0.,0.,.04,0.,0.,0.,0.,0.,0.,.04,-.9,.18,0.,0.,0.,
00485             0.,.04,-.9,.18,.7,-.18,.2,.16 };
00486     static doublereal ssize2[28]        /* was [14][2] */ = { 0.,0.,0.,0.,0.,
00487             0.,0.,0.,0.,0.,0.,0.,0.,0.,1.17,1.17,1.17,1.17,1.17,1.17,1.17,
00488             1.17,1.17,1.17,1.17,1.17,1.17,1.17 };
00489 
00490     /* Builtin functions */
00491     integer s_wsle(cilist *), do_lio(integer *, integer *, char *, ftnlen), 
00492             e_wsle(void);
00493     /* Subroutine */ int s_stop(char *, ftnlen);
00494 
00495     /* Local variables */
00496     integer i__, k, ki, kn, mx, my;
00497     doublereal sx[7], sy[7], stx[7], sty[7];
00498     integer lenx, leny;
00499     doublereal mwpc[11];
00500     extern /* Subroutine */ int drot_(integer *, doublereal *, integer *, 
00501             doublereal *, integer *, doublereal *, doublereal *);
00502     integer mwpn[11];
00503     doublereal mwps[11], mwpx[5], mwpy[5];
00504     integer ksize;
00505     doublereal copyx[5], copyy[5];
00506     extern /* Subroutine */ int stest_(integer *, doublereal *, doublereal *, 
00507             doublereal *, doublereal *);
00508     doublereal mwptx[55]        /* was [11][5] */, mwpty[55]    /* was [11][5]
00509              */;
00510     integer mwpinx[11], mwpiny[11];
00511     doublereal mwpstx[5], mwpsty[5];
00512 
00513     /* Fortran I/O blocks */
00514     static cilist io___82 = { 0, 6, 0, 0, 0 };
00515 
00516 
00517 /*     .. Parameters .. */
00518 /*     .. Scalar Arguments .. */
00519 /*     .. Scalars in Common .. */
00520 /*     .. Local Scalars .. */
00521 /*     .. Local Arrays .. */
00522 /*     .. External Subroutines .. */
00523 /*     .. Intrinsic Functions .. */
00524 /*     .. Common blocks .. */
00525 /*     .. Data statements .. */
00526 /*     .. Executable Statements .. */
00527 
00528     for (ki = 1; ki <= 4; ++ki) {
00529         combla_1.incx = incxs[ki - 1];
00530         combla_1.incy = incys[ki - 1];
00531         mx = abs(combla_1.incx);
00532         my = abs(combla_1.incy);
00533 
00534         for (kn = 1; kn <= 4; ++kn) {
00535             combla_1.n = ns[kn - 1];
00536             ksize = min(2,kn);
00537             lenx = lens[kn + (mx << 2) - 5];
00538             leny = lens[kn + (my << 2) - 5];
00539 
00540             if (combla_1.icase == 4) {
00541 /*              .. DROT .. */
00542                 for (i__ = 1; i__ <= 7; ++i__) {
00543                     sx[i__ - 1] = dx1[i__ - 1];
00544                     sy[i__ - 1] = dy1[i__ - 1];
00545                     stx[i__ - 1] = dt9x[i__ + (kn + (ki << 2)) * 7 - 36];
00546                     sty[i__ - 1] = dt9y[i__ + (kn + (ki << 2)) * 7 - 36];
00547 /* L20: */
00548                 }
00549                 drot_(&combla_1.n, sx, &combla_1.incx, sy, &combla_1.incy, &
00550                         sc, &ss);
00551                 stest_(&lenx, sx, stx, &ssize2[ksize * 14 - 14], sfac);
00552                 stest_(&leny, sy, sty, &ssize2[ksize * 14 - 14], sfac);
00553             } else {
00554                 s_wsle(&io___82);
00555                 do_lio(&c__9, &c__1, " Shouldn't be here in CHECK3", (ftnlen)
00556                         28);
00557                 e_wsle();
00558                 s_stop("", (ftnlen)0);
00559             }
00560 /* L40: */
00561         }
00562 /* L60: */
00563     }
00564 
00565     mwpc[0] = 1.;
00566     for (i__ = 2; i__ <= 11; ++i__) {
00567         mwpc[i__ - 1] = 0.;
00568 /* L80: */
00569     }
00570     mwps[0] = 0.;
00571     for (i__ = 2; i__ <= 6; ++i__) {
00572         mwps[i__ - 1] = 1.;
00573 /* L100: */
00574     }
00575     for (i__ = 7; i__ <= 11; ++i__) {
00576         mwps[i__ - 1] = -1.;
00577 /* L120: */
00578     }
00579     mwpinx[0] = 1;
00580     mwpinx[1] = 1;
00581     mwpinx[2] = 1;
00582     mwpinx[3] = -1;
00583     mwpinx[4] = 1;
00584     mwpinx[5] = -1;
00585     mwpinx[6] = 1;
00586     mwpinx[7] = 1;
00587     mwpinx[8] = -1;
00588     mwpinx[9] = 1;
00589     mwpinx[10] = -1;
00590     mwpiny[0] = 1;
00591     mwpiny[1] = 1;
00592     mwpiny[2] = -1;
00593     mwpiny[3] = -1;
00594     mwpiny[4] = 2;
00595     mwpiny[5] = 1;
00596     mwpiny[6] = 1;
00597     mwpiny[7] = -1;
00598     mwpiny[8] = -1;
00599     mwpiny[9] = 2;
00600     mwpiny[10] = 1;
00601     for (i__ = 1; i__ <= 11; ++i__) {
00602         mwpn[i__ - 1] = 5;
00603 /* L140: */
00604     }
00605     mwpn[4] = 3;
00606     mwpn[9] = 3;
00607     for (i__ = 1; i__ <= 5; ++i__) {
00608         mwpx[i__ - 1] = (doublereal) i__;
00609         mwpy[i__ - 1] = (doublereal) i__;
00610         mwptx[i__ * 11 - 11] = (doublereal) i__;
00611         mwpty[i__ * 11 - 11] = (doublereal) i__;
00612         mwptx[i__ * 11 - 10] = (doublereal) i__;
00613         mwpty[i__ * 11 - 10] = (doublereal) (-i__);
00614         mwptx[i__ * 11 - 9] = (doublereal) (6 - i__);
00615         mwpty[i__ * 11 - 9] = (doublereal) (i__ - 6);
00616         mwptx[i__ * 11 - 8] = (doublereal) i__;
00617         mwpty[i__ * 11 - 8] = (doublereal) (-i__);
00618         mwptx[i__ * 11 - 6] = (doublereal) (6 - i__);
00619         mwpty[i__ * 11 - 6] = (doublereal) (i__ - 6);
00620         mwptx[i__ * 11 - 5] = (doublereal) (-i__);
00621         mwpty[i__ * 11 - 5] = (doublereal) i__;
00622         mwptx[i__ * 11 - 4] = (doublereal) (i__ - 6);
00623         mwpty[i__ * 11 - 4] = (doublereal) (6 - i__);
00624         mwptx[i__ * 11 - 3] = (doublereal) (-i__);
00625         mwpty[i__ * 11 - 3] = (doublereal) i__;
00626         mwptx[i__ * 11 - 1] = (doublereal) (i__ - 6);
00627         mwpty[i__ * 11 - 1] = (doublereal) (6 - i__);
00628 /* L160: */
00629     }
00630     mwptx[4] = 1.;
00631     mwptx[15] = 3.;
00632     mwptx[26] = 5.;
00633     mwptx[37] = 4.;
00634     mwptx[48] = 5.;
00635     mwpty[4] = -1.;
00636     mwpty[15] = 2.;
00637     mwpty[26] = -2.;
00638     mwpty[37] = 4.;
00639     mwpty[48] = -3.;
00640     mwptx[9] = -1.;
00641     mwptx[20] = -3.;
00642     mwptx[31] = -5.;
00643     mwptx[42] = 4.;
00644     mwptx[53] = 5.;
00645     mwpty[9] = 1.;
00646     mwpty[20] = 2.;
00647     mwpty[31] = 2.;
00648     mwpty[42] = 4.;
00649     mwpty[53] = 3.;
00650     for (i__ = 1; i__ <= 11; ++i__) {
00651         combla_1.incx = mwpinx[i__ - 1];
00652         combla_1.incy = mwpiny[i__ - 1];
00653         for (k = 1; k <= 5; ++k) {
00654             copyx[k - 1] = mwpx[k - 1];
00655             copyy[k - 1] = mwpy[k - 1];
00656             mwpstx[k - 1] = mwptx[i__ + k * 11 - 12];
00657             mwpsty[k - 1] = mwpty[i__ + k * 11 - 12];
00658 /* L180: */
00659         }
00660         drot_(&mwpn[i__ - 1], copyx, &combla_1.incx, copyy, &combla_1.incy, &
00661                 mwpc[i__ - 1], &mwps[i__ - 1]);
00662         stest_(&c__5, copyx, mwpstx, mwpstx, sfac);
00663         stest_(&c__5, copyy, mwpsty, mwpsty, sfac);
00664 /* L200: */
00665     }
00666     return 0;
00667 } /* check3_ */
00668 
00669 /* Subroutine */ int stest_(integer *len, doublereal *scomp, doublereal *
00670         strue, doublereal *ssize, doublereal *sfac)
00671 {
00672     /* Format strings */
00673     static char fmt_99999[] = "(\002                                       F"
00674             "AIL\002)";
00675     static char fmt_99998[] = "(/\002 CASE  N INCX INCY MODE  I             "
00676             "               \002,\002 COMP(I)                             TRU"
00677             "E(I)  DIFFERENCE\002,\002     SIZE(I)\002,/1x)";
00678     static char fmt_99997[] = "(1x,i4,i3,3i5,i3,2d36.8,2d12.4)";
00679 
00680     /* System generated locals */
00681     integer i__1;
00682     doublereal d__1, d__2, d__3, d__4, d__5;
00683 
00684     /* Builtin functions */
00685     integer s_wsfe(cilist *), e_wsfe(void), do_fio(integer *, char *, ftnlen);
00686 
00687     /* Local variables */
00688     integer i__;
00689     doublereal sd;
00690     extern doublereal sdiff_(doublereal *, doublereal *);
00691 
00692     /* Fortran I/O blocks */
00693     static cilist io___99 = { 0, 6, 0, fmt_99999, 0 };
00694     static cilist io___100 = { 0, 6, 0, fmt_99998, 0 };
00695     static cilist io___101 = { 0, 6, 0, fmt_99997, 0 };
00696 
00697 
00698 /*     ********************************* STEST ************************** */
00699 
00700 /*     THIS SUBR COMPARES ARRAYS  SCOMP() AND STRUE() OF LENGTH LEN TO */
00701 /*     SEE IF THE TERM BY TERM DIFFERENCES, MULTIPLIED BY SFAC, ARE */
00702 /*     NEGLIGIBLE. */
00703 
00704 /*     C. L. LAWSON, JPL, 1974 DEC 10 */
00705 
00706 /*     .. Parameters .. */
00707 /*     .. Scalar Arguments .. */
00708 /*     .. Array Arguments .. */
00709 /*     .. Scalars in Common .. */
00710 /*     .. Local Scalars .. */
00711 /*     .. External Functions .. */
00712 /*     .. Intrinsic Functions .. */
00713 /*     .. Common blocks .. */
00714 /*     .. Executable Statements .. */
00715 
00716     /* Parameter adjustments */
00717     --ssize;
00718     --strue;
00719     --scomp;
00720 
00721     /* Function Body */
00722     i__1 = *len;
00723     for (i__ = 1; i__ <= i__1; ++i__) {
00724         sd = scomp[i__] - strue[i__];
00725         d__4 = (d__1 = ssize[i__], abs(d__1)) + (d__2 = *sfac * sd, abs(d__2))
00726                 ;
00727         d__5 = (d__3 = ssize[i__], abs(d__3));
00728         if (sdiff_(&d__4, &d__5) == 0.) {
00729             goto L40;
00730         }
00731 
00732 /*                             HERE    SCOMP(I) IS NOT CLOSE TO STRUE(I). */
00733 
00734         if (! combla_1.pass) {
00735             goto L20;
00736         }
00737 /*                             PRINT FAIL MESSAGE AND HEADER. */
00738         combla_1.pass = FALSE_;
00739         s_wsfe(&io___99);
00740         e_wsfe();
00741         s_wsfe(&io___100);
00742         e_wsfe();
00743 L20:
00744         s_wsfe(&io___101);
00745         do_fio(&c__1, (char *)&combla_1.icase, (ftnlen)sizeof(integer));
00746         do_fio(&c__1, (char *)&combla_1.n, (ftnlen)sizeof(integer));
00747         do_fio(&c__1, (char *)&combla_1.incx, (ftnlen)sizeof(integer));
00748         do_fio(&c__1, (char *)&combla_1.incy, (ftnlen)sizeof(integer));
00749         do_fio(&c__1, (char *)&combla_1.mode, (ftnlen)sizeof(integer));
00750         do_fio(&c__1, (char *)&i__, (ftnlen)sizeof(integer));
00751         do_fio(&c__1, (char *)&scomp[i__], (ftnlen)sizeof(doublereal));
00752         do_fio(&c__1, (char *)&strue[i__], (ftnlen)sizeof(doublereal));
00753         do_fio(&c__1, (char *)&sd, (ftnlen)sizeof(doublereal));
00754         do_fio(&c__1, (char *)&ssize[i__], (ftnlen)sizeof(doublereal));
00755         e_wsfe();
00756 L40:
00757         ;
00758     }
00759     return 0;
00760 
00761 } /* stest_ */
00762 
00763 /* Subroutine */ int stest1_(doublereal *scomp1, doublereal *strue1, 
00764         doublereal *ssize, doublereal *sfac)
00765 {
00766     doublereal scomp[1], strue[1];
00767     extern /* Subroutine */ int stest_(integer *, doublereal *, doublereal *, 
00768             doublereal *, doublereal *);
00769 
00770 /*     ************************* STEST1 ***************************** */
00771 
00772 /*     THIS IS AN INTERFACE SUBROUTINE TO ACCOMODATE THE FORTRAN */
00773 /*     REQUIREMENT THAT WHEN A DUMMY ARGUMENT IS AN ARRAY, THE */
00774 /*     ACTUAL ARGUMENT MUST ALSO BE AN ARRAY OR AN ARRAY ELEMENT. */
00775 
00776 /*     C.L. LAWSON, JPL, 1978 DEC 6 */
00777 
00778 /*     .. Scalar Arguments .. */
00779 /*     .. Array Arguments .. */
00780 /*     .. Local Arrays .. */
00781 /*     .. External Subroutines .. */
00782 /*     .. Executable Statements .. */
00783 
00784     /* Parameter adjustments */
00785     --ssize;
00786 
00787     /* Function Body */
00788     scomp[0] = *scomp1;
00789     strue[0] = *strue1;
00790     stest_(&c__1, scomp, strue, &ssize[1], sfac);
00791 
00792     return 0;
00793 } /* stest1_ */
00794 
00795 doublereal sdiff_(doublereal *sa, doublereal *sb)
00796 {
00797     /* System generated locals */
00798     doublereal ret_val;
00799 
00800 /*     ********************************* SDIFF ************************** */
00801 /*     COMPUTES DIFFERENCE OF TWO NUMBERS.  C. L. LAWSON, JPL 1974 FEB 15 */
00802 
00803 /*     .. Scalar Arguments .. */
00804 /*     .. Executable Statements .. */
00805     ret_val = *sa - *sb;
00806     return ret_val;
00807 } /* sdiff_ */
00808 
00809 /* Subroutine */ int itest1_(integer *icomp, integer *itrue)
00810 {
00811     /* Format strings */
00812     static char fmt_99999[] = "(\002                                       F"
00813             "AIL\002)";
00814     static char fmt_99998[] = "(/\002 CASE  N INCX INCY MODE                "
00815             "               \002,\002 COMP                                TRU"
00816             "E     DIFFERENCE\002,/1x)";
00817     static char fmt_99997[] = "(1x,i4,i3,3i5,2i36,i12)";
00818 
00819     /* Builtin functions */
00820     integer s_wsfe(cilist *), e_wsfe(void), do_fio(integer *, char *, ftnlen);
00821 
00822     /* Local variables */
00823     integer id;
00824 
00825     /* Fortran I/O blocks */
00826     static cilist io___104 = { 0, 6, 0, fmt_99999, 0 };
00827     static cilist io___105 = { 0, 6, 0, fmt_99998, 0 };
00828     static cilist io___107 = { 0, 6, 0, fmt_99997, 0 };
00829 
00830 
00831 /*     ********************************* ITEST1 ************************* */
00832 
00833 /*     THIS SUBROUTINE COMPARES THE VARIABLES ICOMP AND ITRUE FOR */
00834 /*     EQUALITY. */
00835 /*     C. L. LAWSON, JPL, 1974 DEC 10 */
00836 
00837 /*     .. Parameters .. */
00838 /*     .. Scalar Arguments .. */
00839 /*     .. Scalars in Common .. */
00840 /*     .. Local Scalars .. */
00841 /*     .. Common blocks .. */
00842 /*     .. Executable Statements .. */
00843 
00844     if (*icomp == *itrue) {
00845         goto L40;
00846     }
00847 
00848 /*                            HERE ICOMP IS NOT EQUAL TO ITRUE. */
00849 
00850     if (! combla_1.pass) {
00851         goto L20;
00852     }
00853 /*                             PRINT FAIL MESSAGE AND HEADER. */
00854     combla_1.pass = FALSE_;
00855     s_wsfe(&io___104);
00856     e_wsfe();
00857     s_wsfe(&io___105);
00858     e_wsfe();
00859 L20:
00860     id = *icomp - *itrue;
00861     s_wsfe(&io___107);
00862     do_fio(&c__1, (char *)&combla_1.icase, (ftnlen)sizeof(integer));
00863     do_fio(&c__1, (char *)&combla_1.n, (ftnlen)sizeof(integer));
00864     do_fio(&c__1, (char *)&combla_1.incx, (ftnlen)sizeof(integer));
00865     do_fio(&c__1, (char *)&combla_1.incy, (ftnlen)sizeof(integer));
00866     do_fio(&c__1, (char *)&combla_1.mode, (ftnlen)sizeof(integer));
00867     do_fio(&c__1, (char *)&(*icomp), (ftnlen)sizeof(integer));
00868     do_fio(&c__1, (char *)&(*itrue), (ftnlen)sizeof(integer));
00869     do_fio(&c__1, (char *)&id, (ftnlen)sizeof(integer));
00870     e_wsfe();
00871 L40:
00872     return 0;
00873 
00874 } /* itest1_ */
00875 
00876 /* Main program alias */ int dblat1_ () { MAIN__ (); return 0; }


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