1 SUBROUTINE ZLARF( SIDE, M, N, V, INCV, TAU, C, LDC, WORK )
2 IMPLICIT NONE
3 *
4 * -- LAPACK auxiliary routine (version 3.3.1) --
5 * -- LAPACK is a software package provided by Univ. of Tennessee, --
6 * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
7 * -- April 2011 --
8 *
9 * .. Scalar Arguments ..
10 CHARACTER SIDE
11 INTEGER INCV, LDC, M, N
12 COMPLEX*16 TAU
13 * ..
14 * .. Array Arguments ..
15 COMPLEX*16 C( LDC, * ), V( * ), WORK( * )
16 * ..
17 *
18 * Purpose
19 * =======
20 *
21 * ZLARF applies a complex elementary reflector H to a complex M-by-N
22 * matrix C, from either the left or the right. H is represented in the
23 * form
24 *
25 * H = I - tau * v * v**H
26 *
27 * where tau is a complex scalar and v is a complex vector.
28 *
29 * If tau = 0, then H is taken to be the unit matrix.
30 *
31 * To apply H**H, supply conjg(tau) instead
32 * tau.
33 *
34 * Arguments
35 * =========
36 *
37 * SIDE (input) CHARACTER*1
38 * = 'L': form H * C
39 * = 'R': form C * H
40 *
41 * M (input) INTEGER
42 * The number of rows of the matrix C.
43 *
44 * N (input) INTEGER
45 * The number of columns of the matrix C.
46 *
47 * V (input) COMPLEX*16 array, dimension
48 * (1 + (M-1)*abs(INCV)) if SIDE = 'L'
49 * or (1 + (N-1)*abs(INCV)) if SIDE = 'R'
50 * The vector v in the representation of H. V is not used if
51 * TAU = 0.
52 *
53 * INCV (input) INTEGER
54 * The increment between elements of v. INCV <> 0.
55 *
56 * TAU (input) COMPLEX*16
57 * The value tau in the representation of H.
58 *
59 * C (input/output) COMPLEX*16 array, dimension (LDC,N)
60 * On entry, the M-by-N matrix C.
61 * On exit, C is overwritten by the matrix H * C if SIDE = 'L',
62 * or C * H if SIDE = 'R'.
63 *
64 * LDC (input) INTEGER
65 * The leading dimension of the array C. LDC >= max(1,M).
66 *
67 * WORK (workspace) COMPLEX*16 array, dimension
68 * (N) if SIDE = 'L'
69 * or (M) if SIDE = 'R'
70 *
71 * =====================================================================
72 *
73 * .. Parameters ..
74 COMPLEX*16 ONE, ZERO
75 PARAMETER ( ONE = ( 1.0D+0, 0.0D+0 ),
76 $ ZERO = ( 0.0D+0, 0.0D+0 ) )
77 * ..
78 * .. Local Scalars ..
79 LOGICAL APPLYLEFT
80 INTEGER I, LASTV, LASTC
81 * ..
82 * .. External Subroutines ..
83 EXTERNAL ZGEMV, ZGERC
84 * ..
85 * .. External Functions ..
86 LOGICAL LSAME
87 INTEGER ILAZLR, ILAZLC
88 EXTERNAL LSAME, ILAZLR, ILAZLC
89 * ..
90 * .. Executable Statements ..
91 *
92 APPLYLEFT = LSAME( SIDE, 'L' )
93 LASTV = 0
94 LASTC = 0
95 IF( TAU.NE.ZERO ) THEN
96 ! Set up variables for scanning V. LASTV begins pointing to the end
97 ! of V.
98 IF( APPLYLEFT ) THEN
99 LASTV = M
100 ELSE
101 LASTV = N
102 END IF
103 IF( INCV.GT.0 ) THEN
104 I = 1 + (LASTV-1) * INCV
105 ELSE
106 I = 1
107 END IF
108 ! Look for the last non-zero row in V.
109 DO WHILE( LASTV.GT.0 .AND. V( I ).EQ.ZERO )
110 LASTV = LASTV - 1
111 I = I - INCV
112 END DO
113 IF( APPLYLEFT ) THEN
114 ! Scan for the last non-zero column in C(1:lastv,:).
115 LASTC = ILAZLC(LASTV, N, C, LDC)
116 ELSE
117 ! Scan for the last non-zero row in C(:,1:lastv).
118 LASTC = ILAZLR(M, LASTV, C, LDC)
119 END IF
120 END IF
121 ! Note that lastc.eq.0 renders the BLAS operations null; no special
122 ! case is needed at this level.
123 IF( APPLYLEFT ) THEN
124 *
125 * Form H * C
126 *
127 IF( LASTV.GT.0 ) THEN
128 *
129 * w(1:lastc,1) := C(1:lastv,1:lastc)**H * v(1:lastv,1)
130 *
131 CALL ZGEMV( 'Conjugate transpose', LASTV, LASTC, ONE,
132 $ C, LDC, V, INCV, ZERO, WORK, 1 )
133 *
134 * C(1:lastv,1:lastc) := C(...) - v(1:lastv,1) * w(1:lastc,1)**H
135 *
136 CALL ZGERC( LASTV, LASTC, -TAU, V, INCV, WORK, 1, C, LDC )
137 END IF
138 ELSE
139 *
140 * Form C * H
141 *
142 IF( LASTV.GT.0 ) THEN
143 *
144 * w(1:lastc,1) := C(1:lastc,1:lastv) * v(1:lastv,1)
145 *
146 CALL ZGEMV( 'No transpose', LASTC, LASTV, ONE, C, LDC,
147 $ V, INCV, ZERO, WORK, 1 )
148 *
149 * C(1:lastc,1:lastv) := C(...) - w(1:lastc,1) * v(1:lastv,1)**H
150 *
151 CALL ZGERC( LASTC, LASTV, -TAU, WORK, 1, V, INCV, C, LDC )
152 END IF
153 END IF
154 RETURN
155 *
156 * End of ZLARF
157 *
158 END
2 IMPLICIT NONE
3 *
4 * -- LAPACK auxiliary routine (version 3.3.1) --
5 * -- LAPACK is a software package provided by Univ. of Tennessee, --
6 * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
7 * -- April 2011 --
8 *
9 * .. Scalar Arguments ..
10 CHARACTER SIDE
11 INTEGER INCV, LDC, M, N
12 COMPLEX*16 TAU
13 * ..
14 * .. Array Arguments ..
15 COMPLEX*16 C( LDC, * ), V( * ), WORK( * )
16 * ..
17 *
18 * Purpose
19 * =======
20 *
21 * ZLARF applies a complex elementary reflector H to a complex M-by-N
22 * matrix C, from either the left or the right. H is represented in the
23 * form
24 *
25 * H = I - tau * v * v**H
26 *
27 * where tau is a complex scalar and v is a complex vector.
28 *
29 * If tau = 0, then H is taken to be the unit matrix.
30 *
31 * To apply H**H, supply conjg(tau) instead
32 * tau.
33 *
34 * Arguments
35 * =========
36 *
37 * SIDE (input) CHARACTER*1
38 * = 'L': form H * C
39 * = 'R': form C * H
40 *
41 * M (input) INTEGER
42 * The number of rows of the matrix C.
43 *
44 * N (input) INTEGER
45 * The number of columns of the matrix C.
46 *
47 * V (input) COMPLEX*16 array, dimension
48 * (1 + (M-1)*abs(INCV)) if SIDE = 'L'
49 * or (1 + (N-1)*abs(INCV)) if SIDE = 'R'
50 * The vector v in the representation of H. V is not used if
51 * TAU = 0.
52 *
53 * INCV (input) INTEGER
54 * The increment between elements of v. INCV <> 0.
55 *
56 * TAU (input) COMPLEX*16
57 * The value tau in the representation of H.
58 *
59 * C (input/output) COMPLEX*16 array, dimension (LDC,N)
60 * On entry, the M-by-N matrix C.
61 * On exit, C is overwritten by the matrix H * C if SIDE = 'L',
62 * or C * H if SIDE = 'R'.
63 *
64 * LDC (input) INTEGER
65 * The leading dimension of the array C. LDC >= max(1,M).
66 *
67 * WORK (workspace) COMPLEX*16 array, dimension
68 * (N) if SIDE = 'L'
69 * or (M) if SIDE = 'R'
70 *
71 * =====================================================================
72 *
73 * .. Parameters ..
74 COMPLEX*16 ONE, ZERO
75 PARAMETER ( ONE = ( 1.0D+0, 0.0D+0 ),
76 $ ZERO = ( 0.0D+0, 0.0D+0 ) )
77 * ..
78 * .. Local Scalars ..
79 LOGICAL APPLYLEFT
80 INTEGER I, LASTV, LASTC
81 * ..
82 * .. External Subroutines ..
83 EXTERNAL ZGEMV, ZGERC
84 * ..
85 * .. External Functions ..
86 LOGICAL LSAME
87 INTEGER ILAZLR, ILAZLC
88 EXTERNAL LSAME, ILAZLR, ILAZLC
89 * ..
90 * .. Executable Statements ..
91 *
92 APPLYLEFT = LSAME( SIDE, 'L' )
93 LASTV = 0
94 LASTC = 0
95 IF( TAU.NE.ZERO ) THEN
96 ! Set up variables for scanning V. LASTV begins pointing to the end
97 ! of V.
98 IF( APPLYLEFT ) THEN
99 LASTV = M
100 ELSE
101 LASTV = N
102 END IF
103 IF( INCV.GT.0 ) THEN
104 I = 1 + (LASTV-1) * INCV
105 ELSE
106 I = 1
107 END IF
108 ! Look for the last non-zero row in V.
109 DO WHILE( LASTV.GT.0 .AND. V( I ).EQ.ZERO )
110 LASTV = LASTV - 1
111 I = I - INCV
112 END DO
113 IF( APPLYLEFT ) THEN
114 ! Scan for the last non-zero column in C(1:lastv,:).
115 LASTC = ILAZLC(LASTV, N, C, LDC)
116 ELSE
117 ! Scan for the last non-zero row in C(:,1:lastv).
118 LASTC = ILAZLR(M, LASTV, C, LDC)
119 END IF
120 END IF
121 ! Note that lastc.eq.0 renders the BLAS operations null; no special
122 ! case is needed at this level.
123 IF( APPLYLEFT ) THEN
124 *
125 * Form H * C
126 *
127 IF( LASTV.GT.0 ) THEN
128 *
129 * w(1:lastc,1) := C(1:lastv,1:lastc)**H * v(1:lastv,1)
130 *
131 CALL ZGEMV( 'Conjugate transpose', LASTV, LASTC, ONE,
132 $ C, LDC, V, INCV, ZERO, WORK, 1 )
133 *
134 * C(1:lastv,1:lastc) := C(...) - v(1:lastv,1) * w(1:lastc,1)**H
135 *
136 CALL ZGERC( LASTV, LASTC, -TAU, V, INCV, WORK, 1, C, LDC )
137 END IF
138 ELSE
139 *
140 * Form C * H
141 *
142 IF( LASTV.GT.0 ) THEN
143 *
144 * w(1:lastc,1) := C(1:lastc,1:lastv) * v(1:lastv,1)
145 *
146 CALL ZGEMV( 'No transpose', LASTC, LASTV, ONE, C, LDC,
147 $ V, INCV, ZERO, WORK, 1 )
148 *
149 * C(1:lastc,1:lastv) := C(...) - w(1:lastc,1) * v(1:lastv,1)**H
150 *
151 CALL ZGERC( LASTC, LASTV, -TAU, WORK, 1, V, INCV, C, LDC )
152 END IF
153 END IF
154 RETURN
155 *
156 * End of ZLARF
157 *
158 END