LAPACK 3.12.1
LAPACK: Linear Algebra PACKage
Loading...
Searching...
No Matches

◆ chfrk()

subroutine chfrk ( character transr,
character uplo,
character trans,
integer n,
integer k,
real alpha,
complex, dimension( lda, * ) a,
integer lda,
real beta,
complex, dimension( * ) c )

CHFRK performs a Hermitian rank-k operation for matrix in RFP format.

Download CHFRK + dependencies [TGZ] [ZIP] [TXT]

Purpose:
!>
!> Level 3 BLAS like routine for C in RFP Format.
!>
!> CHFRK performs one of the Hermitian rank--k operations
!>
!>    C := alpha*A*A**H + beta*C,
!>
!> or
!>
!>    C := alpha*A**H*A + beta*C,
!>
!> where alpha and beta are real scalars, C is an n--by--n Hermitian
!> matrix and A is an n--by--k matrix in the first case and a k--by--n
!> matrix in the second case.
!>
Parameters
[in]TRANSR
!>          TRANSR is CHARACTER*1
!>          = 'N':  The Normal Form of RFP A is stored;
!>          = 'C':  The Conjugate-transpose Form of RFP A is stored.
!>
[in]UPLO
!>          UPLO is CHARACTER*1
!>           On  entry,   UPLO  specifies  whether  the  upper  or  lower
!>           triangular  part  of the  array  C  is to be  referenced  as
!>           follows:
!>
!>              UPLO = 'U' or 'u'   Only the  upper triangular part of  C
!>                                  is to be referenced.
!>
!>              UPLO = 'L' or 'l'   Only the  lower triangular part of  C
!>                                  is to be referenced.
!>
!>           Unchanged on exit.
!>
[in]TRANS
!>          TRANS is CHARACTER*1
!>           On entry,  TRANS  specifies the operation to be performed as
!>           follows:
!>
!>              TRANS = 'N' or 'n'   C := alpha*A*A**H + beta*C.
!>
!>              TRANS = 'C' or 'c'   C := alpha*A**H*A + beta*C.
!>
!>           Unchanged on exit.
!>
[in]N
!>          N is INTEGER
!>           On entry,  N specifies the order of the matrix C.  N must be
!>           at least zero.
!>           Unchanged on exit.
!>
[in]K
!>          K is INTEGER
!>           On entry with  TRANS = 'N' or 'n',  K  specifies  the number
!>           of  columns   of  the   matrix   A,   and  on   entry   with
!>           TRANS = 'C' or 'c',  K  specifies  the number of rows of the
!>           matrix A.  K must be at least zero.
!>           Unchanged on exit.
!>
[in]ALPHA
!>          ALPHA is REAL
!>           On entry, ALPHA specifies the scalar alpha.
!>           Unchanged on exit.
!>
[in]A
!>          A is COMPLEX array, dimension (LDA,ka)
!>           where KA
!>           is K  when TRANS = 'N' or 'n', and is N otherwise. Before
!>           entry with TRANS = 'N' or 'n', the leading N--by--K part of
!>           the array A must contain the matrix A, otherwise the leading
!>           K--by--N part of the array A must contain the matrix A.
!>           Unchanged on exit.
!>
[in]LDA
!>          LDA is INTEGER
!>           On entry, LDA specifies the first dimension of A as declared
!>           in  the  calling  (sub)  program.   When  TRANS = 'N' or 'n'
!>           then  LDA must be at least  max( 1, n ), otherwise  LDA must
!>           be at least  max( 1, k ).
!>           Unchanged on exit.
!>
[in]BETA
!>          BETA is REAL
!>           On entry, BETA specifies the scalar beta.
!>           Unchanged on exit.
!>
[in,out]C
!>          C is COMPLEX array, dimension (N*(N+1)/2)
!>           On entry, the matrix A in RFP Format. RFP Format is
!>           described by TRANSR, UPLO and N. Note that the imaginary
!>           parts of the diagonal elements need not be set, they are
!>           assumed to be zero, and on exit they are set to zero.
!>
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.

Definition at line 164 of file chfrk.f.

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*
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
lsame
logical function lsame(ca, cb)
LSAME
Definition lsame.f:48
Here is the call graph for this function:
Here is the caller graph for this function: