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 dsfrk(TRANSR, UPLO, TRANS, N, K, ALPHA, A, LDA, BETA, C)
DSFRK performs a symmetric rank-k operation for matrix in RFP format.
subroutine dgemm(TRANSA, TRANSB, M, N, K, ALPHA, A, LDA, B, LDB, BETA, C, LDC)
DGEMM
subroutine dsyrk(UPLO, TRANS, N, K, ALPHA, A, LDA, BETA, C, LDC)
DSYRK
subroutine xerbla(SRNAME, INFO)
XERBLA