LAPACK 3.12.1
LAPACK: Linear Algebra PACKage
Loading...
Searching...
No Matches
chfrk.f
Go to the documentation of this file.
1*> \brief \b CHFRK performs a Hermitian rank-k operation for matrix in RFP format.
2*
3* =========== DOCUMENTATION ===========
4*
5* Online html documentation available at
6* http://www.netlib.org/lapack/explore-html/
7*
8*> Download CHFRK + dependencies
9*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/chfrk.f">
10*> [TGZ]</a>
11*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/chfrk.f">
12*> [ZIP]</a>
13*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/chfrk.f">
14*> [TXT]</a>
15*
16* Definition:
17* ===========
18*
19* SUBROUTINE CHFRK( TRANSR, UPLO, TRANS, N, K, ALPHA, A, LDA, BETA,
20* C )
21*
22* .. Scalar Arguments ..
23* REAL ALPHA, BETA
24* INTEGER K, LDA, N
25* CHARACTER TRANS, TRANSR, UPLO
26* ..
27* .. Array Arguments ..
28* COMPLEX A( LDA, * ), C( * )
29* ..
30*
31*
32*> \par Purpose:
33* =============
34*>
35*> \verbatim
36*>
37*> Level 3 BLAS like routine for C in RFP Format.
38*>
39*> CHFRK performs one of the Hermitian rank--k operations
40*>
41*> C := alpha*A*A**H + beta*C,
42*>
43*> or
44*>
45*> C := alpha*A**H*A + beta*C,
46*>
47*> where alpha and beta are real scalars, C is an n--by--n Hermitian
48*> matrix and A is an n--by--k matrix in the first case and a k--by--n
49*> matrix in the second case.
50*> \endverbatim
51*
52* Arguments:
53* ==========
54*
55*> \param[in] TRANSR
56*> \verbatim
57*> TRANSR is CHARACTER*1
58*> = 'N': The Normal Form of RFP A is stored;
59*> = 'C': The Conjugate-transpose Form of RFP A is stored.
60*> \endverbatim
61*>
62*> \param[in] UPLO
63*> \verbatim
64*> UPLO is CHARACTER*1
65*> On entry, UPLO specifies whether the upper or lower
66*> triangular part of the array C is to be referenced as
67*> follows:
68*>
69*> UPLO = 'U' or 'u' Only the upper triangular part of C
70*> is to be referenced.
71*>
72*> UPLO = 'L' or 'l' Only the lower triangular part of C
73*> is to be referenced.
74*>
75*> Unchanged on exit.
76*> \endverbatim
77*>
78*> \param[in] TRANS
79*> \verbatim
80*> TRANS is CHARACTER*1
81*> On entry, TRANS specifies the operation to be performed as
82*> follows:
83*>
84*> TRANS = 'N' or 'n' C := alpha*A*A**H + beta*C.
85*>
86*> TRANS = 'C' or 'c' C := alpha*A**H*A + beta*C.
87*>
88*> Unchanged on exit.
89*> \endverbatim
90*>
91*> \param[in] N
92*> \verbatim
93*> N is INTEGER
94*> On entry, N specifies the order of the matrix C. N must be
95*> at least zero.
96*> Unchanged on exit.
97*> \endverbatim
98*>
99*> \param[in] K
100*> \verbatim
101*> K is INTEGER
102*> On entry with TRANS = 'N' or 'n', K specifies the number
103*> of columns of the matrix A, and on entry with
104*> TRANS = 'C' or 'c', K specifies the number of rows of the
105*> matrix A. K must be at least zero.
106*> Unchanged on exit.
107*> \endverbatim
108*>
109*> \param[in] ALPHA
110*> \verbatim
111*> ALPHA is REAL
112*> On entry, ALPHA specifies the scalar alpha.
113*> Unchanged on exit.
114*> \endverbatim
115*>
116*> \param[in] A
117*> \verbatim
118*> A is COMPLEX array, dimension (LDA,ka)
119*> where KA
120*> is K when TRANS = 'N' or 'n', and is N otherwise. Before
121*> entry with TRANS = 'N' or 'n', the leading N--by--K part of
122*> the array A must contain the matrix A, otherwise the leading
123*> K--by--N part of the array A must contain the matrix A.
124*> Unchanged on exit.
125*> \endverbatim
126*>
127*> \param[in] LDA
128*> \verbatim
129*> LDA is INTEGER
130*> On entry, LDA specifies the first dimension of A as declared
131*> in the calling (sub) program. When TRANS = 'N' or 'n'
132*> then LDA must be at least max( 1, n ), otherwise LDA must
133*> be at least max( 1, k ).
134*> Unchanged on exit.
135*> \endverbatim
136*>
137*> \param[in] BETA
138*> \verbatim
139*> BETA is REAL
140*> On entry, BETA specifies the scalar beta.
141*> Unchanged on exit.
142*> \endverbatim
143*>
144*> \param[in,out] C
145*> \verbatim
146*> C is COMPLEX array, dimension (N*(N+1)/2)
147*> On entry, the matrix A in RFP Format. RFP Format is
148*> described by TRANSR, UPLO and N. Note that the imaginary
149*> parts of the diagonal elements need not be set, they are
150*> assumed to be zero, and on exit they are set to zero.
151*> \endverbatim
152*
153* Authors:
154* ========
155*
156*> \author Univ. of Tennessee
157*> \author Univ. of California Berkeley
158*> \author Univ. of Colorado Denver
159*> \author NAG Ltd.
160*
161*> \ingroup hfrk
162*
163* =====================================================================
164 SUBROUTINE chfrk( TRANSR, UPLO, TRANS, N, K, ALPHA, A, LDA,
165 $ BETA,
166 $ C )
167*
168* -- LAPACK computational routine --
169* -- LAPACK is a software package provided by Univ. of Tennessee, --
170* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
171*
172* .. Scalar Arguments ..
173 REAL ALPHA, BETA
174 INTEGER K, LDA, N
175 CHARACTER TRANS, TRANSR, UPLO
176* ..
177* .. Array Arguments ..
178 COMPLEX A( LDA, * ), C( * )
179* ..
180*
181* =====================================================================
182*
183* ..
184* .. Parameters ..
185 REAL ONE, ZERO
186 COMPLEX CZERO
187 parameter( one = 1.0e+0, zero = 0.0e+0 )
188 parameter( czero = ( 0.0e+0, 0.0e+0 ) )
189* ..
190* .. Local Scalars ..
191 LOGICAL LOWER, NORMALTRANSR, NISODD, NOTRANS
192 INTEGER INFO, NROWA, J, NK, N1, N2
193 COMPLEX CALPHA, CBETA
194* ..
195* .. External Functions ..
196 LOGICAL LSAME
197 EXTERNAL LSAME
198* ..
199* .. External Subroutines ..
200 EXTERNAL cgemm, cherk, xerbla
201* ..
202* .. Intrinsic Functions ..
203 INTRINSIC max, cmplx
204* ..
205* .. Executable Statements ..
206*
207*
208* Test the input parameters.
209*
210 info = 0
211 normaltransr = lsame( transr, 'N' )
212 lower = lsame( uplo, 'L' )
213 notrans = lsame( trans, 'N' )
214*
215 IF( notrans ) THEN
216 nrowa = n
217 ELSE
218 nrowa = k
219 END IF
220*
221 IF( .NOT.normaltransr .AND. .NOT.lsame( transr, 'C' ) ) THEN
222 info = -1
223 ELSE IF( .NOT.lower .AND. .NOT.lsame( uplo, 'U' ) ) THEN
224 info = -2
225 ELSE IF( .NOT.notrans .AND. .NOT.lsame( trans, 'C' ) ) THEN
226 info = -3
227 ELSE IF( n.LT.0 ) THEN
228 info = -4
229 ELSE IF( k.LT.0 ) THEN
230 info = -5
231 ELSE IF( lda.LT.max( 1, nrowa ) ) THEN
232 info = -8
233 END IF
234 IF( info.NE.0 ) THEN
235 CALL xerbla( 'CHFRK ', -info )
236 RETURN
237 END IF
238*
239* Quick return if possible.
240*
241* The quick return case: ((ALPHA.EQ.0).AND.(BETA.NE.ZERO)) is not
242* done (it is in CHERK for example) and left in the general case.
243*
244 IF( ( n.EQ.0 ) .OR. ( ( ( alpha.EQ.zero ) .OR. ( k.EQ.0 ) ) .AND.
245 $ ( beta.EQ.one ) ) )RETURN
246*
247 IF( ( alpha.EQ.zero ) .AND. ( beta.EQ.zero ) ) THEN
248 DO j = 1, ( ( n*( n+1 ) ) / 2 )
249 c( j ) = czero
250 END DO
251 RETURN
252 END IF
253*
254 calpha = cmplx( alpha, zero )
255 cbeta = cmplx( beta, zero )
256*
257* C is N-by-N.
258* If N is odd, set NISODD = .TRUE., and N1 and N2.
259* If N is even, NISODD = .FALSE., and NK.
260*
261 IF( mod( n, 2 ).EQ.0 ) THEN
262 nisodd = .false.
263 nk = n / 2
264 ELSE
265 nisodd = .true.
266 IF( lower ) THEN
267 n2 = n / 2
268 n1 = n - n2
269 ELSE
270 n1 = n / 2
271 n2 = n - n1
272 END IF
273 END IF
274*
275 IF( nisodd ) THEN
276*
277* N is odd
278*
279 IF( normaltransr ) THEN
280*
281* N is odd and TRANSR = 'N'
282*
283 IF( lower ) THEN
284*
285* N is odd, TRANSR = 'N', and UPLO = 'L'
286*
287 IF( notrans ) THEN
288*
289* N is odd, TRANSR = 'N', UPLO = 'L', and TRANS = 'N'
290*
291 CALL cherk( 'L', 'N', n1, k, alpha, a( 1, 1 ), lda,
292 $ beta, c( 1 ), n )
293 CALL cherk( 'U', 'N', n2, k, alpha, a( n1+1, 1 ),
294 $ lda,
295 $ beta, c( n+1 ), n )
296 CALL cgemm( 'N', 'C', n2, n1, k, calpha, a( n1+1,
297 $ 1 ),
298 $ lda, a( 1, 1 ), lda, cbeta, c( n1+1 ), n )
299*
300 ELSE
301*
302* N is odd, TRANSR = 'N', UPLO = 'L', and TRANS = 'C'
303*
304 CALL cherk( 'L', 'C', n1, k, alpha, a( 1, 1 ), lda,
305 $ beta, c( 1 ), n )
306 CALL cherk( 'U', 'C', n2, k, alpha, a( 1, n1+1 ),
307 $ lda,
308 $ beta, c( n+1 ), n )
309 CALL cgemm( 'C', 'N', n2, n1, k, calpha, a( 1,
310 $ n1+1 ),
311 $ lda, a( 1, 1 ), lda, cbeta, c( n1+1 ), n )
312*
313 END IF
314*
315 ELSE
316*
317* N is odd, TRANSR = 'N', and UPLO = 'U'
318*
319 IF( notrans ) THEN
320*
321* N is odd, TRANSR = 'N', UPLO = 'U', and TRANS = 'N'
322*
323 CALL cherk( 'L', 'N', n1, k, alpha, a( 1, 1 ), lda,
324 $ beta, c( n2+1 ), n )
325 CALL cherk( 'U', 'N', n2, k, alpha, a( n2, 1 ),
326 $ lda,
327 $ beta, c( n1+1 ), n )
328 CALL cgemm( 'N', 'C', n1, n2, k, calpha, a( 1, 1 ),
329 $ lda, a( n2, 1 ), lda, cbeta, c( 1 ), n )
330*
331 ELSE
332*
333* N is odd, TRANSR = 'N', UPLO = 'U', and TRANS = 'C'
334*
335 CALL cherk( 'L', 'C', n1, k, alpha, a( 1, 1 ), lda,
336 $ beta, c( n2+1 ), n )
337 CALL cherk( 'U', 'C', n2, k, alpha, a( 1, n2 ),
338 $ lda,
339 $ beta, c( n1+1 ), n )
340 CALL cgemm( 'C', 'N', n1, n2, k, calpha, a( 1, 1 ),
341 $ lda, a( 1, n2 ), lda, cbeta, c( 1 ), n )
342*
343 END IF
344*
345 END IF
346*
347 ELSE
348*
349* N is odd, and TRANSR = 'C'
350*
351 IF( lower ) THEN
352*
353* N is odd, TRANSR = 'C', and UPLO = 'L'
354*
355 IF( notrans ) THEN
356*
357* N is odd, TRANSR = 'C', UPLO = 'L', and TRANS = 'N'
358*
359 CALL cherk( 'U', 'N', n1, k, alpha, a( 1, 1 ), lda,
360 $ beta, c( 1 ), n1 )
361 CALL cherk( 'L', 'N', n2, k, alpha, a( n1+1, 1 ),
362 $ lda,
363 $ beta, c( 2 ), n1 )
364 CALL cgemm( 'N', 'C', n1, n2, k, calpha, a( 1, 1 ),
365 $ lda, a( n1+1, 1 ), lda, cbeta,
366 $ c( n1*n1+1 ), n1 )
367*
368 ELSE
369*
370* N is odd, TRANSR = 'C', UPLO = 'L', and TRANS = 'C'
371*
372 CALL cherk( 'U', 'C', n1, k, alpha, a( 1, 1 ), lda,
373 $ beta, c( 1 ), n1 )
374 CALL cherk( 'L', 'C', n2, k, alpha, a( 1, n1+1 ),
375 $ lda,
376 $ beta, c( 2 ), n1 )
377 CALL cgemm( 'C', 'N', n1, n2, k, calpha, a( 1, 1 ),
378 $ lda, a( 1, n1+1 ), lda, cbeta,
379 $ c( n1*n1+1 ), n1 )
380*
381 END IF
382*
383 ELSE
384*
385* N is odd, TRANSR = 'C', and UPLO = 'U'
386*
387 IF( notrans ) THEN
388*
389* N is odd, TRANSR = 'C', UPLO = 'U', and TRANS = 'N'
390*
391 CALL cherk( 'U', 'N', n1, k, alpha, a( 1, 1 ), lda,
392 $ beta, c( n2*n2+1 ), n2 )
393 CALL cherk( 'L', 'N', n2, k, alpha, a( n1+1, 1 ),
394 $ lda,
395 $ beta, c( n1*n2+1 ), n2 )
396 CALL cgemm( 'N', 'C', n2, n1, k, calpha, a( n1+1,
397 $ 1 ),
398 $ lda, a( 1, 1 ), lda, cbeta, c( 1 ), n2 )
399*
400 ELSE
401*
402* N is odd, TRANSR = 'C', UPLO = 'U', and TRANS = 'C'
403*
404 CALL cherk( 'U', 'C', n1, k, alpha, a( 1, 1 ), lda,
405 $ beta, c( n2*n2+1 ), n2 )
406 CALL cherk( 'L', 'C', n2, k, alpha, a( 1, n1+1 ),
407 $ lda,
408 $ beta, c( n1*n2+1 ), n2 )
409 CALL cgemm( 'C', 'N', n2, n1, k, calpha, a( 1,
410 $ n1+1 ),
411 $ lda, a( 1, 1 ), lda, cbeta, c( 1 ), n2 )
412*
413 END IF
414*
415 END IF
416*
417 END IF
418*
419 ELSE
420*
421* N is even
422*
423 IF( normaltransr ) THEN
424*
425* N is even and TRANSR = 'N'
426*
427 IF( lower ) THEN
428*
429* N is even, TRANSR = 'N', and UPLO = 'L'
430*
431 IF( notrans ) THEN
432*
433* N is even, TRANSR = 'N', UPLO = 'L', and TRANS = 'N'
434*
435 CALL cherk( 'L', 'N', nk, k, alpha, a( 1, 1 ), lda,
436 $ beta, c( 2 ), n+1 )
437 CALL cherk( 'U', 'N', nk, k, alpha, a( nk+1, 1 ),
438 $ lda,
439 $ beta, c( 1 ), n+1 )
440 CALL cgemm( 'N', 'C', nk, nk, k, calpha, a( nk+1,
441 $ 1 ),
442 $ lda, a( 1, 1 ), lda, cbeta, c( nk+2 ),
443 $ n+1 )
444*
445 ELSE
446*
447* N is even, TRANSR = 'N', UPLO = 'L', and TRANS = 'C'
448*
449 CALL cherk( 'L', 'C', nk, k, alpha, a( 1, 1 ), lda,
450 $ beta, c( 2 ), n+1 )
451 CALL cherk( 'U', 'C', nk, k, alpha, a( 1, nk+1 ),
452 $ lda,
453 $ beta, c( 1 ), n+1 )
454 CALL cgemm( 'C', 'N', nk, nk, k, calpha, a( 1,
455 $ nk+1 ),
456 $ lda, a( 1, 1 ), lda, cbeta, c( nk+2 ),
457 $ n+1 )
458*
459 END IF
460*
461 ELSE
462*
463* N is even, TRANSR = 'N', and UPLO = 'U'
464*
465 IF( notrans ) THEN
466*
467* N is even, TRANSR = 'N', UPLO = 'U', and TRANS = 'N'
468*
469 CALL cherk( 'L', 'N', nk, k, alpha, a( 1, 1 ), lda,
470 $ beta, c( nk+2 ), n+1 )
471 CALL cherk( 'U', 'N', nk, k, alpha, a( nk+1, 1 ),
472 $ lda,
473 $ beta, c( nk+1 ), n+1 )
474 CALL cgemm( 'N', 'C', nk, nk, k, calpha, a( 1, 1 ),
475 $ lda, a( nk+1, 1 ), lda, cbeta, c( 1 ),
476 $ n+1 )
477*
478 ELSE
479*
480* N is even, TRANSR = 'N', UPLO = 'U', and TRANS = 'C'
481*
482 CALL cherk( 'L', 'C', nk, k, alpha, a( 1, 1 ), lda,
483 $ beta, c( nk+2 ), n+1 )
484 CALL cherk( 'U', 'C', nk, k, alpha, a( 1, nk+1 ),
485 $ lda,
486 $ beta, c( nk+1 ), n+1 )
487 CALL cgemm( 'C', 'N', nk, nk, k, calpha, a( 1, 1 ),
488 $ lda, a( 1, nk+1 ), lda, cbeta, c( 1 ),
489 $ n+1 )
490*
491 END IF
492*
493 END IF
494*
495 ELSE
496*
497* N is even, and TRANSR = 'C'
498*
499 IF( lower ) THEN
500*
501* N is even, TRANSR = 'C', and UPLO = 'L'
502*
503 IF( notrans ) THEN
504*
505* N is even, TRANSR = 'C', UPLO = 'L', and TRANS = 'N'
506*
507 CALL cherk( 'U', 'N', nk, k, alpha, a( 1, 1 ), lda,
508 $ beta, c( nk+1 ), nk )
509 CALL cherk( 'L', 'N', nk, k, alpha, a( nk+1, 1 ),
510 $ lda,
511 $ beta, c( 1 ), nk )
512 CALL cgemm( 'N', 'C', nk, nk, k, calpha, a( 1, 1 ),
513 $ lda, a( nk+1, 1 ), lda, cbeta,
514 $ c( ( ( nk+1 )*nk )+1 ), nk )
515*
516 ELSE
517*
518* N is even, TRANSR = 'C', UPLO = 'L', and TRANS = 'C'
519*
520 CALL cherk( 'U', 'C', nk, k, alpha, a( 1, 1 ), lda,
521 $ beta, c( nk+1 ), nk )
522 CALL cherk( 'L', 'C', nk, k, alpha, a( 1, nk+1 ),
523 $ lda,
524 $ beta, c( 1 ), nk )
525 CALL cgemm( 'C', 'N', nk, nk, k, calpha, a( 1, 1 ),
526 $ lda, a( 1, nk+1 ), lda, cbeta,
527 $ c( ( ( nk+1 )*nk )+1 ), nk )
528*
529 END IF
530*
531 ELSE
532*
533* N is even, TRANSR = 'C', and UPLO = 'U'
534*
535 IF( notrans ) THEN
536*
537* N is even, TRANSR = 'C', UPLO = 'U', and TRANS = 'N'
538*
539 CALL cherk( 'U', 'N', nk, k, alpha, a( 1, 1 ), lda,
540 $ beta, c( nk*( nk+1 )+1 ), nk )
541 CALL cherk( 'L', 'N', nk, k, alpha, a( nk+1, 1 ),
542 $ lda,
543 $ beta, c( nk*nk+1 ), nk )
544 CALL cgemm( 'N', 'C', nk, nk, k, calpha, a( nk+1,
545 $ 1 ),
546 $ lda, a( 1, 1 ), lda, cbeta, c( 1 ), nk )
547*
548 ELSE
549*
550* N is even, TRANSR = 'C', UPLO = 'U', and TRANS = 'C'
551*
552 CALL cherk( 'U', 'C', nk, k, alpha, a( 1, 1 ), lda,
553 $ beta, c( nk*( nk+1 )+1 ), nk )
554 CALL cherk( 'L', 'C', nk, k, alpha, a( 1, nk+1 ),
555 $ lda,
556 $ beta, c( nk*nk+1 ), nk )
557 CALL cgemm( 'C', 'N', nk, nk, k, calpha, a( 1,
558 $ nk+1 ),
559 $ lda, a( 1, 1 ), lda, cbeta, c( 1 ), nk )
560*
561 END IF
562*
563 END IF
564*
565 END IF
566*
567 END IF
568*
569 RETURN
570*
571* End of CHFRK
572*
573 END
xerbla
subroutine xerbla(srname, info)
Definition cblat2.f:3285
cgemm
subroutine cgemm(transa, transb, m, n, k, alpha, a, lda, b, ldb, beta, c, ldc)
CGEMM
Definition cgemm.f:188
cherk
subroutine cherk(uplo, trans, n, k, alpha, a, lda, beta, c, ldc)
CHERK
Definition cherk.f:173
chfrk
subroutine chfrk(transr, uplo, trans, n, k, alpha, a, lda, beta, c)
CHFRK performs a Hermitian rank-k operation for matrix in RFP format.
Definition chfrk.f:167