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

◆ chfrk()

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.

Definition at line 166 of file chfrk.f.

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