LAPACK  3.7.1
LAPACK: Linear Algebra PACKage
zher2k.f
Go to the documentation of this file.
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 *> \date December 2016
178 *
179 *> \ingroup complex16_blas_level3
180 *
181 *> \par Further Details:
182 * =====================
183 *>
184 *> \verbatim
185 *>
186 *> Level 3 Blas routine.
187 *>
188 *> -- Written on 8-February-1989.
189 *> Jack Dongarra, Argonne National Laboratory.
190 *> Iain Duff, AERE Harwell.
191 *> Jeremy Du Croz, Numerical Algorithms Group Ltd.
192 *> Sven Hammarling, Numerical Algorithms Group Ltd.
193 *>
194 *> -- Modified 8-Nov-93 to set C(J,J) to DBLE( C(J,J) ) when BETA = 1.
195 *> Ed Anderson, Cray Research Inc.
196 *> \endverbatim
197 *>
198 * =====================================================================
199  SUBROUTINE zher2k(UPLO,TRANS,N,K,ALPHA,A,LDA,B,LDB,BETA,C,LDC)
200 *
201 * -- Reference BLAS level3 routine (version 3.7.0) --
202 * -- Reference BLAS is a software package provided by Univ. of Tennessee, --
203 * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
204 * December 2016
205 *
206 * .. Scalar Arguments ..
207  COMPLEX*16 ALPHA
208  DOUBLE PRECISION BETA
209  INTEGER K,LDA,LDB,LDC,N
210  CHARACTER TRANS,UPLO
211 * ..
212 * .. Array Arguments ..
213  COMPLEX*16 A(lda,*),B(ldb,*),C(ldc,*)
214 * ..
215 *
216 * =====================================================================
217 *
218 * .. External Functions ..
219  LOGICAL LSAME
220  EXTERNAL lsame
221 * ..
222 * .. External Subroutines ..
223  EXTERNAL xerbla
224 * ..
225 * .. Intrinsic Functions ..
226  INTRINSIC dble,dconjg,max
227 * ..
228 * .. Local Scalars ..
229  COMPLEX*16 TEMP1,TEMP2
230  INTEGER I,INFO,J,L,NROWA
231  LOGICAL UPPER
232 * ..
233 * .. Parameters ..
234  DOUBLE PRECISION ONE
235  parameter(one=1.0d+0)
236  COMPLEX*16 ZERO
237  parameter(zero= (0.0d+0,0.0d+0))
238 * ..
239 *
240 * Test the input parameters.
241 *
242  IF (lsame(trans,'N')) THEN
243  nrowa = n
244  ELSE
245  nrowa = k
246  END IF
247  upper = lsame(uplo,'U')
248 *
249  info = 0
250  IF ((.NOT.upper) .AND. (.NOT.lsame(uplo,'L'))) THEN
251  info = 1
252  ELSE IF ((.NOT.lsame(trans,'N')) .AND.
253  + (.NOT.lsame(trans,'C'))) THEN
254  info = 2
255  ELSE IF (n.LT.0) THEN
256  info = 3
257  ELSE IF (k.LT.0) THEN
258  info = 4
259  ELSE IF (lda.LT.max(1,nrowa)) THEN
260  info = 7
261  ELSE IF (ldb.LT.max(1,nrowa)) THEN
262  info = 9
263  ELSE IF (ldc.LT.max(1,n)) THEN
264  info = 12
265  END IF
266  IF (info.NE.0) THEN
267  CALL xerbla('ZHER2K',info)
268  RETURN
269  END IF
270 *
271 * Quick return if possible.
272 *
273  IF ((n.EQ.0) .OR. (((alpha.EQ.zero).OR.
274  + (k.EQ.0)).AND. (beta.EQ.one))) RETURN
275 *
276 * And when alpha.eq.zero.
277 *
278  IF (alpha.EQ.zero) THEN
279  IF (upper) THEN
280  IF (beta.EQ.dble(zero)) THEN
281  DO 20 j = 1,n
282  DO 10 i = 1,j
283  c(i,j) = zero
284  10 CONTINUE
285  20 CONTINUE
286  ELSE
287  DO 40 j = 1,n
288  DO 30 i = 1,j - 1
289  c(i,j) = beta*c(i,j)
290  30 CONTINUE
291  c(j,j) = beta*dble(c(j,j))
292  40 CONTINUE
293  END IF
294  ELSE
295  IF (beta.EQ.dble(zero)) THEN
296  DO 60 j = 1,n
297  DO 50 i = j,n
298  c(i,j) = zero
299  50 CONTINUE
300  60 CONTINUE
301  ELSE
302  DO 80 j = 1,n
303  c(j,j) = beta*dble(c(j,j))
304  DO 70 i = j + 1,n
305  c(i,j) = beta*c(i,j)
306  70 CONTINUE
307  80 CONTINUE
308  END IF
309  END IF
310  RETURN
311  END IF
312 *
313 * Start the operations.
314 *
315  IF (lsame(trans,'N')) THEN
316 *
317 * Form C := alpha*A*B**H + conjg( alpha )*B*A**H +
318 * C.
319 *
320  IF (upper) THEN
321  DO 130 j = 1,n
322  IF (beta.EQ.dble(zero)) THEN
323  DO 90 i = 1,j
324  c(i,j) = zero
325  90 CONTINUE
326  ELSE IF (beta.NE.one) THEN
327  DO 100 i = 1,j - 1
328  c(i,j) = beta*c(i,j)
329  100 CONTINUE
330  c(j,j) = beta*dble(c(j,j))
331  ELSE
332  c(j,j) = dble(c(j,j))
333  END IF
334  DO 120 l = 1,k
335  IF ((a(j,l).NE.zero) .OR. (b(j,l).NE.zero)) THEN
336  temp1 = alpha*dconjg(b(j,l))
337  temp2 = dconjg(alpha*a(j,l))
338  DO 110 i = 1,j - 1
339  c(i,j) = c(i,j) + a(i,l)*temp1 +
340  + b(i,l)*temp2
341  110 CONTINUE
342  c(j,j) = dble(c(j,j)) +
343  + dble(a(j,l)*temp1+b(j,l)*temp2)
344  END IF
345  120 CONTINUE
346  130 CONTINUE
347  ELSE
348  DO 180 j = 1,n
349  IF (beta.EQ.dble(zero)) THEN
350  DO 140 i = j,n
351  c(i,j) = zero
352  140 CONTINUE
353  ELSE IF (beta.NE.one) THEN
354  DO 150 i = j + 1,n
355  c(i,j) = beta*c(i,j)
356  150 CONTINUE
357  c(j,j) = beta*dble(c(j,j))
358  ELSE
359  c(j,j) = dble(c(j,j))
360  END IF
361  DO 170 l = 1,k
362  IF ((a(j,l).NE.zero) .OR. (b(j,l).NE.zero)) THEN
363  temp1 = alpha*dconjg(b(j,l))
364  temp2 = dconjg(alpha*a(j,l))
365  DO 160 i = j + 1,n
366  c(i,j) = c(i,j) + a(i,l)*temp1 +
367  + b(i,l)*temp2
368  160 CONTINUE
369  c(j,j) = dble(c(j,j)) +
370  + dble(a(j,l)*temp1+b(j,l)*temp2)
371  END IF
372  170 CONTINUE
373  180 CONTINUE
374  END IF
375  ELSE
376 *
377 * Form C := alpha*A**H*B + conjg( alpha )*B**H*A +
378 * C.
379 *
380  IF (upper) THEN
381  DO 210 j = 1,n
382  DO 200 i = 1,j
383  temp1 = zero
384  temp2 = zero
385  DO 190 l = 1,k
386  temp1 = temp1 + dconjg(a(l,i))*b(l,j)
387  temp2 = temp2 + dconjg(b(l,i))*a(l,j)
388  190 CONTINUE
389  IF (i.EQ.j) THEN
390  IF (beta.EQ.dble(zero)) THEN
391  c(j,j) = dble(alpha*temp1+
392  + dconjg(alpha)*temp2)
393  ELSE
394  c(j,j) = beta*dble(c(j,j)) +
395  + dble(alpha*temp1+
396  + dconjg(alpha)*temp2)
397  END IF
398  ELSE
399  IF (beta.EQ.dble(zero)) THEN
400  c(i,j) = alpha*temp1 + dconjg(alpha)*temp2
401  ELSE
402  c(i,j) = beta*c(i,j) + alpha*temp1 +
403  + dconjg(alpha)*temp2
404  END IF
405  END IF
406  200 CONTINUE
407  210 CONTINUE
408  ELSE
409  DO 240 j = 1,n
410  DO 230 i = j,n
411  temp1 = zero
412  temp2 = zero
413  DO 220 l = 1,k
414  temp1 = temp1 + dconjg(a(l,i))*b(l,j)
415  temp2 = temp2 + dconjg(b(l,i))*a(l,j)
416  220 CONTINUE
417  IF (i.EQ.j) THEN
418  IF (beta.EQ.dble(zero)) THEN
419  c(j,j) = dble(alpha*temp1+
420  + dconjg(alpha)*temp2)
421  ELSE
422  c(j,j) = beta*dble(c(j,j)) +
423  + dble(alpha*temp1+
424  + dconjg(alpha)*temp2)
425  END IF
426  ELSE
427  IF (beta.EQ.dble(zero)) THEN
428  c(i,j) = alpha*temp1 + dconjg(alpha)*temp2
429  ELSE
430  c(i,j) = beta*c(i,j) + alpha*temp1 +
431  + dconjg(alpha)*temp2
432  END IF
433  END IF
434  230 CONTINUE
435  240 CONTINUE
436  END IF
437  END IF
438 *
439  RETURN
440 *
441 * End of ZHER2K.
442 *
443  END
xerbla
subroutine xerbla(SRNAME, INFO)
XERBLA
Definition: xerbla.f:62
zher2k
subroutine zher2k(UPLO, TRANS, N, K, ALPHA, A, LDA, B, LDB, BETA, C, LDC)
ZHER2K
Definition: zher2k.f:200