1 /* srotm.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
srotm_(integer * n,real * sx,integer * incx,real * sy,integer * incy,real * sparam)15 /* Subroutine */ int srotm_(integer *n, real *sx, integer *incx, real *sy,
16 integer *incy, real *sparam)
17 {
18 /* Initialized data */
19
20 static real zero = 0.f;
21 static real two = 2.f;
22
23 /* System generated locals */
24 integer i__1, i__2;
25
26 /* Local variables */
27 integer i__;
28 real w, z__;
29 integer kx, ky;
30 real sh11, sh12, sh21, sh22, sflag;
31 integer nsteps;
32
33 /* .. Scalar Arguments .. */
34 /* .. */
35 /* .. Array Arguments .. */
36 /* .. */
37
38 /* Purpose */
39 /* ======= */
40
41 /* APPLY THE MODIFIED GIVENS TRANSFORMATION, H, TO THE 2 BY N MATRIX */
42
43 /* (SX**T) , WHERE **T INDICATES TRANSPOSE. THE ELEMENTS OF SX ARE IN */
44 /* (DX**T) */
45
46 /* SX(LX+I*INCX), I = 0 TO N-1, WHERE LX = 1 IF INCX .GE. 0, ELSE */
47 /* LX = (-INCX)*N, AND SIMILARLY FOR SY USING USING LY AND INCY. */
48 /* WITH SPARAM(1)=SFLAG, H HAS ONE OF THE FOLLOWING FORMS.. */
49
50 /* SFLAG=-1.E0 SFLAG=0.E0 SFLAG=1.E0 SFLAG=-2.E0 */
51
52 /* (SH11 SH12) (1.E0 SH12) (SH11 1.E0) (1.E0 0.E0) */
53 /* H=( ) ( ) ( ) ( ) */
54 /* (SH21 SH22), (SH21 1.E0), (-1.E0 SH22), (0.E0 1.E0). */
55 /* SEE SROTMG FOR A DESCRIPTION OF DATA STORAGE IN SPARAM. */
56
57
58 /* Arguments */
59 /* ========= */
60
61 /* N (input) INTEGER */
62 /* number of elements in input vector(s) */
63
64 /* SX (input/output) REAL array, dimension N */
65 /* double precision vector with N elements */
66
67 /* INCX (input) INTEGER */
68 /* storage spacing between elements of SX */
69
70 /* SY (input/output) REAL array, dimension N */
71 /* double precision vector with N elements */
72
73 /* INCY (input) INTEGER */
74 /* storage spacing between elements of SY */
75
76 /* SPARAM (input/output) REAL array, dimension 5 */
77 /* SPARAM(1)=SFLAG */
78 /* SPARAM(2)=SH11 */
79 /* SPARAM(3)=SH21 */
80 /* SPARAM(4)=SH12 */
81 /* SPARAM(5)=SH22 */
82
83 /* ===================================================================== */
84
85 /* .. Local Scalars .. */
86 /* .. */
87 /* .. Data statements .. */
88 /* Parameter adjustments */
89 --sparam;
90 --sy;
91 --sx;
92
93 /* Function Body */
94 /* .. */
95
96 sflag = sparam[1];
97 if (*n <= 0 || sflag + two == zero) {
98 goto L140;
99 }
100 if (! (*incx == *incy && *incx > 0)) {
101 goto L70;
102 }
103
104 nsteps = *n * *incx;
105 if (sflag < 0.f) {
106 goto L50;
107 } else if (sflag == 0) {
108 goto L10;
109 } else {
110 goto L30;
111 }
112 L10:
113 sh12 = sparam[4];
114 sh21 = sparam[3];
115 i__1 = nsteps;
116 i__2 = *incx;
117 for (i__ = 1; i__2 < 0 ? i__ >= i__1 : i__ <= i__1; i__ += i__2) {
118 w = sx[i__];
119 z__ = sy[i__];
120 sx[i__] = w + z__ * sh12;
121 sy[i__] = w * sh21 + z__;
122 /* L20: */
123 }
124 goto L140;
125 L30:
126 sh11 = sparam[2];
127 sh22 = sparam[5];
128 i__2 = nsteps;
129 i__1 = *incx;
130 for (i__ = 1; i__1 < 0 ? i__ >= i__2 : i__ <= i__2; i__ += i__1) {
131 w = sx[i__];
132 z__ = sy[i__];
133 sx[i__] = w * sh11 + z__;
134 sy[i__] = -w + sh22 * z__;
135 /* L40: */
136 }
137 goto L140;
138 L50:
139 sh11 = sparam[2];
140 sh12 = sparam[4];
141 sh21 = sparam[3];
142 sh22 = sparam[5];
143 i__1 = nsteps;
144 i__2 = *incx;
145 for (i__ = 1; i__2 < 0 ? i__ >= i__1 : i__ <= i__1; i__ += i__2) {
146 w = sx[i__];
147 z__ = sy[i__];
148 sx[i__] = w * sh11 + z__ * sh12;
149 sy[i__] = w * sh21 + z__ * sh22;
150 /* L60: */
151 }
152 goto L140;
153 L70:
154 kx = 1;
155 ky = 1;
156 if (*incx < 0) {
157 kx = (1 - *n) * *incx + 1;
158 }
159 if (*incy < 0) {
160 ky = (1 - *n) * *incy + 1;
161 }
162
163 if (sflag < 0.f) {
164 goto L120;
165 } else if (sflag == 0) {
166 goto L80;
167 } else {
168 goto L100;
169 }
170 L80:
171 sh12 = sparam[4];
172 sh21 = sparam[3];
173 i__2 = *n;
174 for (i__ = 1; i__ <= i__2; ++i__) {
175 w = sx[kx];
176 z__ = sy[ky];
177 sx[kx] = w + z__ * sh12;
178 sy[ky] = w * sh21 + z__;
179 kx += *incx;
180 ky += *incy;
181 /* L90: */
182 }
183 goto L140;
184 L100:
185 sh11 = sparam[2];
186 sh22 = sparam[5];
187 i__2 = *n;
188 for (i__ = 1; i__ <= i__2; ++i__) {
189 w = sx[kx];
190 z__ = sy[ky];
191 sx[kx] = w * sh11 + z__;
192 sy[ky] = -w + sh22 * z__;
193 kx += *incx;
194 ky += *incy;
195 /* L110: */
196 }
197 goto L140;
198 L120:
199 sh11 = sparam[2];
200 sh12 = sparam[4];
201 sh21 = sparam[3];
202 sh22 = sparam[5];
203 i__2 = *n;
204 for (i__ = 1; i__ <= i__2; ++i__) {
205 w = sx[kx];
206 z__ = sy[ky];
207 sx[kx] = w * sh11 + z__ * sh12;
208 sy[ky] = w * sh21 + z__ * sh22;
209 kx += *incx;
210 ky += *incy;
211 /* L130: */
212 }
213 L140:
214 return 0;
215 } /* srotm_ */
216
217