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