1 /* srotmg.f -- translated by f2c (version 20100827). 2 You must link the resulting object file with libf2c: 3 on Microsoft Windows system, link with libf2c.lib; 4 on Linux or Unix systems, link with .../path/to/libf2c.a -lm 5 or, if you install libf2c.a in a standard place, with -lf2c -lm 6 -- in that order, at the end of the command line, as in 7 cc *.o -lf2c -lm 8 Source for libf2c is in /netlib/f2c/libf2c.zip, e.g., 9 10 http://www.netlib.org/f2c/libf2c.zip 11 */ 12 13 #include "datatypes.h" 14 15 /* Subroutine */ int srotmg_(real *sd1, real *sd2, real *sx1, real *sy1, real 16 *sparam) 17 { 18 /* Initialized data */ 19 20 static real zero = 0.f; 21 static real one = 1.f; 22 static real two = 2.f; 23 static real gam = 4096.f; 24 static real gamsq = 16777200.f; 25 static real rgamsq = 5.96046e-8f; 26 27 /* Format strings */ 28 static char fmt_120[] = ""; 29 static char fmt_150[] = ""; 30 static char fmt_180[] = ""; 31 static char fmt_210[] = ""; 32 33 /* System generated locals */ 34 real r__1; 35 36 /* Local variables */ 37 real su, sp1, sp2, sq1, sq2, sh11, sh12, sh21, sh22; 38 integer igo; 39 real sflag, stemp; 40 41 /* Assigned format variables */ 42 static char *igo_fmt; 43 44 /* .. Scalar Arguments .. */ 45 /* .. */ 46 /* .. Array Arguments .. */ 47 /* .. */ 48 49 /* Purpose */ 50 /* ======= */ 51 52 /* CONSTRUCT THE MODIFIED GIVENS TRANSFORMATION MATRIX H WHICH ZEROS */ 53 /* THE SECOND COMPONENT OF THE 2-VECTOR (SQRT(SD1)*SX1,SQRT(SD2)* */ 54 /* SY2)**T. */ 55 /* WITH SPARAM(1)=SFLAG, H HAS ONE OF THE FOLLOWING FORMS.. */ 56 57 /* SFLAG=-1.E0 SFLAG=0.E0 SFLAG=1.E0 SFLAG=-2.E0 */ 58 59 /* (SH11 SH12) (1.E0 SH12) (SH11 1.E0) (1.E0 0.E0) */ 60 /* H=( ) ( ) ( ) ( ) */ 61 /* (SH21 SH22), (SH21 1.E0), (-1.E0 SH22), (0.E0 1.E0). */ 62 /* LOCATIONS 2-4 OF SPARAM CONTAIN SH11,SH21,SH12, AND SH22 */ 63 /* RESPECTIVELY. (VALUES OF 1.E0, -1.E0, OR 0.E0 IMPLIED BY THE */ 64 /* VALUE OF SPARAM(1) ARE NOT STORED IN SPARAM.) */ 65 66 /* THE VALUES OF GAMSQ AND RGAMSQ SET IN THE DATA STATEMENT MAY BE */ 67 /* INEXACT. THIS IS OK AS THEY ARE ONLY USED FOR TESTING THE SIZE */ 68 /* OF SD1 AND SD2. ALL ACTUAL SCALING OF DATA IS DONE USING GAM. */ 69 70 71 /* Arguments */ 72 /* ========= */ 73 74 75 /* SD1 (input/output) REAL */ 76 77 /* SD2 (input/output) REAL */ 78 79 /* SX1 (input/output) REAL */ 80 81 /* SY1 (input) REAL */ 82 83 84 /* SPARAM (input/output) REAL array, dimension 5 */ 85 /* SPARAM(1)=SFLAG */ 86 /* SPARAM(2)=SH11 */ 87 /* SPARAM(3)=SH21 */ 88 /* SPARAM(4)=SH12 */ 89 /* SPARAM(5)=SH22 */ 90 91 /* ===================================================================== */ 92 93 /* .. Local Scalars .. */ 94 /* .. */ 95 /* .. Intrinsic Functions .. */ 96 /* .. */ 97 /* .. Data statements .. */ 98 99 /* Parameter adjustments */ 100 --sparam; 101 102 /* Function Body */ 103 /* .. */ 104 if (! (*sd1 < zero)) { 105 goto L10; 106 } 107 /* GO ZERO-H-D-AND-SX1.. */ 108 goto L60; 109 L10: 110 /* CASE-SD1-NONNEGATIVE */ 111 sp2 = *sd2 * *sy1; 112 if (! (sp2 == zero)) { 113 goto L20; 114 } 115 sflag = -two; 116 goto L260; 117 /* REGULAR-CASE.. */ 118 L20: 119 sp1 = *sd1 * *sx1; 120 sq2 = sp2 * *sy1; 121 sq1 = sp1 * *sx1; 122 123 if (! (dabs(sq1) > dabs(sq2))) { 124 goto L40; 125 } 126 sh21 = -(*sy1) / *sx1; 127 sh12 = sp2 / sp1; 128 129 su = one - sh12 * sh21; 130 131 if (! (su <= zero)) { 132 goto L30; 133 } 134 /* GO ZERO-H-D-AND-SX1.. */ 135 goto L60; 136 L30: 137 sflag = zero; 138 *sd1 /= su; 139 *sd2 /= su; 140 *sx1 *= su; 141 /* GO SCALE-CHECK.. */ 142 goto L100; 143 L40: 144 if (! (sq2 < zero)) { 145 goto L50; 146 } 147 /* GO ZERO-H-D-AND-SX1.. */ 148 goto L60; 149 L50: 150 sflag = one; 151 sh11 = sp1 / sp2; 152 sh22 = *sx1 / *sy1; 153 su = one + sh11 * sh22; 154 stemp = *sd2 / su; 155 *sd2 = *sd1 / su; 156 *sd1 = stemp; 157 *sx1 = *sy1 * su; 158 /* GO SCALE-CHECK */ 159 goto L100; 160 /* PROCEDURE..ZERO-H-D-AND-SX1.. */ 161 L60: 162 sflag = -one; 163 sh11 = zero; 164 sh12 = zero; 165 sh21 = zero; 166 sh22 = zero; 167 168 *sd1 = zero; 169 *sd2 = zero; 170 *sx1 = zero; 171 /* RETURN.. */ 172 goto L220; 173 /* PROCEDURE..FIX-H.. */ 174 L70: 175 if (! (sflag >= zero)) { 176 goto L90; 177 } 178 179 if (! (sflag == zero)) { 180 goto L80; 181 } 182 sh11 = one; 183 sh22 = one; 184 sflag = -one; 185 goto L90; 186 L80: 187 sh21 = -one; 188 sh12 = one; 189 sflag = -one; 190 L90: 191 switch (igo) { 192 case 0: goto L120; 193 case 1: goto L150; 194 case 2: goto L180; 195 case 3: goto L210; 196 } 197 /* PROCEDURE..SCALE-CHECK */ 198 L100: 199 L110: 200 if (! (*sd1 <= rgamsq)) { 201 goto L130; 202 } 203 if (*sd1 == zero) { 204 goto L160; 205 } 206 igo = 0; 207 igo_fmt = fmt_120; 208 /* FIX-H.. */ 209 goto L70; 210 L120: 211 /* Computing 2nd power */ 212 r__1 = gam; 213 *sd1 *= r__1 * r__1; 214 *sx1 /= gam; 215 sh11 /= gam; 216 sh12 /= gam; 217 goto L110; 218 L130: 219 L140: 220 if (! (*sd1 >= gamsq)) { 221 goto L160; 222 } 223 igo = 1; 224 igo_fmt = fmt_150; 225 /* FIX-H.. */ 226 goto L70; 227 L150: 228 /* Computing 2nd power */ 229 r__1 = gam; 230 *sd1 /= r__1 * r__1; 231 *sx1 *= gam; 232 sh11 *= gam; 233 sh12 *= gam; 234 goto L140; 235 L160: 236 L170: 237 if (! (dabs(*sd2) <= rgamsq)) { 238 goto L190; 239 } 240 if (*sd2 == zero) { 241 goto L220; 242 } 243 igo = 2; 244 igo_fmt = fmt_180; 245 /* FIX-H.. */ 246 goto L70; 247 L180: 248 /* Computing 2nd power */ 249 r__1 = gam; 250 *sd2 *= r__1 * r__1; 251 sh21 /= gam; 252 sh22 /= gam; 253 goto L170; 254 L190: 255 L200: 256 if (! (dabs(*sd2) >= gamsq)) { 257 goto L220; 258 } 259 igo = 3; 260 igo_fmt = fmt_210; 261 /* FIX-H.. */ 262 goto L70; 263 L210: 264 /* Computing 2nd power */ 265 r__1 = gam; 266 *sd2 /= r__1 * r__1; 267 sh21 *= gam; 268 sh22 *= gam; 269 goto L200; 270 L220: 271 if (sflag < 0.f) { 272 goto L250; 273 } else if (sflag == 0) { 274 goto L230; 275 } else { 276 goto L240; 277 } 278 L230: 279 sparam[3] = sh21; 280 sparam[4] = sh12; 281 goto L260; 282 L240: 283 sparam[2] = sh11; 284 sparam[5] = sh22; 285 goto L260; 286 L250: 287 sparam[2] = sh11; 288 sparam[3] = sh21; 289 sparam[4] = sh12; 290 sparam[5] = sh22; 291 L260: 292 sparam[1] = sflag; 293 return 0; 294 } /* srotmg_ */ 295 296
