1 SUBROUTINE CHPMV(UPLO,N,ALPHA,AP,X,INCX,BETA,Y,INCY)
2 * .. Scalar Arguments ..
3 COMPLEX ALPHA,BETA
4 INTEGER INCX,INCY,N
5 CHARACTER UPLO
6 * ..
7 * .. Array Arguments ..
8 COMPLEX AP(*),X(*),Y(*)
9 * ..
10 *
11 * Purpose
12 * =======
13 *
14 * CHPMV performs the matrix-vector operation
15 *
16 * y := alpha*A*x + beta*y,
17 *
18 * where alpha and beta are scalars, x and y are n element vectors and
19 * A is an n by n hermitian matrix, supplied in packed form.
20 *
21 * Arguments
22 * ==========
23 *
24 * UPLO - CHARACTER*1.
25 * On entry, UPLO specifies whether the upper or lower
26 * triangular part of the matrix A is supplied in the packed
27 * array AP as follows:
28 *
29 * UPLO = 'U' or 'u' The upper triangular part of A is
30 * supplied in AP.
31 *
32 * UPLO = 'L' or 'l' The lower triangular part of A is
33 * supplied in AP.
34 *
35 * Unchanged on exit.
36 *
37 * N - INTEGER.
38 * On entry, N specifies the order of the matrix A.
39 * N must be at least zero.
40 * Unchanged on exit.
41 *
42 * ALPHA - COMPLEX .
43 * On entry, ALPHA specifies the scalar alpha.
44 * Unchanged on exit.
45 *
46 * AP - COMPLEX array of DIMENSION at least
47 * ( ( n*( n + 1 ) )/2 ).
48 * Before entry with UPLO = 'U' or 'u', the array AP must
49 * contain the upper triangular part of the hermitian matrix
50 * packed sequentially, column by column, so that AP( 1 )
51 * contains a( 1, 1 ), AP( 2 ) and AP( 3 ) contain a( 1, 2 )
52 * and a( 2, 2 ) respectively, and so on.
53 * Before entry with UPLO = 'L' or 'l', the array AP must
54 * contain the lower triangular part of the hermitian matrix
55 * packed sequentially, column by column, so that AP( 1 )
56 * contains a( 1, 1 ), AP( 2 ) and AP( 3 ) contain a( 2, 1 )
57 * and a( 3, 1 ) respectively, and so on.
58 * Note that the imaginary parts of the diagonal elements need
59 * not be set and are assumed to be zero.
60 * Unchanged on exit.
61 *
62 * X - COMPLEX array of dimension at least
63 * ( 1 + ( n - 1 )*abs( INCX ) ).
64 * Before entry, the incremented array X must contain the n
65 * element vector x.
66 * Unchanged on exit.
67 *
68 * INCX - INTEGER.
69 * On entry, INCX specifies the increment for the elements of
70 * X. INCX must not be zero.
71 * Unchanged on exit.
72 *
73 * BETA - COMPLEX .
74 * On entry, BETA specifies the scalar beta. When BETA is
75 * supplied as zero then Y need not be set on input.
76 * Unchanged on exit.
77 *
78 * Y - COMPLEX array of dimension at least
79 * ( 1 + ( n - 1 )*abs( INCY ) ).
80 * Before entry, the incremented array Y must contain the n
81 * element vector y. On exit, Y is overwritten by the updated
82 * vector y.
83 *
84 * INCY - INTEGER.
85 * On entry, INCY specifies the increment for the elements of
86 * Y. INCY must not be zero.
87 * Unchanged on exit.
88 *
89 * Further Details
90 * ===============
91 *
92 * Level 2 Blas routine.
93 * The vector and matrix arguments are not referenced when N = 0, or M = 0
94 *
95 * -- Written on 22-October-1986.
96 * Jack Dongarra, Argonne National Lab.
97 * Jeremy Du Croz, Nag Central Office.
98 * Sven Hammarling, Nag Central Office.
99 * Richard Hanson, Sandia National Labs.
100 *
101 * =====================================================================
102 *
103 * .. Parameters ..
104 COMPLEX ONE
105 PARAMETER (ONE= (1.0E+0,0.0E+0))
106 COMPLEX ZERO
107 PARAMETER (ZERO= (0.0E+0,0.0E+0))
108 * ..
109 * .. Local Scalars ..
110 COMPLEX TEMP1,TEMP2
111 INTEGER I,INFO,IX,IY,J,JX,JY,K,KK,KX,KY
112 * ..
113 * .. External Functions ..
114 LOGICAL LSAME
115 EXTERNAL LSAME
116 * ..
117 * .. External Subroutines ..
118 EXTERNAL XERBLA
119 * ..
120 * .. Intrinsic Functions ..
121 INTRINSIC CONJG,REAL
122 * ..
123 *
124 * Test the input parameters.
125 *
126 INFO = 0
127 IF (.NOT.LSAME(UPLO,'U') .AND. .NOT.LSAME(UPLO,'L')) THEN
128 INFO = 1
129 ELSE IF (N.LT.0) THEN
130 INFO = 2
131 ELSE IF (INCX.EQ.0) THEN
132 INFO = 6
133 ELSE IF (INCY.EQ.0) THEN
134 INFO = 9
135 END IF
136 IF (INFO.NE.0) THEN
137 CALL XERBLA('CHPMV ',INFO)
138 RETURN
139 END IF
140 *
141 * Quick return if possible.
142 *
143 IF ((N.EQ.0) .OR. ((ALPHA.EQ.ZERO).AND. (BETA.EQ.ONE))) RETURN
144 *
145 * Set up the start points in X and Y.
146 *
147 IF (INCX.GT.0) THEN
148 KX = 1
149 ELSE
150 KX = 1 - (N-1)*INCX
151 END IF
152 IF (INCY.GT.0) THEN
153 KY = 1
154 ELSE
155 KY = 1 - (N-1)*INCY
156 END IF
157 *
158 * Start the operations. In this version the elements of the array AP
159 * are accessed sequentially with one pass through AP.
160 *
161 * First form y := beta*y.
162 *
163 IF (BETA.NE.ONE) THEN
164 IF (INCY.EQ.1) THEN
165 IF (BETA.EQ.ZERO) THEN
166 DO 10 I = 1,N
167 Y(I) = ZERO
168 10 CONTINUE
169 ELSE
170 DO 20 I = 1,N
171 Y(I) = BETA*Y(I)
172 20 CONTINUE
173 END IF
174 ELSE
175 IY = KY
176 IF (BETA.EQ.ZERO) THEN
177 DO 30 I = 1,N
178 Y(IY) = ZERO
179 IY = IY + INCY
180 30 CONTINUE
181 ELSE
182 DO 40 I = 1,N
183 Y(IY) = BETA*Y(IY)
184 IY = IY + INCY
185 40 CONTINUE
186 END IF
187 END IF
188 END IF
189 IF (ALPHA.EQ.ZERO) RETURN
190 KK = 1
191 IF (LSAME(UPLO,'U')) THEN
192 *
193 * Form y when AP contains the upper triangle.
194 *
195 IF ((INCX.EQ.1) .AND. (INCY.EQ.1)) THEN
196 DO 60 J = 1,N
197 TEMP1 = ALPHA*X(J)
198 TEMP2 = ZERO
199 K = KK
200 DO 50 I = 1,J - 1
201 Y(I) = Y(I) + TEMP1*AP(K)
202 TEMP2 = TEMP2 + CONJG(AP(K))*X(I)
203 K = K + 1
204 50 CONTINUE
205 Y(J) = Y(J) + TEMP1*REAL(AP(KK+J-1)) + ALPHA*TEMP2
206 KK = KK + J
207 60 CONTINUE
208 ELSE
209 JX = KX
210 JY = KY
211 DO 80 J = 1,N
212 TEMP1 = ALPHA*X(JX)
213 TEMP2 = ZERO
214 IX = KX
215 IY = KY
216 DO 70 K = KK,KK + J - 2
217 Y(IY) = Y(IY) + TEMP1*AP(K)
218 TEMP2 = TEMP2 + CONJG(AP(K))*X(IX)
219 IX = IX + INCX
220 IY = IY + INCY
221 70 CONTINUE
222 Y(JY) = Y(JY) + TEMP1*REAL(AP(KK+J-1)) + ALPHA*TEMP2
223 JX = JX + INCX
224 JY = JY + INCY
225 KK = KK + J
226 80 CONTINUE
227 END IF
228 ELSE
229 *
230 * Form y when AP contains the lower triangle.
231 *
232 IF ((INCX.EQ.1) .AND. (INCY.EQ.1)) THEN
233 DO 100 J = 1,N
234 TEMP1 = ALPHA*X(J)
235 TEMP2 = ZERO
236 Y(J) = Y(J) + TEMP1*REAL(AP(KK))
237 K = KK + 1
238 DO 90 I = J + 1,N
239 Y(I) = Y(I) + TEMP1*AP(K)
240 TEMP2 = TEMP2 + CONJG(AP(K))*X(I)
241 K = K + 1
242 90 CONTINUE
243 Y(J) = Y(J) + ALPHA*TEMP2
244 KK = KK + (N-J+1)
245 100 CONTINUE
246 ELSE
247 JX = KX
248 JY = KY
249 DO 120 J = 1,N
250 TEMP1 = ALPHA*X(JX)
251 TEMP2 = ZERO
252 Y(JY) = Y(JY) + TEMP1*REAL(AP(KK))
253 IX = JX
254 IY = JY
255 DO 110 K = KK + 1,KK + N - J
256 IX = IX + INCX
257 IY = IY + INCY
258 Y(IY) = Y(IY) + TEMP1*AP(K)
259 TEMP2 = TEMP2 + CONJG(AP(K))*X(IX)
260 110 CONTINUE
261 Y(JY) = Y(JY) + ALPHA*TEMP2
262 JX = JX + INCX
263 JY = JY + INCY
264 KK = KK + (N-J+1)
265 120 CONTINUE
266 END IF
267 END IF
268 *
269 RETURN
270 *
271 * End of CHPMV .
272 *
273 END
2 * .. Scalar Arguments ..
3 COMPLEX ALPHA,BETA
4 INTEGER INCX,INCY,N
5 CHARACTER UPLO
6 * ..
7 * .. Array Arguments ..
8 COMPLEX AP(*),X(*),Y(*)
9 * ..
10 *
11 * Purpose
12 * =======
13 *
14 * CHPMV performs the matrix-vector operation
15 *
16 * y := alpha*A*x + beta*y,
17 *
18 * where alpha and beta are scalars, x and y are n element vectors and
19 * A is an n by n hermitian matrix, supplied in packed form.
20 *
21 * Arguments
22 * ==========
23 *
24 * UPLO - CHARACTER*1.
25 * On entry, UPLO specifies whether the upper or lower
26 * triangular part of the matrix A is supplied in the packed
27 * array AP as follows:
28 *
29 * UPLO = 'U' or 'u' The upper triangular part of A is
30 * supplied in AP.
31 *
32 * UPLO = 'L' or 'l' The lower triangular part of A is
33 * supplied in AP.
34 *
35 * Unchanged on exit.
36 *
37 * N - INTEGER.
38 * On entry, N specifies the order of the matrix A.
39 * N must be at least zero.
40 * Unchanged on exit.
41 *
42 * ALPHA - COMPLEX .
43 * On entry, ALPHA specifies the scalar alpha.
44 * Unchanged on exit.
45 *
46 * AP - COMPLEX array of DIMENSION at least
47 * ( ( n*( n + 1 ) )/2 ).
48 * Before entry with UPLO = 'U' or 'u', the array AP must
49 * contain the upper triangular part of the hermitian matrix
50 * packed sequentially, column by column, so that AP( 1 )
51 * contains a( 1, 1 ), AP( 2 ) and AP( 3 ) contain a( 1, 2 )
52 * and a( 2, 2 ) respectively, and so on.
53 * Before entry with UPLO = 'L' or 'l', the array AP must
54 * contain the lower triangular part of the hermitian matrix
55 * packed sequentially, column by column, so that AP( 1 )
56 * contains a( 1, 1 ), AP( 2 ) and AP( 3 ) contain a( 2, 1 )
57 * and a( 3, 1 ) respectively, and so on.
58 * Note that the imaginary parts of the diagonal elements need
59 * not be set and are assumed to be zero.
60 * Unchanged on exit.
61 *
62 * X - COMPLEX array of dimension at least
63 * ( 1 + ( n - 1 )*abs( INCX ) ).
64 * Before entry, the incremented array X must contain the n
65 * element vector x.
66 * Unchanged on exit.
67 *
68 * INCX - INTEGER.
69 * On entry, INCX specifies the increment for the elements of
70 * X. INCX must not be zero.
71 * Unchanged on exit.
72 *
73 * BETA - COMPLEX .
74 * On entry, BETA specifies the scalar beta. When BETA is
75 * supplied as zero then Y need not be set on input.
76 * Unchanged on exit.
77 *
78 * Y - COMPLEX array of dimension at least
79 * ( 1 + ( n - 1 )*abs( INCY ) ).
80 * Before entry, the incremented array Y must contain the n
81 * element vector y. On exit, Y is overwritten by the updated
82 * vector y.
83 *
84 * INCY - INTEGER.
85 * On entry, INCY specifies the increment for the elements of
86 * Y. INCY must not be zero.
87 * Unchanged on exit.
88 *
89 * Further Details
90 * ===============
91 *
92 * Level 2 Blas routine.
93 * The vector and matrix arguments are not referenced when N = 0, or M = 0
94 *
95 * -- Written on 22-October-1986.
96 * Jack Dongarra, Argonne National Lab.
97 * Jeremy Du Croz, Nag Central Office.
98 * Sven Hammarling, Nag Central Office.
99 * Richard Hanson, Sandia National Labs.
100 *
101 * =====================================================================
102 *
103 * .. Parameters ..
104 COMPLEX ONE
105 PARAMETER (ONE= (1.0E+0,0.0E+0))
106 COMPLEX ZERO
107 PARAMETER (ZERO= (0.0E+0,0.0E+0))
108 * ..
109 * .. Local Scalars ..
110 COMPLEX TEMP1,TEMP2
111 INTEGER I,INFO,IX,IY,J,JX,JY,K,KK,KX,KY
112 * ..
113 * .. External Functions ..
114 LOGICAL LSAME
115 EXTERNAL LSAME
116 * ..
117 * .. External Subroutines ..
118 EXTERNAL XERBLA
119 * ..
120 * .. Intrinsic Functions ..
121 INTRINSIC CONJG,REAL
122 * ..
123 *
124 * Test the input parameters.
125 *
126 INFO = 0
127 IF (.NOT.LSAME(UPLO,'U') .AND. .NOT.LSAME(UPLO,'L')) THEN
128 INFO = 1
129 ELSE IF (N.LT.0) THEN
130 INFO = 2
131 ELSE IF (INCX.EQ.0) THEN
132 INFO = 6
133 ELSE IF (INCY.EQ.0) THEN
134 INFO = 9
135 END IF
136 IF (INFO.NE.0) THEN
137 CALL XERBLA('CHPMV ',INFO)
138 RETURN
139 END IF
140 *
141 * Quick return if possible.
142 *
143 IF ((N.EQ.0) .OR. ((ALPHA.EQ.ZERO).AND. (BETA.EQ.ONE))) RETURN
144 *
145 * Set up the start points in X and Y.
146 *
147 IF (INCX.GT.0) THEN
148 KX = 1
149 ELSE
150 KX = 1 - (N-1)*INCX
151 END IF
152 IF (INCY.GT.0) THEN
153 KY = 1
154 ELSE
155 KY = 1 - (N-1)*INCY
156 END IF
157 *
158 * Start the operations. In this version the elements of the array AP
159 * are accessed sequentially with one pass through AP.
160 *
161 * First form y := beta*y.
162 *
163 IF (BETA.NE.ONE) THEN
164 IF (INCY.EQ.1) THEN
165 IF (BETA.EQ.ZERO) THEN
166 DO 10 I = 1,N
167 Y(I) = ZERO
168 10 CONTINUE
169 ELSE
170 DO 20 I = 1,N
171 Y(I) = BETA*Y(I)
172 20 CONTINUE
173 END IF
174 ELSE
175 IY = KY
176 IF (BETA.EQ.ZERO) THEN
177 DO 30 I = 1,N
178 Y(IY) = ZERO
179 IY = IY + INCY
180 30 CONTINUE
181 ELSE
182 DO 40 I = 1,N
183 Y(IY) = BETA*Y(IY)
184 IY = IY + INCY
185 40 CONTINUE
186 END IF
187 END IF
188 END IF
189 IF (ALPHA.EQ.ZERO) RETURN
190 KK = 1
191 IF (LSAME(UPLO,'U')) THEN
192 *
193 * Form y when AP contains the upper triangle.
194 *
195 IF ((INCX.EQ.1) .AND. (INCY.EQ.1)) THEN
196 DO 60 J = 1,N
197 TEMP1 = ALPHA*X(J)
198 TEMP2 = ZERO
199 K = KK
200 DO 50 I = 1,J - 1
201 Y(I) = Y(I) + TEMP1*AP(K)
202 TEMP2 = TEMP2 + CONJG(AP(K))*X(I)
203 K = K + 1
204 50 CONTINUE
205 Y(J) = Y(J) + TEMP1*REAL(AP(KK+J-1)) + ALPHA*TEMP2
206 KK = KK + J
207 60 CONTINUE
208 ELSE
209 JX = KX
210 JY = KY
211 DO 80 J = 1,N
212 TEMP1 = ALPHA*X(JX)
213 TEMP2 = ZERO
214 IX = KX
215 IY = KY
216 DO 70 K = KK,KK + J - 2
217 Y(IY) = Y(IY) + TEMP1*AP(K)
218 TEMP2 = TEMP2 + CONJG(AP(K))*X(IX)
219 IX = IX + INCX
220 IY = IY + INCY
221 70 CONTINUE
222 Y(JY) = Y(JY) + TEMP1*REAL(AP(KK+J-1)) + ALPHA*TEMP2
223 JX = JX + INCX
224 JY = JY + INCY
225 KK = KK + J
226 80 CONTINUE
227 END IF
228 ELSE
229 *
230 * Form y when AP contains the lower triangle.
231 *
232 IF ((INCX.EQ.1) .AND. (INCY.EQ.1)) THEN
233 DO 100 J = 1,N
234 TEMP1 = ALPHA*X(J)
235 TEMP2 = ZERO
236 Y(J) = Y(J) + TEMP1*REAL(AP(KK))
237 K = KK + 1
238 DO 90 I = J + 1,N
239 Y(I) = Y(I) + TEMP1*AP(K)
240 TEMP2 = TEMP2 + CONJG(AP(K))*X(I)
241 K = K + 1
242 90 CONTINUE
243 Y(J) = Y(J) + ALPHA*TEMP2
244 KK = KK + (N-J+1)
245 100 CONTINUE
246 ELSE
247 JX = KX
248 JY = KY
249 DO 120 J = 1,N
250 TEMP1 = ALPHA*X(JX)
251 TEMP2 = ZERO
252 Y(JY) = Y(JY) + TEMP1*REAL(AP(KK))
253 IX = JX
254 IY = JY
255 DO 110 K = KK + 1,KK + N - J
256 IX = IX + INCX
257 IY = IY + INCY
258 Y(IY) = Y(IY) + TEMP1*AP(K)
259 TEMP2 = TEMP2 + CONJG(AP(K))*X(IX)
260 110 CONTINUE
261 Y(JY) = Y(JY) + ALPHA*TEMP2
262 JX = JX + INCX
263 JY = JY + INCY
264 KK = KK + (N-J+1)
265 120 CONTINUE
266 END IF
267 END IF
268 *
269 RETURN
270 *
271 * End of CHPMV .
272 *
273 END