/* cblat1.f -- translated by f2c (version 20061008). You must link the resulting object file with libf2c: on Microsoft Windows system, link with libf2c.lib; on Linux or Unix systems, link with .../path/to/libf2c.a -lm or, if you install libf2c.a in a standard place, with -lf2c -lm -- in that order, at the end of the command line, as in cc *.o -lf2c -lm Source for libf2c is in /netlib/f2c/libf2c.zip, e.g., http://www.netlib.org/f2c/libf2c.zip */ #include "f2c.h" #include "blaswrap.h" /* Common Block Declarations */ struct { integer icase, n, incx, incy, mode; logical pass; } combla_; #define combla_1 combla_ /* Table of constant values */ static integer c__1 = 1; static integer c__9 = 9; static integer c__5 = 5; static real c_b43 = 1.f; /* Main program */ int MAIN__(void) { /* Initialized data */ static real sfac = 9.765625e-4f; /* Format strings */ static char fmt_99999[] = "(\002 Complex BLAS Test Program Results\002,/" "1x)"; static char fmt_99998[] = "(\002 ----" "- PASS -----\002)"; /* Builtin functions */ integer s_wsfe(cilist *), e_wsfe(void); /* Subroutine */ int s_stop(char *, ftnlen); /* Local variables */ integer ic; extern /* Subroutine */ int check1_(real *), check2_(real *), header_( void); /* Fortran I/O blocks */ static cilist io___2 = { 0, 6, 0, fmt_99999, 0 }; static cilist io___4 = { 0, 6, 0, fmt_99998, 0 }; /* Test program for the COMPLEX Level 1 BLAS. */ /* Based upon the original BLAS test routine together with: */ /* F06GAF Example Program Text */ /* .. Parameters .. */ /* .. Scalars in Common .. */ /* .. Local Scalars .. */ /* .. External Subroutines .. */ /* .. Common blocks .. */ /* .. Data statements .. */ /* .. Executable Statements .. */ s_wsfe(&io___2); e_wsfe(); for (ic = 1; ic <= 10; ++ic) { combla_1.icase = ic; header_(); /* Initialize PASS, INCX, INCY, and MODE for a new case. */ /* The value 9999 for INCX, INCY or MODE will appear in the */ /* detailed output, if any, for cases that do not involve */ /* these parameters. */ combla_1.pass = TRUE_; combla_1.incx = 9999; combla_1.incy = 9999; combla_1.mode = 9999; if (combla_1.icase <= 5) { check2_(&sfac); } else if (combla_1.icase >= 6) { check1_(&sfac); } /* -- Print */ if (combla_1.pass) { s_wsfe(&io___4); e_wsfe(); } /* L20: */ } s_stop("", (ftnlen)0); return 0; } /* MAIN__ */ /* Subroutine */ int header_(void) { /* Initialized data */ static char l[6*10] = "CDOTC " "CDOTU " "CAXPY " "CCOPY " "CSWAP " "SCNR" "M2" "SCASUM" "CSCAL " "CSSCAL" "ICAMAX"; /* Format strings */ static char fmt_99999[] = "(/\002 Test of subprogram number\002,i3,12x,a" "6)"; /* Builtin functions */ integer s_wsfe(cilist *), do_fio(integer *, char *, ftnlen), e_wsfe(void); /* Fortran I/O blocks */ static cilist io___6 = { 0, 6, 0, fmt_99999, 0 }; /* .. Parameters .. */ /* .. Scalars in Common .. */ /* .. Local Arrays .. */ /* .. Common blocks .. */ /* .. Data statements .. */ /* .. Executable Statements .. */ s_wsfe(&io___6); do_fio(&c__1, (char *)&combla_1.icase, (ftnlen)sizeof(integer)); do_fio(&c__1, l + (0 + (0 + (combla_1.icase - 1) * 6)), (ftnlen)6); e_wsfe(); return 0; } /* header_ */ /* Subroutine */ int check1_(real *sfac) { /* Initialized data */ static real strue2[5] = { 0.f,.5f,.6f,.7f,.8f }; static real strue4[5] = { 0.f,.7f,1.f,1.3f,1.6f }; static complex ctrue5[80] /* was [8][5][2] */ = { {.1f,.1f},{1.f,2.f},{ 1.f,2.f},{1.f,2.f},{1.f,2.f},{1.f,2.f},{1.f,2.f},{1.f,2.f},{-.16f, -.37f},{3.f,4.f},{3.f,4.f},{3.f,4.f},{3.f,4.f},{3.f,4.f},{3.f,4.f} ,{3.f,4.f},{-.17f,-.19f},{.13f,-.39f},{5.f,6.f},{5.f,6.f},{5.f, 6.f},{5.f,6.f},{5.f,6.f},{5.f,6.f},{.11f,-.03f},{-.17f,.46f},{ -.17f,-.19f},{7.f,8.f},{7.f,8.f},{7.f,8.f},{7.f,8.f},{7.f,8.f},{ .19f,-.17f},{.2f,-.35f},{.35f,.2f},{.14f,.08f},{2.f,3.f},{2.f,3.f} ,{2.f,3.f},{2.f,3.f},{.1f,.1f},{4.f,5.f},{4.f,5.f},{4.f,5.f},{4.f, 5.f},{4.f,5.f},{4.f,5.f},{4.f,5.f},{-.16f,-.37f},{6.f,7.f},{6.f, 7.f},{6.f,7.f},{6.f,7.f},{6.f,7.f},{6.f,7.f},{6.f,7.f},{-.17f, -.19f},{8.f,9.f},{.13f,-.39f},{2.f,5.f},{2.f,5.f},{2.f,5.f},{2.f, 5.f},{2.f,5.f},{.11f,-.03f},{3.f,6.f},{-.17f,.46f},{4.f,7.f},{ -.17f,-.19f},{7.f,2.f},{7.f,2.f},{7.f,2.f},{.19f,-.17f},{5.f,8.f}, {.2f,-.35f},{6.f,9.f},{.35f,.2f},{8.f,3.f},{.14f,.08f},{9.f,4.f} } ; static complex ctrue6[80] /* was [8][5][2] */ = { {.1f,.1f},{1.f,2.f},{ 1.f,2.f},{1.f,2.f},{1.f,2.f},{1.f,2.f},{1.f,2.f},{1.f,2.f},{.09f, -.12f},{3.f,4.f},{3.f,4.f},{3.f,4.f},{3.f,4.f},{3.f,4.f},{3.f,4.f} ,{3.f,4.f},{.03f,-.09f},{.15f,-.03f},{5.f,6.f},{5.f,6.f},{5.f,6.f} ,{5.f,6.f},{5.f,6.f},{5.f,6.f},{.03f,.03f},{-.18f,.03f},{.03f, -.09f},{7.f,8.f},{7.f,8.f},{7.f,8.f},{7.f,8.f},{7.f,8.f},{.09f, .03f},{.15f,0.f},{0.f,.15f},{0.f,.06f},{2.f,3.f},{2.f,3.f},{2.f, 3.f},{2.f,3.f},{.1f,.1f},{4.f,5.f},{4.f,5.f},{4.f,5.f},{4.f,5.f},{ 4.f,5.f},{4.f,5.f},{4.f,5.f},{.09f,-.12f},{6.f,7.f},{6.f,7.f},{ 6.f,7.f},{6.f,7.f},{6.f,7.f},{6.f,7.f},{6.f,7.f},{.03f,-.09f},{ 8.f,9.f},{.15f,-.03f},{2.f,5.f},{2.f,5.f},{2.f,5.f},{2.f,5.f},{ 2.f,5.f},{.03f,.03f},{3.f,6.f},{-.18f,.03f},{4.f,7.f},{.03f,-.09f} ,{7.f,2.f},{7.f,2.f},{7.f,2.f},{.09f,.03f},{5.f,8.f},{.15f,0.f},{ 6.f,9.f},{0.f,.15f},{8.f,3.f},{0.f,.06f},{9.f,4.f} }; static integer itrue3[5] = { 0,1,2,2,2 }; static real sa = .3f; static complex ca = {.4f,-.7f}; static complex cv[80] /* was [8][5][2] */ = { {.1f,.1f},{1.f,2.f},{ 1.f,2.f},{1.f,2.f},{1.f,2.f},{1.f,2.f},{1.f,2.f},{1.f,2.f},{.3f, -.4f},{3.f,4.f},{3.f,4.f},{3.f,4.f},{3.f,4.f},{3.f,4.f},{3.f,4.f}, {3.f,4.f},{.1f,-.3f},{.5f,-.1f},{5.f,6.f},{5.f,6.f},{5.f,6.f},{ 5.f,6.f},{5.f,6.f},{5.f,6.f},{.1f,.1f},{-.6f,.1f},{.1f,-.3f},{7.f, 8.f},{7.f,8.f},{7.f,8.f},{7.f,8.f},{7.f,8.f},{.3f,.1f},{.5f,0.f},{ 0.f,.5f},{0.f,.2f},{2.f,3.f},{2.f,3.f},{2.f,3.f},{2.f,3.f},{.1f, .1f},{4.f,5.f},{4.f,5.f},{4.f,5.f},{4.f,5.f},{4.f,5.f},{4.f,5.f},{ 4.f,5.f},{.3f,-.4f},{6.f,7.f},{6.f,7.f},{6.f,7.f},{6.f,7.f},{6.f, 7.f},{6.f,7.f},{6.f,7.f},{.1f,-.3f},{8.f,9.f},{.5f,-.1f},{2.f,5.f} ,{2.f,5.f},{2.f,5.f},{2.f,5.f},{2.f,5.f},{.1f,.1f},{3.f,6.f},{ -.6f,.1f},{4.f,7.f},{.1f,-.3f},{7.f,2.f},{7.f,2.f},{7.f,2.f},{.3f, .1f},{5.f,8.f},{.5f,0.f},{6.f,9.f},{0.f,.5f},{8.f,3.f},{0.f,.2f},{ 9.f,4.f} }; /* System generated locals */ integer i__1, i__2, i__3; real r__1; complex q__1; /* Builtin functions */ integer s_wsle(cilist *), do_lio(integer *, integer *, char *, ftnlen), e_wsle(void); /* Subroutine */ int s_stop(char *, ftnlen); /* Local variables */ integer i__; complex cx[8]; integer np1, len; extern /* Subroutine */ int cscal_(integer *, complex *, complex *, integer *), ctest_(integer *, complex *, complex *, complex *, real *); complex mwpcs[5], mwpct[5]; extern doublereal scnrm2_(integer *, complex *, integer *); extern /* Subroutine */ int itest1_(integer *, integer *), stest1_(real *, real *, real *, real *); extern integer icamax_(integer *, complex *, integer *); extern /* Subroutine */ int csscal_(integer *, real *, complex *, integer *); extern doublereal scasum_(integer *, complex *, integer *); /* Fortran I/O blocks */ static cilist io___19 = { 0, 6, 0, 0, 0 }; /* .. Parameters .. */ /* .. Scalar Arguments .. */ /* .. Scalars in Common .. */ /* .. Local Scalars .. */ /* .. Local Arrays .. */ /* .. External Functions .. */ /* .. External Subroutines .. */ /* .. Intrinsic Functions .. */ /* .. Common blocks .. */ /* .. Data statements .. */ /* .. Executable Statements .. */ for (combla_1.incx = 1; combla_1.incx <= 2; ++combla_1.incx) { for (np1 = 1; np1 <= 5; ++np1) { combla_1.n = np1 - 1; len = max(combla_1.n,1) << 1; /* .. Set vector arguments .. */ i__1 = len; for (i__ = 1; i__ <= i__1; ++i__) { i__2 = i__ - 1; i__3 = i__ + (np1 + combla_1.incx * 5 << 3) - 49; cx[i__2].r = cv[i__3].r, cx[i__2].i = cv[i__3].i; /* L20: */ } if (combla_1.icase == 6) { /* .. SCNRM2 .. */ r__1 = scnrm2_(&combla_1.n, cx, &combla_1.incx); stest1_(&r__1, &strue2[np1 - 1], &strue2[np1 - 1], sfac); } else if (combla_1.icase == 7) { /* .. SCASUM .. */ r__1 = scasum_(&combla_1.n, cx, &combla_1.incx); stest1_(&r__1, &strue4[np1 - 1], &strue4[np1 - 1], sfac); } else if (combla_1.icase == 8) { /* .. CSCAL .. */ cscal_(&combla_1.n, &ca, cx, &combla_1.incx); ctest_(&len, cx, &ctrue5[(np1 + combla_1.incx * 5 << 3) - 48], &ctrue5[(np1 + combla_1.incx * 5 << 3) - 48], sfac); } else if (combla_1.icase == 9) { /* .. CSSCAL .. */ csscal_(&combla_1.n, &sa, cx, &combla_1.incx); ctest_(&len, cx, &ctrue6[(np1 + combla_1.incx * 5 << 3) - 48], &ctrue6[(np1 + combla_1.incx * 5 << 3) - 48], sfac); } else if (combla_1.icase == 10) { /* .. ICAMAX .. */ i__1 = icamax_(&combla_1.n, cx, &combla_1.incx); itest1_(&i__1, &itrue3[np1 - 1]); } else { s_wsle(&io___19); do_lio(&c__9, &c__1, " Shouldn't be here in CHECK1", (ftnlen) 28); e_wsle(); s_stop("", (ftnlen)0); } /* L40: */ } /* L60: */ } combla_1.incx = 1; if (combla_1.icase == 8) { /* CSCAL */ /* Add a test for alpha equal to zero. */ ca.r = 0.f, ca.i = 0.f; for (i__ = 1; i__ <= 5; ++i__) { i__1 = i__ - 1; mwpct[i__1].r = 0.f, mwpct[i__1].i = 0.f; i__1 = i__ - 1; mwpcs[i__1].r = 1.f, mwpcs[i__1].i = 1.f; /* L80: */ } cscal_(&c__5, &ca, cx, &combla_1.incx); ctest_(&c__5, cx, mwpct, mwpcs, sfac); } else if (combla_1.icase == 9) { /* CSSCAL */ /* Add a test for alpha equal to zero. */ sa = 0.f; for (i__ = 1; i__ <= 5; ++i__) { i__1 = i__ - 1; mwpct[i__1].r = 0.f, mwpct[i__1].i = 0.f; i__1 = i__ - 1; mwpcs[i__1].r = 1.f, mwpcs[i__1].i = 1.f; /* L100: */ } csscal_(&c__5, &sa, cx, &combla_1.incx); ctest_(&c__5, cx, mwpct, mwpcs, sfac); /* Add a test for alpha equal to one. */ sa = 1.f; for (i__ = 1; i__ <= 5; ++i__) { i__1 = i__ - 1; i__2 = i__ - 1; mwpct[i__1].r = cx[i__2].r, mwpct[i__1].i = cx[i__2].i; i__1 = i__ - 1; i__2 = i__ - 1; mwpcs[i__1].r = cx[i__2].r, mwpcs[i__1].i = cx[i__2].i; /* L120: */ } csscal_(&c__5, &sa, cx, &combla_1.incx); ctest_(&c__5, cx, mwpct, mwpcs, sfac); /* Add a test for alpha equal to minus one. */ sa = -1.f; for (i__ = 1; i__ <= 5; ++i__) { i__1 = i__ - 1; i__2 = i__ - 1; q__1.r = -cx[i__2].r, q__1.i = -cx[i__2].i; mwpct[i__1].r = q__1.r, mwpct[i__1].i = q__1.i; i__1 = i__ - 1; i__2 = i__ - 1; q__1.r = -cx[i__2].r, q__1.i = -cx[i__2].i; mwpcs[i__1].r = q__1.r, mwpcs[i__1].i = q__1.i; /* L140: */ } csscal_(&c__5, &sa, cx, &combla_1.incx); ctest_(&c__5, cx, mwpct, mwpcs, sfac); } return 0; } /* check1_ */ /* Subroutine */ int check2_(real *sfac) { /* Initialized data */ static complex ca = {.4f,-.7f}; static integer incxs[4] = { 1,2,-2,-1 }; static integer incys[4] = { 1,-2,1,-2 }; static integer lens[8] /* was [4][2] */ = { 1,1,2,4,1,1,3,7 }; static integer ns[4] = { 0,1,2,4 }; static complex cx1[7] = { {.7f,-.8f},{-.4f,-.7f},{-.1f,-.9f},{.2f,-.8f},{ -.9f,-.4f},{.1f,.4f},{-.6f,.6f} }; static complex cy1[7] = { {.6f,-.6f},{-.9f,.5f},{.7f,-.6f},{.1f,-.5f},{ -.1f,-.2f},{-.5f,-.3f},{.8f,-.7f} }; static complex ct8[112] /* was [7][4][4] */ = { {.6f,-.6f},{0.f,0.f},{ 0.f,0.f},{0.f,0.f},{0.f,0.f},{0.f,0.f},{0.f,0.f},{.32f,-1.41f},{ 0.f,0.f},{0.f,0.f},{0.f,0.f},{0.f,0.f},{0.f,0.f},{0.f,0.f},{.32f, -1.41f},{-1.55f,.5f},{0.f,0.f},{0.f,0.f},{0.f,0.f},{0.f,0.f},{0.f, 0.f},{.32f,-1.41f},{-1.55f,.5f},{.03f,-.89f},{-.38f,-.96f},{0.f, 0.f},{0.f,0.f},{0.f,0.f},{.6f,-.6f},{0.f,0.f},{0.f,0.f},{0.f,0.f}, {0.f,0.f},{0.f,0.f},{0.f,0.f},{.32f,-1.41f},{0.f,0.f},{0.f,0.f},{ 0.f,0.f},{0.f,0.f},{0.f,0.f},{0.f,0.f},{-.07f,-.89f},{-.9f,.5f},{ .42f,-1.41f},{0.f,0.f},{0.f,0.f},{0.f,0.f},{0.f,0.f},{.78f,.06f},{ -.9f,.5f},{.06f,-.13f},{.1f,-.5f},{-.77f,-.49f},{-.5f,-.3f},{.52f, -1.51f},{.6f,-.6f},{0.f,0.f},{0.f,0.f},{0.f,0.f},{0.f,0.f},{0.f, 0.f},{0.f,0.f},{.32f,-1.41f},{0.f,0.f},{0.f,0.f},{0.f,0.f},{0.f, 0.f},{0.f,0.f},{0.f,0.f},{-.07f,-.89f},{-1.18f,-.31f},{0.f,0.f},{ 0.f,0.f},{0.f,0.f},{0.f,0.f},{0.f,0.f},{.78f,.06f},{-1.54f,.97f},{ .03f,-.89f},{-.18f,-1.31f},{0.f,0.f},{0.f,0.f},{0.f,0.f},{.6f, -.6f},{0.f,0.f},{0.f,0.f},{0.f,0.f},{0.f,0.f},{0.f,0.f},{0.f,0.f}, {.32f,-1.41f},{0.f,0.f},{0.f,0.f},{0.f,0.f},{0.f,0.f},{0.f,0.f},{ 0.f,0.f},{.32f,-1.41f},{-.9f,.5f},{.05f,-.6f},{0.f,0.f},{0.f,0.f}, {0.f,0.f},{0.f,0.f},{.32f,-1.41f},{-.9f,.5f},{.05f,-.6f},{.1f, -.5f},{-.77f,-.49f},{-.5f,-.3f},{.32f,-1.16f} }; static complex ct7[16] /* was [4][4] */ = { {0.f,0.f},{-.06f,-.9f},{ .65f,-.47f},{-.34f,-1.22f},{0.f,0.f},{-.06f,-.9f},{-.59f,-1.46f},{ -1.04f,-.04f},{0.f,0.f},{-.06f,-.9f},{-.83f,.59f},{.07f,-.37f},{ 0.f,0.f},{-.06f,-.9f},{-.76f,-1.15f},{-1.33f,-1.82f} }; static complex ct6[16] /* was [4][4] */ = { {0.f,0.f},{.9f,.06f},{ .91f,-.77f},{1.8f,-.1f},{0.f,0.f},{.9f,.06f},{1.45f,.74f},{.2f, .9f},{0.f,0.f},{.9f,.06f},{-.55f,.23f},{.83f,-.39f},{0.f,0.f},{ .9f,.06f},{1.04f,.79f},{1.95f,1.22f} }; static complex ct10x[112] /* was [7][4][4] */ = { {.7f,-.8f},{0.f,0.f},{ 0.f,0.f},{0.f,0.f},{0.f,0.f},{0.f,0.f},{0.f,0.f},{.6f,-.6f},{0.f, 0.f},{0.f,0.f},{0.f,0.f},{0.f,0.f},{0.f,0.f},{0.f,0.f},{.6f,-.6f}, {-.9f,.5f},{0.f,0.f},{0.f,0.f},{0.f,0.f},{0.f,0.f},{0.f,0.f},{.6f, -.6f},{-.9f,.5f},{.7f,-.6f},{.1f,-.5f},{0.f,0.f},{0.f,0.f},{0.f, 0.f},{.7f,-.8f},{0.f,0.f},{0.f,0.f},{0.f,0.f},{0.f,0.f},{0.f,0.f}, {0.f,0.f},{.6f,-.6f},{0.f,0.f},{0.f,0.f},{0.f,0.f},{0.f,0.f},{0.f, 0.f},{0.f,0.f},{.7f,-.6f},{-.4f,-.7f},{.6f,-.6f},{0.f,0.f},{0.f, 0.f},{0.f,0.f},{0.f,0.f},{.8f,-.7f},{-.4f,-.7f},{-.1f,-.2f},{.2f, -.8f},{.7f,-.6f},{.1f,.4f},{.6f,-.6f},{.7f,-.8f},{0.f,0.f},{0.f, 0.f},{0.f,0.f},{0.f,0.f},{0.f,0.f},{0.f,0.f},{.6f,-.6f},{0.f,0.f}, {0.f,0.f},{0.f,0.f},{0.f,0.f},{0.f,0.f},{0.f,0.f},{-.9f,.5f},{ -.4f,-.7f},{.6f,-.6f},{0.f,0.f},{0.f,0.f},{0.f,0.f},{0.f,0.f},{ .1f,-.5f},{-.4f,-.7f},{.7f,-.6f},{.2f,-.8f},{-.9f,.5f},{.1f,.4f},{ .6f,-.6f},{.7f,-.8f},{0.f,0.f},{0.f,0.f},{0.f,0.f},{0.f,0.f},{0.f, 0.f},{0.f,0.f},{.6f,-.6f},{0.f,0.f},{0.f,0.f},{0.f,0.f},{0.f,0.f}, {0.f,0.f},{0.f,0.f},{.6f,-.6f},{.7f,-.6f},{0.f,0.f},{0.f,0.f},{ 0.f,0.f},{0.f,0.f},{0.f,0.f},{.6f,-.6f},{.7f,-.6f},{-.1f,-.2f},{ .8f,-.7f},{0.f,0.f},{0.f,0.f},{0.f,0.f} }; static complex ct10y[112] /* was [7][4][4] */ = { {.6f,-.6f},{0.f,0.f},{ 0.f,0.f},{0.f,0.f},{0.f,0.f},{0.f,0.f},{0.f,0.f},{.7f,-.8f},{0.f, 0.f},{0.f,0.f},{0.f,0.f},{0.f,0.f},{0.f,0.f},{0.f,0.f},{.7f,-.8f}, {-.4f,-.7f},{0.f,0.f},{0.f,0.f},{0.f,0.f},{0.f,0.f},{0.f,0.f},{ .7f,-.8f},{-.4f,-.7f},{-.1f,-.9f},{.2f,-.8f},{0.f,0.f},{0.f,0.f},{ 0.f,0.f},{.6f,-.6f},{0.f,0.f},{0.f,0.f},{0.f,0.f},{0.f,0.f},{0.f, 0.f},{0.f,0.f},{.7f,-.8f},{0.f,0.f},{0.f,0.f},{0.f,0.f},{0.f,0.f}, {0.f,0.f},{0.f,0.f},{-.1f,-.9f},{-.9f,.5f},{.7f,-.8f},{0.f,0.f},{ 0.f,0.f},{0.f,0.f},{0.f,0.f},{-.6f,.6f},{-.9f,.5f},{-.9f,-.4f},{ .1f,-.5f},{-.1f,-.9f},{-.5f,-.3f},{.7f,-.8f},{.6f,-.6f},{0.f,0.f}, {0.f,0.f},{0.f,0.f},{0.f,0.f},{0.f,0.f},{0.f,0.f},{.7f,-.8f},{0.f, 0.f},{0.f,0.f},{0.f,0.f},{0.f,0.f},{0.f,0.f},{0.f,0.f},{-.1f,-.9f} ,{.7f,-.8f},{0.f,0.f},{0.f,0.f},{0.f,0.f},{0.f,0.f},{0.f,0.f},{ -.6f,.6f},{-.9f,-.4f},{-.1f,-.9f},{.7f,-.8f},{0.f,0.f},{0.f,0.f},{ 0.f,0.f},{.6f,-.6f},{0.f,0.f},{0.f,0.f},{0.f,0.f},{0.f,0.f},{0.f, 0.f},{0.f,0.f},{.7f,-.8f},{0.f,0.f},{0.f,0.f},{0.f,0.f},{0.f,0.f}, {0.f,0.f},{0.f,0.f},{.7f,-.8f},{-.9f,.5f},{-.4f,-.7f},{0.f,0.f},{ 0.f,0.f},{0.f,0.f},{0.f,0.f},{.7f,-.8f},{-.9f,.5f},{-.4f,-.7f},{ .1f,-.5f},{-.1f,-.9f},{-.5f,-.3f},{.2f,-.8f} }; static complex csize1[4] = { {0.f,0.f},{.9f,.9f},{1.63f,1.73f},{2.9f, 2.78f} }; static complex csize3[14] = { {0.f,0.f},{0.f,0.f},{0.f,0.f},{0.f,0.f},{ 0.f,0.f},{0.f,0.f},{0.f,0.f},{1.17f,1.17f},{1.17f,1.17f},{1.17f, 1.17f},{1.17f,1.17f},{1.17f,1.17f},{1.17f,1.17f},{1.17f,1.17f} }; static complex csize2[14] /* was [7][2] */ = { {0.f,0.f},{0.f,0.f},{0.f, 0.f},{0.f,0.f},{0.f,0.f},{0.f,0.f},{0.f,0.f},{1.54f,1.54f},{1.54f, 1.54f},{1.54f,1.54f},{1.54f,1.54f},{1.54f,1.54f},{1.54f,1.54f},{ 1.54f,1.54f} }; /* System generated locals */ integer i__1, i__2; complex q__1; /* Builtin functions */ integer s_wsle(cilist *), do_lio(integer *, integer *, char *, ftnlen), e_wsle(void); /* Subroutine */ int s_stop(char *, ftnlen); /* Local variables */ integer i__, ki, kn; complex cx[7], cy[7]; integer mx, my; complex cdot[1]; integer lenx, leny; extern /* Complex */ VOID cdotc_(complex *, integer *, complex *, integer *, complex *, integer *); extern /* Subroutine */ int ccopy_(integer *, complex *, integer *, complex *, integer *); extern /* Complex */ VOID cdotu_(complex *, integer *, complex *, integer *, complex *, integer *); extern /* Subroutine */ int cswap_(integer *, complex *, integer *, complex *, integer *), ctest_(integer *, complex *, complex *, complex *, real *); integer ksize; extern /* Subroutine */ int caxpy_(integer *, complex *, complex *, integer *, complex *, integer *); /* Fortran I/O blocks */ static cilist io___48 = { 0, 6, 0, 0, 0 }; /* .. Parameters .. */ /* .. Scalar Arguments .. */ /* .. Scalars in Common .. */ /* .. Local Scalars .. */ /* .. Local Arrays .. */ /* .. External Functions .. */ /* .. External Subroutines .. */ /* .. Intrinsic Functions .. */ /* .. Common blocks .. */ /* .. Data statements .. */ /* .. Executable Statements .. */ for (ki = 1; ki <= 4; ++ki) { combla_1.incx = incxs[ki - 1]; combla_1.incy = incys[ki - 1]; mx = abs(combla_1.incx); my = abs(combla_1.incy); for (kn = 1; kn <= 4; ++kn) { combla_1.n = ns[kn - 1]; ksize = min(2,kn); lenx = lens[kn + (mx << 2) - 5]; leny = lens[kn + (my << 2) - 5]; /* .. initialize all argument arrays .. */ for (i__ = 1; i__ <= 7; ++i__) { i__1 = i__ - 1; i__2 = i__ - 1; cx[i__1].r = cx1[i__2].r, cx[i__1].i = cx1[i__2].i; i__1 = i__ - 1; i__2 = i__ - 1; cy[i__1].r = cy1[i__2].r, cy[i__1].i = cy1[i__2].i; /* L20: */ } if (combla_1.icase == 1) { /* .. CDOTC .. */ cdotc_(&q__1, &combla_1.n, cx, &combla_1.incx, cy, & combla_1.incy); cdot[0].r = q__1.r, cdot[0].i = q__1.i; ctest_(&c__1, cdot, &ct6[kn + (ki << 2) - 5], &csize1[kn - 1], sfac); } else if (combla_1.icase == 2) { /* .. CDOTU .. */ cdotu_(&q__1, &combla_1.n, cx, &combla_1.incx, cy, & combla_1.incy); cdot[0].r = q__1.r, cdot[0].i = q__1.i; ctest_(&c__1, cdot, &ct7[kn + (ki << 2) - 5], &csize1[kn - 1], sfac); } else if (combla_1.icase == 3) { /* .. CAXPY .. */ caxpy_(&combla_1.n, &ca, cx, &combla_1.incx, cy, & combla_1.incy); ctest_(&leny, cy, &ct8[(kn + (ki << 2)) * 7 - 35], &csize2[ ksize * 7 - 7], sfac); } else if (combla_1.icase == 4) { /* .. CCOPY .. */ ccopy_(&combla_1.n, cx, &combla_1.incx, cy, &combla_1.incy); ctest_(&leny, cy, &ct10y[(kn + (ki << 2)) * 7 - 35], csize3, & c_b43); } else if (combla_1.icase == 5) { /* .. CSWAP .. */ cswap_(&combla_1.n, cx, &combla_1.incx, cy, &combla_1.incy); ctest_(&lenx, cx, &ct10x[(kn + (ki << 2)) * 7 - 35], csize3, & c_b43); ctest_(&leny, cy, &ct10y[(kn + (ki << 2)) * 7 - 35], csize3, & c_b43); } else { s_wsle(&io___48); do_lio(&c__9, &c__1, " Shouldn't be here in CHECK2", (ftnlen) 28); e_wsle(); s_stop("", (ftnlen)0); } /* L40: */ } /* L60: */ } return 0; } /* check2_ */ /* Subroutine */ int stest_(integer *len, real *scomp, real *strue, real * ssize, real *sfac) { /* Format strings */ static char fmt_99999[] = "(\002 F" "AIL\002)"; static char fmt_99998[] = "(/\002 CASE N INCX INCY MODE I " " \002,\002 COMP(I) TRU" "E(I) DIFFERENCE\002,\002 SIZE(I)\002,/1x)"; static char fmt_99997[] = "(1x,i4,i3,3i5,i3,2e36.8,2e12.4)"; /* System generated locals */ integer i__1; real r__1, r__2, r__3, r__4, r__5; /* Builtin functions */ integer s_wsfe(cilist *), e_wsfe(void), do_fio(integer *, char *, ftnlen); /* Local variables */ integer i__; real sd; extern doublereal sdiff_(real *, real *); /* Fortran I/O blocks */ static cilist io___51 = { 0, 6, 0, fmt_99999, 0 }; static cilist io___52 = { 0, 6, 0, fmt_99998, 0 }; static cilist io___53 = { 0, 6, 0, fmt_99997, 0 }; /* ********************************* STEST ************************** */ /* THIS SUBR COMPARES ARRAYS SCOMP() AND STRUE() OF LENGTH LEN TO */ /* SEE IF THE TERM BY TERM DIFFERENCES, MULTIPLIED BY SFAC, ARE */ /* NEGLIGIBLE. */ /* C. L. LAWSON, JPL, 1974 DEC 10 */ /* .. Parameters .. */ /* .. Scalar Arguments .. */ /* .. Array Arguments .. */ /* .. Scalars in Common .. */ /* .. Local Scalars .. */ /* .. External Functions .. */ /* .. Intrinsic Functions .. */ /* .. Common blocks .. */ /* .. Executable Statements .. */ /* Parameter adjustments */ --ssize; --strue; --scomp; /* Function Body */ i__1 = *len; for (i__ = 1; i__ <= i__1; ++i__) { sd = scomp[i__] - strue[i__]; r__4 = (r__1 = ssize[i__], dabs(r__1)) + (r__2 = *sfac * sd, dabs( r__2)); r__5 = (r__3 = ssize[i__], dabs(r__3)); if (sdiff_(&r__4, &r__5) == 0.f) { goto L40; } /* HERE SCOMP(I) IS NOT CLOSE TO STRUE(I). */ if (! combla_1.pass) { goto L20; } /* PRINT FAIL MESSAGE AND HEADER. */ combla_1.pass = FALSE_; s_wsfe(&io___51); e_wsfe(); s_wsfe(&io___52); e_wsfe(); L20: s_wsfe(&io___53); do_fio(&c__1, (char *)&combla_1.icase, (ftnlen)sizeof(integer)); do_fio(&c__1, (char *)&combla_1.n, (ftnlen)sizeof(integer)); do_fio(&c__1, (char *)&combla_1.incx, (ftnlen)sizeof(integer)); do_fio(&c__1, (char *)&combla_1.incy, (ftnlen)sizeof(integer)); do_fio(&c__1, (char *)&combla_1.mode, (ftnlen)sizeof(integer)); do_fio(&c__1, (char *)&i__, (ftnlen)sizeof(integer)); do_fio(&c__1, (char *)&scomp[i__], (ftnlen)sizeof(real)); do_fio(&c__1, (char *)&strue[i__], (ftnlen)sizeof(real)); do_fio(&c__1, (char *)&sd, (ftnlen)sizeof(real)); do_fio(&c__1, (char *)&ssize[i__], (ftnlen)sizeof(real)); e_wsfe(); L40: ; } return 0; } /* stest_ */ /* Subroutine */ int stest1_(real *scomp1, real *strue1, real *ssize, real * sfac) { real scomp[1], strue[1]; extern /* Subroutine */ int stest_(integer *, real *, real *, real *, real *); /* ************************* STEST1 ***************************** */ /* THIS IS AN INTERFACE SUBROUTINE TO ACCOMODATE THE FORTRAN */ /* REQUIREMENT THAT WHEN A DUMMY ARGUMENT IS AN ARRAY, THE */ /* ACTUAL ARGUMENT MUST ALSO BE AN ARRAY OR AN ARRAY ELEMENT. */ /* C.L. LAWSON, JPL, 1978 DEC 6 */ /* .. Scalar Arguments .. */ /* .. Array Arguments .. */ /* .. Local Arrays .. */ /* .. External Subroutines .. */ /* .. Executable Statements .. */ /* Parameter adjustments */ --ssize; /* Function Body */ scomp[0] = *scomp1; strue[0] = *strue1; stest_(&c__1, scomp, strue, &ssize[1], sfac); return 0; } /* stest1_ */ doublereal sdiff_(real *sa, real *sb) { /* System generated locals */ real ret_val; /* ********************************* SDIFF ************************** */ /* COMPUTES DIFFERENCE OF TWO NUMBERS. C. L. LAWSON, JPL 1974 FEB 15 */ /* .. Scalar Arguments .. */ /* .. Executable Statements .. */ ret_val = *sa - *sb; return ret_val; } /* sdiff_ */ /* Subroutine */ int ctest_(integer *len, complex *ccomp, complex *ctrue, complex *csize, real *sfac) { /* System generated locals */ integer i__1, i__2; /* Builtin functions */ double r_imag(complex *); /* Local variables */ integer i__; real scomp[20], ssize[20], strue[20]; extern /* Subroutine */ int stest_(integer *, real *, real *, real *, real *); /* **************************** CTEST ***************************** */ /* C.L. LAWSON, JPL, 1978 DEC 6 */ /* .. Scalar Arguments .. */ /* .. Array Arguments .. */ /* .. Local Scalars .. */ /* .. Local Arrays .. */ /* .. External Subroutines .. */ /* .. Intrinsic Functions .. */ /* .. Executable Statements .. */ /* Parameter adjustments */ --csize; --ctrue; --ccomp; /* Function Body */ i__1 = *len; for (i__ = 1; i__ <= i__1; ++i__) { i__2 = i__; scomp[(i__ << 1) - 2] = ccomp[i__2].r; scomp[(i__ << 1) - 1] = r_imag(&ccomp[i__]); i__2 = i__; strue[(i__ << 1) - 2] = ctrue[i__2].r; strue[(i__ << 1) - 1] = r_imag(&ctrue[i__]); i__2 = i__; ssize[(i__ << 1) - 2] = csize[i__2].r; ssize[(i__ << 1) - 1] = r_imag(&csize[i__]); /* L20: */ } i__1 = *len << 1; stest_(&i__1, scomp, strue, ssize, sfac); return 0; } /* ctest_ */ /* Subroutine */ int itest1_(integer *icomp, integer *itrue) { /* Format strings */ static char fmt_99999[] = "(\002 F" "AIL\002)"; static char fmt_99998[] = "(/\002 CASE N INCX INCY MODE " " \002,\002 COMP TRU" "E DIFFERENCE\002,/1x)"; static char fmt_99997[] = "(1x,i4,i3,3i5,2i36,i12)"; /* Builtin functions */ integer s_wsfe(cilist *), e_wsfe(void), do_fio(integer *, char *, ftnlen); /* Local variables */ integer id; /* Fortran I/O blocks */ static cilist io___60 = { 0, 6, 0, fmt_99999, 0 }; static cilist io___61 = { 0, 6, 0, fmt_99998, 0 }; static cilist io___63 = { 0, 6, 0, fmt_99997, 0 }; /* ********************************* ITEST1 ************************* */ /* THIS SUBROUTINE COMPARES THE VARIABLES ICOMP AND ITRUE FOR */ /* EQUALITY. */ /* C. L. LAWSON, JPL, 1974 DEC 10 */ /* .. Parameters .. */ /* .. Scalar Arguments .. */ /* .. Scalars in Common .. */ /* .. Local Scalars .. */ /* .. Common blocks .. */ /* .. Executable Statements .. */ if (*icomp == *itrue) { goto L40; } /* HERE ICOMP IS NOT EQUAL TO ITRUE. */ if (! combla_1.pass) { goto L20; } /* PRINT FAIL MESSAGE AND HEADER. */ combla_1.pass = FALSE_; s_wsfe(&io___60); e_wsfe(); s_wsfe(&io___61); e_wsfe(); L20: id = *icomp - *itrue; s_wsfe(&io___63); do_fio(&c__1, (char *)&combla_1.icase, (ftnlen)sizeof(integer)); do_fio(&c__1, (char *)&combla_1.n, (ftnlen)sizeof(integer)); do_fio(&c__1, (char *)&combla_1.incx, (ftnlen)sizeof(integer)); do_fio(&c__1, (char *)&combla_1.incy, (ftnlen)sizeof(integer)); do_fio(&c__1, (char *)&combla_1.mode, (ftnlen)sizeof(integer)); do_fio(&c__1, (char *)&(*icomp), (ftnlen)sizeof(integer)); do_fio(&c__1, (char *)&(*itrue), (ftnlen)sizeof(integer)); do_fio(&c__1, (char *)&id, (ftnlen)sizeof(integer)); e_wsfe(); L40: return 0; } /* itest1_ */ /* Main program alias */ int cblat1_ () { MAIN__ (); return 0; }