1 /* ./src_f77/dlasr.f -- translated by f2c (version 20030320).
2 You must link the resulting object file with the libraries:
3 -lf2c -lm (in that order)
4 */
5
6 #include <punc/vf2c.h>
7
dlasr_(char * side,char * pivot,char * direct,integer * m,integer * n,doublereal * c__,doublereal * s,doublereal * a,integer * lda,ftnlen side_len,ftnlen pivot_len,ftnlen direct_len)8 /* Subroutine */ int dlasr_(char *side, char *pivot, char *direct, integer *m,
9 integer *n, doublereal *c__, doublereal *s, doublereal *a, integer *
10 lda, ftnlen side_len, ftnlen pivot_len, ftnlen direct_len)
11 {
12 /* System generated locals */
13 integer a_dim1, a_offset, i__1, i__2;
14
15 /* Local variables */
16 static integer i__, j, info;
17 static doublereal temp;
18 extern logical lsame_(char *, char *, ftnlen, ftnlen);
19 static doublereal ctemp, stemp;
20 extern /* Subroutine */ int xerbla_(char *, integer *, ftnlen);
21
22
23 /* -- LAPACK auxiliary routine (version 3.0) -- */
24 /* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., */
25 /* Courant Institute, Argonne National Lab, and Rice University */
26 /* October 31, 1992 */
27
28 /* .. Scalar Arguments .. */
29 /* .. */
30 /* .. Array Arguments .. */
31 /* .. */
32
33 /* Purpose */
34 /* ======= */
35
36 /* DLASR performs the transformation */
37
38 /* A := P*A, when SIDE = 'L' or 'l' ( Left-hand side ) */
39
40 /* A := A*P', when SIDE = 'R' or 'r' ( Right-hand side ) */
41
42 /* where A is an m by n real matrix and P is an orthogonal matrix, */
43 /* consisting of a sequence of plane rotations determined by the */
44 /* parameters PIVOT and DIRECT as follows ( z = m when SIDE = 'L' or 'l' */
45 /* and z = n when SIDE = 'R' or 'r' ): */
46
47 /* When DIRECT = 'F' or 'f' ( Forward sequence ) then */
48
49 /* P = P( z - 1 )*...*P( 2 )*P( 1 ), */
50
51 /* and when DIRECT = 'B' or 'b' ( Backward sequence ) then */
52
53 /* P = P( 1 )*P( 2 )*...*P( z - 1 ), */
54
55 /* where P( k ) is a plane rotation matrix for the following planes: */
56
57 /* when PIVOT = 'V' or 'v' ( Variable pivot ), */
58 /* the plane ( k, k + 1 ) */
59
60 /* when PIVOT = 'T' or 't' ( Top pivot ), */
61 /* the plane ( 1, k + 1 ) */
62
63 /* when PIVOT = 'B' or 'b' ( Bottom pivot ), */
64 /* the plane ( k, z ) */
65
66 /* c( k ) and s( k ) must contain the cosine and sine that define the */
67 /* matrix P( k ). The two by two plane rotation part of the matrix */
68 /* P( k ), R( k ), is assumed to be of the form */
69
70 /* R( k ) = ( c( k ) s( k ) ). */
71 /* ( -s( k ) c( k ) ) */
72
73 /* This version vectorises across rows of the array A when SIDE = 'L'. */
74
75 /* Arguments */
76 /* ========= */
77
78 /* SIDE (input) CHARACTER*1 */
79 /* Specifies whether the plane rotation matrix P is applied to */
80 /* A on the left or the right. */
81 /* = 'L': Left, compute A := P*A */
82 /* = 'R': Right, compute A:= A*P' */
83
84 /* DIRECT (input) CHARACTER*1 */
85 /* Specifies whether P is a forward or backward sequence of */
86 /* plane rotations. */
87 /* = 'F': Forward, P = P( z - 1 )*...*P( 2 )*P( 1 ) */
88 /* = 'B': Backward, P = P( 1 )*P( 2 )*...*P( z - 1 ) */
89
90 /* PIVOT (input) CHARACTER*1 */
91 /* Specifies the plane for which P(k) is a plane rotation */
92 /* matrix. */
93 /* = 'V': Variable pivot, the plane (k,k+1) */
94 /* = 'T': Top pivot, the plane (1,k+1) */
95 /* = 'B': Bottom pivot, the plane (k,z) */
96
97 /* M (input) INTEGER */
98 /* The number of rows of the matrix A. If m <= 1, an immediate */
99 /* return is effected. */
100
101 /* N (input) INTEGER */
102 /* The number of columns of the matrix A. If n <= 1, an */
103 /* immediate return is effected. */
104
105 /* C, S (input) DOUBLE PRECISION arrays, dimension */
106 /* (M-1) if SIDE = 'L' */
107 /* (N-1) if SIDE = 'R' */
108 /* c(k) and s(k) contain the cosine and sine that define the */
109 /* matrix P(k). The two by two plane rotation part of the */
110 /* matrix P(k), R(k), is assumed to be of the form */
111 /* R( k ) = ( c( k ) s( k ) ). */
112 /* ( -s( k ) c( k ) ) */
113
114 /* A (input/output) DOUBLE PRECISION array, dimension (LDA,N) */
115 /* The m by n matrix A. On exit, A is overwritten by P*A if */
116 /* SIDE = 'R' or by A*P' if SIDE = 'L'. */
117
118 /* LDA (input) INTEGER */
119 /* The leading dimension of the array A. LDA >= max(1,M). */
120
121 /* ===================================================================== */
122
123 /* .. Parameters .. */
124 /* .. */
125 /* .. Local Scalars .. */
126 /* .. */
127 /* .. External Functions .. */
128 /* .. */
129 /* .. External Subroutines .. */
130 /* .. */
131 /* .. Intrinsic Functions .. */
132 /* .. */
133 /* .. Executable Statements .. */
134
135 /* Test the input parameters */
136
137 /* Parameter adjustments */
138 --c__;
139 --s;
140 a_dim1 = *lda;
141 a_offset = 1 + a_dim1;
142 a -= a_offset;
143
144 /* Function Body */
145 info = 0;
146 if (! (lsame_(side, "L", (ftnlen)1, (ftnlen)1) || lsame_(side, "R", (
147 ftnlen)1, (ftnlen)1))) {
148 info = 1;
149 } else if (! (lsame_(pivot, "V", (ftnlen)1, (ftnlen)1) || lsame_(pivot,
150 "T", (ftnlen)1, (ftnlen)1) || lsame_(pivot, "B", (ftnlen)1, (
151 ftnlen)1))) {
152 info = 2;
153 } else if (! (lsame_(direct, "F", (ftnlen)1, (ftnlen)1) || lsame_(direct,
154 "B", (ftnlen)1, (ftnlen)1))) {
155 info = 3;
156 } else if (*m < 0) {
157 info = 4;
158 } else if (*n < 0) {
159 info = 5;
160 } else if (*lda < max(1,*m)) {
161 info = 9;
162 }
163 if (info != 0) {
164 xerbla_("DLASR ", &info, (ftnlen)6);
165 return 0;
166 }
167
168 /* Quick return if possible */
169
170 if (*m == 0 || *n == 0) {
171 return 0;
172 }
173 if (lsame_(side, "L", (ftnlen)1, (ftnlen)1)) {
174
175 /* Form P * A */
176
177 if (lsame_(pivot, "V", (ftnlen)1, (ftnlen)1)) {
178 if (lsame_(direct, "F", (ftnlen)1, (ftnlen)1)) {
179 i__1 = *m - 1;
180 for (j = 1; j <= i__1; ++j) {
181 ctemp = c__[j];
182 stemp = s[j];
183 if (ctemp != 1. || stemp != 0.) {
184 i__2 = *n;
185 for (i__ = 1; i__ <= i__2; ++i__) {
186 temp = a[j + 1 + i__ * a_dim1];
187 a[j + 1 + i__ * a_dim1] = ctemp * temp - stemp *
188 a[j + i__ * a_dim1];
189 a[j + i__ * a_dim1] = stemp * temp + ctemp * a[j
190 + i__ * a_dim1];
191 /* L10: */
192 }
193 }
194 /* L20: */
195 }
196 } else if (lsame_(direct, "B", (ftnlen)1, (ftnlen)1)) {
197 for (j = *m - 1; j >= 1; --j) {
198 ctemp = c__[j];
199 stemp = s[j];
200 if (ctemp != 1. || stemp != 0.) {
201 i__1 = *n;
202 for (i__ = 1; i__ <= i__1; ++i__) {
203 temp = a[j + 1 + i__ * a_dim1];
204 a[j + 1 + i__ * a_dim1] = ctemp * temp - stemp *
205 a[j + i__ * a_dim1];
206 a[j + i__ * a_dim1] = stemp * temp + ctemp * a[j
207 + i__ * a_dim1];
208 /* L30: */
209 }
210 }
211 /* L40: */
212 }
213 }
214 } else if (lsame_(pivot, "T", (ftnlen)1, (ftnlen)1)) {
215 if (lsame_(direct, "F", (ftnlen)1, (ftnlen)1)) {
216 i__1 = *m;
217 for (j = 2; j <= i__1; ++j) {
218 ctemp = c__[j - 1];
219 stemp = s[j - 1];
220 if (ctemp != 1. || stemp != 0.) {
221 i__2 = *n;
222 for (i__ = 1; i__ <= i__2; ++i__) {
223 temp = a[j + i__ * a_dim1];
224 a[j + i__ * a_dim1] = ctemp * temp - stemp * a[
225 i__ * a_dim1 + 1];
226 a[i__ * a_dim1 + 1] = stemp * temp + ctemp * a[
227 i__ * a_dim1 + 1];
228 /* L50: */
229 }
230 }
231 /* L60: */
232 }
233 } else if (lsame_(direct, "B", (ftnlen)1, (ftnlen)1)) {
234 for (j = *m; j >= 2; --j) {
235 ctemp = c__[j - 1];
236 stemp = s[j - 1];
237 if (ctemp != 1. || stemp != 0.) {
238 i__1 = *n;
239 for (i__ = 1; i__ <= i__1; ++i__) {
240 temp = a[j + i__ * a_dim1];
241 a[j + i__ * a_dim1] = ctemp * temp - stemp * a[
242 i__ * a_dim1 + 1];
243 a[i__ * a_dim1 + 1] = stemp * temp + ctemp * a[
244 i__ * a_dim1 + 1];
245 /* L70: */
246 }
247 }
248 /* L80: */
249 }
250 }
251 } else if (lsame_(pivot, "B", (ftnlen)1, (ftnlen)1)) {
252 if (lsame_(direct, "F", (ftnlen)1, (ftnlen)1)) {
253 i__1 = *m - 1;
254 for (j = 1; j <= i__1; ++j) {
255 ctemp = c__[j];
256 stemp = s[j];
257 if (ctemp != 1. || stemp != 0.) {
258 i__2 = *n;
259 for (i__ = 1; i__ <= i__2; ++i__) {
260 temp = a[j + i__ * a_dim1];
261 a[j + i__ * a_dim1] = stemp * a[*m + i__ * a_dim1]
262 + ctemp * temp;
263 a[*m + i__ * a_dim1] = ctemp * a[*m + i__ *
264 a_dim1] - stemp * temp;
265 /* L90: */
266 }
267 }
268 /* L100: */
269 }
270 } else if (lsame_(direct, "B", (ftnlen)1, (ftnlen)1)) {
271 for (j = *m - 1; j >= 1; --j) {
272 ctemp = c__[j];
273 stemp = s[j];
274 if (ctemp != 1. || stemp != 0.) {
275 i__1 = *n;
276 for (i__ = 1; i__ <= i__1; ++i__) {
277 temp = a[j + i__ * a_dim1];
278 a[j + i__ * a_dim1] = stemp * a[*m + i__ * a_dim1]
279 + ctemp * temp;
280 a[*m + i__ * a_dim1] = ctemp * a[*m + i__ *
281 a_dim1] - stemp * temp;
282 /* L110: */
283 }
284 }
285 /* L120: */
286 }
287 }
288 }
289 } else if (lsame_(side, "R", (ftnlen)1, (ftnlen)1)) {
290
291 /* Form A * P' */
292
293 if (lsame_(pivot, "V", (ftnlen)1, (ftnlen)1)) {
294 if (lsame_(direct, "F", (ftnlen)1, (ftnlen)1)) {
295 i__1 = *n - 1;
296 for (j = 1; j <= i__1; ++j) {
297 ctemp = c__[j];
298 stemp = s[j];
299 if (ctemp != 1. || stemp != 0.) {
300 i__2 = *m;
301 for (i__ = 1; i__ <= i__2; ++i__) {
302 temp = a[i__ + (j + 1) * a_dim1];
303 a[i__ + (j + 1) * a_dim1] = ctemp * temp - stemp *
304 a[i__ + j * a_dim1];
305 a[i__ + j * a_dim1] = stemp * temp + ctemp * a[
306 i__ + j * a_dim1];
307 /* L130: */
308 }
309 }
310 /* L140: */
311 }
312 } else if (lsame_(direct, "B", (ftnlen)1, (ftnlen)1)) {
313 for (j = *n - 1; j >= 1; --j) {
314 ctemp = c__[j];
315 stemp = s[j];
316 if (ctemp != 1. || stemp != 0.) {
317 i__1 = *m;
318 for (i__ = 1; i__ <= i__1; ++i__) {
319 temp = a[i__ + (j + 1) * a_dim1];
320 a[i__ + (j + 1) * a_dim1] = ctemp * temp - stemp *
321 a[i__ + j * a_dim1];
322 a[i__ + j * a_dim1] = stemp * temp + ctemp * a[
323 i__ + j * a_dim1];
324 /* L150: */
325 }
326 }
327 /* L160: */
328 }
329 }
330 } else if (lsame_(pivot, "T", (ftnlen)1, (ftnlen)1)) {
331 if (lsame_(direct, "F", (ftnlen)1, (ftnlen)1)) {
332 i__1 = *n;
333 for (j = 2; j <= i__1; ++j) {
334 ctemp = c__[j - 1];
335 stemp = s[j - 1];
336 if (ctemp != 1. || stemp != 0.) {
337 i__2 = *m;
338 for (i__ = 1; i__ <= i__2; ++i__) {
339 temp = a[i__ + j * a_dim1];
340 a[i__ + j * a_dim1] = ctemp * temp - stemp * a[
341 i__ + a_dim1];
342 a[i__ + a_dim1] = stemp * temp + ctemp * a[i__ +
343 a_dim1];
344 /* L170: */
345 }
346 }
347 /* L180: */
348 }
349 } else if (lsame_(direct, "B", (ftnlen)1, (ftnlen)1)) {
350 for (j = *n; j >= 2; --j) {
351 ctemp = c__[j - 1];
352 stemp = s[j - 1];
353 if (ctemp != 1. || stemp != 0.) {
354 i__1 = *m;
355 for (i__ = 1; i__ <= i__1; ++i__) {
356 temp = a[i__ + j * a_dim1];
357 a[i__ + j * a_dim1] = ctemp * temp - stemp * a[
358 i__ + a_dim1];
359 a[i__ + a_dim1] = stemp * temp + ctemp * a[i__ +
360 a_dim1];
361 /* L190: */
362 }
363 }
364 /* L200: */
365 }
366 }
367 } else if (lsame_(pivot, "B", (ftnlen)1, (ftnlen)1)) {
368 if (lsame_(direct, "F", (ftnlen)1, (ftnlen)1)) {
369 i__1 = *n - 1;
370 for (j = 1; j <= i__1; ++j) {
371 ctemp = c__[j];
372 stemp = s[j];
373 if (ctemp != 1. || stemp != 0.) {
374 i__2 = *m;
375 for (i__ = 1; i__ <= i__2; ++i__) {
376 temp = a[i__ + j * a_dim1];
377 a[i__ + j * a_dim1] = stemp * a[i__ + *n * a_dim1]
378 + ctemp * temp;
379 a[i__ + *n * a_dim1] = ctemp * a[i__ + *n *
380 a_dim1] - stemp * temp;
381 /* L210: */
382 }
383 }
384 /* L220: */
385 }
386 } else if (lsame_(direct, "B", (ftnlen)1, (ftnlen)1)) {
387 for (j = *n - 1; j >= 1; --j) {
388 ctemp = c__[j];
389 stemp = s[j];
390 if (ctemp != 1. || stemp != 0.) {
391 i__1 = *m;
392 for (i__ = 1; i__ <= i__1; ++i__) {
393 temp = a[i__ + j * a_dim1];
394 a[i__ + j * a_dim1] = stemp * a[i__ + *n * a_dim1]
395 + ctemp * temp;
396 a[i__ + *n * a_dim1] = ctemp * a[i__ + *n *
397 a_dim1] - stemp * temp;
398 /* L230: */
399 }
400 }
401 /* L240: */
402 }
403 }
404 }
405 }
406
407 return 0;
408
409 /* End of DLASR */
410
411 } /* dlasr_ */
412
413