166 SUBROUTINE ssfrk( TRANSR, UPLO, TRANS, N, K, ALPHA, A, LDA, BETA,
177 CHARACTER TRANS, TRANSR, UPLO
180 REAL A( lda, * ), C( * )
187 parameter ( one = 1.0e+0, zero = 0.0e+0 )
190 LOGICAL LOWER, NORMALTRANSR, NISODD, NOTRANS
191 INTEGER INFO, NROWA, J, NK, N1, N2
208 normaltransr = lsame( transr,
'N' )
209 lower = lsame( uplo,
'L' )
210 notrans = lsame( trans,
'N' )
218 IF( .NOT.normaltransr .AND. .NOT.lsame( transr,
'T' ) )
THEN
220 ELSE IF( .NOT.lower .AND. .NOT.lsame( uplo,
'U' ) )
THEN
222 ELSE IF( .NOT.notrans .AND. .NOT.lsame( trans,
'T' ) )
THEN
224 ELSE IF( n.LT.0 )
THEN
226 ELSE IF( k.LT.0 )
THEN
228 ELSE IF( lda.LT.max( 1, nrowa ) )
THEN
232 CALL xerbla(
'SSFRK ', -info )
241 IF( ( n.EQ.0 ) .OR. ( ( ( alpha.EQ.zero ) .OR. ( k.EQ.0 ) ) .AND.
242 $ ( beta.EQ.one ) ) )
RETURN
244 IF( ( alpha.EQ.zero ) .AND. ( beta.EQ.zero ) )
THEN
245 DO j = 1, ( ( n*( n+1 ) ) / 2 )
255 IF( mod( n, 2 ).EQ.0 )
THEN
273 IF( normaltransr )
THEN
285 CALL ssyrk(
'L',
'N', n1, k, alpha, a( 1, 1 ), lda,
287 CALL ssyrk(
'U',
'N', n2, k, alpha, a( n1+1, 1 ), lda,
288 $ beta, c( n+1 ), n )
289 CALL sgemm(
'N',
'T', n2, n1, k, alpha, a( n1+1, 1 ),
290 $ lda, a( 1, 1 ), lda, beta, c( n1+1 ), n )
296 CALL ssyrk(
'L',
'T', n1, k, alpha, a( 1, 1 ), lda,
298 CALL ssyrk(
'U',
'T', n2, k, alpha, a( 1, n1+1 ), lda,
299 $ beta, c( n+1 ), n )
300 CALL sgemm(
'T',
'N', n2, n1, k, alpha, a( 1, n1+1 ),
301 $ lda, a( 1, 1 ), lda, beta, c( n1+1 ), n )
313 CALL ssyrk(
'L',
'N', n1, k, alpha, a( 1, 1 ), lda,
314 $ beta, c( n2+1 ), n )
315 CALL ssyrk(
'U',
'N', n2, k, alpha, a( n2, 1 ), lda,
316 $ beta, c( n1+1 ), n )
317 CALL sgemm(
'N',
'T', n1, n2, k, alpha, a( 1, 1 ),
318 $ lda, a( n2, 1 ), lda, beta, c( 1 ), n )
324 CALL ssyrk(
'L',
'T', n1, k, alpha, a( 1, 1 ), lda,
325 $ beta, c( n2+1 ), n )
326 CALL ssyrk(
'U',
'T', n2, k, alpha, a( 1, n2 ), lda,
327 $ beta, c( n1+1 ), n )
328 CALL sgemm(
'T',
'N', n1, n2, k, alpha, a( 1, 1 ),
329 $ lda, a( 1, n2 ), lda, beta, c( 1 ), n )
347 CALL ssyrk(
'U',
'N', n1, k, alpha, a( 1, 1 ), lda,
349 CALL ssyrk(
'L',
'N', n2, k, alpha, a( n1+1, 1 ), lda,
351 CALL sgemm(
'N',
'T', n1, n2, k, alpha, a( 1, 1 ),
352 $ lda, a( n1+1, 1 ), lda, beta,
359 CALL ssyrk(
'U',
'T', n1, k, alpha, a( 1, 1 ), lda,
361 CALL ssyrk(
'L',
'T', n2, k, alpha, a( 1, n1+1 ), lda,
363 CALL sgemm(
'T',
'N', n1, n2, k, alpha, a( 1, 1 ),
364 $ lda, a( 1, n1+1 ), lda, beta,
377 CALL ssyrk(
'U',
'N', n1, k, alpha, a( 1, 1 ), lda,
378 $ beta, c( n2*n2+1 ), n2 )
379 CALL ssyrk(
'L',
'N', n2, k, alpha, a( n1+1, 1 ), lda,
380 $ beta, c( n1*n2+1 ), n2 )
381 CALL sgemm(
'N',
'T', n2, n1, k, alpha, a( n1+1, 1 ),
382 $ lda, a( 1, 1 ), lda, beta, c( 1 ), n2 )
388 CALL ssyrk(
'U',
'T', n1, k, alpha, a( 1, 1 ), lda,
389 $ beta, c( n2*n2+1 ), n2 )
390 CALL ssyrk(
'L',
'T', n2, k, alpha, a( 1, n1+1 ), lda,
391 $ beta, c( n1*n2+1 ), n2 )
392 CALL sgemm(
'T',
'N', n2, n1, k, alpha, a( 1, n1+1 ),
393 $ lda, a( 1, 1 ), lda, beta, c( 1 ), n2 )
405 IF( normaltransr )
THEN
417 CALL ssyrk(
'L',
'N', nk, k, alpha, a( 1, 1 ), lda,
418 $ beta, c( 2 ), n+1 )
419 CALL ssyrk(
'U',
'N', nk, k, alpha, a( nk+1, 1 ), lda,
420 $ beta, c( 1 ), n+1 )
421 CALL sgemm(
'N',
'T', nk, nk, k, alpha, a( nk+1, 1 ),
422 $ lda, a( 1, 1 ), lda, beta, c( nk+2 ),
429 CALL ssyrk(
'L',
'T', nk, k, alpha, a( 1, 1 ), lda,
430 $ beta, c( 2 ), n+1 )
431 CALL ssyrk(
'U',
'T', nk, k, alpha, a( 1, nk+1 ), lda,
432 $ beta, c( 1 ), n+1 )
433 CALL sgemm(
'T',
'N', nk, nk, k, alpha, a( 1, nk+1 ),
434 $ lda, a( 1, 1 ), lda, beta, c( nk+2 ),
447 CALL ssyrk(
'L',
'N', nk, k, alpha, a( 1, 1 ), lda,
448 $ beta, c( nk+2 ), n+1 )
449 CALL ssyrk(
'U',
'N', nk, k, alpha, a( nk+1, 1 ), lda,
450 $ beta, c( nk+1 ), n+1 )
451 CALL sgemm(
'N',
'T', nk, nk, k, alpha, a( 1, 1 ),
452 $ lda, a( nk+1, 1 ), lda, beta, c( 1 ),
459 CALL ssyrk(
'L',
'T', nk, k, alpha, a( 1, 1 ), lda,
460 $ beta, c( nk+2 ), n+1 )
461 CALL ssyrk(
'U',
'T', nk, k, alpha, a( 1, nk+1 ), lda,
462 $ beta, c( nk+1 ), n+1 )
463 CALL sgemm(
'T',
'N', nk, nk, k, alpha, a( 1, 1 ),
464 $ lda, a( 1, nk+1 ), lda, beta, c( 1 ),
483 CALL ssyrk(
'U',
'N', nk, k, alpha, a( 1, 1 ), lda,
484 $ beta, c( nk+1 ), nk )
485 CALL ssyrk(
'L',
'N', nk, k, alpha, a( nk+1, 1 ), lda,
487 CALL sgemm(
'N',
'T', nk, nk, k, alpha, a( 1, 1 ),
488 $ lda, a( nk+1, 1 ), lda, beta,
489 $ c( ( ( nk+1 )*nk )+1 ), nk )
495 CALL ssyrk(
'U',
'T', nk, k, alpha, a( 1, 1 ), lda,
496 $ beta, c( nk+1 ), nk )
497 CALL ssyrk(
'L',
'T', nk, k, alpha, a( 1, nk+1 ), lda,
499 CALL sgemm(
'T',
'N', nk, nk, k, alpha, a( 1, 1 ),
500 $ lda, a( 1, nk+1 ), lda, beta,
501 $ c( ( ( nk+1 )*nk )+1 ), nk )
513 CALL ssyrk(
'U',
'N', nk, k, alpha, a( 1, 1 ), lda,
514 $ beta, c( nk*( nk+1 )+1 ), nk )
515 CALL ssyrk(
'L',
'N', nk, k, alpha, a( nk+1, 1 ), lda,
516 $ beta, c( nk*nk+1 ), nk )
517 CALL sgemm(
'N',
'T', nk, nk, k, alpha, a( nk+1, 1 ),
518 $ lda, a( 1, 1 ), lda, beta, c( 1 ), nk )
524 CALL ssyrk(
'U',
'T', nk, k, alpha, a( 1, 1 ), lda,
525 $ beta, c( nk*( nk+1 )+1 ), nk )
526 CALL ssyrk(
'L',
'T', nk, k, alpha, a( 1, nk+1 ), lda,
527 $ beta, c( nk*nk+1 ), nk )
528 CALL sgemm(
'T',
'N', nk, nk, k, alpha, a( 1, nk+1 ),
529 $ lda, a( 1, 1 ), lda, beta, c( 1 ), nk )
subroutine ssyrk(UPLO, TRANS, N, K, ALPHA, A, LDA, BETA, C, LDC)
SSYRK
subroutine sgemm(TRANSA, TRANSB, M, N, K, ALPHA, A, LDA, B, LDB, BETA, C, LDC)
SGEMM
subroutine xerbla(SRNAME, INFO)
XERBLA
subroutine ssfrk(TRANSR, UPLO, TRANS, N, K, ALPHA, A, LDA, BETA, C)
SSFRK performs a symmetric rank-k operation for matrix in RFP format.