1 double precision function dcabs1(z) 2 double complex z,zz 3 double precision t(2) 4 equivalence (zz,t(1)) 5 zz = z 6 dcabs1 = dabs(t(1)) + dabs(t(2)) 7 return 8 end 9 double precision function dzasum(n,zx,incx) 10c 11c takes the sum of the absolute values. 12c jack dongarra, 3/11/78. 13c modified 3/93 to return if incx .le. 0. 14c modified 12/3/93, array(1) declarations changed to array(*) 15c 16 double complex zx(*) 17 double precision stemp,dcabs1 18 integer i,incx,ix,n 19c 20 dzasum = 0.0d0 21 stemp = 0.0d0 22 if( n.le.0 .or. incx.le.0 )return 23 if(incx.eq.1)go to 20 24c 25c code for increment not equal to 1 26c 27 ix = 1 28 do 10 i = 1,n 29 stemp = stemp + dcabs1(zx(ix)) 30 ix = ix + incx 31 10 continue 32 dzasum = stemp 33 return 34c 35c code for increment equal to 1 36c 37 20 do 30 i = 1,n 38 stemp = stemp + dcabs1(zx(i)) 39 30 continue 40 dzasum = stemp 41 return 42 end 43 DOUBLE PRECISION FUNCTION DZNRM2( N, X, INCX ) 44* .. Scalar Arguments .. 45 INTEGER INCX, N 46* .. Array Arguments .. 47 DOUBLE COMPLEX X( * ) 48* .. 49* 50* DZNRM2 returns the euclidean norm of a vector via the function 51* name, so that 52* 53* DZNRM2 := sqrt( conjg( x' )*x ) 54* 55* 56* 57* -- This version written on 25-October-1982. 58* Modified on 14-October-1993 to inline the call to ZLASSQ. 59* Sven Hammarling, Nag Ltd. 60* 61* 62* .. Parameters .. 63 DOUBLE PRECISION ONE , ZERO 64 PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 ) 65* .. Local Scalars .. 66 INTEGER IX 67 DOUBLE PRECISION NORM, SCALE, SSQ, TEMP 68* .. Intrinsic Functions .. 69 INTRINSIC ABS, DIMAG, DBLE, SQRT 70* .. 71* .. Executable Statements .. 72 IF( N.LT.1 .OR. INCX.LT.1 )THEN 73 NORM = ZERO 74 ELSE 75 SCALE = ZERO 76 SSQ = ONE 77* The following loop is equivalent to this call to the LAPACK 78* auxiliary routine: 79* CALL ZLASSQ( N, X, INCX, SCALE, SSQ ) 80* 81 DO 10, IX = 1, 1 + ( N - 1 )*INCX, INCX 82 IF( DBLE( X( IX ) ).NE.ZERO )THEN 83 TEMP = ABS( DBLE( X( IX ) ) ) 84 IF( SCALE.LT.TEMP )THEN 85 SSQ = ONE + SSQ*( SCALE/TEMP )**2 86 SCALE = TEMP 87 ELSE 88 SSQ = SSQ + ( TEMP/SCALE )**2 89 END IF 90 END IF 91 IF( DIMAG( X( IX ) ).NE.ZERO )THEN 92 TEMP = ABS( DIMAG( X( IX ) ) ) 93 IF( SCALE.LT.TEMP )THEN 94 SSQ = ONE + SSQ*( SCALE/TEMP )**2 95 SCALE = TEMP 96 ELSE 97 SSQ = SSQ + ( TEMP/SCALE )**2 98 END IF 99 END IF 100 10 CONTINUE 101 NORM = SCALE * SQRT( SSQ ) 102 END IF 103* 104 DZNRM2 = NORM 105 RETURN 106* 107* End of DZNRM2. 108* 109 END 110 integer function izamax(n,zx,incx) 111c 112c finds the index of element having max. absolute value. 113c jack dongarra, 1/15/85. 114c modified 3/93 to return if incx .le. 0. 115c modified 12/3/93, array(1) declarations changed to array(*) 116c 117 double complex zx(*) 118 double precision smax 119 integer i,incx,ix,n 120 double precision dcabs1 121c 122 izamax = 0 123 if( n.lt.1 .or. incx.le.0 )return 124 izamax = 1 125 if(n.eq.1)return 126 if(incx.eq.1)go to 20 127c 128c code for increment not equal to 1 129c 130 ix = 1 131 smax = dcabs1(zx(1)) 132 ix = ix + incx 133 do 10 i = 2,n 134 if(dcabs1(zx(ix)).le.smax) go to 5 135 izamax = i 136 smax = dcabs1(zx(ix)) 137 5 ix = ix + incx 138 10 continue 139 return 140c 141c code for increment equal to 1 142c 143 20 smax = dcabs1(zx(1)) 144 do 30 i = 2,n 145 if(dcabs1(zx(i)).le.smax) go to 30 146 izamax = i 147 smax = dcabs1(zx(i)) 148 30 continue 149 return 150 end 151 subroutine zaxpy(n,za,zx,incx,zy,incy) 152c 153c constant times a vector plus a vector. 154c jack dongarra, 3/11/78. 155c modified 12/3/93, array(1) declarations changed to array(*) 156c 157 double complex zx(*),zy(*),za 158 integer i,incx,incy,ix,iy,n 159 double precision dcabs1 160 if(n.le.0)return 161 if (dcabs1(za) .eq. 0.0d0) return 162 if (incx.eq.1.and.incy.eq.1)go to 20 163c 164c code for unequal increments or equal increments 165c not equal to 1 166c 167 ix = 1 168 iy = 1 169 if(incx.lt.0)ix = (-n+1)*incx + 1 170 if(incy.lt.0)iy = (-n+1)*incy + 1 171 do 10 i = 1,n 172 zy(iy) = zy(iy) + za*zx(ix) 173 ix = ix + incx 174 iy = iy + incy 175 10 continue 176 return 177c 178c code for both increments equal to 1 179c 180 20 do 30 i = 1,n 181 zy(i) = zy(i) + za*zx(i) 182 30 continue 183 return 184 end 185 subroutine zcopy(n,zx,incx,zy,incy) 186c 187c copies a vector, x, to a vector, y. 188c jack dongarra, linpack, 4/11/78. 189c modified 12/3/93, array(1) declarations changed to array(*) 190c 191 double complex zx(*),zy(*) 192 integer i,incx,incy,ix,iy,n 193c 194 if(n.le.0)return 195 if(incx.eq.1.and.incy.eq.1)go to 20 196c 197c code for unequal increments or equal increments 198c not equal to 1 199c 200 ix = 1 201 iy = 1 202 if(incx.lt.0)ix = (-n+1)*incx + 1 203 if(incy.lt.0)iy = (-n+1)*incy + 1 204 do 10 i = 1,n 205 zy(iy) = zx(ix) 206 ix = ix + incx 207 iy = iy + incy 208 10 continue 209 return 210c 211c code for both increments equal to 1 212c 213 20 do 30 i = 1,n 214 zy(i) = zx(i) 215 30 continue 216 return 217 end 218 double complex function zdotc(n,zx,incx,zy,incy) 219c 220c forms the dot product of a vector. 221c jack dongarra, 3/11/78. 222c modified 12/3/93, array(1) declarations changed to array(*) 223c 224 double complex zx(*),zy(*),ztemp 225 integer i,incx,incy,ix,iy,n 226 intrinsic dconjg 227 ztemp = (0.0d0,0.0d0) 228 zdotc = (0.0d0,0.0d0) 229 if(n.le.0)return 230 if(incx.eq.1.and.incy.eq.1)go to 20 231c 232c code for unequal increments or equal increments 233c not equal to 1 234c 235 ix = 1 236 iy = 1 237 if(incx.lt.0)ix = (-n+1)*incx + 1 238 if(incy.lt.0)iy = (-n+1)*incy + 1 239 do 10 i = 1,n 240 ztemp = ztemp + dconjg(zx(ix))*zy(iy) 241 ix = ix + incx 242 iy = iy + incy 243 10 continue 244 zdotc = ztemp 245 return 246c 247c code for both increments equal to 1 248c 249 20 do 30 i = 1,n 250 ztemp = ztemp + dconjg(zx(i))*zy(i) 251 30 continue 252 zdotc = ztemp 253 return 254 end 255 double complex function zdotu(n,zx,incx,zy,incy) 256c 257c forms the dot product of two vectors. 258c jack dongarra, 3/11/78. 259c modified 12/3/93, array(1) declarations changed to array(*) 260c 261 double complex zx(*),zy(*),ztemp 262 integer i,incx,incy,ix,iy,n 263 ztemp = (0.0d0,0.0d0) 264 zdotu = (0.0d0,0.0d0) 265 if(n.le.0)return 266 if(incx.eq.1.and.incy.eq.1)go to 20 267c 268c code for unequal increments or equal increments 269c not equal to 1 270c 271 ix = 1 272 iy = 1 273 if(incx.lt.0)ix = (-n+1)*incx + 1 274 if(incy.lt.0)iy = (-n+1)*incy + 1 275 do 10 i = 1,n 276 ztemp = ztemp + zx(ix)*zy(iy) 277 ix = ix + incx 278 iy = iy + incy 279 10 continue 280 zdotu = ztemp 281 return 282c 283c code for both increments equal to 1 284c 285 20 do 30 i = 1,n 286 ztemp = ztemp + zx(i)*zy(i) 287 30 continue 288 zdotu = ztemp 289 return 290 end 291 subroutine zdscal(n,da,zx,incx) 292c 293c scales a vector by a constant. 294c jack dongarra, 3/11/78. 295c modified 3/93 to return if incx .le. 0. 296c modified 12/3/93, array(1) declarations changed to array(*) 297c 298 intrinsic dcmplx 299 double complex zx(*) 300 double precision da 301 integer i,incx,ix,n 302c 303 if( n.le.0 .or. incx.le.0 )return 304 if(incx.eq.1)go to 20 305c 306c code for increment not equal to 1 307c 308 ix = 1 309 do 10 i = 1,n 310 zx(ix) = dcmplx(da,0.0d0)*zx(ix) 311 ix = ix + incx 312 10 continue 313 return 314c 315c code for increment equal to 1 316c 317 20 do 30 i = 1,n 318 zx(i) = dcmplx(da,0.0d0)*zx(i) 319 30 continue 320 return 321 end 322 SUBROUTINE ZGEMV ( TRANS, M, N, ALPHA, A, LDA, X, INCX, 323 $ BETA, Y, INCY ) 324* .. Scalar Arguments .. 325 DOUBLE COMPLEX ALPHA, BETA 326 INTEGER INCX, INCY, LDA, M, N 327 CHARACTER TRANS 328* .. Array Arguments .. 329 DOUBLE COMPLEX A( LDA, * ), X( * ), Y( * ) 330* .. 331* 332* Purpose 333* ======= 334* 335* ZGEMV performs one of the matrix-vector operations 336* 337* y := alpha*A*x + beta*y, or y := alpha*A'*x + beta*y, or 338* 339* y := alpha*conjg( A' )*x + beta*y, 340* 341* where alpha and beta are scalars, x and y are vectors and A is an 342* m by n matrix. 343* 344* Parameters 345* ========== 346* 347* TRANS - CHARACTER*1. 348* On entry, TRANS specifies the operation to be performed as 349* follows: 350* 351* TRANS = 'N' or 'n' y := alpha*A*x + beta*y. 352* 353* TRANS = 'T' or 't' y := alpha*A'*x + beta*y. 354* 355* TRANS = 'C' or 'c' y := alpha*conjg( A' )*x + beta*y. 356* 357* Unchanged on exit. 358* 359* M - INTEGER. 360* On entry, M specifies the number of rows of the matrix A. 361* M must be at least zero. 362* Unchanged on exit. 363* 364* N - INTEGER. 365* On entry, N specifies the number of columns of the matrix A. 366* N must be at least zero. 367* Unchanged on exit. 368* 369* ALPHA - DOUBLE COMPLEX . 370* On entry, ALPHA specifies the scalar alpha. 371* Unchanged on exit. 372* 373* A - DOUBLE COMPLEX array of DIMENSION ( LDA, n ). 374* Before entry, the leading m by n part of the array A must 375* contain the matrix of coefficients. 376* Unchanged on exit. 377* 378* LDA - INTEGER. 379* On entry, LDA specifies the first dimension of A as declared 380* in the calling (sub) program. LDA must be at least 381* max( 1, m ). 382* Unchanged on exit. 383* 384* X - DOUBLE COMPLEX array of DIMENSION at least 385* ( 1 + ( n - 1 )*abs( INCX ) ) when TRANS = 'N' or 'n' 386* and at least 387* ( 1 + ( m - 1 )*abs( INCX ) ) otherwise. 388* Before entry, the incremented array X must contain the 389* vector x. 390* Unchanged on exit. 391* 392* INCX - INTEGER. 393* On entry, INCX specifies the increment for the elements of 394* X. INCX must not be zero. 395* Unchanged on exit. 396* 397* BETA - DOUBLE COMPLEX . 398* On entry, BETA specifies the scalar beta. When BETA is 399* supplied as zero then Y need not be set on input. 400* Unchanged on exit. 401* 402* Y - DOUBLE COMPLEX array of DIMENSION at least 403* ( 1 + ( m - 1 )*abs( INCY ) ) when TRANS = 'N' or 'n' 404* and at least 405* ( 1 + ( n - 1 )*abs( INCY ) ) otherwise. 406* Before entry with BETA non-zero, the incremented array Y 407* must contain the vector y. On exit, Y is overwritten by the 408* updated vector y. 409* 410* INCY - INTEGER. 411* On entry, INCY specifies the increment for the elements of 412* Y. INCY must not be zero. 413* Unchanged on exit. 414* 415* 416* Level 2 Blas routine. 417* 418* -- Written on 22-October-1986. 419* Jack Dongarra, Argonne National Lab. 420* Jeremy Du Croz, Nag Central Office. 421* Sven Hammarling, Nag Central Office. 422* Richard Hanson, Sandia National Labs. 423* 424* 425* .. Parameters .. 426 DOUBLE COMPLEX ONE 427 PARAMETER ( ONE = ( 1.0D+0, 0.0D+0 ) ) 428 DOUBLE COMPLEX ZERO 429 PARAMETER ( ZERO = ( 0.0D+0, 0.0D+0 ) ) 430* .. Local Scalars .. 431 DOUBLE COMPLEX TEMP 432 INTEGER I, INFO, IX, IY, J, JX, JY, KX, KY, LENX, LENY 433 LOGICAL NOCONJ 434* .. External Functions .. 435 LOGICAL LSAME 436 EXTERNAL LSAME 437* .. External Subroutines .. 438 EXTERNAL XERBLA 439* .. Intrinsic Functions .. 440 INTRINSIC DCONJG, MAX 441* .. 442* .. Executable Statements .. 443* 444* Test the input parameters. 445* 446 INFO = 0 447 IF ( .NOT.LSAME( TRANS, 'N' ).AND. 448 $ .NOT.LSAME( TRANS, 'T' ).AND. 449 $ .NOT.LSAME( TRANS, 'C' ) )THEN 450 INFO = 1 451 ELSE IF( M.LT.0 )THEN 452 INFO = 2 453 ELSE IF( N.LT.0 )THEN 454 INFO = 3 455 ELSE IF( LDA.LT.MAX( 1, M ) )THEN 456 INFO = 6 457 ELSE IF( INCX.EQ.0 )THEN 458 INFO = 8 459 ELSE IF( INCY.EQ.0 )THEN 460 INFO = 11 461 END IF 462 IF( INFO.NE.0 )THEN 463 CALL XERBLA( 'ZGEMV ', INFO ) 464 RETURN 465 END IF 466* 467* Quick return if possible. 468* 469 IF( ( M.EQ.0 ).OR.( N.EQ.0 ).OR. 470 $ ( ( ALPHA.EQ.ZERO ).AND.( BETA.EQ.ONE ) ) ) 471 $ RETURN 472* 473 NOCONJ = LSAME( TRANS, 'T' ) 474* 475* Set LENX and LENY, the lengths of the vectors x and y, and set 476* up the start points in X and Y. 477* 478 IF( LSAME( TRANS, 'N' ) )THEN 479 LENX = N 480 LENY = M 481 ELSE 482 LENX = M 483 LENY = N 484 END IF 485 IF( INCX.GT.0 )THEN 486 KX = 1 487 ELSE 488 KX = 1 - ( LENX - 1 )*INCX 489 END IF 490 IF( INCY.GT.0 )THEN 491 KY = 1 492 ELSE 493 KY = 1 - ( LENY - 1 )*INCY 494 END IF 495* 496* Start the operations. In this version the elements of A are 497* accessed sequentially with one pass through A. 498* 499* First form y := beta*y. 500* 501 IF( BETA.NE.ONE )THEN 502 IF( INCY.EQ.1 )THEN 503 IF( BETA.EQ.ZERO )THEN 504 DO 10, I = 1, LENY 505 Y( I ) = ZERO 506 10 CONTINUE 507 ELSE 508 DO 20, I = 1, LENY 509 Y( I ) = BETA*Y( I ) 510 20 CONTINUE 511 END IF 512 ELSE 513 IY = KY 514 IF( BETA.EQ.ZERO )THEN 515 DO 30, I = 1, LENY 516 Y( IY ) = ZERO 517 IY = IY + INCY 518 30 CONTINUE 519 ELSE 520 DO 40, I = 1, LENY 521 Y( IY ) = BETA*Y( IY ) 522 IY = IY + INCY 523 40 CONTINUE 524 END IF 525 END IF 526 END IF 527 IF( ALPHA.EQ.ZERO ) 528 $ RETURN 529 IF( LSAME( TRANS, 'N' ) )THEN 530* 531* Form y := alpha*A*x + y. 532* 533 JX = KX 534 IF( INCY.EQ.1 )THEN 535 DO 60, J = 1, N 536c IF( X( JX ).NE.ZERO )THEN 537 TEMP = ALPHA*X( JX ) 538 DO 50, I = 1, M 539 Y( I ) = Y( I ) + TEMP*A( I, J ) 540 50 CONTINUE 541c END IF 542 JX = JX + INCX 543 60 CONTINUE 544 ELSE 545 DO 80, J = 1, N 546c IF( X( JX ).NE.ZERO )THEN 547 TEMP = ALPHA*X( JX ) 548 IY = KY 549 DO 70, I = 1, M 550 Y( IY ) = Y( IY ) + TEMP*A( I, J ) 551 IY = IY + INCY 552 70 CONTINUE 553c END IF 554 JX = JX + INCX 555 80 CONTINUE 556 END IF 557 ELSE 558* 559* Form y := alpha*A'*x + y or y := alpha*conjg( A' )*x + y. 560* 561 JY = KY 562 IF( INCX.EQ.1 )THEN 563 DO 110, J = 1, N 564 TEMP = ZERO 565 IF( NOCONJ )THEN 566 DO 90, I = 1, M 567 TEMP = TEMP + A( I, J )*X( I ) 568 90 CONTINUE 569 ELSE 570 DO 100, I = 1, M 571 TEMP = TEMP + DCONJG( A( I, J ) )*X( I ) 572 100 CONTINUE 573 END IF 574 Y( JY ) = Y( JY ) + ALPHA*TEMP 575 JY = JY + INCY 576 110 CONTINUE 577 ELSE 578 DO 140, J = 1, N 579 TEMP = ZERO 580 IX = KX 581 IF( NOCONJ )THEN 582 DO 120, I = 1, M 583 TEMP = TEMP + A( I, J )*X( IX ) 584 IX = IX + INCX 585 120 CONTINUE 586 ELSE 587 DO 130, I = 1, M 588 TEMP = TEMP + DCONJG( A( I, J ) )*X( IX ) 589 IX = IX + INCX 590 130 CONTINUE 591 END IF 592 Y( JY ) = Y( JY ) + ALPHA*TEMP 593 JY = JY + INCY 594 140 CONTINUE 595 END IF 596 END IF 597* 598 RETURN 599* 600* End of ZGEMV . 601* 602 END 603 SUBROUTINE ZGERC ( M, N, ALPHA, X, INCX, Y, INCY, A, LDA ) 604* .. Scalar Arguments .. 605 DOUBLE COMPLEX ALPHA 606 INTEGER INCX, INCY, LDA, M, N 607* .. Array Arguments .. 608 DOUBLE COMPLEX A( LDA, * ), X( * ), Y( * ) 609* .. 610* 611* Purpose 612* ======= 613* 614* ZGERC performs the rank 1 operation 615* 616* A := alpha*x*conjg( y' ) + A, 617* 618* where alpha is a scalar, x is an m element vector, y is an n element 619* vector and A is an m by n matrix. 620* 621* Parameters 622* ========== 623* 624* M - INTEGER. 625* On entry, M specifies the number of rows of the matrix A. 626* M must be at least zero. 627* Unchanged on exit. 628* 629* N - INTEGER. 630* On entry, N specifies the number of columns of the matrix A. 631* N must be at least zero. 632* Unchanged on exit. 633* 634* ALPHA - DOUBLE COMPLEX . 635* On entry, ALPHA specifies the scalar alpha. 636* Unchanged on exit. 637* 638* X - DOUBLE COMPLEX array of dimension at least 639* ( 1 + ( m - 1 )*abs( INCX ) ). 640* Before entry, the incremented array X must contain the m 641* element vector x. 642* Unchanged on exit. 643* 644* INCX - INTEGER. 645* On entry, INCX specifies the increment for the elements of 646* X. INCX must not be zero. 647* Unchanged on exit. 648* 649* Y - DOUBLE COMPLEX array of dimension at least 650* ( 1 + ( n - 1 )*abs( INCY ) ). 651* Before entry, the incremented array Y must contain the n 652* element vector y. 653* Unchanged on exit. 654* 655* INCY - INTEGER. 656* On entry, INCY specifies the increment for the elements of 657* Y. INCY must not be zero. 658* Unchanged on exit. 659* 660* A - DOUBLE COMPLEX array of DIMENSION ( LDA, n ). 661* Before entry, the leading m by n part of the array A must 662* contain the matrix of coefficients. On exit, A is 663* overwritten by the updated matrix. 664* 665* LDA - INTEGER. 666* On entry, LDA specifies the first dimension of A as declared 667* in the calling (sub) program. LDA must be at least 668* max( 1, m ). 669* Unchanged on exit. 670* 671* 672* Level 2 Blas routine. 673* 674* -- Written on 22-October-1986. 675* Jack Dongarra, Argonne National Lab. 676* Jeremy Du Croz, Nag Central Office. 677* Sven Hammarling, Nag Central Office. 678* Richard Hanson, Sandia National Labs. 679* 680* 681* .. Parameters .. 682 DOUBLE COMPLEX ZERO 683 PARAMETER ( ZERO = ( 0.0D+0, 0.0D+0 ) ) 684* .. Local Scalars .. 685 DOUBLE COMPLEX TEMP 686 INTEGER I, INFO, IX, J, JY, KX 687* .. External Subroutines .. 688 EXTERNAL XERBLA 689* .. Intrinsic Functions .. 690 INTRINSIC DCONJG, MAX 691* .. 692* .. Executable Statements .. 693* 694* Test the input parameters. 695* 696 INFO = 0 697 IF ( M.LT.0 )THEN 698 INFO = 1 699 ELSE IF( N.LT.0 )THEN 700 INFO = 2 701 ELSE IF( INCX.EQ.0 )THEN 702 INFO = 5 703 ELSE IF( INCY.EQ.0 )THEN 704 INFO = 7 705 ELSE IF( LDA.LT.MAX( 1, M ) )THEN 706 INFO = 9 707 END IF 708 IF( INFO.NE.0 )THEN 709 CALL XERBLA( 'ZGERC ', INFO ) 710 RETURN 711 END IF 712* 713* Quick return if possible. 714* 715 IF( ( M.EQ.0 ).OR.( N.EQ.0 ).OR.( ALPHA.EQ.ZERO ) ) 716 $ RETURN 717* 718* Start the operations. In this version the elements of A are 719* accessed sequentially with one pass through A. 720* 721 IF( INCY.GT.0 )THEN 722 JY = 1 723 ELSE 724 JY = 1 - ( N - 1 )*INCY 725 END IF 726 IF( INCX.EQ.1 )THEN 727 DO 20, J = 1, N 728c IF( Y( JY ).NE.ZERO )THEN 729 TEMP = ALPHA*DCONJG( Y( JY ) ) 730 DO 10, I = 1, M 731 A( I, J ) = A( I, J ) + X( I )*TEMP 732 10 CONTINUE 733c END IF 734 JY = JY + INCY 735 20 CONTINUE 736 ELSE 737 IF( INCX.GT.0 )THEN 738 KX = 1 739 ELSE 740 KX = 1 - ( M - 1 )*INCX 741 END IF 742 DO 40, J = 1, N 743c IF( Y( JY ).NE.ZERO )THEN 744 TEMP = ALPHA*DCONJG( Y( JY ) ) 745 IX = KX 746 DO 30, I = 1, M 747 A( I, J ) = A( I, J ) + X( IX )*TEMP 748 IX = IX + INCX 749 30 CONTINUE 750c END IF 751 JY = JY + INCY 752 40 CONTINUE 753 END IF 754* 755 RETURN 756* 757* End of ZGERC . 758* 759 END 760 SUBROUTINE ZHEMV ( UPLO, N, ALPHA, A, LDA, X, INCX, 761 $ BETA, Y, INCY ) 762* .. Scalar Arguments .. 763 DOUBLE COMPLEX ALPHA, BETA 764 INTEGER INCX, INCY, LDA, N 765 CHARACTER UPLO 766* .. Array Arguments .. 767 DOUBLE COMPLEX A( LDA, * ), X( * ), Y( * ) 768* .. 769* 770* Purpose 771* ======= 772* 773* ZHEMV performs the matrix-vector operation 774* 775* y := alpha*A*x + beta*y, 776* 777* where alpha and beta are scalars, x and y are n element vectors and 778* A is an n by n hermitian matrix. 779* 780* Parameters 781* ========== 782* 783* UPLO - CHARACTER*1. 784* On entry, UPLO specifies whether the upper or lower 785* triangular part of the array A is to be referenced as 786* follows: 787* 788* UPLO = 'U' or 'u' Only the upper triangular part of A 789* is to be referenced. 790* 791* UPLO = 'L' or 'l' Only the lower triangular part of A 792* is to be referenced. 793* 794* Unchanged on exit. 795* 796* N - INTEGER. 797* On entry, N specifies the order of the matrix A. 798* N must be at least zero. 799* Unchanged on exit. 800* 801* ALPHA - DOUBLE COMPLEX . 802* On entry, ALPHA specifies the scalar alpha. 803* Unchanged on exit. 804* 805* A - DOUBLE COMPLEX array of DIMENSION ( LDA, n ). 806* Before entry with UPLO = 'U' or 'u', the leading n by n 807* upper triangular part of the array A must contain the upper 808* triangular part of the hermitian matrix and the strictly 809* lower triangular part of A is not referenced. 810* Before entry with UPLO = 'L' or 'l', the leading n by n 811* lower triangular part of the array A must contain the lower 812* triangular part of the hermitian matrix and the strictly 813* upper triangular part of A is not referenced. 814* Note that the imaginary parts of the diagonal elements need 815* not be set and are assumed to be zero. 816* Unchanged on exit. 817* 818* LDA - INTEGER. 819* On entry, LDA specifies the first dimension of A as declared 820* in the calling (sub) program. LDA must be at least 821* max( 1, n ). 822* Unchanged on exit. 823* 824* X - DOUBLE COMPLEX array of dimension at least 825* ( 1 + ( n - 1 )*abs( INCX ) ). 826* Before entry, the incremented array X must contain the n 827* element vector x. 828* Unchanged on exit. 829* 830* INCX - INTEGER. 831* On entry, INCX specifies the increment for the elements of 832* X. INCX must not be zero. 833* Unchanged on exit. 834* 835* BETA - DOUBLE COMPLEX . 836* On entry, BETA specifies the scalar beta. When BETA is 837* supplied as zero then Y need not be set on input. 838* Unchanged on exit. 839* 840* Y - DOUBLE COMPLEX array of dimension at least 841* ( 1 + ( n - 1 )*abs( INCY ) ). 842* Before entry, the incremented array Y must contain the n 843* element vector y. On exit, Y is overwritten by the updated 844* vector y. 845* 846* INCY - INTEGER. 847* On entry, INCY specifies the increment for the elements of 848* Y. INCY must not be zero. 849* Unchanged on exit. 850* 851* 852* Level 2 Blas routine. 853* 854* -- Written on 22-October-1986. 855* Jack Dongarra, Argonne National Lab. 856* Jeremy Du Croz, Nag Central Office. 857* Sven Hammarling, Nag Central Office. 858* Richard Hanson, Sandia National Labs. 859* 860* 861* .. Parameters .. 862 DOUBLE COMPLEX ONE 863 PARAMETER ( ONE = ( 1.0D+0, 0.0D+0 ) ) 864 DOUBLE COMPLEX ZERO 865 PARAMETER ( ZERO = ( 0.0D+0, 0.0D+0 ) ) 866* .. Local Scalars .. 867 DOUBLE COMPLEX TEMP1, TEMP2 868 INTEGER I, INFO, IX, IY, J, JX, JY, KX, KY 869* .. External Functions .. 870 LOGICAL LSAME 871 EXTERNAL LSAME 872* .. External Subroutines .. 873 EXTERNAL XERBLA 874* .. Intrinsic Functions .. 875 INTRINSIC DCONJG, MAX, DBLE 876* .. 877* .. Executable Statements .. 878* 879* Test the input parameters. 880* 881 INFO = 0 882 IF ( .NOT.LSAME( UPLO, 'U' ).AND. 883 $ .NOT.LSAME( UPLO, 'L' ) )THEN 884 INFO = 1 885 ELSE IF( N.LT.0 )THEN 886 INFO = 2 887 ELSE IF( LDA.LT.MAX( 1, N ) )THEN 888 INFO = 5 889 ELSE IF( INCX.EQ.0 )THEN 890 INFO = 7 891 ELSE IF( INCY.EQ.0 )THEN 892 INFO = 10 893 END IF 894 IF( INFO.NE.0 )THEN 895 CALL XERBLA( 'ZHEMV ', INFO ) 896 RETURN 897 END IF 898* 899* Quick return if possible. 900* 901 IF( ( N.EQ.0 ).OR.( ( ALPHA.EQ.ZERO ).AND.( BETA.EQ.ONE ) ) ) 902 $ RETURN 903* 904* Set up the start points in X and Y. 905* 906 IF( INCX.GT.0 )THEN 907 KX = 1 908 ELSE 909 KX = 1 - ( N - 1 )*INCX 910 END IF 911 IF( INCY.GT.0 )THEN 912 KY = 1 913 ELSE 914 KY = 1 - ( N - 1 )*INCY 915 END IF 916* 917* Start the operations. In this version the elements of A are 918* accessed sequentially with one pass through the triangular part 919* of A. 920* 921* First form y := beta*y. 922* 923 IF( BETA.NE.ONE )THEN 924 IF( INCY.EQ.1 )THEN 925 IF( BETA.EQ.ZERO )THEN 926 DO 10, I = 1, N 927 Y( I ) = ZERO 928 10 CONTINUE 929 ELSE 930 DO 20, I = 1, N 931 Y( I ) = BETA*Y( I ) 932 20 CONTINUE 933 END IF 934 ELSE 935 IY = KY 936 IF( BETA.EQ.ZERO )THEN 937 DO 30, I = 1, N 938 Y( IY ) = ZERO 939 IY = IY + INCY 940 30 CONTINUE 941 ELSE 942 DO 40, I = 1, N 943 Y( IY ) = BETA*Y( IY ) 944 IY = IY + INCY 945 40 CONTINUE 946 END IF 947 END IF 948 END IF 949 IF( ALPHA.EQ.ZERO ) 950 $ RETURN 951 IF( LSAME( UPLO, 'U' ) )THEN 952* 953* Form y when A is stored in upper triangle. 954* 955 IF( ( INCX.EQ.1 ).AND.( INCY.EQ.1 ) )THEN 956 DO 60, J = 1, N 957 TEMP1 = ALPHA*X( J ) 958 TEMP2 = ZERO 959 DO 50, I = 1, J - 1 960 Y( I ) = Y( I ) + TEMP1*A( I, J ) 961 TEMP2 = TEMP2 + DCONJG( A( I, J ) )*X( I ) 962 50 CONTINUE 963 Y( J ) = Y( J ) + TEMP1*DBLE( A( J, J ) ) + ALPHA*TEMP2 964 60 CONTINUE 965 ELSE 966 JX = KX 967 JY = KY 968 DO 80, J = 1, N 969 TEMP1 = ALPHA*X( JX ) 970 TEMP2 = ZERO 971 IX = KX 972 IY = KY 973 DO 70, I = 1, J - 1 974 Y( IY ) = Y( IY ) + TEMP1*A( I, J ) 975 TEMP2 = TEMP2 + DCONJG( A( I, J ) )*X( IX ) 976 IX = IX + INCX 977 IY = IY + INCY 978 70 CONTINUE 979 Y( JY ) = Y( JY ) + TEMP1*DBLE( A( J, J ) ) + ALPHA*TEMP2 980 JX = JX + INCX 981 JY = JY + INCY 982 80 CONTINUE 983 END IF 984 ELSE 985* 986* Form y when A is stored in lower triangle. 987* 988 IF( ( INCX.EQ.1 ).AND.( INCY.EQ.1 ) )THEN 989 DO 100, J = 1, N 990 TEMP1 = ALPHA*X( J ) 991 TEMP2 = ZERO 992 Y( J ) = Y( J ) + TEMP1*DBLE( A( J, J ) ) 993 DO 90, I = J + 1, N 994 Y( I ) = Y( I ) + TEMP1*A( I, J ) 995 TEMP2 = TEMP2 + DCONJG( A( I, J ) )*X( I ) 996 90 CONTINUE 997 Y( J ) = Y( J ) + ALPHA*TEMP2 998 100 CONTINUE 999 ELSE 1000 JX = KX 1001 JY = KY 1002 DO 120, J = 1, N 1003 TEMP1 = ALPHA*X( JX ) 1004 TEMP2 = ZERO 1005 Y( JY ) = Y( JY ) + TEMP1*DBLE( A( J, J ) ) 1006 IX = JX 1007 IY = JY 1008 DO 110, I = J + 1, N 1009 IX = IX + INCX 1010 IY = IY + INCY 1011 Y( IY ) = Y( IY ) + TEMP1*A( I, J ) 1012 TEMP2 = TEMP2 + DCONJG( A( I, J ) )*X( IX ) 1013 110 CONTINUE 1014 Y( JY ) = Y( JY ) + ALPHA*TEMP2 1015 JX = JX + INCX 1016 JY = JY + INCY 1017 120 CONTINUE 1018 END IF 1019 END IF 1020* 1021 RETURN 1022* 1023* End of ZHEMV . 1024* 1025 END 1026 SUBROUTINE ZHER2 ( UPLO, N, ALPHA, X, INCX, Y, INCY, A, LDA ) 1027* .. Scalar Arguments .. 1028 DOUBLE COMPLEX ALPHA 1029 INTEGER INCX, INCY, LDA, N 1030 CHARACTER UPLO 1031* .. Array Arguments .. 1032 DOUBLE COMPLEX A( LDA, * ), X( * ), Y( * ) 1033* .. 1034* 1035* Purpose 1036* ======= 1037* 1038* ZHER2 performs the hermitian rank 2 operation 1039* 1040* A := alpha*x*conjg( y' ) + conjg( alpha )*y*conjg( x' ) + A, 1041* 1042* where alpha is a scalar, x and y are n element vectors and A is an n 1043* by n hermitian matrix. 1044* 1045* Parameters 1046* ========== 1047* 1048* UPLO - CHARACTER*1. 1049* On entry, UPLO specifies whether the upper or lower 1050* triangular part of the array A is to be referenced as 1051* follows: 1052* 1053* UPLO = 'U' or 'u' Only the upper triangular part of A 1054* is to be referenced. 1055* 1056* UPLO = 'L' or 'l' Only the lower triangular part of A 1057* is to be referenced. 1058* 1059* Unchanged on exit. 1060* 1061* N - INTEGER. 1062* On entry, N specifies the order of the matrix A. 1063* N must be at least zero. 1064* Unchanged on exit. 1065* 1066* ALPHA - DOUBLE COMPLEX . 1067* On entry, ALPHA specifies the scalar alpha. 1068* Unchanged on exit. 1069* 1070* X - DOUBLE COMPLEX array of dimension at least 1071* ( 1 + ( n - 1 )*abs( INCX ) ). 1072* Before entry, the incremented array X must contain the n 1073* element vector x. 1074* Unchanged on exit. 1075* 1076* INCX - INTEGER. 1077* On entry, INCX specifies the increment for the elements of 1078* X. INCX must not be zero. 1079* Unchanged on exit. 1080* 1081* Y - DOUBLE COMPLEX array of dimension at least 1082* ( 1 + ( n - 1 )*abs( INCY ) ). 1083* Before entry, the incremented array Y must contain the n 1084* element vector y. 1085* Unchanged on exit. 1086* 1087* INCY - INTEGER. 1088* On entry, INCY specifies the increment for the elements of 1089* Y. INCY must not be zero. 1090* Unchanged on exit. 1091* 1092* A - DOUBLE COMPLEX array of DIMENSION ( LDA, n ). 1093* Before entry with UPLO = 'U' or 'u', the leading n by n 1094* upper triangular part of the array A must contain the upper 1095* triangular part of the hermitian matrix and the strictly 1096* lower triangular part of A is not referenced. On exit, the 1097* upper triangular part of the array A is overwritten by the 1098* upper triangular part of the updated matrix. 1099* Before entry with UPLO = 'L' or 'l', the leading n by n 1100* lower triangular part of the array A must contain the lower 1101* triangular part of the hermitian matrix and the strictly 1102* upper triangular part of A is not referenced. On exit, the 1103* lower triangular part of the array A is overwritten by the 1104* lower triangular part of the updated matrix. 1105* Note that the imaginary parts of the diagonal elements need 1106* not be set, they are assumed to be zero, and on exit they 1107* are set to zero. 1108* 1109* LDA - INTEGER. 1110* On entry, LDA specifies the first dimension of A as declared 1111* in the calling (sub) program. LDA must be at least 1112* max( 1, n ). 1113* Unchanged on exit. 1114* 1115* 1116* Level 2 Blas routine. 1117* 1118* -- Written on 22-October-1986. 1119* Jack Dongarra, Argonne National Lab. 1120* Jeremy Du Croz, Nag Central Office. 1121* Sven Hammarling, Nag Central Office. 1122* Richard Hanson, Sandia National Labs. 1123* 1124* 1125* .. Parameters .. 1126 DOUBLE COMPLEX ZERO 1127 PARAMETER ( ZERO = ( 0.0D+0, 0.0D+0 ) ) 1128* .. Local Scalars .. 1129 DOUBLE COMPLEX TEMP1, TEMP2 1130 INTEGER I, INFO, IX, IY, J, JX, JY, KX, KY 1131* .. External Functions .. 1132 LOGICAL LSAME 1133 EXTERNAL LSAME 1134* .. External Subroutines .. 1135 EXTERNAL XERBLA 1136* .. Intrinsic Functions .. 1137 INTRINSIC DCONJG, MAX, DBLE 1138* .. 1139* .. Executable Statements .. 1140* 1141* Test the input parameters. 1142* 1143 INFO = 0 1144 IF ( .NOT.LSAME( UPLO, 'U' ).AND. 1145 $ .NOT.LSAME( UPLO, 'L' ) )THEN 1146 INFO = 1 1147 ELSE IF( N.LT.0 )THEN 1148 INFO = 2 1149 ELSE IF( INCX.EQ.0 )THEN 1150 INFO = 5 1151 ELSE IF( INCY.EQ.0 )THEN 1152 INFO = 7 1153 ELSE IF( LDA.LT.MAX( 1, N ) )THEN 1154 INFO = 9 1155 END IF 1156 IF( INFO.NE.0 )THEN 1157 CALL XERBLA( 'ZHER2 ', INFO ) 1158 RETURN 1159 END IF 1160* 1161* Quick return if possible. 1162* 1163 IF( ( N.EQ.0 ).OR.( ALPHA.EQ.ZERO ) ) 1164 $ RETURN 1165* 1166* Set up the start points in X and Y if the increments are not both 1167* unity. 1168* 1169 IF( ( INCX.NE.1 ).OR.( INCY.NE.1 ) )THEN 1170 IF( INCX.GT.0 )THEN 1171 KX = 1 1172 ELSE 1173 KX = 1 - ( N - 1 )*INCX 1174 END IF 1175 IF( INCY.GT.0 )THEN 1176 KY = 1 1177 ELSE 1178 KY = 1 - ( N - 1 )*INCY 1179 END IF 1180 JX = KX 1181 JY = KY 1182 END IF 1183* 1184* Start the operations. In this version the elements of A are 1185* accessed sequentially with one pass through the triangular part 1186* of A. 1187* 1188 IF( LSAME( UPLO, 'U' ) )THEN 1189* 1190* Form A when A is stored in the upper triangle. 1191* 1192 IF( ( INCX.EQ.1 ).AND.( INCY.EQ.1 ) )THEN 1193 DO 20, J = 1, N 1194c IF( ( X( J ).NE.ZERO ).OR.( Y( J ).NE.ZERO ) )THEN 1195 TEMP1 = ALPHA*DCONJG( Y( J ) ) 1196 TEMP2 = DCONJG( ALPHA*X( J ) ) 1197 DO 10, I = 1, J - 1 1198 A( I, J ) = A( I, J ) + X( I )*TEMP1 + Y( I )*TEMP2 1199 10 CONTINUE 1200 A( J, J ) = DBLE( A( J, J ) ) + 1201 $ DBLE( X( J )*TEMP1 + Y( J )*TEMP2 ) 1202c ELSE 1203c A( J, J ) = DBLE( A( J, J ) ) 1204c END IF 1205 20 CONTINUE 1206 ELSE 1207 DO 40, J = 1, N 1208c IF( ( X( JX ).NE.ZERO ).OR.( Y( JY ).NE.ZERO ) )THEN 1209 TEMP1 = ALPHA*DCONJG( Y( JY ) ) 1210 TEMP2 = DCONJG( ALPHA*X( JX ) ) 1211 IX = KX 1212 IY = KY 1213 DO 30, I = 1, J - 1 1214 A( I, J ) = A( I, J ) + X( IX )*TEMP1 1215 $ + Y( IY )*TEMP2 1216 IX = IX + INCX 1217 IY = IY + INCY 1218 30 CONTINUE 1219 A( J, J ) = DBLE( A( J, J ) ) + 1220 $ DBLE( X( JX )*TEMP1 + Y( JY )*TEMP2 ) 1221c ELSE 1222c A( J, J ) = DBLE( A( J, J ) ) 1223c END IF 1224 JX = JX + INCX 1225 JY = JY + INCY 1226 40 CONTINUE 1227 END IF 1228 ELSE 1229* 1230* Form A when A is stored in the lower triangle. 1231* 1232 IF( ( INCX.EQ.1 ).AND.( INCY.EQ.1 ) )THEN 1233 DO 60, J = 1, N 1234c IF( ( X( J ).NE.ZERO ).OR.( Y( J ).NE.ZERO ) )THEN 1235 TEMP1 = ALPHA*DCONJG( Y( J ) ) 1236 TEMP2 = DCONJG( ALPHA*X( J ) ) 1237 A( J, J ) = DBLE( A( J, J ) ) + 1238 $ DBLE( X( J )*TEMP1 + Y( J )*TEMP2 ) 1239 DO 50, I = J + 1, N 1240 A( I, J ) = A( I, J ) + X( I )*TEMP1 + Y( I )*TEMP2 1241 50 CONTINUE 1242c ELSE 1243c A( J, J ) = DBLE( A( J, J ) ) 1244c END IF 1245 60 CONTINUE 1246 ELSE 1247 DO 80, J = 1, N 1248c IF( ( X( JX ).NE.ZERO ).OR.( Y( JY ).NE.ZERO ) )THEN 1249 TEMP1 = ALPHA*DCONJG( Y( JY ) ) 1250 TEMP2 = DCONJG( ALPHA*X( JX ) ) 1251 A( J, J ) = DBLE( A( J, J ) ) + 1252 $ DBLE( X( JX )*TEMP1 + Y( JY )*TEMP2 ) 1253 IX = JX 1254 IY = JY 1255 DO 70, I = J + 1, N 1256 IX = IX + INCX 1257 IY = IY + INCY 1258 A( I, J ) = A( I, J ) + X( IX )*TEMP1 1259 $ + Y( IY )*TEMP2 1260 70 CONTINUE 1261c ELSE 1262c A( J, J ) = DBLE( A( J, J ) ) 1263c END IF 1264 JX = JX + INCX 1265 JY = JY + INCY 1266 80 CONTINUE 1267 END IF 1268 END IF 1269* 1270 RETURN 1271* 1272* End of ZHER2 . 1273* 1274 END 1275 SUBROUTINE ZHER2K( UPLO, TRANS, N, K, ALPHA, A, LDA, B, LDB, BETA, 1276 $ C, LDC ) 1277* .. Scalar Arguments .. 1278 CHARACTER TRANS, UPLO 1279 INTEGER K, LDA, LDB, LDC, N 1280 DOUBLE PRECISION BETA 1281 DOUBLE COMPLEX ALPHA 1282* .. 1283* .. Array Arguments .. 1284 DOUBLE COMPLEX A( LDA, * ), B( LDB, * ), C( LDC, * ) 1285* .. 1286* 1287* Purpose 1288* ======= 1289* 1290* ZHER2K performs one of the hermitian rank 2k operations 1291* 1292* C := alpha*A*conjg( B' ) + conjg( alpha )*B*conjg( A' ) + beta*C, 1293* 1294* or 1295* 1296* C := alpha*conjg( A' )*B + conjg( alpha )*conjg( B' )*A + beta*C, 1297* 1298* where alpha and beta are scalars with beta real, C is an n by n 1299* hermitian matrix and A and B are n by k matrices in the first case 1300* and k by n matrices in the second case. 1301* 1302* Parameters 1303* ========== 1304* 1305* UPLO - CHARACTER*1. 1306* On entry, UPLO specifies whether the upper or lower 1307* triangular part of the array C is to be referenced as 1308* follows: 1309* 1310* UPLO = 'U' or 'u' Only the upper triangular part of C 1311* is to be referenced. 1312* 1313* UPLO = 'L' or 'l' Only the lower triangular part of C 1314* is to be referenced. 1315* 1316* Unchanged on exit. 1317* 1318* TRANS - CHARACTER*1. 1319* On entry, TRANS specifies the operation to be performed as 1320* follows: 1321* 1322* TRANS = 'N' or 'n' C := alpha*A*conjg( B' ) + 1323* conjg( alpha )*B*conjg( A' ) + 1324* beta*C. 1325* 1326* TRANS = 'C' or 'c' C := alpha*conjg( A' )*B + 1327* conjg( alpha )*conjg( B' )*A + 1328* beta*C. 1329* 1330* Unchanged on exit. 1331* 1332* N - INTEGER. 1333* On entry, N specifies the order of the matrix C. N must be 1334* at least zero. 1335* Unchanged on exit. 1336* 1337* K - INTEGER. 1338* On entry with TRANS = 'N' or 'n', K specifies the number 1339* of columns of the matrices A and B, and on entry with 1340* TRANS = 'C' or 'c', K specifies the number of rows of the 1341* matrices A and B. K must be at least zero. 1342* Unchanged on exit. 1343* 1344* ALPHA - DOUBLE COMPLEX . 1345* On entry, ALPHA specifies the scalar alpha. 1346* Unchanged on exit. 1347* 1348* A - DOUBLE COMPLEX array of DIMENSION ( LDA, ka ), where ka is 1349* k when TRANS = 'N' or 'n', and is n otherwise. 1350* Before entry with TRANS = 'N' or 'n', the leading n by k 1351* part of the array A must contain the matrix A, otherwise 1352* the leading k by n part of the array A must contain the 1353* matrix A. 1354* Unchanged on exit. 1355* 1356* LDA - INTEGER. 1357* On entry, LDA specifies the first dimension of A as declared 1358* in the calling (sub) program. When TRANS = 'N' or 'n' 1359* then LDA must be at least max( 1, n ), otherwise LDA must 1360* be at least max( 1, k ). 1361* Unchanged on exit. 1362* 1363* B - DOUBLE COMPLEX array of DIMENSION ( LDB, kb ), where kb is 1364* k when TRANS = 'N' or 'n', and is n otherwise. 1365* Before entry with TRANS = 'N' or 'n', the leading n by k 1366* part of the array B must contain the matrix B, otherwise 1367* the leading k by n part of the array B must contain the 1368* matrix B. 1369* Unchanged on exit. 1370* 1371* LDB - INTEGER. 1372* On entry, LDB specifies the first dimension of B as declared 1373* in the calling (sub) program. When TRANS = 'N' or 'n' 1374* then LDB must be at least max( 1, n ), otherwise LDB must 1375* be at least max( 1, k ). 1376* Unchanged on exit. 1377* 1378* BETA - DOUBLE PRECISION . 1379* On entry, BETA specifies the scalar beta. 1380* Unchanged on exit. 1381* 1382* C - DOUBLE COMPLEX array of DIMENSION ( LDC, n ). 1383* Before entry with UPLO = 'U' or 'u', the leading n by n 1384* upper triangular part of the array C must contain the upper 1385* triangular part of the hermitian matrix and the strictly 1386* lower triangular part of C is not referenced. On exit, the 1387* upper triangular part of the array C is overwritten by the 1388* upper triangular part of the updated matrix. 1389* Before entry with UPLO = 'L' or 'l', the leading n by n 1390* lower triangular part of the array C must contain the lower 1391* triangular part of the hermitian matrix and the strictly 1392* upper triangular part of C is not referenced. On exit, the 1393* lower triangular part of the array C is overwritten by the 1394* lower triangular part of the updated matrix. 1395* Note that the imaginary parts of the diagonal elements need 1396* not be set, they are assumed to be zero, and on exit they 1397* are set to zero. 1398* 1399* LDC - INTEGER. 1400* On entry, LDC specifies the first dimension of C as declared 1401* in the calling (sub) program. LDC must be at least 1402* max( 1, n ). 1403* Unchanged on exit. 1404* 1405* 1406* Level 3 Blas routine. 1407* 1408* -- Written on 8-February-1989. 1409* Jack Dongarra, Argonne National Laboratory. 1410* Iain Duff, AERE Harwell. 1411* Jeremy Du Croz, Numerical Algorithms Group Ltd. 1412* Sven Hammarling, Numerical Algorithms Group Ltd. 1413* 1414* -- Modified 8-Nov-93 to set C(J,J) to DBLE( C(J,J) ) when BETA = 1. 1415* Ed Anderson, Cray Research Inc. 1416* 1417* 1418* .. External Functions .. 1419 LOGICAL LSAME 1420 EXTERNAL LSAME 1421* .. 1422* .. External Subroutines .. 1423 EXTERNAL XERBLA 1424* .. 1425* .. Intrinsic Functions .. 1426 INTRINSIC DBLE, DCONJG, MAX 1427* .. 1428* .. Local Scalars .. 1429 LOGICAL UPPER 1430 INTEGER I, INFO, J, L, NROWA 1431 DOUBLE COMPLEX TEMP1, TEMP2 1432* .. 1433* .. Parameters .. 1434 DOUBLE PRECISION ONE 1435 PARAMETER ( ONE = 1.0D+0 ) 1436 DOUBLE COMPLEX ZERO 1437 PARAMETER ( ZERO = ( 0.0D+0, 0.0D+0 ) ) 1438* .. 1439* .. Executable Statements .. 1440* 1441* Test the input parameters. 1442* 1443 IF( LSAME( TRANS, 'N' ) ) THEN 1444 NROWA = N 1445 ELSE 1446 NROWA = K 1447 END IF 1448 UPPER = LSAME( UPLO, 'U' ) 1449* 1450 INFO = 0 1451 IF( ( .NOT.UPPER ) .AND. ( .NOT.LSAME( UPLO, 'L' ) ) ) THEN 1452 INFO = 1 1453 ELSE IF( ( .NOT.LSAME( TRANS, 'N' ) ) .AND. 1454 $ ( .NOT.LSAME( TRANS, 'C' ) ) ) THEN 1455 INFO = 2 1456 ELSE IF( N.LT.0 ) THEN 1457 INFO = 3 1458 ELSE IF( K.LT.0 ) THEN 1459 INFO = 4 1460 ELSE IF( LDA.LT.MAX( 1, NROWA ) ) THEN 1461 INFO = 7 1462 ELSE IF( LDB.LT.MAX( 1, NROWA ) ) THEN 1463 INFO = 9 1464 ELSE IF( LDC.LT.MAX( 1, N ) ) THEN 1465 INFO = 12 1466 END IF 1467 IF( INFO.NE.0 ) THEN 1468 CALL XERBLA( 'ZHER2K', INFO ) 1469 RETURN 1470 END IF 1471* 1472* Quick return if possible. 1473* 1474 IF( ( N.EQ.0 ) .OR. ( ( ( ALPHA.EQ.ZERO ) .OR. ( K.EQ.0 ) ) .AND. 1475 $ ( BETA.EQ.ONE ) ) )RETURN 1476* 1477* And when alpha.eq.zero. 1478* 1479 IF( ALPHA.EQ.ZERO ) THEN 1480 IF( UPPER ) THEN 1481 IF( BETA.EQ.DBLE( ZERO ) ) THEN 1482 DO 20 J = 1, N 1483 DO 10 I = 1, J 1484 C( I, J ) = ZERO 1485 10 CONTINUE 1486 20 CONTINUE 1487 ELSE 1488 DO 40 J = 1, N 1489 DO 30 I = 1, J - 1 1490 C( I, J ) = BETA*C( I, J ) 1491 30 CONTINUE 1492 C( J, J ) = BETA*DBLE( C( J, J ) ) 1493 40 CONTINUE 1494 END IF 1495 ELSE 1496 IF( BETA.EQ.DBLE( ZERO ) ) THEN 1497 DO 60 J = 1, N 1498 DO 50 I = J, N 1499 C( I, J ) = ZERO 1500 50 CONTINUE 1501 60 CONTINUE 1502 ELSE 1503 DO 80 J = 1, N 1504 C( J, J ) = BETA*DBLE( C( J, J ) ) 1505 DO 70 I = J + 1, N 1506 C( I, J ) = BETA*C( I, J ) 1507 70 CONTINUE 1508 80 CONTINUE 1509 END IF 1510 END IF 1511 RETURN 1512 END IF 1513* 1514* Start the operations. 1515* 1516 IF( LSAME( TRANS, 'N' ) ) THEN 1517* 1518* Form C := alpha*A*conjg( B' ) + conjg( alpha )*B*conjg( A' ) + 1519* C. 1520* 1521 IF( UPPER ) THEN 1522 DO 130 J = 1, N 1523 IF( BETA.EQ.DBLE( ZERO ) ) THEN 1524 DO 90 I = 1, J 1525 C( I, J ) = ZERO 1526 90 CONTINUE 1527 ELSE IF( BETA.NE.ONE ) THEN 1528 DO 100 I = 1, J - 1 1529 C( I, J ) = BETA*C( I, J ) 1530 100 CONTINUE 1531 C( J, J ) = BETA*DBLE( C( J, J ) ) 1532 ELSE 1533 C( J, J ) = DBLE( C( J, J ) ) 1534 END IF 1535 DO 120 L = 1, K 1536c IF( ( A( J, L ).NE.ZERO ) .OR. ( B( J, L ).NE.ZERO ) ) 1537c $ THEN 1538 TEMP1 = ALPHA*DCONJG( B( J, L ) ) 1539 TEMP2 = DCONJG( ALPHA*A( J, L ) ) 1540 DO 110 I = 1, J - 1 1541 C( I, J ) = C( I, J ) + A( I, L )*TEMP1 + 1542 $ B( I, L )*TEMP2 1543 110 CONTINUE 1544 C( J, J ) = DBLE( C( J, J ) ) + 1545 $ DBLE( A( J, L )*TEMP1+B( J, L )*TEMP2 ) 1546c END IF 1547 120 CONTINUE 1548 130 CONTINUE 1549 ELSE 1550 DO 180 J = 1, N 1551 IF( BETA.EQ.DBLE( ZERO ) ) THEN 1552 DO 140 I = J, N 1553 C( I, J ) = ZERO 1554 140 CONTINUE 1555 ELSE IF( BETA.NE.ONE ) THEN 1556 DO 150 I = J + 1, N 1557 C( I, J ) = BETA*C( I, J ) 1558 150 CONTINUE 1559 C( J, J ) = BETA*DBLE( C( J, J ) ) 1560 ELSE 1561 C( J, J ) = DBLE( C( J, J ) ) 1562 END IF 1563 DO 170 L = 1, K 1564c IF( ( A( J, L ).NE.ZERO ) .OR. ( B( J, L ).NE.ZERO ) ) 1565c $ THEN 1566 TEMP1 = ALPHA*DCONJG( B( J, L ) ) 1567 TEMP2 = DCONJG( ALPHA*A( J, L ) ) 1568 DO 160 I = J + 1, N 1569 C( I, J ) = C( I, J ) + A( I, L )*TEMP1 + 1570 $ B( I, L )*TEMP2 1571 160 CONTINUE 1572 C( J, J ) = DBLE( C( J, J ) ) + 1573 $ DBLE( A( J, L )*TEMP1+B( J, L )*TEMP2 ) 1574c END IF 1575 170 CONTINUE 1576 180 CONTINUE 1577 END IF 1578 ELSE 1579* 1580* Form C := alpha*conjg( A' )*B + conjg( alpha )*conjg( B' )*A + 1581* C. 1582* 1583 IF( UPPER ) THEN 1584 DO 210 J = 1, N 1585 DO 200 I = 1, J 1586 TEMP1 = ZERO 1587 TEMP2 = ZERO 1588 DO 190 L = 1, K 1589 TEMP1 = TEMP1 + DCONJG( A( L, I ) )*B( L, J ) 1590 TEMP2 = TEMP2 + DCONJG( B( L, I ) )*A( L, J ) 1591 190 CONTINUE 1592 IF( I.EQ.J ) THEN 1593 IF( BETA.EQ.DBLE( ZERO ) ) THEN 1594 C( J, J ) = DBLE( ALPHA*TEMP1+DCONJG( ALPHA )* 1595 $ TEMP2 ) 1596 ELSE 1597 C( J, J ) = BETA*DBLE( C( J, J ) ) + 1598 $ DBLE( ALPHA*TEMP1+DCONJG( ALPHA )* 1599 $ TEMP2 ) 1600 END IF 1601 ELSE 1602 IF( BETA.EQ.DBLE( ZERO ) ) THEN 1603 C( I, J ) = ALPHA*TEMP1 + DCONJG( ALPHA )*TEMP2 1604 ELSE 1605 C( I, J ) = BETA*C( I, J ) + ALPHA*TEMP1 + 1606 $ DCONJG( ALPHA )*TEMP2 1607 END IF 1608 END IF 1609 200 CONTINUE 1610 210 CONTINUE 1611 ELSE 1612 DO 240 J = 1, N 1613 DO 230 I = J, N 1614 TEMP1 = ZERO 1615 TEMP2 = ZERO 1616 DO 220 L = 1, K 1617 TEMP1 = TEMP1 + DCONJG( A( L, I ) )*B( L, J ) 1618 TEMP2 = TEMP2 + DCONJG( B( L, I ) )*A( L, J ) 1619 220 CONTINUE 1620 IF( I.EQ.J ) THEN 1621 IF( BETA.EQ.DBLE( ZERO ) ) THEN 1622 C( J, J ) = DBLE( ALPHA*TEMP1+DCONJG( ALPHA )* 1623 $ TEMP2 ) 1624 ELSE 1625 C( J, J ) = BETA*DBLE( C( J, J ) ) + 1626 $ DBLE( ALPHA*TEMP1+DCONJG( ALPHA )* 1627 $ TEMP2 ) 1628 END IF 1629 ELSE 1630 IF( BETA.EQ.DBLE( ZERO ) ) THEN 1631 C( I, J ) = ALPHA*TEMP1 + DCONJG( ALPHA )*TEMP2 1632 ELSE 1633 C( I, J ) = BETA*C( I, J ) + ALPHA*TEMP1 + 1634 $ DCONJG( ALPHA )*TEMP2 1635 END IF 1636 END IF 1637 230 CONTINUE 1638 240 CONTINUE 1639 END IF 1640 END IF 1641* 1642 RETURN 1643* 1644* End of ZHER2K. 1645* 1646 END 1647 subroutine zscal(n,za,zx,incx) 1648c 1649c scales a vector by a constant. 1650c jack dongarra, 3/11/78. 1651c modified 3/93 to return if incx .le. 0. 1652c modified 12/3/93, array(1) declarations changed to array(*) 1653c 1654 double complex za,zx(*) 1655 integer i,incx,ix,n 1656c 1657 if( n.le.0 .or. incx.le.0 )return 1658 if(incx.eq.1)go to 20 1659c 1660c code for increment not equal to 1 1661c 1662 ix = 1 1663 do 10 i = 1,n 1664 zx(ix) = za*zx(ix) 1665 ix = ix + incx 1666 10 continue 1667 return 1668c 1669c code for increment equal to 1 1670c 1671 20 do 30 i = 1,n 1672 zx(i) = za*zx(i) 1673 30 continue 1674 return 1675 end 1676 subroutine zswap (n,zx,incx,zy,incy) 1677c 1678c interchanges two vectors. 1679c jack dongarra, 3/11/78. 1680c modified 12/3/93, array(1) declarations changed to array(*) 1681c 1682 double complex zx(*),zy(*),ztemp 1683 integer i,incx,incy,ix,iy,n 1684c 1685 if(n.le.0)return 1686 if(incx.eq.1.and.incy.eq.1)go to 20 1687c 1688c code for unequal increments or equal increments not equal 1689c to 1 1690c 1691 ix = 1 1692 iy = 1 1693 if(incx.lt.0)ix = (-n+1)*incx + 1 1694 if(incy.lt.0)iy = (-n+1)*incy + 1 1695 do 10 i = 1,n 1696 ztemp = zx(ix) 1697 zx(ix) = zy(iy) 1698 zy(iy) = ztemp 1699 ix = ix + incx 1700 iy = iy + incy 1701 10 continue 1702 return 1703c 1704c code for both increments equal to 1 1705 20 do 30 i = 1,n 1706 ztemp = zx(i) 1707 zx(i) = zy(i) 1708 zy(i) = ztemp 1709 30 continue 1710 return 1711 end 1712 SUBROUTINE ZTRMM ( SIDE, UPLO, TRANSA, DIAG, M, N, ALPHA, A, LDA, 1713 $ B, LDB ) 1714* .. Scalar Arguments .. 1715 CHARACTER SIDE, UPLO, TRANSA, DIAG 1716 INTEGER M, N, LDA, LDB 1717 DOUBLE COMPLEX ALPHA 1718* .. Array Arguments .. 1719 DOUBLE COMPLEX A( LDA, * ), B( LDB, * ) 1720* .. 1721* 1722* Purpose 1723* ======= 1724* 1725* ZTRMM performs one of the matrix-matrix operations 1726* 1727* B := alpha*op( A )*B, or B := alpha*B*op( A ) 1728* 1729* where alpha is a scalar, B is an m by n matrix, A is a unit, or 1730* non-unit, upper or lower triangular matrix and op( A ) is one of 1731* 1732* op( A ) = A or op( A ) = A' or op( A ) = conjg( A' ). 1733* 1734* Parameters 1735* ========== 1736* 1737* SIDE - CHARACTER*1. 1738* On entry, SIDE specifies whether op( A ) multiplies B from 1739* the left or right as follows: 1740* 1741* SIDE = 'L' or 'l' B := alpha*op( A )*B. 1742* 1743* SIDE = 'R' or 'r' B := alpha*B*op( A ). 1744* 1745* Unchanged on exit. 1746* 1747* UPLO - CHARACTER*1. 1748* On entry, UPLO specifies whether the matrix A is an upper or 1749* lower triangular matrix as follows: 1750* 1751* UPLO = 'U' or 'u' A is an upper triangular matrix. 1752* 1753* UPLO = 'L' or 'l' A is a lower triangular matrix. 1754* 1755* Unchanged on exit. 1756* 1757* TRANSA - CHARACTER*1. 1758* On entry, TRANSA specifies the form of op( A ) to be used in 1759* the matrix multiplication as follows: 1760* 1761* TRANSA = 'N' or 'n' op( A ) = A. 1762* 1763* TRANSA = 'T' or 't' op( A ) = A'. 1764* 1765* TRANSA = 'C' or 'c' op( A ) = conjg( A' ). 1766* 1767* Unchanged on exit. 1768* 1769* DIAG - CHARACTER*1. 1770* On entry, DIAG specifies whether or not A is unit triangular 1771* as follows: 1772* 1773* DIAG = 'U' or 'u' A is assumed to be unit triangular. 1774* 1775* DIAG = 'N' or 'n' A is not assumed to be unit 1776* triangular. 1777* 1778* Unchanged on exit. 1779* 1780* M - INTEGER. 1781* On entry, M specifies the number of rows of B. M must be at 1782* least zero. 1783* Unchanged on exit. 1784* 1785* N - INTEGER. 1786* On entry, N specifies the number of columns of B. N must be 1787* at least zero. 1788* Unchanged on exit. 1789* 1790* ALPHA - DOUBLE COMPLEX . 1791* On entry, ALPHA specifies the scalar alpha. When alpha is 1792* zero then A is not referenced and B need not be set before 1793* entry. 1794* Unchanged on exit. 1795* 1796* A - DOUBLE COMPLEX array of DIMENSION ( LDA, k ), where k is m 1797* when SIDE = 'L' or 'l' and is n when SIDE = 'R' or 'r'. 1798* Before entry with UPLO = 'U' or 'u', the leading k by k 1799* upper triangular part of the array A must contain the upper 1800* triangular matrix and the strictly lower triangular part of 1801* A is not referenced. 1802* Before entry with UPLO = 'L' or 'l', the leading k by k 1803* lower triangular part of the array A must contain the lower 1804* triangular matrix and the strictly upper triangular part of 1805* A is not referenced. 1806* Note that when DIAG = 'U' or 'u', the diagonal elements of 1807* A are not referenced either, but are assumed to be unity. 1808* Unchanged on exit. 1809* 1810* LDA - INTEGER. 1811* On entry, LDA specifies the first dimension of A as declared 1812* in the calling (sub) program. When SIDE = 'L' or 'l' then 1813* LDA must be at least max( 1, m ), when SIDE = 'R' or 'r' 1814* then LDA must be at least max( 1, n ). 1815* Unchanged on exit. 1816* 1817* B - DOUBLE COMPLEX array of DIMENSION ( LDB, n ). 1818* Before entry, the leading m by n part of the array B must 1819* contain the matrix B, and on exit is overwritten by the 1820* transformed matrix. 1821* 1822* LDB - INTEGER. 1823* On entry, LDB specifies the first dimension of B as declared 1824* in the calling (sub) program. LDB must be at least 1825* max( 1, m ). 1826* Unchanged on exit. 1827* 1828* 1829* Level 3 Blas routine. 1830* 1831* -- Written on 8-February-1989. 1832* Jack Dongarra, Argonne National Laboratory. 1833* Iain Duff, AERE Harwell. 1834* Jeremy Du Croz, Numerical Algorithms Group Ltd. 1835* Sven Hammarling, Numerical Algorithms Group Ltd. 1836* 1837* 1838* .. External Functions .. 1839 LOGICAL LSAME 1840 EXTERNAL LSAME 1841* .. External Subroutines .. 1842 EXTERNAL XERBLA 1843* .. Intrinsic Functions .. 1844 INTRINSIC DCONJG, MAX 1845* .. Local Scalars .. 1846 LOGICAL LSIDE, NOCONJ, NOUNIT, UPPER 1847 INTEGER I, INFO, J, K, NROWA 1848 DOUBLE COMPLEX TEMP 1849* .. Parameters .. 1850 DOUBLE COMPLEX ONE 1851 PARAMETER ( ONE = ( 1.0D+0, 0.0D+0 ) ) 1852 DOUBLE COMPLEX ZERO 1853 PARAMETER ( ZERO = ( 0.0D+0, 0.0D+0 ) ) 1854* .. 1855* .. Executable Statements .. 1856* 1857* Test the input parameters. 1858* 1859 LSIDE = LSAME( SIDE , 'L' ) 1860 IF( LSIDE )THEN 1861 NROWA = M 1862 ELSE 1863 NROWA = N 1864 END IF 1865 NOCONJ = LSAME( TRANSA, 'T' ) 1866 NOUNIT = LSAME( DIAG , 'N' ) 1867 UPPER = LSAME( UPLO , 'U' ) 1868* 1869 INFO = 0 1870 IF( ( .NOT.LSIDE ).AND. 1871 $ ( .NOT.LSAME( SIDE , 'R' ) ) )THEN 1872 INFO = 1 1873 ELSE IF( ( .NOT.UPPER ).AND. 1874 $ ( .NOT.LSAME( UPLO , 'L' ) ) )THEN 1875 INFO = 2 1876 ELSE IF( ( .NOT.LSAME( TRANSA, 'N' ) ).AND. 1877 $ ( .NOT.LSAME( TRANSA, 'T' ) ).AND. 1878 $ ( .NOT.LSAME( TRANSA, 'C' ) ) )THEN 1879 INFO = 3 1880 ELSE IF( ( .NOT.LSAME( DIAG , 'U' ) ).AND. 1881 $ ( .NOT.LSAME( DIAG , 'N' ) ) )THEN 1882 INFO = 4 1883 ELSE IF( M .LT.0 )THEN 1884 INFO = 5 1885 ELSE IF( N .LT.0 )THEN 1886 INFO = 6 1887 ELSE IF( LDA.LT.MAX( 1, NROWA ) )THEN 1888 INFO = 9 1889 ELSE IF( LDB.LT.MAX( 1, M ) )THEN 1890 INFO = 11 1891 END IF 1892 IF( INFO.NE.0 )THEN 1893 CALL XERBLA( 'ZTRMM ', INFO ) 1894 RETURN 1895 END IF 1896* 1897* Quick return if possible. 1898* 1899 IF( N.EQ.0 ) 1900 $ RETURN 1901* 1902* And when alpha.eq.zero. 1903* 1904 IF( ALPHA.EQ.ZERO )THEN 1905 DO 20, J = 1, N 1906 DO 10, I = 1, M 1907 B( I, J ) = ZERO 1908 10 CONTINUE 1909 20 CONTINUE 1910 RETURN 1911 END IF 1912* 1913* Start the operations. 1914* 1915 IF( LSIDE )THEN 1916 IF( LSAME( TRANSA, 'N' ) )THEN 1917* 1918* Form B := alpha*A*B. 1919* 1920 IF( UPPER )THEN 1921 DO 50, J = 1, N 1922 DO 40, K = 1, M 1923c IF( B( K, J ).NE.ZERO )THEN 1924 TEMP = ALPHA*B( K, J ) 1925 DO 30, I = 1, K - 1 1926 B( I, J ) = B( I, J ) + TEMP*A( I, K ) 1927 30 CONTINUE 1928 IF( NOUNIT ) 1929 $ TEMP = TEMP*A( K, K ) 1930 B( K, J ) = TEMP 1931c END IF 1932 40 CONTINUE 1933 50 CONTINUE 1934 ELSE 1935 DO 80, J = 1, N 1936 DO 70 K = M, 1, -1 1937c IF( B( K, J ).NE.ZERO )THEN 1938 TEMP = ALPHA*B( K, J ) 1939 B( K, J ) = TEMP 1940 IF( NOUNIT ) 1941 $ B( K, J ) = B( K, J )*A( K, K ) 1942 DO 60, I = K + 1, M 1943 B( I, J ) = B( I, J ) + TEMP*A( I, K ) 1944 60 CONTINUE 1945c END IF 1946 70 CONTINUE 1947 80 CONTINUE 1948 END IF 1949 ELSE 1950* 1951* Form B := alpha*A'*B or B := alpha*conjg( A' )*B. 1952* 1953 IF( UPPER )THEN 1954 DO 120, J = 1, N 1955 DO 110, I = M, 1, -1 1956 TEMP = B( I, J ) 1957 IF( NOCONJ )THEN 1958 IF( NOUNIT ) 1959 $ TEMP = TEMP*A( I, I ) 1960 DO 90, K = 1, I - 1 1961 TEMP = TEMP + A( K, I )*B( K, J ) 1962 90 CONTINUE 1963 ELSE 1964 IF( NOUNIT ) 1965 $ TEMP = TEMP*DCONJG( A( I, I ) ) 1966 DO 100, K = 1, I - 1 1967 TEMP = TEMP + DCONJG( A( K, I ) )*B( K, J ) 1968 100 CONTINUE 1969 END IF 1970 B( I, J ) = ALPHA*TEMP 1971 110 CONTINUE 1972 120 CONTINUE 1973 ELSE 1974 DO 160, J = 1, N 1975 DO 150, I = 1, M 1976 TEMP = B( I, J ) 1977 IF( NOCONJ )THEN 1978 IF( NOUNIT ) 1979 $ TEMP = TEMP*A( I, I ) 1980 DO 130, K = I + 1, M 1981 TEMP = TEMP + A( K, I )*B( K, J ) 1982 130 CONTINUE 1983 ELSE 1984 IF( NOUNIT ) 1985 $ TEMP = TEMP*DCONJG( A( I, I ) ) 1986 DO 140, K = I + 1, M 1987 TEMP = TEMP + DCONJG( A( K, I ) )*B( K, J ) 1988 140 CONTINUE 1989 END IF 1990 B( I, J ) = ALPHA*TEMP 1991 150 CONTINUE 1992 160 CONTINUE 1993 END IF 1994 END IF 1995 ELSE 1996 IF( LSAME( TRANSA, 'N' ) )THEN 1997* 1998* Form B := alpha*B*A. 1999* 2000 IF( UPPER )THEN 2001 DO 200, J = N, 1, -1 2002 TEMP = ALPHA 2003 IF( NOUNIT ) 2004 $ TEMP = TEMP*A( J, J ) 2005 DO 170, I = 1, M 2006 B( I, J ) = TEMP*B( I, J ) 2007 170 CONTINUE 2008 DO 190, K = 1, J - 1 2009c IF( A( K, J ).NE.ZERO )THEN 2010 TEMP = ALPHA*A( K, J ) 2011 DO 180, I = 1, M 2012 B( I, J ) = B( I, J ) + TEMP*B( I, K ) 2013 180 CONTINUE 2014c END IF 2015 190 CONTINUE 2016 200 CONTINUE 2017 ELSE 2018 DO 240, J = 1, N 2019 TEMP = ALPHA 2020 IF( NOUNIT ) 2021 $ TEMP = TEMP*A( J, J ) 2022 DO 210, I = 1, M 2023 B( I, J ) = TEMP*B( I, J ) 2024 210 CONTINUE 2025 DO 230, K = J + 1, N 2026c IF( A( K, J ).NE.ZERO )THEN 2027 TEMP = ALPHA*A( K, J ) 2028 DO 220, I = 1, M 2029 B( I, J ) = B( I, J ) + TEMP*B( I, K ) 2030 220 CONTINUE 2031c END IF 2032 230 CONTINUE 2033 240 CONTINUE 2034 END IF 2035 ELSE 2036* 2037* Form B := alpha*B*A' or B := alpha*B*conjg( A' ). 2038* 2039 IF( UPPER )THEN 2040 DO 280, K = 1, N 2041 DO 260, J = 1, K - 1 2042 IF( A( J, K ).NE.ZERO )THEN 2043 IF( NOCONJ )THEN 2044 TEMP = ALPHA*A( J, K ) 2045 ELSE 2046 TEMP = ALPHA*DCONJG( A( J, K ) ) 2047 END IF 2048 DO 250, I = 1, M 2049 B( I, J ) = B( I, J ) + TEMP*B( I, K ) 2050 250 CONTINUE 2051 END IF 2052 260 CONTINUE 2053 TEMP = ALPHA 2054 IF( NOUNIT )THEN 2055 IF( NOCONJ )THEN 2056 TEMP = TEMP*A( K, K ) 2057 ELSE 2058 TEMP = TEMP*DCONJG( A( K, K ) ) 2059 END IF 2060 END IF 2061 IF( TEMP.NE.ONE )THEN 2062 DO 270, I = 1, M 2063 B( I, K ) = TEMP*B( I, K ) 2064 270 CONTINUE 2065 END IF 2066 280 CONTINUE 2067 ELSE 2068 DO 320, K = N, 1, -1 2069 DO 300, J = K + 1, N 2070c IF( A( J, K ).NE.ZERO )THEN 2071 IF( NOCONJ )THEN 2072 TEMP = ALPHA*A( J, K ) 2073 ELSE 2074 TEMP = ALPHA*DCONJG( A( J, K ) ) 2075 END IF 2076 DO 290, I = 1, M 2077 B( I, J ) = B( I, J ) + TEMP*B( I, K ) 2078 290 CONTINUE 2079c END IF 2080 300 CONTINUE 2081 TEMP = ALPHA 2082 IF( NOUNIT )THEN 2083 IF( NOCONJ )THEN 2084 TEMP = TEMP*A( K, K ) 2085 ELSE 2086 TEMP = TEMP*DCONJG( A( K, K ) ) 2087 END IF 2088 END IF 2089 IF( TEMP.NE.ONE )THEN 2090 DO 310, I = 1, M 2091 B( I, K ) = TEMP*B( I, K ) 2092 310 CONTINUE 2093 END IF 2094 320 CONTINUE 2095 END IF 2096 END IF 2097 END IF 2098* 2099 RETURN 2100* 2101* End of ZTRMM . 2102* 2103 END 2104 SUBROUTINE ZTRMV ( UPLO, TRANS, DIAG, N, A, LDA, X, INCX ) 2105* .. Scalar Arguments .. 2106 INTEGER INCX, LDA, N 2107 CHARACTER DIAG, TRANS, UPLO 2108* .. Array Arguments .. 2109 DOUBLE COMPLEX A( LDA, * ), X( * ) 2110* .. 2111* 2112* Purpose 2113* ======= 2114* 2115* ZTRMV performs one of the matrix-vector operations 2116* 2117* x := A*x, or x := A'*x, or x := conjg( A' )*x, 2118* 2119* where x is an n element vector and A is an n by n unit, or non-unit, 2120* upper or lower triangular matrix. 2121* 2122* Parameters 2123* ========== 2124* 2125* UPLO - CHARACTER*1. 2126* On entry, UPLO specifies whether the matrix is an upper or 2127* lower triangular matrix as follows: 2128* 2129* UPLO = 'U' or 'u' A is an upper triangular matrix. 2130* 2131* UPLO = 'L' or 'l' A is a lower triangular matrix. 2132* 2133* Unchanged on exit. 2134* 2135* TRANS - CHARACTER*1. 2136* On entry, TRANS specifies the operation to be performed as 2137* follows: 2138* 2139* TRANS = 'N' or 'n' x := A*x. 2140* 2141* TRANS = 'T' or 't' x := A'*x. 2142* 2143* TRANS = 'C' or 'c' x := conjg( A' )*x. 2144* 2145* Unchanged on exit. 2146* 2147* DIAG - CHARACTER*1. 2148* On entry, DIAG specifies whether or not A is unit 2149* triangular as follows: 2150* 2151* DIAG = 'U' or 'u' A is assumed to be unit triangular. 2152* 2153* DIAG = 'N' or 'n' A is not assumed to be unit 2154* triangular. 2155* 2156* Unchanged on exit. 2157* 2158* N - INTEGER. 2159* On entry, N specifies the order of the matrix A. 2160* N must be at least zero. 2161* Unchanged on exit. 2162* 2163* A - DOUBLE COMPLEX array of DIMENSION ( LDA, n ). 2164* Before entry with UPLO = 'U' or 'u', the leading n by n 2165* upper triangular part of the array A must contain the upper 2166* triangular matrix and the strictly lower triangular part of 2167* A is not referenced. 2168* Before entry with UPLO = 'L' or 'l', the leading n by n 2169* lower triangular part of the array A must contain the lower 2170* triangular matrix and the strictly upper triangular part of 2171* A is not referenced. 2172* Note that when DIAG = 'U' or 'u', the diagonal elements of 2173* A are not referenced either, but are assumed to be unity. 2174* Unchanged on exit. 2175* 2176* LDA - INTEGER. 2177* On entry, LDA specifies the first dimension of A as declared 2178* in the calling (sub) program. LDA must be at least 2179* max( 1, n ). 2180* Unchanged on exit. 2181* 2182* X - DOUBLE COMPLEX array of dimension at least 2183* ( 1 + ( n - 1 )*abs( INCX ) ). 2184* Before entry, the incremented array X must contain the n 2185* element vector x. On exit, X is overwritten with the 2186* tranformed vector x. 2187* 2188* INCX - INTEGER. 2189* On entry, INCX specifies the increment for the elements of 2190* X. INCX must not be zero. 2191* Unchanged on exit. 2192* 2193* 2194* Level 2 Blas routine. 2195* 2196* -- Written on 22-October-1986. 2197* Jack Dongarra, Argonne National Lab. 2198* Jeremy Du Croz, Nag Central Office. 2199* Sven Hammarling, Nag Central Office. 2200* Richard Hanson, Sandia National Labs. 2201* 2202* 2203* .. Parameters .. 2204 DOUBLE COMPLEX ZERO 2205 PARAMETER ( ZERO = ( 0.0D+0, 0.0D+0 ) ) 2206* .. Local Scalars .. 2207 DOUBLE COMPLEX TEMP 2208 INTEGER I, INFO, IX, J, JX, KX 2209 LOGICAL NOCONJ, NOUNIT 2210* .. External Functions .. 2211 LOGICAL LSAME 2212 EXTERNAL LSAME 2213* .. External Subroutines .. 2214 EXTERNAL XERBLA 2215* .. Intrinsic Functions .. 2216 INTRINSIC DCONJG, MAX 2217* .. 2218* .. Executable Statements .. 2219* 2220* Test the input parameters. 2221* 2222 INFO = 0 2223 IF ( .NOT.LSAME( UPLO , 'U' ).AND. 2224 $ .NOT.LSAME( UPLO , 'L' ) )THEN 2225 INFO = 1 2226 ELSE IF( .NOT.LSAME( TRANS, 'N' ).AND. 2227 $ .NOT.LSAME( TRANS, 'T' ).AND. 2228 $ .NOT.LSAME( TRANS, 'C' ) )THEN 2229 INFO = 2 2230 ELSE IF( .NOT.LSAME( DIAG , 'U' ).AND. 2231 $ .NOT.LSAME( DIAG , 'N' ) )THEN 2232 INFO = 3 2233 ELSE IF( N.LT.0 )THEN 2234 INFO = 4 2235 ELSE IF( LDA.LT.MAX( 1, N ) )THEN 2236 INFO = 6 2237 ELSE IF( INCX.EQ.0 )THEN 2238 INFO = 8 2239 END IF 2240 IF( INFO.NE.0 )THEN 2241 CALL XERBLA( 'ZTRMV ', INFO ) 2242 RETURN 2243 END IF 2244* 2245* Quick return if possible. 2246* 2247 IF( N.EQ.0 ) 2248 $ RETURN 2249* 2250 NOCONJ = LSAME( TRANS, 'T' ) 2251 NOUNIT = LSAME( DIAG , 'N' ) 2252* 2253* Set up the start point in X if the increment is not unity. This 2254* will be ( N - 1 )*INCX too small for descending loops. 2255* 2256 IF( INCX.LE.0 )THEN 2257 KX = 1 - ( N - 1 )*INCX 2258 ELSE IF( INCX.NE.1 )THEN 2259 KX = 1 2260 END IF 2261* 2262* Start the operations. In this version the elements of A are 2263* accessed sequentially with one pass through A. 2264* 2265 IF( LSAME( TRANS, 'N' ) )THEN 2266* 2267* Form x := A*x. 2268* 2269 IF( LSAME( UPLO, 'U' ) )THEN 2270 IF( INCX.EQ.1 )THEN 2271 DO 20, J = 1, N 2272c IF( X( J ).NE.ZERO )THEN 2273 TEMP = X( J ) 2274 DO 10, I = 1, J - 1 2275 X( I ) = X( I ) + TEMP*A( I, J ) 2276 10 CONTINUE 2277 IF( NOUNIT ) 2278 $ X( J ) = X( J )*A( J, J ) 2279c END IF 2280 20 CONTINUE 2281 ELSE 2282 JX = KX 2283 DO 40, J = 1, N 2284c IF( X( JX ).NE.ZERO )THEN 2285 TEMP = X( JX ) 2286 IX = KX 2287 DO 30, I = 1, J - 1 2288 X( IX ) = X( IX ) + TEMP*A( I, J ) 2289 IX = IX + INCX 2290 30 CONTINUE 2291 IF( NOUNIT ) 2292 $ X( JX ) = X( JX )*A( J, J ) 2293c END IF 2294 JX = JX + INCX 2295 40 CONTINUE 2296 END IF 2297 ELSE 2298 IF( INCX.EQ.1 )THEN 2299 DO 60, J = N, 1, -1 2300c IF( X( J ).NE.ZERO )THEN 2301 TEMP = X( J ) 2302 DO 50, I = N, J + 1, -1 2303 X( I ) = X( I ) + TEMP*A( I, J ) 2304 50 CONTINUE 2305 IF( NOUNIT ) 2306 $ X( J ) = X( J )*A( J, J ) 2307c END IF 2308 60 CONTINUE 2309 ELSE 2310 KX = KX + ( N - 1 )*INCX 2311 JX = KX 2312 DO 80, J = N, 1, -1 2313c IF( X( JX ).NE.ZERO )THEN 2314 TEMP = X( JX ) 2315 IX = KX 2316 DO 70, I = N, J + 1, -1 2317 X( IX ) = X( IX ) + TEMP*A( I, J ) 2318 IX = IX - INCX 2319 70 CONTINUE 2320 IF( NOUNIT ) 2321 $ X( JX ) = X( JX )*A( J, J ) 2322c END IF 2323 JX = JX - INCX 2324 80 CONTINUE 2325 END IF 2326 END IF 2327 ELSE 2328* 2329* Form x := A'*x or x := conjg( A' )*x. 2330* 2331 IF( LSAME( UPLO, 'U' ) )THEN 2332 IF( INCX.EQ.1 )THEN 2333 DO 110, J = N, 1, -1 2334 TEMP = X( J ) 2335 IF( NOCONJ )THEN 2336 IF( NOUNIT ) 2337 $ TEMP = TEMP*A( J, J ) 2338 DO 90, I = J - 1, 1, -1 2339 TEMP = TEMP + A( I, J )*X( I ) 2340 90 CONTINUE 2341 ELSE 2342 IF( NOUNIT ) 2343 $ TEMP = TEMP*DCONJG( A( J, J ) ) 2344 DO 100, I = J - 1, 1, -1 2345 TEMP = TEMP + DCONJG( A( I, J ) )*X( I ) 2346 100 CONTINUE 2347 END IF 2348 X( J ) = TEMP 2349 110 CONTINUE 2350 ELSE 2351 JX = KX + ( N - 1 )*INCX 2352 DO 140, J = N, 1, -1 2353 TEMP = X( JX ) 2354 IX = JX 2355 IF( NOCONJ )THEN 2356 IF( NOUNIT ) 2357 $ TEMP = TEMP*A( J, J ) 2358 DO 120, I = J - 1, 1, -1 2359 IX = IX - INCX 2360 TEMP = TEMP + A( I, J )*X( IX ) 2361 120 CONTINUE 2362 ELSE 2363 IF( NOUNIT ) 2364 $ TEMP = TEMP*DCONJG( A( J, J ) ) 2365 DO 130, I = J - 1, 1, -1 2366 IX = IX - INCX 2367 TEMP = TEMP + DCONJG( A( I, J ) )*X( IX ) 2368 130 CONTINUE 2369 END IF 2370 X( JX ) = TEMP 2371 JX = JX - INCX 2372 140 CONTINUE 2373 END IF 2374 ELSE 2375 IF( INCX.EQ.1 )THEN 2376 DO 170, J = 1, N 2377 TEMP = X( J ) 2378 IF( NOCONJ )THEN 2379 IF( NOUNIT ) 2380 $ TEMP = TEMP*A( J, J ) 2381 DO 150, I = J + 1, N 2382 TEMP = TEMP + A( I, J )*X( I ) 2383 150 CONTINUE 2384 ELSE 2385 IF( NOUNIT ) 2386 $ TEMP = TEMP*DCONJG( A( J, J ) ) 2387 DO 160, I = J + 1, N 2388 TEMP = TEMP + DCONJG( A( I, J ) )*X( I ) 2389 160 CONTINUE 2390 END IF 2391 X( J ) = TEMP 2392 170 CONTINUE 2393 ELSE 2394 JX = KX 2395 DO 200, J = 1, N 2396 TEMP = X( JX ) 2397 IX = JX 2398 IF( NOCONJ )THEN 2399 IF( NOUNIT ) 2400 $ TEMP = TEMP*A( J, J ) 2401 DO 180, I = J + 1, N 2402 IX = IX + INCX 2403 TEMP = TEMP + A( I, J )*X( IX ) 2404 180 CONTINUE 2405 ELSE 2406 IF( NOUNIT ) 2407 $ TEMP = TEMP*DCONJG( A( J, J ) ) 2408 DO 190, I = J + 1, N 2409 IX = IX + INCX 2410 TEMP = TEMP + DCONJG( A( I, J ) )*X( IX ) 2411 190 CONTINUE 2412 END IF 2413 X( JX ) = TEMP 2414 JX = JX + INCX 2415 200 CONTINUE 2416 END IF 2417 END IF 2418 END IF 2419* 2420 RETURN 2421* 2422* End of ZTRMV . 2423* 2424 END 2425 SUBROUTINE ZTRSM ( SIDE, UPLO, TRANSA, DIAG, M, N, ALPHA, A, LDA, 2426 $ B, LDB ) 2427* .. Scalar Arguments .. 2428 CHARACTER SIDE, UPLO, TRANSA, DIAG 2429 INTEGER M, N, LDA, LDB 2430 DOUBLE COMPLEX ALPHA 2431* .. Array Arguments .. 2432 DOUBLE COMPLEX A( LDA, * ), B( LDB, * ) 2433* .. 2434* 2435* Purpose 2436* ======= 2437* 2438* ZTRSM solves one of the matrix equations 2439* 2440* op( A )*X = alpha*B, or X*op( A ) = alpha*B, 2441* 2442* where alpha is a scalar, X and B are m by n matrices, A is a unit, or 2443* non-unit, upper or lower triangular matrix and op( A ) is one of 2444* 2445* op( A ) = A or op( A ) = A' or op( A ) = conjg( A' ). 2446* 2447* The matrix X is overwritten on B. 2448* 2449* Parameters 2450* ========== 2451* 2452* SIDE - CHARACTER*1. 2453* On entry, SIDE specifies whether op( A ) appears on the left 2454* or right of X as follows: 2455* 2456* SIDE = 'L' or 'l' op( A )*X = alpha*B. 2457* 2458* SIDE = 'R' or 'r' X*op( A ) = alpha*B. 2459* 2460* Unchanged on exit. 2461* 2462* UPLO - CHARACTER*1. 2463* On entry, UPLO specifies whether the matrix A is an upper or 2464* lower triangular matrix as follows: 2465* 2466* UPLO = 'U' or 'u' A is an upper triangular matrix. 2467* 2468* UPLO = 'L' or 'l' A is a lower triangular matrix. 2469* 2470* Unchanged on exit. 2471* 2472* TRANSA - CHARACTER*1. 2473* On entry, TRANSA specifies the form of op( A ) to be used in 2474* the matrix multiplication as follows: 2475* 2476* TRANSA = 'N' or 'n' op( A ) = A. 2477* 2478* TRANSA = 'T' or 't' op( A ) = A'. 2479* 2480* TRANSA = 'C' or 'c' op( A ) = conjg( A' ). 2481* 2482* Unchanged on exit. 2483* 2484* DIAG - CHARACTER*1. 2485* On entry, DIAG specifies whether or not A is unit triangular 2486* as follows: 2487* 2488* DIAG = 'U' or 'u' A is assumed to be unit triangular. 2489* 2490* DIAG = 'N' or 'n' A is not assumed to be unit 2491* triangular. 2492* 2493* Unchanged on exit. 2494* 2495* M - INTEGER. 2496* On entry, M specifies the number of rows of B. M must be at 2497* least zero. 2498* Unchanged on exit. 2499* 2500* N - INTEGER. 2501* On entry, N specifies the number of columns of B. N must be 2502* at least zero. 2503* Unchanged on exit. 2504* 2505* ALPHA - DOUBLE COMPLEX . 2506* On entry, ALPHA specifies the scalar alpha. When alpha is 2507* zero then A is not referenced and B need not be set before 2508* entry. 2509* Unchanged on exit. 2510* 2511* A - DOUBLE COMPLEX array of DIMENSION ( LDA, k ), where k is m 2512* when SIDE = 'L' or 'l' and is n when SIDE = 'R' or 'r'. 2513* Before entry with UPLO = 'U' or 'u', the leading k by k 2514* upper triangular part of the array A must contain the upper 2515* triangular matrix and the strictly lower triangular part of 2516* A is not referenced. 2517* Before entry with UPLO = 'L' or 'l', the leading k by k 2518* lower triangular part of the array A must contain the lower 2519* triangular matrix and the strictly upper triangular part of 2520* A is not referenced. 2521* Note that when DIAG = 'U' or 'u', the diagonal elements of 2522* A are not referenced either, but are assumed to be unity. 2523* Unchanged on exit. 2524* 2525* LDA - INTEGER. 2526* On entry, LDA specifies the first dimension of A as declared 2527* in the calling (sub) program. When SIDE = 'L' or 'l' then 2528* LDA must be at least max( 1, m ), when SIDE = 'R' or 'r' 2529* then LDA must be at least max( 1, n ). 2530* Unchanged on exit. 2531* 2532* B - DOUBLE COMPLEX array of DIMENSION ( LDB, n ). 2533* Before entry, the leading m by n part of the array B must 2534* contain the right-hand side matrix B, and on exit is 2535* overwritten by the solution matrix X. 2536* 2537* LDB - INTEGER. 2538* On entry, LDB specifies the first dimension of B as declared 2539* in the calling (sub) program. LDB must be at least 2540* max( 1, m ). 2541* Unchanged on exit. 2542* 2543* 2544* Level 3 Blas routine. 2545* 2546* -- Written on 8-February-1989. 2547* Jack Dongarra, Argonne National Laboratory. 2548* Iain Duff, AERE Harwell. 2549* Jeremy Du Croz, Numerical Algorithms Group Ltd. 2550* Sven Hammarling, Numerical Algorithms Group Ltd. 2551* 2552* 2553* .. External Functions .. 2554 LOGICAL LSAME 2555 EXTERNAL LSAME 2556* .. External Subroutines .. 2557 EXTERNAL XERBLA 2558* .. Intrinsic Functions .. 2559 INTRINSIC DCONJG, MAX 2560* .. Local Scalars .. 2561 LOGICAL LSIDE, NOCONJ, NOUNIT, UPPER 2562 INTEGER I, INFO, J, K, NROWA 2563 DOUBLE COMPLEX TEMP 2564* .. Parameters .. 2565 DOUBLE COMPLEX ONE 2566 PARAMETER ( ONE = ( 1.0D+0, 0.0D+0 ) ) 2567 DOUBLE COMPLEX ZERO 2568 PARAMETER ( ZERO = ( 0.0D+0, 0.0D+0 ) ) 2569* .. 2570* .. Executable Statements .. 2571* 2572* Test the input parameters. 2573* 2574 LSIDE = LSAME( SIDE , 'L' ) 2575 IF( LSIDE )THEN 2576 NROWA = M 2577 ELSE 2578 NROWA = N 2579 END IF 2580 NOCONJ = LSAME( TRANSA, 'T' ) 2581 NOUNIT = LSAME( DIAG , 'N' ) 2582 UPPER = LSAME( UPLO , 'U' ) 2583* 2584 INFO = 0 2585 IF( ( .NOT.LSIDE ).AND. 2586 $ ( .NOT.LSAME( SIDE , 'R' ) ) )THEN 2587 INFO = 1 2588 ELSE IF( ( .NOT.UPPER ).AND. 2589 $ ( .NOT.LSAME( UPLO , 'L' ) ) )THEN 2590 INFO = 2 2591 ELSE IF( ( .NOT.LSAME( TRANSA, 'N' ) ).AND. 2592 $ ( .NOT.LSAME( TRANSA, 'T' ) ).AND. 2593 $ ( .NOT.LSAME( TRANSA, 'C' ) ) )THEN 2594 INFO = 3 2595 ELSE IF( ( .NOT.LSAME( DIAG , 'U' ) ).AND. 2596 $ ( .NOT.LSAME( DIAG , 'N' ) ) )THEN 2597 INFO = 4 2598 ELSE IF( M .LT.0 )THEN 2599 INFO = 5 2600 ELSE IF( N .LT.0 )THEN 2601 INFO = 6 2602 ELSE IF( LDA.LT.MAX( 1, NROWA ) )THEN 2603 INFO = 9 2604 ELSE IF( LDB.LT.MAX( 1, M ) )THEN 2605 INFO = 11 2606 END IF 2607 IF( INFO.NE.0 )THEN 2608 CALL XERBLA( 'ZTRSM ', INFO ) 2609 RETURN 2610 END IF 2611* 2612* Quick return if possible. 2613* 2614 IF( N.EQ.0 ) 2615 $ RETURN 2616* 2617* And when alpha.eq.zero. 2618* 2619 IF( ALPHA.EQ.ZERO )THEN 2620 DO 20, J = 1, N 2621 DO 10, I = 1, M 2622 B( I, J ) = ZERO 2623 10 CONTINUE 2624 20 CONTINUE 2625 RETURN 2626 END IF 2627* 2628* Start the operations. 2629* 2630 IF( LSIDE )THEN 2631 IF( LSAME( TRANSA, 'N' ) )THEN 2632* 2633* Form B := alpha*inv( A )*B. 2634* 2635 IF( UPPER )THEN 2636 DO 60, J = 1, N 2637 IF( ALPHA.NE.ONE )THEN 2638 DO 30, I = 1, M 2639 B( I, J ) = ALPHA*B( I, J ) 2640 30 CONTINUE 2641 END IF 2642 DO 50, K = M, 1, -1 2643c IF( B( K, J ).NE.ZERO )THEN 2644 IF( NOUNIT ) 2645 $ B( K, J ) = B( K, J )/A( K, K ) 2646 DO 40, I = 1, K - 1 2647 B( I, J ) = B( I, J ) - B( K, J )*A( I, K ) 2648 40 CONTINUE 2649c END IF 2650 50 CONTINUE 2651 60 CONTINUE 2652 ELSE 2653 DO 100, J = 1, N 2654 IF( ALPHA.NE.ONE )THEN 2655 DO 70, I = 1, M 2656 B( I, J ) = ALPHA*B( I, J ) 2657 70 CONTINUE 2658 END IF 2659 DO 90 K = 1, M 2660c IF( B( K, J ).NE.ZERO )THEN 2661 IF( NOUNIT ) 2662 $ B( K, J ) = B( K, J )/A( K, K ) 2663 DO 80, I = K + 1, M 2664 B( I, J ) = B( I, J ) - B( K, J )*A( I, K ) 2665 80 CONTINUE 2666c END IF 2667 90 CONTINUE 2668 100 CONTINUE 2669 END IF 2670 ELSE 2671* 2672* Form B := alpha*inv( A' )*B 2673* or B := alpha*inv( conjg( A' ) )*B. 2674* 2675 IF( UPPER )THEN 2676 DO 140, J = 1, N 2677 DO 130, I = 1, M 2678 TEMP = ALPHA*B( I, J ) 2679 IF( NOCONJ )THEN 2680 DO 110, K = 1, I - 1 2681 TEMP = TEMP - A( K, I )*B( K, J ) 2682 110 CONTINUE 2683 IF( NOUNIT ) 2684 $ TEMP = TEMP/A( I, I ) 2685 ELSE 2686 DO 120, K = 1, I - 1 2687 TEMP = TEMP - DCONJG( A( K, I ) )*B( K, J ) 2688 120 CONTINUE 2689 IF( NOUNIT ) 2690 $ TEMP = TEMP/DCONJG( A( I, I ) ) 2691 END IF 2692 B( I, J ) = TEMP 2693 130 CONTINUE 2694 140 CONTINUE 2695 ELSE 2696 DO 180, J = 1, N 2697 DO 170, I = M, 1, -1 2698 TEMP = ALPHA*B( I, J ) 2699 IF( NOCONJ )THEN 2700 DO 150, K = I + 1, M 2701 TEMP = TEMP - A( K, I )*B( K, J ) 2702 150 CONTINUE 2703 IF( NOUNIT ) 2704 $ TEMP = TEMP/A( I, I ) 2705 ELSE 2706 DO 160, K = I + 1, M 2707 TEMP = TEMP - DCONJG( A( K, I ) )*B( K, J ) 2708 160 CONTINUE 2709 IF( NOUNIT ) 2710 $ TEMP = TEMP/DCONJG( A( I, I ) ) 2711 END IF 2712 B( I, J ) = TEMP 2713 170 CONTINUE 2714 180 CONTINUE 2715 END IF 2716 END IF 2717 ELSE 2718 IF( LSAME( TRANSA, 'N' ) )THEN 2719* 2720* Form B := alpha*B*inv( A ). 2721* 2722 IF( UPPER )THEN 2723 DO 230, J = 1, N 2724 IF( ALPHA.NE.ONE )THEN 2725 DO 190, I = 1, M 2726 B( I, J ) = ALPHA*B( I, J ) 2727 190 CONTINUE 2728 END IF 2729 DO 210, K = 1, J - 1 2730c IF( A( K, J ).NE.ZERO )THEN 2731 DO 200, I = 1, M 2732 B( I, J ) = B( I, J ) - A( K, J )*B( I, K ) 2733 200 CONTINUE 2734c END IF 2735 210 CONTINUE 2736 IF( NOUNIT )THEN 2737 TEMP = ONE/A( J, J ) 2738 DO 220, I = 1, M 2739 B( I, J ) = TEMP*B( I, J ) 2740 220 CONTINUE 2741 END IF 2742 230 CONTINUE 2743 ELSE 2744 DO 280, J = N, 1, -1 2745 IF( ALPHA.NE.ONE )THEN 2746 DO 240, I = 1, M 2747 B( I, J ) = ALPHA*B( I, J ) 2748 240 CONTINUE 2749 END IF 2750 DO 260, K = J + 1, N 2751c IF( A( K, J ).NE.ZERO )THEN 2752 DO 250, I = 1, M 2753 B( I, J ) = B( I, J ) - A( K, J )*B( I, K ) 2754 250 CONTINUE 2755c END IF 2756 260 CONTINUE 2757 IF( NOUNIT )THEN 2758 TEMP = ONE/A( J, J ) 2759 DO 270, I = 1, M 2760 B( I, J ) = TEMP*B( I, J ) 2761 270 CONTINUE 2762 END IF 2763 280 CONTINUE 2764 END IF 2765 ELSE 2766* 2767* Form B := alpha*B*inv( A' ) 2768* or B := alpha*B*inv( conjg( A' ) ). 2769* 2770 IF( UPPER )THEN 2771 DO 330, K = N, 1, -1 2772 IF( NOUNIT )THEN 2773 IF( NOCONJ )THEN 2774 TEMP = ONE/A( K, K ) 2775 ELSE 2776 TEMP = ONE/DCONJG( A( K, K ) ) 2777 END IF 2778 DO 290, I = 1, M 2779 B( I, K ) = TEMP*B( I, K ) 2780 290 CONTINUE 2781 END IF 2782 DO 310, J = 1, K - 1 2783c IF( A( J, K ).NE.ZERO )THEN 2784 IF( NOCONJ )THEN 2785 TEMP = A( J, K ) 2786 ELSE 2787 TEMP = DCONJG( A( J, K ) ) 2788c END IF 2789 DO 300, I = 1, M 2790 B( I, J ) = B( I, J ) - TEMP*B( I, K ) 2791 300 CONTINUE 2792 END IF 2793 310 CONTINUE 2794 IF( ALPHA.NE.ONE )THEN 2795 DO 320, I = 1, M 2796 B( I, K ) = ALPHA*B( I, K ) 2797 320 CONTINUE 2798 END IF 2799 330 CONTINUE 2800 ELSE 2801 DO 380, K = 1, N 2802 IF( NOUNIT )THEN 2803 IF( NOCONJ )THEN 2804 TEMP = ONE/A( K, K ) 2805 ELSE 2806 TEMP = ONE/DCONJG( A( K, K ) ) 2807 END IF 2808 DO 340, I = 1, M 2809 B( I, K ) = TEMP*B( I, K ) 2810 340 CONTINUE 2811 END IF 2812 DO 360, J = K + 1, N 2813c IF( A( J, K ).NE.ZERO )THEN 2814 IF( NOCONJ )THEN 2815 TEMP = A( J, K ) 2816 ELSE 2817 TEMP = DCONJG( A( J, K ) ) 2818 END IF 2819 DO 350, I = 1, M 2820 B( I, J ) = B( I, J ) - TEMP*B( I, K ) 2821 350 CONTINUE 2822c END IF 2823 360 CONTINUE 2824 IF( ALPHA.NE.ONE )THEN 2825 DO 370, I = 1, M 2826 B( I, K ) = ALPHA*B( I, K ) 2827 370 CONTINUE 2828 END IF 2829 380 CONTINUE 2830 END IF 2831 END IF 2832 END IF 2833* 2834 RETURN 2835* 2836* End of ZTRSM . 2837* 2838 END 2839 SUBROUTINE ZTRSV ( UPLO, TRANS, DIAG, N, A, LDA, X, INCX ) 2840* .. Scalar Arguments .. 2841 INTEGER INCX, LDA, N 2842 CHARACTER DIAG, TRANS, UPLO 2843* .. Array Arguments .. 2844 DOUBLE COMPLEX A( LDA, * ), X( * ) 2845* .. 2846* 2847* Purpose 2848* ======= 2849* 2850* ZTRSV solves one of the systems of equations 2851* 2852* A*x = b, or A'*x = b, or conjg( A' )*x = b, 2853* 2854* where b and x are n element vectors and A is an n by n unit, or 2855* non-unit, upper or lower triangular matrix. 2856* 2857* No test for singularity or near-singularity is included in this 2858* routine. Such tests must be performed before calling this routine. 2859* 2860* Parameters 2861* ========== 2862* 2863* UPLO - CHARACTER*1. 2864* On entry, UPLO specifies whether the matrix is an upper or 2865* lower triangular matrix as follows: 2866* 2867* UPLO = 'U' or 'u' A is an upper triangular matrix. 2868* 2869* UPLO = 'L' or 'l' A is a lower triangular matrix. 2870* 2871* Unchanged on exit. 2872* 2873* TRANS - CHARACTER*1. 2874* On entry, TRANS specifies the equations to be solved as 2875* follows: 2876* 2877* TRANS = 'N' or 'n' A*x = b. 2878* 2879* TRANS = 'T' or 't' A'*x = b. 2880* 2881* TRANS = 'C' or 'c' conjg( A' )*x = b. 2882* 2883* Unchanged on exit. 2884* 2885* DIAG - CHARACTER*1. 2886* On entry, DIAG specifies whether or not A is unit 2887* triangular as follows: 2888* 2889* DIAG = 'U' or 'u' A is assumed to be unit triangular. 2890* 2891* DIAG = 'N' or 'n' A is not assumed to be unit 2892* triangular. 2893* 2894* Unchanged on exit. 2895* 2896* N - INTEGER. 2897* On entry, N specifies the order of the matrix A. 2898* N must be at least zero. 2899* Unchanged on exit. 2900* 2901* A - DOUBLE COMPLEX array of DIMENSION ( LDA, n ). 2902* Before entry with UPLO = 'U' or 'u', the leading n by n 2903* upper triangular part of the array A must contain the upper 2904* triangular matrix and the strictly lower triangular part of 2905* A is not referenced. 2906* Before entry with UPLO = 'L' or 'l', the leading n by n 2907* lower triangular part of the array A must contain the lower 2908* triangular matrix and the strictly upper triangular part of 2909* A is not referenced. 2910* Note that when DIAG = 'U' or 'u', the diagonal elements of 2911* A are not referenced either, but are assumed to be unity. 2912* Unchanged on exit. 2913* 2914* LDA - INTEGER. 2915* On entry, LDA specifies the first dimension of A as declared 2916* in the calling (sub) program. LDA must be at least 2917* max( 1, n ). 2918* Unchanged on exit. 2919* 2920* X - DOUBLE COMPLEX array of dimension at least 2921* ( 1 + ( n - 1 )*abs( INCX ) ). 2922* Before entry, the incremented array X must contain the n 2923* element right-hand side vector b. On exit, X is overwritten 2924* with the solution vector x. 2925* 2926* INCX - INTEGER. 2927* On entry, INCX specifies the increment for the elements of 2928* X. INCX must not be zero. 2929* Unchanged on exit. 2930* 2931* 2932* Level 2 Blas routine. 2933* 2934* -- Written on 22-October-1986. 2935* Jack Dongarra, Argonne National Lab. 2936* Jeremy Du Croz, Nag Central Office. 2937* Sven Hammarling, Nag Central Office. 2938* Richard Hanson, Sandia National Labs. 2939* 2940* 2941* .. Parameters .. 2942 DOUBLE COMPLEX ZERO 2943 PARAMETER ( ZERO = ( 0.0D+0, 0.0D+0 ) ) 2944* .. Local Scalars .. 2945 DOUBLE COMPLEX TEMP 2946 INTEGER I, INFO, IX, J, JX, KX 2947 LOGICAL NOCONJ, NOUNIT 2948* .. External Functions .. 2949 LOGICAL LSAME 2950 EXTERNAL LSAME 2951* .. External Subroutines .. 2952 EXTERNAL XERBLA 2953* .. Intrinsic Functions .. 2954 INTRINSIC DCONJG, MAX 2955* .. 2956* .. Executable Statements .. 2957* 2958* Test the input parameters. 2959* 2960 INFO = 0 2961 IF ( .NOT.LSAME( UPLO , 'U' ).AND. 2962 $ .NOT.LSAME( UPLO , 'L' ) )THEN 2963 INFO = 1 2964 ELSE IF( .NOT.LSAME( TRANS, 'N' ).AND. 2965 $ .NOT.LSAME( TRANS, 'T' ).AND. 2966 $ .NOT.LSAME( TRANS, 'C' ) )THEN 2967 INFO = 2 2968 ELSE IF( .NOT.LSAME( DIAG , 'U' ).AND. 2969 $ .NOT.LSAME( DIAG , 'N' ) )THEN 2970 INFO = 3 2971 ELSE IF( N.LT.0 )THEN 2972 INFO = 4 2973 ELSE IF( LDA.LT.MAX( 1, N ) )THEN 2974 INFO = 6 2975 ELSE IF( INCX.EQ.0 )THEN 2976 INFO = 8 2977 END IF 2978 IF( INFO.NE.0 )THEN 2979 CALL XERBLA( 'ZTRSV ', INFO ) 2980 RETURN 2981 END IF 2982* 2983* Quick return if possible. 2984* 2985 IF( N.EQ.0 ) 2986 $ RETURN 2987* 2988 NOCONJ = LSAME( TRANS, 'T' ) 2989 NOUNIT = LSAME( DIAG , 'N' ) 2990* 2991* Set up the start point in X if the increment is not unity. This 2992* will be ( N - 1 )*INCX too small for descending loops. 2993* 2994 IF( INCX.LE.0 )THEN 2995 KX = 1 - ( N - 1 )*INCX 2996 ELSE IF( INCX.NE.1 )THEN 2997 KX = 1 2998 END IF 2999* 3000* Start the operations. In this version the elements of A are 3001* accessed sequentially with one pass through A. 3002* 3003 IF( LSAME( TRANS, 'N' ) )THEN 3004* 3005* Form x := inv( A )*x. 3006* 3007 IF( LSAME( UPLO, 'U' ) )THEN 3008 IF( INCX.EQ.1 )THEN 3009 DO 20, J = N, 1, -1 3010c IF( X( J ).NE.ZERO )THEN 3011 IF( NOUNIT ) 3012 $ X( J ) = X( J )/A( J, J ) 3013 TEMP = X( J ) 3014 DO 10, I = J - 1, 1, -1 3015 X( I ) = X( I ) - TEMP*A( I, J ) 3016 10 CONTINUE 3017c END IF 3018 20 CONTINUE 3019 ELSE 3020 JX = KX + ( N - 1 )*INCX 3021 DO 40, J = N, 1, -1 3022c IF( X( JX ).NE.ZERO )THEN 3023 IF( NOUNIT ) 3024 $ X( JX ) = X( JX )/A( J, J ) 3025 TEMP = X( JX ) 3026 IX = JX 3027 DO 30, I = J - 1, 1, -1 3028 IX = IX - INCX 3029 X( IX ) = X( IX ) - TEMP*A( I, J ) 3030 30 CONTINUE 3031c END IF 3032 JX = JX - INCX 3033 40 CONTINUE 3034 END IF 3035 ELSE 3036 IF( INCX.EQ.1 )THEN 3037 DO 60, J = 1, N 3038c IF( X( J ).NE.ZERO )THEN 3039 IF( NOUNIT ) 3040 $ X( J ) = X( J )/A( J, J ) 3041 TEMP = X( J ) 3042 DO 50, I = J + 1, N 3043 X( I ) = X( I ) - TEMP*A( I, J ) 3044 50 CONTINUE 3045c END IF 3046 60 CONTINUE 3047 ELSE 3048 JX = KX 3049 DO 80, J = 1, N 3050c IF( X( JX ).NE.ZERO )THEN 3051 IF( NOUNIT ) 3052 $ X( JX ) = X( JX )/A( J, J ) 3053 TEMP = X( JX ) 3054 IX = JX 3055 DO 70, I = J + 1, N 3056 IX = IX + INCX 3057 X( IX ) = X( IX ) - TEMP*A( I, J ) 3058 70 CONTINUE 3059c END IF 3060 JX = JX + INCX 3061 80 CONTINUE 3062 END IF 3063 END IF 3064 ELSE 3065* 3066* Form x := inv( A' )*x or x := inv( conjg( A' ) )*x. 3067* 3068 IF( LSAME( UPLO, 'U' ) )THEN 3069 IF( INCX.EQ.1 )THEN 3070 DO 110, J = 1, N 3071 TEMP = X( J ) 3072 IF( NOCONJ )THEN 3073 DO 90, I = 1, J - 1 3074 TEMP = TEMP - A( I, J )*X( I ) 3075 90 CONTINUE 3076 IF( NOUNIT ) 3077 $ TEMP = TEMP/A( J, J ) 3078 ELSE 3079 DO 100, I = 1, J - 1 3080 TEMP = TEMP - DCONJG( A( I, J ) )*X( I ) 3081 100 CONTINUE 3082 IF( NOUNIT ) 3083 $ TEMP = TEMP/DCONJG( A( J, J ) ) 3084 END IF 3085 X( J ) = TEMP 3086 110 CONTINUE 3087 ELSE 3088 JX = KX 3089 DO 140, J = 1, N 3090 IX = KX 3091 TEMP = X( JX ) 3092 IF( NOCONJ )THEN 3093 DO 120, I = 1, J - 1 3094 TEMP = TEMP - A( I, J )*X( IX ) 3095 IX = IX + INCX 3096 120 CONTINUE 3097 IF( NOUNIT ) 3098 $ TEMP = TEMP/A( J, J ) 3099 ELSE 3100 DO 130, I = 1, J - 1 3101 TEMP = TEMP - DCONJG( A( I, J ) )*X( IX ) 3102 IX = IX + INCX 3103 130 CONTINUE 3104 IF( NOUNIT ) 3105 $ TEMP = TEMP/DCONJG( A( J, J ) ) 3106 END IF 3107 X( JX ) = TEMP 3108 JX = JX + INCX 3109 140 CONTINUE 3110 END IF 3111 ELSE 3112 IF( INCX.EQ.1 )THEN 3113 DO 170, J = N, 1, -1 3114 TEMP = X( J ) 3115 IF( NOCONJ )THEN 3116 DO 150, I = N, J + 1, -1 3117 TEMP = TEMP - A( I, J )*X( I ) 3118 150 CONTINUE 3119 IF( NOUNIT ) 3120 $ TEMP = TEMP/A( J, J ) 3121 ELSE 3122 DO 160, I = N, J + 1, -1 3123 TEMP = TEMP - DCONJG( A( I, J ) )*X( I ) 3124 160 CONTINUE 3125 IF( NOUNIT ) 3126 $ TEMP = TEMP/DCONJG( A( J, J ) ) 3127 END IF 3128 X( J ) = TEMP 3129 170 CONTINUE 3130 ELSE 3131 KX = KX + ( N - 1 )*INCX 3132 JX = KX 3133 DO 200, J = N, 1, -1 3134 IX = KX 3135 TEMP = X( JX ) 3136 IF( NOCONJ )THEN 3137 DO 180, I = N, J + 1, -1 3138 TEMP = TEMP - A( I, J )*X( IX ) 3139 IX = IX - INCX 3140 180 CONTINUE 3141 IF( NOUNIT ) 3142 $ TEMP = TEMP/A( J, J ) 3143 ELSE 3144 DO 190, I = N, J + 1, -1 3145 TEMP = TEMP - DCONJG( A( I, J ) )*X( IX ) 3146 IX = IX - INCX 3147 190 CONTINUE 3148 IF( NOUNIT ) 3149 $ TEMP = TEMP/DCONJG( A( J, J ) ) 3150 END IF 3151 X( JX ) = TEMP 3152 JX = JX - INCX 3153 200 CONTINUE 3154 END IF 3155 END IF 3156 END IF 3157* 3158 RETURN 3159* 3160* End of ZTRSV . 3161* 3162 END 3163 subroutine zdrot (n,zx,incx,zy,incy,c,s) 3164c 3165c applies a plane rotation, where the cos and sin (c and s) are 3166c double precision and the vectors zx and zy are double complex. 3167c jack dongarra, linpack, 3/11/78. 3168c 3169 double complex zx(*),zy(*),ztemp 3170 double precision c,s 3171 integer i,incx,incy,ix,iy,n 3172c 3173 if(n.le.0)return 3174 if(incx.eq.1.and.incy.eq.1)go to 20 3175c 3176c code for unequal increments or equal increments not equal 3177c to 1 3178c 3179 ix = 1 3180 iy = 1 3181 if(incx.lt.0)ix = (-n+1)*incx + 1 3182 if(incy.lt.0)iy = (-n+1)*incy + 1 3183 do 10 i = 1,n 3184 ztemp = c*zx(ix) + s*zy(iy) 3185 zy(iy) = c*zy(iy) - s*zx(ix) 3186 zx(ix) = ztemp 3187 ix = ix + incx 3188 iy = iy + incy 3189 10 continue 3190 return 3191c 3192c code for both increments equal to 1 3193c 3194 20 do 30 i = 1,n 3195 ztemp = c*zx(i) + s*zy(i) 3196 zy(i) = c*zy(i) - s*zx(i) 3197 zx(i) = ztemp 3198 30 continue 3199 return 3200 end 3201 SUBROUTINE ZGBMV ( TRANS, M, N, KL, KU, ALPHA, A, LDA, X, INCX, 3202 $ BETA, Y, INCY ) 3203* .. Scalar Arguments .. 3204 DOUBLE COMPLEX ALPHA, BETA 3205 INTEGER INCX, INCY, KL, KU, LDA, M, N 3206 CHARACTER TRANS 3207* .. Array Arguments .. 3208 DOUBLE COMPLEX A( LDA, * ), X( * ), Y( * ) 3209* .. 3210* 3211* Purpose 3212* ======= 3213* 3214* ZGBMV performs one of the matrix-vector operations 3215* 3216* y := alpha*A*x + beta*y, or y := alpha*A'*x + beta*y, or 3217* 3218* y := alpha*conjg( A' )*x + beta*y, 3219* 3220* where alpha and beta are scalars, x and y are vectors and A is an 3221* m by n band matrix, with kl sub-diagonals and ku super-diagonals. 3222* 3223* Parameters 3224* ========== 3225* 3226* TRANS - CHARACTER*1. 3227* On entry, TRANS specifies the operation to be performed as 3228* follows: 3229* 3230* TRANS = 'N' or 'n' y := alpha*A*x + beta*y. 3231* 3232* TRANS = 'T' or 't' y := alpha*A'*x + beta*y. 3233* 3234* TRANS = 'C' or 'c' y := alpha*conjg( A' )*x + beta*y. 3235* 3236* Unchanged on exit. 3237* 3238* M - INTEGER. 3239* On entry, M specifies the number of rows of the matrix A. 3240* M must be at least zero. 3241* Unchanged on exit. 3242* 3243* N - INTEGER. 3244* On entry, N specifies the number of columns of the matrix A. 3245* N must be at least zero. 3246* Unchanged on exit. 3247* 3248* KL - INTEGER. 3249* On entry, KL specifies the number of sub-diagonals of the 3250* matrix A. KL must satisfy 0 .le. KL. 3251* Unchanged on exit. 3252* 3253* KU - INTEGER. 3254* On entry, KU specifies the number of super-diagonals of the 3255* matrix A. KU must satisfy 0 .le. KU. 3256* Unchanged on exit. 3257* 3258* ALPHA - DOUBLE COMPLEX . 3259* On entry, ALPHA specifies the scalar alpha. 3260* Unchanged on exit. 3261* 3262* A - DOUBLE COMPLEX array of DIMENSION ( LDA, n ). 3263* Before entry, the leading ( kl + ku + 1 ) by n part of the 3264* array A must contain the matrix of coefficients, supplied 3265* column by column, with the leading diagonal of the matrix in 3266* row ( ku + 1 ) of the array, the first super-diagonal 3267* starting at position 2 in row ku, the first sub-diagonal 3268* starting at position 1 in row ( ku + 2 ), and so on. 3269* Elements in the array A that do not correspond to elements 3270* in the band matrix (such as the top left ku by ku triangle) 3271* are not referenced. 3272* The following program segment will transfer a band matrix 3273* from conventional full matrix storage to band storage: 3274* 3275* DO 20, J = 1, N 3276* K = KU + 1 - J 3277* DO 10, I = MAX( 1, J - KU ), MIN( M, J + KL ) 3278* A( K + I, J ) = matrix( I, J ) 3279* 10 CONTINUE 3280* 20 CONTINUE 3281* 3282* Unchanged on exit. 3283* 3284* LDA - INTEGER. 3285* On entry, LDA specifies the first dimension of A as declared 3286* in the calling (sub) program. LDA must be at least 3287* ( kl + ku + 1 ). 3288* Unchanged on exit. 3289* 3290* X - DOUBLE COMPLEX array of DIMENSION at least 3291* ( 1 + ( n - 1 )*abs( INCX ) ) when TRANS = 'N' or 'n' 3292* and at least 3293* ( 1 + ( m - 1 )*abs( INCX ) ) otherwise. 3294* Before entry, the incremented array X must contain the 3295* vector x. 3296* Unchanged on exit. 3297* 3298* INCX - INTEGER. 3299* On entry, INCX specifies the increment for the elements of 3300* X. INCX must not be zero. 3301* Unchanged on exit. 3302* 3303* BETA - DOUBLE COMPLEX . 3304* On entry, BETA specifies the scalar beta. When BETA is 3305* supplied as zero then Y need not be set on input. 3306* Unchanged on exit. 3307* 3308* Y - DOUBLE COMPLEX array of DIMENSION at least 3309* ( 1 + ( m - 1 )*abs( INCY ) ) when TRANS = 'N' or 'n' 3310* and at least 3311* ( 1 + ( n - 1 )*abs( INCY ) ) otherwise. 3312* Before entry, the incremented array Y must contain the 3313* vector y. On exit, Y is overwritten by the updated vector y. 3314* 3315* 3316* INCY - INTEGER. 3317* On entry, INCY specifies the increment for the elements of 3318* Y. INCY must not be zero. 3319* Unchanged on exit. 3320* 3321* 3322* Level 2 Blas routine. 3323* 3324* -- Written on 22-October-1986. 3325* Jack Dongarra, Argonne National Lab. 3326* Jeremy Du Croz, Nag Central Office. 3327* Sven Hammarling, Nag Central Office. 3328* Richard Hanson, Sandia National Labs. 3329* 3330* 3331* .. Parameters .. 3332 DOUBLE COMPLEX ONE 3333 PARAMETER ( ONE = ( 1.0D+0, 0.0D+0 ) ) 3334 DOUBLE COMPLEX ZERO 3335 PARAMETER ( ZERO = ( 0.0D+0, 0.0D+0 ) ) 3336* .. Local Scalars .. 3337 DOUBLE COMPLEX TEMP 3338 INTEGER I, INFO, IX, IY, J, JX, JY, K, KUP1, KX, KY, 3339 $ LENX, LENY 3340 LOGICAL NOCONJ 3341* .. External Functions .. 3342 LOGICAL LSAME 3343 EXTERNAL LSAME 3344* .. External Subroutines .. 3345 EXTERNAL XERBLA 3346* .. Intrinsic Functions .. 3347 INTRINSIC DCONJG, MAX, MIN 3348* .. 3349* .. Executable Statements .. 3350* 3351* Test the input parameters. 3352* 3353 INFO = 0 3354 IF ( .NOT.LSAME( TRANS, 'N' ).AND. 3355 $ .NOT.LSAME( TRANS, 'T' ).AND. 3356 $ .NOT.LSAME( TRANS, 'C' ) )THEN 3357 INFO = 1 3358 ELSE IF( M.LT.0 )THEN 3359 INFO = 2 3360 ELSE IF( N.LT.0 )THEN 3361 INFO = 3 3362 ELSE IF( KL.LT.0 )THEN 3363 INFO = 4 3364 ELSE IF( KU.LT.0 )THEN 3365 INFO = 5 3366 ELSE IF( LDA.LT.( KL + KU + 1 ) )THEN 3367 INFO = 8 3368 ELSE IF( INCX.EQ.0 )THEN 3369 INFO = 10 3370 ELSE IF( INCY.EQ.0 )THEN 3371 INFO = 13 3372 END IF 3373 IF( INFO.NE.0 )THEN 3374 CALL XERBLA( 'ZGBMV ', INFO ) 3375 RETURN 3376 END IF 3377* 3378* Quick return if possible. 3379* 3380 IF( ( M.EQ.0 ).OR.( N.EQ.0 ).OR. 3381 $ ( ( ALPHA.EQ.ZERO ).AND.( BETA.EQ.ONE ) ) ) 3382 $ RETURN 3383* 3384 NOCONJ = LSAME( TRANS, 'T' ) 3385* 3386* Set LENX and LENY, the lengths of the vectors x and y, and set 3387* up the start points in X and Y. 3388* 3389 IF( LSAME( TRANS, 'N' ) )THEN 3390 LENX = N 3391 LENY = M 3392 ELSE 3393 LENX = M 3394 LENY = N 3395 END IF 3396 IF( INCX.GT.0 )THEN 3397 KX = 1 3398 ELSE 3399 KX = 1 - ( LENX - 1 )*INCX 3400 END IF 3401 IF( INCY.GT.0 )THEN 3402 KY = 1 3403 ELSE 3404 KY = 1 - ( LENY - 1 )*INCY 3405 END IF 3406* 3407* Start the operations. In this version the elements of A are 3408* accessed sequentially with one pass through the band part of A. 3409* 3410* First form y := beta*y. 3411* 3412 IF( BETA.NE.ONE )THEN 3413 IF( INCY.EQ.1 )THEN 3414 IF( BETA.EQ.ZERO )THEN 3415 DO 10, I = 1, LENY 3416 Y( I ) = ZERO 3417 10 CONTINUE 3418 ELSE 3419 DO 20, I = 1, LENY 3420 Y( I ) = BETA*Y( I ) 3421 20 CONTINUE 3422 END IF 3423 ELSE 3424 IY = KY 3425 IF( BETA.EQ.ZERO )THEN 3426 DO 30, I = 1, LENY 3427 Y( IY ) = ZERO 3428 IY = IY + INCY 3429 30 CONTINUE 3430 ELSE 3431 DO 40, I = 1, LENY 3432 Y( IY ) = BETA*Y( IY ) 3433 IY = IY + INCY 3434 40 CONTINUE 3435 END IF 3436 END IF 3437 END IF 3438 IF( ALPHA.EQ.ZERO ) 3439 $ RETURN 3440 KUP1 = KU + 1 3441 IF( LSAME( TRANS, 'N' ) )THEN 3442* 3443* Form y := alpha*A*x + y. 3444* 3445 JX = KX 3446 IF( INCY.EQ.1 )THEN 3447 DO 60, J = 1, N 3448c IF( X( JX ).NE.ZERO )THEN 3449 TEMP = ALPHA*X( JX ) 3450 K = KUP1 - J 3451 DO 50, I = MAX( 1, J - KU ), MIN( M, J + KL ) 3452 Y( I ) = Y( I ) + TEMP*A( K + I, J ) 3453 50 CONTINUE 3454c END IF 3455 JX = JX + INCX 3456 60 CONTINUE 3457 ELSE 3458 DO 80, J = 1, N 3459c IF( X( JX ).NE.ZERO )THEN 3460 TEMP = ALPHA*X( JX ) 3461 IY = KY 3462 K = KUP1 - J 3463 DO 70, I = MAX( 1, J - KU ), MIN( M, J + KL ) 3464 Y( IY ) = Y( IY ) + TEMP*A( K + I, J ) 3465 IY = IY + INCY 3466 70 CONTINUE 3467c END IF 3468 JX = JX + INCX 3469 IF( J.GT.KU ) 3470 $ KY = KY + INCY 3471 80 CONTINUE 3472 END IF 3473 ELSE 3474* 3475* Form y := alpha*A'*x + y or y := alpha*conjg( A' )*x + y. 3476* 3477 JY = KY 3478 IF( INCX.EQ.1 )THEN 3479 DO 110, J = 1, N 3480 TEMP = ZERO 3481 K = KUP1 - J 3482 IF( NOCONJ )THEN 3483 DO 90, I = MAX( 1, J - KU ), MIN( M, J + KL ) 3484 TEMP = TEMP + A( K + I, J )*X( I ) 3485 90 CONTINUE 3486 ELSE 3487 DO 100, I = MAX( 1, J - KU ), MIN( M, J + KL ) 3488 TEMP = TEMP + DCONJG( A( K + I, J ) )*X( I ) 3489 100 CONTINUE 3490 END IF 3491 Y( JY ) = Y( JY ) + ALPHA*TEMP 3492 JY = JY + INCY 3493 110 CONTINUE 3494 ELSE 3495 DO 140, J = 1, N 3496 TEMP = ZERO 3497 IX = KX 3498 K = KUP1 - J 3499 IF( NOCONJ )THEN 3500 DO 120, I = MAX( 1, J - KU ), MIN( M, J + KL ) 3501 TEMP = TEMP + A( K + I, J )*X( IX ) 3502 IX = IX + INCX 3503 120 CONTINUE 3504 ELSE 3505 DO 130, I = MAX( 1, J - KU ), MIN( M, J + KL ) 3506 TEMP = TEMP + DCONJG( A( K + I, J ) )*X( IX ) 3507 IX = IX + INCX 3508 130 CONTINUE 3509 END IF 3510 Y( JY ) = Y( JY ) + ALPHA*TEMP 3511 JY = JY + INCY 3512 IF( J.GT.KU ) 3513 $ KX = KX + INCX 3514 140 CONTINUE 3515 END IF 3516 END IF 3517* 3518 RETURN 3519* 3520* End of ZGBMV . 3521* 3522 END 3523 SUBROUTINE ZGERU ( M, N, ALPHA, X, INCX, Y, INCY, A, LDA ) 3524* .. Scalar Arguments .. 3525 DOUBLE COMPLEX ALPHA 3526 INTEGER INCX, INCY, LDA, M, N 3527* .. Array Arguments .. 3528 DOUBLE COMPLEX A( LDA, * ), X( * ), Y( * ) 3529* .. 3530* 3531* Purpose 3532* ======= 3533* 3534* ZGERU performs the rank 1 operation 3535* 3536* A := alpha*x*y' + A, 3537* 3538* where alpha is a scalar, x is an m element vector, y is an n element 3539* vector and A is an m by n matrix. 3540* 3541* Parameters 3542* ========== 3543* 3544* M - INTEGER. 3545* On entry, M specifies the number of rows of the matrix A. 3546* M must be at least zero. 3547* Unchanged on exit. 3548* 3549* N - INTEGER. 3550* On entry, N specifies the number of columns of the matrix A. 3551* N must be at least zero. 3552* Unchanged on exit. 3553* 3554* ALPHA - DOUBLE COMPLEX . 3555* On entry, ALPHA specifies the scalar alpha. 3556* Unchanged on exit. 3557* 3558* X - DOUBLE COMPLEX array of dimension at least 3559* ( 1 + ( m - 1 )*abs( INCX ) ). 3560* Before entry, the incremented array X must contain the m 3561* element vector x. 3562* Unchanged on exit. 3563* 3564* INCX - INTEGER. 3565* On entry, INCX specifies the increment for the elements of 3566* X. INCX must not be zero. 3567* Unchanged on exit. 3568* 3569* Y - DOUBLE COMPLEX array of dimension at least 3570* ( 1 + ( n - 1 )*abs( INCY ) ). 3571* Before entry, the incremented array Y must contain the n 3572* element vector y. 3573* Unchanged on exit. 3574* 3575* INCY - INTEGER. 3576* On entry, INCY specifies the increment for the elements of 3577* Y. INCY must not be zero. 3578* Unchanged on exit. 3579* 3580* A - DOUBLE COMPLEX array of DIMENSION ( LDA, n ). 3581* Before entry, the leading m by n part of the array A must 3582* contain the matrix of coefficients. On exit, A is 3583* overwritten by the updated matrix. 3584* 3585* LDA - INTEGER. 3586* On entry, LDA specifies the first dimension of A as declared 3587* in the calling (sub) program. LDA must be at least 3588* max( 1, m ). 3589* Unchanged on exit. 3590* 3591* 3592* Level 2 Blas routine. 3593* 3594* -- Written on 22-October-1986. 3595* Jack Dongarra, Argonne National Lab. 3596* Jeremy Du Croz, Nag Central Office. 3597* Sven Hammarling, Nag Central Office. 3598* Richard Hanson, Sandia National Labs. 3599* 3600* 3601* .. Parameters .. 3602 DOUBLE COMPLEX ZERO 3603 PARAMETER ( ZERO = ( 0.0D+0, 0.0D+0 ) ) 3604* .. Local Scalars .. 3605 DOUBLE COMPLEX TEMP 3606 INTEGER I, INFO, IX, J, JY, KX 3607* .. External Subroutines .. 3608 EXTERNAL XERBLA 3609* .. Intrinsic Functions .. 3610 INTRINSIC MAX 3611* .. 3612* .. Executable Statements .. 3613* 3614* Test the input parameters. 3615* 3616 INFO = 0 3617 IF ( M.LT.0 )THEN 3618 INFO = 1 3619 ELSE IF( N.LT.0 )THEN 3620 INFO = 2 3621 ELSE IF( INCX.EQ.0 )THEN 3622 INFO = 5 3623 ELSE IF( INCY.EQ.0 )THEN 3624 INFO = 7 3625 ELSE IF( LDA.LT.MAX( 1, M ) )THEN 3626 INFO = 9 3627 END IF 3628 IF( INFO.NE.0 )THEN 3629 CALL XERBLA( 'ZGERU ', INFO ) 3630 RETURN 3631 END IF 3632* 3633* Quick return if possible. 3634* 3635 IF( ( M.EQ.0 ).OR.( N.EQ.0 ).OR.( ALPHA.EQ.ZERO ) ) 3636 $ RETURN 3637* 3638* Start the operations. In this version the elements of A are 3639* accessed sequentially with one pass through A. 3640* 3641 IF( INCY.GT.0 )THEN 3642 JY = 1 3643 ELSE 3644 JY = 1 - ( N - 1 )*INCY 3645 END IF 3646 IF( INCX.EQ.1 )THEN 3647 DO 20, J = 1, N 3648c IF( Y( JY ).NE.ZERO )THEN 3649 TEMP = ALPHA*Y( JY ) 3650 DO 10, I = 1, M 3651 A( I, J ) = A( I, J ) + X( I )*TEMP 3652 10 CONTINUE 3653c END IF 3654 JY = JY + INCY 3655 20 CONTINUE 3656 ELSE 3657 IF( INCX.GT.0 )THEN 3658 KX = 1 3659 ELSE 3660 KX = 1 - ( M - 1 )*INCX 3661 END IF 3662 DO 40, J = 1, N 3663c IF( Y( JY ).NE.ZERO )THEN 3664 TEMP = ALPHA*Y( JY ) 3665 IX = KX 3666 DO 30, I = 1, M 3667 A( I, J ) = A( I, J ) + X( IX )*TEMP 3668 IX = IX + INCX 3669 30 CONTINUE 3670c END IF 3671 JY = JY + INCY 3672 40 CONTINUE 3673 END IF 3674* 3675 RETURN 3676* 3677* End of ZGERU . 3678* 3679 END 3680 SUBROUTINE ZHBMV ( UPLO, N, K, ALPHA, A, LDA, X, INCX, 3681 $ BETA, Y, INCY ) 3682* .. Scalar Arguments .. 3683 DOUBLE COMPLEX ALPHA, BETA 3684 INTEGER INCX, INCY, K, LDA, N 3685 CHARACTER UPLO 3686* .. Array Arguments .. 3687 DOUBLE COMPLEX A( LDA, * ), X( * ), Y( * ) 3688* .. 3689* 3690* Purpose 3691* ======= 3692* 3693* ZHBMV performs the matrix-vector operation 3694* 3695* y := alpha*A*x + beta*y, 3696* 3697* where alpha and beta are scalars, x and y are n element vectors and 3698* A is an n by n hermitian band matrix, with k super-diagonals. 3699* 3700* Parameters 3701* ========== 3702* 3703* UPLO - CHARACTER*1. 3704* On entry, UPLO specifies whether the upper or lower 3705* triangular part of the band matrix A is being supplied as 3706* follows: 3707* 3708* UPLO = 'U' or 'u' The upper triangular part of A is 3709* being supplied. 3710* 3711* UPLO = 'L' or 'l' The lower triangular part of A is 3712* being supplied. 3713* 3714* Unchanged on exit. 3715* 3716* N - INTEGER. 3717* On entry, N specifies the order of the matrix A. 3718* N must be at least zero. 3719* Unchanged on exit. 3720* 3721* K - INTEGER. 3722* On entry, K specifies the number of super-diagonals of the 3723* matrix A. K must satisfy 0 .le. K. 3724* Unchanged on exit. 3725* 3726* ALPHA - DOUBLE COMPLEX . 3727* On entry, ALPHA specifies the scalar alpha. 3728* Unchanged on exit. 3729* 3730* A - DOUBLE COMPLEX array of DIMENSION ( LDA, n ). 3731* Before entry with UPLO = 'U' or 'u', the leading ( k + 1 ) 3732* by n part of the array A must contain the upper triangular 3733* band part of the hermitian matrix, supplied column by 3734* column, with the leading diagonal of the matrix in row 3735* ( k + 1 ) of the array, the first super-diagonal starting at 3736* position 2 in row k, and so on. The top left k by k triangle 3737* of the array A is not referenced. 3738* The following program segment will transfer the upper 3739* triangular part of a hermitian band matrix from conventional 3740* full matrix storage to band storage: 3741* 3742* DO 20, J = 1, N 3743* M = K + 1 - J 3744* DO 10, I = MAX( 1, J - K ), J 3745* A( M + I, J ) = matrix( I, J ) 3746* 10 CONTINUE 3747* 20 CONTINUE 3748* 3749* Before entry with UPLO = 'L' or 'l', the leading ( k + 1 ) 3750* by n part of the array A must contain the lower triangular 3751* band part of the hermitian matrix, supplied column by 3752* column, with the leading diagonal of the matrix in row 1 of 3753* the array, the first sub-diagonal starting at position 1 in 3754* row 2, and so on. The bottom right k by k triangle of the 3755* array A is not referenced. 3756* The following program segment will transfer the lower 3757* triangular part of a hermitian band matrix from conventional 3758* full matrix storage to band storage: 3759* 3760* DO 20, J = 1, N 3761* M = 1 - J 3762* DO 10, I = J, MIN( N, J + K ) 3763* A( M + I, J ) = matrix( I, J ) 3764* 10 CONTINUE 3765* 20 CONTINUE 3766* 3767* Note that the imaginary parts of the diagonal elements need 3768* not be set and are assumed to be zero. 3769* Unchanged on exit. 3770* 3771* LDA - INTEGER. 3772* On entry, LDA specifies the first dimension of A as declared 3773* in the calling (sub) program. LDA must be at least 3774* ( k + 1 ). 3775* Unchanged on exit. 3776* 3777* X - DOUBLE COMPLEX array of DIMENSION at least 3778* ( 1 + ( n - 1 )*abs( INCX ) ). 3779* Before entry, the incremented array X must contain the 3780* vector x. 3781* Unchanged on exit. 3782* 3783* INCX - INTEGER. 3784* On entry, INCX specifies the increment for the elements of 3785* X. INCX must not be zero. 3786* Unchanged on exit. 3787* 3788* BETA - DOUBLE COMPLEX . 3789* On entry, BETA specifies the scalar beta. 3790* Unchanged on exit. 3791* 3792* Y - DOUBLE COMPLEX array of DIMENSION at least 3793* ( 1 + ( n - 1 )*abs( INCY ) ). 3794* Before entry, the incremented array Y must contain the 3795* vector y. On exit, Y is overwritten by the updated vector y. 3796* 3797* INCY - INTEGER. 3798* On entry, INCY specifies the increment for the elements of 3799* Y. INCY must not be zero. 3800* Unchanged on exit. 3801* 3802* 3803* Level 2 Blas routine. 3804* 3805* -- Written on 22-October-1986. 3806* Jack Dongarra, Argonne National Lab. 3807* Jeremy Du Croz, Nag Central Office. 3808* Sven Hammarling, Nag Central Office. 3809* Richard Hanson, Sandia National Labs. 3810* 3811* 3812* .. Parameters .. 3813 DOUBLE COMPLEX ONE 3814 PARAMETER ( ONE = ( 1.0D+0, 0.0D+0 ) ) 3815 DOUBLE COMPLEX ZERO 3816 PARAMETER ( ZERO = ( 0.0D+0, 0.0D+0 ) ) 3817* .. Local Scalars .. 3818 DOUBLE COMPLEX TEMP1, TEMP2 3819 INTEGER I, INFO, IX, IY, J, JX, JY, KPLUS1, KX, KY, L 3820* .. External Functions .. 3821 LOGICAL LSAME 3822 EXTERNAL LSAME 3823* .. External Subroutines .. 3824 EXTERNAL XERBLA 3825* .. Intrinsic Functions .. 3826 INTRINSIC DCONJG, MAX, MIN, DBLE 3827* .. 3828* .. Executable Statements .. 3829* 3830* Test the input parameters. 3831* 3832 INFO = 0 3833 IF ( .NOT.LSAME( UPLO, 'U' ).AND. 3834 $ .NOT.LSAME( UPLO, 'L' ) )THEN 3835 INFO = 1 3836 ELSE IF( N.LT.0 )THEN 3837 INFO = 2 3838 ELSE IF( K.LT.0 )THEN 3839 INFO = 3 3840 ELSE IF( LDA.LT.( K + 1 ) )THEN 3841 INFO = 6 3842 ELSE IF( INCX.EQ.0 )THEN 3843 INFO = 8 3844 ELSE IF( INCY.EQ.0 )THEN 3845 INFO = 11 3846 END IF 3847 IF( INFO.NE.0 )THEN 3848 CALL XERBLA( 'ZHBMV ', INFO ) 3849 RETURN 3850 END IF 3851* 3852* Quick return if possible. 3853* 3854 IF( ( N.EQ.0 ).OR.( ( ALPHA.EQ.ZERO ).AND.( BETA.EQ.ONE ) ) ) 3855 $ RETURN 3856* 3857* Set up the start points in X and Y. 3858* 3859 IF( INCX.GT.0 )THEN 3860 KX = 1 3861 ELSE 3862 KX = 1 - ( N - 1 )*INCX 3863 END IF 3864 IF( INCY.GT.0 )THEN 3865 KY = 1 3866 ELSE 3867 KY = 1 - ( N - 1 )*INCY 3868 END IF 3869* 3870* Start the operations. In this version the elements of the array A 3871* are accessed sequentially with one pass through A. 3872* 3873* First form y := beta*y. 3874* 3875 IF( BETA.NE.ONE )THEN 3876 IF( INCY.EQ.1 )THEN 3877 IF( BETA.EQ.ZERO )THEN 3878 DO 10, I = 1, N 3879 Y( I ) = ZERO 3880 10 CONTINUE 3881 ELSE 3882 DO 20, I = 1, N 3883 Y( I ) = BETA*Y( I ) 3884 20 CONTINUE 3885 END IF 3886 ELSE 3887 IY = KY 3888 IF( BETA.EQ.ZERO )THEN 3889 DO 30, I = 1, N 3890 Y( IY ) = ZERO 3891 IY = IY + INCY 3892 30 CONTINUE 3893 ELSE 3894 DO 40, I = 1, N 3895 Y( IY ) = BETA*Y( IY ) 3896 IY = IY + INCY 3897 40 CONTINUE 3898 END IF 3899 END IF 3900 END IF 3901 IF( ALPHA.EQ.ZERO ) 3902 $ RETURN 3903 IF( LSAME( UPLO, 'U' ) )THEN 3904* 3905* Form y when upper triangle of A is stored. 3906* 3907 KPLUS1 = K + 1 3908 IF( ( INCX.EQ.1 ).AND.( INCY.EQ.1 ) )THEN 3909 DO 60, J = 1, N 3910 TEMP1 = ALPHA*X( J ) 3911 TEMP2 = ZERO 3912 L = KPLUS1 - J 3913 DO 50, I = MAX( 1, J - K ), J - 1 3914 Y( I ) = Y( I ) + TEMP1*A( L + I, J ) 3915 TEMP2 = TEMP2 + DCONJG( A( L + I, J ) )*X( I ) 3916 50 CONTINUE 3917 Y( J ) = Y( J ) + TEMP1*DBLE( A( KPLUS1, J ) ) 3918 $ + ALPHA*TEMP2 3919 60 CONTINUE 3920 ELSE 3921 JX = KX 3922 JY = KY 3923 DO 80, J = 1, N 3924 TEMP1 = ALPHA*X( JX ) 3925 TEMP2 = ZERO 3926 IX = KX 3927 IY = KY 3928 L = KPLUS1 - J 3929 DO 70, I = MAX( 1, J - K ), J - 1 3930 Y( IY ) = Y( IY ) + TEMP1*A( L + I, J ) 3931 TEMP2 = TEMP2 + DCONJG( A( L + I, J ) )*X( IX ) 3932 IX = IX + INCX 3933 IY = IY + INCY 3934 70 CONTINUE 3935 Y( JY ) = Y( JY ) + TEMP1*DBLE( A( KPLUS1, J ) ) 3936 $ + ALPHA*TEMP2 3937 JX = JX + INCX 3938 JY = JY + INCY 3939 IF( J.GT.K )THEN 3940 KX = KX + INCX 3941 KY = KY + INCY 3942 END IF 3943 80 CONTINUE 3944 END IF 3945 ELSE 3946* 3947* Form y when lower triangle of A is stored. 3948* 3949 IF( ( INCX.EQ.1 ).AND.( INCY.EQ.1 ) )THEN 3950 DO 100, J = 1, N 3951 TEMP1 = ALPHA*X( J ) 3952 TEMP2 = ZERO 3953 Y( J ) = Y( J ) + TEMP1*DBLE( A( 1, J ) ) 3954 L = 1 - J 3955 DO 90, I = J + 1, MIN( N, J + K ) 3956 Y( I ) = Y( I ) + TEMP1*A( L + I, J ) 3957 TEMP2 = TEMP2 + DCONJG( A( L + I, J ) )*X( I ) 3958 90 CONTINUE 3959 Y( J ) = Y( J ) + ALPHA*TEMP2 3960 100 CONTINUE 3961 ELSE 3962 JX = KX 3963 JY = KY 3964 DO 120, J = 1, N 3965 TEMP1 = ALPHA*X( JX ) 3966 TEMP2 = ZERO 3967 Y( JY ) = Y( JY ) + TEMP1*DBLE( A( 1, J ) ) 3968 L = 1 - J 3969 IX = JX 3970 IY = JY 3971 DO 110, I = J + 1, MIN( N, J + K ) 3972 IX = IX + INCX 3973 IY = IY + INCY 3974 Y( IY ) = Y( IY ) + TEMP1*A( L + I, J ) 3975 TEMP2 = TEMP2 + DCONJG( A( L + I, J ) )*X( IX ) 3976 110 CONTINUE 3977 Y( JY ) = Y( JY ) + ALPHA*TEMP2 3978 JX = JX + INCX 3979 JY = JY + INCY 3980 120 CONTINUE 3981 END IF 3982 END IF 3983* 3984 RETURN 3985* 3986* End of ZHBMV . 3987* 3988 END 3989 SUBROUTINE ZHEMM ( SIDE, UPLO, M, N, ALPHA, A, LDA, B, LDB, 3990 $ BETA, C, LDC ) 3991* .. Scalar Arguments .. 3992 CHARACTER SIDE, UPLO 3993 INTEGER M, N, LDA, LDB, LDC 3994 DOUBLE COMPLEX ALPHA, BETA 3995* .. Array Arguments .. 3996 DOUBLE COMPLEX A( LDA, * ), B( LDB, * ), C( LDC, * ) 3997* .. 3998* 3999* Purpose 4000* ======= 4001* 4002* ZHEMM performs one of the matrix-matrix operations 4003* 4004* C := alpha*A*B + beta*C, 4005* 4006* or 4007* 4008* C := alpha*B*A + beta*C, 4009* 4010* where alpha and beta are scalars, A is an hermitian matrix and B and 4011* C are m by n matrices. 4012* 4013* Parameters 4014* ========== 4015* 4016* SIDE - CHARACTER*1. 4017* On entry, SIDE specifies whether the hermitian matrix A 4018* appears on the left or right in the operation as follows: 4019* 4020* SIDE = 'L' or 'l' C := alpha*A*B + beta*C, 4021* 4022* SIDE = 'R' or 'r' C := alpha*B*A + beta*C, 4023* 4024* Unchanged on exit. 4025* 4026* UPLO - CHARACTER*1. 4027* On entry, UPLO specifies whether the upper or lower 4028* triangular part of the hermitian matrix A is to be 4029* referenced as follows: 4030* 4031* UPLO = 'U' or 'u' Only the upper triangular part of the 4032* hermitian matrix is to be referenced. 4033* 4034* UPLO = 'L' or 'l' Only the lower triangular part of the 4035* hermitian matrix is to be referenced. 4036* 4037* Unchanged on exit. 4038* 4039* M - INTEGER. 4040* On entry, M specifies the number of rows of the matrix C. 4041* M must be at least zero. 4042* Unchanged on exit. 4043* 4044* N - INTEGER. 4045* On entry, N specifies the number of columns of the matrix C. 4046* N must be at least zero. 4047* Unchanged on exit. 4048* 4049* ALPHA - DOUBLE COMPLEX . 4050* On entry, ALPHA specifies the scalar alpha. 4051* Unchanged on exit. 4052* 4053* A - DOUBLE COMPLEX array of DIMENSION ( LDA, ka ), where ka is 4054* m when SIDE = 'L' or 'l' and is n otherwise. 4055* Before entry with SIDE = 'L' or 'l', the m by m part of 4056* the array A must contain the hermitian matrix, such that 4057* when UPLO = 'U' or 'u', the leading m by m upper triangular 4058* part of the array A must contain the upper triangular part 4059* of the hermitian matrix and the strictly lower triangular 4060* part of A is not referenced, and when UPLO = 'L' or 'l', 4061* the leading m by m lower triangular part of the array A 4062* must contain the lower triangular part of the hermitian 4063* matrix and the strictly upper triangular part of A is not 4064* referenced. 4065* Before entry with SIDE = 'R' or 'r', the n by n part of 4066* the array A must contain the hermitian matrix, such that 4067* when UPLO = 'U' or 'u', the leading n by n upper triangular 4068* part of the array A must contain the upper triangular part 4069* of the hermitian matrix and the strictly lower triangular 4070* part of A is not referenced, and when UPLO = 'L' or 'l', 4071* the leading n by n lower triangular part of the array A 4072* must contain the lower triangular part of the hermitian 4073* matrix and the strictly upper triangular part of A is not 4074* referenced. 4075* Note that the imaginary parts of the diagonal elements need 4076* not be set, they are assumed to be zero. 4077* Unchanged on exit. 4078* 4079* LDA - INTEGER. 4080* On entry, LDA specifies the first dimension of A as declared 4081* in the calling (sub) program. When SIDE = 'L' or 'l' then 4082* LDA must be at least max( 1, m ), otherwise LDA must be at 4083* least max( 1, n ). 4084* Unchanged on exit. 4085* 4086* B - DOUBLE COMPLEX array of DIMENSION ( LDB, n ). 4087* Before entry, the leading m by n part of the array B must 4088* contain the matrix B. 4089* Unchanged on exit. 4090* 4091* LDB - INTEGER. 4092* On entry, LDB specifies the first dimension of B as declared 4093* in the calling (sub) program. LDB must be at least 4094* max( 1, m ). 4095* Unchanged on exit. 4096* 4097* BETA - DOUBLE COMPLEX . 4098* On entry, BETA specifies the scalar beta. When BETA is 4099* supplied as zero then C need not be set on input. 4100* Unchanged on exit. 4101* 4102* C - DOUBLE COMPLEX array of DIMENSION ( LDC, n ). 4103* Before entry, the leading m by n part of the array C must 4104* contain the matrix C, except when beta is zero, in which 4105* case C need not be set on entry. 4106* On exit, the array C is overwritten by the m by n updated 4107* matrix. 4108* 4109* LDC - INTEGER. 4110* On entry, LDC specifies the first dimension of C as declared 4111* in the calling (sub) program. LDC must be at least 4112* max( 1, m ). 4113* Unchanged on exit. 4114* 4115* 4116* Level 3 Blas routine. 4117* 4118* -- Written on 8-February-1989. 4119* Jack Dongarra, Argonne National Laboratory. 4120* Iain Duff, AERE Harwell. 4121* Jeremy Du Croz, Numerical Algorithms Group Ltd. 4122* Sven Hammarling, Numerical Algorithms Group Ltd. 4123* 4124* 4125* .. External Functions .. 4126 LOGICAL LSAME 4127 EXTERNAL LSAME 4128* .. External Subroutines .. 4129 EXTERNAL XERBLA 4130* .. Intrinsic Functions .. 4131 INTRINSIC DCONJG, MAX, DBLE 4132* .. Local Scalars .. 4133 LOGICAL UPPER 4134 INTEGER I, INFO, J, K, NROWA 4135 DOUBLE COMPLEX TEMP1, TEMP2 4136* .. Parameters .. 4137 DOUBLE COMPLEX ONE 4138 PARAMETER ( ONE = ( 1.0D+0, 0.0D+0 ) ) 4139 DOUBLE COMPLEX ZERO 4140 PARAMETER ( ZERO = ( 0.0D+0, 0.0D+0 ) ) 4141* .. 4142* .. Executable Statements .. 4143* 4144* Set NROWA as the number of rows of A. 4145* 4146 IF( LSAME( SIDE, 'L' ) )THEN 4147 NROWA = M 4148 ELSE 4149 NROWA = N 4150 END IF 4151 UPPER = LSAME( UPLO, 'U' ) 4152* 4153* Test the input parameters. 4154* 4155 INFO = 0 4156 IF( ( .NOT.LSAME( SIDE, 'L' ) ).AND. 4157 $ ( .NOT.LSAME( SIDE, 'R' ) ) )THEN 4158 INFO = 1 4159 ELSE IF( ( .NOT.UPPER ).AND. 4160 $ ( .NOT.LSAME( UPLO, 'L' ) ) )THEN 4161 INFO = 2 4162 ELSE IF( M .LT.0 )THEN 4163 INFO = 3 4164 ELSE IF( N .LT.0 )THEN 4165 INFO = 4 4166 ELSE IF( LDA.LT.MAX( 1, NROWA ) )THEN 4167 INFO = 7 4168 ELSE IF( LDB.LT.MAX( 1, M ) )THEN 4169 INFO = 9 4170 ELSE IF( LDC.LT.MAX( 1, M ) )THEN 4171 INFO = 12 4172 END IF 4173 IF( INFO.NE.0 )THEN 4174 CALL XERBLA( 'ZHEMM ', INFO ) 4175 RETURN 4176 END IF 4177* 4178* Quick return if possible. 4179* 4180 IF( ( M.EQ.0 ).OR.( N.EQ.0 ).OR. 4181 $ ( ( ALPHA.EQ.ZERO ).AND.( BETA.EQ.ONE ) ) ) 4182 $ RETURN 4183* 4184* And when alpha.eq.zero. 4185* 4186 IF( ALPHA.EQ.ZERO )THEN 4187 IF( BETA.EQ.ZERO )THEN 4188 DO 20, J = 1, N 4189 DO 10, I = 1, M 4190 C( I, J ) = ZERO 4191 10 CONTINUE 4192 20 CONTINUE 4193 ELSE 4194 DO 40, J = 1, N 4195 DO 30, I = 1, M 4196 C( I, J ) = BETA*C( I, J ) 4197 30 CONTINUE 4198 40 CONTINUE 4199 END IF 4200 RETURN 4201 END IF 4202* 4203* Start the operations. 4204* 4205 IF( LSAME( SIDE, 'L' ) )THEN 4206* 4207* Form C := alpha*A*B + beta*C. 4208* 4209 IF( UPPER )THEN 4210 DO 70, J = 1, N 4211 DO 60, I = 1, M 4212 TEMP1 = ALPHA*B( I, J ) 4213 TEMP2 = ZERO 4214 DO 50, K = 1, I - 1 4215 C( K, J ) = C( K, J ) + TEMP1*A( K, I ) 4216 TEMP2 = TEMP2 + 4217 $ B( K, J )*DCONJG( A( K, I ) ) 4218 50 CONTINUE 4219 IF( BETA.EQ.ZERO )THEN 4220 C( I, J ) = TEMP1*DBLE( A( I, I ) ) + 4221 $ ALPHA*TEMP2 4222 ELSE 4223 C( I, J ) = BETA *C( I, J ) + 4224 $ TEMP1*DBLE( A( I, I ) ) + 4225 $ ALPHA*TEMP2 4226 END IF 4227 60 CONTINUE 4228 70 CONTINUE 4229 ELSE 4230 DO 100, J = 1, N 4231 DO 90, I = M, 1, -1 4232 TEMP1 = ALPHA*B( I, J ) 4233 TEMP2 = ZERO 4234 DO 80, K = I + 1, M 4235 C( K, J ) = C( K, J ) + TEMP1*A( K, I ) 4236 TEMP2 = TEMP2 + 4237 $ B( K, J )*DCONJG( A( K, I ) ) 4238 80 CONTINUE 4239 IF( BETA.EQ.ZERO )THEN 4240 C( I, J ) = TEMP1*DBLE( A( I, I ) ) + 4241 $ ALPHA*TEMP2 4242 ELSE 4243 C( I, J ) = BETA *C( I, J ) + 4244 $ TEMP1*DBLE( A( I, I ) ) + 4245 $ ALPHA*TEMP2 4246 END IF 4247 90 CONTINUE 4248 100 CONTINUE 4249 END IF 4250 ELSE 4251* 4252* Form C := alpha*B*A + beta*C. 4253* 4254 DO 170, J = 1, N 4255 TEMP1 = ALPHA*DBLE( A( J, J ) ) 4256 IF( BETA.EQ.ZERO )THEN 4257 DO 110, I = 1, M 4258 C( I, J ) = TEMP1*B( I, J ) 4259 110 CONTINUE 4260 ELSE 4261 DO 120, I = 1, M 4262 C( I, J ) = BETA*C( I, J ) + TEMP1*B( I, J ) 4263 120 CONTINUE 4264 END IF 4265 DO 140, K = 1, J - 1 4266 IF( UPPER )THEN 4267 TEMP1 = ALPHA*A( K, J ) 4268 ELSE 4269 TEMP1 = ALPHA*DCONJG( A( J, K ) ) 4270 END IF 4271 DO 130, I = 1, M 4272 C( I, J ) = C( I, J ) + TEMP1*B( I, K ) 4273 130 CONTINUE 4274 140 CONTINUE 4275 DO 160, K = J + 1, N 4276 IF( UPPER )THEN 4277 TEMP1 = ALPHA*DCONJG( A( J, K ) ) 4278 ELSE 4279 TEMP1 = ALPHA*A( K, J ) 4280 END IF 4281 DO 150, I = 1, M 4282 C( I, J ) = C( I, J ) + TEMP1*B( I, K ) 4283 150 CONTINUE 4284 160 CONTINUE 4285 170 CONTINUE 4286 END IF 4287* 4288 RETURN 4289* 4290* End of ZHEMM . 4291* 4292 END 4293 SUBROUTINE ZHER ( UPLO, N, ALPHA, X, INCX, A, LDA ) 4294* .. Scalar Arguments .. 4295 DOUBLE PRECISION ALPHA 4296 INTEGER INCX, LDA, N 4297 CHARACTER UPLO 4298* .. Array Arguments .. 4299 DOUBLE COMPLEX A( LDA, * ), X( * ) 4300* .. 4301* 4302* Purpose 4303* ======= 4304* 4305* ZHER performs the hermitian rank 1 operation 4306* 4307* A := alpha*x*conjg( x' ) + A, 4308* 4309* where alpha is a real scalar, x is an n element vector and A is an 4310* n by n hermitian matrix. 4311* 4312* Parameters 4313* ========== 4314* 4315* UPLO - CHARACTER*1. 4316* On entry, UPLO specifies whether the upper or lower 4317* triangular part of the array A is to be referenced as 4318* follows: 4319* 4320* UPLO = 'U' or 'u' Only the upper triangular part of A 4321* is to be referenced. 4322* 4323* UPLO = 'L' or 'l' Only the lower triangular part of A 4324* is to be referenced. 4325* 4326* Unchanged on exit. 4327* 4328* N - INTEGER. 4329* On entry, N specifies the order of the matrix A. 4330* N must be at least zero. 4331* Unchanged on exit. 4332* 4333* ALPHA - DOUBLE PRECISION. 4334* On entry, ALPHA specifies the scalar alpha. 4335* Unchanged on exit. 4336* 4337* X - DOUBLE COMPLEX array of dimension at least 4338* ( 1 + ( n - 1 )*abs( INCX ) ). 4339* Before entry, the incremented array X must contain the n 4340* element vector x. 4341* Unchanged on exit. 4342* 4343* INCX - INTEGER. 4344* On entry, INCX specifies the increment for the elements of 4345* X. INCX must not be zero. 4346* Unchanged on exit. 4347* 4348* A - DOUBLE COMPLEX array of DIMENSION ( LDA, n ). 4349* Before entry with UPLO = 'U' or 'u', the leading n by n 4350* upper triangular part of the array A must contain the upper 4351* triangular part of the hermitian matrix and the strictly 4352* lower triangular part of A is not referenced. On exit, the 4353* upper triangular part of the array A is overwritten by the 4354* upper triangular part of the updated matrix. 4355* Before entry with UPLO = 'L' or 'l', the leading n by n 4356* lower triangular part of the array A must contain the lower 4357* triangular part of the hermitian matrix and the strictly 4358* upper triangular part of A is not referenced. On exit, the 4359* lower triangular part of the array A is overwritten by the 4360* lower triangular part of the updated matrix. 4361* Note that the imaginary parts of the diagonal elements need 4362* not be set, they are assumed to be zero, and on exit they 4363* are set to zero. 4364* 4365* LDA - INTEGER. 4366* On entry, LDA specifies the first dimension of A as declared 4367* in the calling (sub) program. LDA must be at least 4368* max( 1, n ). 4369* Unchanged on exit. 4370* 4371* 4372* Level 2 Blas routine. 4373* 4374* -- Written on 22-October-1986. 4375* Jack Dongarra, Argonne National Lab. 4376* Jeremy Du Croz, Nag Central Office. 4377* Sven Hammarling, Nag Central Office. 4378* Richard Hanson, Sandia National Labs. 4379* 4380* 4381* .. Parameters .. 4382 DOUBLE COMPLEX ZERO 4383 PARAMETER ( ZERO = ( 0.0D+0, 0.0D+0 ) ) 4384* .. Local Scalars .. 4385 DOUBLE COMPLEX TEMP 4386 INTEGER I, INFO, IX, J, JX, KX 4387* .. External Functions .. 4388 LOGICAL LSAME 4389 EXTERNAL LSAME 4390* .. External Subroutines .. 4391 EXTERNAL XERBLA 4392* .. Intrinsic Functions .. 4393 INTRINSIC DCONJG, MAX, DBLE 4394* .. 4395* .. Executable Statements .. 4396* 4397* Test the input parameters. 4398* 4399 INFO = 0 4400 IF ( .NOT.LSAME( UPLO, 'U' ).AND. 4401 $ .NOT.LSAME( UPLO, 'L' ) )THEN 4402 INFO = 1 4403 ELSE IF( N.LT.0 )THEN 4404 INFO = 2 4405 ELSE IF( INCX.EQ.0 )THEN 4406 INFO = 5 4407 ELSE IF( LDA.LT.MAX( 1, N ) )THEN 4408 INFO = 7 4409 END IF 4410 IF( INFO.NE.0 )THEN 4411 CALL XERBLA( 'ZHER ', INFO ) 4412 RETURN 4413 END IF 4414* 4415* Quick return if possible. 4416* 4417 IF( ( N.EQ.0 ).OR.( ALPHA.EQ.DBLE( ZERO ) ) ) 4418 $ RETURN 4419* 4420* Set the start point in X if the increment is not unity. 4421* 4422 IF( INCX.LE.0 )THEN 4423 KX = 1 - ( N - 1 )*INCX 4424 ELSE IF( INCX.NE.1 )THEN 4425 KX = 1 4426 END IF 4427* 4428* Start the operations. In this version the elements of A are 4429* accessed sequentially with one pass through the triangular part 4430* of A. 4431* 4432 IF( LSAME( UPLO, 'U' ) )THEN 4433* 4434* Form A when A is stored in upper triangle. 4435* 4436 IF( INCX.EQ.1 )THEN 4437 DO 20, J = 1, N 4438c IF( X( J ).NE.ZERO )THEN 4439 TEMP = ALPHA*DCONJG( X( J ) ) 4440 DO 10, I = 1, J - 1 4441 A( I, J ) = A( I, J ) + X( I )*TEMP 4442 10 CONTINUE 4443 A( J, J ) = DBLE( A( J, J ) ) + DBLE( X( J )*TEMP ) 4444c ELSE 4445c A( J, J ) = DBLE( A( J, J ) ) 4446c END IF 4447 20 CONTINUE 4448 ELSE 4449 JX = KX 4450 DO 40, J = 1, N 4451c IF( X( JX ).NE.ZERO )THEN 4452 TEMP = ALPHA*DCONJG( X( JX ) ) 4453 IX = KX 4454 DO 30, I = 1, J - 1 4455 A( I, J ) = A( I, J ) + X( IX )*TEMP 4456 IX = IX + INCX 4457 30 CONTINUE 4458 A( J, J ) = DBLE( A( J, J ) ) + DBLE( X( JX )*TEMP ) 4459c ELSE 4460c A( J, J ) = DBLE( A( J, J ) ) 4461c END IF 4462 JX = JX + INCX 4463 40 CONTINUE 4464 END IF 4465 ELSE 4466* 4467* Form A when A is stored in lower triangle. 4468* 4469 IF( INCX.EQ.1 )THEN 4470 DO 60, J = 1, N 4471c IF( X( J ).NE.ZERO )THEN 4472 TEMP = ALPHA*DCONJG( X( J ) ) 4473 A( J, J ) = DBLE( A( J, J ) ) + DBLE( TEMP*X( J ) ) 4474 DO 50, I = J + 1, N 4475 A( I, J ) = A( I, J ) + X( I )*TEMP 4476 50 CONTINUE 4477c ELSE 4478c A( J, J ) = DBLE( A( J, J ) ) 4479c END IF 4480 60 CONTINUE 4481 ELSE 4482 JX = KX 4483 DO 80, J = 1, N 4484c IF( X( JX ).NE.ZERO )THEN 4485 TEMP = ALPHA*DCONJG( X( JX ) ) 4486 A( J, J ) = DBLE( A( J, J ) ) + DBLE( TEMP*X( JX ) ) 4487 IX = JX 4488 DO 70, I = J + 1, N 4489 IX = IX + INCX 4490 A( I, J ) = A( I, J ) + X( IX )*TEMP 4491 70 CONTINUE 4492c ELSE 4493c A( J, J ) = DBLE( A( J, J ) ) 4494c END IF 4495 JX = JX + INCX 4496 80 CONTINUE 4497 END IF 4498 END IF 4499* 4500 RETURN 4501* 4502* End of ZHER . 4503* 4504 END 4505 SUBROUTINE ZHERK( UPLO, TRANS, N, K, ALPHA, A, LDA, BETA, C, LDC ) 4506* .. Scalar Arguments .. 4507 CHARACTER TRANS, UPLO 4508 INTEGER K, LDA, LDC, N 4509 DOUBLE PRECISION ALPHA, BETA 4510* .. 4511* .. Array Arguments .. 4512 DOUBLE COMPLEX A( LDA, * ), C( LDC, * ) 4513* .. 4514* 4515* Purpose 4516* ======= 4517* 4518* ZHERK performs one of the hermitian rank k operations 4519* 4520* C := alpha*A*conjg( A' ) + beta*C, 4521* 4522* or 4523* 4524* C := alpha*conjg( A' )*A + beta*C, 4525* 4526* where alpha and beta are real scalars, C is an n by n hermitian 4527* matrix and A is an n by k matrix in the first case and a k by n 4528* matrix in the second case. 4529* 4530* Parameters 4531* ========== 4532* 4533* UPLO - CHARACTER*1. 4534* On entry, UPLO specifies whether the upper or lower 4535* triangular part of the array C is to be referenced as 4536* follows: 4537* 4538* UPLO = 'U' or 'u' Only the upper triangular part of C 4539* is to be referenced. 4540* 4541* UPLO = 'L' or 'l' Only the lower triangular part of C 4542* is to be referenced. 4543* 4544* Unchanged on exit. 4545* 4546* TRANS - CHARACTER*1. 4547* On entry, TRANS specifies the operation to be performed as 4548* follows: 4549* 4550* TRANS = 'N' or 'n' C := alpha*A*conjg( A' ) + beta*C. 4551* 4552* TRANS = 'C' or 'c' C := alpha*conjg( A' )*A + beta*C. 4553* 4554* Unchanged on exit. 4555* 4556* N - INTEGER. 4557* On entry, N specifies the order of the matrix C. N must be 4558* at least zero. 4559* Unchanged on exit. 4560* 4561* K - INTEGER. 4562* On entry with TRANS = 'N' or 'n', K specifies the number 4563* of columns of the matrix A, and on entry with 4564* TRANS = 'C' or 'c', K specifies the number of rows of the 4565* matrix A. K must be at least zero. 4566* Unchanged on exit. 4567* 4568* ALPHA - DOUBLE PRECISION . 4569* On entry, ALPHA specifies the scalar alpha. 4570* Unchanged on exit. 4571* 4572* A - DOUBLE COMPLEX array of DIMENSION ( LDA, ka ), where ka is 4573* k when TRANS = 'N' or 'n', and is n otherwise. 4574* Before entry with TRANS = 'N' or 'n', the leading n by k 4575* part of the array A must contain the matrix A, otherwise 4576* the leading k by n part of the array A must contain the 4577* matrix A. 4578* Unchanged on exit. 4579* 4580* LDA - INTEGER. 4581* On entry, LDA specifies the first dimension of A as declared 4582* in the calling (sub) program. When TRANS = 'N' or 'n' 4583* then LDA must be at least max( 1, n ), otherwise LDA must 4584* be at least max( 1, k ). 4585* Unchanged on exit. 4586* 4587* BETA - DOUBLE PRECISION. 4588* On entry, BETA specifies the scalar beta. 4589* Unchanged on exit. 4590* 4591* C - DOUBLE COMPLEX array of DIMENSION ( LDC, n ). 4592* Before entry with UPLO = 'U' or 'u', the leading n by n 4593* upper triangular part of the array C must contain the upper 4594* triangular part of the hermitian matrix and the strictly 4595* lower triangular part of C is not referenced. On exit, the 4596* upper triangular part of the array C is overwritten by the 4597* upper triangular part of the updated matrix. 4598* Before entry with UPLO = 'L' or 'l', the leading n by n 4599* lower triangular part of the array C must contain the lower 4600* triangular part of the hermitian matrix and the strictly 4601* upper triangular part of C is not referenced. On exit, the 4602* lower triangular part of the array C is overwritten by the 4603* lower triangular part of the updated matrix. 4604* Note that the imaginary parts of the diagonal elements need 4605* not be set, they are assumed to be zero, and on exit they 4606* are set to zero. 4607* 4608* LDC - INTEGER. 4609* On entry, LDC specifies the first dimension of C as declared 4610* in the calling (sub) program. LDC must be at least 4611* max( 1, n ). 4612* Unchanged on exit. 4613* 4614* 4615* Level 3 Blas routine. 4616* 4617* -- Written on 8-February-1989. 4618* Jack Dongarra, Argonne National Laboratory. 4619* Iain Duff, AERE Harwell. 4620* Jeremy Du Croz, Numerical Algorithms Group Ltd. 4621* Sven Hammarling, Numerical Algorithms Group Ltd. 4622* 4623* -- Modified 8-Nov-93 to set C(J,J) to DBLE( C(J,J) ) when BETA = 1. 4624* Ed Anderson, Cray Research Inc. 4625* 4626* 4627* .. External Functions .. 4628 LOGICAL LSAME 4629 EXTERNAL LSAME 4630* .. 4631* .. External Subroutines .. 4632 EXTERNAL XERBLA 4633* .. 4634* .. Intrinsic Functions .. 4635 INTRINSIC DBLE, DCMPLX, DCONJG, MAX 4636* .. 4637* .. Local Scalars .. 4638 LOGICAL UPPER 4639 INTEGER I, INFO, J, L, NROWA 4640 DOUBLE PRECISION RTEMP 4641 DOUBLE COMPLEX TEMP 4642* .. 4643* .. Parameters .. 4644 DOUBLE PRECISION ONE, ZERO 4645 PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 ) 4646* .. 4647* .. Executable Statements .. 4648* 4649* Test the input parameters. 4650* 4651 IF( LSAME( TRANS, 'N' ) ) THEN 4652 NROWA = N 4653 ELSE 4654 NROWA = K 4655 END IF 4656 UPPER = LSAME( UPLO, 'U' ) 4657* 4658 INFO = 0 4659 IF( ( .NOT.UPPER ) .AND. ( .NOT.LSAME( UPLO, 'L' ) ) ) THEN 4660 INFO = 1 4661 ELSE IF( ( .NOT.LSAME( TRANS, 'N' ) ) .AND. 4662 $ ( .NOT.LSAME( TRANS, 'C' ) ) ) THEN 4663 INFO = 2 4664 ELSE IF( N.LT.0 ) THEN 4665 INFO = 3 4666 ELSE IF( K.LT.0 ) THEN 4667 INFO = 4 4668 ELSE IF( LDA.LT.MAX( 1, NROWA ) ) THEN 4669 INFO = 7 4670 ELSE IF( LDC.LT.MAX( 1, N ) ) THEN 4671 INFO = 10 4672 END IF 4673 IF( INFO.NE.0 ) THEN 4674 CALL XERBLA( 'ZHERK ', INFO ) 4675 RETURN 4676 END IF 4677* 4678* Quick return if possible. 4679* 4680 IF( ( N.EQ.0 ) .OR. ( ( ( ALPHA.EQ.ZERO ) .OR. ( K.EQ.0 ) ) .AND. 4681 $ ( BETA.EQ.ONE ) ) )RETURN 4682* 4683* And when alpha.eq.zero. 4684* 4685 IF( ALPHA.EQ.ZERO ) THEN 4686 IF( UPPER ) THEN 4687 IF( BETA.EQ.ZERO ) THEN 4688 DO 20 J = 1, N 4689 DO 10 I = 1, J 4690 C( I, J ) = ZERO 4691 10 CONTINUE 4692 20 CONTINUE 4693 ELSE 4694 DO 40 J = 1, N 4695 DO 30 I = 1, J - 1 4696 C( I, J ) = BETA*C( I, J ) 4697 30 CONTINUE 4698 C( J, J ) = BETA*DBLE( C( J, J ) ) 4699 40 CONTINUE 4700 END IF 4701 ELSE 4702 IF( BETA.EQ.ZERO ) THEN 4703 DO 60 J = 1, N 4704 DO 50 I = J, N 4705 C( I, J ) = ZERO 4706 50 CONTINUE 4707 60 CONTINUE 4708 ELSE 4709 DO 80 J = 1, N 4710 C( J, J ) = BETA*DBLE( C( J, J ) ) 4711 DO 70 I = J + 1, N 4712 C( I, J ) = BETA*C( I, J ) 4713 70 CONTINUE 4714 80 CONTINUE 4715 END IF 4716 END IF 4717 RETURN 4718 END IF 4719* 4720* Start the operations. 4721* 4722 IF( LSAME( TRANS, 'N' ) ) THEN 4723* 4724* Form C := alpha*A*conjg( A' ) + beta*C. 4725* 4726 IF( UPPER ) THEN 4727 DO 130 J = 1, N 4728 IF( BETA.EQ.ZERO ) THEN 4729 DO 90 I = 1, J 4730 C( I, J ) = ZERO 4731 90 CONTINUE 4732 ELSE IF( BETA.NE.ONE ) THEN 4733 DO 100 I = 1, J - 1 4734 C( I, J ) = BETA*C( I, J ) 4735 100 CONTINUE 4736 C( J, J ) = BETA*DBLE( C( J, J ) ) 4737 ELSE 4738 C( J, J ) = DBLE( C( J, J ) ) 4739 END IF 4740 DO 120 L = 1, K 4741 IF( A( J, L ).NE.DCMPLX( ZERO ) ) THEN 4742 TEMP = ALPHA*DCONJG( A( J, L ) ) 4743 DO 110 I = 1, J - 1 4744 C( I, J ) = C( I, J ) + TEMP*A( I, L ) 4745 110 CONTINUE 4746 C( J, J ) = DBLE( C( J, J ) ) + 4747 $ DBLE( TEMP*A( I, L ) ) 4748 END IF 4749 120 CONTINUE 4750 130 CONTINUE 4751 ELSE 4752 DO 180 J = 1, N 4753 IF( BETA.EQ.ZERO ) THEN 4754 DO 140 I = J, N 4755 C( I, J ) = ZERO 4756 140 CONTINUE 4757 ELSE IF( BETA.NE.ONE ) THEN 4758 C( J, J ) = BETA*DBLE( C( J, J ) ) 4759 DO 150 I = J + 1, N 4760 C( I, J ) = BETA*C( I, J ) 4761 150 CONTINUE 4762 ELSE 4763 C( J, J ) = DBLE( C( J, J ) ) 4764 END IF 4765 DO 170 L = 1, K 4766 IF( A( J, L ).NE.DCMPLX( ZERO ) ) THEN 4767 TEMP = ALPHA*DCONJG( A( J, L ) ) 4768 C( J, J ) = DBLE( C( J, J ) ) + 4769 $ DBLE( TEMP*A( J, L ) ) 4770 DO 160 I = J + 1, N 4771 C( I, J ) = C( I, J ) + TEMP*A( I, L ) 4772 160 CONTINUE 4773 END IF 4774 170 CONTINUE 4775 180 CONTINUE 4776 END IF 4777 ELSE 4778* 4779* Form C := alpha*conjg( A' )*A + beta*C. 4780* 4781 IF( UPPER ) THEN 4782 DO 220 J = 1, N 4783 DO 200 I = 1, J - 1 4784 TEMP = ZERO 4785 DO 190 L = 1, K 4786 TEMP = TEMP + DCONJG( A( L, I ) )*A( L, J ) 4787 190 CONTINUE 4788 IF( BETA.EQ.ZERO ) THEN 4789 C( I, J ) = ALPHA*TEMP 4790 ELSE 4791 C( I, J ) = ALPHA*TEMP + BETA*C( I, J ) 4792 END IF 4793 200 CONTINUE 4794 RTEMP = ZERO 4795 DO 210 L = 1, K 4796 RTEMP = RTEMP + DCONJG( A( L, J ) )*A( L, J ) 4797 210 CONTINUE 4798 IF( BETA.EQ.ZERO ) THEN 4799 C( J, J ) = ALPHA*RTEMP 4800 ELSE 4801 C( J, J ) = ALPHA*RTEMP + BETA*DBLE( C( J, J ) ) 4802 END IF 4803 220 CONTINUE 4804 ELSE 4805 DO 260 J = 1, N 4806 RTEMP = ZERO 4807 DO 230 L = 1, K 4808 RTEMP = RTEMP + DCONJG( A( L, J ) )*A( L, J ) 4809 230 CONTINUE 4810 IF( BETA.EQ.ZERO ) THEN 4811 C( J, J ) = ALPHA*RTEMP 4812 ELSE 4813 C( J, J ) = ALPHA*RTEMP + BETA*DBLE( C( J, J ) ) 4814 END IF 4815 DO 250 I = J + 1, N 4816 TEMP = ZERO 4817 DO 240 L = 1, K 4818 TEMP = TEMP + DCONJG( A( L, I ) )*A( L, J ) 4819 240 CONTINUE 4820 IF( BETA.EQ.ZERO ) THEN 4821 C( I, J ) = ALPHA*TEMP 4822 ELSE 4823 C( I, J ) = ALPHA*TEMP + BETA*C( I, J ) 4824 END IF 4825 250 CONTINUE 4826 260 CONTINUE 4827 END IF 4828 END IF 4829* 4830 RETURN 4831* 4832* End of ZHERK . 4833* 4834 END 4835 SUBROUTINE ZHPMV ( UPLO, N, ALPHA, AP, X, INCX, BETA, Y, INCY ) 4836* .. Scalar Arguments .. 4837 DOUBLE COMPLEX ALPHA, BETA 4838 INTEGER INCX, INCY, N 4839 CHARACTER UPLO 4840* .. Array Arguments .. 4841 DOUBLE COMPLEX AP( * ), X( * ), Y( * ) 4842* .. 4843* 4844* Purpose 4845* ======= 4846* 4847* ZHPMV performs the matrix-vector operation 4848* 4849* y := alpha*A*x + beta*y, 4850* 4851* where alpha and beta are scalars, x and y are n element vectors and 4852* A is an n by n hermitian matrix, supplied in packed form. 4853* 4854* Parameters 4855* ========== 4856* 4857* UPLO - CHARACTER*1. 4858* On entry, UPLO specifies whether the upper or lower 4859* triangular part of the matrix A is supplied in the packed 4860* array AP as follows: 4861* 4862* UPLO = 'U' or 'u' The upper triangular part of A is 4863* supplied in AP. 4864* 4865* UPLO = 'L' or 'l' The lower triangular part of A is 4866* supplied in AP. 4867* 4868* Unchanged on exit. 4869* 4870* N - INTEGER. 4871* On entry, N specifies the order of the matrix A. 4872* N must be at least zero. 4873* Unchanged on exit. 4874* 4875* ALPHA - DOUBLE COMPLEX . 4876* On entry, ALPHA specifies the scalar alpha. 4877* Unchanged on exit. 4878* 4879* AP - DOUBLE COMPLEX array of DIMENSION at least 4880* ( ( n*( n + 1 ) )/2 ). 4881* Before entry with UPLO = 'U' or 'u', the array AP must 4882* contain the upper triangular part of the hermitian matrix 4883* packed sequentially, column by column, so that AP( 1 ) 4884* contains a( 1, 1 ), AP( 2 ) and AP( 3 ) contain a( 1, 2 ) 4885* and a( 2, 2 ) respectively, and so on. 4886* Before entry with UPLO = 'L' or 'l', the array AP must 4887* contain the lower triangular part of the hermitian matrix 4888* packed sequentially, column by column, so that AP( 1 ) 4889* contains a( 1, 1 ), AP( 2 ) and AP( 3 ) contain a( 2, 1 ) 4890* and a( 3, 1 ) respectively, and so on. 4891* Note that the imaginary parts of the diagonal elements need 4892* not be set and are assumed to be zero. 4893* Unchanged on exit. 4894* 4895* X - DOUBLE COMPLEX array of dimension at least 4896* ( 1 + ( n - 1 )*abs( INCX ) ). 4897* Before entry, the incremented array X must contain the n 4898* element vector x. 4899* Unchanged on exit. 4900* 4901* INCX - INTEGER. 4902* On entry, INCX specifies the increment for the elements of 4903* X. INCX must not be zero. 4904* Unchanged on exit. 4905* 4906* BETA - DOUBLE COMPLEX . 4907* On entry, BETA specifies the scalar beta. When BETA is 4908* supplied as zero then Y need not be set on input. 4909* Unchanged on exit. 4910* 4911* Y - DOUBLE COMPLEX array of dimension at least 4912* ( 1 + ( n - 1 )*abs( INCY ) ). 4913* Before entry, the incremented array Y must contain the n 4914* element vector y. On exit, Y is overwritten by the updated 4915* vector y. 4916* 4917* INCY - INTEGER. 4918* On entry, INCY specifies the increment for the elements of 4919* Y. INCY must not be zero. 4920* Unchanged on exit. 4921* 4922* 4923* Level 2 Blas routine. 4924* 4925* -- Written on 22-October-1986. 4926* Jack Dongarra, Argonne National Lab. 4927* Jeremy Du Croz, Nag Central Office. 4928* Sven Hammarling, Nag Central Office. 4929* Richard Hanson, Sandia National Labs. 4930* 4931* 4932* .. Parameters .. 4933 DOUBLE COMPLEX ONE 4934 PARAMETER ( ONE = ( 1.0D+0, 0.0D+0 ) ) 4935 DOUBLE COMPLEX ZERO 4936 PARAMETER ( ZERO = ( 0.0D+0, 0.0D+0 ) ) 4937* .. Local Scalars .. 4938 DOUBLE COMPLEX TEMP1, TEMP2 4939 INTEGER I, INFO, IX, IY, J, JX, JY, K, KK, KX, KY 4940* .. External Functions .. 4941 LOGICAL LSAME 4942 EXTERNAL LSAME 4943* .. External Subroutines .. 4944 EXTERNAL XERBLA 4945* .. Intrinsic Functions .. 4946 INTRINSIC DCONJG, DBLE 4947* .. 4948* .. Executable Statements .. 4949* 4950* Test the input parameters. 4951* 4952 INFO = 0 4953 IF ( .NOT.LSAME( UPLO, 'U' ).AND. 4954 $ .NOT.LSAME( UPLO, 'L' ) )THEN 4955 INFO = 1 4956 ELSE IF( N.LT.0 )THEN 4957 INFO = 2 4958 ELSE IF( INCX.EQ.0 )THEN 4959 INFO = 6 4960 ELSE IF( INCY.EQ.0 )THEN 4961 INFO = 9 4962 END IF 4963 IF( INFO.NE.0 )THEN 4964 CALL XERBLA( 'ZHPMV ', INFO ) 4965 RETURN 4966 END IF 4967* 4968* Quick return if possible. 4969* 4970 IF( ( N.EQ.0 ).OR.( ( ALPHA.EQ.ZERO ).AND.( BETA.EQ.ONE ) ) ) 4971 $ RETURN 4972* 4973* Set up the start points in X and Y. 4974* 4975 IF( INCX.GT.0 )THEN 4976 KX = 1 4977 ELSE 4978 KX = 1 - ( N - 1 )*INCX 4979 END IF 4980 IF( INCY.GT.0 )THEN 4981 KY = 1 4982 ELSE 4983 KY = 1 - ( N - 1 )*INCY 4984 END IF 4985* 4986* Start the operations. In this version the elements of the array AP 4987* are accessed sequentially with one pass through AP. 4988* 4989* First form y := beta*y. 4990* 4991 IF( BETA.NE.ONE )THEN 4992 IF( INCY.EQ.1 )THEN 4993 IF( BETA.EQ.ZERO )THEN 4994 DO 10, I = 1, N 4995 Y( I ) = ZERO 4996 10 CONTINUE 4997 ELSE 4998 DO 20, I = 1, N 4999 Y( I ) = BETA*Y( I ) 5000 20 CONTINUE 5001 END IF 5002 ELSE 5003 IY = KY 5004 IF( BETA.EQ.ZERO )THEN 5005 DO 30, I = 1, N 5006 Y( IY ) = ZERO 5007 IY = IY + INCY 5008 30 CONTINUE 5009 ELSE 5010 DO 40, I = 1, N 5011 Y( IY ) = BETA*Y( IY ) 5012 IY = IY + INCY 5013 40 CONTINUE 5014 END IF 5015 END IF 5016 END IF 5017 IF( ALPHA.EQ.ZERO ) 5018 $ RETURN 5019 KK = 1 5020 IF( LSAME( UPLO, 'U' ) )THEN 5021* 5022* Form y when AP contains the upper triangle. 5023* 5024 IF( ( INCX.EQ.1 ).AND.( INCY.EQ.1 ) )THEN 5025 DO 60, J = 1, N 5026 TEMP1 = ALPHA*X( J ) 5027 TEMP2 = ZERO 5028 K = KK 5029 DO 50, I = 1, J - 1 5030 Y( I ) = Y( I ) + TEMP1*AP( K ) 5031 TEMP2 = TEMP2 + DCONJG( AP( K ) )*X( I ) 5032 K = K + 1 5033 50 CONTINUE 5034 Y( J ) = Y( J ) + TEMP1*DBLE( AP( KK + J - 1 ) ) 5035 $ + ALPHA*TEMP2 5036 KK = KK + J 5037 60 CONTINUE 5038 ELSE 5039 JX = KX 5040 JY = KY 5041 DO 80, J = 1, N 5042 TEMP1 = ALPHA*X( JX ) 5043 TEMP2 = ZERO 5044 IX = KX 5045 IY = KY 5046 DO 70, K = KK, KK + J - 2 5047 Y( IY ) = Y( IY ) + TEMP1*AP( K ) 5048 TEMP2 = TEMP2 + DCONJG( AP( K ) )*X( IX ) 5049 IX = IX + INCX 5050 IY = IY + INCY 5051 70 CONTINUE 5052 Y( JY ) = Y( JY ) + TEMP1*DBLE( AP( KK + J - 1 ) ) 5053 $ + ALPHA*TEMP2 5054 JX = JX + INCX 5055 JY = JY + INCY 5056 KK = KK + J 5057 80 CONTINUE 5058 END IF 5059 ELSE 5060* 5061* Form y when AP contains the lower triangle. 5062* 5063 IF( ( INCX.EQ.1 ).AND.( INCY.EQ.1 ) )THEN 5064 DO 100, J = 1, N 5065 TEMP1 = ALPHA*X( J ) 5066 TEMP2 = ZERO 5067 Y( J ) = Y( J ) + TEMP1*DBLE( AP( KK ) ) 5068 K = KK + 1 5069 DO 90, I = J + 1, N 5070 Y( I ) = Y( I ) + TEMP1*AP( K ) 5071 TEMP2 = TEMP2 + DCONJG( AP( K ) )*X( I ) 5072 K = K + 1 5073 90 CONTINUE 5074 Y( J ) = Y( J ) + ALPHA*TEMP2 5075 KK = KK + ( N - J + 1 ) 5076 100 CONTINUE 5077 ELSE 5078 JX = KX 5079 JY = KY 5080 DO 120, J = 1, N 5081 TEMP1 = ALPHA*X( JX ) 5082 TEMP2 = ZERO 5083 Y( JY ) = Y( JY ) + TEMP1*DBLE( AP( KK ) ) 5084 IX = JX 5085 IY = JY 5086 DO 110, K = KK + 1, KK + N - J 5087 IX = IX + INCX 5088 IY = IY + INCY 5089 Y( IY ) = Y( IY ) + TEMP1*AP( K ) 5090 TEMP2 = TEMP2 + DCONJG( AP( K ) )*X( IX ) 5091 110 CONTINUE 5092 Y( JY ) = Y( JY ) + ALPHA*TEMP2 5093 JX = JX + INCX 5094 JY = JY + INCY 5095 KK = KK + ( N - J + 1 ) 5096 120 CONTINUE 5097 END IF 5098 END IF 5099* 5100 RETURN 5101* 5102* End of ZHPMV . 5103* 5104 END 5105 SUBROUTINE ZHPR ( UPLO, N, ALPHA, X, INCX, AP ) 5106* .. Scalar Arguments .. 5107 DOUBLE PRECISION ALPHA 5108 INTEGER INCX, N 5109 CHARACTER UPLO 5110* .. Array Arguments .. 5111 DOUBLE COMPLEX AP( * ), X( * ) 5112* .. 5113* 5114* Purpose 5115* ======= 5116* 5117* ZHPR performs the hermitian rank 1 operation 5118* 5119* A := alpha*x*conjg( x' ) + A, 5120* 5121* where alpha is a real scalar, x is an n element vector and A is an 5122* n by n hermitian matrix, supplied in packed form. 5123* 5124* Parameters 5125* ========== 5126* 5127* UPLO - CHARACTER*1. 5128* On entry, UPLO specifies whether the upper or lower 5129* triangular part of the matrix A is supplied in the packed 5130* array AP as follows: 5131* 5132* UPLO = 'U' or 'u' The upper triangular part of A is 5133* supplied in AP. 5134* 5135* UPLO = 'L' or 'l' The lower triangular part of A is 5136* supplied in AP. 5137* 5138* Unchanged on exit. 5139* 5140* N - INTEGER. 5141* On entry, N specifies the order of the matrix A. 5142* N must be at least zero. 5143* Unchanged on exit. 5144* 5145* ALPHA - DOUBLE PRECISION. 5146* On entry, ALPHA specifies the scalar alpha. 5147* Unchanged on exit. 5148* 5149* X - DOUBLE COMPLEX array of dimension at least 5150* ( 1 + ( n - 1 )*abs( INCX ) ). 5151* Before entry, the incremented array X must contain the n 5152* element vector x. 5153* Unchanged on exit. 5154* 5155* INCX - INTEGER. 5156* On entry, INCX specifies the increment for the elements of 5157* X. INCX must not be zero. 5158* Unchanged on exit. 5159* 5160* AP - DOUBLE COMPLEX array of DIMENSION at least 5161* ( ( n*( n + 1 ) )/2 ). 5162* Before entry with UPLO = 'U' or 'u', the array AP must 5163* contain the upper triangular part of the hermitian matrix 5164* packed sequentially, column by column, so that AP( 1 ) 5165* contains a( 1, 1 ), AP( 2 ) and AP( 3 ) contain a( 1, 2 ) 5166* and a( 2, 2 ) respectively, and so on. On exit, the array 5167* AP is overwritten by the upper triangular part of the 5168* updated matrix. 5169* Before entry with UPLO = 'L' or 'l', the array AP must 5170* contain the lower triangular part of the hermitian matrix 5171* packed sequentially, column by column, so that AP( 1 ) 5172* contains a( 1, 1 ), AP( 2 ) and AP( 3 ) contain a( 2, 1 ) 5173* and a( 3, 1 ) respectively, and so on. On exit, the array 5174* AP is overwritten by the lower triangular part of the 5175* updated matrix. 5176* Note that the imaginary parts of the diagonal elements need 5177* not be set, they are assumed to be zero, and on exit they 5178* are set to zero. 5179* 5180* 5181* Level 2 Blas routine. 5182* 5183* -- Written on 22-October-1986. 5184* Jack Dongarra, Argonne National Lab. 5185* Jeremy Du Croz, Nag Central Office. 5186* Sven Hammarling, Nag Central Office. 5187* Richard Hanson, Sandia National Labs. 5188* 5189* 5190* .. Parameters .. 5191 DOUBLE COMPLEX ZERO 5192 PARAMETER ( ZERO = ( 0.0D+0, 0.0D+0 ) ) 5193* .. Local Scalars .. 5194 DOUBLE COMPLEX TEMP 5195 INTEGER I, INFO, IX, J, JX, K, KK, KX 5196* .. External Functions .. 5197 LOGICAL LSAME 5198 EXTERNAL LSAME 5199* .. External Subroutines .. 5200 EXTERNAL XERBLA 5201* .. Intrinsic Functions .. 5202 INTRINSIC DCONJG, DBLE 5203* .. 5204* .. Executable Statements .. 5205* 5206* Test the input parameters. 5207* 5208 INFO = 0 5209 IF ( .NOT.LSAME( UPLO, 'U' ).AND. 5210 $ .NOT.LSAME( UPLO, 'L' ) )THEN 5211 INFO = 1 5212 ELSE IF( N.LT.0 )THEN 5213 INFO = 2 5214 ELSE IF( INCX.EQ.0 )THEN 5215 INFO = 5 5216 END IF 5217 IF( INFO.NE.0 )THEN 5218 CALL XERBLA( 'ZHPR ', INFO ) 5219 RETURN 5220 END IF 5221* 5222* Quick return if possible. 5223* 5224 IF( ( N.EQ.0 ).OR.( ALPHA.EQ.DBLE( ZERO ) ) ) 5225 $ RETURN 5226* 5227* Set the start point in X if the increment is not unity. 5228* 5229 IF( INCX.LE.0 )THEN 5230 KX = 1 - ( N - 1 )*INCX 5231 ELSE IF( INCX.NE.1 )THEN 5232 KX = 1 5233 END IF 5234* 5235* Start the operations. In this version the elements of the array AP 5236* are accessed sequentially with one pass through AP. 5237* 5238 KK = 1 5239 IF( LSAME( UPLO, 'U' ) )THEN 5240* 5241* Form A when upper triangle is stored in AP. 5242* 5243 IF( INCX.EQ.1 )THEN 5244 DO 20, J = 1, N 5245c IF( X( J ).NE.ZERO )THEN 5246 TEMP = ALPHA*DCONJG( X( J ) ) 5247 K = KK 5248 DO 10, I = 1, J - 1 5249 AP( K ) = AP( K ) + X( I )*TEMP 5250 K = K + 1 5251 10 CONTINUE 5252 AP( KK + J - 1 ) = DBLE( AP( KK + J - 1 ) ) 5253 $ + DBLE( X( J )*TEMP ) 5254c ELSE 5255c AP( KK + J - 1 ) = DBLE( AP( KK + J - 1 ) ) 5256c END IF 5257 KK = KK + J 5258 20 CONTINUE 5259 ELSE 5260 JX = KX 5261 DO 40, J = 1, N 5262c IF( X( JX ).NE.ZERO )THEN 5263 TEMP = ALPHA*DCONJG( X( JX ) ) 5264 IX = KX 5265 DO 30, K = KK, KK + J - 2 5266 AP( K ) = AP( K ) + X( IX )*TEMP 5267 IX = IX + INCX 5268 30 CONTINUE 5269 AP( KK + J - 1 ) = DBLE( AP( KK + J - 1 ) ) 5270 $ + DBLE( X( JX )*TEMP ) 5271c ELSE 5272c AP( KK + J - 1 ) = DBLE( AP( KK + J - 1 ) ) 5273c END IF 5274 JX = JX + INCX 5275 KK = KK + J 5276 40 CONTINUE 5277 END IF 5278 ELSE 5279* 5280* Form A when lower triangle is stored in AP. 5281* 5282 IF( INCX.EQ.1 )THEN 5283 DO 60, J = 1, N 5284c IF( X( J ).NE.ZERO )THEN 5285 TEMP = ALPHA*DCONJG( X( J ) ) 5286 AP( KK ) = DBLE( AP( KK ) ) + DBLE( TEMP*X( J ) ) 5287 K = KK + 1 5288 DO 50, I = J + 1, N 5289 AP( K ) = AP( K ) + X( I )*TEMP 5290 K = K + 1 5291 50 CONTINUE 5292c ELSE 5293c AP( KK ) = DBLE( AP( KK ) ) 5294c END IF 5295 KK = KK + N - J + 1 5296 60 CONTINUE 5297 ELSE 5298 JX = KX 5299 DO 80, J = 1, N 5300c IF( X( JX ).NE.ZERO )THEN 5301 TEMP = ALPHA*DCONJG( X( JX ) ) 5302 AP( KK ) = DBLE( AP( KK ) ) + DBLE( TEMP*X( JX ) ) 5303 IX = JX 5304 DO 70, K = KK + 1, KK + N - J 5305 IX = IX + INCX 5306 AP( K ) = AP( K ) + X( IX )*TEMP 5307 70 CONTINUE 5308c ELSE 5309c AP( KK ) = DBLE( AP( KK ) ) 5310c END IF 5311 JX = JX + INCX 5312 KK = KK + N - J + 1 5313 80 CONTINUE 5314 END IF 5315 END IF 5316* 5317 RETURN 5318* 5319* End of ZHPR . 5320* 5321 END 5322 SUBROUTINE ZHPR2 ( UPLO, N, ALPHA, X, INCX, Y, INCY, AP ) 5323* .. Scalar Arguments .. 5324 DOUBLE COMPLEX ALPHA 5325 INTEGER INCX, INCY, N 5326 CHARACTER UPLO 5327* .. Array Arguments .. 5328 DOUBLE COMPLEX AP( * ), X( * ), Y( * ) 5329* .. 5330* 5331* Purpose 5332* ======= 5333* 5334* ZHPR2 performs the hermitian rank 2 operation 5335* 5336* A := alpha*x*conjg( y' ) + conjg( alpha )*y*conjg( x' ) + A, 5337* 5338* where alpha is a scalar, x and y are n element vectors and A is an 5339* n by n hermitian matrix, supplied in packed form. 5340* 5341* Parameters 5342* ========== 5343* 5344* UPLO - CHARACTER*1. 5345* On entry, UPLO specifies whether the upper or lower 5346* triangular part of the matrix A is supplied in the packed 5347* array AP as follows: 5348* 5349* UPLO = 'U' or 'u' The upper triangular part of A is 5350* supplied in AP. 5351* 5352* UPLO = 'L' or 'l' The lower triangular part of A is 5353* supplied in AP. 5354* 5355* Unchanged on exit. 5356* 5357* N - INTEGER. 5358* On entry, N specifies the order of the matrix A. 5359* N must be at least zero. 5360* Unchanged on exit. 5361* 5362* ALPHA - DOUBLE COMPLEX . 5363* On entry, ALPHA specifies the scalar alpha. 5364* Unchanged on exit. 5365* 5366* X - DOUBLE COMPLEX array of dimension at least 5367* ( 1 + ( n - 1 )*abs( INCX ) ). 5368* Before entry, the incremented array X must contain the n 5369* element vector x. 5370* Unchanged on exit. 5371* 5372* INCX - INTEGER. 5373* On entry, INCX specifies the increment for the elements of 5374* X. INCX must not be zero. 5375* Unchanged on exit. 5376* 5377* Y - DOUBLE COMPLEX array of dimension at least 5378* ( 1 + ( n - 1 )*abs( INCY ) ). 5379* Before entry, the incremented array Y must contain the n 5380* element vector y. 5381* Unchanged on exit. 5382* 5383* INCY - INTEGER. 5384* On entry, INCY specifies the increment for the elements of 5385* Y. INCY must not be zero. 5386* Unchanged on exit. 5387* 5388* AP - DOUBLE COMPLEX array of DIMENSION at least 5389* ( ( n*( n + 1 ) )/2 ). 5390* Before entry with UPLO = 'U' or 'u', the array AP must 5391* contain the upper triangular part of the hermitian matrix 5392* packed sequentially, column by column, so that AP( 1 ) 5393* contains a( 1, 1 ), AP( 2 ) and AP( 3 ) contain a( 1, 2 ) 5394* and a( 2, 2 ) respectively, and so on. On exit, the array 5395* AP is overwritten by the upper triangular part of the 5396* updated matrix. 5397* Before entry with UPLO = 'L' or 'l', the array AP must 5398* contain the lower triangular part of the hermitian matrix 5399* packed sequentially, column by column, so that AP( 1 ) 5400* contains a( 1, 1 ), AP( 2 ) and AP( 3 ) contain a( 2, 1 ) 5401* and a( 3, 1 ) respectively, and so on. On exit, the array 5402* AP is overwritten by the lower triangular part of the 5403* updated matrix. 5404* Note that the imaginary parts of the diagonal elements need 5405* not be set, they are assumed to be zero, and on exit they 5406* are set to zero. 5407* 5408* 5409* Level 2 Blas routine. 5410* 5411* -- Written on 22-October-1986. 5412* Jack Dongarra, Argonne National Lab. 5413* Jeremy Du Croz, Nag Central Office. 5414* Sven Hammarling, Nag Central Office. 5415* Richard Hanson, Sandia National Labs. 5416* 5417* 5418* .. Parameters .. 5419 DOUBLE COMPLEX ZERO 5420 PARAMETER ( ZERO = ( 0.0D+0, 0.0D+0 ) ) 5421* .. Local Scalars .. 5422 DOUBLE COMPLEX TEMP1, TEMP2 5423 INTEGER I, INFO, IX, IY, J, JX, JY, K, KK, KX, KY 5424* .. External Functions .. 5425 LOGICAL LSAME 5426 EXTERNAL LSAME 5427* .. External Subroutines .. 5428 EXTERNAL XERBLA 5429* .. Intrinsic Functions .. 5430 INTRINSIC DCONJG, DBLE 5431* .. 5432* .. Executable Statements .. 5433* 5434* Test the input parameters. 5435* 5436 INFO = 0 5437 IF ( .NOT.LSAME( UPLO, 'U' ).AND. 5438 $ .NOT.LSAME( UPLO, 'L' ) )THEN 5439 INFO = 1 5440 ELSE IF( N.LT.0 )THEN 5441 INFO = 2 5442 ELSE IF( INCX.EQ.0 )THEN 5443 INFO = 5 5444 ELSE IF( INCY.EQ.0 )THEN 5445 INFO = 7 5446 END IF 5447 IF( INFO.NE.0 )THEN 5448 CALL XERBLA( 'ZHPR2 ', INFO ) 5449 RETURN 5450 END IF 5451* 5452* Quick return if possible. 5453* 5454 IF( ( N.EQ.0 ).OR.( ALPHA.EQ.ZERO ) ) 5455 $ RETURN 5456* 5457* Set up the start points in X and Y if the increments are not both 5458* unity. 5459* 5460 IF( ( INCX.NE.1 ).OR.( INCY.NE.1 ) )THEN 5461 IF( INCX.GT.0 )THEN 5462 KX = 1 5463 ELSE 5464 KX = 1 - ( N - 1 )*INCX 5465 END IF 5466 IF( INCY.GT.0 )THEN 5467 KY = 1 5468 ELSE 5469 KY = 1 - ( N - 1 )*INCY 5470 END IF 5471 JX = KX 5472 JY = KY 5473 END IF 5474* 5475* Start the operations. In this version the elements of the array AP 5476* are accessed sequentially with one pass through AP. 5477* 5478 KK = 1 5479 IF( LSAME( UPLO, 'U' ) )THEN 5480* 5481* Form A when upper triangle is stored in AP. 5482* 5483 IF( ( INCX.EQ.1 ).AND.( INCY.EQ.1 ) )THEN 5484 DO 20, J = 1, N 5485c IF( ( X( J ).NE.ZERO ).OR.( Y( J ).NE.ZERO ) )THEN 5486 TEMP1 = ALPHA*DCONJG( Y( J ) ) 5487 TEMP2 = DCONJG( ALPHA*X( J ) ) 5488 K = KK 5489 DO 10, I = 1, J - 1 5490 AP( K ) = AP( K ) + X( I )*TEMP1 + Y( I )*TEMP2 5491 K = K + 1 5492 10 CONTINUE 5493 AP( KK + J - 1 ) = DBLE( AP( KK + J - 1 ) ) + 5494 $ DBLE( X( J )*TEMP1 + Y( J )*TEMP2 ) 5495c ELSE 5496c AP( KK + J - 1 ) = DBLE( AP( KK + J - 1 ) ) 5497c END IF 5498 KK = KK + J 5499 20 CONTINUE 5500 ELSE 5501 DO 40, J = 1, N 5502c IF( ( X( JX ).NE.ZERO ).OR.( Y( JY ).NE.ZERO ) )THEN 5503 TEMP1 = ALPHA*DCONJG( Y( JY ) ) 5504 TEMP2 = DCONJG( ALPHA*X( JX ) ) 5505 IX = KX 5506 IY = KY 5507 DO 30, K = KK, KK + J - 2 5508 AP( K ) = AP( K ) + X( IX )*TEMP1 + Y( IY )*TEMP2 5509 IX = IX + INCX 5510 IY = IY + INCY 5511 30 CONTINUE 5512 AP( KK + J - 1 ) = DBLE( AP( KK + J - 1 ) ) + 5513 $ DBLE( X( JX )*TEMP1 + 5514 $ Y( JY )*TEMP2 ) 5515c ELSE 5516c AP( KK + J - 1 ) = DBLE( AP( KK + J - 1 ) ) 5517c END IF 5518 JX = JX + INCX 5519 JY = JY + INCY 5520 KK = KK + J 5521 40 CONTINUE 5522 END IF 5523 ELSE 5524* 5525* Form A when lower triangle is stored in AP. 5526* 5527 IF( ( INCX.EQ.1 ).AND.( INCY.EQ.1 ) )THEN 5528 DO 60, J = 1, N 5529c IF( ( X( J ).NE.ZERO ).OR.( Y( J ).NE.ZERO ) )THEN 5530 TEMP1 = ALPHA*DCONJG( Y( J ) ) 5531 TEMP2 = DCONJG( ALPHA*X( J ) ) 5532 AP( KK ) = DBLE( AP( KK ) ) + 5533 $ DBLE( X( J )*TEMP1 + Y( J )*TEMP2 ) 5534 K = KK + 1 5535 DO 50, I = J + 1, N 5536 AP( K ) = AP( K ) + X( I )*TEMP1 + Y( I )*TEMP2 5537 K = K + 1 5538 50 CONTINUE 5539c ELSE 5540c AP( KK ) = DBLE( AP( KK ) ) 5541c END IF 5542 KK = KK + N - J + 1 5543 60 CONTINUE 5544 ELSE 5545 DO 80, J = 1, N 5546c IF( ( X( JX ).NE.ZERO ).OR.( Y( JY ).NE.ZERO ) )THEN 5547 TEMP1 = ALPHA*DCONJG( Y( JY ) ) 5548 TEMP2 = DCONJG( ALPHA*X( JX ) ) 5549 AP( KK ) = DBLE( AP( KK ) ) + 5550 $ DBLE( X( JX )*TEMP1 + Y( JY )*TEMP2 ) 5551 IX = JX 5552 IY = JY 5553 DO 70, K = KK + 1, KK + N - J 5554 IX = IX + INCX 5555 IY = IY + INCY 5556 AP( K ) = AP( K ) + X( IX )*TEMP1 + Y( IY )*TEMP2 5557 70 CONTINUE 5558c ELSE 5559c AP( KK ) = DBLE( AP( KK ) ) 5560c END IF 5561 JX = JX + INCX 5562 JY = JY + INCY 5563 KK = KK + N - J + 1 5564 80 CONTINUE 5565 END IF 5566 END IF 5567* 5568 RETURN 5569* 5570* End of ZHPR2 . 5571* 5572 END 5573 subroutine zrotg(ca,cb,c,s) 5574 double complex ca,cb,s 5575 double precision c 5576 double precision norm,scale 5577 double complex alpha 5578 intrinsic dconjg, dcmplx 5579 if (cdabs(ca) .ne. 0.0d0) go to 10 5580 c = 0.0d0 5581 s = (1.0d0,0.0d0) 5582 ca = cb 5583 go to 20 5584 10 continue 5585 scale = cdabs(ca) + cdabs(cb) 5586 norm = scale*dsqrt((cdabs(ca/dcmplx(scale,0.0d0)))**2 + 5587 * (cdabs(cb/dcmplx(scale,0.0d0)))**2) 5588 alpha = ca /cdabs(ca) 5589 c = cdabs(ca) / norm 5590 s = alpha * dconjg(cb) / norm 5591 ca = alpha * norm 5592 20 continue 5593 return 5594 end 5595 SUBROUTINE ZSYMM ( SIDE, UPLO, M, N, ALPHA, A, LDA, B, LDB, 5596 $ BETA, C, LDC ) 5597* .. Scalar Arguments .. 5598 CHARACTER SIDE, UPLO 5599 INTEGER M, N, LDA, LDB, LDC 5600 DOUBLE COMPLEX ALPHA, BETA 5601* .. Array Arguments .. 5602 DOUBLE COMPLEX A( LDA, * ), B( LDB, * ), C( LDC, * ) 5603* .. 5604* 5605* Purpose 5606* ======= 5607* 5608* ZSYMM performs one of the matrix-matrix operations 5609* 5610* C := alpha*A*B + beta*C, 5611* 5612* or 5613* 5614* C := alpha*B*A + beta*C, 5615* 5616* where alpha and beta are scalars, A is a symmetric matrix and B and 5617* C are m by n matrices. 5618* 5619* Parameters 5620* ========== 5621* 5622* SIDE - CHARACTER*1. 5623* On entry, SIDE specifies whether the symmetric matrix A 5624* appears on the left or right in the operation as follows: 5625* 5626* SIDE = 'L' or 'l' C := alpha*A*B + beta*C, 5627* 5628* SIDE = 'R' or 'r' C := alpha*B*A + beta*C, 5629* 5630* Unchanged on exit. 5631* 5632* UPLO - CHARACTER*1. 5633* On entry, UPLO specifies whether the upper or lower 5634* triangular part of the symmetric matrix A is to be 5635* referenced as follows: 5636* 5637* UPLO = 'U' or 'u' Only the upper triangular part of the 5638* symmetric matrix is to be referenced. 5639* 5640* UPLO = 'L' or 'l' Only the lower triangular part of the 5641* symmetric matrix is to be referenced. 5642* 5643* Unchanged on exit. 5644* 5645* M - INTEGER. 5646* On entry, M specifies the number of rows of the matrix C. 5647* M must be at least zero. 5648* Unchanged on exit. 5649* 5650* N - INTEGER. 5651* On entry, N specifies the number of columns of the matrix C. 5652* N must be at least zero. 5653* Unchanged on exit. 5654* 5655* ALPHA - DOUBLE COMPLEX . 5656* On entry, ALPHA specifies the scalar alpha. 5657* Unchanged on exit. 5658* 5659* A - DOUBLE COMPLEX array of DIMENSION ( LDA, ka ), where ka is 5660* m when SIDE = 'L' or 'l' and is n otherwise. 5661* Before entry with SIDE = 'L' or 'l', the m by m part of 5662* the array A must contain the symmetric matrix, such that 5663* when UPLO = 'U' or 'u', the leading m by m upper triangular 5664* part of the array A must contain the upper triangular part 5665* of the symmetric matrix and the strictly lower triangular 5666* part of A is not referenced, and when UPLO = 'L' or 'l', 5667* the leading m by m lower triangular part of the array A 5668* must contain the lower triangular part of the symmetric 5669* matrix and the strictly upper triangular part of A is not 5670* referenced. 5671* Before entry with SIDE = 'R' or 'r', the n by n part of 5672* the array A must contain the symmetric matrix, such that 5673* when UPLO = 'U' or 'u', the leading n by n upper triangular 5674* part of the array A must contain the upper triangular part 5675* of the symmetric matrix and the strictly lower triangular 5676* part of A is not referenced, and when UPLO = 'L' or 'l', 5677* the leading n by n lower triangular part of the array A 5678* must contain the lower triangular part of the symmetric 5679* matrix and the strictly upper triangular part of A is not 5680* referenced. 5681* Unchanged on exit. 5682* 5683* LDA - INTEGER. 5684* On entry, LDA specifies the first dimension of A as declared 5685* in the calling (sub) program. When SIDE = 'L' or 'l' then 5686* LDA must be at least max( 1, m ), otherwise LDA must be at 5687* least max( 1, n ). 5688* Unchanged on exit. 5689* 5690* B - DOUBLE COMPLEX array of DIMENSION ( LDB, n ). 5691* Before entry, the leading m by n part of the array B must 5692* contain the matrix B. 5693* Unchanged on exit. 5694* 5695* LDB - INTEGER. 5696* On entry, LDB specifies the first dimension of B as declared 5697* in the calling (sub) program. LDB must be at least 5698* max( 1, m ). 5699* Unchanged on exit. 5700* 5701* BETA - DOUBLE COMPLEX . 5702* On entry, BETA specifies the scalar beta. When BETA is 5703* supplied as zero then C need not be set on input. 5704* Unchanged on exit. 5705* 5706* C - DOUBLE COMPLEX array of DIMENSION ( LDC, n ). 5707* Before entry, the leading m by n part of the array C must 5708* contain the matrix C, except when beta is zero, in which 5709* case C need not be set on entry. 5710* On exit, the array C is overwritten by the m by n updated 5711* matrix. 5712* 5713* LDC - INTEGER. 5714* On entry, LDC specifies the first dimension of C as declared 5715* in the calling (sub) program. LDC must be at least 5716* max( 1, m ). 5717* Unchanged on exit. 5718* 5719* 5720* Level 3 Blas routine. 5721* 5722* -- Written on 8-February-1989. 5723* Jack Dongarra, Argonne National Laboratory. 5724* Iain Duff, AERE Harwell. 5725* Jeremy Du Croz, Numerical Algorithms Group Ltd. 5726* Sven Hammarling, Numerical Algorithms Group Ltd. 5727* 5728* 5729* .. External Functions .. 5730 LOGICAL LSAME 5731 EXTERNAL LSAME 5732* .. External Subroutines .. 5733 EXTERNAL XERBLA 5734* .. Intrinsic Functions .. 5735 INTRINSIC MAX 5736* .. Local Scalars .. 5737 LOGICAL UPPER 5738 INTEGER I, INFO, J, K, NROWA 5739 DOUBLE COMPLEX TEMP1, TEMP2 5740* .. Parameters .. 5741 DOUBLE COMPLEX ONE 5742 PARAMETER ( ONE = ( 1.0D+0, 0.0D+0 ) ) 5743 DOUBLE COMPLEX ZERO 5744 PARAMETER ( ZERO = ( 0.0D+0, 0.0D+0 ) ) 5745* .. 5746* .. Executable Statements .. 5747* 5748* Set NROWA as the number of rows of A. 5749* 5750 IF( LSAME( SIDE, 'L' ) )THEN 5751 NROWA = M 5752 ELSE 5753 NROWA = N 5754 END IF 5755 UPPER = LSAME( UPLO, 'U' ) 5756* 5757* Test the input parameters. 5758* 5759 INFO = 0 5760 IF( ( .NOT.LSAME( SIDE, 'L' ) ).AND. 5761 $ ( .NOT.LSAME( SIDE, 'R' ) ) )THEN 5762 INFO = 1 5763 ELSE IF( ( .NOT.UPPER ).AND. 5764 $ ( .NOT.LSAME( UPLO, 'L' ) ) )THEN 5765 INFO = 2 5766 ELSE IF( M .LT.0 )THEN 5767 INFO = 3 5768 ELSE IF( N .LT.0 )THEN 5769 INFO = 4 5770 ELSE IF( LDA.LT.MAX( 1, NROWA ) )THEN 5771 INFO = 7 5772 ELSE IF( LDB.LT.MAX( 1, M ) )THEN 5773 INFO = 9 5774 ELSE IF( LDC.LT.MAX( 1, M ) )THEN 5775 INFO = 12 5776 END IF 5777 IF( INFO.NE.0 )THEN 5778 CALL XERBLA( 'ZSYMM ', INFO ) 5779 RETURN 5780 END IF 5781* 5782* Quick return if possible. 5783* 5784 IF( ( M.EQ.0 ).OR.( N.EQ.0 ).OR. 5785 $ ( ( ALPHA.EQ.ZERO ).AND.( BETA.EQ.ONE ) ) ) 5786 $ RETURN 5787* 5788* And when alpha.eq.zero. 5789* 5790 IF( ALPHA.EQ.ZERO )THEN 5791 IF( BETA.EQ.ZERO )THEN 5792 DO 20, J = 1, N 5793 DO 10, I = 1, M 5794 C( I, J ) = ZERO 5795 10 CONTINUE 5796 20 CONTINUE 5797 ELSE 5798 DO 40, J = 1, N 5799 DO 30, I = 1, M 5800 C( I, J ) = BETA*C( I, J ) 5801 30 CONTINUE 5802 40 CONTINUE 5803 END IF 5804 RETURN 5805 END IF 5806* 5807* Start the operations. 5808* 5809 IF( LSAME( SIDE, 'L' ) )THEN 5810* 5811* Form C := alpha*A*B + beta*C. 5812* 5813 IF( UPPER )THEN 5814 DO 70, J = 1, N 5815 DO 60, I = 1, M 5816 TEMP1 = ALPHA*B( I, J ) 5817 TEMP2 = ZERO 5818 DO 50, K = 1, I - 1 5819 C( K, J ) = C( K, J ) + TEMP1 *A( K, I ) 5820 TEMP2 = TEMP2 + B( K, J )*A( K, I ) 5821 50 CONTINUE 5822 IF( BETA.EQ.ZERO )THEN 5823 C( I, J ) = TEMP1*A( I, I ) + ALPHA*TEMP2 5824 ELSE 5825 C( I, J ) = BETA *C( I, J ) + 5826 $ TEMP1*A( I, I ) + ALPHA*TEMP2 5827 END IF 5828 60 CONTINUE 5829 70 CONTINUE 5830 ELSE 5831 DO 100, J = 1, N 5832 DO 90, I = M, 1, -1 5833 TEMP1 = ALPHA*B( I, J ) 5834 TEMP2 = ZERO 5835 DO 80, K = I + 1, M 5836 C( K, J ) = C( K, J ) + TEMP1 *A( K, I ) 5837 TEMP2 = TEMP2 + B( K, J )*A( K, I ) 5838 80 CONTINUE 5839 IF( BETA.EQ.ZERO )THEN 5840 C( I, J ) = TEMP1*A( I, I ) + ALPHA*TEMP2 5841 ELSE 5842 C( I, J ) = BETA *C( I, J ) + 5843 $ TEMP1*A( I, I ) + ALPHA*TEMP2 5844 END IF 5845 90 CONTINUE 5846 100 CONTINUE 5847 END IF 5848 ELSE 5849* 5850* Form C := alpha*B*A + beta*C. 5851* 5852 DO 170, J = 1, N 5853 TEMP1 = ALPHA*A( J, J ) 5854 IF( BETA.EQ.ZERO )THEN 5855 DO 110, I = 1, M 5856 C( I, J ) = TEMP1*B( I, J ) 5857 110 CONTINUE 5858 ELSE 5859 DO 120, I = 1, M 5860 C( I, J ) = BETA*C( I, J ) + TEMP1*B( I, J ) 5861 120 CONTINUE 5862 END IF 5863 DO 140, K = 1, J - 1 5864 IF( UPPER )THEN 5865 TEMP1 = ALPHA*A( K, J ) 5866 ELSE 5867 TEMP1 = ALPHA*A( J, K ) 5868 END IF 5869 DO 130, I = 1, M 5870 C( I, J ) = C( I, J ) + TEMP1*B( I, K ) 5871 130 CONTINUE 5872 140 CONTINUE 5873 DO 160, K = J + 1, N 5874 IF( UPPER )THEN 5875 TEMP1 = ALPHA*A( J, K ) 5876 ELSE 5877 TEMP1 = ALPHA*A( K, J ) 5878 END IF 5879 DO 150, I = 1, M 5880 C( I, J ) = C( I, J ) + TEMP1*B( I, K ) 5881 150 CONTINUE 5882 160 CONTINUE 5883 170 CONTINUE 5884 END IF 5885* 5886 RETURN 5887* 5888* End of ZSYMM . 5889* 5890 END 5891 SUBROUTINE ZSYR2K( UPLO, TRANS, N, K, ALPHA, A, LDA, B, LDB, 5892 $ BETA, C, LDC ) 5893* .. Scalar Arguments .. 5894 CHARACTER UPLO, TRANS 5895 INTEGER N, K, LDA, LDB, LDC 5896 DOUBLE COMPLEX ALPHA, BETA 5897* .. Array Arguments .. 5898 DOUBLE COMPLEX A( LDA, * ), B( LDB, * ), C( LDC, * ) 5899* .. 5900* 5901* Purpose 5902* ======= 5903* 5904* ZSYR2K performs one of the symmetric rank 2k operations 5905* 5906* C := alpha*A*B' + alpha*B*A' + beta*C, 5907* 5908* or 5909* 5910* C := alpha*A'*B + alpha*B'*A + beta*C, 5911* 5912* where alpha and beta are scalars, C is an n by n symmetric matrix 5913* and A and B are n by k matrices in the first case and k by n 5914* matrices in the second case. 5915* 5916* Parameters 5917* ========== 5918* 5919* UPLO - CHARACTER*1. 5920* On entry, UPLO specifies whether the upper or lower 5921* triangular part of the array C is to be referenced as 5922* follows: 5923* 5924* UPLO = 'U' or 'u' Only the upper triangular part of C 5925* is to be referenced. 5926* 5927* UPLO = 'L' or 'l' Only the lower triangular part of C 5928* is to be referenced. 5929* 5930* Unchanged on exit. 5931* 5932* TRANS - CHARACTER*1. 5933* On entry, TRANS specifies the operation to be performed as 5934* follows: 5935* 5936* TRANS = 'N' or 'n' C := alpha*A*B' + alpha*B*A' + 5937* beta*C. 5938* 5939* TRANS = 'T' or 't' C := alpha*A'*B + alpha*B'*A + 5940* beta*C. 5941* 5942* Unchanged on exit. 5943* 5944* N - INTEGER. 5945* On entry, N specifies the order of the matrix C. N must be 5946* at least zero. 5947* Unchanged on exit. 5948* 5949* K - INTEGER. 5950* On entry with TRANS = 'N' or 'n', K specifies the number 5951* of columns of the matrices A and B, and on entry with 5952* TRANS = 'T' or 't', K specifies the number of rows of the 5953* matrices A and B. K must be at least zero. 5954* Unchanged on exit. 5955* 5956* ALPHA - DOUBLE COMPLEX . 5957* On entry, ALPHA specifies the scalar alpha. 5958* Unchanged on exit. 5959* 5960* A - DOUBLE COMPLEX array of DIMENSION ( LDA, ka ), where ka is 5961* k when TRANS = 'N' or 'n', and is n otherwise. 5962* Before entry with TRANS = 'N' or 'n', the leading n by k 5963* part of the array A must contain the matrix A, otherwise 5964* the leading k by n part of the array A must contain the 5965* matrix A. 5966* Unchanged on exit. 5967* 5968* LDA - INTEGER. 5969* On entry, LDA specifies the first dimension of A as declared 5970* in the calling (sub) program. When TRANS = 'N' or 'n' 5971* then LDA must be at least max( 1, n ), otherwise LDA must 5972* be at least max( 1, k ). 5973* Unchanged on exit. 5974* 5975* B - DOUBLE COMPLEX array of DIMENSION ( LDB, kb ), where kb is 5976* k when TRANS = 'N' or 'n', and is n otherwise. 5977* Before entry with TRANS = 'N' or 'n', the leading n by k 5978* part of the array B must contain the matrix B, otherwise 5979* the leading k by n part of the array B must contain the 5980* matrix B. 5981* Unchanged on exit. 5982* 5983* LDB - INTEGER. 5984* On entry, LDB specifies the first dimension of B as declared 5985* in the calling (sub) program. When TRANS = 'N' or 'n' 5986* then LDB must be at least max( 1, n ), otherwise LDB must 5987* be at least max( 1, k ). 5988* Unchanged on exit. 5989* 5990* BETA - DOUBLE COMPLEX . 5991* On entry, BETA specifies the scalar beta. 5992* Unchanged on exit. 5993* 5994* C - DOUBLE COMPLEX array of DIMENSION ( LDC, n ). 5995* Before entry with UPLO = 'U' or 'u', the leading n by n 5996* upper triangular part of the array C must contain the upper 5997* triangular part of the symmetric matrix and the strictly 5998* lower triangular part of C is not referenced. On exit, the 5999* upper triangular part of the array C is overwritten by the 6000* upper triangular part of the updated matrix. 6001* Before entry with UPLO = 'L' or 'l', the leading n by n 6002* lower triangular part of the array C must contain the lower 6003* triangular part of the symmetric matrix and the strictly 6004* upper triangular part of C is not referenced. On exit, the 6005* lower triangular part of the array C is overwritten by the 6006* lower triangular part of the updated matrix. 6007* 6008* LDC - INTEGER. 6009* On entry, LDC specifies the first dimension of C as declared 6010* in the calling (sub) program. LDC must be at least 6011* max( 1, n ). 6012* Unchanged on exit. 6013* 6014* 6015* Level 3 Blas routine. 6016* 6017* -- Written on 8-February-1989. 6018* Jack Dongarra, Argonne National Laboratory. 6019* Iain Duff, AERE Harwell. 6020* Jeremy Du Croz, Numerical Algorithms Group Ltd. 6021* Sven Hammarling, Numerical Algorithms Group Ltd. 6022* 6023* 6024* .. External Functions .. 6025 LOGICAL LSAME 6026 EXTERNAL LSAME 6027* .. External Subroutines .. 6028 EXTERNAL XERBLA 6029* .. Intrinsic Functions .. 6030 INTRINSIC MAX 6031* .. Local Scalars .. 6032 LOGICAL UPPER 6033 INTEGER I, INFO, J, L, NROWA 6034 DOUBLE COMPLEX TEMP1, TEMP2 6035* .. Parameters .. 6036 DOUBLE COMPLEX ONE 6037 PARAMETER ( ONE = ( 1.0D+0, 0.0D+0 ) ) 6038 DOUBLE COMPLEX ZERO 6039 PARAMETER ( ZERO = ( 0.0D+0, 0.0D+0 ) ) 6040* .. 6041* .. Executable Statements .. 6042* 6043* Test the input parameters. 6044* 6045 IF( LSAME( TRANS, 'N' ) )THEN 6046 NROWA = N 6047 ELSE 6048 NROWA = K 6049 END IF 6050 UPPER = LSAME( UPLO, 'U' ) 6051* 6052 INFO = 0 6053 IF( ( .NOT.UPPER ).AND. 6054 $ ( .NOT.LSAME( UPLO , 'L' ) ) )THEN 6055 INFO = 1 6056 ELSE IF( ( .NOT.LSAME( TRANS, 'N' ) ).AND. 6057 $ ( .NOT.LSAME( TRANS, 'T' ) ) )THEN 6058 INFO = 2 6059 ELSE IF( N .LT.0 )THEN 6060 INFO = 3 6061 ELSE IF( K .LT.0 )THEN 6062 INFO = 4 6063 ELSE IF( LDA.LT.MAX( 1, NROWA ) )THEN 6064 INFO = 7 6065 ELSE IF( LDB.LT.MAX( 1, NROWA ) )THEN 6066 INFO = 9 6067 ELSE IF( LDC.LT.MAX( 1, N ) )THEN 6068 INFO = 12 6069 END IF 6070 IF( INFO.NE.0 )THEN 6071 CALL XERBLA( 'ZSYR2K', INFO ) 6072 RETURN 6073 END IF 6074* 6075* Quick return if possible. 6076* 6077 IF( ( N.EQ.0 ).OR. 6078 $ ( ( ( ALPHA.EQ.ZERO ).OR.( K.EQ.0 ) ).AND.( BETA.EQ.ONE ) ) ) 6079 $ RETURN 6080* 6081* And when alpha.eq.zero. 6082* 6083 IF( ALPHA.EQ.ZERO )THEN 6084 IF( UPPER )THEN 6085 IF( BETA.EQ.ZERO )THEN 6086 DO 20, J = 1, N 6087 DO 10, I = 1, J 6088 C( I, J ) = ZERO 6089 10 CONTINUE 6090 20 CONTINUE 6091 ELSE 6092 DO 40, J = 1, N 6093 DO 30, I = 1, J 6094 C( I, J ) = BETA*C( I, J ) 6095 30 CONTINUE 6096 40 CONTINUE 6097 END IF 6098 ELSE 6099 IF( BETA.EQ.ZERO )THEN 6100 DO 60, J = 1, N 6101 DO 50, I = J, N 6102 C( I, J ) = ZERO 6103 50 CONTINUE 6104 60 CONTINUE 6105 ELSE 6106 DO 80, J = 1, N 6107 DO 70, I = J, N 6108 C( I, J ) = BETA*C( I, J ) 6109 70 CONTINUE 6110 80 CONTINUE 6111 END IF 6112 END IF 6113 RETURN 6114 END IF 6115* 6116* Start the operations. 6117* 6118 IF( LSAME( TRANS, 'N' ) )THEN 6119* 6120* Form C := alpha*A*B' + alpha*B*A' + C. 6121* 6122 IF( UPPER )THEN 6123 DO 130, J = 1, N 6124 IF( BETA.EQ.ZERO )THEN 6125 DO 90, I = 1, J 6126 C( I, J ) = ZERO 6127 90 CONTINUE 6128 ELSE IF( BETA.NE.ONE )THEN 6129 DO 100, I = 1, J 6130 C( I, J ) = BETA*C( I, J ) 6131 100 CONTINUE 6132 END IF 6133 DO 120, L = 1, K 6134c IF( ( A( J, L ).NE.ZERO ).OR. 6135c $ ( B( J, L ).NE.ZERO ) )THEN 6136 TEMP1 = ALPHA*B( J, L ) 6137 TEMP2 = ALPHA*A( J, L ) 6138 DO 110, I = 1, J 6139 C( I, J ) = C( I, J ) + A( I, L )*TEMP1 + 6140 $ B( I, L )*TEMP2 6141 110 CONTINUE 6142c END IF 6143 120 CONTINUE 6144 130 CONTINUE 6145 ELSE 6146 DO 180, J = 1, N 6147 IF( BETA.EQ.ZERO )THEN 6148 DO 140, I = J, N 6149 C( I, J ) = ZERO 6150 140 CONTINUE 6151 ELSE IF( BETA.NE.ONE )THEN 6152 DO 150, I = J, N 6153 C( I, J ) = BETA*C( I, J ) 6154 150 CONTINUE 6155 END IF 6156 DO 170, L = 1, K 6157c IF( ( A( J, L ).NE.ZERO ).OR. 6158c $ ( B( J, L ).NE.ZERO ) )THEN 6159 TEMP1 = ALPHA*B( J, L ) 6160 TEMP2 = ALPHA*A( J, L ) 6161 DO 160, I = J, N 6162 C( I, J ) = C( I, J ) + A( I, L )*TEMP1 + 6163 $ B( I, L )*TEMP2 6164 160 CONTINUE 6165c END IF 6166 170 CONTINUE 6167 180 CONTINUE 6168 END IF 6169 ELSE 6170* 6171* Form C := alpha*A'*B + alpha*B'*A + C. 6172* 6173 IF( UPPER )THEN 6174 DO 210, J = 1, N 6175 DO 200, I = 1, J 6176 TEMP1 = ZERO 6177 TEMP2 = ZERO 6178 DO 190, L = 1, K 6179 TEMP1 = TEMP1 + A( L, I )*B( L, J ) 6180 TEMP2 = TEMP2 + B( L, I )*A( L, J ) 6181 190 CONTINUE 6182 IF( BETA.EQ.ZERO )THEN 6183 C( I, J ) = ALPHA*TEMP1 + ALPHA*TEMP2 6184 ELSE 6185 C( I, J ) = BETA *C( I, J ) + 6186 $ ALPHA*TEMP1 + ALPHA*TEMP2 6187 END IF 6188 200 CONTINUE 6189 210 CONTINUE 6190 ELSE 6191 DO 240, J = 1, N 6192 DO 230, I = J, N 6193 TEMP1 = ZERO 6194 TEMP2 = ZERO 6195 DO 220, L = 1, K 6196 TEMP1 = TEMP1 + A( L, I )*B( L, J ) 6197 TEMP2 = TEMP2 + B( L, I )*A( L, J ) 6198 220 CONTINUE 6199 IF( BETA.EQ.ZERO )THEN 6200 C( I, J ) = ALPHA*TEMP1 + ALPHA*TEMP2 6201 ELSE 6202 C( I, J ) = BETA *C( I, J ) + 6203 $ ALPHA*TEMP1 + ALPHA*TEMP2 6204 END IF 6205 230 CONTINUE 6206 240 CONTINUE 6207 END IF 6208 END IF 6209* 6210 RETURN 6211* 6212* End of ZSYR2K. 6213* 6214 END 6215 SUBROUTINE ZSYRK ( UPLO, TRANS, N, K, ALPHA, A, LDA, 6216 $ BETA, C, LDC ) 6217* .. Scalar Arguments .. 6218 CHARACTER UPLO, TRANS 6219 INTEGER N, K, LDA, LDC 6220 DOUBLE COMPLEX ALPHA, BETA 6221* .. Array Arguments .. 6222 DOUBLE COMPLEX A( LDA, * ), C( LDC, * ) 6223* .. 6224* 6225* Purpose 6226* ======= 6227* 6228* ZSYRK performs one of the symmetric rank k operations 6229* 6230* C := alpha*A*A' + beta*C, 6231* 6232* or 6233* 6234* C := alpha*A'*A + beta*C, 6235* 6236* where alpha and beta are scalars, C is an n by n symmetric matrix 6237* and A is an n by k matrix in the first case and a k by n matrix 6238* in the second case. 6239* 6240* Parameters 6241* ========== 6242* 6243* UPLO - CHARACTER*1. 6244* On entry, UPLO specifies whether the upper or lower 6245* triangular part of the array C is to be referenced as 6246* follows: 6247* 6248* UPLO = 'U' or 'u' Only the upper triangular part of C 6249* is to be referenced. 6250* 6251* UPLO = 'L' or 'l' Only the lower triangular part of C 6252* is to be referenced. 6253* 6254* Unchanged on exit. 6255* 6256* TRANS - CHARACTER*1. 6257* On entry, TRANS specifies the operation to be performed as 6258* follows: 6259* 6260* TRANS = 'N' or 'n' C := alpha*A*A' + beta*C. 6261* 6262* TRANS = 'T' or 't' C := alpha*A'*A + beta*C. 6263* 6264* Unchanged on exit. 6265* 6266* N - INTEGER. 6267* On entry, N specifies the order of the matrix C. N must be 6268* at least zero. 6269* Unchanged on exit. 6270* 6271* K - INTEGER. 6272* On entry with TRANS = 'N' or 'n', K specifies the number 6273* of columns of the matrix A, and on entry with 6274* TRANS = 'T' or 't', K specifies the number of rows of the 6275* matrix A. K must be at least zero. 6276* Unchanged on exit. 6277* 6278* ALPHA - DOUBLE COMPLEX . 6279* On entry, ALPHA specifies the scalar alpha. 6280* Unchanged on exit. 6281* 6282* A - DOUBLE COMPLEX array of DIMENSION ( LDA, ka ), where ka is 6283* k when TRANS = 'N' or 'n', and is n otherwise. 6284* Before entry with TRANS = 'N' or 'n', the leading n by k 6285* part of the array A must contain the matrix A, otherwise 6286* the leading k by n part of the array A must contain the 6287* matrix A. 6288* Unchanged on exit. 6289* 6290* LDA - INTEGER. 6291* On entry, LDA specifies the first dimension of A as declared 6292* in the calling (sub) program. When TRANS = 'N' or 'n' 6293* then LDA must be at least max( 1, n ), otherwise LDA must 6294* be at least max( 1, k ). 6295* Unchanged on exit. 6296* 6297* BETA - DOUBLE COMPLEX . 6298* On entry, BETA specifies the scalar beta. 6299* Unchanged on exit. 6300* 6301* C - DOUBLE COMPLEX array of DIMENSION ( LDC, n ). 6302* Before entry with UPLO = 'U' or 'u', the leading n by n 6303* upper triangular part of the array C must contain the upper 6304* triangular part of the symmetric matrix and the strictly 6305* lower triangular part of C is not referenced. On exit, the 6306* upper triangular part of the array C is overwritten by the 6307* upper triangular part of the updated matrix. 6308* Before entry with UPLO = 'L' or 'l', the leading n by n 6309* lower triangular part of the array C must contain the lower 6310* triangular part of the symmetric matrix and the strictly 6311* upper triangular part of C is not referenced. On exit, the 6312* lower triangular part of the array C is overwritten by the 6313* lower triangular part of the updated matrix. 6314* 6315* LDC - INTEGER. 6316* On entry, LDC specifies the first dimension of C as declared 6317* in the calling (sub) program. LDC must be at least 6318* max( 1, n ). 6319* Unchanged on exit. 6320* 6321* 6322* Level 3 Blas routine. 6323* 6324* -- Written on 8-February-1989. 6325* Jack Dongarra, Argonne National Laboratory. 6326* Iain Duff, AERE Harwell. 6327* Jeremy Du Croz, Numerical Algorithms Group Ltd. 6328* Sven Hammarling, Numerical Algorithms Group Ltd. 6329* 6330* 6331* .. External Functions .. 6332 LOGICAL LSAME 6333 EXTERNAL LSAME 6334* .. External Subroutines .. 6335 EXTERNAL XERBLA 6336* .. Intrinsic Functions .. 6337 INTRINSIC MAX 6338* .. Local Scalars .. 6339 LOGICAL UPPER 6340 INTEGER I, INFO, J, L, NROWA 6341 DOUBLE COMPLEX TEMP 6342* .. Parameters .. 6343 DOUBLE COMPLEX ONE 6344 PARAMETER ( ONE = ( 1.0D+0, 0.0D+0 ) ) 6345 DOUBLE COMPLEX ZERO 6346 PARAMETER ( ZERO = ( 0.0D+0, 0.0D+0 ) ) 6347* .. 6348* .. Executable Statements .. 6349* 6350* Test the input parameters. 6351* 6352 IF( LSAME( TRANS, 'N' ) )THEN 6353 NROWA = N 6354 ELSE 6355 NROWA = K 6356 END IF 6357 UPPER = LSAME( UPLO, 'U' ) 6358* 6359 INFO = 0 6360 IF( ( .NOT.UPPER ).AND. 6361 $ ( .NOT.LSAME( UPLO , 'L' ) ) )THEN 6362 INFO = 1 6363 ELSE IF( ( .NOT.LSAME( TRANS, 'N' ) ).AND. 6364 $ ( .NOT.LSAME( TRANS, 'T' ) ) )THEN 6365 INFO = 2 6366 ELSE IF( N .LT.0 )THEN 6367 INFO = 3 6368 ELSE IF( K .LT.0 )THEN 6369 INFO = 4 6370 ELSE IF( LDA.LT.MAX( 1, NROWA ) )THEN 6371 INFO = 7 6372 ELSE IF( LDC.LT.MAX( 1, N ) )THEN 6373 INFO = 10 6374 END IF 6375 IF( INFO.NE.0 )THEN 6376 CALL XERBLA( 'ZSYRK ', INFO ) 6377 RETURN 6378 END IF 6379* 6380* Quick return if possible. 6381* 6382 IF( ( N.EQ.0 ).OR. 6383 $ ( ( ( ALPHA.EQ.ZERO ).OR.( K.EQ.0 ) ).AND.( BETA.EQ.ONE ) ) ) 6384 $ RETURN 6385* 6386* And when alpha.eq.zero. 6387* 6388 IF( ALPHA.EQ.ZERO )THEN 6389 IF( UPPER )THEN 6390 IF( BETA.EQ.ZERO )THEN 6391 DO 20, J = 1, N 6392 DO 10, I = 1, J 6393 C( I, J ) = ZERO 6394 10 CONTINUE 6395 20 CONTINUE 6396 ELSE 6397 DO 40, J = 1, N 6398 DO 30, I = 1, J 6399 C( I, J ) = BETA*C( I, J ) 6400 30 CONTINUE 6401 40 CONTINUE 6402 END IF 6403 ELSE 6404 IF( BETA.EQ.ZERO )THEN 6405 DO 60, J = 1, N 6406 DO 50, I = J, N 6407 C( I, J ) = ZERO 6408 50 CONTINUE 6409 60 CONTINUE 6410 ELSE 6411 DO 80, J = 1, N 6412 DO 70, I = J, N 6413 C( I, J ) = BETA*C( I, J ) 6414 70 CONTINUE 6415 80 CONTINUE 6416 END IF 6417 END IF 6418 RETURN 6419 END IF 6420* 6421* Start the operations. 6422* 6423 IF( LSAME( TRANS, 'N' ) )THEN 6424* 6425* Form C := alpha*A*A' + beta*C. 6426* 6427 IF( UPPER )THEN 6428 DO 130, J = 1, N 6429 IF( BETA.EQ.ZERO )THEN 6430 DO 90, I = 1, J 6431 C( I, J ) = ZERO 6432 90 CONTINUE 6433 ELSE IF( BETA.NE.ONE )THEN 6434 DO 100, I = 1, J 6435 C( I, J ) = BETA*C( I, J ) 6436 100 CONTINUE 6437 END IF 6438 DO 120, L = 1, K 6439c IF( A( J, L ).NE.ZERO )THEN 6440 TEMP = ALPHA*A( J, L ) 6441 DO 110, I = 1, J 6442 C( I, J ) = C( I, J ) + TEMP*A( I, L ) 6443 110 CONTINUE 6444c END IF 6445 120 CONTINUE 6446 130 CONTINUE 6447 ELSE 6448 DO 180, J = 1, N 6449 IF( BETA.EQ.ZERO )THEN 6450 DO 140, I = J, N 6451 C( I, J ) = ZERO 6452 140 CONTINUE 6453 ELSE IF( BETA.NE.ONE )THEN 6454 DO 150, I = J, N 6455 C( I, J ) = BETA*C( I, J ) 6456 150 CONTINUE 6457 END IF 6458 DO 170, L = 1, K 6459c IF( A( J, L ).NE.ZERO )THEN 6460 TEMP = ALPHA*A( J, L ) 6461 DO 160, I = J, N 6462 C( I, J ) = C( I, J ) + TEMP*A( I, L ) 6463 160 CONTINUE 6464c END IF 6465 170 CONTINUE 6466 180 CONTINUE 6467 END IF 6468 ELSE 6469* 6470* Form C := alpha*A'*A + beta*C. 6471* 6472 IF( UPPER )THEN 6473 DO 210, J = 1, N 6474 DO 200, I = 1, J 6475 TEMP = ZERO 6476 DO 190, L = 1, K 6477 TEMP = TEMP + A( L, I )*A( L, J ) 6478 190 CONTINUE 6479 IF( BETA.EQ.ZERO )THEN 6480 C( I, J ) = ALPHA*TEMP 6481 ELSE 6482 C( I, J ) = ALPHA*TEMP + BETA*C( I, J ) 6483 END IF 6484 200 CONTINUE 6485 210 CONTINUE 6486 ELSE 6487 DO 240, J = 1, N 6488 DO 230, I = J, N 6489 TEMP = ZERO 6490 DO 220, L = 1, K 6491 TEMP = TEMP + A( L, I )*A( L, J ) 6492 220 CONTINUE 6493 IF( BETA.EQ.ZERO )THEN 6494 C( I, J ) = ALPHA*TEMP 6495 ELSE 6496 C( I, J ) = ALPHA*TEMP + BETA*C( I, J ) 6497 END IF 6498 230 CONTINUE 6499 240 CONTINUE 6500 END IF 6501 END IF 6502* 6503 RETURN 6504* 6505* End of ZSYRK . 6506* 6507 END 6508 SUBROUTINE ZTBMV ( UPLO, TRANS, DIAG, N, K, A, LDA, X, INCX ) 6509* .. Scalar Arguments .. 6510 INTEGER INCX, K, LDA, N 6511 CHARACTER DIAG, TRANS, UPLO 6512* .. Array Arguments .. 6513 DOUBLE COMPLEX A( LDA, * ), X( * ) 6514* .. 6515* 6516* Purpose 6517* ======= 6518* 6519* ZTBMV performs one of the matrix-vector operations 6520* 6521* x := A*x, or x := A'*x, or x := conjg( A' )*x, 6522* 6523* where x is an n element vector and A is an n by n unit, or non-unit, 6524* upper or lower triangular band matrix, with ( k + 1 ) diagonals. 6525* 6526* Parameters 6527* ========== 6528* 6529* UPLO - CHARACTER*1. 6530* On entry, UPLO specifies whether the matrix is an upper or 6531* lower triangular matrix as follows: 6532* 6533* UPLO = 'U' or 'u' A is an upper triangular matrix. 6534* 6535* UPLO = 'L' or 'l' A is a lower triangular matrix. 6536* 6537* Unchanged on exit. 6538* 6539* TRANS - CHARACTER*1. 6540* On entry, TRANS specifies the operation to be performed as 6541* follows: 6542* 6543* TRANS = 'N' or 'n' x := A*x. 6544* 6545* TRANS = 'T' or 't' x := A'*x. 6546* 6547* TRANS = 'C' or 'c' x := conjg( A' )*x. 6548* 6549* Unchanged on exit. 6550* 6551* DIAG - CHARACTER*1. 6552* On entry, DIAG specifies whether or not A is unit 6553* triangular as follows: 6554* 6555* DIAG = 'U' or 'u' A is assumed to be unit triangular. 6556* 6557* DIAG = 'N' or 'n' A is not assumed to be unit 6558* triangular. 6559* 6560* Unchanged on exit. 6561* 6562* N - INTEGER. 6563* On entry, N specifies the order of the matrix A. 6564* N must be at least zero. 6565* Unchanged on exit. 6566* 6567* K - INTEGER. 6568* On entry with UPLO = 'U' or 'u', K specifies the number of 6569* super-diagonals of the matrix A. 6570* On entry with UPLO = 'L' or 'l', K specifies the number of 6571* sub-diagonals of the matrix A. 6572* K must satisfy 0 .le. K. 6573* Unchanged on exit. 6574* 6575* A - DOUBLE COMPLEX array of DIMENSION ( LDA, n ). 6576* Before entry with UPLO = 'U' or 'u', the leading ( k + 1 ) 6577* by n part of the array A must contain the upper triangular 6578* band part of the matrix of coefficients, supplied column by 6579* column, with the leading diagonal of the matrix in row 6580* ( k + 1 ) of the array, the first super-diagonal starting at 6581* position 2 in row k, and so on. The top left k by k triangle 6582* of the array A is not referenced. 6583* The following program segment will transfer an upper 6584* triangular band matrix from conventional full matrix storage 6585* to band storage: 6586* 6587* DO 20, J = 1, N 6588* M = K + 1 - J 6589* DO 10, I = MAX( 1, J - K ), J 6590* A( M + I, J ) = matrix( I, J ) 6591* 10 CONTINUE 6592* 20 CONTINUE 6593* 6594* Before entry with UPLO = 'L' or 'l', the leading ( k + 1 ) 6595* by n part of the array A must contain the lower triangular 6596* band part of the matrix of coefficients, supplied column by 6597* column, with the leading diagonal of the matrix in row 1 of 6598* the array, the first sub-diagonal starting at position 1 in 6599* row 2, and so on. The bottom right k by k triangle of the 6600* array A is not referenced. 6601* The following program segment will transfer a lower 6602* triangular band matrix from conventional full matrix storage 6603* to band storage: 6604* 6605* DO 20, J = 1, N 6606* M = 1 - J 6607* DO 10, I = J, MIN( N, J + K ) 6608* A( M + I, J ) = matrix( I, J ) 6609* 10 CONTINUE 6610* 20 CONTINUE 6611* 6612* Note that when DIAG = 'U' or 'u' the elements of the array A 6613* corresponding to the diagonal elements of the matrix are not 6614* referenced, but are assumed to be unity. 6615* Unchanged on exit. 6616* 6617* LDA - INTEGER. 6618* On entry, LDA specifies the first dimension of A as declared 6619* in the calling (sub) program. LDA must be at least 6620* ( k + 1 ). 6621* Unchanged on exit. 6622* 6623* X - DOUBLE COMPLEX array of dimension at least 6624* ( 1 + ( n - 1 )*abs( INCX ) ). 6625* Before entry, the incremented array X must contain the n 6626* element vector x. On exit, X is overwritten with the 6627* tranformed vector x. 6628* 6629* INCX - INTEGER. 6630* On entry, INCX specifies the increment for the elements of 6631* X. INCX must not be zero. 6632* Unchanged on exit. 6633* 6634* 6635* Level 2 Blas routine. 6636* 6637* -- Written on 22-October-1986. 6638* Jack Dongarra, Argonne National Lab. 6639* Jeremy Du Croz, Nag Central Office. 6640* Sven Hammarling, Nag Central Office. 6641* Richard Hanson, Sandia National Labs. 6642* 6643* 6644* .. Parameters .. 6645 DOUBLE COMPLEX ZERO 6646 PARAMETER ( ZERO = ( 0.0D+0, 0.0D+0 ) ) 6647* .. Local Scalars .. 6648 DOUBLE COMPLEX TEMP 6649 INTEGER I, INFO, IX, J, JX, KPLUS1, KX, L 6650 LOGICAL NOCONJ, NOUNIT 6651* .. External Functions .. 6652 LOGICAL LSAME 6653 EXTERNAL LSAME 6654* .. External Subroutines .. 6655 EXTERNAL XERBLA 6656* .. Intrinsic Functions .. 6657 INTRINSIC DCONJG, MAX, MIN 6658* .. 6659* .. Executable Statements .. 6660* 6661* Test the input parameters. 6662* 6663 INFO = 0 6664 IF ( .NOT.LSAME( UPLO , 'U' ).AND. 6665 $ .NOT.LSAME( UPLO , 'L' ) )THEN 6666 INFO = 1 6667 ELSE IF( .NOT.LSAME( TRANS, 'N' ).AND. 6668 $ .NOT.LSAME( TRANS, 'T' ).AND. 6669 $ .NOT.LSAME( TRANS, 'C' ) )THEN 6670 INFO = 2 6671 ELSE IF( .NOT.LSAME( DIAG , 'U' ).AND. 6672 $ .NOT.LSAME( DIAG , 'N' ) )THEN 6673 INFO = 3 6674 ELSE IF( N.LT.0 )THEN 6675 INFO = 4 6676 ELSE IF( K.LT.0 )THEN 6677 INFO = 5 6678 ELSE IF( LDA.LT.( K + 1 ) )THEN 6679 INFO = 7 6680 ELSE IF( INCX.EQ.0 )THEN 6681 INFO = 9 6682 END IF 6683 IF( INFO.NE.0 )THEN 6684 CALL XERBLA( 'ZTBMV ', INFO ) 6685 RETURN 6686 END IF 6687* 6688* Quick return if possible. 6689* 6690 IF( N.EQ.0 ) 6691 $ RETURN 6692* 6693 NOCONJ = LSAME( TRANS, 'T' ) 6694 NOUNIT = LSAME( DIAG , 'N' ) 6695* 6696* Set up the start point in X if the increment is not unity. This 6697* will be ( N - 1 )*INCX too small for descending loops. 6698* 6699 IF( INCX.LE.0 )THEN 6700 KX = 1 - ( N - 1 )*INCX 6701 ELSE IF( INCX.NE.1 )THEN 6702 KX = 1 6703 END IF 6704* 6705* Start the operations. In this version the elements of A are 6706* accessed sequentially with one pass through A. 6707* 6708 IF( LSAME( TRANS, 'N' ) )THEN 6709* 6710* Form x := A*x. 6711* 6712 IF( LSAME( UPLO, 'U' ) )THEN 6713 KPLUS1 = K + 1 6714 IF( INCX.EQ.1 )THEN 6715 DO 20, J = 1, N 6716c IF( X( J ).NE.ZERO )THEN 6717 TEMP = X( J ) 6718 L = KPLUS1 - J 6719 DO 10, I = MAX( 1, J - K ), J - 1 6720 X( I ) = X( I ) + TEMP*A( L + I, J ) 6721 10 CONTINUE 6722 IF( NOUNIT ) 6723 $ X( J ) = X( J )*A( KPLUS1, J ) 6724c END IF 6725 20 CONTINUE 6726 ELSE 6727 JX = KX 6728 DO 40, J = 1, N 6729c IF( X( JX ).NE.ZERO )THEN 6730 TEMP = X( JX ) 6731 IX = KX 6732 L = KPLUS1 - J 6733 DO 30, I = MAX( 1, J - K ), J - 1 6734 X( IX ) = X( IX ) + TEMP*A( L + I, J ) 6735 IX = IX + INCX 6736 30 CONTINUE 6737 IF( NOUNIT ) 6738 $ X( JX ) = X( JX )*A( KPLUS1, J ) 6739c END IF 6740 JX = JX + INCX 6741 IF( J.GT.K ) 6742 $ KX = KX + INCX 6743 40 CONTINUE 6744 END IF 6745 ELSE 6746 IF( INCX.EQ.1 )THEN 6747 DO 60, J = N, 1, -1 6748c IF( X( J ).NE.ZERO )THEN 6749 TEMP = X( J ) 6750 L = 1 - J 6751 DO 50, I = MIN( N, J + K ), J + 1, -1 6752 X( I ) = X( I ) + TEMP*A( L + I, J ) 6753 50 CONTINUE 6754 IF( NOUNIT ) 6755 $ X( J ) = X( J )*A( 1, J ) 6756c END IF 6757 60 CONTINUE 6758 ELSE 6759 KX = KX + ( N - 1 )*INCX 6760 JX = KX 6761 DO 80, J = N, 1, -1 6762c IF( X( JX ).NE.ZERO )THEN 6763 TEMP = X( JX ) 6764 IX = KX 6765 L = 1 - J 6766 DO 70, I = MIN( N, J + K ), J + 1, -1 6767 X( IX ) = X( IX ) + TEMP*A( L + I, J ) 6768 IX = IX - INCX 6769 70 CONTINUE 6770 IF( NOUNIT ) 6771 $ X( JX ) = X( JX )*A( 1, J ) 6772c END IF 6773 JX = JX - INCX 6774 IF( ( N - J ).GE.K ) 6775 $ KX = KX - INCX 6776 80 CONTINUE 6777 END IF 6778 END IF 6779 ELSE 6780* 6781* Form x := A'*x or x := conjg( A' )*x. 6782* 6783 IF( LSAME( UPLO, 'U' ) )THEN 6784 KPLUS1 = K + 1 6785 IF( INCX.EQ.1 )THEN 6786 DO 110, J = N, 1, -1 6787 TEMP = X( J ) 6788 L = KPLUS1 - J 6789 IF( NOCONJ )THEN 6790 IF( NOUNIT ) 6791 $ TEMP = TEMP*A( KPLUS1, J ) 6792 DO 90, I = J - 1, MAX( 1, J - K ), -1 6793 TEMP = TEMP + A( L + I, J )*X( I ) 6794 90 CONTINUE 6795 ELSE 6796 IF( NOUNIT ) 6797 $ TEMP = TEMP*DCONJG( A( KPLUS1, J ) ) 6798 DO 100, I = J - 1, MAX( 1, J - K ), -1 6799 TEMP = TEMP + DCONJG( A( L + I, J ) )*X( I ) 6800 100 CONTINUE 6801 END IF 6802 X( J ) = TEMP 6803 110 CONTINUE 6804 ELSE 6805 KX = KX + ( N - 1 )*INCX 6806 JX = KX 6807 DO 140, J = N, 1, -1 6808 TEMP = X( JX ) 6809 KX = KX - INCX 6810 IX = KX 6811 L = KPLUS1 - J 6812 IF( NOCONJ )THEN 6813 IF( NOUNIT ) 6814 $ TEMP = TEMP*A( KPLUS1, J ) 6815 DO 120, I = J - 1, MAX( 1, J - K ), -1 6816 TEMP = TEMP + A( L + I, J )*X( IX ) 6817 IX = IX - INCX 6818 120 CONTINUE 6819 ELSE 6820 IF( NOUNIT ) 6821 $ TEMP = TEMP*DCONJG( A( KPLUS1, J ) ) 6822 DO 130, I = J - 1, MAX( 1, J - K ), -1 6823 TEMP = TEMP + DCONJG( A( L + I, J ) )*X( IX ) 6824 IX = IX - INCX 6825 130 CONTINUE 6826 END IF 6827 X( JX ) = TEMP 6828 JX = JX - INCX 6829 140 CONTINUE 6830 END IF 6831 ELSE 6832 IF( INCX.EQ.1 )THEN 6833 DO 170, J = 1, N 6834 TEMP = X( J ) 6835 L = 1 - J 6836 IF( NOCONJ )THEN 6837 IF( NOUNIT ) 6838 $ TEMP = TEMP*A( 1, J ) 6839 DO 150, I = J + 1, MIN( N, J + K ) 6840 TEMP = TEMP + A( L + I, J )*X( I ) 6841 150 CONTINUE 6842 ELSE 6843 IF( NOUNIT ) 6844 $ TEMP = TEMP*DCONJG( A( 1, J ) ) 6845 DO 160, I = J + 1, MIN( N, J + K ) 6846 TEMP = TEMP + DCONJG( A( L + I, J ) )*X( I ) 6847 160 CONTINUE 6848 END IF 6849 X( J ) = TEMP 6850 170 CONTINUE 6851 ELSE 6852 JX = KX 6853 DO 200, J = 1, N 6854 TEMP = X( JX ) 6855 KX = KX + INCX 6856 IX = KX 6857 L = 1 - J 6858 IF( NOCONJ )THEN 6859 IF( NOUNIT ) 6860 $ TEMP = TEMP*A( 1, J ) 6861 DO 180, I = J + 1, MIN( N, J + K ) 6862 TEMP = TEMP + A( L + I, J )*X( IX ) 6863 IX = IX + INCX 6864 180 CONTINUE 6865 ELSE 6866 IF( NOUNIT ) 6867 $ TEMP = TEMP*DCONJG( A( 1, J ) ) 6868 DO 190, I = J + 1, MIN( N, J + K ) 6869 TEMP = TEMP + DCONJG( A( L + I, J ) )*X( IX ) 6870 IX = IX + INCX 6871 190 CONTINUE 6872 END IF 6873 X( JX ) = TEMP 6874 JX = JX + INCX 6875 200 CONTINUE 6876 END IF 6877 END IF 6878 END IF 6879* 6880 RETURN 6881* 6882* End of ZTBMV . 6883* 6884 END 6885 SUBROUTINE ZTBSV ( UPLO, TRANS, DIAG, N, K, A, LDA, X, INCX ) 6886* .. Scalar Arguments .. 6887 INTEGER INCX, K, LDA, N 6888 CHARACTER DIAG, TRANS, UPLO 6889* .. Array Arguments .. 6890 DOUBLE COMPLEX A( LDA, * ), X( * ) 6891* .. 6892* 6893* Purpose 6894* ======= 6895* 6896* ZTBSV solves one of the systems of equations 6897* 6898* A*x = b, or A'*x = b, or conjg( A' )*x = b, 6899* 6900* where b and x are n element vectors and A is an n by n unit, or 6901* non-unit, upper or lower triangular band matrix, with ( k + 1 ) 6902* diagonals. 6903* 6904* No test for singularity or near-singularity is included in this 6905* routine. Such tests must be performed before calling this routine. 6906* 6907* Parameters 6908* ========== 6909* 6910* UPLO - CHARACTER*1. 6911* On entry, UPLO specifies whether the matrix is an upper or 6912* lower triangular matrix as follows: 6913* 6914* UPLO = 'U' or 'u' A is an upper triangular matrix. 6915* 6916* UPLO = 'L' or 'l' A is a lower triangular matrix. 6917* 6918* Unchanged on exit. 6919* 6920* TRANS - CHARACTER*1. 6921* On entry, TRANS specifies the equations to be solved as 6922* follows: 6923* 6924* TRANS = 'N' or 'n' A*x = b. 6925* 6926* TRANS = 'T' or 't' A'*x = b. 6927* 6928* TRANS = 'C' or 'c' conjg( A' )*x = b. 6929* 6930* Unchanged on exit. 6931* 6932* DIAG - CHARACTER*1. 6933* On entry, DIAG specifies whether or not A is unit 6934* triangular as follows: 6935* 6936* DIAG = 'U' or 'u' A is assumed to be unit triangular. 6937* 6938* DIAG = 'N' or 'n' A is not assumed to be unit 6939* triangular. 6940* 6941* Unchanged on exit. 6942* 6943* N - INTEGER. 6944* On entry, N specifies the order of the matrix A. 6945* N must be at least zero. 6946* Unchanged on exit. 6947* 6948* K - INTEGER. 6949* On entry with UPLO = 'U' or 'u', K specifies the number of 6950* super-diagonals of the matrix A. 6951* On entry with UPLO = 'L' or 'l', K specifies the number of 6952* sub-diagonals of the matrix A. 6953* K must satisfy 0 .le. K. 6954* Unchanged on exit. 6955* 6956* A - DOUBLE COMPLEX array of DIMENSION ( LDA, n ). 6957* Before entry with UPLO = 'U' or 'u', the leading ( k + 1 ) 6958* by n part of the array A must contain the upper triangular 6959* band part of the matrix of coefficients, supplied column by 6960* column, with the leading diagonal of the matrix in row 6961* ( k + 1 ) of the array, the first super-diagonal starting at 6962* position 2 in row k, and so on. The top left k by k triangle 6963* of the array A is not referenced. 6964* The following program segment will transfer an upper 6965* triangular band matrix from conventional full matrix storage 6966* to band storage: 6967* 6968* DO 20, J = 1, N 6969* M = K + 1 - J 6970* DO 10, I = MAX( 1, J - K ), J 6971* A( M + I, J ) = matrix( I, J ) 6972* 10 CONTINUE 6973* 20 CONTINUE 6974* 6975* Before entry with UPLO = 'L' or 'l', the leading ( k + 1 ) 6976* by n part of the array A must contain the lower triangular 6977* band part of the matrix of coefficients, supplied column by 6978* column, with the leading diagonal of the matrix in row 1 of 6979* the array, the first sub-diagonal starting at position 1 in 6980* row 2, and so on. The bottom right k by k triangle of the 6981* array A is not referenced. 6982* The following program segment will transfer a lower 6983* triangular band matrix from conventional full matrix storage 6984* to band storage: 6985* 6986* DO 20, J = 1, N 6987* M = 1 - J 6988* DO 10, I = J, MIN( N, J + K ) 6989* A( M + I, J ) = matrix( I, J ) 6990* 10 CONTINUE 6991* 20 CONTINUE 6992* 6993* Note that when DIAG = 'U' or 'u' the elements of the array A 6994* corresponding to the diagonal elements of the matrix are not 6995* referenced, but are assumed to be unity. 6996* Unchanged on exit. 6997* 6998* LDA - INTEGER. 6999* On entry, LDA specifies the first dimension of A as declared 7000* in the calling (sub) program. LDA must be at least 7001* ( k + 1 ). 7002* Unchanged on exit. 7003* 7004* X - DOUBLE COMPLEX array of dimension at least 7005* ( 1 + ( n - 1 )*abs( INCX ) ). 7006* Before entry, the incremented array X must contain the n 7007* element right-hand side vector b. On exit, X is overwritten 7008* with the solution vector x. 7009* 7010* INCX - INTEGER. 7011* On entry, INCX specifies the increment for the elements of 7012* X. INCX must not be zero. 7013* Unchanged on exit. 7014* 7015* 7016* Level 2 Blas routine. 7017* 7018* -- Written on 22-October-1986. 7019* Jack Dongarra, Argonne National Lab. 7020* Jeremy Du Croz, Nag Central Office. 7021* Sven Hammarling, Nag Central Office. 7022* Richard Hanson, Sandia National Labs. 7023* 7024* 7025* .. Parameters .. 7026 DOUBLE COMPLEX ZERO 7027 PARAMETER ( ZERO = ( 0.0D+0, 0.0D+0 ) ) 7028* .. Local Scalars .. 7029 DOUBLE COMPLEX TEMP 7030 INTEGER I, INFO, IX, J, JX, KPLUS1, KX, L 7031 LOGICAL NOCONJ, NOUNIT 7032* .. External Functions .. 7033 LOGICAL LSAME 7034 EXTERNAL LSAME 7035* .. External Subroutines .. 7036 EXTERNAL XERBLA 7037* .. Intrinsic Functions .. 7038 INTRINSIC DCONJG, MAX, MIN 7039* .. 7040* .. Executable Statements .. 7041* 7042* Test the input parameters. 7043* 7044 INFO = 0 7045 IF ( .NOT.LSAME( UPLO , 'U' ).AND. 7046 $ .NOT.LSAME( UPLO , 'L' ) )THEN 7047 INFO = 1 7048 ELSE IF( .NOT.LSAME( TRANS, 'N' ).AND. 7049 $ .NOT.LSAME( TRANS, 'T' ).AND. 7050 $ .NOT.LSAME( TRANS, 'C' ) )THEN 7051 INFO = 2 7052 ELSE IF( .NOT.LSAME( DIAG , 'U' ).AND. 7053 $ .NOT.LSAME( DIAG , 'N' ) )THEN 7054 INFO = 3 7055 ELSE IF( N.LT.0 )THEN 7056 INFO = 4 7057 ELSE IF( K.LT.0 )THEN 7058 INFO = 5 7059 ELSE IF( LDA.LT.( K + 1 ) )THEN 7060 INFO = 7 7061 ELSE IF( INCX.EQ.0 )THEN 7062 INFO = 9 7063 END IF 7064 IF( INFO.NE.0 )THEN 7065 CALL XERBLA( 'ZTBSV ', INFO ) 7066 RETURN 7067 END IF 7068* 7069* Quick return if possible. 7070* 7071 IF( N.EQ.0 ) 7072 $ RETURN 7073* 7074 NOCONJ = LSAME( TRANS, 'T' ) 7075 NOUNIT = LSAME( DIAG , 'N' ) 7076* 7077* Set up the start point in X if the increment is not unity. This 7078* will be ( N - 1 )*INCX too small for descending loops. 7079* 7080 IF( INCX.LE.0 )THEN 7081 KX = 1 - ( N - 1 )*INCX 7082 ELSE IF( INCX.NE.1 )THEN 7083 KX = 1 7084 END IF 7085* 7086* Start the operations. In this version the elements of A are 7087* accessed by sequentially with one pass through A. 7088* 7089 IF( LSAME( TRANS, 'N' ) )THEN 7090* 7091* Form x := inv( A )*x. 7092* 7093 IF( LSAME( UPLO, 'U' ) )THEN 7094 KPLUS1 = K + 1 7095 IF( INCX.EQ.1 )THEN 7096 DO 20, J = N, 1, -1 7097c IF( X( J ).NE.ZERO )THEN 7098 L = KPLUS1 - J 7099 IF( NOUNIT ) 7100 $ X( J ) = X( J )/A( KPLUS1, J ) 7101 TEMP = X( J ) 7102 DO 10, I = J - 1, MAX( 1, J - K ), -1 7103 X( I ) = X( I ) - TEMP*A( L + I, J ) 7104 10 CONTINUE 7105c END IF 7106 20 CONTINUE 7107 ELSE 7108 KX = KX + ( N - 1 )*INCX 7109 JX = KX 7110 DO 40, J = N, 1, -1 7111 KX = KX - INCX 7112c IF( X( JX ).NE.ZERO )THEN 7113 IX = KX 7114 L = KPLUS1 - J 7115 IF( NOUNIT ) 7116 $ X( JX ) = X( JX )/A( KPLUS1, J ) 7117 TEMP = X( JX ) 7118 DO 30, I = J - 1, MAX( 1, J - K ), -1 7119 X( IX ) = X( IX ) - TEMP*A( L + I, J ) 7120 IX = IX - INCX 7121 30 CONTINUE 7122c END IF 7123 JX = JX - INCX 7124 40 CONTINUE 7125 END IF 7126 ELSE 7127 IF( INCX.EQ.1 )THEN 7128 DO 60, J = 1, N 7129c IF( X( J ).NE.ZERO )THEN 7130 L = 1 - J 7131 IF( NOUNIT ) 7132 $ X( J ) = X( J )/A( 1, J ) 7133 TEMP = X( J ) 7134 DO 50, I = J + 1, MIN( N, J + K ) 7135 X( I ) = X( I ) - TEMP*A( L + I, J ) 7136 50 CONTINUE 7137c END IF 7138 60 CONTINUE 7139 ELSE 7140 JX = KX 7141 DO 80, J = 1, N 7142 KX = KX + INCX 7143c IF( X( JX ).NE.ZERO )THEN 7144 IX = KX 7145 L = 1 - J 7146 IF( NOUNIT ) 7147 $ X( JX ) = X( JX )/A( 1, J ) 7148 TEMP = X( JX ) 7149 DO 70, I = J + 1, MIN( N, J + K ) 7150 X( IX ) = X( IX ) - TEMP*A( L + I, J ) 7151 IX = IX + INCX 7152 70 CONTINUE 7153c END IF 7154 JX = JX + INCX 7155 80 CONTINUE 7156 END IF 7157 END IF 7158 ELSE 7159* 7160* Form x := inv( A' )*x or x := inv( conjg( A') )*x. 7161* 7162 IF( LSAME( UPLO, 'U' ) )THEN 7163 KPLUS1 = K + 1 7164 IF( INCX.EQ.1 )THEN 7165 DO 110, J = 1, N 7166 TEMP = X( J ) 7167 L = KPLUS1 - J 7168 IF( NOCONJ )THEN 7169 DO 90, I = MAX( 1, J - K ), J - 1 7170 TEMP = TEMP - A( L + I, J )*X( I ) 7171 90 CONTINUE 7172 IF( NOUNIT ) 7173 $ TEMP = TEMP/A( KPLUS1, J ) 7174 ELSE 7175 DO 100, I = MAX( 1, J - K ), J - 1 7176 TEMP = TEMP - DCONJG( A( L + I, J ) )*X( I ) 7177 100 CONTINUE 7178 IF( NOUNIT ) 7179 $ TEMP = TEMP/DCONJG( A( KPLUS1, J ) ) 7180 END IF 7181 X( J ) = TEMP 7182 110 CONTINUE 7183 ELSE 7184 JX = KX 7185 DO 140, J = 1, N 7186 TEMP = X( JX ) 7187 IX = KX 7188 L = KPLUS1 - J 7189 IF( NOCONJ )THEN 7190 DO 120, I = MAX( 1, J - K ), J - 1 7191 TEMP = TEMP - A( L + I, J )*X( IX ) 7192 IX = IX + INCX 7193 120 CONTINUE 7194 IF( NOUNIT ) 7195 $ TEMP = TEMP/A( KPLUS1, J ) 7196 ELSE 7197 DO 130, I = MAX( 1, J - K ), J - 1 7198 TEMP = TEMP - DCONJG( A( L + I, J ) )*X( IX ) 7199 IX = IX + INCX 7200 130 CONTINUE 7201 IF( NOUNIT ) 7202 $ TEMP = TEMP/DCONJG( A( KPLUS1, J ) ) 7203 END IF 7204 X( JX ) = TEMP 7205 JX = JX + INCX 7206 IF( J.GT.K ) 7207 $ KX = KX + INCX 7208 140 CONTINUE 7209 END IF 7210 ELSE 7211 IF( INCX.EQ.1 )THEN 7212 DO 170, J = N, 1, -1 7213 TEMP = X( J ) 7214 L = 1 - J 7215 IF( NOCONJ )THEN 7216 DO 150, I = MIN( N, J + K ), J + 1, -1 7217 TEMP = TEMP - A( L + I, J )*X( I ) 7218 150 CONTINUE 7219 IF( NOUNIT ) 7220 $ TEMP = TEMP/A( 1, J ) 7221 ELSE 7222 DO 160, I = MIN( N, J + K ), J + 1, -1 7223 TEMP = TEMP - DCONJG( A( L + I, J ) )*X( I ) 7224 160 CONTINUE 7225 IF( NOUNIT ) 7226 $ TEMP = TEMP/DCONJG( A( 1, J ) ) 7227 END IF 7228 X( J ) = TEMP 7229 170 CONTINUE 7230 ELSE 7231 KX = KX + ( N - 1 )*INCX 7232 JX = KX 7233 DO 200, J = N, 1, -1 7234 TEMP = X( JX ) 7235 IX = KX 7236 L = 1 - J 7237 IF( NOCONJ )THEN 7238 DO 180, I = MIN( N, J + K ), J + 1, -1 7239 TEMP = TEMP - A( L + I, J )*X( IX ) 7240 IX = IX - INCX 7241 180 CONTINUE 7242 IF( NOUNIT ) 7243 $ TEMP = TEMP/A( 1, J ) 7244 ELSE 7245 DO 190, I = MIN( N, J + K ), J + 1, -1 7246 TEMP = TEMP - DCONJG( A( L + I, J ) )*X( IX ) 7247 IX = IX - INCX 7248 190 CONTINUE 7249 IF( NOUNIT ) 7250 $ TEMP = TEMP/DCONJG( A( 1, J ) ) 7251 END IF 7252 X( JX ) = TEMP 7253 JX = JX - INCX 7254 IF( ( N - J ).GE.K ) 7255 $ KX = KX - INCX 7256 200 CONTINUE 7257 END IF 7258 END IF 7259 END IF 7260* 7261 RETURN 7262* 7263* End of ZTBSV . 7264* 7265 END 7266 SUBROUTINE ZTPMV ( UPLO, TRANS, DIAG, N, AP, X, INCX ) 7267* .. Scalar Arguments .. 7268 INTEGER INCX, N 7269 CHARACTER DIAG, TRANS, UPLO 7270* .. Array Arguments .. 7271 DOUBLE COMPLEX AP( * ), X( * ) 7272* .. 7273* 7274* Purpose 7275* ======= 7276* 7277* ZTPMV performs one of the matrix-vector operations 7278* 7279* x := A*x, or x := A'*x, or x := conjg( A' )*x, 7280* 7281* where x is an n element vector and A is an n by n unit, or non-unit, 7282* upper or lower triangular matrix, supplied in packed form. 7283* 7284* Parameters 7285* ========== 7286* 7287* UPLO - CHARACTER*1. 7288* On entry, UPLO specifies whether the matrix is an upper or 7289* lower triangular matrix as follows: 7290* 7291* UPLO = 'U' or 'u' A is an upper triangular matrix. 7292* 7293* UPLO = 'L' or 'l' A is a lower triangular matrix. 7294* 7295* Unchanged on exit. 7296* 7297* TRANS - CHARACTER*1. 7298* On entry, TRANS specifies the operation to be performed as 7299* follows: 7300* 7301* TRANS = 'N' or 'n' x := A*x. 7302* 7303* TRANS = 'T' or 't' x := A'*x. 7304* 7305* TRANS = 'C' or 'c' x := conjg( A' )*x. 7306* 7307* Unchanged on exit. 7308* 7309* DIAG - CHARACTER*1. 7310* On entry, DIAG specifies whether or not A is unit 7311* triangular as follows: 7312* 7313* DIAG = 'U' or 'u' A is assumed to be unit triangular. 7314* 7315* DIAG = 'N' or 'n' A is not assumed to be unit 7316* triangular. 7317* 7318* Unchanged on exit. 7319* 7320* N - INTEGER. 7321* On entry, N specifies the order of the matrix A. 7322* N must be at least zero. 7323* Unchanged on exit. 7324* 7325* AP - DOUBLE COMPLEX array of DIMENSION at least 7326* ( ( n*( n + 1 ) )/2 ). 7327* Before entry with UPLO = 'U' or 'u', the array AP must 7328* contain the upper triangular matrix packed sequentially, 7329* column by column, so that AP( 1 ) contains a( 1, 1 ), 7330* AP( 2 ) and AP( 3 ) contain a( 1, 2 ) and a( 2, 2 ) 7331* respectively, and so on. 7332* Before entry with UPLO = 'L' or 'l', the array AP must 7333* contain the lower triangular matrix packed sequentially, 7334* column by column, so that AP( 1 ) contains a( 1, 1 ), 7335* AP( 2 ) and AP( 3 ) contain a( 2, 1 ) and a( 3, 1 ) 7336* respectively, and so on. 7337* Note that when DIAG = 'U' or 'u', the diagonal elements of 7338* A are not referenced, but are assumed to be unity. 7339* Unchanged on exit. 7340* 7341* X - DOUBLE COMPLEX array of dimension at least 7342* ( 1 + ( n - 1 )*abs( INCX ) ). 7343* Before entry, the incremented array X must contain the n 7344* element vector x. On exit, X is overwritten with the 7345* tranformed vector x. 7346* 7347* INCX - INTEGER. 7348* On entry, INCX specifies the increment for the elements of 7349* X. INCX must not be zero. 7350* Unchanged on exit. 7351* 7352* 7353* Level 2 Blas routine. 7354* 7355* -- Written on 22-October-1986. 7356* Jack Dongarra, Argonne National Lab. 7357* Jeremy Du Croz, Nag Central Office. 7358* Sven Hammarling, Nag Central Office. 7359* Richard Hanson, Sandia National Labs. 7360* 7361* 7362* .. Parameters .. 7363 DOUBLE COMPLEX ZERO 7364 PARAMETER ( ZERO = ( 0.0D+0, 0.0D+0 ) ) 7365* .. Local Scalars .. 7366 DOUBLE COMPLEX TEMP 7367 INTEGER I, INFO, IX, J, JX, K, KK, KX 7368 LOGICAL NOCONJ, NOUNIT 7369* .. External Functions .. 7370 LOGICAL LSAME 7371 EXTERNAL LSAME 7372* .. External Subroutines .. 7373 EXTERNAL XERBLA 7374* .. Intrinsic Functions .. 7375 INTRINSIC DCONJG 7376* .. 7377* .. Executable Statements .. 7378* 7379* Test the input parameters. 7380* 7381 INFO = 0 7382 IF ( .NOT.LSAME( UPLO , 'U' ).AND. 7383 $ .NOT.LSAME( UPLO , 'L' ) )THEN 7384 INFO = 1 7385 ELSE IF( .NOT.LSAME( TRANS, 'N' ).AND. 7386 $ .NOT.LSAME( TRANS, 'T' ).AND. 7387 $ .NOT.LSAME( TRANS, 'C' ) )THEN 7388 INFO = 2 7389 ELSE IF( .NOT.LSAME( DIAG , 'U' ).AND. 7390 $ .NOT.LSAME( DIAG , 'N' ) )THEN 7391 INFO = 3 7392 ELSE IF( N.LT.0 )THEN 7393 INFO = 4 7394 ELSE IF( INCX.EQ.0 )THEN 7395 INFO = 7 7396 END IF 7397 IF( INFO.NE.0 )THEN 7398 CALL XERBLA( 'ZTPMV ', INFO ) 7399 RETURN 7400 END IF 7401* 7402* Quick return if possible. 7403* 7404 IF( N.EQ.0 ) 7405 $ RETURN 7406* 7407 NOCONJ = LSAME( TRANS, 'T' ) 7408 NOUNIT = LSAME( DIAG , 'N' ) 7409* 7410* Set up the start point in X if the increment is not unity. This 7411* will be ( N - 1 )*INCX too small for descending loops. 7412* 7413 IF( INCX.LE.0 )THEN 7414 KX = 1 - ( N - 1 )*INCX 7415 ELSE IF( INCX.NE.1 )THEN 7416 KX = 1 7417 END IF 7418* 7419* Start the operations. In this version the elements of AP are 7420* accessed sequentially with one pass through AP. 7421* 7422 IF( LSAME( TRANS, 'N' ) )THEN 7423* 7424* Form x:= A*x. 7425* 7426 IF( LSAME( UPLO, 'U' ) )THEN 7427 KK = 1 7428 IF( INCX.EQ.1 )THEN 7429 DO 20, J = 1, N 7430c IF( X( J ).NE.ZERO )THEN 7431 TEMP = X( J ) 7432 K = KK 7433 DO 10, I = 1, J - 1 7434 X( I ) = X( I ) + TEMP*AP( K ) 7435 K = K + 1 7436 10 CONTINUE 7437 IF( NOUNIT ) 7438 $ X( J ) = X( J )*AP( KK + J - 1 ) 7439c END IF 7440 KK = KK + J 7441 20 CONTINUE 7442 ELSE 7443 JX = KX 7444 DO 40, J = 1, N 7445c IF( X( JX ).NE.ZERO )THEN 7446 TEMP = X( JX ) 7447 IX = KX 7448 DO 30, K = KK, KK + J - 2 7449 X( IX ) = X( IX ) + TEMP*AP( K ) 7450 IX = IX + INCX 7451 30 CONTINUE 7452 IF( NOUNIT ) 7453 $ X( JX ) = X( JX )*AP( KK + J - 1 ) 7454c END IF 7455 JX = JX + INCX 7456 KK = KK + J 7457 40 CONTINUE 7458 END IF 7459 ELSE 7460 KK = ( N*( N + 1 ) )/2 7461 IF( INCX.EQ.1 )THEN 7462 DO 60, J = N, 1, -1 7463c IF( X( J ).NE.ZERO )THEN 7464 TEMP = X( J ) 7465 K = KK 7466 DO 50, I = N, J + 1, -1 7467 X( I ) = X( I ) + TEMP*AP( K ) 7468 K = K - 1 7469 50 CONTINUE 7470 IF( NOUNIT ) 7471 $ X( J ) = X( J )*AP( KK - N + J ) 7472c END IF 7473 KK = KK - ( N - J + 1 ) 7474 60 CONTINUE 7475 ELSE 7476 KX = KX + ( N - 1 )*INCX 7477 JX = KX 7478 DO 80, J = N, 1, -1 7479c IF( X( JX ).NE.ZERO )THEN 7480 TEMP = X( JX ) 7481 IX = KX 7482 DO 70, K = KK, KK - ( N - ( J + 1 ) ), -1 7483 X( IX ) = X( IX ) + TEMP*AP( K ) 7484 IX = IX - INCX 7485 70 CONTINUE 7486 IF( NOUNIT ) 7487 $ X( JX ) = X( JX )*AP( KK - N + J ) 7488c END IF 7489 JX = JX - INCX 7490 KK = KK - ( N - J + 1 ) 7491 80 CONTINUE 7492 END IF 7493 END IF 7494 ELSE 7495* 7496* Form x := A'*x or x := conjg( A' )*x. 7497* 7498 IF( LSAME( UPLO, 'U' ) )THEN 7499 KK = ( N*( N + 1 ) )/2 7500 IF( INCX.EQ.1 )THEN 7501 DO 110, J = N, 1, -1 7502 TEMP = X( J ) 7503 K = KK - 1 7504 IF( NOCONJ )THEN 7505 IF( NOUNIT ) 7506 $ TEMP = TEMP*AP( KK ) 7507 DO 90, I = J - 1, 1, -1 7508 TEMP = TEMP + AP( K )*X( I ) 7509 K = K - 1 7510 90 CONTINUE 7511 ELSE 7512 IF( NOUNIT ) 7513 $ TEMP = TEMP*DCONJG( AP( KK ) ) 7514 DO 100, I = J - 1, 1, -1 7515 TEMP = TEMP + DCONJG( AP( K ) )*X( I ) 7516 K = K - 1 7517 100 CONTINUE 7518 END IF 7519 X( J ) = TEMP 7520 KK = KK - J 7521 110 CONTINUE 7522 ELSE 7523 JX = KX + ( N - 1 )*INCX 7524 DO 140, J = N, 1, -1 7525 TEMP = X( JX ) 7526 IX = JX 7527 IF( NOCONJ )THEN 7528 IF( NOUNIT ) 7529 $ TEMP = TEMP*AP( KK ) 7530 DO 120, K = KK - 1, KK - J + 1, -1 7531 IX = IX - INCX 7532 TEMP = TEMP + AP( K )*X( IX ) 7533 120 CONTINUE 7534 ELSE 7535 IF( NOUNIT ) 7536 $ TEMP = TEMP*DCONJG( AP( KK ) ) 7537 DO 130, K = KK - 1, KK - J + 1, -1 7538 IX = IX - INCX 7539 TEMP = TEMP + DCONJG( AP( K ) )*X( IX ) 7540 130 CONTINUE 7541 END IF 7542 X( JX ) = TEMP 7543 JX = JX - INCX 7544 KK = KK - J 7545 140 CONTINUE 7546 END IF 7547 ELSE 7548 KK = 1 7549 IF( INCX.EQ.1 )THEN 7550 DO 170, J = 1, N 7551 TEMP = X( J ) 7552 K = KK + 1 7553 IF( NOCONJ )THEN 7554 IF( NOUNIT ) 7555 $ TEMP = TEMP*AP( KK ) 7556 DO 150, I = J + 1, N 7557 TEMP = TEMP + AP( K )*X( I ) 7558 K = K + 1 7559 150 CONTINUE 7560 ELSE 7561 IF( NOUNIT ) 7562 $ TEMP = TEMP*DCONJG( AP( KK ) ) 7563 DO 160, I = J + 1, N 7564 TEMP = TEMP + DCONJG( AP( K ) )*X( I ) 7565 K = K + 1 7566 160 CONTINUE 7567 END IF 7568 X( J ) = TEMP 7569 KK = KK + ( N - J + 1 ) 7570 170 CONTINUE 7571 ELSE 7572 JX = KX 7573 DO 200, J = 1, N 7574 TEMP = X( JX ) 7575 IX = JX 7576 IF( NOCONJ )THEN 7577 IF( NOUNIT ) 7578 $ TEMP = TEMP*AP( KK ) 7579 DO 180, K = KK + 1, KK + N - J 7580 IX = IX + INCX 7581 TEMP = TEMP + AP( K )*X( IX ) 7582 180 CONTINUE 7583 ELSE 7584 IF( NOUNIT ) 7585 $ TEMP = TEMP*DCONJG( AP( KK ) ) 7586 DO 190, K = KK + 1, KK + N - J 7587 IX = IX + INCX 7588 TEMP = TEMP + DCONJG( AP( K ) )*X( IX ) 7589 190 CONTINUE 7590 END IF 7591 X( JX ) = TEMP 7592 JX = JX + INCX 7593 KK = KK + ( N - J + 1 ) 7594 200 CONTINUE 7595 END IF 7596 END IF 7597 END IF 7598* 7599 RETURN 7600* 7601* End of ZTPMV . 7602* 7603 END 7604 SUBROUTINE ZTPSV ( UPLO, TRANS, DIAG, N, AP, X, INCX ) 7605* .. Scalar Arguments .. 7606 INTEGER INCX, N 7607 CHARACTER DIAG, TRANS, UPLO 7608* .. Array Arguments .. 7609 DOUBLE COMPLEX AP( * ), X( * ) 7610* .. 7611* 7612* Purpose 7613* ======= 7614* 7615* ZTPSV solves one of the systems of equations 7616* 7617* A*x = b, or A'*x = b, or conjg( A' )*x = b, 7618* 7619* where b and x are n element vectors and A is an n by n unit, or 7620* non-unit, upper or lower triangular matrix, supplied in packed form. 7621* 7622* No test for singularity or near-singularity is included in this 7623* routine. Such tests must be performed before calling this routine. 7624* 7625* Parameters 7626* ========== 7627* 7628* UPLO - CHARACTER*1. 7629* On entry, UPLO specifies whether the matrix is an upper or 7630* lower triangular matrix as follows: 7631* 7632* UPLO = 'U' or 'u' A is an upper triangular matrix. 7633* 7634* UPLO = 'L' or 'l' A is a lower triangular matrix. 7635* 7636* Unchanged on exit. 7637* 7638* TRANS - CHARACTER*1. 7639* On entry, TRANS specifies the equations to be solved as 7640* follows: 7641* 7642* TRANS = 'N' or 'n' A*x = b. 7643* 7644* TRANS = 'T' or 't' A'*x = b. 7645* 7646* TRANS = 'C' or 'c' conjg( A' )*x = b. 7647* 7648* Unchanged on exit. 7649* 7650* DIAG - CHARACTER*1. 7651* On entry, DIAG specifies whether or not A is unit 7652* triangular as follows: 7653* 7654* DIAG = 'U' or 'u' A is assumed to be unit triangular. 7655* 7656* DIAG = 'N' or 'n' A is not assumed to be unit 7657* triangular. 7658* 7659* Unchanged on exit. 7660* 7661* N - INTEGER. 7662* On entry, N specifies the order of the matrix A. 7663* N must be at least zero. 7664* Unchanged on exit. 7665* 7666* AP - DOUBLE COMPLEX array of DIMENSION at least 7667* ( ( n*( n + 1 ) )/2 ). 7668* Before entry with UPLO = 'U' or 'u', the array AP must 7669* contain the upper triangular matrix packed sequentially, 7670* column by column, so that AP( 1 ) contains a( 1, 1 ), 7671* AP( 2 ) and AP( 3 ) contain a( 1, 2 ) and a( 2, 2 ) 7672* respectively, and so on. 7673* Before entry with UPLO = 'L' or 'l', the array AP must 7674* contain the lower triangular matrix packed sequentially, 7675* column by column, so that AP( 1 ) contains a( 1, 1 ), 7676* AP( 2 ) and AP( 3 ) contain a( 2, 1 ) and a( 3, 1 ) 7677* respectively, and so on. 7678* Note that when DIAG = 'U' or 'u', the diagonal elements of 7679* A are not referenced, but are assumed to be unity. 7680* Unchanged on exit. 7681* 7682* X - DOUBLE COMPLEX array of dimension at least 7683* ( 1 + ( n - 1 )*abs( INCX ) ). 7684* Before entry, the incremented array X must contain the n 7685* element right-hand side vector b. On exit, X is overwritten 7686* with the solution vector x. 7687* 7688* INCX - INTEGER. 7689* On entry, INCX specifies the increment for the elements of 7690* X. INCX must not be zero. 7691* Unchanged on exit. 7692* 7693* 7694* Level 2 Blas routine. 7695* 7696* -- Written on 22-October-1986. 7697* Jack Dongarra, Argonne National Lab. 7698* Jeremy Du Croz, Nag Central Office. 7699* Sven Hammarling, Nag Central Office. 7700* Richard Hanson, Sandia National Labs. 7701* 7702* 7703* .. Parameters .. 7704 DOUBLE COMPLEX ZERO 7705 PARAMETER ( ZERO = ( 0.0D+0, 0.0D+0 ) ) 7706* .. Local Scalars .. 7707 DOUBLE COMPLEX TEMP 7708 INTEGER I, INFO, IX, J, JX, K, KK, KX 7709 LOGICAL NOCONJ, NOUNIT 7710* .. External Functions .. 7711 LOGICAL LSAME 7712 EXTERNAL LSAME 7713* .. External Subroutines .. 7714 EXTERNAL XERBLA 7715* .. Intrinsic Functions .. 7716 INTRINSIC DCONJG 7717* .. 7718* .. Executable Statements .. 7719* 7720* Test the input parameters. 7721* 7722 INFO = 0 7723 IF ( .NOT.LSAME( UPLO , 'U' ).AND. 7724 $ .NOT.LSAME( UPLO , 'L' ) )THEN 7725 INFO = 1 7726 ELSE IF( .NOT.LSAME( TRANS, 'N' ).AND. 7727 $ .NOT.LSAME( TRANS, 'T' ).AND. 7728 $ .NOT.LSAME( TRANS, 'C' ) )THEN 7729 INFO = 2 7730 ELSE IF( .NOT.LSAME( DIAG , 'U' ).AND. 7731 $ .NOT.LSAME( DIAG , 'N' ) )THEN 7732 INFO = 3 7733 ELSE IF( N.LT.0 )THEN 7734 INFO = 4 7735 ELSE IF( INCX.EQ.0 )THEN 7736 INFO = 7 7737 END IF 7738 IF( INFO.NE.0 )THEN 7739 CALL XERBLA( 'ZTPSV ', INFO ) 7740 RETURN 7741 END IF 7742* 7743* Quick return if possible. 7744* 7745 IF( N.EQ.0 ) 7746 $ RETURN 7747* 7748 NOCONJ = LSAME( TRANS, 'T' ) 7749 NOUNIT = LSAME( DIAG , 'N' ) 7750* 7751* Set up the start point in X if the increment is not unity. This 7752* will be ( N - 1 )*INCX too small for descending loops. 7753* 7754 IF( INCX.LE.0 )THEN 7755 KX = 1 - ( N - 1 )*INCX 7756 ELSE IF( INCX.NE.1 )THEN 7757 KX = 1 7758 END IF 7759* 7760* Start the operations. In this version the elements of AP are 7761* accessed sequentially with one pass through AP. 7762* 7763 IF( LSAME( TRANS, 'N' ) )THEN 7764* 7765* Form x := inv( A )*x. 7766* 7767 IF( LSAME( UPLO, 'U' ) )THEN 7768 KK = ( N*( N + 1 ) )/2 7769 IF( INCX.EQ.1 )THEN 7770 DO 20, J = N, 1, -1 7771c IF( X( J ).NE.ZERO )THEN 7772 IF( NOUNIT ) 7773 $ X( J ) = X( J )/AP( KK ) 7774 TEMP = X( J ) 7775 K = KK - 1 7776 DO 10, I = J - 1, 1, -1 7777 X( I ) = X( I ) - TEMP*AP( K ) 7778 K = K - 1 7779 10 CONTINUE 7780c END IF 7781 KK = KK - J 7782 20 CONTINUE 7783 ELSE 7784 JX = KX + ( N - 1 )*INCX 7785 DO 40, J = N, 1, -1 7786c IF( X( JX ).NE.ZERO )THEN 7787 IF( NOUNIT ) 7788 $ X( JX ) = X( JX )/AP( KK ) 7789 TEMP = X( JX ) 7790 IX = JX 7791 DO 30, K = KK - 1, KK - J + 1, -1 7792 IX = IX - INCX 7793 X( IX ) = X( IX ) - TEMP*AP( K ) 7794 30 CONTINUE 7795c END IF 7796 JX = JX - INCX 7797 KK = KK - J 7798 40 CONTINUE 7799 END IF 7800 ELSE 7801 KK = 1 7802 IF( INCX.EQ.1 )THEN 7803 DO 60, J = 1, N 7804c IF( X( J ).NE.ZERO )THEN 7805 IF( NOUNIT ) 7806 $ X( J ) = X( J )/AP( KK ) 7807 TEMP = X( J ) 7808 K = KK + 1 7809 DO 50, I = J + 1, N 7810 X( I ) = X( I ) - TEMP*AP( K ) 7811 K = K + 1 7812 50 CONTINUE 7813c END IF 7814 KK = KK + ( N - J + 1 ) 7815 60 CONTINUE 7816 ELSE 7817 JX = KX 7818 DO 80, J = 1, N 7819c IF( X( JX ).NE.ZERO )THEN 7820 IF( NOUNIT ) 7821 $ X( JX ) = X( JX )/AP( KK ) 7822 TEMP = X( JX ) 7823 IX = JX 7824 DO 70, K = KK + 1, KK + N - J 7825 IX = IX + INCX 7826 X( IX ) = X( IX ) - TEMP*AP( K ) 7827 70 CONTINUE 7828c END IF 7829 JX = JX + INCX 7830 KK = KK + ( N - J + 1 ) 7831 80 CONTINUE 7832 END IF 7833 END IF 7834 ELSE 7835* 7836* Form x := inv( A' )*x or x := inv( conjg( A' ) )*x. 7837* 7838 IF( LSAME( UPLO, 'U' ) )THEN 7839 KK = 1 7840 IF( INCX.EQ.1 )THEN 7841 DO 110, J = 1, N 7842 TEMP = X( J ) 7843 K = KK 7844 IF( NOCONJ )THEN 7845 DO 90, I = 1, J - 1 7846 TEMP = TEMP - AP( K )*X( I ) 7847 K = K + 1 7848 90 CONTINUE 7849 IF( NOUNIT ) 7850 $ TEMP = TEMP/AP( KK + J - 1 ) 7851 ELSE 7852 DO 100, I = 1, J - 1 7853 TEMP = TEMP - DCONJG( AP( K ) )*X( I ) 7854 K = K + 1 7855 100 CONTINUE 7856 IF( NOUNIT ) 7857 $ TEMP = TEMP/DCONJG( AP( KK + J - 1 ) ) 7858 END IF 7859 X( J ) = TEMP 7860 KK = KK + J 7861 110 CONTINUE 7862 ELSE 7863 JX = KX 7864 DO 140, J = 1, N 7865 TEMP = X( JX ) 7866 IX = KX 7867 IF( NOCONJ )THEN 7868 DO 120, K = KK, KK + J - 2 7869 TEMP = TEMP - AP( K )*X( IX ) 7870 IX = IX + INCX 7871 120 CONTINUE 7872 IF( NOUNIT ) 7873 $ TEMP = TEMP/AP( KK + J - 1 ) 7874 ELSE 7875 DO 130, K = KK, KK + J - 2 7876 TEMP = TEMP - DCONJG( AP( K ) )*X( IX ) 7877 IX = IX + INCX 7878 130 CONTINUE 7879 IF( NOUNIT ) 7880 $ TEMP = TEMP/DCONJG( AP( KK + J - 1 ) ) 7881 END IF 7882 X( JX ) = TEMP 7883 JX = JX + INCX 7884 KK = KK + J 7885 140 CONTINUE 7886 END IF 7887 ELSE 7888 KK = ( N*( N + 1 ) )/2 7889 IF( INCX.EQ.1 )THEN 7890 DO 170, J = N, 1, -1 7891 TEMP = X( J ) 7892 K = KK 7893 IF( NOCONJ )THEN 7894 DO 150, I = N, J + 1, -1 7895 TEMP = TEMP - AP( K )*X( I ) 7896 K = K - 1 7897 150 CONTINUE 7898 IF( NOUNIT ) 7899 $ TEMP = TEMP/AP( KK - N + J ) 7900 ELSE 7901 DO 160, I = N, J + 1, -1 7902 TEMP = TEMP - DCONJG( AP( K ) )*X( I ) 7903 K = K - 1 7904 160 CONTINUE 7905 IF( NOUNIT ) 7906 $ TEMP = TEMP/DCONJG( AP( KK - N + J ) ) 7907 END IF 7908 X( J ) = TEMP 7909 KK = KK - ( N - J + 1 ) 7910 170 CONTINUE 7911 ELSE 7912 KX = KX + ( N - 1 )*INCX 7913 JX = KX 7914 DO 200, J = N, 1, -1 7915 TEMP = X( JX ) 7916 IX = KX 7917 IF( NOCONJ )THEN 7918 DO 180, K = KK, KK - ( N - ( J + 1 ) ), -1 7919 TEMP = TEMP - AP( K )*X( IX ) 7920 IX = IX - INCX 7921 180 CONTINUE 7922 IF( NOUNIT ) 7923 $ TEMP = TEMP/AP( KK - N + J ) 7924 ELSE 7925 DO 190, K = KK, KK - ( N - ( J + 1 ) ), -1 7926 TEMP = TEMP - DCONJG( AP( K ) )*X( IX ) 7927 IX = IX - INCX 7928 190 CONTINUE 7929 IF( NOUNIT ) 7930 $ TEMP = TEMP/DCONJG( AP( KK - N + J ) ) 7931 END IF 7932 X( JX ) = TEMP 7933 JX = JX - INCX 7934 KK = KK - ( N - J + 1 ) 7935 200 CONTINUE 7936 END IF 7937 END IF 7938 END IF 7939* 7940 RETURN 7941* 7942* End of ZTPSV . 7943* 7944 END 7945 SUBROUTINE ZGEMM ( TRANSA, TRANSB, M, N, K, ALPHA, A, LDA, B, LDB, 7946 $ BETA, C, LDC ) 7947* .. Scalar Arguments .. 7948 CHARACTER TRANSA, TRANSB 7949 INTEGER M, N, K, LDA, LDB, LDC 7950 DOUBLE COMPLEX ALPHA, BETA 7951* .. Array Arguments .. 7952 DOUBLE COMPLEX A( LDA, * ), B( LDB, * ), C( LDC, * ) 7953* .. 7954* 7955* Purpose 7956* ======= 7957* 7958* ZGEMM performs one of the matrix-matrix operations 7959* 7960* C := alpha*op( A )*op( B ) + beta*C, 7961* 7962* where op( X ) is one of 7963* 7964* op( X ) = X or op( X ) = X' or op( X ) = conjg( X' ), 7965* 7966* alpha and beta are scalars, and A, B and C are matrices, with op( A ) 7967* an m by k matrix, op( B ) a k by n matrix and C an m by n matrix. 7968* 7969* Parameters 7970* ========== 7971* 7972* TRANSA - CHARACTER*1. 7973* On entry, TRANSA specifies the form of op( A ) to be used in 7974* the matrix multiplication as follows: 7975* 7976* TRANSA = 'N' or 'n', op( A ) = A. 7977* 7978* TRANSA = 'T' or 't', op( A ) = A'. 7979* 7980* TRANSA = 'C' or 'c', op( A ) = conjg( A' ). 7981* 7982* Unchanged on exit. 7983* 7984* TRANSB - CHARACTER*1. 7985* On entry, TRANSB specifies the form of op( B ) to be used in 7986* the matrix multiplication as follows: 7987* 7988* TRANSB = 'N' or 'n', op( B ) = B. 7989* 7990* TRANSB = 'T' or 't', op( B ) = B'. 7991* 7992* TRANSB = 'C' or 'c', op( B ) = conjg( B' ). 7993* 7994* Unchanged on exit. 7995* 7996* M - INTEGER. 7997* On entry, M specifies the number of rows of the matrix 7998* op( A ) and of the matrix C. M must be at least zero. 7999* Unchanged on exit. 8000* 8001* N - INTEGER. 8002* On entry, N specifies the number of columns of the matrix 8003* op( B ) and the number of columns of the matrix C. N must be 8004* at least zero. 8005* Unchanged on exit. 8006* 8007* K - INTEGER. 8008* On entry, K specifies the number of columns of the matrix 8009* op( A ) and the number of rows of the matrix op( B ). K must 8010* be at least zero. 8011* Unchanged on exit. 8012* 8013* ALPHA - DOUBLE COMPLEX . 8014* On entry, ALPHA specifies the scalar alpha. 8015* Unchanged on exit. 8016* 8017* A - DOUBLE COMPLEX array of DIMENSION ( LDA, ka ), where ka is 8018* k when TRANSA = 'N' or 'n', and is m otherwise. 8019* Before entry with TRANSA = 'N' or 'n', the leading m by k 8020* part of the array A must contain the matrix A, otherwise 8021* the leading k by m part of the array A must contain the 8022* matrix A. 8023* Unchanged on exit. 8024* 8025* LDA - INTEGER. 8026* On entry, LDA specifies the first dimension of A as declared 8027* in the calling (sub) program. When TRANSA = 'N' or 'n' then 8028* LDA must be at least max( 1, m ), otherwise LDA must be at 8029* least max( 1, k ). 8030* Unchanged on exit. 8031* 8032* B - DOUBLE COMPLEX array of DIMENSION ( LDB, kb ), where kb is 8033* n when TRANSB = 'N' or 'n', and is k otherwise. 8034* Before entry with TRANSB = 'N' or 'n', the leading k by n 8035* part of the array B must contain the matrix B, otherwise 8036* the leading n by k part of the array B must contain the 8037* matrix B. 8038* Unchanged on exit. 8039* 8040* LDB - INTEGER. 8041* On entry, LDB specifies the first dimension of B as declared 8042* in the calling (sub) program. When TRANSB = 'N' or 'n' then 8043* LDB must be at least max( 1, k ), otherwise LDB must be at 8044* least max( 1, n ). 8045* Unchanged on exit. 8046* 8047* BETA - DOUBLE COMPLEX . 8048* On entry, BETA specifies the scalar beta. When BETA is 8049* supplied as zero then C need not be set on input. 8050* Unchanged on exit. 8051* 8052* C - DOUBLE COMPLEX array of DIMENSION ( LDC, n ). 8053* Before entry, the leading m by n part of the array C must 8054* contain the matrix C, except when beta is zero, in which 8055* case C need not be set on entry. 8056* On exit, the array C is overwritten by the m by n matrix 8057* ( alpha*op( A )*op( B ) + beta*C ). 8058* 8059* LDC - INTEGER. 8060* On entry, LDC specifies the first dimension of C as declared 8061* in the calling (sub) program. LDC must be at least 8062* max( 1, m ). 8063* Unchanged on exit. 8064* 8065* 8066* Level 3 Blas routine. 8067* 8068* -- Written on 8-February-1989. 8069* Jack Dongarra, Argonne National Laboratory. 8070* Iain Duff, AERE Harwell. 8071* Jeremy Du Croz, Numerical Algorithms Group Ltd. 8072* Sven Hammarling, Numerical Algorithms Group Ltd. 8073* 8074* 8075* .. External Functions .. 8076 LOGICAL LSAME 8077 EXTERNAL LSAME 8078* .. External Subroutines .. 8079 EXTERNAL XERBLA 8080* .. Intrinsic Functions .. 8081 INTRINSIC DCONJG, MAX 8082* .. Local Scalars .. 8083 LOGICAL CONJA, CONJB, NOTA, NOTB 8084 INTEGER I, INFO, J, L, NCOLA, NROWA, NROWB 8085 DOUBLE COMPLEX TEMP 8086* .. Parameters .. 8087 DOUBLE COMPLEX ONE 8088 PARAMETER ( ONE = ( 1.0D+0, 0.0D+0 ) ) 8089 DOUBLE COMPLEX ZERO 8090 PARAMETER ( ZERO = ( 0.0D+0, 0.0D+0 ) ) 8091* .. 8092* .. Executable Statements .. 8093* 8094* Set NOTA and NOTB as true if A and B respectively are not 8095* conjugated or transposed, set CONJA and CONJB as true if A and 8096* B respectively are to be transposed but not conjugated and set 8097* NROWA, NCOLA and NROWB as the number of rows and columns of A 8098* and the number of rows of B respectively. 8099* 8100 NOTA = LSAME( TRANSA, 'N' ) 8101 NOTB = LSAME( TRANSB, 'N' ) 8102 CONJA = LSAME( TRANSA, 'C' ) 8103 CONJB = LSAME( TRANSB, 'C' ) 8104 IF( NOTA )THEN 8105 NROWA = M 8106 NCOLA = K 8107 ELSE 8108 NROWA = K 8109 NCOLA = M 8110 END IF 8111 IF( NOTB )THEN 8112 NROWB = K 8113 ELSE 8114 NROWB = N 8115 END IF 8116* 8117* Test the input parameters. 8118* 8119 INFO = 0 8120 IF( ( .NOT.NOTA ).AND. 8121 $ ( .NOT.CONJA ).AND. 8122 $ ( .NOT.LSAME( TRANSA, 'T' ) ) )THEN 8123 INFO = 1 8124 ELSE IF( ( .NOT.NOTB ).AND. 8125 $ ( .NOT.CONJB ).AND. 8126 $ ( .NOT.LSAME( TRANSB, 'T' ) ) )THEN 8127 INFO = 2 8128 ELSE IF( M .LT.0 )THEN 8129 INFO = 3 8130 ELSE IF( N .LT.0 )THEN 8131 INFO = 4 8132 ELSE IF( K .LT.0 )THEN 8133 INFO = 5 8134 ELSE IF( LDA.LT.MAX( 1, NROWA ) )THEN 8135 INFO = 8 8136 ELSE IF( LDB.LT.MAX( 1, NROWB ) )THEN 8137 INFO = 10 8138 ELSE IF( LDC.LT.MAX( 1, M ) )THEN 8139 INFO = 13 8140 END IF 8141 IF( INFO.NE.0 )THEN 8142 CALL XERBLA( 'ZGEMM ', INFO ) 8143 RETURN 8144 END IF 8145* 8146* Quick return if possible. 8147* 8148 IF( ( M.EQ.0 ).OR.( N.EQ.0 ).OR. 8149 $ ( ( ( ALPHA.EQ.ZERO ).OR.( K.EQ.0 ) ).AND.( BETA.EQ.ONE ) ) ) 8150 $ RETURN 8151* 8152* And when alpha.eq.zero. 8153* 8154 IF( ALPHA.EQ.ZERO )THEN 8155 IF( BETA.EQ.ZERO )THEN 8156 DO 20, J = 1, N 8157 DO 10, I = 1, M 8158 C( I, J ) = ZERO 8159 10 CONTINUE 8160 20 CONTINUE 8161 ELSE 8162 DO 40, J = 1, N 8163 DO 30, I = 1, M 8164 C( I, J ) = BETA*C( I, J ) 8165 30 CONTINUE 8166 40 CONTINUE 8167 END IF 8168 RETURN 8169 END IF 8170* 8171* Start the operations. 8172* 8173 IF( NOTB )THEN 8174 IF( NOTA )THEN 8175* 8176* Form C := alpha*A*B + beta*C. 8177* 8178 DO 90, J = 1, N 8179 IF( BETA.EQ.ZERO )THEN 8180 DO 50, I = 1, M 8181 C( I, J ) = ZERO 8182 50 CONTINUE 8183 ELSE IF( BETA.NE.ONE )THEN 8184 DO 60, I = 1, M 8185 C( I, J ) = BETA*C( I, J ) 8186 60 CONTINUE 8187 END IF 8188 DO 80, L = 1, K 8189c IF( B( L, J ).NE.ZERO )THEN 8190 TEMP = ALPHA*B( L, J ) 8191 DO 70, I = 1, M 8192 C( I, J ) = C( I, J ) + TEMP*A( I, L ) 8193 70 CONTINUE 8194c END IF 8195 80 CONTINUE 8196 90 CONTINUE 8197 ELSE IF( CONJA )THEN 8198* 8199* Form C := alpha*conjg( A' )*B + beta*C. 8200* 8201 DO 120, J = 1, N 8202 DO 110, I = 1, M 8203 TEMP = ZERO 8204 DO 100, L = 1, K 8205 TEMP = TEMP + DCONJG( A( L, I ) )*B( L, J ) 8206 100 CONTINUE 8207 IF( BETA.EQ.ZERO )THEN 8208 C( I, J ) = ALPHA*TEMP 8209 ELSE 8210 C( I, J ) = ALPHA*TEMP + BETA*C( I, J ) 8211 END IF 8212 110 CONTINUE 8213 120 CONTINUE 8214 ELSE 8215* 8216* Form C := alpha*A'*B + beta*C 8217* 8218 DO 150, J = 1, N 8219 DO 140, I = 1, M 8220 TEMP = ZERO 8221 DO 130, L = 1, K 8222 TEMP = TEMP + A( L, I )*B( L, J ) 8223 130 CONTINUE 8224 IF( BETA.EQ.ZERO )THEN 8225 C( I, J ) = ALPHA*TEMP 8226 ELSE 8227 C( I, J ) = ALPHA*TEMP + BETA*C( I, J ) 8228 END IF 8229 140 CONTINUE 8230 150 CONTINUE 8231 END IF 8232 ELSE IF( NOTA )THEN 8233 IF( CONJB )THEN 8234* 8235* Form C := alpha*A*conjg( B' ) + beta*C. 8236* 8237 DO 200, J = 1, N 8238 IF( BETA.EQ.ZERO )THEN 8239 DO 160, I = 1, M 8240 C( I, J ) = ZERO 8241 160 CONTINUE 8242 ELSE IF( BETA.NE.ONE )THEN 8243 DO 170, I = 1, M 8244 C( I, J ) = BETA*C( I, J ) 8245 170 CONTINUE 8246 END IF 8247 DO 190, L = 1, K 8248c IF( B( J, L ).NE.ZERO )THEN 8249 TEMP = ALPHA*DCONJG( B( J, L ) ) 8250 DO 180, I = 1, M 8251 C( I, J ) = C( I, J ) + TEMP*A( I, L ) 8252 180 CONTINUE 8253c END IF 8254 190 CONTINUE 8255 200 CONTINUE 8256 ELSE 8257* 8258* Form C := alpha*A*B' + beta*C 8259* 8260 DO 250, J = 1, N 8261 IF( BETA.EQ.ZERO )THEN 8262 DO 210, I = 1, M 8263 C( I, J ) = ZERO 8264 210 CONTINUE 8265 ELSE IF( BETA.NE.ONE )THEN 8266 DO 220, I = 1, M 8267 C( I, J ) = BETA*C( I, J ) 8268 220 CONTINUE 8269 END IF 8270 DO 240, L = 1, K 8271c IF( B( J, L ).NE.ZERO )THEN 8272 TEMP = ALPHA*B( J, L ) 8273 DO 230, I = 1, M 8274 C( I, J ) = C( I, J ) + TEMP*A( I, L ) 8275 230 CONTINUE 8276c END IF 8277 240 CONTINUE 8278 250 CONTINUE 8279 END IF 8280 ELSE IF( CONJA )THEN 8281 IF( CONJB )THEN 8282* 8283* Form C := alpha*conjg( A' )*conjg( B' ) + beta*C. 8284* 8285 DO 280, J = 1, N 8286 DO 270, I = 1, M 8287 TEMP = ZERO 8288 DO 260, L = 1, K 8289 TEMP = TEMP + 8290 $ DCONJG( A( L, I ) )*DCONJG( B( J, L ) ) 8291 260 CONTINUE 8292 IF( BETA.EQ.ZERO )THEN 8293 C( I, J ) = ALPHA*TEMP 8294 ELSE 8295 C( I, J ) = ALPHA*TEMP + BETA*C( I, J ) 8296 END IF 8297 270 CONTINUE 8298 280 CONTINUE 8299 ELSE 8300* 8301* Form C := alpha*conjg( A' )*B' + beta*C 8302* 8303 DO 310, J = 1, N 8304 DO 300, I = 1, M 8305 TEMP = ZERO 8306 DO 290, L = 1, K 8307 TEMP = TEMP + DCONJG( A( L, I ) )*B( J, L ) 8308 290 CONTINUE 8309 IF( BETA.EQ.ZERO )THEN 8310 C( I, J ) = ALPHA*TEMP 8311 ELSE 8312 C( I, J ) = ALPHA*TEMP + BETA*C( I, J ) 8313 END IF 8314 300 CONTINUE 8315 310 CONTINUE 8316 END IF 8317 ELSE 8318 IF( CONJB )THEN 8319* 8320* Form C := alpha*A'*conjg( B' ) + beta*C 8321* 8322 DO 340, J = 1, N 8323 DO 330, I = 1, M 8324 TEMP = ZERO 8325 DO 320, L = 1, K 8326 TEMP = TEMP + A( L, I )*DCONJG( B( J, L ) ) 8327 320 CONTINUE 8328 IF( BETA.EQ.ZERO )THEN 8329 C( I, J ) = ALPHA*TEMP 8330 ELSE 8331 C( I, J ) = ALPHA*TEMP + BETA*C( I, J ) 8332 END IF 8333 330 CONTINUE 8334 340 CONTINUE 8335 ELSE 8336* 8337* Form C := alpha*A'*B' + beta*C 8338* 8339 DO 370, J = 1, N 8340 DO 360, I = 1, M 8341 TEMP = ZERO 8342 DO 350, L = 1, K 8343 TEMP = TEMP + A( L, I )*B( J, L ) 8344 350 CONTINUE 8345 IF( BETA.EQ.ZERO )THEN 8346 C( I, J ) = ALPHA*TEMP 8347 ELSE 8348 C( I, J ) = ALPHA*TEMP + BETA*C( I, J ) 8349 END IF 8350 360 CONTINUE 8351 370 CONTINUE 8352 END IF 8353 END IF 8354* 8355 RETURN 8356* 8357* End of ZGEMM . 8358* 8359 END 8360