blas/f2c/srotmg.c

/* srotmg.f -- translated by f2c (version 20100827).
   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 "datatypes.h"

/* Subroutine */ void srotmg_(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 su, sp1, sp2, sq1, sq2, sh11, sh12, sh21, sh22;
  integer igo;
  real sflag, stemp;

  /* Assigned format variables */
  static char *igo_fmt;
  (void)igo_fmt;

  /*     .. Scalar Arguments .. */
  /*     .. */
  /*     .. Array Arguments .. */
  /*     .. */

  /*  Purpose */
  /*  ======= */

  /*     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. */

  /*  Arguments */
  /*  ========= */

  /*  SD1    (input/output) REAL */

  /*  SD2    (input/output) REAL */

  /*  SX1    (input/output) REAL */

  /*  SY1    (input) REAL */

  /*  SPARAM (input/output)  REAL array, dimension 5 */
  /*     SPARAM(1)=SFLAG */
  /*     SPARAM(2)=SH11 */
  /*     SPARAM(3)=SH21 */
  /*     SPARAM(4)=SH12 */
  /*     SPARAM(5)=SH22 */

  /*  ===================================================================== */

  /*     .. Local Scalars .. */
  /*     .. */
  /*     .. Intrinsic Functions .. */
  /*     .. */
  /*     .. Data statements .. */

  /* 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 (!(dabs(sq1) > dabs(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 (!(dabs(*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 (!(dabs(*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;
} /* srotmg_ */