168 SUBROUTINE chfrk( TRANSR, UPLO, TRANS, N, K, ALPHA, A, LDA, BETA,
179 CHARACTER TRANS, TRANSR, UPLO
182 COMPLEX A( lda, * ), C( * )
191 parameter( one = 1.0e+0, zero = 0.0e+0 )
192 parameter( czero = ( 0.0e+0, 0.0e+0 ) )
195 LOGICAL LOWER, NORMALTRANSR, NISODD, NOTRANS
196 INTEGER INFO, NROWA, J, NK, N1, N2
197 COMPLEX CALPHA, CBETA
215 normaltransr = lsame( transr,
'N' )
216 lower = lsame( uplo,
'L' )
217 notrans = lsame( trans,
'N' )
225 IF( .NOT.normaltransr .AND. .NOT.lsame( transr,
'C' ) )
THEN
227 ELSE IF( .NOT.lower .AND. .NOT.lsame( uplo,
'U' ) )
THEN
229 ELSE IF( .NOT.notrans .AND. .NOT.lsame( trans,
'C' ) )
THEN
231 ELSE IF( n.LT.0 )
THEN
233 ELSE IF( k.LT.0 )
THEN
235 ELSE IF( lda.LT.max( 1, nrowa ) )
THEN
239 CALL
xerbla(
'CHFRK ', -info )
248 IF( ( n.EQ.0 ) .OR. ( ( ( alpha.EQ.zero ) .OR. ( k.EQ.0 ) ) .AND.
249 $ ( beta.EQ.one ) ) )
RETURN
251 IF( ( alpha.EQ.zero ) .AND. ( beta.EQ.zero ) )
THEN
252 DO j = 1, ( ( n*( n+1 ) ) / 2 )
258 calpha = cmplx( alpha, zero )
259 cbeta = cmplx( beta, zero )
265 IF( mod( n, 2 ).EQ.0 )
THEN
283 IF( normaltransr )
THEN
295 CALL
cherk(
'L',
'N', n1, k, alpha, a( 1, 1 ), lda,
297 CALL
cherk(
'U',
'N', n2, k, alpha, a( n1+1, 1 ), lda,
298 $ beta, c( n+1 ), n )
299 CALL
cgemm(
'N',
'C', n2, n1, k, calpha, a( n1+1, 1 ),
300 $ lda, a( 1, 1 ), lda, cbeta, c( n1+1 ), n )
306 CALL
cherk(
'L',
'C', n1, k, alpha, a( 1, 1 ), lda,
308 CALL
cherk(
'U',
'C', n2, k, alpha, a( 1, n1+1 ), lda,
309 $ beta, c( n+1 ), n )
310 CALL
cgemm(
'C',
'N', n2, n1, k, calpha, a( 1, n1+1 ),
311 $ lda, a( 1, 1 ), lda, cbeta, c( n1+1 ), n )
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 ), lda,
326 $ beta, c( n1+1 ), n )
327 CALL
cgemm(
'N',
'C', n1, n2, k, calpha, a( 1, 1 ),
328 $ lda, a( n2, 1 ), lda, cbeta, c( 1 ), n )
334 CALL
cherk(
'L',
'C', n1, k, alpha, a( 1, 1 ), lda,
335 $ beta, c( n2+1 ), n )
336 CALL
cherk(
'U',
'C', n2, k, alpha, a( 1, n2 ), lda,
337 $ beta, c( n1+1 ), n )
338 CALL
cgemm(
'C',
'N', n1, n2, k, calpha, a( 1, 1 ),
339 $ lda, a( 1, n2 ), lda, cbeta, c( 1 ), n )
357 CALL
cherk(
'U',
'N', n1, k, alpha, a( 1, 1 ), lda,
359 CALL
cherk(
'L',
'N', n2, k, alpha, a( n1+1, 1 ), lda,
361 CALL
cgemm(
'N',
'C', n1, n2, k, calpha, a( 1, 1 ),
362 $ lda, a( n1+1, 1 ), lda, cbeta,
369 CALL
cherk(
'U',
'C', n1, k, alpha, a( 1, 1 ), lda,
371 CALL
cherk(
'L',
'C', n2, k, alpha, a( 1, n1+1 ), lda,
373 CALL
cgemm(
'C',
'N', n1, n2, k, calpha, a( 1, 1 ),
374 $ lda, a( 1, n1+1 ), lda, cbeta,
387 CALL
cherk(
'U',
'N', n1, k, alpha, a( 1, 1 ), lda,
388 $ beta, c( n2*n2+1 ), n2 )
389 CALL
cherk(
'L',
'N', n2, k, alpha, a( n1+1, 1 ), lda,
390 $ beta, c( n1*n2+1 ), n2 )
391 CALL
cgemm(
'N',
'C', n2, n1, k, calpha, a( n1+1, 1 ),
392 $ lda, a( 1, 1 ), lda, cbeta, c( 1 ), n2 )
398 CALL
cherk(
'U',
'C', n1, k, alpha, a( 1, 1 ), lda,
399 $ beta, c( n2*n2+1 ), n2 )
400 CALL
cherk(
'L',
'C', n2, k, alpha, a( 1, n1+1 ), lda,
401 $ beta, c( n1*n2+1 ), n2 )
402 CALL
cgemm(
'C',
'N', n2, n1, k, calpha, a( 1, n1+1 ),
403 $ lda, a( 1, 1 ), lda, cbeta, c( 1 ), n2 )
415 IF( normaltransr )
THEN
427 CALL
cherk(
'L',
'N', nk, k, alpha, a( 1, 1 ), lda,
428 $ beta, c( 2 ), n+1 )
429 CALL
cherk(
'U',
'N', nk, k, alpha, a( nk+1, 1 ), lda,
430 $ beta, c( 1 ), n+1 )
431 CALL
cgemm(
'N',
'C', nk, nk, k, calpha, a( nk+1, 1 ),
432 $ lda, a( 1, 1 ), lda, cbeta, c( nk+2 ),
439 CALL
cherk(
'L',
'C', nk, k, alpha, a( 1, 1 ), lda,
440 $ beta, c( 2 ), n+1 )
441 CALL
cherk(
'U',
'C', nk, k, alpha, a( 1, nk+1 ), lda,
442 $ beta, c( 1 ), n+1 )
443 CALL
cgemm(
'C',
'N', nk, nk, k, calpha, a( 1, nk+1 ),
444 $ lda, a( 1, 1 ), lda, cbeta, c( nk+2 ),
457 CALL
cherk(
'L',
'N', nk, k, alpha, a( 1, 1 ), lda,
458 $ beta, c( nk+2 ), n+1 )
459 CALL
cherk(
'U',
'N', nk, k, alpha, a( nk+1, 1 ), lda,
460 $ beta, c( nk+1 ), n+1 )
461 CALL
cgemm(
'N',
'C', nk, nk, k, calpha, a( 1, 1 ),
462 $ lda, a( nk+1, 1 ), lda, cbeta, c( 1 ),
469 CALL
cherk(
'L',
'C', nk, k, alpha, a( 1, 1 ), lda,
470 $ beta, c( nk+2 ), n+1 )
471 CALL
cherk(
'U',
'C', nk, k, alpha, a( 1, nk+1 ), lda,
472 $ beta, c( nk+1 ), n+1 )
473 CALL
cgemm(
'C',
'N', nk, nk, k, calpha, a( 1, 1 ),
474 $ lda, a( 1, nk+1 ), lda, cbeta, c( 1 ),
493 CALL
cherk(
'U',
'N', nk, k, alpha, a( 1, 1 ), lda,
494 $ beta, c( nk+1 ), nk )
495 CALL
cherk(
'L',
'N', nk, k, alpha, a( nk+1, 1 ), lda,
497 CALL
cgemm(
'N',
'C', nk, nk, k, calpha, a( 1, 1 ),
498 $ lda, a( nk+1, 1 ), lda, cbeta,
499 $ c( ( ( nk+1 )*nk )+1 ), nk )
505 CALL
cherk(
'U',
'C', nk, k, alpha, a( 1, 1 ), lda,
506 $ beta, c( nk+1 ), nk )
507 CALL
cherk(
'L',
'C', nk, k, alpha, a( 1, nk+1 ), lda,
509 CALL
cgemm(
'C',
'N', nk, nk, k, calpha, a( 1, 1 ),
510 $ lda, a( 1, nk+1 ), lda, cbeta,
511 $ c( ( ( nk+1 )*nk )+1 ), nk )
523 CALL
cherk(
'U',
'N', nk, k, alpha, a( 1, 1 ), lda,
524 $ beta, c( nk*( nk+1 )+1 ), nk )
525 CALL
cherk(
'L',
'N', nk, k, alpha, a( nk+1, 1 ), lda,
526 $ beta, c( nk*nk+1 ), nk )
527 CALL
cgemm(
'N',
'C', nk, nk, k, calpha, a( nk+1, 1 ),
528 $ lda, a( 1, 1 ), lda, cbeta, c( 1 ), nk )
534 CALL
cherk(
'U',
'C', nk, k, alpha, a( 1, 1 ), lda,
535 $ beta, c( nk*( nk+1 )+1 ), nk )
536 CALL
cherk(
'L',
'C', nk, k, alpha, a( 1, nk+1 ), lda,
537 $ beta, c( nk*nk+1 ), nk )
538 CALL
cgemm(
'C',
'N', nk, nk, k, calpha, a( 1, nk+1 ),
539 $ lda, a( 1, 1 ), lda, cbeta, c( 1 ), nk )
subroutine xerbla(SRNAME, INFO)
XERBLA
subroutine chfrk(TRANSR, UPLO, TRANS, N, K, ALPHA, A, LDA, BETA, C)
CHFRK performs a Hermitian rank-k operation for matrix in RFP format.
subroutine cgemm(TRANSA, TRANSB, M, N, K, ALPHA, A, LDA, B, LDB, BETA, C, LDC)
CGEMM
subroutine cherk(UPLO, TRANS, N, K, ALPHA, A, LDA, BETA, C, LDC)
CHERK