blis/frame/compat/f2c/bla_rotg.c

   1 /*
   2
   3    BLIS
   4    An object-based framework for developing high-performance BLAS-like
   5    libraries.
   6
   7    Copyright (C) 2014, The University of Texas at Austin
   8
   9    Redistribution and use in source and binary forms, with or without
  10    modification, are permitted provided that the following conditions are
  11    met:
  12     - Redistributions of source code must retain the above copyright
  13       notice, this list of conditions and the following disclaimer.
  14     - Redistributions in binary form must reproduce the above copyright
  15       notice, this list of conditions and the following disclaimer in the
  16       documentation and/or other materials provided with the distribution.
  17     - Neither the name of The University of Texas at Austin nor the names
  18       of its contributors may be used to endorse or promote products
  19       derived from this software without specific prior written permission.
  20
  21    THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
  22    "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
  23    LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
  24    A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
  25    HOLDER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
  26    SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
  27    LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
  28    DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
  29    THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
  30    (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
  31    OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
  32
  33 */
  34
  35 #include "blis.h"
  36
  37 #ifdef BLIS_ENABLE_BLAS2BLIS
  38
  39 /* srotg.f -- translated by f2c (version 19991025).
  40    You must link the resulting object file with the libraries:
  41         -lf2c -lm   (in that order)
  42 */
  43
  44 /* Table of constant values */
  45
  46 static real sc_b4 = 1.f;
  47
  48 /* Subroutine */ int PASTEF77(s,rotg)(real *sa, real *sb, real *c__, real *s)
  49 {
  50     /* System generated locals */
  51     real r__1, r__2;
  52
  53     /* Builtin functions */
  54     double sqrt(doublereal), bla_r_sign(real *, real *);
  55
  56     /* Local variables */
  57     real r__, scale, z__, roe;
  58
  59
  60 /*     construct givens plane rotation. */
  61 /*     jack dongarra, linpack, 3/11/78. */
  62
  63
  64     roe = *sb;
  65     if (bli_fabs(*sa) > bli_fabs(*sb)) {
  66         roe = *sa;
  67     }
  68     scale = bli_fabs(*sa) + bli_fabs(*sb);
  69     if (scale != 0.f) {
  70         goto L10;
  71     }
  72     *c__ = 1.f;
  73     *s = 0.f;
  74     r__ = 0.f;
  75     z__ = 0.f;
  76     goto L20;
  77 L10:
  78 /* Computing 2nd power */
  79     r__1 = *sa / scale;
  80 /* Computing 2nd power */
  81     r__2 = *sb / scale;
  82     r__ = scale * sqrt(r__1 * r__1 + r__2 * r__2);
  83     r__ = bla_r_sign(&sc_b4, &roe) * r__;
  84     *c__ = *sa / r__;
  85     *s = *sb / r__;
  86     z__ = 1.f;
  87     if (bli_fabs(*sa) > bli_fabs(*sb)) {
  88         z__ = *s;
  89     }
  90     if (bli_fabs(*sb) >= bli_fabs(*sa) && *c__ != 0.f) {
  91         z__ = 1.f / *c__;
  92     }
  93 L20:
  94     *sa = r__;
  95     *sb = z__;
  96     return 0;
  97 } /* srotg_ */
  98
  99 /* drotg.f -- translated by f2c (version 19991025).
 100    You must link the resulting object file with the libraries:
 101         -lf2c -lm   (in that order)
 102 */
 103
 104 /* Table of constant values */
 105
 106 static doublereal dc_b4 = 1.;
 107
 108 /* Subroutine */ int PASTEF77(d,rotg)(doublereal *da, doublereal *db, doublereal *c__, doublereal *s)
 109 {
 110     /* System generated locals */
 111     doublereal d__1, d__2;
 112
 113     /* Builtin functions */
 114     double sqrt(doublereal), bla_d_sign(doublereal *, doublereal *);
 115
 116     /* Local variables */
 117     doublereal r__, scale, z__, roe;
 118
 119
 120 /*     construct givens plane rotation. */
 121 /*     jack dongarra, linpack, 3/11/78. */
 122
 123
 124     roe = *db;
 125     if (bli_fabs(*da) > bli_fabs(*db)) {
 126         roe = *da;
 127     }
 128     scale = bli_fabs(*da) + bli_fabs(*db);
 129     if (scale != 0.) {
 130         goto L10;
 131     }
 132     *c__ = 1.;
 133     *s = 0.;
 134     r__ = 0.;
 135     z__ = 0.;
 136     goto L20;
 137 L10:
 138 /* Computing 2nd power */
 139     d__1 = *da / scale;
 140 /* Computing 2nd power */
 141     d__2 = *db / scale;
 142     r__ = scale * sqrt(d__1 * d__1 + d__2 * d__2);
 143     r__ = bla_d_sign(&dc_b4, &roe) * r__;
 144     *c__ = *da / r__;
 145     *s = *db / r__;
 146     z__ = 1.;
 147     if (bli_fabs(*da) > bli_fabs(*db)) {
 148         z__ = *s;
 149     }
 150     if (bli_fabs(*db) >= bli_fabs(*da) && *c__ != 0.) {
 151         z__ = 1. / *c__;
 152     }
 153 L20:
 154     *da = r__;
 155     *db = z__;
 156     return 0;
 157 } /* drotg_ */
 158
 159 /* crotg.f -- translated by f2c (version 19991025).
 160    You must link the resulting object file with the libraries:
 161         -lf2c -lm   (in that order)
 162 */
 163
 164 /* Subroutine */ int PASTEF77(c,rotg)(singlecomplex *ca, singlecomplex *cb, real *c__, singlecomplex *s)
 165 {
 166     /* System generated locals */
 167     real r__1, r__2;
 168     singlecomplex q__1, q__2, q__3;
 169
 170     /* Builtin functions */
 171     double bla_c_abs(singlecomplex *), sqrt(doublereal);
 172     void bla_r_cnjg(singlecomplex *, singlecomplex *);
 173
 174     /* Local variables */
 175     real norm;
 176     singlecomplex alpha;
 177     real scale;
 178
 179     if (bla_c_abs(ca) != 0.f) {
 180         goto L10;
 181     }
 182     *c__ = 0.f;
 183     bli_csets( 1.f, 0.f, *s );
 184     bli_csets( bli_creal(*cb), bli_cimag(*cb), *ca );
 185     goto L20;
 186 L10:
 187     scale = bla_c_abs(ca) + bla_c_abs(cb);
 188     bli_csets( (bli_creal(*ca) / scale), (bli_cimag(*ca) / scale), q__1 );
 189 /* Computing 2nd power */
 190     r__1 = bla_c_abs(&q__1);
 191     bli_csets( (bli_creal(*cb) / scale), (bli_cimag(*cb) / scale), q__2 );
 192 /* Computing 2nd power */
 193     r__2 = bla_c_abs(&q__2);
 194     norm = scale * sqrt(r__1 * r__1 + r__2 * r__2);
 195     r__1 = bla_c_abs(ca);
 196     bli_csets( (bli_creal(*ca) / r__1), (bli_cimag(*ca) / r__1), q__1 );
 197     bli_csets( (bli_creal(q__1)), (bli_cimag(q__1)), alpha );
 198     *c__ = bla_c_abs(ca) / norm;
 199     bla_r_cnjg(&q__3, cb);
 200     bli_csets( (bli_creal(alpha) * bli_creal(q__3) - bli_cimag(alpha) * bli_cimag(q__3)), (bli_creal(alpha) * bli_cimag(q__3) + bli_cimag(alpha) * bli_creal(q__3)), q__2 );
 201     bli_csets( (bli_creal(q__2) / norm), (bli_cimag(q__2) / norm), q__1 );
 202     bli_csets( bli_creal(q__1), bli_cimag(q__1), *s );
 203     bli_csets( (norm * bli_creal(alpha)), (norm * bli_cimag(alpha)), q__1 );
 204     bli_csets( bli_creal(q__1), bli_cimag(q__1), *ca );
 205 L20:
 206     return 0;
 207 } /* crotg_ */
 208
 209 /* zrotg.f -- translated by f2c (version 19991025).
 210    You must link the resulting object file with the libraries:
 211         -lf2c -lm   (in that order)
 212 */
 213
 214 /* Subroutine */ int PASTEF77(z,rotg)(doublecomplex *ca, doublecomplex *cb, doublereal *c__, doublecomplex *s)
 215 {
 216     /* System generated locals */
 217     doublereal d__1, d__2;
 218     doublecomplex z__1, z__2, z__3, z__4;
 219
 220     /* Builtin functions */
 221     double bla_z_abs(doublecomplex *);
 222     void bla_z_div(doublecomplex *, doublecomplex *, doublecomplex *);
 223     double sqrt(doublereal);
 224     void bla_d_cnjg(doublecomplex *, doublecomplex *);
 225
 226     /* Local variables */
 227     doublereal norm;
 228     doublecomplex alpha;
 229     doublereal scale;
 230
 231     if (bla_z_abs(ca) != 0.) {
 232         goto L10;
 233     }
 234     *c__ = 0.;
 235     bli_zsets( 1., 0., *s );
 236     bli_zsets( bli_zreal(*cb), bli_zimag(*cb), *ca );
 237     goto L20;
 238 L10:
 239     scale = bla_z_abs(ca) + bla_z_abs(cb);
 240     bli_zsets( (scale), (0.), z__2 );
 241     bla_z_div(&z__1, ca, &z__2);
 242 /* Computing 2nd power */
 243     d__1 = bla_z_abs(&z__1);
 244     bli_zsets( (scale), (0.), z__4 );
 245     bla_z_div(&z__3, cb, &z__4);
 246 /* Computing 2nd power */
 247     d__2 = bla_z_abs(&z__3);
 248     norm = scale * sqrt(d__1 * d__1 + d__2 * d__2);
 249     d__1 = bla_z_abs(ca);
 250     bli_zsets( (bli_zreal(*ca) / d__1), (bli_zimag(*ca) / d__1), z__1 );
 251     bli_zsets( (bli_zreal(z__1)), (bli_zimag(z__1)), alpha );
 252     *c__ = bla_z_abs(ca) / norm;
 253     bla_d_cnjg(&z__3, cb);
 254     bli_zsets( (bli_zreal(alpha) * bli_zreal(z__3) - bli_zimag(alpha) * bli_zimag(z__3)), (bli_zreal(alpha) * bli_zimag(z__3) + bli_zimag(alpha) * bli_zreal(z__3)), z__2 );
 255     bli_zsets( (bli_zreal(z__2) / norm), (bli_zimag(z__2) / norm), z__1 );
 256     bli_zsets( bli_zreal(z__1), bli_zimag(z__1), *s );
 257     bli_zsets( (norm * bli_zreal(alpha)), (norm * bli_zimag(alpha)), z__1 );
 258     bli_zsets( bli_zreal(z__1), bli_zimag(z__1), *ca );
 259 L20:
 260     return 0;
 261 } /* zrotg_ */
 262
 263 #endif
 264