1 /* -- translated by f2c (version 19940927).
2 You must link the resulting object file with the libraries:
3 -lf2c -lm (in that order)
4 */
5
6 #include "f2c.h"
7
8 /* Table of constant values */
9
10 static integer c__4 = 4;
11 static integer c__8 = 8;
12
zlarot_(logical * lrows,logical * lleft,logical * lright,integer * nl,doublecomplex * c,doublecomplex * s,doublecomplex * a,integer * lda,doublecomplex * xleft,doublecomplex * xright)13 /* Subroutine */ int zlarot_(logical *lrows, logical *lleft, logical *lright,
14 integer *nl, doublecomplex *c, doublecomplex *s, doublecomplex *a,
15 integer *lda, doublecomplex *xleft, doublecomplex *xright)
16 {
17 /* System generated locals */
18 integer i__1, i__2, i__3, i__4;
19 doublecomplex z__1, z__2, z__3, z__4, z__5, z__6;
20
21 /* Builtin functions */
22 void d_cnjg(doublecomplex *, doublecomplex *);
23
24 /* Local variables */
25 static integer iinc, j, inext;
26 static doublecomplex tempx;
27 static integer ix, iy, nt;
28 static doublecomplex xt[2], yt[2];
29 extern /* Subroutine */ int xerbla_(char *, integer *);
30 static integer iyt;
31
32
33 /* -- LAPACK auxiliary test routine (version 2.0) --
34 Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
35 Courant Institute, Argonne National Lab, and Rice University
36 February 29, 1992
37
38
39 Purpose
40 =======
41
42 ZLAROT applies a (Givens) rotation to two adjacent rows or
43 columns, where one element of the first and/or last column/row
44 may be a separate variable. This is specifically indended
45 for use on matrices stored in some format other than GE, so
46 that elements of the matrix may be used or modified for which
47 no array element is provided.
48
49 One example is a symmetric matrix in SB format (bandwidth=4), for
50
51 which UPLO='L': Two adjacent rows will have the format:
52
53 row j: * * * * * . . . .
54 row j+1: * * * * * . . . .
55
56 '*' indicates elements for which storage is provided,
57 '.' indicates elements for which no storage is provided, but
58 are not necessarily zero; their values are determined by
59 symmetry. ' ' indicates elements which are necessarily zero,
60 and have no storage provided.
61
62 Those columns which have two '*'s can be handled by DROT.
63 Those columns which have no '*'s can be ignored, since as long
64 as the Givens rotations are carefully applied to preserve
65 symmetry, their values are determined.
66 Those columns which have one '*' have to be handled separately,
67 by using separate variables "p" and "q":
68
69 row j: * * * * * p . . .
70 row j+1: q * * * * * . . . .
71
72 The element p would have to be set correctly, then that column
73 is rotated, setting p to its new value. The next call to
74 ZLAROT would rotate columns j and j+1, using p, and restore
75 symmetry. The element q would start out being zero, and be
76 made non-zero by the rotation. Later, rotations would presumably
77
78 be chosen to zero q out.
79
80 Typical Calling Sequences: rotating the i-th and (i+1)-st rows.
81 ------- ------- ---------
82
83 General dense matrix:
84
85 CALL ZLAROT(.TRUE.,.FALSE.,.FALSE., N, C,S,
86 A(i,1),LDA, DUMMY, DUMMY)
87
88 General banded matrix in GB format:
89
90 j = MAX(1, i-KL )
91 NL = MIN( N, i+KU+1 ) + 1-j
92 CALL ZLAROT( .TRUE., i-KL.GE.1, i+KU.LT.N, NL, C,S,
93 A(KU+i+1-j,j),LDA-1, XLEFT, XRIGHT )
94
95 [ note that i+1-j is just MIN(i,KL+1) ]
96
97 Symmetric banded matrix in SY format, bandwidth K,
98 lower triangle only:
99
100 j = MAX(1, i-K )
101 NL = MIN( K+1, i ) + 1
102 CALL ZLAROT( .TRUE., i-K.GE.1, .TRUE., NL, C,S,
103 A(i,j), LDA, XLEFT, XRIGHT )
104
105 Same, but upper triangle only:
106
107 NL = MIN( K+1, N-i ) + 1
108 CALL ZLAROT( .TRUE., .TRUE., i+K.LT.N, NL, C,S,
109 A(i,i), LDA, XLEFT, XRIGHT )
110
111 Symmetric banded matrix in SB format, bandwidth K,
112 lower triangle only:
113
114 [ same as for SY, except:]
115 . . . .
116 A(i+1-j,j), LDA-1, XLEFT, XRIGHT )
117
118 [ note that i+1-j is just MIN(i,K+1) ]
119
120 Same, but upper triangle only:
121 . . .
122 A(K+1,i), LDA-1, XLEFT, XRIGHT )
123
124 Rotating columns is just the transpose of rotating rows, except
125
126 for GB and SB: (rotating columns i and i+1)
127
128 GB:
129 j = MAX(1, i-KU )
130 NL = MIN( N, i+KL+1 ) + 1-j
131 CALL ZLAROT( .TRUE., i-KU.GE.1, i+KL.LT.N, NL, C,S,
132 A(KU+j+1-i,i),LDA-1, XTOP, XBOTTM )
133
134 [note that KU+j+1-i is just MAX(1,KU+2-i)]
135
136 SB: (upper triangle)
137
138 . . . . . .
139 A(K+j+1-i,i),LDA-1, XTOP, XBOTTM )
140
141 SB: (lower triangle)
142
143 . . . . . .
144 A(1,i),LDA-1, XTOP, XBOTTM )
145
146 Arguments
147 =========
148
149 LROWS - LOGICAL
150 If .TRUE., then ZLAROT will rotate two rows. If .FALSE.,
151 then it will rotate two columns.
152 Not modified.
153
154 LLEFT - LOGICAL
155 If .TRUE., then XLEFT will be used instead of the
156 corresponding element of A for the first element in the
157 second row (if LROWS=.FALSE.) or column (if LROWS=.TRUE.)
158 If .FALSE., then the corresponding element of A will be
159 used.
160 Not modified.
161
162 LRIGHT - LOGICAL
163 If .TRUE., then XRIGHT will be used instead of the
164 corresponding element of A for the last element in the
165 first row (if LROWS=.FALSE.) or column (if LROWS=.TRUE.) If
166
167 .FALSE., then the corresponding element of A will be used.
168 Not modified.
169
170 NL - INTEGER
171 The length of the rows (if LROWS=.TRUE.) or columns (if
172 LROWS=.FALSE.) to be rotated. If XLEFT and/or XRIGHT are
173 used, the columns/rows they are in should be included in
174 NL, e.g., if LLEFT = LRIGHT = .TRUE., then NL must be at
175 least 2. The number of rows/columns to be rotated
176 exclusive of those involving XLEFT and/or XRIGHT may
177 not be negative, i.e., NL minus how many of LLEFT and
178 LRIGHT are .TRUE. must be at least zero; if not, XERBLA
179 will be called.
180 Not modified.
181
182 C, S - COMPLEX*16
183 Specify the Givens rotation to be applied. If LROWS is
184 true, then the matrix ( c s )
185 ( _ _ )
186 (-s c ) is applied from the left;
187 if false, then the transpose (not conjugated) thereof is
188 applied from the right. Note that in contrast to the
189 output of ZROTG or to most versions of ZROT, both C and S
190 are complex. For a Givens rotation, |C|**2 + |S|**2 should
191
192 be 1, but this is not checked.
193 Not modified.
194
195 A - COMPLEX*16 array.
196 The array containing the rows/columns to be rotated. The
197 first element of A should be the upper left element to
198 be rotated.
199 Read and modified.
200
201 LDA - INTEGER
202 The "effective" leading dimension of A. If A contains
203 a matrix stored in GE, HE, or SY format, then this is just
204 the leading dimension of A as dimensioned in the calling
205 routine. If A contains a matrix stored in band (GB, HB, or
206
207 SB) format, then this should be *one less* than the leading
208
209 dimension used in the calling routine. Thus, if A were
210 dimensioned A(LDA,*) in ZLAROT, then A(1,j) would be the
211 j-th element in the first of the two rows to be rotated,
212 and A(2,j) would be the j-th in the second, regardless of
213 how the array may be stored in the calling routine. [A
214 cannot, however, actually be dimensioned thus, since for
215 band format, the row number may exceed LDA, which is not
216 legal FORTRAN.]
217 If LROWS=.TRUE., then LDA must be at least 1, otherwise
218 it must be at least NL minus the number of .TRUE. values
219 in XLEFT and XRIGHT.
220 Not modified.
221
222 XLEFT - COMPLEX*16
223 If LLEFT is .TRUE., then XLEFT will be used and modified
224 instead of A(2,1) (if LROWS=.TRUE.) or A(1,2)
225 (if LROWS=.FALSE.).
226 Read and modified.
227
228 XRIGHT - COMPLEX*16
229 If LRIGHT is .TRUE., then XRIGHT will be used and modified
230 instead of A(1,NL) (if LROWS=.TRUE.) or A(NL,1)
231 (if LROWS=.FALSE.).
232 Read and modified.
233
234 =====================================================================
235
236
237
238 Set up indices, arrays for ends
239
240 Parameter adjustments */
241 --a;
242
243 /* Function Body */
244 if (*lrows) {
245 iinc = *lda;
246 inext = 1;
247 } else {
248 iinc = 1;
249 inext = *lda;
250 }
251
252 if (*lleft) {
253 nt = 1;
254 ix = iinc + 1;
255 iy = *lda + 2;
256 xt[0].r = a[1].r, xt[0].i = a[1].i;
257 yt[0].r = xleft->r, yt[0].i = xleft->i;
258 } else {
259 nt = 0;
260 ix = 1;
261 iy = inext + 1;
262 }
263
264 if (*lright) {
265 iyt = inext + 1 + (*nl - 1) * iinc;
266 ++nt;
267 i__1 = nt - 1;
268 xt[i__1].r = xright->r, xt[i__1].i = xright->i;
269 i__1 = nt - 1;
270 i__2 = iyt;
271 yt[i__1].r = a[i__2].r, yt[i__1].i = a[i__2].i;
272 }
273
274 /* Check for errors */
275
276 if (*nl < nt) {
277 xerbla_("ZLAROT", &c__4);
278 return 0;
279 }
280 if (*lda <= 0 || ! (*lrows) && *lda < *nl - nt) {
281 xerbla_("ZLAROT", &c__8);
282 return 0;
283 }
284
285 /* Rotate
286
287 ZROT( NL-NT, A(IX),IINC, A(IY),IINC, C, S ) with complex C, S */
288
289 i__1 = *nl - nt - 1;
290 for (j = 0; j <= i__1; ++j) {
291 i__2 = ix + j * iinc;
292 z__2.r = c->r * a[i__2].r - c->i * a[i__2].i, z__2.i = c->r * a[i__2]
293 .i + c->i * a[i__2].r;
294 i__3 = iy + j * iinc;
295 z__3.r = s->r * a[i__3].r - s->i * a[i__3].i, z__3.i = s->r * a[i__3]
296 .i + s->i * a[i__3].r;
297 z__1.r = z__2.r + z__3.r, z__1.i = z__2.i + z__3.i;
298 tempx.r = z__1.r, tempx.i = z__1.i;
299 i__2 = iy + j * iinc;
300 d_cnjg(&z__4, s);
301 z__3.r = -z__4.r, z__3.i = -z__4.i;
302 i__3 = ix + j * iinc;
303 z__2.r = z__3.r * a[i__3].r - z__3.i * a[i__3].i, z__2.i = z__3.r * a[
304 i__3].i + z__3.i * a[i__3].r;
305 d_cnjg(&z__6, c);
306 i__4 = iy + j * iinc;
307 z__5.r = z__6.r * a[i__4].r - z__6.i * a[i__4].i, z__5.i = z__6.r * a[
308 i__4].i + z__6.i * a[i__4].r;
309 z__1.r = z__2.r + z__5.r, z__1.i = z__2.i + z__5.i;
310 a[i__2].r = z__1.r, a[i__2].i = z__1.i;
311 i__2 = ix + j * iinc;
312 a[i__2].r = tempx.r, a[i__2].i = tempx.i;
313 /* L10: */
314 }
315
316 /* ZROT( NT, XT,1, YT,1, C, S ) with complex C, S */
317
318 i__1 = nt;
319 for (j = 1; j <= i__1; ++j) {
320 i__2 = j - 1;
321 z__2.r = c->r * xt[i__2].r - c->i * xt[i__2].i, z__2.i = c->r * xt[
322 i__2].i + c->i * xt[i__2].r;
323 i__3 = j - 1;
324 z__3.r = s->r * yt[i__3].r - s->i * yt[i__3].i, z__3.i = s->r * yt[
325 i__3].i + s->i * yt[i__3].r;
326 z__1.r = z__2.r + z__3.r, z__1.i = z__2.i + z__3.i;
327 tempx.r = z__1.r, tempx.i = z__1.i;
328 i__2 = j - 1;
329 d_cnjg(&z__4, s);
330 z__3.r = -z__4.r, z__3.i = -z__4.i;
331 i__3 = j - 1;
332 z__2.r = z__3.r * xt[i__3].r - z__3.i * xt[i__3].i, z__2.i = z__3.r *
333 xt[i__3].i + z__3.i * xt[i__3].r;
334 d_cnjg(&z__6, c);
335 i__4 = j - 1;
336 z__5.r = z__6.r * yt[i__4].r - z__6.i * yt[i__4].i, z__5.i = z__6.r *
337 yt[i__4].i + z__6.i * yt[i__4].r;
338 z__1.r = z__2.r + z__5.r, z__1.i = z__2.i + z__5.i;
339 yt[i__2].r = z__1.r, yt[i__2].i = z__1.i;
340 i__2 = j - 1;
341 xt[i__2].r = tempx.r, xt[i__2].i = tempx.i;
342 /* L20: */
343 }
344
345 /* Stuff values back into XLEFT, XRIGHT, etc. */
346
347 if (*lleft) {
348 a[1].r = xt[0].r, a[1].i = xt[0].i;
349 xleft->r = yt[0].r, xleft->i = yt[0].i;
350 }
351
352 if (*lright) {
353 i__1 = nt - 1;
354 xright->r = xt[i__1].r, xright->i = xt[i__1].i;
355 i__1 = iyt;
356 i__2 = nt - 1;
357 a[i__1].r = yt[i__2].r, a[i__1].i = yt[i__2].i;
358 }
359
360 return 0;
361
362 /* End of ZLAROT */
363
364 } /* zlarot_ */
365
366