1*> \brief \b ZHER2K 2* 3* =========== DOCUMENTATION =========== 4* 5* Online html documentation available at 6* http://www.netlib.org/lapack/explore-html/ 7* 8* Definition: 9* =========== 10* 11* SUBROUTINE ZHER2K(UPLO,TRANS,N,K,ALPHA,A,LDA,B,LDB,BETA,C,LDC) 12* 13* .. Scalar Arguments .. 14* COMPLEX*16 ALPHA 15* DOUBLE PRECISION BETA 16* INTEGER K,LDA,LDB,LDC,N 17* CHARACTER TRANS,UPLO 18* .. 19* .. Array Arguments .. 20* COMPLEX*16 A(LDA,*),B(LDB,*),C(LDC,*) 21* .. 22* 23* 24*> \par Purpose: 25* ============= 26*> 27*> \verbatim 28*> 29*> ZHER2K performs one of the hermitian rank 2k operations 30*> 31*> C := alpha*A*B**H + conjg( alpha )*B*A**H + beta*C, 32*> 33*> or 34*> 35*> C := alpha*A**H*B + conjg( alpha )*B**H*A + beta*C, 36*> 37*> where alpha and beta are scalars with beta real, C is an n by n 38*> hermitian matrix and A and B are n by k matrices in the first case 39*> and k by n matrices in the second case. 40*> \endverbatim 41* 42* Arguments: 43* ========== 44* 45*> \param[in] UPLO 46*> \verbatim 47*> UPLO is CHARACTER*1 48*> On entry, UPLO specifies whether the upper or lower 49*> triangular part of the array C is to be referenced as 50*> follows: 51*> 52*> UPLO = 'U' or 'u' Only the upper triangular part of C 53*> is to be referenced. 54*> 55*> UPLO = 'L' or 'l' Only the lower triangular part of C 56*> is to be referenced. 57*> \endverbatim 58*> 59*> \param[in] TRANS 60*> \verbatim 61*> TRANS is CHARACTER*1 62*> On entry, TRANS specifies the operation to be performed as 63*> follows: 64*> 65*> TRANS = 'N' or 'n' C := alpha*A*B**H + 66*> conjg( alpha )*B*A**H + 67*> beta*C. 68*> 69*> TRANS = 'C' or 'c' C := alpha*A**H*B + 70*> conjg( alpha )*B**H*A + 71*> beta*C. 72*> \endverbatim 73*> 74*> \param[in] N 75*> \verbatim 76*> N is INTEGER 77*> On entry, N specifies the order of the matrix C. N must be 78*> at least zero. 79*> \endverbatim 80*> 81*> \param[in] K 82*> \verbatim 83*> K is INTEGER 84*> On entry with TRANS = 'N' or 'n', K specifies the number 85*> of columns of the matrices A and B, and on entry with 86*> TRANS = 'C' or 'c', K specifies the number of rows of the 87*> matrices A and B. K must be at least zero. 88*> \endverbatim 89*> 90*> \param[in] ALPHA 91*> \verbatim 92*> ALPHA is COMPLEX*16 . 93*> On entry, ALPHA specifies the scalar alpha. 94*> \endverbatim 95*> 96*> \param[in] A 97*> \verbatim 98*> A is COMPLEX*16 array, dimension ( LDA, ka ), where ka is 99*> k when TRANS = 'N' or 'n', and is n otherwise. 100*> Before entry with TRANS = 'N' or 'n', the leading n by k 101*> part of the array A must contain the matrix A, otherwise 102*> the leading k by n part of the array A must contain the 103*> matrix A. 104*> \endverbatim 105*> 106*> \param[in] LDA 107*> \verbatim 108*> LDA is INTEGER 109*> On entry, LDA specifies the first dimension of A as declared 110*> in the calling (sub) program. When TRANS = 'N' or 'n' 111*> then LDA must be at least max( 1, n ), otherwise LDA must 112*> be at least max( 1, k ). 113*> \endverbatim 114*> 115*> \param[in] B 116*> \verbatim 117*> B is COMPLEX*16 array, dimension ( LDB, kb ), where kb is 118*> k when TRANS = 'N' or 'n', and is n otherwise. 119*> Before entry with TRANS = 'N' or 'n', the leading n by k 120*> part of the array B must contain the matrix B, otherwise 121*> the leading k by n part of the array B must contain the 122*> matrix B. 123*> \endverbatim 124*> 125*> \param[in] LDB 126*> \verbatim 127*> LDB is INTEGER 128*> On entry, LDB specifies the first dimension of B as declared 129*> in the calling (sub) program. When TRANS = 'N' or 'n' 130*> then LDB must be at least max( 1, n ), otherwise LDB must 131*> be at least max( 1, k ). 132*> Unchanged on exit. 133*> \endverbatim 134*> 135*> \param[in] BETA 136*> \verbatim 137*> BETA is DOUBLE PRECISION . 138*> On entry, BETA specifies the scalar beta. 139*> \endverbatim 140*> 141*> \param[in,out] C 142*> \verbatim 143*> C is COMPLEX*16 array, dimension ( LDC, N ) 144*> Before entry with UPLO = 'U' or 'u', the leading n by n 145*> upper triangular part of the array C must contain the upper 146*> triangular part of the hermitian matrix and the strictly 147*> lower triangular part of C is not referenced. On exit, the 148*> upper triangular part of the array C is overwritten by the 149*> upper triangular part of the updated matrix. 150*> Before entry with UPLO = 'L' or 'l', the leading n by n 151*> lower triangular part of the array C must contain the lower 152*> triangular part of the hermitian matrix and the strictly 153*> upper triangular part of C is not referenced. On exit, the 154*> lower triangular part of the array C is overwritten by the 155*> lower triangular part of the updated matrix. 156*> Note that the imaginary parts of the diagonal elements need 157*> not be set, they are assumed to be zero, and on exit they 158*> are set to zero. 159*> \endverbatim 160*> 161*> \param[in] LDC 162*> \verbatim 163*> LDC is INTEGER 164*> On entry, LDC specifies the first dimension of C as declared 165*> in the calling (sub) program. LDC must be at least 166*> max( 1, n ). 167*> \endverbatim 168* 169* Authors: 170* ======== 171* 172*> \author Univ. of Tennessee 173*> \author Univ. of California Berkeley 174*> \author Univ. of Colorado Denver 175*> \author NAG Ltd. 176* 177*> \ingroup complex16_blas_level3 178* 179*> \par Further Details: 180* ===================== 181*> 182*> \verbatim 183*> 184*> Level 3 Blas routine. 185*> 186*> -- Written on 8-February-1989. 187*> Jack Dongarra, Argonne National Laboratory. 188*> Iain Duff, AERE Harwell. 189*> Jeremy Du Croz, Numerical Algorithms Group Ltd. 190*> Sven Hammarling, Numerical Algorithms Group Ltd. 191*> 192*> -- Modified 8-Nov-93 to set C(J,J) to DBLE( C(J,J) ) when BETA = 1. 193*> Ed Anderson, Cray Research Inc. 194*> \endverbatim 195*> 196* ===================================================================== 197 SUBROUTINE ZHER2K(UPLO,TRANS,N,K,ALPHA,A,LDA,B,LDB,BETA,C,LDC) 198* 199* -- Reference BLAS level3 routine -- 200* -- Reference BLAS is a software package provided by Univ. of Tennessee, -- 201* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- 202* 203* .. Scalar Arguments .. 204 COMPLEX*16 ALPHA 205 DOUBLE PRECISION BETA 206 INTEGER K,LDA,LDB,LDC,N 207 CHARACTER TRANS,UPLO 208* .. 209* .. Array Arguments .. 210 COMPLEX*16 A(LDA,*),B(LDB,*),C(LDC,*) 211* .. 212* 213* ===================================================================== 214* 215* .. External Functions .. 216 LOGICAL LSAME 217 EXTERNAL LSAME 218* .. 219* .. External Subroutines .. 220 EXTERNAL XERBLA 221* .. 222* .. Intrinsic Functions .. 223 INTRINSIC DBLE,DCONJG,MAX 224* .. 225* .. Local Scalars .. 226 COMPLEX*16 TEMP1,TEMP2 227 INTEGER I,INFO,J,L,NROWA 228 LOGICAL UPPER 229* .. 230* .. Parameters .. 231 DOUBLE PRECISION ONE 232 PARAMETER (ONE=1.0D+0) 233 COMPLEX*16 ZERO 234 PARAMETER (ZERO= (0.0D+0,0.0D+0)) 235* .. 236* 237* Test the input parameters. 238* 239 IF (LSAME(TRANS,'N')) THEN 240 NROWA = N 241 ELSE 242 NROWA = K 243 END IF 244 UPPER = LSAME(UPLO,'U') 245* 246 INFO = 0 247 IF ((.NOT.UPPER) .AND. (.NOT.LSAME(UPLO,'L'))) THEN 248 INFO = 1 249 ELSE IF ((.NOT.LSAME(TRANS,'N')) .AND. 250 + (.NOT.LSAME(TRANS,'C'))) THEN 251 INFO = 2 252 ELSE IF (N.LT.0) THEN 253 INFO = 3 254 ELSE IF (K.LT.0) THEN 255 INFO = 4 256 ELSE IF (LDA.LT.MAX(1,NROWA)) THEN 257 INFO = 7 258 ELSE IF (LDB.LT.MAX(1,NROWA)) THEN 259 INFO = 9 260 ELSE IF (LDC.LT.MAX(1,N)) THEN 261 INFO = 12 262 END IF 263 IF (INFO.NE.0) THEN 264 CALL XERBLA('ZHER2K',INFO) 265 RETURN 266 END IF 267* 268* Quick return if possible. 269* 270 IF ((N.EQ.0) .OR. (((ALPHA.EQ.ZERO).OR. 271 + (K.EQ.0)).AND. (BETA.EQ.ONE))) RETURN 272* 273* And when alpha.eq.zero. 274* 275 IF (ALPHA.EQ.ZERO) THEN 276 IF (UPPER) THEN 277 IF (BETA.EQ.DBLE(ZERO)) THEN 278 DO 20 J = 1,N 279 DO 10 I = 1,J 280 C(I,J) = ZERO 281 10 CONTINUE 282 20 CONTINUE 283 ELSE 284 DO 40 J = 1,N 285 DO 30 I = 1,J - 1 286 C(I,J) = BETA*C(I,J) 287 30 CONTINUE 288 C(J,J) = BETA*DBLE(C(J,J)) 289 40 CONTINUE 290 END IF 291 ELSE 292 IF (BETA.EQ.DBLE(ZERO)) THEN 293 DO 60 J = 1,N 294 DO 50 I = J,N 295 C(I,J) = ZERO 296 50 CONTINUE 297 60 CONTINUE 298 ELSE 299 DO 80 J = 1,N 300 C(J,J) = BETA*DBLE(C(J,J)) 301 DO 70 I = J + 1,N 302 C(I,J) = BETA*C(I,J) 303 70 CONTINUE 304 80 CONTINUE 305 END IF 306 END IF 307 RETURN 308 END IF 309* 310* Start the operations. 311* 312 IF (LSAME(TRANS,'N')) THEN 313* 314* Form C := alpha*A*B**H + conjg( alpha )*B*A**H + 315* C. 316* 317 IF (UPPER) THEN 318 DO 130 J = 1,N 319 IF (BETA.EQ.DBLE(ZERO)) THEN 320 DO 90 I = 1,J 321 C(I,J) = ZERO 322 90 CONTINUE 323 ELSE IF (BETA.NE.ONE) THEN 324 DO 100 I = 1,J - 1 325 C(I,J) = BETA*C(I,J) 326 100 CONTINUE 327 C(J,J) = BETA*DBLE(C(J,J)) 328 ELSE 329 C(J,J) = DBLE(C(J,J)) 330 END IF 331 DO 120 L = 1,K 332 IF ((A(J,L).NE.ZERO) .OR. (B(J,L).NE.ZERO)) THEN 333 TEMP1 = ALPHA*DCONJG(B(J,L)) 334 TEMP2 = DCONJG(ALPHA*A(J,L)) 335 DO 110 I = 1,J - 1 336 C(I,J) = C(I,J) + A(I,L)*TEMP1 + 337 + B(I,L)*TEMP2 338 110 CONTINUE 339 C(J,J) = DBLE(C(J,J)) + 340 + DBLE(A(J,L)*TEMP1+B(J,L)*TEMP2) 341 END IF 342 120 CONTINUE 343 130 CONTINUE 344 ELSE 345 DO 180 J = 1,N 346 IF (BETA.EQ.DBLE(ZERO)) THEN 347 DO 140 I = J,N 348 C(I,J) = ZERO 349 140 CONTINUE 350 ELSE IF (BETA.NE.ONE) THEN 351 DO 150 I = J + 1,N 352 C(I,J) = BETA*C(I,J) 353 150 CONTINUE 354 C(J,J) = BETA*DBLE(C(J,J)) 355 ELSE 356 C(J,J) = DBLE(C(J,J)) 357 END IF 358 DO 170 L = 1,K 359 IF ((A(J,L).NE.ZERO) .OR. (B(J,L).NE.ZERO)) THEN 360 TEMP1 = ALPHA*DCONJG(B(J,L)) 361 TEMP2 = DCONJG(ALPHA*A(J,L)) 362 DO 160 I = J + 1,N 363 C(I,J) = C(I,J) + A(I,L)*TEMP1 + 364 + B(I,L)*TEMP2 365 160 CONTINUE 366 C(J,J) = DBLE(C(J,J)) + 367 + DBLE(A(J,L)*TEMP1+B(J,L)*TEMP2) 368 END IF 369 170 CONTINUE 370 180 CONTINUE 371 END IF 372 ELSE 373* 374* Form C := alpha*A**H*B + conjg( alpha )*B**H*A + 375* C. 376* 377 IF (UPPER) THEN 378 DO 210 J = 1,N 379 DO 200 I = 1,J 380 TEMP1 = ZERO 381 TEMP2 = ZERO 382 DO 190 L = 1,K 383 TEMP1 = TEMP1 + DCONJG(A(L,I))*B(L,J) 384 TEMP2 = TEMP2 + DCONJG(B(L,I))*A(L,J) 385 190 CONTINUE 386 IF (I.EQ.J) THEN 387 IF (BETA.EQ.DBLE(ZERO)) THEN 388 C(J,J) = DBLE(ALPHA*TEMP1+ 389 + DCONJG(ALPHA)*TEMP2) 390 ELSE 391 C(J,J) = BETA*DBLE(C(J,J)) + 392 + DBLE(ALPHA*TEMP1+ 393 + DCONJG(ALPHA)*TEMP2) 394 END IF 395 ELSE 396 IF (BETA.EQ.DBLE(ZERO)) THEN 397 C(I,J) = ALPHA*TEMP1 + DCONJG(ALPHA)*TEMP2 398 ELSE 399 C(I,J) = BETA*C(I,J) + ALPHA*TEMP1 + 400 + DCONJG(ALPHA)*TEMP2 401 END IF 402 END IF 403 200 CONTINUE 404 210 CONTINUE 405 ELSE 406 DO 240 J = 1,N 407 DO 230 I = J,N 408 TEMP1 = ZERO 409 TEMP2 = ZERO 410 DO 220 L = 1,K 411 TEMP1 = TEMP1 + DCONJG(A(L,I))*B(L,J) 412 TEMP2 = TEMP2 + DCONJG(B(L,I))*A(L,J) 413 220 CONTINUE 414 IF (I.EQ.J) THEN 415 IF (BETA.EQ.DBLE(ZERO)) THEN 416 C(J,J) = DBLE(ALPHA*TEMP1+ 417 + DCONJG(ALPHA)*TEMP2) 418 ELSE 419 C(J,J) = BETA*DBLE(C(J,J)) + 420 + DBLE(ALPHA*TEMP1+ 421 + DCONJG(ALPHA)*TEMP2) 422 END IF 423 ELSE 424 IF (BETA.EQ.DBLE(ZERO)) THEN 425 C(I,J) = ALPHA*TEMP1 + DCONJG(ALPHA)*TEMP2 426 ELSE 427 C(I,J) = BETA*C(I,J) + ALPHA*TEMP1 + 428 + DCONJG(ALPHA)*TEMP2 429 END IF 430 END IF 431 230 CONTINUE 432 240 CONTINUE 433 END IF 434 END IF 435* 436 RETURN 437* 438* End of ZHER2K 439* 440 END 441