 LAPACK  3.10.0 LAPACK: Linear Algebra PACKage

## ◆ 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.

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.```

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 *
subroutine xerbla(SRNAME, INFO)
XERBLA
Definition: xerbla.f:60
logical function lsame(CA, CB)
LSAME
Definition: lsame.f:53
subroutine cgemm(TRANSA, TRANSB, M, N, K, ALPHA, A, LDA, B, LDB, BETA, C, LDC)
CGEMM
Definition: cgemm.f:187
subroutine cherk(UPLO, TRANS, N, K, ALPHA, A, LDA, BETA, C, LDC)
CHERK
Definition: cherk.f:173
Here is the call graph for this function:
Here is the caller graph for this function: