diff --git a/frame/compat/bla_rot.c b/frame/compat/attic/bla_rot.c similarity index 100% rename from frame/compat/bla_rot.c rename to frame/compat/attic/bla_rot.c diff --git a/frame/compat/bla_rot.h b/frame/compat/attic/bla_rot.h similarity index 100% rename from frame/compat/bla_rot.h rename to frame/compat/attic/bla_rot.h diff --git a/frame/compat/bla_rotg.c b/frame/compat/attic/bla_rotg.c similarity index 100% rename from frame/compat/bla_rotg.c rename to frame/compat/attic/bla_rotg.c diff --git a/frame/compat/bla_rotg.h b/frame/compat/attic/bla_rotg.h similarity index 100% rename from frame/compat/bla_rotg.h rename to frame/compat/attic/bla_rotg.h diff --git a/frame/compat/bla_rotm.c b/frame/compat/attic/bla_rotm.c similarity index 100% rename from frame/compat/bla_rotm.c rename to frame/compat/attic/bla_rotm.c diff --git a/frame/compat/bla_rotm.h b/frame/compat/attic/bla_rotm.h similarity index 100% rename from frame/compat/bla_rotm.h rename to frame/compat/attic/bla_rotm.h diff --git a/frame/compat/bla_rotmg.c b/frame/compat/attic/bla_rotmg.c similarity index 100% rename from frame/compat/bla_rotmg.c rename to frame/compat/attic/bla_rotmg.c diff --git a/frame/compat/bla_rotmg.h b/frame/compat/attic/bla_rotmg.h similarity index 100% rename from frame/compat/bla_rotmg.h rename to frame/compat/attic/bla_rotmg.h diff --git a/frame/compat/bli_blas.h b/frame/compat/bli_blas.h index 4934eea05..72c0161b8 100644 --- a/frame/compat/bli_blas.h +++ b/frame/compat/bli_blas.h @@ -40,10 +40,10 @@ #include "bla_copy.h" #include "bla_dot.h" #include "bla_nrm2.h" -#include "bla_rot.h" -#include "bla_rotg.h" -#include "bla_rotm.h" -#include "bla_rotmg.h" +//#include "bla_rot.h" +//#include "bla_rotg.h" +//#include "bla_rotm.h" +//#include "bla_rotmg.h" #include "bla_scal.h" #include "bla_swap.h" diff --git a/frame/compat/f2c/bla_rot.c b/frame/compat/f2c/bla_rot.c new file mode 100644 index 000000000..890be1c38 --- /dev/null +++ b/frame/compat/f2c/bla_rot.c @@ -0,0 +1,368 @@ +/* + + BLIS + An object-based framework for developing high-performance BLAS-like + libraries. + + Copyright (C) 2013, The University of Texas + + Redistribution and use in source and binary forms, with or without + modification, are permitted provided that the following conditions are + met: + - Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + - Redistributions in binary form must reproduce the above copyright + notice, this list of conditions and the following disclaimer in the + documentation and/or other materials provided with the distribution. + - Neither the name of The University of Texas nor the names of its + contributors may be used to endorse or promote products derived + from this software without specific prior written permission. + + THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS + "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT + LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR + A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT + HOLDER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, + SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT + LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, + DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY + THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT + (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE + OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. + +*/ + +#include "blis.h" + +#ifdef BLIS_ENABLE_BLAS2BLIS + +#include "bli_f2c.h" + +/* srot.f -- translated by f2c (version 19991025). + You must link the resulting object file with the libraries: + -lf2c -lm (in that order) +*/ + +/* Subroutine */ int PASTEF77(s,rot)(integer *n, real *sx, integer *incx, real *sy, + integer *incy, real *c__, real *s) +{ + /* System generated locals */ + integer i__1; + + /* Local variables */ + integer i__; + real stemp; + integer ix, iy; + + +/* applies a plane rotation. */ +/* jack dongarra, linpack, 3/11/78. */ +/* modified 12/3/93, array(1) declarations changed to array(*) */ + + + /* Parameter adjustments */ + --sy; + --sx; + + /* Function Body */ + if (*n <= 0) { + return 0; + } + if (*incx == 1 && *incy == 1) { + goto L20; + } + +/* code for unequal increments or equal increments not equal */ +/* to 1 */ + + ix = 1; + iy = 1; + if (*incx < 0) { + ix = (-(*n) + 1) * *incx + 1; + } + if (*incy < 0) { + iy = (-(*n) + 1) * *incy + 1; + } + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { + stemp = *c__ * sx[ix] + *s * sy[iy]; + sy[iy] = *c__ * sy[iy] - *s * sx[ix]; + sx[ix] = stemp; + ix += *incx; + iy += *incy; +/* L10: */ + } + return 0; + +/* code for both increments equal to 1 */ + +L20: + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { + stemp = *c__ * sx[i__] + *s * sy[i__]; + sy[i__] = *c__ * sy[i__] - *s * sx[i__]; + sx[i__] = stemp; +/* L30: */ + } + return 0; +} /* srot_ */ + +/* drot.f -- translated by f2c (version 19991025). + You must link the resulting object file with the libraries: + -lf2c -lm (in that order) +*/ + +/* Subroutine */ int PASTEF77(d,rot)(integer *n, doublereal *dx, integer *incx, + doublereal *dy, integer *incy, doublereal *c__, doublereal *s) +{ + /* System generated locals */ + integer i__1; + + /* Local variables */ + integer i__; + doublereal dtemp; + integer ix, iy; + + +/* applies a plane rotation. */ +/* jack dongarra, linpack, 3/11/78. */ +/* modified 12/3/93, array(1) declarations changed to array(*) */ + + + /* Parameter adjustments */ + --dy; + --dx; + + /* Function Body */ + if (*n <= 0) { + return 0; + } + if (*incx == 1 && *incy == 1) { + goto L20; + } + +/* code for unequal increments or equal increments not equal */ +/* to 1 */ + + ix = 1; + iy = 1; + if (*incx < 0) { + ix = (-(*n) + 1) * *incx + 1; + } + if (*incy < 0) { + iy = (-(*n) + 1) * *incy + 1; + } + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { + dtemp = *c__ * dx[ix] + *s * dy[iy]; + dy[iy] = *c__ * dy[iy] - *s * dx[ix]; + dx[ix] = dtemp; + ix += *incx; + iy += *incy; +/* L10: */ + } + return 0; + +/* code for both increments equal to 1 */ + +L20: + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { + dtemp = *c__ * dx[i__] + *s * dy[i__]; + dy[i__] = *c__ * dy[i__] - *s * dx[i__]; + dx[i__] = dtemp; +/* L30: */ + } + return 0; +} /* drot_ */ + +/* csrot.f -- translated by f2c (version 19991025). + You must link the resulting object file with the libraries: + -lf2c -lm (in that order) +*/ + +/* Subroutine */ int PASTEF77(cs,rot)(integer *n, singlecomplex *cx, integer *incx, singlecomplex * + cy, integer *incy, real *c__, real *s) +{ + /* System generated locals */ + integer i__1, i__2, i__3, i__4; + singlecomplex q__1, q__2, q__3; + + /* Local variables */ + integer i__; + singlecomplex ctemp; + integer ix, iy; + + +/* applies a plane rotation, where the cos and sin (c and s) are real */ +/* and the vectors cx and cy are complex. */ +/* jack dongarra, linpack, 3/11/78. */ + + + /* Parameter adjustments */ + --cy; + --cx; + + /* Function Body */ + if (*n <= 0) { + return 0; + } + if (*incx == 1 && *incy == 1) { + goto L20; + } + +/* code for unequal increments or equal increments not equal */ +/* to 1 */ + + ix = 1; + iy = 1; + if (*incx < 0) { + ix = (-(*n) + 1) * *incx + 1; + } + if (*incy < 0) { + iy = (-(*n) + 1) * *incy + 1; + } + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { + i__2 = ix; + q__2.real = *c__ * cx[i__2].real, q__2.imag = *c__ * cx[i__2].imag; + i__3 = iy; + q__3.real = *s * cy[i__3].real, q__3.imag = *s * cy[i__3].imag; + q__1.real = q__2.real + q__3.real, q__1.imag = q__2.imag + q__3.imag; + ctemp.real = q__1.real, ctemp.imag = q__1.imag; + i__2 = iy; + i__3 = iy; + q__2.real = *c__ * cy[i__3].real, q__2.imag = *c__ * cy[i__3].imag; + i__4 = ix; + q__3.real = *s * cx[i__4].real, q__3.imag = *s * cx[i__4].imag; + q__1.real = q__2.real - q__3.real, q__1.imag = q__2.imag - q__3.imag; + cy[i__2].real = q__1.real, cy[i__2].imag = q__1.imag; + i__2 = ix; + cx[i__2].real = ctemp.real, cx[i__2].imag = ctemp.imag; + ix += *incx; + iy += *incy; +/* L10: */ + } + return 0; + +/* code for both increments equal to 1 */ + +L20: + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { + i__2 = i__; + q__2.real = *c__ * cx[i__2].real, q__2.imag = *c__ * cx[i__2].imag; + i__3 = i__; + q__3.real = *s * cy[i__3].real, q__3.imag = *s * cy[i__3].imag; + q__1.real = q__2.real + q__3.real, q__1.imag = q__2.imag + q__3.imag; + ctemp.real = q__1.real, ctemp.imag = q__1.imag; + i__2 = i__; + i__3 = i__; + q__2.real = *c__ * cy[i__3].real, q__2.imag = *c__ * cy[i__3].imag; + i__4 = i__; + q__3.real = *s * cx[i__4].real, q__3.imag = *s * cx[i__4].imag; + q__1.real = q__2.real - q__3.real, q__1.imag = q__2.imag - q__3.imag; + cy[i__2].real = q__1.real, cy[i__2].imag = q__1.imag; + i__2 = i__; + cx[i__2].real = ctemp.real, cx[i__2].imag = ctemp.imag; +/* L30: */ + } + return 0; +} /* csrot_ */ + +/* zdrot.f -- translated by f2c (version 19991025). + You must link the resulting object file with the libraries: + -lf2c -lm (in that order) +*/ + +/* Subroutine */ int PASTEF77(zd,rot)(integer *n, doublecomplex *zx, integer *incx, + doublecomplex *zy, integer *incy, doublereal *c__, doublereal *s) +{ + /* System generated locals */ + integer i__1, i__2, i__3, i__4; + doublecomplex z__1, z__2, z__3; + + /* Local variables */ + integer i__; + doublecomplex ztemp; + integer ix, iy; + + +/* applies a plane rotation, where the cos and sin (c and s) are */ +/* double precision and the vectors zx and zy are double complex. */ +/* jack dongarra, linpack, 3/11/78. */ + + + /* Parameter adjustments */ + --zy; + --zx; + + /* Function Body */ + if (*n <= 0) { + return 0; + } + if (*incx == 1 && *incy == 1) { + goto L20; + } + +/* code for unequal increments or equal increments not equal */ +/* to 1 */ + + ix = 1; + iy = 1; + if (*incx < 0) { + ix = (-(*n) + 1) * *incx + 1; + } + if (*incy < 0) { + iy = (-(*n) + 1) * *incy + 1; + } + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { + i__2 = ix; + z__2.real = *c__ * zx[i__2].real, z__2.imag = *c__ * zx[i__2].imag; + i__3 = iy; + z__3.real = *s * zy[i__3].real, z__3.imag = *s * zy[i__3].imag; + z__1.real = z__2.real + z__3.real, z__1.imag = z__2.imag + z__3.imag; + ztemp.real = z__1.real, ztemp.imag = z__1.imag; + i__2 = iy; + i__3 = iy; + z__2.real = *c__ * zy[i__3].real, z__2.imag = *c__ * zy[i__3].imag; + i__4 = ix; + z__3.real = *s * zx[i__4].real, z__3.imag = *s * zx[i__4].imag; + z__1.real = z__2.real - z__3.real, z__1.imag = z__2.imag - z__3.imag; + zy[i__2].real = z__1.real, zy[i__2].imag = z__1.imag; + i__2 = ix; + zx[i__2].real = ztemp.real, zx[i__2].imag = ztemp.imag; + ix += *incx; + iy += *incy; +/* L10: */ + } + return 0; + +/* code for both increments equal to 1 */ + +L20: + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { + i__2 = i__; + z__2.real = *c__ * zx[i__2].real, z__2.imag = *c__ * zx[i__2].imag; + i__3 = i__; + z__3.real = *s * zy[i__3].real, z__3.imag = *s * zy[i__3].imag; + z__1.real = z__2.real + z__3.real, z__1.imag = z__2.imag + z__3.imag; + ztemp.real = z__1.real, ztemp.imag = z__1.imag; + i__2 = i__; + i__3 = i__; + z__2.real = *c__ * zy[i__3].real, z__2.imag = *c__ * zy[i__3].imag; + i__4 = i__; + z__3.real = *s * zx[i__4].real, z__3.imag = *s * zx[i__4].imag; + z__1.real = z__2.real - z__3.real, z__1.imag = z__2.imag - z__3.imag; + zy[i__2].real = z__1.real, zy[i__2].imag = z__1.imag; + i__2 = i__; + zx[i__2].real = ztemp.real, zx[i__2].imag = ztemp.imag; +/* L30: */ + } + return 0; +} /* zdrot_ */ + +#endif + diff --git a/frame/compat/f2c/bla_rotg.c b/frame/compat/f2c/bla_rotg.c new file mode 100644 index 000000000..b8b9d35d1 --- /dev/null +++ b/frame/compat/f2c/bla_rotg.c @@ -0,0 +1,270 @@ +/* + + BLIS + An object-based framework for developing high-performance BLAS-like + libraries. + + Copyright (C) 2013, The University of Texas + + Redistribution and use in source and binary forms, with or without + modification, are permitted provided that the following conditions are + met: + - Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + - Redistributions in binary form must reproduce the above copyright + notice, this list of conditions and the following disclaimer in the + documentation and/or other materials provided with the distribution. + - Neither the name of The University of Texas nor the names of its + contributors may be used to endorse or promote products derived + from this software without specific prior written permission. + + THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS + "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT + LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR + A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT + HOLDER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, + SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT + LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, + DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY + THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT + (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE + OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. + +*/ + +#include "blis.h" + +#ifdef BLIS_ENABLE_BLAS2BLIS + +#include "bli_f2c.h" + +/* srotg.f -- translated by f2c (version 19991025). + You must link the resulting object file with the libraries: + -lf2c -lm (in that order) +*/ + +/* Table of constant values */ + +static real sc_b4 = 1.f; + +/* Subroutine */ int PASTEF77(s,rotg)(real *sa, real *sb, real *c__, real *s) +{ + /* System generated locals */ + real r__1, r__2; + + /* Builtin functions */ + double sqrt(doublereal), r_sign(real *, real *); + + /* Local variables */ + real r__, scale, z__, roe; + + +/* construct givens plane rotation. */ +/* jack dongarra, linpack, 3/11/78. */ + + + roe = *sb; + if (abs(*sa) > abs(*sb)) { + roe = *sa; + } + scale = abs(*sa) + abs(*sb); + if (scale != 0.f) { + goto L10; + } + *c__ = 1.f; + *s = 0.f; + r__ = 0.f; + z__ = 0.f; + goto L20; +L10: +/* Computing 2nd power */ + r__1 = *sa / scale; +/* Computing 2nd power */ + r__2 = *sb / scale; + r__ = scale * sqrt(r__1 * r__1 + r__2 * r__2); + r__ = r_sign(&sc_b4, &roe) * r__; + *c__ = *sa / r__; + *s = *sb / r__; + z__ = 1.f; + if (abs(*sa) > abs(*sb)) { + z__ = *s; + } + if (abs(*sb) >= abs(*sa) && *c__ != 0.f) { + z__ = 1.f / *c__; + } +L20: + *sa = r__; + *sb = z__; + return 0; +} /* srotg_ */ + +/* drotg.f -- translated by f2c (version 19991025). + You must link the resulting object file with the libraries: + -lf2c -lm (in that order) +*/ + +/* Table of constant values */ + +static doublereal dc_b4 = 1.; + +/* Subroutine */ int PASTEF77(d,rotg)(doublereal *da, doublereal *db, doublereal *c__, + doublereal *s) +{ + /* System generated locals */ + doublereal d__1, d__2; + + /* Builtin functions */ + double sqrt(doublereal), d_sign(doublereal *, doublereal *); + + /* Local variables */ + doublereal r__, scale, z__, roe; + + +/* construct givens plane rotation. */ +/* jack dongarra, linpack, 3/11/78. */ + + + roe = *db; + if (abs(*da) > abs(*db)) { + roe = *da; + } + scale = abs(*da) + abs(*db); + if (scale != 0.) { + goto L10; + } + *c__ = 1.; + *s = 0.; + r__ = 0.; + z__ = 0.; + goto L20; +L10: +/* Computing 2nd power */ + d__1 = *da / scale; +/* Computing 2nd power */ + d__2 = *db / scale; + r__ = scale * sqrt(d__1 * d__1 + d__2 * d__2); + r__ = d_sign(&dc_b4, &roe) * r__; + *c__ = *da / r__; + *s = *db / r__; + z__ = 1.; + if (abs(*da) > abs(*db)) { + z__ = *s; + } + if (abs(*db) >= abs(*da) && *c__ != 0.) { + z__ = 1. / *c__; + } +L20: + *da = r__; + *db = z__; + return 0; +} /* drotg_ */ + +/* crotg.f -- translated by f2c (version 19991025). + You must link the resulting object file with the libraries: + -lf2c -lm (in that order) +*/ + +/* Subroutine */ int PASTEF77(c,rotg)(singlecomplex *ca, singlecomplex *cb, real *c__, singlecomplex *s) +{ + /* System generated locals */ + real r__1, r__2; + singlecomplex q__1, q__2, q__3; + + /* Builtin functions */ + double c_abs(singlecomplex *), sqrt(doublereal); + void r_cnjg(singlecomplex *, singlecomplex *); + + /* Local variables */ + real norm; + singlecomplex alpha; + real scale; + + if (c_abs(ca) != 0.f) { + goto L10; + } + *c__ = 0.f; + s->real = 1.f, s->imag = 0.f; + ca->real = cb->real, ca->imag = cb->imag; + goto L20; +L10: + scale = c_abs(ca) + c_abs(cb); + q__1.real = ca->real / scale, q__1.imag = ca->imag / scale; +/* Computing 2nd power */ + r__1 = c_abs(&q__1); + q__2.real = cb->real / scale, q__2.imag = cb->imag / scale; +/* Computing 2nd power */ + r__2 = c_abs(&q__2); + norm = scale * sqrt(r__1 * r__1 + r__2 * r__2); + r__1 = c_abs(ca); + q__1.real = ca->real / r__1, q__1.imag = ca->imag / r__1; + alpha.real = q__1.real, alpha.imag = q__1.imag; + *c__ = c_abs(ca) / norm; + r_cnjg(&q__3, cb); + q__2.real = alpha.real * q__3.real - alpha.imag * q__3.imag, q__2.imag = alpha.real * q__3.imag + + alpha.imag * q__3.real; + q__1.real = q__2.real / norm, q__1.imag = q__2.imag / norm; + s->real = q__1.real, s->imag = q__1.imag; + q__1.real = norm * alpha.real, q__1.imag = norm * alpha.imag; + ca->real = q__1.real, ca->imag = q__1.imag; +L20: + return 0; +} /* crotg_ */ + +/* zrotg.f -- translated by f2c (version 19991025). + You must link the resulting object file with the libraries: + -lf2c -lm (in that order) +*/ + +/* Subroutine */ int PASTEF77(z,rotg)(doublecomplex *ca, doublecomplex *cb, doublereal * + c__, doublecomplex *s) +{ + /* System generated locals */ + doublereal d__1, d__2; + doublecomplex z__1, z__2, z__3, z__4; + + /* Builtin functions */ + double z_abs(doublecomplex *); + void z_div(doublecomplex *, doublecomplex *, doublecomplex *); + double sqrt(doublereal); + void d_cnjg(doublecomplex *, doublecomplex *); + + /* Local variables */ + doublereal norm; + doublecomplex alpha; + doublereal scale; + + if (z_abs(ca) != 0.) { + goto L10; + } + *c__ = 0.; + s->real = 1., s->imag = 0.; + ca->real = cb->real, ca->imag = cb->imag; + goto L20; +L10: + scale = z_abs(ca) + z_abs(cb); + z__2.real = scale, z__2.imag = 0.; + z_div(&z__1, ca, &z__2); +/* Computing 2nd power */ + d__1 = z_abs(&z__1); + z__4.real = scale, z__4.imag = 0.; + z_div(&z__3, cb, &z__4); +/* Computing 2nd power */ + d__2 = z_abs(&z__3); + norm = scale * sqrt(d__1 * d__1 + d__2 * d__2); + d__1 = z_abs(ca); + z__1.real = ca->real / d__1, z__1.imag = ca->imag / d__1; + alpha.real = z__1.real, alpha.imag = z__1.imag; + *c__ = z_abs(ca) / norm; + d_cnjg(&z__3, cb); + z__2.real = alpha.real * z__3.real - alpha.imag * z__3.imag, z__2.imag = alpha.real * z__3.imag + + alpha.imag * z__3.real; + z__1.real = z__2.real / norm, z__1.imag = z__2.imag / norm; + s->real = z__1.real, s->imag = z__1.imag; + z__1.real = norm * alpha.real, z__1.imag = norm * alpha.imag; + ca->real = z__1.real, ca->imag = z__1.imag; +L20: + return 0; +} /* zrotg_ */ + +#endif + diff --git a/frame/compat/f2c/bla_rotm.c b/frame/compat/f2c/bla_rotm.c new file mode 100644 index 000000000..0fdd4c77e --- /dev/null +++ b/frame/compat/f2c/bla_rotm.c @@ -0,0 +1,376 @@ +/* + + BLIS + An object-based framework for developing high-performance BLAS-like + libraries. + + Copyright (C) 2013, The University of Texas + + Redistribution and use in source and binary forms, with or without + modification, are permitted provided that the following conditions are + met: + - Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + - Redistributions in binary form must reproduce the above copyright + notice, this list of conditions and the following disclaimer in the + documentation and/or other materials provided with the distribution. + - Neither the name of The University of Texas nor the names of its + contributors may be used to endorse or promote products derived + from this software without specific prior written permission. + + THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS + "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT + LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR + A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT + HOLDER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, + SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT + LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, + DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY + THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT + (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE + OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. + +*/ + +#include "blis.h" + +#ifdef BLIS_ENABLE_BLAS2BLIS + +#include "bli_f2c.h" + +/* srotm.f -- translated by f2c (version 19991025). + You must link the resulting object file with the libraries: + -lf2c -lm (in that order) +*/ + +/* Subroutine */ int PASTEF77(s,rotm)(integer *n, real *sx, integer *incx, real *sy, + integer *incy, real *sparam) +{ + /* Initialized data */ + + static real zero = 0.f; + static real two = 2.f; + + /* System generated locals */ + integer i__1, i__2; + + /* Local variables */ + integer i__; + real w, z__, sflag; + integer kx, ky, nsteps; + real sh11, sh12, sh21, sh22; + + +/* APPLY THE MODIFIED GIVENS TRANSFORMATION, H, TO THE 2 BY N MATRIX */ + +/* (SX**T) , WHERE **T INDICATES TRANSPOSE. THE ELEMENTS OF SX ARE IN */ +/* (DX**T) */ + +/* SX(LX+I*INCX), I = 0 TO N-1, WHERE LX = 1 IF INCX .GE. 0, ELSE */ +/* LX = (-INCX)*N, AND SIMILARLY FOR SY USING USING LY AND INCY. */ +/* WITH SPARAM(1)=SFLAG, H HAS ONE OF THE FOLLOWING FORMS.. */ + +/* SFLAG=-1.E0 SFLAG=0.E0 SFLAG=1.E0 SFLAG=-2.E0 */ + +/* (SH11 SH12) (1.E0 SH12) (SH11 1.E0) (1.E0 0.E0) */ +/* H=( ) ( ) ( ) ( ) */ +/* (SH21 SH22), (SH21 1.E0), (-1.E0 SH22), (0.E0 1.E0). */ +/* SEE SROTMG FOR A DESCRIPTION OF DATA STORAGE IN SPARAM. */ + + /* Parameter adjustments */ + --sparam; + --sy; + --sx; + + /* Function Body */ + + sflag = sparam[1]; + if (*n <= 0 || sflag + two == zero) { + goto L140; + } + if (! (*incx == *incy && *incx > 0)) { + goto L70; + } + + nsteps = *n * *incx; + if (sflag < 0.f) { + goto L50; + } else if (sflag == 0) { + goto L10; + } else { + goto L30; + } +L10: + sh12 = sparam[4]; + sh21 = sparam[3]; + i__1 = nsteps; + i__2 = *incx; + for (i__ = 1; i__2 < 0 ? i__ >= i__1 : i__ <= i__1; i__ += i__2) { + w = sx[i__]; + z__ = sy[i__]; + sx[i__] = w + z__ * sh12; + sy[i__] = w * sh21 + z__; +/* L20: */ + } + goto L140; +L30: + sh11 = sparam[2]; + sh22 = sparam[5]; + i__2 = nsteps; + i__1 = *incx; + for (i__ = 1; i__1 < 0 ? i__ >= i__2 : i__ <= i__2; i__ += i__1) { + w = sx[i__]; + z__ = sy[i__]; + sx[i__] = w * sh11 + z__; + sy[i__] = -w + sh22 * z__; +/* L40: */ + } + goto L140; +L50: + sh11 = sparam[2]; + sh12 = sparam[4]; + sh21 = sparam[3]; + sh22 = sparam[5]; + i__1 = nsteps; + i__2 = *incx; + for (i__ = 1; i__2 < 0 ? i__ >= i__1 : i__ <= i__1; i__ += i__2) { + w = sx[i__]; + z__ = sy[i__]; + sx[i__] = w * sh11 + z__ * sh12; + sy[i__] = w * sh21 + z__ * sh22; +/* L60: */ + } + goto L140; +L70: + kx = 1; + ky = 1; + if (*incx < 0) { + kx = (1 - *n) * *incx + 1; + } + if (*incy < 0) { + ky = (1 - *n) * *incy + 1; + } + + if (sflag < 0.f) { + goto L120; + } else if (sflag == 0) { + goto L80; + } else { + goto L100; + } +L80: + sh12 = sparam[4]; + sh21 = sparam[3]; + i__2 = *n; + for (i__ = 1; i__ <= i__2; ++i__) { + w = sx[kx]; + z__ = sy[ky]; + sx[kx] = w + z__ * sh12; + sy[ky] = w * sh21 + z__; + kx += *incx; + ky += *incy; +/* L90: */ + } + goto L140; +L100: + sh11 = sparam[2]; + sh22 = sparam[5]; + i__2 = *n; + for (i__ = 1; i__ <= i__2; ++i__) { + w = sx[kx]; + z__ = sy[ky]; + sx[kx] = w * sh11 + z__; + sy[ky] = -w + sh22 * z__; + kx += *incx; + ky += *incy; +/* L110: */ + } + goto L140; +L120: + sh11 = sparam[2]; + sh12 = sparam[4]; + sh21 = sparam[3]; + sh22 = sparam[5]; + i__2 = *n; + for (i__ = 1; i__ <= i__2; ++i__) { + w = sx[kx]; + z__ = sy[ky]; + sx[kx] = w * sh11 + z__ * sh12; + sy[ky] = w * sh21 + z__ * sh22; + kx += *incx; + ky += *incy; +/* L130: */ + } +L140: + return 0; +} /* srotm_ */ + +/* drotm.f -- translated by f2c (version 19991025). + You must link the resulting object file with the libraries: + -lf2c -lm (in that order) +*/ + +/* Subroutine */ int PASTEF77(d,rotm)(integer *n, doublereal *dx, integer *incx, + doublereal *dy, integer *incy, doublereal *dparam) +{ + /* Initialized data */ + + static doublereal zero = 0.; + static doublereal two = 2.; + + /* System generated locals */ + integer i__1, i__2; + + /* Local variables */ + integer i__; + doublereal dflag, w, z__; + integer kx, ky, nsteps; + doublereal dh11, dh12, dh22, dh21; + + +/* APPLY THE MODIFIED GIVENS TRANSFORMATION, H, TO THE 2 BY N MATRIX */ + +/* (DX**T) , WHERE **T INDICATES TRANSPOSE. THE ELEMENTS OF DX ARE IN */ +/* (DY**T) */ + +/* DX(LX+I*INCX), I = 0 TO N-1, WHERE LX = 1 IF INCX .GE. 0, ELSE */ +/* LX = (-INCX)*N, AND SIMILARLY FOR SY USING LY AND INCY. */ +/* WITH DPARAM(1)=DFLAG, H HAS ONE OF THE FOLLOWING FORMS.. */ + +/* DFLAG=-1.D0 DFLAG=0.D0 DFLAG=1.D0 DFLAG=-2.D0 */ + +/* (DH11 DH12) (1.D0 DH12) (DH11 1.D0) (1.D0 0.D0) */ +/* H=( ) ( ) ( ) ( ) */ +/* (DH21 DH22), (DH21 1.D0), (-1.D0 DH22), (0.D0 1.D0). */ +/* SEE DROTMG FOR A DESCRIPTION OF DATA STORAGE IN DPARAM. */ + + /* Parameter adjustments */ + --dparam; + --dy; + --dx; + + /* Function Body */ + + dflag = dparam[1]; + if (*n <= 0 || dflag + two == zero) { + goto L140; + } + if (! (*incx == *incy && *incx > 0)) { + goto L70; + } + + nsteps = *n * *incx; + if (dflag < 0.) { + goto L50; + } else if (dflag == 0) { + goto L10; + } else { + goto L30; + } +L10: + dh12 = dparam[4]; + dh21 = dparam[3]; + i__1 = nsteps; + i__2 = *incx; + for (i__ = 1; i__2 < 0 ? i__ >= i__1 : i__ <= i__1; i__ += i__2) { + w = dx[i__]; + z__ = dy[i__]; + dx[i__] = w + z__ * dh12; + dy[i__] = w * dh21 + z__; +/* L20: */ + } + goto L140; +L30: + dh11 = dparam[2]; + dh22 = dparam[5]; + i__2 = nsteps; + i__1 = *incx; + for (i__ = 1; i__1 < 0 ? i__ >= i__2 : i__ <= i__2; i__ += i__1) { + w = dx[i__]; + z__ = dy[i__]; + dx[i__] = w * dh11 + z__; + dy[i__] = -w + dh22 * z__; +/* L40: */ + } + goto L140; +L50: + dh11 = dparam[2]; + dh12 = dparam[4]; + dh21 = dparam[3]; + dh22 = dparam[5]; + i__1 = nsteps; + i__2 = *incx; + for (i__ = 1; i__2 < 0 ? i__ >= i__1 : i__ <= i__1; i__ += i__2) { + w = dx[i__]; + z__ = dy[i__]; + dx[i__] = w * dh11 + z__ * dh12; + dy[i__] = w * dh21 + z__ * dh22; +/* L60: */ + } + goto L140; +L70: + kx = 1; + ky = 1; + if (*incx < 0) { + kx = (1 - *n) * *incx + 1; + } + if (*incy < 0) { + ky = (1 - *n) * *incy + 1; + } + + if (dflag < 0.) { + goto L120; + } else if (dflag == 0) { + goto L80; + } else { + goto L100; + } +L80: + dh12 = dparam[4]; + dh21 = dparam[3]; + i__2 = *n; + for (i__ = 1; i__ <= i__2; ++i__) { + w = dx[kx]; + z__ = dy[ky]; + dx[kx] = w + z__ * dh12; + dy[ky] = w * dh21 + z__; + kx += *incx; + ky += *incy; +/* L90: */ + } + goto L140; +L100: + dh11 = dparam[2]; + dh22 = dparam[5]; + i__2 = *n; + for (i__ = 1; i__ <= i__2; ++i__) { + w = dx[kx]; + z__ = dy[ky]; + dx[kx] = w * dh11 + z__; + dy[ky] = -w + dh22 * z__; + kx += *incx; + ky += *incy; +/* L110: */ + } + goto L140; +L120: + dh11 = dparam[2]; + dh12 = dparam[4]; + dh21 = dparam[3]; + dh22 = dparam[5]; + i__2 = *n; + for (i__ = 1; i__ <= i__2; ++i__) { + w = dx[kx]; + z__ = dy[ky]; + dx[kx] = w * dh11 + z__ * dh12; + dy[ky] = w * dh21 + z__ * dh22; + kx += *incx; + ky += *incy; +/* L130: */ + } +L140: + return 0; +} /* drotm_ */ + +#endif + diff --git a/frame/compat/f2c/bla_rotmg.c b/frame/compat/f2c/bla_rotmg.c new file mode 100644 index 000000000..4f2ca26de --- /dev/null +++ b/frame/compat/f2c/bla_rotmg.c @@ -0,0 +1,542 @@ +/* + + BLIS + An object-based framework for developing high-performance BLAS-like + libraries. + + Copyright (C) 2013, The University of Texas + + Redistribution and use in source and binary forms, with or without + modification, are permitted provided that the following conditions are + met: + - Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + - Redistributions in binary form must reproduce the above copyright + notice, this list of conditions and the following disclaimer in the + documentation and/or other materials provided with the distribution. + - Neither the name of The University of Texas nor the names of its + contributors may be used to endorse or promote products derived + from this software without specific prior written permission. + + THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS + "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT + LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR + A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT + HOLDER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, + SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT + LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, + DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY + THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT + (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE + OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. + +*/ + +#include "blis.h" + +#ifdef BLIS_ENABLE_BLAS2BLIS + +#include "bli_f2c.h" + +/* srotmg.f -- translated by f2c (version 19991025). + You must link the resulting object file with the libraries: + -lf2c -lm (in that order) +*/ + +/* Subroutine */ int PASTEF77(s,rotmg)(real *sd1, real *sd2, real *sx1, real *sy1, real + *sparam) +{ + /* Initialized data */ + + static real zero = 0.f; + static real one = 1.f; + static real two = 2.f; + static real gam = 4096.f; + static real gamsq = 16777200.f; + static real rgamsq = 5.96046e-8f; + + /* Format strings */ + static char fmt_120[] = ""; + static char fmt_150[] = ""; + static char fmt_180[] = ""; + static char fmt_210[] = ""; + + /* System generated locals */ + real r__1; + + /* Local variables */ + real sflag, stemp, su, sp1, sp2, sq2, sq1, + sh11 = 0.f, sh21 = 0.f, sh12 = 0.f, sh22 = 0.f; + integer igo; + + /* Assigned format variables */ + static char *igo_fmt; + + +/* CONSTRUCT THE MODIFIED GIVENS TRANSFORMATION MATRIX H WHICH ZEROS */ +/* THE SECOND COMPONENT OF THE 2-VECTOR (SQRT(SD1)*SX1,SQRT(SD2)* */ +/* SY2)**T. */ +/* WITH SPARAM(1)=SFLAG, H HAS ONE OF THE FOLLOWING FORMS.. */ + +/* SFLAG=-1.E0 SFLAG=0.E0 SFLAG=1.E0 SFLAG=-2.E0 */ + +/* (SH11 SH12) (1.E0 SH12) (SH11 1.E0) (1.E0 0.E0) */ +/* H=( ) ( ) ( ) ( ) */ +/* (SH21 SH22), (SH21 1.E0), (-1.E0 SH22), (0.E0 1.E0). */ +/* LOCATIONS 2-4 OF SPARAM CONTAIN SH11,SH21,SH12, AND SH22 */ +/* RESPECTIVELY. (VALUES OF 1.E0, -1.E0, OR 0.E0 IMPLIED BY THE */ +/* VALUE OF SPARAM(1) ARE NOT STORED IN SPARAM.) */ + +/* THE VALUES OF GAMSQ AND RGAMSQ SET IN THE DATA STATEMENT MAY BE */ +/* INEXACT. THIS IS OK AS THEY ARE ONLY USED FOR TESTING THE SIZE */ +/* OF SD1 AND SD2. ALL ACTUAL SCALING OF DATA IS DONE USING GAM. */ + + + /* Parameter adjustments */ + --sparam; + + /* Function Body */ + if (! (*sd1 < zero)) { + goto L10; + } +/* GO ZERO-H-D-AND-SX1.. */ + goto L60; +L10: +/* CASE-SD1-NONNEGATIVE */ + sp2 = *sd2 * *sy1; + if (! (sp2 == zero)) { + goto L20; + } + sflag = -two; + goto L260; +/* REGULAR-CASE.. */ +L20: + sp1 = *sd1 * *sx1; + sq2 = sp2 * *sy1; + sq1 = sp1 * *sx1; + + if (! (abs(sq1) > abs(sq2))) { + goto L40; + } + sh21 = -(*sy1) / *sx1; + sh12 = sp2 / sp1; + + su = one - sh12 * sh21; + + if (! (su <= zero)) { + goto L30; + } +/* GO ZERO-H-D-AND-SX1.. */ + goto L60; +L30: + sflag = zero; + *sd1 /= su; + *sd2 /= su; + *sx1 *= su; +/* GO SCALE-CHECK.. */ + goto L100; +L40: + if (! (sq2 < zero)) { + goto L50; + } +/* GO ZERO-H-D-AND-SX1.. */ + goto L60; +L50: + sflag = one; + sh11 = sp1 / sp2; + sh22 = *sx1 / *sy1; + su = one + sh11 * sh22; + stemp = *sd2 / su; + *sd2 = *sd1 / su; + *sd1 = stemp; + *sx1 = *sy1 * su; +/* GO SCALE-CHECK */ + goto L100; +/* PROCEDURE..ZERO-H-D-AND-SX1.. */ +L60: + sflag = -one; + sh11 = zero; + sh12 = zero; + sh21 = zero; + sh22 = zero; + + *sd1 = zero; + *sd2 = zero; + *sx1 = zero; +/* RETURN.. */ + goto L220; +/* PROCEDURE..FIX-H.. */ +L70: + if (! (sflag >= zero)) { + goto L90; + } + + if (! (sflag == zero)) { + goto L80; + } + sh11 = one; + sh22 = one; + sflag = -one; + goto L90; +L80: + sh21 = -one; + sh12 = one; + sflag = -one; +L90: + switch (igo) { + case 0: goto L120; + case 1: goto L150; + case 2: goto L180; + case 3: goto L210; + } +/* PROCEDURE..SCALE-CHECK */ +L100: +L110: + if (! (*sd1 <= rgamsq)) { + goto L130; + } + if (*sd1 == zero) { + goto L160; + } + igo = 0; + igo_fmt = fmt_120; +/* FIX-H.. */ + goto L70; +L120: +/* Computing 2nd power */ + r__1 = gam; + *sd1 *= r__1 * r__1; + *sx1 /= gam; + sh11 /= gam; + sh12 /= gam; + goto L110; +L130: +L140: + if (! (*sd1 >= gamsq)) { + goto L160; + } + igo = 1; + igo_fmt = fmt_150; +/* FIX-H.. */ + goto L70; +L150: +/* Computing 2nd power */ + r__1 = gam; + *sd1 /= r__1 * r__1; + *sx1 *= gam; + sh11 *= gam; + sh12 *= gam; + goto L140; +L160: +L170: + if (! (abs(*sd2) <= rgamsq)) { + goto L190; + } + if (*sd2 == zero) { + goto L220; + } + igo = 2; + igo_fmt = fmt_180; +/* FIX-H.. */ + goto L70; +L180: +/* Computing 2nd power */ + r__1 = gam; + *sd2 *= r__1 * r__1; + sh21 /= gam; + sh22 /= gam; + goto L170; +L190: +L200: + if (! (abs(*sd2) >= gamsq)) { + goto L220; + } + igo = 3; + igo_fmt = fmt_210; +/* FIX-H.. */ + goto L70; +L210: +/* Computing 2nd power */ + r__1 = gam; + *sd2 /= r__1 * r__1; + sh21 *= gam; + sh22 *= gam; + goto L200; +L220: + if (sflag < 0.f) { + goto L250; + } else if (sflag == 0) { + goto L230; + } else { + goto L240; + } +L230: + sparam[3] = sh21; + sparam[4] = sh12; + goto L260; +L240: + sparam[2] = sh11; + sparam[5] = sh22; + goto L260; +L250: + sparam[2] = sh11; + sparam[3] = sh21; + sparam[4] = sh12; + sparam[5] = sh22; +L260: + sparam[1] = sflag; + return 0; +} /* srotmg_ */ + +/* drotmg.f -- translated by f2c (version 19991025). + You must link the resulting object file with the libraries: + -lf2c -lm (in that order) +*/ + +/* Subroutine */ int PASTEF77(d,rotmg)(doublereal *dd1, doublereal *dd2, doublereal * + dx1, doublereal *dy1, doublereal *dparam) +{ + /* Initialized data */ + + static doublereal zero = 0.; + static doublereal one = 1.; + static doublereal two = 2.; + static doublereal gam = 4096.; + static doublereal gamsq = 16777216.; + static doublereal rgamsq = 5.9604645e-8; + + /* Format strings */ + static char fmt_120[] = ""; + static char fmt_150[] = ""; + static char fmt_180[] = ""; + static char fmt_210[] = ""; + + /* System generated locals */ + doublereal d__1; + + /* Local variables */ + doublereal dflag, dtemp, du, dp1, dp2, dq2, dq1, + dh11 = 0.f, dh21 = 0.f, dh12 = 0.f, dh22 = 0.f; + integer igo; + + /* Assigned format variables */ + static char *igo_fmt; + + +/* CONSTRUCT THE MODIFIED GIVENS TRANSFORMATION MATRIX H WHICH ZEROS */ +/* THE SECOND COMPONENT OF THE 2-VECTOR (DSQRT(DD1)*DX1,DSQRT(DD2)* */ +/* DY2)**T. */ +/* WITH DPARAM(1)=DFLAG, H HAS ONE OF THE FOLLOWING FORMS.. */ + +/* DFLAG=-1.D0 DFLAG=0.D0 DFLAG=1.D0 DFLAG=-2.D0 */ + +/* (DH11 DH12) (1.D0 DH12) (DH11 1.D0) (1.D0 0.D0) */ +/* H=( ) ( ) ( ) ( ) */ +/* (DH21 DH22), (DH21 1.D0), (-1.D0 DH22), (0.D0 1.D0). */ +/* LOCATIONS 2-4 OF DPARAM CONTAIN DH11, DH21, DH12, AND DH22 */ +/* RESPECTIVELY. (VALUES OF 1.D0, -1.D0, OR 0.D0 IMPLIED BY THE */ +/* VALUE OF DPARAM(1) ARE NOT STORED IN DPARAM.) */ + +/* THE VALUES OF GAMSQ AND RGAMSQ SET IN THE DATA STATEMENT MAY BE */ +/* INEXACT. THIS IS OK AS THEY ARE ONLY USED FOR TESTING THE SIZE */ +/* OF DD1 AND DD2. ALL ACTUAL SCALING OF DATA IS DONE USING GAM. */ + + + /* Parameter adjustments */ + --dparam; + + /* Function Body */ + if (! (*dd1 < zero)) { + goto L10; + } +/* GO ZERO-H-D-AND-DX1.. */ + goto L60; +L10: +/* CASE-DD1-NONNEGATIVE */ + dp2 = *dd2 * *dy1; + if (! (dp2 == zero)) { + goto L20; + } + dflag = -two; + goto L260; +/* REGULAR-CASE.. */ +L20: + dp1 = *dd1 * *dx1; + dq2 = dp2 * *dy1; + dq1 = dp1 * *dx1; + + if (! (abs(dq1) > abs(dq2))) { + goto L40; + } + dh21 = -(*dy1) / *dx1; + dh12 = dp2 / dp1; + + du = one - dh12 * dh21; + + if (! (du <= zero)) { + goto L30; + } +/* GO ZERO-H-D-AND-DX1.. */ + goto L60; +L30: + dflag = zero; + *dd1 /= du; + *dd2 /= du; + *dx1 *= du; +/* GO SCALE-CHECK.. */ + goto L100; +L40: + if (! (dq2 < zero)) { + goto L50; + } +/* GO ZERO-H-D-AND-DX1.. */ + goto L60; +L50: + dflag = one; + dh11 = dp1 / dp2; + dh22 = *dx1 / *dy1; + du = one + dh11 * dh22; + dtemp = *dd2 / du; + *dd2 = *dd1 / du; + *dd1 = dtemp; + *dx1 = *dy1 * du; +/* GO SCALE-CHECK */ + goto L100; +/* PROCEDURE..ZERO-H-D-AND-DX1.. */ +L60: + dflag = -one; + dh11 = zero; + dh12 = zero; + dh21 = zero; + dh22 = zero; + + *dd1 = zero; + *dd2 = zero; + *dx1 = zero; +/* RETURN.. */ + goto L220; +/* PROCEDURE..FIX-H.. */ +L70: + if (! (dflag >= zero)) { + goto L90; + } + + if (! (dflag == zero)) { + goto L80; + } + dh11 = one; + dh22 = one; + dflag = -one; + goto L90; +L80: + dh21 = -one; + dh12 = one; + dflag = -one; +L90: + switch (igo) { + case 0: goto L120; + case 1: goto L150; + case 2: goto L180; + case 3: goto L210; + } +/* PROCEDURE..SCALE-CHECK */ +L100: +L110: + if (! (*dd1 <= rgamsq)) { + goto L130; + } + if (*dd1 == zero) { + goto L160; + } + igo = 0; + igo_fmt = fmt_120; +/* FIX-H.. */ + goto L70; +L120: +/* Computing 2nd power */ + d__1 = gam; + *dd1 *= d__1 * d__1; + *dx1 /= gam; + dh11 /= gam; + dh12 /= gam; + goto L110; +L130: +L140: + if (! (*dd1 >= gamsq)) { + goto L160; + } + igo = 1; + igo_fmt = fmt_150; +/* FIX-H.. */ + goto L70; +L150: +/* Computing 2nd power */ + d__1 = gam; + *dd1 /= d__1 * d__1; + *dx1 *= gam; + dh11 *= gam; + dh12 *= gam; + goto L140; +L160: +L170: + if (! (abs(*dd2) <= rgamsq)) { + goto L190; + } + if (*dd2 == zero) { + goto L220; + } + igo = 2; + igo_fmt = fmt_180; +/* FIX-H.. */ + goto L70; +L180: +/* Computing 2nd power */ + d__1 = gam; + *dd2 *= d__1 * d__1; + dh21 /= gam; + dh22 /= gam; + goto L170; +L190: +L200: + if (! (abs(*dd2) >= gamsq)) { + goto L220; + } + igo = 3; + igo_fmt = fmt_210; +/* FIX-H.. */ + goto L70; +L210: +/* Computing 2nd power */ + d__1 = gam; + *dd2 /= d__1 * d__1; + dh21 *= gam; + dh22 *= gam; + goto L200; +L220: + if (dflag < 0.) { + goto L250; + } else if (dflag == 0) { + goto L230; + } else { + goto L240; + } +L230: + dparam[3] = dh21; + dparam[4] = dh12; + goto L260; +L240: + dparam[2] = dh11; + dparam[5] = dh22; + goto L260; +L250: + dparam[2] = dh11; + dparam[3] = dh21; + dparam[4] = dh12; + dparam[5] = dh22; +L260: + dparam[1] = dflag; + return 0; +} /* drotmg_ */ + +#endif +