LAPACK 3.12.0
LAPACK: Linear Algebra PACKage
Loading...
Searching...
No Matches

◆ ssfrk()

subroutine ssfrk ( character  transr,
character  uplo,
character  trans,
integer  n,
integer  k,
real  alpha,
real, dimension( lda, * )  a,
integer  lda,
real  beta,
real, dimension( * )  c 
)

SSFRK performs a symmetric rank-k operation for matrix in RFP format.

Download SSFRK + dependencies [TGZ] [ZIP] [TXT]

Purpose:
 Level 3 BLAS like routine for C in RFP Format.

 SSFRK performs one of the symmetric rank--k operations

    C := alpha*A*A**T + beta*C,

 or

    C := alpha*A**T*A + beta*C,

 where alpha and beta are real scalars, C is an n--by--n symmetric
 matrix and A is an n--by--k matrix in the first case and a k--by--n
 matrix in the second case.
Parameters
[in]TRANSR
          TRANSR is CHARACTER*1
          = 'N':  The Normal Form of RFP A is stored;
          = 'T':  The Transpose Form of RFP A is stored.
[in]UPLO
          UPLO is CHARACTER*1
           On  entry, UPLO specifies whether the upper or lower
           triangular part of the array C is to be referenced as
           follows:

              UPLO = 'U' or 'u'   Only the upper triangular part of C
                                  is to be referenced.

              UPLO = 'L' or 'l'   Only the lower triangular part of C
                                  is to be referenced.

           Unchanged on exit.
[in]TRANS
          TRANS is CHARACTER*1
           On entry, TRANS specifies the operation to be performed as
           follows:

              TRANS = 'N' or 'n'   C := alpha*A*A**T + beta*C.

              TRANS = 'T' or 't'   C := alpha*A**T*A + beta*C.

           Unchanged on exit.
[in]N
          N is INTEGER
           On entry, N specifies the order of the matrix C. N must be
           at least zero.
           Unchanged on exit.
[in]K
          K is INTEGER
           On entry with TRANS = 'N' or 'n', K specifies the number
           of  columns of the matrix A, and on entry with TRANS = 'T'
           or 't', K specifies the number of rows of the matrix A. K
           must be at least zero.
           Unchanged on exit.
[in]ALPHA
          ALPHA is REAL
           On entry, ALPHA specifies the scalar alpha.
           Unchanged on exit.
[in]A
          A is REAL array, dimension (LDA,ka)
           where KA
           is K  when TRANS = 'N' or 'n', and is N otherwise. Before
           entry with TRANS = 'N' or 'n', the leading N--by--K part of
           the array A must contain the matrix A, otherwise the leading
           K--by--N part of the array A must contain the matrix A.
           Unchanged on exit.
[in]LDA
          LDA is INTEGER
           On entry, LDA specifies the first dimension of A as declared
           in  the  calling  (sub)  program.   When  TRANS = 'N' or 'n'
           then  LDA must be at least  max( 1, n ), otherwise  LDA must
           be at least  max( 1, k ).
           Unchanged on exit.
[in]BETA
          BETA is REAL
           On entry, BETA specifies the scalar beta.
           Unchanged on exit.
[in,out]C
          C is REAL array, dimension (NT)
           NT = N*(N+1)/2. On entry, the symmetric matrix C in RFP
           Format. RFP Format is described by TRANSR, UPLO and N.
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.

Definition at line 164 of file ssfrk.f.

166*
167* -- LAPACK computational routine --
168* -- LAPACK is a software package provided by Univ. of Tennessee, --
169* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
170*
171* .. Scalar Arguments ..
172 REAL ALPHA, BETA
173 INTEGER K, LDA, N
174 CHARACTER TRANS, TRANSR, UPLO
175* ..
176* .. Array Arguments ..
177 REAL A( LDA, * ), C( * )
178* ..
179*
180* =====================================================================
181*
182* .. Parameters ..
183 REAL ONE, ZERO
184 parameter( one = 1.0e+0, zero = 0.0e+0 )
185* ..
186* .. Local Scalars ..
187 LOGICAL LOWER, NORMALTRANSR, NISODD, NOTRANS
188 INTEGER INFO, NROWA, J, NK, N1, N2
189* ..
190* .. External Functions ..
191 LOGICAL LSAME
192 EXTERNAL lsame
193* ..
194* .. External Subroutines ..
195 EXTERNAL sgemm, ssyrk, xerbla
196* ..
197* .. Intrinsic Functions ..
198 INTRINSIC max
199* ..
200* .. Executable Statements ..
201*
202* Test the input parameters.
203*
204 info = 0
205 normaltransr = lsame( transr, 'N' )
206 lower = lsame( uplo, 'L' )
207 notrans = lsame( trans, 'N' )
208*
209 IF( notrans ) THEN
210 nrowa = n
211 ELSE
212 nrowa = k
213 END IF
214*
215 IF( .NOT.normaltransr .AND. .NOT.lsame( transr, 'T' ) ) THEN
216 info = -1
217 ELSE IF( .NOT.lower .AND. .NOT.lsame( uplo, 'U' ) ) THEN
218 info = -2
219 ELSE IF( .NOT.notrans .AND. .NOT.lsame( trans, 'T' ) ) THEN
220 info = -3
221 ELSE IF( n.LT.0 ) THEN
222 info = -4
223 ELSE IF( k.LT.0 ) THEN
224 info = -5
225 ELSE IF( lda.LT.max( 1, nrowa ) ) THEN
226 info = -8
227 END IF
228 IF( info.NE.0 ) THEN
229 CALL xerbla( 'SSFRK ', -info )
230 RETURN
231 END IF
232*
233* Quick return if possible.
234*
235* The quick return case: ((ALPHA.EQ.0).AND.(BETA.NE.ZERO)) is not
236* done (it is in SSYRK for example) and left in the general case.
237*
238 IF( ( n.EQ.0 ) .OR. ( ( ( alpha.EQ.zero ) .OR. ( k.EQ.0 ) ) .AND.
239 $ ( beta.EQ.one ) ) )RETURN
240*
241 IF( ( alpha.EQ.zero ) .AND. ( beta.EQ.zero ) ) THEN
242 DO j = 1, ( ( n*( n+1 ) ) / 2 )
243 c( j ) = zero
244 END DO
245 RETURN
246 END IF
247*
248* C is N-by-N.
249* If N is odd, set NISODD = .TRUE., and N1 and N2.
250* If N is even, NISODD = .FALSE., and NK.
251*
252 IF( mod( n, 2 ).EQ.0 ) THEN
253 nisodd = .false.
254 nk = n / 2
255 ELSE
256 nisodd = .true.
257 IF( lower ) THEN
258 n2 = n / 2
259 n1 = n - n2
260 ELSE
261 n1 = n / 2
262 n2 = n - n1
263 END IF
264 END IF
265*
266 IF( nisodd ) THEN
267*
268* N is odd
269*
270 IF( normaltransr ) THEN
271*
272* N is odd and TRANSR = 'N'
273*
274 IF( lower ) THEN
275*
276* N is odd, TRANSR = 'N', and UPLO = 'L'
277*
278 IF( notrans ) THEN
279*
280* N is odd, TRANSR = 'N', UPLO = 'L', and TRANS = 'N'
281*
282 CALL ssyrk( 'L', 'N', n1, k, alpha, a( 1, 1 ), lda,
283 $ beta, c( 1 ), n )
284 CALL ssyrk( 'U', 'N', n2, k, alpha, a( n1+1, 1 ), lda,
285 $ beta, c( n+1 ), n )
286 CALL sgemm( 'N', 'T', n2, n1, k, alpha, a( n1+1, 1 ),
287 $ lda, a( 1, 1 ), lda, beta, c( n1+1 ), n )
288*
289 ELSE
290*
291* N is odd, TRANSR = 'N', UPLO = 'L', and TRANS = 'T'
292*
293 CALL ssyrk( 'L', 'T', n1, k, alpha, a( 1, 1 ), lda,
294 $ beta, c( 1 ), n )
295 CALL ssyrk( 'U', 'T', n2, k, alpha, a( 1, n1+1 ), lda,
296 $ beta, c( n+1 ), n )
297 CALL sgemm( 'T', 'N', n2, n1, k, alpha, a( 1, n1+1 ),
298 $ lda, a( 1, 1 ), lda, beta, c( n1+1 ), n )
299*
300 END IF
301*
302 ELSE
303*
304* N is odd, TRANSR = 'N', and UPLO = 'U'
305*
306 IF( notrans ) THEN
307*
308* N is odd, TRANSR = 'N', UPLO = 'U', and TRANS = 'N'
309*
310 CALL ssyrk( 'L', 'N', n1, k, alpha, a( 1, 1 ), lda,
311 $ beta, c( n2+1 ), n )
312 CALL ssyrk( 'U', 'N', n2, k, alpha, a( n2, 1 ), lda,
313 $ beta, c( n1+1 ), n )
314 CALL sgemm( 'N', 'T', n1, n2, k, alpha, a( 1, 1 ),
315 $ lda, a( n2, 1 ), lda, beta, c( 1 ), n )
316*
317 ELSE
318*
319* N is odd, TRANSR = 'N', UPLO = 'U', and TRANS = 'T'
320*
321 CALL ssyrk( 'L', 'T', n1, k, alpha, a( 1, 1 ), lda,
322 $ beta, c( n2+1 ), n )
323 CALL ssyrk( 'U', 'T', n2, k, alpha, a( 1, n2 ), lda,
324 $ beta, c( n1+1 ), n )
325 CALL sgemm( 'T', 'N', n1, n2, k, alpha, a( 1, 1 ),
326 $ lda, a( 1, n2 ), lda, beta, c( 1 ), n )
327*
328 END IF
329*
330 END IF
331*
332 ELSE
333*
334* N is odd, and TRANSR = 'T'
335*
336 IF( lower ) THEN
337*
338* N is odd, TRANSR = 'T', and UPLO = 'L'
339*
340 IF( notrans ) THEN
341*
342* N is odd, TRANSR = 'T', UPLO = 'L', and TRANS = 'N'
343*
344 CALL ssyrk( 'U', 'N', n1, k, alpha, a( 1, 1 ), lda,
345 $ beta, c( 1 ), n1 )
346 CALL ssyrk( 'L', 'N', n2, k, alpha, a( n1+1, 1 ), lda,
347 $ beta, c( 2 ), n1 )
348 CALL sgemm( 'N', 'T', n1, n2, k, alpha, a( 1, 1 ),
349 $ lda, a( n1+1, 1 ), lda, beta,
350 $ c( n1*n1+1 ), n1 )
351*
352 ELSE
353*
354* N is odd, TRANSR = 'T', UPLO = 'L', and TRANS = 'T'
355*
356 CALL ssyrk( 'U', 'T', n1, k, alpha, a( 1, 1 ), lda,
357 $ beta, c( 1 ), n1 )
358 CALL ssyrk( 'L', 'T', n2, k, alpha, a( 1, n1+1 ), lda,
359 $ beta, c( 2 ), n1 )
360 CALL sgemm( 'T', 'N', n1, n2, k, alpha, a( 1, 1 ),
361 $ lda, a( 1, n1+1 ), lda, beta,
362 $ c( n1*n1+1 ), n1 )
363*
364 END IF
365*
366 ELSE
367*
368* N is odd, TRANSR = 'T', and UPLO = 'U'
369*
370 IF( notrans ) THEN
371*
372* N is odd, TRANSR = 'T', UPLO = 'U', and TRANS = 'N'
373*
374 CALL ssyrk( 'U', 'N', n1, k, alpha, a( 1, 1 ), lda,
375 $ beta, c( n2*n2+1 ), n2 )
376 CALL ssyrk( 'L', 'N', n2, k, alpha, a( n1+1, 1 ), lda,
377 $ beta, c( n1*n2+1 ), n2 )
378 CALL sgemm( 'N', 'T', n2, n1, k, alpha, a( n1+1, 1 ),
379 $ lda, a( 1, 1 ), lda, beta, c( 1 ), n2 )
380*
381 ELSE
382*
383* N is odd, TRANSR = 'T', UPLO = 'U', and TRANS = 'T'
384*
385 CALL ssyrk( 'U', 'T', n1, k, alpha, a( 1, 1 ), lda,
386 $ beta, c( n2*n2+1 ), n2 )
387 CALL ssyrk( 'L', 'T', n2, k, alpha, a( 1, n1+1 ), lda,
388 $ beta, c( n1*n2+1 ), n2 )
389 CALL sgemm( 'T', 'N', n2, n1, k, alpha, a( 1, n1+1 ),
390 $ lda, a( 1, 1 ), lda, beta, c( 1 ), n2 )
391*
392 END IF
393*
394 END IF
395*
396 END IF
397*
398 ELSE
399*
400* N is even
401*
402 IF( normaltransr ) THEN
403*
404* N is even and TRANSR = 'N'
405*
406 IF( lower ) THEN
407*
408* N is even, TRANSR = 'N', and UPLO = 'L'
409*
410 IF( notrans ) THEN
411*
412* N is even, TRANSR = 'N', UPLO = 'L', and TRANS = 'N'
413*
414 CALL ssyrk( 'L', 'N', nk, k, alpha, a( 1, 1 ), lda,
415 $ beta, c( 2 ), n+1 )
416 CALL ssyrk( 'U', 'N', nk, k, alpha, a( nk+1, 1 ), lda,
417 $ beta, c( 1 ), n+1 )
418 CALL sgemm( 'N', 'T', nk, nk, k, alpha, a( nk+1, 1 ),
419 $ lda, a( 1, 1 ), lda, beta, c( nk+2 ),
420 $ n+1 )
421*
422 ELSE
423*
424* N is even, TRANSR = 'N', UPLO = 'L', and TRANS = 'T'
425*
426 CALL ssyrk( 'L', 'T', nk, k, alpha, a( 1, 1 ), lda,
427 $ beta, c( 2 ), n+1 )
428 CALL ssyrk( 'U', 'T', nk, k, alpha, a( 1, nk+1 ), lda,
429 $ beta, c( 1 ), n+1 )
430 CALL sgemm( 'T', 'N', nk, nk, k, alpha, a( 1, nk+1 ),
431 $ lda, a( 1, 1 ), lda, beta, c( nk+2 ),
432 $ n+1 )
433*
434 END IF
435*
436 ELSE
437*
438* N is even, TRANSR = 'N', and UPLO = 'U'
439*
440 IF( notrans ) THEN
441*
442* N is even, TRANSR = 'N', UPLO = 'U', and TRANS = 'N'
443*
444 CALL ssyrk( 'L', 'N', nk, k, alpha, a( 1, 1 ), lda,
445 $ beta, c( nk+2 ), n+1 )
446 CALL ssyrk( 'U', 'N', nk, k, alpha, a( nk+1, 1 ), lda,
447 $ beta, c( nk+1 ), n+1 )
448 CALL sgemm( 'N', 'T', nk, nk, k, alpha, a( 1, 1 ),
449 $ lda, a( nk+1, 1 ), lda, beta, c( 1 ),
450 $ n+1 )
451*
452 ELSE
453*
454* N is even, TRANSR = 'N', UPLO = 'U', and TRANS = 'T'
455*
456 CALL ssyrk( 'L', 'T', nk, k, alpha, a( 1, 1 ), lda,
457 $ beta, c( nk+2 ), n+1 )
458 CALL ssyrk( 'U', 'T', nk, k, alpha, a( 1, nk+1 ), lda,
459 $ beta, c( nk+1 ), n+1 )
460 CALL sgemm( 'T', 'N', nk, nk, k, alpha, a( 1, 1 ),
461 $ lda, a( 1, nk+1 ), lda, beta, c( 1 ),
462 $ n+1 )
463*
464 END IF
465*
466 END IF
467*
468 ELSE
469*
470* N is even, and TRANSR = 'T'
471*
472 IF( lower ) THEN
473*
474* N is even, TRANSR = 'T', and UPLO = 'L'
475*
476 IF( notrans ) THEN
477*
478* N is even, TRANSR = 'T', UPLO = 'L', and TRANS = 'N'
479*
480 CALL ssyrk( 'U', 'N', nk, k, alpha, a( 1, 1 ), lda,
481 $ beta, c( nk+1 ), nk )
482 CALL ssyrk( 'L', 'N', nk, k, alpha, a( nk+1, 1 ), lda,
483 $ beta, c( 1 ), nk )
484 CALL sgemm( 'N', 'T', nk, nk, k, alpha, a( 1, 1 ),
485 $ lda, a( nk+1, 1 ), lda, beta,
486 $ c( ( ( nk+1 )*nk )+1 ), nk )
487*
488 ELSE
489*
490* N is even, TRANSR = 'T', UPLO = 'L', and TRANS = 'T'
491*
492 CALL ssyrk( 'U', 'T', nk, k, alpha, a( 1, 1 ), lda,
493 $ beta, c( nk+1 ), nk )
494 CALL ssyrk( 'L', 'T', nk, k, alpha, a( 1, nk+1 ), lda,
495 $ beta, c( 1 ), nk )
496 CALL sgemm( 'T', 'N', nk, nk, k, alpha, a( 1, 1 ),
497 $ lda, a( 1, nk+1 ), lda, beta,
498 $ c( ( ( nk+1 )*nk )+1 ), nk )
499*
500 END IF
501*
502 ELSE
503*
504* N is even, TRANSR = 'T', and UPLO = 'U'
505*
506 IF( notrans ) THEN
507*
508* N is even, TRANSR = 'T', UPLO = 'U', and TRANS = 'N'
509*
510 CALL ssyrk( 'U', 'N', nk, k, alpha, a( 1, 1 ), lda,
511 $ beta, c( nk*( nk+1 )+1 ), nk )
512 CALL ssyrk( 'L', 'N', nk, k, alpha, a( nk+1, 1 ), lda,
513 $ beta, c( nk*nk+1 ), nk )
514 CALL sgemm( 'N', 'T', nk, nk, k, alpha, a( nk+1, 1 ),
515 $ lda, a( 1, 1 ), lda, beta, c( 1 ), nk )
516*
517 ELSE
518*
519* N is even, TRANSR = 'T', UPLO = 'U', and TRANS = 'T'
520*
521 CALL ssyrk( 'U', 'T', nk, k, alpha, a( 1, 1 ), lda,
522 $ beta, c( nk*( nk+1 )+1 ), nk )
523 CALL ssyrk( 'L', 'T', nk, k, alpha, a( 1, nk+1 ), lda,
524 $ beta, c( nk*nk+1 ), nk )
525 CALL sgemm( 'T', 'N', nk, nk, k, alpha, a( 1, nk+1 ),
526 $ lda, a( 1, 1 ), lda, beta, c( 1 ), nk )
527*
528 END IF
529*
530 END IF
531*
532 END IF
533*
534 END IF
535*
536 RETURN
537*
538* End of SSFRK
539*
xerbla
subroutine xerbla(srname, info)
Definition cblat2.f:3285
sgemm
subroutine sgemm(transa, transb, m, n, k, alpha, a, lda, b, ldb, beta, c, ldc)
SGEMM
Definition sgemm.f:188
ssyrk
subroutine ssyrk(uplo, trans, n, k, alpha, a, lda, beta, c, ldc)
SSYRK
Definition ssyrk.f:169
lsame
logical function lsame(ca, cb)
LSAME
Definition lsame.f:48
Here is the call graph for this function:
Here is the caller graph for this function: