166 SUBROUTINE dsfrk( TRANSR, UPLO, TRANS, N, K, ALPHA, A, LDA, BETA,
175 DOUBLE PRECISION ALPHA, BETA
177 CHARACTER TRANS, TRANSR, UPLO
180 DOUBLE PRECISION A( lda, * ), C( * )
187 DOUBLE PRECISION ONE, ZERO
188 parameter( one = 1.0d+0, zero = 0.0d+0 )
191 LOGICAL LOWER, NORMALTRANSR, NISODD, NOTRANS
192 INTEGER INFO, NROWA, J, NK, N1, N2
209 normaltransr = lsame( transr,
'N' )
210 lower = lsame( uplo,
'L' )
211 notrans = lsame( trans,
'N' )
219 IF( .NOT.normaltransr .AND. .NOT.lsame( transr,
'T' ) )
THEN
221 ELSE IF( .NOT.lower .AND. .NOT.lsame( uplo,
'U' ) )
THEN
223 ELSE IF( .NOT.notrans .AND. .NOT.lsame( trans,
'T' ) )
THEN
225 ELSE IF( n.LT.0 )
THEN
227 ELSE IF( k.LT.0 )
THEN
229 ELSE IF( lda.LT.max( 1, nrowa ) )
THEN
233 CALL
xerbla(
'DSFRK ', -info )
242 IF( ( n.EQ.0 ) .OR. ( ( ( alpha.EQ.zero ) .OR. ( k.EQ.0 ) ) .AND.
243 $ ( beta.EQ.one ) ) )
RETURN
245 IF( ( alpha.EQ.zero ) .AND. ( beta.EQ.zero ) )
THEN
246 DO j = 1, ( ( n*( n+1 ) ) / 2 )
256 IF( mod( n, 2 ).EQ.0 )
THEN
274 IF( normaltransr )
THEN
286 CALL
dsyrk(
'L',
'N', n1, k, alpha, a( 1, 1 ), lda,
288 CALL
dsyrk(
'U',
'N', n2, k, alpha, a( n1+1, 1 ), lda,
289 $ beta, c( n+1 ), n )
290 CALL
dgemm(
'N',
'T', n2, n1, k, alpha, a( n1+1, 1 ),
291 $ lda, a( 1, 1 ), lda, beta, c( n1+1 ), n )
297 CALL
dsyrk(
'L',
'T', n1, k, alpha, a( 1, 1 ), lda,
299 CALL
dsyrk(
'U',
'T', n2, k, alpha, a( 1, n1+1 ), lda,
300 $ beta, c( n+1 ), n )
301 CALL
dgemm(
'T',
'N', n2, n1, k, alpha, a( 1, n1+1 ),
302 $ lda, a( 1, 1 ), lda, beta, c( n1+1 ), n )
314 CALL
dsyrk(
'L',
'N', n1, k, alpha, a( 1, 1 ), lda,
315 $ beta, c( n2+1 ), n )
316 CALL
dsyrk(
'U',
'N', n2, k, alpha, a( n2, 1 ), lda,
317 $ beta, c( n1+1 ), n )
318 CALL
dgemm(
'N',
'T', n1, n2, k, alpha, a( 1, 1 ),
319 $ lda, a( n2, 1 ), lda, beta, c( 1 ), n )
325 CALL
dsyrk(
'L',
'T', n1, k, alpha, a( 1, 1 ), lda,
326 $ beta, c( n2+1 ), n )
327 CALL
dsyrk(
'U',
'T', n2, k, alpha, a( 1, n2 ), lda,
328 $ beta, c( n1+1 ), n )
329 CALL
dgemm(
'T',
'N', n1, n2, k, alpha, a( 1, 1 ),
330 $ lda, a( 1, n2 ), lda, beta, c( 1 ), n )
348 CALL
dsyrk(
'U',
'N', n1, k, alpha, a( 1, 1 ), lda,
350 CALL
dsyrk(
'L',
'N', n2, k, alpha, a( n1+1, 1 ), lda,
352 CALL
dgemm(
'N',
'T', n1, n2, k, alpha, a( 1, 1 ),
353 $ lda, a( n1+1, 1 ), lda, beta,
360 CALL
dsyrk(
'U',
'T', n1, k, alpha, a( 1, 1 ), lda,
362 CALL
dsyrk(
'L',
'T', n2, k, alpha, a( 1, n1+1 ), lda,
364 CALL
dgemm(
'T',
'N', n1, n2, k, alpha, a( 1, 1 ),
365 $ lda, a( 1, n1+1 ), lda, beta,
378 CALL
dsyrk(
'U',
'N', n1, k, alpha, a( 1, 1 ), lda,
379 $ beta, c( n2*n2+1 ), n2 )
380 CALL
dsyrk(
'L',
'N', n2, k, alpha, a( n1+1, 1 ), lda,
381 $ beta, c( n1*n2+1 ), n2 )
382 CALL
dgemm(
'N',
'T', n2, n1, k, alpha, a( n1+1, 1 ),
383 $ lda, a( 1, 1 ), lda, beta, c( 1 ), n2 )
389 CALL
dsyrk(
'U',
'T', n1, k, alpha, a( 1, 1 ), lda,
390 $ beta, c( n2*n2+1 ), n2 )
391 CALL
dsyrk(
'L',
'T', n2, k, alpha, a( 1, n1+1 ), lda,
392 $ beta, c( n1*n2+1 ), n2 )
393 CALL
dgemm(
'T',
'N', n2, n1, k, alpha, a( 1, n1+1 ),
394 $ lda, a( 1, 1 ), lda, beta, c( 1 ), n2 )
406 IF( normaltransr )
THEN
418 CALL
dsyrk(
'L',
'N', nk, k, alpha, a( 1, 1 ), lda,
419 $ beta, c( 2 ), n+1 )
420 CALL
dsyrk(
'U',
'N', nk, k, alpha, a( nk+1, 1 ), lda,
421 $ beta, c( 1 ), n+1 )
422 CALL
dgemm(
'N',
'T', nk, nk, k, alpha, a( nk+1, 1 ),
423 $ lda, a( 1, 1 ), lda, beta, c( nk+2 ),
430 CALL
dsyrk(
'L',
'T', nk, k, alpha, a( 1, 1 ), lda,
431 $ beta, c( 2 ), n+1 )
432 CALL
dsyrk(
'U',
'T', nk, k, alpha, a( 1, nk+1 ), lda,
433 $ beta, c( 1 ), n+1 )
434 CALL
dgemm(
'T',
'N', nk, nk, k, alpha, a( 1, nk+1 ),
435 $ lda, a( 1, 1 ), lda, beta, c( nk+2 ),
448 CALL
dsyrk(
'L',
'N', nk, k, alpha, a( 1, 1 ), lda,
449 $ beta, c( nk+2 ), n+1 )
450 CALL
dsyrk(
'U',
'N', nk, k, alpha, a( nk+1, 1 ), lda,
451 $ beta, c( nk+1 ), n+1 )
452 CALL
dgemm(
'N',
'T', nk, nk, k, alpha, a( 1, 1 ),
453 $ lda, a( nk+1, 1 ), lda, beta, c( 1 ),
460 CALL
dsyrk(
'L',
'T', nk, k, alpha, a( 1, 1 ), lda,
461 $ beta, c( nk+2 ), n+1 )
462 CALL
dsyrk(
'U',
'T', nk, k, alpha, a( 1, nk+1 ), lda,
463 $ beta, c( nk+1 ), n+1 )
464 CALL
dgemm(
'T',
'N', nk, nk, k, alpha, a( 1, 1 ),
465 $ lda, a( 1, nk+1 ), lda, beta, c( 1 ),
484 CALL
dsyrk(
'U',
'N', nk, k, alpha, a( 1, 1 ), lda,
485 $ beta, c( nk+1 ), nk )
486 CALL
dsyrk(
'L',
'N', nk, k, alpha, a( nk+1, 1 ), lda,
488 CALL
dgemm(
'N',
'T', nk, nk, k, alpha, a( 1, 1 ),
489 $ lda, a( nk+1, 1 ), lda, beta,
490 $ c( ( ( nk+1 )*nk )+1 ), nk )
496 CALL
dsyrk(
'U',
'T', nk, k, alpha, a( 1, 1 ), lda,
497 $ beta, c( nk+1 ), nk )
498 CALL
dsyrk(
'L',
'T', nk, k, alpha, a( 1, nk+1 ), lda,
500 CALL
dgemm(
'T',
'N', nk, nk, k, alpha, a( 1, 1 ),
501 $ lda, a( 1, nk+1 ), lda, beta,
502 $ c( ( ( nk+1 )*nk )+1 ), nk )
514 CALL
dsyrk(
'U',
'N', nk, k, alpha, a( 1, 1 ), lda,
515 $ beta, c( nk*( nk+1 )+1 ), nk )
516 CALL
dsyrk(
'L',
'N', nk, k, alpha, a( nk+1, 1 ), lda,
517 $ beta, c( nk*nk+1 ), nk )
518 CALL
dgemm(
'N',
'T', nk, nk, k, alpha, a( nk+1, 1 ),
519 $ lda, a( 1, 1 ), lda, beta, c( 1 ), nk )
525 CALL
dsyrk(
'U',
'T', nk, k, alpha, a( 1, 1 ), lda,
526 $ beta, c( nk*( nk+1 )+1 ), nk )
527 CALL
dsyrk(
'L',
'T', nk, k, alpha, a( 1, nk+1 ), lda,
528 $ beta, c( nk*nk+1 ), nk )
529 CALL
dgemm(
'T',
'N', nk, nk, k, alpha, a( 1, nk+1 ),
530 $ lda, a( 1, 1 ), lda, beta, c( 1 ), nk )
subroutine dgemm(TRANSA, TRANSB, M, N, K, ALPHA, A, LDA, B, LDB, BETA, C, LDC)
DGEMM
subroutine xerbla(SRNAME, INFO)
XERBLA
subroutine dsyrk(UPLO, TRANS, N, K, ALPHA, A, LDA, BETA, C, LDC)
DSYRK
subroutine dsfrk(TRANSR, UPLO, TRANS, N, K, ALPHA, A, LDA, BETA, C)
DSFRK performs a symmetric rank-k operation for matrix in RFP format.