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