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 xerbla(SRNAME, INFO)
XERBLA
logical function lsame(CA, CB)
LSAME
subroutine sgemm(TRANSA, TRANSB, M, N, K, ALPHA, A, LDA, B, LDB, BETA, C, LDC)
SGEMM
set ue cd $ADTTMP cat<< EOF > tmp f Program LinearEquations Implicit none Real j
subroutine ssfrk(TRANSR, UPLO, TRANS, N, K, ALPHA, A, LDA, BETA, C)
SSFRK performs a symmetric rank-k operation for matrix in RFP format.