swiftnav: srotmg.c Source File

Go to the documentation of this file.
00001 /* srotmg.f -- translated by f2c (version 20061008).
00002    You must link the resulting object file with libf2c:
00003         on Microsoft Windows system, link with libf2c.lib;
00004         on Linux or Unix systems, link with .../path/to/libf2c.a -lm
00005         or, if you install libf2c.a in a standard place, with -lf2c -lm
00006         -- in that order, at the end of the command line, as in
00007                 cc *.o -lf2c -lm
00008         Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
00009 
00010                 http://www.netlib.org/f2c/libf2c.zip
00011 */
00012 
00013 #include "f2c.h"
00014 #include "blaswrap.h"
00015 
00016 /* Subroutine */ int srotmg_(real *sd1, real *sd2, real *sx1, real *sy1, real 
00017         *sparam)
00018 {
00019     /* Initialized data */
00020 
00021     static real zero = 0.f;
00022     static real one = 1.f;
00023     static real two = 2.f;
00024     static real gam = 4096.f;
00025     static real gamsq = 16777200.f;
00026     static real rgamsq = 5.96046e-8f;
00027 
00028     /* Format strings */
00029     static char fmt_120[] = "";
00030     static char fmt_150[] = "";
00031     static char fmt_180[] = "";
00032     static char fmt_210[] = "";
00033 
00034     /* System generated locals */
00035     real r__1;
00036 
00037     /* Local variables */
00038     real su, sp1, sp2, sq1, sq2, sh11, sh12, sh21, sh22;
00039     integer igo;
00040     real sflag, stemp;
00041 
00042     /* Assigned format variables */
00043     static char *igo_fmt;
00044 
00045 /*     .. Scalar Arguments .. */
00046 /*     .. */
00047 /*     .. Array Arguments .. */
00048 /*     .. */
00049 
00050 /*  Purpose */
00051 /*  ======= */
00052 
00053 /*     CONSTRUCT THE MODIFIED GIVENS TRANSFORMATION MATRIX H WHICH ZEROS */
00054 /*     THE SECOND COMPONENT OF THE 2-VECTOR  (SQRT(SD1)*SX1,SQRT(SD2)* */
00055 /*     SY2)**T. */
00056 /*     WITH SPARAM(1)=SFLAG, H HAS ONE OF THE FOLLOWING FORMS.. */
00057 
00058 /*     SFLAG=-1.E0     SFLAG=0.E0        SFLAG=1.E0     SFLAG=-2.E0 */
00059 
00060 /*       (SH11  SH12)    (1.E0  SH12)    (SH11  1.E0)    (1.E0  0.E0) */
00061 /*     H=(          )    (          )    (          )    (          ) */
00062 /*       (SH21  SH22),   (SH21  1.E0),   (-1.E0 SH22),   (0.E0  1.E0). */
00063 /*     LOCATIONS 2-4 OF SPARAM CONTAIN SH11,SH21,SH12, AND SH22 */
00064 /*     RESPECTIVELY. (VALUES OF 1.E0, -1.E0, OR 0.E0 IMPLIED BY THE */
00065 /*     VALUE OF SPARAM(1) ARE NOT STORED IN SPARAM.) */
00066 
00067 /*     THE VALUES OF GAMSQ AND RGAMSQ SET IN THE DATA STATEMENT MAY BE */
00068 /*     INEXACT.  THIS IS OK AS THEY ARE ONLY USED FOR TESTING THE SIZE */
00069 /*     OF SD1 AND SD2.  ALL ACTUAL SCALING OF DATA IS DONE USING GAM. */
00070 
00071 
00072 /*  Arguments */
00073 /*  ========= */
00074 
00075 
00076 /*  SD1    (input/output) REAL */
00077 
00078 /*  SD2    (input/output) REAL */
00079 
00080 /*  SX1    (input/output) REAL */
00081 
00082 /*  SY1    (input) REAL */
00083 
00084 
00085 /*  SPARAM (input/output)  REAL array, dimension 5 */
00086 /*     SPARAM(1)=SFLAG */
00087 /*     SPARAM(2)=SH11 */
00088 /*     SPARAM(3)=SH21 */
00089 /*     SPARAM(4)=SH12 */
00090 /*     SPARAM(5)=SH22 */
00091 
00092 /*  ===================================================================== */
00093 
00094 /*     .. Local Scalars .. */
00095 /*     .. */
00096 /*     .. Intrinsic Functions .. */
00097 /*     .. */
00098 /*     .. Data statements .. */
00099 
00100     /* Parameter adjustments */
00101     --sparam;
00102 
00103     /* Function Body */
00104 /*     .. */
00105     if (! (*sd1 < zero)) {
00106         goto L10;
00107     }
00108 /*       GO ZERO-H-D-AND-SX1.. */
00109     goto L60;
00110 L10:
00111 /*     CASE-SD1-NONNEGATIVE */
00112     sp2 = *sd2 * *sy1;
00113     if (! (sp2 == zero)) {
00114         goto L20;
00115     }
00116     sflag = -two;
00117     goto L260;
00118 /*     REGULAR-CASE.. */
00119 L20:
00120     sp1 = *sd1 * *sx1;
00121     sq2 = sp2 * *sy1;
00122     sq1 = sp1 * *sx1;
00123 
00124     if (! (dabs(sq1) > dabs(sq2))) {
00125         goto L40;
00126     }
00127     sh21 = -(*sy1) / *sx1;
00128     sh12 = sp2 / sp1;
00129 
00130     su = one - sh12 * sh21;
00131 
00132     if (! (su <= zero)) {
00133         goto L30;
00134     }
00135 /*         GO ZERO-H-D-AND-SX1.. */
00136     goto L60;
00137 L30:
00138     sflag = zero;
00139     *sd1 /= su;
00140     *sd2 /= su;
00141     *sx1 *= su;
00142 /*         GO SCALE-CHECK.. */
00143     goto L100;
00144 L40:
00145     if (! (sq2 < zero)) {
00146         goto L50;
00147     }
00148 /*         GO ZERO-H-D-AND-SX1.. */
00149     goto L60;
00150 L50:
00151     sflag = one;
00152     sh11 = sp1 / sp2;
00153     sh22 = *sx1 / *sy1;
00154     su = one + sh11 * sh22;
00155     stemp = *sd2 / su;
00156     *sd2 = *sd1 / su;
00157     *sd1 = stemp;
00158     *sx1 = *sy1 * su;
00159 /*         GO SCALE-CHECK */
00160     goto L100;
00161 /*     PROCEDURE..ZERO-H-D-AND-SX1.. */
00162 L60:
00163     sflag = -one;
00164     sh11 = zero;
00165     sh12 = zero;
00166     sh21 = zero;
00167     sh22 = zero;
00168 
00169     *sd1 = zero;
00170     *sd2 = zero;
00171     *sx1 = zero;
00172 /*         RETURN.. */
00173     goto L220;
00174 /*     PROCEDURE..FIX-H.. */
00175 L70:
00176     if (! (sflag >= zero)) {
00177         goto L90;
00178     }
00179 
00180     if (! (sflag == zero)) {
00181         goto L80;
00182     }
00183     sh11 = one;
00184     sh22 = one;
00185     sflag = -one;
00186     goto L90;
00187 L80:
00188     sh21 = -one;
00189     sh12 = one;
00190     sflag = -one;
00191 L90:
00192     switch (igo) {
00193         case 0: goto L120;
00194         case 1: goto L150;
00195         case 2: goto L180;
00196         case 3: goto L210;
00197     }
00198 /*     PROCEDURE..SCALE-CHECK */
00199 L100:
00200 L110:
00201     if (! (*sd1 <= rgamsq)) {
00202         goto L130;
00203     }
00204     if (*sd1 == zero) {
00205         goto L160;
00206     }
00207     igo = 0;
00208     igo_fmt = fmt_120;
00209 /*              FIX-H.. */
00210     goto L70;
00211 L120:
00212 /* Computing 2nd power */
00213     r__1 = gam;
00214     *sd1 *= r__1 * r__1;
00215     *sx1 /= gam;
00216     sh11 /= gam;
00217     sh12 /= gam;
00218     goto L110;
00219 L130:
00220 L140:
00221     if (! (*sd1 >= gamsq)) {
00222         goto L160;
00223     }
00224     igo = 1;
00225     igo_fmt = fmt_150;
00226 /*              FIX-H.. */
00227     goto L70;
00228 L150:
00229 /* Computing 2nd power */
00230     r__1 = gam;
00231     *sd1 /= r__1 * r__1;
00232     *sx1 *= gam;
00233     sh11 *= gam;
00234     sh12 *= gam;
00235     goto L140;
00236 L160:
00237 L170:
00238     if (! (dabs(*sd2) <= rgamsq)) {
00239         goto L190;
00240     }
00241     if (*sd2 == zero) {
00242         goto L220;
00243     }
00244     igo = 2;
00245     igo_fmt = fmt_180;
00246 /*              FIX-H.. */
00247     goto L70;
00248 L180:
00249 /* Computing 2nd power */
00250     r__1 = gam;
00251     *sd2 *= r__1 * r__1;
00252     sh21 /= gam;
00253     sh22 /= gam;
00254     goto L170;
00255 L190:
00256 L200:
00257     if (! (dabs(*sd2) >= gamsq)) {
00258         goto L220;
00259     }
00260     igo = 3;
00261     igo_fmt = fmt_210;
00262 /*              FIX-H.. */
00263     goto L70;
00264 L210:
00265 /* Computing 2nd power */
00266     r__1 = gam;
00267     *sd2 /= r__1 * r__1;
00268     sh21 *= gam;
00269     sh22 *= gam;
00270     goto L200;
00271 L220:
00272     if (sflag < 0.f) {
00273         goto L250;
00274     } else if (sflag == 0) {
00275         goto L230;
00276     } else {
00277         goto L240;
00278     }
00279 L230:
00280     sparam[3] = sh21;
00281     sparam[4] = sh12;
00282     goto L260;
00283 L240:
00284     sparam[2] = sh11;
00285     sparam[5] = sh22;
00286     goto L260;
00287 L250:
00288     sparam[2] = sh11;
00289     sparam[3] = sh21;
00290     sparam[4] = sh12;
00291     sparam[5] = sh22;
00292 L260:
00293     sparam[1] = sflag;
00294     return 0;
00295 } /* srotmg_ */