168 SUBROUTINE zhfrk( TRANSR, UPLO, TRANS, N, K, ALPHA, A, LDA, BETA,
177 DOUBLE PRECISION alpha, beta
179 CHARACTER trans, transr, uplo
182 COMPLEX*16 a( lda, * ), c( * )
188 DOUBLE PRECISION one, zero
190 parameter( one = 1.0d+0, zero = 0.0d+0 )
191 parameter( czero = ( 0.0d+0, 0.0d+0 ) )
194 LOGICAL lower, normaltransr, nisodd, notrans
195 INTEGER info, nrowa,
j, nk, n1, n2
196 COMPLEX*16 calpha, cbeta
206 INTRINSIC max, dcmplx
214 normaltransr =
lsame( transr,
'N' )
215 lower =
lsame( uplo,
'L' )
216 notrans =
lsame( trans,
'N' )
224 IF( .NOT.normaltransr .AND. .NOT.
lsame( transr,
'C' ) )
THEN
226 ELSE IF( .NOT.lower .AND. .NOT.
lsame( uplo,
'U' ) )
THEN
228 ELSE IF( .NOT.notrans .AND. .NOT.
lsame( trans,
'C' ) )
THEN
230 ELSE IF( n.LT.0 )
THEN
232 ELSE IF( k.LT.0 )
THEN
234 ELSE IF( lda.LT.max( 1, nrowa ) )
THEN
238 CALL
xerbla(
'ZHFRK ', -info )
247 IF( ( n.EQ.0 ) .OR. ( ( ( alpha.EQ.zero ) .OR. ( k.EQ.0 ) ) .AND.
248 $ ( beta.EQ.one ) ) )
RETURN
250 IF( ( alpha.EQ.zero ) .AND. ( beta.EQ.zero ) )
THEN
251 DO j = 1, ( ( n*( n+1 ) ) / 2 )
257 calpha = dcmplx( alpha, zero )
258 cbeta = dcmplx( beta, zero )
264 IF( mod( n, 2 ).EQ.0 )
THEN
282 IF( normaltransr )
THEN
294 CALL
zherk(
'L',
'N', n1, k, alpha, a( 1, 1 ), lda,
296 CALL
zherk(
'U',
'N', n2, k, alpha, a( n1+1, 1 ), lda,
297 $ beta, c( n+1 ), n )
298 CALL
zgemm(
'N',
'C', n2, n1, k, calpha, a( n1+1, 1 ),
299 $ lda, a( 1, 1 ), lda, cbeta, c( n1+1 ), n )
305 CALL
zherk(
'L',
'C', n1, k, alpha, a( 1, 1 ), lda,
307 CALL
zherk(
'U',
'C', n2, k, alpha, a( 1, n1+1 ), lda,
308 $ beta, c( n+1 ), n )
309 CALL
zgemm(
'C',
'N', n2, n1, k, calpha, a( 1, n1+1 ),
310 $ lda, a( 1, 1 ), lda, cbeta, c( n1+1 ), n )
322 CALL
zherk(
'L',
'N', n1, k, alpha, a( 1, 1 ), lda,
323 $ beta, c( n2+1 ), n )
324 CALL
zherk(
'U',
'N', n2, k, alpha, a( n2, 1 ), lda,
325 $ beta, c( n1+1 ), n )
326 CALL
zgemm(
'N',
'C', n1, n2, k, calpha, a( 1, 1 ),
327 $ lda, a( n2, 1 ), lda, cbeta, c( 1 ), n )
333 CALL
zherk(
'L',
'C', n1, k, alpha, a( 1, 1 ), lda,
334 $ beta, c( n2+1 ), n )
335 CALL
zherk(
'U',
'C', n2, k, alpha, a( 1, n2 ), lda,
336 $ beta, c( n1+1 ), n )
337 CALL
zgemm(
'C',
'N', n1, n2, k, calpha, a( 1, 1 ),
338 $ lda, a( 1, n2 ), lda, cbeta, c( 1 ), n )
356 CALL
zherk(
'U',
'N', n1, k, alpha, a( 1, 1 ), lda,
358 CALL
zherk(
'L',
'N', n2, k, alpha, a( n1+1, 1 ), lda,
360 CALL
zgemm(
'N',
'C', n1, n2, k, calpha, a( 1, 1 ),
361 $ lda, a( n1+1, 1 ), lda, cbeta,
368 CALL
zherk(
'U',
'C', n1, k, alpha, a( 1, 1 ), lda,
370 CALL
zherk(
'L',
'C', n2, k, alpha, a( 1, n1+1 ), lda,
372 CALL
zgemm(
'C',
'N', n1, n2, k, calpha, a( 1, 1 ),
373 $ lda, a( 1, n1+1 ), lda, cbeta,
386 CALL
zherk(
'U',
'N', n1, k, alpha, a( 1, 1 ), lda,
387 $ beta, c( n2*n2+1 ), n2 )
388 CALL
zherk(
'L',
'N', n2, k, alpha, a( n1+1, 1 ), lda,
389 $ beta, c( n1*n2+1 ), n2 )
390 CALL
zgemm(
'N',
'C', n2, n1, k, calpha, a( n1+1, 1 ),
391 $ lda, a( 1, 1 ), lda, cbeta, c( 1 ), n2 )
397 CALL
zherk(
'U',
'C', n1, k, alpha, a( 1, 1 ), lda,
398 $ beta, c( n2*n2+1 ), n2 )
399 CALL
zherk(
'L',
'C', n2, k, alpha, a( 1, n1+1 ), lda,
400 $ beta, c( n1*n2+1 ), n2 )
401 CALL
zgemm(
'C',
'N', n2, n1, k, calpha, a( 1, n1+1 ),
402 $ lda, a( 1, 1 ), lda, cbeta, c( 1 ), n2 )
414 IF( normaltransr )
THEN
426 CALL
zherk(
'L',
'N', nk, k, alpha, a( 1, 1 ), lda,
427 $ beta, c( 2 ), n+1 )
428 CALL
zherk(
'U',
'N', nk, k, alpha, a( nk+1, 1 ), lda,
429 $ beta, c( 1 ), n+1 )
430 CALL
zgemm(
'N',
'C', nk, nk, k, calpha, a( nk+1, 1 ),
431 $ lda, a( 1, 1 ), lda, cbeta, c( nk+2 ),
438 CALL
zherk(
'L',
'C', nk, k, alpha, a( 1, 1 ), lda,
439 $ beta, c( 2 ), n+1 )
440 CALL
zherk(
'U',
'C', nk, k, alpha, a( 1, nk+1 ), lda,
441 $ beta, c( 1 ), n+1 )
442 CALL
zgemm(
'C',
'N', nk, nk, k, calpha, a( 1, nk+1 ),
443 $ lda, a( 1, 1 ), lda, cbeta, c( nk+2 ),
456 CALL
zherk(
'L',
'N', nk, k, alpha, a( 1, 1 ), lda,
457 $ beta, c( nk+2 ), n+1 )
458 CALL
zherk(
'U',
'N', nk, k, alpha, a( nk+1, 1 ), lda,
459 $ beta, c( nk+1 ), n+1 )
460 CALL
zgemm(
'N',
'C', nk, nk, k, calpha, a( 1, 1 ),
461 $ lda, a( nk+1, 1 ), lda, cbeta, c( 1 ),
468 CALL
zherk(
'L',
'C', nk, k, alpha, a( 1, 1 ), lda,
469 $ beta, c( nk+2 ), n+1 )
470 CALL
zherk(
'U',
'C', nk, k, alpha, a( 1, nk+1 ), lda,
471 $ beta, c( nk+1 ), n+1 )
472 CALL
zgemm(
'C',
'N', nk, nk, k, calpha, a( 1, 1 ),
473 $ lda, a( 1, nk+1 ), lda, cbeta, c( 1 ),
492 CALL
zherk(
'U',
'N', nk, k, alpha, a( 1, 1 ), lda,
493 $ beta, c( nk+1 ), nk )
494 CALL
zherk(
'L',
'N', nk, k, alpha, a( nk+1, 1 ), lda,
496 CALL
zgemm(
'N',
'C', nk, nk, k, calpha, a( 1, 1 ),
497 $ lda, a( nk+1, 1 ), lda, cbeta,
498 $ c( ( ( nk+1 )*nk )+1 ), nk )
504 CALL
zherk(
'U',
'C', nk, k, alpha, a( 1, 1 ), lda,
505 $ beta, c( nk+1 ), nk )
506 CALL
zherk(
'L',
'C', nk, k, alpha, a( 1, nk+1 ), lda,
508 CALL
zgemm(
'C',
'N', nk, nk, k, calpha, a( 1, 1 ),
509 $ lda, a( 1, nk+1 ), lda, cbeta,
510 $ c( ( ( nk+1 )*nk )+1 ), nk )
522 CALL
zherk(
'U',
'N', nk, k, alpha, a( 1, 1 ), lda,
523 $ beta, c( nk*( nk+1 )+1 ), nk )
524 CALL
zherk(
'L',
'N', nk, k, alpha, a( nk+1, 1 ), lda,
525 $ beta, c( nk*nk+1 ), nk )
526 CALL
zgemm(
'N',
'C', nk, nk, k, calpha, a( nk+1, 1 ),
527 $ lda, a( 1, 1 ), lda, cbeta, c( 1 ), nk )
533 CALL
zherk(
'U',
'C', nk, k, alpha, a( 1, 1 ), lda,
534 $ beta, c( nk*( nk+1 )+1 ), nk )
535 CALL
zherk(
'L',
'C', nk, k, alpha, a( 1, nk+1 ), lda,
536 $ beta, c( nk*nk+1 ), nk )
537 CALL
zgemm(
'C',
'N', nk, nk, k, calpha, a( 1, nk+1 ),
538 $ lda, a( 1, 1 ), lda, cbeta, c( 1 ), nk )
subroutine zherk(UPLO, TRANS, N, K, ALPHA, A, LDA, BETA, C, LDC)
ZHERK
subroutine zgemm(TRANSA, TRANSB, M, N, K, ALPHA, A, LDA, B, LDB, BETA, C, LDC)
ZGEMM
subroutine xerbla(SRNAME, INFO)
XERBLA
logical function lsame(CA, CB)
LSAME
subroutine zhfrk(TRANSR, UPLO, TRANS, N, K, ALPHA, A, LDA, BETA, C)
ZHFRK performs a Hermitian rank-k operation for matrix in RFP format.
set ue cd $ADTTMP cat<< EOF > tmp f Program LinearEquations Implicit none Real j