LAPACK  3.6.1
LAPACK: Linear Algebra PACKage
subroutine dsfrk ( character  TRANSR,
character  UPLO,
character  TRANS,
integer  N,
integer  K,
double precision  ALPHA,
double precision, dimension( lda, * )  A,
integer  LDA,
double precision  BETA,
double precision, dimension( * )  C 
)

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

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

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

 DSFRK 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 DOUBLE PRECISION
           On entry, ALPHA specifies the scalar alpha.
           Unchanged on exit.
[in]A
          A is DOUBLE PRECISION 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 DOUBLE PRECISION
           On entry, BETA specifies the scalar beta.
           Unchanged on exit.
[in,out]C
          C is DOUBLE PRECISION 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.
Date
September 2012

Definition at line 168 of file dsfrk.f.

168 *
169 * -- LAPACK computational routine (version 3.4.2) --
170 * -- LAPACK is a software package provided by Univ. of Tennessee, --
171 * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
172 * September 2012
173 *
174 * .. Scalar Arguments ..
175  DOUBLE PRECISION alpha, beta
176  INTEGER k, lda, n
177  CHARACTER trans, transr, uplo
178 * ..
179 * .. Array Arguments ..
180  DOUBLE PRECISION a( lda, * ), c( * )
181 * ..
182 *
183 * =====================================================================
184 *
185 * ..
186 * .. Parameters ..
187  DOUBLE PRECISION one, zero
188  parameter ( one = 1.0d+0, zero = 0.0d+0 )
189 * ..
190 * .. Local Scalars ..
191  LOGICAL lower, normaltransr, nisodd, notrans
192  INTEGER info, nrowa, j, nk, n1, n2
193 * ..
194 * .. External Functions ..
195  LOGICAL lsame
196  EXTERNAL lsame
197 * ..
198 * .. External Subroutines ..
199  EXTERNAL xerbla, dgemm, dsyrk
200 * ..
201 * .. Intrinsic Functions ..
202  INTRINSIC max
203 * ..
204 * .. Executable Statements ..
205 *
206 * Test the input parameters.
207 *
208  info = 0
209  normaltransr = lsame( transr, 'N' )
210  lower = lsame( uplo, 'L' )
211  notrans = lsame( trans, 'N' )
212 *
213  IF( notrans ) THEN
214  nrowa = n
215  ELSE
216  nrowa = k
217  END IF
218 *
219  IF( .NOT.normaltransr .AND. .NOT.lsame( transr, 'T' ) ) THEN
220  info = -1
221  ELSE IF( .NOT.lower .AND. .NOT.lsame( uplo, 'U' ) ) THEN
222  info = -2
223  ELSE IF( .NOT.notrans .AND. .NOT.lsame( trans, 'T' ) ) THEN
224  info = -3
225  ELSE IF( n.LT.0 ) THEN
226  info = -4
227  ELSE IF( k.LT.0 ) THEN
228  info = -5
229  ELSE IF( lda.LT.max( 1, nrowa ) ) THEN
230  info = -8
231  END IF
232  IF( info.NE.0 ) THEN
233  CALL xerbla( 'DSFRK ', -info )
234  RETURN
235  END IF
236 *
237 * Quick return if possible.
238 *
239 * The quick return case: ((ALPHA.EQ.0).AND.(BETA.NE.ZERO)) is not
240 * done (it is in DSYRK for example) and left in the general case.
241 *
242  IF( ( n.EQ.0 ) .OR. ( ( ( alpha.EQ.zero ) .OR. ( k.EQ.0 ) ) .AND.
243  $ ( beta.EQ.one ) ) )RETURN
244 *
245  IF( ( alpha.EQ.zero ) .AND. ( beta.EQ.zero ) ) THEN
246  DO j = 1, ( ( n*( n+1 ) ) / 2 )
247  c( j ) = zero
248  END DO
249  RETURN
250  END IF
251 *
252 * C is N-by-N.
253 * If N is odd, set NISODD = .TRUE., and N1 and N2.
254 * If N is even, NISODD = .FALSE., and NK.
255 *
256  IF( mod( n, 2 ).EQ.0 ) THEN
257  nisodd = .false.
258  nk = n / 2
259  ELSE
260  nisodd = .true.
261  IF( lower ) THEN
262  n2 = n / 2
263  n1 = n - n2
264  ELSE
265  n1 = n / 2
266  n2 = n - n1
267  END IF
268  END IF
269 *
270  IF( nisodd ) THEN
271 *
272 * N is odd
273 *
274  IF( normaltransr ) THEN
275 *
276 * N is odd and TRANSR = 'N'
277 *
278  IF( lower ) THEN
279 *
280 * N is odd, TRANSR = 'N', and UPLO = 'L'
281 *
282  IF( notrans ) THEN
283 *
284 * N is odd, TRANSR = 'N', UPLO = 'L', and TRANS = 'N'
285 *
286  CALL dsyrk( 'L', 'N', n1, k, alpha, a( 1, 1 ), lda,
287  $ beta, c( 1 ), n )
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 )
292 *
293  ELSE
294 *
295 * N is odd, TRANSR = 'N', UPLO = 'L', and TRANS = 'T'
296 *
297  CALL dsyrk( 'L', 'T', n1, k, alpha, a( 1, 1 ), lda,
298  $ beta, c( 1 ), n )
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 )
303 *
304  END IF
305 *
306  ELSE
307 *
308 * N is odd, TRANSR = 'N', and UPLO = 'U'
309 *
310  IF( notrans ) THEN
311 *
312 * N is odd, TRANSR = 'N', UPLO = 'U', and TRANS = 'N'
313 *
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 )
320 *
321  ELSE
322 *
323 * N is odd, TRANSR = 'N', UPLO = 'U', and TRANS = 'T'
324 *
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 )
331 *
332  END IF
333 *
334  END IF
335 *
336  ELSE
337 *
338 * N is odd, and TRANSR = 'T'
339 *
340  IF( lower ) THEN
341 *
342 * N is odd, TRANSR = 'T', and UPLO = 'L'
343 *
344  IF( notrans ) THEN
345 *
346 * N is odd, TRANSR = 'T', UPLO = 'L', and TRANS = 'N'
347 *
348  CALL dsyrk( 'U', 'N', n1, k, alpha, a( 1, 1 ), lda,
349  $ beta, c( 1 ), n1 )
350  CALL dsyrk( 'L', 'N', n2, k, alpha, a( n1+1, 1 ), lda,
351  $ beta, c( 2 ), n1 )
352  CALL dgemm( 'N', 'T', n1, n2, k, alpha, a( 1, 1 ),
353  $ lda, a( n1+1, 1 ), lda, beta,
354  $ c( n1*n1+1 ), n1 )
355 *
356  ELSE
357 *
358 * N is odd, TRANSR = 'T', UPLO = 'L', and TRANS = 'T'
359 *
360  CALL dsyrk( 'U', 'T', n1, k, alpha, a( 1, 1 ), lda,
361  $ beta, c( 1 ), n1 )
362  CALL dsyrk( 'L', 'T', n2, k, alpha, a( 1, n1+1 ), lda,
363  $ beta, c( 2 ), n1 )
364  CALL dgemm( 'T', 'N', n1, n2, k, alpha, a( 1, 1 ),
365  $ lda, a( 1, n1+1 ), lda, beta,
366  $ c( n1*n1+1 ), n1 )
367 *
368  END IF
369 *
370  ELSE
371 *
372 * N is odd, TRANSR = 'T', and UPLO = 'U'
373 *
374  IF( notrans ) THEN
375 *
376 * N is odd, TRANSR = 'T', UPLO = 'U', and TRANS = 'N'
377 *
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 )
384 *
385  ELSE
386 *
387 * N is odd, TRANSR = 'T', UPLO = 'U', and TRANS = 'T'
388 *
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 )
395 *
396  END IF
397 *
398  END IF
399 *
400  END IF
401 *
402  ELSE
403 *
404 * N is even
405 *
406  IF( normaltransr ) THEN
407 *
408 * N is even and TRANSR = 'N'
409 *
410  IF( lower ) THEN
411 *
412 * N is even, TRANSR = 'N', and UPLO = 'L'
413 *
414  IF( notrans ) THEN
415 *
416 * N is even, TRANSR = 'N', UPLO = 'L', and TRANS = 'N'
417 *
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 ),
424  $ n+1 )
425 *
426  ELSE
427 *
428 * N is even, TRANSR = 'N', UPLO = 'L', and TRANS = 'T'
429 *
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 ),
436  $ n+1 )
437 *
438  END IF
439 *
440  ELSE
441 *
442 * N is even, TRANSR = 'N', and UPLO = 'U'
443 *
444  IF( notrans ) THEN
445 *
446 * N is even, TRANSR = 'N', UPLO = 'U', and TRANS = 'N'
447 *
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 ),
454  $ n+1 )
455 *
456  ELSE
457 *
458 * N is even, TRANSR = 'N', UPLO = 'U', and TRANS = 'T'
459 *
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 ),
466  $ n+1 )
467 *
468  END IF
469 *
470  END IF
471 *
472  ELSE
473 *
474 * N is even, and TRANSR = 'T'
475 *
476  IF( lower ) THEN
477 *
478 * N is even, TRANSR = 'T', and UPLO = 'L'
479 *
480  IF( notrans ) THEN
481 *
482 * N is even, TRANSR = 'T', UPLO = 'L', and TRANS = 'N'
483 *
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,
487  $ beta, c( 1 ), nk )
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 )
491 *
492  ELSE
493 *
494 * N is even, TRANSR = 'T', UPLO = 'L', and TRANS = 'T'
495 *
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,
499  $ beta, c( 1 ), nk )
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 )
503 *
504  END IF
505 *
506  ELSE
507 *
508 * N is even, TRANSR = 'T', and UPLO = 'U'
509 *
510  IF( notrans ) THEN
511 *
512 * N is even, TRANSR = 'T', UPLO = 'U', and TRANS = 'N'
513 *
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 )
520 *
521  ELSE
522 *
523 * N is even, TRANSR = 'T', UPLO = 'U', and TRANS = 'T'
524 *
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 )
531 *
532  END IF
533 *
534  END IF
535 *
536  END IF
537 *
538  END IF
539 *
540  RETURN
541 *
542 * End of DSFRK
543 *
dgemm
subroutine dgemm(TRANSA, TRANSB, M, N, K, ALPHA, A, LDA, B, LDB, BETA, C, LDC)
DGEMM
Definition: dgemm.f:189
dsyrk
subroutine dsyrk(UPLO, TRANS, N, K, ALPHA, A, LDA, BETA, C, LDC)
DSYRK
Definition: dsyrk.f:171
xerbla
subroutine xerbla(SRNAME, INFO)
XERBLA
Definition: xerbla.f:62
lsame
logical function lsame(CA, CB)
LSAME
Definition: lsame.f:55

Here is the call graph for this function:

Here is the caller graph for this function: