296 lines
5.9 KiB
C
296 lines
5.9 KiB
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 */ int 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;
|
|
|
|
/* .. 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;
|
|
return 0;
|
|
} /* srotmg_ */
|
|
|