srotmg.c
Go to the documentation of this file.
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 
int srotmg_(real *sd1, real *sd2, real *sx1, real *sy1, real *sparam)
Definition: srotmg.c:15
EIGEN_DONT_INLINE Scalar zero()
Definition: svd_common.h:296
Definition: main.h:100
Point2(* f)(const Point3 &, OptionalJacobian< 2, 3 >)
#define dabs(x)
Definition: datatypes.h:18
int integer
Definition: datatypes.h:8


gtsam
Author(s):
autogenerated on Tue Jul 4 2023 02:36:19