LAPACK  3.11.0
LAPACK: Linear Algebra PACKage
zher2k.f
1 *> \brief \b ZHER2K
2 *
3 * =========== DOCUMENTATION ===========
4 *
5 * Online html documentation available at
6 * http://www.netlib.org/lapack/explore-html/
7 *
8 * Definition:
9 * ===========
10 *
11 * SUBROUTINE ZHER2K(UPLO,TRANS,N,K,ALPHA,A,LDA,B,LDB,BETA,C,LDC)
12 *
13 * .. Scalar Arguments ..
14 * COMPLEX*16 ALPHA
15 * DOUBLE PRECISION BETA
16 * INTEGER K,LDA,LDB,LDC,N
17 * CHARACTER TRANS,UPLO
18 * ..
19 * .. Array Arguments ..
20 * COMPLEX*16 A(LDA,*),B(LDB,*),C(LDC,*)
21 * ..
22 *
23 *
24 *> \par Purpose:
25 * =============
26 *>
27 *> \verbatim
28 *>
29 *> ZHER2K performs one of the hermitian rank 2k operations
30 *>
31 *> C := alpha*A*B**H + conjg( alpha )*B*A**H + beta*C,
32 *>
33 *> or
34 *>
35 *> C := alpha*A**H*B + conjg( alpha )*B**H*A + beta*C,
36 *>
37 *> where alpha and beta are scalars with beta real, C is an n by n
38 *> hermitian matrix and A and B are n by k matrices in the first case
39 *> and k by n matrices in the second case.
40 *> \endverbatim
41 *
42 * Arguments:
43 * ==========
44 *
45 *> \param[in] UPLO
46 *> \verbatim
47 *> UPLO is CHARACTER*1
48 *> On entry, UPLO specifies whether the upper or lower
49 *> triangular part of the array C is to be referenced as
50 *> follows:
51 *>
52 *> UPLO = 'U' or 'u' Only the upper triangular part of C
53 *> is to be referenced.
54 *>
55 *> UPLO = 'L' or 'l' Only the lower triangular part of C
56 *> is to be referenced.
57 *> \endverbatim
58 *>
59 *> \param[in] TRANS
60 *> \verbatim
61 *> TRANS is CHARACTER*1
62 *> On entry, TRANS specifies the operation to be performed as
63 *> follows:
64 *>
65 *> TRANS = 'N' or 'n' C := alpha*A*B**H +
66 *> conjg( alpha )*B*A**H +
67 *> beta*C.
68 *>
69 *> TRANS = 'C' or 'c' C := alpha*A**H*B +
70 *> conjg( alpha )*B**H*A +
71 *> beta*C.
72 *> \endverbatim
73 *>
74 *> \param[in] N
75 *> \verbatim
76 *> N is INTEGER
77 *> On entry, N specifies the order of the matrix C. N must be
78 *> at least zero.
79 *> \endverbatim
80 *>
81 *> \param[in] K
82 *> \verbatim
83 *> K is INTEGER
84 *> On entry with TRANS = 'N' or 'n', K specifies the number
85 *> of columns of the matrices A and B, and on entry with
86 *> TRANS = 'C' or 'c', K specifies the number of rows of the
87 *> matrices A and B. K must be at least zero.
88 *> \endverbatim
89 *>
90 *> \param[in] ALPHA
91 *> \verbatim
92 *> ALPHA is COMPLEX*16 .
93 *> On entry, ALPHA specifies the scalar alpha.
94 *> \endverbatim
95 *>
96 *> \param[in] A
97 *> \verbatim
98 *> A is COMPLEX*16 array, dimension ( LDA, ka ), where ka is
99 *> k when TRANS = 'N' or 'n', and is n otherwise.
100 *> Before entry with TRANS = 'N' or 'n', the leading n by k
101 *> part of the array A must contain the matrix A, otherwise
102 *> the leading k by n part of the array A must contain the
103 *> matrix A.
104 *> \endverbatim
105 *>
106 *> \param[in] LDA
107 *> \verbatim
108 *> LDA is INTEGER
109 *> On entry, LDA specifies the first dimension of A as declared
110 *> in the calling (sub) program. When TRANS = 'N' or 'n'
111 *> then LDA must be at least max( 1, n ), otherwise LDA must
112 *> be at least max( 1, k ).
113 *> \endverbatim
114 *>
115 *> \param[in] B
116 *> \verbatim
117 *> B is COMPLEX*16 array, dimension ( LDB, kb ), where kb is
118 *> k when TRANS = 'N' or 'n', and is n otherwise.
119 *> Before entry with TRANS = 'N' or 'n', the leading n by k
120 *> part of the array B must contain the matrix B, otherwise
121 *> the leading k by n part of the array B must contain the
122 *> matrix B.
123 *> \endverbatim
124 *>
125 *> \param[in] LDB
126 *> \verbatim
127 *> LDB is INTEGER
128 *> On entry, LDB specifies the first dimension of B as declared
129 *> in the calling (sub) program. When TRANS = 'N' or 'n'
130 *> then LDB must be at least max( 1, n ), otherwise LDB must
131 *> be at least max( 1, k ).
132 *> Unchanged on exit.
133 *> \endverbatim
134 *>
135 *> \param[in] BETA
136 *> \verbatim
137 *> BETA is DOUBLE PRECISION .
138 *> On entry, BETA specifies the scalar beta.
139 *> \endverbatim
140 *>
141 *> \param[in,out] C
142 *> \verbatim
143 *> C is COMPLEX*16 array, dimension ( LDC, N )
144 *> Before entry with UPLO = 'U' or 'u', the leading n by n
145 *> upper triangular part of the array C must contain the upper
146 *> triangular part of the hermitian matrix and the strictly
147 *> lower triangular part of C is not referenced. On exit, the
148 *> upper triangular part of the array C is overwritten by the
149 *> upper triangular part of the updated matrix.
150 *> Before entry with UPLO = 'L' or 'l', the leading n by n
151 *> lower triangular part of the array C must contain the lower
152 *> triangular part of the hermitian matrix and the strictly
153 *> upper triangular part of C is not referenced. On exit, the
154 *> lower triangular part of the array C is overwritten by the
155 *> lower triangular part of the updated matrix.
156 *> Note that the imaginary parts of the diagonal elements need
157 *> not be set, they are assumed to be zero, and on exit they
158 *> are set to zero.
159 *> \endverbatim
160 *>
161 *> \param[in] LDC
162 *> \verbatim
163 *> LDC is INTEGER
164 *> On entry, LDC specifies the first dimension of C as declared
165 *> in the calling (sub) program. LDC must be at least
166 *> max( 1, n ).
167 *> \endverbatim
168 *
169 * Authors:
170 * ========
171 *
172 *> \author Univ. of Tennessee
173 *> \author Univ. of California Berkeley
174 *> \author Univ. of Colorado Denver
175 *> \author NAG Ltd.
176 *
177 *> \ingroup her2k
178 *
179 *> \par Further Details:
180 * =====================
181 *>
182 *> \verbatim
183 *>
184 *> Level 3 Blas routine.
185 *>
186 *> -- Written on 8-February-1989.
187 *> Jack Dongarra, Argonne National Laboratory.
188 *> Iain Duff, AERE Harwell.
189 *> Jeremy Du Croz, Numerical Algorithms Group Ltd.
190 *> Sven Hammarling, Numerical Algorithms Group Ltd.
191 *>
192 *> -- Modified 8-Nov-93 to set C(J,J) to DBLE( C(J,J) ) when BETA = 1.
193 *> Ed Anderson, Cray Research Inc.
194 *> \endverbatim
195 *>
196 * =====================================================================
197  SUBROUTINE zher2k(UPLO,TRANS,N,K,ALPHA,A,LDA,B,LDB,BETA,C,LDC)
198 *
199 * -- Reference BLAS level3 routine --
200 * -- Reference BLAS is a software package provided by Univ. of Tennessee, --
201 * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
202 *
203 * .. Scalar Arguments ..
204  COMPLEX*16 ALPHA
205  DOUBLE PRECISION BETA
206  INTEGER K,LDA,LDB,LDC,N
207  CHARACTER TRANS,UPLO
208 * ..
209 * .. Array Arguments ..
210  COMPLEX*16 A(lda,*),B(ldb,*),C(ldc,*)
211 * ..
212 *
213 * =====================================================================
214 *
215 * .. External Functions ..
216  LOGICAL LSAME
217  EXTERNAL lsame
218 * ..
219 * .. External Subroutines ..
220  EXTERNAL xerbla
221 * ..
222 * .. Intrinsic Functions ..
223  INTRINSIC dble,dconjg,max
224 * ..
225 * .. Local Scalars ..
226  COMPLEX*16 TEMP1,TEMP2
227  INTEGER I,INFO,J,L,NROWA
228  LOGICAL UPPER
229 * ..
230 * .. Parameters ..
231  DOUBLE PRECISION ONE
232  parameter(one=1.0d+0)
233  COMPLEX*16 ZERO
234  parameter(zero= (0.0d+0,0.0d+0))
235 * ..
236 *
237 * Test the input parameters.
238 *
239  IF (lsame(trans,'N')) THEN
240  nrowa = n
241  ELSE
242  nrowa = k
243  END IF
244  upper = lsame(uplo,'U')
245 *
246  info = 0
247  IF ((.NOT.upper) .AND. (.NOT.lsame(uplo,'L'))) THEN
248  info = 1
249  ELSE IF ((.NOT.lsame(trans,'N')) .AND.
250  + (.NOT.lsame(trans,'C'))) THEN
251  info = 2
252  ELSE IF (n.LT.0) THEN
253  info = 3
254  ELSE IF (k.LT.0) THEN
255  info = 4
256  ELSE IF (lda.LT.max(1,nrowa)) THEN
257  info = 7
258  ELSE IF (ldb.LT.max(1,nrowa)) THEN
259  info = 9
260  ELSE IF (ldc.LT.max(1,n)) THEN
261  info = 12
262  END IF
263  IF (info.NE.0) THEN
264  CALL xerbla('ZHER2K',info)
265  RETURN
266  END IF
267 *
268 * Quick return if possible.
269 *
270  IF ((n.EQ.0) .OR. (((alpha.EQ.zero).OR.
271  + (k.EQ.0)).AND. (beta.EQ.one))) RETURN
272 *
273 * And when alpha.eq.zero.
274 *
275  IF (alpha.EQ.zero) THEN
276  IF (upper) THEN
277  IF (beta.EQ.dble(zero)) THEN
278  DO 20 j = 1,n
279  DO 10 i = 1,j
280  c(i,j) = zero
281  10 CONTINUE
282  20 CONTINUE
283  ELSE
284  DO 40 j = 1,n
285  DO 30 i = 1,j - 1
286  c(i,j) = beta*c(i,j)
287  30 CONTINUE
288  c(j,j) = beta*dble(c(j,j))
289  40 CONTINUE
290  END IF
291  ELSE
292  IF (beta.EQ.dble(zero)) THEN
293  DO 60 j = 1,n
294  DO 50 i = j,n
295  c(i,j) = zero
296  50 CONTINUE
297  60 CONTINUE
298  ELSE
299  DO 80 j = 1,n
300  c(j,j) = beta*dble(c(j,j))
301  DO 70 i = j + 1,n
302  c(i,j) = beta*c(i,j)
303  70 CONTINUE
304  80 CONTINUE
305  END IF
306  END IF
307  RETURN
308  END IF
309 *
310 * Start the operations.
311 *
312  IF (lsame(trans,'N')) THEN
313 *
314 * Form C := alpha*A*B**H + conjg( alpha )*B*A**H +
315 * C.
316 *
317  IF (upper) THEN
318  DO 130 j = 1,n
319  IF (beta.EQ.dble(zero)) THEN
320  DO 90 i = 1,j
321  c(i,j) = zero
322  90 CONTINUE
323  ELSE IF (beta.NE.one) THEN
324  DO 100 i = 1,j - 1
325  c(i,j) = beta*c(i,j)
326  100 CONTINUE
327  c(j,j) = beta*dble(c(j,j))
328  ELSE
329  c(j,j) = dble(c(j,j))
330  END IF
331  DO 120 l = 1,k
332  IF ((a(j,l).NE.zero) .OR. (b(j,l).NE.zero)) THEN
333  temp1 = alpha*dconjg(b(j,l))
334  temp2 = dconjg(alpha*a(j,l))
335  DO 110 i = 1,j - 1
336  c(i,j) = c(i,j) + a(i,l)*temp1 +
337  + b(i,l)*temp2
338  110 CONTINUE
339  c(j,j) = dble(c(j,j)) +
340  + dble(a(j,l)*temp1+b(j,l)*temp2)
341  END IF
342  120 CONTINUE
343  130 CONTINUE
344  ELSE
345  DO 180 j = 1,n
346  IF (beta.EQ.dble(zero)) THEN
347  DO 140 i = j,n
348  c(i,j) = zero
349  140 CONTINUE
350  ELSE IF (beta.NE.one) THEN
351  DO 150 i = j + 1,n
352  c(i,j) = beta*c(i,j)
353  150 CONTINUE
354  c(j,j) = beta*dble(c(j,j))
355  ELSE
356  c(j,j) = dble(c(j,j))
357  END IF
358  DO 170 l = 1,k
359  IF ((a(j,l).NE.zero) .OR. (b(j,l).NE.zero)) THEN
360  temp1 = alpha*dconjg(b(j,l))
361  temp2 = dconjg(alpha*a(j,l))
362  DO 160 i = j + 1,n
363  c(i,j) = c(i,j) + a(i,l)*temp1 +
364  + b(i,l)*temp2
365  160 CONTINUE
366  c(j,j) = dble(c(j,j)) +
367  + dble(a(j,l)*temp1+b(j,l)*temp2)
368  END IF
369  170 CONTINUE
370  180 CONTINUE
371  END IF
372  ELSE
373 *
374 * Form C := alpha*A**H*B + conjg( alpha )*B**H*A +
375 * C.
376 *
377  IF (upper) THEN
378  DO 210 j = 1,n
379  DO 200 i = 1,j
380  temp1 = zero
381  temp2 = zero
382  DO 190 l = 1,k
383  temp1 = temp1 + dconjg(a(l,i))*b(l,j)
384  temp2 = temp2 + dconjg(b(l,i))*a(l,j)
385  190 CONTINUE
386  IF (i.EQ.j) THEN
387  IF (beta.EQ.dble(zero)) THEN
388  c(j,j) = dble(alpha*temp1+
389  + dconjg(alpha)*temp2)
390  ELSE
391  c(j,j) = beta*dble(c(j,j)) +
392  + dble(alpha*temp1+
393  + dconjg(alpha)*temp2)
394  END IF
395  ELSE
396  IF (beta.EQ.dble(zero)) THEN
397  c(i,j) = alpha*temp1 + dconjg(alpha)*temp2
398  ELSE
399  c(i,j) = beta*c(i,j) + alpha*temp1 +
400  + dconjg(alpha)*temp2
401  END IF
402  END IF
403  200 CONTINUE
404  210 CONTINUE
405  ELSE
406  DO 240 j = 1,n
407  DO 230 i = j,n
408  temp1 = zero
409  temp2 = zero
410  DO 220 l = 1,k
411  temp1 = temp1 + dconjg(a(l,i))*b(l,j)
412  temp2 = temp2 + dconjg(b(l,i))*a(l,j)
413  220 CONTINUE
414  IF (i.EQ.j) THEN
415  IF (beta.EQ.dble(zero)) THEN
416  c(j,j) = dble(alpha*temp1+
417  + dconjg(alpha)*temp2)
418  ELSE
419  c(j,j) = beta*dble(c(j,j)) +
420  + dble(alpha*temp1+
421  + dconjg(alpha)*temp2)
422  END IF
423  ELSE
424  IF (beta.EQ.dble(zero)) THEN
425  c(i,j) = alpha*temp1 + dconjg(alpha)*temp2
426  ELSE
427  c(i,j) = beta*c(i,j) + alpha*temp1 +
428  + dconjg(alpha)*temp2
429  END IF
430  END IF
431  230 CONTINUE
432  240 CONTINUE
433  END IF
434  END IF
435 *
436  RETURN
437 *
438 * End of ZHER2K
439 *
440  END
xerbla
subroutine xerbla(SRNAME, INFO)
XERBLA
Definition: xerbla.f:60
zher2k
subroutine zher2k(UPLO, TRANS, N, K, ALPHA, A, LDA, B, LDB, BETA, C, LDC)
ZHER2K
Definition: zher2k.f:198