1: SUBROUTINE DLASR( SIDE, PIVOT, DIRECT, M, N, C, S, A, LDA )
2: *
3: * -- LAPACK auxiliary routine (version 3.2) --
4: * -- LAPACK is a software package provided by Univ. of Tennessee, --
5: * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
6: * November 2006
7: *
8: * .. Scalar Arguments ..
9: CHARACTER DIRECT, PIVOT, SIDE
10: INTEGER LDA, M, N
11: * ..
12: * .. Array Arguments ..
13: DOUBLE PRECISION A( LDA, * ), C( * ), S( * )
14: * ..
15: *
16: * Purpose
17: * =======
18: *
19: * DLASR applies a sequence of plane rotations to a real matrix A,
20: * from either the left or the right.
21: *
22: * When SIDE = 'L', the transformation takes the form
23: *
24: * A := P*A
25: *
26: * and when SIDE = 'R', the transformation takes the form
27: *
28: * A := A*P**T
29: *
30: * where P is an orthogonal matrix consisting of a sequence of z plane
31: * rotations, with z = M when SIDE = 'L' and z = N when SIDE = 'R',
32: * and P**T is the transpose of P.
33: *
34: * When DIRECT = 'F' (Forward sequence), then
35: *
36: * P = P(z-1) * ... * P(2) * P(1)
37: *
38: * and when DIRECT = 'B' (Backward sequence), then
39: *
40: * P = P(1) * P(2) * ... * P(z-1)
41: *
42: * where P(k) is a plane rotation matrix defined by the 2-by-2 rotation
43: *
44: * R(k) = ( c(k) s(k) )
45: * = ( -s(k) c(k) ).
46: *
47: * When PIVOT = 'V' (Variable pivot), the rotation is performed
48: * for the plane (k,k+1), i.e., P(k) has the form
49: *
50: * P(k) = ( 1 )
51: * ( ... )
52: * ( 1 )
53: * ( c(k) s(k) )
54: * ( -s(k) c(k) )
55: * ( 1 )
56: * ( ... )
57: * ( 1 )
58: *
59: * where R(k) appears as a rank-2 modification to the identity matrix in
60: * rows and columns k and k+1.
61: *
62: * When PIVOT = 'T' (Top pivot), the rotation is performed for the
63: * plane (1,k+1), so P(k) has the form
64: *
65: * P(k) = ( c(k) s(k) )
66: * ( 1 )
67: * ( ... )
68: * ( 1 )
69: * ( -s(k) c(k) )
70: * ( 1 )
71: * ( ... )
72: * ( 1 )
73: *
74: * where R(k) appears in rows and columns 1 and k+1.
75: *
76: * Similarly, when PIVOT = 'B' (Bottom pivot), the rotation is
77: * performed for the plane (k,z), giving P(k) the form
78: *
79: * P(k) = ( 1 )
80: * ( ... )
81: * ( 1 )
82: * ( c(k) s(k) )
83: * ( 1 )
84: * ( ... )
85: * ( 1 )
86: * ( -s(k) c(k) )
87: *
88: * where R(k) appears in rows and columns k and z. The rotations are
89: * performed without ever forming P(k) explicitly.
90: *
91: * Arguments
92: * =========
93: *
94: * SIDE (input) CHARACTER*1
95: * Specifies whether the plane rotation matrix P is applied to
96: * A on the left or the right.
97: * = 'L': Left, compute A := P*A
98: * = 'R': Right, compute A:= A*P**T
99: *
100: * PIVOT (input) CHARACTER*1
101: * Specifies the plane for which P(k) is a plane rotation
102: * matrix.
103: * = 'V': Variable pivot, the plane (k,k+1)
104: * = 'T': Top pivot, the plane (1,k+1)
105: * = 'B': Bottom pivot, the plane (k,z)
106: *
107: * DIRECT (input) CHARACTER*1
108: * Specifies whether P is a forward or backward sequence of
109: * plane rotations.
110: * = 'F': Forward, P = P(z-1)*...*P(2)*P(1)
111: * = 'B': Backward, P = P(1)*P(2)*...*P(z-1)
112: *
113: * M (input) INTEGER
114: * The number of rows of the matrix A. If m <= 1, an immediate
115: * return is effected.
116: *
117: * N (input) INTEGER
118: * The number of columns of the matrix A. If n <= 1, an
119: * immediate return is effected.
120: *
121: * C (input) DOUBLE PRECISION array, dimension
122: * (M-1) if SIDE = 'L'
123: * (N-1) if SIDE = 'R'
124: * The cosines c(k) of the plane rotations.
125: *
126: * S (input) DOUBLE PRECISION array, dimension
127: * (M-1) if SIDE = 'L'
128: * (N-1) if SIDE = 'R'
129: * The sines s(k) of the plane rotations. The 2-by-2 plane
130: * rotation part of the matrix P(k), R(k), has the form
131: * R(k) = ( c(k) s(k) )
132: * ( -s(k) c(k) ).
133: *
134: * A (input/output) DOUBLE PRECISION array, dimension (LDA,N)
135: * The M-by-N matrix A. On exit, A is overwritten by P*A if
136: * SIDE = 'R' or by A*P**T if SIDE = 'L'.
137: *
138: * LDA (input) INTEGER
139: * The leading dimension of the array A. LDA >= max(1,M).
140: *
141: * =====================================================================
142: *
143: * .. Parameters ..
144: DOUBLE PRECISION ONE, ZERO
145: PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 )
146: * ..
147: * .. Local Scalars ..
148: INTEGER I, INFO, J
149: DOUBLE PRECISION CTEMP, STEMP, TEMP
150: * ..
151: * .. External Functions ..
152: LOGICAL LSAME
153: EXTERNAL LSAME
154: * ..
155: * .. External Subroutines ..
156: EXTERNAL XERBLA
157: * ..
158: * .. Intrinsic Functions ..
159: INTRINSIC MAX
160: * ..
161: * .. Executable Statements ..
162: *
163: * Test the input parameters
164: *
165: INFO = 0
166: IF( .NOT.( LSAME( SIDE, 'L' ) .OR. LSAME( SIDE, 'R' ) ) ) THEN
167: INFO = 1
168: ELSE IF( .NOT.( LSAME( PIVOT, 'V' ) .OR. LSAME( PIVOT,
169: $ 'T' ) .OR. LSAME( PIVOT, 'B' ) ) ) THEN
170: INFO = 2
171: ELSE IF( .NOT.( LSAME( DIRECT, 'F' ) .OR. LSAME( DIRECT, 'B' ) ) )
172: $ THEN
173: INFO = 3
174: ELSE IF( M.LT.0 ) THEN
175: INFO = 4
176: ELSE IF( N.LT.0 ) THEN
177: INFO = 5
178: ELSE IF( LDA.LT.MAX( 1, M ) ) THEN
179: INFO = 9
180: END IF
181: IF( INFO.NE.0 ) THEN
182: CALL XERBLA( 'DLASR ', INFO )
183: RETURN
184: END IF
185: *
186: * Quick return if possible
187: *
188: IF( ( M.EQ.0 ) .OR. ( N.EQ.0 ) )
189: $ RETURN
190: IF( LSAME( SIDE, 'L' ) ) THEN
191: *
192: * Form P * A
193: *
194: IF( LSAME( PIVOT, 'V' ) ) THEN
195: IF( LSAME( DIRECT, 'F' ) ) THEN
196: DO 20 J = 1, M - 1
197: CTEMP = C( J )
198: STEMP = S( J )
199: IF( ( CTEMP.NE.ONE ) .OR. ( STEMP.NE.ZERO ) ) THEN
200: DO 10 I = 1, N
201: TEMP = A( J+1, I )
202: A( J+1, I ) = CTEMP*TEMP - STEMP*A( J, I )
203: A( J, I ) = STEMP*TEMP + CTEMP*A( J, I )
204: 10 CONTINUE
205: END IF
206: 20 CONTINUE
207: ELSE IF( LSAME( DIRECT, 'B' ) ) THEN
208: DO 40 J = M - 1, 1, -1
209: CTEMP = C( J )
210: STEMP = S( J )
211: IF( ( CTEMP.NE.ONE ) .OR. ( STEMP.NE.ZERO ) ) THEN
212: DO 30 I = 1, N
213: TEMP = A( J+1, I )
214: A( J+1, I ) = CTEMP*TEMP - STEMP*A( J, I )
215: A( J, I ) = STEMP*TEMP + CTEMP*A( J, I )
216: 30 CONTINUE
217: END IF
218: 40 CONTINUE
219: END IF
220: ELSE IF( LSAME( PIVOT, 'T' ) ) THEN
221: IF( LSAME( DIRECT, 'F' ) ) THEN
222: DO 60 J = 2, M
223: CTEMP = C( J-1 )
224: STEMP = S( J-1 )
225: IF( ( CTEMP.NE.ONE ) .OR. ( STEMP.NE.ZERO ) ) THEN
226: DO 50 I = 1, N
227: TEMP = A( J, I )
228: A( J, I ) = CTEMP*TEMP - STEMP*A( 1, I )
229: A( 1, I ) = STEMP*TEMP + CTEMP*A( 1, I )
230: 50 CONTINUE
231: END IF
232: 60 CONTINUE
233: ELSE IF( LSAME( DIRECT, 'B' ) ) THEN
234: DO 80 J = M, 2, -1
235: CTEMP = C( J-1 )
236: STEMP = S( J-1 )
237: IF( ( CTEMP.NE.ONE ) .OR. ( STEMP.NE.ZERO ) ) THEN
238: DO 70 I = 1, N
239: TEMP = A( J, I )
240: A( J, I ) = CTEMP*TEMP - STEMP*A( 1, I )
241: A( 1, I ) = STEMP*TEMP + CTEMP*A( 1, I )
242: 70 CONTINUE
243: END IF
244: 80 CONTINUE
245: END IF
246: ELSE IF( LSAME( PIVOT, 'B' ) ) THEN
247: IF( LSAME( DIRECT, 'F' ) ) THEN
248: DO 100 J = 1, M - 1
249: CTEMP = C( J )
250: STEMP = S( J )
251: IF( ( CTEMP.NE.ONE ) .OR. ( STEMP.NE.ZERO ) ) THEN
252: DO 90 I = 1, N
253: TEMP = A( J, I )
254: A( J, I ) = STEMP*A( M, I ) + CTEMP*TEMP
255: A( M, I ) = CTEMP*A( M, I ) - STEMP*TEMP
256: 90 CONTINUE
257: END IF
258: 100 CONTINUE
259: ELSE IF( LSAME( DIRECT, 'B' ) ) THEN
260: DO 120 J = M - 1, 1, -1
261: CTEMP = C( J )
262: STEMP = S( J )
263: IF( ( CTEMP.NE.ONE ) .OR. ( STEMP.NE.ZERO ) ) THEN
264: DO 110 I = 1, N
265: TEMP = A( J, I )
266: A( J, I ) = STEMP*A( M, I ) + CTEMP*TEMP
267: A( M, I ) = CTEMP*A( M, I ) - STEMP*TEMP
268: 110 CONTINUE
269: END IF
270: 120 CONTINUE
271: END IF
272: END IF
273: ELSE IF( LSAME( SIDE, 'R' ) ) THEN
274: *
275: * Form A * P'
276: *
277: IF( LSAME( PIVOT, 'V' ) ) THEN
278: IF( LSAME( DIRECT, 'F' ) ) THEN
279: DO 140 J = 1, N - 1
280: CTEMP = C( J )
281: STEMP = S( J )
282: IF( ( CTEMP.NE.ONE ) .OR. ( STEMP.NE.ZERO ) ) THEN
283: DO 130 I = 1, M
284: TEMP = A( I, J+1 )
285: A( I, J+1 ) = CTEMP*TEMP - STEMP*A( I, J )
286: A( I, J ) = STEMP*TEMP + CTEMP*A( I, J )
287: 130 CONTINUE
288: END IF
289: 140 CONTINUE
290: ELSE IF( LSAME( DIRECT, 'B' ) ) THEN
291: DO 160 J = N - 1, 1, -1
292: CTEMP = C( J )
293: STEMP = S( J )
294: IF( ( CTEMP.NE.ONE ) .OR. ( STEMP.NE.ZERO ) ) THEN
295: DO 150 I = 1, M
296: TEMP = A( I, J+1 )
297: A( I, J+1 ) = CTEMP*TEMP - STEMP*A( I, J )
298: A( I, J ) = STEMP*TEMP + CTEMP*A( I, J )
299: 150 CONTINUE
300: END IF
301: 160 CONTINUE
302: END IF
303: ELSE IF( LSAME( PIVOT, 'T' ) ) THEN
304: IF( LSAME( DIRECT, 'F' ) ) THEN
305: DO 180 J = 2, N
306: CTEMP = C( J-1 )
307: STEMP = S( J-1 )
308: IF( ( CTEMP.NE.ONE ) .OR. ( STEMP.NE.ZERO ) ) THEN
309: DO 170 I = 1, M
310: TEMP = A( I, J )
311: A( I, J ) = CTEMP*TEMP - STEMP*A( I, 1 )
312: A( I, 1 ) = STEMP*TEMP + CTEMP*A( I, 1 )
313: 170 CONTINUE
314: END IF
315: 180 CONTINUE
316: ELSE IF( LSAME( DIRECT, 'B' ) ) THEN
317: DO 200 J = N, 2, -1
318: CTEMP = C( J-1 )
319: STEMP = S( J-1 )
320: IF( ( CTEMP.NE.ONE ) .OR. ( STEMP.NE.ZERO ) ) THEN
321: DO 190 I = 1, M
322: TEMP = A( I, J )
323: A( I, J ) = CTEMP*TEMP - STEMP*A( I, 1 )
324: A( I, 1 ) = STEMP*TEMP + CTEMP*A( I, 1 )
325: 190 CONTINUE
326: END IF
327: 200 CONTINUE
328: END IF
329: ELSE IF( LSAME( PIVOT, 'B' ) ) THEN
330: IF( LSAME( DIRECT, 'F' ) ) THEN
331: DO 220 J = 1, N - 1
332: CTEMP = C( J )
333: STEMP = S( J )
334: IF( ( CTEMP.NE.ONE ) .OR. ( STEMP.NE.ZERO ) ) THEN
335: DO 210 I = 1, M
336: TEMP = A( I, J )
337: A( I, J ) = STEMP*A( I, N ) + CTEMP*TEMP
338: A( I, N ) = CTEMP*A( I, N ) - STEMP*TEMP
339: 210 CONTINUE
340: END IF
341: 220 CONTINUE
342: ELSE IF( LSAME( DIRECT, 'B' ) ) THEN
343: DO 240 J = N - 1, 1, -1
344: CTEMP = C( J )
345: STEMP = S( J )
346: IF( ( CTEMP.NE.ONE ) .OR. ( STEMP.NE.ZERO ) ) THEN
347: DO 230 I = 1, M
348: TEMP = A( I, J )
349: A( I, J ) = STEMP*A( I, N ) + CTEMP*TEMP
350: A( I, N ) = CTEMP*A( I, N ) - STEMP*TEMP
351: 230 CONTINUE
352: END IF
353: 240 CONTINUE
354: END IF
355: END IF
356: END IF
357: *
358: RETURN
359: *
360: * End of DLASR
361: *
362: END
CVSweb interface <joel.bertrand@systella.fr>
![[BACK]](/cvsweb/icons/back.gif){kind=icon}
Return to dlasr.f CVS log ![[TXT]](/cvsweb/icons/text.gif){kind=icon}
![[DIR]](/cvsweb/icons/dir.gif){kind=icon}
Up to [local] / rpl / lapack / lapack