LAPACK 3.12.0
LAPACK: Linear Algebra PACKage
Loading...
Searching...
No Matches
cherk.f
Go to the documentation of this file.
1*> \brief \b CHERK
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 CHERK(UPLO,TRANS,N,K,ALPHA,A,LDA,BETA,C,LDC)
12*
13* .. Scalar Arguments ..
14* REAL ALPHA,BETA
15* INTEGER K,LDA,LDC,N
16* CHARACTER TRANS,UPLO
17* ..
18* .. Array Arguments ..
19* COMPLEX A(LDA,*),C(LDC,*)
20* ..
21*
22*
23*> \par Purpose:
24* =============
25*>
26*> \verbatim
27*>
28*> CHERK 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 REAL
88*> On entry, ALPHA specifies the scalar alpha.
89*> \endverbatim
90*>
91*> \param[in] A
92*> \verbatim
93*> A is COMPLEX array, 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 REAL
113*> On entry, BETA specifies the scalar beta.
114*> \endverbatim
115*>
116*> \param[in,out] C
117*> \verbatim
118*> C is COMPLEX array, 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*> \ingroup herk
153*
154*> \par Further Details:
155* =====================
156*>
157*> \verbatim
158*>
159*> Level 3 Blas routine.
160*>
161*> -- Written on 8-February-1989.
162*> Jack Dongarra, Argonne National Laboratory.
163*> Iain Duff, AERE Harwell.
164*> Jeremy Du Croz, Numerical Algorithms Group Ltd.
165*> Sven Hammarling, Numerical Algorithms Group Ltd.
166*>
167*> -- Modified 8-Nov-93 to set C(J,J) to REAL( C(J,J) ) when BETA = 1.
168*> Ed Anderson, Cray Research Inc.
169*> \endverbatim
170*>
171* =====================================================================
172 SUBROUTINE cherk(UPLO,TRANS,N,K,ALPHA,A,LDA,BETA,C,LDC)
173*
174* -- Reference BLAS level3 routine --
175* -- Reference BLAS is a software package provided by Univ. of Tennessee, --
176* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
177*
178* .. Scalar Arguments ..
179 REAL ALPHA,BETA
180 INTEGER K,LDA,LDC,N
181 CHARACTER TRANS,UPLO
182* ..
183* .. Array Arguments ..
184 COMPLEX A(LDA,*),C(LDC,*)
185* ..
186*
187* =====================================================================
188*
189* .. External Functions ..
190 LOGICAL LSAME
191 EXTERNAL lsame
192* ..
193* .. External Subroutines ..
194 EXTERNAL xerbla
195* ..
196* .. Intrinsic Functions ..
197 INTRINSIC cmplx,conjg,max,real
198* ..
199* .. Local Scalars ..
200 COMPLEX TEMP
201 REAL RTEMP
202 INTEGER I,INFO,J,L,NROWA
203 LOGICAL UPPER
204* ..
205* .. Parameters ..
206 REAL ONE,ZERO
207 parameter(one=1.0e+0,zero=0.0e+0)
208* ..
209*
210* Test the input parameters.
211*
212 IF (lsame(trans,'N')) THEN
213 nrowa = n
214 ELSE
215 nrowa = k
216 END IF
217 upper = lsame(uplo,'U')
218*
219 info = 0
220 IF ((.NOT.upper) .AND. (.NOT.lsame(uplo,'L'))) THEN
221 info = 1
222 ELSE IF ((.NOT.lsame(trans,'N')) .AND.
223 + (.NOT.lsame(trans,'C'))) THEN
224 info = 2
225 ELSE IF (n.LT.0) THEN
226 info = 3
227 ELSE IF (k.LT.0) THEN
228 info = 4
229 ELSE IF (lda.LT.max(1,nrowa)) THEN
230 info = 7
231 ELSE IF (ldc.LT.max(1,n)) THEN
232 info = 10
233 END IF
234 IF (info.NE.0) THEN
235 CALL xerbla('CHERK ',info)
236 RETURN
237 END IF
238*
239* Quick return if possible.
240*
241 IF ((n.EQ.0) .OR. (((alpha.EQ.zero).OR.
242 + (k.EQ.0)).AND. (beta.EQ.one))) RETURN
243*
244* And when alpha.eq.zero.
245*
246 IF (alpha.EQ.zero) THEN
247 IF (upper) THEN
248 IF (beta.EQ.zero) THEN
249 DO 20 j = 1,n
250 DO 10 i = 1,j
251 c(i,j) = zero
252 10 CONTINUE
253 20 CONTINUE
254 ELSE
255 DO 40 j = 1,n
256 DO 30 i = 1,j - 1
257 c(i,j) = beta*c(i,j)
258 30 CONTINUE
259 c(j,j) = beta*real(c(j,j))
260 40 CONTINUE
261 END IF
262 ELSE
263 IF (beta.EQ.zero) THEN
264 DO 60 j = 1,n
265 DO 50 i = j,n
266 c(i,j) = zero
267 50 CONTINUE
268 60 CONTINUE
269 ELSE
270 DO 80 j = 1,n
271 c(j,j) = beta*real(c(j,j))
272 DO 70 i = j + 1,n
273 c(i,j) = beta*c(i,j)
274 70 CONTINUE
275 80 CONTINUE
276 END IF
277 END IF
278 RETURN
279 END IF
280*
281* Start the operations.
282*
283 IF (lsame(trans,'N')) THEN
284*
285* Form C := alpha*A*A**H + beta*C.
286*
287 IF (upper) THEN
288 DO 130 j = 1,n
289 IF (beta.EQ.zero) THEN
290 DO 90 i = 1,j
291 c(i,j) = zero
292 90 CONTINUE
293 ELSE IF (beta.NE.one) THEN
294 DO 100 i = 1,j - 1
295 c(i,j) = beta*c(i,j)
296 100 CONTINUE
297 c(j,j) = beta*real(c(j,j))
298 ELSE
299 c(j,j) = real(c(j,j))
300 END IF
301 DO 120 l = 1,k
302 IF (a(j,l).NE.cmplx(zero)) THEN
303 temp = alpha*conjg(a(j,l))
304 DO 110 i = 1,j - 1
305 c(i,j) = c(i,j) + temp*a(i,l)
306 110 CONTINUE
307 c(j,j) = real(c(j,j)) + real(temp*a(i,l))
308 END IF
309 120 CONTINUE
310 130 CONTINUE
311 ELSE
312 DO 180 j = 1,n
313 IF (beta.EQ.zero) THEN
314 DO 140 i = j,n
315 c(i,j) = zero
316 140 CONTINUE
317 ELSE IF (beta.NE.one) THEN
318 c(j,j) = beta*real(c(j,j))
319 DO 150 i = j + 1,n
320 c(i,j) = beta*c(i,j)
321 150 CONTINUE
322 ELSE
323 c(j,j) = real(c(j,j))
324 END IF
325 DO 170 l = 1,k
326 IF (a(j,l).NE.cmplx(zero)) THEN
327 temp = alpha*conjg(a(j,l))
328 c(j,j) = real(c(j,j)) + real(temp*a(j,l))
329 DO 160 i = j + 1,n
330 c(i,j) = c(i,j) + temp*a(i,l)
331 160 CONTINUE
332 END IF
333 170 CONTINUE
334 180 CONTINUE
335 END IF
336 ELSE
337*
338* Form C := alpha*A**H*A + beta*C.
339*
340 IF (upper) THEN
341 DO 220 j = 1,n
342 DO 200 i = 1,j - 1
343 temp = zero
344 DO 190 l = 1,k
345 temp = temp + conjg(a(l,i))*a(l,j)
346 190 CONTINUE
347 IF (beta.EQ.zero) THEN
348 c(i,j) = alpha*temp
349 ELSE
350 c(i,j) = alpha*temp + beta*c(i,j)
351 END IF
352 200 CONTINUE
353 rtemp = zero
354 DO 210 l = 1,k
355 rtemp = rtemp + real(conjg(a(l,j))*a(l,j))
356 210 CONTINUE
357 IF (beta.EQ.zero) THEN
358 c(j,j) = alpha*rtemp
359 ELSE
360 c(j,j) = alpha*rtemp + beta*real(c(j,j))
361 END IF
362 220 CONTINUE
363 ELSE
364 DO 260 j = 1,n
365 rtemp = zero
366 DO 230 l = 1,k
367 rtemp = rtemp + real(conjg(a(l,j))*a(l,j))
368 230 CONTINUE
369 IF (beta.EQ.zero) THEN
370 c(j,j) = alpha*rtemp
371 ELSE
372 c(j,j) = alpha*rtemp + beta*real(c(j,j))
373 END IF
374 DO 250 i = j + 1,n
375 temp = zero
376 DO 240 l = 1,k
377 temp = temp + conjg(a(l,i))*a(l,j)
378 240 CONTINUE
379 IF (beta.EQ.zero) THEN
380 c(i,j) = alpha*temp
381 ELSE
382 c(i,j) = alpha*temp + beta*c(i,j)
383 END IF
384 250 CONTINUE
385 260 CONTINUE
386 END IF
387 END IF
388*
389 RETURN
390*
391* End of CHERK
392*
393 END
subroutine xerbla(srname, info)
Definition cblat2.f:3285
subroutine cherk(uplo, trans, n, k, alpha, a, lda, beta, c, ldc)
CHERK
Definition cherk.f:173