162 SUBROUTINE dsfrk( TRANSR, UPLO, TRANS, N, K, ALPHA, A, LDA,
171 DOUBLE PRECISION ALPHA, BETA
173 CHARACTER TRANS, TRANSR, UPLO
176 DOUBLE PRECISION A( LDA, * ), C( * )
183 DOUBLE PRECISION ONE, ZERO
184 PARAMETER ( ONE = 1.0d+0, zero = 0.0d+0 )
187 LOGICAL LOWER, NORMALTRANSR, NISODD, NOTRANS
188 INTEGER INFO, NROWA, J, NK, N1, N2
205 normaltransr = lsame( transr,
'N' )
206 lower = lsame( uplo,
'L' )
207 notrans = lsame( trans,
'N' )
215 IF( .NOT.normaltransr .AND. .NOT.lsame( transr,
'T' ) )
THEN
217 ELSE IF( .NOT.lower .AND. .NOT.lsame( uplo,
'U' ) )
THEN
219 ELSE IF( .NOT.notrans .AND. .NOT.lsame( trans,
'T' ) )
THEN
221 ELSE IF( n.LT.0 )
THEN
223 ELSE IF( k.LT.0 )
THEN
225 ELSE IF( lda.LT.max( 1, nrowa ) )
THEN
229 CALL xerbla(
'DSFRK ', -info )
238 IF( ( n.EQ.0 ) .OR. ( ( ( alpha.EQ.zero ) .OR. ( k.EQ.0 ) ) .AND.
239 $ ( beta.EQ.one ) ) )
RETURN
241 IF( ( alpha.EQ.zero ) .AND. ( beta.EQ.zero ) )
THEN
242 DO j = 1, ( ( n*( n+1 ) ) / 2 )
252 IF( mod( n, 2 ).EQ.0 )
THEN
270 IF( normaltransr )
THEN
282 CALL dsyrk(
'L',
'N', n1, k, alpha, a( 1, 1 ), lda,
284 CALL dsyrk(
'U',
'N', n2, k, alpha, a( n1+1, 1 ),
286 $ beta, c( n+1 ), n )
287 CALL dgemm(
'N',
'T', n2, n1, k, alpha, a( n1+1,
289 $ lda, a( 1, 1 ), lda, beta, c( n1+1 ), n )
295 CALL dsyrk(
'L',
'T', n1, k, alpha, a( 1, 1 ), lda,
297 CALL dsyrk(
'U',
'T', n2, k, alpha, a( 1, n1+1 ),
299 $ beta, c( n+1 ), n )
300 CALL dgemm(
'T',
'N', n2, n1, k, alpha, a( 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 ),
318 $ beta, c( n1+1 ), n )
319 CALL dgemm(
'N',
'T', n1, n2, k, alpha, a( 1, 1 ),
320 $ lda, a( n2, 1 ), lda, beta, c( 1 ), n )
326 CALL dsyrk(
'L',
'T', n1, k, alpha, a( 1, 1 ), lda,
327 $ beta, c( n2+1 ), n )
328 CALL dsyrk(
'U',
'T', n2, k, alpha, a( 1, n2 ),
330 $ beta, c( n1+1 ), n )
331 CALL dgemm(
'T',
'N', n1, n2, k, alpha, a( 1, 1 ),
332 $ lda, a( 1, n2 ), lda, beta, c( 1 ), n )
350 CALL dsyrk(
'U',
'N', n1, k, alpha, a( 1, 1 ), lda,
352 CALL dsyrk(
'L',
'N', n2, k, alpha, a( n1+1, 1 ),
355 CALL dgemm(
'N',
'T', n1, n2, k, alpha, a( 1, 1 ),
356 $ lda, a( n1+1, 1 ), lda, beta,
363 CALL dsyrk(
'U',
'T', n1, k, alpha, a( 1, 1 ), lda,
365 CALL dsyrk(
'L',
'T', n2, k, alpha, a( 1, n1+1 ),
368 CALL dgemm(
'T',
'N', n1, n2, k, alpha, a( 1, 1 ),
369 $ lda, a( 1, n1+1 ), lda, beta,
382 CALL dsyrk(
'U',
'N', n1, k, alpha, a( 1, 1 ), lda,
383 $ beta, c( n2*n2+1 ), n2 )
384 CALL dsyrk(
'L',
'N', n2, k, alpha, a( n1+1, 1 ),
386 $ beta, c( n1*n2+1 ), n2 )
387 CALL dgemm(
'N',
'T', n2, n1, k, alpha, a( n1+1,
389 $ lda, a( 1, 1 ), lda, beta, c( 1 ), n2 )
395 CALL dsyrk(
'U',
'T', n1, k, alpha, a( 1, 1 ), lda,
396 $ beta, c( n2*n2+1 ), n2 )
397 CALL dsyrk(
'L',
'T', n2, k, alpha, a( 1, n1+1 ),
399 $ beta, c( n1*n2+1 ), n2 )
400 CALL dgemm(
'T',
'N', n2, n1, k, alpha, a( 1,
402 $ lda, a( 1, 1 ), lda, beta, c( 1 ), n2 )
414 IF( normaltransr )
THEN
426 CALL dsyrk(
'L',
'N', nk, k, alpha, a( 1, 1 ), lda,
427 $ beta, c( 2 ), n+1 )
428 CALL dsyrk(
'U',
'N', nk, k, alpha, a( nk+1, 1 ),
430 $ beta, c( 1 ), n+1 )
431 CALL dgemm(
'N',
'T', nk, nk, k, alpha, a( nk+1,
433 $ lda, a( 1, 1 ), lda, beta, c( nk+2 ),
440 CALL dsyrk(
'L',
'T', nk, k, alpha, a( 1, 1 ), lda,
441 $ beta, c( 2 ), n+1 )
442 CALL dsyrk(
'U',
'T', nk, k, alpha, a( 1, nk+1 ),
444 $ beta, c( 1 ), n+1 )
445 CALL dgemm(
'T',
'N', nk, nk, k, alpha, a( 1,
447 $ lda, a( 1, 1 ), lda, beta, c( nk+2 ),
460 CALL dsyrk(
'L',
'N', nk, k, alpha, a( 1, 1 ), lda,
461 $ beta, c( nk+2 ), n+1 )
462 CALL dsyrk(
'U',
'N', nk, k, alpha, a( nk+1, 1 ),
464 $ beta, c( nk+1 ), n+1 )
465 CALL dgemm(
'N',
'T', nk, nk, k, alpha, a( 1, 1 ),
466 $ lda, a( nk+1, 1 ), lda, beta, c( 1 ),
473 CALL dsyrk(
'L',
'T', nk, k, alpha, a( 1, 1 ), lda,
474 $ beta, c( nk+2 ), n+1 )
475 CALL dsyrk(
'U',
'T', nk, k, alpha, a( 1, nk+1 ),
477 $ beta, c( nk+1 ), n+1 )
478 CALL dgemm(
'T',
'N', nk, nk, k, alpha, a( 1, 1 ),
479 $ lda, a( 1, nk+1 ), lda, beta, c( 1 ),
498 CALL dsyrk(
'U',
'N', nk, k, alpha, a( 1, 1 ), lda,
499 $ beta, c( nk+1 ), nk )
500 CALL dsyrk(
'L',
'N', nk, k, alpha, a( nk+1, 1 ),
503 CALL dgemm(
'N',
'T', nk, nk, k, alpha, a( 1, 1 ),
504 $ lda, a( nk+1, 1 ), lda, beta,
505 $ c( ( ( nk+1 )*nk )+1 ), nk )
511 CALL dsyrk(
'U',
'T', nk, k, alpha, a( 1, 1 ), lda,
512 $ beta, c( nk+1 ), nk )
513 CALL dsyrk(
'L',
'T', nk, k, alpha, a( 1, nk+1 ),
516 CALL dgemm(
'T',
'N', nk, nk, k, alpha, a( 1, 1 ),
517 $ lda, a( 1, nk+1 ), lda, beta,
518 $ c( ( ( nk+1 )*nk )+1 ), nk )
530 CALL dsyrk(
'U',
'N', nk, k, alpha, a( 1, 1 ), lda,
531 $ beta, c( nk*( nk+1 )+1 ), nk )
532 CALL dsyrk(
'L',
'N', nk, k, alpha, a( nk+1, 1 ),
534 $ beta, c( nk*nk+1 ), nk )
535 CALL dgemm(
'N',
'T', nk, nk, k, alpha, a( nk+1,
537 $ lda, a( 1, 1 ), lda, beta, c( 1 ), nk )
543 CALL dsyrk(
'U',
'T', nk, k, alpha, a( 1, 1 ), lda,
544 $ beta, c( nk*( nk+1 )+1 ), nk )
545 CALL dsyrk(
'L',
'T', nk, k, alpha, a( 1, nk+1 ),
547 $ beta, c( nk*nk+1 ), nk )
548 CALL dgemm(
'T',
'N', nk, nk, k, alpha, a( 1,
550 $ lda, a( 1, 1 ), lda, beta, c( 1 ), nk )