LAPACK  3.10.1
LAPACK: Linear Algebra PACKage

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