root / src / blas / zher2k.f @ 7
Historique | Voir | Annoter | Télécharger (12,86 ko)
1 | 1 | equemene | SUBROUTINE ZHER2K(UPLO,TRANS,N,K,ALPHA,A,LDA,B,LDB,BETA,C,LDC) |
---|---|---|---|
2 | 1 | equemene | * .. Scalar Arguments .. |
3 | 1 | equemene | DOUBLE COMPLEX ALPHA |
4 | 1 | equemene | DOUBLE PRECISION BETA |
5 | 1 | equemene | INTEGER K,LDA,LDB,LDC,N |
6 | 1 | equemene | CHARACTER TRANS,UPLO |
7 | 1 | equemene | * .. |
8 | 1 | equemene | * .. Array Arguments .. |
9 | 1 | equemene | DOUBLE COMPLEX A(LDA,*),B(LDB,*),C(LDC,*) |
10 | 1 | equemene | * .. |
11 | 1 | equemene | * |
12 | 1 | equemene | * Purpose |
13 | 1 | equemene | * ======= |
14 | 1 | equemene | * |
15 | 1 | equemene | * ZHER2K performs one of the hermitian rank 2k operations |
16 | 1 | equemene | * |
17 | 1 | equemene | * C := alpha*A*conjg( B' ) + conjg( alpha )*B*conjg( A' ) + beta*C, |
18 | 1 | equemene | * |
19 | 1 | equemene | * or |
20 | 1 | equemene | * |
21 | 1 | equemene | * C := alpha*conjg( A' )*B + conjg( alpha )*conjg( B' )*A + beta*C, |
22 | 1 | equemene | * |
23 | 1 | equemene | * where alpha and beta are scalars with beta real, C is an n by n |
24 | 1 | equemene | * hermitian matrix and A and B are n by k matrices in the first case |
25 | 1 | equemene | * and k by n matrices in the second case. |
26 | 1 | equemene | * |
27 | 1 | equemene | * Arguments |
28 | 1 | equemene | * ========== |
29 | 1 | equemene | * |
30 | 1 | equemene | * UPLO - CHARACTER*1. |
31 | 1 | equemene | * On entry, UPLO specifies whether the upper or lower |
32 | 1 | equemene | * triangular part of the array C is to be referenced as |
33 | 1 | equemene | * follows: |
34 | 1 | equemene | * |
35 | 1 | equemene | * UPLO = 'U' or 'u' Only the upper triangular part of C |
36 | 1 | equemene | * is to be referenced. |
37 | 1 | equemene | * |
38 | 1 | equemene | * UPLO = 'L' or 'l' Only the lower triangular part of C |
39 | 1 | equemene | * is to be referenced. |
40 | 1 | equemene | * |
41 | 1 | equemene | * Unchanged on exit. |
42 | 1 | equemene | * |
43 | 1 | equemene | * TRANS - CHARACTER*1. |
44 | 1 | equemene | * On entry, TRANS specifies the operation to be performed as |
45 | 1 | equemene | * follows: |
46 | 1 | equemene | * |
47 | 1 | equemene | * TRANS = 'N' or 'n' C := alpha*A*conjg( B' ) + |
48 | 1 | equemene | * conjg( alpha )*B*conjg( A' ) + |
49 | 1 | equemene | * beta*C. |
50 | 1 | equemene | * |
51 | 1 | equemene | * TRANS = 'C' or 'c' C := alpha*conjg( A' )*B + |
52 | 1 | equemene | * conjg( alpha )*conjg( B' )*A + |
53 | 1 | equemene | * beta*C. |
54 | 1 | equemene | * |
55 | 1 | equemene | * Unchanged on exit. |
56 | 1 | equemene | * |
57 | 1 | equemene | * N - INTEGER. |
58 | 1 | equemene | * On entry, N specifies the order of the matrix C. N must be |
59 | 1 | equemene | * at least zero. |
60 | 1 | equemene | * Unchanged on exit. |
61 | 1 | equemene | * |
62 | 1 | equemene | * K - INTEGER. |
63 | 1 | equemene | * On entry with TRANS = 'N' or 'n', K specifies the number |
64 | 1 | equemene | * of columns of the matrices A and B, and on entry with |
65 | 1 | equemene | * TRANS = 'C' or 'c', K specifies the number of rows of the |
66 | 1 | equemene | * matrices A and B. K must be at least zero. |
67 | 1 | equemene | * Unchanged on exit. |
68 | 1 | equemene | * |
69 | 1 | equemene | * ALPHA - COMPLEX*16 . |
70 | 1 | equemene | * On entry, ALPHA specifies the scalar alpha. |
71 | 1 | equemene | * Unchanged on exit. |
72 | 1 | equemene | * |
73 | 1 | equemene | * A - COMPLEX*16 array of DIMENSION ( LDA, ka ), where ka is |
74 | 1 | equemene | * k when TRANS = 'N' or 'n', and is n otherwise. |
75 | 1 | equemene | * Before entry with TRANS = 'N' or 'n', the leading n by k |
76 | 1 | equemene | * part of the array A must contain the matrix A, otherwise |
77 | 1 | equemene | * the leading k by n part of the array A must contain the |
78 | 1 | equemene | * matrix A. |
79 | 1 | equemene | * Unchanged on exit. |
80 | 1 | equemene | * |
81 | 1 | equemene | * LDA - INTEGER. |
82 | 1 | equemene | * On entry, LDA specifies the first dimension of A as declared |
83 | 1 | equemene | * in the calling (sub) program. When TRANS = 'N' or 'n' |
84 | 1 | equemene | * then LDA must be at least max( 1, n ), otherwise LDA must |
85 | 1 | equemene | * be at least max( 1, k ). |
86 | 1 | equemene | * Unchanged on exit. |
87 | 1 | equemene | * |
88 | 1 | equemene | * B - COMPLEX*16 array of DIMENSION ( LDB, kb ), where kb is |
89 | 1 | equemene | * k when TRANS = 'N' or 'n', and is n otherwise. |
90 | 1 | equemene | * Before entry with TRANS = 'N' or 'n', the leading n by k |
91 | 1 | equemene | * part of the array B must contain the matrix B, otherwise |
92 | 1 | equemene | * the leading k by n part of the array B must contain the |
93 | 1 | equemene | * matrix B. |
94 | 1 | equemene | * Unchanged on exit. |
95 | 1 | equemene | * |
96 | 1 | equemene | * LDB - INTEGER. |
97 | 1 | equemene | * On entry, LDB specifies the first dimension of B as declared |
98 | 1 | equemene | * in the calling (sub) program. When TRANS = 'N' or 'n' |
99 | 1 | equemene | * then LDB must be at least max( 1, n ), otherwise LDB must |
100 | 1 | equemene | * be at least max( 1, k ). |
101 | 1 | equemene | * Unchanged on exit. |
102 | 1 | equemene | * |
103 | 1 | equemene | * BETA - DOUBLE PRECISION . |
104 | 1 | equemene | * On entry, BETA specifies the scalar beta. |
105 | 1 | equemene | * Unchanged on exit. |
106 | 1 | equemene | * |
107 | 1 | equemene | * C - COMPLEX*16 array of DIMENSION ( LDC, n ). |
108 | 1 | equemene | * Before entry with UPLO = 'U' or 'u', the leading n by n |
109 | 1 | equemene | * upper triangular part of the array C must contain the upper |
110 | 1 | equemene | * triangular part of the hermitian matrix and the strictly |
111 | 1 | equemene | * lower triangular part of C is not referenced. On exit, the |
112 | 1 | equemene | * upper triangular part of the array C is overwritten by the |
113 | 1 | equemene | * upper triangular part of the updated matrix. |
114 | 1 | equemene | * Before entry with UPLO = 'L' or 'l', the leading n by n |
115 | 1 | equemene | * lower triangular part of the array C must contain the lower |
116 | 1 | equemene | * triangular part of the hermitian matrix and the strictly |
117 | 1 | equemene | * upper triangular part of C is not referenced. On exit, the |
118 | 1 | equemene | * lower triangular part of the array C is overwritten by the |
119 | 1 | equemene | * lower triangular part of the updated matrix. |
120 | 1 | equemene | * Note that the imaginary parts of the diagonal elements need |
121 | 1 | equemene | * not be set, they are assumed to be zero, and on exit they |
122 | 1 | equemene | * are set to zero. |
123 | 1 | equemene | * |
124 | 1 | equemene | * LDC - INTEGER. |
125 | 1 | equemene | * On entry, LDC specifies the first dimension of C as declared |
126 | 1 | equemene | * in the calling (sub) program. LDC must be at least |
127 | 1 | equemene | * max( 1, n ). |
128 | 1 | equemene | * Unchanged on exit. |
129 | 1 | equemene | * |
130 | 1 | equemene | * |
131 | 1 | equemene | * Level 3 Blas routine. |
132 | 1 | equemene | * |
133 | 1 | equemene | * -- Written on 8-February-1989. |
134 | 1 | equemene | * Jack Dongarra, Argonne National Laboratory. |
135 | 1 | equemene | * Iain Duff, AERE Harwell. |
136 | 1 | equemene | * Jeremy Du Croz, Numerical Algorithms Group Ltd. |
137 | 1 | equemene | * Sven Hammarling, Numerical Algorithms Group Ltd. |
138 | 1 | equemene | * |
139 | 1 | equemene | * -- Modified 8-Nov-93 to set C(J,J) to DBLE( C(J,J) ) when BETA = 1. |
140 | 1 | equemene | * Ed Anderson, Cray Research Inc. |
141 | 1 | equemene | * |
142 | 1 | equemene | * |
143 | 1 | equemene | * .. External Functions .. |
144 | 1 | equemene | LOGICAL LSAME |
145 | 1 | equemene | EXTERNAL LSAME |
146 | 1 | equemene | * .. |
147 | 1 | equemene | * .. External Subroutines .. |
148 | 1 | equemene | EXTERNAL XERBLA |
149 | 1 | equemene | * .. |
150 | 1 | equemene | * .. Intrinsic Functions .. |
151 | 1 | equemene | INTRINSIC DBLE,DCONJG,MAX |
152 | 1 | equemene | * .. |
153 | 1 | equemene | * .. Local Scalars .. |
154 | 1 | equemene | DOUBLE COMPLEX TEMP1,TEMP2 |
155 | 1 | equemene | INTEGER I,INFO,J,L,NROWA |
156 | 1 | equemene | LOGICAL UPPER |
157 | 1 | equemene | * .. |
158 | 1 | equemene | * .. Parameters .. |
159 | 1 | equemene | DOUBLE PRECISION ONE |
160 | 1 | equemene | PARAMETER (ONE=1.0D+0) |
161 | 1 | equemene | DOUBLE COMPLEX ZERO |
162 | 1 | equemene | PARAMETER (ZERO= (0.0D+0,0.0D+0)) |
163 | 1 | equemene | * .. |
164 | 1 | equemene | * |
165 | 1 | equemene | * Test the input parameters. |
166 | 1 | equemene | * |
167 | 1 | equemene | IF (LSAME(TRANS,'N')) THEN |
168 | 1 | equemene | NROWA = N |
169 | 1 | equemene | ELSE |
170 | 1 | equemene | NROWA = K |
171 | 1 | equemene | END IF |
172 | 1 | equemene | UPPER = LSAME(UPLO,'U') |
173 | 1 | equemene | * |
174 | 1 | equemene | INFO = 0 |
175 | 1 | equemene | IF ((.NOT.UPPER) .AND. (.NOT.LSAME(UPLO,'L'))) THEN |
176 | 1 | equemene | INFO = 1 |
177 | 1 | equemene | ELSE IF ((.NOT.LSAME(TRANS,'N')) .AND. |
178 | 1 | equemene | + (.NOT.LSAME(TRANS,'C'))) THEN |
179 | 1 | equemene | INFO = 2 |
180 | 1 | equemene | ELSE IF (N.LT.0) THEN |
181 | 1 | equemene | INFO = 3 |
182 | 1 | equemene | ELSE IF (K.LT.0) THEN |
183 | 1 | equemene | INFO = 4 |
184 | 1 | equemene | ELSE IF (LDA.LT.MAX(1,NROWA)) THEN |
185 | 1 | equemene | INFO = 7 |
186 | 1 | equemene | ELSE IF (LDB.LT.MAX(1,NROWA)) THEN |
187 | 1 | equemene | INFO = 9 |
188 | 1 | equemene | ELSE IF (LDC.LT.MAX(1,N)) THEN |
189 | 1 | equemene | INFO = 12 |
190 | 1 | equemene | END IF |
191 | 1 | equemene | IF (INFO.NE.0) THEN |
192 | 1 | equemene | CALL XERBLA('ZHER2K',INFO) |
193 | 1 | equemene | RETURN |
194 | 1 | equemene | END IF |
195 | 1 | equemene | * |
196 | 1 | equemene | * Quick return if possible. |
197 | 1 | equemene | * |
198 | 1 | equemene | IF ((N.EQ.0) .OR. (((ALPHA.EQ.ZERO).OR. |
199 | 1 | equemene | + (K.EQ.0)).AND. (BETA.EQ.ONE))) RETURN |
200 | 1 | equemene | * |
201 | 1 | equemene | * And when alpha.eq.zero. |
202 | 1 | equemene | * |
203 | 1 | equemene | IF (ALPHA.EQ.ZERO) THEN |
204 | 1 | equemene | IF (UPPER) THEN |
205 | 1 | equemene | IF (BETA.EQ.DBLE(ZERO)) THEN |
206 | 1 | equemene | DO 20 J = 1,N |
207 | 1 | equemene | DO 10 I = 1,J |
208 | 1 | equemene | C(I,J) = ZERO |
209 | 1 | equemene | 10 CONTINUE |
210 | 1 | equemene | 20 CONTINUE |
211 | 1 | equemene | ELSE |
212 | 1 | equemene | DO 40 J = 1,N |
213 | 1 | equemene | DO 30 I = 1,J - 1 |
214 | 1 | equemene | C(I,J) = BETA*C(I,J) |
215 | 1 | equemene | 30 CONTINUE |
216 | 1 | equemene | C(J,J) = BETA*DBLE(C(J,J)) |
217 | 1 | equemene | 40 CONTINUE |
218 | 1 | equemene | END IF |
219 | 1 | equemene | ELSE |
220 | 1 | equemene | IF (BETA.EQ.DBLE(ZERO)) THEN |
221 | 1 | equemene | DO 60 J = 1,N |
222 | 1 | equemene | DO 50 I = J,N |
223 | 1 | equemene | C(I,J) = ZERO |
224 | 1 | equemene | 50 CONTINUE |
225 | 1 | equemene | 60 CONTINUE |
226 | 1 | equemene | ELSE |
227 | 1 | equemene | DO 80 J = 1,N |
228 | 1 | equemene | C(J,J) = BETA*DBLE(C(J,J)) |
229 | 1 | equemene | DO 70 I = J + 1,N |
230 | 1 | equemene | C(I,J) = BETA*C(I,J) |
231 | 1 | equemene | 70 CONTINUE |
232 | 1 | equemene | 80 CONTINUE |
233 | 1 | equemene | END IF |
234 | 1 | equemene | END IF |
235 | 1 | equemene | RETURN |
236 | 1 | equemene | END IF |
237 | 1 | equemene | * |
238 | 1 | equemene | * Start the operations. |
239 | 1 | equemene | * |
240 | 1 | equemene | IF (LSAME(TRANS,'N')) THEN |
241 | 1 | equemene | * |
242 | 1 | equemene | * Form C := alpha*A*conjg( B' ) + conjg( alpha )*B*conjg( A' ) + |
243 | 1 | equemene | * C. |
244 | 1 | equemene | * |
245 | 1 | equemene | IF (UPPER) THEN |
246 | 1 | equemene | DO 130 J = 1,N |
247 | 1 | equemene | IF (BETA.EQ.DBLE(ZERO)) THEN |
248 | 1 | equemene | DO 90 I = 1,J |
249 | 1 | equemene | C(I,J) = ZERO |
250 | 1 | equemene | 90 CONTINUE |
251 | 1 | equemene | ELSE IF (BETA.NE.ONE) THEN |
252 | 1 | equemene | DO 100 I = 1,J - 1 |
253 | 1 | equemene | C(I,J) = BETA*C(I,J) |
254 | 1 | equemene | 100 CONTINUE |
255 | 1 | equemene | C(J,J) = BETA*DBLE(C(J,J)) |
256 | 1 | equemene | ELSE |
257 | 1 | equemene | C(J,J) = DBLE(C(J,J)) |
258 | 1 | equemene | END IF |
259 | 1 | equemene | DO 120 L = 1,K |
260 | 1 | equemene | IF ((A(J,L).NE.ZERO) .OR. (B(J,L).NE.ZERO)) THEN |
261 | 1 | equemene | TEMP1 = ALPHA*DCONJG(B(J,L)) |
262 | 1 | equemene | TEMP2 = DCONJG(ALPHA*A(J,L)) |
263 | 1 | equemene | DO 110 I = 1,J - 1 |
264 | 1 | equemene | C(I,J) = C(I,J) + A(I,L)*TEMP1 + |
265 | 1 | equemene | + B(I,L)*TEMP2 |
266 | 1 | equemene | 110 CONTINUE |
267 | 1 | equemene | C(J,J) = DBLE(C(J,J)) + |
268 | 1 | equemene | + DBLE(A(J,L)*TEMP1+B(J,L)*TEMP2) |
269 | 1 | equemene | END IF |
270 | 1 | equemene | 120 CONTINUE |
271 | 1 | equemene | 130 CONTINUE |
272 | 1 | equemene | ELSE |
273 | 1 | equemene | DO 180 J = 1,N |
274 | 1 | equemene | IF (BETA.EQ.DBLE(ZERO)) THEN |
275 | 1 | equemene | DO 140 I = J,N |
276 | 1 | equemene | C(I,J) = ZERO |
277 | 1 | equemene | 140 CONTINUE |
278 | 1 | equemene | ELSE IF (BETA.NE.ONE) THEN |
279 | 1 | equemene | DO 150 I = J + 1,N |
280 | 1 | equemene | C(I,J) = BETA*C(I,J) |
281 | 1 | equemene | 150 CONTINUE |
282 | 1 | equemene | C(J,J) = BETA*DBLE(C(J,J)) |
283 | 1 | equemene | ELSE |
284 | 1 | equemene | C(J,J) = DBLE(C(J,J)) |
285 | 1 | equemene | END IF |
286 | 1 | equemene | DO 170 L = 1,K |
287 | 1 | equemene | IF ((A(J,L).NE.ZERO) .OR. (B(J,L).NE.ZERO)) THEN |
288 | 1 | equemene | TEMP1 = ALPHA*DCONJG(B(J,L)) |
289 | 1 | equemene | TEMP2 = DCONJG(ALPHA*A(J,L)) |
290 | 1 | equemene | DO 160 I = J + 1,N |
291 | 1 | equemene | C(I,J) = C(I,J) + A(I,L)*TEMP1 + |
292 | 1 | equemene | + B(I,L)*TEMP2 |
293 | 1 | equemene | 160 CONTINUE |
294 | 1 | equemene | C(J,J) = DBLE(C(J,J)) + |
295 | 1 | equemene | + DBLE(A(J,L)*TEMP1+B(J,L)*TEMP2) |
296 | 1 | equemene | END IF |
297 | 1 | equemene | 170 CONTINUE |
298 | 1 | equemene | 180 CONTINUE |
299 | 1 | equemene | END IF |
300 | 1 | equemene | ELSE |
301 | 1 | equemene | * |
302 | 1 | equemene | * Form C := alpha*conjg( A' )*B + conjg( alpha )*conjg( B' )*A + |
303 | 1 | equemene | * C. |
304 | 1 | equemene | * |
305 | 1 | equemene | IF (UPPER) THEN |
306 | 1 | equemene | DO 210 J = 1,N |
307 | 1 | equemene | DO 200 I = 1,J |
308 | 1 | equemene | TEMP1 = ZERO |
309 | 1 | equemene | TEMP2 = ZERO |
310 | 1 | equemene | DO 190 L = 1,K |
311 | 1 | equemene | TEMP1 = TEMP1 + DCONJG(A(L,I))*B(L,J) |
312 | 1 | equemene | TEMP2 = TEMP2 + DCONJG(B(L,I))*A(L,J) |
313 | 1 | equemene | 190 CONTINUE |
314 | 1 | equemene | IF (I.EQ.J) THEN |
315 | 1 | equemene | IF (BETA.EQ.DBLE(ZERO)) THEN |
316 | 1 | equemene | C(J,J) = DBLE(ALPHA*TEMP1+ |
317 | 1 | equemene | + DCONJG(ALPHA)*TEMP2) |
318 | 1 | equemene | ELSE |
319 | 1 | equemene | C(J,J) = BETA*DBLE(C(J,J)) + |
320 | 1 | equemene | + DBLE(ALPHA*TEMP1+ |
321 | 1 | equemene | + DCONJG(ALPHA)*TEMP2) |
322 | 1 | equemene | END IF |
323 | 1 | equemene | ELSE |
324 | 1 | equemene | IF (BETA.EQ.DBLE(ZERO)) THEN |
325 | 1 | equemene | C(I,J) = ALPHA*TEMP1 + DCONJG(ALPHA)*TEMP2 |
326 | 1 | equemene | ELSE |
327 | 1 | equemene | C(I,J) = BETA*C(I,J) + ALPHA*TEMP1 + |
328 | 1 | equemene | + DCONJG(ALPHA)*TEMP2 |
329 | 1 | equemene | END IF |
330 | 1 | equemene | END IF |
331 | 1 | equemene | 200 CONTINUE |
332 | 1 | equemene | 210 CONTINUE |
333 | 1 | equemene | ELSE |
334 | 1 | equemene | DO 240 J = 1,N |
335 | 1 | equemene | DO 230 I = J,N |
336 | 1 | equemene | TEMP1 = ZERO |
337 | 1 | equemene | TEMP2 = ZERO |
338 | 1 | equemene | DO 220 L = 1,K |
339 | 1 | equemene | TEMP1 = TEMP1 + DCONJG(A(L,I))*B(L,J) |
340 | 1 | equemene | TEMP2 = TEMP2 + DCONJG(B(L,I))*A(L,J) |
341 | 1 | equemene | 220 CONTINUE |
342 | 1 | equemene | IF (I.EQ.J) THEN |
343 | 1 | equemene | IF (BETA.EQ.DBLE(ZERO)) THEN |
344 | 1 | equemene | C(J,J) = DBLE(ALPHA*TEMP1+ |
345 | 1 | equemene | + DCONJG(ALPHA)*TEMP2) |
346 | 1 | equemene | ELSE |
347 | 1 | equemene | C(J,J) = BETA*DBLE(C(J,J)) + |
348 | 1 | equemene | + DBLE(ALPHA*TEMP1+ |
349 | 1 | equemene | + DCONJG(ALPHA)*TEMP2) |
350 | 1 | equemene | END IF |
351 | 1 | equemene | ELSE |
352 | 1 | equemene | IF (BETA.EQ.DBLE(ZERO)) THEN |
353 | 1 | equemene | C(I,J) = ALPHA*TEMP1 + DCONJG(ALPHA)*TEMP2 |
354 | 1 | equemene | ELSE |
355 | 1 | equemene | C(I,J) = BETA*C(I,J) + ALPHA*TEMP1 + |
356 | 1 | equemene | + DCONJG(ALPHA)*TEMP2 |
357 | 1 | equemene | END IF |
358 | 1 | equemene | END IF |
359 | 1 | equemene | 230 CONTINUE |
360 | 1 | equemene | 240 CONTINUE |
361 | 1 | equemene | END IF |
362 | 1 | equemene | END IF |
363 | 1 | equemene | * |
364 | 1 | equemene | RETURN |
365 | 1 | equemene | * |
366 | 1 | equemene | * End of ZHER2K. |
367 | 1 | equemene | * |
368 | 1 | equemene | END |