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

CHFRK performs a Hermitian rank-k operation for matrix in RFP format.

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

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

 CHFRK performs one of the Hermitian rank--k operations

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

 or

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

 where alpha and beta are real scalars, C is an n--by--n Hermitian
 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;
          = 'C':  The Conjugate-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**H + beta*C.

              TRANS = 'C' or 'c'   C := alpha*A**H*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 = 'C' or 'c',  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 COMPLEX 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 COMPLEX array, dimension (N*(N+1)/2)
           On entry, the matrix A in RFP Format. RFP Format is
           described by TRANSR, UPLO and N. Note that the imaginary
           parts of the diagonal elements need not be set, they are
           assumed to be zero, and on exit they are set to zero.
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.
Date
September 2012

Definition at line 170 of file chfrk.f.

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