1*> \brief \b CHFRK performs a Hermitian rank-k operation for matrix in RFP format. 2* 3* =========== DOCUMENTATION =========== 4* 5* Online html documentation available at 6* http://www.netlib.org/lapack/explore-html/ 7* 8*> \htmlonly 9*> Download CHFRK + dependencies 10*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/chfrk.f"> 11*> [TGZ]</a> 12*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/chfrk.f"> 13*> [ZIP]</a> 14*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/chfrk.f"> 15*> [TXT]</a> 16*> \endhtmlonly 17* 18* Definition: 19* =========== 20* 21* SUBROUTINE CHFRK( TRANSR, UPLO, TRANS, N, K, ALPHA, A, LDA, BETA, 22* C ) 23* 24* .. Scalar Arguments .. 25* REAL ALPHA, BETA 26* INTEGER K, LDA, N 27* CHARACTER TRANS, TRANSR, UPLO 28* .. 29* .. Array Arguments .. 30* COMPLEX A( LDA, * ), C( * ) 31* .. 32* 33* 34*> \par Purpose: 35* ============= 36*> 37*> \verbatim 38*> 39*> Level 3 BLAS like routine for C in RFP Format. 40*> 41*> CHFRK performs one of the Hermitian rank--k operations 42*> 43*> C := alpha*A*A**H + beta*C, 44*> 45*> or 46*> 47*> C := alpha*A**H*A + beta*C, 48*> 49*> where alpha and beta are real scalars, C is an n--by--n Hermitian 50*> matrix and A is an n--by--k matrix in the first case and a k--by--n 51*> matrix in the second case. 52*> \endverbatim 53* 54* Arguments: 55* ========== 56* 57*> \param[in] TRANSR 58*> \verbatim 59*> TRANSR is CHARACTER*1 60*> = 'N': The Normal Form of RFP A is stored; 61*> = 'C': The Conjugate-transpose Form of RFP A is stored. 62*> \endverbatim 63*> 64*> \param[in] UPLO 65*> \verbatim 66*> UPLO is CHARACTER*1 67*> On entry, UPLO specifies whether the upper or lower 68*> triangular part of the array C is to be referenced as 69*> follows: 70*> 71*> UPLO = 'U' or 'u' Only the upper triangular part of C 72*> is to be referenced. 73*> 74*> UPLO = 'L' or 'l' Only the lower triangular part of C 75*> is to be referenced. 76*> 77*> Unchanged on exit. 78*> \endverbatim 79*> 80*> \param[in] TRANS 81*> \verbatim 82*> TRANS is CHARACTER*1 83*> On entry, TRANS specifies the operation to be performed as 84*> follows: 85*> 86*> TRANS = 'N' or 'n' C := alpha*A*A**H + beta*C. 87*> 88*> TRANS = 'C' or 'c' C := alpha*A**H*A + beta*C. 89*> 90*> Unchanged on exit. 91*> \endverbatim 92*> 93*> \param[in] N 94*> \verbatim 95*> N is INTEGER 96*> On entry, N specifies the order of the matrix C. N must be 97*> at least zero. 98*> Unchanged on exit. 99*> \endverbatim 100*> 101*> \param[in] K 102*> \verbatim 103*> K is INTEGER 104*> On entry with TRANS = 'N' or 'n', K specifies the number 105*> of columns of the matrix A, and on entry with 106*> TRANS = 'C' or 'c', K specifies the number of rows of the 107*> matrix A. K must be at least zero. 108*> Unchanged on exit. 109*> \endverbatim 110*> 111*> \param[in] ALPHA 112*> \verbatim 113*> ALPHA is REAL 114*> On entry, ALPHA specifies the scalar alpha. 115*> Unchanged on exit. 116*> \endverbatim 117*> 118*> \param[in] A 119*> \verbatim 120*> A is COMPLEX array, dimension (LDA,ka) 121*> where KA 122*> is K when TRANS = 'N' or 'n', and is N otherwise. Before 123*> entry with TRANS = 'N' or 'n', the leading N--by--K part of 124*> the array A must contain the matrix A, otherwise the leading 125*> K--by--N part of the array A must contain the matrix A. 126*> Unchanged on exit. 127*> \endverbatim 128*> 129*> \param[in] LDA 130*> \verbatim 131*> LDA is INTEGER 132*> On entry, LDA specifies the first dimension of A as declared 133*> in the calling (sub) program. When TRANS = 'N' or 'n' 134*> then LDA must be at least max( 1, n ), otherwise LDA must 135*> be at least max( 1, k ). 136*> Unchanged on exit. 137*> \endverbatim 138*> 139*> \param[in] BETA 140*> \verbatim 141*> BETA is REAL 142*> On entry, BETA specifies the scalar beta. 143*> Unchanged on exit. 144*> \endverbatim 145*> 146*> \param[in,out] C 147*> \verbatim 148*> C is COMPLEX array, dimension (N*(N+1)/2) 149*> On entry, the matrix A in RFP Format. RFP Format is 150*> described by TRANSR, UPLO and N. Note that the imaginary 151*> parts of the diagonal elements need not be set, they are 152*> assumed to be zero, and on exit they are set to zero. 153*> \endverbatim 154* 155* Authors: 156* ======== 157* 158*> \author Univ. of Tennessee 159*> \author Univ. of California Berkeley 160*> \author Univ. of Colorado Denver 161*> \author NAG Ltd. 162* 163*> \ingroup complexOTHERcomputational 164* 165* ===================================================================== 166 SUBROUTINE CHFRK( TRANSR, UPLO, TRANS, N, K, ALPHA, A, LDA, BETA, 167 $ C ) 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* 550 END 551