1 /* drotmg.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 drotmg_(doublereal *dd1, doublereal *dd2, doublereal * 16 dx1, doublereal *dy1, doublereal *dparam) 17 { 18 /* Initialized data */ 19 20 static doublereal zero = 0.; 21 static doublereal one = 1.; 22 static doublereal two = 2.; 23 static doublereal gam = 4096.; 24 static doublereal gamsq = 16777216.; 25 static doublereal rgamsq = 5.9604645e-8; 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 doublereal d__1; 35 36 /* Local variables */ 37 doublereal du, dp1, dp2, dq1, dq2, dh11, dh12, dh21, dh22; 38 integer igo; 39 doublereal dflag, dtemp; 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 (DSQRT(DD1)*DX1,DSQRT(DD2)* */ 54 /* DY2)**T. */ 55 /* WITH DPARAM(1)=DFLAG, H HAS ONE OF THE FOLLOWING FORMS.. */ 56 57 /* DFLAG=-1.D0 DFLAG=0.D0 DFLAG=1.D0 DFLAG=-2.D0 */ 58 59 /* (DH11 DH12) (1.D0 DH12) (DH11 1.D0) (1.D0 0.D0) */ 60 /* H=( ) ( ) ( ) ( ) */ 61 /* (DH21 DH22), (DH21 1.D0), (-1.D0 DH22), (0.D0 1.D0). */ 62 /* LOCATIONS 2-4 OF DPARAM CONTAIN DH11, DH21, DH12, AND DH22 */ 63 /* RESPECTIVELY. (VALUES OF 1.D0, -1.D0, OR 0.D0 IMPLIED BY THE */ 64 /* VALUE OF DPARAM(1) ARE NOT STORED IN DPARAM.) */ 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 DD1 AND DD2. ALL ACTUAL SCALING OF DATA IS DONE USING GAM. */ 69 70 71 /* Arguments */ 72 /* ========= */ 73 74 /* DD1 (input/output) DOUBLE PRECISION */ 75 76 /* DD2 (input/output) DOUBLE PRECISION */ 77 78 /* DX1 (input/output) DOUBLE PRECISION */ 79 80 /* DY1 (input) DOUBLE PRECISION */ 81 82 /* DPARAM (input/output) DOUBLE PRECISION array, dimension 5 */ 83 /* DPARAM(1)=DFLAG */ 84 /* DPARAM(2)=DH11 */ 85 /* DPARAM(3)=DH21 */ 86 /* DPARAM(4)=DH12 */ 87 /* DPARAM(5)=DH22 */ 88 89 /* ===================================================================== */ 90 91 /* .. Local Scalars .. */ 92 /* .. */ 93 /* .. Intrinsic Functions .. */ 94 /* .. */ 95 /* .. Data statements .. */ 96 97 /* Parameter adjustments */ 98 --dparam; 99 100 /* Function Body */ 101 /* .. */ 102 if (! (*dd1 < zero)) { 103 goto L10; 104 } 105 /* GO ZERO-H-D-AND-DX1.. */ 106 goto L60; 107 L10: 108 /* CASE-DD1-NONNEGATIVE */ 109 dp2 = *dd2 * *dy1; 110 if (! (dp2 == zero)) { 111 goto L20; 112 } 113 dflag = -two; 114 goto L260; 115 /* REGULAR-CASE.. */ 116 L20: 117 dp1 = *dd1 * *dx1; 118 dq2 = dp2 * *dy1; 119 dq1 = dp1 * *dx1; 120 121 if (! (abs(dq1) > abs(dq2))) { 122 goto L40; 123 } 124 dh21 = -(*dy1) / *dx1; 125 dh12 = dp2 / dp1; 126 127 du = one - dh12 * dh21; 128 129 if (! (du <= zero)) { 130 goto L30; 131 } 132 /* GO ZERO-H-D-AND-DX1.. */ 133 goto L60; 134 L30: 135 dflag = zero; 136 *dd1 /= du; 137 *dd2 /= du; 138 *dx1 *= du; 139 /* GO SCALE-CHECK.. */ 140 goto L100; 141 L40: 142 if (! (dq2 < zero)) { 143 goto L50; 144 } 145 /* GO ZERO-H-D-AND-DX1.. */ 146 goto L60; 147 L50: 148 dflag = one; 149 dh11 = dp1 / dp2; 150 dh22 = *dx1 / *dy1; 151 du = one + dh11 * dh22; 152 dtemp = *dd2 / du; 153 *dd2 = *dd1 / du; 154 *dd1 = dtemp; 155 *dx1 = *dy1 * du; 156 /* GO SCALE-CHECK */ 157 goto L100; 158 /* PROCEDURE..ZERO-H-D-AND-DX1.. */ 159 L60: 160 dflag = -one; 161 dh11 = zero; 162 dh12 = zero; 163 dh21 = zero; 164 dh22 = zero; 165 166 *dd1 = zero; 167 *dd2 = zero; 168 *dx1 = zero; 169 /* RETURN.. */ 170 goto L220; 171 /* PROCEDURE..FIX-H.. */ 172 L70: 173 if (! (dflag >= zero)) { 174 goto L90; 175 } 176 177 if (! (dflag == zero)) { 178 goto L80; 179 } 180 dh11 = one; 181 dh22 = one; 182 dflag = -one; 183 goto L90; 184 L80: 185 dh21 = -one; 186 dh12 = one; 187 dflag = -one; 188 L90: 189 switch (igo) { 190 case 0: goto L120; 191 case 1: goto L150; 192 case 2: goto L180; 193 case 3: goto L210; 194 } 195 /* PROCEDURE..SCALE-CHECK */ 196 L100: 197 L110: 198 if (! (*dd1 <= rgamsq)) { 199 goto L130; 200 } 201 if (*dd1 == zero) { 202 goto L160; 203 } 204 igo = 0; 205 igo_fmt = fmt_120; 206 /* FIX-H.. */ 207 goto L70; 208 L120: 209 /* Computing 2nd power */ 210 d__1 = gam; 211 *dd1 *= d__1 * d__1; 212 *dx1 /= gam; 213 dh11 /= gam; 214 dh12 /= gam; 215 goto L110; 216 L130: 217 L140: 218 if (! (*dd1 >= gamsq)) { 219 goto L160; 220 } 221 igo = 1; 222 igo_fmt = fmt_150; 223 /* FIX-H.. */ 224 goto L70; 225 L150: 226 /* Computing 2nd power */ 227 d__1 = gam; 228 *dd1 /= d__1 * d__1; 229 *dx1 *= gam; 230 dh11 *= gam; 231 dh12 *= gam; 232 goto L140; 233 L160: 234 L170: 235 if (! (abs(*dd2) <= rgamsq)) { 236 goto L190; 237 } 238 if (*dd2 == zero) { 239 goto L220; 240 } 241 igo = 2; 242 igo_fmt = fmt_180; 243 /* FIX-H.. */ 244 goto L70; 245 L180: 246 /* Computing 2nd power */ 247 d__1 = gam; 248 *dd2 *= d__1 * d__1; 249 dh21 /= gam; 250 dh22 /= gam; 251 goto L170; 252 L190: 253 L200: 254 if (! (abs(*dd2) >= gamsq)) { 255 goto L220; 256 } 257 igo = 3; 258 igo_fmt = fmt_210; 259 /* FIX-H.. */ 260 goto L70; 261 L210: 262 /* Computing 2nd power */ 263 d__1 = gam; 264 *dd2 /= d__1 * d__1; 265 dh21 *= gam; 266 dh22 *= gam; 267 goto L200; 268 L220: 269 if (dflag < 0.) { 270 goto L250; 271 } else if (dflag == 0) { 272 goto L230; 273 } else { 274 goto L240; 275 } 276 L230: 277 dparam[3] = dh21; 278 dparam[4] = dh12; 279 goto L260; 280 L240: 281 dparam[2] = dh11; 282 dparam[5] = dh22; 283 goto L260; 284 L250: 285 dparam[2] = dh11; 286 dparam[3] = dh21; 287 dparam[4] = dh12; 288 dparam[5] = dh22; 289 L260: 290 dparam[1] = dflag; 291 return 0; 292 } /* drotmg_ */ 293 294
