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
srotmg_(real * sd1,real * sd2,real * sx1,real * sy1,real * sparam)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