LAPACK 3.12.1
LAPACK: Linear Algebra PACKage
•All Classes Namespaces Files Functions Variables Typedefs Enumerations Enumerator Macros Modules Pages

◆ zhfrk()

subroutine zhfrk ( character transr,
character uplo,
character trans,
integer n,
integer k,
double precision alpha,
complex*16, dimension( lda, * ) a,
integer lda,
double precision beta,
complex*16, dimension( * ) c )

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

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

Purpose:
!>
!> Level 3 BLAS like routine for C in RFP Format.
!>
!> ZHFRK 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 DOUBLE PRECISION
!>           On entry, ALPHA specifies the scalar alpha.
!>           Unchanged on exit.
!>
[in]A
!>          A is COMPLEX*16 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 COMPLEX*16 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 164 of file zhfrk.f.

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