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
drotmg_(doublereal * dd1,doublereal * dd2,doublereal * dx1,doublereal * dy1,doublereal * dparam)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